--- /dev/null
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Mon Nov 25 01:14:37 MET 1996
+Failed to get HTML/index.html: 150 Opening BINARY mode data connection for HTML/index.html (2715 bytes).
+Failed to get HTML/index.html.bak: 227 Entering Passive Mode (193,59,9,226,4,165)
+Failed to get HTML/quickref.ps.Z: timed out
+Failed to get HTML/comptble.ps.Z: timed out
+Failed to get sources/pass1/unix.lnk: timed out
+Failed to get sources/pass1/stdio.c: timed out
+Failed to get sources/pass1/memfil.c: timed out
+Failed to get sources/pass1/ml3.c: timed out
+Failed to get sources/pass1/main.c: timed out
+Failed to get sources/pass1/wan1.ff: timed out
+Failed to get sources/pass1/scan.ff: timed out
+Failed to get sources/pass1/it1.ff: timed out
+Failed to get sources/pass1/al13.ff: timed out
+Failed to get sources/pass1/al12.ff: timed out
+Failed to get sources/pass1/al11.ff: timed out
+Failed to get sources/pass1/it0.ff: timed out
+Failed to get sources/pass1/debug.f: timed out
+Failed to get sources/pass1/hash.f: timed out
+Failed to get sources/pass1/wan2.f: timed out
+Failed to get sources/pass1/wan3.f: timed out
+Failed to get sources/pass1/dsw.f: timed out
+Failed to get sources/pass1/statist.f: timed out
+Failed to get sources/pass1/spgrec.f: timed out
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Tue Nov 26 00:20:42 MET 1996
+Failed to get HTML/index.html: 150 Opening BINARY mode data connection for HTML/index.html (2715 bytes).
+Failed to get HTML/index.html.bak: 227 Entering Passive Mode (193,59,9,226,6,122)
+Failed to get HTML/quickref.ps.Z: timed out
+Failed to get HTML/comptble.ps.Z: timed out
+Failed to get sources/pass1/unix.lnk: timed out
+Failed to get sources/pass1/stdio.c: timed out
+Failed to get sources/pass1/memfil.c: timed out
+Failed to get sources/pass1/ml3.c: timed out
+Failed to get sources/pass1/main.c: timed out
+Failed to get sources/pass1/wan1.ff: timed out
+Failed to get sources/pass1/scan.ff: timed out
+Failed to get sources/pass1/it1.ff: timed out
+Failed to get sources/pass1/al13.ff: timed out
+Failed to get sources/pass1/al12.ff: timed out
+Failed to get sources/pass1/al11.ff: timed out
+Failed to get sources/pass1/it0.ff: timed out
+Failed to get sources/pass1/debug.f: timed out
+Failed to get sources/pass1/hash.f: timed out
+Failed to get sources/pass1/wan2.f: timed out
+Failed to get sources/pass1/wan3.f: timed out
+Failed to get sources/pass1/dsw.f: timed out
+Failed to get sources/pass1/statist.f: timed out
+Failed to get sources/pass1/spgrec.f: timed out
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Thu Nov 28 08:34:34 MET 1996
+Failed to get HTML/index.html: 150 Opening BINARY mode data connection for HTML/index.html (2715 bytes).
+Failed to get HTML/index.html.bak: 227 Entering Passive Mode (193,59,9,226,4,244)
+Failed to get HTML/quickref.ps.Z: timed out
+Failed to get HTML/comptble.ps.Z: timed out
+Failed to get sources/pass1/unix.lnk: timed out
+Failed to get sources/pass1/stdio.c: timed out
+Failed to get sources/pass1/memfil.c: timed out
+Failed to get sources/pass1/ml3.c: timed out
+Failed to get sources/pass1/main.c: timed out
+Failed to get sources/pass1/wan1.ff: timed out
+Failed to get sources/pass1/scan.ff: timed out
+Failed to get sources/pass1/it1.ff: timed out
+Failed to get sources/pass1/al13.ff: timed out
+Failed to get sources/pass1/al12.ff: timed out
+Failed to get sources/pass1/al11.ff: timed out
+Failed to get sources/pass1/it0.ff: timed out
+Failed to get sources/pass1/debug.f: timed out
+Failed to get sources/pass1/hash.f: timed out
+Failed to get sources/pass1/wan2.f: timed out
+Failed to get sources/pass1/wan3.f: timed out
+Failed to get sources/pass1/dsw.f: timed out
+Failed to get sources/pass1/statist.f: timed out
+Failed to get sources/pass1/spgrec.f: timed out
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Mon Dec 2 14:49:10 MET 1996
+Failed to get HTML/index.html: 150 Opening BINARY mode data connection for HTML/index.html (2715 bytes).
+Failed to get HTML/quickref.ps.Z: 227 Entering Passive Mode (193,59,9,226,5,158)
+Failed to get HTML/comptble.ps.Z: timed out
+Failed to get sources/pass1/unix.lnk: timed out
+Failed to get sources/pass1/stdio.c: timed out
+Failed to get sources/pass1/memfil.c: timed out
+Failed to get sources/pass1/ml3.c: timed out
+Failed to get sources/pass1/main.c: timed out
+Failed to get sources/pass1/wan1.ff: timed out
+Failed to get sources/pass1/scan.ff: timed out
+Failed to get sources/pass1/it1.ff: timed out
+Failed to get sources/pass1/al13.ff: timed out
+Failed to get sources/pass1/al12.ff: timed out
+Failed to get sources/pass1/al11.ff: timed out
+Failed to get sources/pass1/it0.ff: timed out
+Failed to get sources/pass1/debug.f: timed out
+Failed to get sources/pass1/hash.f: timed out
+Failed to get sources/pass1/wan2.f: timed out
+Failed to get sources/pass1/wan3.f: timed out
+Failed to get sources/pass1/dsw.f: timed out
+Failed to get sources/pass1/statist.f: timed out
+Failed to get sources/pass1/spgrec.f: timed out
+Failed to get sources/pass1/resume.f: timed out
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Tue Dec 3 00:21:09 MET 1996
+Got HTML/index.html 2715
+Got HTML/quickref.ps.Z 51935
+Got HTML/comptble.ps.Z 23003
+Got sources/pass1/unix.lnk 144
+Got sources/pass1/stdio.c 1770
+Got sources/pass1/memfil.c 5868
+Got sources/pass1/ml3.c 10756
+Got sources/pass1/main.c 2319
+Got sources/pass1/wan1.ff 29014
+Got sources/pass1/scan.ff 24601
+Got sources/pass1/it1.ff 60577
+Got sources/pass1/al13.ff 98702
+Got sources/pass1/al12.ff 67222
+Got sources/pass1/al11.ff 113254
+Got sources/pass1/it0.ff 28091
+Got sources/pass1/debug.f 12469
+Got sources/pass1/hash.f 48676
+Got sources/pass1/wan2.f 55883
+Got sources/pass1/wan3.f 49687
+Got sources/pass1/dsw.f 141801
+Got sources/pass1/statist.f 3009
+Got sources/pass1/spgrec.f 3456
+Got sources/pass1/resume.f 4405
+Got sources/pass1/ml2.f 25660
+Got sources/pass1/ifun.f 1618
+Got sources/pass1/stos.h 1179
+Got sources/pass1/option.h 106
+Got sources/pass1/f2c.h 4093
+Got sources/pass1/blank3.h 910
+Got sources/pass1/blank2.h 1108
+Got sources/pass1/blank.h 1418
+Got sources/pass1/makefile 2254
+Got sources/pass1/logdeb.log 60113
+Got sources/pass1/makefil 2043
+Got sources/pass1/msdos.lnk 131
+Got sources/pass1/loglan 200098
+Got sources/pass1/blank.doc 2683
+Got sources/gen/genint.h 6370
+Got sources/gen/glodefs.h 10497
+Got sources/gen/mainvar.h 4811
+Got sources/gen/oxen.h 3564
+Got sources/gen/oxen.c 20711
+Got sources/gen/gen.c 19658
+Got sources/gen/lists.c 17680
+Got sources/gen/genprot.c 13547
+Got sources/gen/logen.c 10076
+Got sources/gen/mainvar.c 8154
+Got sources/gen/lcode.c 6858
+Got sources/gen/genio.c 6306
+Got sources/gen/deb.c 5358
+Got sources/gen/back.c 4306
+Got sources/f2c/putpcc.c 36792
+Got sources/f2c/put.c 9081
+Got sources/f2c/vax.c 7649
+Got sources/f2c/sysdep.c 6792
+Got sources/f2c/safstrcp.c 2884
+Got sources/f2c/readme 1831
+Got sources/f2c/tokdefs.h 1807
+Got sources/f2c/tokens 727
+Got sources/f2c/version.c 143
+Got sources/f2c/usignal.h 124
+Got sources/f2c/rm.bat 80
+Got sources/f2c/gram.c 79753
+Got sources/f2c/expr.c 55807
+Got sources/f2c/format.c 49696
+Got sources/f2c/output.c 38940
+Got sources/f2c/proc.c 33028
+Got sources/f2c/lex.c 29242
+Got sources/f2c/io.c 27451
+Got sources/f2c/defs.h 23461
+Got sources/f2c/formatd.c 23180
+Got sources/f2c/intr.c 19638
+Got sources/f2c/names.c 18381
+Got sources/f2c/misc.c 17876
+Got sources/f2c/exec.c 17697
+Got sources/f2c/pread.c 15807
+Got sources/f2c/main.c 15305
+Got sources/f2c/parsearg.c 13258
+Got sources/f2c/p1output.c 12088
+Got sources/f2c/init.c 10018
+Got sources/f2c/equiv.c 8503
+Got sources/f2c/nicepr.c 8497
+Got sources/f2c/data.c 8255
+Got sources/f2c/defines.h 8162
+Got sources/f2c/gram.dcl 8031
+Got sources/f2c/gram.hd 7531
+Got sources/f2c/f2c.1 5964
+Got sources/f2c/p1defs.h 5688
+Got sources/f2c/mem.c 4672
+Got sources/f2c/f2c.h 4093
+Got sources/f2c/cds.c 3919
+Got sources/f2c/error.c 3484
+Got sources/f2c/malloc.c 3370
+Got sources/f2c/gram.io 3274
+Got sources/f2c/gram.exp 3072
+Got sources/f2c/gram.exe 3067
+Got sources/f2c/output.h 2109
+Got sources/f2c/memset.c 1964
+Got sources/f2c/makefile 1870
+Got sources/f2c/makefile.txt 1870
+Got sources/f2c/makefile.bak 1870
+Got sources/f2c/pccdefs.h 1195
+Got sources/f2c/notice 1177
+Got sources/f2c/ftypes.h 941
+Got sources/f2c/parse.h 862
+Got sources/f2c/names.h 727
+Got sources/f2c/machdefs.h 659
+Got sources/f2c/iob.h 459
+Got sources/f2c/nicepr.h 412
+Got sources/f2c/format.h 300
+Got sources/f2c/link.lnk 229
+Got loglan96/loglan93/loglan.tar 163840
+Got loglan96/loglan93/instr.cc 11894
+Got loglan96/loglan93/instr.h 5504
+Got loglan96/loglan93/expr.cc 20426
+Got loglan96/loglan93/objects.h 4646
+Got loglan96/loglan93/objects.cc 5845
+Got loglan96/loglan93/syntax.y 40972
+Got loglan96/loglan93/expr.h 9372
+Got loglan96/loglan93/lex.l 24428
+Got loglan96/loglan93/makefile 1840
+Got loglan96/loglan93/symtable.h 3508
+Got loglan96/loglan93/tstsymbt.cc 1959
+Got loglan96/loglan93/test3.log 50
+Got loglan96/loglan93/tstobj.cc 862
+Got loglan96/loglan93/test.log 837
+Got loglan96/loglan93/tstexpr.cc 677
+Got loglan96/loglan93/symtable.cc 7209
+Got loglan96/loglan93/test4.log 38
+Got loglan96/loglan93/test2.log 59
+Got loglan96/loglan93/test1.log 71
+Got loglan96/loglan94/newgramr.doc 39647
+Got loglan96/loglan94/neweditr.log 4318
+Got loglan96/loglan95/planwork.doc 28417
+Got loglan96/loglan95/liste.doc 1848
+Got loglan96/loglan95/pv3.doc 2349
+Got loglan96/loglan95/library.doc 4027
+Got loglan96/loglan95/libmangr.doc 4083
+Got loglan96/loglan95/filesys.doc 2428
+Got loglan96/loglan95/grammar0.doc 32166
+Got loglan96/loglan95/newgram3.doc 47488
+Got loglan96/loglan95/propo1.doc 4419
+Got loglan96/loglan95/pv2.doc 10011
+Got loglan96/loglan95/pv1.doc 3372
+Got loglan96/loglan95/newgram2.doc 44002
+Got loglan96/loglan84.rs/readme 566
+Got loglan96/loglan84.rs/rsloglan.doc 146021
+Got loglan96/loglan84.rs/antek6.txt 111361
+Got loglan96/loglan84.rs/loginlog.txt 126932
+Got loglan96/loglan84.rs/antek4.txt 49087
+Got loglan96/loglan84.rs/antek3.txt 27563
+Got loglan96/loglan84.rs/antek2.txt 24156
+Got loglan96/lcode/readme 281
+Got loglan96/lcode/lcode 10354
+Got at_work/loglan96/index.html 790
+Got at_work/loglan96/index.html.bak 790
+Got at_work/loglan96/index.map 23
+Got at_work/loglan96/intro.gif 117569
+Got examples/examples/strassen.log 46434
+Got examples/examples/helpcor.log 62131
+Got examples/examples/p.log 32491
+Got examples/grazyna.xmp/belote.log 86360
+Got examples/grazyna.xmp/morp3d.log 87908
+Got examples/grazyna.xmp/morps.log 170790
+Got examples/grazyna.xmp/dominate.log 37905
+Got examples/grazyna.xmp/bus13.log 29550
+Got examples/grazyna.xmp/sort.log 12098
+Got examples/grazyna.xmp/convexh1.log 10218
+Got examples/grazyna.xmp/station.log 41691
+Got examples/grazyna.xmp/binda3.log 13827
+Got examples/grazyna.xmp/part.log 5367
+Got examples/grazyna.xmp/cub.log 19147
+Got examples/grazyna.xmp/pina.log 51927
+Got examples/grazyna.xmp/new.log 37043
+Got examples/pataud/new5.log 20732
+Got examples/pataud/new3.log 22058
+Got examples/pataud/new2.log 14921
+Got examples/pataud/new1.log 5881
+Got examples/pataud/multilvl.log 622
+Got examples/pataud/simula2.log 116904
+Got examples/pataud/mon.log 4045
+Got examples/pataud/test.dat 16
+Got examples/pataud/simula.log 78001
+Got examples/pataud/windows.log 27546
+Got examples/pataud/ville.dat 973
+Got examples/pataud/ville.log 9137
+Got examples/pataud/verspec.log 7583
+Got examples/pataud/verspecf.doc 10707
+Got examples/pataud/proc2.log 11727
+Got examples/test19/bibliog.bas 0
+Got examples/test19/bibliog.dta 0
+Got examples/test19/autor.idx 0
+Got examples/test19/nrpzycji.idx 0
+Got examples/test19/data.bas 2512
+Got examples/test19/test19.log 83228
+Got bin/readme 546
+Got bin/atari/loglan.ttp 237302
+Got bin/atari/intgem.prg 79502
+Got bin/atari/gen.ttp 39297
+Got bin/atari/atari.ps 112696
+Got bin/atari/atari.doc 11257
+Got bin/atari/atari.use 987
+Got bin/atari/atari.usr 11161
+Got bin/atari/atariusr.txt 8307
+Got bin/atari/ms.tos 9104
+Got bin/atari/desktop.inf 481
+Got bin/atari/me.ttp 76692
+Got bin/atari/emacs.rc 6796
+Got bin/l2c/readme 498
+Got bin/l2c/l2c1.exe 104360
+Got bin/l2c/l2c2.exe 114748
+Got bin/dos/drivers.grp/s3864_2m.grn 904
+Got bin/dos/drivers.grp/s3805_1m.grn 832
+Got bin/dos/drivers.grp/ati_16md.grn 979
+Got bin/dos/drivers.grp/vesa111.vdr 3046
+Got bin/dos/drivers.grp/oak.grn 499
+Got bin/dos/drivers.grp/atiultra.grn 1208
+Got bin/dos/drivers.grp/ati.grd 375
+Got bin/dos/drivers.grp/video7.grd 331
+Got bin/dos/drivers.grp/aheadb.grd 267
+Got bin/dos/drivers.grp/chips.grd 282
+Got bin/dos/drivers.grp/everex.grd 311
+Got bin/dos/drivers.grp/genoa.grd 285
+Got bin/dos/drivers.grp/paradise.grd 263
+Got bin/dos/drivers.grp/aheada.grd 287
+Got bin/dos/drivers.grp/cl5426.grn 549
+Got bin/dos/drivers.grp/wd90c3x.grn 624
+Got bin/dos/drivers.grp/wdvanila.grn 609
+Got bin/dos/drivers.grp/newss24x.grn 668
+Got bin/dos/drivers.grp/stealth.grn 617
+Got bin/dos/drivers.grp/tr8900.grn 578
+Got bin/dos/drivers.grp/vesa_s3.grn 735
+Got bin/dos/drivers.grp/viper.grn 749
+Got bin/dos/drivers.grp/realtek.grn 577
+Got bin/dos/drivers.grp/stdvga.grn 502
+Got bin/dos/drivers.grp/ativga.grn 565
+Got bin/dos/drivers.grp/cirrus54.grn 700
+Got bin/dos/drivers.grp/et3000.grn 530
+Got bin/dos/drivers.grp/acumos.grn 547
+Got bin/dos/drivers.grp/atigupro.grn 513
+Got bin/dos/drivers.grp/et4000.grn 884
+Got bin/dos/drivers.grp/ss24x.grn 1041
+Got bin/dos/drivers.grp/sparadis.grn 549
+Got bin/dos/286/dirinfo 279
+Got bin/dos/286/readme 619
+Got bin/dos/286/hgchint.exe 133290
+Got bin/dos/286/egahint.exe 134410
+Got bin/dos/286/egaint.exe 93444
+Got bin/dos/286/hgcint.exe 92340
+Got bin/dos/286/hgen.exe 51404
+Got bin/dos/286/gen.exe 48840
+Got bin/dos/286/loglan.exe 248828
+Got bin/dos/286/egahint.old 152057
+Got bin/dos/286/egaint.old 83883
+Got bin/dos/286/old/ne2lotek.exe 10064
+Got bin/dos/286/old/pkzip.exe 32880
+Got bin/dos/286/old/l2c1.exe 104360
+Got bin/dos/286/old/l2c2.exe 114748
+Got bin/dos/286/old/gen.exe 31402
+Got bin/dos/286/old/prep.exe 18644
+Got bin/dos/286/old/loglan.exe 248828
+Got bin/dos/286/old/hint.exe 150689
+Got bin/dos/286/old/int.exe 82779
+Got bin/dos/286/old/hgen.exe 32672
+Got bin/dos/286/cga/cg64int.exe 82587
+Got bin/dos/286/cga/cg32int.exe 82955
+Got bin/dos/286/cga/cg64hint.exe 150497
+Got bin/dos/286/cga/cgaint1.exe 101203
+Got bin/dos/386/readme 787
+Got bin/dos/386/cc.bat 266
+Got bin/dos/386/int.exe 149912
+Got bin/dos/386/gen.exe 69598
+Got bin/dos/386/loglan.exe 219928
+Got bin/dos/386/old1.log 2301
+Got bin/dos/386/dirinfo 71
+Got bin/dos/486/loglan.exe 225368
+Got bin/dos/486/readme 158
+Got bin/dos/486/logpp.exe 72704
+Got bin/dos/486/int.exe 150360
+Got bin/dos/486/cc.bat 308
+Got bin/dos/486/gen.exe 70174
+Got bin/dos/486/go32.exe 78666
+unlink /ftp/mirrors/aragorn.pb.bialystok.pl/pub/loglan/HTML/.in.index.html.
+unlink /ftp/mirrors/aragorn.pb.bialystok.pl/pub/loglan/HTML/.in.index.html. failed: No such file or directory
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Thu Dec 5 02:39:15 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Fri Dec 6 02:57:32 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sat Dec 7 01:58:35 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sun Dec 8 02:22:37 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Mon Dec 9 02:06:24 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Mon Dec 9 23:11:39 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Thu Dec 12 02:37:46 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sat Dec 14 11:14:35 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sun Dec 15 00:35:25 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sun Dec 15 23:57:12 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Mon Dec 16 23:32:41 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Wed Dec 18 01:03:48 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Wed Dec 18 23:37:27 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Fri Dec 20 02:23:16 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sun Dec 22 02:44:08 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Mon Dec 23 00:01:53 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Tue Dec 24 00:56:29 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Wed Dec 25 00:05:35 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Thu Dec 26 01:26:19 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Fri Dec 27 01:56:13 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sat Dec 28 00:26:15 MET 1996
+mirroring loglan (aragorn.pb.bialystok.pl:/pub/loglan) completed successfully @ Sat Dec 28 23:17:43 MET 1996
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Classes</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U>\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 5) Classes</H1>\r
+<HR>\r
+\r
+<P>\r
+Class is a facility which covers such programming constructs as\r
+structured type, package, access type, data structure etc. To\r
+begin with the presentation of this construct, let us consider\r
+a structured type assembled from primitive ones:\r
+<P>\r
+<IMG SRC="gifs/cl01.gif"> \r
+<P>\r
+The above class declaration has the attributes : dollars (real),\r
+not_paid (boolean), and year,month,day (integer). Wherever class\r
+bill is visibile one can declare variables of type bill:\r
+<PRE>\r
+<B>var</B> x,y,z: bill\r
+</PRE>\r
+\r
+<P>\r
+The values of variables x, y, z can be the addresses of objects\r
+of class bill. These variables are called reference variables.\r
+With reference variable one can create and operate the objects\r
+of reference variable type.\r
+<P>\r
+An object of a class is created by the class generation statement\r
+(new), and thereafter, its attributes are accessed through dot\r
+notation.\r
+<P>\r
+<IMG SRC="gifs/cl03.gif"> \r
+<P>\r
+If an object of class bill has been created (new bill) and its\r
+address has been assigned to variable x (x:=new bill), then the\r
+attributes of that object are accessible through dot notation\r
+(remote access). The expression x.dollars gives , for instance,\r
+the remote access to attribute dollars of the object referenced\r
+by x. All attributes of class objects are initialized as usual.\r
+For the above example the object referenced by x, after the execution\r
+of the specified sequence of statements, has the following structure:\r
+<P>\r
+<IMG SRC="gifs/Fig0401.gif"> \r
+<P>\r
+The object referenced by y and z has the following structure:\r
+<P>\r
+<IMG SRC="gifs/Fig0402.gif"> \r
+<P>\r
+The value none is the default initial value of any reference variable\r
+and denotes no object. A remote access to an attribute of none\r
+raises a run time error.\r
+<P>\r
+Class may have also formal parameters (as procedures and functions).\r
+Kinds and transmission modes of formal parameters are the same\r
+as in the case of procedures.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cl04.gif"> \r
+<P>\r
+Let, for instance, variables z1, z2, z3 be of type node. Then\r
+the sequence of statements:\r
+<P>\r
+<IMG SRC="gifs/cl05.gif"> \r
+<P>\r
+creates the structure:\r
+<P>\r
+<IMG SRC="gifs/Fig0403.gif"> \r
+<P>\r
+where arrows denote the values of the reference variables.\r
+<P>\r
+Class may also have a sequence of statements (as any other unit).\r
+That sequence can initialize the attributes of the class objects.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cl06.gif"> \r
+<P>\r
+Attribute module is evaluated for any object generation of class\r
+complex:\r
+<P>\r
+<IMG SRC="gifs/cl07.gif"> \r
+<P>\r
+For the execution of a class generator, first a class object is\r
+created, then the input parameters are transmitted , and finally,\r
+the sequence of statements (if any) is performed. Return is made\r
+with the execution of return statement or the final end of a unit.\r
+Upon return the output parameters are transmitted.\r
+<P>\r
+Procedure object is automatically deallocated when return is made\r
+to the caller. Class object is not deallocated , its address can\r
+be assigned to a reference variable, and its attributes can be\r
+thereafter accessed via this variable.\r
+<P>\r
+The classes presented so far had only variable attributes. In\r
+general, class attributes may be also other syntactic entities,\r
+such as constants, procedures, functions, classes etc. Classes\r
+with procedure and function attributes provide a good facility\r
+to define data structures.\r
+<P>\r
+Example:\r
+<P>\r
+A push_down memory of integers may be implemented in the following\r
+way:\r
+<P>\r
+<IMG SRC="gifs/cl08.gif"> \r
+<P>\r
+Assume that somewhere in a program reference variables of type\r
+push_down are declared (of course, in place where push_down is\r
+visibile):\r
+<P>\r
+<IMG SRC="gifs/cl09.gif"> \r
+<P>\r
+Three different push_down memories may be now generated:\r
+<P>\r
+<IMG SRC="gifs/cl10.gif"> \r
+<P>\r
+One can use these push_down memories as follows:\r
+<P>\r
+<IMG SRC="gifs/cl11.gif"> \r
+<P>\r
+etc. <HR>\r
+\r
+<P>\r
+<A HREF="Procedur.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+ <A HREF="HomePage.htm"> <IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="adjustab.htm"><IMG SRC="gifs/NextPage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Concurrent processes</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U>\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 13) Concurrent processes\r
+</H1>\r
+<HR>\r
+\r
+<P>\r
+Loglan allows to create and execute objects-processes. They can\r
+operate simultaneously on different computers linked into a LAN\r
+network or a few processes can share one processor (its time-slices).\r
+<P>\r
+Process modules are different from the classes and coroutines\r
+for, they use the keyword process. The syntax of process modules\r
+is otherwise the same. In a process one can use a few more instructions:\r
+resume (resume a process which is passive), stop - make the current\r
+process passive, etc.\r
+<P>\r
+All processes (even those executed on the same computer) are implemented\r
+as distributed, i.e. without any shared memory. This fact implies\r
+some restrictions on how processes may be used. Not all restrictions\r
+are enforced by the present compiler, so it is the programmer's\r
+responsibility to respect them. For the details see the User's\r
+Manual.\r
+<P>\r
+Semantics of the generator <B>new</B> is slightly modified when\r
+applied to the processes. The first parameter of the first process\r
+unit in the prefix sequence must be of type INTEGER. This parameter\r
+denotes the node number of the computer on which this process\r
+will be created. For a single computer operation this parameter\r
+must be equal to 0.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cp01.gif"> \r
+<P>\r
+COMMUNICATION MECHANISM\r
+<P>\r
+Processes may communicate and synchronize by a mechanism based\r
+on rendez-vous. It will be referred to as "alien call"\r
+in the following description.\r
+<P>\r
+An alien call is either:\r
+<UL>\r
+<LI>a procedure call performed by a remote access to a process\r
+object, or\r
+<LI>a call of a procedure which is a formal parameter of a process,\r
+or\r
+<LI>a call of a procedure which is a formal parameter of an alien-called\r
+procedure (this is a recursive definition).\r
+</UL>\r
+\r
+<P>\r
+Every process object has an enable mask. It is defined as a subset\r
+of all procedures declared directly inside a process unit or any\r
+unit from its prefix sequence (i.e. subset of all procedures that\r
+may be alien-called).\r
+<P>\r
+A procedure is enabled in a process if it belongs to that process'\r
+enable mask. A procedure is disabled if it does not belong to\r
+the enable mask.\r
+<P>\r
+Immediately after generation of a process object its enable mask\r
+is empty (all procedures are disabled).\r
+<P>\r
+Semantics of the alien call is different from the remote call\r
+described in the report. Both the calling process and the process\r
+in which the procedure is declared (i.e. the called process) are\r
+involved in the alien call. This way the alien call may be used\r
+as a synchronization mechanism.\r
+<P>\r
+The calling process passes the input parameters and waits for\r
+the call to be completed.\r
+<P>\r
+The alien-called procedure is executed by the called process.\r
+Execution of the procedure will not begin before certain conditions\r
+are satisfied. First, the called process must not be suspended\r
+in any way. The only exception is that it may be waiting during\r
+the ACCEPT statement (see below). Second, the procedure must be\r
+enabled in the called process.\r
+<P>\r
+When the above two conditions are met the called process is interrupted\r
+and forced to execute the alien-called procedure (with parameters\r
+passed by the calling process).\r
+<P>\r
+Upon entry to the alien-called procedure all procedures become\r
+disabled in the called process.\r
+<P>\r
+Upon exit the enable mask of the called process is restored to\r
+that from before the call (regardless of how it has been changed\r
+during the execution of the procedure). The called process is\r
+resumed at the point of the interruption. The execution of the\r
+ACCEPT statement is ended if the called process was waiting during\r
+the ACCEPT (see below). At last the calling process reads back\r
+the output parameters and resumes its execution after the call\r
+statement.\r
+<P>\r
+The process executing an alien-called procedure can easily be\r
+interrupted by another alien call if the enable mask is changed.\r
+<P>\r
+There are some new language constructs associated with the alien\r
+call mechanism. The following statements change the enable mask\r
+of a process:\r
+<P>\r
+<IMG SRC="gifs/cp02.gif"> \r
+<P>\r
+enables the procedures with identifiers p1, ..., pn. If there\r
+are any processes waiting for an alien call of one of these procedures,\r
+one of them is chosen and its request is processed. The scheduling\r
+is done on a FIFO basis, so it is strongly fair. The statement:\r
+<P>\r
+<IMG SRC="gifs/cp03.gif"> \r
+<P>\r
+disables the procedures with identifiers p1, ..., pn.\r
+<P>\r
+In addition a special form of the RETURN statement:\r
+<P>\r
+<IMG SRC="gifs/cp04.gif"> \r
+<P>\r
+allows to enable the procedures p1, ..., pn and disable the procedures\r
+q1,...,qn after the enable mask is restored on exit from the alien-called\r
+procedure. It is legal only in the alien-called procedures (the\r
+legality is not enforced by the compiler).\r
+<P>\r
+A called process may avoid busy waiting for an alien call by means\r
+of the ACCEPT statement:\r
+<P>\r
+<IMG SRC="gifs/cp05.gif"> \r
+<P>\r
+adds the procedures p1, ..., pn to the current mask, and waits\r
+for an alien call of one of the currently enabled procedures.\r
+After the procedure return the enable mask is restored to that\r
+from before the ACCEPT statement.\r
+<P>\r
+Note that the ACCEPT statement alone (i.e. without any ENABLE/DISABLE\r
+statements or options) provides a sufficient communication mechanism.\r
+In this case the called process may execute the alien-called procedure\r
+only during the ACCEPT statement (because otherwise all procedures\r
+are disabled). It means that the enable mask may be forgotten\r
+altogether and the alien call may be used as a pure totally synchronous\r
+rendez-vous. Other constructs are introduced to make partially\r
+asynchronous communication patterns possible.\r
+<P>\r
+Below find a complete listing of a simple example - monitors.\r
+<P>\r
+<IMG SRC="gifs/cp06.gif"> <HR>\r
+<hr>\r
+<P>\r
+<A HREF="Exceptio.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Referenc.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Exception handling</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U>\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 12) Exception handling\r
+</H1>\r
+<HR>\r
+\r
+<P>\r
+Exceptions are events that cause interruption of normal program\r
+execution. One kind of exceptions are those which are raised as\r
+a result of some run time errors. For instance, when an attempt\r
+is made to access a killed object, when the result of numeric\r
+operation does not lie within the range, when the dynamic storage\r
+allocated to a program is exceeded etc.\r
+<P>\r
+Another kind of exceptions are those which are raised explicitly\r
+by a user (with the execution of the raise statement).\r
+<P>\r
+The response to exceptions (one or more) is defined by an exception\r
+handler. A handler may appear at the end of declarations of any\r
+unit. The corresponding actions are defined as sequences of statements\r
+preceded by keyword when and an exception identifier.\r
+<P>\r
+Example:\r
+<P>\r
+In procedure squareeq (p.3) we wish to include the case when a=0.\r
+It may be treated as an exception (division by zero).\r
+<P>\r
+<IMG SRC="gifs/eh01.gif"> \r
+<P>\r
+The handler declared in that procedure handles the only one exception\r
+(division_by_zero).\r
+<P>\r
+When an exception is raised, the corresponding handler is searched\r
+for, starting from the active object and going through return\r
+traces. If there is no object containing the declaration of the\r
+handler, then the program (or the corresponding process) is terminated.\r
+Otherwise the control is transferred to the first found handler.\r
+<P>\r
+In our example the handler is declared within the unit itself,\r
+so control is passed to a sequence:\r
+<P>\r
+<IMG SRC="gifs/eh02.gif"> \r
+<P>\r
+Therefore, when b=/=0, the unique root of square equation will\r
+be determined and the procedure will be normally terminated (terminate).\r
+In general, terminate causes that all the objects are terminated,\r
+starting from that one where the exception was raised and ending\r
+on that one where the handler was found. Then the computation\r
+is continued in a normal way.\r
+<P>\r
+In our example, when b=0, a new exception is raised by the user.\r
+For this kind of exceptions , the exception itself should be declared\r
+(because it is not predefined as a run time error). Its declaration\r
+may have parameters which are transmitted to a handler. The exception\r
+declaration need not be visible by the exception handler. However\r
+the way the handler is searched for does not differ from the standard\r
+one. Consider an example:\r
+<P>\r
+<IMG SRC="gifs/eh03.gif"> \r
+<P>\r
+Exception Wrong_data may be raised wherever its declaration (signal\r
+Wrong_data) is visible. When its handler is found the specified\r
+sequence of actions is performed. In the example above different\r
+handlers may be 0efined in inner units to the main block where\r
+squereeq is called.\r
+<P>\r
+The case a=0 could be included, of course, in a normal way, i.e.\r
+by a corresponding conditional statement occurring in the procedure\r
+body. But the case a=0 was assumed to be exceptional (happens\r
+scarcely). Thus the evaluation of condition a=0 would be mostly\r
+unnecessary. As can be noticed thanks to exceptions the above\r
+problem can be solved with the minimal waste of run time. <HR>\r
+\r
+<hr><P>\r
+<A HREF="Programm.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Concurre.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Formal types</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U> \r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 9) Formal types</H1>\r
+<HR>\r
+\r
+<P>\r
+Formal types serve for unit parametrization with respect to any\r
+non-primitive type.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/ft01.gif"> \r
+<P>\r
+Procedure Gsort (the generalization of procedure sort from p.4)\r
+has type parameter T. A corresponding actual parameter may be\r
+an arbitrary non-primitive type. An actual parameter corresponding\r
+to A should be an array of elements of the actual type T. Function\r
+less should define the linear ordering on the domain T.\r
+<P>\r
+For instance, the array A of type bill (cf p.7) may be sorted\r
+with respect to attribute dollars , if the function:\r
+<P>\r
+<IMG SRC="gifs/ft02.gif"> \r
+<P>\r
+is used as an actual parameter:\r
+<P>\r
+<IMG SRC="gifs/ft03.gif"> \r
+<P>\r
+If the user desires to sort A with respect to date, it is sufficient\r
+to declare :\r
+<P>\r
+<IMG SRC="gifs/ft04.gif"> \r
+<P>\r
+and to call: <B>call</B> Gsort(bill,A,earlier); <HR>\r
+\r
+<P><hr>\r
+<A HREF="Prefixin.htm"><IMG SRC="gifs/PrevPage.gif"></A> \r
+<A HREF="homepage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Protecti.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>Loglan Home Page</TITLE>
+</HEAD>
+
+<BODY>
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo.gif"> Welcome to the Loglan 82 Micro Manual.</H1>
+
+<HR>
+<P><B>Author : </B> <A HREF="mailto:antek@mofnet.gov.pl">Antoni Kreczmar</A> <I>Institute of Informatics, Warsaw University - March 1990</I>
+<P><B>Edited by : </B> <A HREF="http://www.univ-pau.fr/~salwicki/GMyAS.html">Andrzej Salwicki</A> <I>LITA, Pau - November 1990</I>
+<P><B>HTML version : </B><A HREF="http://www.univ-pau.fr/~linfo062/"> Karl-Stefan Lapère</A>
+<HR>
+<A HREF="../loghome.htm"><IMG SRC="gifs/PrevPage.gif"></A>
+<IMG SRC="gifs/HomePage.gif">
+<A HREF="TableOfC.htm"><IMG SRC="gifs/NextPage.gif"></A>
+<HR>
+
+<ADDRESS><U>Last update 02/07/95</U>
+<P>Comments, suggestions and critiques are welcome to : <A HREF="mailto:Andrzej.Salwicki@univ-pau.fr"> Andrzej.Salwicki@univ-pau.fr</A>
+<P>
+</ADDRESS>
+</BODY>
+</HTML>
+
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">
+<HTML>
+
+<HEAD>
+
+<TITLE>Introduction</TITLE>
+
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">
+<META NAME="AUTHOR" CONTENT="NOM">
+</HEAD>
+
+<BODY>
+
+<P>
+<U><I>Loglan 82, A micro-manual of the programming language -
+Basic constructs and facilities</I></U>
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 1) Introduction</H1>
+<HR>
+
+<P>
+LOGLAN-82 is a universal programming language designed at the
+Institute of Informatics, University of Warsaw. Its syntax is
+patterned upon Pascal's. Its rich semantics includes the classical
+constructs and facilities offered by the Algol-family programming
+languages as well as more modern facilities, such as concurrency
+and exception handling.
+<P>
+The basic constructs and facilities of the LOGLAN-82 programming
+language include:
+<UL>
+<LI>A convenient set of <A HREF="compound.htm">structured statements</A>,
+<LI><A HREF="modulari.htm">Modularity</A> (with the possibility\r
+of module nesting and extending),\r
+<LI><A HREF="Classes.htm">Classes</A> (as a generalization of\r
+records) which enable to define complex structured types, data\r
+structures, packages, etc.,\r
+<LI><A HREF="adjustab.htm">Adjustable arrays</A> whose bounds\r
+are determined at run-time in such a way that multidimensional\r
+arrays may be of various shapes, e.g. triangular, k-diagonal,\r
+streaked, etc.,\r
+<LI><A HREF="coroutin.htm">Coroutines and semi-coroutines</A>,\r
+<LI><A HREF="Prefixin.htm">Prefixing</A> - the facility borrowed\r
+from Simula-67, substantially generalized in LOGLAN-82 - which\r
+enables to build up hierarchies of types and data structures,\r
+problem-oriented languages, etc.,\r
+<LI><A HREF="Formalty.htm">Formal types</A> treated as a method\r
+of module parametrization,\r
+<LI>Module <A HREF=Protecti.htm">protection</A> and encapsulation\r
+techniques,\r
+<LI><A HREF="Programm.htm">Programmed deallocator</A> - a tool\r
+for efficient and secure garbage collection, which allows the\r
+user to implement the optimal strategy of storage management,\r
+<LI><A HREF="Exceptio.htm">Exception handling</A> which provides\r
+facilities for dealing with run-time errors and other exceptional\r
+situations raised by the user,\r
+<LI><A HREF="Concurre.htm">Concurrency</A> easily adaptable to\r
+any operating system kernel and allowing parallel programming\r
+in a natural and efficient way.\r
+</UL>\r
+\r
+<P>\r
+The language covers system programming, data processing, and numerical\r
+computations. Its constructs represent the state-of-art and are\r
+efficiently implementable. Large systems consisting of many cooperating\r
+modules are easily decomposed and assembled, due to the class\r
+concept and prefixing.\r
+<P>\r
+LOGLAN-82 constructs and facilities have appeared and evolved\r
+simultaneously with the experiments on the first pilot compiler\r
+(implemented on Mera-400 Polish minicomputer). The research on\r
+LOGLAN-82 implementation engendered with new algorithms for static\r
+semantics, context analysis, code generation, data structures\r
+for storage management etc.\r
+<P>\r
+The LOGLAN-82 compiler provides a keen analysis of syntactic and\r
+semantic errors at compilation as well as at run time. The object\r
+code is very efficient with respect to time and space. The completeness\r
+of error checking guarantees full security and ease of program\r
+debugging. <HR>\r
+\r
+<P><hr>\r
+<A HREF="Tableofc.htm"><IMG SRC="gifs/PrevPage.gif"></A> \r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="compound.htm"><IMG SRC="gifs/NextPage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Prefixing</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U>\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 8) Prefixing</H1>\r
+<HR>\r
+\r
+<P>\r
+Classes and prefixing are ingenius inventions of Simula-67(cf\r
+[1]). Unfortunately they were hardly ever known and, perhaps,\r
+by this have not been introduced into many programming language\r
+that gained certain popularity. Moreover, implementation constraints\r
+of Simula-67 bind prefixing and classes workableness to such a\r
+degree that both facilities cannot be used in all respects. We\r
+hope that LOGLAN-82, adopting merits and rooting up deficiencies\r
+of these constructs, will smooth their variations and vivify theirs\r
+usefulness.\r
+<P>\r
+What is prefixing ? First of all it is a method for unit extending.\r
+Consider the simplest example:\r
+<P>\r
+<IMG SRC="gifs/pr01.gif"> \r
+<P>\r
+Assume the user desires to extend this class with new attributes.\r
+Instead of writing a completely new class, he may enlarge the\r
+existing one:\r
+<P>\r
+<IMG SRC="gifs/pr02.gif"> \r
+<P>\r
+Class gas_bill is prefixed by class bill. This new declaration\r
+may appear anywhere within the scope of declaration of class bill.\r
+(In Simula-67 such a prefixing is forbidden in nested units.)\r
+Class gas_bill has all the attributes of class bill and additionally\r
+its own attributes (in this case the only one: cube_meters). The\r
+generation statement of this class has the form:\r
+<P>\r
+<IMG SRC="gifs/pr03.gif"> \r
+<P>\r
+where z is a reference variable of type gas_bill. Remote access\r
+to the attributes of prefixed class is standard:\r
+<P>\r
+<IMG SRC="gifs/pr04.gif"> \r
+<P>\r
+Consider now the example of a class with parameters.\r
+<P>\r
+Assume that in a program a class:\r
+<P>\r
+<IMG SRC="gifs/pr05.gif"> \r
+<P>\r
+and its extension:\r
+<P>\r
+<IMG SRC="gifs/pr06.gif"> \r
+<P>\r
+are declared.\r
+<P>\r
+Then for variable z of type id_card and variable t of type idf_card\r
+the corresponding generation statement may be the following:\r
+<P>\r
+<IMG SRC="gifs/pr07.gif"> \r
+<P>\r
+Thus the formal parameters of a class are concatenated with the\r
+formal parameters of its prefix.\r
+<P>\r
+One can still extend class idf_card. For instance:\r
+<P>\r
+<IMG SRC="gifs/pr08.gif"> \r
+<P>\r
+Prefixing allows to build up hierarchies of classes. Each one\r
+hierarchy has a tree structure. A root of such a tree is a class\r
+without prefix. One class is a successor of another class iff\r
+the first is prefixed by the latter one.\r
+<P>\r
+Consider the prefix structure:\r
+<P>\r
+<IMG SRC="gifs/Fig0701.gif"> \r
+<P>\r
+Class H has a prefix sequence A, B, E, F, H. Let a, b, ... , h\r
+denote the corresponding unique attributes of classes A, B, ...\r
+, H, respectively. The objects of these classes have the following\r
+forms:\r
+<P>\r
+<IMG SRC="gifs/Fig0702.gif"> \r
+<P>\r
+Let Ra, Rb,..., Rh denote reference variables of types A, B,...,\r
+H, respectively. Then the following expressions are correct:\r
+<P>\r
+<IMG SRC="gifs/pr09.gif"> \r
+<P>\r
+Variable Ra may designate the object of class B (or C,..., H),\r
+i.e. the statement:\r
+<P>\r
+<IMG SRC="gifs/pr10.gif"> \r
+<P>\r
+is legal. But then attribute b is not accessible through dot via\r
+Ra, i.e. Ra.b is incorrect. This follows from insecurity of such\r
+a remote access. In fact, variable Ra may point any object of\r
+a class prefixed by A, in particular, Ra may point the object\r
+of A itself, which has no attribute b. If Ra.b had been correct,\r
+a compiler should have distiguish the cases Ra points to the object\r
+of A or not. But this, of course, is undistinguishable at compilation\r
+time.\r
+<P>\r
+To allow, however, the user's access to attribute b (after instruction\r
+Ra:=<B>new</B> B), the instantaneous type modification is provided\r
+within the language:\r
+<P>\r
+<IMG SRC="gifs/pr11.gif"> \r
+<P>\r
+The correctness of this expression is checked at run time. If\r
+Ra designates an object of B or prefixed ba B, the type of the\r
+expression is B. Otherwise the expression is erroneous. Thus,\r
+for instance, the expressions:\r
+<P>\r
+<IMG SRC="gifs/pr12.gif"> \r
+<P>\r
+enable remote access to the attributes b, c, ... via Ra.\r
+<P>\r
+So far the question of attribute concatenation was merely discussed.\r
+However the sequences of statements can be also concatenated.\r
+<P>\r
+Consider class B prefixed with class A. In the sequence of statements\r
+of class A the keyword inner may occur anywhere, but only once.\r
+The sequence of statements of class B consists of the sequence\r
+of statements of class A with inner replaced by the sequence of\r
+statements of class B.\r
+<P>\r
+<IMG SRC="gifs/Fig0703.gif"> \r
+<P>\r
+In this case inner in class B is equivalent to the empty statement.\r
+If class B prefixes another class, say C, then inner in B is replaced\r
+by the sequence of statements of class C, and so on. If inner\r
+does not occur explicitly, an implicit occurrence of inner before\r
+the final end of a class is assumed.\r
+<P>\r
+Example\r
+<P>\r
+Let class complex be declared as usual:\r
+<P>\r
+<IMG SRC="gifs/pr13.gif"> \r
+<P>\r
+and assume one desires to declare a class mcomplex with the additional\r
+attribute module. In order the generation of class mcomplex define\r
+the value of attribute module, one can declare a class:\r
+<P>\r
+<IMG SRC="gifs/pr14.gif"> \r
+<P>\r
+Class mcomplex may be still extended:\r
+<P>\r
+<IMG SRC="gifs/pr15.gif"> \r
+<P>\r
+For these declarations each generation of class mcomplex defines\r
+the value of attribute module, each generation of class pcomplex\r
+defines the values of attributes module and alfa.\r
+<P>\r
+For reference variables z1, z2 z3 of type complex, the following\r
+sequence of statements illustrates the presented constructs:\r
+<P>\r
+<IMG SRC="gifs/pr16.gif"> \r
+<P>\r
+Example:\r
+<P>\r
+Binary search tree (Bst) is a binary tree where for each node\r
+x the nodes in the left subtree are less than x, the nodes in\r
+the right subtree are greater than x. It is the well-known exercise\r
+to program the algorithms for the following operations on Bst:\r
+<P>\r
+member(x) = true iff x belongs to Bst\r
+<P>\r
+insert(x), enlarge Bst with x, if x does not yet belong to Bst\r
+<P>\r
+We define both these operations in a class:\r
+<P>\r
+<IMG SRC="gifs/pr17.gif"> \r
+<P>\r
+In the example the common actions of member and insert are programmed\r
+in class help. Then it suffices to use class help as a prefix\r
+of function member and procedure insert, instead of redundant\r
+occurrences of the corresponding sequence of statements in both\r
+units.\r
+<P>\r
+Class Bst may be applied as follows:\r
+<P>\r
+<IMG SRC="gifs/pr18.gif"> \r
+<P>\r
+As shown in the declaration of Bst, class may prefix not only\r
+other classes but also procedures and functions. Class may prefix\r
+blocks as well.\r
+<P>\r
+Example:\r
+<P>\r
+Let class push_down (p. 5) prefix a block:\r
+<P>\r
+<IMG SRC="gifs/pr19.gif"> \r
+<P>\r
+In the above block prefixed with class push_down one can use pop\r
+and push as local attributes. (They are local since the block\r
+is embedded in the prefix push down.)\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pr20.gif"> \r
+<P>\r
+In place where classes push_down and Bst are visible together\r
+a block prefixed with Bst may be nested in a block prefixed with\r
+push_down (or vice versa). In the inner block both data structures\r
+are directly accessible. Note that this construct is illegal in\r
+Simula 67. <HR>\r
+\r
+<P><hr>\r
+<A HREF="coroutin.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="FormalTy.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Procedures and functions</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U>\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 4) Procedures and\r
+functions</H1>\r
+<HR>\r
+\r
+<P>\r
+Procedures and functions are well-known kinds of units. Their\r
+syntax is modelled on Pascal's, though with some slight modifications.\r
+Procedure (function) declaration consists of a specification part\r
+and a body.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pf01.gif"> \r
+<P>\r
+Procedure or function specification begins with its identifier\r
+preceded by the keyword unit. (The same syntax concerns any other\r
+module named unit.) Then follows its kind declaration, its formal\r
+parameters (if any), and the type of the returned value (only\r
+for functions). A body consists of declaration lists for local\r
+entities and a sequence of statements. The keyword <B>begin</B>\r
+commences the sequence of statements, and is omitted, if this\r
+sequence is empty. The value returned by a function equals to\r
+the most recent value of the standard variable "result",\r
+implicitly declared in any function. This variable can be used\r
+as a local auxiliary variable as well.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pf02.gif"> \r
+<P>\r
+The optional identifier at the end of a unit must repeat the identifier\r
+of a unit. It is suggested that the compilers check the order\r
+of unit nesting, so these optional occurrences of identifiers\r
+would facilitate program debugging.\r
+<P>\r
+All the local variables of a unit are initialized (real with 0.0,\r
+integer with 0, boolean with false etc.). Thus , for instance,\r
+the value of function Newton is 0 for m&gtn, since "result"\r
+is also initialized, as any other local variable.\r
+<P>\r
+The return statement (return) completes the execution of a procedure\r
+(function) body,i.e. return is made to the caller. If return does\r
+not appear explicitly, return is made with the execution of the\r
+final end of a unit. Upon return to the caller the procedure (function)\r
+object is deallocated.\r
+<P>\r
+Functions are invoked in expressions with the corresponding list\r
+of actual parameters. Procedures are invoked by call statement\r
+(also with the corresponding list of actual parameters).\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pf03.gif"> \r
+<P>\r
+Formal parameters are of four categories: variable parameters,\r
+procedure parameters, function parameters and type parameters\r
+(cf p.8). Variable parameters are considered local variables to\r
+the unit. A variable parameter has one of three transmission modes:\r
+input, output or inout. If no mode is explicitly given the input\r
+mode is assumed. For instance in the unit declaration:\r
+<P>\r
+<IMG SRC="gifs/pf04.gif"> \r
+<P>\r
+x,y,b are input parameters , c,i are output parameters , and j\r
+is inout parameter.\r
+<P>\r
+Input parameter acts as a local variable whose value is initialized\r
+by the value of the corresponding actual parameter. Output parameter\r
+acts as a local variable initialized in the standard manner (real\r
+with 0.0, integer with 0, boolean with false etc.). Upon return\r
+its value is assigned to the corresponding actual parameter, in\r
+which case it must be a variable. However the address of such\r
+an actual parameter is determined upon entry to the body. Inout\r
+parameter acts as an input parameter and output parameter together.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pf05.gif"> \r
+<P>\r
+A procedure call to the above unit may be the following:\r
+<P>\r
+<IMG SRC="gifs/pf06.gif"> \r
+<P>\r
+where g,h,gi,hi are real variables.\r
+<P>\r
+No restriction is imposed on the order of declarations. In particular,\r
+recursive procedures and functions can be declared without additional\r
+announcements (in contrast to Pascal).\r
+<P>\r
+Example:\r
+<P>\r
+For two recursive sequences defined as:\r
+<P>\r
+a(n)=b(n-1)+n+2 n>0\r
+<P>\r
+b(n)=a(n-1)+(n-1)*n n>0\r
+<P>\r
+a(0)=b(0)=0\r
+<P>\r
+one can declare two functions:\r
+<P>\r
+<IMG SRC="gifs/pf07.gif"> \r
+<P>\r
+and invoke them:\r
+<P>\r
+k:=a(100)*b(50)+a(15);\r
+<P>\r
+Functions and procedures can be formal parameters as well.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pf08.gif"> \r
+<P>\r
+In the above declaration, after the input variable parameters\r
+a,b,eps and the output variable parameter x, a function parameter\r
+f appears. Note that its specification part is complete. Thus\r
+the check of actual-formal parameter compatibility is possible\r
+at compilation time. Making use of this syntactic facility is\r
+not possible in general, if a formal procedure (function) is again\r
+a formal parameter of a formal procedure (function). The second\r
+degree of formal procedures (functions) nesting is rather scarce,\r
+but LOGLAN-82 admits such a construct. Then formal procedure (function)\r
+has no specification part and the full check of actual-formal\r
+parameter compatibility is left to be done at run time.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/pf09.gif"> \r
+<P>\r
+Procedure G is a first degree parameter, therefore it occurs with\r
+complete specification part. Procedure H is a second degree parameter\r
+and has no specification part. In this case a procedure call can\r
+be strongly recursive:\r
+<P>\r
+<IMG SRC="gifs/pf10.gif"> <HR>\r
+\r
+<hr><P>\r
+<A HREF="Modulari.htm"><IMG SRC="gifs/PrevPage.gif"></A> \r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Classes.htm"><IMG SRC="gifs/NextPage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Programmed deallocation</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4><U><I>Loglan 82, A micro-manual of the programming language\r
+- Basic constructs and facilities</I></U></H4>\r
+\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 11) Programmed deallocation\r
+</H1>\r
+<HR>\r
+\r
+<P>\r
+The classical methods implemented to deallocate class objects\r
+are based on reference counters or garbage collection. Sometimes\r
+the both methods may be combined. A reference counter is a system\r
+attribute holding the number of references pointing to the given\r
+object. Hence any change of the value of a reference variable\r
+X is followed by a corresponding increase or decrease of the value\r
+of its reference counter. When the reference counter becomes equal\r
+0, the object can be deallocated.\r
+<P>\r
+The deallocation of class objects may also occur during the process\r
+of garbage collection. During this process all unreferenced objects\r
+are found and removed (while memory may be compactified). In order\r
+to keep the garbage collector able to collect all the garbage,\r
+the user should clear all reference variables , i.e. set to None,\r
+whenever possible. This system has many disadvantages. First of\r
+all, the programmer is forced to clear all reference variables,\r
+even those which are of auxiliary character. Moreover, garbage\r
+collector is a very expensive mechanism and thus it can be used\r
+only in emergency cases.\r
+<P>\r
+In LOGLAN a dual operation to the object generator, the so-called\r
+object deallocator is provided. Its syntactic form is as follows:\r
+<P>\r
+<IMG SRC="gifs/pd01.gif"> \r
+<P>\r
+where X is a reference expression. If the value of X points to\r
+no object (none) then kill(X) is equivalent to an empty statement.\r
+If the value of X points to an object O, then after the execution\r
+of kill(X), the object O is deallocated. Moreover all reference\r
+variables which pointed to O are set to none. This deallocator\r
+provides full <I>security</I>, i.e. the attempt to access the\r
+deallocated object O is checked and results in a run-time error.\r
+<P>\r
+For example:\r
+<P>\r
+<IMG SRC="gifs/pd02.gif"> \r
+<P>\r
+causes the same run-time error as:\r
+<P>\r
+<IMG SRC="gifs/pd03.gif"> \r
+<P>\r
+The system of storage management is arranged in such a way that\r
+the frames of killed objects may be immediately reused without\r
+the necessity of calling the garbage collector, i.e. the relocation\r
+is performed automatically. There is nothing for it but to remember\r
+not to use remote access to a killed object. (Note that the same\r
+problem appears when remote access X.W is used and X=none).\r
+<P>\r
+Example:\r
+<P>\r
+Below a practical example of the programmed deallocation is presented.\r
+Consider class Bst (p.7). Let us define a procedure that deallocates\r
+the whole tree and is called with the termination of the class\r
+Bst.\r
+<P>\r
+<IMG SRC="gifs/pd04.gif"> \r
+<P>\r
+Bst may be applied as a prefix:\r
+<P>\r
+<IMG SRC="gifs/pd05.gif"> \r
+<P>\r
+and automatically will cause the deallocation of the whole tree\r
+after return to call kill_all(root) from the prefixed block.\r
+<P>\r
+To use properly this structure by remote accessing one must call\r
+kill_all by himself:\r
+<P>\r
+<IMG SRC="gifs/pd06.gif"> \r
+<P>\r
+Finally note that deallocator kill enables deallocation of array\r
+objects, and suspended coroutines and processes as well (cf p.13).\r
+<HR>\r
+\r
+<P><hr>\r
+<A HREF="Protecti.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+<A HREF="HomePage.html"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Exceptio.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Protection techniques</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4><U><I>Loglan 82, A micro-manual of the programming language\r
+- Basic constructs and facilities</I></U></H4>\r
+\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 10) Protection techniques\r
+</H1>\r
+<HR>\r
+\r
+<P>\r
+Protection techniques ease secure programming. If a program is\r
+large, uses some system classes, is designed by a team etc., this\r
+is important (and non-trivial) to impose some restrictions on\r
+access to non-local attributes.\r
+<P>\r
+Let us consider a data structure declared as a class. Some of\r
+its attributes should be accessible for the class users, the others\r
+should not. For instance, in class Bst (p.7) the attributes member\r
+and insert are to be accessible. On the other hand the attributes\r
+root, node and help should not be accessible, even for a meddlesome\r
+user. An improper use of them may jeopardize the data structure\r
+invariants.\r
+<P>\r
+To forbid the access to some class attributes the three following\r
+protection mechanisms are provided: <B>close</B>, <B>hidden</B>\r
+and <B>taken</B>.\r
+<P>\r
+The protection close defined in a class forbids remote access\r
+to the specified attributes. For example, consider the class declaration:\r
+<P>\r
+<IMG SRC="gifs/pt01.gif"> \r
+<P>\r
+Remote access to the attributes x,y,z from outside of A is forbidden.\r
+<P>\r
+The protection hidden (with akin syntax) does not allow to use\r
+the specified attributes form outside of A neither by the remote\r
+access nor in the units prefixed by A. The only way to use a hidden\r
+attribute is to use it within the body of class A.\r
+<P>\r
+Protection taken defines these attributes derived from prefix,\r
+which the user wishes to use in the prefixed unit. Consider a\r
+unit B prefixed by a class A. In unit B one may specify the attributes\r
+of A which are used in B. This protects the user against an unconscious\r
+use of an attribute of class A in unit B (because of identifier\r
+conflict). When taken list does not occur, then by default, all\r
+non-hidden attributes of class A are accessible in unit B. <HR>\r
+\r
+<P><hr>\r
+<A HREF="FormalTy.htm"><IMG SRC="gifs/PrevPage.gif"></A> \r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Programm.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>References</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4><U><I>Loglan 82, A micro-manual of the programming language\r
+- Basic constructs and facilities</I></U></H4>\r
+\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 14) References</H1>\r
+<HR>\r
+\r
+<P>\r
+<B>Report on the Loglan 82 programming Language</B> Bartol, <I>Warszawa-Lodz,\r
+PWN, 1984</I> \r
+<P>\r
+<B>Simula 67 Common Base Language</B> O.-J. Dahl, B. Myhrhaug,\r
+K. Nygaard, <I>Norwegian Computing Center, Oslo, 1970</I> \r
+<P>\r
+<B>Monitors, an operating system structuring concept</B> Hoare\r
+C.A.R., <I>CACM, vol.17,N.10, October 1974, pp.549-57</I> \r
+<P>\r
+<B>Loglan'82 User's guide</B>, Institute of Informatics, <I>University\r
+of Warsaw 1983-1988</I>, LITA, <I>Université de Pau et\r
+des pays de l'Adour, 1993</I> \r
+<P>\r
+<B>Loglan'88 - Report on the Programming Language</B> A.Kreczmar,\r
+A.Salwicki, M. Warpechowski, ,\r
+<P>\r
+<B>Lecture Notes on Computer Science vol. 414</B>, <I>Springer\r
+Vlg, 1990, ISBN 3-540-52325-1</I> \r
+<P>\r
+<B>LOGLAN, Wydawnictwa Naukowo-Techniczne</B>, A.Szalas, J.Warpechowska,\r
+<I>Warszawa, 1991 ISBN 82-204-1295-1</I> (<U>if you can read polish</U>)\r
+<HR>\r
+\r
+<P>\r
+<A HREF="concurre.htm"><IMG SRC="gifs/PrevPage.gif"></A> \r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> <IMG SRC="gifs/NextPage.gif">\r
+<HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">
+<HTML>
+
+<HEAD>
+
+<TITLE>Table of contents</TITLE>
+
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">
+<META NAME="AUTHOR" CONTENT="NOM">
+</HEAD>
+
+<BODY>
+
+<P>
+<U><I>Loglan 82, A micro-manual of the programming language -
+Basic constructs and facilities</I></U>
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> Table of contents
+</H1>
+<HR>
+
+<OL>
+<LI><A HREF="Introduc.htm">Introduction</A>
+<LI><A HREF="compound.htm">Compound statements</A>
+<LI><A HREF="modulari.htm">Modularity</A>
+<LI><A HREF="Procedur.htm">Procedures and functions</A>
+<LI><A HREF="Classes.htm">Classes</A>
+<LI><A HREF="adjustab.htm">Adjustable arrays</A>
+<LI><A HREF="coroutin.htm">Coroutines and semicoroutines</A>
+<LI><A HREF="Prefixin.htm">Prefixing</A>
+<LI><A HREF="Formalty.htm">Formal types</A>
+<LI><A HREF="Protecti.htm">Protection techniques</A>
+<LI><A HREF="Programm.htm">Programmed deallocation</A>
+<LI><A HREF="Exceptio.htm">Exception handling</A>
+<LI><A HREF="Concurre.htm">Concurrent processes</A>
+<LI><A HREF="Referenc.htm">References</A>
+</OL>
+<HR>
+<hr>
+<P>
+<A HREF="HomePage.htm"><IMG SRC="gifs/PrevPage.gif"></A>
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A>
+<A HREF="Introduc.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>
+<hr>
+<ADDRESS>
+Last update 02/07/95
+</ADDRESS>
+
+<ADDRESS>
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>
+
+</ADDRESS>
+
+</BODY>
+
+</HTML>
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Adjustable arrays</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4><U><I>Loglan 82, A micro-manual of the programming language\r
+- Basic constructs and facilities</I></U></H4>\r
+\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 6) Adjustable arrays\r
+</H1>\r
+<HR>\r
+\r
+<P>\r
+In LOGLAN-82 arrays are adjustable at run time. They may be treated\r
+as objects of specified standard type with index instead of identifier\r
+selecting an attribute. An adjustable array should be declare\r
+somewhere among the lists of declarations and then may be generated\r
+in the sequence of statements.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/aa01.gif"> \r
+<P>\r
+A variable A is an array variable. Its value should be the reference\r
+to an integer array, i.e. a composite object consisting of integer\r
+components each one defined by an integer index.\r
+<P>\r
+Array generation statement:\r
+<P>\r
+<IMG SRC="gifs/aa02.gif"> \r
+<P>\r
+allocates a one-dimensional integer array with the index bounds\r
+1,n , and assigns its address to variable A.\r
+<P>\r
+The figure below illustrates this situation:\r
+<P>\r
+<IMG SRC="gifs/Fig0501.gif"> \r
+<P>\r
+A general case of array generation statement has the form:\r
+<P>\r
+<IMG SRC="gifs/aa03.gif"> \r
+<P>\r
+where lower and upper are arithmetic expressions which define\r
+the range of the array index.\r
+<P>\r
+Example:\r
+<P>\r
+Two-dimensional array declaration :\r
+<P>\r
+<IMG SRC="gifs/aa04.gif"> \r
+<P>\r
+and generation:\r
+<P>\r
+<IMG SRC="gifs/aa05.gif"> \r
+<P>\r
+create the structure:\r
+<P>\r
+<IMG SRC="gifs/Fig0502.gif"> \r
+<P>\r
+<IMG SRC="gifs/aa06.gif"> \r
+<P>\r
+Array A is the square array n by n. Each element A(i) , 1<=i<=n\r
+contains the address of row A(i,j), 1<=j<=n. Array B is\r
+the lower-triangular array. Each element B(i), 1<=i<=n,\r
+contains the address of row B(i,j), 1<=j<=i. Thus an assignment\r
+statement A(n,n):=B(n,n) transmits real value B(n,n) to real variable\r
+A(n,n). Assignment B(1):=A(1) transmits the address of the first\r
+row of A to variable B(1). Finally assignment B(1):=copy (A(1))\r
+creates a copy of the first row of A and assigns its address to\r
+B(1).\r
+<P>\r
+Upper and lower bounds of an adjustable array A are determined\r
+by standard operators lower(A) and upper(A).\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/aa07.gif"> \r
+<P>\r
+If an array variable A refers to no array its value is equal none\r
+(the standard default value of any array variable). An attempt\r
+to access an array element (e.g. A(i)) or a bound (e.g. lower(A)),\r
+where A is none, raises a run time error. <HR>\r
+\r
+<P>\r
+<hr>\r
+<A HREF="classes.htm"><IMG SRC="gifs/PrevPage.gif"></A> <A HREF="homepage.htm">\r
+<IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="coroutin.htm"><IMG SRC="gifs/NextPage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Compound Statements</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4><U><I>Loglan 82, A micro-manual of the programming language\r
+- Basic constructs and facilities</I></U></H4>\r
+\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 2) Compound Statements\r
+</H1>\r
+<HR>\r
+\r
+<P>\r
+Compound statements in LOGLAN-82 are built up from simple statements\r
+(like assignment statement e.g. x:=y+0.5, call statement e.g.\r
+call P(7,x+5) etc.) by means of conditional, iteration and case\r
+statements.\r
+<P>\r
+The syntax of conditional statement is as follows:\r
+<P>\r
+<IMG SRC="gifs/cs01.gif"> \r
+<P>\r
+where "<B>else</B> part" may be omitted:\r
+<P>\r
+<IMG SRC="gifs/cs02.gif"> \r
+<P>\r
+The semantics of conditional statement is standard. The keyword\r
+<B>fi</B> allows to nest conditional statements without appearence\r
+of "dangling <B>else</B>" ambiguity.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cs03.gif"> \r
+<P>\r
+The statements in a sequence of statements are separated with\r
+semicolons (semicolon may end a sequence , and then, the last\r
+statement in the sequence is the empty statement).\r
+<P>\r
+The short circuit control forms are realized in LOGLAN-82 by the\r
+conditional statements with <B>orif</B> (or <B>andif</B>) list.\r
+A conditional statement with <B>orif</B> list has the form:\r
+<P>\r
+<IMG SRC="gifs/cs04.gif"> \r
+<P>\r
+and corresponds somehow to a conditional statement:\r
+<P>\r
+<IMG SRC="gifs/cs05.gif"> \r
+<P>\r
+The above conditional statement (without orif list) selects for\r
+execution one of two sequences of statements, depending on the\r
+truth value of the boolean expression:\r
+<P>\r
+<IMG SRC="gifs/cs06.gif"> \r
+<P>\r
+which is always evaluated till the end. For the execution of the\r
+conditional statement with <B>orif</B> list the specified conditons\r
+wb1,...,wbk are evaluated in succession, until the first one evaluates\r
+to true. Then the rest of the sequence wb1,...,wbk is abandoned\r
+and "<B>then</B> part" is executed. If none of the conditions\r
+wb1,...,wbk evaluates to true "<B>else</B> part" is\r
+executed (if any).\r
+<P>\r
+Conditional statements with <B>orif</B> list facilitate to program\r
+those conditions, which evaluation to the end may raise a run-time\r
+error.\r
+<P>\r
+Example:\r
+<P>\r
+The execution of the statement:\r
+<P>\r
+<IMG SRC="gifs/cs07.gif"> \r
+<P>\r
+where the value of i is greater than n, and A is an array with\r
+upper bound n, will raise the run-time error. Then the user can\r
+write:\r
+<P>\r
+<IMG SRC="gifs/cs08.gif"> \r
+<P>\r
+what allows to avoid this run-time error and probably agrees with\r
+his intension.\r
+<P>\r
+Conditional statement with andif list has the form:\r
+<P>\r
+<IMG SRC="gifs/cs09.gif"> \r
+<P>\r
+For the execution of this kind of statements, the conditions wb1,...,wbk\r
+are evaluated in succession, until the first one evaluates to\r
+false; then "<B>else</B> part" (if any) is executed.\r
+Otherwise "<B>then</B> part" is executed.\r
+<P>\r
+Iteration statement in LOGLAN-82 has the form:\r
+<P>\r
+<IMG SRC="gifs/cs10.gif"> \r
+<P>\r
+An iteration statement specifies repeated execution of the sequence\r
+of statements and terminates with the execution of the simple\r
+statement <B>exit</B> \r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cs11.gif"> \r
+<P>\r
+If two iteration statements are nested, then double <B>exit</B>\r
+in the inner one terminates both of them.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cs12.gif"> \r
+<P>\r
+In the example above simultaneous assignment statements are illustrated\r
+(e.g. r,x:=0) and comments, which begin with a left parenthesis\r
+immediately followed by an asterisk and end with an asterisk immediately\r
+followed by a right parenthesis.\r
+<P>\r
+Triple <B>exit</B> terminates three nested iteration statements,\r
+four <B>exit</B> terminates four nested iteration statements etc.\r
+<P>\r
+The iteration statement with <B>while</B> condition:\r
+<P>\r
+<IMG SRC="gifs/cs13.gif"> \r
+<P>\r
+is equivalent to:\r
+<P>\r
+<IMG SRC="gifs/cs14.gif"> \r
+<P>\r
+The iteration statements with controlled variables (for statements)\r
+have the forms:\r
+<P>\r
+<IMG SRC="gifs/cs15.gif"> \r
+<P>\r
+or\r
+<P>\r
+<IMG SRC="gifs/cs16.gif"> \r
+<P>\r
+The type of the controlled variable j must be discrete. The value\r
+of this variable in the case of the for statement with to is increased,\r
+and in the case of the <B>for</B> statement with <B>downto</B>\r
+is decreased. The discrete range begins with the value of wa1\r
+and changes with the step equal to the value of wa2. The execution\r
+of the <B>for</B> statement with to terminates when the value\r
+of j for the first time becomes greater than the value of wa3\r
+(with downto when the value of j for the first time becomes less\r
+than the value of wa3). After the for statement termination the\r
+value of its controlled variable is determined and equal to the\r
+first value exceeding the specified discrete range.\r
+<P>\r
+The values of expressions wa1, wa2 and wa3 are evaluated once,\r
+upon entry to the iteration statement. Default value of wa2 is\r
+equal 1 (when the keyword step and expression wa2 are omitted).\r
+<P>\r
+<B>For</B> or <B>while</B> statements may be combined with exit\r
+statement.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cs17.gif"> \r
+<P>\r
+The above iteration statement terminates either for the least\r
+j, 1<=j<=n, such that x=A(j) or for j=n+1 when x=/=A(j),\r
+j=1,...,n.\r
+<P>\r
+To enhance the user's comfort, the simple statement <B>repeat</B>\r
+is provided. It may appear in an iteration statement and causes\r
+the current iteration to be finished and the next one to be continued\r
+(something like jump to CONTINUE in Fortran's DO statements).\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/cs18.gif"> \r
+<P>\r
+Just as <B>exit</B>, <B>repeat</B> may appear in <B>for</B> statement\r
+or <B>while</B> statement. Then the next iteration begins with\r
+either the evaluation of a new value of the controlled variable\r
+(<B>for</B> statement) or <B>with</B> the evaluation of the condition\r
+(while statement).\r
+<P>\r
+Case statement in LOGLAN-82 has the form:\r
+<P>\r
+<IMG SRC="gifs/cs19.gif"> \r
+<P>\r
+where WA is an expression , L1,...,Lk are constants and I1,...,\r
+Ik,I are sequences of statements.\r
+<P>\r
+A <B>case</B> statement selects for execution a sequence of statements\r
+Ij, 1<=j<=k, where the value of WA equals Lj. The choice\r
+<B>otherwise</B> covers all values (possibly none) not given in\r
+the previous choices. The execution of a <B>case</B> statement\r
+chooses one and only one alternative (since the choices are to\r
+be exhaustive and mutually exclusive). <HR>\r
+\r
+<P>\r
+<hr>\r
+<A HREF="tableofc.htm"><IMG SRC="gifs/PrevPage.gif"></A> \r
+<A HREF="homepage.htm"> <IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="modulari.htm"><IMG SRC="gifs/NextPage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Coroutines and semicoroutines</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4><U><I>Loglan 82, A micro-manual of the programming language\r
+- Basic constructs and facilities</I></U></H4>\r
+\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 7) Coroutines and\r
+semicoroutines</H1>\r
+<HR>\r
+\r
+<P>\r
+Coroutine is a generalization of class. A coroutine object is\r
+an object such that the execution of its sequence of statements\r
+can be suspended and reactivated in a programmed manner. Consider\r
+first a simple class with a sequence of statements such that after\r
+return some non-executed statements remain. The generation of\r
+its object terminates with the execution of return statement,\r
+although the object can be later reactivated. If such a class\r
+is declared as a coroutine, then its objects may be reactivated.\r
+This can be realized by an attach statement:\r
+<PRE>\r
+<B>attach</B>(X)\r
+</PRE>\r
+\r
+<P>\r
+where X is a reference variable designating the activating coroutine\r
+object.\r
+<P>\r
+In general, since the moment of generation a coroutine object\r
+is either active or suspended. Any reactivation of a suspended\r
+coroutine object X (by attach(X)) causes the active coroutine\r
+object to be suspended and continues the execution of X from the\r
+statement following the last executed one.\r
+<P>\r
+Main program is also a coroutine. It is accessed through the standard\r
+variable main and may be reactivated (if suspended) by the statement\r
+attach(main).\r
+<P>\r
+Example:\r
+<P>\r
+In the example below the cooperation of two coroutines is presented.\r
+One reads the real values from an input device, another prints\r
+these values in columns on a line-printer, n numbers in a line.\r
+The input stream ends with 0.\r
+<P>\r
+<IMG SRC="gifs/co02.gif"> \r
+<P>\r
+Then\r
+<P>\r
+<IMG SRC="gifs/co03.gif"> \r
+<P>\r
+In the example below the application of detach statement is illustrated.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/co04.gif"> \r
+<P>\r
+Coroutines play the substantial role in process simulation. Class\r
+Simulation provided in Simula-67 makes use of coroutines at most\r
+degree. LOGLAN-82 provides for easy simulation as well. The LOGLAN-82\r
+class Simulation is implemented on a heap what gives lg(n) time\r
+cost (in contrast with O(n) cost of the original implementation).\r
+It covers also various simulation problems of large size and degree\r
+of complexity. <HR>\r
+<hr>\r
+<P>\r
+<A HREF="Adjustab.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Prefixin.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Modularity</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+<U><I>Loglan 82, A micro-manual of the programming language -\r
+Basic constructs and facilities</I></U>\r
+<H1><IMG ALIGN=MIDDLE SRC="gifs/logo2.gif"> 3) Modularity</H1>\r
+<HR>\r
+\r
+<P>\r
+Modular structure of the language is gained due to the large set\r
+of means for module nesting and extending. Program modules (<B>unit</B>s)\r
+are <B>blocks</B>, <A HREF="procedur.htm">procedures</A>, <A HREF="procedur.htm">functions</A>,\r
+<A HREF="classes.htm">classes</A>, <A HREF="coroutin.htm">coroutines</A>\r
+and <A HREF="concurre.htm">processes</A>. <B>Block</B> is the\r
+simplest kind of <B>unit</B>. Its syntax is the following:\r
+<P>\r
+<IMG SRC="gifs/mo01.gif"> \r
+<P>\r
+The sequence of statements commences with the keyword <B>begin</B>\r
+(it may be omitted when this sequence is empty). The lists of\r
+declarations define the syntactic entities (variables, constants,\r
+other <B>unit</B>s), whose scope is that block. The syntactic\r
+entities are identified in the sequence of statements by means\r
+of names (identifiers).\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/mo02.gif"> \r
+<P>\r
+In the lists of declarations semicolons terminate the whole lists,\r
+not the lists elements. Any declaration list must begin with the\r
+pertinent keyword (<B>var</B> for variables, <B>const</B> for\r
+constants etc.). The value of an expression defining a constant\r
+must be determinable statically (at compilation time).\r
+<P>\r
+Program in LOGLAN-82 may be a block or alternatively may be of\r
+the following form:\r
+<P>\r
+<IMG SRC="gifs/mo03.gif"> \r
+<P>\r
+Then the whole program can be identified by that name (the source\r
+as well as the object code).\r
+<P>\r
+A block can appear in the sequence of statements (of any <B>unit</B>),\r
+thus it is a statement. (Main block is assumed to appear as a\r
+statement of the given job control language.)\r
+<P>\r
+For the execution of a block statement the object of block is\r
+created in a computer memory, and then, the sequence of statements\r
+is performed. The syntactic entities declared in the block are\r
+allocated in its object. After a block's termination its object\r
+is automatically deallocated (and the corresponding space may\r
+be immediately reused).\r
+<P>\r
+The modular structure of the language works "in full steam"\r
+when not only blocks, but the other kinds of <B>unit</B>s are\r
+also used. They will be described closer in the following points.\r
+<P>\r
+<B>Unit</B> nesting allows to build up hierarchies of units and\r
+supports security of programming. It follows from the general\r
+visibility rules; namely, a syntactic entity declared in an outer\r
+unit is visible in an <B>inner</B> one (unless hidden by an <B>inner</B>\r
+declaration). On the other hand, a syntactic entity declared in\r
+an <B>inner</B> <B>unit</B> is not visible from an outer one.\r
+<P>\r
+Example:\r
+<P>\r
+<IMG SRC="gifs/mo04.gif"> \r
+<P>\r
+In this program, first the main block statement is executed (with\r
+variables a,b,c,i,j,k). Next, after the read statement, the inner\r
+block statement is executed (with variables j,k). In the inner\r
+block the global variables j,k are hidden by the local ones. \r
+<HR>\r
+\r
+<hr><P>\r
+<A HREF="Compound.htm"><IMG SRC="gifs/PrevPage.gif"></A>\r
+<A HREF="HomePage.htm"><IMG SRC="gifs/HomePage.gif"></A> \r
+<A HREF="Procedur.htm"><IMG SRC="gifs/NextPage.gif"></A> <HR>\r
+\r
+<ADDRESS>\r
+Last update 02/07/95 \r
+</ADDRESS>\r
+\r
+<ADDRESS>\r
+Comments, suggestions and critiques are welcome to : <A HREF="mailto:linfo062@crisv2.univ-pau.fr">linfo062@crisv2.univ-pau.fr</A>\r
+\r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<PRE>
+<B>program</B> monitors;
+
+(* this an example showing 5 processes: two of them are in fact monitors, one controls the screen=ekran *)
+
+ <B>unit</B> ANSI: <B>class</B>;
+ (* CHECK whether config.sys contains a line device=ansi.sy the class ANSI enables operations on cursor, and bold, blink, underscore etc. *)
+
+ <B>unit</B> Bold : <B>procedure</B>;
+ <B>begin</B>
+ write( chr(27), "[1m")
+ <B>end</B> Bold;
+
+ <B>unit</B> Blink : <B>procedure</B>;
+ <B>begin</B>
+ write( chr(27), "[5m")
+ <B>end</B> Blink;
+
+ <B>unit</B> Reverse : <B>procedure</B>;
+ <B>begin</B>
+ write( chr(27), "[7m")
+ <B>end</B> Reverse;
+
+ <B>unit</B> Normal : <B>procedure</B>;
+ <B>begin</B>
+ write( chr(27), "[0m")
+ <B>end</B> Normal;
+
+ <B>unit</B> Underscore : <B>procedure</B>;
+ <B>begin</B>
+ write( chr(27), "[4m")
+ <B>end</B> Underscore;
+
+ <B>unit</B> inchar : IIUWgraph <B>function</B> : integer;
+ (*podaj nr znaku przeslanego z klawiatury *)
+ <B>var</B> i : integer;
+ <B>begin</B>
+ <B>do</B>
+ i := inkey;
+ <B>if</B> i <> 0 <B>then</B> <B>exit</B> <B>fi</B>;
+ <B>od</B>;
+ <B>result</B> := i;
+ <B>end</B> inchar;
+
+ <B>unit</B> NewPage : <B>procedure</B>;
+ <B>begin</B>
+ write( chr(27), "[2J")
+ <B>end</B> NewPage;
+
+ <B>unit</B> SetCursor : <B>procedure</B>(row, column : integer);
+ <B>var</B> c,d,e,f : char,
+ i,j : integer;
+ <B>begin</B>
+ i := row <B>div</B> 10;
+ j := row <B>mod</B> 10;
+ c := chr(48+i);
+ d := chr(48+j);
+ i := column <B>div</B> 10;
+ j := column <B>mod</B> 10;
+ e := chr(48+i);
+ f := chr(48+j);
+ write( chr(27), "[", c, d, ";", e, f, "H")
+ <B>end</B> SetCursor;
+<B>end</B> ANSI;
+
+
+ <B>unit</B> monitor: process(node:integer, size:integer,e: ekran);
+
+ <B>var</B> buf: <B>arrayof</B> integer,
+ nr,i,j,k1,k2,n1,n2: integer;
+
+
+ <B>unit</B> lire: <B>procedure</B>(<B>output</B> k: integer);
+ <B>begin</B>
+ <B>call</B> e.druk(13,2+nr*30+k1,0,k2);
+ <B>call</B> e.druk(13,2+nr*30+(i-1)*6,1,buf(i));
+ k1:=(i-1)*6;
+ k:=buf(i);
+ k2:=k;
+ i:= (i <B>mod</B> size)+1;
+ <B>if</B> i=j
+ <B>then</B>
+ <B>call</B> e.printtext("i equal j")
+ <B>fi</B>;
+ <B>end</B> lire;
+
+ <B>unit</B> ecrire: <B>procedure</B>(n:integer);
+ <B>begin</B>
+ <B>call</B> e.druk(13,2+nr*30+n1,0,n2);
+ <B>call</B> e.druk(13,2+nr*30+(j-1)*6,2,n);
+ n1:=(j-1)*6;
+ buf(j) := n;
+ n2:=buf(j);
+ j := (j <B>mod</B> size)+1;
+ <B>if</B> i=j
+ <B>then</B>
+ <B>call</B> e.printtext("j equal i")
+ <B>fi</B>;
+ <B>end</B> ecrire;
+ <B>begin</B>
+ <B>array</B> buf <B>dim</B>(1:size);
+ nr := size - 4;
+ <B>for</B> i := 1 to size
+ <B>do</B>
+ buf(i) := i+nr*4;
+ <B>call</B> e.druk(13,2+nr*30+(i-1)*6,0,buf(i));
+ <B>od</B>;
+ i:=1;
+ j := size;
+ k1:=0;
+ k2:=buf(1);
+ n1:=(size-1)*6;
+ n2:=buf(size);
+ (* <B>end</B> initialize buffer *)
+ <B>return</B>;
+
+ <B>do</B>
+ <B>accept</B> lire, ecrire
+ <B>od</B>
+ <B>end</B> monitor;
+
+ <B>unit</B> prcs: process(node,nr:integer, mleft,mright:
+ monitor, e: ekran);
+ <B>var</B> l,o: integer;
+
+ <B>begin</B>
+ <B>call</B> e.SetCursor(8+(nr-1)*10,29);
+ <B>if</B> nr = 1
+ <B>then</B>
+ <B>call</B> e.printtext("<-- p1 <--");
+ <B>else</B>
+ <B>call</B> e.printtext("--> p2 -->");
+ <B>fi</B>;
+ <B>return</B>;
+ <B>do</B>
+ <B>call</B> mleft.lire(l) ;
+ <B>call</B> e.druk(11+(nr-1)*4,31-(nr-1)*8,1,l);
+ l:= l+1;
+ <B>call</B> mright.ecrire(l) ;
+ <B>call</B> e.druk(10+(nr-1)*6,23+(nr-1)*8,2,l);
+ <B>if</B> l <B>mod</B> 15 = 0
+ <B>then</B>
+ o:= e.inchar;
+ <B>if</B> o = -79 <B>then</B> <B>call</B> <B>endrun</B> <B>fi</B>;
+ <B>fi</B>;
+ <B>od</B>;
+ <B>end</B> prcs;
+
+<B>unit</B> ekran : ANSI process(nrprocesora: integer);
+ <B>unit</B> printtext: <B>procedure</B>(s:string);
+ <B>begin</B>
+ write(s);
+ <B>call</B> Normal;
+ <B>end</B> printtext;
+
+ <B>unit</B> druk: <B>procedure</B>(gdzieW,gdzieK,jak,co:integer);
+ <B>begin</B>
+ <B>call</B> SetCursor(gdzieW,gdzieK);
+ write(" ");
+ <B>if</B> jak=0 <B>then</B> <B>call</B> Normal <B>else</B>
+ <B>if</B> jak=1 <B>then</B> <B>call</B> Reverse <B>else</B>
+ <B>if</B> jak=2 <B>then</B> <B>call</B> Bold
+ <B>fi</B>
+ <B>fi</B>
+ <B>fi</B>;
+ write(co:3);
+ <B>call</B> Normal;
+ <B>end</B> druk;
+
+ <B>unit</B> print: <B>procedure</B> (i:integer);
+ <B>begin</B>
+ write(i:4)
+ <B>end</B> print;
+ <B>begin</B>
+ <B>return</B>;
+
+ <B>do</B> <B>accept</B> inchar,
+ Normal,NewPage, SetCursor, Bold, Underscore,
+ Reverse, Blink, print, printtext, druk
+ <B>od</B>
+ <B>end</B> ekran;
+
+<B>var</B> m1,m2:monitor,
+ e:ekran,
+ p1,p2:prcs;
+
+<B>begin</B> (* ----- HERE IS THE MAIN PROGRAM ----- *)
+ (* create a configuration *)
+ e:= <B>new</B> ekran(0);
+ <B>resume</B>(e);
+ <B>call</B> e.Normal;
+ <B>call</B> e.NewPage;
+ m1 := <B>new</B> monitor(0,4,e);
+ m2 := <B>new</B> monitor(0,5,e);
+
+ p1 := <B>new</B> prcs(0,1,m2,m1,e);
+ p2 := <B>new</B> prcs(0,2,m1,m2,e);
+
+ <B>resume</B>(m1);
+ <B>resume</B>(m2);
+ <B>resume</B>(p1);
+ <B>resume</B>(p2);
+<B>end</B> monitors;
+</PRE>
\ No newline at end of file
--- /dev/null
+<html>\r
+\r
+<head>\r
+<title> Algorithmic Logic: its home page</title>\r
+</head>\r
+\r
+<body>\r
+<H1> Algorithmic Logic </H1>\r
+<h6> its home page </h6>\r
+\r
+<h4>Table of contents</h4>\r
+<ol>\r
+<li><a href="#def">Definition <em> per genus proximus et differentia specifica</em></a>\r
+<li><a href="#goal">Goals of AL</a>\r
+<li><a href="#struc">Structure of AL</a>\r
+<li><a href="#appli">Applications</a>\r
+ <dir>\r
+ <li>specifications of algorithms, data structures and programming languages\r
+\r
+\r
+ \r
+ <li>analysis of properties of programs (<em>verification</em>)\r
+\r
+ <li>axiomatic definition of programming languages\r
+\r
+ </dir>\r
+<li><a href="copyrigh.htm">Copyrights </a>\r
+<li><a href="biblio.htm">Readings</A>\r
+\r
+<li><a href="#new">What's new in AL?</a>\r
+<li><a href="projects.htm">Invitation to projects </A>\r
+ <dir>\r
+ <li>the assistant in proving, more precisely ...\r
+ <li>an axiomatic specification of the Loglan'95 programming language...\r
+ </dir>\r
+\r
+</ol>\r
+<hr><br><br><br>\r
+<ol>\r
+<p><li><h6><a name="def">Definitions</h6></a> \r
+<DL>\r
+ <DT><em>algorithmic logics</em></dt>\r
+ <DD> are a kind of logics of programs, their components are:\r
+ a formalized algorithmic language and \r
+ a consequence operation defined by means of logical axioms and inference rules. \r
+ </DD>\r
+<p>\r
+ <dt><em>logics of programs</em> </dt>\r
+ <dd>is a family of logics, the language of a logic of programs admits \r
+ programs as modalities. <br>\r
+ Examples: <ul>\r
+ <li>calculus of Floyd (descriptions of flowdiagrams)[1967], <li>calculus (Hoare) of partial correctness formulas [1969],\r
+ <li>algorithmic logic [1969-1994], <li>calculus of weakest preconditions (Dijkstra)[1974], <li>dynamic logic [1976], etc. \r
+ </ul>\r
+ </dd>\r
+<p>\r
+ <dt><em>an algorithmic language</em> </dt>\r
+ <dd>\r
+ is the smallest language which contains both the set of programs and the set of first order formulas and which is closed under the formation rule:<br>\r
+if P is a program and f is a formula then the expression Pf is an algorithmic formula. The set of algorithmic formulas admits the usual formation rules: disjunction, conjunction, negation, implication, quantification. \r
+ </dd>\r
+\r
+</dl>\r
+\r
+<li><p>\r
+<h6><a name="goal">Goals of AL</A></h6>\r
+- the study of semantic properties of computer programs. The role of AL \r
+in computer science is similar to that of mathematical logic in mathematics.\r
+AL studies those properties of programs whih are valid by virtue of their\r
+syntactical structure, independently of any interpretation of functional and\r
+relational symbols in programs. This leads to the discovery of algorithmic \r
+tautologies and inference rules, thus enabling algorithmic reasoning.\r
+Various programming constructs, one may say, various programming languages\r
+lead to various logics. In one logic you can discuss the properties of \r
+deterministic iterative programs, in another one may analyse the properties \r
+of concurrent(hence non-deterministic) programs, in yet another ...\r
+The theories based on AL are of interest for the study of abstract data types.\r
+For example, an algorithmic theory of stacks is the theory determined by its \r
+algorithmic language and the set specific axioms, <br>\r
+\r
+<p>\r
+<li><h6><a name="struc">Structure of AL</A></h6>\r
+<em> A recipe</EM>:\r
+Take one programming language Lp and its semantics. Consider the \r
+semantical phenomena of the executions of programs (like termination, \r
+correctness, partial correctness, equivalence etc.). Add a first-order \r
+language L1. Mix well, you will obtain an algorithmic language La. \r
+Remark its capability to express the semantical properties of programs \r
+(mentioned earlier).\r
+What you need now is a handful of axioms and inference rules. Be careful. \r
+Avoid inconsistency. Search for the completeness of your logic.\r
+Now, you are ready to serve formal proofs\r
+of semantical properties of programs and other theorems. \r
+\r
+<li>\r
+<h6><a name="appli">Applications</A></h6>\r
+<ul>\r
+<li>specification of algorithms, data structures and programming languages\r
+A program K is specified by a pair of formulae alpha and beta. The formula\r
+ of the form <br>\r
+alpha => K beta<br>\r
+is satisfied by a state of memory s iff either s does not satifies the \r
+precondition alpha, or if program K transforms the initial state s into a\r
+resulting state s' (i.e. no infinite loops, no fails either) and the state \r
+s' satisfies the post-condition beta.\r
+A set Z of formulae specifies a (family of) data structure(s) iff all formulas\r
+are valid in the data structure belonging to the family and no data structure\r
+outide the family satisfies all the formulae of the given set Z\r
+\r
+ \r
+<li>verification and more precisely analysis of properties of programs\r
+One does it by proving the formulas that express the properties f programs\r
+\r
+<li>axiomatic definition of programming languages\r
+In a paper we we proved that the meanings of programming operators such as\r
+assignment operator, composition of programs operator begin... end,\r
+condititional instruction operator if ... then ... else ... fi operator,\r
+iteration instruction operator while... do ... od are uniquely determined\r
+by he fact that they satisfy the tautologies of algorithmic logic and that\r
+they are conformant to the inference rules of AL.\r
+In other papers we show that the primitive data types of programming languages\r
+are axiomatizable and we study their algorihmic theories.\r
+</ul>\r
+<br>\r
+\r
+<li><h6><a href="copyrigh.htm">Copyrights </a></h6>\r
+\r
+<li>\r
+<h6>What to <a href="biblio.htm">read</a>?</h6>\r
+<br>\r
+\r
+<li><h6><a name="new"> What's new in AL?</A></h6>\r
+We would like to announce two results of 1994.<br>\r
+In spite of the <a href="#Tennenbaum">Tennenbaum's theorem</A>\r
+ <a name="powrot1"></a>it is possible to \r
+to construct a programmable and non-standard model for\r
+ the elementary theory of stacks.\r
+The same remark applies as well to other specifications.<br>\r
+\r
+<strong>Theorem 1</strong><br>\r
+Let <a href="#stacks">S</a> be<a name="powrot2"></a> the algebraic specification of stacks. There exists a programmed\r
+module Stacks which correctly implements all the axioms mentioned in the specification S,\r
+the module Stacks admits infinite popping of certain stacks.\r
+<br>WARNING. Be careful, it may be the case that a software module satisfies\r
+all axioms of a given first-order specification, yet it may be pathological\r
+one. The facts: a module fulfills the axioms and the module is programmable \r
+do not necessarily means that the module has any value.<br>\r
+\r
+<br><strong>Theorem 2</strong><br>\r
+Algorithmic theory of stacks of bounded capacity is the \r
+complement of a recursively enumerable set.\r
+<br> Intuitively speaking this result gives an assuring answer to the question\r
+<em> 'Can one do the research of properties of programs\r
+using the calculus of AL? The nature of AL seem so complicated. Perhaps it would be better \r
+to use another logic of programs.'</em><br>\r
+Quite unexpectedly the oponents of AL are confronted with \r
+two facts:<br>\r
+- the dynamic logic has finitistic inference rules and \r
+ the highly undecidable set of axioms,<br>\r
+- the algorithmic logic has a number of omega-rules,\r
+ but the set of theorems of algorithmic theories of\r
+ practical interest is relatively low in the hierarchy of Kleene-Mostowski.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+<li>\r
+<H6><a name="project">Two projects</A> </H6>\r
+<ul>\r
+<li>the assistant in proving, more precisely ...\r
+<li>an axiomatic specification of the Loglan'95 programming language...\r
+</ul>\r
+\r
+</ol>\r
+<hr>\r
+<h4>Explanations of notions used </h4><hr>\r
+<br>\r
+<a name="stacks">\r
+Algebraic specification of stacks:<Br>\r
+The universe is a union of two sets S- for stacks and E- for elements.<br>\r
+Operations and predicates:<br>\r
+push: E x S -> S<br>\r
+pop: S -> S <br>\r
+top: S -> E <br>\r
+empty: S -> {true, false} <br>\r
+Axioms:<br>\r
+<em>not</em> empty(push(e,s))<br>\r
+s = pop(push(e, s)) <br>\r
+e = top(push(e, s)) <br>\r
+<em>not</em> empty(s) => s = push(top(s), pop(s)) \r
+<a href="#powrot2">Back</a><br><br><hr>\r
+</a>\r
+<br>\r
+<a name="Tennenbaum">Tennenbaum's theorem<br>\r
+If M is a recursive(<em>i.e. programmable</em>) model of Peano's\r
+axioms of arithmetic of natural numbers then it is isomorphic to the\r
+standard model of natural numbers.<a href="#powrot1">Back</a>\r
+\r
+<hr>\r
+<address> <a href="../GMyAS.html">GM y AS</a> 10:07 01/01/1995 </address>\r
+</body>\r
+</html>\r
--- /dev/null
+
+<html>\r
+<head>\r
+<title>Loglan'82 - Availability</title>\r
+</head>\r
+\r
+<body>\r
+<H1><img src="loglanmm.gif">How to get a copy of Loglan'82</H1>\r
+\r
+Institute of Informatics, University of Warsaw and <br> \r
+<strong>LITA</strong> Universite de Pau<br>\r
+have the privilege and the pleasure to inform you that since August 1993 \r
+the programming language LOGLAN'82, its compilers and its environments are \r
+ accessible for the usage from<br>\r
+\r
+ <em>the server</em>: aragorn.pb.bialystok.pl = 193.59.9.226<br>\r
+ <em>user</em>: anonymous = ftp<br>\r
+ <em>Password</em>:{your internet mail address}<br>\r
+ <em>directory</em>: pub/loglan<br>\r
+</em>\r
+\r
+<em> FTP </em> with WWW <a href="ftp://aragorn.pb.bialystok.pl/loglan"> directly </a>. \r
+ \r
+Or use the following link to the\r
+<a href="http://aragorn.pb.bialystok.pl/~loglan"> Loglan82 archive </a> on \r
+the aragorn.pb.bialystok.pl<br>\r
+Our apologies for the eventual inconveniences, at present we do not dispose a better link/server.\r
+<p>\rHowever you can try a mirror located at
+ <A HREF="http://sunsite.icm.edu.pl/loglan/">sunsite.icm.edu.pl </A>
+We acknowledge the help of ICM. <br> There is also a French site at
+<A HREF="http://infpc1.univ-pau.fr"> LITA Universite de Pau </A>
+</b></em>\r
+</p> \r
+<hr>\r
+<p><pre> These programs are free software; you can redistribute it \r
+ and/or modify it under the terms of the GNU General Public License\r
+ as published by the Free Software Foundation; either version 2 of \r
+ the License, or (at your option) any later version.\r
+ \r
+ These programs are distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. \r
+ See the GNU General Public License for more details.<br></pre>\r
+<hr>\r
+<a href="solate.htm"><img src="prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="homepage.gif"> </a>\r
+ <a href="openpbms.htm"><img src="nextpage.gif"></a>\r
+ \r
+<hr>\r
+<address>\r
+<a href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </a> 11:12 01/12/1994\r
+</address>\r
+</body>\r
+</html>\r
+
+ppp
\ No newline at end of file
--- /dev/null
+
+<html>\r
+<head>\r
+<title>Loglan'82 - Availability</title>\r
+</head>\r
+\r
+<body>\r
+<H1><img src="Microman/gifs/logo2.gif">How to get a copy of Loglan'82</H1>\r
+\r
+Institute of Informatics, University of Warsaw and <br> \r
+<strong>LITA</strong> Universite de Pau<br>\r
+have the privilege and the pleasure to inform you that since August 1993 \r
+the programming language LOGLAN'82, its compilers and its environments are \r
+ accessible for the usage from<br>\r
+\r
+ <em>the server</em>: aragorn.pb.bialystok.pl = 193.59.9.226<br>\r
+ <em>user</em>: anonymous = ftp<br>\r
+ <em>Password</em>:{your internet mail address}<br>\r
+ <em>directory</em>: pub/loglan<br>\r
+</em>\r
+\r
+<em> FTP </em> with WWW <a href="ftp://aragorn.pb.bialystok.pl/loglan"> directly </a>. \r
+ \r
+Or use the following link to the\r
+<a href="http://aragorn.pb.bialystok.pl/~loglan"> Loglan82 archive </a> on \r
+the aragorn.pb.bialystok.pl<br>\r
+Our apologies for the eventual inconveniences, at present we do not dispose a better link/server.\r
+<p>\rHowever you can try a mirror located at
+ <A HREF="http://sunsite.icm.edu.pl/loglan/">sunsite.icm.edu.pl </A>
+We acknowledge the help of ICM. <br> There is also a French site at
+<A HREF="http://infpc1.univ-pau.fr"> LITA Universite de Pau </A>
+</b></em>\r
+</p> \r
+<hr>\r
+<p><pre> These programs are free software; you can redistribute it \r
+ and/or modify it under the terms of the GNU General Public License\r
+ as published by the Free Software Foundation; either version 2 of \r
+ the License, or (at your option) any later version.\r
+ \r
+ These programs are distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. \r
+ See the GNU General Public License for more details.<br></pre>\r
+<hr>\r
+<a href="solate.htm"><img src="MicroMan/gifs/prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="MicroMan/gifs/homepage.gif"> </a>\r
+ <a href="openpbms.htm"><img src="MicroMan/gifs/nextpage.gif"></a>\r
+ \r
+<hr>\r
+<address>\r
+<a href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </a> 11:12 01/12/1994\r
+</address>\r
+</body>\r
+</html>\r
+
+ppp
\ No newline at end of file
--- /dev/null
+<html>\r
+<HEAD><TITLE>Bibliography on Loglan'82</TITLE></HEAD>\r
+<BODY>\r
+<H1>BIBLIOGRAPHY </H1>\r
+<H6>Last update: November 24, 1994</H6>\r
+<P>\r
+\r
+Should you like to read on Loglan and its companion Algorithmic Logic, here it is, a short list of more important \r
+papers.<P>\r
+<H2>LOGLAN'82</H2>\r
+<UL>\r
+<LI>Bartol,W.M., et al.<BR>\r
+<EM>Report on the Loglan 82 programming Language,</EM><BR><EM>\r
+</EM>Warszawa-Lodz, PWN, 1984<P>\r
+\r
+<LI>A.Kreczmar<BR>\r
+<EM>A micro-manual of the programming language LOGLAN-82,</EM><BR>\r
+Institute of Informatics, University of Warsaw, 1984<P>\r
+(there exists a french translation of the above manual)\r
+(both texts are distributed together with this package)<P>\r
+\r
+<LI>A.Kreczmar, A.Salwicki, M. Warpechowski, <BR>\r
+<EM>Loglan'88 - Report on the Programming Language,</EM><P>\r
+Lecture Notes on Computer Science vol. 414, Springer Vlg, 1990,\r
+ISBN 3-540-52325-1<P>\r
+\r
+<LI> <STRONG>do you read polish? there exists a good manual of Loglan!</STRONG> <P>\r
+A.Szalas, J.Warpechowska,<BR>\r
+<EM>LOGLAN, </EM><BR><EM>\r
+</EM>Wydawnictwa Naukowo-Techniczne, Warszawa, 1991 ISBN 82-204-1295-1 <P>\r
+ \r
+\r
+<LI><H3>Some papers devoted to the problems and challenges of Loglan.</H3>\r
+<UL>\r
+\r
+<LI>Bartol,W.M., Kreczmar, A., Litwiniuk, A., Oktaba, H.,<P>\r
+<EM>Semantic and Implementation of Prefixing at Many Levels, </EM><P>\r
+in Lecture Notes in Computer Science vol.148, Springer Verlag, Berlin,\r
+1983, pp.45-80<P>\r
+\r
+<LI>Krause,M., Kreczmar, A., Langmaack, H., Salwicki,A.,\r
+<EM>Specification and Implementation Problems of Programming Languaages\r
+Proper for Hierarchical Data Types,</EM><P>\r
+Report 8410 of Institut fuer Informatik und Praktische Mathematik\r
+Christian-Albrechts-Universitaet Kiel, 1984, pp.1-68<P>\r
+\r
+<LI>Kreczmar,A., Salwicki,A.,<P>\r
+<EM>Concatenable Type Declarations, Their Application and Implementation</EM><P>\r
+in: Programming Languages and System Design, in Programming, Languages and System Design Proc. IFIP TC2 \r
+Conference (J.Bormann ed.) Dresden, 1983 \r
+North Holland, Amsterdam, 1983, pp.29-41<P>\r
+\r
+\r
+<LI>Cioni, G., Kreczmar, A.,\r
+<EM>Modules in high level programming languages</EM>\r
+in: Advanced Programming Methodologies (G.Cioni, A.Salwicki eds.)\r
+Academic Press, London, 1989, 247-340<P>\r
+\r
+<LI>Kreczmar, A.,<P>\r
+<EM>On inheritance Rule in Object Oriented Programming</EM>\r
+in: Advanced Programming Methodologies\r
+Academic Press, London, 1989, pp. 141-164\r
+\r
+<LI>Cioni,G., Kreczmar,A., Vitale, R.,<P>\r
+<EM>Storage Management</EM><P>\r
+in: Advanced Programming Methodologies\r
+Academic Press, London, 1989, pp.341-366\r
+\r
+\r
+<LI>Cioni, G., Kreczmar, A.,<P>\r
+<EM>Programmed deallocation without Dangling References,</EM><P>\r
+IPL, vol. 18 1984, pp. 179-185\r
+\r
+<LI>Krause, M., Kreczmar, A., Langmaack, H., Warpechowski, M.,<P>\r
+<EM>Concatenation of program modules, an Algebraic Approach to the Semantic and Implementation \r
+Problems,</EM><P>\r
+in: Proc. Computation Theory, LNCS 208, Springer Vlg, Berlin, 1986, pp. 134-156\r
+full text in: Report 8701 of Institut fuer Informatik und Praktische Mathematik\r
+Christian-Albrechts-Universitaet Kiel, 1987, pp.1-48<P>\r
+\r
+<LI>Krause, M.,<P>\r
+<EM>Die Korrektheit einer Implementation der Modulpraefigerung mit reiner Static Scope Semantik,</EM><P>\r
+Report 8616 of Institut fuer Informatik und Praktische Mathematik<P>\r
+Christian-Albrechts-Universitaet Kiel, 1986, pp.1-139<P>\r
+\r
+<LI>Langmaack, H.,<P>\r
+<EM>On static Semantic of Prefixing</EM> (=inheritance),<P>\r
+Talk delivered during the Summer School on Loglan'82, Zaborow, September 1983<P>\r
+\r
+</UL>\r
+\r
+<li><H3>Ph.D. theses (in polish!) related somehow to Loglan project.</H3>\r
+<P>\r
+<UL>\r
+<li>Szalas, A., <BR>\r
+<EM>On parallel processes, </EM>1984<P>\r
+\r
+<li>Gburzynski, P.,<P>\r
+<EM>GPR - theorem prover</EM> 1982<P>\r
+\r
+<li>Petermann, U.,<BR>\r
+<EM>On file system and signalling exceptions between processes</EM> 1987<P>\r
+\r
+<li>Oktaba, H.<P>\r
+<EM>On Formalisation of the Notion of Reference and its Applications in Theory of Data Structures</EM>, 1982<P>\r
+\r
+<li>Bartol, W.M., <P>\r
+<EM>Application of Static Structure of Type Declarations and the System of Dynamic Configurations in a Definition \r
+of Semantics of a Universal Programming Language</EM> 1981<P>\r
+\r
+<li>Szczepanska-Wasersztrum, D.,<P>\r
+<EM>A logical system for reasoning about exceptions</EM>,1990<P>\r
+\r
+<li>Litwiniuk, A.I.,<P>\r
+<EM>Several algorithms for optimisation of code in presence of nesting</EM>, 1988<P>\r
+\r
+<li>Jankowska-Puchalka B.<BR>\r
+<EM>A code genarator generator for an object oriented language</EM>, 1992<P>\r
+</UL>\r
+</UL>\r
+<H2>Algorithmic Logic</H2>\r
+<ul>\r
+<li>There is a monograph:<P>\r
+\r
+G.Mirkowska, A.Salwicki, <BR>\r
+<EM>Algorithmic Logic</EM>, <BR>\r
+D.Reidel & Polish Scientific Publ., Dordrecht & Warszawa, 1987, ISBN 83-01-06859-0<P>\r
+ the book contains a chapter devoted to certain problems of Loglan.<P>\r
+\r
+<li>A new book on AL appeared in polish<BR>\r
+G.Mirkowska, A.Salwicki, <BR>\r
+<EM>Logika algorytmiczna dla programistow,</EM><BR><EM>\r
+</EM>Wydawnictwa Naukowo-Techniczne, Warszawa, 1993 (ISBN 83-204-1296-X). <P>\r
+An english version in preparation.<P>\r
+\r
+\r
+<li><H3>There are many papers discussing the applications of AL in programming.</H3>\r
+<P>\r
+<ul>\r
+<li>Salwicki, A.,<P>\r
+<EM>Development of Software from Algorithmic Specifications</EM><P>\r
+in: Advanced Programming Methodologies\r
+Academic Press, London, 1989, pp.1-40<P>\r
+\r
+<li>Salwicki, A.,<P>\r
+<EM>On algorithmic theory of Stacks,</EM><P>\r
+in Proc. MFCS'78 (J.Winnkowski ed.), LNCS 63, Springer Berlin 1978, pp.<P>\r
+\r
+<li>Salwicki, A.,<P>\r
+<EM>On algorithmic theory of dictionaries,</EM><P>\r
+Proc. Logic of Programs (E.Engeler ed.), LNCS 125, Springer, Berlin 1981 pp.145-168<P>\r
+\r
+<li>Müldner, T., Salwicki, A.,<P>\r
+<EM>On algorithmic Properties of Concurrent Programs,</EM><P>\r
+in: Proc. Logic of Programs (E.Engeler ed.), LNCS 125, Springer, Berlin 1981 pp.170-193<P>\r
+\r
+<li>Mirkowska,G., Salwicki, A.,<P>\r
+<EM>On applications of Algorithmic Logic,</EM><P>\r
+in: Proc. CAAP'86 (P. Franchi-Zanetacci ed.) Springer, 1986 pp.288-306<P>\r
+\r
+<li>Mirkowska,G., Salwicki, A.,<P>\r
+<EM>Axiomatic definability of programming language semantics,</EM><P>\r
+in: Proc. IFIP Working Conf on Formal Description of Programming Concepts\r
+Ebberup 1986 (M. Wirsing ed.)\r
+North Holland, Amsterdam, 1986, pp1-15<P>\r
+\r
+<li>Mirkowska,G., Salwicki, A.,<P>\r
+<EM>On Axiomatic Definition of Max-model of concurrency,</EM><P>\r
+in Proc. Advanced School on Mathematical Models of Parallelism Rome 1986\r
+(M. Venturini-Zilli ed.) LNCS Springer Berlin<P>\r
+\r
+<li>Salwicki, A.,<P>\r
+<EM>Algorithmic Theories of Data Structures,</EM><P>\r
+in Proc. ICALP'82 (M.Nilsen, E.Schmidt eds.) LNCS 140 Springer, Berlin, 1982, pp. 458-472\r
+</UL>\r
+</ul>\r
+\r
+\r
+<H2>Related literature </H2>\r
+<ul>\r
+<li><H3>on object programming</H3>\r
+ is immense<P>\r
+\r
+<I>Let us quote a few books:</I><P>\r
+<ul>\r
+<li>E. Horowitz, <BR>\r
+<EM>Fundamentals of Programming Languages, </EM><BR><EM>\r
+</EM>Springer, New York, 1983<P>\r
+\r
+\r
+<li>O.-J. Dahl, B. Myhrhaug, K. Nygaard, <BR>\r
+<EM>Simula 67 Common Base Language, </EM><BR><EM>\r
+</EM>Norwegian Computing Center, Oslo, 1970 <BR> the mother of object languages!!<P>\r
+\r
+<li>B. Meyer,<BR>\r
+<EM>Object-oriented software construction,</EM><BR><EM>\r
+</EM>Prentice Hall, 1988<P>\r
+\r
+<li>B. Stroustrup <BR>\r
+<EM>The C++ Programming Language, </EM><BR><EM>\r
+</EM>Addison-Wesley, Reading, Mass., 1991<P>\r
+</UL>\r
+<li><H3>on logics of programs:</H3>\r
+<P>\r
+\r
+<I>see a survey</I><P>\r
+<ul>\r
+<li>D. Kozen, J. Tiuryn<BR>\r
+Logics of Programs,<BR>\r
+in: Handbook of Theoretical Computer Science, vol.B, Formal Models and Semantics\r
+Elsevier, Amsterdam, 1990, pp. 789-998<P>\r
+</UL>\r
+</UL>\r
+<HR>\r
+<A HREF = "hmm?">up</A>\r
+<HR>\r
+<ADDRESS><A HREF = "http://www.univ-pau.fr/~salwicki/GMyAS.html">GMyAS</A> \r
+Last update Wed 10 May 1995</ADDRESS>\r
+\r
+</BODY>\r
+</html>\r
+\r
+\r
+\r
--- /dev/null
+<html>
+<head>
+<TITLE>Loglan'82 Biuletyn nr 2</TITLE>
+
+
+</head>
+<body>
+<h4>Instytut Informatyki Politechniki Bia³ostockiej z
+przyjemno\9cci¹ zawiadamia, ¿e od
+pewnego czasu dzia³a w sieci Internetu\r </h4>
+
+\r
+<TABLE BORDER="border" ALIGN=center>
+<tr><th colspan=2><EM> repozytorium jêzyka pogramowania obiektowego </EM> </th></tr>
+ <tr>
+<td><IMG ALIGN=TOP SRC = "MicroMan/gifs/logo2.gif" > </td>
+<td><STRONG> Loglan'82 </STRONG> </td></tr>
+</table> \r
+\r
+<tr>
+<td colspan=2>
+ <H2> <STRONG> Co? </STRONG> </h2>
+ <H3> Loglan'82 jest jêzykiem programowania obiektowego,
+wspó³bie¿nego, rozproszonego o niepowtarzalnych walorach. </H3>
+\r
+ <P>
+Udostêpniamy: \r
+<UL>
+<LI>kompilatory+interpretatory Loglanu na rózne platformy, w tym sieciowe,\r
+<li>dokumentacjê,\r
+<li>zbiór przyk³adów,\r
+<li>edytory:
+LOTEK i edytor strukturalny (tylko dla \9crodowiska DOS),\r
+\8f<li>ZRÓD£A!\r
+\r</ul>
+</td>
+</tr>
+<tr>
+<TD VALIGN=top> <H2> <STRONG> Gdzie? </STRONG> </H2>
+ \r
+ <P>
+http://aragorn.pb.bialystok.pl
+ <P>
+lub\r
+ <P>
+ftp://aragorn.pb.bialystok.pl/pub/loglan \r
+ <P>
+i jego lustrzane odbicia (znacznie szybciej osi¹galne w sieci)\r
+ <P>
+ http://sunsite.icm.edu.pl/loglan/ \r
+ <P>
+ ftp://sunsite/icm.edu.pl/pub/loglan/ \r
+\r
+ <P>
+ http://infpc1.univ-pau.fr/ \r
+ <P>
+ftp://infpc1.univ-pau.fr/pub/loglan82
+</td>
+<TD VALIGN=top>
+ <H2> <STRONG> Jak? </STRONG> </H2>
+
+ <P>
+dla WWW: Mosaic, Netscape, Lynx, ...
+ <P>
+dla anonymous FTP
+ <P>
+ <P>
+ Dziekujemy prof. Markowi Niezgodce
+ <P>
+i p. Wojtkowi Sylwestrzakowi z ICM
+ <P> ten server dziala od 1993
+
+</td>
+</tr>
+<tr>
+<td colspan=2>
+ <H1> Zachecamy do (bezplatnego!) korzystania z naszej bazy wiedzy. </H1>
+
+</td>
+</tr>
+<tr>
+<td colspan=2>
+ <H2> Dlaczego? </H2> <P>
+
+
+</td>
+
+</tr>
+<TR><TD>Uczelnie, jednostki badawcze, pracownicy uczelni i studenci, firmy softwareowe, etc. mog¹ wykorzystywaæ Loglan jako jêzyk programowania obiektowego:\r
+\r
+<UL>
+<LI>W dydaktyce programowania pocz¹tkowego, algorytmów i struktur danych, programowania obiektowego, programowania wspó³bie¿nego i rozproszonego, itd.\r
+<LI>W szybkim tworzeniu prototypów du¿ych, skomplikowanych aplikacji.\r
+<LI>W badaniach: jako narzêdzie badawcze, a tak¿e jako bogate \9fród³o ciekawych i wa¿nych problemów badawczych (http://aragorn.pb.bialystok.pl/loglan/openpbms.html).\r
+\r</UL>
+
+
+<P>
+Loglan nie jest gorszy od innych jêzyków programowania obiektowego (por. http://aragorn.pb.bialystok.pl/loglan/tablica3.html )\r
+Stosowanie Loglanu pozwola wyposa¿yæ uczelnie, pracowników, studentów itd. w licencjonowane oprogramowanie, bez ¿adnych kosztów! Co wiêcej, stwarza do\9cæ rzadk¹ okazjê rozdawania studentom legalnie i za darmo oprogramowania wspieraj¹cego proces dydaktyczny. Nauczyciele i s³uchacze bêd¹ mogli wymieniaæ siê \9fród³ami programów loglanowskich i uzyskaj¹ te same wyniki bowiem Loglan jest niezale¿ny od platformy i dzia³a tak samo w DOSie, Unixie, Atari ST (my\9climy te¿ o platformach MacIntosh i Amiga), w sieciach rozleg³ych Internet i lokalnych Novell.\r
+\r
+
+<P>
+Jezyk oferuje niezwykle bogaty zestaw narzêdzi programowania obiektowego, ³¹cznie z obiektami-procesami rozproszonymi w sieci komputerowej. . Procesy komunikuj¹ siê w sposób ca³kowicie obiektowy: dwa procesy wspólnie realizuj¹ jak¹\9c metodê jednego z dwu procesów wg pewnego protoko³u, jest to obce wywo³anie inaczej alien call zaproponowany i zrealizowany przez B. Ciesielskiego w r.1988. Wszystkie znane mechanizmy synchronizacji i komunikacji procesów sprowadzaj¹ siê do mechanizmu alien call w prosty i tani sposób.\r
+<H3>UWAGA</H3>
+.\r
+Ostatnio reklamuja siê jêzyki przyblizaj¹ce siê do wysokiego standardu rozwi¹zañ opracowanych dla Loglanu. Mo¿emy jednak przewidywac, ¿e w bie¿¹cym stuleciu nie pojawi siê nowy istotnie lepszy od Loglanu jêzyk programowania obiektowego. Zalety naszych rozwiazañ zostan¹ nale¿ycie docenione w odleg³ej jeszcze przysz³o\9cci, gdy jaka\9c bogata firma zechce promowaæ "swoje" odkrycie. Rozwi¹zania Loglanu wspieraj¹ siê wynikami badañ przeprowadzonych przez zespó³ profesorów A. Kreczmara, A. Salwickiego. (por. credits.html) Czy mo¿na oczekiwaæ ¿e jaka\9c, nawet bogata, firma zainwestuje w potrzebne badania?\r
+<H3>KONIEC UWAGI.</H3>
+\r
+
+<P>
+Programowanie w Loglanie jest znacznie ³atwiejsze ni¿ w innych jêzykach programowania obiektowego (por http://aragorn.pb.bialystok.pl/loglan/quick.htm). \r
+\r
+
+<P>
+Programowanie w Loglanie jest o wiele bezpieczniejsze ni¿ w innych jêzykach programowania:\r
+kompilator wykrywa wiele b³êdów (tak¿e tych nie dostrzeganych przez inne kompilatory), i opisuje nature i miejsce b³êdów,\r
+wiele b³êdów jest wykrywanych i sygnalizowanych w trakcie wykonywania programu (b³êdy takie s¹ lokalizowane w tekscie programu \9fród³owego i czytelnie opisane),\r
+zarz¹dzanie zasobami pamiêciowymi jest bezpieczne i mocne,\r
+np. programista nie musi siê obawiaæ gro\9fby trudnego do wykrycia b³êdu "wisz¹cych referencji":\r
+
+<HR>
+
+<P>
+<H3>PRZYKLAD (w Pascalu lub C++)</H3>
+\r
+<BR>Niech x, y, z bêd¹ zmiennymi wskazuj¹cymi na rekord lub obiekt typu T.\r
+<BR>Po wykonaniu instrukcji dispose(y) lub odp. free(y) warto\9cci¹ zmiennej y jest wska\9fnik nil do pustego obiektu. Wska\9fniki x i z nadal pokazuj¹ na pole pamiêci zajmowane przez nieistniej¹cy ju¿ obiekt. Po wykonaniu instukcji new lub malloc to samo pole mo¿e byæ wskazywane przez zmienn¹ u jako obiekt typu T'. \r
+<BR>Porównaj to z aksjomatem Loglanu\r
+ {(x<>none&y=x&z=x) ( [kill(y)](x=y=z=none)}\r
+<BR>Jego sens jest oczywisty. Warto nadmieniæ, ¿e 1° koszt tej dealokacji obiektu x nie zale¿y od liczby wska\9fników do obiektu, nie musisz o tym mysleæ 2° system sygnalizuje wszelkie próby dostêpu do informacji w obiekcie, który (ju¿/jeszcze) nie istnieje.\r
+ponadto programista mo¿e sam zaprojektowaæ reakcjê na b³êdy i na sygna³y podnoszone przez program w trakcie jego realizacji.\r
+\r
+</table> \r
+\r
+\r
+\r
+\r
+
+<HR>
+
+<H1>NIE PRZEGAP!</H1>
+\r
+<OL>
+<LI>Porównaj sam, Loglan i inne jêzyki programowania i wyrób sobie swój w³asny pogl¹d w tej sprawie,\r
+<LI>Policz: jedna licencja na kompilator jêzyka pretenduj¹cego do miana obiektowo\9cci to XXX z³ razy ilo\9cæ stanowisk pracy w twej uczelni i u studentów. Ile to by kosztowa³o?\r
+<LI>Zauwa¿! w jednym jêzyku programowania oferujemy Ci komplet narzêdzi:\r
+klasy i obiekty, wspó³programy, procesy, dziedziczenie i zagnie¿dzanie modu³ów, ochronê atrybutów prywatnych obiektów wg ¿yczenia twórcy klasy, deklaracje sygna³ów i obs³ugê przerwañ i sygna³ów, wiele sposobów na tworzenie modu³ów generycznych - sparametryzowanych typem danych, dziedziczenie ne tylko w klasach ale w ka¿dym rodzaju modu³u: funkcji, procedurze, bloku, zspó³programie, procesie .\r
+<LI>Uwierz nam! jêzyki o podobnych w³asno\9cciach zostan¹ odkryte w Ameryce dopiero za parê lat. Chcesz czekaæ?\r
+<LI>Zrób sobie wieloprocesorow¹, sieciow¹, virtualn¹ maszynê Loglanowsk¹! (Tanio! oto jedna z recept: we\9f tyle PC ile zdo³asz, po³¹cz je w sieæ lokaln¹, zainstaluj Loglan. )\r
+<LI>Zarób na Loglanie! Mo¿esz go sprzedawaæ, nie mamy nic przeciw temu i nie ¿¹damy niczego od Ciebie. Musisz tylko zachowaæ informacjê o prawach autorskich w sprzedawanych przez Ciebie kopiach. Tak jak to siê dzieje (lub jak powinno siê dziaæ) w przypadku TEXa, Linuxa, produktów GNU, etc. \r
+</OL>
+\r
+<HR>
+
+
+<P>
+Przekonaj siê lub znajd\9f s³aby punkt w naszej argumentacji.
+Napisz nam o Twoich zastrze¿eniach <A HREF="mailto:salwicki@aragorn.pb.bialystok.pl" METHODS="mailto">mailto:salwicki@aragorn.pb.bialystok.pl</A>\r
+
+<P>
+Nie przejd\9f obojêtnie wobec naszej oferty bo byæ mo¿e przegapisz co\9c co ma dla Ciebie znaczenie. Je\9cli masz j¹ odrzuciæ to zrób to \9cwiadomie, na podstawie rzeczowych przes³anek. (Napisz nam o Twych zastrze¿eniach.)\r
+\r
+
+<P>
+Czy argument "to siê nie przyjmie" ma tu istotne znaczenie? \r
+a) je\9cli prowadzisz zajêcia dydaktyczne lub jestes ich s³uchaczem: to zauwa¿, ¿e ¿aden inny\r
+jêzyk programowania nie dostarczy Ci tak w³a\9cciwej podstawy do studiowania zjawisk zwi¹zanych z obiektami. Np. temat "modu³y generyczne" w jêzyku C++ sprowadza siê do szablonów (ang. template). W Loglanie znamy kilkana\9ccie ró¿nych rowi¹zañ tego problemu. A same szablony maj¹ wiêcej wad ni¿ tego mo¿na by oczekiwaæ. \r
+Po Loglanie mo¿na nauczaæ jakiegokolwiek jêzyka programowania znacznie szybciej i wydajniej. Wystarcz¹ 2 popo³udnia by nauczyæ C++, Smalltalka lub innego jêzyka z obiektami. (A w³a\9cciwie dlaczego naucza siê Pascala a nie Loglanu?) \r
+b) je\9cli tworzysz swoje w³asne oprogramowanie i ma ono byæ w³¹czone w wiêkszy system ju¿ istniej¹cych modu³ów to pozostañ przy wybranym jêzyku progamowania. Rozwa¿ jednak mo¿liwo\9cæ napisania najpierw prototypu Twego oprogramowania w Loglanie i sprawdzenia jego zgodno\9cci ze specyfikacj¹ (poprzez walidacjê lub weryfikacjê) a potem przekodowania do C czy C++1. Prototyp powinien powstaæ trzy razy szybciej. \r\r\rWspomnieæ o nowo\9cci: sieæ maszyn DOSowych mo¿e realizowaæ maszynê wieloprocesorow¹\r
+\r
+<HR>
+<EM>Notatki</EM><BR>
+Wspomnieæ o tym, ¿e chocia¿ Loglan jest "samoróbk¹" uczelnian¹ to i tak mo¿e byæ u¿ywany przez wielu, w odró¿nieniu od samochodu.\r
+\r
+\r
+\r<BR>
+1 Wspomnijmy tu o eksperymentalnym programie L2C t³umacz¹cym z Loglanu na C jaki powsta³ parê lat temu na Uniwersytecie \8cl¹skim.\r\r
+
+</body>
+</html>
--- /dev/null
+<html>
+<head>
+<TITLE>Loglan'82 Biuletyn nr 2</TITLE>
+
+
+</head>
+<body>
+<h4>Instytut Informatyki Politechniki Bia³ostockiej z
+przyjemno\9cci¹ zawiadamia, ¿e od
+pewnego czasu dzia³a w sieci Internetu\r </h4>
+
+\r
+<TABLE BORDER="border" ALIGN=center>
+<tr><th colspan=2><EM> repozytorium jêzyka pogramowania obiektowego </EM> </th></tr>
+ <tr>
+<td><IMG ALIGN=TOP SRC = "MicroMan/gifs/logo2.gif" > </td>
+<td><STRONG> Loglan'82 </STRONG> </td></tr>
+</table> \r
+\r
+<tr>
+<td colspan=2>
+ <H2> <STRONG> Co? </STRONG> </h2>
+ <H3> Loglan'82 jest jêzykiem programowania obiektowego,
+wspó³bie¿nego, rozproszonego o niepowtarzalnych walorach. </H3>
+\r
+ <P>
+Udostêpniamy: \r
+<UL>
+<LI>kompilatory+interpretatory Loglanu na rózne platformy, w tym sieciowe,\r
+<li>dokumentacjê,\r
+<li>zbiór przyk³adów,\r
+<li>edytory:
+LOTEK i edytor strukturalny (tylko dla \9crodowiska DOS),\r
+\8f<li>ZRÓD£A!\r
+\r</ul>
+</td>
+</tr>
+<tr>
+<TD VALIGN=top> <H2> <STRONG> Gdzie? </STRONG> </H2>
+ \r
+ <P>
+http://aragorn.pb.bialystok.pl
+ <P>
+lub\r
+ <P>
+ftp://aragorn.pb.bialystok.pl/pub/loglan \r
+ <P>
+i jego lustrzane odbicia (znacznie szybciej osi¹galne w sieci)\r
+ <P>
+ http://sunsite.icm.edu.pl/loglan/ \r
+ <P>
+ ftp://sunsite/icm.edu.pl/pub/loglan/ \r
+\r
+ <P>
+ http://infpc1.univ-pau.fr/ \r
+ <P>
+ftp://infpc1.univ-pau.fr/pub/loglan82
+</td>
+<TD VALIGN=top>
+ <H2> <STRONG> Jak? </STRONG> </H2>
+
+ <P>
+dla WWW: Mosaic, Netscape, Lynx, ...
+ <P>
+dla anonymous FTP
+ <P>
+ <P>
+ Dziekujemy prof. Markowi Niezgodce
+ <P>
+i p. Wojtkowi Sylwestrzakowi z ICM
+ <P> ten server dziala od 1993
+
+</td>
+</tr>
+<tr>
+<td colspan=2>
+ <H1> Zachecamy do (bezplatnego!) korzystania z naszej bazy wiedzy. </H1>
+
+</td>
+</tr>
+<tr>
+<td colspan=2>
+ <H2> Dlaczego? </H2> <P>
+
+
+</td>
+
+</tr>
+<TR><TD>Uczelnie, jednostki badawcze, pracownicy uczelni i studenci, firmy softwareowe, etc. mog¹ wykorzystywaæ Loglan jako jêzyk programowania obiektowego:\r
+\r
+<UL>
+<LI>W dydaktyce programowania pocz¹tkowego, algorytmów i struktur danych, programowania obiektowego, programowania wspó³bie¿nego i rozproszonego, itd.\r
+<LI>W szybkim tworzeniu prototypów du¿ych, skomplikowanych aplikacji.\r
+<LI>W badaniach: jako narzêdzie badawcze, a tak¿e jako bogate \9fród³o ciekawych i wa¿nych problemów badawczych (http://aragorn.pb.bialystok.pl/loglan/openpbms.html).\r
+\r</UL>
+
+
+<P>
+Loglan nie jest gorszy od innych jêzyków programowania obiektowego (por. http://aragorn.pb.bialystok.pl/loglan/tablica3.html )\r
+Stosowanie Loglanu pozwola wyposa¿yæ uczelnie, pracowników, studentów itd. w licencjonowane oprogramowanie, bez ¿adnych kosztów! Co wiêcej, stwarza do\9cæ rzadk¹ okazjê rozdawania studentom legalnie i za darmo oprogramowania wspieraj¹cego proces dydaktyczny. Nauczyciele i s³uchacze bêd¹ mogli wymieniaæ siê \9fród³ami programów loglanowskich i uzyskaj¹ te same wyniki bowiem Loglan jest niezale¿ny od platformy i dzia³a tak samo w DOSie, Unixie, Atari ST (my\9climy te¿ o platformach MacIntosh i Amiga), w sieciach rozleg³ych Internet i lokalnych Novell.\r
+\r
+
+<P>
+Jezyk oferuje niezwykle bogaty zestaw narzêdzi programowania obiektowego, ³¹cznie z obiektami-procesami rozproszonymi w sieci komputerowej. . Procesy komunikuj¹ siê w sposób ca³kowicie obiektowy: dwa procesy wspólnie realizuj¹ jak¹\9c metodê jednego z dwu procesów wg pewnego protoko³u, jest to obce wywo³anie inaczej alien call zaproponowany i zrealizowany przez B. Ciesielskiego w r.1988. Wszystkie znane mechanizmy synchronizacji i komunikacji procesów sprowadzaj¹ siê do mechanizmu alien call w prosty i tani sposób.\r
+<H3>UWAGA</H3>
+.\r
+Ostatnio reklamuja siê jêzyki przyblizaj¹ce siê do wysokiego standardu rozwi¹zañ opracowanych dla Loglanu. Mo¿emy jednak przewidywac, ¿e w bie¿¹cym stuleciu nie pojawi siê nowy istotnie lepszy od Loglanu jêzyk programowania obiektowego. Zalety naszych rozwiazañ zostan¹ nale¿ycie docenione w odleg³ej jeszcze przysz³o\9cci, gdy jaka\9c bogata firma zechce promowaæ "swoje" odkrycie. Rozwi¹zania Loglanu wspieraj¹ siê wynikami badañ przeprowadzonych przez zespó³ profesorów A. Kreczmara, A. Salwickiego. (por. credits.html) Czy mo¿na oczekiwaæ ¿e jaka\9c, nawet bogata, firma zainwestuje w potrzebne badania?\r
+<H3>KONIEC UWAGI.</H3>
+\r
+
+<P>
+Programowanie w Loglanie jest znacznie ³atwiejsze ni¿ w innych jêzykach programowania obiektowego (por http://aragorn.pb.bialystok.pl/loglan/quick.htm). \r
+\r
+
+<P>
+Programowanie w Loglanie jest o wiele bezpieczniejsze ni¿ w innych jêzykach programowania:\r
+kompilator wykrywa wiele b³êdów (tak¿e tych nie dostrzeganych przez inne kompilatory), i opisuje nature i miejsce b³êdów,\r
+wiele b³êdów jest wykrywanych i sygnalizowanych w trakcie wykonywania programu (b³êdy takie s¹ lokalizowane w tekscie programu \9fród³owego i czytelnie opisane),\r
+zarz¹dzanie zasobami pamiêciowymi jest bezpieczne i mocne,\r
+np. programista nie musi siê obawiaæ gro\9fby trudnego do wykrycia b³êdu "wisz¹cych referencji":\r
+
+<HR>
+
+<P>
+<H3>PRZYKLAD (w Pascalu lub C++)</H3>
+\r
+<BR>Niech x, y, z bêd¹ zmiennymi wskazuj¹cymi na rekord lub obiekt typu T.\r
+<BR>Po wykonaniu instrukcji dispose(y) lub odp. free(y) warto\9cci¹ zmiennej y jest wska\9fnik nil do pustego obiektu. Wska\9fniki x i z nadal pokazuj¹ na pole pamiêci zajmowane przez nieistniej¹cy ju¿ obiekt. Po wykonaniu instukcji new lub malloc to samo pole mo¿e byæ wskazywane przez zmienn¹ u jako obiekt typu T'. \r
+<BR>Porównaj to z aksjomatem Loglanu\r
+ {(x<>none&y=x&z=x) ( [kill(y)](x=y=z=none)}\r
+<BR>Jego sens jest oczywisty. Warto nadmieniæ, ¿e 1° koszt tej dealokacji obiektu x nie zale¿y od liczby wska\9fników do obiektu, nie musisz o tym mysleæ 2° system sygnalizuje wszelkie próby dostêpu do informacji w obiekcie, który (ju¿/jeszcze) nie istnieje.\r
+ponadto programista mo¿e sam zaprojektowaæ reakcjê na b³êdy i na sygna³y podnoszone przez program w trakcie jego realizacji.\r
+\r
+</table> \r
+\r
+\r
+\r
+\r
+
+<HR>
+
+<H1>NIE PRZEGAP!</H1>
+\r
+<OL>
+<LI>Porównaj sam, Loglan i inne jêzyki programowania i wyrób sobie swój w³asny pogl¹d w tej sprawie,\r
+<LI>Policz: jedna licencja na kompilator jêzyka pretenduj¹cego do miana obiektowo\9cci to XXX z³ razy ilo\9cæ stanowisk pracy w twej uczelni i u studentów. Ile to by kosztowa³o?\r
+<LI>Zauwa¿! w jednym jêzyku programowania oferujemy Ci komplet narzêdzi:\r
+klasy i obiekty, wspó³programy, procesy, dziedziczenie i zagnie¿dzanie modu³ów, ochronê atrybutów prywatnych obiektów wg ¿yczenia twórcy klasy, deklaracje sygna³ów i obs³ugê przerwañ i sygna³ów, wiele sposobów na tworzenie modu³ów generycznych - sparametryzowanych typem danych, dziedziczenie ne tylko w klasach ale w ka¿dym rodzaju modu³u: funkcji, procedurze, bloku, zspó³programie, procesie .\r
+<LI>Uwierz nam! jêzyki o podobnych w³asno\9cciach zostan¹ odkryte w Ameryce dopiero za parê lat. Chcesz czekaæ?\r
+<LI>Zrób sobie wieloprocesorow¹, sieciow¹, virtualn¹ maszynê Loglanowsk¹! (Tanio! oto jedna z recept: we\9f tyle PC ile zdo³asz, po³¹cz je w sieæ lokaln¹, zainstaluj Loglan. )\r
+<LI>Zarób na Loglanie! Mo¿esz go sprzedawaæ, nie mamy nic przeciw temu i nie ¿¹damy niczego od Ciebie. Musisz tylko zachowaæ informacjê o prawach autorskich w sprzedawanych przez Ciebie kopiach. Tak jak to siê dzieje (lub jak powinno siê dziaæ) w przypadku TEXa, Linuxa, produktów GNU, etc. \r
+</OL>
+\r
+<HR>
+
+
+<P>
+Przekonaj siê lub znajd\9f s³aby punkt w naszej argumentacji.
+Napisz nam o Twoich zastrze¿eniach <A HREF="mailto:salwicki@aragorn.pb.bialystok.pl" METHODS="mailto">mailto:salwicki@aragorn.pb.bialystok.pl</A>\r
+
+<P>
+Nie przejd\9f obojêtnie wobec naszej oferty bo byæ mo¿e przegapisz co\9c co ma dla Ciebie znaczenie. Je\9cli masz j¹ odrzuciæ to zrób to \9cwiadomie, na podstawie rzeczowych przes³anek. (Napisz nam o Twych zastrze¿eniach.)\r
+\r
+
+<P>
+Czy argument "to siê nie przyjmie" ma tu istotne znaczenie? \r
+a) je\9cli prowadzisz zajêcia dydaktyczne lub jestes ich s³uchaczem: to zauwa¿, ¿e ¿aden inny\r
+jêzyk programowania nie dostarczy Ci tak w³a\9cciwej podstawy do studiowania zjawisk zwi¹zanych z obiektami. Np. temat "modu³y generyczne" w jêzyku C++ sprowadza siê do szablonów (ang. template). W Loglanie znamy kilkana\9ccie ró¿nych rowi¹zañ tego problemu. A same szablony maj¹ wiêcej wad ni¿ tego mo¿na by oczekiwaæ. \r
+Po Loglanie mo¿na nauczaæ jakiegokolwiek jêzyka programowania znacznie szybciej i wydajniej. Wystarcz¹ 2 popo³udnia by nauczyæ C++, Smalltalka lub innego jêzyka z obiektami. (A w³a\9cciwie dlaczego naucza siê Pascala a nie Loglanu?) \r
+b) je\9cli tworzysz swoje w³asne oprogramowanie i ma ono byæ w³¹czone w wiêkszy system ju¿ istniej¹cych modu³ów to pozostañ przy wybranym jêzyku progamowania. Rozwa¿ jednak mo¿liwo\9cæ napisania najpierw prototypu Twego oprogramowania w Loglanie i sprawdzenia jego zgodno\9cci ze specyfikacj¹ (poprzez walidacjê lub weryfikacjê) a potem przekodowania do C czy C++1. Prototyp powinien powstaæ trzy razy szybciej. \r\r\rWspomnieæ o nowo\9cci: sieæ maszyn DOSowych mo¿e realizowaæ maszynê wieloprocesorow¹\r
+\r
+<HR>
+<EM>Notatki</EM><BR>
+Wspomnieæ o tym, ¿e chocia¿ Loglan jest "samoróbk¹" uczelnian¹ to i tak mo¿e byæ u¿ywany przez wielu, w odró¿nieniu od samochodu.\r
+\r
+\r
+\r<BR>
+1 Wspomnijmy tu o eksperymentalnym programie L2C t³umacz¹cym z Loglanu na C jaki powsta³ parê lat temu na Uniwersytecie \8cl¹skim.\r\r
+
+</body>
+</html>
--- /dev/null
+<html>
+<head>
+<TITLE>Loglan'82 Biuletyn nr 2</TITLE>
+
+
+</head>
+<body>
+<h4>Instytut Informatyki Politechniki Bia³ostockiej z
+przyjemno\9cci¹ zawiadamia, ¿e od
+pewnego czasu dzia³a w sieci Internetu
\r <P>
+
+\r
+ <EM> repozytorium jêzyka pogramowania obiektowego </EM>
+ <P>
+<IMG ALIGN=TOP SRC = "MicroMan/gifs/logo2.gif" >
+<STRONG> Loglan'82 </STRONG> </h4> \r
+\r
+<tr>
+<td colspan=2>
+ <H2> <STRONG> Co? </STRONG> </h2>
+ <H3> Loglan'82 jest jêzykiem programowania obiektowego,
+wspó³bie¿nego, rozproszonego o niepowtarzalnych walorach. </H3>
+\r
+ <P>
+Udostêpniamy: \r
+<UL>
+<LI>kompilatory+interpretatory Loglanu na rózne platformy, w tym sieciowe,\r
+<li>dokumentacjê,\r
+<li>zbiór przyk³adów,\r
+<li>edytory:
+LOTEK i edytor strukturalny (tylko dla \9crodowiska DOS),\r
+\8f<li>RZRÓD£A!\r
+\r</ul>
+</td>
+</tr>
+<tr>
+<td align=top> <H2> <STRONG> Gdzie? </STRONG> </H2>
+ \r
+ <P>
+http://aragorn.pb.bialystok.pl
+ <P>
+lub\r
+ <P>
+ftp://aragorn.pb.bialystok.pl/pub/loglan \r
+ <P>
+i jego lustrzane odbicia (znacznie szybciej osi¹galne w sieci)\r
+ <P>
+ http://sunsite.icm.edu.pl/loglan/ \r
+ <P>
+ ftp://sunsite/icm.edu.pl/pub/loglan/ \r
+\r
+ <P>
+ http://infpc1.univ-pau.fr/ \r
+ <P>
+ftp://infpc1.univ-pau.fr/pub/loglan82
+</td>
+<td align=top>
+ <H2> <STRONG> Jak? </STRONG> </H2>
+
+ <P>
+dla WWW: Mosaic, Netscape, Lynx, ...
+ <P>
+dla anonymous FTP
+ <P>
+ <P>
+ Dziekujemy prof. Markowi Niezgodce
+ <P>
+i p. Wojtkowi Sylwestrzakowi z ICM
+ <P> ten server dziala od 1993
+
+</td>
+</tr>
+<tr>
+<td colspan=2>
+ <H1> Zachecamy do (bezplatnego!) korzystania z naszej bazy wiedzy. </H1>
+
+</td>
+</tr>
+<tr>
+<td colspan=2>
+ <H2> Dlaczego? </H2> <P>
+
+
+</td>
+</tr>
+</table> \r
+\r
+\r
+\r
+\r
+Uczelnie, jednostki badawcze, pracownicy uczelni i studenci, firmy softwareowe, etc. mog¹ wykorzystywaæ Loglan jako jêzyk programowania obiektowego:\r
+\r
+W dydaktyce programowania pocz¹tkowego, algorytmów i struktur danych, programowania obiektowego, programowania wspó³bie¿nego i rozproszonego, itd.\r
+W szybkim tworzeniu prototypów du¿ych, skomplikowanych aplikacji.\r
+W badaniach: jako narzêdzie badawcze, a tak¿e jako bogate \9fród³o ciekawych i wa¿nych problemów badawczych (http://aragorn.pb.bialystok.pl/loglan/openpbms.html).\r
+\r
+Loglan nie jest gorszy od innych jêzyków programowania obiektowego (por. http://aragorn.pb.bialystok.pl/loglan/tablica3.html )\r
+Stosowanie Loglanu pozwola wyposa¿yæ uczelnie, pracowników, studentów itd. w licencjonowane oprogramowanie, bez ¿adnych kosztów! Co wiêcej, stwarza do\9cæ rzadk¹ okazjê rozdawania studentom legalnie i za darmo oprogramowania wspieraj¹cego proces dydaktyczny. Nauczyciele i s³uchacze bêd¹ mogli wymieniaæ siê \9fród³ami programów loglanowskich i uzyskaj¹ te same wyniki bowiem Loglan jest niezale¿ny od platformy i dzia³a tak samo w DOSie, Unixie, Atari ST (my\9climy te¿ o platformach MacIntosh i Amiga), w sieciach rozleg³ych Internet i lokalnych Novell.\r
+\r
+Jezyk oferuje niezwykle bogaty zestaw narzêdzi programowania obiektowego, ³¹cznie z obiektami-procesami rozproszonymi w sieci komputerowej. . Procesy komunikuj¹ siê w sposób ca³kowicie obiektowy: dwa procesy wspólnie realizuj¹ jak¹\9c metodê jednego z dwu procesów wg pewnego protoko³u, jest to obce wywo³anie inaczej alien call zaproponowany i zrealizowany przez B. Ciesielskiego w r.1988. Wszystkie znane mechanizmy synchronizacji i komunikacji procesów sprowadzaj¹ siê do mechanizmu alien call w prosty i tani sposób.\r
+UWAGA.\r
+Ostatnio reklamuja siê jêzyki przyblizaj¹ce siê do wysokiego standardu rozwi¹zañ opracowanych dla Loglanu. Mo¿emy jednak przewidywac, ¿e w bie¿¹cym stuleciu nie pojawi siê nowy istotnie lepszy od Loglanu jêzyk programowania obiektowego. Zalety naszych rozwiazañ zostan¹ nale¿ycie docenione w odleg³ej jeszcze przysz³o\9cci, gdy jaka\9c bogata firma zechce promowaæ "swoje" odkrycie. Rozwi¹zania Loglanu wspieraj¹ siê wynikami badañ przeprowadzonych przez zespó³ profesorów A. Kreczmara, A. Salwickiego. (por. credits.html) Czy mo¿na oczekiwaæ ¿e jaka\9c, nawet bogata, firma zainwestuje w potrzebne badania?\r
+KONIEC UWAGI.\r
+Programowanie w Loglanie jest znacznie ³atwiejsze ni¿ w innych jêzykach programowania obiektowego (por http://aragorn.pb.bialystok.pl/loglan/quick.htm). \r
+\r
+Programowanie w Loglanie jest o wiele bezpieczniejsze ni¿ w innych jêzykach programowania:\r
+kompilator wykrywa wiele b³êdów (tak¿e tych nie dostrzeganych przez inne kompilatory), i opisuje nature i miejsce b³êdów,\r
+wiele b³êdów jest wykrywanych i sygnalizowanych w trakcie wykonywania programu (b³êdy takie s¹ lokalizowane w tekscie programu \9fród³owego i czytelnie opisane),\r
+zarz¹dzanie zasobami pamiêciowymi jest bezpieczne i mocne,\r
+np. programista nie musi siê obawiaæ gro\9fby trudnego do wykrycia b³êdu "wisz¹cych referencji":\r
+PRZYKLAD (w Pascalu lub C++)\r
+Niech x, y, z bêd¹ zmiennymi wskazuj¹cymi na rekord lub obiekt typu T.\r
+Po wykonaniu instrukcji dispose(y) lub odp. free(y) warto\9cci¹ zmiennej y jest wska\9fnik nil do pustego obiektu. Wska\9fniki x i z nadal pokazuj¹ na pole pamiêci zajmowane przez nieistniej¹cy ju¿ obiekt. Po wykonaniu instukcji new lub malloc to samo pole mo¿e byæ wskazywane przez zmienn¹ u jako obiekt typu T'. \r
+Porównaj to z aksjomatem Loglanu\r
+ {(x<>none&y=x&z=x) ( [kill(y)](x=y=z=none)}\r
+Jego sens jest oczywisty. Warto nadmieniæ, ¿e 1° koszt tej dealokacji obiektu x nie zale¿y od liczby wska\9fników do obiektu, nie musisz o tym mysleæ 2° system sygnalizuje wszelkie próby dostêpu do informacji w obiekcie, który (ju¿/jeszcze) nie istnieje.\r
+ponadto programista mo¿e sam zaprojektowaæ reakcjê na b³êdy i na sygna³y podnoszone przez program w trakcie jego realizacji.\r
+\r
+NIE PRZEGAP!\r
+Porównaj sam, Loglan i inne jêzyki programowania i wyrób sobie swój w³asny pogl¹d w tej sprawie,\r
+Policz: jedna licencja na kompilator jêzyka pretenduj¹cego do miana obiektowo\9cci to XXX z³ razy ilo\9cæ stanowisk pracy w twej uczelni i u studentów. Ile to by kosztowa³o?\r
+Zauwa¿! w jednym jêzyku programowania oferujemy Ci komplet narzêdzi:\r
+klasy i obiekty, wspó³programy, procesy, dziedziczenie i zagnie¿dzanie modu³ów, ochronê atrybutów prywatnych obiektów wg ¿yczenia twórcy klasy, deklaracje sygna³ów i obs³ugê przerwañ i sygna³ów, wiele sposobów na tworzenie modu³ów generycznych - sparametryzowanych typem danych, dziedziczenie ne tylko w klasach ale w ka¿dym rodzaju modu³u: funkcji, procedurze, bloku, zspó³programie, procesie .\r
+Uwierz nam! jêzyki o podobnych w³asno\9cciach zostan¹ odkryte w Ameryce dopiero za parê lat. Chcesz czekaæ?\r
+Zrób sobie wieloprocesorow¹, sieciow¹, virtualn¹ maszynê Loglanowsk¹! (Tanio! oto jedna z recept: we\9f tyle PC ile zdo³asz, po³¹cz je w sieæ lokaln¹, zainstaluj Loglan. )\r
+Zarób na Loglanie! Mo¿esz go sprzedawaæ, nie mamy nic przeciw temu i nie ¿¹damy niczego od Ciebie. Musisz tylko zachowaæ informacjê o prawach autorskich w sprzedawanych przez Ciebie kopiach. Tak jak to siê dzieje (lub jak powinno siê dziaæ) w przypadku TEXa, Linuxa, produktów GNU, etc. \r
+\r
+Przekonaj siê lub znajd\9f s³aby punkt w naszej argumentacji. Napisz nam o Twoich zastrze¿eniach mailto:salwicki@aragorn.pb.bialystok.pl\r
+Nie przejd\9f obojêtnie wobec naszej oferty bo byæ mo¿e przegapisz co\9c co ma dla Ciebie znaczenie. Je\9cli masz j¹ odrzuciæ to zrób to \9cwiadomie, na podstawie rzeczowych przes³anek. (Napisz nam o Twych zastrze¿eniach.)\r
+\r
+Czy argument "to siê nie przyjmie" ma tu istotne znaczenie? \r
+a) je\9cli prowadzisz zajêcia dydaktyczne lub jestes ich s³uchaczem: to zauwa¿, ¿e ¿aden inny\r
+jêzyk programowania nie dostarczy Ci tak w³a\9cciwej podstawy do studiowania zjawisk zwi¹zanych z obiektami. Np. temat "modu³y generyczne" w jêzyku C++ sprowadza siê do szablonów (ang. template). W Loglanie znamy kilkana\9ccie ró¿nych rowi¹zañ tego problemu. A same szablony maj¹ wiêcej wad ni¿ tego mo¿na by oczekiwaæ. \r
+Po Loglanie mo¿na nauczaæ jakiegokolwiek jêzyka programowania znacznie szybciej i wydajniej. Wystarcz¹ 2 popo³udnia by nauczyæ C++, Smalltalka lub innego jêzyka z obiektami. (A w³a\9cciwie dlaczego naucza siê Pascala a nie Loglanu?) \r
+b) je\9cli tworzysz swoje w³asne oprogramowanie i ma ono byæ w³¹czone w wiêkszy system ju¿ istniej¹cych modu³ów to pozostañ przy wybranym jêzyku progamowania. Rozwa¿ jednak mo¿liwo\9cæ napisania najpierw prototypu Twego oprogramowania w Loglanie i sprawdzenia jego zgodno\9cci ze specyfikacj¹ (poprzez walidacjê lub weryfikacjê) a potem przekodowania do C czy C++1. Prototyp powinien powstaæ trzy razy szybciej. \r\r\rWspomnieæ o nowo\9cci: sieæ maszyn DOSowych mo¿e realizowaæ maszynê wieloprocesorow¹\r
+\r
+Wspomnieæ o tym, ¿e chocia¿ Loglan jest "samoróbk¹" uczelnian¹ to i tak mo¿e byæ u¿ywany przez wielu, w odró¿nieniu od samochodu.\r
+\r
+\r
+\r
+1 Wspomnijmy tu o eksperymentalnym programie L2C t³umacz¹cym z Loglanu na C jaki powsta³ parê lat temu na Uniwersytecie \8cl¹skim.\r\r
+
+</body>
+</html>p
\ No newline at end of file
--- /dev/null
+<html>
+<head>
+<TITLE>Loglan'82 Biuletyn nr 2</TITLE>
+
+
+</head>
+<body>
+<h3>Instytut Informatyki Politechniki Bia³ostockiej z
+przyjemno\9csci¹ zawiadamia, ¿e od p
+pewnego czasu dzia³a w sieci Internetu\r
+\r
+repozytorium jêzyka pogramowania obiektowego Loglan'82</h3> \r
+\r
+\r
+ <H1> <STRONG> Co? </STRONG> </h1>
+ <H2> Loglan'82 jest jêzykiem programowania obiektowego,
+wspó³bie¿nego, rozproszonego o niepowtarzalnych walorach. </H2>
+\r
+ <P>
+Udostêpniamy: \r
+
+<UL>
+<LI>kompilatory+interpretatory Loglanu na róne platformy, w tym sieciowe,\r
+dokumentacjê,\r
+<li>zbiór przyk³adów,\r
+<li>edytory:
+
+ LOTEK i edytor strukturalny (tylko dla \9crodowiska DOS),\r
+\8f<li>RZRÓD£A!\r
+\r</ul>
+Gdzie? Jak?\r
+ http://aragorn.pb.bialystok.pl dla WWW: Mosaic, Netscape, Lynx, ...\r
+lub\r
+ ftp://aragorn.pb.bialystok.pl/pub/loglan dla anonymous FTP\r
+i jego lustrzane odbicia (znacznie szybciej osi¹galne w sieci)\r
+ http://sunsite.icm.edu.pl/loglan/ DZIEKUJEMY prof. Markowi Niezgódce \r
+ ftp://sunsite/icm.edu.pl/pub/loglan/ i Wojtkowi Sylwestrzakowi z ICM\r
+\r
+ http://infpc1.univ-pau.fr/ ten server dzia³a od 1993\r
+ ftp://infpc1.univ-pau.fr/pub/loglan82 \r
+Zachêcamy do (bezp³atnego!) korzystania z naszej bazy wiedzy.\r
+\r
+Dlaczego?\r
+\r
+Uczelnie, jednostki badawcze, pracownicy uczelni i studenci, firmy softwareowe, etc. mog¹ wykorzystywaæ Loglan jako jêzyk programowania obiektowego:\r
+\r
+W dydaktyce programowania pocz¹tkowego, algorytmów i struktur danych, programowania obiektowego, programowania wspó³bie¿nego i rozproszonego, itd.\r
+W szybkim tworzeniu prototypów du¿ych, skomplikowanych aplikacji.\r
+W badaniach: jako narzêdzie badawcze, a tak¿e jako bogate \9fród³o ciekawych i wa¿nych problemów badawczych (http://aragorn.pb.bialystok.pl/loglan/openpbms.html).\r
+\r
+Loglan nie jest gorszy od innych jêzyków programowania obiektowego (por. http://aragorn.pb.bialystok.pl/loglan/tablica3.html )\r
+Stosowanie Loglanu pozwola wyposa¿yæ uczelnie, pracowników, studentów itd. w licencjonowane oprogramowanie, bez ¿adnych kosztów! Co wiêcej, stwarza do\9cæ rzadk¹ okazjê rozdawania studentom legalnie i za darmo oprogramowania wspieraj¹cego proces dydaktyczny. Nauczyciele i s³uchacze bêd¹ mogli wymieniaæ siê \9fród³ami programów loglanowskich i uzyskaj¹ te same wyniki bowiem Loglan jest niezale¿ny od platformy i dzia³a tak samo w DOSie, Unixie, Atari ST (my\9climy te¿ o platformach MacIntosh i Amiga), w sieciach rozleg³ych Internet i lokalnych Novell.\r
+\r
+Jezyk oferuje niezwykle bogaty zestaw narzêdzi programowania obiektowego, ³¹cznie z obiektami-procesami rozproszonymi w sieci komputerowej. . Procesy komunikuj¹ siê w sposób ca³kowicie obiektowy: dwa procesy wspólnie realizuj¹ jak¹\9c metodê jednego z dwu procesów wg pewnego protoko³u, jest to obce wywo³anie inaczej alien call zaproponowany i zrealizowany przez B. Ciesielskiego w r.1988. Wszystkie znane mechanizmy synchronizacji i komunikacji procesów sprowadzaj¹ siê do mechanizmu alien call w prosty i tani sposób.\r
+UWAGA.\r
+Ostatnio reklamuja siê jêzyki przyblizaj¹ce siê do wysokiego standardu rozwi¹zañ opracowanych dla Loglanu. Mo¿emy jednak przewidywac, ¿e w bie¿¹cym stuleciu nie pojawi siê nowy istotnie lepszy od Loglanu jêzyk programowania obiektowego. Zalety naszych rozwiazañ zostan¹ nale¿ycie docenione w odleg³ej jeszcze przysz³o\9cci, gdy jaka\9c bogata firma zechce promowaæ "swoje" odkrycie. Rozwi¹zania Loglanu wspieraj¹ siê wynikami badañ przeprowadzonych przez zespó³ profesorów A. Kreczmara, A. Salwickiego. (por. credits.html) Czy mo¿na oczekiwaæ ¿e jaka\9c, nawet bogata, firma zainwestuje w potrzebne badania?\r
+KONIEC UWAGI.\r
+Programowanie w Loglanie jest znacznie ³atwiejsze ni¿ w innych jêzykach programowania obiektowego (por http://aragorn.pb.bialystok.pl/loglan/quick.htm). \r
+\r
+Programowanie w Loglanie jest o wiele bezpieczniejsze ni¿ w innych jêzykach programowania:\r
+kompilator wykrywa wiele b³êdów (tak¿e tych nie dostrzeganych przez inne kompilatory), i opisuje nature i miejsce b³êdów,\r
+wiele b³êdów jest wykrywanych i sygnalizowanych w trakcie wykonywania programu (b³êdy takie s¹ lokalizowane w tekscie programu \9fród³owego i czytelnie opisane),\r
+zarz¹dzanie zasobami pamiêciowymi jest bezpieczne i mocne,\r
+np. programista nie musi siê obawiaæ gro\9fby trudnego do wykrycia b³êdu "wisz¹cych referencji":\r
+PRZYKLAD (w Pascalu lub C++)\r
+Niech x, y, z bêd¹ zmiennymi wskazuj¹cymi na rekord lub obiekt typu T.\r
+Po wykonaniu instrukcji dispose(y) lub odp. free(y) warto\9cci¹ zmiennej y jest wska\9fnik nil do pustego obiektu. Wska\9fniki x i z nadal pokazuj¹ na pole pamiêci zajmowane przez nieistniej¹cy ju¿ obiekt. Po wykonaniu instukcji new lub malloc to samo pole mo¿e byæ wskazywane przez zmienn¹ u jako obiekt typu T'. \r
+Porównaj to z aksjomatem Loglanu\r
+ {(x<>none&y=x&z=x) ( [kill(y)](x=y=z=none)}\r
+Jego sens jest oczywisty. Warto nadmieniæ, ¿e 1° koszt tej dealokacji obiektu x nie zale¿y od liczby wska\9fników do obiektu, nie musisz o tym mysleæ 2° system sygnalizuje wszelkie próby dostêpu do informacji w obiekcie, który (ju¿/jeszcze) nie istnieje.\r
+ponadto programista mo¿e sam zaprojektowaæ reakcjê na b³êdy i na sygna³y podnoszone przez program w trakcie jego realizacji.\r
+\r
+NIE PRZEGAP!\r
+Porównaj sam, Loglan i inne jêzyki programowania i wyrób sobie swój w³asny pogl¹d w tej sprawie,\r
+Policz: jedna licencja na kompilator jêzyka pretenduj¹cego do miana obiektowo\9cci to XXX z³ razy ilo\9cæ stanowisk pracy w twej uczelni i u studentów. Ile to by kosztowa³o?\r
+Zauwa¿! w jednym jêzyku programowania oferujemy Ci komplet narzêdzi:\r
+klasy i obiekty, wspó³programy, procesy, dziedziczenie i zagnie¿dzanie modu³ów, ochronê atrybutów prywatnych obiektów wg ¿yczenia twórcy klasy, deklaracje sygna³ów i obs³ugê przerwañ i sygna³ów, wiele sposobów na tworzenie modu³ów generycznych - sparametryzowanych typem danych, dziedziczenie ne tylko w klasach ale w ka¿dym rodzaju modu³u: funkcji, procedurze, bloku, zspó³programie, procesie .\r
+Uwierz nam! jêzyki o podobnych w³asno\9cciach zostan¹ odkryte w Ameryce dopiero za parê lat. Chcesz czekaæ?\r
+Zrób sobie wieloprocesorow¹, sieciow¹, virtualn¹ maszynê Loglanowsk¹! (Tanio! oto jedna z recept: we\9f tyle PC ile zdo³asz, po³¹cz je w sieæ lokaln¹, zainstaluj Loglan. )\r
+Zarób na Loglanie! Mo¿esz go sprzedawaæ, nie mamy nic przeciw temu i nie ¿¹damy niczego od Ciebie. Musisz tylko zachowaæ informacjê o prawach autorskich w sprzedawanych przez Ciebie kopiach. Tak jak to siê dzieje (lub jak powinno siê dziaæ) w przypadku TEXa, Linuxa, produktów GNU, etc. \r
+\r
+Przekonaj siê lub znajd\9f s³aby punkt w naszej argumentacji. Napisz nam o Twoich zastrze¿eniach mailto:salwicki@aragorn.pb.bialystok.pl\r
+Nie przejd\9f obojêtnie wobec naszej oferty bo byæ mo¿e przegapisz co\9c co ma dla Ciebie znaczenie. Je\9cli masz j¹ odrzuciæ to zrób to \9cwiadomie, na podstawie rzeczowych przes³anek. (Napisz nam o Twych zastrze¿eniach.)\r
+\r
+Czy argument "to siê nie przyjmie" ma tu istotne znaczenie? \r
+a) je\9cli prowadzisz zajêcia dydaktyczne lub jestes ich s³uchaczem: to zauwa¿, ¿e ¿aden inny\r
+jêzyk programowania nie dostarczy Ci tak w³a\9cciwej podstawy do studiowania zjawisk zwi¹zanych z obiektami. Np. temat "modu³y generyczne" w jêzyku C++ sprowadza siê do szablonów (ang. template). W Loglanie znamy kilkana\9ccie ró¿nych rowi¹zañ tego problemu. A same szablony maj¹ wiêcej wad ni¿ tego mo¿na by oczekiwaæ. \r
+Po Loglanie mo¿na nauczaæ jakiegokolwiek jêzyka programowania znacznie szybciej i wydajniej. Wystarcz¹ 2 popo³udnia by nauczyæ C++, Smalltalka lub innego jêzyka z obiektami. (A w³a\9cciwie dlaczego naucza siê Pascala a nie Loglanu?) \r
+b) je\9cli tworzysz swoje w³asne oprogramowanie i ma ono byæ w³¹czone w wiêkszy system ju¿ istniej¹cych modu³ów to pozostañ przy wybranym jêzyku progamowania. Rozwa¿ jednak mo¿liwo\9cæ napisania najpierw prototypu Twego oprogramowania w Loglanie i sprawdzenia jego zgodno\9cci ze specyfikacj¹ (poprzez walidacjê lub weryfikacjê) a potem przekodowania do C czy C++1. Prototyp powinien powstaæ trzy razy szybciej. \r\r\rWspomnieæ o nowo\9cci: sieæ maszyn DOSowych mo¿e realizowaæ maszynê wieloprocesorow¹\r
+\r
+Wspomnieæ o tym, ¿e chocia¿ Loglan jest "samoróbk¹" uczelnian¹ to i tak mo¿e byæ u¿ywany przez wielu, w odró¿nieniu od samochodu.\r
+\r
+\r
+\r
+1 Wspomnijmy tu o eksperymentalnym programie L2C t³umacz¹cym z Loglanu na C jaki powsta³ parê lat temu na Uniwersytecie \8cl¹skim.\r\r
+
+</body>
+</html>p
\ No newline at end of file
--- /dev/null
+<html>
+<head>
+<TITLE>Loglan'82 Biuletyn nr 2</TITLE>
+
+
+</head>
+<body>
+<h3>Instytut Informatyki Politechniki Bia³ostockiej z przyjemno\9csci¹ zawiadamia, ¿e od pewnego czasu dzia³a w sieci Internetu\r
+\r
+repozytorium jêzyka pogramowania obiektowego Loglan'82</h3> \r
+\r
+\r
+Co? Loglan'82 jest jêzykiem programowania obiektowego, wspó³bie¿nego, rozproszonego o niepowtarzalnych walorach.\r
+Udostêpniamy: \r
+kompilatory+interpretatory Loglanu na róne platformy, w tym sieciowe,\r
+dokumentacjê,\r
+zbiór przyk³adów,\r
+edytory: LOTEK i edytor strukturalny (tylko dla \9crodowiska DOS),\r
+\8fRÓD£A!\r
+\r
+Gdzie? Jak?\r
+ http://aragorn.pb.bialystok.pl dla WWW: Mosaic, Netscape, Lynx, ...\r
+lub\r
+ ftp://aragorn.pb.bialystok.pl/pub/loglan dla anonymous FTP\r
+i jego lustrzane odbicia (znacznie szybciej osi¹galne w sieci)\r
+ http://sunsite.icm.edu.pl/loglan/ DZIEKUJEMY prof. Markowi Niezgódce \r
+ ftp://sunsite/icm.edu.pl/pub/loglan/ i Wojtkowi Sylwestrzakowi z ICM\r
+\r
+ http://infpc1.univ-pau.fr/ ten server dzia³a od 1993\r
+ ftp://infpc1.univ-pau.fr/pub/loglan82 \r
+Zachêcamy do (bezp³atnego!) korzystania z naszej bazy wiedzy.\r
+\r
+Dlaczego?\r
+\r
+Uczelnie, jednostki badawcze, pracownicy uczelni i studenci, firmy softwareowe, etc. mog¹ wykorzystywaæ Loglan jako jêzyk programowania obiektowego:\r
+\r
+W dydaktyce programowania pocz¹tkowego, algorytmów i struktur danych, programowania obiektowego, programowania wspó³bie¿nego i rozproszonego, itd.\r
+W szybkim tworzeniu prototypów du¿ych, skomplikowanych aplikacji.\r
+W badaniach: jako narzêdzie badawcze, a tak¿e jako bogate \9fród³o ciekawych i wa¿nych problemów badawczych (http://aragorn.pb.bialystok.pl/loglan/openpbms.html).\r
+\r
+Loglan nie jest gorszy od innych jêzyków programowania obiektowego (por. http://aragorn.pb.bialystok.pl/loglan/tablica3.html )\r
+Stosowanie Loglanu pozwola wyposa¿yæ uczelnie, pracowników, studentów itd. w licencjonowane oprogramowanie, bez ¿adnych kosztów! Co wiêcej, stwarza do\9cæ rzadk¹ okazjê rozdawania studentom legalnie i za darmo oprogramowania wspieraj¹cego proces dydaktyczny. Nauczyciele i s³uchacze bêd¹ mogli wymieniaæ siê \9fród³ami programów loglanowskich i uzyskaj¹ te same wyniki bowiem Loglan jest niezale¿ny od platformy i dzia³a tak samo w DOSie, Unixie, Atari ST (my\9climy te¿ o platformach MacIntosh i Amiga), w sieciach rozleg³ych Internet i lokalnych Novell.\r
+\r
+Jezyk oferuje niezwykle bogaty zestaw narzêdzi programowania obiektowego, ³¹cznie z obiektami-procesami rozproszonymi w sieci komputerowej. . Procesy komunikuj¹ siê w sposób ca³kowicie obiektowy: dwa procesy wspólnie realizuj¹ jak¹\9c metodê jednego z dwu procesów wg pewnego protoko³u, jest to obce wywo³anie inaczej alien call zaproponowany i zrealizowany przez B. Ciesielskiego w r.1988. Wszystkie znane mechanizmy synchronizacji i komunikacji procesów sprowadzaj¹ siê do mechanizmu alien call w prosty i tani sposób.\r
+UWAGA.\r
+Ostatnio reklamuja siê jêzyki przyblizaj¹ce siê do wysokiego standardu rozwi¹zañ opracowanych dla Loglanu. Mo¿emy jednak przewidywac, ¿e w bie¿¹cym stuleciu nie pojawi siê nowy istotnie lepszy od Loglanu jêzyk programowania obiektowego. Zalety naszych rozwiazañ zostan¹ nale¿ycie docenione w odleg³ej jeszcze przysz³o\9cci, gdy jaka\9c bogata firma zechce promowaæ "swoje" odkrycie. Rozwi¹zania Loglanu wspieraj¹ siê wynikami badañ przeprowadzonych przez zespó³ profesorów A. Kreczmara, A. Salwickiego. (por. credits.html) Czy mo¿na oczekiwaæ ¿e jaka\9c, nawet bogata, firma zainwestuje w potrzebne badania?\r
+KONIEC UWAGI.\r
+Programowanie w Loglanie jest znacznie ³atwiejsze ni¿ w innych jêzykach programowania obiektowego (por http://aragorn.pb.bialystok.pl/loglan/quick.htm). \r
+\r
+Programowanie w Loglanie jest o wiele bezpieczniejsze ni¿ w innych jêzykach programowania:\r
+kompilator wykrywa wiele b³êdów (tak¿e tych nie dostrzeganych przez inne kompilatory), i opisuje nature i miejsce b³êdów,\r
+wiele b³êdów jest wykrywanych i sygnalizowanych w trakcie wykonywania programu (b³êdy takie s¹ lokalizowane w tekscie programu \9fród³owego i czytelnie opisane),\r
+zarz¹dzanie zasobami pamiêciowymi jest bezpieczne i mocne,\r
+np. programista nie musi siê obawiaæ gro\9fby trudnego do wykrycia b³êdu "wisz¹cych referencji":\r
+PRZYKLAD (w Pascalu lub C++)\r
+Niech x, y, z bêd¹ zmiennymi wskazuj¹cymi na rekord lub obiekt typu T.\r
+Po wykonaniu instrukcji dispose(y) lub odp. free(y) warto\9cci¹ zmiennej y jest wska\9fnik nil do pustego obiektu. Wska\9fniki x i z nadal pokazuj¹ na pole pamiêci zajmowane przez nieistniej¹cy ju¿ obiekt. Po wykonaniu instukcji new lub malloc to samo pole mo¿e byæ wskazywane przez zmienn¹ u jako obiekt typu T'. \r
+Porównaj to z aksjomatem Loglanu\r
+ {(x<>none&y=x&z=x) ( [kill(y)](x=y=z=none)}\r
+Jego sens jest oczywisty. Warto nadmieniæ, ¿e 1° koszt tej dealokacji obiektu x nie zale¿y od liczby wska\9fników do obiektu, nie musisz o tym mysleæ 2° system sygnalizuje wszelkie próby dostêpu do informacji w obiekcie, który (ju¿/jeszcze) nie istnieje.\r
+ponadto programista mo¿e sam zaprojektowaæ reakcjê na b³êdy i na sygna³y podnoszone przez program w trakcie jego realizacji.\r
+\r
+NIE PRZEGAP!\r
+Porównaj sam, Loglan i inne jêzyki programowania i wyrób sobie swój w³asny pogl¹d w tej sprawie,\r
+Policz: jedna licencja na kompilator jêzyka pretenduj¹cego do miana obiektowo\9cci to XXX z³ razy ilo\9cæ stanowisk pracy w twej uczelni i u studentów. Ile to by kosztowa³o?\r
+Zauwa¿! w jednym jêzyku programowania oferujemy Ci komplet narzêdzi:\r
+klasy i obiekty, wspó³programy, procesy, dziedziczenie i zagnie¿dzanie modu³ów, ochronê atrybutów prywatnych obiektów wg ¿yczenia twórcy klasy, deklaracje sygna³ów i obs³ugê przerwañ i sygna³ów, wiele sposobów na tworzenie modu³ów generycznych - sparametryzowanych typem danych, dziedziczenie ne tylko w klasach ale w ka¿dym rodzaju modu³u: funkcji, procedurze, bloku, zspó³programie, procesie .\r
+Uwierz nam! jêzyki o podobnych w³asno\9cciach zostan¹ odkryte w Ameryce dopiero za parê lat. Chcesz czekaæ?\r
+Zrób sobie wieloprocesorow¹, sieciow¹, virtualn¹ maszynê Loglanowsk¹! (Tanio! oto jedna z recept: we\9f tyle PC ile zdo³asz, po³¹cz je w sieæ lokaln¹, zainstaluj Loglan. )\r
+Zarób na Loglanie! Mo¿esz go sprzedawaæ, nie mamy nic przeciw temu i nie ¿¹damy niczego od Ciebie. Musisz tylko zachowaæ informacjê o prawach autorskich w sprzedawanych przez Ciebie kopiach. Tak jak to siê dzieje (lub jak powinno siê dziaæ) w przypadku TEXa, Linuxa, produktów GNU, etc. \r
+\r
+Przekonaj siê lub znajd\9f s³aby punkt w naszej argumentacji. Napisz nam o Twoich zastrze¿eniach mailto:salwicki@aragorn.pb.bialystok.pl\r
+Nie przejd\9f obojêtnie wobec naszej oferty bo byæ mo¿e przegapisz co\9c co ma dla Ciebie znaczenie. Je\9cli masz j¹ odrzuciæ to zrób to \9cwiadomie, na podstawie rzeczowych przes³anek. (Napisz nam o Twych zastrze¿eniach.)\r
+\r
+Czy argument "to siê nie przyjmie" ma tu istotne znaczenie? \r
+a) je\9cli prowadzisz zajêcia dydaktyczne lub jestes ich s³uchaczem: to zauwa¿, ¿e ¿aden inny\r
+jêzyk programowania nie dostarczy Ci tak w³a\9cciwej podstawy do studiowania zjawisk zwi¹zanych z obiektami. Np. temat "modu³y generyczne" w jêzyku C++ sprowadza siê do szablonów (ang. template). W Loglanie znamy kilkana\9ccie ró¿nych rowi¹zañ tego problemu. A same szablony maj¹ wiêcej wad ni¿ tego mo¿na by oczekiwaæ. \r
+Po Loglanie mo¿na nauczaæ jakiegokolwiek jêzyka programowania znacznie szybciej i wydajniej. Wystarcz¹ 2 popo³udnia by nauczyæ C++, Smalltalka lub innego jêzyka z obiektami. (A w³a\9cciwie dlaczego naucza siê Pascala a nie Loglanu?) \r
+b) je\9cli tworzysz swoje w³asne oprogramowanie i ma ono byæ w³¹czone w wiêkszy system ju¿ istniej¹cych modu³ów to pozostañ przy wybranym jêzyku progamowania. Rozwa¿ jednak mo¿liwo\9cæ napisania najpierw prototypu Twego oprogramowania w Loglanie i sprawdzenia jego zgodno\9cci ze specyfikacj¹ (poprzez walidacjê lub weryfikacjê) a potem przekodowania do C czy C++1. Prototyp powinien powstaæ trzy razy szybciej. \r\r\rWspomnieæ o nowo\9cci: sieæ maszyn DOSowych mo¿e realizowaæ maszynê wieloprocesorow¹\r
+\r
+Wspomnieæ o tym, ¿e chocia¿ Loglan jest "samoróbk¹" uczelnian¹ to i tak mo¿e byæ u¿ywany przez wielu, w odró¿nieniu od samochodu.\r
+\r
+\r
+\r
+1 Wspomnijmy tu o eksperymentalnym programie L2C t³umacz¹cym z Loglanu na C jaki powsta³ parê lat temu na Uniwersytecie \8cl¹skim.\r\r
+
+</body>
+</html>p
\ No newline at end of file
--- /dev/null
+<html>\r
+<! last modification Wed 8 Feb 1995>\r
+<head>\r
+<title>credits & acknowledgements</title>\r
+</head>\r
+\r
+<body>\r
+<h1><img src="loglanmm.gif" align=middle>Credits & Acknowledgments</h1>\r
+<ul><li><li></ul>\r
+<h4>this is a preliminary version </h4>\r
+<ul><li><li><li></ul>\r
+<hr>\r
+\r
+\r
+<h2>1st step: Loglan'77</h2>\r
+In 1977 A. Salwicki aided by Tomasz Müldner, Hanna Oktaba, Wieslawa \r
+Ratajczak initiated a research on the feasability of a universal programming \r
+language which was to go beyond the Simula'67 and to enable new features: \r
+processes, inheritance from unequal levels, inheritance in procedures, \r
+fuctions etc..<br> The report on the language was ready in 1978. It helped us to \r
+sign a contract with polish computer industry (We thank A. Janicki once the \r
+deputy director of the Mera trust for his enthousiastic support.)<br> Our next \r
+success was the arrival of prof. Antoni Kreczmar as the leader of the compiler \r
+group.\r
+\r
+<h2>Loglan'82</h2>\r
+In October 1978 the Loglan group started its work. The compiler group \r
+headed by A. Kreczmar included also: W. Nykowski, Marek Lao, Andrzej I. \r
+Litwiniuk, Danuta Szczepanska-Wasersztrum, Pawel Gburzynski.<br>\r
+We had to install, repair* (* means iterations) the Mera 400 computers, \r
+develop its poor software environment. This task was accomplished by Pawel \r
+Gburzynski and Piotr Findeisen) . They did a lot of things:the file system and \r
+other extensions of the operating system of Mera 400, the assembler Gass, the editor \r
+EDM, ...<br>\r
+The only programming language installed then on Mera was Fortran; we had no \r
+choice, our compiler group had to write the compiler of Loglan in Fortran. <br>\r
+And it works efficiently till today!<br>\r
+The compiler group was encouraged by the analysis and application group \r
+including Lech Banachowski, Hanna Oktaba, Tomasz Müldner, Wieslawa \r
+Ratajczak-Bartol, Andrzej Salwicki, Lucjan Stapp and others.<br>\r
+Our main question was the following:<em> is it possible at all?</em> does it exist a way to execute in a \r
+consistent way programs that accept inheritance and nesting, inheritance \r
+which permits to inherit from a different level ?<br>\r
+Other important problems were: is it possible to maintain the Dijkstra's \r
+mechanism of update of the Display Vector? is it posible to do deallocation of \r
+an object in a safe way, without dangling references? Is it possible to give a \r
+simpler but equally powerful mechanism of coroutines to that of Simula'67? \r
+And many other questions.<br>\r
+It was Antoni Kreczmar who found the answers to the basic questions [ ]. <br>\r
+Moreover, he wrote the kernel of the executing system for Loglan - the \r
+Running System (1979).<br>\r
+W.Nykowski wrote the scanner and the parser.<br>\r
+Andrzej I. Litwiniuk wrote the code generator using many novel ideas.<br>\r
+Danuta Szczepanska did static semantic module.<br>\r
+The late Marek Lao did the module that checks the compatibility of types, using his own results.<br>\r
+After different adventures the first version of the Loglan compiler became \r
+operational in December 1981.<br>\r
+Everybody worked with the enthousiasm testing, debugging, extending our \r
+child.<br>\r
+In June 1982 Danuta Szczepanska in cooperation with A. Kreczmar added \r
+the mechanism of exception handling. <br>\r
+The Loglan system was ready. In comparison with the report of the language \r
+it lacked of separate compilation (and it still lacks of this mechanism) and \r
+processes.\r
+A. Salwicki did a prothese implementing processes as coroutines. But it never \r
+became popular. Happily in 1988 Bolek Ciesielski did a superb contribution: \r
+his concept of procedure calls as the synchronisation mechanism deserves \r
+attention.[ ]<br>\r
+The industrial partner accepted our work in June 1982. There was no \r
+continuation however.\r
+\r
+<h2>1982-1990</h2>\r
+1983 Loglan's summer school in Zaborow and Hans Langmaack's contribution<br>\r
+1984 P. Gburzynski and A. I. Litwiniuk port the Loglan to Siemens komputer \r
+(a clone of IBM mainframe - have you ever heard of these jurassic \r
+mainframes my dear?)<br>\r
+A. Szalas presented his Ph.D. thesis ..<br>\r
+1984 an interactive debugger was added to the Loglan system by Teresa \r
+Przytycka.<br>\r
+1984 Radziejowice french-polish meeting on formal methods of programs \r
+theory and object tools of programming<br>\r
+1985 a longlife and successful cooperation with CNR IASI Rome begins. In \r
+cooperation with, Gianna Cioni, Alfonso Miola and others (Giorgio Ausiello)<<br> \r
+The results of the cooperation are numerous: here we shall quote only the the \r
+installation of Loglan on VAX/VMS, debugger, report <br>\r
+U. Petermann<br>\r
+1986 the members of Loglan team were distinguished by the first price <br>\r
+1986-90. A multi-goal and multi-university project was launched. Among 27 \r
+teams there were 4 using or developping Loglan.<br> The results: \r
+M. Warpechowski<br>\r
+Loglan book by A. Szalas and J.Warpechowska appeared in <br>\r
+A proposal for the new standard of Loglan in LNCS \r
+\r
+<h2>porting to Unix environment</h2>\r
+A step toward it was made by Marcin Benke and Grzegorz who translated \r
+GEN part of Loglan's system.<br>\r
+It was Pawel Susicki who ported Loglan to Xenix using the hints of A. \r
+Salwicki. It turned out that using f2c crosscompiler we are able to create \r
+Loglan compiler in the Unix environment without using a Fortran compiler.<br>\r
+In the summer 1991 Pawel Susicki installed Loglan on several Unix \r
+computers accesible to LITA: PC486/SCO Unix, HP900, Sun4 with SunOS \r
+(thanks to O. Rafiq for leasing us the Sun during August 1991).<br>\r
+In 1992 Pawel Susicki wrote a support for processes distributed in network of \r
+(hetergeneous) Unix machines. He had no chance to debug it however. <br>\r
+Sebastien Bernard ported Loglan to the Atari.<br>\r
+1993. Eric Becourt and Jerome Larrieu did a new version of predefined class \r
+Xiiuwgraf for the users of Unix.<br>\r
+ A. Salwicki prepared a distribution packet of \r
+Loglan and put it in the server infpc1 of anonymous FTP users.<br>\r
+1994. Frederic Pataud made a new better version of predefined class \r
+IIuwgraph for users of Dos 386/486 machines.<br>\r
+Eric Becourt did Logpp - now you can #include\r
+<p>
+Oskar Swida made a network version of Loglan.<p>
+For a moment it was a network of SUNs equipped with Solaris.
+<p>April 1996 (Oskar Swida)
+A network of DOS machines equipped with LANWORKPLACE aor NETWARE
+constitutes a virtual, multiprocessor, network Loglan machine.
+
+<hr>\r
+see also:\r
+ <ul>\r
+ <p><li>\r
+ <p><li>\r
+ </ul>\r
+<hr>\r
+<hr>\r
+<a href="drFun.htm"><img src="prevpage.gif"> </a>\r
+<a href="loghome.htm"><img src="homepage.gif"> </a>\r
+ <a href="solate.htm"><img src="nextpage.gif"></a>\r
+<hr>\r
+<address>\r
+<a href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </a> 12:12 02/02/1995\r
+</address>\r
+\r
+</body>\r
+</html>\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+p
\ No newline at end of file
--- /dev/null
+<html>\r
+<! last modification Wed 8 Feb 1995>\r
+<head>\r
+<title>credits & acknowledgements</title>\r
+</head>\r
+\r
+<body>\r
+<h1><img src="loglanmm.gif" align=middle>Credits & Acknowledgments</h1>\r
+<ul><li><li></ul>\r
+<h4>this is a preliminary version </h4>\r
+<ul><li><li><li></ul>\r
+<hr>\r
+\r
+\r
+<h2>1st step: Loglan'77</h2>\r
+In 1977 A. Salwicki aided by Tomasz Müldner, Hanna Oktaba, Wieslawa \r
+Ratajczak initiated a research on the feasability of a universal programming \r
+language which was to go beyond the Simula'67 and to enable new features: \r
+processes, inheritance from unequal levels, inheritance in procedures, \r
+fuctions etc..<br> The report on the language was ready in 1978. It helped us to \r
+sign a contract with polish computer industry (We thank A. Janicki once the \r
+deputy director of the Mera trust for his enthousiastic support.)<br> Our next \r
+success was the arrival of prof. Antoni Kreczmar as the leader of the compiler \r
+group.\r
+\r
+<h2>Loglan'82</h2>\r
+In October 1978 the Loglan group started its work. The compiler group \r
+headed by A. Kreczmar included also: W. Nykowski, Marek Lao, Andrzej I. \r
+Litwiniuk, Danuta Szczepanska-Wasersztrum, Pawel Gburzynski.<br>\r
+We had to install, repair* (* means iterations) the Mera 400 computers, \r
+develop its poor software environment. This task was accomplished by Pawel \r
+Gburzynski and Piotr Findeisen) . They did a lot of things:the file system and \r
+other extensions of the operating system of Mera 400, the assembler Gass, the editor \r
+EDM, ...<br>\r
+The only programming language installed then on Mera was Fortran; we had no \r
+choice, our compiler group had to write the compiler of Loglan in Fortran. <br>\r
+And it works efficiently till today!<br>\r
+The compiler group was encouraged by the analysis and application group \r
+including Lech Banachowski, Hanna Oktaba, Tomasz Müldner, Wieslawa \r
+Ratajczak-Bartol, Andrzej Salwicki, Lucjan Stapp and others.<br>\r
+Our main question was the following:<em> is it possible at all?</em> does it exist a way to execute in a \r
+consistent way programs that accept inheritance and nesting, inheritance \r
+which permits to inherit from a different level ?<br>\r
+Other important problems were: is it possible to maintain the Dijkstra's \r
+mechanism of update of the Display Vector? is it posible to do deallocation of \r
+an object in a safe way, without dangling references? Is it possible to give a \r
+simpler but equally powerful mechanism of coroutines to that of Simula'67? \r
+And many other questions.<br>\r
+It was Antoni Kreczmar who found the answers to the basic questions [ ]. <br>\r
+Moreover, he wrote the kernel of the executing system for Loglan - the \r
+Running System (1979).<br>\r
+W.Nykowski wrote the scanner and the parser.<br>\r
+Andrzej I. Litwiniuk wrote the code generator using many novel ideas.<br>\r
+Danuta Szczepanska did static semantic module.<br>\r
+The late Marek Lao did the module that checks the compatibility of types, using his own results.<br>\r
+After different adventures the first version of the Loglan compiler became \r
+operational in December 1981.<br>\r
+Everybody worked with the enthousiasm testing, debugging, extending our \r
+child.<br>\r
+In June 1982 Danuta Szczepanska in cooperation with A. Kreczmar added \r
+the mechanism of exception handling. <br>\r
+The Loglan system was ready. In comparison with the report of the language \r
+it lacked of separate compilation (and it still lacks of this mechanism) and \r
+processes.\r
+A. Salwicki did a prothese implementing processes as coroutines. But it never \r
+became popular. Happily in 1988 Bolek Ciesielski did a superb contribution: \r
+his concept of procedure calls as the synchronisation mechanism deserves \r
+attention.[ ]<br>\r
+The industrial partner accepted our work in June 1982. There was no \r
+continuation however.\r
+\r
+<h2>1982-1990</h2>\r
+1983 Loglan's summer school in Zaborow and Hans Langmaack's contribution<br>\r
+1984 P. Gburzynski and A. I. Litwiniuk port the Loglan to Siemens komputer \r
+(a clone of IBM mainframe - have you ever heard of these jurassic \r
+mainframes my dear?)<br>\r
+A. Szalas presented his Ph.D. thesis ..<br>\r
+1984 an interactive debugger was added to the Loglan system by Teresa \r
+Przytycka.<br>\r
+1984 Radziejowice french-polish meeting on formal methods of programs \r
+theory and object tools of programming<br>\r
+1985 a longlife and successful cooperation with CNR IASI Rome begins. In \r
+cooperation with, Gianna Cioni, Alfonso Miola and others (Giorgio Ausiello)<<br> \r
+The results of the cooperation are numerous: here we shall quote only the the \r
+installation of Loglan on VAX/VMS, debugger, report <br>\r
+U. Petermann<br>\r
+1986 the members of Loglan team were distinguished by the first price <br>\r
+1986-90. A multi-goal and multi-university project was launched. Among 27 \r
+teams there were 4 using or developping Loglan.<br> The results: \r
+M. Warpechowski<br>\r
+Loglan book by A. Szalas and J.Warpechowska appeared in <br>\r
+A proposal for the new standard of Loglan in LNCS \r
+\r
+<h2>porting to Unix environment</h2>\r
+A step toward it was made by Marcin Benke and Grzegorz who translated \r
+GEN part of Loglan's system.<br>\r
+It was Pawel Susicki who ported Loglan to Xenix using the hints of A. \r
+Salwicki. It turned out that using f2c crosscompiler we are able to create \r
+Loglan compiler in the Unix environment without using a Fortran compiler.<br>\r
+In the summer 1991 Pawel Susicki installed Loglan on several Unix \r
+computers accesible to LITA: PC486/SCO Unix, HP900, Sun4 with SunOS \r
+(thanks to O. Rafiq for leasing us the Sun during August 1991).<br>\r
+In 1992 Pawel Susicki wrote a support for processes distributed in network of \r
+(hetergeneous) Unix machines. He had no chance to debug it however. <br>\r
+Sebastien Bernard ported Loglan to the Atari.<br>\r
+1993. Eric Becourt and Jerome Larrieu did a new version of predefined class \r
+Xiiuwgraf for the users of Unix.<br>\r
+ A. Salwicki prepared a distribution packet of \r
+Loglan and put it in the server infpc1 of anonymous FTP users.<br>\r
+1994. Frederic Pataud made a new better version of predefined class \r
+IIuwgraph for users of Dos 386/486 machines.<br>\r
+Eric Becourt did Logpp - now you can #include\r
+\r
+<hr>\r
+see also:\r
+ <ul>\r
+ <p><li>\r
+ <p><li>\r
+ </ul>\r
+<hr>\r
+<hr>\r
+<a href="drFun.htm"><img src="prevpage.gif"> </a>\r
+<a href="loghome.htm"><img src="homepage.gif"> </a>\r
+ <a href="solate.htm"><img src="nextpage.gif"></a>\r
+<hr>\r
+<address>\r
+<a href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </a> 12:12 02/02/1995\r
+</address>\r
+\r
+</body>\r
+</html>\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+p
\ No newline at end of file
--- /dev/null
+[User Menu0]\r
+Menu_Name=Starting Points\r
+Menu_Type=TOPLEVEL\r
+Item0=Starting Points Document,http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/StartingPoints/NetworkStartingPoints.html\r
+Item1=NCSA Mosaic Demo Document,http://www.ncsa.uiuc.edu/demoweb/demo.html\r
+Item2=NCSA Mosaic's 'What's New' Page,http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/Docs/whats-new.html\r
+Item3=NCSA Mosaic Home Page,http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/NCSAMosaicHome.html\r
+Item4=Windows Mosaic home page,http://www.ncsa.uiuc.edu/SDG/Software/WinMosaic/HomePage.html\r
+Item5=MENU,UserMenu1\r
+Item6=MENU,UserMenu2\r
+Item7=MENU,UserMenu3\r
+Item8=Finger Gateway,http://cs.indiana.edu/finger/gateway\r
+Item9=Whois Gateway,gopher://sipb.mit.edu:70/1B%3aInternet%20whois%20servers\r
+Item10=MENU,UserMenu4\r
+Item11=Archie Request Form,http://hoohoo.ncsa.uiuc.edu/archie.html\r
+\r
+[User Menu1]\r
+Menu_Name=World Wide Web Info\r
+Item0=Web Overview,http://www.w3.org/hypertext/WWW/LineMode/Defaults/default.html\r
+Item1=Web Project,http://www.w3.org/hypertext/WWW/TheProject.html\r
+Item2=Data Sources By Service,http://www.w3.org/hypertext/DataSources/ByAccess.html\r
+Item3=Information By Subject,http://www.w3.org/hypertext/DataSources/bySubject/Overview.html\r
+Item4=Web Servers Directory,http://www.w3.org/hypertext/DataSources/WWW/Servers.html\r
+Item5=HTML Quick Reference,http://www.ncsa.uiuc.edu/General/Internet/WWW/HTMLQuickRef.html\r
+Item6=Internet RFCs,http://www.cis.ohio-state.edu:80/hypertext/information/rfc.html\r
+\r
+[User Menu2]\r
+Menu_Name=Home Pages\r
+Item0=The University of Illinois at Urbana-Champaign,http://www.uiuc.edu\r
+Item1=NCSA Home Page,http://www.ncsa.uiuc.edu/General/NCSAHome.html\r
+Item2=CERN Home Page,http://info.cern.ch/\r
+Item3=UNC-Chapel Hill home page,http://sunsite.unc.edu\r
+Item4=ANU Bioinformatics,http://life.anu.edu.au:80/\r
+Item5=Data Research Home Page,http://dranet.dra.com/\r
+Item6=British Columbia,http://www.cs.ubc.ca/\r
+Item7=BSDI Home Page,http://www.bsdi.com/\r
+Item8=Carnegie Mellon,http://www.cs.cmu.edu:8001/Web/FrontDoor.html\r
+Item9=Cornell Law School,http://www.law.cornell.edu/lii.table.html\r
+Item10=Cornell Theory Center,http://www.tc.cornell.edu:80/ctc.html\r
+Item11=DESY Home Page,http://info.desy.de:80/\r
+Item12=ECE WWW Page,http://www.ece.uiuc.edu\r
+Item13=Honolulu Home Page,http://www.hcc.hawaii.edu/\r
+Item14=Indiana Home Page,http://cs.indiana.edu/home-page.html\r
+Item15=Lysator ACS Sweden,http://www.lysator.liu.se:80/\r
+Item16=National Center for Atmospheric Research,http://http.ucar.edu/metapage.html\r
+Item17=Northwestern Home Page,http://www.acns.nwu.edu/\r
+Item18=CICA's WWW Server ,http://www.cica.indiana.edu\r
+Item19=Ohio State Home Page,http://www.cis.ohio-state.edu:80/hypertext/information/information.html\r
+Item20=SSC Home Page,http://www.ssc.gov/SSC.html\r
+\r
+[User Menu3]\r
+Menu_Name=Gopher Servers\r
+Item0=Gopherspace Overview,gopher://gopher.micro.umn.edu:70/11/Other%20Gopher%20and%20Information%20Servers\r
+Item1=Veronica Search,gopher://veronica.scs.unr.edu:70/11/veronica\r
+Item2=NCSA Gopher,gopher://gopher.ncsa.uiuc.edu:70/1\r
+Item3=PSC Gopher,gopher://gopher.psc.edu:70/1\r
+Item4=SDSC Gopher,gopher://gopher.sdsc.edu:70/1\r
+Item5=Original (UMN) Gopher,gopher://gopher.micro.umn.edu:70/1\r
+Item6=UIUC Gopher,gopher://gopher.uiuc.edu:70/1\r
+Item7=UIUC Weather Machine,gopher://wx.atmos.uiuc.edu:70/1\r
+Item8=SDSU Sounds,gopher://athena.sdsu.edu:71/11/sounds\r
+\r
+[User Menu4]\r
+Menu_Name=Other Documents\r
+Item0=Beginner's Guide to HTML,http://www.ncsa.uiuc.edu/demoweb/html-primer.html\r
+Item1=InterNIC Info Source,gopher://is.internic.net:70/11/infosource\r
+Item2=Internet Services List,http://slacvx.slac.stanford.edu:80/misc/internet-services.html\r
+Item3=Internet Talk Radio,http://www.ncsa.uiuc.edu/radio/radio.html\r
+Item4=Library of Congress Vatican Exhibit,http://www.ncsa.uiuc.edu/SDG/Experimental/vatican.exhibit/Vatican.exhibit.html\r
+Item5=NCSA Access Magazine,http://www.ncsa.uiuc.edu/Pubs/access/accessDir.html\r
+Item6=Doctor Fun,http://sunsite.unc.edu/Dave/drfun.html\r
+Item7=Postmodern Culture,http://jefferson.village.virginia.edu/pmc/contents.all.html\r
+Item8=Zippy The Pinhead,http://www.cis.ohio-state.edu:84/\r
+Item9=Britannica Online,http://www.eb.com/\r
+Item10=ANU Art History Exhibit,http://www.ncsa.uiuc.edu/SDG/Experimental/anu-art-history/home.html\r
+Item11=Web/Net T-Shirts,http://sashimi.wwa.com/~notime/mdd/www_shirt.html\r
+Item12=Census Information,gopher://bigcat.missouri.edu/11/reference/census/us/basictables/\r
+Item13=FTP Sites,http://hoohoo.ncsa.uiuc.edu:80/ftp-interface.html\r
+\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<html>\r
+<HEAD><TITLE> Error Codes </TITLE></HEAD> \r
+ <BODY> \r
+<H1>APPENDIX D : ERROR CODES</H1>\r
+ <CODE>0 - ***declaration part overloaded</CODE> <P>\r
+<EM>Overflow of compiler data structure of declaration part. Possible reasons: too complicated program structure \r
+(too many classes, protection lists, parameter lists,...), too complicated function expressions e.g. f(g(h(...))). \r
+It is possible that removing some errors e.g. "unvisible identifier" causes shortening of the program.</EM> <P>\r
+ <CODE>10 - ***too many errors </CODE><P>\r
+Overflow of error diagnostic table. 1024 first detected errors are printed, but global number of error is equal \r
+to number of all detected errors. <P>\r
+ <CODE>41 - ***declaration part overloaded</CODE> <P>\r
+Comments as for 0. <P>\r
+ <SAMP>101 - ':=' expected</SAMP> <P>\r
+ <KBD>102 - ';' expected </KBD><P>\r
+ <EM>103 - 'then' expected</EM> <P>\r
+ <STRONG>104 - 'fi'/'else' expected</STRONG> <P>\r
+ <VAR>105 - 'od' expected</VAR> <P>\r
+ <CITE>106 - '(' expected</CITE> <P>\r
+ 107 - ')' expected <P>\r
+ 108 - 'do' expected <P>\r
+ 109 - identifier expected <P>\r
+ 110 - too many exits found <P>\r
+ Length of sequence exit exit ...exit exceeds level of loop nesting +1. <P>\r
+ 111 - illegal character <P>\r
+ 112 - wrong structure of 'if'-statement <P>\r
+ 113 - 'end' missing <P>\r
+ 114 - '.' expected <P>\r
+ <CODE>115 - illegal constant in expression</CODE> <P>\r
+ <DFN>Character constant or text appears in logical or arithmetical expression.</DFN> <P>\r
+ 116 - '=' expected <P>\r
+ 117 - constant expected <P>\r
+ 118 - ':' expected <P>\r
+ 119 - unit kind specification expected <P>\r
+Keywords: class, procedure, function, coroutine or process missing in module headline. <P>\r
+ 120 - 'hidden' or 'close' occurred twice <P>\r
+ 121 - 'hidden' or 'close' out of a class <P>\r
+ 122 - 'block' expected <P>\r
+ 123 - object expression is not a generator <P>\r
+Object expression appearing as instruction is not a generator e.g. new (a).b <P>\r
+ 124 - 'dim' expected <P>\r
+ 125 - 'to'/'downto' expected <P>\r
+ 126 - illegal arithmetic operator <P>\r
+ 127 - declaration part expected <P>\r
+ 128 - incorrect identifier at 'end' <P>\r
+Module name after end does not correspond to name in module headline. <P>\r
+ 129 - wrong structure of 'case'-statement <P>\r
+ 130 - wrong structure of 'do'-statement <P>\r
+ 131 - illegal use of 'main' <P>\r
+ Name main may be used only as an argument of attach operator; in other cases it is illegal. <P>\r
+ 132 - 'when' expected <P>\r
+ 133 - too many branches in 'case'-statement <P>\r
+Number of branches in case instruction is greater than 160. <P>\r
+ 134 - 'begin' missed <P>\r
+ 135 - bad option <P>\r
+ 136 - is it really a loglan program??? <P>\r
+There is no Loglan keyword found in source program like: begin, block, unit, class,... <P>\r
+ 137 - 'block' missed - parsing began <P>\r
+There is no keyword block or program at the beginning of the Loglan program. This message indicates \r
+the source line, that is the first compiled line. <P>\r
+ 138 - 'repeat' out of a loop <P>\r
+ The length of sequence: (exit)*repeat exceeds nested depth of the loop. <P>\r
+ 139 - there is no path to this statement <P>\r
+ 140 - 'andif'/'orif' mixed <P>\r
+ 141 - array of 'semaphore' is illegal <P>\r
+ 142 - wrong handler end <P>\r
+Handler declaration is not ended by instruction end or end handlers. <P>\r
+ 143 - lastwill inside a structured statement <P>\r
+ 144 - repeated lastwill <P>\r
+Label LASTWILL appears more than once in the same module. <P>\r
+ 145 - no parameter specification <P>\r
+ 146 - wrong register specification <P>\r
+ 147 - "," expected<P>\r
+ 191 - ***null program <P>\r
+There is no source program on the input file or there is no module declaration. Causes termination of \r
+program compilation. <P>\r
+ 196 - ***too many identifiers <P>\r
+Entire length of all identifiers and keywords is greater than 3000 characters. This overflow terminates program \r
+compilation. <P>\r
+ 197 - ***too many formal parameters <P>\r
+The length of formal parameter list and declared local variables (in actual module) is greater than 130. This \r
+error terminates program compilation. <P>\r
+ 198 - ***parsing stack overloaded <P>\r
+Too complicated (nested) program structure. This error terminates program compilation. <P>\r
+ 199 - ***too many prototypes <P>\r
+Too many declarations in program caused overflow of the compiler data structure. This error terminates \r
+program compilation. <P>\r
+ 201 - wrong real constant <P>\r
+ 202 - wrong comment <P>\r
+ 203 - wrong character constant <P>\r
+ 204 - wrong integer constant <P>\r
+ 205 - integer overflow <P>\r
+Integer constant out of range. <P>\r
+ 206 - real overflow <P>\r
+Real constant out of range. <P>\r
+ 211 - identifier too long <P>\r
+Length of identifier is greater than 20 characters. <P>\r
+ 212 - string too long <P>\r
+Length of string constant is greater than 260 characters. <P>\r
+ 301 - prefix is not a class id <P>\r
+Prefix name ID is not a class name. It may appear when identifier ID is used earlier (declared more than \r
+once). <P>\r
+ 303 - coroutine/process illegal here as prefix id <P>\r
+Procedure, function or block can't be prefixed by coroutine or process. <P>\r
+ 304 - hidden identifier cannot be taken id <P>\r
+Identifier ID placed on taken list is on hidden list in the prefixing module. <P>\r
+ 305 - undeclared identifier id <P>\r
+ 306 - undeclared type identifier id <P>\r
+ 307 - type identifier expected id <P>\r
+Identifier ID used in variable or function declaration as a type name, is not declared earlier as a type (but \r
+name has been used earlier). <P>\r
+ 308 - undeclared prefix identifier id <P>\r
+ 309 - declared more than once id <P>\r
+ 310 - taken list in unprefixed unit <P>\r
+ 316 - formal type specification after use id <P>\r
+Formal type ID appears in the parameter list after using this identifier as parameter type e.g. (... x: ID; type \r
+ID, ...). <P>\r
+ 317 - hidden type identifier id <P>\r
+Type name ID is on hidden list in a prefix of one of the modules from SL chain of actual module and it is a \r
+nearest declaration of this identifier. <P>\r
+ 318 - type identifier not taken id <P>\r
+Type name ID is not on taken list in a prefix of one of the modules from SL chain of actual module. <P>\r
+ 319 - hidden identifier in the list id <P>\r
+Identifier ID from hidden or close list is on hidden list in one of the prefixing modules. <P>\r
+ 320 - identifier in the list not taken id <P>\r
+Identifer ID from hidden or close list is not placed on taken list in none of the prefixing modules. <P>\r
+ 321 - identifier cannot be taken id <P>\r
+Identifer ID from taken list is placed on taken list in none of the prefixes. <P>\r
+ 322 - hidden prefix identifier id <P>\r
+Analogical to 317 error. <P>\r
+ 323 - prefix identifier not taken id <P>\r
+Analogical to 318 error. <P>\r
+ 329 - only procedure and function may be virtual <P>\r
+ virtual specification appears with class specification. <P>\r
+ 330 - virtual in unprefixed block/procedure/function <P>\r
+ 331 - incompatible kinds of virtuals id <P>\r
+Kind of virtual module ID is different from kind of replaced module (e.g. one of them is a function, the other \r
+one is a procedure). <P>\r
+ 332 - incompatible types of virtuals id <P>\r
+ Type of virtual function ID is different from type of replaced function. <P>\r
+ 333 - different lengths of form.param.lists in virtuals id <P>\r
+Virtual module ID and replaced module have different number of formal parameters. <P>\r
+ 334 - conflict kinds of the 1st level parameters id <P>\r
+In the headline of virtual module ID kind of formal parameter differs from corresponding formal parameter in \r
+the headline of replaced module (e.g. type and variable, input and output parameters,.). <P>\r
+ 335 - incompatible types of the 1st level parameters id <P>\r
+There are formal parameters of different types (function, procedure) in the headline of virtual module ID \r
+and in the headline of replaced module on the same position. <P>\r
+ 336 - different lengths of the 2nd level params lists id <P>\r
+There are formal procedures/functions with different numbers of parameters in the headline of virtual \r
+module ID and in the headline of replaced module on the same position. <P>\r
+ 337 - incompatible kinds of the 2nd level parameters id <P>\r
+There are parameters of different kinds on the same position in the corresponding procedure or function \r
+parameters in the headline of virtual module ID and in the headline of replaced module. <P>\r
+ 338 - incompatible types of the 2nd level parameters id <P>\r
+There are parameters of different types on the same position in the corresponding procedure or function in the \r
+headline of virtual module ID and in the headline of replaced module. <P>\r
+ 341 - ***declaration part overloaded <P>\r
+Analogical to error 0. <P>\r
+ 342 - ***too many classes declared <P>\r
+ 343 - ***too many prototypes <P>\r
+Too many modules declared on the same level. <P>\r
+ 350 - undeclared signal identifier id <P>\r
+ 351 - hidden signal identifier id <P>\r
+Analogical to error 317. <P>\r
+ 352 - signal identifier not taken id <P>\r
+Analogical to error 318. <P>\r
+ 353 - signal identifier expected id <P>\r
+Identifier ID placed in handler declaration as a signal name has not been declared as a signal. <P>\r
+ 354 - different types of parameters id <P>\r
+In the headlines of signals, that have common handler, parameters of the different types appear on the same \r
+position. ID is one of these parameters. <P>\r
+ 355 - incompatible kinds of parameters id <P>\r
+In the headlines of signals that have common handler, parameters of different kinds appear on the same \r
+position. ID is one of these parameters. <P>\r
+ 356 - different identifiers of parameters id <P>\r
+In the headlines of signals that have common handler parameters of different names appear on the same \r
+position. ID is one of these parameters. <P>\r
+ 357 - incompatible kinds of the 2nd level parameters id <P>\r
+Analogous to error 355 for 2-nd level paramKters. <P>\r
+ 358 - different types of the 2nd level parameters id <P>\r
+Analogous to error 354 for the 2-nd level parameters. <P>\r
+ 359 - different lengths of the 2nd level params lists id <P>\r
+There are formal procedures or formal functions with different number of parameters on the same position in \r
+the headlines of signals this have common handler. ID is one of these formal parameters/functions. <P>\r
+ 360 - different lengths of form. param. lists in signals id <P>\r
+There are different number of formal parameters in the signals that have common handler. ID is one of these \r
+signals. <P>\r
+ 361 - non-local formal type cannot be used id <P>\r
+Formal parameter ID of signal is of non local formal type. <P>\r
+ 362 - repeated handler for signal id <P>\r
+There are more than one handler for signal ID in the same module. <P>\r
+ 370 - only 'input' is legal here <P>\r
+Formal parameter output or inout is illegal in process. <P>\r
+ 398 - class prefixed by itself id <P>\r
+Construction unit ID: ID class is not allowed. <P>\r
+ 399 - cycle in prefix sequence id <P>\r
+ID is a class identifier used in cyclic prefixing i.e. ID prefixes a, a prefixes b, ... , z prefixes ID. This \r
+construction is not allowed. <P>\r
+ 401 - wrong label in 'case' id <P>\r
+Label in case instruction is not a constant. <P>\r
+ 402 - 'case' statement nested too deeply <P>\r
+Nesting level in case instruction is greater than 6. <P>\r
+ 403 - too long span of 'case' labels <P>\r
+Range of branches in case instruction is greater than 160. <P>\r
+ 404 - repeated label in 'case'-statement id <P>\r
+Label ID appears more than once in case instruction. <P>\r
+ 405 - illegal type of 'case' expression id <P>\r
+Control expression in case statement is not of <P>\r
+ integer or char type. <P>\r
+ 406 - different types of labels and 'case' expression <P>\r
+ 407 - non-logical expression after 'if'/'while' id <P>\r
+ 408 - real constant out of integer range <P>\r
+Error during conversion of real constant to integer constant. <P>\r
+ 410 - simple variable expected id <P>\r
+Control variable in for loop is not a simple variable. <P>\r
+ 411 - non-integer control variable id <P>\r
+Control variable ID in for loop is not of integer type. <P>\r
+ 412 - non-integer expression id <P>\r
+Expression placed as array index or bound limit in array generation or as step in for loop or as format in \r
+write statement should be reducable to integer type. <P>\r
+ 413 - file expression expected id <P>\r
+ 414 - string expression expected id <P>\r
+ 415 - reference expression expected id <P>\r
+Expression placed before dot (remote access), before qua or as a argument of kill or copy statement is \r
+not of class type. <P>\r
+ 416 - array expression expected id <P>\r
+ 417 - boolean expression expected id <P>\r
+ 418 - semaphore variable expected <P>\r
+ 419 - illegal type in 'open' <P>\r
+The type name placed in open is different than TEXT, REAL, INTEGER, CHAR and DIRECT. <P>\r
+ 420 - variable expected id <P>\r
+Expression placed on the left side of assignment statement or as an argument of read instruction or in array \r
+instruction is not a variable. <P>\r
+ 421 - class identifier after 'new' expected id <P>\r
+Identifier ID placed after new is not a class identifier. <P>\r
+ 422 - procedure identifier after 'call' expected id <P>\r
+ 423 - 'new' missing id <P>\r
+Keyword new doesn't appear before class identifier for object generation. <P>\r
+ 424 - 'call' missing id <P>\r
+Keyword call doesn't appear before procedure identifier for procedure call. <P>\r
+ 425 - 'inner' out of a class <P>\r
+ 426 - 'inner' occurred more than once <P>\r
+ 427 - 'wind'/'terminate' out of a handler <P>\r
+ 428 - 'inner' inside lastwill <P>\r
+ 429 - definition cannot be reduced to constant id <P>\r
+Identifier ID placed in constant definition is not a constant. <P>\r
+ 430 - undefined constant in the definition id <P>\r
+ 431 - wrong number of indices id <P>\r
+Number of indices in referencing to array element is different from declared number of indices. <P>\r
+ 432 - index out of range id <P>\r
+ 433 - upper bound less than lower bound id <P>\r
+ 434 - too many subscripts id <P>\r
+Dimension of static array ID is greater than 7. <P>\r
+ 435 - variable is not array id <P>\r
+ 440 - type identifier expected after 'arrayof' id <P>\r
+Identifier ID placed after arrayof in actual parameter list, corresponding to type parameter is not a type name. \r
+<P>\r
+ 441 - incorrect format in 'write' <P>\r
+There is format for expression of char type or there is double format for expression of type integer or \r
+string. <P>\r
+ 442 - illegal expression in 'write' <P>\r
+Argument of write statement is not of type char, string, integer or real. <P>\r
+ 443 - illegal type of variable in 'read' id <P>\r
+Argument of read statement is not of type char, integer or real. <P>\r
+ 444 - no data for i/o transfer <P>\r
+There is only file identifier in I/O instruction. <P>\r
+ 445 - illegal expression in 'put' <P>\r
+ 446 - illegal expression in 'get' <P>\r
+ 448 - 'raise' missing id <P>\r
+There is signal identifier without keyword raise in the context of signal raising. <P>\r
+ 449 - signal identifier expected id <P>\r
+Identifer ID after keyword raise is not a signal identifier. <P>\r
+ 450 - illegal procedure occurrence id <P>\r
+Procedure name ID appears in illegal context. <P>\r
+ 451 - illegal class occurrence id <P>\r
+Class name ID appears in illegal context. <P>\r
+ 452 - illegal type occurrence id <P>\r
+Type name ID appears in illegal context. <P>\r
+ 453 - illegal signal occurrence id <P>\r
+Signal name ID appears in illegal context. <P>\r
+ 454 - illegal operator occurence <P>\r
+ 455 - wrong number of operands <P>\r
+ 460 - divided by zero <P>\r
+ 470 - illegal input parameter id <P>\r
+Actual parameter associated with input parameter is not expression that may have any value: it is e.g. \r
+procedure name <P>\r
+ 471 - illegal output parameter id <P>\r
+Actual parameter corredponded to output parameter is not a variable. <P>\r
+ 472 - illegal type parameter id <P>\r
+Actual parameter ID associated with type parameter is not a type name. <P>\r
+ 473 - illegal procedure parameter id <P>\r
+Actual parameter ID associated with procedure parameter is not a procedure name. <P>\r
+ 474 - illegal function parameter id <P>\r
+Actual parameter ID associated with function parameter is not a function name. <P>\r
+ 475 - illegal left side of 'is'/'in' id <P>\r
+Left side argument ID of is/in is not a reference expression. <P>\r
+ 476 - illegal right side od 'is'/'in' id <P>\r
+Right side argument ID of is / in is not a class name. <P>\r
+ 477 - illegal parameter of 'attach' id <P>\r
+Parameter ID of attach statement is not a reference variable of class object. <P>\r
+ 478 - illegal type of expression<P>\r
+ 479 - negative step value<P>\r
+ 550 - ***stack overloaded <P>\r
+This error may be removed by dividing expressions into subexpressions, making simpler nested callings of \r
+arrays, functions, classes and for loops. This error terminates compilation of current module, but other modules \r
+will be compiled. <P>\r
+ 551 - ***too many auxiliary variables needed <P>\r
+Too complicated expressions. This error may be removed by declaration of additional variables and using \r
+them as auxiliary variables in expressions. <P>\r
+ 552 - ***too many auxiliary reference variable needed <P>\r
+Analogical to error 551. <P>\r
+ 553 - ***statement sequence too long or too complicated <P>\r
+This error may be removed by adding 'goto' statement into sequence of instructions e.g. if false then exit fi, \r
+inner, ... or by dividing complicated expression into subexpressions. <P>\r
+ 554 - ***real constants dictionary overflow <P>\r
+Too many real constant, maybe because of evaluation of expressions built from real constants. <P>\r
+ 600 - undeclared identifier id <P>\r
+ 601 - illegal type before '.' id <P>\r
+Expression placed before dot (remote access) is not of class type. <P>\r
+ 602 - close identifier after '.' id <P>\r
+Identifier ID placed after dot is on close list in the class or its prefix that construct expression before dot. <P>\r
+ 603 - undeclared identifier after '.' id <P>\r
+Identifier ID placed after dot is not attribute of expression placed before dot. It may be caused by missing \r
+declaration or using bad prefix for class constructing expression before dot. <P>\r
+ 604 - illegal operand type id <P>\r
+One of the arguments in arithmetical expression or in relation is not of arithmetical type. <P>\r
+ 605 - illegal type in 'div/'mod' term id <P>\r
+Expression identified by ID used as argument of div or mode operation is not of integer type. <P>\r
+ 606 - incompatible types in comparison id <P>\r
+ID is an identifier of left argument of relation. <P>\r
+ 607 - unrelated class types in comparison id <P>\r
+ID is an identifier of left argument of relation. Both arguments are of class type and none of these classes \r
+prefixes the other one. <P>\r
+ 608 - string cannot be compared id <P>\r
+ID identifies a string. <P>\r
+ 609 - incompatible types in assignment/transmission id <P>\r
+ID is an identifier of left side of assignment statement or an identifier of actual parameter in object generation. \r
+Types of both sides of instruction or type of formal parameter and type of actual parameter are incompatible. \r
+<P>\r
+ 610 - unrelated class types in assignment/transmission id <P>\r
+Analogical to errors 609 and 607. <P>\r
+ 611 - constant after '.' id <P>\r
+An attempt to remote access to constant. <P>\r
+ 612 - this class does not occur in sl-chain id <P>\r
+ Class ID appeared in expression this ID, but ID dosn't prefix any module in SL chain of actual module. It \r
+may be a cycle. <P>\r
+ 613,614 - class identifier expected id <P>\r
+For error 613: identifier ID used in expression this ID is not of class type. For error 614: identifier ID used in \r
+expression this ID is not name of any type. <P>\r
+ 615 - illegal type before 'qua' id <P>\r
+ Object expression before qua should be of one of the types: class, coroutine, process or simple (not array) \r
+formal type. <P>\r
+ 616,617 - illegal type after 'qua' id <P>\r
+For error 616: identifier ID used after qua is not of any type. <BR>\r
+For error 617: identifier ID used after qua is not of class type. <P>\r
+ 618 - unrelated types in 'qua'-expression id <P>\r
+Identifier ID is a name of class type used after qua. This class type and class type used before qua doesn't \r
+prefix each other. <P>\r
+ 619 - hidden identifier id <P>\r
+Identifier ID used in construction qua ID or this ID is on hidden list in the prefix of one of the module from \r
+SL chain of actual module. <P>\r
+ 620 - not taken identifier id <P>\r
+Identifier ID used in construction qua ID or this ID is not on taken list in any prefix of any module of \r
+actual module. <P>\r
+ 621 - invisible identifier after '.' id <P>\r
+Identifier ID placed after dot is on hidden list or is not on taken list in prefix. <P>\r
+ 622 - formal parameter list is shorter id <P>\r
+Identifier ID identifies generated object: class, procedure or function. Formal parameters list of this object is \r
+shorter than actual parameters list. <P>\r
+ 623 - formal parameter list is longer id <P>\r
+Analogical to error 622. <P>\r
+ 624 - actual parameter is not a reference type id <P>\r
+Actual parameter identified by ID in generated object can't be of primitive type: integer, real, boolean or \r
+string. <P>\r
+ 625 - actual parameter is not a type id <P>\r
+Actual parameter identified by ID is not a type, so it can't replace formal type parameter. <P>\r
+ 626 - procedure-function conflict between parameters id <P>\r
+Actual parameter, identified by ID, that replaced formal parameter in generated object is function whereas \r
+formal parameter is a procedure or vice versa. <P>\r
+ 627 - unmatched heads-wrong kinds of parameters id <P>\r
+ID identifies actual module that replaced formal module. There are parameters of different kinds on the same \r
+position in the headlines of these modules. For input - output conflict the agreement of parameter types is \r
+checked also. <P>\r
+ 628 - unmatched heads-incompatible types in lists id <P>\r
+ID identifies actual module that replaced formal module. There are input /output parameters of different \r
+types on the same position in the headlines of actual and formal module. <P>\r
+ 629 - unmatched heads-unrelated class types in lists id <P>\r
+ID identifies actual module that replaced formal module. There are input/output parameters specifying \r
+classes of disjointed prefix sequences <P>\r
+in the headlines of actual and formal module. <P>\r
+ 630 - unmatched heads-different numbers of parameters id <P>\r
+There are different lengths of headlines in actual module identified by ID and formal module. <P>\r
+ 631 - incompatible types of function parameters id <P>\r
+There are different types of actual function specified by identifier ID and formal function in generated \r
+object. <P>\r
+ 632 - function/procedure expected id <P>\r
+Actual parameter identified by identifier ID is not function/procedure, whereas corresponding formal \r
+parameter is function/procedure. <P>\r
+ 633 - actual function type defined weaker than formal id <P>\r
+Type of actual function identified by ID is weaker defined than formal function type e.g. formal function \r
+type is statically defined, whereas actual function type is formal (external) or formal \r
+function is class, whereas actual function type is coroutine or process. <P>\r
+ 634 - unmatched heads-too weak type in actual list id <P>\r
+There are input/output parameters on the same position in the headlines of actual module identified by \r
+identifier ID and formal module, but ID is weaker defined than corresponding formal module parameter (see \r
+error 633). <P>\r
+ 635 - standard function/procedure cannot be actual par. id <P>\r
+ID identifies standard procedure/function used as actual parameter. <P>\r
+ 636 - illegal use of semaphore id <P>\r
+ 637 - 'semaphore' cannot be used id <P>\r
+<HR>\r
+<Address>BACK </Address> \r
+</BODY>\r
+</html>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>
+\r
+<HEAD>\r
+\r
+<TITLE>Loglan'82 home page</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1><IMG SRC="MicroMan/gifs/logo.gif" ALIGN=BOTTOM>
+Loglan'82 - programming with objects </H1>
+<HR>\r
+\r
+<H3>Loglan's home page </H3>
+<BR>
+Your ticket No.: <IMG SRC="/cgi-bin/Count.cgi?pad=0&dd=B|df=loghome.dat" align=absmiddle>
+<BR>
+<HR>\r
+\r
+<P>\r
+Loglan'82 is an object-oriented, universal, imperative programming\r
+language.<BR>\r
+It comes with Doc, Compilers (DOS, Unix, Atari,.), Examples etc.\r
+<BR>\r
+Four features of Loglan'82 make it original and interesting for\r
+everybody:\r
+<UL>\r
+<LI><A href="whylog.htm#mli">Multi-LEVEL Inheritance </A>\r
+<LI><A href="whylog.htm#mki">Multi-kind Inheritance </A>\r
+<LI><A href="whylog.htm#saf">SAFETY ! </A>\r
+<LI><A href="whylog.htm#conc">Object-Oriented CONCURRENCY</A>\r
+\r
+</UL>\r
+\r
+<P>\r
+<HR>\r
+\r
+<H2>INDEX</H2>\r
+
+<P ALIGN=justify>
+<SMALL>\rA SUGGESTION: Use recent versions of Mosaic or Netscape viewers
+in order to read the tables we prepared for you.<BR>
+For those who can not see the tables there are ASCII versions
+of tables as well as postscript files</SMALL>
+
+<P>
+
+<ul>\r
+<LI><A href="whylog.htm">Why Loglan'82? Should I be acquainted with it? </A>\r
+\r
+\r
+
+\r
+\r
+<LI><A href="quick.htm">a Quick Reference Card of Loglan'82</A>\r
+
+<UL>
+<LI>a postscript version is <A href="quickref.ps.Z"> here</A> \r
+<LI>thou viewst just <A href="quickref.txt"> ascii file</A>\r
+</UL>
+\r
+ \r
+<LI><A href="tablica3.htm">a short comparison with other OO languages</A>\r
+\r
+<UL>
+<LI>a postscript version is <A href="comptble.ps.Z">here</A> \r
+<LI>thou viewst just <A href="tablica3.txt">ascii file</A> \r
+</UL>
+
+\r
+\r
+<LI><A href="MicroMan/HomePage.htm">A micro-manual of Loglan'82</A>\r
+\r
+<LI><A href="availlty.htm">How to get a copy of Loglan'82 system? </A>\r
+<LI><A href="platform.htm">existing platforms </A>\r
+\r
+<UL>
+<LI><A href="platform.htm#dos">DOS</A> \r
+<LI><A href="platform.htm#unix">Unix</A> \r
+<LI><A href="platform.htm#ata">Atari</A> \r
+<LI><A href="platform.htm#othe">others</A> \r
+</UL>
+
+\r
+<LI><A href="openpbms.htm">research problems related to Loglan'82 </A>\r
+\r
+<UL>
+<LI>solved ones\r
+<LI>open ones\r
+</UL>
+
+\r
+<LI><A href="/drFun.html">Dr Fun or the mysteries of "scientific" bureaucracy </A>\r
+<LI><A href="credits.htm">a short history of Loglan'82 project </A>\r
+<LI><A href="solate.htm">why I learn so late on Loglan'82? </A>\r
+<LI><A HREF="/loglan/biuletyn/index.html" METHODS="http">Loglan News</A>
+\r
+</ul>
+\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://aragorn.pb.bialystok.pl/~salwicki/">AS</A> last\r
+update Sun 21 May 1995 \r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>
+\r
+<HEAD>\r
+\r
+<TITLE>Loglan'82 home page</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1><IMG SRC="MicroMan/gifs/logo.gif" ALIGN=BOTTOM>
+Loglan'82 - programming with objects </H1>
+<HR>\r
+\r
+<H3>Loglan's home page </H3>\r
+<HR>\r
+\r
+<P>\r
+Loglan'82 is an object-oriented, universal, imperative programming\r
+language.<BR>\r
+It comes with Doc, Compilers (DOS, Unix, Atari,.), Examples etc.\r
+<BR>\r
+Four features of Loglan'82 make it original and interesting for\r
+everybody:\r
+<UL>\r
+<LI><A href="whylog.htm#mli">Multi-LEVEL Inheritance </A>\r
+<LI><A href="whylog.htm#mki">Multi-kind Inheritance </A>\r
+<LI><A href="whylog.htm#saf">SAFETY ! </A>\r
+<LI><A href="whylog.htm#conc">Object-Oriented CONCURRENCY</A>\r
+\r
+</UL>\r
+\r
+<P>\r
+<HR>\r
+\r
+<H2>INDEX</H2>\r
+
+<P ALIGN=justify>
+<SMALL>\rA SUGGESTION: Use recent versions of Mosaic or Netscape viewers
+in order to read the tables we prepared for you.<BR>
+For those who can not see the tables there are ASCII versions
+of tables as well as postscript files</SMALL>
+
+<P>
+
+<ul>\r
+<LI><A href="whylog.htm">Why Loglan'82? Should I be acquainted with it? </A>\r
+\r
+\r
+
+\r
+\r
+<LI><A href="quick.htm">a Quick Reference Card of Loglan'82</A>\r
+
+<UL>
+<LI>a postscript version is <A href="quickref.ps.Z"> here</A> \r
+<LI>thou viewst just <A href="quickref.txt"> ascii file</A>\r
+</UL>
+\r
+ \r
+<LI><A href="tablica3.htm">a short comparison with other OO languages</A>\r
+\r
+<UL>
+<LI>a postscript version is <A href="comptble.ps.Z">here</A> \r
+<LI>thou viewst just <A href="tablica3.txt">ascii file</A> \r
+</UL>
+
+\r
+\r
+<LI><A href="MicroMan/HomePage.htm">A micro-manual of Loglan'82</A>\r
+\r
+<LI><A href="availlty.htm">How to get a copy of Loglan'82 system? </A>\r
+<LI><A href="platform.htm">existing platforms </A>\r
+\r
+<UL>
+<LI><A href="platform.htm#dos">DOS</A> \r
+<LI><A href="platform.htm#unix">Unix</A> \r
+<LI><A href="platform.htm#ata">Atari</A> \r
+<LI><A href="platform.htm#othe">others</A> \r
+</UL>
+
+\r
+<LI><A href="openpbms.htm">research problems related to Loglan'82 </A>\r
+\r
+<UL>
+<LI>solved ones\r
+<LI>open ones\r
+</UL>
+
+\r
+<LI><A href="/drFun.html">Dr Fun or the mysteries of "scientific" bureaucracy </A>\r
+<LI><A href="credits.htm">a short history of Loglan'82 project </A>\r
+<LI><A href="solate.htm">why I learn so late on Loglan'82? </A>\r
+<LI><A HREF="/biuletyn/index.html" METHODS="http">Loglan News</A>
+\r
+</ul>
+\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://aragorn.pb.bialystok.pl/~salwicki/">AS</A> last\r
+update Sun 21 May 1995 \r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>
+\r
+<HEAD>\r
+\r
+<TITLE>Loglan'82 home page</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1><IMG SRC="MicroMan/gifs/logo.gif" ALIGN=BOTTOM>
+Loglan'82 - programming with objects </H1>
+<HR>\r
+\r
+<H3>Loglan's home page </H3>\r
+<HR>\r
+\r
+<P>\r
+Loglan'82 is an object-oriented, universal, imperative programming\r
+language.<BR>\r
+It comes with Doc, Compilers (DOS, Unix, Atari,.), Examples etc.\r
+<BR>\r
+Four features of Loglan'82 make it original and interesting for\r
+everybody:\r
+<UL>\r
+<LI><A href="whylog.htm#mli">Multi-LEVEL Inheritance </A>\r
+<LI><A href="whylog.htm#mki">Multi-kind Inheritance </A>\r
+<LI><A href="whylog.htm#saf">SAFETY ! </A>\r
+<LI><A href="whylog.htm#conc">Object-Oriented CONCURRENCY</A><EM>\r
+</EM>\r
+</UL>\r
+\r
+<P>\r
+<HR>\r
+\r
+<H2>INDEX</H2>\r
+\r
+<DIR>\r
+<LI><A href="whylog.htm">Why Loglan'82? Should I be acquainted with it? </A>\r
+\r
+\r
+<H6>A SUGGESTION: Use recent versions of Mosaic or Netscape viewers\r
+in order to read the tables we prepared for you.<BR>\r
+For those who can not see the tables there are ASCII versions\r
+of tables as well as postscript files </H6>\r
+\r
+\r
+<LI><A href="quick.htm">a Quick Reference Card of Loglan'82</A>\r
+<ul>\r
+<LI>a postscript version is <A href="quickref.ps.Z">here</A> \r
+<LI>thou viewst just<A href="quickref.txt">ascii file</A>\r
+</ul>\r
+ \r
+<LI><A href="tablica3.htm">a short comparison with other OO languages</A>\r
+<ul>\r
+<LI>a postscript version is <A href="comptble.ps.Z">here</A> \r
+<LI>thou viewst just <A href="tablica3.txt">ascii file</A> \r
+</ul>\r
+\r
+<LI><A href="MicroMan/HomePage.htm">A micro-manual of Loglan'82</A>\r
+\r
+<LI><A href="availlty.htm">How to get a copy of Loglan'82 system? </A>\r
+<LI><A href="platform.htm">existing platforms </A>\r
+<ul>\r
+<LI><A href="platform.htm#dos">DOS</A> \r
+<LI><A href="platform.htm#unix">Unix</A> \r
+<LI><A href="platform.htm#ata">Atari</A> \r
+<LI><A href="platform.htm#othe">others</A> \r
+</ul>\r
+\r
+<LI><A href="openpbms.htm">research problems related to Loglan'82 </A>\r
+<ul>\r
+<LI>solved ones\r
+<LI>open ones\r
+</ul>\r
+\r
+<LI><A href="/drFun.html">Dr Fun or the mysteries of "scientific" bureaucracy </A>\r
+<LI><A href="credits.htm">a short history of Loglan'82 project </A>\r
+<LI><A href="solate.htm">why I learn so late on Loglan'82? </A>\r
+</UL>\r
+</dir>\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS</A> last\r
+update Sun 21 May 1995 \r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
+p
\ No newline at end of file
--- /dev/null
+<html>\r
+<HEAD><TITLE>iiuwgraph</TITLE></HEAD>\r
+<H1 align=center>unit IIUWGRAPH: class;</H1>\r
+<H2>a predefined Loglan'82 <IMG SRC="http://www.univ-pau.fr/~salwicki/loglanmm.gif" ALT="LOGLAN"></IMG> class </H2>\r
+\r
+{ this predefined class enables basic graphic operations\r
+ for DOS machines based on <B>486 </B> or 386 processors \r
+}<P>\r
+\r
+{this document gives the specification of new version of IIUWGRAPH \r
+ class<BR>\r
+ made in October 1994 by <B><I>Frederic Pataud </I></B>à Pau}<P>\r
+<HR>\r
+<A NAME="Table of Contents"><B>Table of Contents</B></A>.<BR>\r
+\r
+\r
+<UL>\r
+<LI>unit <A HREF = "#GRON">GRON</A> : procedure (i: integer);\r
+<LI>unit <A HREF = "#GROFF">GROFF</A> : procedure;\r
+<LI>unit <A HREF = "#CLS">CLS</A> : procedure;\r
+<LI>unit <A HREF = "#COLOR">COLOR</A> : procedure(co : integer);\r
+<LI>unit <A HREF = "#STYLE">STYLE</A> : procedure(styl : integer);\r
+<LI>unit <A HREF = "#BORDER">BORDER</A> : procedure (background_Colour: integer);\r
+<LI>unit <A HREF = "#PALLET">PALLET</A> : procedure (nr : integer);\r
+<LI>{ PROCEDURES CONTROLLING POSITION }\r
+<LI>unit <A HREF = "#MOVE">MOVE</A> : procedure (x,y :integer);\r
+<LI>unit <A HREF = "#INXPOS">INXPOS</A> : function: integer;\r
+<LI>unit <A HREF = "#INYPOS">INYPOS</A> : function : integer;\r
+<LI>unit <A HREF = "#PUSHXY">PUSHXY</A> : procedure;\r
+<LI>unit <A HREF = "#POPXY">POPXY</A>: procedure;\r
+<LI>{ PROCEDURES SERVING POINTS LINES}\r
+<LI>unit <A HREF = "#POINT">POINT</A> : procedure(x,y: integer);\r
+<LI>unit <A HREF = "#INPIX">INPIX</A> : function (x,y : integer) : integer;\r
+<LI>unit <A HREF = "#DRAW">DRAW</A> : procedure( x,y : integer);\r
+<LI>unit <A HREF = "#intens">intens</A>: procedure(Size :integer; xCoord,yCoord:arrayof integer, \r
+Colour,Filled :integer);\r
+<li>unit <a href="#CIRB">cirb </a> {draw a circle} procedure;\r
+<LI>unit <A HREF = "#HFILL">hfill</A>: procedure( x : integer);\r
+<LI>unit <A HREF = "#VFILL">vfill</A>: procedure( y : integer);\r
+<LI>unit <A HREF = "#PATERN">patern</A>: procedure( x1,y1,x2,y2,c,b : integer);\r
+<LI>{ Procedures operating on bitmaps }\r
+<LI>unit <A HREF = "#GETMAP">GETMAP </A> : function (x,y : integer) : arrayof integer;\r
+<LI>unit <A HREF = "#PUTMAP">PUTMAP </A> : procedure ( a: arrayof integer);\r
+<LI>unit <A HREF = "#ORMAP">ORMAP </A> : procedure ( a : arrayof integer);\r
+<LI>unit <A HREF = "#XORMAP">XORMAP </A> : procedure ( a: arrayof integer);\r
+<LI>{Procedures operating on characters and strings}\r
+<LI>unit <A HREF = "#outstring">outstring</A>: procedure(x,y: integer, s: string, back_col, front_col: \r
+ integer);\r
+<LI>unit <A HREF = "#track">track</A>: procedure( x,y,c,valeur : integer);\r
+<LI>unit <A HREF = "#inkey">inkey </A> : function : integer;\r
+<LI>unit <A HREF = "#HASCII">HASCII </A> : procedure(c: integer);\r
+<LI>unit <A HREF = "#hfont">hfont</A>: function( x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;\r
+<LI>unit <A HREF = "#hfont8">hfont8</A>: function( x,y,lg,maxlg: integer,\r
+default: arrayof char,col_f,col_e,col_c : integer): arrayof char;\r
+<LI>unit <A HREF = "#HPAGE">HPAGE </A> : procedure(x,y,long: integer, A: arrayof char, back, front: \r
+ integer);\r
+<LI>unit <A HREF = "#MOUSE">MOUSE</A>: class;\r
+<LI>unit <A HREF = "#init">init</A>: procedure(checkMouse, checkKeyboard: integer);\r
+<LI>unit <A HREF = "#getmovement">getmovement</A>: procedure(checkMouse, checkKeyboard: \r
+ integer);\r
+<LI>unit <A HREF = "#getpress">getpress</A>: function(v,p,h,l,r,c : integer): Boolean;\r
+<LI>unit <A HREF = "#showcursor">showcursor</A>: procedure;\r
+<LI>unit <A HREF = "#hidecursor">hidecursor</A>: procedure;\r
+<LI> <A HREF = "#sample program">a sample program</A>\r
+</UL>\r
+\r
+<HR>\r
+\r
+\r
+\r
+{ the early versions of library IIUWGRAPH have been elaborated by \r
+ Piotr Carlsson, Miroslawa Milkowska, Janina Jankowska, \r
+ Michal Jankowski at Institute of Informatics, \r
+ University of Warsaw 1987,<P>\r
+ and added to Loglan system by Danuta Szczepanska 1987, <P>\r
+ \r
+ the recent versions were done at LITA, Pau,<P>\r
+ by<P>\r
+ Pawel Susicki (1991) for Unix,<P>\r
+ Sebastien Bernard (1992) for ATARI, see a separate document,<BR>\r
+ Eric Becourt et Jerôme Larrieu (1993) for Unix and Xwindows, see a \r
+ separate document on Xiiuwgraf ,\r
+ <P>\r
+ \r
+<P align=right>\r
+fait à Pau, le 15 Novembre 1994, par Andrzej Salwicki, LITA}<P align=left>\r
+\r
+{ the predefined class IIUWGRAPH is included in all versions of interpreter of \r
+Loglan, with the <I>exception</I> of the present version of interpreter for \r
+VAX/VMS.}<P>\r
+<HR> \r
+<P>\r
+<PRE>\r
+<B>hidden</B> MaxX, MaxY, current_X, current_Y, is_graphic_On, \r
+ current_Colour, current_Background_Colour, current_Style, \r
+ current_Palette, current_Pattern ; \r
+\r
+\r
+ \r
+<B>const</B> MaxX = \r
+ MaxY = \r
+\r
+{ the screen's coordinates are \r
+ \r
+ (0,0) ----------------------> (MaxX,0) \r
+ ¦ \r
+ ¦ \r
+ ¦ \r
+ V \r
+ (0, MaxY) (MaxX,MaxY) \r
+\r
+}\r
+ \r
+\r
+<B>var</B> currentDriver : integer, { see NOCARD below } \r
+ current_X, current_Y: integer { it is the current position } \r
+ is_graphic_On: Boolean, { evidently tells whether we are in \r
+ graphics mode } \r
+ current_Colour : integer, { } \r
+ current_Background_Colour : integer, \r
+ current_Style : integer, { } \r
+ current_Palette : integer, \r
+ current_Pattern \r
+</PRE>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="GRON"> GRON </A> <B> procedure </B> \r
+(i: integer);</H2>\r
+ { procedure sets the monitor in graphic mode and clears the buffer \r
+ of screen. The parameter determines the resolution and the number of \r
+ colours.<BR>\r
+The user should assure that the resolution chosen should correspond to that \r
+which is set by means of command <BR>\r
+SET go32 drivers {path}< driver.file> < width> < height> < \r
+noColours> \r
+eg.<BR>\r
+set go32 drivers c:\loglan\svga\drivers\vesa.grn gw 1024 gh 480 nc 256<BR>\r
+<P> An execution of instruction call gron(i) <B><I>must precede</I> \r
+</B> any of the graphic commands described below.<P>\r
+<PRE>\r
+case (i)\r
+ {\r
+ 0 : 640x480x16\r
+ 1 : 640x480x256\r
+ 2 : 800x600x16\r
+ 3 : 800x600x256\r
+ 4 : 1024x768x16\r
+ 5 : 1024x768x256\r
+ 6 : 1280x1024x16\r
+ 7 : 1280x1024x256\r
+ 8 : 1600x1280x16\r
+ 9 : 1600x1280x256\r
+ }\r
+</PRE> \r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="GROFF"> GROFF </A><B> procedure </B>; </H2>\r
+ { the procedure sets the monitor in the text mode filling it with \r
+ spaces.<P>\r
+ DO NOT FORGET to set the monitor in the text mode before \r
+you terminate your program<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A NAME="CLS"> CLS </A> . \r
+: <B> procedure</B>;</H2>\r
+ { the screen will be cleared and filled with colour 0 }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A><P>\r
+\r
+\r
+\r
+<H2>{ PROCEDURES CONTROLLING THE COLOURS }</H2>\r
+<P>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="COLOR"> COLOR </A> : \r
+<B> procedure</B>(co : integer);</H2>\r
+{ sets current color to co <BR>\r
+ for monochrome displays, 0 means black, non-0 - white<BR>\r
+ for color displays, 0 means background<BR>\r
+ see PALLET<P>\r
+} <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="STYLE"> STYLE </A> : \r
+<B> procedure</B>(styl : integer);</H2>\r
+{ sets style of lines and fill shades to a combination<P>\r
+ of current color and background color (for mono -<P>\r
+ white and black, respectively) according to 5 predefined<P>\r
+ patterns:<P>\r
+<PRE>\r
+ 0 ....\r
+ 1 ****\r
+ 2 ***.\r
+ 3 **..\r
+ 4 *.*.\r
+ 5 *...\r
+</PRE>\r
+ where '*' means current color, '.' background colour<P>\r
+When drawing the segments the subsequent pixels will have colour determined \r
+by cyclic application of style pattern. The first and the last pixels of a segment \r
+will have always current colour.<P>\r
+When filling contours the given style will be applied to horizontal lines with even \r
+coordinate. The style for odd lines is determined automatically.<P>\r
+The same applies for perpendicular lines.<P>\r
+}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="BORDER"> BORDER </A> . : \r
+<B>procedure</B> (background_Colour: \r
+integer);</H2>\r
+ \r
+<P> { sets actual background color to i ( i = 0,1,...,15 ) }<P>\r
+\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PALLET"> PALLET </A> : \r
+<B>procedure</B> (nr : integer);</H2>\r
+ {the following line makes an example, it is not valid for, say,\r
+256 colours\r
+<P>\r
+the codes of colors are <I>usually i.e. when you have 16 colours,</I> as follows<P>\r
+<PRE>\r
+ 0 black\r
+ 1 blue dark\r
+ 2 green dark\r
+ 3 turquoise dark\r
+ 4 red dark\r
+ 5 violet\r
+ 6 brown\r
+ 7 grey light\r
+ 8 grey dark \r
+ 9 blue\r
+ 10 green\r
+ 11 turquoise\r
+ 12 red light\r
+ 13 rose\r
+ 14 yellow\r
+ 15 white\r
+</PRE> }\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+\r
+<H2>{ PROCEDURES CONTROLLING POSITION }</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="MOVE">MOVE</A> : \r
+<B>procedure</B> (x,y :integer);</H2>\r
+ { procedure MOVE sets the current position on the screen on the pixel \r
+ with coordinates<P>\r
+ x - column,<P>\r
+ y - line }<P>\r
+ { precondition of MOVE:\r
+ <I>0<x<MaxX & 0<y<MaxY </I>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="INXPOS">INXPOS</A> : \r
+<B>function</B>: integer;</H2>\r
+ { function INXPOS returns the x coordinate of the current position }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A \r
+NAME="INYPOS">INYPOS</A> : \r
+<B>function</B> : integer;</H2>\r
+ { function INYPOS returns the y coordinate of the current position }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PUSHXY">PUSHXY</A> : \r
+<B>procedure</B>;</H2>\r
+{ pushes current position, color & style onto the stack.<P>\r
+ The stack is kept internally, max depth is 16<P>\r
+}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A \r
+NAME="POPXY">POPXY</A> : \r
+<B>procedure</B>;</H2>\r
+\r
+{ restores position, color & style from internal stack }<P>\r
+\r
+{ Example<P>\r
+<PRE>unit DIAGONAL : procedure;\r
+ var ix, iy : integer;\r
+begin\r
+ call PUSHXY;\r
+ ix := INXPOS;\r
+ iy := INYPOS;\r
+ call DRAW(ix+10, iy+10);\r
+ call POPXY\r
+end DIAGONAL;\r
+</PRE>}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2>{ PROCEDURES SERVING POINTS & \r
+LINES}</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="POINT">POINT</A> : \r
+<B>procedure</B>(x,y: integer);</H2>\r
+{ moves current position to pixel (x,y) and sets it to the current color \r
+<P>\r
+ }<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="INPIX">INPIX</A> : <B>function</B> \r
+(x,y : integer) : integer;</H2>\r
+ { <P>\r
+ moves to pixel (x,y) and returns its color setting;<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="DRAW">DRAW</A> : \r
+<B>procedure</B>( x,y : integer);</H2>\r
+ { <P>\r
+ draws a line from current screen position to (<I>x,y</I>);<P>\r
+ sets current position to (<I>x,y</I>);<P>\r
+ line is drawn in current color, with both terminal pixels<P>\r
+ always turned white ( non-background) for non-black<P>\r
+ ( non-background ) line color.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="intens">intens</A> : \r
+<B>procedure</B>(Size :integer; \r
+xCoord,yCoord:arrayof integer, Colour,Filled \r
+:integer);</H2>\r
+ \r
+/* draw a polygon*/\r
+{ draw a simple, closed polygon of Size points, the edges of the polygon go from \r
+(<I>xCoord[i], yCoord[i]</I>) to (<I>xCoord[i+1], yCoord[i+1]</I>) for i = 1, ..., Size-1\r
+The colour used will be <I>Colour</I>. The polygon will be filled iff <I>Filled</I>< \r
+> 0.\r
+}<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<BR><P>\r
+<H2><B>unit </B><A NAME="CIRB"> CIRB</A> : <B>procedure</B> (xi, yi, rx,ry : integer, alfa, beta : real, \r
+cbord, fill : integer);<P></H2>\r
+\r
+\r
+ {\r
+<P> draws a circle (or ellipse, depending on aspect value, see below),<P>\r
+ optionally filling its interior; <P>\r
+ does not preserve position;<P>\r
+ (<I>xi,yi</I>) - are center coordinates,<P>\r
+ <I>rx</I> - radius in pixels (horizontally),<BR>\r
+ <I>ry</I> - radius in pixels (perpendicularly),<P>\r
+ <I>alfa, beta</I> - starting & ending angles; if alfa=beta a full<P>\r
+ circle is drawn; values should be given in radians;<P>\r
+ <I>cbord</I> - border color,<P>\r
+ <I>fill</I> - if fill < > 0, interior is filled in current style& color<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A NAME="hfill">hfill</A> : \r
+<B>procedure</B>( x : integer);</H2>\r
+ { draw an horizontal line between the current position and<P>\r
+ (x,currentY) with the current color, after it change the current<P>\r
+ position to (x, currentY)<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A NAME="vfill">vfill</A> : \r
+<B>procedure</B>( y : integer);</H2>\r
+ { draw a vertical line between the current position and<P>\r
+ (currentX,y) with the current color, after it change the current<P>\r
+ position to (currentX,y)<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="patern">patern</A> : \r
+<B>procedure</B>( x1,y1,x2,y2,c,b : \r
+integer);</H2>\r
+ { draw a <B><I>rectangle</I></B> between the points (<I>x1,y1</I>) and \r
+(<I>x2</I>,<I>y2</I>) with the<P>\r
+ color <I>c</I> (the current color is not change). if <I>b</I>=0 then the box \r
+is<P>\r
+ empty else it is filled.<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2>{ Procedures operating on bitmaps }</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="GETMAP">GETMAP</A> : \r
+<B>function</B> (x,y : integer) : <B>arrayof</B> \r
+integer;</H2>\r
+ {saves rectangular area between current position as<P>\r
+ top left corner and (ix,iy) as bottom right corner,<P>\r
+ including border lines;<P>\r
+ position remains unchanged.<P>\r
+ array of integer should have <P>\r
+ 4+(rows**columns/8* *coeff)<P>\r
+ bytes. The coefficient coeff is 1 for Hercules, 2 for CGA, 4 for EGA<P>\r
+ card.<P>\r
+ ATTENTION: in DOS 286 environment a bigger size of the array may \r
+ necessitate the use of <I>loglan</I> with<I> the option H+</I>, see also \r
+memavail <P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PUTMAP">PUTMAP</A> : \r
+<B>procedure</B> ( a: <B>arrayof</B> \r
+integer);</H2>\r
+ {sets rectangular area of screen pixels to that saved<P>\r
+ by "getmap" in "iarray";<P>\r
+ same size is restored, with top left corner in current<P>\r
+ position;<P>\r
+ position remains unchanged.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="ORMAP">ORMAP</A> : \r
+<B>procedure</B> ( a : <B>arrayof \r
+</B>integer);</H2>\r
+ {same as putmap, but saved bitmap is or'ed into screen<P>\r
+ rather than just set.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A NAME="XORMAP \r
+">XORMAP </A> : <B>procedure</B> ( a: \r
+<B>arrayof</B> integer);</H2>\r
+ {same as putmap, but saved bitmap is xor'ed into screen<P>\r
+ rather than just set.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+<H2>{Procedures operating on characters and strings}</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="outstring">outstring</A> : \r
+<B>procedure</B>(x,y: integer, s: string, back_col, \r
+front_col: integer);</H2>\r
+ { <I>x, y</I> are the coordinates where to put the string,<P>\r
+ <I>s</I> is the string to be shown, in <I>front_col</I> colour letters on the \r
+<I>back_col</I> colour background<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="track">track</A> \r
+: <B>procedure</B>( x,y,c,valeur : integer);\r
+</H2>\r
+ { write an integer value <I>valeur</I> at the position (<I>x,y</I>) with the \r
+color <I>c</I>.\r
+ It does not change the current position nor the current color<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="inkey ">inkey \r
+</A> : <B>function</B> : integer;</H2>\r
+\r
+ { returns next character from keyboard buffer;<P>\r
+ 0 is returned if buffer is empty;<P>\r
+ special keys are returned as negative numbers;<P>\r
+ ALT-NUM method may be used for entering character codes<P>\r
+ above 127 (this makes entering special keys 128-132<P>\r
+ impossible);<P>\r
+ if a character is returned, it is also removed<P>\r
+ from the buffer, so MS-DOS will not see it (CTRL-C!);<P>\r
+ typeahead is allowed, echo is suppressed.<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="HASCII \r
+">HASCII </A> : <B>procedure</B>(c: \r
+integer);</H2>\r
+ {'xor's the character = chr(c) in a 8*8 box with top left corner<P>\r
+ in the current position;<P>\r
+ moves current position by (8,0);<P>\r
+ call hascii(0)- sets complete box to black ( =background ),<P>\r
+ with no change in position.<P>\r
+}\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+\r
+<H2><B>unit </B><A NAME="hfont">hfont</A> \r
+: <B>function</B>( \r
+x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;</H2>\r
+\r
+ { arrange a small 1 line window for <B><I>reading</I></B> an integer value \r
+from this window,\r
+the position of the window corner is (<I>x, y</I>),\r
+the length of the window is <I>lg</I> characters,\r
+the value v should be greater than <I>min</I> and smaller than <I>max</I>,\r
+the default value read is <I>default</I>,<P>\r
+the colour of the window is <I>col_f</I>,<BR>\r
+the colour of the digits is <I>col_e,</I><BR>\r
+the colour of cursor is <I>col_c</I><P>\r
+\r
+ reads in graphic mode an integer in the window which begins at the (x,y)\r
+ position, window is lg caracteres long. the maximum length of the<P>\r
+ integer that is read is 10. there is a default value, a minimum value\r
+ and a maximum value. the window is drawn with the col_f color, the \r
+ cursor is in the col_c color and the integer is writing in the col_e<P>\r
+ color. you can use 0..9,+,-,backspace,escape and return keys. }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A NAME="hfont8">hfont8</A> \r
+: <B>function</B>( \r
+x,y,lg,maxlg: integer,default: arrayof char,\r
+col_f,col_e,col_c : integer): arrayof char;</H2>\r
+\r
+ { arrange a small 1 line window for <B><I>reading</I></B> an array of characters (<I>text</I>) \r
+from this window,\r
+the position of the window corner is (<I>x, y</I>),\r
+the length of the window is <I>lg</I> characters,\r
+the text should not be longer than <I>maxlg</I> characters,\r
+the default text shown is <I>default</I>,<P>\r
+the colour of the window is <I>col_f</I>,<BR>\r
+the colour of the digits is <I>col_e,</I><BR>\r
+the colour of cursor is <I>col_c</I><P>\r
+\r
+ reads in graphic mode a text (i.e. an array of characters)\r
+ in the window which begins at the (x,y)\r
+ position, window is lg caracteres long. the maximum length of the\r
+ text that is read is maxlg. there is a default text shown,\r
+ the window is drawn with the col_f color, the \r
+ cursor is in the col_c color and the integer is writing in the col_e<P>\r
+ color.<P> You can use 0..9,+,-,backspace,escape and return keys. }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A NAME="HPAGE \r
+">HPAGE </A> : <B>procedure</B>(x,y,long: \r
+integer, A: arrayof char, back, front: integer);</H2>\r
+ { this procedure arranges a 1-line high window in position <I>x,y</I> of \r
+length <I>long</I> in which a portion of text <I>A</I> is shown in colour \r
+<I>front</I> on the background colour <I>back</I>. <P>\r
+ Making use of keys controlling the cursor {left, right, PgUp, PgDn}<P>\r
+ the user can scroll the text (horizontally) in the window. Pressing the \r
+ Enter key terminates the procedure} <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<P align=left><B>end</B> IIUWGRAPH;<P>\r
+\r
+\r
+\r
+<HR>\r
+<P><H2><B>unit </B> <A \r
+NAME="MOUSE">MOUSE</A> : \r
+<B>class</B>; </H2>\r
+ <P>\r
+<I>You can safely skip the following french text if you can not read french.<BR>\r
+It is put here for the convenience of my french students.<BR>\r
+</I>\r
+\r
+<HR>\r
+<H6>{ <I>init</I> -lors de l'initialisation de la souris, on peut définir les événements qui vont faire réagir la \r
+fonction getpress; le premier et le deuxième paramètre représentent respectivement la souris et le clavier, si une \r
+valeur non nulle est donnée comme paramètre alors getpress réagira à l'événement.<P>\r
+\r
+ Une paire (1,1) va permettre de prendre en compte à la fois les événements de la souris et ceux du clavier; \r
+une paire (1,0) quand à elle ne prendra en compte que la souris. Pour une plus grande souplesse d'utilisation, il est \r
+possible lors du programme, après l'initalisation, de changer cette prise en compte, cela se fera par l'appel de la \r
+procedure <I>getmovement</I>, procédure ayant les mêmes paramètres (avec le même ordre) que la fonction \r
+init.<P>\r
+\r
+ Pour detecter les événements, on utilisa la fonction <I>getpress</I>, qui retourne un booléen indiquant la \r
+présence ou l'absence d'événement (respectivement les valeurs true et false). Il est bon de noter qu'ainsi définie la \r
+fonction getpress n'est pas bloquante. Les paramètres en retour sont soit nuls (pas d'événement) soit \r
+correspondent:<P>\r
+\r
+ bool:=getpress(v,p,h,l,r,c : integer);<P>\r
+ v = position en y de la souris<P>\r
+ p = keyboard status (Touche control_left,control_right, alt, alt_gr, shift_left, shift_right)<P>\r
+ h = position en x de la souris<P>\r
+ l = touche clavier<P>\r
+ r = flags<P>\r
+ c = boutons de la souris (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)<P>\r
+ Nb: le bouton central n'est pas géré.<P>\r
+\r
+NOTEZ BIEN! Lorsque les événements du clavier sont pris en compte dans \r
+le gestionnaire, <B>il ne faut \r
+pas </B>utiliser les fonctions d'entrées clavier readl, readln, hfont, hfont8, hpage, inkey,...) <I>sous peine de \r
+plantage de l'ordinateur</I>.<P>\r
+}</H6>\r
+<HR>\r
+<P>\r
+<H2> <B>unit </B> <A NAME="init">init</A> \r
+: <B>procedure</B>(checkMouse, \r
+checkKeyboard: integer); </H2>\r
+ { initializes the Mouse driver.<P>\r
+ tells which events will be checked:<P>\r
+ if checkMouse < > 0 then the events of Mouse will be \r
+reported to <A HREF = "#getpress">getpress</A>, otherwise \r
+ignored;<P>\r
+ if checkKeyboard < > 0 then the events of Keyboard will be \r
+reported to getpress, otherwise ignored<P>\r
+ <B><I>Attention please!</I></B> While the events of \r
+the keyboard are taken under control by \r
+<I>init</I> or <I>getmovement</I><P>\r
+ <B><I>do not use</I></B> the functions or procedures: read,\r
+ readln, hfont, hfont8, hpage, inkey \r
+that read keys<P>\r
+ YOU RISK TO HANG YOUR SYSTEM!<P>\r
+<B> }</B><P>\r
+ <B>end</B> init <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B> unit </B><A \r
+NAME="getmovement">getmovement</A> : \r
+<B>procedure</B>(checkMouse, checkKeyboard: \r
+integer); </H2>\r
+ tells which events will be checked:<P>\r
+ if checkMouse < > 0 then the events of Mouse will be \r
+reported to <A HREF = "#getpress">getpress</A>, otherwise \r
+ignored;<P>\r
+ if checkKeyboard < > 0 then the events of Keyboard will be \r
+reported to getpress, otherwise ignored<P>\r
+ <B><I>Attention please!</I></B> While the events of the \r
+keyboard are taken under control by \r
+<I>init</I> or <I>getmovement</I><P>\r
+ <B><I>do not use</I></B> the functions or procedures: read,\r
+ readln, hfont, hfont8, hpage, inkey \r
+that read keys<P>\r
+ YOU RISK TO HANG YOUR SYSTEM!<P>\r
+ <B>end</B> getmovement;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B> unit </B> <A \r
+NAME="getpress">getpress</A> : \r
+<B>function</B>(v,p,h,l,r,c : integer): \r
+Boolean;</H2>\r
+ { <I>v</I> = y coordinate of the cursor,<P>\r
+ <I>h</I> = x coordinate of the cursor,<P>\r
+ <I>p</I> = keybord status control_left,control_right, alt, alt_gr, shift_left, shift_right<P>\r
+ <I>l</I> = code of key pressed<P>\r
+ <I>r</I> = flags<P>\r
+ <I>c</I> = buttons pressed (0=none, 1=left, 2=right, 3=both)<P>\r
+ Nb: the middle button is not taken into account.<P>\r
+ <B>end</B> getpress<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2> <B>unit </B> <A \r
+NAME="showcursor">showcursor</A> : \r
+<B>procedure</B>; </H2>\r
+ {the cursor becomes visible and follows the movements of the mouse}<P>\r
+ end showcursor;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2> <B>unit </B> <A \r
+NAME="hidecursor">hidecursor</A> : \r
+<B>procedure</B>; </H2>\r
+ {the cursor becomes invisible}<P>\r
+ end hidecursor;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A><BR>\r
+\r
+<P align=left><B>end</B> MOUSE;<P>\r
+\r
+<HR>\r
+\r
+<H2>Enclosed you find a <A NAME="sample program">sample program</A> .</H2>\r
+<PRE>\r
+Program SystemeGraph; \r
+ (* by Frederic Pataud, October 1994 *) \r
+Begin \r
+Pref iiuwgraph block (* inherit the graphic functions *) \r
+ Begin \r
+ Pref mouse block (* inherit the mouse functions *) \r
+\r
+\r
+(*********************************************************************) \r
+(* P r o g r a m m e P r i n c i p a l *) \r
+(*********************************************************************) \r
+ var v,p,h,i : integer, \r
+ l,r,c : integer, \r
+ rep : arrayof char, \r
+ d : boolean, \r
+ xx,yy : arrayof integer, \r
+ status,code,x,y,flags,button : integer; \r
+ \r
+ Begin \r
+ \r
+ call gron(0); (* enter the graphic mode *) \r
+ call init(1,0); (* initialize the mouse, disregard the keyboard events, check for mouse events *) \r
+ \r
+ call showcursor; (* show cursor *) \r
+ call patern(5,5,635,475,2,0); (* make a frame around the screen *) \r
+ call outstring(10,10,"x=",2,0); \r
+ call outstring(100,10,"y=",2,0); \r
+ call outstring(10,30,"status = ",2,0); \r
+ call outstring(10,50,"code = ",2,0); \r
+ call outstring(10,70,"flags = ",2,0); \r
+ call outstring(10,90,"button = ",2,0); \r
+ call patern(100,210,300,320,3,1); (* make a rectangle filled in colour 3 *) \r
+\r
+ array xx dim (1:6); \r
+ array yy dim (1:6); \r
+ xx(1):=410; yy(1):=10; \r
+ xx(2):=450; yy(2):=30; \r
+ xx(3):=460; yy(3):=50; \r
+ xx(4):=430; yy(4):=80; \r
+ xx(5):=420; yy(5):=40; \r
+ xx(6):=480; yy(6):=30; \r
+ call intens(6,xx,yy,8,1); (* show a polygon filled*) \r
+ for i:=1 to 6 \r
+ do \r
+ yy(i):=yy(i)+100; \r
+ od; \r
+ call intens(6,xx,yy,15,0); (* show another polygon empty *) \r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0); (* draw an empty pie or camembert *) \r
+ call cirb(400,400,40,40,600,4000,11,1); (* draw a filled pie *) \r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); (* read integer from a window *) \r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); (* show text *) \r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15); (* read text *) \r
+ \r
+ call getmovement(1,1); (* take into consideration both key events and mouse events *) \r
+ \r
+ do \r
+ d:=getpress(v,p,h,l,r,c); (* ask about an event *) \r
+ if (d) \r
+ then call outstring(10,400,"Event",2,0); \r
+ call patern(80,25,130,100,0,1); \r
+ call track(40,10,v,0,4); (* print integer *) \r
+ call track(140,10,p,0,4); \r
+ call track(80,30,h,0,4); \r
+ call track(80,50,l,0,4); \r
+ call track(80,70,r,0,4); \r
+ call track(80,90,c,0,4); \r
+ if((h=164 and l=27) or (c=3)) (* exit if either two buttons were pressed c=3 or Ctrl+Esc key *) \r
+ then exit; \r
+ fi; \r
+ fi; \r
+ od; \r
+ call groff; (* leave the graphic mode and return to the text mode *) \r
+ writeln("i=",i); \r
+ for i:=lower(rep) to upper(rep) \r
+ do \r
+ write(rep(i)); \r
+ od; \r
+ writeln; \r
+ End \r
+ End \r
+End. \r
+</PRE>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<p align=LEFT>\r
+<HR>\r
+<Address> <A HREF = "http://www.univ-pau.fr/~salwicki/GMyAS.html">GMyAS</A> Last update Sun 7 May \r
+1995 </Address> \r
+</BODY>\r
+</html>\r
+\r
--- /dev/null
+<html>\r
+<HEAD><TITLE>iiuwgraph</TITLE>\r
+</HEAD>\r
+<body>\r
+<H1 align=center>unit IIUWGRAPH: class;</H1>\r
+<H2 align=center><IMG SRC="loglanmm.gif" ALT="LOGLAN's LOGO"></IMG>a predefined Loglan'82 class </H2>\r
+\r
+{ this predefined class enables basic graphic operations\r
+ for DOS machines based on <B>486</B> or 386 processors \r
+}<P>\r
+\r
+{this document gives the specification of new version of IIUWGRAPH \r
+ class<BR>\r
+ made in October 1994 by <B><I>Frederic Pataud </I></B>à Pau}<P>\r
+<HR>\r
+<A NAME="Table of Contents"><B>Table of Contents</B></A>.<BR>\r
+\r
+<DIR>\r
+<li> {IIUWGRAPH class}\r
+<ul>\r
+<li> {PROCEDURES of OVERALL CONTROL}\r
+<ul>\r
+<LI>unit <A HREF = "#GRON">GRON</A> : procedure (i: integer);\r
+<LI>unit <A HREF = "#GROFF">GROFF</A> : procedure;\r
+<LI>unit <A HREF = "#CLS">CLS</A> : procedure;\r
+<LI>unit <A HREF = "#COLOR">COLOR</A> : procedure(co : integer);\r
+<LI>unit <A HREF = "#STYLE">STYLE</A> : procedure(styl : integer);\r
+<LI>unit <A HREF = "#BORDER">BORDER</A> : procedure (background_Colour: integer);\r
+<LI>unit <A HREF = "#PALLET">PALLET</A> : procedure (nr : integer);\r
+</ul>\r
+<LI>{ PROCEDURES CONTROLLING POSITION }\r
+<ul>\r
+<LI>unit <A HREF = "#MOVE">MOVE</A> : procedure (x,y :integer);\r
+<LI>unit <A HREF = "#INXPOS">INXPOS</A> : function: integer;\r
+<LI>unit <A HREF = "#INYPOS">INYPOS</A> : function : integer;\r
+<LI>unit <A HREF = "#PUSHXY">PUSHXY</A> : procedure;\r
+<LI>unit <A HREF = "#POPXY">POPXY</A>: procedure;\r
+</ul>\r
+<LI>{ PROCEDURES SERVING POINTS and LINES}\r
+<ul>\r
+<LI>unit <A HREF = "#POINT">POINT</A> : procedure(x,y: integer);\r
+<LI>unit <A HREF = "#INPIX">INPIX</A> : function (x,y : integer) : integer;\r
+<LI>unit <A HREF = "#DRAW">DRAW</A> : procedure( x,y : integer);\r
+<LI>unit <A HREF = "#intens">intens</A>: procedure(Size :integer; xCoord,yCoord:arrayof integer, \r
+Colour,Filled :integer);\r
+<li>unit <a href="#CIRB">cirb </a> {draw a circle} procedure;\r
+<LI>unit <A HREF = "#HFILL">hfill</A>: procedure( x : integer);\r
+<LI>unit <A HREF = "#VFILL">vfill</A>: procedure( y : integer);\r
+<LI>unit <A HREF = "#PATERN">patern</A>: procedure( x1,y1,x2,y2,c,b : integer);\r
+</ul>\r
+<LI>{ Procedures operating on bitmaps }\r
+<ul>\r
+<LI>unit <A HREF = "#GETMAP">GETMAP </A> : function (x,y : integer) : arrayof integer;\r
+<LI>unit <A HREF = "#PUTMAP">PUTMAP </A> : procedure ( a: arrayof integer);\r
+<LI>unit <A HREF = "#ORMAP">ORMAP </A> : procedure ( a : arrayof integer);\r
+<LI>unit <A HREF = "#XORMAP">XORMAP </A> : procedure ( a: arrayof integer);\r
+</ul>\r
+<LI>{Procedures operating on characters and strings}\r
+<ul>\r
+<LI>unit <A HREF = "#outstring">outstring</A>: procedure(x,y: integer, s: string, back_col, front_col: \r
+ integer);\r
+<LI>unit <A HREF = "#track">track</A>: procedure( x,y,c,valeur : integer);\r
+<LI>unit <A HREF = "#inkey">inkey </A> : function : integer;\r
+<LI>unit <A HREF = "#HASCII">HASCII </A> : procedure(c: integer);\r
+<LI>unit <A HREF = "#hfont">hfont</A>: function( x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;\r
+<LI>unit <A HREF = "#HPAGE">HPAGE </A> : procedure(x,y,long: integer, A: arrayof char, back, front: \r
+ integer);\r
+</ul>\r
+</ul>\r
+\r
+<LI>unit <A HREF = "#MOUSE">MOUSE</A>: class;\r
+<ul>\r
+<LI>unit <A HREF = "#init">init</A>: procedure(checkMouse, checkKeyboard: integer);\r
+<LI>unit <A HREF = "#getmovement">getmovement</A>: procedure(checkMouse, checkKeyboard: \r
+ integer);\r
+<LI>unit <A HREF = "#getpress">getpress</A>: function(v,p,h,l,r,c : integer): Boolean;\r
+<LI>unit <A HREF = "#showcursor">showcursor</A>: procedure;\r
+<LI>unit <A HREF = "#hidecursor">hidecursor</A>: procedure;\r
+</ul>\r
+<LI> a sample<A HREF = "#sample program"> program</A>\r
+</dir>\r
+\r
+<HR>\r
+\r
+\r
+\r
+{ the early versions of library IIUWGRAPH have been elaborated by \r
+ Piotr Carlsson, Miroslawa Milkowska, Janina Jankowska, \r
+ Michal Jankowski at Institute of Informatics, \r
+ University of Warsaw 1987,<P>\r
+ and added to Loglan system by Danuta Szczepanska 1987, <P>\r
+ \r
+ the recent versions were done at LITA, Pau,<P>\r
+ by<P>\r
+ Pawel Susicki (1991) for Unix,<P>\r
+ Sebastien Bernard (1992) for ATARI, see a separate document,<BR>\r
+ Eric Becourt et Jerôme Larrieu (1993) for Unix and Xwindows, see a \r
+ separate document on Xiiuwgraf ,\r
+ <P>\r
+ \r
+<P>\r
+fait à Pau, le 15 Novembre 1994, par Andrzej Salwicki, LITA}<P>\r
+\r
+{ the predefined class IIUWGRAPH is included in all versions of interpreter of \r
+Loglan, with the <I>exception</I> of the present version of interpreter for \r
+VAX/VMS.}<P>\r
+<HR> \r
+<P>\r
+<PRE>\r
+<b>unit</b> IIUWGRAPH: <b>class</b>;\r
+<B> hidden</B> MaxX, MaxY, current_X, current_Y, is_graphic_On, \r
+ current_Colour, current_Background_Colour, current_Style, \r
+ current_Palette, current_Pattern ; \r
+\r
+\r
+ \r
+<B> const</B> MaxX = \r
+ MaxY = \r
+\r
+{ the screen's coordinates are \r
+ \r
+ (0,0) ----------------------> (MaxX,0) \r
+ ¦ \r
+ ¦ \r
+ ¦ \r
+ V \r
+ (0, MaxY) (MaxX,MaxY) \r
+\r
+}\r
+ \r
+\r
+<B> var</B> currentDriver : integer, { see NOCARD below } \r
+ current_X, current_Y: integer { it is the current position } \r
+ is_graphic_On: Boolean, { evidently tells whether we are in \r
+ graphics mode } \r
+ current_Colour : integer, { } \r
+ current_Background_Colour : integer, \r
+ current_Style : integer, { } \r
+ current_Palette : integer, \r
+ current_Pattern \r
+</PRE>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="GRON"> GRON </A> <B> procedure </B> \r
+(i: integer);</H2>\r
+ { procedure sets the monitor in graphic mode and clears the buffer \r
+ of screen. The parameter determines the resolution and the number of \r
+ colours.<BR>\r
+The user should assure that the resolution chosen should correspond to that \r
+which is set by means of command <BR>\r
+SET go32 drivers {path}< driver.file> < width> < height> < \r
+noColours> \r
+eg.<BR>\r
+set go32 drivers c:\loglan\svga\drivers\vesa.grn gw 1024 gh 480 nc 256<BR>\r
+<P> An execution of instruction call gron(i) <B><I>must precede</I> \r
+</B> any of the graphic commands described below.<P>\r
+<PRE>\r
+case (i)\r
+ {\r
+ 0 : 640x480x16\r
+ 1 : 640x480x256\r
+ 2 : 800x600x16\r
+ 3 : 800x600x256\r
+ 4 : 1024x768x16\r
+ 5 : 1024x768x256\r
+ 6 : 1280x1024x16\r
+ 7 : 1280x1024x256\r
+ 8 : 1600x1280x16\r
+ 9 : 1600x1280x256\r
+ }\r
+</PRE> }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit</B> <A \r
+NAME="GROFF"> GROFF </A><B> procedure</B\r
+>;</H2>\r
+ { the procedure sets the monitor in the text mode filling it with \r
+ spaces.<P>\r
+ DO NOT FORGET to set the monitor in the text mode before \r
+you terminate your program<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit</B> <A NAME="CLS"> CLS </A> . \r
+: <B> procedure</B>;</H2>\r
+ { the screen will be cleared and filled with colour 0 }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+\r
+{ PROCEDURES CONTROLLING THE COLOURS }<P>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="COLOR"> COLOR </A> . : \r
+<B> procedure</B>(co : integer);</H2>\r
+{ sets current color to co <BR>\r
+ for monochrome displays, 0 means black, non-0 - white<BR>\r
+ for color displays, 0 means background<BR>\r
+ see PALLET<P>\r
+} <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="STYLE"> STYLE </A> : \r
+<B> procedure</B>(styl : integer);</H2>\r
+{ sets style of lines and fill shades to a combination<P>\r
+ of current color and background color (for mono -<P>\r
+ white and black, respectively) according to 5 predefined<P>\r
+ patterns:<P>\r
+<PRE>\r
+ 0 ....\r
+ 1 ****\r
+ 2 ***.\r
+ 3 **..\r
+ 4 *.*.\r
+ 5 *...\r
+</PRE>\r
+ where '*' means current color, '.' background colour<P>\r
+When drawing the segments the subsequent pixels will have colour determined \r
+by cyclic application of style pattern. The first and the last pixels of a segment \r
+will have always current colour.<P>\r
+When filling contours the given style will be applied to horizontal lines with even \r
+coordinate. The style for odd lines is determined automatically.<P>\r
+The same applies for perpendicular lines.<P>\r
+}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="BORDER"> BORDER </A> . : \r
+<B>procedure</B> (background_Colour: \r
+integer);</H2>\r
+ \r
+<P> { sets actual background color to i ( i = 0,1,...,15 ) }<P>\r
+\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PALLET"> PALLET </A> : \r
+<B>procedure</B> (nr : integer);</H2>\r
+ {the following line makes an example, it is not valid for, say,\r
+256 colours\r
+<P>\r
+the codes of colors are <I>usually i.e. when you have 16 colours,</I> as follows<P>\r
+ 0 black<P>\r
+ 1 blue dark<P>\r
+ 2 green dark<P>\r
+ 3 turquoise dark<P>\r
+ 4 red dark<P>\r
+ 5 violet<P>\r
+ 6 brown<P>\r
+ 7 grey light<P>\r
+ 8 grey dark <P>\r
+ 9 blue<P>\r
+ 10 green<P>\r
+ 11 turquoise<P>\r
+ 12 red light<P>\r
+ 13 rose<P>\r
+ 14 yellow<P>\r
+ 15 white<P>\r
+ \r
+<P> }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+\r
+<H2>{ PROCEDURES CONTROLLING POSITION }</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="MOVE">MOVE</A> : \r
+<B>procedure</B> (x,y :integer);</H2>\r
+ { procedure MOVE sets the current position on the screen on the pixel \r
+ with coordinates<P>\r
+ x - column,<P>\r
+ y - line }<P>\r
+ { precondition of MOVE:<P>\r
+ 0*x*MaxX & 0*y*MaxY <P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="INXPOS">INXPOS</A> : \r
+<B>function</B>: integer;</H2>\r
+ { function INXPOS returns the x coordinate of the current position }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A \r
+NAME="INYPOS">INYPOS</A> : \r
+<B>function</B> : integer;</H2>\r
+ { function INYPOS returns the y coordinate of the current position }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PUSHXY">PUSHXY</A> : \r
+<B>procedure</B>;</H2>\r
+{ pushes current position, color & style onto the stack.<P>\r
+ The stack is kept internally, max depth is 16<P>\r
+}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A \r
+NAME="POPXY">POPXY</A> : \r
+<B>procedure</B>;</H2>\r
+\r
+{ restores position, color & style from internal stack }<P>\r
+\r
+{ Example<P>\r
+<PRE>unit DIAGONAL : procedure;<P>\r
+ var ix, iy : integer;<P>\r
+begin<P>\r
+ call PUSHXY;<P>\r
+ ix := INXPOS;<P>\r
+ iy := INYPOS;<P>\r
+ call DRAW(ix+10, iy+10);<P>\r
+ call POPXY<P>\r
+end DIAGONAL;<P>\r
+</PRE>}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2>{ PROCEDURES SERVING POINTS & \r
+LINES}</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="POINT">POINT</A> : \r
+<B>procedure</B>(x,y: integer);</H2>\r
+{ moves current position to pixel (x,y) and sets it to the current color \r
+<P>\r
+ }<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="INPIX">INPIX</A> : <B>function</B> \r
+(x,y : integer) : integer;</H2>\r
+ { <P>\r
+ moves to pixel (x,y) and returns its color setting;<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="DRAW">DRAW</A> : \r
+<B>procedure</B>( x,y : integer);</H2>\r
+ { <P>\r
+ draws a line from current screen position to (<I>x,y</I>);<P>\r
+ sets current position to (<I>x,y</I>);<P>\r
+ line is drawn in current color, with both terminal pixels<P>\r
+ always turned white ( non-background) for non-black<P>\r
+ ( non-background ) line color.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="intens">intens</A> : \r
+<B>procedure</B>(Size :integer; \r
+xCoord,yCoord:arrayof integer, Colour,Filled \r
+:integer);</H2>\r
+ \r
+/* draw a polygon*/\r
+{ draw a simple, closed polygon of Size points, the edges of the polygon go from \r
+(<I>xCoord[i], yCoord[i]</I>) to (<I>xCoord[i+1], yCoord[i+1]</I>) for i = 1, ..., Size-1\r
+The colour used will be <I>Colour</I>. The polygon will be filled iff <I>Filled</I>< \r
+> 0.\r
+}<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<BR><P>\r
+<H2><B>unit </B><A NAME="CIRB"> CIRB</A> : <B>procedure</B> (xi, yi, rx,ry : integer, alfa, beta : real, \r
+cbord, fill : integer);<P></H2>\r
+\r
+\r
+ {\r
+<P> draws a circle (or ellipse, depending on aspect value, see below),<P>\r
+ optionally filling its interior; <P>\r
+ does not preserve position;<P>\r
+ (<I>xi,yi</I>) - are center coordinates,<P>\r
+ <I>rx</I> - radius in pixels (horizontally),<BR>\r
+ <I>ry</I> - radius in pixels (perpendicularly),<P>\r
+ <I>alfa, beta</I> - starting & ending angles; if alfa=beta a full<P>\r
+ circle is drawn; values should be given in radians;<P>\r
+ <I>cbord</I> - border color,<P>\r
+ <I>fill</I> - if fill < > 0, interior is filled in current style& color<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A NAME="hfill">hfill</A> : \r
+<B>procedure</B>( x : integer);</H2>\r
+ { draw an horizontal line between the current position and<P>\r
+ (x,currentY) with the current color, after it change the current<P>\r
+ position to (x, currentY)<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A NAME="vfill">vfill</A> : \r
+<B>procedure</B>( y : integer);</H2>\r
+ { draw a vertical line between the current position and<P>\r
+ (currentX,y) with the current color, after it change the current<P>\r
+ position to (currentX,y)<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="patern">patern</A> : \r
+<B>procedure</B>( x1,y1,x2,y2,c,b : \r
+integer);</H2>\r
+ { draw a <B><I>rectangle</I></B> between the points (<I>x1,y1</I>) and \r
+(<I>x2</I>,<I>y2</I>) with the<P>\r
+ color <I>c</I> (the current color is not change). if <I>b</I>=0 then the box \r
+is<P>\r
+ empty else it is filled.<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2>{ Procedures operating on bitmaps }</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="GETMAP">GETMAP</A> : \r
+<B>function</B> (x,y : integer) : <B>arrayof</B> \r
+integer;</H2>\r
+ {saves rectangular area between current position as<P>\r
+ top left corner and (ix,iy) as bottom right corner,<P>\r
+ including border lines;<P>\r
+ position remains unchanged.<P>\r
+ array of integer should have <P>\r
+ 4+(rows**columns/8* *coeff)<P>\r
+ bytes. The coefficient coeff is 1 for Hercules, 2 for CGA, 4 for EGA<P>\r
+ card.<P>\r
+ ATTENTION: in DOS 286 environment a bigger size of the array may \r
+ necessitate the use of <I>loglan</I> with<I> the option H+</I>, see also \r
+memavail <P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PUTMAP">PUTMAP</A> : \r
+<B>procedure</B> ( a: <B>arrayof</B> \r
+integer);</H2>\r
+ {sets rectangular area of screen pixels to that saved<P>\r
+ by "getmap" in "iarray";<P>\r
+ same size is restored, with top left corner in current<P>\r
+ position;<P>\r
+ position remains unchanged.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="ORMAP">ORMAP</A> : \r
+<B>procedure</B> ( a : <B>arrayof \r
+</B>integer);</H2>\r
+ {same as putmap, but saved bitmap is or'ed into screen<P>\r
+ rather than just set.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A NAME="XORMAP">XORMAP </A> : \r
+<B>procedure</B> ( a: \r
+<B>arrayof</B> integer);</H2>\r
+ {same as putmap, but saved bitmap is xor'ed into screen<P>\r
+ rather than just set.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+<H2>{Procedures operating on characters and strings}</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="outstring">outstring</A> : \r
+<B>procedure</B>(x,y: integer, s: string, back_col, \r
+front_col: integer);</H2>\r
+ { <I>x, y</I> are the coordinates where to put the string,<P>\r
+ <I>s</I> is the string to be shown, in <I>front_col</I> colour letters on the \r
+<I>back_col</I> colour background<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="track">track</A> \r
+: <B>procedure</B>( x,y,c,valeur : integer);\r
+</H2>\r
+ { write an integer value <I>valeur</I> at the position (<I>x,y</I>) with the \r
+color <I>c</I>.\r
+ It does not change the current position nor the current color<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="inkey ">inkey \r
+</A> : <B>function</B> : integer;</H2>\r
+\r
+ { returns next character from keyboard buffer;<P>\r
+ 0 is returned if buffer is empty;<P>\r
+ special keys are returned as negative numbers;<P>\r
+ ALT-NUM method may be used for entering character codes<P>\r
+ above 127 (this makes entering special keys 128-132<P>\r
+ impossible);<P>\r
+ if a character is returned, it is also removed<P>\r
+ from the buffer, so MS-DOS will not see it (CTRL-C!);<P>\r
+ typeahead is allowed, echo is suppressed.<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="HASCII \r
+">HASCII </A> : <B>procedure</B>(c: \r
+integer);</H2>\r
+ {'xor's the character = chr(c) in a 8*8 box with top left corner<P>\r
+ in the current position;<P>\r
+ moves current position by (8,0);<P>\r
+ call hascii(0)- sets complete box to black ( =background ),<P>\r
+ with no change in position.<P>\r
+}\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+\r
+<H2><B>unit </B><A NAME="hfont">hfont</A> \r
+: <B>function</B>( \r
+x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;</H2>\r
+\r
+ { arrange a small 1 line window for <B><I>reading</I></B> an integer value \r
+from this window,\r
+the position of the window corner is (<I>x, y</I>),\r
+the length of the window is <I>lg</I> characters,\r
+the value v should be greater than <I>min</I> and smaller than <I>max</I>,\r
+the default value read is <I>default</I>,<P>\r
+the colour of the window is <I>col_f</I>,<BR>\r
+the colour of the digits is <I>col_e,</I><BR>\r
+the colour of cursor is <I>col_c</I><P>\r
+\r
+ reads in graphic mode an integer in the window which begins at the (x,y)\r
+ position, window is lg caracteres long. the maximum length of the<P>\r
+ integer that is read is 10. there is a default value, a minimum value\r
+ and a maximum value. the window is drawn with the col_f color, the \r
+ cursor is in the col_c color and the integer is writing in the col_e<P>\r
+ color. you can use 0..9,+,-,backspace,escape and return keys. }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A NAME="HPAGE">HPAGE </A> : <B>procedure</B>(x,y,long: \r
+integer, A: arrayof char, back, front: integer);</H2>\r
+ { this procedure arranges a 1-line high window in position <I>x,y</I> of \r
+length <I>long</I> in which a portion of text <I>A</I> is shown in colour \r
+<I>front</I> on the background colour <I>back</I>. <P>\r
+ Making use of keys controlling the cursor {left, right, PgUp, PgDn}<P>\r
+ the user can scroll the text (horizontally) in the window. Pressing the \r
+ Enter key terminates the procedure} <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<P align=left><B>end</B> IIUWGRAPH;<P>\r
+\r
+\r
+\r
+<HR>\r
+<P><H2><B>unit </B> <A NAME="MOUSE">MOUSE</A> .: \r
+<B>class</B>; </H2>\r
+ <P><HR>\r
+<H6>{ <I>init</I> -lors de l'initialisation de la souris, on peut définir les événements qui vont faire réagir la \r
+fonction getpress; le premier et le deuxième paramètre représentent respectivement la souris et le clavier, si une \r
+valeur non nulle est donnée comme paramètre alors getpress réagira à l'événement.<P>\r
+\r
+ Une paire (1,1) va permettre de prendre en compte à la fois les événements de la souris et ceux du clavier; \r
+une paire (1,0) quand à elle ne prendra en compte que la souris. Pour une plus grande souplesse d'utilisation, il est \r
+possible lors du programme, après l'initalisation, de changer cette prise en compte, cela se fera par l'appel de la \r
+procedure <I>getmovement</I>, procédure ayant les mêmes paramètres (avec le même ordre) que la fonction \r
+init.<P>\r
+\r
+ Pour detecter les événements, on utilisa la fonction <I>getpress</I>, qui retourne un booléen indiquant la \r
+présence ou l'absence d'événement (respectivement les valeurs true et false). Il est bon de noter qu'ainsi définie la \r
+fonction getpress n'est pas bloquante. Les paramètres en retour sont soit nuls (pas d'événement) soit \r
+correspondent:<P>\r
+\r
+ bool:=getpress(v,p,h,l,r,c : integer);<P>\r
+ v = position en y de la souris<P>\r
+ p = keyboard status (Touche control_left,control_right, alt, alt_gr, shift_left, shift_right)<P>\r
+ h = position en x de la souris<P>\r
+ l = touche clavier<P>\r
+ r = flags<P>\r
+ c = boutons de la souris (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)<P>\r
+ Nb: le bouton central n'est pas géré.<P>\r
+\r
+NOTEZ BIEN! Lorsque les événements du clavier sont pris en compte dans le gestionnaire, <B>il</B> <B>ne faut \r
+pas </B>utiliser les fonctions d'entrées clavier readl, readln, hfont, hfont8, hpage, inkey,...) <I>sous peine de \r
+plantage de l'ordinateur</I>.<P>\r
+}</H6>\r
+<HR>\r
+<P>\r
+<H2> <B>unit </B> <A NAME="init">init</A> \r
+: <B>procedure</B>(checkMouse, \r
+checkKeyboard: integer); </H2>\r
+ { initializes the Mouse driver.<P>\r
+ tells which events will be checked:<P>\r
+ if checkMouse < > 0 then the events of Mouse will be reported to getpress, see below otherwise \r
+ignored;<P>\r
+ if checkKeyboard < > 0 then the events of Keyboard will be reported to getpress, otherwise ignored<P>\r
+ <B><I>Attention please!</I></B> While the events of the keyboard are taken under control by \r
+<I>init</I> or <I>getmovement</I><P>\r
+ <B><I>do not use</I></B> the functions or procedures: read, readln, hfont, hfont8, hpage, inkey \r
+that read keys<P>\r
+ YOU RISK TO HANG YOUR SYSTEM!<P>\r
+<B> }</B><P>\r
+ <B>end</B> init <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B> unit </B><A \r
+NAME="getmovement">getmovement</A> : \r
+<B>procedure</B>(checkMouse, checkKeyboard: \r
+integer); </H2>\r
+ tells which events will be checked:<P>\r
+ if checkMouse < > 0 then the events of Mouse will be reported to getpress, see below otherwise \r
+ignored;<P>\r
+ if checkKeyboard < > 0 then the events of Keyboard will be reported to getpress, otherwise ignored<P>\r
+ <B><I>Attention please!</I></B> While the events of the keyboard are taken under control by \r
+<I>init</I> or <I>getmovement</I><P>\r
+ <B><I>do not use</I></B> the functions or procedures: read, readln, hfont, hfont8, hpage, inkey \r
+that read keys<P>\r
+ YOU RISK TO HANG YOUR SYSTEM!<P>\r
+ <B>end</B> getmovement;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B> unit </B> <A \r
+NAME="getpress">getpress</A> : \r
+<B>function</B>(v,p,h,l,r,c : integer): \r
+Boolean;</H2>\r
+ { <I>v</I> = y coordinate of the cursor,<P>\r
+ <I>h</I> = x coordinate of the cursor,<P>\r
+ <I>p</I> = keybord status control_left,control_right, alt, alt_gr, shift_left, shift_right<P>\r
+ <I>l</I> = code of key pressed<P>\r
+ <I>r</I> = flags<P>\r
+ <I>c</I> = buttons pressed (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)<P>\r
+ Nb: the middle button is not taken into account.<P>\r
+ <B>end</B> getpress<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2> <B>unit </B> <A \r
+NAME="showcursor">showcursor</A> : \r
+<B>procedure</B>; </H2>\r
+ {the cursor becomes visible and follows the movements of the mouse}<P>\r
+ end showcursor;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2> <B>unit </B> <A \r
+NAME="hidecursor">hidecursor</A> : \r
+<B>procedure</B>; </H2>\r
+ {the cursor becomes invisible}<P>\r
+ end hidecursor;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A><BR>\r
+\r
+<P align=left><B>end</B> MOUSE;<P>\r
+\r
+<HR>\r
+\r
+<H2>Enclosed you find a <A NAME="sample program">sample program</A> .</H2>\r
+<PRE>\r
+Program SystemeGraph; \r
+ (* by Frederic Pataud, October 1994 *) \r
+Begin \r
+Pref iiuwgraph block (* inherit the graphic functions *) \r
+ Begin \r
+ Pref mouse block (* inherit the mouse functions *) \r
+\r
+\r
+(*********************************************************************) \r
+(* P r o g r a m m e P r i n c i p a l *) \r
+(*********************************************************************) \r
+ var v,p,h,i : integer, \r
+ l,r,c : integer, \r
+ rep : arrayof char, \r
+ d : boolean, \r
+ xx,yy : arrayof integer, \r
+ status,code,x,y,flags,button : integer; \r
+ \r
+ Begin \r
+ \r
+ call gron(0); (* enter the graphic mode *) \r
+ call init(1,0); (* initialize the mouse, disregard the keyboard events, check for mouse events *) \r
+ \r
+ call showcursor; (* show cursor *) \r
+ call patern(5,5,635,475,2,0); (* make a frame around the screen *) \r
+ call outstring(10,10,"x=",2,0); \r
+ call outstring(100,10,"y=",2,0); \r
+ call outstring(10,30,"status = ",2,0); \r
+ call outstring(10,50,"code = ",2,0); \r
+ call outstring(10,70,"flags = ",2,0); \r
+ call outstring(10,90,"button = ",2,0); \r
+ call patern(100,210,300,320,3,1); (* make a rectangle filled in colour 3 *) \r
+\r
+ array xx dim (1:6); \r
+ array yy dim (1:6); \r
+ xx(1):=410; yy(1):=10; \r
+ xx(2):=450; yy(2):=30; \r
+ xx(3):=460; yy(3):=50; \r
+ xx(4):=430; yy(4):=80; \r
+ xx(5):=420; yy(5):=40; \r
+ xx(6):=480; yy(6):=30; \r
+ call intens(6,xx,yy,8,1); (* show a polygon filled*) \r
+ for i:=1 to 6 \r
+ do \r
+ yy(i):=yy(i)+100; \r
+ od; \r
+ call intens(6,xx,yy,15,0); (* show another polygon empty *) \r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0); (* draw an empty pie or camembert *) \r
+ call cirb(400,400,40,40,600,4000,11,1); (* draw a filled pie *) \r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); (* read integer from a window *) \r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); (* show text *) \r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15); (* read text *) \r
+ \r
+ call getmovement(1,1); (* take into consideration both key events and mouse events *) \r
+ \r
+ do \r
+ d:=getpress(v,p,h,l,r,c); (* ask about an event *) \r
+ if (d) \r
+ then call outstring(10,400,"Event",2,0); \r
+ call patern(80,25,130,100,0,1); \r
+ call track(40,10,v,0,4); (* print integer *) \r
+ call track(140,10,p,0,4); \r
+ call track(80,30,h,0,4); \r
+ call track(80,50,l,0,4); \r
+ call track(80,70,r,0,4); \r
+ call track(80,90,c,0,4); \r
+ if((h=164 and l=27) or (c=3)) (* exit if either two buttons were pressed c=3 or Ctrl+Esc key *) \r
+ then exit; \r
+ fi; \r
+ fi; \r
+ od; \r
+ call groff; (* leave the graphic mode and return to the text mode *) \r
+ writeln("i=",i); \r
+ for i:=lower(rep) to upper(rep) \r
+ do \r
+ write(rep(i)); \r
+ od; \r
+ writeln; \r
+ End \r
+ End \r
+End. \r
+</PRE>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<p align=LEFT>\r
+<HR>\r
+<Address> <A HREF = "http://www.univ-pau.fr/~salwicki/GMyAS.html">GMyAS</A> Last update Sun 7 May \r
+1995 </Address> \r
+</BODY>\r
+</html>\r
+\r
--- /dev/null
+<html>\r
+<HEAD><TITLE>iiuwgraph</TITLE></HEAD>\r
+<H1 align=center>unit IIUWGRAPH: class;</H1>\r
+<H2>a predefined Loglan'82 class <IMG SRC="http://www.univ-pau.fr/~salwicki/loglanmm.gif" ALT="LOGLAN"></IMG></H2>\r
+\r
+{ this predefined class enables basic graphic operations\r
+ for DOS machines based on <B>486</B> or 386 processors \r
+}<P>\r
+\r
+{this document gives the specification of new version of IIUWGRAPH \r
+ class<BR>\r
+ made in October 1994 by <B><I>Frederic Pataud </I></B>à Pau}<P>\r
+<HR>\r
+<A NAME="Table of Contents"><B>Table of Contents</B></A>.<BR>\r
+\r
+\r
+<UL>\r
+<LI>unit <A HREF = "#GRON">GRON</A> : procedure (i: integer);\r
+<LI>unit <A HREF = "#GROFF">GROFF</A> : procedure;\r
+<LI>unit <A HREF = "#CLS">CLS</A> : procedure;\r
+<LI>unit <A HREF = "#COLOR">COLOR</A> : procedure(co : integer);\r
+<LI>unit <A HREF = "#STYLE">STYLE</A> : procedure(styl : integer);\r
+<LI>unit <A HREF = "#BORDER">BORDER</A> : procedure (background_Colour: integer);\r
+<LI>unit <A HREF = "#PALLET">PALLET</A> : procedure (nr : integer);\r
+<LI>{ PROCEDURES CONTROLLING POSITION }\r
+<LI>unit <A HREF = "#MOVE">MOVE</A> : procedure (x,y :integer);\r
+<LI>unit <A HREF = "#INXPOS">INXPOS</A> : function: integer;\r
+<LI>unit <A HREF = "#INYPOS">INYPOS</A> : function : integer;\r
+<LI>unit <A HREF = "#PUSHXY">PUSHXY</A> : procedure;\r
+<LI>unit <A HREF = "#POPXY">POPXY</A>: procedure;\r
+<LI>{ PROCEDURES SERVING POINTS LINES}\r
+<LI>unit <A HREF = "#POINT">POINT</A> : procedure(x,y: integer);\r
+<LI>unit <A HREF = "#INPIX">INPIX</A> : function (x,y : integer) : integer;\r
+<LI>unit <A HREF = "#DRAW">DRAW</A> : procedure( x,y : integer);\r
+<LI>unit <A HREF = "#intens">intens</A>: procedure(Size :integer; xCoord,yCoord:arrayof integer, \r
+Colour,Filled :integer);\r
+<li>unit <a href="#CIRB">cirb </a> {draw a circle} procedure;\r
+<LI>unit <A HREF = "#HFILL">hfill</A>: procedure( x : integer);\r
+<LI>unit <A HREF = "#VFILL">vfill</A>: procedure( y : integer);\r
+<LI>unit <A HREF = "#PATERN">patern</A>: procedure( x1,y1,x2,y2,c,b : integer);\r
+<LI>{ Procedures operating on bitmaps }\r
+<LI>unit <A HREF = "#GETMAP">GETMAP </A> : function (x,y : integer) : arrayof integer;\r
+<LI>unit <A HREF = "#PUTMAP">PUTMAP </A> : procedure ( a: arrayof integer);\r
+<LI>unit <A HREF = "#ORMAP">ORMAP </A> : procedure ( a : arrayof integer);\r
+<LI>unit <A HREF = "#XORMAP">XORMAP </A> : procedure ( a: arrayof integer);\r
+<LI>{Procedures operating on characters and strings}\r
+<LI>unit <A HREF = "#outstring">outstring</A>: procedure(x,y: integer, s: string, back_col, front_col: \r
+ integer);\r
+<LI>unit <A HREF = "#track">track</A>: procedure( x,y,c,valeur : integer);\r
+<LI>unit <A HREF = "#inkey">inkey </A> : function : integer;\r
+<LI>unit <A HREF = "#HASCII">HASCII </A> : procedure(c: integer);\r
+<LI>unit <A HREF = "#hfont">hfont</A>: function( x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;\r
+<LI>unit <A HREF = "#HPAGE">HPAGE </A> : procedure(x,y,long: integer, A: arrayof char, back, front: \r
+ integer);\r
+<LI>unit <A HREF = "#MOUSE">MOUSE</A>: class;\r
+<LI>unit <A HREF = "#init">init</A>: procedure(checkMouse, checkKeyboard: integer);\r
+<LI>unit <A HREF = "#getmovement">getmovement</A>: procedure(checkMouse, checkKeyboard: \r
+ integer);\r
+<LI>unit <A HREF = "#getpress">getpress</A>: function(v,p,h,l,r,c : integer): Boolean;\r
+<LI>unit <A HREF = "#showcursor">showcursor</A>: procedure;\r
+<LI>unit <A HREF = "#hidecursor">hidecursor</A>: procedure;\r
+<LI> <A HREF = "#sample program">a sample program</A>\r
+</UL>\r
+\r
+<HR>\r
+\r
+\r
+\r
+{ the early versions of library IIUWGRAPH have been elaborated by \r
+ Piotr Carlsson, Miroslawa Milkowska, Janina Jankowska, \r
+ Michal Jankowski at Institute of Informatics, \r
+ University of Warsaw 1987,<P>\r
+ and added to Loglan system by Danuta Szczepanska 1987, <P>\r
+ \r
+ the recent versions were done at LITA, Pau,<P>\r
+ by<P>\r
+ Pawel Susicki (1991) for Unix,<P>\r
+ Sebastien Bernard (1992) for ATARI, see a separate document,<BR>\r
+ Eric Becourt et Jerôme Larrieu (1993) for Unix and Xwindows, see a \r
+ separate document on Xiiuwgraf ,\r
+ <P>\r
+ \r
+<P align=right>\r
+fait à Pau, le 15 Novembre 1994, par Andrzej Salwicki, LITA}<P align=left>\r
+\r
+{ the predefined class IIUWGRAPH is included in all versions of interpreter of \r
+Loglan, with the <I>exception</I> of the present version of interpreter for \r
+VAX/VMS.}<P>\r
+<HR> \r
+<P>\r
+<PRE>\r
+<B>hidden</B> MaxX, MaxY, current_X, current_Y, is_graphic_On, \r
+ current_Colour, current_Background_Colour, current_Style, \r
+ current_Palette, current_Pattern ; \r
+\r
+\r
+ \r
+<B>const</B> MaxX = \r
+ MaxY = \r
+\r
+{ the screen's coordinates are \r
+ \r
+ (0,0) ----------------------> (MaxX,0) \r
+ ¦ \r
+ ¦ \r
+ ¦ \r
+ V \r
+ (0, MaxY) (MaxX,MaxY) \r
+\r
+}\r
+ \r
+\r
+<B>var</B> currentDriver : integer, { see NOCARD below } \r
+ current_X, current_Y: integer { it is the current position } \r
+ is_graphic_On: Boolean, { evidently tells whether we are in \r
+ graphics mode } \r
+ current_Colour : integer, { } \r
+ current_Background_Colour : integer, \r
+ current_Style : integer, { } \r
+ current_Palette : integer, \r
+ current_Pattern \r
+</PRE>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="GRON"> GRON </A> <B> procedure </B> \r
+(i: integer);</H2>\r
+ { procedure sets the monitor in graphic mode and clears the buffer \r
+ of screen. The parameter determines the resolution and the number of \r
+ colours.<BR>\r
+The user should assure that the resolution chosen should correspond to that \r
+which is set by means of command <BR>\r
+SET go32 drivers {path}< driver.file> < width> < height> < \r
+noColours> \r
+eg.<BR>\r
+set go32 drivers c:\loglan\svga\drivers\vesa.grn gw 1024 gh 480 nc 256<BR>\r
+<P> An execution of instruction call gron(i) <B><I>must precede</I> \r
+</B> any of the graphic commands described below.<P>\r
+<PRE>\r
+case (i)\r
+ {\r
+ 0 : 640x480x16\r
+ 1 : 640x480x256\r
+ 2 : 800x600x16\r
+ 3 : 800x600x256\r
+ 4 : 1024x768x16\r
+ 5 : 1024x768x256\r
+ 6 : 1280x1024x16\r
+ 7 : 1280x1024x256\r
+ 8 : 1600x1280x16\r
+ 9 : 1600x1280x256\r
+ }\r
+</PRE> \r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit</B> <A \r
+NAME="GROFF"> GROFF </A><B> procedure</B\r
+>;</H2>\r
+ { the procedure sets the monitor in the text mode filling it with \r
+ spaces.<P>\r
+ DO NOT FORGET to set the monitor in the text mode before \r
+you terminate your program<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit</B> <A NAME="CLS"> CLS </A> . \r
+: <B> procedure</B>;</H2>\r
+ { the screen will be cleared and filled with colour 0 }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A><P>\r
+\r
+\r
+\r
+<H2>{ PROCEDURES CONTROLLING THE COLOURS }</H2>\r
+<P>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="COLOR"> COLOR </A> . : \r
+<B> procedure</B>(co : integer);</H2>\r
+{ sets current color to co <BR>\r
+ for monochrome displays, 0 means black, non-0 - white<BR>\r
+ for color displays, 0 means background<BR>\r
+ see PALLET<P>\r
+} <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="STYLE"> STYLE </A> : \r
+<B> procedure</B>(styl : integer);</H2>\r
+{ sets style of lines and fill shades to a combination<P>\r
+ of current color and background color (for mono -<P>\r
+ white and black, respectively) according to 5 predefined<P>\r
+ patterns:<P>\r
+<PRE>\r
+ 0 ....\r
+ 1 ****\r
+ 2 ***.\r
+ 3 **..\r
+ 4 *.*.\r
+ 5 *...\r
+</PRE>\r
+ where '*' means current color, '.' background colour<P>\r
+When drawing the segments the subsequent pixels will have colour determined \r
+by cyclic application of style pattern. The first and the last pixels of a segment \r
+will have always current colour.<P>\r
+When filling contours the given style will be applied to horizontal lines with even \r
+coordinate. The style for odd lines is determined automatically.<P>\r
+The same applies for perpendicular lines.<P>\r
+}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="BORDER"> BORDER </A> . : \r
+<B>procedure</B> (background_Colour: \r
+integer);</H2>\r
+ \r
+<P> { sets actual background color to i ( i = 0,1,...,15 ) }<P>\r
+\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PALLET"> PALLET </A> : \r
+<B>procedure</B> (nr : integer);</H2>\r
+ {the following line makes an example, it is not valid for, say,\r
+256 colours\r
+<P>\r
+the codes of colors are <I>usually i.e. when you have 16 colours,</I> as follows<P>\r
+<PRE>\r
+ 0 black\r
+ 1 blue dark\r
+ 2 green dark\r
+ 3 turquoise dark\r
+ 4 red dark\r
+ 5 violet\r
+ 6 brown\r
+ 7 grey light\r
+ 8 grey dark \r
+ 9 blue\r
+ 10 green\r
+ 11 turquoise\r
+ 12 red light\r
+ 13 rose\r
+ 14 yellow\r
+ 15 white\r
+</PRE> }\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+\r
+<H2>{ PROCEDURES CONTROLLING POSITION }</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="MOVE">MOVE</A> : \r
+<B>procedure</B> (x,y :integer);</H2>\r
+ { procedure MOVE sets the current position on the screen on the pixel \r
+ with coordinates<P>\r
+ x - column,<P>\r
+ y - line }<P>\r
+ { precondition of MOVE:\r
+ <I>0*x*MaxX & 0*y*MaxY </I>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="INXPOS">INXPOS</A> : \r
+<B>function</B>: integer;</H2>\r
+ { function INXPOS returns the x coordinate of the current position }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A \r
+NAME="INYPOS">INYPOS</A> : \r
+<B>function</B> : integer;</H2>\r
+ { function INYPOS returns the y coordinate of the current position }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PUSHXY">PUSHXY</A> : \r
+<B>procedure</B>;</H2>\r
+{ pushes current position, color & style onto the stack.<P>\r
+ The stack is kept internally, max depth is 16<P>\r
+}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A \r
+NAME="POPXY">POPXY</A> : \r
+<B>procedure</B>;</H2>\r
+\r
+{ restores position, color & style from internal stack }<P>\r
+\r
+{ Example<P>\r
+<PRE>unit DIAGONAL : procedure;\r
+ var ix, iy : integer;\r
+begin\r
+ call PUSHXY;\r
+ ix := INXPOS;\r
+ iy := INYPOS;\r
+ call DRAW(ix+10, iy+10);\r
+ call POPXY\r
+end DIAGONAL;\r
+</PRE>}\r
+<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2>{ PROCEDURES SERVING POINTS & \r
+LINES}</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="POINT">POINT</A> : \r
+<B>procedure</B>(x,y: integer);</H2>\r
+{ moves current position to pixel (x,y) and sets it to the current color \r
+<P>\r
+ }<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="INPIX">INPIX</A> : <B>function</B> \r
+(x,y : integer) : integer;</H2>\r
+ { <P>\r
+ moves to pixel (x,y) and returns its color setting;<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="DRAW">DRAW</A> : \r
+<B>procedure</B>( x,y : integer);</H2>\r
+ { <P>\r
+ draws a line from current screen position to (<I>x,y</I>);<P>\r
+ sets current position to (<I>x,y</I>);<P>\r
+ line is drawn in current color, with both terminal pixels<P>\r
+ always turned white ( non-background) for non-black<P>\r
+ ( non-background ) line color.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="intens">intens</A> : \r
+<B>procedure</B>(Size :integer; \r
+xCoord,yCoord:arrayof integer, Colour,Filled \r
+:integer);</H2>\r
+ \r
+/* draw a polygon*/\r
+{ draw a simple, closed polygon of Size points, the edges of the polygon go from \r
+(<I>xCoord[i], yCoord[i]</I>) to (<I>xCoord[i+1], yCoord[i+1]</I>) for i = 1, ..., Size-1\r
+The colour used will be <I>Colour</I>. The polygon will be filled iff <I>Filled</I>< \r
+> 0.\r
+}<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<BR><P>\r
+<H2><B>unit </B><A NAME="CIRB"> CIRB</A> : <B>procedure</B> (xi, yi, rx,ry : integer, alfa, beta : real, \r
+cbord, fill : integer);<P></H2>\r
+\r
+\r
+ {\r
+<P> draws a circle (or ellipse, depending on aspect value, see below),<P>\r
+ optionally filling its interior; <P>\r
+ does not preserve position;<P>\r
+ (<I>xi,yi</I>) - are center coordinates,<P>\r
+ <I>rx</I> - radius in pixels (horizontally),<BR>\r
+ <I>ry</I> - radius in pixels (perpendicularly),<P>\r
+ <I>alfa, beta</I> - starting & ending angles; if alfa=beta a full<P>\r
+ circle is drawn; values should be given in radians;<P>\r
+ <I>cbord</I> - border color,<P>\r
+ <I>fill</I> - if fill < > 0, interior is filled in current style& color<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A NAME="hfill">hfill</A> : \r
+<B>procedure</B>( x : integer);</H2>\r
+ { draw an horizontal line between the current position and<P>\r
+ (x,currentY) with the current color, after it change the current<P>\r
+ position to (x, currentY)<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B><A NAME="vfill">vfill</A> : \r
+<B>procedure</B>( y : integer);</H2>\r
+ { draw a vertical line between the current position and<P>\r
+ (currentX,y) with the current color, after it change the current<P>\r
+ position to (currentX,y)<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="patern">patern</A> : \r
+<B>procedure</B>( x1,y1,x2,y2,c,b : \r
+integer);</H2>\r
+ { draw a <B><I>rectangle</I></B> between the points (<I>x1,y1</I>) and \r
+(<I>x2</I>,<I>y2</I>) with the<P>\r
+ color <I>c</I> (the current color is not change). if <I>b</I>=0 then the box \r
+is<P>\r
+ empty else it is filled.<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2>{ Procedures operating on bitmaps }</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="GETMAP">GETMAP</A> : \r
+<B>function</B> (x,y : integer) : <B>arrayof</B> \r
+integer;</H2>\r
+ {saves rectangular area between current position as<P>\r
+ top left corner and (ix,iy) as bottom right corner,<P>\r
+ including border lines;<P>\r
+ position remains unchanged.<P>\r
+ array of integer should have <P>\r
+ 4+(rows**columns/8* *coeff)<P>\r
+ bytes. The coefficient coeff is 1 for Hercules, 2 for CGA, 4 for EGA<P>\r
+ card.<P>\r
+ ATTENTION: in DOS 286 environment a bigger size of the array may \r
+ necessitate the use of <I>loglan</I> with<I> the option H+</I>, see also \r
+memavail <P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="PUTMAP">PUTMAP</A> : \r
+<B>procedure</B> ( a: <B>arrayof</B> \r
+integer);</H2>\r
+ {sets rectangular area of screen pixels to that saved<P>\r
+ by "getmap" in "iarray";<P>\r
+ same size is restored, with top left corner in current<P>\r
+ position;<P>\r
+ position remains unchanged.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A \r
+NAME="ORMAP">ORMAP</A> : \r
+<B>procedure</B> ( a : <B>arrayof \r
+</B>integer);</H2>\r
+ {same as putmap, but saved bitmap is or'ed into screen<P>\r
+ rather than just set.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+<H2><B>unit </B> <A NAME="XORMAP \r
+">XORMAP </A> : <B>procedure</B> ( a: \r
+<B>arrayof</B> integer);</H2>\r
+ {same as putmap, but saved bitmap is xor'ed into screen<P>\r
+ rather than just set.<P>\r
+ }\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+<H2>{Procedures operating on characters and strings}</H2>\r
+\r
+<H2><B>unit </B> <A \r
+NAME="outstring">outstring</A> : \r
+<B>procedure</B>(x,y: integer, s: string, back_col, \r
+front_col: integer);</H2>\r
+ { <I>x, y</I> are the coordinates where to put the string,<P>\r
+ <I>s</I> is the string to be shown, in <I>front_col</I> colour letters on the \r
+<I>back_col</I> colour background<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="track">track</A> \r
+: <B>procedure</B>( x,y,c,valeur : integer);\r
+</H2>\r
+ { write an integer value <I>valeur</I> at the position (<I>x,y</I>) with the \r
+color <I>c</I>.\r
+ It does not change the current position nor the current color<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="inkey ">inkey \r
+</A> : <B>function</B> : integer;</H2>\r
+\r
+ { returns next character from keyboard buffer;<P>\r
+ 0 is returned if buffer is empty;<P>\r
+ special keys are returned as negative numbers;<P>\r
+ ALT-NUM method may be used for entering character codes<P>\r
+ above 127 (this makes entering special keys 128-132<P>\r
+ impossible);<P>\r
+ if a character is returned, it is also removed<P>\r
+ from the buffer, so MS-DOS will not see it (CTRL-C!);<P>\r
+ typeahead is allowed, echo is suppressed.<P>\r
+ }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B>unit </B> <A NAME="HASCII \r
+">HASCII </A> : <B>procedure</B>(c: \r
+integer);</H2>\r
+ {'xor's the character = chr(c) in a 8*8 box with top left corner<P>\r
+ in the current position;<P>\r
+ moves current position by (8,0);<P>\r
+ call hascii(0)- sets complete box to black ( =background ),<P>\r
+ with no change in position.<P>\r
+}\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<P>\r
+\r
+\r
+<H2><B>unit </B><A NAME="hfont">hfont</A> \r
+: <B>function</B>( \r
+x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;</H2>\r
+\r
+ { arrange a small 1 line window for <B><I>reading</I></B> an integer value \r
+from this window,\r
+the position of the window corner is (<I>x, y</I>),\r
+the length of the window is <I>lg</I> characters,\r
+the value v should be greater than <I>min</I> and smaller than <I>max</I>,\r
+the default value read is <I>default</I>,<P>\r
+the colour of the window is <I>col_f</I>,<BR>\r
+the colour of the digits is <I>col_e,</I><BR>\r
+the colour of cursor is <I>col_c</I><P>\r
+\r
+ reads in graphic mode an integer in the window which begins at the (x,y)\r
+ position, window is lg caracteres long. the maximum length of the<P>\r
+ integer that is read is 10. there is a default value, a minimum value\r
+ and a maximum value. the window is drawn with the col_f color, the \r
+ cursor is in the col_c color and the integer is writing in the col_e<P>\r
+ color. you can use 0..9,+,-,backspace,escape and return keys. }<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2><B>unit </B> <A NAME="HPAGE \r
+">HPAGE </A> : <B>procedure</B>(x,y,long: \r
+integer, A: arrayof char, back, front: integer);</H2>\r
+ { this procedure arranges a 1-line high window in position <I>x,y</I> of \r
+length <I>long</I> in which a portion of text <I>A</I> is shown in colour \r
+<I>front</I> on the background colour <I>back</I>. <P>\r
+ Making use of keys controlling the cursor {left, right, PgUp, PgDn}<P>\r
+ the user can scroll the text (horizontally) in the window. Pressing the \r
+ Enter key terminates the procedure} <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<P align=left><B>end</B> IIUWGRAPH;<P>\r
+\r
+\r
+\r
+<HR>\r
+<P><H2><B>unit </B> <A \r
+NAME="MOUSE">MOUSE</A> .: \r
+<B>class</B>; </H2>\r
+ <P><HR>\r
+<H6>{ <I>init</I> -lors de l'initialisation de la souris, on peut définir les événements qui vont faire réagir la \r
+fonction getpress; le premier et le deuxième paramètre représentent respectivement la souris et le clavier, si une \r
+valeur non nulle est donnée comme paramètre alors getpress réagira à l'événement.<P>\r
+\r
+ Une paire (1,1) va permettre de prendre en compte à la fois les événements de la souris et ceux du clavier; \r
+une paire (1,0) quand à elle ne prendra en compte que la souris. Pour une plus grande souplesse d'utilisation, il est \r
+possible lors du programme, après l'initalisation, de changer cette prise en compte, cela se fera par l'appel de la \r
+procedure <I>getmovement</I>, procédure ayant les mêmes paramètres (avec le même ordre) que la fonction \r
+init.<P>\r
+\r
+ Pour detecter les événements, on utilisa la fonction <I>getpress</I>, qui retourne un booléen indiquant la \r
+présence ou l'absence d'événement (respectivement les valeurs true et false). Il est bon de noter qu'ainsi définie la \r
+fonction getpress n'est pas bloquante. Les paramètres en retour sont soit nuls (pas d'événement) soit \r
+correspondent:<P>\r
+\r
+ bool:=getpress(v,p,h,l,r,c : integer);<P>\r
+ v = position en y de la souris<P>\r
+ p = keyboard status (Touche control_left,control_right, alt, alt_gr, shift_left, shift_right)<P>\r
+ h = position en x de la souris<P>\r
+ l = touche clavier<P>\r
+ r = flags<P>\r
+ c = boutons de la souris (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)<P>\r
+ Nb: le bouton central n'est pas géré.<P>\r
+\r
+NOTEZ BIEN! Lorsque les événements du clavier sont pris en compte dans le gestionnaire, <B>il</B> <B>ne faut \r
+pas </B>utiliser les fonctions d'entrées clavier readl, readln, hfont, hfont8, hpage, inkey,...) <I>sous peine de \r
+plantage de l'ordinateur</I>.<P>\r
+}</H6>\r
+<HR>\r
+<P>\r
+<H2> <B>unit </B> <A NAME="init">init</A> \r
+: <B>procedure</B>(checkMouse, \r
+checkKeyboard: integer); </H2>\r
+ { initializes the Mouse driver.<P>\r
+ tells which events will be checked:<P>\r
+ if checkMouse < > 0 then the events of Mouse will be reported to getpress, see below otherwise \r
+ignored;<P>\r
+ if checkKeyboard < > 0 then the events of Keyboard will be reported to getpress, otherwise ignored<P>\r
+ <B><I>Attention please!</I></B> While the events of the keyboard are taken under control by \r
+<I>init</I> or <I>getmovement</I><P>\r
+ <B><I>do not use</I></B> the functions or procedures: read, readln, hfont, hfont8, hpage, inkey \r
+that read keys<P>\r
+ YOU RISK TO HANG YOUR SYSTEM!<P>\r
+<B> }</B><P>\r
+ <B>end</B> init <P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B> unit </B><A \r
+NAME="getmovement">getmovement</A> : \r
+<B>procedure</B>(checkMouse, checkKeyboard: \r
+integer); </H2>\r
+ tells which events will be checked:<P>\r
+ if checkMouse < > 0 then the events of Mouse will be reported to getpress, see below otherwise \r
+ignored;<P>\r
+ if checkKeyboard < > 0 then the events of Keyboard will be reported to getpress, otherwise ignored<P>\r
+ <B><I>Attention please!</I></B> While the events of the keyboard are taken under control by \r
+<I>init</I> or <I>getmovement</I><P>\r
+ <B><I>do not use</I></B> the functions or procedures: read, readln, hfont, hfont8, hpage, inkey \r
+that read keys<P>\r
+ YOU RISK TO HANG YOUR SYSTEM!<P>\r
+ <B>end</B> getmovement;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2><B> unit </B> <A \r
+NAME="getpress">getpress</A> : \r
+<B>function</B>(v,p,h,l,r,c : integer): \r
+Boolean;</H2>\r
+ { <I>v</I> = y coordinate of the cursor,<P>\r
+ <I>h</I> = x coordinate of the cursor,<P>\r
+ <I>p</I> = keybord status control_left,control_right, alt, alt_gr, shift_left, shift_right<P>\r
+ <I>l</I> = code of key pressed<P>\r
+ <I>r</I> = flags<P>\r
+ <I>c</I> = buttons pressed (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)<P>\r
+ Nb: the middle button is not taken into account.<P>\r
+ <B>end</B> getpress<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+\r
+<H2> <B>unit </B> <A \r
+NAME="showcursor">showcursor</A> : \r
+<B>procedure</B>; </H2>\r
+ {the cursor becomes visible and follows the movements of the mouse}<P>\r
+ end showcursor;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+\r
+<H2> <B>unit </B> <A \r
+NAME="hidecursor">hidecursor</A> : \r
+<B>procedure</B>; </H2>\r
+ {the cursor becomes invisible}<P>\r
+ end hidecursor;<P>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A><BR>\r
+\r
+<P align=left><B>end</B> MOUSE;<P>\r
+\r
+<HR>\r
+\r
+<H2>Enclosed you find a <A NAME="sample program">sample program</A> .</H2>\r
+<PRE>\r
+Program SystemeGraph; \r
+ (* by Frederic Pataud, October 1994 *) \r
+Begin \r
+Pref iiuwgraph block (* inherit the graphic functions *) \r
+ Begin \r
+ Pref mouse block (* inherit the mouse functions *) \r
+\r
+\r
+(*********************************************************************) \r
+(* P r o g r a m m e P r i n c i p a l *) \r
+(*********************************************************************) \r
+ var v,p,h,i : integer, \r
+ l,r,c : integer, \r
+ rep : arrayof char, \r
+ d : boolean, \r
+ xx,yy : arrayof integer, \r
+ status,code,x,y,flags,button : integer; \r
+ \r
+ Begin \r
+ \r
+ call gron(0); (* enter the graphic mode *) \r
+ call init(1,0); (* initialize the mouse, disregard the keyboard events, check for mouse events *) \r
+ \r
+ call showcursor; (* show cursor *) \r
+ call patern(5,5,635,475,2,0); (* make a frame around the screen *) \r
+ call outstring(10,10,"x=",2,0); \r
+ call outstring(100,10,"y=",2,0); \r
+ call outstring(10,30,"status = ",2,0); \r
+ call outstring(10,50,"code = ",2,0); \r
+ call outstring(10,70,"flags = ",2,0); \r
+ call outstring(10,90,"button = ",2,0); \r
+ call patern(100,210,300,320,3,1); (* make a rectangle filled in colour 3 *) \r
+\r
+ array xx dim (1:6); \r
+ array yy dim (1:6); \r
+ xx(1):=410; yy(1):=10; \r
+ xx(2):=450; yy(2):=30; \r
+ xx(3):=460; yy(3):=50; \r
+ xx(4):=430; yy(4):=80; \r
+ xx(5):=420; yy(5):=40; \r
+ xx(6):=480; yy(6):=30; \r
+ call intens(6,xx,yy,8,1); (* show a polygon filled*) \r
+ for i:=1 to 6 \r
+ do \r
+ yy(i):=yy(i)+100; \r
+ od; \r
+ call intens(6,xx,yy,15,0); (* show another polygon empty *) \r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0); (* draw an empty pie or camembert *) \r
+ call cirb(400,400,40,40,600,4000,11,1); (* draw a filled pie *) \r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); (* read integer from a window *) \r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); (* show text *) \r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15); (* read text *) \r
+ \r
+ call getmovement(1,1); (* take into consideration both key events and mouse events *) \r
+ \r
+ do \r
+ d:=getpress(v,p,h,l,r,c); (* ask about an event *) \r
+ if (d) \r
+ then call outstring(10,400,"Event",2,0); \r
+ call patern(80,25,130,100,0,1); \r
+ call track(40,10,v,0,4); (* print integer *) \r
+ call track(140,10,p,0,4); \r
+ call track(80,30,h,0,4); \r
+ call track(80,50,l,0,4); \r
+ call track(80,70,r,0,4); \r
+ call track(80,90,c,0,4); \r
+ if((h=164 and l=27) or (c=3)) (* exit if either two buttons were pressed c=3 or Ctrl+Esc key *) \r
+ then exit; \r
+ fi; \r
+ fi; \r
+ od; \r
+ call groff; (* leave the graphic mode and return to the text mode *) \r
+ writeln("i=",i); \r
+ for i:=lower(rep) to upper(rep) \r
+ do \r
+ write(rep(i)); \r
+ od; \r
+ writeln; \r
+ End \r
+ End \r
+End. \r
+</PRE>\r
+<P ALIGN=RIGHT><A HREF = "#Table of Contents">to ToC</A>\r
+<p align=LEFT>\r
+<HR>\r
+<Address> <A HREF = "http://www.univ-pau.fr/~salwicki/GMyAS.html">GMyAS</A> Last update Sun 7 May \r
+1995 </Address> \r
+</BODY>\r
+</html>\r
+\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Klasy i obiekty</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1><IMG SRC="loglanmm.gif" ALIGN="BOTTOM"> Chapter 1: Classes\r
+and objects</H1>\r
+\r
+<P>\r
+The still growing fascination of object-oriented programming dates\r
+to 1989 when several software companies offered compilers of object-oriented\r
+Pascal's, of C (C++ and Objective C) etc. We welcome this recognition\r
+of merits of object-oriented programming with satisfaction. Let\r
+us recall that classes and objects have more than 24 years of\r
+tradition. They appeared in Simula-67. Along the line of R&D\r
+concerning classes and their objects one can find the results\r
+achieved at the Institute of Informatics, University of Warsaw.\r
+We shall present many of them during these lectures.\r
+<P>\r
+Notion of object has its roots in the well known structure of\r
+an Algol and Pascal-like program.\r
+<P>\r
+Let us begin with the notion of module. In a program one can indicate\r
+several modules. The whole program is a module, every procedure\r
+and function declared in a program is a module too.\r
+<P>\r
+In the language Loglan we have more kinds of modules:\r
+<UL>\r
+<LI> blocks, \r
+<LI>procedures, \r
+<LI>functions, \r
+<LI>classes, \r
+<LI>coroutines, \r
+<LI>processes, \r
+<LI>modules which serve the exceptions and/or signals - they are\r
+shortly called handlers.\r
+</UL>\r
+\r
+<P>\r
+Let us look at the most external module of a program\r
+<PRE>\r
+ _______________________ \r
+ |<B>program</B> name (...) |\r
+ | | This a module.\r
+ | <<I>declarations</I>> e.g. | (It can contain other modules) \r
+ | <B>var</B> x,y:real,a:bool;|\r
+ | |\r
+ |<B>begin</B> |\r
+ | |\r
+ | <<I>instructions</I>> e.g. |\r
+ | x:=x+y; |\r
+ | a:=x*x<y; |\r
+ | <B>if</B> <B>not</B> a <B>then</B> ...<B>fi</B>;|\r
+ | <B>while</B> ... |\r
+ | <B>do</B> |\r
+ | ... |\r
+ | <B>od</B> |\r
+ | |\r
+ |<B>end</B> |\r
+ |_____________________|\r
+</PRE>\r
+\r
+<P>\r
+During an execution of a program the so called activation record\r
+of the above module is allocated in a memory. This is a prototype\r
+of the notion of object.\r
+<PRE>\r
+ _________________________\r
+ |<I>memory of data</I> |\r
+ | |\r
+ | x real 0.5 |\r
+R | y real -1.17 | This is an activation record,\r
+A | a bool true | sometimes called a dynamic ins-\r
+M | ..................... | tance of the (program) module.\r
+ |<I>memory of instructions</I> |\r
+m | x:=x+y; |\r
+e | a:=x*x<y; |\r
+m | <B>if</B> <B>not</B> a <B>then</B> ... <B>fi</B>; |\r
+o | <B>while</B> ... |\r
+r | <B>do</B> |\r
+y | ... |\r
+ | <B>od</B> |\r
+ |_______________________|\r
+</PRE>\r
+\r
+<P>\r
+Object-oriented programming develops the above remarks and enriches\r
+the image the reader could build from them. In particular, object-oriented\r
+programming requires more frames and assumes a wider spectrum\r
+of the types of frames. Objects are just one type of frames appearing\r
+in programming.\r
+<P>\r
+More frames! Where they are coming from? Can we recognize them\r
+in our Pascal practice? Yes, they arise during execution of procedure\r
+statements. How? They are known under the name of activation records\r
+or dynamic instances of procedures.\r
+<P>\r
+An example, a snapshot of program's execution may look like:\r
+<P>\r
+The above picture is a snapshot of an execution of the main program\r
+taken in the moment when in the main program we executed a <B>call\r
+</B>g procedure instruction, which caused the creation of an activation\r
+record for g and its execution, which in turn executed a <B>call\r
+</B>f procedure instruction, which caused the creation of (1st)\r
+instance of an activation record for f procedure and ...\r
+<PRE>\r
+ __________________________________________________\r
+ | ___________ |\r
+ __|______________ _____________|____ | | \r
+ | <I>activ.rec</I> f | | <I>activ.rec. </I>g | | |\r
+ | ÆÍÍÍÍÍ>͵ | | |\r
+ | <I>(1st instance)</I>| | <I>(1st instance)</I> | | |\r
+ | | | | ____________\r
+ | | |<I> ______________</I> ====> | <I>Main</I> |\r
+ | <I>____________</I> | | | | |\r
+ | ... | | <B>call</B> f | |f: <B>proc</B> |\r
+ | <B>call </B>f | | | | |\r
+ | | | | |g: <B>proc</B> |\r
+ | | | | | |\r
+ ----------------- ------------------ |<I>_________</I> |\r
+ ^ | |\r
+ | _________________________________>___|<B>call </B>g |\r
+ ________________ __________________ | |\r
+| <I>activ.rec. </I>f | | <I>activ.rec. </I>f ÃÄÄÄÄ>Ä´ |\r
+| ÆÍ<ÍÍ͵ | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+| <I>(2nd instance)</I> | | <I>(3rd instance)</I> |\r
+| | | |\r
+| <I>_____________</I> | | |\r
+| | | |\r
+| <B>call </B>f | | ... |\r
+| | | |\r
+|________________| |_________________|\r
+</PRE>\r
+\r
+<P>\r
+The instance of main program is the static father of all remaining\r
+activation records. This may be denoted by single lines (static\r
+links) leading to the leftmost object. A static father of an object\r
+is to be searched when the processor finds an identifier e.g.\r
+a variable which is non-local for a currently executed object.\r
+This in turn may lead to further searches along the path of static\r
+links. In every snapshot the set of objects together with the\r
+set of all static links creates a tree. Every edge of this graph\r
+corresponds to the tree structure of module nesting in an obvious\r
+way.\r
+<P>\r
+Another kind of arrows (double lines) leads from an object to\r
+its dynamic father i.e. to the object in which processor subsumes\r
+the execution of instructions when all the instructions of a current\r
+object are executed to the <B>end. </B>The<B> </B>graph<B> </B>structure\r
+of objects and dynamic links differs from the previous one and\r
+shows "who called who". Making use of our Pascal experience\r
+we would like to assert it is a straight line structure. Later\r
+we shall see that objects and coroutines enrich and complicate\r
+the picture.\r
+<P>\r
+Let us think of a <I>scenario</I> for an activation record of\r
+a procedure.\r
+<P>\r
+<I>About Simula-67 <BR>\r
+</I>The origins of object oriented programming go back to 1967\r
+when O.-J.Dahl, K.Nygaard and B.Myhrhaug defined the language\r
+Simula-67. [books: SIMULA<B>begin</B> by G.Birtwistle, O.J.Dahl,\r
+Auerbach Publ. and Simula 67 by W.M.Bartol, H.Oktaba, PWN Publ.\r
+are worth reading].\r
+<P>\r
+<I>about class <BR>\r
+</I>General structure of a class module is as follows:\r
+<PRE>\r
+<B> unit </B><<I>name_of_class</I> >: <B> class</B> (<<I>formal parameters</I>>);\r
+ <<I>local declarations\r
+ of variables, procedures, functions and classes</I>! >\r
+ <B>begin</B> \r
+ <<I>instructions</I>>\r
+ <B>end</B> <<I>name_of_class</I> >\r
+</PRE>\r
+\r
+<P>\r
+<U>Example</U> \r
+<PRE>\r
+<B>unit </B>circle : <B> class</B> (center: point, radius: real);\r
+<B>unit</B> intersects: <B>function</B> (c: circle): line;\r
+{the function returns the line which passes through the intersection points of this circle object and the c circle object, NOTE! it might return <B>none </B>if the two circles have no common points, see how it is solved below }...\r
+<B>end</B> intersects; \r
+<B>begin</B> \r
+<B>if</B> r=0 <B>then</B> <B>raise </B>SignalNoCircle <B>fi\r
+end</B> circle\r
+</PRE>\r
+\r
+<P>\r
+Let us remark that the syntactic difference between a procedure\r
+declaration and class declaration is little: the keyword <U>procedure</U>\r
+is replaced by another keyword <U>class</U>. However, the semantics\r
+is entirely different as it will be seen from the diagram-scenario\r
+below.\r
+<P>\r
+<I>declaration of variables of type class <BR>\r
+</I>One can assume that every declaration of a class introduces\r
+a new type, for it enables declarations of variables like:\r
+<PRE>\r
+ <B>var </B>x : circle\r
+</PRE>\r
+\r
+<P>\r
+objects<BR>\r
+Objects of classes can be generated by means of expressions (object\r
+generator) of the form <BR>\r
+<B>new</B> KLASA(<I>actual_parameters</I>> <BR>\r
+and stored in variables <BR>\r
+k:= <B>new</B> KLASA(<I>actual_paramts</I>) <BR>\r
+One module of a class can serve as a pattern for many objects\r
+<BR>\r
+x:= <B>new</B> circle(point1, 88); <BR>\r
+y:= <B>new</B> circle(<B>new</B> point(45,159), 644) <BR>\r
+they can have different names. The names help to acces objects\r
+<BR>\r
+z:= x <BR>\r
+and their internal structure <BR>\r
+x.center ... y.radius <BR>\r
+The values of the latter expressions will be correspondingly:\r
+point1 and 644.\r
+<PRE>\r
+scenario of an object looks as follows<A NAME="DDE_LINK1"></A><A NAME="DDE_LINK2"></A>\r
+</PRE>\r
+\r
+<P>\r
+<I>IMPORTANT consequences</I> <BR>\r
+1. one can use initialization phase to execute an algorithm or\r
+to initialize objects.<BR>\r
+<B>EXERCISE</B>. write factorial algorithm using objects and no\r
+recursion. <BR>\r
+2. objects can be used as records, <BR>\r
+<B>EXERCISE</B>. write a piece of program which realizes a tree.\r
+<BR>\r
+3. one can send commands to objects, an object is able to execute\r
+the <B>call</B> commands referring to its local procedure declarations\r
+(and local functions too) <BR>\r
+e.g. call x.aProc(a) <BR>\r
+z:= x.aFun(b) <BR>\r
+if aProc and aFun were declared in a class C and if x denotes\r
+an object of the class C.\r
+<PRE>\r
+Examples\r
+ complex numbers\r
+<B>unit</B> complex: <B> class</B> (re,im: real);\r
+<B>var</B> module: real;\r
+<B> unit </B>add:<B> function</B>(z: complex): complex;\r
+<B>begin</B> result:= <B> new</B> complex(re+z.re, im+z.im)\r
+<B> end</B> add;\r
+<B>unit </B>mult:<B> function</B>(z: complex): complex;\r
+<B>begin</B> result:= <B> new</B> complex(re*z.re-im*z.im, re*z.im+z.re*im)\r
+<B> end</B> mult;\r
+<B>begin</B> module:= sqrt(re*re+im*im)\r
+<B>end </B>complex;\r
+\r
+Having such class one can create several objects of type complex and manipulate on them e.g.\r
+<B>program </B>UsingComplex;\r
+<B>unit</B> complex ... <B>end</B> complex;\r
+<B>var</B> c1,c2,z1,z2: complex;\r
+<B>begin</B> c1:= <B>new</B> complex(1,9); <I>{creation of complex number 1+9i}</I> c2:= <B>new</B> complex(-3,-21); <I> {second object of class complex}</I> z1:= c1.add(c2.mult(c1)); <I>{now z1=c1+(c2*c1))}</I> z2:= z1.mult(<B>new </B>complex(z1.re,-z1.im)) <I>{Note an object without a name, once used, it becomes a garbage}</I><B>end </B>UsingComplex\r
+</PRE>\r
+\r
+<P>\r
+<B>EXERCISE</B>. Write a similar program in Pascal and compare\r
+: how many parameters transmitted in an expression?, are the concepts\r
+of complex numbers encapsulated?\r
+<P>\r
+EXAMPLE which follows introduces concepts of planar geometry and\r
+uses them in a prefixed block. The reader can run it and modify\r
+it as well. {This is the first Loglan program I wrote in December\r
+1981 to test the compiler.} <BR>\r
+\r
+<PRE>\r
+<B>program</B> CircumscribedCircle;\r
+\r
+<B>unit</B> GEOPLAN : <B>class</B>;\r
+(* This class is in fact a problem oriented language, it offers various facilities for problem solving in the field of analitical planar geometry. \r
+<I>The class has the following structure:</I> <I>remark the correspondence between software notions of class, procedure, function and</I> <I>the notions of general algebra: algebraic structure, sorts and operations </I> \r
+\r
+ GEOPLAN <----- class <I>algebraic structure</I> / | \\r
+ / | \\r
+ / | \\r
+ POINT CIRCLE LINE <----- classes <I>sorts</I> / | \ | / | \ \r
+ / | \ | / | \ <I>operations</I> / | | | | | \ <--|\r
+ / | | | | | \ |\r
+opera- EQUALS DIST | | MEETS | \ |\r
+ ERROR | | ERROR \ tions \r
+ | | / \r
+ INTERSECTS | |\r
+ | |\r
+ PARALLELTO <--|\r
+<I>*)</I> <B>unit</B> POINT : <B>class</B>(X,Y : REAL);\r
+<B>unit</B> EQUALS : <B>function</B> (Q : POINT) : BOOLEAN;\r
+<B>begin</B> RESULT:= Q.X=X <B>and</B> Q.Y=Y ;\r
+<B>end</B> EQUALS;\r
+\r
+<B>unit</B> DIST : <B>function</B> (P : POINT) : REAL;\r
+<I>(* DISTANCE BETWEEN THIS POINT AND POINT P *)</I> <B>begin</B> <B>if</B> P = <B>none</B> <B>then</B> <B>call</B> ERROR\r
+<B>else</B> <B>result</B>:= SQRT((X-P.X)*(X-P.X)+(Y-P.Y)*(Y-P.Y))\r
+<B>fi</B> <B>end</B> DIST;\r
+\r
+\r
+<B>unit</B> <B>virtual</B> ERROR : <B>procedure</B>;\r
+<B>begin</B> WRITELN(" THERE IS NO POINT")\r
+<B>end</B> ERROR;\r
+<B>end</B> POINT;\r
+\r
+\r
+<B>unit</B> CIRCLE : <B>class</B> (P : POINT, R : REAL);\r
+<I>{ THE CIRCLE IS REPRESENTED BY ITS CENTER P AND THE RADIUS R }</I> \r
+<B>unit</B> INTERSECTS : <B>function</B> (C : CIRCLE) : LINE;\r
+<I>(* IF BOTH CIRCLES INTERSECT AT 2 POINTS, THE LINE JOINING THEM\r
+ IS RETURNED. IF CIRCLES INTERSECT AT ONE POINT, IT IS TANGENT\r
+ TO BOTH OF THEM. OTHERWISE PERPENDICULAR BISECTION OF THEIR CENTRES IS RETURNED *)</I> <B>var</B> R1,R2 : REAL;\r
+<B>begin</B> <B>if</B> C=/= <B>none</B> <B>then</B> R1:= R*R-P.X*P.X-P.Y*P.Y;\r
+ R2:= C.R*C.R-C.P.X*C.P.X-C.P.Y*C.P.Y;\r
+<B>result</B> := <B>new</B> LINE (P.X-C.P.X,P.Y-C.P.Y,(R1-R2)/2);\r
+<B>fi</B> <B>end</B> INTERSECTS;\r
+\r
+<B>begin</B> <B>if</B> P=<B>none</B> \r
+<B>then</B> WRITELN (" WRONG CENTRE")\r
+<B>fi</B> <B>end</B> CIRCLE;\r
+\r
+\r
+<B>unit</B> LINE : <B>class</B> (A,B,C : REAL);\r
+<I>{LINE IS REPRESENTED BY COEFFICIENTS OF EQUATION AX+BY+C=0 }</I> \r
+\r
+<B>unit</B> MEETS : <B>function</B> (L : LINE) : POINT;\r
+<I> (* IF TWO LINES INTERSECT function MEETS RETURNS THE POINT\r
+ OF INTERSECTION, OTHERWISE RETURNS NONE *)</I> <B>VAR</B> T : REAL;\r
+<B>begin</B> <B>if</B> L =/= <B>none</B> <B>and</B> <B>not</B> PARALLELTO (L)\r
+<B>then</B> T := 1/(L.A*B-L.B*A);\r
+<B>result</B> := <B>new</B> POINT (-T*(B*L.C-C*L.B),\r
+ T*(A*L.C-C*L.A));\r
+<B>else</B> <B>call</B> ERROR\r
+<B>fi</B> <B>end</B> MEETS;\r
+<B>unit</B> PARALLELTO : <B>function</B> (L : LINE) : BOOLEAN;\r
+<B>begin</B> <B>if</B> L=/= <B>none</B> <B>then</B> <B>if</B> A*L.B-B*L.A = 0.0\r
+<B>then</B> <B>result</B>:=TRUE; WRITELN(" zle"); \r
+<B>else</B> <B>result</B>:=FALSE; WRITELN(" dobrze");\r
+<B>fi</B> \r
+<B>else</B> <B>call</B> ERROR\r
+<B>fi</B> <B>end</B> PARALLELTO;\r
+\r
+<B>unit</B> <B>virtual</B> ERROR : <B>procedure</B>;\r
+<B>begin</B> WRITELN(" THERE IS NO LINE")\r
+<B>end</B> ERROR;\r
+\r
+<B>var</B> D : REAL;\r
+\r
+<B>begin</B> <I>(* NORMALIZATION OF COEFFICIENTS *)</I> D := SQRT(A*A+B*B);\r
+<B>if</B> D= 0.0\r
+<B>then</B> WRITELN( " ZLE, ZERO"); <B>call</B> ERROR\r
+<B>else</B> A := A/D;\r
+ B := B/D;\r
+ C := C/D;\r
+<B>fi</B> <B>end</B> LINE;\r
+\r
+<B>end</B> GEOPLAN;\r
+\r
+\r
+\r
+<B>begin</B> \r
+<B>pref</B> GEOPLAN <B>block</B><I> (* THE LANGUAGE GEOPLAN IS USED FOR FINDING THE CIRCLE CIRCUMSCRIBED ON A GIVEN TRIANGLE:</I> \r
+ P\r
+ / \\r
+ / \\r
+ / .<-\------- CENTRE \r
+ / \\r
+ Q---------R \r
+<I>*)</I> <B>taken</B> POINT,LINE,CIRCLE;\r
+\r
+<B>var</B> P,Q,R,CENTRE : POINT,\r
+ L1,L2 : LINE,\r
+ C1,C2,C4 : CIRCLE,\r
+ RADIUS, X1,Y1 : REAL;\r
+\r
+<B>begin</B> <B>do</B> WRITELN("THIS PROGRAM FINDS THE CENTRE AND RADIUS OF ");\r
+ WRITELN(" THE CIRCLE CIRCUMSCRIBED ON A GIVEN TRIANGLE ");\r
+ WRITELN(" GIVE THE VERTICES COEFFICIENTS OF A TRIANGLE");\r
+ WRITELN(" X1,Y1= ?? ??");\r
+ READ (X1,Y1);\r
+ P := <B>new</B> POINT(X1,Y1);\r
+ WRITELN(" ",X1," ",Y1);\r
+ WRITELN(" X2,Y2= ?? ??");\r
+ READ (X1,Y1);\r
+ Q := <B>new</B> POINT(X1,Y1);\r
+ WRITELN(" ",X1," ",Y1);\r
+ WRITELN(" X3,Y3= ?? ??");\r
+ READ (X1,Y1);\r
+ R := <B>new</B> POINT (X1,Y1);\r
+ WRITELN(" ",X1," ",Y1);\r
+\r
+ RADIUS := P.DIST(Q) + Q.DIST(R);\r
+ C1 := <B>new</B> CIRCLE (P,RADIUS);\r
+ C2 := <B>new</B> CIRCLE (Q,RADIUS);\r
+ C4 := <B>new</B> CIRCLE (R,RADIUS);\r
+\r
+ L1 := C2.INTERSECTS(C1); \r
+<I> (*THE PERPENDICULAR BISECTOR OF THE SIDE PQ*)</I> L2 := C2.INTERSECTS(C4); \r
+<I> (*THE PERPENDICULAR BISECTOR OF THE SIDE QR *)</I> \r
+ CENTRE := L1.MEETS(L2);\r
+\r
+<B>if</B> CENTRE = <B>none</B> <B>then</B> WRITELN(" ALL POINTS LAY ON THE SAME LINE");\r
+<B>else</B> WRITELN(" THE CIRCUMSCRIBED CIRCLE IS AS FOLOWS:");\r
+ WRITELN(" CENTRE = (",CENTRE.X,',',CENTRE.Y,')');\r
+ WRITELN(" RADIUS = ",CENTRE.DIST(P));\r
+<B>fi</B> <B>od</B> <B>end\r
+end</B> \r
+The static structure of modules in the above program is the tree\r
+\r
+\r
+ PROGRAM\r
+ / \\r
+ / \\r
+ / \ \r
+ / \\r
+ GEOPLAN <B>pref</B> GEOPLAN <B>block</B> \r
+\r
+ / | \\r
+ / | \\r
+ / | \\r
+ POINT CIRCLE LINE \r
+\r
+ / | \ | / | \ \r
+ / | \ | / | \\r
+ / | | | | | \ \r
+ / | | | | | \ \r
+ EQUALS DIST | | MEETS | \ \r
+ ERROR | | ERROR \r
+ | |\r
+ | | \r
+ INTERSECTS | \r
+ | \r
+ PARALLELTO \r
+\r
+\r
+The edges lead from a module to its static father (up). The module GEOPLAN and the block prefixed with the name GEOPLAN are in another relation: namely of prefixing, or inheritance. We shall develop this remark later. What is worth noting here is that the structure of GEOPLAN remains intact. This is due to the fact that the class GEOPLAN encapsulates the structure of internal classes and modules.\r
+</PRE>\r
+\r
+<P>\r
+Let us view a few snapshots.\r
+<PRE>\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ The initial snapshot shows just one \r
+ |<B>program</B> | dynamic instance of the main prog-\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ | ram.\r
+ | |GEOPLAN | |\r
+ | | | | The only instruction to be execu-\r
+ | | | | ted is the instruction of prefixed \r
+ | | | | block.\r
+ | | | |\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ |\r
+ | |\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ |\r
+ | |<B>block</B> | | ---- block prefixed with GEOPLAN\r
+ | | | |\r
+ | | | |\r
+ | | | |\r
+ | | | |\r
+ | | | |\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ |\r
+ | |\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ\r
+\r
+Just before the first writeln ... instruction\r
+\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿SL ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿\r
+ |program ÃÄÄ<ÄÄÄÄÄÄÄÄÄ´GEOPLAN <B>block</B> |\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ |DL | |\r
+ | |GEOPLAN | ÆÍÍ<ÍÍÍÍÍÍÍÍ͵ all features of |\r
+ | | | | | GEOPLAN inhtd. |\r
+ | | | | | |\r
+ | | | | | P point <B>none</B> |\r
+ | | | | | Q point <B>none</B> |\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | R point <B>none</B> |\r
+ | | | C1 circle <B>none</B> |\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ | | C2 circle <B>none</B> |\r
+ | |<B>block</B> | | | C4 circle <B>none</B> |\r
+ | | | | | L1 line <B>none</B> |\r
+ | | | | | L2 line <B> none</B> |\r
+ | | | | | RADIUS real 0 |\r
+ | | | | | CENTRE |\r
+ | | | | | |\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | |\r
+ | | | |\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ\r
+ This may be a snapshot just before the instruction putting radius to be equal the sum of distances PQ and QR. We omitted all SL links and DL links in order to simplify the picture. \r
+\r
+\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ |program | |GEOPLAN <B>block</B> | ÚÄÄÄÄÄ´ X real 4 |\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ | | | | | Y real 6 |\r
+ | |GEOPLAN | | | all features of | | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | GEOPLAN inhtd. | | ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | | | ÚÄÄÄ´ X real -4|\r
+ | | | | | P point ÄÄÄÄÄÄÄÅÄÙ | | Y real 88|\r
+ | | | | | Q point ÄÄÄÄÄÄÄÅÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | R point ÄÄÄÄÄÄÄÅÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | C1 circle <B>none</B> | | | X real -9|\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ | | C2 circle <B>none</B> | ÀÄÄÄ´ Y real 23|\r
+ | |<B>block</B> | | | C4 circle <B>none</B> | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | L1 line <B>none</B> | \r
+ | | | | | L2 line <B> none</B> | \r
+ | | | | | RADIUS real 0 |\r
+ | | | | | |\r
+ | | | | | |\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | => radius:= ... |\r
+ | | | |\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ\r
+\r
+\r
+\r
+\r
+ This may be a snapshot just after the three circles were created. \r
+\r
+\r
+ ___________________ ___________________ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ |program | |GEOPLAN <B>block</B> | ÚÄÄÄÄÄ´ X real 4 |\r
+ | _______________ | | | | | Y real 6 |\r
+ | |GEOPLAN | | | all features of | | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | GEOPLAN inhtd. | | ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | | | ÚÄÄÄ´ X real -4|\r
+ | | | | | P point ÄÄÄÄÄÄÄÅÄÙ | | Y real 88|\r
+ | | | | | Q point ÄÄÄÄÄÄÄÅÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | |_____________| | | R point ÄÄÄÄÄÄÄÅÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | C1 circle ÄÄÄÄÄÄÅÄÄ¿| | X real -9|\r
+ | _______________ | | C2 circle ÄÄÄÄÄÄÅÄ¿|ÀÄÄÄ´ Y real 23|\r
+ | |<B>block</B> | | | C4 circle ÄÄÄÄÄÄÅ¿|ÀÄÄ¿ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | L1 line <B>none</B> ||ÀÄÄ¿| ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | L2 line <B> none</B> |ÀÄ¿ |ÀÄ´CENTER P |\r
+ | | | | | RADIUS real 0 | | | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | | | ÀÄÄÂÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | | | |CENTER Q |\r
+ | |_____________| | | => L1:= ... | | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ |_________________| |_________________| ÀÄÄÄÄ´CENTER R |\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+</PRE>\r
+\r
+<P>\r
+<TT>This may be a snapshot of situation in which two lines were\r
+created and their intersection point was found.</TT> \r
+<PRE>\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ |program | |GEOPLAN <B>block</B> | ÚÄÄÄÄÄ´ X real 4 |\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ | | | | | Y real 6 |\r
+ | |GEOPLAN | | | all features of | | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | GEOPLAN inhtd. | | ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | | | ÚÄÄÄ´ X real -4|\r
+ | | | | | P point ÄÄÄÄÄÄÅÄÙ | | Y real 88|\r
+ | | | | | Q point ÄÄÄÄÄÄÅÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | R point ÄÄÄÄÄÄÅÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | C1 circle ÄÄÄÄÄÄÅÄÄ¿| | X real -9|\r
+ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ | | C2 circle ÄÄÄÄÄÄÅÄ¿|ÀÄÄÄ´ Y real 23|\r
+ | |<B>block</B> | | | C4 circle ÄÄÄÄÄÄÅ¿|ÀÄÄ¿ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | L1 line ÄÄÄÄÄÄ¿||ÀÄÄ¿| ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | L2 line <B> </B>ÄÄÄÄÄ¿||ÀÄ¿ |ÀÄ´CENTER P |\r
+ | | | | | RADIUS real 0 |ÀÅÄ¿| | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | CENTRE Ä¿ | | || ÀÄÄÂÄÄÄÄÄÄÄÄÄÄ¿\r
+ | | | | | | | | || |CENTER Q |\r
+ | ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | => <B>if </B>CE|NTRE | | || ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ | | | | | | || ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÅÄÙ |ÀÄÄÄÄ´CENTER R |\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ | | ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ ÚÄÄÄÄÄÄÄÄÁÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´ | ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿\r
+ | X <I><B>coeff. of</B> </I>| |A real ... | ÀÄ´A real ... |\r
+ | Y <I><B>solution</B> </I> | |B real ... | |B real ... |\r
+ | | |C real ... | |C real ... |\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ\r
+\r
+\r
+<B>Exercises</B>. Add drawing functions as attributes of classes point, line, circle. \r
+Write the algorithm inverting a point w.r.t. a given circle.\r
+</PRE>\r
+\r
+<ADDRESS>\r
+Andrzej Salwicki \r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Loglan'82 home page</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1><IMG SRC="icons/logo.gif" ALT="logo" ALIGN="BOTTOM"></A>\r
+Loglan'82 - programming with objects </H1>\r
+<HR>\r
+\r
+<H3>Loglan's home page </H3>\r
+<HR>\r
+\r
+<P>\r
+Loglan'82 is an object-oriented, universal, imperative programming\r
+language.<BR>\r
+It comes with Doc, Compilers (DOS, Unix, Atari,.), Examples etc.\r
+<BR>\r
+Four features of Loglan'82 make it original and interesting for\r
+everybody:\r
+<UL>\r
+<LI><A href="whylog.htm#mli">Multi-LEVEL Inheritance </A>\r
+<LI><A href="whylog.htm#mki">Multi-kind Inheritance </A>\r
+<LI><A href="whylog.htm#saf">SAFETY ! </A>\r
+<LI><A href="whylog.htm#conc">Object-Oriented CONCURRENCY</A><EM>\r
+</EM>\r
+</UL>\r
+\r
+<P>\r
+<HR>\r
+\r
+<H2>INDEX</H2>\r
+\r
+<DIR>\r
+<LI><A href="whylog.htm">Why Loglan'82? Should I be acquainted with it? </A>\r
+\r
+\r
+<H6>A SUGGESTION: Use recent versions of Mosaic or Netscape viewers\r
+in order to read the tables we prepared for you.<BR>\r
+For those who can not see the tables there are ASCII versions\r
+of tables as well as postscript files </H6>\r
+\r
+\r
+<LI><A href="quick.htm">a Quick Reference Card of Loglan'82</A>\r
+<ul>\r
+<LI>a postscript version is <A href="quickref.ps.Z">here</A> \r
+<LI>thou viewst just<A href="quickref.txt">ascii file</A>\r
+</ul>\r
+ \r
+<LI><A href="tablica3.htm">a short comparison with other OO languages</A>\r
+<ul>\r
+<LI>a postscript version is <A href="comptble.ps.Z">here</A> \r
+<LI>thou viewst just <A href="tablica3.txt">ascii file</A> \r
+</ul>\r
+\r
+<LI><A href="MicroMan/HomePage.htm">A micro-manual of Loglan'82</A>\r
+\r
+<LI><A href="availlty.htm">How to get a copy of Loglan'82 system? </A>\r
+<LI><A href="platform.htm">existing platforms </A>\r
+<ul>\r
+<LI><A href="platform.htm#dos">DOS</A> \r
+<LI><A href="platform.htm#unix">Unix</A> \r
+<LI><A href="platform.htm#ata">Atari</A> \r
+<LI><A href="platform.htm#othe">others</A> \r
+</ul>\r
+\r
+<LI><A href="openpbms.htm">research problems related to Loglan'82 </A>\r
+<ul>\r
+<LI>solved ones\r
+<LI>open ones\r
+</ul>\r
+\r
+<LI><A href="/drFun.html">Dr Fun or the mysteries of "scientific" bureaucracy </A>\r
+<LI><A href="credits.htm">a short history of Loglan'82 project </A>\r
+<LI><A href="solate.htm">why I learn so late on Loglan'82? </A>\r
+</UL>\r
+</dir>\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS</A> last\r
+update Sun 21 May 1995 \r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
+pp
\ No newline at end of file
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Loglan'82 home page</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1><IMG SRC="/icons/logo.gif" ALT="logo" ALIGN="BOTTOM"></A>\r
+Loglan'82 - programming with objects </H1>\r
+<HR>\r
+\r
+<H3>Loglan's home page </H3>\r
+<HR>\r
+\r
+<P>\r
+Loglan'82 is an object-oriented, universal, imperative programming\r
+language.<BR>\r
+It comes with Doc, Compilers (DOS, Unix, Atari,.), Examples etc.\r
+<BR>\r
+Four features of Loglan'82 make it original and interesting for\r
+everybody:\r
+<UL>\r
+<LI><A href="whylog.htm#mli">Multi-LEVEL Inheritance </A>\r
+<LI><A href="whylog.htm#mki">Multi-kind Inheritance </A>\r
+<LI><A href="whylog.htm#saf">SAFETY ! </A>\r
+<LI><A href="whylog.htm#conc">Object-Oriented CONCURRENCY</A><EM>\r
+</EM>\r
+</UL>\r
+\r
+<P>\r
+<HR>\r
+\r
+<H2>INDEX</H2>\r
+\r
+<DIR>\r
+<LI><A href="whylog.htm">Why Loglan'82? Should I be acquainted with it? </A>\r
+\r
+\r
+<H6>A SUGGESTION: Use recent versions of Mosaic or Netscape viewers\r
+in order to read the tables we prepared for you.<BR>\r
+For those who can not see the tables there are ASCII versions\r
+of tables as well as postscript files </H6>\r
+\r
+\r
+<LI><A href="quick.htm">a Quick Reference Card of Loglan'82</A>\r
+<ul>\r
+<LI>a postscript version is <A href="quickref.ps.Z">here</A> \r
+<LI>thou viewst just<A href="quickref.txt">ascii file</A>\r
+</ul>\r
+ \r
+<LI><A href="tablica3.htm">a short comparison with other OO languages</A>\r
+<ul>\r
+<LI>a postscript version is <A href="comptble.ps.Z">here</A> \r
+<LI>thou viewst just <A href="tablica3.txt">ascii file</A> \r
+</ul>\r
+\r
+<LI><A href="MicroMan/HomePage.htm">A micro-manual of Loglan'82</A>\r
+\r
+<LI><A href="availlty.htm">How to get a copy of Loglan'82 system? </A>\r
+<LI><A href="platform.htm">existing platforms </A>\r
+<ul>\r
+<LI><A href="platform.htm#dos">DOS</A> \r
+<LI><A href="platform.htm#unix">Unix</A> \r
+<LI><A href="platform.htm#ata">Atari</A> \r
+<LI><A href="platform.htm#othe">others</A> \r
+</ul>\r
+\r
+<LI><A href="openpbms.htm">research problems related to Loglan'82 </A>\r
+<ul>\r
+<LI>solved ones\r
+<LI>open ones\r
+</ul>\r
+\r
+<LI><A href="/drFun.html">Dr Fun or the mysteries of "scientific" bureaucracy </A>\r
+<LI><A href="credits.htm">a short history of Loglan'82 project </A>\r
+<LI><A href="solate.htm">why I learn so late on Loglan'82? </A>\r
+</UL>\r
+</dir>\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS</A> last\r
+update Sun 21 May 1995 \r
+</ADDRESS>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
+p
\ No newline at end of file
--- /dev/null
+<html>\r
+<head><title> Index of Loglan82 archive </title> </head>\r
+\r
+<body>\r
+<h1> Index of Loglan82 archive </h1>\r
+<h2> on <I>infpc1.univ-pau.fr</I> </h2>\r
+\r
+<ul>\r
+<li> <a href="infpc1.html"> up to parents directory </a> </li>\r
+<li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/doc/doc.zip"> Documentation files </a> </li>\r
+ <ul> </ul>\r
+<li><a href=""> </a> executables </li>\r
+ <ul>\r
+ <li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/exe/exe486.zip"> Loglan for 486 DOS machines </a> (32 bits version, uses GO32 of GNU distribution) </li>\r
+ <li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/exe/exe386.zip"> Loglan for 386 machines</a> (32 bits version, uses GO32 and emu387) </li>\r
+ <li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/exe/exe286.zi"> Loglan for 286=AT machines </a>, if you have just PC/AT computer </li>\r
+ <li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/exe/atari.zip"> Loglan for Atari ST </a> </li>\r
+ <li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/exe/l2c.zip"> Loglan'82 to C crosscompiler </a> of very limited use! </li>\r
+ </ul>\r
+<li><a href="file://infpc1.univ-pau.fr/pub/Loglan82/sources/sources.zip"> Sources for installation on Unix machines </a> see Installation.txt file </li>\r
+<li><a href=""> </a> DOS environment </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+<li><a href=""> </a> </li>\r
+\r
+</ul>\r
+<hr>\r
+<address> <A HREF = "GMyAS.html">AS</A> Last update Mon 6 Mar 1995 </address>\r
+</body>\r
+</html>
\ No newline at end of file
--- /dev/null
+<HTML>\r
+<HEAD>\r
+<TITLE>Open research problems</TITLE>\r
+</HEAD>\r
+\r
+<BODY>\r
+<H1><img src="loglanmm.gif"> Open problems and questions</H1>\r
+<P>Loglan'82 is the <A HREF = "credits.html">result</A> of university \r
+research.\r
+We were not pretending to conquer the market. It happened however that the\r
+ language turned out to be \r
+a good vehicle for teaching objects. Its features still make him\r
+a good candidate language for those who wish to have a reliable\r
+tool for programming quite complicated algorithms, data structures and \r
+systems.\r
+\r
+<P>On the other hand we believe that it is necessary to study the \r
+problems and questions which arise in the domain of object\r
+programming.\r
+We believe that the progress is done by profiting from the experience \r
+and results obtained by others and by adding someones own results.\r
+Therefore we propose to study the questions listed below.\r
+To our knowledge they are still open. We shall be happy to hear any news\r
+ and comments\r
+from you.\r
+\r
+<P><H2>List of open questions and problems</H2>\r
+\r
+<UL>\r
+ <li><P><STRONG>1.</STRONG><EM> Is it possible to have simultaneously in\r
+ one programming language:<BR>\r
+ <UL>\r
+ <li>nesting of modules,\r
+ <li> multiple inheritance? \r
+ </UL></EM>\r
+ <p> REMARKS.<BR>\r
+ a) One may doubt: do we need nesting of modules in the presence of\r
+ (multiple) inheritance? I believe that YES, we really need both \r
+ways\r
+ of module's construction.<BR> \r
+ b) From the experience of Loglan'82 we know that <STRONG>nesting + \r
+multilevel \r
+ inheritance + multikind inheritance + effective managemant of\r
+ objects </STRONG> is possible. Similar experience is witnessed by BETA\r
+ project.<BR>\r
+ c) It is possible to simulate multiple inheritance in Loglan'82\r
+ (to some extent).<BR>\r
+ d) Still, one may doubt whether a consistent semantics of a language\r
+ that admits both multiple inheritance and nesting exists. \r
+ Another question which is strongly related to this one arise: \r
+ can we do it efficiently?\r
+ <li><P> <STRONG>2.</STRONG> <EM>Is it possible to manage in a (quasi-) uniform way object of different \r
+ nature:\r
+ <UL>\r
+ <li> "usual" objects,\r
+ <li> persistent objects,\r
+ <li> process objects - they may be realised as network objects\r
+ or process-objects in a parallel computer?\r
+ </UL></EM>\r
+ \r
+ <p> REMARKS.<BR>\r
+ a) The experience of Loglan'82 witnesses that usual objects and process objects \r
+ may coexist.<BR>\r
+ b) We imagine that the system created by A. Kreczmar may be easily\r
+ cloned in order to manage persistent objects.<BR>\r
+ \r
+ \r
+ <li><P> <STRONG>3. </STRONG> <EM>Is it possible to use the mechanisms of \r
+classes, inheritance etc. in order to \r
+ manage the libraries of predefined modules?</EM>\r
+ <P>REMARKS.<BR>\r
+ We imagine that it would be much better to use inheritance etc.\r
+ instead of #INCLUDE <file> mechanism. Why we should mix up these \r
+ notions so different: file and module?\r
+ <li> <P><STRONG>4. </STRONG><EM>Is it possible to conceive the virtual\r
+ Loglan computer (i.e.\r
+ its interpreter or if you prefer its running system) \r
+ as a confederation of processes?</EM>\r
+ <P>REMARKS.<BR>\r
+ In fact the present system of Loglan'82 is already a pair of processes\r
+ 1° an interpreter of graphic commands and 2° the running system of Loglan'82\r
+ itself.\r
+\r
+ <li><P> <STRONG>5. </STRONG> <EM>How to specify and implement a symbol\r
+ table for a language \r
+ (say Loglan'95) that admits both nesting and multi inheritance?</EM>\r
+ <p> REMARKS.<BR>\r
+ To tell the truth we know how to implement the sumbol table. It \r
+ seems very interesting to make and publish a specification of \r
+ this subsystem of the future Loglan'95 system as it contains \r
+ plenty of interesting features and brings a new and important variant \r
+ of the notion of dictionary data structure [cf.]\r
+ <li> <P><STRONG>6. </STRONG> <EM>Is it possible to use efficiently object \r
+ programming in a compiler\r
+ project?</EM>\r
+ <P>REMARKS. We wish to advocate two theses: that the recursive \r
+ descending analysis should\r
+ gain as much attention as the ascending one, that OO programming\r
+ has to play its proper rôle in the automatic construction of parsers.\r
+ Moreover, we see the importance and multiple usage of trees of\r
+ abstract syntax of a program for various transformations of it.\r
+ \r
+ <li> <P><STRONG>7. </STRONG> <EM>Is it possible to construct an editor \r
+which would aid the programmer \r
+ to develop a program within certain guidelines of "good" programming?</EM>\r
+ <P>Remarks. We believe that it is possible to give a new shape to\r
+ the "webbing" of programs as proposed by D. Knuth.\r
+\r
+ <li><P> <STRONG>8. </STRONG><EM>Is it possible to conjuge the compiler\r
+ project for Loglan'95\r
+ together with a proof assistant project for Algorithmic Logic?</EM>\r
+ <P> REMARKS.\r
+ \r
+\r
+</UL>\r
+As you see the list of questions is quite long. We would appreciate any\r
+ help.\r
+We are looking for collaborators to work together on the problems listed \r
+above.\r
+There is plenty of work for everybody.\r
+For example, we have a system of network objects=processes written by\r
+Pawel Susicki. He could not debug the system. Would you?\r
+<hr>\r
+<a href="availlty.htm"><img src="icons/PrevPage.gif"> </a>\r
+<a href="loghome.htm"><img src="icons/HomePage.gif"> </a>\r
+ <a href="credits.htm"><img src="icons/NextPage.gif"></a>\r
+\r
+<HR>\r
+<A HREF = "GMyAS.html">Andrzej Salwicki</A> Last update Fri 19 May 1995\r
+</BODY>\r
+</HTML>pp
\ No newline at end of file
--- /dev/null
+<HTML>\r
+<HEAD>\r
+<TITLE>Open research problems</TITLE>\r
+</HEAD>\r
+\r
+<BODY>\r
+<H1><img src="loglanmm.gif"> Open problems and questions</H1>\r
+<P>Loglan'82 is the <A HREF = "credits.html">result</A> of university \r
+research.\r
+We were not pretending to conquer the market. It happened however that the\r
+ language turned out to be \r
+a good vehicle for teaching objects. Its features still make him\r
+a good candidate language for those who wish to have a reliable\r
+tool for programming quite complicated algorithms, data structures and \r
+systems.\r
+\r
+<P>On the other hand we believe that it is necessary to study the \r
+problems and questions which arise in the domain of object\r
+programming.\r
+We believe that the progress is done by profiting from the experience \r
+and results obtained by others and by adding someones own results.\r
+Therefore we propose to study the questions listed below.\r
+To our knowledge they are still open. We shall be happy to hear any news\r
+ and comments\r
+from you.\r
+\r
+<P><H2>List of open questions and problems</H2>\r
+\r
+<UL>\r
+ <li><P><STRONG>1.</STRONG><EM> Is it possible to have simultaneously in\r
+ one programming language:<BR>\r
+ <UL>\r
+ <li>nesting of modules,\r
+ <li> multiple inheritance? \r
+ </UL></EM>\r
+ <p> REMARKS.<BR>\r
+ a) One may doubt: do we need nesting of modules in the presence of\r
+ (multiple) inheritance? I believe that YES, we really need both \r
+ways\r
+ of module's construction.<BR> \r
+ b) From the experience of Loglan'82 we know that <STRONG>nesting + \r
+multilevel \r
+ inheritance + multikind inheritance + effective managemant of\r
+ objects </STRONG> is possible. Similar experience is witnessed by BETA\r
+ project.<BR>\r
+ c) It is possible to simulate multiple inheritance in Loglan'82\r
+ (to some extent).<BR>\r
+ d) Still, one may doubt whether a consistent semantics of a language\r
+ that admits both multiple inheritance and nesting exists. \r
+ Another question which is strongly related to this one arise: \r
+ can we do it efficiently?\r
+ <li><P> <STRONG>2.</STRONG> <EM>Is it possible to manage in a (quasi-) uniform way object of different \r
+ nature:\r
+ <UL>\r
+ <li> "usual" objects,\r
+ <li> persistent objects,\r
+ <li> process objects - they may be realised as network objects\r
+ or process-objects in a parallel computer?\r
+ </UL></EM>\r
+ \r
+ <p> REMARKS.<BR>\r
+ a) The experience of Loglan'82 witnesses that usual objects and process objects \r
+ may coexist.<BR>\r
+ b) We imagine that the system created by A. Kreczmar may be easily\r
+ cloned in order to manage persistent objects.<BR>\r
+ \r
+ \r
+ <li><P> <STRONG>3. </STRONG> <EM>Is it possible to use the mechanisms of \r
+classes, inheritance etc. in order to \r
+ manage the libraries of predefined modules?</EM>\r
+ <P>REMARKS.<BR>\r
+ We imagine that it would be much better to use inheritance etc.\r
+ instead of #INCLUDE <file> mechanism. Why we should mix up these \r
+ notions so different: file and module?\r
+ <li> <P><STRONG>4. </STRONG><EM>Is it possible to conceive the virtual\r
+ Loglan computer (i.e.\r
+ its interpreter or if you prefer its running system) \r
+ as a confederation of processes?</EM>\r
+ <P>REMARKS.<BR>\r
+ In fact the present system of Loglan'82 is already a pair of processes\r
+ 1° an interpreter of graphic commands and 2° the running system of Loglan'82\r
+ itself.\r
+\r
+ <li><P> <STRONG>5. </STRONG> <EM>How to specify and implement a symbol\r
+ table for a language \r
+ (say Loglan'95) that admits both nesting and multi inheritance?</EM>\r
+ <p> REMARKS.<BR>\r
+ To tell the truth we know how to implement the sumbol table. It \r
+ seems very interesting to make and publish a specification of \r
+ this subsystem of the future Loglan'95 system as it contains \r
+ plenty of interesting features and brings a new and important variant \r
+ of the notion of dictionary data structure [cf.]\r
+ <li> <P><STRONG>6. </STRONG> <EM>Is it possible to use efficiently object \r
+ programming in a compiler\r
+ project?</EM>\r
+ <P>REMARKS. We wish to advocate two theses: that the recursive \r
+ descending analysis should\r
+ gain as much attention as the ascending one, that OO programming\r
+ has to play its proper rôle in the automatic construction of parsers.\r
+ Moreover, we see the importance and multiple usage of trees of\r
+ abstract syntax of a program for various transformations of it.\r
+ \r
+ <li> <P><STRONG>7. </STRONG> <EM>Is it possible to construct an editor \r
+which would aid the programmer \r
+ to develop a program within certain guidelines of "good" programming?</EM>\r
+ <P>Remarks. We believe that it is possible to give a new shape to\r
+ the "webbing" of programs as proposed by D. Knuth.\r
+\r
+ <li><P> <STRONG>8. </STRONG><EM>Is it possible to conjuge the compiler\r
+ project for Loglan'95\r
+ together with a proof assistant project for Algorithmic Logic?</EM>\r
+ <P> REMARKS.\r
+ \r
+\r
+</UL>\r
+As you see the list of questions is quite long. We would appreciate any\r
+ help.\r
+We are looking for collaborators to work together on the problems listed \r
+above.\r
+There is plenty of work for everybody.\r
+For example, we have a system of network objects=processes written by\r
+Pawel Susicki. He could not debug the system. Would you?\r
+<hr>\r
+<a href="availlty.htm"><img src="prevpage.gif"> </a>\r
+<a href="loghome.htm"><img src="homepage.gif"> </a>\r
+ <a href="credits.htm"><img src="nextpage.gif"></a>\r
+\r
+<HR>\r
+<A HREF = "GMyAS.html">Andrzej Salwicki</A> Last update Fri 19 May 1995\r
+</BODY>\r
+</HTML>p
\ No newline at end of file
--- /dev/null
+<html>\r
+<head>\r
+<title>Supported Platforms</title>\r
+<head>\r
+\r
+<body>\r
+<h1><img src="loglanmm.gif">Supported Platforms</H1>\r
+<dir>\r
+<li><a href="#dos">DOS</a>\r
+<li><a href="#unix">Unix</a>\r
+<li><a href="#ata">Atari</a>\r
+<li><a href="#othe">others</a>\r
+</dir>\r
+\r
+<ul>\r
+<li><a name="dos">Dos</a><br>\r
+ There exist versions adapted to various machines: AT, 486, 386. \r
+ Therefore you should choose a version that corresponds to your \r
+ computer in order to gain on the speed of compilation and execution.\r
+ Next, you should choose the driver corresponding to your graphic\r
+ card. If it seems too complicated for you choose VGA.\r
+ We feel sorry to tell you that for a moment the versions of\r
+ predefined class\r
+<ul>\r
+<li> <a href="iuwgraf3.htm> IIUWGRAPH (486 and 386) </a>\r
+<li> <a href="iuwgraf.txt> IIUWGRAPH (286) </a>\r
+</ul>\r
+ vary depending on the hardware. It means\r
+ that you should indicate in your program the platform & graphics\r
+ used. \r
+\r
+<li><a name="unix">Unix</a><br>\r
+ Most of Unix machines allow to install Loglan'82 without problems.\r
+ We have verified PC/Linux - it is probably the most popular choice,\r
+ PC/SCO Unix, HP, Sun4 with SunOS, SunSparcStation10 with Solaris.\r
+ Some users encountered the difficulties however. <br>\r
+\r
+ In order to install Loglan: copy the source files,adapt the files \r
+ makefile and execute make in each subdirectory:f2c, pass1, gen, in.\r
+\r
+If you wish to use the predefined class IIUWGRAPH then <br>\r
+please read the following description <a href="http://www.univ-pau.fr/~salwicki/xiiuwgrf.htm"> Xiiuwgraf </a>, or click here<a href="http://www.univ-pau.fr/~salwicki/xiiuwgra.txt"> Xiiuwgraf.txt </a> in order to view an ASCII file.<br>\r
+ \r
+<li><a name="ata">Atari</a><br>\r
+ In the subdirectory "ATARI" we put the executables. It suffices to copy them.\r
+ Please read the accompanying text.\r
+ Pay attention to the fact that grapic operations are realised\r
+ somewhat differently. \r
+<li><a name="othe">others</a><br>\r
+ The first compiler of Loglan'82 was running (1982-1988?) on \r
+ mini-computers MERA 400.<br> \r
+ There is a version for VAX/VMS which was used in several places.\r
+ Should you be interested in it, please contact us.\r
+ \r
+</ul>\r
+\r
+<hr>\r
+<a href="loghome.html"><img src="http://www.univ-pau.fr/div/img/up_motif.gif"></a>\r
+<a href="drFun.html"><img src="http://www.univ-pau.fr/div/img/next_motif.gif"></a> \r
+<a href="resprobl.html"><img src="http://www.univ-pau.fr/div/img/previous_motif.gif"></a>\r
+<hr>\r
+<address>\r
+<a href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </a>\r
+ last update 2 January 1995\r
+</address>\r
+</body>\r
+</html>\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+<html>\r
+<HEAD><TITLE>Processes</TITLE></HEAD>\r
+\r
+\r
+<BODY>\r
+<H1>Chapter: PROCESSES</H1>\r
+\r
+<H2>by Andrzej Salwicki</H2>\r
+\r
+<H4>Plan</H4>\r
+\r
+\r
+<UL>\r
+<LI><A HREF = "#syntax">Syntax</A>\r
+<UL>\r
+<LI><A HREF = "#restric">Context Restrictions</A>\r
+<LI><A HREF = "#alicall">Alien Call</A>\r
+<LI><A HREF = "#maska">Mask</A>\r
+</UL>\r
+\r
+<LI><A HREF = "#semantyka">Semantics</A>\r
+<UL>\r
+<LI><A HREF = "#accept">Accept</A>\r
+<LI><A HREF = "#aliencall">Execution of Alien Call</A>\r
+</UL>\r
+\r
+<LI><A HREF = "#przyklady">Examples</A>\r
+<LI>Tips: how to\r
+</UL>\r
+ \r
+<HR>\r
+<H4>Introduction</H4>\r
+<P>\r
+The word <em>process </em> has two meanings: it may denote a module of a programm or\r
+it may denote an object of a module. <BR>\r
+Once created a process-object may be activated. Its instructions are executed in parallel \r
+with the instructions of other processes-objects. The word <I>multithread </I>execution explains \r
+well the intuition of concurrent processes.\r
+While the objects of classes and of coroutines share a processor, \r
+the objects of processes do have a processor associated with each \r
+object of process. The processor can be either a physical processor \r
+e.g. a personal computer or workstation connected to other computers \r
+by means of LAN network, or it may be a virtual processor, in reality \r
+it can be an ability to acquire a time slice of a real computer. \r
+(More or less like a process in Unix system).\r
+\r
+\r
+<P>\r
+<H2><A NAME = "syntax">Syntax</A></H2>\r
+\r
+\r
+<P>The syntax of module process is similar to those of modules class or coroutine\r
+\r
+<PRE><B>unit</B> {<I>processTypeName</I>}: {<I>prefix</I>} <B>process</B> ({<I>formalParameters</I>}):\r
+ {<I>declarations</I>}\r
+<B>begin</B>\r
+ {<I>instructions</I>}\r
+<B>end</B> {<I>processTypeName</I>};</PRE>\r
+\r
+The present status of the processes in Loglan82 is experimental. There are several contextual restrictions imposed. Some of them are explained by the experimental and temporary status ... Some of them are not checked by the compiler. Sorry! Attention please!\r
+\r
+<H3><A NAME = "restric">Context restrictions.</A></H3>\r
+\r
+\r
+<OL>\r
+<LI> All process modules should be declared as global units. They can not be nested. They can inherit however. \r
+<BR>This is explained by the distributed model of memory of processes. \r
+<LI> There is no shared memory. Every process can access only its private resources, whether declared locally or transmitted as parameters, or procedures and functions declared in other object of process if it is accessible to the process.\r
+<LI> The parameters of a process can be\r
+<BR> integer, real, char, Boolean, string i.e. of primitive type\r
+<BR>or\r
+<BR> process objects\r
+<BR>or\r
+<BR> procedure declared in a process object\r
+<BR>or\r
+ <BR> procedure transmitted as a formal parameter.\r
+\r
+<LI> The procedure's instruction of the form\r
+<P>\r
+ call X.proced1(params)\r
+\r
+<BR>placed in the body of a process module has an effect of communicating the calling process with the callee X.\r
+<BR>Therefore such an instruction will be named an alien call of a procedure. We shall see later that the execution of an alien call needs a cooperation of both the calling and the callee processes.\r
+\r
+<LI> The operations in, is , qua, this\r
+are not defined on processes. The user should not put them in the body of a process module.\r
+<P>Sorry, the compiler will not check it as an error!!!\r
+\r
+<LI> There is no dynamic type checking concerning objects of processes.\r
+<BR>Again, the compiler does not warn you. Be careful!\r
+\r
+<LI> Each process has its own subsystem of coroutines. The instructions attach and detach can not transfer the control beyond the subsystem.\r
+\r
+\r
+<LI> No process object can access the global variables declared in the MAIN process. This does not apply to the principal program=MAIN. Remark that MAIN is a process object too.\r
+\r
+</OL>\r
+<P><H2><A NAME = "alicall">Allien call</A></H2>\r
+\r
+\r
+<DD><P>Let Y be a process object. Let X be another process object. If a command of the following form \r
+\r
+ <P> <B>call</B> X.procedr1(actual_params)\r
+\r
+<BR>is to be executed in Y then we shall say of an allien call.\r
+<BR>The called procedure, in this example procedr1, can be either: \r
+<UL>\r
+<LI> - one of the procedures declared in the process X, or\r
+<LI> - one of procedures being formal parameters of X, or\r
+\r
+<LI> - a procedure which is a formal parameter of another procedure called by alien call (this is a recursive definition). \r
+</UL>\r
+<P>Y is said a calling process, X is the callee process.\r
+\r
+\r
+<H3><A NAME = "maska">Mask</A>.</H3>\r
+\r
+\r
+<P>Each process has a predefined variable MASK associated with it. The value of the variable is a subset of the set of names of procedures and functions that are declared inside the process.\r
+\r
+The initial value of the MASK is the empty set .\r
+\r
+The instructions <B>ENABLE</B> and <B>DISABLE</B> can change the value of the MASK variable.\r
+\r
+<PRE>\r
+\r
+ MASK={q1, ... ,qn}\r
+ \r
+ \r
+ <B>enable</B> p1,p2; \r
+ <B>disable</B> p1, p2;\r
+ \r
+ \r
+ MASK={q1, ... , qn, p1, p2}\r
+</PRE>\r
+As you see from the above diagram an instruction 'enable' adds the names to the MASK. An instruction 'disable' deletes the names from the mask.\r
+\r
+There are two other instructions \r
+ <B>RETURN ENABLE</B> p1, ... , pn <B>DISABLE</B> q1, ... , qk;\r
+and\r
+ <B>ACCEPT</B> p1, ... , pl;\r
+\r
+which modify the value of the mask. Their meaning is described below.\r
+\r
+The instruction RETURN ENABLE p1, ... , pn DISABLE q1, ... , qk; is legible in the body of a procedure or function only. The instruction ACCEPT can be put anywhere in a process module.\r
+\r
+\r
+\r
+<P>\r
+<H2><A NAME = "semantyka">SEMANTICS</A></H2>\r
+\r
+<P>Let us repeat: a process can be initialised, its initialisation phase terminates when the return statement is reached. It can be given a name, say p, and it remains passive. When another proces executes the command resume(p) then the process p is activated, its actions are executed in parallel with the actions of the other active processes.\r
+Once activated it continues the execution of its commands. It may execute a stop command and become a passive process. Other processescan call for an allien call of a procedure (or function) declared in the process p. The permission to interrupt the execution of its own commands and to do a service for an external process will be granted iffthe process p is active and if the name of the called procedure is in MASK.\r
+The process can change the value of the MASK variable by means of commands enable and disable. One can use also the commands accept and return disable ... enable...\r
+<P>\r
+<H3><A NAME = "accept">ACCEPT</A></H3>\r
+\r
+<P>\r
+The execution of the command accept p1, ... , pn is as follows:\r
+1° the names p1, ... ,pn are added to the MASK\r
+2° the process waits for an allien call of a procedure listed in the MASK.\r
+\r
+When an allien call is terminated the MASK is set to its previous value, i.e. to that before the ACCEPT was executed. This is a rule with an exception: see the return disable ... enable... command below. \r
+\r
+\r
+\r
+<H3><A NAME = "aliencall">Execution of an allien call</A></H3>\r
+\r
+\r
+<OL>\r
+<BR>\r
+<LI>1. The calling process Y calls the callee process X and waits,\r
+<LI>2. If the callee process X is active and if it is before execution of its Loglan command C and if the name of the called procedure is in the value of MASK variable, (let us recall it is a set of names of procedures) then the callee X is interrupted and\r
+<LI>3. The calling process Y transmits the actual parameters of the called procedure to the process X and waits.\r
+<LI>4. The calllee X saves the MASK, next, the MASK is set to empty (it means that all further alien calls are to wait) \r
+<BR> REMARK that the called procedure can change the value of MASK.\r
+<LI>5. The callee X executes the called procedure.\r
+<LI>6. When the execution of the procedure reaches its end then the output parameters of the procedure are transmitted to the calling process Y which receives them.\r
+<LI>7. The MASK is restored to its state before the call.\r
+<BR>REMARK. If the execution of the called procedure ends with the command\r
+<BR> <B>return enable</B> ... <B>disable</B> ...;\r
+<LI>Then the restored MASK is subject to the modifications described by this command.\r
+<LI>8. Both processes resume their activities from before alien call\r
+<BR> - the calling process passes to the instruction next to the alien call,\r
+<BR> - the callee process executes the instruction C which was planned already to be executed.\r
+<BR> \r
+</OL>\r
+\r
+\r
+The semantical phenomena\r
+of parallel programming are different than those of sequential programming. \r
+\r
+<A NAME = "przyklady">Example 1</A>\r
+Let us look what will happen if you execute the following program First.\r
+First of all, you will remark that the strings are mixed. This is because\r
+ the commands write(a(i)) of the process w1 are executed in parallel with \r
+the commands write(a(i)) of the another process w2. The screen receives \r
+them interleaved and so the characters appear on the screen interleaved. \r
+\r
+Next, remark that the execution of a program is no longer determined \r
+by its text and its data. Execute the following program twice and compare \r
+the results. You will observe that the results displayed on the screen are \r
+different. However there is no visible reason for this difference.\r
+\r
+\r
+<PRE><B>program</B> First;\r
+ <B> unit </B>writer: <B>process</B>(node:integer, nr:integer,s: string);\r
+ <B> var </B>i: integer,\r
+ A: <B>arrayof </B>char;\r
+ <B> begin</B>\r
+ <B> return;</B>\r
+ a:=unpack(s);\r
+ <B> for </B>i := lower(a) <B>to </B>upper(a)\r
+ <B> do</B>\r
+ write(a(i));\r
+ <B> od;</B>\r
+ writeln;\r
+ <B> end </B>writer;\r
+ \r
+ <B> var </B>w1, w2: writer, i: integer;\r
+ \r
+<B>begin</B>\r
+ w1:=<B>new</B> writer(0,1,"ici un texte tres long,\r
+ tres long, tres long tres long tres long tres long");\r
+ w2:=<B>new</B> writer(0,2,"zdies otche'n dolgoj tiekst, otche'n dolgoj tiekst, otche'n dolgoj tiekst");\r
+ <B> resume</B>(w1);\r
+ <B> resume</B>(w2);\r
+ writeln("give me a character");\r
+ readln;\r
+<B>end </B>First\r
+ </PRE>\r
+We are going now to remede the interleaving the characters. \r
+For this purpose we are going to construct a semaphore. \r
+But what it is a semaphore? Well, it is a device that allows \r
+a train to pass iff it is in a state permitting to pass and in \r
+the same moment of the passage it changes its state to blocking one. \r
+Therefore only one train is authoised to pass. In the state blocking \r
+it accepts only the demand to liberate the semaphore i.e. the state of \r
+the semaphore changes from blocking to free. By default, it is assumed \r
+that it is only the train that passed who will execute the command: \r
+liberate (when it leaves the station).\r
+\r
+\r
+\r
+<PRE><B>program</B> Second;\r
+\r
+ <B>unit </B>aSemaphore: <B>process</B>(node:integer);\r
+ <B>unit </B>pass: <B>procedure;</B>\r
+ <B>end </B>pass;\r
+ <B>unit </B>free: <B>procedure;</B>\r
+ <B>end </B>free;\r
+ <B>begin</B>\r
+ <B>return;</B>\r
+ <B>do</B>\r
+ <B>accept </B>pass;\r
+ <B>accept </B>free;\r
+ <B>od</B>\r
+ <B>end </B>aSemaphore;\r
+\r
+ <B>unit </B>writer: <B>process</B>(node:integer, nr:integer,s: string, sem: aSemaphore);\r
+ <B>var </B>i: integer,\r
+ A: <B>arrayof </B>char;\r
+ <B>begin</B>\r
+ <B>return;</B>\r
+ <B>call </B>sem.pass;\r
+ a:=unpack(s);\r
+ <B>for </B>i := lower(a) <B>to </B>upper(a)\r
+ <B>do</B>\r
+ write(a(i));\r
+ <B>od;</B>\r
+ writeln;\r
+ <B>call </B>sem.free;\r
+ <B>end </B>writer;\r
+ \r
+ <B>var </B>s: aSemaphore, w1, w2: writer, i: integer;\r
+ \r
+<B>begin</B>\r
+ s := <B>new </B>aSemaphore(0);\r
+ resume(s);\r
+ w1:=<B>new</B> writer(0,1,"ici un texte tres long,\r
+ tres long, tres long tres long tres long tres long",s);\r
+ w2:=<B>new</B> writer(0,2,"zdies otche'n dolgoj tiekst, otche'n dolgoj tiekst, otche'n dolgoj tiekst", s);\r
+ resume(w1);\r
+ resume(w2);\r
+ writeln("give me a character");\r
+ readln;\r
+<B>end </B>Second\r
+</PRE>\r
+\r
+<B><I>Theorem</I></B>\r
+The texts shown on the screen will never be mixed.\r
+\r
+We can prove even stronger theorem that for any number of objects-processes of type writer defined as in the program Second they critical sections (here it means printing on the screen) will be executed in mutual exclusivity.\r
+\r
+Therefore with the use of semaphores one is able to assure \r
+the mutual exclusivity of critical sections of given processes.\r
+\r
+A new question appears: is it true that semaphores garantee \r
+the mutual exclusion?\r
+The answer is no, as it can be seen from the Third program.\r
+\r
+\r
+\r
+<PRE>program Third;\r
+\r
+ unit Semaphore: process(node:integer);\r
+ unit pass: procedure;\r
+ end pass;\r
+ unit free: procedure;\r
+ end free;\r
+ begin\r
+ return;\r
+ do\r
+ accept pass;\r
+ accept free;\r
+ od\r
+ end Semaphore;\r
+\r
+ unit writer1: process(node:integer, nr:integer,s: string, sem: semaphore);\r
+ var i: integer,\r
+ A: arrayof char;\r
+ begin\r
+ return;\r
+ call sem.pass;\r
+ a:=unpack(s);\r
+ for i := lower(a) to upper(a)\r
+ do\r
+ write(a(i));\r
+ od;\r
+ writeln;\r
+ call sem.free;\r
+ end writer1;\r
+ unit writer2: process(node:integer, nr:integer,s: string, sem: semaphore);\r
+ var i: integer,\r
+ A: arrayof char;\r
+ begin\r
+ return;\r
+ call sem.free;\r
+ a:=unpack(s);\r
+ for i := lower(a) to upper(a)\r
+ do\r
+ write(a(i));\r
+ od;\r
+ writeln;\r
+ call sem.pass;\r
+ end writer2;\r
+ var s: semaphore, w1: writer1, w2: writer2, i: integer;\r
+begin\r
+ s := new semaphore(0);\r
+ resume(s);\r
+ w1:=new writer1(0,1,"ici un texte tres long,\r
+ tres long, tres long tres long tres long tres long",s);\r
+ w2:=new writer2(0,2,"zdies otche'n dolgoj tiekst, otche'n dolgoj tiekst, otche'n dolgoj tiekst", s);\r
+ resume(w1);\r
+ resume(w2);\r
+ writeln("give me a character");\r
+ readln;\r
+end Third\r
+</PRE>\r
+The example above reveals that one should use semaphores with rigour. \r
+It may be the case that both processes use a semaphore but due \r
+to an error their critical sections are executed in parallel causing \r
+a chaos.\r
+\r
+In most cases it would be better to conceive the architecture of the \r
+system of parallel processes as clients and servers. In the example \r
+below we create one server: ecran for serving the resourc eof screen. \r
+The processes are calling the process server asking for a service. \r
+In this case it will be printing on the screen. \r
+ \r
+<PRE>program Fourth;\r
+ unit ecran: process(node: integer); (* it is a server *)\r
+ unit print: procedure(s: string);\r
+ var i: integer,\r
+ A: arrayof char;\r
+ begin\r
+ a:=unpack(s);\r
+ for i := lower(a) to upper(a)\r
+ do\r
+ write(a(i));\r
+ od;\r
+ writeln;\r
+ end print;\r
+ begin\r
+ return;\r
+ do accept print od (* it offers just the print service *)\r
+ end ecran;\r
+\r
+ unit writer: process(node:integer, nr:integer,s: string, ec:ecran); \r
+ (* it is a client *)\r
+ begin\r
+ return;\r
+ call ec.print(s)\r
+ end writer;\r
+ \r
+ var e: ecran, w1, w2: writer, i: integer;\r
+ \r
+begin\r
+ e := new ecran(0);\r
+ resume(e);\r
+ w1:=new writer(0,1,"ici un texte tres long,\r
+ tres long, tres long tres long tres long tres long", e);\r
+ w2:=new writer(0,2,"zdies otche'n dolgoj tiekst, otche'n dolgoj tiekst, otche'n dolgoj tiekst", e);\r
+ resume(w1);\r
+ resume(w2);\r
+ writeln("give me a character");\r
+ readln;\r
+end Fourth\r
+</PRE>\r
+Theorem\r
+The critical sections of printing the texts supplied by the processes w1 and w2 is done in mutual exclusion.\r
+\r
+============================================================================\r
+Example 5\r
+\r
+In the example below we shall illustrate an asynchronous cooperation of processes.\r
+The case we are going to discuss now is as follows: there are several processes " writers ". Any of writers may print a file on a designated printer. In order to increase the throughput and in order to avoid an intermixed printing we have spoolers - one for each printer. A printer prints files taking them out of a queue.\r
+\r
+<PRE><B>program</B> Five;\r
+ \r
+ <B>unit </B>writer1: <B>process</B>(node: integer, printer1: spooler);\r
+\r
+ <B>begin</B>\r
+\r
+ <B>end </B>writer1;\r
+\r
+ <B>unit </B>writer2: <B>process</B>(node: integer, printer1, printer2: spooler);\r
+ (* this process may print on any of 2 printers *)\r
+ <B>end </B>writer2\r
+\r
+ <B>unit </B>spooler: <B>process</B>(node: integer);\r
+\r
+ <B>var </B>Q: queue,\r
+ f: file,\r
+ tick: integer;\r
+ \r
+ <B>unit </B>print: <B>procedure</B>(f: file, ticket: integer);\r
+ <B>begin</B>\r
+ <B>call </B>Q.insert(f);\r
+ <B>if </B>Q.full <B>then </B><B>return disable</B> print <B>fi;</B>\r
+ tick := tick + 1;\r
+ ticket := tick;\r
+ <B>end </B>print;\r
+\r
+ <B>begin </B>(*spooler*)\r
+ Q := <B>new </B>queue;\r
+ <B>return;</B>\r
+\r
+ <B>do</B>\r
+ <B>disable </B>print;\r
+ <B>if </B>Q.empty <B>then </B><B>accept</B> print <B>fi;</B>\r
+ f := Q.out;\r
+ <B>enable</B> print;\r
+ (* printing the file *)\r
+ ...\r
+ <B>od</B>\r
+ <B>end </B>spooler;\r
+\r
+ <B>var </B>s1, s2: spooler,\r
+ w1, w2: writer1,\r
+ w3 : writer2;\r
+<B>begin</B>\r
+\r
+ ...\r
+ s1 := <B>new </B>spooler(0);\r
+ <B>resume</B>(s1);\r
+\r
+ w1:= <B>new </B>writer1(0, s1);\r
+ w2 := <B>new </B>writer1(0, s1);\r
+ <B>resume</B>(s1);\r
+ <B>resume</B>(s2);\r
+\r
+ \r
+<B>end </B>Five\r
+</PRE>\r
+What are the properties of the program Five?\r
+Is it possible to obtain a mixture of texts coming from different files?\r
+<HR>\r
+<ADDRESS></ADDRESS>\r
+</body>\r
+</html>\r
+<DD>\r
+\r
+\r
+\r
+\r
+\r
+<H2></H2>\r
+ò\r
+<HR>
\ No newline at end of file
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Programowanie Obiktowe</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1>Programowanie Obiektowe</H1>\r
+\r
+<H3>1995/96 prof. Andrzej Salwicki</H3>\r
+\r
+<H3>wyklad i cwiczenia, III rok informatyki PB</H3>\r
+<HR>\r
+\r
+<P>\r
+Spis Tresci\r
+<DIR>\r
+<LI><A HREF="#cele">Cele: </A>\r
+<LI><A HREF="#streszczenie">Streszczenie</A>\r
+<LI><A HREF="#program">Program</A> \r
+<LI><A HREF="#metody">Metody pracy</A>\r
+<LI><A HREF="#pomoce">Pomoce dydaktyczne - Loglan'82</A>\r
+<LI><A HREF="#notatki">Notatki z wykladow</A>\r
+<LI><A HREF="#cwiczenia">Notatki z cwiczen</A> \r
+<LI><A HREF="#pytania">Pytania egzaminacyjne</A> \r
+</DIR>\r
+<HR>\r
+\r
+<H3><A NAME="cele">Cele:</A></H3>\r
+\r
+<OL>\r
+<LI>pomoc sluchaczom w wyrobieniu sobie pogladu na obiekty,\r
+<LI>opanowac narzedzia programowania obiektowego\r
+</OL>\r
+\r
+<H3><A NAME="streszczenie">Streszczenie</A> </H3>\r
+\r
+<H3><A NAME="program">Program</A> </H3>\r
+\r
+<H3><A NAME="metody">Metody pracy</A> </H3>\r
+\r
+<H3><A NAME="pomoce">Pomoce dydaktyczne - Loglan'82</A></H3>\r
+\r
+<P>\r
+Metody programowania obiektowego sa ilustrowane przykladami zrealizowanymi\r
+w jezyku Loglan'82. Wybralismy Loglan z wielu powodow:<BR>\r
+mozemy w nim zrealizowac \r
+<H3><A NAME="notatki"></A>Notatki z wykladow </H3>\r
+\r
+<H3><A NAME="cwiczenia">Notatki z cwiczen</A> </H3>\r
+\r
+<H3><A NAME="pytania">Pytania egzaminacyjne</A> </H3>\r
+\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<html>\r
+<head>\r
+<title>Quick Reference Card </title>\r
+</head>\r
+<body>\r
+\r
+<H1><img align=middle src="loglanmm.gif"> LOGLAN'82</H1>\r
+<H2>Quick Reference Card</H2>\r
+\r
+<table border>\r
+<tr>\r
+<td> <em> Syntax Form </em> </td>\r
+<td> <em> its (informal) meaning </em> </td>\r
+</tr>\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td><strong>program</strong> <<EM> name</em>>;<br> <em><declarations</em>><br>\r
+<strong>begin</strong><br> <em><instructions</em>><br> <strong>end</strong> </td>\r
+<td>Program is a module (=unit).<br> It is the root of a tree of nested units. <br>During an execution of a program this tree is used as a collection of patterns for <em>instances </em>. An instance of a unit is either an <em> activation record</em> of a procedure, a function, a block unit, or an <em> object</em> of a class, a coroutine, a process. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2><em>DECLARATIONS </em> </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><em>there are five forms of a declaration </em> </td>\r
+<th>var, const, unit, signal, handlers </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>var </strong> x:T, y,z: U </td>\r
+<td>declaration of variables: x of type T, y,z of type U </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>There exist <strong>units</strong> in several colours i.e. <strong><em>kind</em></strong>s </td>\r
+<td><strong>procedure, class, coroutine, process, block, handler, function</strong> </td>\r
+</tr>\r
+<tr>\r
+<td><strong>unit</strong> A: <<strong><em>kind</em></strong>>(<<em>params</strong></em>>);<br>\r
+ <<em>declarations</em>><br>\r
+<strong>begin</strong><br>\r
+<<em>instructions</em>>;<br> <strong>end </strong> A; </td>\r
+<td>declaration of a module A.<br>\r
+\r
+<em> params</em> is a list of formal parameters.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>\r
+<h7>Remarks</h7>\r
+<h7>- block has no name</h7>\r
+<h7>- - its first line is: <strong>block</strong> or <strong>pref</strong> C <strong>block</strong></H7>\r
+<h7>- function has a type of result after parameters,</H7>\r
+<h7>- handler has a different form, see below,<H7>\r
+<h7>- lastwill instructions are executed exceptionally.</h7> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong> const</strong> cc=82 </td>\r
+<td>declaration of a constant </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>signal</strong> S;<br><strong>signal</strong> Alarm(x:T, y:Q); </td>\r
+<td>declaration of a signal S<br> a signal may have a list of formal parameters </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>handlers</strong><br>\r
+ <strong>when </strong> <em>sig1, SIGN3<em>: <em>Inst</em>; <strong>return</strong><br>\r
+<strong>when </strong> <em>sig2</em>: instructions2; <strong>wind</strong>;<br>\r
+<strong>others </strong> <em>instr2</em>; <strong>terminate</strong><br>\r
+<strong> end handlers </strong></td>\r
+<td>declaration of a module which handles exceptions,<br>\r
+<em>sig1, sig2, SIGN3</em> are names of exceptions or signals<br>\r
+<em>Inst, instructions2, instr2</em> are sequences of instructions,<br>\r
+<em> handler appears as the last declaration in a unit!! </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2><em>Parametrisation of Units</em> </td>\r
+\r
+</tr>\r
+\r
+\r
+<tr>\r
+<td><em>modes</em> of transmission of values of expressions are: </td>\r
+<td><strong>input, output, inout</strong> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong> procedure, function, type</strong> can be transmitted as parameter as well </td>\r
+<td> <u>formal procedures and functions</u> should be specified i.e. the types of arguments and results should be given.<br> A <u>formal type </u> T alone is of limited use, however it may accompany other parameters using T. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Processes are <em>distributed</em>, it means that they cannot share objects. You can transmit only values of simple types and names of processes or formal procedures to be used for alien calls. </td>\r
+<td>Processes can reside on <em>different</em> processors of your computer or network. Or several processes may share one processor (UNIX and DOS systems). This explains the reasons for the restrictions. The present implementation of processes has several limitations. Sorry. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2><strong>INSTRUCTIONS </strong> </th>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2><strong>Atomic instructions </strong></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <<em>expression</em>> </td>\r
+<td>assignment instruction </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <strong>copy</strong>(<<em>expression</em>) </td>\r
+<td>a copying assignment instruction, has sense only for object expressions </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>call</strong> Aprocedure(params) </td>\r
+<td>procedure call instruction </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>return</strong> </td>\r
+<td>leaving procedure or function </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>exit</strong> or <strong>exit exit</strong> or <strong>exitexitexit</strong> ... </td>\r
+<td>leaving one, two or more nested loops <strong>do ...od</strong> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong> new</strong> Aclass(params) </td>\r
+<td>instruction generating an object </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Objects </th>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <strong>new</strong> Aclass(params) </td>\r
+<td>creates an object of class Aclass with params and stores it under the name of x </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>end</strong> Aclass <br> also <strong>return</strong> </td>\r
+<td>terminating initialisation of a newly created object </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>kill</strong>(x) </td>\r
+<td>deallocation instruction, causes x=none and kill x<br> REMARK<br> No dangling references!<br>{x=y & x=z}=>kill(x){x=none & y=none & z =none} </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>inner</strong> </td>\r
+<td>pseudoinstruction; it is a slot to put the instructions of an <em>inheriting</em> unit; </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Coroutines </th>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <strong>new </strong>Cor(params) </td>\r
+<td>creates a coroutine object x of type Cor, the coroutine-object x is passive </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>attach</strong>(x) </td>\r
+<td>makes the current coroutine chain passive and activates coroutine x </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>detach</strong> </td>\r
+<td>undoes the last attach </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2> <h7>You can combine coroutines and recursive procedures.</h7><br>\r
+<h7>Coroutines enable quasi-parallel programming - of importance for SIMULATION and games. </h7><br>\r
+</td>\r
+</tr>\r
+<tr>\r
+<th colspan=2>Processes & Concurrency </th>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>Loglan'82 offers truly object oriented processes and an object oriented communication mechanism <em>alien call</em> just by calling methods of a distant process </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>process5 := <strong>new</strong> prcsTyp(...) </td>\r
+<td>creates an object-process of<br><strong>unit</strong> prcsTyp:<strong>process</strong>(<params>) </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>resume</strong>(process5) </td>\r
+<td>activate a passive process <em>process5</em> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>stop</strong> </td>\r
+<td>the current process passivates </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>enable </strong> <em>hisProcedure</em> </td>\r
+<td> process adds the name of hisProcedure to the MASK of the process, enabling other processes to communicate with the process by means of hisProcdure. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>disable </strong> <em>aProcedure, aFunction</em> </td>\r
+<td> deletes the names: aProcedure, aFunction from the MASK.</td>\r
+</tr>\r
+<tr>\r
+<td><strong>accept </strong> aProc1, aProc2, AFun </td>\r
+<td>process waits (<em>inactively</em>) for another process calling a method.<br>\r
+accept makes possible rendez-vous of this process and another process calling a method from the MASK or the list aProc1, aProc2, aFun. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>return disable</strong> aProc1 <strong>enable</strong> aProc2 </td>\r
+<td>return from a rendez-vous reestablishes the MASK of the called process; it is possible to modify its MASK disabling some procedures and enabling others. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>call</strong> process5.hisProcedure(par)<br>\r
+<h2>this is ALIEN CALL</h2> </td>\r
+<td>The current process demands <em>process5</em> process to execute <em>hisProcedure</em> with the <em>par</em> parameters transmitted and waits for the results, eventually gets outputs.<br>\r
+1) this instruction may meet with an <strong>accept</strong> instruction of <em>process5</em> processs - in such a case there is a rendez-vous of two processes,<br>\r
+2) otherwise the <strong>call</strong> tents to interrupt the normal flow of execution of the called process. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Exception handling </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>raise </strong> <em> aSignal</em> </td>\r
+<td>A signal is raised. This lances the research of a module <strong>handler</strong> of the <em>aSignal</em> signal along the chain of DL links i.e. along dynamic fathers of instances. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>3 forms of terminating an exception handling are provided:</td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>return</strong> </td>\r
+<td>returns to after raise statement </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>wind</strong> </td>\r
+<td>destructs several instances of units (cf.lastwill) but the instance containing the handler. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>terminate</strong> </td>\r
+<td>destructs several instances of units (cf.lastwill) and the instance containing the handler. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Composed Instructions </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>if </strong> <em>Cond </em> <strong>then </strong> I <strong>else </strong> J <strong>fi</strong> </td>\r
+<td><em>Cond </em> is a Boolean expression, I,J are sequences of instructions,<br>\r
+(<em>else J is optional</em> ) </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>do </strong> I <strong>od </strong> </td>\r
+<td>looping instruction, it is suggested to put an <strong>exit </strong> instruction among the instructions I. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>while </strong> <em>Cond </em> <strong>do </strong> I <strong>od</strong></td>\r
+<td>is equivalent to<br>\r
+<strong>do </strong><br> <strong>if </strong> <em>Cond </em> <strong>then </strong> I <strong>else exit fi<br> od</strong> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>for </strong> i := A <strong>to </strong> B <strong>do </strong> I <strong>od </strong> </td>\r
+<td>i - an integer variable, A, B integer expressions, I a sequence of instructions </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>case </strong> c<br>\r
+ <strong>when </strong> c1: I1;<br>\r
+ <strong>when </strong> c2: I2;<br>\r
+ <strong>otherwise </strong> J <br>\r
+<strong>esac</strong> </td>\r
+<td> case instruction,<br>\r
+I, J are sequences of instructions,<br>\r
+c an integer expression, c1, c2 integer constants </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>EXPRESSIONS </th>\r
+</tr>\r
+\r
+<tr>\r
+<td> Arithmetic expressions </td>\r
+<td> they are as you believe they should be </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Boolean expressions </td>\r
+<td>NOTE object relations <strong>in </strong> and <strong>is </strong>, e.g. <strong>if </strong> x <strong>in </strong> Class2 </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>Object expressions </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>new </strong> T(actual_params)</td>\r
+<td>returns a new object of class (coroutine, process) T </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>this </strong> T </td>\r
+<td>returns as a value the object of type T containing this expression </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>E <strong>qua </strong> A </td>\r
+<td>qualifies the value of object expression E as of type A<br>\r
+<em>Raises error </em> if not E <strong>in </strong> A </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>copy</strong>(E) </td>\r
+<td>returns a copy of the value of the object expression E </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Character expressions </td>\r
+<td>as usual </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>String expressions </td>\r
+<td>no operations on strings </td>\r
+</tr>\r
+\r
+<tr>\r
+<td> </td>\r
+<td> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><H1>INHERITANCE & NESTING</H1> </td>\r
+<td>2 fundamental methods of unit's composition </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><em>Multi-level inheritance </em> permits to make extensions of classes, coroutines, processes defined on different levels of the nesting structure of units. </td>\r
+<td><em>Multi-kind inheritance </em> permits to inherit in a block, procedure, function, class, coroutine or process. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><em>Multiple inheritance </em> is emulated by means of multi-level inheritance and other ingredients of Loglan'82 </td>\r
+<td><em>Generic modules </em> are doable in various ways: by formal types, by multi-level inheritance combined with nesting, to say nothing about <em>virtuals</em>. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td> </td>\r
+<td> </td>\r
+</tr>\r
+\r
+</table>\r
+<hr>\r
+<a href="whylog.htm"><img src="prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="homepage.gif"></a>\r
+<a href="tablica3.htm"><img src="nextpage.gif"></a> \r
+<hr>\r
+<address>\r
+<a href="GMyAS.html">AS </a> Last update Sat 4 Feb 1995\r
+</address>\r
+\r
+</body>\r
+</html>pp
\ No newline at end of file
--- /dev/null
+<html>\r
+<head>\r
+<title>Quick Reference Card </title>\r
+</head>\r
+<body>\r
+\r
+<H1><img align=middle src="loglanmm.gif"> LOGLAN'82</H1>\r
+<H2>Quick Reference Card</H2>\r
+\r
+<table border>\r
+<tr>\r
+<td> <em> Syntax Form </em> </td>\r
+<td> <em> its (informal) meaning </em> </td>\r
+</tr>\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td><strong>program</strong> <<EM> name</em>>;<br> <em><declarations</em>><br>\r
+<strong>begin</strong><br> <em><instructions</em>><br> <strong>end</strong> </td>\r
+<td>Program is a module (=unit).<br> It is the root of a tree of nested units. <br>During an execution of a program this tree is used as a collection of patterns for <em>instances </em>. An instance of a unit is either an <em> activation record</em> of a procedure, a function, a block unit, or an <em> object</em> of a class, a coroutine, a process. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2><em>DECLARATIONS </em> </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><em>there are five forms of a declaration </em> </td>\r
+<th>var, const, unit, signal, handlers </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>var </strong> x:T, y,z: U </td>\r
+<td>declaration of variables: x of type T, y,z of type U </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>There exist <strong>units</strong> in several colours i.e. <strong><em>kind</em></strong>s </td>\r
+<td><strong>procedure, class, coroutine, process, block, handler, function</strong> </td>\r
+</tr>\r
+<tr>\r
+<td><strong>unit</strong> A: <<strong><em>kind</em></strong>>(<<em>params</strong></em>>);<br>\r
+ <<em>declarations</em>><br>\r
+<strong>begin</strong><br>\r
+<<em>instructions</em>>;<br> <strong>end </strong> A; </td>\r
+<td>declaration of a module A.<br>\r
+\r
+<em> params</em> is a list of formal parameters.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>\r
+<h7>Remarks</h7>\r
+<h7>- block has no name</h7>\r
+<h7>- - its first line is: <strong>block</strong> or <strong>pref</strong> C <strong>block</strong></H7>\r
+<h7>- function has a type of result after parameters,</H7>\r
+<h7>- handler has a different form, see below,<H7>\r
+<h7>- lastwill instructions are executed exceptionally.</h7> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong> const</strong> cc=82 </td>\r
+<td>declaration of a constant </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>signal</strong> S;<br><strong>signal</strong> Alarm(x:T, y:Q); </td>\r
+<td>declaration of a signal S<br> a signal may have a list of formal parameters </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>handlers</strong><br>\r
+ <strong>when </strong> <em>sig1, SIGN3<em>: <em>Inst</em>; <strong>return</strong><br>\r
+<strong>when </strong> <em>sig2</em>: instructions2; <strong>wind</strong>;<br>\r
+<strong>others </strong> <em>instr2</em>; <strong>terminate</strong><br>\r
+<strong> end handlers </strong></td>\r
+<td>declaration of a module which handles exceptions,<br>\r
+<em>sig1, sig2, SIGN3</em> are names of exceptions or signals<br>\r
+<em>Inst, instructions2, instr2</em> are sequences of instructions,<br>\r
+<em> handler appears as the last declaration in a unit!! </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2><em>Parametrisation of Units</em> </td>\r
+\r
+</tr>\r
+\r
+\r
+<tr>\r
+<td><em>modes</em> of transmission of values of expressions are: </td>\r
+<td><strong>input, output, inout</strong> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong> procedure, function, type</strong> can be transmitted as parameter as well </td>\r
+<td> <u>formal procedures and functions</u> should be specified i.e. the types of arguments and results should be given.<br> A <u>formal type </u> T alone is of limited use, however it may accompany other parameters using T. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Processes are <em>distributed</em>, it means that they cannot share objects. You can transmit only values of simple types and names of processes or formal procedures to be used for alien calls. </td>\r
+<td>Processes can reside on <em>different</em> processors of your computer or network. Or several processes may share one processor (UNIX and DOS systems). This explains the reasons for the restrictions. The present implementation of processes has several limitations. Sorry. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2><strong>INSTRUCTIONS </strong> </th>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2><strong>Atomic instructions </strong></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <<em>expression</em>> </td>\r
+<td>assignment instruction </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <strong>copy</strong>(<<em>expression</em>) </td>\r
+<td>a copying assignment instruction, has sense only for object expressions </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>call</strong> Aprocedure(params) </td>\r
+<td>procedure call instruction </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>return</strong> </td>\r
+<td>leaving procedure or function </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>exit</strong> or <strong>exit exit</strong> or <strong>exitexitexit</strong> ... </td>\r
+<td>leaving one, two or more nested loops <strong>do ...od</strong> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong> new</strong> Aclass(params) </td>\r
+<td>instruction generating an object </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Objects </th>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <strong>new</strong> Aclass(params) </td>\r
+<td>creates an object of class Aclass with params and stores it under the name of x </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>end</strong> Aclass <br> also <strong>return</strong> </td>\r
+<td>terminating initialisation of a newly created object </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>kill</strong>(x) </td>\r
+<td>deallocation instruction, causes x=none and kill x<br> REMARK<br> No dangling references!<br>{x=y & x=z}=>kill(x){x=none & y=none & z =none} </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>inner</strong> </td>\r
+<td>pseudoinstruction; it is a slot to put the instructions of an <em>inheriting</em> unit; </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Coroutines </th>\r
+</tr>\r
+\r
+<tr>\r
+<td>x := <strong>new </strong>Cor(params) </td>\r
+<td>creates a coroutine object x of type Cor, the coroutine-object x is passive </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>attach</strong>(x) </td>\r
+<td>makes the current coroutine chain passive and activates coroutine x </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>detach</strong> </td>\r
+<td>undoes the last attach </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2> <h7>You can combine coroutines and recursive procedures.</h7><br>\r
+<h7>Coroutines enable quasi-parallel programming - of importance for SIMULATION and games. </h7><br>\r
+</td>\r
+</tr>\r
+<tr>\r
+<th colspan=2>Processes & Concurrency </th>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>Loglan'82 offers truly object oriented processes and an object oriented communication mechanism <em>alien call</em> just by calling methods of a distant process </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>process5 := <strong>new</strong> prcsTyp(...) </td>\r
+<td>creates an object-process of<br><strong>unit</strong> prcsTyp:<strong>process</strong>(<params>) </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>resume</strong>(process5) </td>\r
+<td>activate a passive process <em>process5</em> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>stop</strong> </td>\r
+<td>the current process passivates </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>enable </strong> <em>hisProcedure</em> </td>\r
+<td> process adds the name of hisProcedure to the MASK of the process, enabling other processes to communicate with the process by means of hisProcdure. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>disable </strong> <em>aProcedure, aFunction</em> </td>\r
+<td> deletes the names: aProcedure, aFunction from the MASK.</td>\r
+</tr>\r
+<tr>\r
+<td><strong>accept </strong> aProc1, aProc2, AFun </td>\r
+<td>process waits (<em>inactively</em>) for another process calling a method.<br>\r
+accept makes possible rendez-vous of this process and another process calling a method from the MASK or the list aProc1, aProc2, aFun. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>return disable</strong> aProc1 <strong>enable</strong> aProc2 </td>\r
+<td>return from a rendez-vous reestablishes the MASK of the called process; it is possible to modify its MASK disabling some procedures and enabling others. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>call</strong> process5.hisProcedure(par)<br>\r
+<h2>this is ALIEN CALL</h2> </td>\r
+<td>The current process demands <em>process5</em> process to execute <em>hisProcedure</em> with the <em>par</em> parameters transmitted and waits for the results, eventually gets outputs.<br>\r
+1) this instruction may meet with an <strong>accept</strong> instruction of <em>process5</em> processs - in such a case there is a rendez-vous of two processes,<br>\r
+2) otherwise the <strong>call</strong> tents to interrupt the normal flow of execution of the called process. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Exception handling </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>raise </strong> <em> aSignal</em> </td>\r
+<td>A signal is raised. This lances the research of a module <strong>handler</strong> of the <em>aSignal</em> signal along the chain of DL links i.e. along dynamic fathers of instances. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>3 forms of terminating an exception handling are provided:</td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>return</strong> </td>\r
+<td>returns to after raise statement </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>wind</strong> </td>\r
+<td>destructs several instances of units (cf.lastwill) but the instance containing the handler. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>terminate</strong> </td>\r
+<td>destructs several instances of units (cf.lastwill) and the instance containing the handler. </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>Composed Instructions </th>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>if </strong> <em>Cond </em> <strong>then </strong> I <strong>else </strong> J <strong>fi</strong> </td>\r
+<td><em>Cond </em> is a Boolean expression, I,J are sequences of instructions,<br>\r
+(<em>else J is optional</em> ) </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>do </strong> I <strong>od </strong> </td>\r
+<td>looping instruction, it is suggested to put an <strong>exit </strong> instruction among the instructions I. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>while </strong> <em>Cond </em> <strong>do </strong> I <strong>od</strong></td>\r
+<td>is equivalent to<br>\r
+<strong>do </strong><br> <strong>if </strong> <em>Cond </em> <strong>then </strong> I <strong>else exit fi<br> od</strong> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>for </strong> i := A <strong>to </strong> B <strong>do </strong> I <strong>od </strong> </td>\r
+<td>i - an integer variable, A, B integer expressions, I a sequence of instructions </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>case </strong> c<br>\r
+ <strong>when </strong> c1: I1;<br>\r
+ <strong>when </strong> c2: I2;<br>\r
+ <strong>otherwise </strong> J <br>\r
+<strong>esac</strong> </td>\r
+<td> case instruction,<br>\r
+I, J are sequences of instructions,<br>\r
+c an integer expression, c1, c2 integer constants </td>\r
+</tr>\r
+\r
+<tr>\r
+<th colspan=2>EXPRESSIONS </th>\r
+</tr>\r
+\r
+<tr>\r
+<td> Arithmetic expressions </td>\r
+<td> they are as you believe they should be </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Boolean expressions </td>\r
+<td>NOTE object relations <strong>in </strong> and <strong>is </strong>, e.g. <strong>if </strong> x <strong>in </strong> Class2 </td>\r
+</tr>\r
+\r
+<tr>\r
+<td colspan=2>Object expressions </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>new </strong> T(actual_params)</td>\r
+<td>returns a new object of class (coroutine, process) T </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>this </strong> T </td>\r
+<td>returns as a value the object of type T containing this expression </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>E <strong>qua </strong> A </td>\r
+<td>qualifies the value of object expression E as of type A<br>\r
+<em>Raises error </em> if not E <strong>in </strong> A </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><strong>copy</strong>(E) </td>\r
+<td>returns a copy of the value of the object expression E </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Character expressions </td>\r
+<td>as usual </td>\r
+</tr>\r
+\r
+<tr>\r
+<td>String expressions </td>\r
+<td>no operations on strings </td>\r
+</tr>\r
+\r
+<tr>\r
+<td> </td>\r
+<td> </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><H1>INHERITANCE & NESTING</H1> </td>\r
+<td>2 fundamental methods of unit's composition </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><em>Multi-level inheritance </em> permits to make extensions of classes, coroutines, processes defined on different levels of the nesting structure of units. </td>\r
+<td><em>Multi-kind inheritance </em> permits to inherit in a block, procedure, function, class, coroutine or process. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td><em>Multiple inheritance </em> is emulated by means of multi-level inheritance and other ingredients of Loglan'82 </td>\r
+<td><em>Generic modules </em> are doable in various ways: by formal types, by multi-level inheritance combined with nesting, to say nothing about <em>virtuals</em>. </td>\r
+</tr>\r
+\r
+<tr>\r
+<td> </td>\r
+<td> </td>\r
+</tr>\r
+\r
+</table>\r
+<hr>\r
+<a href="whylog.htm"><img src="/icons/prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="/icons/homepage.gif"></a>\r
+<a href="tablica3.htm"><img src="/icons/nextpage.gif"></a> \r
+<hr>\r
+<address>\r
+<a href="GMyAS.html">AS </a> Last update Sat 4 Feb 1995\r
+</address>\r
+\r
+</body>\r
+</html>pp
\ No newline at end of file
--- /dev/null
+LOGLAN'82\r
+Quick Reference Card\r
+Syntax Form\r
+ its meaning (informal)\r
+\r
+ program <name>;\r
+ <declarations>\r
+ begin\r
+ <instructions>;\r
+ end\r
+Program is a unit. It is the root of a tree of units.\r
+During an execution of the program this tree is \r
+used as a collection of patterns for instances. An \r
+instance of a unit is either an activation record (of \r
+a procedure) or an object(of a class).\r
+\r
+Declarations\r
+\r
+\r
+there are five forms of a declaration: \r
+\r
+\r
+\r
+var, const, unit, signal, handlers \r
+\r
+ var x: T, y,z: U;\r
+declaration of variables x of type T, y,z of type U\r
+\r
+ unit A: B<kind>(params);\r
+ <declarations>\r
+ begin\r
+ <instructions>;\r
+ last_will: <instructions>\r
+ end A;\r
+\r
+evidently you need not to inherit from a module \r
+declaration of a module A which inherits from B. \r
+kind may be one of: procedure, class, coroutine, \r
+process, block, handler, function\r
+params is a list of formal parameters,\r
+REMARKS\r
+- block has no name \r
+ its first line is: block or pref C block\r
+- function has a type of result after parameters,\r
+- handler has a different form., see below,\r
+- last_will instruction are executed exceptionally.\r
+\r
+ const cc=80\r
+declaration of a constant\r
+\r
+ signal S;\r
+ signal Alarm(x: T, y: Q);\r
+declaration of a signal S\r
+it may have a list of formal parameters \r
+\r
+\r
+ handlers\r
+ when sig1,SIGN3: Inst; return;\r
+ when sig2: instructions2; wind;\r
+ others in; terminate\r
+ end handlers\r
+declaration of a module handling exceptions,\r
+sig1, sig2, SIGN3 are names of exceptions,\r
+Inst, instructions2,in are sequences of instructions\r
+\r
+handlers appear as the last declaration in a unit\r
+\r
+\r
+\r
+\r
+Parametrisation of Units\r
+\r
+\r
+modes of transmission: \r
+input, output, inout values of expressions\r
+\r
+also procedure, function, type can be \r
+transmitted as a parameter\r
+formal procedures(functions) should be specified \r
+i.e. the types of arguments and results should be \r
+given.\r
+a formal type T alone is of limited use, however it \r
+may accompany other parameters using T.\r
+\r
+Processes are distributed it means that \r
+they cannot share objects. You can \r
+transmit only values of simple types and \r
+names of processes or formal procedures \r
+to be used for alien calls.\r
+Processes can reside on different systems of your \r
+network. This explains the reasons for the \r
+restrictions. \r
+The present implementation of processes has \r
+several limitations. Sorry.\r
+\r
+Instructions\r
+\r
+\r
+Atomic instructions\r
+\r
+\r
+ x := <expression>\r
+assignment instruction\r
+\r
+ x := copy (<expression>)\r
+copying assignment instruction, has sense only for \r
+object expressions\r
+\r
+ call Aprocedure(params)\r
+procedure call instruction\r
+\r
+ return\r
+leaving procedure or function\r
+\r
+ exit or exit exit or exit exit exit\r
+leaving one, two or three nested loops do od\r
+\r
+ new Aclass(params) \r
+instruction generating an object\r
+\r
+ Objects\r
+\r
+\r
+ x := new Aclass(params)\r
+creates an object of class Aclass with params\r
+and stores it under the name of x\r
+\r
+ end Aclass or return\r
+terminating initialisation of a newly created object\r
+\r
+ kill(x)\r
+deallocation instruction, causes{x=none}and kills x\r
+REMARK. No dangling references!\r
+{x=y&x=z} => kill(x) {x=none&y=none&z=none}\r
+\r
+ inner\r
+pseudoinstruction: a slot for the instructions of an \r
+inheriting unit\r
+\r
+ Coroutines\r
+\r
+\r
+ x := new Cor(params)\r
+creates a coroutine object x of type Cor\r
+\r
+ attach(x)\r
+activates coroutine x, and then makes the current \r
+coroutine chain passive \r
+\r
+ detach\r
+undoes the last attach \r
+\r
+ Processes & Concurrency\r
+truly object oriented processes and an objective com-\r
+munication mechanism just by calling methods of a \r
+distant process\r
+\r
+ proces5:=new procesType(...);\r
+creates an object of \r
+ unit procesType: process(<formParams>); ...\r
+\r
+ resume(proces5)\r
+activate a passive process process5\r
+\r
+ stop\r
+the current process passivates\r
+\r
+ enable hisprocedure\r
+adds the name hisprocedure to the MASK of the \r
+process, enabling other processes to communicate \r
+with the process by means of hisprocedure\r
+\r
+ disable aProcedure,aFunction\r
+deletes aProcedure,aFunction from the MASK\r
+\r
+ accept aProc1, aProc2, aFnctn\r
+process waits (inactively) for another process \r
+calling a method; \r
+accept makes possible rendez-vous of this process \r
+and another process calling his method\r
+\r
+ return disable aProc1 enable aQ\r
+return from a rendez-vous reestablishes the MASK \r
+of the called process; it is posible to modify its \r
+MASK disabling some procedures and enabling \r
+others\r
+\r
+ call proces5.hisprocedure(par)\r
+\r
+ *\r
+\r
+ this is ALIEN CALL\r
+the current process demands process5 process to \r
+execute hisprocedure with the transmitted par \r
+parameters and waits for the eventual outputs;\r
+1 this instruction may meet with an accept \r
+instruction of process5 process - in such case there \r
+is a rendez-vous of two process,\r
+2 otherwise the call tents to interrupt the normal \r
+flow of execution of the called process5 process.\r
+\r
+ \r
+ Exception handling\r
+\r
+\r
+ raise Asignal\r
+Asignal is raised. This lances the research of a \r
+module handling the signal along the chain of DL \r
+links i.e. along dynamic fathers of instances. \r
+\r
+ return\r
+* returns to after raise statement\r
+\r
+ wind\r
+* 3 forms of terminating an exception handling\r
+\r
+ terminate\r
+* destructs (lastwill) several instances of units\r
+\r
+\r
+Composed instructions\r
+\r
+\r
+ if * then I else J fi\r
+* is a Boolean expression\r
+I, J are sequences of instructions {else J is optional}\r
+\r
+ do I od\r
+looping instruction; it is suggested to put an exit \r
+instruction among the instructions I, see below\r
+\r
+ while * do I od\r
+* is a Boolean expression\r
+I a sequence of instructions\r
+equivalent to\r
+do\r
+ if * then I else exit fi\r
+od\r
+\r
+ for i:= A to B do I od\r
+i integer variable, A, B integer expressions,\r
+I a sequence of instructions\r
+\r
+ case c\r
+ when c1: I;\r
+ otherwise J\r
+ esac\r
+case instruction\r
+I, J are sequences of instructions\r
+c is an expression, c1 is a constant\r
+ \r
+\r
+\r
+Expressions\r
+\r
+\r
+Arithmetic expressions\r
+\r
+\r
+Boolean expressions\r
+remark in and is object relations, e.g. if x in Clas2 \r
+\r
+Object expressions\r
+\r
+\r
+ new T(actual_params)\r
+create new object of class (coroutine, process) T \r
+passing the actual_params list to it\r
+\r
+ this T\r
+returns as a value the object of type T containing \r
+this expression\r
+\r
+ E qua A\r
+qualifies the value of E as of type A\r
+Raises error if not E in A\r
+\r
+ copy(E)\r
+returns a copy of value of the object expression E \r
+\r
+Character expressions\r
+\r
+\r
+String expressions\r
+only constant strings!\r
+\r
+\r
+Inheritance & Nesting * \r
+\r
+2 fundamental methods of unit's composition\r
+\r
+Multi-level inheritance permits to make \r
+extensions of classes, coroutines, \r
+processes defined on different level of \r
+the nesting structure of units.\r
+Multi-kind inheritance permits to inherit in a \r
+block, procedure, function, class, coroutine or \r
+process.\r
+\r
+\r
+Multiple inheritance is doable by means \r
+of multi-level inheritance and other \r
+ingredients of Loglan.\r
+Generic modules are doable in various ways: by \r
+formal types, by multi-level inheritance combined \r
+with nesting, to say nothing about virtuals.\r
+\r
+\r
+Loglan'82 Quick Reference Card - 3 - December, 94\r
+\r
+\r
--- /dev/null
+<HTML><HEAD><TITLE>Read it first</TITLE>\r
+</HEAD>\r
+<BODY>\r
+<H1>Index of pub directory on <I>infpc1.univ-pau.fr</I></H1>\r
+\r
+We are giving you access to several directories.\r
+\r
+<UL>\r
+\r
+<P><LI>In <A HREF ="Loglan82.htm">Loglan82 directory</A> you will find the Loglan'82 system:\r
+ its compilers, the documentation, the sources, its environment, the examples\r
+\r
+<P><LI>In <A HREF = "AlgoLog.htm">Algorithmic_Logic</A> directory you will find some reports and papers in preliminary form.\r
+You are bound by the <A HREF = "copyr.html">Copyright</A>.\r
+\r
+<P><LI>In <A HREF = "catalli1.htm">Lecture_Notes_Li1 directory</A> we present a sample of lecture notes on the course Li& and other \r
+material. This is our intelectual property and you are bound by the <A HREF = "Copyr.html">Copyright</A>.\r
+\r
+<P><LI>In <A HREF = "Loglan95.htm">Loglan'95 Research directory</A> we put some material to inform you about our plans of research.Should you be\r
+interested in the topics please contact us.\r
+</UL>\r
+\r
+<HR><ADDRESS><A HREF = "GMyAS.html">AS </A>Last update Sun 5 Mar 1995</ADDRESS>\r
+</BODY>\r
+</HTML>\r
+\r
+\r
+<H1></H1>\r
+\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Signals</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H4>Loglan'82 Programming Language<BR>\r
+______________________________</H4>\r
+\r
+<H1>Signallling Exceptional Situations & Treatment of Exceptions\r
+<BR>\r
+</H1>\r
+\r
+<H2>1. MOTIVATIONS</H2>\r
+\r
+<P>\r
+Programs which we are constructing should be <I>robust</I>, i.e.\r
+they should not fail even if the values of parameters(data) for\r
+a procedure, function etc.are out of the domain of a procedure\r
+in question. The minimal requirement would be: if the data do\r
+not belong to the assumed domain of program then this information\r
+should be displayed. However, in many cases the programmer is\r
+able to react at errors which appear during the execution of a\r
+program.<BR>\r
+Sometimes she(he) is able to use the mechanisms build for the\r
+use in unusual situations in a non-standard, elegant way (see\r
+the example MAZE below). However we are not suggesting this to\r
+turn into your style or "maniere" of writing programs.\r
+<P>\r
+Another keyword applicable here is security. If we wish to construct\r
+a secure program then we need appropriate tools to assure this\r
+property.<BR>\r
+What will be called an exceptional situation?<BR>\r
+<B>Example 1<BR>\r
+</B>Let us consider the data structure STACKS with operations\r
+<BR>\r
+\r
+<UL>\r
+<LI>pop(s)\r
+<LI>push(e,s)\r
+<LI>top(s)\r
+<LI>empty(s)\r
+</UL>\r
+\r
+<P>\r
+It will be an exceptional situation, if one will call pop for\r
+an empty stack or will call push for a full stack. Obviously we\r
+can require that the user never calls pop(s) when s in an empty\r
+stack, but our program can be more flexible i.e. clever and we\r
+can foresee eventual unproper usage of the partial operations\r
+from our module. <BR>\r
+\r
+<P>\r
+Another example of exceptional situation arrive when one thinks\r
+of getting an element of an array in such a way that the index\r
+of the element is outside the limits of the array. Obviously we\r
+can advise to replace any occurrency of a subscripted variable\r
+A[i] by a guarded command like the following one\r
+<PRE>\r
+ if lower(A)-1 < i and i < upper(A)+1 \r
+ then \r
+ y := A[i]\r
+ else\r
+ (* put here your reaction for the array index error *)\r
+ fi <BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+which replaces the instruction\r
+<PRE>\r
+ y := A[i]\r
+</PRE>\r
+\r
+<P>\r
+.<BR>\r
+The advice consequently applied throughout a program would make\r
+it unreadable, thus opening the doors for numerous errors. A solution\r
+lies in signalling an error or exception and propagating such\r
+a signal to the nearest object or dynamic instance of a procedure\r
+which contain a recipe (a handler) how to react. Some exceptional\r
+situations are detected automatically by the Loglan system (see\r
+the list of run-time errors) . Some exceptions may be signalled\r
+trough the <B>raise</B> instruction.<BR>\r
+\r
+<H2>2. SYNTAX</H2>\r
+\r
+<P>\r
+Treatment of signals in Loglan is distributed onto different fragments\r
+of a program.\r
+<UL>\r
+<LI>(a) declaration of signal\r
+<LI>(b) handlers of exceptions\r
+<LI>(c) <B>raise</B> instruction\r
+<LI>(d) <B>return</B>, <B>terminated</B>, <B>wind</B>: the ways\r
+to terminate handlers\r
+<LI>(e) <B>lastwill</B> \r
+</UL>\r
+\r
+<P>\r
+In order to do with signals and exceptional situations one must:\r
+<BR>\r
+\r
+<OL>\r
+<LI>declare a signal,<BR>\r
+\r
+<LI>propagate the signal toward a handler,<BR>\r
+\r
+<LI>write one or more modules which will handle the signal,<BR>\r
+\r
+<LI>exit from a handler,<BR>\r
+\r
+<LI>the latter action may necessitate the execution of the lastwill\r
+instructions for the instances of modules that may be killed by\r
+such an exit.<BR>\r
+\r
+</OL>\r
+\r
+<H2>3. SEMANTICS</H2>\r
+\r
+<H3>(a) Signal declaration <BR>\r
+</H3>\r
+\r
+<P>\r
+A signal declaration consists of keyword <B>signal</B> and the\r
+list of names of signals we are going to use together with eventual\r
+lists of formal parameters (the parameters of signals are not\r
+obligatory however ), e.g. <BR>\r
+\r
+<PRE>\r
+<B>signal</B> empty_stack(s:stack),\r
+ no_record(r:key),\r
+ stackoverflow; \r
+</PRE>\r
+\r
+<P>\r
+Declaration of signal(s)may appear anywhere in the declaration\r
+part of a module. <BR>\r
+\r
+<H3>(b) Modules handling signals <BR>\r
+</H3>\r
+\r
+<P>\r
+Let <I>Ni</I> be a name of a signal and <I>Si</I> a sequence of\r
+instructions. We assume that names of signals are visible (declared).\r
+Then we can write ( as the end part of the declaration part of\r
+a module) the following definition of handling signals:<BR>\r
+\r
+<PRE>\r
+handlers\r
+ when <I>N1</I>: <I>S1</I>;\r
+<B>when</B> <I>N2</I>: <I>S2</I>;\r
+ ..............\r
+<B>others </B><I>Sn\r
+</I><B>end handlers</B>\r
+</PRE>\r
+\r
+<P>\r
+The sequence of instructions Si is called a handler for the signal\r
+Ni. The sequence Sn appearing after the clause <B>others</B> is\r
+a universal handler for any signal which can be propagated into\r
+an object of this module and which is not listed above. Si - can\r
+contain any legal instructions and moreover instructions <B>return,\r
+wind, terminate</B> which determine the way in which this handler\r
+will be finished, and the place where the execution of program\r
+will be continued. <BR>\r
+\r
+<H3>(c) Raising a signal <BR>\r
+</H3>\r
+\r
+<P>\r
+An instruction raising a signal contains the keyword <B>raise</B>\r
+and the name of a signal which we would like to be handled, the\r
+list of actual parameters can be given if the signal was declared\r
+with a list of formal parameters. <BR>\r
+<B>Example 2<BR>\r
+<B> raise </B></B>found;<BR>\r
+<B>if </B>x> size <B> then raise </B>too_much <B>fi;<BR>\r
+raise</B> empty_stack(s)<BR>\r
+<BR>\r
+Meaning:<BR>\r
+A signal can be raised during an execution of a program either\r
+by run-time system (e.g. MEMERROR) or by program (cf. <B>raise</B>\r
+instruction above) Suppose that a signal f has been raised in\r
+an object M. For brevity, we shall use the name object also for\r
+dynamic instances of blocks, functions, procedures. If M contains\r
+a handler for f then this handler is executed. More precisely:\r
+an instance H of this handler is created, the static father of\r
+H is M, the dynamic father of H is the module in which the signal\r
+was raised, in this case it is again M. Otherwise the search of\r
+a handler for a signal is continued in the dynamic father of the\r
+object M. One can also say that the signal has been propagated\r
+to the dynamic father of the object. There are three modifications\r
+to this scheme: 1. if M is an exception handler then signal is\r
+propagated to the object in which M is declared 2. if M is a coroutine\r
+or the whole program then the whole program is terminated' 3.\r
+If M is a process then the process is terminated. When an object\r
+containing a handler for the signal was found, the object of handler\r
+is created. Its dynamic father is the object in which the signal\r
+was raised, its static father is the object in which a declaration\r
+of the handler was found. <BR>\r
+<B>Example 3</B> <BR>\r
+\r
+<PRE>\r
+<B>program</B> three;\r
+<B>unit </B>record : class;\r
+<B>var </B>key : T;\r
+<B> end</B> record;\r
+\r
+<B> signal</B> no_record(k:T);\r
+<B>unit </B>search : <B> function</B>(k:T): record;\r
+<B>var </B>r:record;\r
+<B>handlers\r
+ when </B>eof_error: <B>raise </B>no_record(k);\r
+<B>end handlers</B>;\r
+<B> begin\r
+ do</B> get(f,r);\r
+<B> if</B> equal(r.key,k)<B> then </B> result:=r; exit <B>fi</B>;\r
+<B>od\r
+ end</B> search;\r
+<B>handlers\r
+ when</B> no_record : ...\r
+<B>end handlers</B>;\r
+<B>begin</B> ...\r
+ r:=search(k);\r
+ ...\r
+<B>end </B>three<BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+In this example the signal no-record is raised when the system\r
+raises the signal eof. Thus we reinterpret the eof signal and\r
+adapt it to our aims. <BR>\r
+\r
+<P>\r
+<B>Example 4</B> <BR>\r
+\r
+<PRE>\r
+<B>program</B> exercise4;\r
+ <B>signal</B> f;\r
+ <B>unit</B> A: <B>procedure</B>;\r
+ <B>begin</B>...\r
+ <B>raise</B> f;\r
+ ...\r
+ <B>end</B> A;\r
+\r
+ <B>unit</B> B : <B>procedure</B>;\r
+ <B>handlers\r
+</B> <B>when</B> f : ...\r
+ <B>end</B> handlers;\r
+ <B>begin\r
+</B> <B>call</B> A; \r
+ ...\r
+ <B>raise</B> f;\r
+ <B>end</B> B;\r
+ <B>handlers\r
+</B> <B>when</B> f :...\r
+ <B>end</B> handlers;\r
+<B>begin</B> (*main program *)\r
+ ...\r
+ <B>raise</B> f;\r
+ ...\r
+ <B>call</B> B;\r
+ ...\r
+ <B>call </B>A\r
+<B>end </B>exercise4.<BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+In this example one signal has two handlers. The signal f raised\r
+in the main program or in procedure A will be served by the handler\r
+declared in the main program module. The signal f raised in procedure\r
+B either directly: by <B>raise</B>, or indirectly by <B>raise</B>\r
+in the procedure A called from B will be served by the handler\r
+declared in procedure B.<BR>\r
+.<BR>\r
+<I> <BR>\r
+</I>\r
+<H3><I>(d) How to end a service (handling) of a signal? <BR>\r
+</I></H3>\r
+\r
+<P>\r
+When the handler finishes the service of a signal, the execution\r
+continues in a module determined by the appropriate instruction\r
+which should be:\r
+<UL>\r
+<LI><B>return</B> - then the execution is resumed in an object\r
+where the instruction <B>raise</B> was executed,\r
+<LI><B>wind</B> - then all objects we were searching for a handler\r
+will be terminated (see <B>lastwill</B>) and the program continues\r
+in the object containing the handler from the dynamic instance\r
+in which it generated an object that later led to the signal raising,\r
+<LI><B>terminate</B> - then all objects we were searching will\r
+be terminated including also the object containing the handler,\r
+the execution is continued in the dynamic father of the object\r
+containing handler,\r
+<LI><B>call</B> endrun - in order to halt the entire program.\r
+<BR>\r
+\r
+</UL>\r
+\r
+<H3>(e) Lastwill <BR>\r
+</H3>\r
+\r
+<P>\r
+When an object (or a dynamic instance of a block, procedure, function)\r
+is terminated abnormally through the execution of <B>wind</B>\r
+or <B>terminate</B> instructions, then the lastwill - a sequence\r
+of instructions will be executed before such an object will be\r
+terminated. The sequence of <B>lastwill</B> instructions must\r
+be located at the <B>end</B> of a module and is announced by a\r
+label <B>lastwill:</B>. A normal termination of an object will\r
+never cause the execution of lastwill. Termination of a dynamic\r
+instance of block, function, procedure causes its deallocation.\r
+In the following example we shall demonstrate the usage of the\r
+<B>wind</B> instruction in a handler. When executed it causes\r
+that all objects - instances beginning from the module in which\r
+a signal was raised and ending in the module containing the handler\r
+are closed and terminated. The execution will be continued in\r
+the object containing the handler from the point which caused\r
+creation. In order to assure the smooth continuation the language\r
+offers a possibility to define a lastwill instruction(s). <BR>\r
+\r
+<P>\r
+<B>Example 5</B> <BR>\r
+\r
+<PRE>\r
+<B>program</B> MAZE;\r
+ <B>var </B>A : <B>arrayof arrayof boolean</B>,\r
+ i,n : <B>integer</B>,\r
+ there_is_a_path : <B>boolean</B>;\r
+ <B>signal </B>Found;\r
+ \r
+ <B>unit </B>PATH : <B> procedure </B>(i,j : <B>integer</B>);\r
+ (* the procedure makes one move from(i,j) *)\r
+ <B>begin\r
+</B> <B>if </B>A(i,j)\r
+ <B>then</B> (* we can go through (i,j) field *)\r
+ <B>if</B> i=n <B>and </B>j=n <B> then raise </B>Found <B>fi</B>;\r
+ <B>if</B> i< n <B>then call</B> PATH(i+1,j) <B>fi</B>;\r
+ <B>if </B>j< n <B>then call </B>PATH(i,j+1) <B>fi;\r
+ fi</B>;\r
+ <B>last_will </B>: write(i,j);\r
+ (* the path will be printed in the reverse order *)\r
+ <B>end </B>PATH;\r
+\r
+ <B>handlers\r
+ when</B> Found : there _is_a_path :=<B>true</B>; <B>wind\r
+ end handlers</B>;\r
+<B>begin</B> (** main program **)\r
+ .... (* create a maze A etc. *)\r
+ <B>call </B>PATH(1,1);\r
+ <B>if </B>there_is_a_path <B> then </B>...\r
+ ...\r
+<B>end MAZE.</B><BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+In this example we can observe how the programmer turned unusual\r
+situation of a raised signal into the desired one: through lastwills\r
+she got a simple program to print the path through the maze. \r
+<BR>\r
+\r
+<H3>(f) Inheritance vs. signalling <BR>\r
+</H3>\r
+\r
+<P>\r
+Handlers (modules handling signals) behave similarly to virtual\r
+procedures, i.e. the new handler from the prefixed module replaces\r
+the module from the prefixing module. <BR>\r
+<B>Example 6<BR>\r
+</B>\r
+<PRE>\r
+<B>unit</B> STACKS: <B>class</B> (type :telem);\r
+ <B>signal</B> empty_stack(s:stack), stack_overflow(s:stack);\r
+ <B>unit</B> stack : <B>class</B> (size:integer);\r
+ <B>hidden</B> place, top;\r
+ <B>var</B> place : <B>arrayof</B> taken,\r
+ top: integer;\r
+ <B>unit</B> pop: <B>function</B>:telem;\r
+ <B>handlers\r
+</B> <B>when</B> conerror: <B>raise</B> empty_stack(<B>this</B> stack)\r
+ <B>end</B> <B>handlers</B>;\r
+ <B>begin\r
+</B> <B>result</B> :=place(top);\r
+ (** here con_error signal can be raised by run_time_system **)\r
+ top:=top-1\r
+ <B>end</B> pop;\r
+\r
+ <B>unit</B> push : <B>procedure</B> (e:telem);\r
+ <B>begin\r
+</B> <B>if</B> top> size \r
+ <B>then\r
+</B> <B>raise</B> stack_overflow(<B>this</B> stack)\r
+ <B>fi</B>;\r
+ top:=top+1;\r
+ place(top):=e\r
+ <B>end</B> push;\r
+\r
+ <B>unit</B> empty: <B>function</B> : boolean;\r
+ <B>begin\r
+</B> <B>result</B>:=top< 1\r
+ <B>end</B> empty;\r
+\r
+ <B>unit</B> increase : <B>procedure</B> (addition: integer);\r
+ <B>var</B> i : integer,\r
+ x : <B>arrayof</B> telem;\r
+ <B>begin\r
+</B> <B>array</B> X <B>dim</B> (size+addition);\r
+ size:=size+addition;\r
+ <B>for</B> i:=1 <B>to</B> upper(place)\r
+ <B>do\r
+</B> x(i):=place(i)\r
+ <B>od</B>;\r
+ <B>kill</B>(place);\r
+ place:=X\r
+ <B>end</B> increase.\r
+\r
+ <B>begin\r
+</B> <B>array</B> place <B>dim</B>(1:size);\r
+ <B>end</B> stack;\r
+ <B>handlers\r
+</B> <B>when</B> empty_stack: write("empty stack"); <B>terminate</B>;\r
+ <B>when</B> stack_overflow: write("stack overflow"); <B>terminate</B>; \r
+ <B>when</B> conerror : write("error in stack increasing");\r
+ <B>call</B> endrun;\r
+ <B>end</B> <B>handlers</B>;\r
+\r
+<B>end</B> STACKS; <BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+Applications<BR>\r
+<B> Example 7<BR>\r
+</B>\r
+<PRE>\r
+<B>program</B> APPLICATION_1;\r
+ <B>unit</B> STACKS: ...\r
+ <B>unit</B> element: ...\r
+ ...\r
+ <B>pref</B> STACKS(element) <B>block\r
+</B> <B>var</B> s1,s2 : stack\r
+ ...\r
+ <B>handlers\r
+</B> <B>when</B> stack_overflow : ...\r
+ <B>call</B> s.increase(70);\r
+ <B>return</B>;\r
+ <B>end</B> <B>handler</B>;\r
+<B> begin</B> (*** block ***)\r
+ ...\r
+ s1:= <B>new</B> stack(c1);\r
+ s2:= <B>new</B> stack(c2);\r
+ ...\r
+ <B>call</B> s1.push(e);\r
+ ...\r
+ y:=s2.pop;\r
+ ...\r
+ <B>end</B> (*block*);\r
+\r
+<B>end</B> APPLICATION_1<BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+In this example the handler for stack_overflow from the prefixed\r
+block overrides the handler given in the class STACKS.<BR>\r
+<BR>\r
+<B>Example 8</B> <BR>\r
+\r
+<PRE>\r
+<B>program</B> ReversePolishNotation; (* Application 2 *)\r
+ <B>unit</B> STACKS: <B>class</B>; ... <B>end</B> STACKS;\r
+ ...\r
+ <B>unit</B> element : <B>class</B>(sign:char);\r
+ <B>end</B> element;\r
+ ...\r
+ <B>pref</B> STACKS(element) <B>block</B>;\r
+ ...\r
+ <B>handlers\r
+</B> <B>when</B> empty_stack: write("\r
+ error in expression_to many ( closing brackets ");\r
+ <B>terminate</B>;\r
+ <B>end</B> <B>handlers</B>;\r
+\r
+ <B>begin</B> (*block *)\r
+ <B>while</B> not eof\r
+ <B>do\r
+</B> read(x);\r
+ <B>if</B> x= ')' <B>then</B> \r
+ (* take operators from stack until ( is met *)\r
+ <B>else\r
+</B> ....\r
+ <B>fi\r
+</B> <B>od\r
+</B> <B>end</B> (*block*)\r
+<B>end</B> ReversePolishNotation;<BR>\r
+\r
+</PRE>\r
+\r
+<P>\r
+This example shows that there are situations in which the user\r
+of a class STACKS knows how to handle the signal empty_stack and\r
+solves the problem gracefully since in this case empty_stack means\r
+that the data were not a well formed expression.<HR>\r
+\r
+<ADDRESS>\r
+<A HREF = "http://www.univ-pau.fr/~salwicki/GMyAS.html">GMyAS</A>\r
+</ADDRESS>\r
+\r
+<P>\r
+Last update Wed 3 May 1995 \r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<html>\r
+<head>\r
+<title>Why I learn so late about Loglan?</title>\r
+</head>\r
+\r
+\r
+<body>\r
+<h1><img src="loglanmm.gif" align=middle>Why I learned so late about Loglan'82?</h1>\r
+\r
+Do not worry. It is not your fault. It is not too late, neither.\r
+As you can see we worked steadily, but <em>slowly</em>. Making the best use of our modest resources.<br>\r
+But now you can use it:\r
+<ul>\r
+<p><li>\r
+in your classes,<br> WE RECOMMEND IT warmly. You can verify it ...\r
+<p><li>\r
+If you are looking for a software vehicle for your nearest research project here it is. A good candidate \r
+which will speed up the programming phase of your project. It is quite probable that your Loglan \r
+experience will influence your project, as Loglan permits to elaborate your own view of the systems.\r
+</ul>\r
+\r
+If you are looking for an interesting project do not hesitate and join us in our Loglan'95 project or in \r
+Programmers_Assistant project.\r
+\r
+\r
+\r
+\r
+<hr>\r
+<a href="credits.htm"><img src="microman/gifs/prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="microman/gifs/homepage.gif"></a>\r
+<a href="whylog.htm"><img src="microman/gifs/nextpage.gif"></a> \r
+<hr>\r
+\r
+<address>\r
+<a href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </a>\r
+ last update 2 January 1995\r
+</address>\r
+\r
+</body>\r
+</html>\r
+\r
--- /dev/null
+<html>\r
+<head>\r
+<title>Brief comparison of OO Languages</title>\r
+\r
+</head>\r
+\r
+<body>\r
+ \r
+<H1 Align=center> <img align=middle src="loglanmm.gif"> A brief comparison of several object oriented languages </H1>\r
+<p Align=Left>In the table below you will find a comparison of several languages with respect to the most important features and tools of programming.</p>\r
+ \r
+<table border>\r
+\r
+<tr>\r
+<th>Languages:<br> ________<br>________<br><em>Features</em><br>----v---- </th>\r
+<td valign=top> S<br>i<BR>m<br>u<br>l<br>a<br>6<br>7 </td>\r
+<td valign=top> o<br>b<br>j<br>.<br>P<br>a<br>s<br>c<br>a<br>l<br>s </td>\r
+<td valign=top> C<br>+<br>+ </td>\r
+<td valign=top> M<br>o<br>d<br>u<br>l<br>a<br> 3 </td>\r
+<td valign=top> S<br>m<br>a<br>l<br>l<br>t<br>a<br>l<br>k </td>\r
+<td valign=top> E<br>i<br>f<br>f<br>e<br>l </td>\r
+<td valign=top> A<br>d<br>a </td>\r
+<td valign=top> B<br>e<br>t<br>a </td>
+<td valign=top> J<br>a<br>v<br>a </td>
+<th valign=top> L<br>o<br>g<br>l<br>a<br>n<br>'<br>8<br>2 </th>\r
+</tr>\r
+<tr>\r
+<th><em> Modularisation</em> </th>\r
+<td> </td>\r
+<td> </td>\r
+<td> </td>\r
+<td> </td>\r
+</tr>\r
+<tr>\r
+<td> - nesting of modules</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - inheritance</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - - multilevel inheritance</td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - - multiple inheritance</td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>
+<td> +<sup>7)</sup> </td>\r
+<td> +<sup>1)</sup> </td>\r
+</tr>\r
+<tr>\r
+<td> -inherit in other modules<sup>2)</sup></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>
+<td> - </td>\r
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - static binding of names</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td> <em>Classes & Objects </em></td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td><em> Coroutines </em></td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td> <em>Processes</em></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - alien call of methods <sup>3)</sup></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td> <em>Signals & Exceptions</em></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> ? </td>
+<td> +<sup>4)</sup> </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+\r
+<tr>\r
+<th> <em>Safety</em></th>\r
+</tr>\r
+<tr>\r
+<td> - safe deallocation<sup>5)</sup></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> ? </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - type checking</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> +? </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - protection of private</td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<th> <em>Genericity & Polymorphism </em></th>\r
+</tr>\r
+<tr>\r
+<td> - types as formal param.</td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> -+ </td>\r
+<td> -+ </td>\r
+<td> -+ </td>\r
+<td> -+ </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - overloading of operators</td>\r
+<td> - </td>\r
+<td> ? </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> ? </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> - </td>\r
+</tr>\r
+<tr>\r
+<td> - virtual methods<sup>6)</sup></td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> ? </td>\r
+<td> + </td>\r
+<td> -+ </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr><td></td><td></td></tr>\r
+\r
+</table>\r
+\r
+\r
+\r
+<hr>\r
+<h4> Footnotes </h4> \r
+\r
+\r
+In Loglan'82:<br>\r
+<ol>\r
+<li> multiple inheritance may be obtained from multi-level inheritance and \r
+ coroutines,\r
+<li> it is possible to inherit a class in a procedure, a function, a process, a coroutine, a block,\r
+<li> alien call is a truly object oriented protocol of executing a method of\r
+ a callee process in cooperation between a calling and the callee processes,\r
+<li> exceptions are handled with continuations and lastwill actions,\r
+<li> i.e. absence of dangling references <em>& </em> possibility to deallocate no longer needed objects,\r
+<li> with virtual methods there is no need for overloading,<br>\r
+several languages admit only virtual methods, they do not admit usual methods\r
+\r<li> in Java there is no multiple inheritance of classes, quite reasonably
+Java distinguishes between classes and interfaces. Multiple inheritance of interfaces is allowed.
+</ol>\r
+<hr>\r
+<a href="quick.htm"><img src="prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="homepage.gif"></a>\r
+<a href="microman/homepage.htm"><img src="nextpage.gif"></a> \r
+<hr>\r
+<address>\r
+<a href="GMyAS.html">AS </a> Last update Tue 12 Mar 1996\r
+</address>\r
+</body>\r
+</html>
+
+
+
+ppp
\ No newline at end of file
--- /dev/null
+<html>\r
+<head>\r
+<title>Brief comparison of OO Languages</title>\r
+\r
+</head>\r
+\r
+<body>\r
+ \r
+<H1 Align=center> <img align=middle src="loglanmm.gif"> A brief comparison of several object oriented languages </H1>\r
+<p Align=Left>In the table below you will find a comparison of several languages with respect to the most important features and tools of programming.</p>\r
+ \r
+<table border>\r
+\r
+<tr>\r
+<th>Languages:<br> ________<br>________<br><em>Features</em><br>----v---- </th>\r
+<td valign=top> S<br>i<BR>m<br>u<br>l<br>a<br>6<br>7 </td>\r
+<td valign=top> o<br>b<br>j<br>.<br>P<br>a<br>s<br>c<br>a<br>l<br>s </td>\r
+<td valign=top> C<br>+<br>+ </td>\r
+<td valign=top> M<br>o<br>d<br>u<br>l<br>a<br> 3 </td>\r
+<td valign=top> S<br>m<br>a<br>l<br>l<br>t<br>a<br>l<br>k </td>\r
+<td valign=top> E<br>i<br>f<br>f<br>e<br>l </td>\r
+<td valign=top> A<br>d<br>a </td>\r
+<td valign=top> B<br>e<br>t<br>a </td>
+<td valign=top> J<br>a<br>v<br>a </td>
+<th valign=top> L<br>o<br>g<br>l<br>a<br>n<br>'<br>8<br>2 </th>\r
+</tr>\r
+<tr>\r
+<th><em> Modularisation</em> </th>\r
+<td> </td>\r
+<td> </td>\r
+<td> </td>\r
+<td> </td>\r
+</tr>\r
+<tr>\r
+<td> - nesting of modules</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - inheritance</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - - multilevel inheritance</td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - - multiple inheritance</td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>
+<td> +<sup>7)</sup> </td>\r
+<td> +<sup>1)</sup> </td>\r
+</tr>\r
+<tr>\r
+<td> -inherit in other modules<sup>2)</sup></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>
+<td> - </td>\r
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - static binding of names</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td> <em>Classes & Objects </em></td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td><em> Coroutines </em></td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td> <em>Processes</em></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - alien call of methods <sup>3)</sup></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+<tr>\r
+<td> <em>Signals & Exceptions</em></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> ? </td>
+<td> +<sup>4)</sup> </td>\r
+</tr>\r
+\r
+<tr><td></td><td></td></tr>\r
+\r
+\r
+<tr>\r
+<th> <em>Safety</em></th>\r
+</tr>\r
+<tr>\r
+<td> - safe deallocation<sup>5)</sup></td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> ? </td>\r
+<td> - </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - type checking</td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> +? </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - protection of private</td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<th> <em>Genericity & Polymorphism </em></th>\r
+</tr>\r
+<tr>\r
+<td> - types as formal param.</td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> - </td>\r
+<td> -+ </td>\r
+<td> -+ </td>\r
+<td> -+ </td>\r
+<td> -+ </td>
+<td> + </td>\r
+</tr>\r
+<tr>\r
+<td> - overloading of operators</td>\r
+<td> - </td>\r
+<td> ? </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> ? </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> - </td>\r
+</tr>\r
+<tr>\r
+<td> - virtual methods<sup>6)</sup></td>\r
+<td> + </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> ? </td>\r
+<td> + </td>\r
+<td> -+ </td>\r
+<td> - </td>\r
+<td> + </td>\r
+<td> + </td>
+<td> + </td>\r
+</tr>\r
+<tr><td></td><td></td></tr>\r
+\r
+</table>\r
+\r
+\r
+\r
+<hr>\r
+<h4> Footnotes </h4> \r
+\r
+\r
+In Loglan'82:<br>\r
+<ol>\r
+<li> multiple inheritance may be obtained from multi-level inheritance and \r
+ coroutines,\r
+<li> it is possible to inherit a class in a procedure, a function, a process, a coroutine, a block,\r
+<li> alien call is a truly object oriented protocol of executing a method of\r
+ a callee process in cooperation between a calling and the callee processes,\r
+<li> exceptions are handled with continuations and lastwill actions,\r
+<li> i.e. absence of dangling references <em>& </em> possibility to deallocate no longer needed objects,\r
+<li> with virtual methods there is no need for overloading,<br>\r
+several languages admit only virtual methods, they do not admit usual methods\r
+\r<li> in Java there is no multiple inheritance of classes, quite reasonably
+Java distinguishes between classes and interfaces. Multiple inheritance of interfaces is allowed.
+</ol>\r
+<hr>\r
+<a href="quick.htm"><img src="/icons/prevpage.gif"></a>\r
+<a href="loghome.htm"><img src="/icons/homepage.gif"></a>\r
+<a href="microman/homepage.htm"><img src="/icons/nextpage.gif"></a> \r
+<hr>\r
+<address>\r
+<a href="GMyAS.html">AS </a> Last update Tue 12 Mar 1996\r
+</address>\r
+</body>\r
+</html>
+
+
+
+ppp
\ No newline at end of file
--- /dev/null
+ \r
+ A brief comparison of several object oriented languages\r
+ =======================================================\r
+\r
+\r
+\r
+ Languages -> S o C M S E A L\r
+ i b + o m i d o\r
+ m j + d a f a g\r
+ Comparison u . u l f l\r
+ of main features l P l l e a\r
+ | a a a t l n\r
+ | - s 3 a '\r
+ V 6 c l 8\r
+ 7 a k 2\r
+ l \r
+ s \r
+\r
+\r
+\r
+Modularisation \r
+ nesting of modules + + - - - - + +\r
+ inheritance + + + + + + - +\r
+ - multilevel - - - - - - - +\r
+ inheritance\r
+ - multiple inh. - - + - + + - + 1) \r
+ inherit in other - - - - - - - + 2)\r
+ modules \r
+ static binding + + - + - - + +\r
+ of identifiers\r
+ \r
+Classes & Objects + + + + + + - +\r
+ \r
+Coroutines + - - + - - - +\r
+ \r
+Processes - - - + - - + +\r
+ alien call - - - - - - - + 3)\r
+ of methods\r
+ \r
+Signals & Exceptions - - - - - - + + 4)\r
+ \r
+Safety \r
+safe deallocation i.e. \r
+ no dangling - - - - - - - +\r
+ references\r
+\r
+ type checking + + - - - - + + \r
+ protection of private + - - + - - + +\r
+ \r
+Genericity&Polymorphism \r
+ types as formal - - - ? - -+ -+ +\r
+ parameters\r
+ overloading - - + + ? + + -\r
+ of operators \r
+ virtual methods + - + ? + + - +\r
+\r
+_______________________________________________________________________ \r
+\r
+\r
+In Loglan'82:\r
+1) - multiple inheritance may be obtained from multi-level inheritance and \r
+ coroutines,\r
+2) - it is possible to inherit a class in a procedure, a function, a process, a coroutine, a block,\r
+3) - alien call is a truly object oriented protocol of executing a method of\r
+ a callee process in cooperation between a calling and the callee processes,\r
+4) - exceptions are handled with continuations and last will actions.\r
+\r
--- /dev/null
+[User Menu0]\r
+Menu_Name=Starting Points\r
+Menu_Type=TOPLEVEL\r
+Item0=Starting Points Document,http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/StartingPoints/NetworkStartingPoints.html\r
+Item1=NCSA Mosaic Demo Document,http://www.ncsa.uiuc.edu/demoweb/demo.html\r
+Item2=NCSA Mosaic's 'What's New' Page,http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/Docs/whats-new.html\r
+Item3=NCSA Mosaic Home Page,http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/NCSAMosaicHome.html\r
+Item4=Windows Mosaic home page,http://www.ncsa.uiuc.edu/SDG/Software/WinMosaic/HomePage.html\r
+Item5=MENU,UserMenu1\r
+Item6=MENU,UserMenu2\r
+Item7=MENU,UserMenu3\r
+Item8=Finger Gateway,http://cs.indiana.edu/finger/gateway\r
+Item9=Whois Gateway,gopher://sipb.mit.edu:70/1B%3aInternet%20whois%20servers\r
+Item10=MENU,UserMenu4\r
+Item11=Archie Request Form,http://hoohoo.ncsa.uiuc.edu/archie.html\r
+\r
+[User Menu1]\r
+Menu_Name=World Wide Web Info\r
+Item0=Web Overview,http://www.w3.org/hypertext/WWW/LineMode/Defaults/default.html\r
+Item1=Web Project,http://www.w3.org/hypertext/WWW/TheProject.html\r
+Item2=Data Sources By Service,http://www.w3.org/hypertext/DataSources/ByAccess.html\r
+Item3=Information By Subject,http://www.w3.org/hypertext/DataSources/bySubject/Overview.html\r
+Item4=Web Servers Directory,http://www.w3.org/hypertext/DataSources/WWW/Servers.html\r
+Item5=HTML Quick Reference,http://www.ncsa.uiuc.edu/General/Internet/WWW/HTMLQuickRef.html\r
+Item6=Internet RFCs,http://www.cis.ohio-state.edu:80/hypertext/information/rfc.html\r
+\r
+[User Menu2]\r
+Menu_Name=Home Pages\r
+Item0=The University of Illinois at Urbana-Champaign,http://www.uiuc.edu\r
+Item1=NCSA Home Page,http://www.ncsa.uiuc.edu/General/NCSAHome.html\r
+Item2=CERN Home Page,http://info.cern.ch/\r
+Item3=UNC-Chapel Hill home page,http://sunsite.unc.edu\r
+Item4=ANU Bioinformatics,http://life.anu.edu.au:80/\r
+Item5=Data Research Home Page,http://dranet.dra.com/\r
+Item6=British Columbia,http://www.cs.ubc.ca/\r
+Item7=BSDI Home Page,http://www.bsdi.com/\r
+Item8=Carnegie Mellon,http://www.cs.cmu.edu:8001/Web/FrontDoor.html\r
+Item9=Cornell Law School,http://www.law.cornell.edu/lii.table.html\r
+Item10=Cornell Theory Center,http://www.tc.cornell.edu:80/ctc.html\r
+Item11=DESY Home Page,http://info.desy.de:80/\r
+Item12=ECE WWW Page,http://www.ece.uiuc.edu\r
+Item13=Honolulu Home Page,http://www.hcc.hawaii.edu/\r
+Item14=Indiana Home Page,http://cs.indiana.edu/home-page.html\r
+Item15=Lysator ACS Sweden,http://www.lysator.liu.se:80/\r
+Item16=National Center for Atmospheric Research,http://http.ucar.edu/metapage.html\r
+Item17=Northwestern Home Page,http://www.acns.nwu.edu/\r
+Item18=CICA's WWW Server ,http://www.cica.indiana.edu\r
+Item19=Ohio State Home Page,http://www.cis.ohio-state.edu:80/hypertext/information/information.html\r
+Item20=SSC Home Page,http://www.ssc.gov/SSC.html\r
+\r
+[User Menu3]\r
+Menu_Name=Gopher Servers\r
+Item0=Gopherspace Overview,gopher://gopher.micro.umn.edu:70/11/Other%20Gopher%20and%20Information%20Servers\r
+Item1=Veronica Search,gopher://veronica.scs.unr.edu:70/11/veronica\r
+Item2=NCSA Gopher,gopher://gopher.ncsa.uiuc.edu:70/1\r
+Item3=PSC Gopher,gopher://gopher.psc.edu:70/1\r
+Item4=SDSC Gopher,gopher://gopher.sdsc.edu:70/1\r
+Item5=Original (UMN) Gopher,gopher://gopher.micro.umn.edu:70/1\r
+Item6=UIUC Gopher,gopher://gopher.uiuc.edu:70/1\r
+Item7=UIUC Weather Machine,gopher://wx.atmos.uiuc.edu:70/1\r
+Item8=SDSU Sounds,gopher://athena.sdsu.edu:71/11/sounds\r
+\r
+[User Menu4]\r
+Menu_Name=Other Documents\r
+Item0=Beginner's Guide to HTML,http://www.ncsa.uiuc.edu/demoweb/html-primer.html\r
+Item1=InterNIC Info Source,gopher://is.internic.net:70/11/infosource\r
+Item2=Internet Services List,http://slacvx.slac.stanford.edu:80/misc/internet-services.html\r
+Item3=Internet Talk Radio,http://www.ncsa.uiuc.edu/radio/radio.html\r
+Item4=Library of Congress Vatican Exhibit,http://www.ncsa.uiuc.edu/SDG/Experimental/vatican.exhibit/Vatican.exhibit.html\r
+Item5=NCSA Access Magazine,http://www.ncsa.uiuc.edu/Pubs/access/accessDir.html\r
+Item6=Doctor Fun,http://sunsite.unc.edu/Dave/drfun.html\r
+Item7=Postmodern Culture,http://jefferson.village.virginia.edu/pmc/contents.all.html\r
+Item8=Zippy The Pinhead,http://www.cis.ohio-state.edu:84/\r
+Item9=Britannica Online,http://www.eb.com/\r
+Item10=ANU Art History Exhibit,http://www.ncsa.uiuc.edu/SDG/Experimental/anu-art-history/home.html\r
+Item11=Web/Net T-Shirts,http://sashimi.wwa.com/~notime/mdd/www_shirt.html\r
+Item12=Census Information,gopher://bigcat.missouri.edu/11/reference/census/us/basictables/\r
+Item13=FTP Sites,http://hoohoo.ncsa.uiuc.edu:80/ftp-interface.html\r
+\r
--- /dev/null
+<HTML>\r
+<HEAD>\r
+<TITLE> Ghostscript and GSview Information </TITLE>\r
+</HEAD>\r
+\r
+<BODY>\r
+<H1 ALIGN=CENTER><A HREF="http://www.cs.wisc.edu/~ghost/index.html">\r
+<IMG SRC="../Images/ghome.gif" ALT="Ghostscript, Ghostview & GSview Icon"> \r
+ Ghostscript and GSview</H1></A>\r
+ \r
+<H1 ALIGN=CENTER>"<I>Copyright Software</I>"</H1>\r
+<HR>\r
+<H1>Ghostscript v3.12</H1>\r
+<H3>Copyright (C) 1989, 1992, 1993, 1994</H3>\r
+<I> This copy of Ghostscript is governed not by the GNU\r
+License, but by a substantially different license in a similar spirit, the\r
+Aladdin Ghostscript Free Public License; the file PUBLIC contains a copy of\r
+this license. You can find this file in the gs312ini.zip file.</I>\r
+<P>\r
+\r
+<B>Aladdin Enterprises<BR>\r
+P.O. box 60264<BR>\r
+Palo Alto, CA 94306<BR>\r
+voice (415)322-0103<BR>\r
+fax (415)322-1734<BR>\r
+ghost@aladdin.com</B>\r
+<P>\r
+\r
+Ghostscript is software that provides:\r
+<UL>\r
+<LI>An interpreter for the PostScript (TM) language, and\r
+<LI>A set of C procedures (the Ghostscript library) that implement\r
+the graphics capabilities that appear as primitive operations in the\r
+PostScript language.\r
+</UL>\r
+<P>\r
+More details are available from the\r
+<A HREF=http://www.cs.wisc.edu/~ghost/index.html>\r
+Ghostscript, Ghostview and GSview</A> home page.\r
+<HR>\r
+\r
+<H1><IMG SRC="../Images/gsview.gif" ALT="GSview Icon" ALIGN=CENTER>\r
+ GSview v3.12 </H1>\r
+<H3>GSview is copyright by Russell Lang.</H3>\r
+<BR>\r
+<I>GSview is distributed with the GSview Free Public Licence.\r
+This licence is contained in the LICENCE file that is contained in the gsvw113b.zip file. \r
+The GSview Free Public Licence does not require any payment to the author;\r
+however the author would welcome any donations to cover costs and time\r
+involved in developing and maintaining GSview. These may be sent to:\r
+</I>\r
+<P>\r
+<B>Russell Lang<BR>\r
+12 Princetown Road<BR>\r
+MOUNT WAVERLEY, VIC 3149<BR>\r
+AUSTRALIA<BR>\r
+</B>\r
+<P>\r
+GSview for Windows is a Graphical User Interface (GUI) for MS-Windows \r
+Ghostscript. GSview is dependent on the Ghostscript. GSview allows selected \r
+pages to be viewed or printed. Ghostscript 3.12 or later is required. \r
+<P>\r
+More details are available from the\r
+ <A HREF=http://www.cs.wisc.edu/~ghost/index.html>\r
+ Ghostscript, Ghostview and GSview</A> home page.\r
+<HR>\r
+\r
+<H1>Installing Ghostscript and GSview</H1>\r
+<OL>\r
+\r
+<LI>Download the following files:\r
+<DL>\r
+<DT>\r
+<A HREF="ftp://ftp.cs.wisc.edu/pub/ghost/aladdin/gs312w32.zip"> \r
+gs312w32.zip</A> (369,810)\r
+<DD> Ghostscript for Win32s Systems\r
+<P>\r
+<DT>\r
+<A HREF="ftp://ftp.cs.wisc.edu/pub/ghost/aladdin/gs312ini.zip">\r
+gs312ini.zip</A> (426,513)\r
+<DD> Necessary files to support Ghostscript\r
+<P>\r
+<DT><A HREF="ftp://ftp.cs.wisc.edu/pub/ghost/aladdin/gs312fn1.zip">\r
+gs312fn1.zip</A> (1,365,916)\r
+<DD>Font package number 1\r
+<P>\r
+<DT><A HREF="ftp://ftp.cs.wisc.edu/pub/ghost/aladdin/gs312fn2.zip">\r
+gs312fn2.zip</A> (741,137)\r
+<DD>Font package number 2\r
+<P>\r
+<DT><A HREF="ftp://ftp.cs.wisc.edu/pub/ghost/rjl/gsview12.zip">\r
+gsview12.zip</A> (570,034)\r
+<DD>GSview - A Graphical User Interface for Ghostscript.\r
+</DL>\r
+<P>\r
+<LI>Download the files to the root directory. ie. c:\\r
+<P>\r
+<LI>Use the "pkunzip -d" command when you unzip the files.\r
+<P>\r
+<LI>Unzip gs312ini.zip and gs312w32.zip. These files will create a subdirectory called "GS3.12".\r
+<P>\r
+<LI>Move gs312f1.zip, gs312fn2.zip and gsvw113b.zip to the c:\gs3.12 directory.\r
+<P>\r
+<LI>Unzip gs312fn1.zip and gs312fn2.zip. These files will a subdirectory called "FONTS"\r
+<P>\r
+<LI>Unzip gsvw113b.zip. This file will create three subdirectories, ESPTOOLS, \r
+GSGRAB & SRC, and put a couple files in the c:\gs3.12 directory. (This file\r
+contains a Windows and an OS/2 version of GSview.)\r
+<P>\r
+<LI>(Optional) Delete the following files from c:\gs3.12: gvpm.exe, \r
+gvpm.hlp, gvpm.inf (the OS/2 version of GSview) and gsview.exe (the 16-bit\r
+version of GSview) \r
+<P>\r
+<LI>Create a program item (icon) within one of your program groups by \r
+dragging and dropping gsview32.exe from File Manager into a Program Group. \r
+<P>\r
+<LI>Start GSview then select "Options, Ghostscript Command", and enter the \r
+correct executable path. Include path for Ghostscript and the path to the\r
+directory that contains the fonts. For example:\r
+<P>\r
+<DL>\r
+<DD> C:\gs3.12\gswin32.exe -IC:\gs3.12;C:\gs3.12\fonts\r
+</DL>\r
+\r
+<P>\r
+<LI>Read the PUBLIC, README, USE.DOC files (Ghostscript) and Readme.gv and LICENSE (GSView) for details about the products. \r
+<P>\r
+</OL>\r
+<HR>\r
+\r
+<H3>Mosaic Configuration:</H3>\r
+<OL>\r
+<LI>Open Options, Preferences..., Viewers\r
+<LI>Edit or enter the following information:\r
+</OL>\r
+\r
+<DL>\r
+<DT>Associate Mime Type of:\r
+<DD><B>application/postscript</B>\r
+<DT>Description of MIME Type (Optional):\r
+<DD> <B>Postscript File Format </B>\r
+<P>\r
+<DT>With this/these extensions:\r
+<DD> <B>.eps,.ai,.ps</B>\r
+<P>\r
+<DT>To This Application:\r
+<DD><B> C:\gs3.12\gswin32 </B>\r
+</DL>\r
+\r
+\r
+<HR>\r
+<ADDRESS>\r
+<A HREF="mailto:mosaic-w@ncsa.uiuc.edu">mosaic-w@ncsa.uiuc.edu</A><BR>\r
+<A HREF="http://www.ncsa.uiuc.edu">\r
+National Center for Supercomputing Applications</A><BR>\r
+<A HREF="http://www.uiuc.edu">University of Illinois at Urbana/Champaign</A><BR>\r
+</ADDRESS>\r
+</BODY>\r
+</HTML>\r
+\r
+\r
+\r
+\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Tarski's World: More Information (1)</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+[<A HREF="Logic-software.html">Back</A> | <A HREF="Tarski2.htm">Forward</A>]\r
+<H2>Tarski's World</H2>\r
+\r
+<P>\r
+<B>Tarski's World</B> is based on a simple premise: that languages\r
+are best learned by using them. The program applies this premise\r
+to the symbo\r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<TITLE>Tarski's World: More Information (3e)</TITLE>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<P>\r
+[<A HREF="tarski3d.htm">Back</A>]\r
+<P>\r
+Here are the files Edgar's World and Edgar's Sentences:\r
+<P>\r
+<IMG SRC="tarski13.GIF"> <IMG SRC="tarski14.GIF"> \r
+<P>\r
+[<A HREF="tarski3d.htm">Back</A>]\r
+<P>\r
+ \r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+[URL]\r
+URL=<http://csli-www.stanford.edu/hp/Tarski3e.html>\r
--- /dev/null
+<!doctype html public "-//IETF//DTD HTML//EN">\r
+<HTML>\r
+\r
+<HEAD>\r
+\r
+<META NAME="GENERATOR" CONTENT="Internet Assistant for Word 1.0Z">\r
+<META NAME="AUTHOR" CONTENT="NOM">\r
+</HEAD>\r
+\r
+<BODY>\r
+\r
+<H1>LOGLAN'82<BR>\r
+</H1>\r
+\r
+<H2>USER'S GUIDE</H2>\r
+\r
+<H3>Institute of Informatics University of Warsaw January 1988\r
+</H3>\r
+\r
+<H5>revised October 1994 24/11/94 08:33 LITA Université\r
+de Pau<BR>\r
+</H5>\r
+\r
+<H2><A NAME="toc">TABLE of CONTENTS</A></H2>\r
+\r
+<P>\r
+<A HREF="#preface">PREFACE 3 1.</A>\r
+<P>\r
+<A HREF="#usingl">USING LOGLAN-82 SYSTEM 3 1.1.</A>\r
+<P>\r
+COMPILATION 3 1.2.\r
+<P>\r
+COMPILER SWITCHES 4 1.3.\r
+<P>\r
+CODE GENERATION 4 1.4.\r
+<P>\r
+PROGRAM execution 5 1.5.\r
+<P>\r
+COMPILE TIME ERRORS 6 1.6.\r
+<P>\r
+RUN-TIME ERRORS 6 2.\r
+<P>\r
+COMPILER OPTIONS 7 2.1.\r
+<P>\r
+OPTION FORMAT 7 2.2.\r
+<P>\r
+OPTIONS LIST 7 2.3.\r
+<P>\r
+FRAGMENTATION 8 3.\r
+<P>\r
+CURRENT LOGLAN-82 IMPLEMENTATION SPECIFICATION 9 3.1. IMPLEMENTED\r
+SUBSET OF LOGLAN 9 3.2. PREDEFINED LANGUAGE ELEMENTS 9 3.3. FILE\r
+SYSTEM 9 3.4. FILE VARIABLES 9 3.4.1. FILE GENERATION 10 3.5.\r
+FILE DEALLOCATION 10 3.6. GENERAL FILE OPERATIONS 10 3.7. TEXT\r
+FILES 11 3.8. BINARY SEQUENTIAL FILES 11 3.9. DIRECT ACCESS BINARY\r
+FILES 11 3.10. CONCURRENCY 12 3.10.1 INVOKING THE LOGLAN INTERPRETER\r
+FOR CONCURRENT ROGRAMS 12 3.10.2 RESTRICTIONS AND DIFFERENCES\r
+FROM THE REPORT 13 3.10.3 COMMUNICATION MECHANISM 14 3.11 SYSTEM\r
+SIGNALS 16 3.12. IMPLEMENTATION RESTRICTIONS 16 4. APPENDIX A\r
+: PREDEFINED CONSTANTS 17 5. APPENDIX B : PREDEFINED CLASSES 17\r
+5.1. MOUSE 19 6. APPENDIX ) : PREDEFINED PROCEDURES AND FUNCTIONS\r
+21 7. APPENDIX D : ERROR CODES 23 8. APPENDIX E : LOGLAN RUNTIME\r
+ERRORS 35 9. APPENDIX F : CHARACTER SET 37 10. BIBLIOGRAPHY 38\r
+10.0.1. LOGLAN'82 38 10.0.2. Algorithmic Logic 41 10.0.3. Related\r
+literature 42\r
+<H1><A NAME="preface">PREFACE</A> </H1>\r
+\r
+<P>\r
+This document provides information necessary to compile and execute\r
+Loglan programs.\r
+<P>\r
+This manual assumes basic knowledge of Loglan-82 language, described\r
+in "Report on the Loglan Programming Language" (see\r
+Bibliography). <A HREF="#toc">to ToC</A>\r
+<H1><A NAME="usingl">1. USING LOGLAN-82 SYSTEM </A></H1>\r
+\r
+<P>\r
+The following three steps are required to execute a Loglan program:\r
+<UL>\r
+<LI>Compilation (to intermediate code),\r
+<LI>Generation of the interpreted code (from intermediate code),\r
+<LI>Interpretation (i.e. execution of program).\r
+</UL>\r
+\r
+<P>\r
+Compilation is accomplished by invoking Loglan compiler. This\r
+step creates two destination files: the intermediate code file(.lcd)\r
+and the listing file(.lst). The intermediate code file is the\r
+input file for the second step: generation of the code accepted\r
+by interpreter. In this step two files containing object code(.pcd\r
+& .ccd) are produced. They are the input files for the third\r
+step: interpretation. This step is equivalent to execution of\r
+a program. <A HREF="#toc">to ToC</A> \r
+<H2>1.1. COMPILATION </H2>\r
+\r
+<P>\r
+To invoke the Loglan compiler without specifying any command line\r
+parameters, type:\r
+<P>\r
+<KBD>LOGLAN</KBD> <I> </I>\r
+<P>\r
+Then the prompt appears on your terminal:\r
+<P>\r
+<KBD>File name: </KBD>\r
+<P>\r
+and the compiler waits for file specification.The default extension\r
+is LOG.\r
+<P>\r
+The compiler will produce (optionally) listing file with the same\r
+file name and the extension LST and will produce, if no error\r
+occurs, the code file with the extension LCD. Destination files\r
+will be stored on the same drive and directory as the source file.\r
+<BR>\r
+\r
+<P>\r
+Examples:\r
+<P>\r
+<SAMP>$ </SAMP><KBD>LOGLAN</KBD><SAMP> </SAMP>\r
+<PRE>\r
+<KBD>File name: PROGRAM </KBD>< ENTER>\r
+</PRE>\r
+\r
+<P>\r
+Loglan compiler compiles program from PROGRAM.LOG file and creates\r
+PROGRAM.LCD.\r
+<PRE>\r
+<KBD>$ LOGLAN A:PROGRAM.DAT</KBD>\r
+</PRE>\r
+\r
+<P>\r
+In this case the source file is A:PROGRAM.DAT. The file PROGRAM.LCD\r
+will be created on drive A.\r
+<PRE>\r
+<KBD>$ LOGLAN /home/vous/PROGRAM2</KBD>\r
+</PRE>\r
+\r
+<P>\r
+If any error occurs, the code file is not produced. At the end\r
+of compilation the following message is printed:\r
+<P>\r
+< number of errors> error(s) detected\r
+<H2>1.2. COMPILER SWITCHES </H2>\r
+\r
+<P>\r
+There are two possibilities to specify compiler's options: by\r
+compiler switches (i.e. external options) or by comments in the\r
+source program (see chapter 2.). You may enter the compiler switches\r
+in command line after file name in the following format:\r
+<P>\r
+where swi consists of character that designates the name of the\r
+option and either '+' or '-'.\r
+<P>\r
+Examples:\r
+<P>\r
+<KBD>$ LOGLAN PROGRAM L- T+</KBD> \r
+<P>\r
+<KBD>$ LOGLAN PROGRAM</KBD> <I> The KBD directive </I>\r
+<P>\r
+In this case the default switches values are assumed.\r
+<P>\r
+Scope of the switch is the entire program. All switches ,except\r
+H, correspond to options. A switch has greater priority then options:\r
+when you specify switch, all corresponding options inside source\r
+program will be ignored. Full description of each option is given\r
+in chapter 2.2. Switch L has additional significance. When this\r
+switch is set off no listing file is produced.\r
+<H2>1.3. CODE GENERATION </H2>\r
+\r
+<P>\r
+In this step information from the intermediate code file is read\r
+and two destination files containing the code are produced. No\r
+switch is permitted for this step. To generate code files, type:\r
+<P>\r
+<KBD>GEN </KBD>< <I>file name</I>>\r
+<P>\r
+ (or <KBD>HGEN</KBD> <I> The KBD directive </I>< <I>file\r
+name</I>> , if the switch H+ was specified for the compiler.(DOS/AT\r
+only))\r
+<P>\r
+You type file name without extension (extension is ignored).\r
+<P>\r
+Examples:\r
+<P>\r
+$ GEN\r
+<P>\r
+FILE_NAME: PROGRAM\r
+<P>\r
+Information is read from file PROGRAM.LCD from default drive and\r
+directory. Two destination files are produced: PROGRAM.CCD and\r
+PROGRAM.PCD and stored in the same directory as the input file.\r
+<P>\r
+$ GEN /home/vous/PROGRAM2\r
+<P>\r
+Files PROGRAM.CCD and PROGRAM.PCD are stored on drive A.\r
+<H2>1.4. PROGRAM execution </H2>\r
+\r
+<P>\r
+To interprete (execute) the Loglan program you must invoke the\r
+interpreter INT or HINT (if tNe switch H+ was specified). File\r
+name must be specified in command line. The file extension is\r
+ignored. The interpreter reads input files with the given name\r
+and extensions CCD and PCD and executes the Loglan program.\r
+<P>\r
+The syntax for calling the interpreter is\r
+<P>\r
+INT < options> < file name>\r
+<P>\r
+or\r
+<P>\r
+HINT < options> < file name> (DOS/AT only)\r
+<P>\r
+The following options are supported:\r
+<P>\r
+/m < n > set memory size for Loglan program (in 16 bit words\r
+for small and 32 bit words for huge memory). For concurrent programs\r
+it means memory size for every process.\r
+<P>\r
+/i information about garbage collection-compactification is printed.\r
+<P>\r
+/r < n > used to invoke interpreter on nodes different from\r
+console (see 3.4.). option parameter is console node number (as\r
+defined by D-Link Network).\r
+<P>\r
+/d causes trace to be printed to the file with .TRD extension\r
+provided that the option or switch D+ was used during compiling.\r
+<P>\r
+At the end of interpretation the following message is printed:\r
+<P>\r
+End of LOGLAN-82 program execution\r
+<P>\r
+Examples:\r
+<P>\r
+$ LOGLAN \DAT\EXAMP.SRC, L+\r
+<P>\r
+The file \DAT\EXAMP.LCD and \DAT\EXAMP.LST are generated.\r
+<P>\r
+$ GEN \DAT\EXAMP\r
+<P>\r
+The files \DAT\EXAMP.CCD and \DAT\EXAMP.PCD are created.\r
+<P>\r
+Then the program can be interpreted by: <BR>\r
+\r
+<P>\r
+$ INT \DAT\EXAMP\r
+<H2>1.5. COMPILE TIME ERRORS</H2>\r
+\r
+<P>\r
+The errors detected during the compilation are printed on the\r
+listing file, if this file is created. In the scope of option\r
+L- or if the switch L is set off only the incorrect lines and\r
+errors messages are printed . When the switch ( not option !)\r
+L is set off then listing file is not produced and incorrect lines\r
+and error messages are printed on the user's terminal.\r
+<P>\r
+Error message has the following format:\r
+<P>\r
+<SAMP>*** ln ERROR en txt id <BR>\r
+</SAMP>\r
+<P>\r
+where:\r
+<P>\r
+ln - index of incorrect line,\r
+<P>\r
+en - error's number (see Appendix B),\r
+<P>\r
+txt- text that explain type of the error,\r
+<P>\r
+id - identifier helpful to situate the error.\r
+<P>\r
+Error messages are printed in the source listing after incorrect\r
+lines.\r
+<P>\r
+For syntax errors (numbered 101-147, 201-212), sign '?' indicates\r
+the error's position in the line.\r
+<P>\r
+Error may be detected beyond the line containing it.\r
+<P>\r
+Identifier helpful to find an error is printed as soon as possible.\r
+<P>\r
+For codes 331-338 error message is printed after first line of\r
+virtual module declaration.\r
+<P>\r
+Errors like "undeclared identifier" are printed in each\r
+module once, after first reference to this identifier. Further\r
+references are ignored.\r
+<P>\r
+The errors related to case instruction may appear before the incorrect\r
+line.\r
+<H2>1.6. RUN-TIME ERRORS </H2>\r
+\r
+<P>\r
+Loglan run-time errors are detected by Loglan run-time system.\r
+When any of these errors occurs, the appropriate system signal\r
+is raised and error message is printed if handler is not found.\r
+All of these error messages are described in Appendix C. moreover\r
+the line number of the last executed statement is printed on the\r
+user's terminal.\r
+<H1>2. COMPILER OPTIONS </H1>\r
+\r
+<P>\r
+Options, like switches are used to pass some information to the\r
+compiler. Options are placed in source program in comments. Scope\r
+of options in source program is textual. Option may appear in\r
+any place of source program, but it is active from the beginning\r
+of the nearest instruction. Listing option L is active from the\r
+next line after line containing setting this option on up to the\r
+line containing setting this option off. Options overwrite defaults,\r
+but are overwritten by switches (external options). Option definition\r
+is not allowed before the keyword program.\r
+<H2>2.1. OPTION FORMAT </H2>\r
+\r
+<P>\r
+Options may be placed in source program in comments in the following\r
+format:\r
+<P>\r
+(*$opt1,opt2,...*)\r
+<P>\r
+where opti consists of character that designates the option and\r
+either '+' or '-' e.g.: (*$L-,T+*). Options in one comment should\r
+be separated by commas. Spaces in such comment are not allowed.\r
+<H2>2.2. OPTIONS LIST </H2>\r
+\r
+<P>\r
+D - trace\r
+<P>\r
+D+ - causes the line numbers of the executed instruction to be\r
+printed,\r
+<P>\r
+D- - default,\r
+<P>\r
+L - listing\r
+<P>\r
+L- - default, only incorrect lines are printed on the terminal\r
+<P>\r
+L+ - all lines are printed on the listing file\r
+<P>\r
+O - optimization\r
+<P>\r
+O+ - optimization of some arithmetical and logical expressions\r
+are included to generated code (default),\r
+<P>\r
+O- - generate code without optimization,\r
+<P>\r
+T - type conflict checking\r
+<P>\r
+T+ - default, dynamic checking of type conflict in assignment\r
+instructions and in parameter transmissions,\r
+<P>\r
+T- - no dynamic checking\r
+<P>\r
+H - memory model (switch only) APPLIES ONLY to PC/AT/XT !!\r
+<P>\r
+H- - default, small memory\r
+<P>\r
+H+ - huge memory\r
+<P>\r
+PC/AT/XT When H- is specified all code and data must fit into\r
+64K <BR>\r
+\r
+<P>\r
+bytes. When H+ is specified all memory available on IBM PC\r
+<P>\r
+may be utilized, with the cost of increased execution time.\r
+<H2>2.3. Fragmentation</H2>\r
+\r
+<P>\r
+It is possible to split one Loglan program into different files.\r
+The preprocessor puts together the fragments of a program coming\r
+from different files and enables in this way the a compilation\r
+and, later, an execution of the entire Loglan source.\r
+<P>\r
+In any place of Loglan text where it is possible to put semicolon\r
+(;) you can put aside the following compiler directive\r
+<P>\r
+#include < <I>file</I>>\r
+<P>\r
+It means that any two declarations of instructions can be separated\r
+by the directive. Do not forget however to end the preceding declaration\r
+or instruction by the semicolon.\r
+<P>\r
+<I>Grammar</I> \r
+<P>\r
+#include "{path> }< file name> " < CR>\r
+CR stands for end of line Carriage Return\r
+<P>\r
+<I>Remarks</I> \r
+<P>\r
+1. It may be a white space between the word 'include' and the\r
+character ".\r
+<P>\r
+2. You need not to specify the path to the included file if it\r
+is stored in the current directory, i.e. the one from which you\r
+began the compilation.\r
+<P>\r
+3. The ortography of path should correspond to the plateform used\r
+<P>\r
+(i.e. in DOS you use \ characters, in Unix it will be / character)\r
+<P>\r
+Example\r
+<PRE>\r
+program pr;\r
+ var x: real;\r
+ #include c:\loglan\examples\simulation.log\r
+\r
+ unit c: class;\r
+ end c;\r
+begin\r
+ read(x);\r
+ ...\r
+end\r
+</PRE>\r
+\r
+<P>\r
+The content of the file c:\loglan\examples\simulation.log replaces\r
+the line include.\r
+<H1>3. CURRENT LOGLAN-82 IMPLEMENTATION SPECIFICATION</H1>\r
+\r
+<H2>3.1. IMPLEMENTED SUBSET OF LOGLAN </H2>\r
+\r
+<P>\r
+The following constructions described in the report of Loglan-82\r
+have not been implemented:\r
+<P>\r
+- local attributes,\r
+<P>\r
+- separate compilation,\r
+<P>\r
+File system is described in 3.3.\r
+<H2>3.2. PREDEFINED LANGUAGE ELEMENTS </H2>\r
+\r
+<P>\r
+Predefined constants, procedures and functions are added to the\r
+language (see Appendix A). Moreover keywords char (short form\r
+of character) and bool (short form of boolean) are added.\r
+<P>\r
+The character set, defined in the report of Loglan-82, is extended\r
+by lower-case letters and the tabulation character (decimal code\r
+9). It is possible to use operator '< > ' which stands for\r
+'not equal'.\r
+<H2>3.3. FILE SYSTEM </H2>\r
+\r
+<P>\r
+Loglan contains the predefined reference type file and a set of\r
+statements and standard procedures to manipulate files. Both sequential\r
+and direct access files are implemented.\r
+<H2>3.4. FILE VARIABLES </H2>\r
+\r
+<P>\r
+Variables of the type file can be declared in the Loglan program\r
+and can be used as any variables of a reference type.\r
+<P>\r
+Example:\r
+<PRE>\r
+ <B>var</B> f:file, \r
+A:<B>arrayof</B> file; \r
+\r
+<B>unit</B> p:<B>procedure</B>(f:file); ... <B>end </B>p; \r
+<B>begin</B> \r
+ ...... \r
+ f := A(i); \r
+ ...... \r
+<B>end</B>; \r
+</PRE>\r
+\r
+<H3>3.4.1. FILE GENERATION </H3>\r
+\r
+<P>\r
+A file object is generated by open statement of the form:\r
+<P>\r
+open(f,T) for internal files or <BR>\r
+<BR>\r
+open(f,T,A) for external files <BR>\r
+\r
+<P>\r
+where\r
+<P>\r
+f is a file variable,\r
+<P>\r
+T = text for text files,\r
+<P>\r
+char for binary sequential files of character,<BR>\r
+integer integer or\r
+<P>\r
+real real values\r
+<P>\r
+direct for direct access binary files.\r
+<P>\r
+A is an expression of the type arrayof char designating external\r
+file name. After execution of open statement the new file object\r
+is created and it becomes a value of the file variable f. If the\r
+file is opened as an external one, then it references to the file\r
+A.\r
+<P>\r
+Example:\r
+<P>\r
+open(data,text) - new internal text file data is opened\r
+<P>\r
+open(num ,integer) - new internal binary file num is opened\r
+<P>\r
+(the file components are integer numbers)\r
+<P>\r
+open(f,text,unpack("my.dat")) - external text file f\r
+is opened;\r
+<P>\r
+it references to the file my.dat stored on the default drive and\r
+directory.\r
+<P>\r
+open(f,direct,A) - an external direct access file with name in\r
+array A is opened.\r
+<H2>3.5. FILE DEALLOCATION </H2>\r
+\r
+<P>\r
+The file can be closed and deallocated by execution of the statement\r
+kill.\r
+<H2>3.6. GENERAL FILE OPERATIONS </H2>\r
+\r
+<P>\r
+There are three standard procedures associated with files: RESET,\r
+REWRITE and UNLINK.\r
+<P>\r
+call RESET(f) rewinds the file f. After execution of RESET on\r
+sequential files only read/get operations are available.\r
+<P>\r
+call REWRITE(f) creates a new empty file. After execution of REWRITE\r
+on sequential files only write/put operations are available.\r
+<P>\r
+call UNLINK(f) closes and deletes file f. File object is deallocated\r
+and f is set to one.\r
+<P>\r
+RESET or REWRITE must be performed on the file opening before\r
+the first I/O operation on it.\r
+<H2>3.7. TEXT FILES </H2>\r
+\r
+<P>\r
+The following operations are available to text files: read, readln,\r
+eoln, write, writeln, eof. The first parameter of the operation\r
+is a file variable. If it is omitted, then a standard input/output\r
+file assigned to user's terminal is used.\r
+<P>\r
+Example:\r
+<PRE>\r
+ read(f,a,b); \r
+read(c); \r
+writeln(g," .... "); \r
+if eof(f) then .... \r
+</PRE>\r
+\r
+<P>\r
+For more information see [1].\r
+<H2>3.8. BINARY SEQUENTIAL FILES</H2>\r
+\r
+<P>\r
+Any file created with the parameter T = integer, real or char\r
+is a binary one. It is a sequence of components of the type T.\r
+Only objects of type T can be read from or written to this file.\r
+<P>\r
+The following operations are available to binary files:\r
+<P>\r
+put(f, w1, ..., wn)\r
+<P>\r
+get(f, x1, ..., xn)\r
+<P>\r
+eof(f)\r
+<P>\r
+where f is a file opened with the type T, wi is an expression\r
+of the type T and xi is a variable of the type T.\r
+<P>\r
+The statement put(f, w1, ..., wn) writes the components w1, ...,wn\r
+to the file f. The statement get(f, x1, ..., xn) reads the next\r
+n components from the file f and assigns them to the variables\r
+x1, ..., xn. The statement eof is the same as for text files.\r
+<H2>3.9. DIRECT ACCESS BINARY FILES</H2>\r
+\r
+<P>\r
+Direct access files are treated as a sequence of bytes without\r
+any interpretation. Operations RESET and REWRITE prepare a file\r
+for both reading and writing. RESET is used for existing files,\r
+<P>\r
+REWRITE for the new ones.\r
+<P>\r
+The following additional operations are available:\r
+<P>\r
+call SEEK(f, offset, base) - moves the file pointer to the position\r
+designated by offset relative to base.\r
+<P>\r
+Offset is a signed integer specifying the number of bytes.\r
+<P>\r
+Possible values for base are:\r
+<P>\r
+0 - begining of file,\r
+<P>\r
+1 - current position of file pointer,\r
+<P>\r
+2 - end of the file.\r
+<P>\r
+Examples:\r
+<P>\r
+call SEEK(f, 0, 0) - rewinds file f,\r
+<P>\r
+call SEEK(f, -3, 1) - backspaces file f by 3 bytes,\r
+<P>\r
+call SEEK(f, 0, 2) - moves the file pointer to the first byte\r
+after end of file\r
+<P>\r
+POSITION(f) - returns current position of the file pointer associated\r
+with f.\r
+<P>\r
+PUTREC(f, A, n) - where A is an array of any primitive type and\r
+n is an integer variable. Let k be the number of bytes occupied\r
+by elements of array A. This operation writes min(k, n) bytes\r
+from A to the file f and advances file pointer by the number of\r
+written bytes. The number of bytes written to the file is returned\r
+in the variable n.\r
+<P>\r
+GETREC(f, A, n) - where A is an existing array of any primitive\r
+type and n is an integer variable. Let k be the number of bytes\r
+occupied by elements of array A This operation reads min(k,n)\r
+bytes (or less, if end of file is encountered) from the file and\r
+advances the file pointer by the number of read bytes. The number\r
+of bytes read from the file is returned in the variable n.\r
+<H2>3.10. CONCURRENCY</H2>\r
+\r
+<P>\r
+Implemented concurrency mechanisms differ much from those described\r
+in the LOGLAN-82 report []. In particular, only distributed processes\r
+are implemented, so they cannot communicate through shared variables.\r
+For this reason semaphores had to be replaced by an entirely new\r
+communication mechanism. Such a mechanism has been designed and\r
+it is based on the rendez-vous schema.\r
+<H3>3.10.1. INVOKING THE LOGLAN INTERPRETER FOR CONCURRENT PROGRAMS\r
+</H3>\r
+\r
+<P>\r
+A concurrent LOGLAN program may run on a single computer with\r
+concurrency simulated by time slicing. In this case LOGLAN interpreter\r
+is invoked as usual. One must only remember that /m optional parameter\r
+(see 1.4.) denotes memory size for each process rather than for\r
+the whole program.\r
+<P>\r
+To achieve true parallel (multiprocessor) execution, a network\r
+of IBM PC computers may be used. For the time being, only D-Link\r
+Network Version 3.21 is supported. In order to run a LOGLAN program\r
+in the network environment take the following steps:\r
+<P>\r
+1) make sure that every node is logged on,\r
+<P>\r
+2) select arbitrarily one node as a console,\r
+<P>\r
+3) invoke the LOGLAN interpreter on every node except the console,\r
+giving it /r option with the console node number (see 1.4.). You\r
+must give the same program file to all interpreters. Most conveniently\r
+it may be achieved by accessing a file on a disk connected through\r
+the network to each node.\r
+<P>\r
+4) invoke the interpreter on the console without the /r option\r
+(in the usual way). Give it the same program file as above.\r
+<P>\r
+After the last step the main program process begins its execution\r
+on the console node. Other processes may be created dynamically\r
+on any node on which an interpreter is running.\r
+<P>\r
+<B>Regardless of the fact whether the network is used or not,\r
+more than one process may be executed on the same computer.</B>\r
+\r
+<H3>3.10.2. RESTRICTIONS AND DIFFERENCES FROM THE REPORT</H3>\r
+\r
+<P>\r
+All processes (even those executed on the same computer) are implemented\r
+as distributed, i.e. without any shared memory. This fact implies\r
+some restrictions on how processes may be used. Not all restrictions\r
+are enforced by the present compiler, so it is the programmer's\r
+responsibility to respect them. This is the list of restrictions:\r
+<P>\r
+1) all process units must be declared as global, i.e. directly\r
+inside the main program,\r
+<P>\r
+2) a process cannot access global variables (except for the main\r
+program process),\r
+<P>\r
+3) any remote access to a process object other than a procedure\r
+call is inhibited\r
+<P>\r
+4) each parameter of\r
+<P>\r
+a process,\r
+<P>\r
+a procedure called by remote access to a process object,\r
+<P>\r
+a procedure parameter of a process,\r
+<P>\r
+must be one of the following:\r
+<P>\r
+a value of the primitive type (INTEGER, REAL, CHAR, BOOLEAN, STRING)\r
+<P>\r
+a procedure declared directly inside a process\r
+<P>\r
+a procedure which is a formal parameter of a process\r
+<P>\r
+any reference to a process object.\r
+<P>\r
+This restriction implies that references to objKcts other than\r
+processes have only local meaning (in a single process) and cannot\r
+be passed among the processes.\r
+<P>\r
+5) comparisons, IS, IN and QUA operations are not allowed for\r
+the references to processes.\r
+<P>\r
+6) operations which require dynamic type checking on the references\r
+to processes are not allowed.\r
+<P>\r
+7) a process may be attached only by a proper coroutine generated\r
+by it.\r
+<P>\r
+8) the variable MAIN is accesible only in the main program process.\r
+<P>\r
+The following concurrent constructs described in the report are\r
+not implemented at all:\r
+<P>\r
+- semaphores and all operations on them\r
+<P>\r
+- the WAIT expression.\r
+<P>\r
+Semantics of the NEW generator is slightly modified when applied\r
+to the processes. The first parameter of the first process unit\r
+in the prefix sequence <I><B>must</B></I> be of type INTEGER.\r
+This parameter denotes the node number of the computer on which\r
+this process will be created. For a single computer operation\r
+this parameter must be equal to 0.\r
+<P>\r
+Example:\r
+<PRE>\r
+<B>unit</B> A:<B>class</B>(msg:string);\r
+...\r
+<B>end</B> A;\r
+<B>unit</B> P:A process(node:integer, pi:real);\r
+...\r
+<B>end </B>P;\r
+...\r
+<B>var </B>x:P;\r
+...\r
+<B>begin</B>...\r
+ (* Create process on node 4. The first parameter is the *) \r
+ (* string required by the prefix A, the second is the node number *)\r
+ x := <B>new</B> P("Hello", 4, 3.141592653);\r
+...\r
+<B>end</B>\r
+</PRE>\r
+\r
+<P>\r
+.\r
+<P>\r
+The following parallel constructs are implemented as defined in\r
+the report:\r
+<P>\r
+- KILL operation for a process\r
+<P>\r
+- RESUME statement\r
+<P>\r
+- STOP statement without parameter.\r
+<H3>3.10.3. COMMUNICATION MECHANISM</H3>\r
+\r
+<P>\r
+Processes may communicate and synchronize by a mechanism based\r
+on rendez-vous. It will be referred to as "alien call"\r
+in the following description.\r
+<P>\r
+An alien call is either:\r
+<P>\r
+- a procedure (or function) call performed by a remote access\r
+to a process object, or\r
+<P>\r
+- a call of a procedure which is a formal parameter of a process,\r
+or\r
+<P>\r
+- a call of a procedure which is a formal parameter of an alien-called\r
+procedure (this is a recursive definition). Every process object\r
+has an enable mask. It is defined as a subset of all procedures\r
+declared directly inside a process unit or any unit from its prefix\r
+sequence (i.e. subset of all procedures that may be alien-called).\r
+<P>\r
+A procedure is enabled in a process if it belongs to that process'\r
+enable mask. A procedure is disabled if it does not belong to\r
+the enable mask.\r
+<P>\r
+Immediately after generation of a process object its enable mask\r
+is empty (all procedures are disabled).\r
+<P>\r
+Semantics of the alien call is different from the remote call\r
+described in the report. Both the calling process and the process\r
+in which the procedure is declared (i.e. the called process) are\r
+involved in the alien call. This way the alien call may be used\r
+as a synchronization mechanism.\r
+<P>\r
+The calling process passes the input parameters and waits for\r
+the call to be completed.\r
+<P>\r
+The alien-called procedure is executed by the called process.\r
+Execution of the procedure will not begin before certain conditions\r
+are satisfied. First, the called process must not be suspended\r
+in any way. The only exception is that it may be waiting during\r
+the ACCEPT statement (see below). Second, the procedure must be\r
+enabled in the called process.\r
+<P>\r
+When the above two conditions are met the called process is interrupted\r
+and forced to execute the alien-called procedure (with parameters\r
+passed by the calling process).\r
+<P>\r
+Upon entry to the alien-called procedure all procedures become\r
+disabled in the called process.\r
+<P>\r
+Upon exit the enable mask of the called process is restored to\r
+that from before the call (regardless of how it has been changed\r
+during the execution of the procedure). The called process is\r
+resumed at the point of the interruption. The execution of the\r
+ACCEPT statement is ended if the called process was waiting during\r
+the ACCEPT (see below).\r
+<P>\r
+At last the calling process reads back the output parameters and\r
+resumes its execution after the call statement.\r
+<P>\r
+The process executing an alien-called procedure can easily be\r
+interrupted by another alien call if the enable mask is changed.\r
+<P>\r
+There are some new language constructs associated with the alien\r
+call mechanism. The following statements change the enable mask\r
+of a process:\r
+<P>\r
+ENABLE p1, ..., pn\r
+<P>\r
+enables the procedures with identifiers p1, ..., pn. If there\r
+are any processes waiting for an alien call of one of these procedures,\r
+one of them is chosen and its request is processed. The scheduling\r
+is done on a FIFO basis, so it is strongly fair. The statement:\r
+<P>\r
+DISABLE p1, ..., pn\r
+<P>\r
+disables the procedures with identifiers p1, ..., pn.\r
+<P>\r
+In addition a special form of the RETURN statement:\r
+<P>\r
+RETURN ENABLE p1, ..., pn DISABLE q1, ..., qn\r
+<P>\r
+allows to enable the procedures p1, ..., pn and disable the procedures\r
+q1,...,qn after the enable mask is restored on exit from the alien-called\r
+procedure. It is legal only in the alien-called procedures (the\r
+legality is not enforced by the compiler).\r
+<P>\r
+A called process may avoid busy waiting for an alien call by means\r
+of the ACCEPT statement:\r
+<P>\r
+ACCEPT p1, ..., pn\r
+<P>\r
+adds the procedures p1, ..., pn to the current mask, and waits\r
+for an alien call of one of the currently enabled procedures.\r
+After the procedure return the enable mask is restored to that\r
+from before the ACCEPT statement.\r
+<P>\r
+Note that the ACCEPT statement alone (i.e. without any ENABLE/DISABLE\r
+statements or options) provides a sufficient communication mechanism.\r
+In this case the called process may execute the alien-called procedure\r
+only during the ACCEPT statement (because otherwise all procedures\r
+are disabled). It means that the enable mask may be forgotten\r
+altogether and the alien call may be used as a pure totally synchronous\r
+rendez-vous. Other constructs are introduced to make partially\r
+asynchronous communication patterns possible.\r
+<H2>3.11. SYSTEM SIGNALS </H2>\r
+\r
+<P>\r
+System signals are connected to runtime errors (see APPENDIX C).\r
+<P>\r
+These signals are the following:\r
+<P>\r
+ACCERROR - reference to non existing object, CONERROR - array\r
+index outside the range or lower bound is greater than upper bound\r
+during array object generation, LOGERROR - errors related to control\r
+transfer, MEMERROR - memory overflow, NUMERROR - errors related\r
+to arithmentic operations like division by zero, floating point\r
+overflow, TYPERROR - type conflict in assignment statement, during\r
+parameter tran smission or headline conflict for actual parameter\r
+function and procedure. SYSERROR - errors related to file system,\r
+like reading after writing, too many files etc.\r
+<H2>3.12. IMPLEMENTATION RESTRICTIONS </H2>\r
+\r
+<P>\r
+- Text line in source program can't be longer than 80 characters.\r
+- Maximal length of identifier is 20 characters, but entire length\r
+of all identifiers and keywords should be less than 3000 characters.\r
+- String constant can't be longer than 260 characters. - For case\r
+instructions: - up to 6 levels of nested case instructions are\r
+allowed, - range of labels can't be greater than 160. - Number\r
+of formal parameters can't be greater than 40, whereas up to 35\r
+output or input parameters are allowed. Total number of formal\r
+parameters and variables declared in one module can't be greater\r
+than 130. - Number of array indices (i.e. arrayof) can't be greater\r
+than 63, - Standard type integer has the range (-32767,+32767)\r
+for small memory (16 - bit word). For huge memory (32-bit word)\r
+the range is (-2147483647,+2147483647), but values of constant\r
+expressions in a program must lie within the range (-2767, 32767).\r
+- Real numbers have the range (-8.43E-37, 3.37E+38) with 24-bit\r
+mantissa and 8-bit exponenet for small memory , giving about 7\r
+digits of precision. For huge memory the range is (4.19E-307,\r
+1.67E+308) with 53-bit mantissa and 11-bit exponent, giving about\r
+15 digits of precision.Values of constant expression in a program\r
+must lie in the range (-8.43E-37, 3.37E+38). Warning\r
+<P>\r
+Compiler computes values of expressions built from constants without\r
+range checking. It means, that integer overflow, floating point\r
+overflow or underflow cause incorrect result without any message.\r
+<H1>APPENDIX A : PREDEFINED CONSTANTS</H1>\r
+\r
+<P>\r
+INTSIZE\r
+<P>\r
+The size in bytes of integer variables\r
+<P>\r
+REALSIZE\r
+<P>\r
+The size in bytes of real variables\r
+<H1>APPENDIX B : PREDEFINED CLASSES</H1>\r
+\r
+<P>\r
+of GRAPHICS & MOUSE\r
+<P>\r
+for PC486 for Unix for PC286\r
+<H1>APPENDIX C : PREDEFINED PROCEDURES AND FUNCTIONS </H1>\r
+\r
+<P>\r
+ENDRUN:procedure; <BR>\r
+Terminates program execution (ABORT). <BR>\r
+RANSET:procedure(x:real); <BR>\r
+Initializes random generator (for RANDOM function) <BR>\r
+RANDOM:function:real; <BR>\r
+Generates uniformly distributed pseudo-random numbers in the interval\r
+(0,1). <BR>\r
+SQRT:function(x:real):real; <BR>\r
+Computes square root of parameter x. <BR>\r
+SIN:function(x:real):real; <BR>\r
+Computes sinus of parameter x. <BR>\r
+COS:function(x:real):real; <BR>\r
+Computes cosinus of parameter x. <BR>\r
+TAN:function(x:real):real; <BR>\r
+Computes tangens of parameter x. <BR>\r
+EXP:function(x:real):real; <BR>\r
+Computes e**x. <BR>\r
+LN:function(x:real):real; <BR>\r
+Computes natural logarithmus of parameter x. <BR>\r
+ATAN:function(x:real):real; <BR>\r
+Computes arcus tangens of parameter x. <BR>\r
+ENTIER:function(x:real):integer; <BR>\r
+Computes entier part of parameter x. <BR>\r
+ROUND:function(x:real):integer; <BR>\r
+Computes rounded value of parameter x: ROUND(x)=ENTIER(x+0.5).\r
+<BR>\r
+IMIN:function(x, y:integer):integer; <BR>\r
+Computes minimum of two parameters. <BR>\r
+IMAX:function(x, y:integer):integer; <BR>\r
+Computes maximum of two parameters. <BR>\r
+IMIN3:function(x, y, z:integer):integer; <BR>\r
+Returns the minimum of three parameters. <BR>\r
+IMAX3:function(x, y, z:integer):integer; <BR>\r
+Returns maximum of three parameters. <BR>\r
+ISHFT:function(x, k:integer):integer; <BR>\r
+Logically shifts x by k bits: left, when k is positive, right\r
+otherwise. <BR>\r
+IAND:function(n, k:integer):integer; <BR>\r
+Returns logical product of parameters (on all bits). <BR>\r
+IOR:function(n, k:integer):integer; <BR>\r
+Returns logical sum of parameters (on all bits). <BR>\r
+XOR:function(n, k:integer):integer; <BR>\r
+Returns exlusive sum of parameters (on all bits). <BR>\r
+INOT:function(n:integer):integer; <BR>\r
+Returns logical complement of parameters (on all bits). <BR>\r
+ORD:function(c:char):integer; <BR>\r
+Returns number that represents character c (see APPENDIX F). \r
+<BR>\r
+The following equations are satisfied: CHR(ORD(c)) = c & ORD(CHR(n))\r
+= n <BR>\r
+CHR:function(n:integer):char; <BR>\r
+Returns character represented by parameter n (see APPENDIX F).\r
+<BR>\r
+UNPACK:function(s:string):arrayof char; <BR>\r
+Returns address of new array object containing characters of the\r
+string s. <BR>\r
+MEMAVAIL:function:integer;<BR>\r
+Returns the size of available memory in the current process (in\r
+words).<BR>\r
+EXEC:function(cmd:arrayof char):integer; <BR>\r
+Calls secondary command processor with cmd as a command string.\r
+Exit code is returned as a value of EXEC. TIME:function: integer;\r
+<BR>\r
+Returns an integer value indicating the amount of central processor\r
+<BR>\r
+time in seconds used by current process. <BR>\r
+RESET:procedure(f:file); <BR>\r
+Positionnes file f at the first component and readies it to reading.\r
+<BR>\r
+REWRITE:procedure(f:file); <BR>\r
+Positionnes file f at the first component and readies it for output.\r
+<BR>\r
+The file f becomes empty (eof(f) = true). <BR>\r
+UNLINK:procedure(f:file);<BR>\r
+Closes and deletes file f (see 3.3.4)<BR>\r
+SEEK:procedure(f:file; offset, base:integer);<BR>\r
+Positiones file pointer (see 3.3.7)<BR>\r
+POSITION:function(f:file):real;<BR>\r
+Reads position of file pointer (see 3.3.7)\r
+<H1>appendix D: Error Codes APPENDIX E : LOGLAN RUNTIME ERRORS\r
+</H1>\r
+\r
+<P>\r
+In the following list system signal name, raised after detection\r
+of runtime error, is placed in brackets.\r
+<P>\r
+ARRAY INDEX ERROR (CONERROR)\r
+<P>\r
+Index outside range during reference to array variable. NEGATIVE\r
+STEP VALUE (CONERROR)\r
+<P>\r
+SL CHAIN CUT OFF (LOGERROR) <BR>\r
+\r
+<P>\r
+Control transfer to object that has SL link cut off earlier in\r
+the consequence of kill operation. ILLEGAL ATTACH (LOGERROR)\r
+<P>\r
+The value of parameter of attach instruction is none or object\r
+differs from coroutine. ILLEGAL DETACH (LOGERROR)\r
+<P>\r
+An attempt to return by detach to coroutine that has been dealocated\r
+(by kill). ILLEGAL RESUME (LOGERROR)\r
+<P>\r
+An attempt to resume an object which is not a process or a process\r
+which is running. TOO MANY PROCESSES ON ONE MACHINE (SYSERROR)\r
+<P>\r
+Number of processes existing on one computer is greater than 64.\r
+INVALID NODE NUMBER (SYSERROR)\r
+<P>\r
+An attempt to create a process on a computer which is not connected\r
+to network. IMPROPER QUA (LOGERROR)\r
+<P>\r
+Error during computing expression of the form: ...x qua a, when\r
+'x' references to none or 'a' doesn't prefix dynamic type object,\r
+which is value of 'x'. ILLEGAL ASSIGNMENT (TYPERROR)\r
+<P>\r
+Type conflict between left and right side of assignment instruction.\r
+FORMAL TYPE MISSING (LOGERROR)\r
+<P>\r
+Formal type is not accessible because of SL cut off. ILLEGAL KILL\r
+(LOGERROR)\r
+<P>\r
+An attempt to deallocate object in SL chain of active object.\r
+ILLEGAL COPY (LOGERROR)\r
+<P>\r
+An attempt to copy non terminated object (i.e. class before execution\r
+of return statement, coroutine before execution of end statement...).\r
+REFERENCE TO NONE (ACCERROR)\r
+<P>\r
+An attempt to remote access (by dot) to attributes of non existing\r
+object: dealocated or not generated. MEMORY OVERFLOW (MEMERROR)\r
+<P>\r
+INCOMPATIBLE HEADERS (TYPERROR) <BR>\r
+\r
+<P>\r
+Actual parameter list of generated object (procedure, function\r
+or class) is incompatible with formal parameter list from module\r
+declaration or formal function type is incompatible with actual\r
+function type. INCORRECT ARRAY BOUNDS (CONERROR) <BR>\r
+\r
+<P>\r
+An attempt to generate dynamic array object, when lower bound\r
+of index range is greater than upper bound.\r
+<P>\r
+DIVISION BY ZERO (NUMERROR) <BR>\r
+\r
+<P>\r
+COROUTINE TERMINATED (LOGERROR)\r
+<P>\r
+An attempt to transfer control to a terminated coroutine. COROUTINE\r
+ACTIVE (LOGERROR)\r
+<P>\r
+An attempt to transfer control to an active coroutine. HANDLER\r
+NOT FOUND (LOGERROR)\r
+<P>\r
+There is no handler for signal declared by user. ILLEGAL RETURN\r
+(LOGERROR)\r
+<P>\r
+An attempt to execute return instruction in handler serving system\r
+signal. UNIMPLEMENTED STANDARD PRC. (LOGERROR)\r
+<P>\r
+Standard procedure or function is not implemented. FORMAL LIST\r
+TOO LONG (MEMERROR)\r
+<P>\r
+Formal parameter list is greater than 40. ILLEGAL I/O OPERATION\r
+(SYSERROR)\r
+<P>\r
+Reading after writing, the type of the read/write parameter does\r
+not match the type of the file etc. I/O ERROR (SYSERROR)\r
+<P>\r
+System error during I/O. CANNOT OPEN FILE (SYSERROR)\r
+<P>\r
+INPUT DATA FORMAT BAD (SYSERROR)<BR>\r
+\r
+<P>\r
+SYSTEM ERROR (SYSERROR)<BR>\r
+Should not occur. UNRECOGNIZED ERROR\r
+<H1>APPENDIX F : CHARACTER SET </H1>\r
+\r
+<P>\r
+At the top of the table are hexadecimal digits (0 to 7), and to\r
+the left of the table are hexadecimal digits (0 to F). Hexadecimal\r
+code of ASCII character is constructed by contatenation of column\r
+label and row label. For example, the value of character representing\r
+the plus sign is 2B.\r
+<PRE>\r
+ 0 1 2 3 4 5 6 7 \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 0 ! NUL ! DLE ! SP ! 0 ! @ ! P ! ! p ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 1 ! SOH ! DC1 ! ! ! 1 ! A ! Q ! a ! q ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 2 ! STX ! DC2 ! " ! 2 ! B ! R ! b ! r ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 3 ! ETX ! DC3 ! # ! 3 ! C ! S ! c ! s ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 4 ! EOT ! DC4 ! $ ! 4 ! D ! T ! d ! t ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 5 ! ENQ ! NAK ! % ! 5 ! E ! U ! e ! u ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 6 ! ACK ! SYN ! & ! 6 ! F ! V ! f ! v ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 7 ! BEL ! ETB ! ' ! 7 ! G ! W ! g ! w ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 8 ! BS ! CAN ! ( ! 8 ! H ! X ! h ! x ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 9 ! HT ! EM ! ) ! 9 ! I ! Y ! i ! y ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ A ! LF ! SUB ! * ! : ! J ! Z ! j ! z ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ B ! VT ! ESC ! + ! ; ! K ! [ ! k ! { ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ C ! FF ! FS ! , ! < ! L ! \ ! l ! | ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ D ! CR ! GS ! - ! = ! M ! ] ! m ! } ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ E ! SO ! RS ! . ! > ! N ! ^ ! n ! ~ ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ F ! SI ! US ! / ! ? ! O ! _ ! o ! DEL ! \r
+ _________________________________________________ \r
+</PRE>\r
+\r
+<P>\r
+. where:\r
+<PRE>\r
+ NUL Null DLE Data Link Escape \r
+ SOH Start of Heading DC1 Device Control 1 \r
+ STX Start of Text DC2 Device Control 2 \r
+ ETX End of Text DC3 Device Control 3 \r
+ EOT End of Transmission DC4 Device Control 4 \r
+ ENQ Enquiry NAK Negative Acknowledge \r
+ ACK Acknowledge SYN Synchronous Idle \r
+ BEL Bell ETB End of Transmission Block \r
+ BS Backspace CAN Cancel \r
+ HT Horizontal Tabulation EM End of Medium \r
+ LF Line Feed SUB Substitute \r
+ VF Vertical Tab ESC Escape \r
+ FF Form Feed FS File Separator \r
+ CR Carriage Return GS Group Separator \r
+ SO Shift Out RS Record Separator \r
+ SI Shift In US Unit Separator \r
+ SP Space DEL Delete \r
+</PRE>\r
+\r
+<H1>Bibliography</H1>\r
+\r
+<P>\r
+16 LITA, Pau Loglan'82 user's manual Loglan'82 users's manual\r
+November 24, 1994 15 \r
+</BODY>\r
+\r
+</HTML>\r
--- /dev/null
+<HTML>
+\r
+<HEAD>\r
+\r
+<TITLE>Why Loglan'82?</TITLE>\r
+\r
+<BODY>\r
+\r
+<H1><IMG src="loglanmm.gif">Why Loglan'82?</H1>\r
+\r
+<P>\r
+We think that everybody should take acquaintance with certain\r
+features of Loglan'82. Even if you will continue to use your favorite\r
+XYZ language, you will be at least aware of what you are missing.\r
+<BR>\r
+Four features of Loglan'82 distinguish it from the other OO languages:\r
+<A NAME="mli"><STRONG>multi-level inheritance, </STRONG></A><BR>\r
+<EM> the language offers both nesting and inheritance of modules\r
+<BR>\r
+</EM>nesting enables <EM> sharing </EM>of environments and inheritance\r
+enables <EM> private copies </EM>of environments. <BR>\r
+Both methods of module's construction are useful and important!\r
+\r
+<LI><A NAME="mki"><STRONG>multi-kind inheritance </STRONG></A>\r
+<BR>\r
+<EM> e.g. a procedure can inherit from a class, <BR>\r
+</EM>making use of it one can enforce protocols, dynamically check\r
+axioms of abstract data types etc.\r
+<LI><A NAME="saf"><STRONG>SAFETY </STRONG></A><BR>\r
+- <EM>Loglan'82 signals a lot of programming errors that pass\r
+unrecognized in other systems.<BR>\r
+- </EM>There is no risk of dangling references, no confusion of\r
+types ...<BR>\r
+ <EM>Safe deallocation statement and safe storage management\r
+system</EM>\r
+<LI><A NAME="conc"><STRONG>object-oriented concurrency </STRONG></A>\r
+<BR>\r
+<EM> objects of processes can be created dynamically and allocated\r
+on a processor accessible by the network <BR>\r
+</EM>The processes can communicate and synchronize through a new,\r
+powerful mechanism:<EM><B> ALIEN CALL </B></EM>\r
+</OL>\r
+\r
+<P>\r
+Other, standard methods of OO programming are present in Loglan'82:\r
+<UL>\r
+<LI>classes and objects of classes,\r
+<LI>virtual methods,\r
+<LI>hierarchies of classes,\r
+<LI>exception handling,\r
+<LI>operators of structured programming,\r
+<LI>dynamic arrays,\r
+<LI>coroutines\r
+<LI>etc.\r
+</UL>\r
+\r
+<P>\r
+\r
+<P>\r
+Loglan'82 is accompanied by an original methodology of software\r
+engineering which supports the most complicated and most expensive\r
+phases of software creation: specification, analysis and verification.\r
+There are good reasons for using Loglan'82 in:\r
+<UL>\r
+<LI><A href="#Edu">education</A>,\r
+<LI><A href="#Fast">fast prototyping of software</A>,\r
+<LI><A href="#res">research</A>.\r
+</UL>\r
+\r
+<H2><A NAME="Edu">Education</A>. </H2>\r
+\r
+<P>\r
+The academic community has a need for one language which enables\r
+to teach all elements of object programming: classes & objects,\r
+coroutines, processes (in Loglan'82 processes are objects which\r
+are able to act in parallel), inheritance, exception handling,\r
+dynamic arrays etc. Loglan'82 offers the complete sets of programming\r
+tools used in object and modular and structural programming.\r
+<P>\r
+It is of importance to have compilers acting in different operating\r
+environments: MS-DOS, Unix, Atari, etc. in order to assure the\r
+exchange of sources between students and teachers, between users\r
+of : personal computers, workstations and servers of university's\r
+networks. We are working on the prolongation of the list of machines\r
+and systems that support Loglan'82.\r
+<P>\r
+Loglan'82 supports other styles of programming e.g. programming\r
+by rules, functional programming etc.\r
+<P>\r
+The teacher and the students can use different computers (see\r
+"Machines" file) and still they can exchange the sources\r
+and to follow the experiments of others. You can distribute the\r
+files of Loglan'82 among the students which own PC/DOS, ATARI,\r
+PS2, PC/Unix. You can install Loglan'82 in your computing centre\r
+on Unix or Vax/VMS or Novell servers. You can install Loglan'82\r
+on your workstation (Sun, PC/Unix, Apollo etc.). On all machines\r
+you can compile and execute the same program. Whether it will\r
+be a student's program checked by a teacher, or an instructive\r
+program transmitted to the students. And students can work at\r
+home or in a computer room of your University.\r
+<P>\r
+For the PC users Loglan'82 comes with an environment consisting\r
+of - lotek - a text editor integrated with compiler and other\r
+tools, - a structural editor which guides you when you do not\r
+know the syntax of Loglan'82, - an electronic manual to be used\r
+with Norton Guide or its clones,\r
+<P>\r
+A set of instructive examples is added to the distribution package.\r
+<P>\r
+We encourage you to experiment with the system since:\r
+<UL>\r
+<LI>you can find it useful and interesting to teach the object\r
+programming,\r
+<LI>you can find Loglan'82 useful in fast prototyping of software,\r
+<LI>you can apply and extend several predefined classes which\r
+define and implement the problem- oriented languages extending\r
+Loglan'82 in various directions.\r
+</UL>\r
+\r
+<H2><A NAME="res">Research</A>.</H2>\r
+\r
+<P>\r
+Loglan'82 has been used as a <EM>tool</EM> with a success in research\r
+in:\r
+<UL>\r
+<LI>object oriented databases,\r
+<LI>symbolic computation (computer algebra, ...),\r
+<LI>formal proofs,\r
+<LI>proving the properties of programs.<BR>\r
+\r
+</UL>\r
+\r
+<P>\r
+this list is not the exhaustive one.\r
+<P>\r
+Loglan'82 is a <EM>source</EM> of many problems of broader interest.\r
+<OL>\r
+<LI>The problem of giving one non-contradictory semantics to the\r
+language admitting both nesting of modules and inheritance from\r
+various levels.\r
+<LI>Dangling reference problem.\r
+<LI>Mathematical models of concurrent processes.<BR>\r
+Loglan'82 is the result of a research on fundamental questions\r
+like 1-3 .\r
+<LI>Multiple inheritance and nesting.\r
+<LI>Libraries of predefined classes - how to define the meaning\r
+of separately compiled modules in the presence of nesting and\r
+multiple inheritance.\r
+<LI>The virtual Loglan'82 machine as a federation of co-processes.\r
+<LI>Execution of processes of a Loglan'82 program in a LAN of\r
+heterogeneous computers.\r
+<LI>Execution of Loglan'82 programs on parallel computers e.g.\r
+transputers.\r
+<LI>to find a complete, axiomatic definition of the notions of\r
+class and of inheritance,\r
+<LI>is it possible to make efficiently the nesting of modules\r
+and the multiple inheritance?\r
+<LI>how to manage the libraries of predefined procedures and classes\r
+in the presence of nesting?\r
+<LI>how to install the language on a real multiprocessor system?\r
+</OL>\r
+\r
+<P>\r
+The problem 1 was solved by the team lead by A.Kreczmar in co-operation\r
+with the group of H. Langmaack.\r
+<P>\r
+The problem 2 was solved by A.Kreczmar and was analyzed formally\r
+by H. Oktaba.\r
+<P>\r
+T.Müldner and A.Salwicki gave the Max model of parallel computations.\r
+H.-D. Burkhard proved that it differs essentially from the interleaving\r
+model.\r
+<P>\r
+B. Ciesielski gave a new concept of objects of processes and a\r
+communication mechanism of alien calls of procedures. This version\r
+was implemented by him in 1988.\r
+<P>\r
+The problems 4 - 12 are open. We would be happy to co-operate\r
+on solving them together with you.\r
+<P>\r
+We recommend Loglan'82 as a tool to be used in the research in:\r
+object-oriented databases, development of CASE tools, VHDL, silicon\r
+compilers, simulation, etc.\r
+<H2><A NAME="Fast">Production of new software</A></H2>\r
+\r
+<P>\r
+There are only a few languages which, like Loglan'82, enable both\r
+ways of modules' developing: nesting (- a module can be declared\r
+in other module) and inheritance (also called prefixing). The\r
+modules of your software can share the environment (by means of\r
+nesting) or they can inherit other modules as private copies of\r
+the modules declared elsewhere. The inheritance in Loglan'82 permits\r
+to inherit a module declared somewhere in the tree of nested modules.\r
+Moreover, the inheritance is no longer restricted to classes.\r
+Any module, whether it will be a class, a block, a procedure,\r
+a function, a coroutine or a process can inherit from a class.\r
+Coroutines and processes can be inherited in classes, coroutines\r
+or processes. Another kind of module is a handler. Handlers serve\r
+to handle signals (of exceptions).\r
+<P>\r
+Altogether one can use 7 kinds of modules.\r
+<P>\r
+The tools offered by Loglan'82 enable in various ways to create\r
+generic modules whether they are to serve as generic procedures\r
+or parameterized data types. In order to do so one can use either\r
+the possibility to pass types as formal parameters or the inheritance\r
+mechanisms. The language makes possible overloading the names\r
+of operations via the mechanism of virtual functions or procedures.\r
+<P>\r
+This and other programming tools offered by Loglan'82 permit to\r
+quickly create a prototype of a program and to test it in a friendly\r
+environment. The compiler gives a good diagnostic of the eventual\r
+errors. For the time being we can not offer a code generator.\r
+Instead you can use the Loglan_to_C crosscompiler.\r
+<P>\r
+The language is especially well suited for the\r
+<UL>\r
+<LI>reusability and\r
+<LI>proving the correctness.\r
+</UL>\r
+\r
+<P>\r
+Loglan'82 supports various methods of programming:\r
+<UL>\r
+<LI>imperative - since it is a descendant of Algol, Pascal, ...\r
+<LI>object-oriented - since it is a continuation, and extension\r
+of the ingenious ideas of Simula-67,\r
+<LI>functional programming is easy,\r
+<LI>programming by rules is supported by a specialized class BACKTRACK\r
+designed and developed in Loglan'82.\r
+</UL>\r
+<HR>\r
+\r
+<ADDRESS>\r
+We would appreciate any news (comments, questions, suggestions,\r
+objections, ...) from you. Please write to Andrzej.Salwicki@univ-pau.fr\r
+\r
+</ADDRESS>\r
+<HR>\r
+\r
+<P>\r
+<A href="availlty.htm"><IMG src="prevpage.gif"></A>\r
+<A href="loghome.htm"><IMG src="homepage.gif"></A>\r
+<A href="quick.htm"><IMG src="nextpage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </A>08:03\r
+04/12/1994 \r
+</ADDRESS>\r
+\r
+<P>\r
+Pau, le 26 Janvier 1994\r
+</BODY>\r
+\r
+</HTML>\r
+p
\ No newline at end of file
--- /dev/null
+<HTML>
+\r
+<HEAD>\r
+\r
+<TITLE>Why Loglan'82?</TITLE>\r
+\r
+<BODY>\r
+\r
+<H1><IMG src="loglanmm.gif">Why Loglan'82?</H1>\r
+\r
+<P>\r
+We think that everybody should take acquaintance with certain\r
+features of Loglan'82. Even if you will continue to use your favorite\r
+XYZ language, you will be at least aware of what you are missing.\r
+<BR>\r
+Four features of Loglan'82 distinguish it from the other OO languages:\r
+<P>\r
+<A NAME="mli"><STRONG>multi-level inheritance, </STRONG></A><BR>\r
+<EM> the language offers both nesting and inheritance of modules\r
+<BR>\r
+</EM>nesting enables <EM> sharing </EM>of environments and inheritance\r
+enables <EM> private copies </EM>of environments. <BR>\r
+Both methods of module's construction are useful and important!\r
+<OL>\r
+<LI><A NAME="mki"><STRONG>multi-kind inheritance </STRONG></A>\r
+<BR>\r
+<EM> e.g. a procedure can inherit from a class, <BR>\r
+</EM>making use of it one can enforce protocols, dynamically check\r
+axioms of abstract data types etc.\r
+<LI><A NAME="saf"><STRONG>SAFETY </STRONG></A><BR>\r
+- <EM>Loglan'82 signals a lot of programming errors that pass\r
+unrecognized in other systems.<BR>\r
+- </EM>There is no risk of dangling references, no confusion of\r
+types ...<BR>\r
+ <EM>Safe deallocation statement and safe storage management\r
+system</EM>\r
+<LI><A NAME="conc"><STRONG>object-oriented concurrency </STRONG></A>\r
+<BR>\r
+<EM> objects of processes can be created dynamically and allocated\r
+on a processor accessible by the network <BR>\r
+</EM>The processes can communicate and synchronize through a new,\r
+powerful mechanism:<EM><B> ALIEN CALL </B></EM>\r
+</OL>\r
+\r
+<P>\r
+Other, standard methods of OO programming are present in Loglan'82:\r
+<UL>\r
+<LI>classes and objects of classes,\r
+<LI>virtual methods,\r
+<LI>hierarchies of classes,\r
+<LI>exception handling,\r
+<LI>operators of structured programming,\r
+<LI>dynamic arrays,\r
+<LI>coroutines\r
+<LI>etc.\r
+</UL>\r
+\r
+<P>\r
+\r
+<P>\r
+Loglan'82 is accompanied by an original methodology of software\r
+engineering which supports the most complicated and most expensive\r
+phases of software creation: specification, analysis and verification.\r
+There are good reasons for using Loglan'82 in:\r
+<UL>\r
+<LI><A href="#Edu">education</A>,\r
+<LI><A href="#Fast">fast prototyping of software</A>,\r
+<LI><A href="#res">research</A>.\r
+</UL>\r
+\r
+<H2><A NAME="Edu">Education</A>. </H2>\r
+\r
+<P>\r
+The academic community has a need for one language which enables\r
+to teach all elements of object programming: classes & objects,\r
+coroutines, processes (in Loglan'82 processes are objects which\r
+are able to act in parallel), inheritance, exception handling,\r
+dynamic arrays etc. Loglan'82 offers the complete sets of programming\r
+tools used in object and modular and structural programming.\r
+<P>\r
+It is of importance to have compilers acting in different operating\r
+environments: MS-DOS, Unix, Atari, etc. in order to assure the\r
+exchange of sources between students and teachers, between users\r
+of : personal computers, workstations and servers of university's\r
+networks. We are working on the prolongation of the list of machines\r
+and systems that support Loglan'82.\r
+<P>\r
+Loglan'82 supports other styles of programming e.g. programming\r
+by rules, functional programming etc.\r
+<P>\r
+The teacher and the students can use different computers (see\r
+"Machines" file) and still they can exchange the sources\r
+and to follow the experiments of others. You can distribute the\r
+files of Loglan'82 among the students which own PC/DOS, ATARI,\r
+PS2, PC/Unix. You can install Loglan'82 in your computing centre\r
+on Unix or Vax/VMS or Novell servers. You can install Loglan'82\r
+on your workstation (Sun, PC/Unix, Apollo etc.). On all machines\r
+you can compile and execute the same program. Whether it will\r
+be a student's program checked by a teacher, or an instructive\r
+program transmitted to the students. And students can work at\r
+home or in a computer room of your University.\r
+<P>\r
+For the PC users Loglan'82 comes with an environment consisting\r
+of - lotek - a text editor integrated with compiler and other\r
+tools, - a structural editor which guides you when you do not\r
+know the syntax of Loglan'82, - an electronic manual to be used\r
+with Norton Guide or its clones,\r
+<P>\r
+A set of instructive examples is added to the distribution package.\r
+<P>\r
+We encourage you to experiment with the system since:\r
+<UL>\r
+<LI>you can find it useful and interesting to teach the object\r
+programming,\r
+<LI>you can find Loglan'82 useful in fast prototyping of software,\r
+<LI>you can apply and extend several predefined classes which\r
+define and implement the problem- oriented languages extending\r
+Loglan'82 in various directions.\r
+</UL>\r
+\r
+<H2><A NAME="res">Research</A>.</H2>\r
+\r
+<P>\r
+Loglan'82 has been used as a <EM>tool</EM> with a success in research\r
+in:\r
+<UL>\r
+<LI>object oriented databases,\r
+<LI>symbolic computation (computer algebra, ...),\r
+<LI>formal proofs,\r
+<LI>proving the properties of programs.<BR>\r
+\r
+</UL>\r
+\r
+<P>\r
+this list is not the exhaustive one.\r
+<P>\r
+Loglan'82 is a <EM>source</EM> of many problems of broader interest.\r
+<OL>\r
+<LI>The problem of giving one non-contradictory semantics to the\r
+language admitting both nesting of modules and inheritance from\r
+various levels.\r
+<LI>Dangling reference problem.\r
+<LI>Mathematical models of concurrent processes.<BR>\r
+Loglan'82 is the result of a research on fundamental questions\r
+like 1-3 .\r
+<LI>Multiple inheritance and nesting.\r
+<LI>Libraries of predefined classes - how to define the meaning\r
+of separately compiled modules in the presence of nesting and\r
+multiple inheritance.\r
+<LI>The virtual Loglan'82 machine as a federation of co-processes.\r
+<LI>Execution of processes of a Loglan'82 program in a LAN of\r
+heterogeneous computers.\r
+<LI>Execution of Loglan'82 programs on parallel computers e.g.\r
+transputers.\r
+<LI>to find a complete, axiomatic definition of the notions of\r
+class and of inheritance,\r
+<LI>is it possible to make efficiently the nesting of modules\r
+and the multiple inheritance?\r
+<LI>how to manage the libraries of predefined procedures and classes\r
+in the presence of nesting?\r
+<LI>how to install the language on a real multiprocessor system?\r
+</OL>\r
+\r
+<P>\r
+The problem 1 was solved by the team lead by A.Kreczmar in co-operation\r
+with the group of H. Langmaack.\r
+<P>\r
+The problem 2 was solved by A.Kreczmar and was analyzed formally\r
+by H. Oktaba.\r
+<P>\r
+T.Müldner and A.Salwicki gave the Max model of parallel computations.\r
+H.-D. Burkhard proved that it differs essentially from the interleaving\r
+model.\r
+<P>\r
+B. Ciesielski gave a new concept of objects of processes and a\r
+communication mechanism of alien calls of procedures. This version\r
+was implemented by him in 1988.\r
+<P>\r
+The problems 4 - 12 are open. We would be happy to co-operate\r
+on solving them together with you.\r
+<P>\r
+We recommend Loglan'82 as a tool to be used in the research in:\r
+object-oriented databases, development of CASE tools, VHDL, silicon\r
+compilers, simulation, etc.\r
+<H2><A NAME="Fast">Production of new software</A></H2>\r
+\r
+<P>\r
+There are only a few languages which, like Loglan'82, enable both\r
+ways of modules' developing: nesting (- a module can be declared\r
+in other module) and inheritance (also called prefixing). The\r
+modules of your software can share the environment (by means of\r
+nesting) or they can inherit other modules as private copies of\r
+the modules declared elsewhere. The inheritance in Loglan'82 permits\r
+to inherit a module declared somewhere in the tree of nested modules.\r
+Moreover, the inheritance is no longer restricted to classes.\r
+Any module, whether it will be a class, a block, a procedure,\r
+a function, a coroutine or a process can inherit from a class.\r
+Coroutines and processes can be inherited in classes, coroutines\r
+or processes. Another kind of module is a handler. Handlers serve\r
+to handle signals (of exceptions).\r
+<P>\r
+Altogether one can use 7 kinds of modules.\r
+<P>\r
+The tools offered by Loglan'82 enable in various ways to create\r
+generic modules whether they are to serve as generic procedures\r
+or parameterized data types. In order to do so one can use either\r
+the possibility to pass types as formal parameters or the inheritance\r
+mechanisms. The language makes possible overloading the names\r
+of operations via the mechanism of virtual functions or procedures.\r
+<P>\r
+This and other programming tools offered by Loglan'82 permit to\r
+quickly create a prototype of a program and to test it in a friendly\r
+environment. The compiler gives a good diagnostic of the eventual\r
+errors. For the time being we can not offer a code generator.\r
+Instead you can use the Loglan_to_C crosscompiler.\r
+<P>\r
+The language is especially well suited for the\r
+<UL>\r
+<LI>reusability and\r
+<LI>proving the correctness.\r
+</UL>\r
+\r
+<P>\r
+Loglan'82 supports various methods of programming:\r
+<UL>\r
+<LI>imperative - since it is a descendant of Algol, Pascal, ...\r
+<LI>object-oriented - since it is a continuation, and extension\r
+of the ingenious ideas of Simula-67,\r
+<LI>functional programming is easy,\r
+<LI>programming by rules is supported by a specialized class BACKTRACK\r
+designed and developed in Loglan'82.\r
+</UL>\r
+<HR>\r
+\r
+<ADDRESS>\r
+We would appreciate any news (comments, questions, suggestions,\r
+objections, ...) from you. Please write to Andrzej.Salwicki@univ-pau.fr\r
+\r
+</ADDRESS>\r
+<HR>\r
+\r
+<P>\r
+<A href="availlty.htm"><IMG src="prevpage.gif"></A>\r
+<A href="loghome.htm"><IMG src="homepage.gif"></A>\r
+<A href="quick.htm"><IMG src="nextpage.gif"></A>\r
+<HR>\r
+\r
+<ADDRESS>\r
+<A href="http://www.univ-pau.fr/~salwicki/GMyAS.html">AS </A>08:03\r
+04/12/1994 \r
+</ADDRESS>\r
+\r
+<P>\r
+Pau, le 26 Janvier 1994\r
+</BODY>\r
+\r
+</HTML>\r
+pp
\ No newline at end of file
--- /dev/null
+<html>\r
+<head>\r
+<TITLE>Xiiuwgraf</TITLE>\r
+</head>\r
+\r
+\r
+<BODY>\r
+<H1> XIIUWGRAF</H1>\r
+\r
+<H5><I>Une classe Loglan predefinie <BR>\r
+pour la gestion de graphismes en multifenêtrage <BR>\r
+sous XWindows.</I></H5>\r
+ \r
+<P>\r
+\r
+\r
+<H3> Auteurs et realisateurs: </H3>\r
+<H2> Eric BECOURT &\r
+ Jerôme LARRIEU </H2>\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+LITA Pau 1993 <P>\r
+<HR>\r
+Table de matières</B> ou \r
+<A NAME="tresc">tresc</A> <BR>\r
+\r
+<UL>\r
+<LI>1: <A HREF = "#diff">Différences essentielles avec \r
+la librairie graphique IIUWGRAPH</A><P>\r
+\r
+\r
+<LI>2: <A HREF = "#Ouvrir">Ouvrir et fermer une fenêtre avec XIIUWGRAF</A><P>\r
+ <UL>\r
+ <LI>2.1 : <A HREF = "#HPAGE">Procédure HPAGE</A><P>\r
+ <LI>2.2 : <A HREF = "#GRON">Procédure GRON</A><P>\r
+ <LI>2.3 : <A HREF = "#GROFF">Procédure GROFF</A><P>\r
+ </UL>\r
+\r
+<LI>3 : <A HREF = "#Description">Description des diverses commandes </A> dédiées aux graphismes \r
+utilisables par l'interprêteur LOGLAN<P>\r
+ <UL>\r
+ <LI>3.1 : <A HREF = "#COLOR">Procédure COLOR</A><P>\r
+ <LI>3.2 : <A HREF = "#BORDER">Procédure BORDER</A><P>\r
+ <LI>3.3 : <A HREF = "#MOVE">Procédure MOVE</A><P>\r
+ <LI>3.4 : <A HREF = "#CLS"> Fonction CLS</A><P>\r
+ <LI>3.5 : <A HREF = "#POINT">Procédure POINT</A><P>\r
+ <LI>3.6 : <A HREF = "#DRAW">Procédure DRAW</A><P>\r
+ <LI>3.7 : <A HREF = "#CIRB"> Procédure CIRB</A><P>\r
+ <LI>3.8 : <A HREF = "#HFILL">Procédure HFILL</A><P>\r
+ <LI>3.9 : <A HREF = "#VFILL">Procédure VFILL</A><P>\r
+ <LI>3.10 : <A HREF = "#INXPOS">Fonction INXPOS</A><P>\r
+ <LI>3.11 : <A HREF = "#INYPOS"> Fonction INYPOS</A><P>\r
+ <LI>3.12 : <A HREF = "#saisie">: Commandes de saisie et de restition d'une partie d'une fenêtre</A><P>\r
+ <UL>\r
+ <LI>3.12.1 : <A HREF = "#GETMAP"> Fonction GETMAP</A><P>\r
+ <LI>3.12.2 : <A HREF = "#PUTMAP"> Procédure PUTMAP</A><P>\r
+ <LI>3.12.3 : <A HREF = "#ORMAP">Procédure ORMAP</A><P>\r
+ <LI>3.12.4 : <A HREF = "#XORMAP">Procédure XORMAP</A><P>\r
+ </UL>\r
+<P> <LI>3.13 : <A HREF = "#INPIX">Procédure INPIX</A><P>\r
+ <LI>3.14 : <A HREF = "#STYLE"> Procédure STYLE</A><P>\r
+ <LI>3.15 : <A HREF = "#caractères">Commandes de saisie et d'affichage de caractèc;res</A><P>\r
+ <UL>\r
+ <LI>3.15.1 : <A HREF = "#INKEY">Fonction INKEY</A><P>\r
+ <LI>3.15.2 : <A HREF = "#HASCII"> Procédure HASCII</A><P>\r
+ <LI>3.15.3 : <A HREF = "#OUTSTRING"> Procédure OUTSTRING</A><P>\r
+ </UL>\r
+<P> <LI>3.16 : <A HREF = "#PUSHXY">Procédure PUSHXY</A><P>\r
+ <LI>3.17 : <A HREF = "#POPXY">Procédure POPXY</A><P>\r
+</UL>\r
+\r
+<LI>4 : Description des commandes de gestion de la souris<P>\r
+ <UL>\r
+ <LI>4.1 : <A HREF = "#STATUS"> Procédure STATUS</A><P>\r
+ <LI>4.2 : <A HREF = "#GETPRESS">Procédure GETPRESS</A><P>\r
+ <LI>4.3 : <A HREF = "#GETRELEASE"> Procédure GETRELEASE</A><P>\r
+ <LI>4.4 : <A HREF = "#GETMOVEMENT"> Procédure GETMOVEMENT</A><P>\r
+ </UL>\r
+</UL>\r
+<HR><HR>\r
+<H2>\r
+1: <A NAME="diff"> \r
+Diff</A>érences essentielles entre XIIUWGRAF et IIUWGRAPH</H2>\r
+\r
+\r
+ Ce paragraphe a pour objet de donner certaines particularités de XIIUWGRAF, ceci afin de comprendre son fonctionnement général.<P>\r
+\r
+ Tout d'abord il est important de signaler qu'à la différence de IIUWGRAPH, XIIUWGRAF est un programme à part entièc;re (plus exactement un processus crée par l'interprêteur LOGLAN).C'est pour cela qu'il est déconseillé (sauf cas de force majeure) de faire CONTROL-C pour terminer un programme : en effet, ceci a pour effet de terminer l'exécution de l'interprêteur sans terminer XIIUWGRAF (création d'un processus zombie). Pour terminer une session graphique, il faudra donc automatiquement taper dans le programme en LOGLAN la commande GROFF car elle va terminer l'exécution de XIIUWGRAF.<P>\r
+\r
+ Certaines commandes de IIUWGRAPH n'ont pas été implémentées (par exemple HIDECURSOR, SHOWCURSOR, PALLET, ...), soit parce qu'elles seraient d'un intérêt trèc;s faible dans la gestion de XWindows, soit parce qu'elles seraient difficilement réalisables, soit parce que les programmeurs ont été atteints de fainéantise chronique.<P>\r
+\r
+ Enfin, dans vos programmes il faudra impérativement que vos unités gérant le graphisme héritent de la classe IIUWGRAPH sous peine d'erreurs à la compilation .<P>\r
+\r
+ATTENTION: appelez Xint au lieu de int<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+<H2>2: <A NAME="Ouvrir">Ouvrir</A> et fermer une fenêtre avec XIIUWGRAF</H2>\r
+\r
+\r
+ XIIUWGRAF permet à l'utilisateur d'ouvrir jusqu'à seize fenêtres à l'écran. Ces fenêtres sont sélectionnables dans le programme en LOGLAN par la commande GRON décrite plus loin.<P>\r
+\r
+<H3>2.1: La procédure <A NAME="HPAGE">HPAGE</A> . </H3>\r
+\r
+ <PRE>unit HPAGE: procedure(numerofenetre,x,y: INTEGER);</PRE><P>\r
+\r
+ Cette procédure a pour rôle de donner la position à laquelle sera affichée la fenêtre dans l'écran, de donner la taille de cette fenêtre et de l'effacer quand le besoin s'en fait sentir. Cette procédure devra être appelée <B>deux fois</B> pour ouvrir <B>une</B> fenêtre.<P>\r
+\r
+ HPAGE reçoit trois paramêtres : le premier est le numéro de la fenêtre (un entier compris entre 0 et 15), les deux suivants sont soit les coordonnées de la fenêtre à l'écran, soit la taille de cette fenêtre. Un troisièc;me appel de HPAGE avec l'un des deux derniers paramêtres nuls aura pour effet de l'effacer.<P>\r
+\r
+ Exemple :\r
+<Pre>\r
+ CALL HPAGE(0, posx, posy);<P>\r
+ CALL HPAGE(0, longueur, hauteur);<P>\r
+</Pre>\r
+ Le coin en haut à gauche de la fenêtre 0 sera aux coordonnées (posx,posy) et la fenêtre aura une taille de longueur X hauteur.<P>\r
+\r
+ CALL HPAGE(0, 0, valeur)<P>\r
+ ou CALL HPAGE(0, valeur, 0)<P>\r
+ ou CALL HPAGE(0, 0, 0)<P>\r
+\r
+ La fenêtre 0 est effacée.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+\r
+\r
+<H3>2.2: La procédure <A NAME="GRON">GRON</A> . </H3>\r
+\r
+ <PRE>unit GRON: procedure(numerofenetre: INTEGER);</PRE><P>\r
+\r
+ La procédure GRON affiche la fenêtre de numéro numerofenetre à l'écran. Ensuite pour sélectionner la fenêtre dans laquelle on veut travailler, on refait un deuxièc;me appel de cette commande.<P>\r
+Exemple :\r
+<Pre>\r
+ CALL HPAGE(0,0,0);<P>\r
+ CALL HPAGE(1,150,0);<P>\r
+ CALL HPAGE(0,100,100);<P>\r
+ CALL HPAGE(1,200,150);<P>\r
+ CALL GRON(0); (* Affichage de la fenêtre 0 *)<P>\r
+ CALL GRON(1); (* Affichage de la fenêtre 1 *)<P>\r
+ ...<P>\r
+ CALL GRON(0); (* Sélection de la fenêtre 1 *)<P>\r
+ ...<P>\r
+</Pre> \r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3> <B>2.3 : La procédure <A NAME="GROFF">GROFF</A> . </B><P></H3>\r
+\r
+ <PRE>unit GROFF: procedure;</PRE><P>\r
+\r
+ L'appel à cette commande a pour conséquence l'effaçage de toutes les fenêtres et la fin d'exécution du processus XIIUWGRAF.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+\r
+<H2>3: <A NAME="Description">Description</A> . des différentes \r
+commandes graphiques</H2>\r
+\r
+\r
+<H3>3.1: Procédure <A NAME="COLOR">COLOR</A> . </H3>\r
+\r
+ <PRE>unit COLOR: procedure(couleur: INTEGER);</PRE><P>\r
+\r
+ Permet de déterminer la couleur d'avant plan (0 pour noir et une valeur supérieure ou égale à 1 pour blanc). Cette commande a une action locale à la fenêtre sélectionnée par GRON.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>3.2: Procédure <A NAME="BORDER">BORDER</A> . </H3>\r
+\r
+ <PRE>unit BORDER: procedure(couleur: INTEGER);</PRE><P>\r
+\r
+ Commande qui sélectionne la couleur de fond.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>3.3: Procédure <A NAME="MOVE">MOVE</A> . </H3>\r
+\r
+ <PRE>unit MOVE: procedure(posx, posy: INTEGER);</PRE><P>\r
+\r
+ posx et posy deviennent les coordonnées courantes dans la fenêtre. Comme COLOR, MOVE n'agit que sur la fenêtre sélectionnée.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>3.4: Procédure <A NAME="CLS">CLS</A> . </H3>\r
+\r
+ <PRE>unit CLS: procedure;</PRE><P>\r
+\r
+ Efface la fenêtre en blanc par défaut ou de la couleur spécifiée par la commande BORDER.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="POINT">POINT</A> . </H3>\r
+\r
+ <PRE><B>unit</B> POINT: <B>procedure</B>(x,y: INTEGER);</PRE><P>\r
+ Affiche un point aux coordonnées (x,y) de la couleur spécifiée par la commande COLOR ou noir par défaut. La position courante dans la fenêtre devient (x,y).<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="DRAW">DRAW</A> . </H3>\r
+\r
+ <PRE><B>unit</B> DRAW: <B>procedure</B>(x,y: INTEGER);</PRE><P>\r
+\r
+ Affiche une ligne qui part de la position courante dans la fenêtre vers la position (x,y). La position courante dans la fenêtre devient (x,y). Elle est affichée avec la couleur courante (sélectionnée avec COLOR) et avec le style de tracé courant (sélectionnée par la commande STYLE décrite plus loin);<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="CIRB">CIRB</A> . </H3>\r
+\r
+ <PRE><B>unit</B> CIRB: <B>procedure</B>(posx,posy,rayon:INTEGER,alpha,beta:REAL,cbord,style,p,q:INTEGER);</PRE><P>\r
+\r
+ Si style a pour valeur 0, CIRB affiche un arc de centre (posx,posy), de rayon rayon. alpha et beta sont les angles de départ et d'arrivée de l'arc en question. Si alpha=beta alors un cercle (ou une ellipse) est dessiné. Si p=q alors on obtient un cercle, si p> q une ellipse allongée dans le sens vertical est obtenue, sinon si p> q on a pour résultat une ellipse allongée dans le sens horizontal. Cet affichage est fait avec la couleur d'avant plan courante et le style de tracé courant.<P>\r
+\r
+ Si style vaut 1, CIRB affiche un arc rempli ressemblant à une portion de camenbert avec la couleur d'avant plan courante.<P>\r
+\r
+ Si style vaut 2, l'intérieur de l'arc délimité par sa courbure et la corde joignant ses deux extrêmités est rempli avec la couleur d'avant plan courante.<P>\r
+\r
+ Si l'on choisi pour style une valeur < 0 ou > 3, la valeur 0 est prise.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="HFILL">HFILL</A> . </H3>\r
+\r
+ <PRE><B>unit</B> HFILL: <B>procedure</B>(y: INTEGER);</PRE><P>\r
+\r
+ Trace une ligne horizontale de la position courante (posx,posy) vers les coordonnées (posx,y) avec la couleur d'avant plan courante et le style de tracé courant. La position courante dans la fenêtre devient (posx,y).<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="VFILL">VFILL</A> . </H3>\r
+\r
+ <PRE><B>unit</B> VFILL: <B>procedure</B>(y: INTEGER);</PRE><P>\r
+\r
+ Trace une ligne verticale de la position courante (posx,posy) vers les coordonnées (x,posy) avec la couleur d'avant plan courante et le style de tracé courant. La position courante dans la fenêtre devient (x,posy).<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Fonction <A NAME="INXPOS">INXPOS</A> . </H3>\r
+\r
+ <PRE><B>unit</B> INXPOS: <B>function</B>: INTEGER;</PRE><P>\r
+\r
+ Retourne la position courante sur l'axe des abscisses de la fenêtre courante.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+ <P>\r
+<H3>: Fonction <A NAME="INYPOS">INYPOS</A> . </H3>\r
+\r
+ <PRE><B>unit</B> INYPOS: <B>function</B>: INTEGER;</PRE><P>\r
+\r
+ Retourne la position courante sur l'axe des ordonnées de la fenêtre courante.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+ <P>\r
+<H3>: Commandes de <A NAME="saisie">saisie</A> . et de restitution d'une partie d'une fenêtre.</H3>\r
+\r
+<H4>: Fonction <A NAME="GETMAP">GETMAP</A> . </H4>\r
+ \r
+<P> <PRE><B>unit</B> GETMAP: <B>function</B>(x,y: INTEGER): <B>arrayof</B> INTEGER;</PRE><P>\r
+\r
+ Sauve dans le tableau tab une partie rectanguraire de la fenêtre courante, le coin en haut à gauche étant la position courante dans la fenêtre et le coin en bas à droite étant la position (x,y).<P>\r
+ Le tableau devrait avoir une taille minimum de: 4 + (nbrelignes * (3 + nbrecol div 8)) octets<P>\r
+ En sachant qu'en LOGLAN un entier tient sur 4 octets(en UNIX seulement), il ne vous reste plus qu' à faire votre cuisine.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H4>: Procédure <A NAME="PUTMAP">PUTMAP</A> . </H4>\r
+\r
+ <PRE><B>unit</B> PUTMAP: <B>procedure</B>(tab: <B>arrayof</B> INTEGER);</PRE><P>\r
+\r
+ Affiche la portion d'image sauvée dans tab à la position courante dans la fenêtre. Ce qu'il y avait à cette même position avant l'affichage est totalement effaçé.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H4>: Procédure <A NAME="ORMAP">ORMAP</A> .</H4>\r
+\r
+ unit ORMAP: procedure(tab: arrayof INTEGER);<P>\r
+\r
+ Lors de l'affichage, une opération OR est faite avec la portion d'image sauvée dans tab et celle à la position courante dans la fenèc;tre: l'image est donc affichée en "transparence".<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H4>: Procédure <A NAME="XORMAP">XORMAP</A> .</H4>\r
+\r
+ <PRE><B>unit</B> XORMAP: <B>procedure</B>(tab: <B>arrayof</B> INTEGER);</PRE><P>\r
+\r
+ Même chose qu' avec ORMAP à la différence qu'une opération XOR est faite avec l'image sauvée dans tab et celle à la position courante dans la fenêtre.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="STYLE">STYLE</A> .</H3>\r
+\r
+ <PRE><B>unit</B> STYLE: <B>procedure</B>(styl: INTEGER);</PRE><P>\r
+\r
+ Définit le style de tracé dans la fenêtre courante.<P>\r
+\r
+ Si style vaut 0, le tracé sera fait avec la couleur de fond.<P>\r
+ Si style vaut 1, le tracé sera fait avec la couleur d'avant plan.<P>\r
+ Si style vaut 2,3,4 ou 5, le tracé sera fait avec les motif suivant :<P>\r
+\r
+ <PRE>2 : ******...******...******<P>\r
+ 3 : ****......****......****<P>\r
+ 4 : **...**...**...**<P>\r
+ 5 : **.........**.........** </PRE> où * : couleur d'avant plan<P>\r
+ . : couleur de fond<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Fonction <A NAME="INPIX">INPIX</A> .</H3>\r
+\r
+ <PRE><B>unit</B> INPIX: <B>function</B>(x,y: INTEGER);</PRE><P>\r
+\r
+ Cette fonction met la postion courante dans la fenêtre à (x,y) et renvoie la couleur du point de la fenêtre à cette position(0 pour noir et 1 pour blanc).<P>\r
+\r
+ <P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Commandes de saisie et d'affichage de <A NAME="caractèc;res">caractèc;res</A> .</H3>\r
+\r
+<H4>: Fonction <A NAME="INKEY">INKEY</A> .</H4>\r
+\r
+ <PRE><B>unit</B> INKEY: <B>function</B>: INTEGER;</PRE><P>\r
+\r
+ Retourne le code ascii de la touche tapée au clavier ou la valeur 0 sinon. L'appui sur les touches spéciales (comme SHIFT, les touche F1, F2, ..., CONTROL, ...) renvoient des valeurs négatives. Vous verrez bien par vous-même quelles sont ces valeurs en faisant un petit programme test.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H4>: Procédure <A NAME="HASCII">HASCII</A> .</H4>\r
+\r
+ <PRE><B>unit</B> HASCII: <B>procedure</B>(code_char: INTEGER);</PRE><P>\r
+\r
+ Affiche le caractèc;re de code ascii code_char avec le coin en haut à gauche du caractèc;re à la position courante (posx,posy) dans la fenêtre. La position courante devient (posx+largeur,posy).<P>\r
+ Si code_char=0, une partie rectangulaire de largeur*hauteur est affichée avec la couleur de fond de la fenêtre courante et position courante dans la fenêtre reste inchangée.<P>\r
+ En général la fonte par défaut qui est utilisée sous XWindows a une hauteur de dix points et une largeur de six points.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="OUTSTRING">OUTSTRING</A> .</H3>\r
+\r
+ <PRE><B>unit</B> OUTSTRING: <B>procedure</B>(tab: <B>arrayof</B> CHAR);</PRE><P>\r
+\r
+ Affiche la chaine de caractèc;re tab à la position courante (posx,posy) de la fenêtre. La position courante devient (posx+largeur*longueur_chaine,posy) où largeur est la largeur de la fonte utilisée.<P>\r
+\r
+ <P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="PUSHXY">PUSHXY</A> .</H3>\r
+\r
+ <PRE><B>unit</B> PUSHXY: <B>procedure</B>;</PRE><P>\r
+\r
+ Sauvegarde le contexte graphique dans une pile, c'est à dire la position courante dans la fenêtre,les couleurs de fond et d'avant plan et le style de tracé sélectionné pour cette fenêtre.<P>\r
+\r
+ Chaque Fenêtre est dotée de sa pile de sauvegarde qui lui est propre et chaque pile a une profondeur maximale de 16.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="POPXY">POPXY</A> .</H3>\r
+\r
+ <PRE><B>unit</B> POPXY: <B>procedure</B>;</PRE><P>\r
+\r
+ Restore dans la fenêtre courante le contexte graphique situé en haut de la pile de sauvegarde et ce contexte est enlevé de la pile.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H2>: Description des commandes de gestion de la <A NAME="souris">souris</A> .</H2>\r
+\r
+\r
+\r
+<H3>: Procédure <A NAME="STATUS">STATUS</A> .</H3>\r
+ \r
+<P> <PRE><B>unit</B> STATUS: <B>procedure</B>(h, v: INTEGER, l, r, c: BOOLEAN);</PRE><P>\r
+\r
+ Cette procédure renvoie la position courante (h,v) du pointeur de la souris ainsi que l'état des boutons de la souris. l,r,c sont respectivement les boutons gauche, droit et du centre de la souris.<P>\r
+\r
+ Ces valeurs booléennes ont la valeur TRUE si le bouton correspondant est appuyé.<P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="GETPRESS">GETPRESS</A> .</H3>\r
+\r
+ <PRE><B>unit</B> GETPRESS: <B>procedure</B>(b: INTEGER; OUTPUT h,v,p : INTEGER, l,r,c : BOOLEAN);</PRE><P>\r
+\r
+ Cette procédure renvoie le nombre p de fois où le bouton sélectionné a été appuyé depuis le dernier appel à cette commande, ainsi que la position (h,v) du curseur la dernièc;re fois que le bouton considéré a été appuyé.<P>\r
+\r
+ Le paramêtre b permet de sélectionner le bouton à tester :<P>\r
+ - 0 : bouton gauche<P>\r
+ - 1 : bouton droit<P>\r
+ - 2 : bouton du milieu<P>\r
+\r
+ En sus, la procédure renvoie l'état courant des trois boutons l,r,c.<P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="GETRELEASE">GETRELEASE</A> .</H3>\r
+\r
+ <PRE><B>unit</B> GETRELEASE: <B>procedure</B>(b: INTEGER; <B>OUTPUT</B> h,v,p : INTEGER, l,r,c : BOOLEAN);</PRE><P>\r
+\r
+ Cette procédure a la même fonction que GETPRESS à la différence qu'elle teste le nombre de relâchementss du bouton sélectionné et non l'appui.<P>\r
+\r
+ <P>\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+<H3>: Procédure <A NAME="GETMOVEMENT">GETMOVEMENT</A> .</H3>\r
+\r
+ <PRE><B>unit</B> GETMOVEMENT: <B>procedure</B>(h,v: INTEGER);</PRE><P>\r
+\r
+ Cette procédure renvoie le mouvement relatif (h,v) du curseur de la souris depuis son dernier appel.<P>\r
+\r
+\r
+\r
+ <P>\r
+\r
+<p align=right> : <A HREF = "#tresc">vers Tableau de Matieres</A></p>\r
+\r
+\r
+\r
+<HR>\r
+\r
+\r
+<Address> : <A HREF = "http://www.univ-pau.fr/~salwicki/GMyAS">GMyAS</A> à Pau, le 25 Octobre 1993 <P></ Address> \r
+</BODY>\r
+</html>\r
+\r
+\r
+\r
--- /dev/null
+<html>\r
+<head>\r
+<title>Zaproszenie do wspolpracy </title>\r
+</head>\r
+<body>\r
+<h1 align=center> Zaproszenie do wspolpracy </h1>\r
+<h3 align=center> w 3 nowych duzych projektach badawczych:</H3>\r
+<dir>\r
+<li><h2 > Loglan'96 </h2>\r
+<li><h2 > CASE Next Generation </h2>\r
+<li><h2 > Algorytmy probabilistyczne </h2></dir>\r
+<hr>\r
+\r
+Do wszystkich, ktorzy chca dzialac:<ul>\r
+\r
+<LI> rozwijac nowe koncepcje programowania <STRONG> <EM> obiektowego, </EM> </STRONG> <STRONG> <EM> wspolbieznego, rownoleglego i rozproszonego </EM> </STRONG> \r
+<li> podniesc(zdobyc) swoje kwalifikacje biorac udzial w badaniach,\r
+<li> przyczynic sie do rozwoju systemu Loglan,\r
+<li> stworzyc nowa jakosc w inzynierii oprogramowania,\r
+<li> dolozyc swoja cegielke do budowy obrazu naszego srodowiska, jako srodowiska dynamicznego, wiedzacego czego chce, zamierzajacego rozwiazac wazne problemy i oferujacego spoleczenstwu wyniki badan\r
+</ul>\r
+<p>kierujemy niniejsze \r
+\r
+\r
+<h1>ZAPROSZENIE</h1>\r
+\r
+na spotkanie - dyskusje<br>\r
+<center><IMG SRC = "crowd2.jpg" ></center>\r
+<h3 align=center>27 marca 1996 o godz. 12</H3>\r
+<h3 align=center>w sali 12, Instytutu Informatyki\r
+Politechnika Bialostocka</h3>\r
+<h4 align=center>ul Wiejska 45a Bialystok</h4>\r
+\r
+<p>Podczas spotkania przedstawimy trzy sporych rozmiarow projekty badawcze:\r
+<ul>\r
+<li> <h3>prof. dr hab. Wiktor DANKO - Algorytmy probabilistyczne</h3>\r
+<li> <h3>prof. dr hab. Grazyna MIRKOWSKA - CASE NT, system CASE nastepnej \r
+generacji</h3>\r
+<li> <h3>prof. dr hab. Andrzej SALWICKI - Loglan'96</h3>\r
+</ul>\r
+\r
+<p>Wszystkie projekty rzucaja <em>wyzwanie</em> trudnosciom teoretycznym, zlozonosci projektow i \r
+naszej ogolnej niemoznosci. Nie mamy zamiaru niczego ukrywac, chcemy te wyzwania \r
+omowic i przedyskutowac. Wiemy, ze ich pokonanie jest mozliwe.<br>\r
+Projekty te sa ze soba scisle powiazane: w projekcie CASE NT chcemy wykorzystac \r
+Loglan jako narzedzie pracy i jako zrodlo doswiadczen, w projekcie Loglan'96 \r
+chcielibysmy by system CASE NT stanowil uzupelnienie systemu kompilator+interpreter.\r
+\r
+<p><h2>Czy mamy szanse? </h2>Jak najbardziej TAK! Swiadcza o tym rozne fakty\r
+<ul>\r
+<li> Loglan'82 - juz raz <a href="loghome.htm">to zrobilismy</a> z sukcesem,\r
+<li> Linux - tu nie tylko sie powiodlo ale system rozprzestrzenia sie (miliony uzytkownikow) i \r
+rozwija (nowi wspolpracownicy w sieci Internet wnosza coraz to nowe pomysly i \r
+rozwiazania)\r
+<li> Java - pojawienie sie Javy - mlodszego brata Loglanu, potwierdza:<br> <em>slusznosc</em> naszych \r
+koncepcji (np. interpreter pozwala uniezaleznic sie od platformy),<br> <em> przewage</em> naszych \r
+doswiadczen(np. alien call nie zostal dotad odkryty i zastosowany poza Loglanem), <br>\r
+<em>dojrzalosc</em> naszej bazy teoretycznej(np. rozwiazanie problemu 'wiszacych referencji", \r
+mozliwosc zagniezdzania modulow i dziedziczenia z roznych poziomow zagniezdzania), \r
+<li> systemy rozproszone - TU JEST NASZA SZANSA! i nisza ekologiczna,\r
+<li> GNU - spokojna praca dla srodowiska informatykow daje rezultaty doceniane przez \r
+wielu (no, moze poza Microsoftem)\r
+</ul>\r
+\r
+\r
+<p><h2>Czy bedziemy sami?</h2>\r
+<p> Mamy nadzieje, ze nie. Kazdy z proponowanych projektow moze przyciagnac wielu wspolpracownikow z Polski i z zewnatrz. Dla kazdego znajdzie sie praca odpowiednia do jego kwalifikacji i zamilowan.\r
+Nasze zaproszenie jest zaadresowane do pracownikow naukowych, ambitnych studentow, placowek badawczych i firm software'owych.\r
+\r
+<p><h2>Co mozemy z tego miec?</h2>\r
+<ol>\r
+<li>Kilka produktow o nowych cechach, nowej jakosci.<br> Produkty te moga byc rozpowsechniane na zasadach jakie zostana przez nas ustalone. Nawet jesli ustalimy, ze "goly" produkt bedzie udostepniany za darmo, to jego odpowiednio "ubrana" wersja moze byc produktem komercyjnym. Osoby i firmy konfekcjonujace software moga zawsze pobierac za to oplaty.<br> Dla przykladu przypominam, ze system TEX jest dystrybuowny za darmo a systemy TEXtures (dla Maca) i Scientific Word (dla Windows), kosztuja kilkaset zlotych/egz. Mozna znalezc inne przyklady (Mosaic i Netscape, Linux ktory mozna sciagnac za darmo lub kupic CD-ROM z Linuxem, etc.)\r
+<li>Najwazniejszym efektem naszych prac powinny sie stac publikacje i komunikaty na konferencjach.\r
+<li>Publikacje te powinny prowadzic do potwierdzenia zdobytych kwalifikacji w postaci <em>stopni naukowych: magisteriow, doktoratow i habilitacji.</em>\r
+\r
+</ol>\r
+<p><h2>Co trzeba zrobic?</h2>\r
+<p> Zacznijmy od cytatu "apetyt rosnie w miare jedzenia". W naszym przypadku oznacza to, ze poczatkowa specyfikacja \r
+projektu (projektow) bedzie ulegac zmianom, rozszerzeniom.\r
+<p>\r
+<h3>Loglan'96 </h3>\r
+<p> Tu jest wiele do zrobienia:\r
+<ul>\r
+<li>projekt nowego jezyka i jego realizacja,<br>\r
+\r
+Nalezy wprowadzic troche niezbednych zmian i troche ulepszen.<br>\r
+Opracowac definicje semantyki jezyka (najlepiej podac aksjomatyczna definicje - to zadanie trudne ale mozliwe do zrealizowania),<br>\r
+Napisac kompilator w Loglanie. <em> Dlaczego w Loglanie?</em><br>\r
+Zaprojektowac nowy interpreter - L-maszyne <em> Dlaczego interpreter?</em><br>\r
+\r
+\r
+<li>rozwoj zastosowan obecnej wersji Loglanu i jej pielegnacja do czasu uruchomienia nowej wersji<br>\r
+Szczegolnie wazne jest dokonczenie prac nad wykonywaniem programow Loglanowskich w sieci maszyn w pelni heterogenicznej. Obecnie Loglan jest realizowany w sieci maszyn Unixowych (Sun, Apollo, Linux, SCO Unix etc). Dla uczelni wazne jest aby siec zawierala maszyny roznych platform (DOS, Windows, Unix...) <br>\r
+Ulepszenie predefiniowanych klas GRAFIKA i MYSZ. Szczegolnie dla X-windows. Obecne wersje nas nie zadowalaja.\r
+<li> opracowanie programu pracowni programowania obiektowego,<br>\r
+\r
+<li> opracowanie bardziej nowoczesnej wersji srodowiska Loglanu\r
+</ul>\r
+Idzie tu nie tylko o badania wdrozeniowe, ktorych cecha jest poszukiwanie odpowiedzi na pytanie: czy mozna zbudowac przedmiot (tu: software) o pozadanych (wyspecyfikowanych ) cechach.\r
+W projekcie mieszcza sie tez badania o charakterze podstawowym - poszukiwanie odpowiedzi na zasadnicze pytania zob. <a href="openpbms.htm">otwarte problemy </a><p>\r
+<h4 align=center>Ponizej przedstawiamy zestawienie zadan w trzech wiekszych grupach tematycznych.</h4> I nieco komentarzy.\r
+\r
+<table border>\r
+<tr ><th colspan=2><p>Loglan'96</th></tr>\r
+<tr><td>Przedyskutowac i zatwierdzic raport jezyka</td><td>uwaga.1sza wersja powinna byc gotowa szybko.\r
+Spodziewamy sie ze trzeba bedzie ja poprawic gdy beda pierwsze wyniki dot. implementacji</td></tr>\r
+<tr><td>Stworzyc opis jezyka</td><td> Chcielibysmy by byl to opis formalny, aksjomatyczny, wykorzystujacy aparature logiki algorytmicznej. Ale wymagac to bedzie rozwiazania nowych problemow. W szczegolnosci dotyczacych dziedziczenia klas.</td></tr>\r
+<tr><td> Stworzyc opis L-maszyny virtualnej czyli interpretera</td><td>Istnieje cenne opracowanie A. Kreczmara. Do niego trzeba by dodac: procesy i obiekty trwale (persistent object).</td></tr>\r
+<tr><td>Podac specyfikacje i zaimplementowac kompilator Loglanu'96 w Loglanie</td><td> Proponujemy by zastosowac metode zstepujacej rekursji. Zastanowic sie czy przy okazji nie da sie stworzyc modulu alternatywnego dla yacca i bisona. Mialoby to polegac na automatycznym tworzeniu klas i innych modulow (pierwszej czesci) kompilatora na podstawie gramatyki jezyka zapisanej w notacji EBNF.</td>\r
+</tr>\r
+<tr><td>Zbadac i zaproponowac nowa koncepcje biblioteki modulow predefiniowanych</td><td>Kazdy program jest domyslnie prefiksowany klasa BIBLIOTEKA<br>\r
+<strong>pref</strong> BIBLIOTEKA <strong>program</strong><em>jego nazwa</em>;<br>\r
+...<br><strong>end</strong>;<br>\r
+Dzieki temu moze dziedziczyc inne moduly zawarte w BIBLIOTECE. <em>Ale tylko te z pierwszego poziomu</em> zagniezdzenia.<br>\r
+Krotko mowiac, uwazamy ze nalezy pojecie biblioteki zorganizowac wokol pojec modul i <strong>klasa</strong>.\r
+ </td></tr>\r
+<tr><td>Zaimplementowac rozpraszanie procesow w sieci heterogenicznej. </td><td> Obecnie potrafimy rozpraszac procesy w sieci maszyn Unixowych. Najblizsze zadania polegaja na przeniesieniu obecnych rozwiazan na siec zawierajaca maszyny DOS i Windows, a takze na Novella i inne platformy. </td> </tr><tr> <td> Biblioteki uslug sieciowych dla programowania w Loglanie.</td> <td>Rozszerzyc zbior klas predefiniowanych o klase NETLIB umozliwiajaca korzystanie z protokolow sieciowych roznych warstw np. TCP/IP, FTP, HTTP, ... </td></tr><tr rowspan=2><th colspan=2>"<em>Stary</em>" Loglan</th></tr>\r
+\r
+<tr><td>Uporzadkowac dokumentacje </td><td>Np. wydac nowa wersje raportu jezyka. To juz jest zaawansowane. </td></tr>\r
+<tr><td>Ulepszyc srodowisko Loglanu </td><td>Np. poprawic edytor Lotek, lub napisac nowy<br>\r
+Rozwazyc ponowne wprowadzenie debuggera Teresy Przytyckiej. <br>\r
+Ujednolicic biblioteke graficzna: w tej chwili biblioteki dla DOSa i Xwindows bardzo sie roznia. Mozna napisac w Loglanie jedna wspolna "czapke". </td></tr>\r
+<tr><td>Uporzadkowac aplikacje i ich opisy </td><td><ol><li>Klasa simulation<li>Opracowac pracownie programowania dla wybranych przedmiotow np. algorytmy i struktury danych , programowanie wspolbiezne i rozproszone, etc.</ol> </td></tr>\r
+<tr> <th colspan=2>Nowe aplikacje</th></tr>\r
+<tr><td> CASE NT </td><td> zob. ponizej </td></tr>\r
+<tr><td> browser typu HotJava </td><td> to moze byc i ciekawe i pozyteczne </td></tr>\r
+<tr><td> Obiektowa baza danych </td><td> Tu jest sporo wynikow zespolu L. Banachowskiego trzeba to wykorzystac </td></tr>\r
+<tr><td> Nowa klasa simulation </td><td> Jak powinna wygladac symulacja przeprowadzana na maszynie wieloprocesorowej? Nie wiemy, ale podejrzewamy ze powinien powstac nowy uniwersalny modul. Jego specyfikacja nie jest dla nas ozywista. Symulacja wieloprocesorowa powinna byc bardziej wydajna za wzgledu na przyspieszenie ale moze tez wnosic i inne aporty. </td></tr>\r
+</table>\r
+Jest oczywiste ze ta tabela to tylko proba zorganizowania roznych zadan zwiazanych z naszym projektem. Bedzie sie ja rozbudowywac i zaopatrywac w odnosniki wskazujace na stan zaawansowania i adres osoby(osob) pracujacych nad zagadnieniem. \r
+<h3>CASE NT</h3>\r
+<p> Obecne systemy CASE sa drogie i nie dostarczaja zadnych narzedzi wpomagajacych analize poprawnosci\r
+powstajacego oprogramowania wzgledem jego specyfikacji. Gorzej, bo nie dostarczane sa narzedzia wspomagajace tworzenie specyfikacji ani tym bardziej ich analizy. Dzis czesto przez specyfikacje rozumie sie liste metod (operacji) czyli funkcji i procedur wraz z wyliczeniem typow argumentow i wynikow. To jest uproszczenie idace zbyt daleko. Mozna dolaczyc postulaty dotyczace tych procedur. Zapisane w jezyku etnicznym nie nadaja sie one do dalszego formalnego przetwarzania.<br>\r
+My mozemy sie wesprzec na naszych wlasnych wynikach dotyczacych specyfikacji. Nasza metoda specyfikacji zostala sprawdzona w kilku eksperymentach i cieszy sie nastepujacymi (meta)wlasnosciami:<br>\r
+<ul>\r
+<li> IDENTYFIKACJA - rozwiazujemy zadanie zidentyfikowania (specyfikacji) abstrakcyjnego typu danych,\r
+<li> PELNOSC - zbior prawdziwych wlasnosci programow wykonywanych w modelach specyfikacji jest rowny zbiorowi wlasnosci dowodliwych z aksjomatow,\r
+</ul> zatem \r
+<ul>\r
+<li> dostarcza KRYTERIUM AKCEPTOWALNOSCI modulow software'owych,\r
+<li> stanowi dobra baze dla weryfikacki wlasnosci dowodow (BAZA DOWODOW)\r
+</ul>\r
+Nowy system CASE powienen stac sie asystentem zespolu tworzacego oprogramowanie. Powinien nie tylko pamietac o sygnaturze modulow jakie maja powstac, ale i o wlasnosciach jakie maja byc zagwarantowane.<br>\r
+<p>Formalnym narzedziem powstajacego systemu CASE bedzie logika algorytmiczna. Rachunek ten w swiecie programowania ma do spelnienia role porownywalna z rola rachunku rozniczkowego i calkowego w tradycyjnej inzynierii mechanicznej czy elektrycznej.<br>\r
+Naszym zdaniem nowy system powinien przewyzszac dotychczas znane systemy i dostarczac narzedzi wspomagajacych dowodzenie wlasnosci programow z aksjomatow specyfikacji.<br>\r
+<strong>Zadania</strong> jakie sobie stawiamy to miedzy innymi opis abstrakcyjnego typu danych: SRODOWISKO DOWODOW FORMALNYCH Logiki Algorytmicznej i jego obiektowa realizacja. Nalezy wiec opisac typy danych np. formula, wezel drzewa dowodu, drzewo dowodu, etc.i operacje na nich. Zaprogramowac klasy i metody odpowiadajace opisanym typom i operacjom. Zaprogramowac przyjazne srodowisko asystujace dowodzeniu wlasnosci programow.\r
+ <H3> Algorytmy probabilistyczne </H3> Algorytmy probabilistyczne znajduja rozliczne zastosowania \r
+ (bardziej znane to np. symulacja i analiza procesow masowej \r
+ obslugi).\r
+<p><table border><tr><td>wyznaczanie prawdopodobienstw zachowan algorytmow \r
+ probabilistycznych dzialajacych na zbiorach skonczonych,</td><td>opracowanie oprogramowania (w Loglanie) umozliwiajacego wyznaczanie prawdopodobienstw zachowan algorytmow probabilistycznych (niezaleznie od symulacji ich dzialania)</td></tr><tr><td>zastosowanie algorytmow do zagadnien analizy informacji \r
+ niepewnej (porownanie z metoda zbiorow przyblizonych - \r
+ Z.Pawlak, A.Skowron), </td><td>w procesie analizy algorytmow probabilistycznych nasza uwaga skupiona jest wylacznie na stanach koncowych, np. proces wypracowania przyblizonych regul decyzyjnych (analogicznie: zasad wnioskowania statystycznego) dokonuje sie przy pomocy pewnego algorytmu probabilistycznego; poszczegolnym regulom odpowiadaja pewne stany koncowe,</td></tr>\r
+<tr><td>badanie zwiazkow miedzy algorytmami probabilistycznymi,\r
+ interpretowanymi w dziedzinach skonczonych, ze skonczenie \r
+ stanowymi lancuchami Markowa:</td><td>nawet w przypadku bardzo prostych iteracyjnych \r
+ algorytmow probabilistycznych, interpretowanych \r
+ w skonczonym zbiorze, odpowiadajacy lancuch Markowa \r
+ nie musi byc ergodyczny,<br> potrafimy juz wyznaczac prawdopodobienstwa przejsc \r
+ wylacznie do stanow koncowych, nawet w przypadku \r
+ lancuchow nieergodycznych.</td></tr></table>\r
+\r
+\r
+\r
+\r
+\r
+\r
+
+\r
+
+<p><h2>Czy trzeba biernie czekac na spotkanie?</h2>\r
+<p> Mamy nadzieje, ze nasza propozycja nie jest Ci obojetna. \r
+<ul>\r
+<li>Jesli jestes oponentem przyjdz na spotkanie lub napisz do nas.\r
+<li>Jesli wydaje Ci sie ze plan jest do przyjecia to zglos sie do nas nie czekajac.\r
+<li>Czekamy na wszelkie uwagi, propozycje, krytyke.\r
+</ul>\r
+<h3> Jesli nie jestes mieszkancem Bialegostoku to nie szkodzi.</h3> Mozemy pracowac razem na odleglosc. (Tak jak pracuja w projekcie Linux i in.). A moze zechcialbys przyjechac 27go? (czy mamy zalatwic nocleg?) \r
+<h3> Jesli czytasz te strony po 27 marca to: </h3>\r
+- przeczytaj <a href="sprawozda.htm">sprawozdanie </a> ze spotkania.<br>\r
+- <a href=mailto://salwicki@ii.pb.bialystok.pl">napisz do nas </a><br>\r
+<hr>\r
+<address> Last update Fri 1 Mar 1996 <br>\r
+<a href="mailto:Grazyna.Mirkowska@univ-pau.fr">Grazyna Mirkowska </a><br>\r
+<a href="mailto:salwicki@ii.pb.bialystok.pl"> Andrzej Salwicki </a>\r
+ </address>\r
+</body>\r
+</html>
\ No newline at end of file
--- /dev/null
+
+<HTML>
+
+<HEAD>
+
+</HEAD>
+
+<BODY>
+<h1>
+<IMG ALIGN=BOTTOM SRC = "http://aragorn.pb.bialystok.pl/../icons/at_work_btn.gif" >
+Sorry, page under construction !
+</h1>
+</BODY>
+
+</HTML>
+
+ÔÔ
--- /dev/null
+
+<HTML>
+
+<HEAD>
+
+</HEAD>
+
+<BODY>
+<h1>
+<IMG ALIGN=BOTTOM SRC = "../icons/at_work_btn.gif" >
+Sorry page under construction !
+</h1>
+</BODY>
+
+</HTML>
+
+Ô
\ No newline at end of file
--- /dev/null
+BLOCK \r
+(* BANK DEPARTMENT SERVICE SIMULATION *)\r
+ \r
+ \r
+ \r
+UNIT PRIORITYQUEUE: CLASS;\r
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+ \r
+ \r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+ \r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+END QUEUEHEAD;\r
+ \r
+ \r
+UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ \r
+UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+(*********************************************************************\r
+*********************************************************************) \r
+ \r
+#include "simula.inc" \r
+ \r
+UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+ \r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE FI;\r
+ END;\r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+ \r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT : PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+ \r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI FI;\r
+ END INTO;\r
+ END LINK;\r
+ \r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+ \r
+ END LISTS;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ (*BEGIN OF BANK DEPARTMENT SIMULATION *)\r
+ \r
+ \r
+ UNIT OFFICE:LISTS CLASS; (*AN OFFICE*)\r
+ \r
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);\r
+ (* TELLER WITH CUSTOMERS QUEUEING UP *)\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* SERVICE OF THIS TELLER WILL BE PRECISED LATER *)\r
+ END SERVICE;\r
+ VAR CSTM:CUSTOMER, (*THE CUSTOMER BEING SERVED*)\r
+ REST,PAUSE:REAL;\r
+ \r
+ BEGIN\r
+ PAUSE:=TIME;\r
+ DO\r
+ REST:=REST+TIME-PAUSE;\r
+ WHILE NOT QUEUE.EMPTY DO\r
+ (* SERVE ALL QUEUE *)\r
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;\r
+ CALL SERVICE;\r
+ CALL SCHEDULE(CSTM,TIME);\r
+ OD;\r
+ PAUSE:=TIME;\r
+ CALL PASSIVATE\r
+ OD;\r
+ END TILL;\r
+ \r
+ UNIT CUSTOMER:SIMPROCESS CLASS;\r
+ \r
+ VAR ELLIST:ELEM, K:INTEGER;\r
+ UNIT ARRIVAL:PROCEDURE(S:TILL);\r
+ (* ATTACHING TELLER S *)\r
+ BEGIN\r
+ IF S=/=NONE THEN\r
+ ELLIST:=NEW ELEM(THIS CUSTOMER);\r
+ CALL ELLIST.INTO(S.QUEUE);\r
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME) FI;\r
+ CALL PASSIVATE; FI;\r
+ END ARRIVAL;\r
+ END CUSTOMER;\r
+ \r
+ END OFFICE;\r
+ \r
+ \r
+ \r
+UNIT BANKDEPARTMENT:OFFICE CLASS;\r
+ \r
+ \r
+ UNIT COUNTER:TILL CLASS;\r
+ VAR PAYTIME:REAL; (*RANDOM SERVICE TIME*)\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ BEGIN\r
+ WRITELN(" THE PAY DESK SERVES CUSTOMER NO",CSTM.K,\r
+ " AT",TIME:10:4);\r
+ CALL CSTM.ELLIST.OUT;\r
+ PAYTIME:=RANDOM*2+2;\r
+ CALL HOLD(PAYTIME);\r
+ END SERVICE;\r
+ END COUNTER;\r
+ \r
+ \r
+ UNIT TELLER:TILL CLASS(NUMBER:INTEGER);\r
+ VAR SERVICETIME:REAL;\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ VAR N:INTEGER;\r
+ BEGIN\r
+ WRITELN(" THE TELLER NO",NUMBER," WAS IDLE FOR",REST:10:4,\r
+ " SEC");\r
+ CALL CSTM.ELLIST.OUT;\r
+ N:=CSTM QUA BANKCUSTOMER.NO;\r
+ WRITELN(" THE CUSTOMER NO",CSTM.K,\r
+ " BEGINS TO BE SERVED BY THE TELLER NO",NUMBER,\r
+ " AT",TIME:10:4);\r
+ ACCOUNT(N):=ACCOUNT(N)+CSTM QUA BANKCUSTOMER.AMOUNT;\r
+ IF ACCOUNT(N)<0 THEN CALL CSTM.ARRIVAL(CONTROL);FI;\r
+ SERVICETIME:=RANDOM*7+3;\r
+ CALL HOLD(SERVICETIME);\r
+ \r
+ END SERVICE;\r
+ END TELLER;\r
+ \r
+ \r
+ UNIT BANKCUSTOMER:CUSTOMER CLASS(NO:INTEGER,AMOUNT:REAL);\r
+ (* BANK CUSTOMER. AMOUNT- THE MONEY TO BE PAID AT THE BANK *)\r
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOOSETELLER:INTEGER;\r
+ BEGIN\r
+ I:=I+1;\r
+ K:=I;\r
+ ARRIVALTIME:=TIME;\r
+ WRITELN(" THE CUSTOMER NO",K," ARRIVED AT",TIME:10:4);\r
+ CHOOSETELLER:=RANDOM*5+1;\r
+ CALL ARRIVAL(TELLERS(CHOOSETELLER));\r
+ IF AMOUNT<0 THEN CALL ARRIVAL(CTR); FI;\r
+ STAYTIME:=TIME-ARRIVALTIME;\r
+ WRITELN(" THE CUSTOMER NO",K," STAYED AT THE BANK FOR",\r
+ STAYTIME:10:4," SEC; STATE OF ACCOUNT",ACCOUNT(NO):10:4);\r
+ END BANKCUSTOMER;\r
+ \r
+ VAR TELLERS:ARRAYOF TELLER,ACCOUNT:ARRAYOF REAL;\r
+ VAR CTR:COUNTER, CONTROL:TILL,I:INTEGER;\r
+ \r
+ BEGIN (* NEW BANK DEPARTMENT GENERATION *)\r
+ CTR:=NEW COUNTER(NEW HEAD);\r
+ ARRAY TELLERS DIM(1:5); (* WE DEAL WITH 5 TELLES *)\r
+ FOR I:=1 TO 5 DO TELLERS(I):=NEW TELLER(NEW HEAD,I); OD;\r
+ ARRAY ACCOUNT DIM(1:100);\r
+ (* WE DEAL WITH 100 ACOUNTS IN THIS BANK DEPARTMENT *)\r
+ FOR I:=1 TO 100 DO ACCOUNT(I):=RANDOM*901+100; OD;\r
+ (* AN ACCOUNT VALUE CAN FLUCTUATE FROM 100 TO 1000$ *)\r
+ I:=0;\r
+ END BANKDEPARTMENT;\r
+ \r
+ \r
+ \r
+ BEGIN (* OF PROGRAM *)\r
+ PREF BANKDEPARTMENT BLOCK\r
+ UNIT GENERATOR:SIMPROCESS CLASS;\r
+ (* CUSTOMERS GENERATION *)\r
+ BEGIN\r
+ DO\r
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,\r
+ RANDOM*9996+5),TIME);\r
+ CALL HOLD(RANDOM*10);\r
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,\r
+ -(RANDOM*900+5)),TIME);\r
+ CALL HOLD(RANDOM*10);\r
+ OD\r
+ END GENERATOR;\r
+ BEGIN\r
+ WRITELN(" BANK DEPARTMENT SERVICE SIMULATION");\r
+ WRITELN;\r
+ CALL SCHEDULE(NEW GENERATOR,TIME);\r
+ CALL HOLD (40);\r
+ END\r
+END \r
--- /dev/null
+rem IF:\r
+rem 1ø the programs: loglan.exe, gen.exe, int.exe are visible here\r
+rem 2ø the first parameter %1 of this command is the file \r
+rem containing what you believe a source of Loglan program\r
+rem THEN it may be useful to use this command cc\r
+\r
+loglan %1\r
+pause\r
+gen %1\r
+del %1.lcd\r
+int %1\r
--- /dev/null
+program essai;\r
+\r
+#include "var.inc";\r
+\r
+\r
+begin\r
+ writeln("give an integer");\r
+ readln(i);\r
+ writeln(i);\r
+end essai;\r
--- /dev/null
+@ECHO OFF\r
+set COMPILER_PATH=c:/loglan/exe/svga\r
+set TMPDIR=c:/tmp\r
+set GO32TMP=c:/tmp\r
+set GO32=driver c:/loglan/exe/386/ega16.grd gw 640 gh 348\r
+\r
--- /dev/null
+Program SystemedeFenetrage;\r
+Begin\r
+Pref iiuwgraph block\r
+ Begin\r
+ Pref mouse block\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* P r o g r a m m e P r i n c i p a l *)\r
+ (*****************************************************************************)\r
+ var v,p,h,i : integer,\r
+ l,r,c : integer,\r
+ rep : arrayof char,\r
+ d : boolean,\r
+ xx,yy : arrayof integer,\r
+ status,code,x,y,flags,button : integer;\r
+ \r
+ Begin\r
+ \r
+ call gron(0);\r
+ call init(1,0);\r
+ \r
+ call showcursor;\r
+ call patern(5,5,635,475,2,0);\r
+ call outstring(10,10,"x=",2,0);\r
+ call outstring(100,10,"y=",2,0);\r
+ call outstring(10,30,"status = ",2,0);\r
+ call outstring(10,50,"code = ",2,0);\r
+ call outstring(10,70,"flags = ",2,0);\r
+ call outstring(10,90,"button = ",2,0);\r
+ call patern(100,210,300,320,3,1);\r
+\r
+ array xx dim (1:6);\r
+ array yy dim (1:6);\r
+ xx(1):=410; yy(1):=10;\r
+ xx(2):=450; yy(2):=30;\r
+ xx(3):=460; yy(3):=50;\r
+ xx(4):=430; yy(4):=80;\r
+ xx(5):=420; yy(5):=40;\r
+ xx(6):=480; yy(6):=30;\r
+ call intens(6,xx,yy,8,1);\r
+ for i:=1 to 6\r
+ do\r
+ yy(i):=yy(i)+100;\r
+ od;\r
+ call intens(6,xx,yy,15,0);\r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0);\r
+ call cirb(400,400,40,40,600,4000,11,1);\r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); \r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); \r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15);\r
+ \r
+ call getmovement(1,1); \r
+ \r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if (d)\r
+ then call outstring(10,400,"Event",2,0);\r
+ call patern(80,25,130,100,0,1);\r
+ call track(40,10,v,0,4);\r
+ call track(140,10,p,0,4);\r
+ call track(80,30,h,0,4);\r
+ call track(80,50,l,0,4);\r
+ call track(80,70,r,0,4);\r
+ call track(80,90,c,0,4);\r
+ if((h=164 and l=27) or (c=3))\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call groff;\r
+ writeln("i=",i);\r
+ for i:=lower(rep) to upper(rep)\r
+ do\r
+ write(rep(i));\r
+ od;\r
+ writeln;\r
+ End\r
+ End\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+Make sure that the directory\r
+\r
+ c:\tmp\r
+exists. It is needed for the correct behaviour of programs.\r
+Don't worry. You have nothing to do in it!\r
+\r
+\r
+\r
+\r
--- /dev/null
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS : COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ BEGIN\r
+ \r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+ \r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ \r
+UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)\r
+ (* WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+END SCHEDULE;\r
+ \r
+UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+\r
+ \r
--- /dev/null
+var j : real;\r
+var i : integer;\r
--- /dev/null
+BLOCK \r
+(* BANK DEPARTMENT SERVICE SIMULATION *)\r
+ \r
+ \r
+ \r
+UNIT PRIORITYQUEUE: CLASS;\r
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+ \r
+ \r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+ \r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+END QUEUEHEAD;\r
+ \r
+ \r
+UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ \r
+UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+(*********************************************************************\r
+*********************************************************************) \r
+ \r
+#include "simula.inc" \r
+ \r
+UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+ \r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE FI;\r
+ END;\r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+ \r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT : PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+ \r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI FI;\r
+ END INTO;\r
+ END LINK;\r
+ \r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+ \r
+ END LISTS;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ (*BEGIN OF BANK DEPARTMENT SIMULATION *)\r
+ \r
+ \r
+ UNIT OFFICE:LISTS CLASS; (*AN OFFICE*)\r
+ \r
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);\r
+ (* TELLER WITH CUSTOMERS QUEUEING UP *)\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* SERVICE OF THIS TELLER WILL BE PRECISED LATER *)\r
+ END SERVICE;\r
+ VAR CSTM:CUSTOMER, (*THE CUSTOMER BEING SERVED*)\r
+ REST,PAUSE:REAL;\r
+ \r
+ BEGIN\r
+ PAUSE:=TIME;\r
+ DO\r
+ REST:=REST+TIME-PAUSE;\r
+ WHILE NOT QUEUE.EMPTY DO\r
+ (* SERVE ALL QUEUE *)\r
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;\r
+ CALL SERVICE;\r
+ CALL SCHEDULE(CSTM,TIME);\r
+ OD;\r
+ PAUSE:=TIME;\r
+ CALL PASSIVATE\r
+ OD;\r
+ END TILL;\r
+ \r
+ UNIT CUSTOMER:SIMPROCESS CLASS;\r
+ \r
+ VAR ELLIST:ELEM, K:INTEGER;\r
+ UNIT ARRIVAL:PROCEDURE(S:TILL);\r
+ (* ATTACHING TELLER S *)\r
+ BEGIN\r
+ IF S=/=NONE THEN\r
+ ELLIST:=NEW ELEM(THIS CUSTOMER);\r
+ CALL ELLIST.INTO(S.QUEUE);\r
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME) FI;\r
+ CALL PASSIVATE; FI;\r
+ END ARRIVAL;\r
+ END CUSTOMER;\r
+ \r
+ END OFFICE;\r
+ \r
+ \r
+ \r
+UNIT BANKDEPARTMENT:OFFICE CLASS;\r
+ \r
+ \r
+ UNIT COUNTER:TILL CLASS;\r
+ VAR PAYTIME:REAL; (*RANDOM SERVICE TIME*)\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ BEGIN\r
+ WRITELN(" THE PAY DESK SERVES CUSTOMER NO",CSTM.K,\r
+ " AT",TIME:10:4);\r
+ CALL CSTM.ELLIST.OUT;\r
+ PAYTIME:=RANDOM*2+2;\r
+ CALL HOLD(PAYTIME);\r
+ END SERVICE;\r
+ END COUNTER;\r
+ \r
+ \r
+ UNIT TELLER:TILL CLASS(NUMBER:INTEGER);\r
+ VAR SERVICETIME:REAL;\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ VAR N:INTEGER;\r
+ BEGIN\r
+ WRITELN(" THE TELLER NO",NUMBER," WAS IDLE FOR",REST:10:4,\r
+ " SEC");\r
+ CALL CSTM.ELLIST.OUT;\r
+ N:=CSTM QUA BANKCUSTOMER.NO;\r
+ WRITELN(" THE CUSTOMER NO",CSTM.K,\r
+ " BEGINS TO BE SERVED BY THE TELLER NO",NUMBER,\r
+ " AT",TIME:10:4);\r
+ ACCOUNT(N):=ACCOUNT(N)+CSTM QUA BANKCUSTOMER.AMOUNT;\r
+ IF ACCOUNT(N)<0 THEN CALL CSTM.ARRIVAL(CONTROL);FI;\r
+ SERVICETIME:=RANDOM*7+3;\r
+ CALL HOLD(SERVICETIME);\r
+ \r
+ END SERVICE;\r
+ END TELLER;\r
+ \r
+ \r
+ UNIT BANKCUSTOMER:CUSTOMER CLASS(NO:INTEGER,AMOUNT:REAL);\r
+ (* BANK CUSTOMER. AMOUNT- THE MONEY TO BE PAID AT THE BANK *)\r
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOOSETELLER:INTEGER;\r
+ BEGIN\r
+ I:=I+1;\r
+ K:=I;\r
+ ARRIVALTIME:=TIME;\r
+ WRITELN(" THE CUSTOMER NO",K," ARRIVED AT",TIME:10:4);\r
+ CHOOSETELLER:=RANDOM*5+1;\r
+ CALL ARRIVAL(TELLERS(CHOOSETELLER));\r
+ IF AMOUNT<0 THEN CALL ARRIVAL(CTR); FI;\r
+ STAYTIME:=TIME-ARRIVALTIME;\r
+ WRITELN(" THE CUSTOMER NO",K," STAYED AT THE BANK FOR",\r
+ STAYTIME:10:4," SEC; STATE OF ACCOUNT",ACCOUNT(NO):10:4);\r
+ END BANKCUSTOMER;\r
+ \r
+ VAR TELLERS:ARRAYOF TELLER,ACCOUNT:ARRAYOF REAL;\r
+ VAR CTR:COUNTER, CONTROL:TILL,I:INTEGER;\r
+ \r
+ BEGIN (* NEW BANK DEPARTMENT GENERATION *)\r
+ CTR:=NEW COUNTER(NEW HEAD);\r
+ ARRAY TELLERS DIM(1:5); (* WE DEAL WITH 5 TELLES *)\r
+ FOR I:=1 TO 5 DO TELLERS(I):=NEW TELLER(NEW HEAD,I); OD;\r
+ ARRAY ACCOUNT DIM(1:100);\r
+ (* WE DEAL WITH 100 ACOUNTS IN THIS BANK DEPARTMENT *)\r
+ FOR I:=1 TO 100 DO ACCOUNT(I):=RANDOM*901+100; OD;\r
+ (* AN ACCOUNT VALUE CAN FLUCTUATE FROM 100 TO 1000$ *)\r
+ I:=0;\r
+ END BANKDEPARTMENT;\r
+ \r
+ \r
+ \r
+ BEGIN (* OF PROGRAM *)\r
+ PREF BANKDEPARTMENT BLOCK\r
+ UNIT GENERATOR:SIMPROCESS CLASS;\r
+ (* CUSTOMERS GENERATION *)\r
+ BEGIN\r
+ DO\r
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,\r
+ RANDOM*9996+5),TIME);\r
+ CALL HOLD(RANDOM*10);\r
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,\r
+ -(RANDOM*900+5)),TIME);\r
+ CALL HOLD(RANDOM*10);\r
+ OD\r
+ END GENERATOR;\r
+ BEGIN\r
+ WRITELN(" BANK DEPARTMENT SERVICE SIMULATION");\r
+ WRITELN;\r
+ CALL SCHEDULE(NEW GENERATOR,TIME);\r
+ CALL HOLD (40);\r
+ END\r
+END \r
--- /dev/null
+rem IF:\r
+rem 1ø the programs: loglan.exe, gen.exe, int.exe are visible here\r
+rem 2ø the first parameter %1 of this command is the file \r
+rem containing what you believe a source of Loglan program\r
+rem THEN it may be useful to use this command cc\r
+\r
+loglan %1\r
+pause\r
+gen %1\r
+del %1.lcd\r
+int %1\r
--- /dev/null
+program essai;\r
+\r
+#include "var.inc";\r
+\r
+\r
+begin\r
+ writeln("give an integer");\r
+ readln(i);\r
+ writeln(i);\r
+end essai;\r
--- /dev/null
+@ECHO OFF\r
+set COMPILER_PATH=c:/loglan/exe/svga\r
+set TMPDIR=c:/tmp\r
+set GO32TMP=c:/tmp\r
+set GO32=driver c:/loglan/exe/386/ega16.grd gw 640 gh 348\r
+\r
--- /dev/null
+Tu znajdziesz wersje kompilatora loglanu\r
+dopuszczajaca\r
+\r
+#include\r
+\r
+i grafike w wersji najnowszej Pataud.\r
+\r
--- /dev/null
+c:\loglan\exe\loglan %1\r
+pause\r
+c:\loglan\exe\gen %1\r
+del %1.lcd\r
+c:\loglan\exe\int %1\r
--- /dev/null
+@ECHO OFF\r
+set TMPDIR=c:/tmp\r
+set GO32TMP=c:/tmp\r
+set GO32=driver emu387 c:/loglan/exe/stdvga.grn gw 640 gh 480\r
+rem path f:\loglan\exe\386;f:\loglan\lotek;%path%
\ No newline at end of file
--- /dev/null
+Program SystemedeFenetrage;\r
+Begin\r
+Pref iiuwgraph block\r
+ Begin\r
+ Pref mouse block\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* P r o g r a m m e P r i n c i p a l *)\r
+ (*****************************************************************************)\r
+ var v,p,h,i : integer,\r
+ l,r,c : integer,\r
+ rep : arrayof char,\r
+ d : boolean,\r
+ xx,yy : arrayof integer,\r
+ status,code,x,y,flags,button : integer;\r
+ \r
+ Begin\r
+ \r
+ call gron(0);\r
+ call init(1,0);\r
+ \r
+ call showcursor;\r
+ call patern(5,5,635,475,2,0);\r
+ call outstring(10,10,"x=",2,0);\r
+ call outstring(100,10,"y=",2,0);\r
+ call outstring(10,30,"status = ",2,0);\r
+ call outstring(10,50,"code = ",2,0);\r
+ call outstring(10,70,"flags = ",2,0);\r
+ call outstring(10,90,"button = ",2,0);\r
+ call patern(100,210,300,320,3,1);\r
+\r
+ array xx dim (1:6);\r
+ array yy dim (1:6);\r
+ xx(1):=410; yy(1):=10;\r
+ xx(2):=450; yy(2):=30;\r
+ xx(3):=460; yy(3):=50;\r
+ xx(4):=430; yy(4):=80;\r
+ xx(5):=420; yy(5):=40;\r
+ xx(6):=480; yy(6):=30;\r
+ call intens(6,xx,yy,8,1);\r
+ for i:=1 to 6\r
+ do\r
+ yy(i):=yy(i)+100;\r
+ od;\r
+ call intens(6,xx,yy,15,0);\r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0);\r
+ call cirb(400,400,40,40,600,4000,11,1);\r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); \r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); \r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15);\r
+ \r
+ call getmovement(1,1); \r
+ \r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if (d)\r
+ then call outstring(10,400,"Event",2,0);\r
+ call patern(80,25,130,100,0,1);\r
+ call track(40,10,v,0,4);\r
+ call track(140,10,p,0,4);\r
+ call track(80,30,h,0,4);\r
+ call track(80,50,l,0,4);\r
+ call track(80,70,r,0,4);\r
+ call track(80,90,c,0,4);\r
+ if((h=164 and l=27) or (c=3))\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call groff;\r
+ writeln("i=",i);\r
+ for i:=lower(rep) to upper(rep)\r
+ do\r
+ write(rep(i));\r
+ od;\r
+ writeln;\r
+ End\r
+ End\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+Make sure that the directory\r
+\r
+ c:\tmp\r
+exists. It is needed for the correct behaviour of programs.\r
+Don't worry. You have nothing to do in it!\r
+\r
+\r
+\r
+\r
--- /dev/null
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS : COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ BEGIN\r
+ \r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+ \r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ \r
+UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)\r
+ (* WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+END SCHEDULE;\r
+ \r
+UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+\r
+ \r
--- /dev/null
+var j : real;\r
+var i : integer;\r
--- /dev/null
+
+<HTML>
+
+<HEAD>
+<TITLE>LOGLAN '96 Project</TITLE>
+
+</HEAD>
+
+<BODY>
+
+
+
+<IMG ALT="intro" border="0" SRC="intro.gif" usemap="#indexmap" ISMAP>
+
+
+<MAP name="indexmap">
+<area shape=rect href=/~swida/research.html coords="385,10 549,57">
+<!area shape=rect href= coords="84,59 228,103"> <! Editor>
+<!area shape=rect href= coords="13,326 234,349"> <! Compilator>
+<!--area shape=circle href=about.html coords="267,113 300,180"-->
+</map>
+
+
+
+
+
+
+ <center> <h1>LOGLAN '96 PROJECT </h1> </center>
+<IMG ALIGN=BOTTOM SRC="/icons/linecolor.gif" >
+<p>
+This project consist of several research problems:
+
+<UL>
+<LI><a href="/~swida/research.html"><B> NVLP </B> Network Virtual Loglan Processor</a>
+<LI><a href="">New Loglan Compilator</a>
+<LI><a href="">Integrated Loglan Editor</a>
+</UL>
+
+
+</BODY>
+
+</HTML>
+
+
--- /dev/null
+
+<HTML>
+
+<HEAD>
+<TITLE>LOGLAN '96 Project</TITLE>
+
+</HEAD>
+
+<BODY>
+
+
+
+<IMG ALT="intro" border="0" SRC="intro.gif" usemap="#indexmap" ISMAP>
+
+
+<MAP name="indexmap">
+<area shape=rect href=/~swida/research.html coords="385,15 400,57">
+<!area shape=rect href= coords="84,59 228,103"> <! Editor>
+<!area shape=rect href= coords="13,326 234,349"> <! Compilator>
+<!--area shape=circle href=about.html coords="267,113 300,180"-->
+</map>
+
+
+
+
+
+
+ <center> <h1>LOGLAN '96 PROJECT </h1> </center>
+<IMG ALIGN=BOTTOM SRC="/icons/linecolor.gif" >
+<p>
+This project consist of several research problems:
+
+<UL>
+<LI><a href="/~swida/research.html"><B> NVLP </B> Network Virtual Loglan Processor</a>
+<LI><a href="">New Loglan Compilator</a>
+<LI><a href="">Integrated Loglan Editor</a>
+</UL>
+
+
+</BODY>
+
+</HTML>
+
+
--- /dev/null
+
+<HTML>
+
+<HEAD>
+<TITLE>LOGLAN '96 Project</TITLE>
+
+</HEAD>
+
+<BODY>
+
+ <center> <h1>LOGLAN '96 PROJECT </h1> </center>
+<IMG ALIGN=BOTTOM SRC="/icons/linecolor.gif" >
+<p>
+This project consist of several research problems:
+
+<UL>
+<LI><a href="/~swida/research.html">Network Virtual Object Processor</a>
+<LI><a href="">New Loglan Compilator</a>
+<LI><a href="">Integrated Loglan Editor</a>
+</UL>
+
+
+</BODY>
+
+</HTML>
+
+
+p
--- /dev/null
+/~swida/research.html
+
--- /dev/null
+
+<HTML>
+
+<HEAD>
+
+</HEAD>
+
+<BODY>
+<h1>
+<IMG ALIGN=BOTTOM SRC = "http://aragorn.pb.bialystok.pl/../icons/at_work_btn.gif" >
+Sorry page under construction !
+</h1>
+</BODY>
+
+</HTML>
+
+ÔÔ
\ No newline at end of file
--- /dev/null
+
+<HTML>
+
+<HEAD>
+
+</HEAD>
+
+<BODY>
+<h1>
+<IMG ALIGN=BOTTOM SRC = "../icons/at_work_btn.gif" >
+Sorry page under construction !
+</h1>
+</BODY>
+
+</HTML>
+
+Ô
\ No newline at end of file
--- /dev/null
+\ 4%!PS-Adobe-3.0\r
+%%Creator: Windows PSCRIPT\r
+%%Title: Microsoft Word - ATARI.DOC\r
+%%BoundingBox: 9 15 584 830\r
+%%DocumentNeededResources: (atend)\r
+%%DocumentSuppliedResources: (atend)\r
+%%Pages: (atend)\r
+%%BeginResource: procset Win35Dict 3 1\r
+/Win35Dict 290 dict def Win35Dict begin/bd{bind def}bind def/in{72\r
+mul}bd/ed{exch def}bd/ld{load def}bd/tr/translate ld/gs/gsave ld/gr\r
+/grestore ld/M/moveto ld/L/lineto ld/rmt/rmoveto ld/rlt/rlineto ld\r
+/rct/rcurveto ld/st/stroke ld/n/newpath ld/sm/setmatrix ld/cm/currentmatrix\r
+ld/cp/closepath ld/ARC/arcn ld/TR{65536 div}bd/lj/setlinejoin ld/lc\r
+/setlinecap ld/ml/setmiterlimit ld/sl/setlinewidth ld/scignore false\r
+def/sc{scignore{pop pop pop}{0 index 2 index eq 2 index 4 index eq\r
+and{pop pop 255 div setgray}{3{255 div 3 1 roll}repeat setrgbcolor}ifelse}ifelse}bd\r
+/FC{bR bG bB sc}bd/fC{/bB ed/bG ed/bR ed}bd/HC{hR hG hB sc}bd/hC{\r
+/hB ed/hG ed/hR ed}bd/PC{pR pG pB sc}bd/pC{/pB ed/pG ed/pR ed}bd/sM\r
+matrix def/PenW 1 def/iPen 5 def/mxF matrix def/mxE matrix def/mxUE\r
+matrix def/mxUF matrix def/fBE false def/iDevRes 72 0 matrix defaultmatrix\r
+dtransform dup mul exch dup mul add sqrt def/fPP false def/SS{fPP{\r
+/SV save def}{gs}ifelse}bd/RS{fPP{SV restore}{gr}ifelse}bd/EJ{gsave\r
+showpage grestore}bd/#C{userdict begin/#copies ed end}bd/FEbuf 2 string\r
+def/FEglyph(G )def/FE{1 exch{dup 16 FEbuf cvrs FEglyph exch 1 exch\r
+putinterval 1 index exch FEglyph cvn put}for}bd/SM{/iRes ed/cyP ed\r
+/cxPg ed/cyM ed/cxM ed 72 100 div dup scale dup 0 ne{90 eq{cyM exch\r
+0 eq{cxM exch tr -90 rotate -1 1 scale}{cxM cxPg add exch tr +90 rotate}ifelse}{cyP\r
+cyM sub exch 0 ne{cxM exch tr -90 rotate}{cxM cxPg add exch tr -90\r
+rotate 1 -1 scale}ifelse}ifelse}{pop cyP cyM sub exch 0 ne{cxM cxPg\r
+add exch tr 180 rotate}{cxM exch tr 1 -1 scale}ifelse}ifelse 100 iRes\r
+div dup scale 0 0 transform .25 add round .25 sub exch .25 add round\r
+.25 sub exch itransform translate}bd/SJ{1 index 0 eq{pop pop/fBE false\r
+def}{1 index/Break ed div/dxBreak ed/fBE true def}ifelse}bd/ANSIVec[\r
+16#0/grave 16#1/acute 16#2/circumflex 16#3/tilde 16#4/macron 16#5/breve\r
+16#6/dotaccent 16#7/dieresis 16#8/ring 16#9/cedilla 16#A/hungarumlaut\r
+16#B/ogonek 16#C/caron 16#D/dotlessi 16#27/quotesingle 16#60/grave\r
+16#7C/bar 16#82/quotesinglbase 16#83/florin 16#84/quotedblbase 16#85\r
+/ellipsis 16#86/dagger 16#87/daggerdbl 16#89/perthousand 16#8A/Scaron\r
+16#8B/guilsinglleft 16#8C/OE 16#91/quoteleft 16#92/quoteright 16#93\r
+/quotedblleft 16#94/quotedblright 16#95/bullet 16#96/endash 16#97\r
+/emdash 16#99/trademark 16#9A/scaron 16#9B/guilsinglright 16#9C/oe\r
+16#9F/Ydieresis 16#A0/space 16#A4/currency 16#A6/brokenbar 16#A7/section\r
+16#A8/dieresis 16#A9/copyright 16#AA/ordfeminine 16#AB/guillemotleft\r
+16#AC/logicalnot 16#AD/hyphen 16#AE/registered 16#AF/macron 16#B0/degree\r
+16#B1/plusminus 16#B2/twosuperior 16#B3/threesuperior 16#B4/acute 16#B5\r
+/mu 16#B6/paragraph 16#B7/periodcentered 16#B8/cedilla 16#B9/onesuperior\r
+16#BA/ordmasculine 16#BB/guillemotright 16#BC/onequarter 16#BD/onehalf\r
+16#BE/threequarters 16#BF/questiondown 16#C0/Agrave 16#C1/Aacute 16#C2\r
+/Acircumflex 16#C3/Atilde 16#C4/Adieresis 16#C5/Aring 16#C6/AE 16#C7\r
+/Ccedilla 16#C8/Egrave 16#C9/Eacute 16#CA/Ecircumflex 16#CB/Edieresis\r
+16#CC/Igrave 16#CD/Iacute 16#CE/Icircumflex 16#CF/Idieresis 16#D0/Eth\r
+16#D1/Ntilde 16#D2/Ograve 16#D3/Oacute 16#D4/Ocircumflex 16#D5/Otilde\r
+16#D6/Odieresis 16#D7/multiply 16#D8/Oslash 16#D9/Ugrave 16#DA/Uacute\r
+16#DB/Ucircumflex 16#DC/Udieresis 16#DD/Yacute 16#DE/Thorn 16#DF/germandbls\r
+16#E0/agrave 16#E1/aacute 16#E2/acircumflex 16#E3/atilde 16#E4/adieresis\r
+16#E5/aring 16#E6/ae 16#E7/ccedilla 16#E8/egrave 16#E9/eacute 16#EA\r
+/ecircumflex 16#EB/edieresis 16#EC/igrave 16#ED/iacute 16#EE/icircumflex\r
+16#EF/idieresis 16#F0/eth 16#F1/ntilde 16#F2/ograve 16#F3/oacute 16#F4\r
+/ocircumflex 16#F5/otilde 16#F6/odieresis 16#F7/divide 16#F8/oslash\r
+16#F9/ugrave 16#FA/uacute 16#FB/ucircumflex 16#FC/udieresis 16#FD/yacute\r
+16#FE/thorn 16#FF/ydieresis ] def/reencdict 12 dict def/IsChar{basefontdict\r
+/CharStrings get exch known}bd/MapCh{dup IsChar not{pop/bullet}if\r
+newfont/Encoding get 3 1 roll put}bd/MapDegree{16#b0/degree IsChar{\r
+/degree}{/ring}ifelse MapCh}bd/MapBB{16#a6/brokenbar IsChar{/brokenbar}{\r
+/bar}ifelse MapCh}bd/ANSIFont{reencdict begin/newfontname ed/basefontname\r
+ed FontDirectory newfontname known not{/basefontdict basefontname findfont\r
+def/newfont basefontdict maxlength dict def basefontdict{exch dup/FID\r
+ne{dup/Encoding eq{exch dup length array copy newfont 3 1 roll put}{exch\r
+newfont 3 1 roll put}ifelse}{pop pop}ifelse}forall newfont/FontName\r
+newfontname put 127 1 159{newfont/Encoding get exch/bullet put}for\r
+ANSIVec aload pop ANSIVec length 2 idiv{MapCh}repeat MapDegree MapBB\r
+newfontname newfont definefont pop}if newfontname end}bd/SB{FC/ULlen\r
+ed/str ed str length fBE not{dup 1 gt{1 sub}if}if/cbStr ed/dxGdi ed\r
+/y0 ed/x0 ed str stringwidth dup 0 ne{/y1 ed/x1 ed y1 y1 mul x1 x1\r
+mul add sqrt dxGdi exch div 1 sub dup x1 mul cbStr div exch y1 mul\r
+cbStr div}{exch abs neg dxGdi add cbStr div exch}ifelse/dyExtra ed\r
+/dxExtra ed x0 y0 M fBE{dxBreak 0 BCh dxExtra dyExtra str awidthshow}{dxExtra\r
+dyExtra str ashow}ifelse fUL{x0 y0 M dxUL dyUL rmt ULlen fBE{Break\r
+add}if 0 mxUE transform gs rlt cyUL sl [] 0 setdash st gr}if fSO{x0\r
+y0 M dxSO dySO rmt ULlen fBE{Break add}if 0 mxUE transform gs rlt cyUL\r
+sl [] 0 setdash st gr}if n/fBE false def}bd/font{/name ed/Ascent ed\r
+0 ne/fT3 ed 0 ne/fSO ed 0 ne/fUL ed/Sy ed/Sx ed 10.0 div/ori ed -10.0\r
+div/esc ed/BCh ed name findfont/xAscent 0 def/yAscent Ascent def/ULesc\r
+esc def ULesc mxUE rotate pop fT3{/esc 0 def xAscent yAscent mxUE transform\r
+/yAscent ed/xAscent ed}if [Sx 0 0 Sy neg xAscent yAscent] esc mxE\r
+rotate mxF concatmatrix makefont setfont [Sx 0 0 Sy neg 0 Ascent] mxUE\r
+mxUF concatmatrix pop fUL{currentfont dup/FontInfo get/UnderlinePosition\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlinePosition get\r
+1000 div 0 exch mxUF transform/dyUL ed/dxUL ed}if fSO{0 .3 mxUF transform\r
+/dySO ed/dxSO ed}if fUL fSO or{currentfont dup/FontInfo get/UnderlineThickness\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlineThickness get\r
+1000 div Sy mul/cyUL ed}if}bd/min{2 copy gt{exch}if pop}bd/max{2 copy\r
+lt{exch}if pop}bd/CP{/ft ed{{ft 0 eq{clip}{eoclip}ifelse}stopped{currentflat\r
+1 add setflat}{exit}ifelse}loop}bd/patfont 10 dict def patfont begin\r
+/FontType 3 def/FontMatrix [1 0 0 -1 0 0] def/FontBBox [0 0 16 16]\r
+def/Encoding StandardEncoding def/BuildChar{pop pop 16 0 0 0 16 16\r
+setcachedevice 16 16 false [1 0 0 1 .25 .25]{pat}imagemask}bd end/p{\r
+/pat 32 string def{}forall 0 1 7{dup 2 mul pat exch 3 index put dup\r
+2 mul 1 add pat exch 3 index put dup 2 mul 16 add pat exch 3 index\r
+put 2 mul 17 add pat exch 2 index put pop}for}bd/pfill{/PatFont patfont\r
+definefont setfont/ch(AAAA)def X0 64 X1{Y1 -16 Y0{1 index exch M ch\r
+show}for pop}for}bd/vert{X0 w X1{dup Y0 M Y1 L st}for}bd/horz{Y0 w\r
+Y1{dup X0 exch M X1 exch L st}for}bd/fdiag{X0 w X1{Y0 M X1 X0 sub dup\r
+rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup rlt st}for}bd/bdiag{X0 w\r
+X1{Y1 M X1 X0 sub dup neg rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup\r
+neg rlt st}for}bd/AU{1 add cvi 15 or}bd/AD{1 sub cvi -16 and}bd/SHR{pathbbox\r
+AU/Y1 ed AU/X1 ed AD/Y0 ed AD/X0 ed}bd/hfill{/w iRes 37.5 div round\r
+def 0.1 sl [] 0 setdash n dup 0 eq{horz}if dup 1 eq{vert}if dup 2 eq{fdiag}if\r
+dup 3 eq{bdiag}if dup 4 eq{horz vert}if 5 eq{fdiag bdiag}if}bd/F{/ft\r
+ed fm 256 and 0 ne{gs FC ft 0 eq{fill}{eofill}ifelse gr}if fm 1536\r
+and 0 ne{SHR gs HC ft CP fm 1024 and 0 ne{/Tmp save def pfill Tmp restore}{fm\r
+15 and hfill}ifelse gr}if}bd/S{PenW sl PC st}bd/m matrix def/GW{iRes\r
+12 div PenW add cvi}bd/DoW{iRes 50 div PenW add cvi}bd/DW{iRes 8 div\r
+PenW add cvi}bd/SP{/PenW ed/iPen ed iPen 0 eq iPen 6 eq or{[] 0 setdash}if\r
+iPen 1 eq{[DW GW] 0 setdash}if iPen 2 eq{[DoW GW] 0 setdash}if iPen\r
+3 eq{[DW GW DoW GW] 0 setdash}if iPen 4 eq{[DW GW DoW GW DoW GW] 0\r
+setdash}if}bd/E{m cm pop tr scale 1 0 moveto 0 0 1 0 360 arc cp m sm}bd\r
+/AG{/sy ed/sx ed sx div 4 1 roll sy div 4 1 roll sx div 4 1 roll sy\r
+div 4 1 roll atan/a2 ed atan/a1 ed sx sy scale a1 a2 ARC}def/A{m cm\r
+pop tr AG m sm}def/P{m cm pop tr 0 0 M AG cp m sm}def/RRect{n 4 copy\r
+M 3 1 roll exch L 4 2 roll L L cp}bd/RRCC{/r ed/y1 ed/x1 ed/y0 ed/x0\r
+ed x0 x1 add 2 div y0 M x1 y0 x1 y1 r arcto 4{pop}repeat x1 y1 x0 y1\r
+r arcto 4{pop}repeat x0 y1 x0 y0 r arcto 4{pop}repeat x0 y0 x1 y0 r\r
+arcto 4{pop}repeat cp}bd/RR{2 copy 0 eq exch 0 eq or{pop pop RRect}{2\r
+copy eq{pop RRCC}{m cm pop/y2 ed/x2 ed/ys y2 x2 div 1 max def/xs x2\r
+y2 div 1 max def/y1 exch ys div def/x1 exch xs div def/y0 exch ys div\r
+def/x0 exch xs div def/r2 x2 y2 min def xs ys scale x0 x1 add 2 div\r
+y0 M x1 y0 x1 y1 r2 arcto 4{pop}repeat x1 y1 x0 y1 r2 arcto 4{pop}repeat\r
+x0 y1 x0 y0 r2 arcto 4{pop}repeat x0 y0 x1 y0 r2 arcto 4{pop}repeat\r
+m sm cp}ifelse}ifelse}bd/PP{{rlt}repeat}bd/OB{gs 0 ne{7 3 roll/y ed\r
+/x ed x y translate ULesc rotate x neg y neg translate x y 7 -3 roll}if\r
+sc B fill gr}bd/B{M/dy ed/dx ed dx 0 rlt 0 dy rlt dx neg 0 rlt cp}bd\r
+/CB{B clip n}bd/ErrHandler{errordict dup maxlength exch length gt\r
+dup{errordict begin}if/errhelpdict 12 dict def errhelpdict begin/stackunderflow(operand stack underflow)def\r
+/undefined(this name is not defined in a dictionary)def/VMerror(you have used up all the printer's memory)def\r
+/typecheck(operator was expecting a different type of operand)def\r
+/ioerror(input/output error occured)def end{end}if errordict begin\r
+/handleerror{$error begin newerror{/newerror false def showpage 72\r
+72 scale/x .25 def/y 9.6 def/Helvetica findfont .2 scalefont setfont\r
+x y moveto(Offending Command = )show/command load{dup type/stringtype\r
+ne{(max err string)cvs}if show}exec/y y .2 sub def x y moveto(Error = )show\r
+errorname{dup type dup( max err string )cvs show( : )show/stringtype\r
+ne{( max err string )cvs}if show}exec errordict begin errhelpdict errorname\r
+known{x 1 add y .2 sub moveto errhelpdict errorname get show}if end\r
+/y y .4 sub def x y moveto(Stack =)show ostack{/y y .2 sub def x 1\r
+add y moveto dup type/stringtype ne{( max err string )cvs}if show}forall\r
+showpage}if end}def end}bd end\r
+%%EndResource\r
+/SVDoc save def\r
+%%EndProlog\r
+%%BeginSetup\r
+Win35Dict begin\r
+ErrHandler\r
+statusdict begin 0 setjobtimeout end\r
+statusdict begin statusdict /jobname (Microsoft Word - ATARI.DOC) put end\r
+/oldDictCnt countdictstack def {statusdict begin 0 setpapertray end\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+/oldDictCnt countdictstack def {a4\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+[{ }\r
+/exec load currenttransfer /exec load] cvx settransfer\r
+/setresolution where { pop 300 300 setresolution } if\r
+%%EndSetup\r
+%%Page: 1 1\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 92 92 0 0 0 90 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+0 0 0 fC\r
+623 362 1162 (LOGLAN pour ATARI STE) 1162 SB\r
+32 0 0 58 58 0 0 0 57 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+860 582 687 (par Sebastien BERNARD) 687 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+339 831 72 (Le ) 86 SB\r
+425 831 196 (langage ) 210 SB\r
+635 831 308 (LOGLAN-82 ) 322 SB\r
+957 831 81 (est ) 96 SB\r
+1053 831 286 (maintenant ) 301 SB\r
+1354 831 252 (disponible ) 267 SB\r
+1621 831 116 (sous ) 131 SB\r
+1752 831 189 (ATARI. ) 204 SB\r
+1956 831 50 (Il ) 65 SB\r
+2021 831 48 (se) 48 SB\r
+339 891 1204 (pr\351sente sous la forme de trois fichiers ex\351cutables :) 1204 SB\r
+339 951 1267 ( * LOGLAN.TTP : premi\350re partie du compilateur.) 1267 SB\r
+339 1011 1688 ( * GEN.TTP : g\351n\351rateur de code \( 2\350me partie du compilateur\).) 1688 SB\r
+339 1071 1020 ( * INTGEM.PRG : interpr\350teur du code.) 1020 SB\r
+339 1191 98 (Ces ) 117 SB\r
+456 1191 119 (trois ) 138 SB\r
+594 1191 186 (fichiers ) 205 SB\r
+799 1191 112 (sont ) 131 SB\r
+930 1191 42 (\340 ) 62 SB\r
+992 1191 168 (mettre ) 188 SB\r
+1180 1191 70 (en ) 90 SB\r
+1270 1191 373 (correspondance ) 393 SB\r
+1663 1191 116 (avec ) 136 SB\r
+1799 1191 78 (les ) 98 SB\r
+1897 1191 172 (fichiers) 172 SB\r
+339 1251 370 (LOGLAN.EXE, ) 381 SB\r
+720 1251 251 (GEN.EXE ) 262 SB\r
+982 1251 58 (et ) 69 SB\r
+1051 1251 229 (INT.EXE ) 240 SB\r
+1291 1251 91 (des ) 103 SB\r
+1394 1251 117 (IBM ) 129 SB\r
+1523 1251 97 (PC. ) 109 SB\r
+1632 1251 73 (Ils ) 85 SB\r
+1717 1251 89 (ont ) 101 SB\r
+1818 1251 78 (les ) 90 SB\r
+1908 1251 161 (memes) 161 SB\r
+339 1311 349 (fonctionnalit\351. ) 352 SB\r
+691 1311 125 (Pour ) 128 SB\r
+819 1311 280 (l'utilisation ) 283 SB\r
+1102 1311 74 (du ) 77 SB\r
+1179 1311 291 (compilateur ) 294 SB\r
+1473 1311 62 (se ) 65 SB\r
+1538 1311 203 (reporter ) 207 SB\r
+1745 1311 73 (au ) 77 SB\r
+1822 1311 189 (manuel ) 193 SB\r
+2015 1311 54 (de) 54 SB\r
+339 1371 286 (l'utilisateur ) 304 SB\r
+643 1371 121 (pour ) 139 SB\r
+782 1371 235 (LOGLAN ) 253 SB\r
+1035 1371 116 (sous ) 134 SB\r
+1169 1371 138 (DOS. ) 156 SB\r
+1325 1371 94 (Cet ) 112 SB\r
+1437 1371 168 (additif ) 187 SB\r
+1624 1371 70 (ne ) 89 SB\r
+1713 1371 143 (traite ) 162 SB\r
+1875 1371 98 (que ) 117 SB\r
+1992 1371 77 (des) 77 SB\r
+339 1431 1349 (diff\351rences entre la version ATARI ST\(E\) et la version PC.) 1349 SB\r
+339 1551 75 (La ) 75 SB\r
+32 0 0 50 50 0 0 0 48 /NewCenturySchlbk-Italic /font22 ANSIFont font\r
+414 1552 561 (configuration minimale ) 561 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+975 1551 1057 (pour utiliser ces programmes est la suivante :) 1057 SB\r
+339 1612 388 ( - 1 Mo de RAM.) 388 SB\r
+339 1672 586 ( - un lecteur double-face.) 586 SB\r
+339 1792 1596 (Il est conseill\351 pour se servir plus facilement du compilateur d'avoir :) 1596 SB\r
+339 1852 619 ( - 2 Mo de RAM \( ou plus \)) 619 SB\r
+339 1912 1126 ( - un disque dur \( ou deux lecteurs \340 la rigueur \)) 1126 SB\r
+32 0 0 50 50 0 0 0 50 /NewCenturySchlbk-Bold /font20 ANSIFont font\r
+339 2032 909 (Comment compiler un programme ) 909 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+1248 2033 14 (:) 14 SB\r
+339 2093 78 ( A ) 81 SB\r
+420 2093 58 (la ) 61 SB\r
+481 2093 243 (diff\351rence ) 247 SB\r
+728 2093 140 (d'une ) 144 SB\r
+872 2093 211 (machine ) 215 SB\r
+1087 2093 116 (sous ) 120 SB\r
+1207 2093 138 (DOS, ) 142 SB\r
+1349 2093 161 (l'Atari ) 165 SB\r
+1514 2093 70 (ne ) 74 SB\r
+1588 2093 193 (poss\350de ) 197 SB\r
+1785 2093 157 (aucun ) 161 SB\r
+1946 2093 123 (mode) 123 SB\r
+339 2153 129 (ligne ) 147 SB\r
+486 2153 89 (qui ) 107 SB\r
+593 2153 282 (permettrait ) 301 SB\r
+894 2153 197 (d'entrer ) 216 SB\r
+1110 2153 291 (directement ) 310 SB\r
+1420 2153 78 (les ) 97 SB\r
+1517 2153 285 (commandes ) 304 SB\r
+1821 2153 175 (suivies ) 194 SB\r
+2015 2153 54 (de) 54 SB\r
+339 2213 279 (param\350tres.) 279 SB\r
+339 2273 50 (A ) 54 SB\r
+393 2273 58 (la ) 63 SB\r
+456 2273 148 (place, ) 153 SB\r
+609 2273 55 (le ) 60 SB\r
+669 2273 179 (bureau ) 184 SB\r
+853 2273 192 (propose ) 197 SB\r
+1050 2273 91 (des ) 96 SB\r
+1146 2273 303 (programmes ) 308 SB\r
+1454 2273 101 (dits ) 106 SB\r
+1560 2273 118 (TOS ) 123 SB\r
+1683 2273 58 (et ) 63 SB\r
+1746 2273 113 (TTP ) 118 SB\r
+1864 2273 98 (\(tos ) 103 SB\r
+1967 2273 102 (avec) 102 SB\r
+339 2333 296 (param\350tres\) ) 307 SB\r
+646 2333 61 (ce ) 72 SB\r
+718 2333 112 (sont ) 123 SB\r
+841 2333 91 (des ) 102 SB\r
+943 2333 303 (programmes ) 314 SB\r
+1257 2333 291 (exploitables ) 302 SB\r
+1559 2333 295 (uniquement ) 306 SB\r
+1865 2333 70 (en ) 81 SB\r
+1946 2333 123 (mode) 123 SB\r
+339 2393 143 (texte. ) 145 SB\r
+484 2393 95 (Les ) 98 SB\r
+582 2393 220 (premiers ) 223 SB\r
+805 2393 130 (n'ont ) 133 SB\r
+938 2393 94 (pas ) 97 SB\r
+1035 2393 162 (besoin ) 165 SB\r
+1200 2393 68 (de ) 71 SB\r
+1271 2393 279 (param\350tres ) 282 SB\r
+1553 2393 191 (\(comme ) 194 SB\r
+1747 2393 115 (CLS ) 118 SB\r
+1865 2393 74 (du ) 77 SB\r
+1942 2393 127 (DOS\)) 127 SB\r
+339 2453 201 (d'autres ) 206 SB\r
+545 2453 89 (ont ) 94 SB\r
+639 2453 162 (besoin ) 168 SB\r
+807 2453 98 (que ) 104 SB\r
+911 2453 96 (l'on ) 102 SB\r
+1013 2453 187 (sp\351cifie ) 193 SB\r
+1206 2453 76 (un ) 82 SB\r
+1288 2453 70 (ou ) 76 SB\r
+1364 2453 230 (plusieurs ) 236 SB\r
+1600 2453 279 (param\350tres ) 285 SB\r
+1885 2453 93 (\(un ) 99 SB\r
+1984 2453 85 (peu) 85 SB\r
+339 2513 493 (comme FORMAT A:\).) 493 SB\r
+339 2573 109 ( En ) 114 SB\r
+453 2573 108 (fait, ) 113 SB\r
+566 2573 58 (la ) 63 SB\r
+629 2573 243 (diff\351rence ) 249 SB\r
+878 2573 136 (entre ) 142 SB\r
+1020 2573 78 (les ) 84 SB\r
+1104 2573 126 (deux ) 132 SB\r
+1236 2573 303 (programmes ) 309 SB\r
+1545 2573 62 (se ) 68 SB\r
+1613 2573 178 (situent ) 184 SB\r
+1797 2573 272 (simplement) 272 SB\r
+339 2633 73 (au ) 81 SB\r
+420 2633 172 (niveau ) 180 SB\r
+600 2633 68 (de ) 76 SB\r
+676 2633 108 (leur ) 116 SB\r
+792 2633 250 (extension. ) 258 SB\r
+1050 2633 95 (Les ) 104 SB\r
+1154 2633 220 (premiers ) 229 SB\r
+1383 2633 62 (se ) 71 SB\r
+1454 2633 246 (terminent ) 255 SB\r
+1709 2633 93 (par ) 102 SB\r
+1811 2633 118 (TOS ) 127 SB\r
+1938 2633 58 (et ) 67 SB\r
+2005 2633 64 (les) 64 SB\r
+339 2693 192 (seconds ) 197 SB\r
+536 2693 93 (par ) 99 SB\r
+635 2693 113 (TTP ) 119 SB\r
+754 2693 87 (\(on ) 93 SB\r
+847 2693 232 (appellera ) 238 SB\r
+1085 2693 76 (un ) 82 SB\r
+1167 2693 118 (TOS ) 124 SB\r
+1291 2693 70 (ou ) 76 SB\r
+1367 2693 76 (un ) 82 SB\r
+1449 2693 113 (TTP ) 119 SB\r
+1568 2693 76 (un ) 82 SB\r
+1650 2693 280 (programme ) 286 SB\r
+1936 2693 133 (ayant) 133 SB\r
+339 2753 649 (l'extension correspondante\).) 649 SB\r
+339 2813 1025 ( La diff\351rence entre un programme texte et ) 1026 SB\r
+1365 2813 76 (un ) 77 SB\r
+1442 2813 280 (programme ) 281 SB\r
+1723 2813 78 (dit ) 79 SB\r
+1802 2813 150 (GEM, ) 151 SB\r
+1953 2813 116 (c'est-) 116 SB\r
+339 2873 151 (\340-dire ) 163 SB\r
+502 2873 213 (utilisant ) 225 SB\r
+727 2873 78 (les ) 90 SB\r
+817 2873 325 (biblioth\350ques ) 337 SB\r
+1154 2873 274 (graphiques ) 287 SB\r
+1441 2873 151 (situ\351s ) 164 SB\r
+1605 2873 125 (dans ) 138 SB\r
+1743 2873 78 (les ) 91 SB\r
+1834 2873 168 (ROMS ) 181 SB\r
+2015 2873 54 (de) 54 SB\r
+339 2933 626 (votre ATARI \(VDI et AES\).) 626 SB\r
+339 2993 1717 ( LOGLAN.TTP et GEN.TTP sont des programmes utilisant le mode texte.) 1717 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font NewCenturySchlbk-Bold\r
+%%+ font NewCenturySchlbk-Italic\r
+%%+ font NewCenturySchlbk-Roman\r
+%%Page: 2 2\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+0 0 0 fC\r
+339 252 380 ( INTGEM.PRG ) 384 SB\r
+723 252 81 (est ) 85 SB\r
+808 252 76 (un ) 80 SB\r
+888 252 280 (programme ) 284 SB\r
+1172 252 213 (utilisant ) 217 SB\r
+1389 252 55 (le ) 59 SB\r
+1448 252 137 (mode ) 142 SB\r
+1590 252 336 (GRAPHIQUE ) 341 SB\r
+1931 252 138 (meme) 138 SB\r
+339 312 53 (si ) 60 SB\r
+399 312 42 (\340 ) 49 SB\r
+448 312 261 (l'ex\351cution ) 268 SB\r
+716 312 68 (de ) 75 SB\r
+791 312 303 (programmes ) 310 SB\r
+1101 312 254 (n'utilisant ) 261 SB\r
+1362 312 94 (pas ) 102 SB\r
+1464 312 78 (les ) 86 SB\r
+1550 312 251 (primitives ) 259 SB\r
+1809 312 260 (graphiques) 260 SB\r
+339 372 74 (du ) 83 SB\r
+422 372 235 (LOGLAN ) 244 SB\r
+666 372 46 (il ) 55 SB\r
+721 372 70 (ne ) 79 SB\r
+800 372 213 (pr\351sente ) 222 SB\r
+1022 372 94 (pas ) 103 SB\r
+1125 372 68 (de ) 77 SB\r
+1202 372 243 (diff\351rence ) 252 SB\r
+1454 372 116 (avec ) 126 SB\r
+1580 372 78 (les ) 88 SB\r
+1668 372 126 (deux ) 136 SB\r
+1804 372 162 (autres ) 172 SB\r
+1976 372 93 (pro-) 93 SB\r
+339 432 241 (grammes, ) 243 SB\r
+582 432 46 (il ) 48 SB\r
+630 432 169 (r\351alise ) 171 SB\r
+801 432 70 (en ) 73 SB\r
+874 432 94 (fait ) 97 SB\r
+971 432 91 (des ) 94 SB\r
+1065 432 337 (initialisations ) 340 SB\r
+1405 432 98 (que ) 101 SB\r
+1506 432 55 (le ) 58 SB\r
+1564 432 179 (bureau ) 182 SB\r
+1746 432 94 (fait ) 97 SB\r
+1843 432 42 (\340 ) 45 SB\r
+1888 432 58 (la ) 61 SB\r
+1949 432 120 (place) 120 SB\r
+339 492 683 (des programmes TOS et TTP.) 683 SB\r
+339 552 161 ( Cela ) 166 SB\r
+505 552 81 (est ) 86 SB\r
+591 552 74 (du ) 79 SB\r
+670 552 73 (au ) 78 SB\r
+748 552 94 (fait ) 99 SB\r
+847 552 98 (que ) 104 SB\r
+951 552 61 (ce ) 67 SB\r
+1018 552 280 (programme ) 286 SB\r
+1304 552 118 (peut ) 124 SB\r
+1428 552 42 (\340 ) 48 SB\r
+1476 552 108 (tout ) 114 SB\r
+1590 552 202 (moment ) 208 SB\r
+1798 552 209 (basculer ) 215 SB\r
+2013 552 56 (en) 56 SB\r
+339 612 1045 (mode graphique, revenir au mode texte, etc...) 1045 SB\r
+339 732 200 ( Quand ) 209 SB\r
+548 732 70 (on ) 79 SB\r
+627 732 136 (lance ) 145 SB\r
+772 732 76 (un ) 85 SB\r
+857 732 280 (programme ) 289 SB\r
+1146 732 132 (TOS, ) 141 SB\r
+1287 732 55 (le ) 64 SB\r
+1351 732 179 (bureau ) 188 SB\r
+1539 732 142 (cache ) 151 SB\r
+1690 732 58 (la ) 67 SB\r
+1757 732 168 (souris, ) 178 SB\r
+1935 732 134 (efface) 134 SB\r
+339 792 1091 (l'\351cran et donne la main au programme appel\351.) 1091 SB\r
+339 852 200 ( Quand ) 203 SB\r
+542 852 70 (on ) 73 SB\r
+615 852 136 (lance ) 140 SB\r
+755 852 76 (un ) 80 SB\r
+835 852 280 (programme ) 284 SB\r
+1119 852 127 (TTP, ) 131 SB\r
+1250 852 55 (le ) 59 SB\r
+1309 852 179 (bureau ) 183 SB\r
+1492 852 199 (suppose ) 203 SB\r
+1695 852 98 (que ) 102 SB\r
+1797 852 272 (l'utilisateur) 272 SB\r
+339 912 116 (veut ) 123 SB\r
+462 912 164 (passer ) 171 SB\r
+633 912 91 (des ) 98 SB\r
+731 912 279 (param\350tres ) 287 SB\r
+1018 912 73 (au ) 81 SB\r
+1099 912 280 (programme ) 288 SB\r
+1387 912 196 (appell\351. ) 204 SB\r
+1591 912 127 (C'est ) 135 SB\r
+1726 912 121 (pour ) 129 SB\r
+1855 912 105 (cela ) 113 SB\r
+1968 912 101 (qu'il) 101 SB\r
+339 972 144 (ouvre ) 147 SB\r
+486 972 101 (une ) 104 SB\r
+590 972 127 (boite ) 130 SB\r
+720 972 68 (de ) 71 SB\r
+791 972 211 (dialogue ) 215 SB\r
+1006 972 116 (avec ) 120 SB\r
+1126 972 101 (une ) 105 SB\r
+1231 972 129 (ligne ) 133 SB\r
+1364 972 111 (vide ) 115 SB\r
+1479 972 121 (pour ) 125 SB\r
+1604 972 98 (que ) 102 SB\r
+1706 972 286 (l'utilisateur ) 290 SB\r
+1996 972 73 (en-) 73 SB\r
+339 1032 937 (tre ce qu'il veut indiquer au programme.) 937 SB\r
+32 0 0 50 50 0 0 0 50 /NewCenturySchlbk-Bold /font20 ANSIFont font\r
+339 1152 360 (LOGLAN.TTP) 360 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+699 1153 1340 ( : Indiquez simplement ce que vous mettriez apr\350s la com-) 1340 SB\r
+339 1213 646 (mande LOGLAN sous DOS.) 646 SB\r
+32 0 0 42 42 1 0 0 41 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+398 1333 160 (exemple) 160 SB\r
+32 0 0 42 42 0 0 0 41 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+558 1333 1240 ( : pour compiler un programme sous DOS vous pourriez entrer :) 1240 SB\r
+398 1433 935 ( LOGLAN MONPROG.LOG L+ O-) 935 SB\r
+398 1533 1593 (pour r\351aliser la meme chose sous ATARI, double-cliquez sur l'icone LOGLAN.TTP) 1593 SB\r
+398 1583 687 (et entrez dans la boite de dialogue :) 687 SB\r
+398 1683 737 ( MONPROG.LOG L+ O-) 737 SB\r
+398 1783 1585 (et cliquez enfin sur le bouton OK et le bureau lancera l'application LOGLAN.TTP) 1585 SB\r
+398 1833 882 (avec 'MONPROG.LOG L+ O-' en param\350tres.) 882 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+339 1943 62 (Si ) 70 SB\r
+409 1943 120 (vous ) 128 SB\r
+537 1943 160 (lancez ) 168 SB\r
+705 1943 348 (LOGLAN.TTP ) 356 SB\r
+1061 1943 119 (sans ) 127 SB\r
+1188 1943 157 (aucun ) 165 SB\r
+1353 1943 293 (param\350tres, ) 302 SB\r
+1655 1943 299 (l'application ) 308 SB\r
+1963 1943 106 (vous) 106 SB\r
+339 2003 275 (demandera ) 282 SB\r
+621 2003 55 (le ) 62 SB\r
+683 2003 114 (nom ) 121 SB\r
+804 2003 74 (du ) 81 SB\r
+885 2003 163 (fichier ) 170 SB\r
+1055 2003 42 (\340 ) 49 SB\r
+1104 2003 227 (compiler. ) 234 SB\r
+1338 2003 171 (Entrez ) 178 SB\r
+1516 2003 42 (\340 ) 50 SB\r
+1566 2003 61 (ce ) 69 SB\r
+1635 2003 263 (moment-l\340 ) 271 SB\r
+1906 2003 55 (le ) 63 SB\r
+1969 2003 100 (nom) 100 SB\r
+339 2063 194 (complet ) 207 SB\r
+546 2063 133 (\(avec ) 146 SB\r
+692 2063 262 (l'extension ) 275 SB\r
+967 2063 139 (.LOG ) 152 SB\r
+1119 2063 31 (\) ) 44 SB\r
+1163 2063 68 (de ) 81 SB\r
+1244 2063 132 (votre ) 145 SB\r
+1389 2063 177 (fichier. ) 190 SB\r
+1579 2063 72 (Le ) 85 SB\r
+1664 2063 291 (compilateur ) 305 SB\r
+1969 2063 100 (sup-) 100 SB\r
+339 2123 1682 (posera que vous voulez compiler ce fichier \340 l'aide des options standards.) 1682 SB\r
+32 0 0 50 50 0 0 0 50 /NewCenturySchlbk-Bold /font20 ANSIFont font\r
+339 2243 246 (GEN.TTP) 246 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+585 2244 1261 (: L'utilisation de fichier est identique \340 LOGLAN.TTP.) 1261 SB\r
+339 2304 243 (GEN.TTP ) 245 SB\r
+584 2304 70 (ne ) 72 SB\r
+656 2304 150 (prend ) 152 SB\r
+808 2304 94 (pas ) 96 SB\r
+904 2304 68 (de ) 70 SB\r
+974 2304 293 (param\350tres, ) 295 SB\r
+1269 2304 46 (il ) 48 SB\r
+1317 2304 210 (convient ) 212 SB\r
+1529 2304 286 (simplement ) 288 SB\r
+1817 2304 68 (de ) 70 SB\r
+1887 2304 77 (lui ) 80 SB\r
+1967 2304 102 (don-) 102 SB\r
+339 2364 1333 (ner le nom de votre application \( sans aucune extension \).) 1333 SB\r
+32 0 0 50 50 0 0 0 50 /NewCenturySchlbk-Bold /font20 ANSIFont font\r
+339 2484 364 (INTGEM.PRG) 364 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+703 2485 14 ( ) 15 SB\r
+718 2485 28 (: ) 29 SB\r
+747 2485 188 (Comme ) 189 SB\r
+936 2485 93 (son ) 94 SB\r
+1030 2485 236 (extension ) 237 SB\r
+1267 2485 230 (l'indique, ) 232 SB\r
+1499 2485 46 (il ) 48 SB\r
+1547 2485 137 (s'agit ) 139 SB\r
+1686 2485 115 (d'un ) 117 SB\r
+1803 2485 266 (programme) 266 SB\r
+339 2545 213 (utilisant ) 219 SB\r
+558 2545 78 (les ) 84 SB\r
+642 2545 288 (graphiques. ) 294 SB\r
+936 2545 72 (Le ) 78 SB\r
+1014 2545 179 (bureau ) 185 SB\r
+1199 2545 232 (consid\350re ) 238 SB\r
+1437 2545 98 (que ) 104 SB\r
+1541 2545 61 (ce ) 67 SB\r
+1608 2545 114 (type ) 120 SB\r
+1728 2545 68 (de ) 75 SB\r
+1803 2545 266 (programme) 266 SB\r
+339 2605 1091 (n'utilise pas de param\350tres pour son ex\351cution.) 1091 SB\r
+339 2665 81 (En ) 87 SB\r
+426 2665 108 (fait, ) 114 SB\r
+540 2665 230 (INTGEM ) 236 SB\r
+776 2665 160 (utilise ) 166 SB\r
+942 2665 78 (les ) 84 SB\r
+1026 2665 175 (memes ) 181 SB\r
+1207 2665 279 (param\350tres ) 285 SB\r
+1492 2665 98 (que ) 105 SB\r
+1597 2665 93 (son ) 100 SB\r
+1697 2665 263 (homologue ) 270 SB\r
+1967 2665 102 (sous) 102 SB\r
+339 2725 124 (DOS.) 124 SB\r
+339 2785 957 (Pour utiliser ce programme vous pouvez :) 957 SB\r
+339 2845 83 ( le ) 85 SB\r
+424 2845 158 (lancer ) 160 SB\r
+584 2845 291 (directement ) 293 SB\r
+877 2845 28 (: ) 30 SB\r
+907 2845 188 (Comme ) 190 SB\r
+1097 2845 362 (LOGLAN.TTP, ) 364 SB\r
+1461 2845 46 (il ) 49 SB\r
+1510 2845 120 (vous ) 123 SB\r
+1633 2845 275 (demandera ) 278 SB\r
+1911 2845 55 (le ) 58 SB\r
+1969 2845 100 (nom) 100 SB\r
+339 2905 74 (du ) 77 SB\r
+416 2905 253 (proramme ) 256 SB\r
+672 2905 42 (\340 ) 45 SB\r
+717 2905 210 (ex\351cuter ) 213 SB\r
+930 2905 58 (et ) 61 SB\r
+991 2905 259 (demarrera ) 262 SB\r
+1253 2905 70 (en ) 73 SB\r
+1326 2905 252 (supposant ) 255 SB\r
+1581 2905 98 (que ) 101 SB\r
+1682 2905 120 (vous ) 123 SB\r
+1805 2905 162 (voulez ) 165 SB\r
+1970 2905 99 (util-) 99 SB\r
+339 2965 100 (iser ) 106 SB\r
+445 2965 78 (les ) 84 SB\r
+529 2965 182 (options ) 188 SB\r
+717 2965 93 (par ) 99 SB\r
+816 2965 163 (d\351faut ) 169 SB\r
+985 2965 74 (du ) 80 SB\r
+1065 2965 305 (compilateur. ) 311 SB\r
+1376 2965 138 (Cette ) 144 SB\r
+1520 2965 254 (utilisation ) 260 SB\r
+1780 2965 70 (ne ) 77 SB\r
+1857 2965 212 (provoque) 212 SB\r
+339 3025 459 (aucune restrictions.) 459 SB\r
+32 0 0 42 42 0 0 0 38 /Times-Roman /font32 ANSIFont font\r
+1193 3265 21 (2) 21 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font NewCenturySchlbk-Bold\r
+%%+ font NewCenturySchlbk-Roman\r
+%%+ font Times-Roman\r
+%%Page: 3 3\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+0 0 0 fC\r
+339 252 281 (Cependant, ) 286 SB\r
+625 252 121 (pour ) 126 SB\r
+751 252 58 (la ) 64 SB\r
+815 252 374 (programmation ) 380 SB\r
+1195 252 91 (des ) 97 SB\r
+1292 252 251 (processus, ) 257 SB\r
+1549 252 78 (les ) 84 SB\r
+1633 252 182 (options ) 188 SB\r
+1821 252 93 (par ) 99 SB\r
+1920 252 149 (d\351faut) 149 SB\r
+339 312 850 (doivent etre modifiees dans certains.) 850 SB\r
+339 372 100 ( Le ) 102 SB\r
+441 372 280 (programme ) 282 SB\r
+723 372 318 (GSORT.LOG ) 320 SB\r
+1043 372 93 (par ) 95 SB\r
+1138 372 219 (exemple, ) 221 SB\r
+1359 372 160 (utilise ) 162 SB\r
+1521 372 78 (les ) 80 SB\r
+1601 372 237 (processus ) 240 SB\r
+1841 372 121 (pour ) 124 SB\r
+1965 372 104 (trier) 104 SB\r
+339 432 76 (un ) 80 SB\r
+419 432 231 (ensemble ) 235 SB\r
+654 432 68 (de ) 72 SB\r
+726 432 186 (valeurs ) 190 SB\r
+916 432 58 (et ) 62 SB\r
+978 432 118 (peut ) 122 SB\r
+1100 432 130 (cr\351er ) 135 SB\r
+1235 432 113 (plus ) 118 SB\r
+1353 432 68 (de ) 73 SB\r
+1426 432 70 (30 ) 75 SB\r
+1501 432 251 (processus. ) 256 SB\r
+1757 432 124 (Avec ) 129 SB\r
+1886 432 58 (la ) 63 SB\r
+1949 432 120 (taille) 120 SB\r
+339 492 215 (m\351moire ) 218 SB\r
+557 492 223 (standard ) 226 SB\r
+783 492 89 (qui ) 92 SB\r
+875 492 81 (est ) 84 SB\r
+959 492 68 (de ) 71 SB\r
+1030 492 154 (30000 ) 157 SB\r
+1187 492 125 (mots ) 128 SB\r
+1315 492 238 (m\351moires ) 241 SB\r
+1556 492 93 (par ) 97 SB\r
+1653 492 251 (processus, ) 255 SB\r
+1908 492 161 (c'est-\340-) 161 SB\r
+339 552 106 (dire ) 107 SB\r
+446 552 154 (60000 ) 155 SB\r
+601 552 147 (octets ) 149 SB\r
+750 552 46 (il ) 48 SB\r
+798 552 169 (faudra ) 171 SB\r
+969 552 154 (60000 ) 156 SB\r
+1125 552 39 (* ) 41 SB\r
+1166 552 70 (30 ) 72 SB\r
+1238 552 44 (= ) 46 SB\r
+1284 552 210 (1800000 ) 212 SB\r
+1496 552 147 (octets ) 149 SB\r
+1645 552 101 (\(1.6 ) 103 SB\r
+1748 552 86 (Mo ) 88 SB\r
+1836 552 31 (\) ) 33 SB\r
+1869 552 68 (de ) 70 SB\r
+1939 552 130 (mem-) 130 SB\r
+339 612 354 (oire disponible.) 354 SB\r
+339 672 143 (Aussi ) 153 SB\r
+492 672 280 (l'utilisation ) 290 SB\r
+782 672 68 (de ) 78 SB\r
+860 672 193 (GSORT ) 203 SB\r
+1063 672 62 (se ) 72 SB\r
+1135 672 193 (fait-elle ) 203 SB\r
+1338 672 116 (avec ) 127 SB\r
+1465 672 185 (l'option ) 196 SB\r
+1661 672 75 (-m ) 86 SB\r
+1747 672 154 (10000 ) 165 SB\r
+1912 672 31 (\( ) 42 SB\r
+1954 672 115 (voire) 115 SB\r
+339 732 703 (7000 \) pour pouvoir l'ex\351cuter.) 703 SB\r
+339 852 1083 ( Pour rem\351dier \340 ce probl\350me, deux solutions :) 1083 SB\r
+339 912 1379 ( Soit vous renommez INTGEM.PRG en INTGEM.TTP : Il ) 1380 SB\r
+1719 912 186 (devient ) 187 SB\r
+1906 912 121 (pour ) 122 SB\r
+2028 912 41 (le) 41 SB\r
+339 972 179 (bureau ) 189 SB\r
+528 972 76 (un ) 86 SB\r
+614 972 280 (programme ) 290 SB\r
+904 972 129 (texte ) 139 SB\r
+1043 972 237 (acceptant ) 247 SB\r
+1290 972 91 (des ) 101 SB\r
+1391 972 293 (param\350tres. ) 304 SB\r
+1695 972 135 (Dans ) 146 SB\r
+1841 972 61 (ce ) 72 SB\r
+1913 972 101 (cas, ) 112 SB\r
+2025 972 44 (la) 44 SB\r
+339 1032 1044 (souris sera inutilisable dans les applications.) 1044 SB\r
+339 1092 162 ( Soit ) 183 SB\r
+522 1092 120 (vous ) 141 SB\r
+663 1092 184 (utilisez ) 205 SB\r
+868 1092 76 (un ) 97 SB\r
+965 1092 179 (bureau ) 200 SB\r
+1165 1092 235 (alternatif ) 256 SB\r
+1421 1092 174 (comme ) 195 SB\r
+1616 1092 276 (NEODESK ) 297 SB\r
+1913 1092 70 (ou ) 92 SB\r
+2005 1092 64 (les) 64 SB\r
+339 1152 232 (derni\350res ) 234 SB\r
+573 1152 183 (version ) 185 SB\r
+758 1152 74 (du ) 76 SB\r
+834 1152 179 (bureau ) 181 SB\r
+1015 1152 175 (ATARI ) 177 SB\r
+1192 1152 31 (\( ) 33 SB\r
+1225 1152 42 (\340 ) 45 SB\r
+1270 1152 150 (partir ) 153 SB\r
+1423 1152 91 (des ) 94 SB\r
+1517 1152 118 (TOS ) 121 SB\r
+1638 1152 84 (2.0 ) 87 SB\r
+1725 1152 31 (- ) 34 SB\r
+1759 1152 172 (MEGA ) 175 SB\r
+1934 1152 115 (STE ) 118 SB\r
+2052 1152 17 (\)) 17 SB\r
+339 1212 89 (qui ) 92 SB\r
+431 1212 119 (elles ) 122 SB\r
+553 1212 288 (connaissent ) 291 SB\r
+844 1212 78 (les ) 81 SB\r
+925 1212 303 (programmes ) 306 SB\r
+1231 1212 136 (GEM ) 140 SB\r
+1371 1212 89 (qui ) 93 SB\r
+1464 1212 227 (prennent ) 231 SB\r
+1695 1212 91 (des ) 95 SB\r
+1790 1212 279 (param\350tres.) 279 SB\r
+339 1272 72 (Le ) 73 SB\r
+412 1272 228 (probl\350me ) 229 SB\r
+641 1272 81 (est ) 82 SB\r
+723 1272 98 (que ) 99 SB\r
+822 1272 97 (soit ) 98 SB\r
+920 1272 46 (il ) 48 SB\r
+968 1272 186 (coutent ) 188 SB\r
+1156 1272 128 (cher, ) 130 SB\r
+1286 1272 97 (soit ) 99 SB\r
+1385 1272 46 (il ) 48 SB\r
+1433 1272 303 (consomment ) 305 SB\r
+1738 1272 68 (de ) 70 SB\r
+1808 1272 58 (la ) 60 SB\r
+1868 1272 201 (m\351moire) 201 SB\r
+339 1332 109 (vive.) 109 SB\r
+339 1392 153 ( Pour ) 161 SB\r
+500 1392 101 (une ) 109 SB\r
+609 1392 254 (utilisation ) 263 SB\r
+872 1392 219 (normale, ) 228 SB\r
+1100 1392 280 (l'utilisation ) 289 SB\r
+1389 1392 68 (de ) 77 SB\r
+1466 1392 352 (INTGEM.PRG ) 361 SB\r
+1827 1392 189 (suivant ) 198 SB\r
+2025 1392 44 (la) 44 SB\r
+339 1452 1034 (premi\350re m\351thode est amplement suffisante.) 1034 SB\r
+32 0 0 54 54 0 0 0 53 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+339 1632 385 (PROBLEMES :) 385 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+339 1697 75 (La ) 79 SB\r
+418 1697 81 (est ) 85 SB\r
+503 1697 55 (le ) 59 SB\r
+562 1697 113 (plus ) 117 SB\r
+679 1697 169 (d\351licat ) 173 SB\r
+852 1697 58 (et ) 62 SB\r
+914 1697 113 (c'est ) 117 SB\r
+1031 1697 221 (pourquoi ) 225 SB\r
+1256 1697 54 (je ) 58 SB\r
+1314 1697 213 (conseille ) 218 SB\r
+1532 1697 101 (une ) 106 SB\r
+1638 1697 324 (configuration ) 329 SB\r
+1967 1697 102 (avec) 102 SB\r
+339 1757 902 (deux lecteurs ou mieux, un disque dur.) 902 SB\r
+339 1817 129 (Voici ) 138 SB\r
+477 1817 55 (le ) 64 SB\r
+541 1817 228 (probl\350me ) 237 SB\r
+778 1817 28 (: ) 37 SB\r
+815 1817 348 (LOGLAN.TTP ) 357 SB\r
+1172 1817 121 (pour ) 130 SB\r
+1302 1817 130 (cr\351er ) 139 SB\r
+1441 1817 76 (un ) 85 SB\r
+1526 1817 163 (fichier ) 173 SB\r
+1699 1817 122 (LCD ) 132 SB\r
+1831 1817 238 (commence) 238 SB\r
+339 1877 93 (par ) 105 SB\r
+444 1877 130 (cr\351er ) 142 SB\r
+586 1877 126 (deux ) 138 SB\r
+724 1877 70 (ou ) 82 SB\r
+806 1877 119 (trois ) 131 SB\r
+937 1877 186 (fichiers ) 198 SB\r
+1135 1877 292 (temporaires ) 304 SB\r
+1439 1877 115 (qu'il ) 127 SB\r
+1566 1877 148 (efface ) 161 SB\r
+1727 1877 42 (\340 ) 55 SB\r
+1782 1877 58 (la ) 71 SB\r
+1853 1877 78 (fin ) 91 SB\r
+1944 1877 68 (de ) 81 SB\r
+2025 1877 44 (la) 44 SB\r
+339 1937 285 (compilation.) 285 SB\r
+339 1997 284 (Ces fichiers ) 285 SB\r
+624 1997 112 (sont ) 113 SB\r
+737 1997 332 (g\351n\351ralement ) 333 SB\r
+1070 1997 352 (proportionnels ) 353 SB\r
+1423 1997 42 (\340 ) 43 SB\r
+1466 1997 58 (la ) 59 SB\r
+1525 1997 262 (complexit\351 ) 263 SB\r
+1788 1997 58 (et ) 59 SB\r
+1847 1997 42 (\340 ) 43 SB\r
+1890 1997 58 (la ) 59 SB\r
+1949 1997 120 (taille) 120 SB\r
+339 2057 68 (de ) 72 SB\r
+411 2057 89 (vos ) 93 SB\r
+504 2057 317 (programmes. ) 321 SB\r
+825 2057 50 (Il ) 54 SB\r
+879 2057 201 (peuvent ) 206 SB\r
+1085 2057 121 (aller ) 126 SB\r
+1211 2057 68 (de ) 73 SB\r
+1284 2057 70 (30 ) 75 SB\r
+1359 2057 78 (Ko ) 83 SB\r
+1442 2057 180 (jusqu'\340 ) 185 SB\r
+1627 2057 98 (100 ) 103 SB\r
+1730 2057 92 (Ko. ) 97 SB\r
+1827 2057 128 (Sans ) 133 SB\r
+1960 2057 109 (indi-) 109 SB\r
+339 2117 178 (cations ) 187 SB\r
+526 2117 238 (contraire, ) 247 SB\r
+773 2117 46 (il ) 55 SB\r
+828 2117 78 (les ) 87 SB\r
+915 2117 108 (cr\351e ) 117 SB\r
+1032 2117 125 (dans ) 134 SB\r
+1166 2117 55 (le ) 64 SB\r
+1230 2117 244 (r\351pertoire ) 253 SB\r
+1483 2117 192 (courant ) 201 SB\r
+1684 2117 75 (\(l\340 ) 84 SB\r
+1768 2117 70 (o\371 ) 80 SB\r
+1848 2117 62 (se ) 72 SB\r
+1920 2117 149 (trouve) 149 SB\r
+339 2177 132 (votre ) 142 SB\r
+481 2177 280 (programme ) 290 SB\r
+771 2177 162 (source ) 172 SB\r
+943 2177 45 (\), ) 55 SB\r
+998 2177 76 (un ) 86 SB\r
+1084 2177 163 (rapide ) 174 SB\r
+1258 2177 149 (calcul ) 160 SB\r
+1418 2177 178 (permet ) 189 SB\r
+1607 2177 68 (de ) 79 SB\r
+1686 2177 288 (s'apercevoir ) 299 SB\r
+1985 2177 84 (que) 84 SB\r
+339 2237 257 (l'ensemble ) 266 SB\r
+605 2237 91 (des ) 100 SB\r
+705 2237 186 (fichiers ) 195 SB\r
+900 2237 283 (ex\351cutables ) 292 SB\r
+1192 2237 185 (sources ) 194 SB\r
+1386 2237 58 (et ) 67 SB\r
+1453 2237 186 (fichiers ) 195 SB\r
+1648 2237 355 (interm\351diaires ) 365 SB\r
+2013 2237 56 (ne) 56 SB\r
+339 2297 1207 (tiennent pas sur une disquette double-face normale.) 1207 SB\r
+339 2357 1716 (Il arrive que pour les fichiers importants, le compilateur vous r\351ponde par) 1716 SB\r
+339 2417 611 ( 'I/O Trap 29') 611 SB\r
+339 2477 105 (cela ) 114 SB\r
+453 2477 185 (signifie ) 194 SB\r
+647 2477 115 (qu'il ) 124 SB\r
+771 2477 82 (n'y ) 91 SB\r
+862 2477 42 (a ) 51 SB\r
+913 2477 113 (plus ) 122 SB\r
+1035 2477 68 (de ) 77 SB\r
+1112 2477 134 (place ) 143 SB\r
+1255 2477 90 (sur ) 100 SB\r
+1355 2477 58 (la ) 68 SB\r
+1423 2477 229 (disquette ) 239 SB\r
+1662 2477 58 (et ) 68 SB\r
+1730 2477 58 (la ) 68 SB\r
+1798 2477 271 (compilation) 271 SB\r
+339 2537 252 (s'arretera. ) 255 SB\r
+594 2537 50 (Il ) 54 SB\r
+648 2537 120 (vous ) 124 SB\r
+772 2537 169 (faudra ) 173 SB\r
+945 2537 122 (faire ) 126 SB\r
+1071 2537 68 (de ) 72 SB\r
+1143 2537 58 (la ) 62 SB\r
+1205 2537 134 (place ) 138 SB\r
+1343 2537 90 (sur ) 94 SB\r
+1437 2537 58 (la ) 62 SB\r
+1499 2537 229 (disquette ) 233 SB\r
+1732 2537 106 (afin ) 110 SB\r
+1842 2537 115 (qu'il ) 119 SB\r
+1961 2537 41 (y ) 45 SB\r
+2006 2537 63 (ait) 63 SB\r
+339 2597 339 (assez de place.) 339 SB\r
+339 2657 139 ( Pour ) 149 SB\r
+488 2657 302 (information, ) 312 SB\r
+800 2657 58 (la ) 68 SB\r
+868 2657 285 (compilation ) 295 SB\r
+1163 2657 74 (du ) 84 SB\r
+1247 2657 280 (programme ) 291 SB\r
+1538 2657 176 (TEST1 ) 187 SB\r
+1725 2657 160 (utilise ) 171 SB\r
+1896 2657 98 (150 ) 109 SB\r
+2005 2657 64 (Ko) 64 SB\r
+339 2717 205 (d'espace ) 216 SB\r
+555 2717 166 (disque ) 177 SB\r
+732 2717 31 (\( ) 42 SB\r
+774 2717 42 (\340 ) 53 SB\r
+827 2717 99 (peu ) 110 SB\r
+937 2717 113 (pr\350s ) 124 SB\r
+1061 2717 31 (\) ) 42 SB\r
+1103 2717 128 (alors ) 139 SB\r
+1242 2717 98 (que ) 109 SB\r
+1351 2717 58 (la ) 69 SB\r
+1420 2717 285 (compilation ) 297 SB\r
+1717 2717 74 (du ) 86 SB\r
+1803 2717 266 (programme) 266 SB\r
+339 2777 763 (LOGDEB utilise environ 600 Ko.) 763 SB\r
+339 2897 1339 (Pour \351viter ce genre de d\351sagr\351ment, plusieurs solutions :) 1339 SB\r
+339 2957 59 ( - ) 65 SB\r
+404 2957 264 (ACHETEZ ) 270 SB\r
+674 2957 96 (UN ) 103 SB\r
+777 2957 221 (DISQUE ) 228 SB\r
+1005 2957 130 (DUR ) 137 SB\r
+1142 2957 28 (: ) 35 SB\r
+1177 2957 46 (il ) 53 SB\r
+1230 2957 89 (ont ) 96 SB\r
+1326 2957 233 (beaucoup ) 240 SB\r
+1566 2957 157 (baiss\351 ) 164 SB\r
+1730 2957 128 (alors ) 135 SB\r
+1865 2957 204 (n'h\351sitez) 204 SB\r
+339 3017 141 (plus...) 141 SB\r
+32 0 0 42 42 0 0 0 38 /Times-Roman /font32 ANSIFont font\r
+1193 3265 21 (3) 21 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font NewCenturySchlbk-Roman\r
+%%+ font Times-Roman\r
+%%Page: 4 4\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+0 0 0 fC\r
+339 252 59 ( - ) 77 SB\r
+416 252 218 (Indiquez ) 236 SB\r
+652 252 42 (\340 ) 60 SB\r
+712 252 348 (LOGLAN.TTP ) 366 SB\r
+1078 252 115 (qu'il ) 133 SB\r
+1211 252 103 (doit ) 122 SB\r
+1333 252 130 (cr\351er ) 149 SB\r
+1482 252 85 (ses ) 104 SB\r
+1586 252 186 (fichiers ) 205 SB\r
+1791 252 278 (temporaires) 278 SB\r
+339 312 1703 (ailleurs \( sur le lecteur B: par exemple ou mieux dans un RAM disque \).) 1703 SB\r
+339 372 181 ( Pour ) 216 SB\r
+555 372 119 (cela, ) 155 SB\r
+710 372 174 (comme ) 210 SB\r
+920 372 116 (sous ) 152 SB\r
+1072 372 138 (DOS, ) 174 SB\r
+1246 372 46 (il ) 82 SB\r
+1328 372 109 (faut ) 145 SB\r
+1473 372 276 (positionner ) 312 SB\r
+1785 372 58 (la ) 94 SB\r
+1879 372 190 (variable) 190 SB\r
+339 432 1652 (d'environnement TEMP sur le chemin o\371 cr\351er les fichiers temporaires.) 1652 SB\r
+339 552 1641 (Voil\340, vous savez \340 peu pr\350s tout sur comment compiler un programme) 1641 SB\r
+339 612 688 (\351crit en LOGLAN sur ATARI.) 688 SB\r
+339 672 231 (J'aimerai ) 242 SB\r
+581 672 165 (attirer ) 176 SB\r
+757 672 253 (l'attention ) 264 SB\r
+1021 672 90 (sur ) 101 SB\r
+1122 672 76 (un ) 87 SB\r
+1209 672 184 (dernier ) 195 SB\r
+1404 672 147 (d\351tail ) 158 SB\r
+1562 672 28 (: ) 40 SB\r
+1602 672 55 (le ) 67 SB\r
+1669 672 311 (param\351trage ) 323 SB\r
+1992 672 77 (des) 77 SB\r
+339 732 296 (applications.) 296 SB\r
+339 792 166 ( Cette ) 174 SB\r
+513 792 159 (option ) 168 SB\r
+681 792 178 (permet ) 187 SB\r
+868 792 68 (de ) 77 SB\r
+945 792 231 (d\351marrer ) 240 SB\r
+1185 792 101 (une ) 110 SB\r
+1295 792 273 (application ) 282 SB\r
+1577 792 427 (automatiquement ) 436 SB\r
+2013 792 56 (en) 56 SB\r
+339 852 1624 (double cliquant simplement sur un fichier ayant l'extension ad\351quate.) 1624 SB\r
+339 912 114 ( Un ) 122 SB\r
+461 912 163 (fichier ) 171 SB\r
+632 912 373 (DESKTOP.INF ) 381 SB\r
+1013 912 81 (est ) 89 SB\r
+1102 912 195 (compris ) 203 SB\r
+1305 912 125 (dans ) 133 SB\r
+1438 912 78 (les ) 86 SB\r
+1524 912 186 (fichiers ) 194 SB\r
+1718 912 89 (qui ) 97 SB\r
+1815 912 112 (sont ) 120 SB\r
+1935 912 97 (mis ) 106 SB\r
+2041 912 28 (\340) 28 SB\r
+339 972 132 (votre ) 133 SB\r
+472 972 280 (disposition. ) 281 SB\r
+753 972 50 (Il ) 52 SB\r
+805 972 202 (contient ) 204 SB\r
+1009 972 58 (la ) 60 SB\r
+1069 972 324 (configuration ) 326 SB\r
+1395 972 121 (pour ) 123 SB\r
+1518 972 78 (les ) 80 SB\r
+1598 972 296 (applications ) 298 SB\r
+1896 972 173 (suivan-) 173 SB\r
+339 1032 81 (tes:) 81 SB\r
+339 1152 1065 ( APPLICATION EXTENSION) 1065 SB\r
+339 1212 992 ( =========== =========) 992 SB\r
+339 1272 893 ( LOGLAN.TTP .LOG) 893 SB\r
+339 1332 897 ( INTGEM.PRG .CCD) 897 SB\r
+32 0 0 50 50 0 0 0 48 /NewCenturySchlbk-Italic /font22 ANSIFont font\r
+339 1453 264 (Autre chose) 264 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+603 1452 1381 (, il est fournis dans la distribution deux autres application :) 1381 SB\r
+339 1513 465 (ME.TTP et MS.TOS) 465 SB\r
+339 1633 210 (ME.TTP ) 221 SB\r
+560 1633 81 (est ) 92 SB\r
+652 1633 207 (l'\351diteur ) 218 SB\r
+870 1633 68 (de ) 79 SB\r
+949 1633 129 (texte ) 141 SB\r
+1090 1633 302 (micro-emacs ) 314 SB\r
+1404 1633 155 (donn\351 ) 167 SB\r
+1571 1633 121 (pour ) 133 SB\r
+1704 1633 98 (que ) 110 SB\r
+1814 1633 96 (l'on ) 108 SB\r
+1922 1633 147 (puisse) 147 SB\r
+339 1693 1439 (\351diter des ourt et ne n\351c\351ssite pas un apprentissage tr\350s ardu.) 1439 SB\r
+339 1813 211 (MS.TOS ) 214 SB\r
+553 1813 81 (est ) 84 SB\r
+637 1813 76 (un ) 80 SB\r
+717 1813 271 (micro-shell ) 275 SB\r
+992 1813 89 (qui ) 93 SB\r
+1085 1813 120 (vous ) 124 SB\r
+1209 1813 247 (permettra ) 251 SB\r
+1460 1813 68 (de ) 72 SB\r
+1532 1813 158 (lancer ) 162 SB\r
+1694 1813 89 (vos ) 93 SB\r
+1787 1813 282 (applications) 282 SB\r
+339 1873 113 (plus ) 118 SB\r
+457 1873 257 (facilement ) 262 SB\r
+719 1873 185 (qu'avec ) 190 SB\r
+909 1873 55 (le ) 60 SB\r
+969 1873 193 (bureau. ) 198 SB\r
+1167 1873 50 (Il ) 55 SB\r
+1222 1873 81 (est ) 86 SB\r
+1308 1873 182 (destin\351 ) 187 SB\r
+1495 1873 42 (\340 ) 47 SB\r
+1542 1873 195 (faciliter ) 201 SB\r
+1743 1873 55 (le ) 61 SB\r
+1804 1873 265 (cyclecompi-) 265 SB\r
+339 1933 1536 (lation -> erreur -> correction\(s\) des erreurs -> compilation -> etc...) 1536 SB\r
+339 1993 1653 (Il ne permet pas de modifier les variables d'environnement mais il peut) 1653 SB\r
+339 2053 904 (rendre quelque services quand meme...) 904 SB\r
+339 2233 1028 ( BONNE PROGRAMMATION !!!) 1028 SB\r
+\r
+%%BeginResource: font Koala-Normal\r
+%!PS-AdobeFont-1.0: Koala-Normal 001.003\r%CreationDate: Wed Feb 05 07:32:32 1992\r%%Creator: Corel's Wfnboss\r%BasedOn: KOALA.WFN 1\r%%DesignSize: 720\r%%VMusage: 38000 40000\r%% CopyRight (c) 1991, Corel Systems Corporation. All rights reserved.\r11 dict begin\r/FontInfo 8 dict dup begin\r/version (001.003) readonly def\r/FullName (Koala Normal) readonly def\r/FamilyName (Koala) readonly def\r/Weight (normal) readonly def\r/ItalicAngle 0 def\r/isFixedPitch false def\r/UnderlinePosition -100 def\r/UnderlineThickness 50 def\rend readonly def\r/FontName /Koala-Normal def\r/PaintType 0 def\r/FontType 1 def\r/FontMatrix [0.001000 0 0 0.001000 0 0] readonly def\r/Encoding 256 array\r0 1 255 {1 index exch /.notdef put} for\rdup 32 /space put\rdup 33 /exclam put\rdup 34 /quotedbl put\rdup 35 /numbersign put\rdup 36 /dollar put\rdup 37 /percent put\rdup 38 /ampersand put\rdup 39 /quotesingle put\rdup 40 /parenleft put\rdup 41 /parenright put\rdup 42 /asterisk put\rdup 43 /plus put\rdup 44 /comma put\rdup 45 /hyphen put\rdup 46 /period put\rdup 47 /slash put\rdup 48 /zero put\rdup 49 /one put\rdup 50 /two put\rdup 51 /three put\rdup 52 /four put\rdup 53 /five put\rdup 54 /six put\rdup 55 /seven put\rdup 56 /eight put\rdup 57 /nine put\rdup 58 /colon put\rdup 59 /semicolon put\rdup 60 /less put\rdup 61 /equal put\rdup 62 /greater put\rdup 63 /question put\rdup 64 /at put\rdup 65 /A put\rdup 66 /B put\rdup 67 /C put\rdup 68 /D put\rdup 69 /E put\rdup 70 /F put\rdup 71 /G put\rdup 72 /H put\rdup 73 /I put\rdup 74 /J put\rdup 75 /K put\rdup 76 /L put\rdup 77 /M put\rdup 78 /N put\rdup 79 /O put\rdup 80 /P put\rdup 81 /Q put\rdup 82 /R put\rdup 83 /S put\rdup 84 /T put\rdup 85 /U put\rdup 86 /V put\rdup 87 /W put\rdup 88 /X put\rdup 89 /Y put\rdup 90 /Z put\rdup 91 /bracketleft put\rdup 92 /backslash put\rdup 93 /bracketright put\rdup 94 /asciicircum put\rdup 95 /underscore put\rdup 96 /grave put\rdup 97 /a put\rdup 98 /b put\rdup 99 /c put\rdup 100 /d put\rdup 101 /e put\rdup 102 /f put\rdup 103 /g put\rdup 104 /h put\rdup 105 /i put\rdup 106 /j put\rdup 107 /k put\rdup 108 /l put\rdup 109 /m put\rdup 110 /n put\rdup 111 /o put\rdup 112 /p put\rdup 113 /q put\rdup 114 /r put\rdup 115 /s put\rdup 116 /t put\rdup 117 /u put\rdup 118 /v put\rdup 119 /w put\rdup 120 /x put\rdup 121 /y put\rdup 122 /z put\rdup 123 /braceleft put\rdup 124 /bar put\rdup 125 /braceright put\rdup 126 /tilde put\rdup 127 / put\rdup 128 / put\rdup 129 / put\rdup 130 /quotesinglebase put\rdup 131 / put\rdup 132 /quotedblbase put\rdup 133 /ellipsis put\rdup 134 /dagger put\rdup 135 /daggerdbl put\rdup 136 / put\rdup 137 /perthousand put\rdup 138 / put\rdup 139 /guilsinglleft put\rdup 140 /ydieresis put\rdup 141 / put\rdup 142 / put\rdup 143 /aacute put\rdup 144 / put\rdup 145 /quoteleft put\rdup 146 /quoteright put\rdup 147 /quotedblleft put\rdup 148 /quotedblright put\rdup 149 /bullet put\rdup 150 /endash put\rdup 151 /emdash put\rdup 152 /circumflex put\rdup 153 /trademark put\rdup 154 / put\rdup 155 /guilsinglright put\rdup 156 /yen put\rdup 157 / put\rdup 158 / put\rdup 159 /ordfeminine put\rdup 160 / put\rdup 161 /caron put\rdup 162 /breve put\rdup 163 /sterling put\rdup 164 /currency put\rdup 165 /Aring put\rdup 166 /brokenbar put\rdup 167 /section put\rdup 168 /dieresis put\rdup 169 /copyright put\rdup 170 / put\rdup 171 /guillemotleft put\rdup 172 /logicalnot put\rdup 173 /hyphen put\rdup 174 /registered put\rdup 175 /iacute put\rdup 176 /ring put\rdup 177 /plusminus put\rdup 178 /ogonek put\rdup 179 /AE put\rdup 180 /acute put\rdup 181 /mu put\rdup 182 /paragraph put\rdup 183 /periodcentered put\rdup 184 /cedilla put\rdup 185 /aring put\rdup 186 / put\rdup 187 /guillemotright put\rdup 188 / put\rdup 189 /hungarumlaut put\rdup 190 / put\rdup 191 /ordmasculine put\rdup 192 / put\rdup 193 / put\rdup 194 / put\rdup 195 / put\rdup 196 / put\rdup 197 / put\rdup 198 /ograve put\rdup 199 / put\rdup 200 / put\rdup 201 / put\rdup 202 /Eacute put\rdup 203 / put\rdup 204 / put\rdup 205 / put\rdup 206 / put\rdup 207 / put\rdup 208 /Eth put\rdup 209 /Ntilde put\rdup 210 / put\rdup 211 /Oacute put\rdup 212 / put\rdup 213 / put\rdup 214 / put\rdup 215 /multiply put\rdup 216 / put\rdup 217 / put\rdup 218 / put\rdup 219 / put\rdup 220 / put\rdup 221 / put\rdup 222 / put\rdup 223 /germandbls put\rdup 224 / put\rdup 225 / put\rdup 226 / put\rdup 227 / put\rdup 228 / put\rdup 229 / put\rdup 230 /igrave put\rdup 231 / put\rdup 232 / put\rdup 233 / put\rdup 234 /ae put\rdup 235 / put\rdup 236 / put\rdup 237 / put\rdup 238 / put\rdup 239 / put\rdup 240 /eth put\rdup 241 /ntilde put\rdup 242 / put\rdup 243 /oacute put\rdup 244 / put\rdup 245 / put\rdup 246 / put\rdup 247 /divide put\rdup 248 / put\rdup 249 / put\rdup 250 / put\rdup 251 / put\rdup 252 / put\rdup 253 / put\rdup 254 / put\rdup 255 / put\rreadonly def\r/FontBBox {-141 -288 1107 855} readonly def\r/UniqueID 4629487 def\rcurrentdict end\rcurrentfile eexec\r\r
+AEB025D4E421B631215B98625E538C86E5E73D2D0EC7019C550CD18A7CC7141CD1D898198532012A5DBAEA1C82707B837246D685E5591898ACE5B2D28D57678BDF4721E43B859E329E444290A494570272FBE4CE35D1B58151AC44A85B18C509ED56E981A08C59ADAE5476343B879F33BC3808A25300B80739A72E73A7D64B5A7897951915686AB2FE6DF18C67FDC839AA91983C4AE828235167766B346BA78685087544C3AFE4152BA2BCC907D0D188969D57DB0CEEEB7DCE55EF19011D00248C44678A3A53FD5D65DD68BCAF3022757783E4EBDE15F5836C9252AFCAA5197CDECF715DF48986D2F891638F2BFEBEF7D6443404F852F3179662CF3ABB958F5397B9FBEEE8AAE83C880CFC671F0E11F060B08169616FB0020106C43AE31DB2F49452E0607F30685C7A504B951DFE26B3294B006D7AFCCEAC871356A2115FEB4A5660580D79148DC1119524182A774180F6AC9EFE86833EEBFCF0A21A704F5108CE1FB952FAACD920C137D67CD54BE09084576319AE8FD7A004886B16736A27628AF1C09F770E20B76134CC2F8D289622DFCDFAA5E8609BFF1E8AF07B1DD0F86BFE79DE21D33B6DF9519F76672DE261A4A78894F1579F840D11FC2DAF1A75BF6E4EBD11990BF07435645DF821E538D9645973E2A844B8DF62A61393F948FE8EC9E079CB7DFFD123C04A585A473693AEA493A0A3EF313FC44C208C934EBADD98026D7E8CBC10A61DA3DBF4179EFB26B3CD8BCEB6E991168960F6EEA2558B1B30DC834C85C16EDCC63B5E39D66C80CA5CAD63D28667473C39D3371E22853E591CCC831A8F8A8F7BECD27E2526E21C499AF1D348D28CA827F1680F84165C491AF348473DCEE621C9A0840B3B7DD45FBF812877E65EE8173132443B83727724F6FF353812D02427D2C5C7726C82061CBD416A0DD5B943AC0D05A2C002887D58EA80C853F77379CBD444DBD4F86FE02366819BE71AA58A0D105FF511BDA502CA831756EA1889034EC81F01699D9EF33A372ECFAEEA4C98815EB6B202E8B87CEDB16FF7F56299AC0D99C88BFD4F5A633D88B61D22D7F56E3C7D28EDBE24BDC0C5398DE7ABE7F1CDFBF36B61E4FF924F7FFD1E1DF417AFEB3F6F28C0729A24B2C83A1B74967DD7E00DA4C5228820480DF4CF3EADA1A3DA204F3A25299B24E172406CBFA015AD07AC3A9BCD4F393E5301DC0D14E9F1400448D2B25C69C8C06BE70537C965657F4527010D0E051B70462A6536F9F2585865F13940680B1093B58E3D747B725E229D1E5E71497043B5253F13060DCA848D25F09DA79BF6DB92BEFBCC910352E50CB90317FFC071BC50F99195D052021A36821EABF2B9E3635BAF9E654BA77AB044EB29530FA09EF29EF7FA0EE0C86B8A2270A4F4D00C61C963563A54BB6B4181CF040250B6160FE11D121475C536D65629A90D8542493DF35A0238779A367A812E9CDE5F035569C5CEC80A618CC385436604F77AECF12C38ED57F86677653112688E8365F8C64F43DCA259C2E5D727366A77B75B9F6799D297DE2009C2961BC31571C4A69CC3FF27C75DF0385C4949D3455341392B45EC58F5FFBBF4A6DD3059F5A05EB664440D828052B114600CD11F7704E4ECE3A82FAA6F62331CFF9B10D57BA75362B2E4A854B86C918A807BA638C98921B76F6432E26FAA6BCB59E966BAC1EAB6DDA401CE0E06A73BEEEDD8EF4DE240390A1D55160521217661BB33876824ED7117A97A0F6A04971F735939F3BA1AB7704A61DE39FBC544315FB6392CB0882C242801BA1D42208BD5BEE50BA38F1281A9D62863787D51DA98A53A2AD4874F8B5DB4FC97C0F3EFFF7EF2A63A36D869A16F7AA2EE6A5D19A64F68F1DEEAF9FF9E65273513380D90A8C8305ACCDE1EAB1D5481D32AC23548A1A8BC7380A41C089BB9A11079E64EA3699C7E72E9E52973544A957332DF7EA08CC9550710B6DFB122A457ED440B272CF1D40B8A0F515E6F1D9A72FBA515CA8CE1E6E86F48BA37A4AE8FC3155BD143BEDC06FCA1B6C11706EEC5A9C65D7480BD0D989A8EDB8293BB4F33872F8042AABA3ADCA70BD9CCB980260A896E559A585CAB2CD73DFCCF9C0EAB3B12C213DFC832F37880BA14DF0DFE2E57C98F4D33372114A04E26D17FDCD043F308A675288AB5F1E4908A9BBD26EAE9AC291065C83EEDEA3F3F6680D155638DFB09464D49CD552E06B460013BC7E084CE4BC908962AB417B22D7DE1D596952479B3B8032E5650DECC87953DAB69D9D82DB2EF767B26542D904259DE5B9598D7E8ECDAF09B9F792C35B82D5A4367760DE65D9B2A9D26A446F6C94C473D1A19204FBA24780EA6CA281796C454FF0C1CDEFA1B92161D689921C190885153D70756DFC2D014728AB0F13CCFE91AF8796059D0E7E7EEBC451CC47425A7384441E1E7ED1DB2164DC6CD2ED06EEE1674B1E57F89DFFF76BA4581EAD57A581B5B3EAF965DF638FEC39BF81BE450085DF69CADA750FD480503DBF9EE12643F6032DDC0E2547346D088883B01873C33D4D618F48C8C735DDCD11A4D932D1FD07D3CEFEE4D44C0C22438B4EE6D21064DE7B493B049C39DB4F0C5C8EBBB88263BD74BFAD407561A9648A9DC0A4238F12AFFD26B05D04A2C093B14352DFBBF860010CFB7580A49BBE4D1FD747A7461B97FA68CD3F3B6DBA8527F33DB2043DB11B694ADB8B735C2E0106E11163C77FE4645F466A08168BE35EE79679813548A77D6E9B2FFA5A2208A2E48F8B7BDF24A3F932CA8CC291B0EA2439149B8F7629F1577BEA7E85D5316DA030EF737FE5E94CB0D5FB09E1234F88FBED834D7C9A96A5C6C51DECE4D7994C199D02F5640EAE402D5ABE81DDFE9B5C134BB2F6FCED5DB2FDC593CF8950E558CB901408B1BB741B774731D6C9707A9E679C7881E79349592E3CA4EEE14D59BC0E0DFABC4E42C5CB7E791BF569FD2EC45BD32B2A9074087CD05BA13E5EEED007F47E55BBB12F85D80188FBCFBEAC565AC8263EE827FF31ED87EB6FB075B6C9DF5F90EF3D8D8BE56245CCCB662DBD1A8DD77A47981D521F1AB0E7F6A5CC402659D56D6651FC4B67A8D1BDF88FA97C0E34CF999163C99F8C65340534DDDA2D77F3716FE295E5D1762C2EF5FDAF17D24B3A10EAE4552F5ADB7D4D539F7C4BA7612021EA6ACE4A46A21FAE7AACDC60AD19B96100C6410F7379D86010C216E989D563650962679C4D3741A7DB9DC5AC38D2D3DA9E2DD394A940382A906E5B26599C0964F557C1E517B8D615546A73C6BFAFB6C97D419024C4AA0838153B7B29803A79C343A20A1C0039B5246E09584353B19EF54A9C5C64DA9FD99065EB2C5546F7B04C9B17C9C6709A2913BFE1DCCB3318EEBC6ACA6C25FCD0B5B46562FBAFFA3FE45DA3DB5E662F852A06A5DB832509E28623002A1C3E9B49608B57BD6AD5429543DCC1430713B448A895D722F2B241219A1F12543A93EA92C2C015294E6EFD997FD14AC4D7D224917EFC3F81125AF387C0F9570EE8632898E339B53EE44364736194712F35EF0A845E86F3DAED7B135FF18DC4A4C485B89899EE027C26458ABD1490F963D9447617BE892539DE20A970B934E0BAAA4BE3D5D406231EA371788A54EB1686BB336560B223561250652093E833C4FA49E48E3128DFCA29BF3397B3346F5CDE63BD0605198562A17C3982C57C84CC936E6A35998DA3EB9E57803C0F310D0767832A904E407CEE752329138A5E981AD3989E4914737D68F0C0CC76A835BFBA7A67F91BB70F8A77DD520338A3BBBB3A178B2526232D8EE7F057AC2DD00B2AB210AE367E3E293C1C701F646E71C414D17ADD0E2211ECCFAAD3E5F81E2FED7DF80AC623B8CE431C0819BB4D49F3F75F055BFB81265B553A39A8DAF0A45DB1E87EE18653BFC161AD04FF29947EAC4816EC94BA83CD180495BB5812D139E47C63454C394CDF6D5BC10FCD6E2EA2B6B299343D77CC7470EB5104C14AEA664458ECBF68CC4C4E6CC91AFC7C67A1E6D70E59C6E147BB6EF34F104025D8C303CC664A74625076876445FE1C1C496BFEB3CAC0ABC0FDBB8AF8E85E03CEC075B37D0D1F0F5D5CE4F3D972489A094A746C530D3124F784D7D850F172D62A975ECEEEBBC192652730BDE03D227C92E90A76BD9CA1BB316F1080E6A31C5B097D523C48433181B86840CAB932B20D6B44EF274955DF709190E96A93DFC79A6C144256B865B7D095CCAA7BDD81754043157121B0277C83EF0DD20C343CE934CD6F67203B378E63B57272FF2983C68F3DCFA12BACE7346E16CE8E52B2DCAD9D15F48EAB9CDCE29B384A71301BF8DFAEDE45DF1213967D8FAFBD47F506DD79F2E4F227141D1F7E0FCA80786CEFDDA18432ED613292981294505F0571B990AAB88185A84CB7E21BC41554000265B43E156A4FDEFA5295AD7382CDAE30B424594C8F25BDBC582B1439796A8DFA6C85D2A3C097EFCAF6186AD497FF9853447DB9F1FE7A01EDBE526702399BE6BA2A2A0F679F094D820EC77593CBBA5EF96D26DCEFD1C257AE80415E950891FBD71B430DBA67B67E86F8783CA1202E564A44B45423340E4A44DB1F3D9E472AEE86AD9CFE193ED26A8D2CE70CCE7A3FD2163893858B8182E059AC9FF290F3DFC95C9A0874992C431D3A349A5327BDCB9E22935810B2404E09E8841E71A4AD9834A51FC38F4226B785B32BCDAE7ADB00FFC9749D252EFFC06E22CE2E7ACC619E201C95BDB2E946AAA321030FDC9E5F2D5B5FE3C6F470C2594D4D397E637FF595C3DCB00EE568A4AA296A31EB6C86944C96477CFCB3CA9FD930C4856201BAD08BCB06FA30C7759F8FD0E933DF4E77EC6C28E339487117B4155B51E16653056499F4F3002CA5B527B823EA7F7675AEED60F14209DBE7FED4A13E4CD1965C29E48446D79441FAF35AD0889611BCA99C054F5F0310E83E6671951041ADE2CB792A2D76D16270212273B755819F8EE93C3A5489E6F8FDA6450B3E8185883E7720F7B7846A307BB45D21BD0626F7532C643738F7F33301AC6C530945520379666F6CBBB10BC1CBFD3FB10A8755F64AC6DE5F5259A8D71152A9C44657AF9A766946E0ABEB1923655F9EA29065A182AAA78ACD3BA6D1A4583A38E1B3FBFA0B89DC953627DD64EE8E8A8B0B7FB579F32508F29C087C3ADD88B07C93CE52763E2F6B54B2DE988C325A430BF716C48C7C061B292F8FD2C61505898338A38990B60650576BE2D74D8C74886220E884943D39013F56D3C3B3C99F98125538341B9AD1F3A6BA95F018B3D8EB1DD25903377180ECC02B10DA2F50C2ED5F9D4F8297EB17F0C3D83D3F56BCFEEDDC762AF984B1F72643A466BAEFFBE418C2EABF2741C8D8CFA433C87C28C01F43DFA9E1DDFFEE9768BB0A792CB41AE2C70DDAF6AEEF2301CAC0E316BA0D078AA1C90BC3EE6F62005762231F00024BC6550B2DC3D5C21380E23A40A1F8F52866B6BA536BB0B699DF8BFE26E8ACCFC66505C7EB138A76A46DADC53A8C68415141AC1AC0EE0D5D71D250556876DCB49551BF6FCA02DD7AE1BD0D91277F71ED81139742A057F58AF5B5E2BBC598D789DEA497C4B55688A5FF3E9467DFF48801EEFC81699FD0B66F1322725B3B2B3EED4E319BE7D33D6BDA7F4A2DA8B2A552DFA836B3705E835EBC971E7EC1D7AB5DEE98F53348FE1164F286E1981B8C4E5292DCD7B04DD08EE20A15E2042BA611A3A94F6BC25EA965DC6BCB782A9109797FAE5CD41868ECDB8437B8BD9F8FAEDB1C4D7CA4B8822C655F3A9A95884F159ED5C91954F0F2E7DD3FE6F31233AA4EEC303BCAA8CA5428726ADCB1CC61EFF574ED55C55FCE3349244E7C3FF31A7FCC8ACFDDEF9A3FCA0F3397597D9456560E6F5966CAC0B8F254ED1F196CD59C0FC165F66282AAF51CC3794002A32344067BF57CC14FBFE8027FC795B8E7024B01E04FBD3B2AD1BDFF2413C1D85D598E5037C15AD3A80930BEC66AA2D175E94385EF1BC00C7ADAFBB5A17D551C5BBBBDA0DA6E66A686FDD9F172EA2BD0DA152240FE70D29C39E24654EB8C231D20AFC26575837281C743BE6DE6C1F8CD4873CE18800DDD36EBB3003C9316D7BCA4E521D461A1F863A5AA57FAF57E552F6094C2FE918D2A58C3051C9C8473215D1DEEE6D05C27BD50D99AC93E60CAB307829A3352392D5A99A5D4F8B6BAF50A80E3AEF45BC85AD5AF7114C9FA07AA50A142296E237B735AF93AF8F16EEE3484D46E59F2E179B8CC2B3B048054A7A2F0C5EE9116F736297C1F9E2FC375987E7A531FD1EE95903754BDFDC59A071154A817B5A367D11903A50FCBB54F2D0FBC9AFA37AAFD876583E601A1153421CD94D25C03D293B2684670BB6C4C0609D85F8987B3BAB78AD47D96EE1880ACDF470598D5AA19C334DB66096B4BA1EDD25A690EB17AE0162EC9601BC414C64285985C3CF279E139F8FBC10674411F26295FB894CAE4F5EC945F163552DAA0B648E8F96A37D10560B1296676BE6C6412E479B7695276C6DAC40027A807E9C1EE1DE2CAD505B0ED9554F25E20711C5D50F5036667FBE19C0DF6753B272E2439917BF2BAEC22846D6925F995D4D32FF06343E24641A3A9A86D0919CAFDF6FCDD3C67C978ABC2E4B2433583511DF003DE2AE960BF4EEF5E888BE4EBE92EDD7A78F4FB01CCAA44BF5C9DE62A6DAD33DB9F51AEFF659A4AB7E0414A94B42E40F622244267C7B564F88D3F4031D9DECBB64CBAF0F8FA6C21F91908CBA26FD9C84C331B770964A346E720ECEDC278AFD18887443152B053F21C1E3ACC9786D0AE28E7915A5D28934648A41B3AAEC657B52806320592CBD6BBC195EEE6B1E2DEEB3E2F782C4D14212B1A29AF27B4129334E92A7224E0E63789F7D2631AE27BE8DB7939B96380C0EB727B0865D664AC7CF387DC58CD85189F70AE6980078F66708BE44CD2F3B68D97AA6E10559DB53F18C709EEEE2957D434B87DBFC3E23A7571790028FC1C7BA4DF2EBCE9022DFFBB5DFE455F69A0321BA6B905D6078F45C7F7E8F82BE5CA1E159A1679544A569BDED5A587A53BC7428A081A3E8AA85AEB8A56992F18249B119A2B1D8392AF51AFD0217C5E93ACE578FD61994D7F534C0EA9C33AB6E123C862A7CAB938068A55D11D9D0B2717129569C6DAFDD8E942E411C39647C1CB42D29D3ED7E8CC3925436B0F5CC2DD1BCD9610336F5C9E03D6E7A9DEBE90EA2804301885DD9919FFFB85ED70EADC1D0218A9FAEA6A75C372284544ABC2FD57B5251B19FE55ED9D5020B0EA99C73C182EDFB4B48C126A622F1AB6F8CD509F89E559E7F41629FA73CC79F766534A8CE7427A13D83BD8A1F34B54D141EB238E97950BB0445CB733DC1CDA23793EDBAE8CE3D17E9FCDE7AEB16D01B328D7BBEE69FD4CA6C31C8B01AAAEDA747A4B58C80E7D671D2853D88415D70A5280F89D20DB11F9A8671A077D889F04DF3494A574A3F994D4E9FBC1120FBCC1CE16CE844B0DA510CFCF25D071F529F0348BF94CFE5740C6929C001FDAB89DB2D86BA716E7648F1268A0192ABF8E54CD443AD3BB3AE0DA4FE096BD270CE028770A660841C36199AD3BCE8F049A6DF640C79FC72EAB3F4DEEF2E3CDE3DE03AE3797FB8838C95955596E532D754D9D23DC5D28E4AD066F9DE0CB60D6AFF1F0953A00194010C44F733E37CBD7CA70B15D90AEF088DCE0E70EB91E7A1AB35C983695627EC50C45E00C5D97A5218FA8A580187CD95E4F82C4EF6BF9E398EF86BD577F4860EB0E7CA1ABD2609D66C814D8B8CDC0871EF1E4EB3143C792BD5CC48FF0CE9C94ED60A8F805D797488E7989AB818B334927182C7729ACC38FAE739605EF3DDCA8ADE10C18720A44D3C6EC2D034030F9D6ACF75230827776CCD6DBF17EA3F8A2F16E6B1E1AD2F8A6D9B6AF619151281EC01C9C59B8BD1C4E0280E83CA2778885E1B79824CB5383762BA8F18BDDC3D1D0A5DB4F032EBC98965D735F35EA2E2177AF5E18D0398732C3E485B78838596A36F3579B1BBF77CB7677C24BC13E2428236F73E5D377E41CB3A98F2A58D6661C57145DA9294C8C2A4A4F52DA8372F4D84EC78A0F6BFCBB3C331C5BA409A68A773A51FBA70FDD4A997D2919CF1B1643BF9AE4AC1B5043C94E5E2482515C960492BCD08F4101676A1C0AC77E17A846655F4A544A91313FB028EED5B041D4BD5BC130DBC80B73B206F13B04271B05DE8BA16FCE0B68F6E2BF72DC69364DFC0B5AE3E9CA384554696F48010EDBBD0F63147A848A319E0BC1FD377311B9F79C4B6DE46267CAB5BD5BC0DBDAC3655348FA255FDB46E6DD687596DCC0C0DBB909D1420ECBC5D2E966FFED386F07DFEC6ACC26FF1C4311CEE5A26163CC2D4FEBF388E7C88C6C5269585D48C8095804257E6DFA844EB0861BDEBC5ED3127F2638CF30285125ABF23D7E1B93CE708746CCD5EF202DDC38F6CE3446D6B66C9D573CA5AA978C52552B3CBD608CEC94F6A49EFEF101346A5A2EB1B4990383756797E6C1B9C687C7F5EAFB528A824F3A5DEE04ECE29BE7772E2CA5FDCA23C3D6744C546C4175C886FBC6B68F2E1D61BD3B0D61DD784D4DF20A47BF3ED8A6B3CD148984B488907C9532FF5EA2DDAE977688CF6F8E79026C58BACE60C3A87E75D8D9874C64F2686B886BF8C807E3B40B9F682D0955B682049E41901467AC11C852F9DEF1659DE541BD9AEAA0F404B8840F86743ABDF22BED9376668264C59EFF358E4D664A6C7457FBF719ED947A5910583415B319E0E2C647BEEF2AB0B2640E8F26C6DC35C44D9E25FB9CDEBC734F221D18A2692ED4FBDD078077D8BE78762DBEB9108922C6F26ED0234B7DF4EB47D80E71F08E4E5D93551D4FDE0325E12E52A688A83421ACEB216A2D91CCC219AEC4403C2105268E3EC009E1B7D78BF5B9A2D373234B5E369817C15DF5FA8F26E73223622D55E0DF2EC2AEE487F6DCC50D34C90297532857CBDC13891EDEB08C323A5EA8D3997FBEB5D6895A30EDE4DD162F66F9EC51E50CF54F85C27BCC0008E4458BE744037A94EBC841BC134E20413A26A871579894E40848E0BCA258E5D1EC261303826FF8FC1E3D2AC9C68A51C52388D1295DC53C4A667AD589E3227E75A19CFFD9E48105CDA8736989AFFACD81D4B33292162E803925AAFE68AFC2ACDEA1DDA5440F7676D2CC7216B7D5944F86B993CEDF0F498DFA73D91D69A68F0795127EFFE2173D4B27D0CC3D49F336FF04496C8D77748D930D56A5830DF727FDFBB310532141A229218D935CF9653FA8250D268C4FA5737026D36304D4450113197F901D0598DE2C546135254F0B4B382C2A17FF198F7DCFBF820616C4595736CFF08E8C725754D41ED3057885386FDD6C6759721F498CB3D1E54C5BF776040959E267D4C14EBFE891FB406CDC193D375633320204A55C71AFE2E8C6BA2E1EF29342279EB7505D40A2CC01B83863364608F3887EFCDE4F277BF4DCEF5694957ED69231948F2A7AA9C1EE23AB0605834B9A18B2C6A434BF79B432192CA0A11E5D8BE397A41B0D964DFA36148253DFCC8CA79EB4D1E95E5271A96E9C42A2DAF970A8BEBC25BE8FD259757BCD67B355453B8B7323676CBF6CBB36B139C324E4CC2D4C11DD0EB7111C338829C60830B5C3B8BBAE9DBBC7AF6F492ED1DF3876970A5A9B8C2021668112A3D98BEC5F96AF3CB5C184CC4AF4B4FE5FAEDB206F4C5054D2574A612F08A25D04B0CC5A9FAC53BA97B7E5AB7DED44683D09EBE469C0771DAC83BC6446E1984BB5625CCB42672F68AF4CE05D5B7903FC977D1D9578E22F01574E31F6645B51EA722D4A45D74478BAB5763C08F4AA3A06DE61E422A4B020196C8D62C1DDAE9984F1D8601B0C0C5F29333BCADE7BCCF93FBE391107B6CBE868A019F48790B59F75C4B35A9DB8CA923D7534C539371D7664222FFCD5CDD1F952D3F2D6A03A9E5F412249E7B614EE507B3F4EACCBA55F3F668D74BC3B7F1CDDD9290866057A05D1CF17E3E763131A1389F5E192F1BC329705D45B8C64E6E442C618D6C1A8FFA71F9E33108C2B739F5310986B90B76739415048B39B05A38664A3703CBE2C4EA7321FBEB609225F0861F0578FC7FD3BB66AD241A1CECCB245F13710798629E3AC5FF39885342186B7C130E2A5A27B537089915BBB41DFF764FC840E22403FDA7ED5432CC9B0B2A96E1E3F86C9F0FEEEF3BB90AF9CC4F6235169DD1CE77F17738430B7A397FE8EA75E288F7F3B26F42209E151154E7119AB3E71020D48CCD63A485DBB42DECD2AEED74D8AC867A8A6A03BF77E16DBC626EC5516935D374BD2A0AE4294DEC71BBD81DEA89FDA80DA13A292235A4230F673743F20C297FCB9462CCE2F36FF5FFB6870B3D0955F4B6EB91529216E448D4512A75A044142B3FEE8894BF1A50D71C3E3277D6BD579575DB226599CD12D9C314005EDA587EF6864A5BA005E0F40F249EF56A70244ABFA0EDD594B8841482822A7871C89E38FCC734422AF9AE04D6A10203C1EE2350729026757CB41EF0AE6DD05AB14EA1D453A70544B71CA7A22022A75D37C60A90AF27D1EBE04E3A42C0A1BCD09A50CD6456D7D5B5F83F25114BC77FEE784F31506959B7FBF73A00EDE1F2E90F5A0FFD77704BFFD9009FC1DA95A2D1C32C95E7A5ED16CFAEDBD203321025BCF5E3615622C40EEF41A7E8FCA42131C5D7F00DA2447E97D2B9750E51D64012D58F8A847545FC6E7E3F373B53A437B9BBFD23FD8371EB8D42948017FCB6587A9A88B6BDB35DCA2B8859C0C7E017ACF1B337E00C7C89653749D8A72BFA19428A99555BB6749AEAB4C69C5CD6DDBCDAE434DFAA9A465C8AD937987867318E86BDE0435FA4F8B7581CF66E720225757477603D8A6308B0E8E4C6C1F6C152A7F43811E7F71F8BAF37A4A01F2EDA2A68B4A5949AA97C42C7DBA9A666B0CCA0330BD04023045226610D86749E0660716642BD537C2DB1C7C44D44E099C7350A2049682E5C45D4DE95532710AE73AC650D1BF6DC2986F4E55347986CF93930A777283FB35ABBC93EEA8FAD0F55954EEAF203F6502B0D8D7C6CC8D3F1F25F3EA67BC37401A41F4408C042DF977217CD45B271CC9415128DAC0E05EE64BF9092B6564E837FD6BEE56676F76C8A6027E4959B4D8AC0BE3CA517551FA04952698D29C3BE115222F10AD39CA141E9BA9093DF0C7411B57EAC366C1B91D427AB23A85483C3CD388E1F111645898569891F22F954D3AE92DD852D51CC3D3D37C3A5318974357CF3145B41ECB9772198D8C1EDF1E38AAAF336A1D9F87F7D0F1C485ADEE172B3627CD24A5DD74F0C0ADA7A6487841052DC137C1DEBB197BFFD21CFA7571F33BC1D898067B96F1B7F7E6E34F647AE9197B1E0458C3E377866E134E76D78EDE4D186059FAA76AF7FCF8F4F11FD155E2E50C299D0EB4ACCB7433B7CB1963AFB159665FC50E44193B0FC21364B2E3B44D98CDAF86FD140CA9807C9425551F83C94C77B1F631EF97CC93C08994D82784E807497A2FED828846886EF3DDB41F1C4572742815BE6752DA1E44D3D81E1C500298071A8CFBBFFCC8AFF042DD4E19DABFE99C44776392FF00879FF732495C9BDC5308FDBD765A8874F7DC0A22E6ACA3465E848090D701D38713C4EE7D235C5E64AD47C3447258A7F594AFC1FD41A8D6BDD11A8A63531B9FC7DC98EB2C127F7CA583A0A174C3E6711069EBE91525629B64534FA3D4310ACF4AB2792BF4FADBBD1137D1F865DB057D6DC5F774E8C80314E41EC79680048BC06FA1801A9105F1B30BD69C59751749F40424306FC87D786786415B7B80FA115B7E234B1C30D035300AB000C028349C48AA4F16495E0C1FB75595D7E4DE4FC1C984FDE8DB1240023607B13983B45C4CCEB73ADECA7B9867034B301C32DD3C12C4AAD7466F53243D70F184C19E13F07B9CC6002A16E01C282FE8C39A082B56452218ADF6EB73FA8BD906365072BFDB805C50EC875E4CAEDFF396140B8DAFE9D8F0A7202F0E1AA5B405D613E8520997A24E576EBD01D52571086A129B0FB98AA45AA9B5188051C96F0921F857A02081CA85614EAF7B09E56BE086FA274498A542D065073786472CD5B1903E641EAC91B67370BC2BA8D9B20EF16E6309A58F835A14DCC949932E5E8EACEA47DBE1126D3C219AD698AEF632829DC13883481F36232B787F629CA01FC8E4FA32FF00AF9F4C2781ADEBB83AC799C43D95B2BF298FC009764881B3C65FB3DBC1719393A56F27A404729FAC49A5A979535F93474B77E0C4A11CAEDC375D79713E85D0999659779F6E1D5E6E433B1D17B0AECB9CCE321988B26BF49B341ACBB0347326E4D8734A83D70702EFF65ABDA6BFCE7E74E9424DBF04C18A355F7E1B9326DC9D037D2AEBB57DDAE60B57F0D866D6D7AA5E3FFFC8AB06FC4D5F1B19041C2281AFCE40D7FCDE1F9FF2A634106E33B46672BAD7D281A57BF4A5A1CAF68F07350B0C37C6AD225F8B48D9386B00A08586402AA3A4BED5614067CE1099056638FC1229F6E87DCC7971D8F7DACB38CE5B8B23DA0084B3D4863EF09AFDA1E20C4CE4E2D1B9406139848708B9CE713200BEC755D341F77A8240133C299EB39C7015FEE8A8C5FC1EB14F380B1698BBA27CF1FFC9B739A7F230AEAABCD4590C132980AB39FACA3E9290D488437010F6828868E2349BA2081A4655010E964DAAEC843188ACCCC26C8EFDB4AC6E0AA026C8A5737F0E1260F04FEFE50874497B8B15A6E8033FF9282121F6E37D00BA7387FDEA6DFDE11E0B3AB052830785F658C2D2CE12D9DC1D51AA0DF70D11A35A919D651668780EBC3C699F48652D44FC866FE6694EA74F24FB2FED212247EF7FB16781907D0A66409359BED6B780E55F9EF78F93EFAC31C1D21ACE4A9ACCEF597C761927452A6AEACD37840D96FF0919B884058D0ABE6BA4AFA3883E6CD9D8FBE34B8DFF5519106561F179E1BDF6B1811649868BF06B73B3F62D51D15DD5D084D3DDE715DFFCAD67136AC967E05600B72F7719E00826D2276C61004B363E843CB7A2FE41411A18E3C75A6E5460D2D4C7EED5E83CF095D8109499C07269A1756726708B84DCF12F23027A2F44264EE7EEEE820C7861D593021BF77263795CBBB12EBB8E1E3C7374C5C6F8F8EB349CD77D4F2E40018DFC9122D728CBEBA5F9206AB0DB06870F09548094E2B7E24B024DA5AB55520BB97A479027BE624FFBA8165AB67DA4EACA87E78226E1E0B4083207A17237A6DA519F674D7F8D5DD5DC8A304C6924F021377D71FD42B91E4E7902568B4BB37E9B1BB2DE689D090A13E8CB05709D45D10EA19A2A758C7C8891765E47283E53273585ED30656107C7A465A3BD4829FDD6FB87183B5124A7670EA72DA9AF2BA9E963C1BBA02884BCD84CE3123EAE9200109FD106074553195E520629F58B9F4BD8BCFBEF1F2912A4D83CD3F73626909FB9D2014CAE18BEA6F7334B03C3DF477A3C64F38062EE2B564121D861E737108054929B74E61450A2E3E2E6B131A6AEC88D81D4159A8402FDDDA7A496BCF3C06962C961126EEBA7FB59577C76169B9092BFEE0B422886E7BC8DDB5D0066631AEE61276D7072EE930447934D47E5E189870A45E51211ABEDCD413EA19F311023904F26A8D395682AD475FC975BCA71984CE9A6C1D25A3D9E9F420175CF92A51D3CC950E2AF0FA25CF34BA2FECD765C8D549E5A068501F966D7A18F86DF3E2B69F605EB4A762F6329BDF6A6614FE9A50814D1320BA0632F4D3D977E0E85FFAC051CEB6A695ECE254F6B43260516817CFB0EBCFB6A4E0064FE7723B036C40FBA4135C1B24D67AF18947BD391EABBFC44F70C012A9B25254FD382F6E53797BA3044FC723396BD5A34A92BC26B2FEBE5388CC90876D25869679FB665EFCAC516EE63C1F0CCF035B6FCE30B13C9BF3A16390BC6BAB312CA44756C3816A646BA4B844EC9C4F9805B718F48513189B2E1B78F74C589658EA4B2DD53D73779E172D3B4BE4E83A66ADD00DA88F01F725BC67CA695E075ECFB7FB537030B36F589A5E375FDA978895586710E036EFD7AD81339A245C1A6364373F9FB57DD49A98FB7AD9BB1B29A3E0E58F8AC7E0CDDE2D65074C3BFA55E50593D81A486BF68B0042A4219E7BFE23D0691E5A27A8D10B655D7A0725C5EDF1240923598FB1DA4B1F9A2F533EA19C148367E594FF1CF4CE75CA7D7EA662A4FD44521A5AFD23C3B42AE0D857023CE47E0074C535DF93A5047A92E91FB0A4B7D5D8F1682D725F4E8D55157AD082AD918FF2A6051AB00A26B19BD65CC3D287560CBD235B0F0F774FA38EBFDC580767BBC1CF16689C9C7347789F4E251166336B0759B5B5FFB79415480DF76C9E737BC09CA51D7FD729E7A5D4CAFC8F18CBA702B7E6F3C36FC31E4F3D04DE38B5D8A1E3975CD49CBA6033A877A5B15030923C3CBA1970D3F40B34D36A156CEDF9CA841F4332686768A8713B7E16195C9F009FE1C88D5F4AD0FBB5DD4D46FBAC0873D49A7F15ACB845DF908A2A08F24C2B66CC2691A2CB8A7D2D04823DEEBFAAF191D5B467670E9827056AF7254CBD5CC1517C96C55266CD97546F9B15E7065817F7E30658EBFFEAB6A9D02302B4B2477D6CE0CCDBC1D61A1EDB0AA3C3C1C31814357117EED6D77D31AAFBFAFB7938E2CFEB5D8B69C8BAC3A6FBCDF9F8347448DCA392B2CA5A50B2BD1C740D91760AD0A3EACBBF9ECB87BB42E15B86CDC71D2F51BDBB1868B9294F51ACA5873B8E093BD71F7F3684D2717F202CA4A38AF8ED31D0999E3AEAD5D56C7205C579B0FD0FF8563BE3D63459709DE35C435A15F82EC73716AC7C88A2E52B04BBC487CF405F95FC4A63516906BA62DF972BCE2BEDE6DE5C023F5B5124AAF336F9F020CF889D599F0D1D5709914FD66E0CD7E3B7C7B6CDE1BABCACCD45F6945DD2BD5B0572B09C34477136BC64350E962DF1C455AC3C49523715F8F346980210930694AF52723C183CDE8E94EFA252C44FEC452EF474827B104BDF72FE841EBEB7F0880D1211DBF10B07D9A4C37E9FB98D30329014C7DCE1082B8BF6A3C4F8E908FD31C997EE34A4662F4E7CB1E72C616953C67080611E4746B69339E7A3D4D1744687B12CA26A374FC3EC5C824AEA37ECA7070903A5A6409EE787322E766EA997CCFC56D0AC04BE6B929D0A42C3C0AB54C318512C7A9296F0BD27EFC72A6F1EC8BF8F6FBFDACADBDA41D5C6ECB6ACBD7033FB991108334AF12974D257BC641E3AF1CC7F62FEF22B6B1788850791A44A253A4F0D9E2408331373E525D1417118BF27A5484269E66F717429F27FF7F8EE9F71B9E9D20FCEB5E864CDBB1C06F35A251D3604F4671280371B27629D05789833534BFE4B2ED10B203D6D6D74F589B92C20EE8DF47D34A831E99102F03A4E428692980CBCFCCAA2E0D1EFCAD8806F9D0DEB7C7090081AFC5BBA1C9401EB13FFC2A8CD1E90B57D98A67AFCA910D7AA0A527C8F2F8A16FDC07556887CE9A808391C6242F232FEE155C67A44ACE5A7DE820EF8E25646BC07DE00CF409B7ECA876F8E6095DA2EED104686EA1C14016732C01AAFAF4369AD360B995E858E67C54711F63A19858A9DE03EE2048810257B4B0BD6EC686A88C08E9FAF92CD70D9B0E18A674A83A06E5AED916EC7C574A27CE860C75156441CF40F40AE88518EE992229DF687BF38C5DB914420A3ECE025B9098B63653325FA8C8EBDBAD682A0BBA32BF129ACC6A6C85B779F7E9EBEFE1F32D0520B5F1D3F21656F9CE77B9729E8CB43E468177852DF4DA67A22F32E6BCC36830005D1858A5C07AE8FD1F9172CB00B0FD56037D0D1D851254AB2F44414C4F61AE9BCD229C33F58D0C4B3EC34083431FF64A058CF55F23ED03E6542515D59E7A5280797DB5105DAB9F8836C35A64CD578686E3142593BE33F7441AC2A4E74573421BDC7714618C0FA00F59C512967043490A4DFF96AC8619A59F908D8CAA66A4041C3D1BA0584308B0E58A4E5A6C3D1258AA68B3A89782A2AD4D255BDD5B1667C23556D7C4931BCDE23D24CA262C057DC2FFFBFA4942074E543977F759C72898F99BD8C7508991D9A445BE08516ACC1BEEA931F91598EA4FDC5BB14C67A8938D0CBAE95294C5E622654AA3A8ED39DFFD28383E2531514A6F71C749CBC6248DDAD462CECAAB2CC7E938FDE69F6170F224A013E59C7FC605D5594CC6D5B41713D732EF6D9873461E3057C2EA559B7E161BA6BB657AED63DE07B66C6451CF77F5A5E6301947FA2C43ADD5AC5D2B1048CE65C6EF6383BF2607A80CE114D98E8319E990A7B0A1838F409A7F5F009B08B0FEDEF824CDD4ED913DA038855BF4287432BCE5770ABE796858B5431504B450F67C034C1650ED6392CB832A9A7E8C9CF402DFB028BF5B5CF7885B1B028B32E5900D1ADB58121517709EE992DC7FAC74197222C73F9AF8FF167256A35DD2571058CD835DF1710D319E9333197105CAAB3EFB697DF5D3F75BC370AE7C0A1122D162F79B3B83C0ED2920153246E233D22E32AC030FC526964360121D32B2F94B89FBDD137BCCC289052E5FD64B0AF62C82ECB5F964A9B8A81C21225969B7A7650CBDB9D99DAA6900B442B6E46916E0BE29679400960C5545669AFC607E87E445945590E45589852E79EF22B4C2C1D5CD6AC43E5143BD85D37FEC81D69C66237551329A7AAC385874B1337B2A1A2A5D9EE0A59FD6D49B67CCC6594AC97CFEBCBD7D7198BDBD488E9ADC5A79E16741CE87C89D76ACB57A0726C17EA6A56EE57DD169BE18F1E85B49E3785E3147DE1E0CF124088E25493788D2E61DCF8EAC2FAED15F84E95FE8311B29B9D4A6282EED67D2998FF60ED506864423DC56CD7845A830C6C9B47F26E2D100D42E0D963C13B1BC479148248CD9281AAA2B0CC74E7EA1DFEB3F74219BF1C301166F22AF9D1423DC41B0AAD7311F99F0DC93A26DC990E7FE60F5DBA5E2693DDD004F03EF8D94056A9649FDEBFA4EA21C245CF2B5E85C09C5BCCEABB3E3ADD26D7C5CF0DB3A468969E351C82795DA9002AC8FA0E8B3DC1C4E2E84AFA61DB060696BA115A686F32C3C3FE54F6344E5AC6CDBE565A5CC814F6B87C53830DFE9D4B29E0A7E58AE9F7E3C85E15493C3965A8A9711068664E062AB683A03C886CE897C039E76F0CEF6D1D86224C229007BC42DD26B255DDB541334B8E283410091B9B37DFB169EC2B88A89717FBC22AB4A74AF6FC36506379D5C67465A09110B30743B7C3C53C7177579648332595D98484281D1CCAFCC7617735574FC7BA17BAFD336DF35B87EE2460315972DF7CAF73A15F85219CE9D96C2A0EA93C735A841F87616602B341EF493792EC3C1845E6761722E1687CB73D8BD4E70A95EFCAE768199A825950AB709853E9DC125118DA52D931D321DD9EE397DB715C81732252AEF2BF829C10FEDF634E82E08006287AC4F1DB65362600340B34437B43B918D67A1F4D36CFD223F2F3FC0C95D81BB79A2CE0B580B3DE313502176432C070ED057DA6CEBF020D03089F29721BBF6F9E664A6CE97B3F5B9896AB09D1645DF622DEE21C452028D8FF99C5DB4055E38AEA8C6B18F3AB00E4EE305614CCB353689AC3259162DBF341EED39E9598F0486FCD4D1E96B14C52AD7C004CF0690B7F545C96E0AB3B76DEB3902E3033CF9C64EE4A48E5E3A95F82C3258C17AEB77B1C8EE9F3AB7474885A4E90C76ACD308D2946DD302CE649CC3901299DB80F581320D53399C8AA1C2A7B0F3C360F99DD9A0039EFFF20C504E6C16CC4D3262A763721561D83A661D2A6797284FD5A390F5636C6206840A72DFF02B3F071FA7C06B8E784C13CF523F82642FABDBD490C0ECDB5F6D0283A51336A651EE0631FE7B06392E7804FCE27A56319092D4D2F0C08047C1098B9F975916AADB8A6D5E43308638CDC1F1DBC45A2687452965F0F5BF6411C96BED7EE7224C6FF35E6ADD16A903EF801200F4DF5EB1209F6CF429A1372D3711C714696C11657FC4D23CD57D1BD20417D42C264BE22A4B1561FFA0B8C4643813536C32639CF02855C0D77DD7E07C3BB43AAC874283FC5474F86DD79E4EA41D0FB6519AB887A1F300FBD817C16E7A75525A5D3F200FA3918CCA6A9212D1298A377F6D5DD00EB97885906628E84B310D62D645425E6B888277EAD49E10BF745FC5C9997621DB426F5E9A9FFDB799366AEBD9917A971F319D81CF91D0FCCD512A147F66874874A7CE8AAADF46B2C594809C0C0783A26879C34083D09540258CEE979DF97EEDD3C8D1B6C178FE84ACA3F982FE1FC7B60773CBADE57EAFE26C7079E23A23B687BB81C687D274A85A4193B639DDD15302AB11A5622DC28B7FB696297F9A6F457CA745C7484C2F37154E27DAC57443FBE1305072163DE5CF930F981145AFD51469F2D7F405146A6D8F44E6733CBF134DF2AE6911705424D7D8C0F1347D72A0E3B53873BD017C952EC2A5C02D1E0866AF8FA5C558C09D457DFEB92606704DFA0A562A7C97BD0789E7233DBABF01F83CB6D0F37403140A145E3A8ABA61D7D34E2F3B899BB3445B64FC0F5B9B8D180EFE6171073F98A8DAC5A9EBD406ABA6411FD9948648C95A839D1CE88E78C3B9EFC41BB61E887CAC9573587B3C713F81DEC3152030F67C75B6DB2002118B43237FBA2B0F0F383DA0B10124EB20E93F85E0D0B433D3E47C2402DD5AAEC1DB20D60D10A51004EB0592337455B04D2D0C241F1CDF16136B59A92092587C300690E31CEBD0873C5B9F793E36E7F3C94F9B0F5A494189A1C852FD91B42B1D4B58BC16B5CC42591F0E25E34AB1DFE28B571E309D9872A1FEC094E345FE57EC80C37089B280F42E9B653DEF59AF90ADCA77C12E4F3B3263FCCE42C45E270DC6170DCBCD4FF8C6ACDFE5502FAB1D20B454BBDFAD227455043EC06662EAFB2019269F56765D93948D367E01393BEF9BDB61C9CB6DBEA7CD104809E709A9C9E1E629AF962E4B29844CD394A9B3D56594A279E99B09D0775399B46BE643089144A10EF96AF7119DE27BE8C3D8893CF14485E982CB0D7A1F42BCD08C323EC068B7DCC13B7965E7691DFF6C82958B4E74F2FA210FBA324AFF061CF166DB5A51056CCF25CFFB428413C540C9F71E14E6774039A771A38CCF3AC16812B9DB2C1CD178373D5E3D513623C178937019BDD528AFF8BA30F08273FB70ACAB143F6F2E93D73ABC6DFCEF8F4C4BEA297623AD2BC565FD59F87797CA31A942FAF1B65D84CC8EAF6B63CFBB808A96F271D88D75073541BF7D3F2A9962D953869C521D440AABA9F3BA262453AFC94E6EA4A1F097F74E40FB693D59665BF4EA09E6EC097283C67BFA5EE48C1A468B3F938780ADFEF091AF47D9F986585C5239801CE23B8B5AB182B30D78EF632AD110CFE0259AD20BD32EC64D1086BC54185A33708FF34BE79C693B6E6B778F67F484DC69EE4888381696CD6A4F52CF6CF25807228D0F036E77E9FA96DB9F92955AA4E2171CB6DF45D60BB17518469369F826A9868B7A7BBC6BBE5286C26C60CA36A5298DB3F2EFCEAF9140B2434790B3FCB2E3EAF173D9F43913223E35F46115EF494B2588C3F659A52F1CB6BE44AA1EFFC1F184024984D1B3C61325839C219D538B5859D70A6892B667FF2766F2CA1AFB9DF3E9CAF19746971BE8720C1A74F66CFDE0E676036703D8B4B77F25A05E89D11E176FB752C75003266F6E359714F451D10CA9FD67AF880DB7BE18C813FD9BA998A725E36697F6346083718C6AA54A9DD705EF5856D0EA9526EEA4CD6960408F1C70B91270EF8B0F3A526B9C13D656645DE13785D768E48A630180E221EE2A62104F8966A03943F7315CAAF9E1102516375CCDEA1DE9502177817A8354773BA4175B94BA9964D233DABAC1C51895C0A671C2B230DE3248B196EAD0FF5F0167183808E7D18CE15F082169029D878FD3CDCDEF65D2CF2C4B35D0AF54F27D68FF99BDFCC6C7A3BFF208108B2BF7B1C2708D0DA1E5A010AA485FF14595245EF572936233FAD349CB5849F3A67D031EFB6E357E1134198E9A4AA39E9A2F03A6AF9586038A92CB24C2FD9235168BF99A1273094561A908326D0D0E58C848B3BAFD0071BA9C72A274B4AE6528A5BEE972532EBD10D8AB19BC0A469AF9BE9D80FA245E124947939B237895C5C92656D49E60E12332572C1481105931E971D654EF0C4DC01E8A27F4DAFBF73D2F35DC78CA0A888F18933356134727F0AC7E153B8F904959C15D6B201B42FC0177DEC81E8FEE066467760BE3BAE6043F86094E35A329894B3C19BC434EEDCE57EA9A68BC6AAE20DDCD77C369F56D95181D8E4137E839E1D5E46AECF4388EE5E42C93D50099EC20FB23694AF46A2DE18C5F1E36AD3E1DBB675D061FC49E5BD21BF62E88B378788F965A50C44007F974D2FEB64CD9A7415643BE2BB253E4F8EF664D3C71933921607FA33F9E935AFA8E18AC26FF5BCC267BC06768B7016748BA915FF1D37BF52926C6FAE64BFB75945B9E7A589C5CBE051C288D31EC38BD7356560A52D57462E808C3C107293DF1C28C3793D3F47A4D4D2202571E91857016B90F40EFD8B02763E454F9808FCC5AD0EDB5D41036CE56F59C3D3FF0228175AD3FDC2F817929CF8587342AEAD1E31A4E41FCA00D20B1F94BFFEF5C449D5A1DC6D3AC2614B956C2F3D4E723D24AF817162E8F5CA0A0542ABB04EA5B0B6FC487D6915F54E674DF0C4D84F62B8BCD76D1FDDAAC219694B6536EB79B5D690A740C377B953DF0D8160D538A581093F4F96F38CE89D12D6F33C9A2AAC9C859E51058C78F6FDD833FA29CF894A984B3336F3A9EE20FF7DC21A0CE1A0827E1DE08534E3AD5D3FD715E0D0822BF1A905E4014F466C5043F7547C673CD0A8E5BA68710B361600E0E21A645D7D9596488F39775E19B1EE6B47DCE05DE7E6D04E9C105280DC768D4C534DF351AA0E39BF36B2488564C5A7BEC30416B3BAE5600EAFC035A003560C8625F4752060C093C70F934B02A5CC1A94B593A917B33BE0082B0746C6BDEFEFD683E6B79BA94B9EFBD288DC5607E750BCE65471116C4283040C6279929AFC4DEE4040F8522C6D7DD95FDDB3EEEF1EBFA09BF3B24982855F7B70785E6968918CDD860B9395CBE9AF5F5F3D4F56396416687DF8789DF196C397B39FC49EC60594E29B8C3D31572BA3972684A3ED441BD9911772963D6CA8200190B9A587B855AA1FC449B9087F3971BE48A4FE750E67E052A0C4B5A01F721B18A364A134CB36B89A7B22F8A501583D1BF8F7789CB2D8598A49614A24191B7D2778EBBD65304991A7D723B2BFD41B01EB945BD01671ABE79DF2D2C2DEBF8AC7A35383551C184F02D9C5039F796ECB6A7D12A193BAC68B1B766D3D8C03F1D281338E0DFCCC5AA308BBD91FE6E438155696290CB55D43B606891971AF0A188B7ACBE7A09FB7AE0CF5C101F845BC5E1E35FCCFAB011A6B65CC71A593AAE0939F0A6225CEEE385E89E30E8A00D4BDF3E60B72B3CEF884F8E41628D209B0651E5096F5E0991139889A17F31DC6A4137A3C8D64145E37FB6F69203383CFEF81B3E1E3D1CEE0C2BA5000D29907FBFEC3430F23FC4F7DB2CCB938A9DA022932EA14C417634C06AC95A06C0A82A315F8406CA2B935FE77184A1F570877E37E6A82F56F3E790261ED1B2DD3C2B9C4652E4F0E31ED2D81561A7730A1E623205504A70150777EA1205CA29C5F04F73DE02546586EB30D9707D93D9500EE04BDE5942E70B55B0253315945DC1119880CB839C7B4BCB54C103BAE94F78DCAA1778A7A83CDAF363ADE3A28A6EEB3DAB74046AE53C8640FEEC79B4CBE9B5A16802F1E2D1FF37410CF159CCF8BBBEED54DD64751D50F97D9D003EEF1609CE28071E3DA4653ACCCECF3AD251BA6A7C2E6CFDA7980C2A6B68B31B2C46DC2599D75EDED0A35E1069BBAA5D25E0FAAE5664DFF075ED20A8598B9366FD0C0C03AFA9D0CA0389051A500906A93B6A664A15307064FFA4DE328BD36D2A3348B3BBF9BB21A109CA4724CF1EEC32516612A8A2C11B09E847B333C22FE11B18468FF5C4581BA7A484AF5D742FBAA646BFE1F5AABEFCEF6EF5E15256F8C4AB79FE099642A4BEE687A9068E56149137023CFCB7072ED160BE480AEDB674275E97870D6F86576F653B5DD64463FC2F4B316A9BC6BA83209759BB482D08FB672ADF1BF124217B4E2DDDE00F1D89C2AC8E130F44FE80522005CE58D98C2BC6A729A2271B53253C62CB080D058C6EE1F0C719847A367BE06B5767EA8C73F516FD98A5801DC22B8C6CE49225087D8C341F296F2D697077232ED7B07CC740DB12040703AD9DD9DF45F3F3637F591FFA9F774188BFABDD2E486434AC7A3C1FA870D0C8ACD357DBFDA9A3BE18BD5BF62445DD3F4468A58FB274510D202FF8BFD6E8701B9655210D05AF25A626D5F772582D07AB0D93FC721A1DCC28AD45D3D7DFA66D3A49578B46CCB2EB62649BA0BA733C8DE88AE3B5716B38F9F1D6F19179E9F663A85A1237549FCBC7E93E0A584C67834C029B0BED6E4967328737A57A18BA1ECD6D0F45076ABC61706D94D0DEEB9A5AB9053587C48393C76766DA607048E7F145D6F9C53D3C4D9FBA7834836394AE179416C64A4BD1AF0E93E82F95487AF76D035714625989F2D05F1A136C9F5C093226ABCF6D910AFBE6FF4D6F41A49C396309B77120E3349F1647E0442077C6508B9A3CFE24A26A9377E7190187877F68DFDA1E4E531D2DE1CB8B884897F0A837852BE7AC6333D78AD453E726128AB0CA333E97206AB8B14B9B69862A98108330DEB988FD2E063281AB95448D2D3B1C1F1686F9E8C3F5600DE3827CAF007C3FB5E036A6A351177FA0745115F5A58FE688040CF0C6C9EC7CA6A77924D6DE6D99285FE2B6967FED219DBB98DDCDC4C23124F64E74F5566B09EB9200ADCC454A9445DEB9101069462257AE8DB62C517AC31D2E5752BAAF00208DF1458BE331C27FEE4236726023F0753EDD357271945F2CF65FF20CB8726DCD1AEA7FAEA4B6695B7AAB3FFEA21E882B41AD60163C784BE89540A03669A5C36DB2EAE917B166B0F47C1BE77E58130ECA71CEC54B910637771E7B807386E7CCAF502212E62D62E11BCA016B6714CC3E73E4E437ED4D3C5B15F1A73F7C25C39E74FDD2744479638D6A70039E8736F81DC6AAB84223FDDDC87D9D4C2CC894DF70F0E41A381986FEE96317CD06426E20E82723D42477D6AE9F1448A2A9E151C2C40A62CEAFDEBA54A46A652BCD351E3FDFF79531CBDC3E76881C5E4668DF1E2D71D2B6F090B47F79A8AA71CC0A9B3D5F03CCD74B04B370FBC640A4F02A91050CCC8ABBD68A150F056B2CE54B3D7BEBFE9BE5A979B0DC0F3D058805E1AC79DAEA3EB15E224B644ACAE461E5899907E3B628EA907373BECDDF4EE01E8306DD0291B59864B2512EE0307CCE9104ED87B9E27337BA6B8EEF6344AA15C5DFB6F505A7F38F2A13E78B90BB8D5591C603CC1A303633E948A6717B3310AFC319AC494A5E889B11FEA53E3D1F199AA1BF1187C062600977D313F57BD82C4E7ED6B6D9D4A8A5CFE035ACB9DC6C6AD51657111AA9951DD13324E865F683101BB7F010C13284CC23DB909681F93F9820C7FA696B20450C85FA890CA7345EB9E2183F2ACBAE45FF660C34EAB5399C4B4084A403D23EAFA5DB8DE5C2D8E5260FBF4260F739CB5AA7DB8B7FBA8E0B1606B7C031482D2F42E423DABACD2CDC916D29D5618AEF69F57688A3EE89746F73EB1F9CD05F2DDC96A7B9E964B06C5A1397A80C554F4B9BAA7FEC30EBB174BD2AC9E1DDB1D0420F8124D06046AACB824EEDDA0CD467B74FF953CB1607D60965E2D906703AF73DEDCBA3F50044ED9DE0F8E85D77CB4ADBCD5012543DC03CAF038832C93F0D8362AA42C6E57AB5D5574456E57FEB77190BAA005BAFB17996E1ED207719547319C325CB1CC46656FD1D85EF7E2964A45337BBBDA0E35A01951FD5E425BF89E7373A90D5D3351055F9AAD4EE58CC49530C05B270CEB08F7A444E0CB114680F1D954CD1E9B729C95DEA0D8D310AE25655C017CF57614635872924878C7500B71DD5A9CD8DAA22540D76C9D8B4F60A336B1805955F8F0649F3F60F1C7C7EEF55D39A296FC955C9C90D3641B45B8EE4DB325A5BC4FF7B82BE52023D30F85D16DBE4DEF643B6265C9BB024144FCDE1DA43B00124DE54AD592F6C017210E6E1A4168BCF9B12177B3057A00795DC67AC4C8FBB5005C4B4988E94777093C0DEE5FF18D7D01B39F8A18E5EE0F2BFA824DF7E8CC21F4500D9FBB8539C0EC4345C0547C8D9619DF36541CF06AEA610CB4DD5CDD5F07D180DC412B9EF1C4CC9045C2581E5A79185401A3DABBFE10364F0072CB63D25AF7DDBDF22A851A78ADA97F7EA2B35BCE0CDBA01C8A6418402D493D4EDC1AF9FC1A88A7C2E70FE428ED8002FB4F748C63C3C759B9C41287C4C1275AE065A1B169941AC925698EE38475D253AE48558ED638C8A53A716B3AC50C671AFC87E8F02A31BC2E4D30148A0247F293B17A71A55A07302577AE1DEC767139D0A3A1DE5C521F57D9ACE4146D7FF5C56CC51784B89D5253DFF9DC85CF1C9E153A6A76D295256A8E4DB4EFC521B37DAC4A5D7733EE406BFAE8724D80338527E6D96B3185609580CEC3220B48E0FF319C2D7E16CE51B90922DC8A9B1322483D7BB42CC20B31ABD4B2A519F57AA415D9792E7B9B7E8783AA65ABBD8A47FA7455644BB90CA692BDAB31C8C32F01C7EA587E67867A1ADC24367E3E3790F4D147F1B1B110B290402F669DB8F025DDC0A7CBADC62CB6430B4B8945D6E25E223375149ED9714166E8DB77F16772BDB91A6FBA1A3B0B69066CD755854EE4D7911AFFCDE5A29F3F6A6A0544835F627E4F0C34B00A0E933E6DE539844AA59A32B83B689DABA7F3736EB208672F6F5448DDAF1DF5A2B59B9A700E3A049780AE1B8DCD184F282932DCB109F9E6427FF8B8DDB512AE1A500C9902ECC3638D7D7A5714E8954FDDB5CECB67B69C214B0E4C096E36FDAE1C49393405DD9F15A6A29584FC9F243C7021CEB3E81110902BAB9BD809FCA8A1ABC75B8D1DE24C531E145DD6EDF5A2EA8B76A7ACDFC769CD982AAA3D3573BC0B21AAF103F1DF160FF878A2A3F0BAAD5286247EB80DA7EF0D22C4B31D0124B9A31F29A0C12FFAE27B4982881F9B65E9AB76DA26AB4CFF7FA7814AF0863A4406F9CE263145268F2721B203723A3618D9E9DDC73C97919C21A37F5E3E6EFA6953280AD50653B31FB88FC20C9C6A7FE1B814998CAD7876FBA28F07916EE1852ED8826888CCC9C7CDE6F464A77C0C114D27F4D1DEBCE88BF023A16B052A2DB1C95A7E320A0C3563CBBBC18E4953CE08B8B17B14691D3E5CE9CE3CB41B92CA0BC73D8149F8A9024346DF289E64531F6B2B97E774B46CCDFF41D2BEB81FBC22FA419ED5728A95A2A3165FBEEA994E9A7C56258170B69299352526DF1C7B22053E46AA87DCEA865E23CFACDD9DD01900E2A7493565078403B76ADFE882D5D2FB54C3525C0D20BEADB7FB27D0B3AB74E16D9EFE4600A414E399BB8738C90B6E33148AF1F6370C85C01F91CD826C2173CBAA86CD0B8FFE54F29514CCA99A3D93E7B46444FFDC64B859695A563B2A5DB60F369FB8C608D161C3DC60F0C42DE3FBAE10460C24EDE84D30920575945C36252371D67C52F98A8F25987D8B2AF56FE2F5A5BFB97E496CAB31E1C08ADC6DC7F08CAF580FC93A9A7A975F03213063C12968C1D378DB7D7B6AA1E78112AEF9F619F5EE244D0EADFF175C618545A823440214F2F768DD80AA75CB216AA80B903D6FC87AC20D24DE9784D60FD97ED2BF725A59AEC63819E0A79D32096981F6F24A879FB0504AEF39B28407FFB587777F6DCC6761B3FD8AB03C465BA07CF7353AFE7565EF2D8E8AB673010134EC64DA3F1AB1160A9752D228EA388D6189EB522800369F92B864E2202DC6814619BE05614181EC80858A71D366740B13ABC77D41020CE3A81A3793710E0869427257D30BF4691A953781D5A327E202A777DDFD9178CB4F7C9B2976CD4AA0B81030F6A5B7FFD4A65B4AD46C3FF4337F93E269D5E72A1A45AA99101BAED2E6EA813F6A05EF6310B497012AEF7A461760D95AFC1ADDE1881D8ADE9E01A02D8E54373F9703564CD83EF5CDDF855206ECBFB0D0D2AD5C3450CE496BA3BB5D7F521C98D9FED617027DCEE639AAF717A258A1272170B8D72AAEAD1EE3B0B2891F67302F031B77F94BCF19413B126CBE2E7E2D56F01E567ACC104DEDBA0B2BC44D2ECCCCA1FAF9F928AC6B734F953876C98DFAAE64514C1BFF8D2AFB4AA58CCADEDC009285B1F25C9B675D0E3F485E02552648737A7E33C74B6F58B823221FDCF6FAFC096729A1C4C16CC0BF96A522D31E40CFF70BC63B6BD2CC3FE8CB1C8B41713DE73F570A59304A0A42019F856880CF62806CD26F67A2645A58619EB0A2C0B9B01EE4E72D2D8ED1BD474B7AB77C727E724E644ABFBB6EDD40E25E50E2DBB59D607E722E83826A11FAB302AC478CF7364111B3F397944159FE5A9B5320DB661AF0A7A244A10DB1A9E5560A861476497B4DECB9DA01903AC6DCDC63A54BFD17AEFB706A2F4274E47C8B1A5F14565329398F0418B30A91C57AB96D205CE100968E00D592521B6DEC96563B25822385933F8D9D3BC93C3F0776359AE60CC34A4E1A1B6756268D96AE74F90C73472699DF4A2200502C8A04639823CC3187E352C9B6092ED22F13067B0F9D085AFCB2632AEC1D6D890757DA0CB3D7DAEB6C595698D79A832092E15CFF07B176658054FCD8FC81F68D7A379CA25AE7F43777B502883EC4D9BCA5F8F96C3D475CECAEB21CEB307FA29D9EC87B04046528488429811A9733B085A963A6D73FA16C7BA168672B311552475FFDCF251740D48806551E6225F6C90907DA23DC17CE187B02602F7254BE00995316C743FB8A2021D773C4AE6EF878C343ED4DD092B500365CFE3128D6EE890E866091BF4BFBAB672FA1C1A72CDE22CEF16FF5B545C02E32CE23AAAB6E4790A821E18BBEDF58DA55A4D1F43768ABF14C077B3B8F07E5BA7D9C31534FD80197D3960584631DD8029087E92C9783C1E4952FE3B0F3E7C832F52271392465DA30AA3CC783B4ED0DED23DC8836965E353BE7143CB82B8FCA84D1474CB29C6A655097CE0FBC9FF0599AF9864B8241E6638F5C80E086E62E1A1748E20EE8E2A3BFBFCC604CA1359507B0A1D987F873B4AB9B847E8D07B1A7D83A9A18878D0F7C8F1FA029DA26BB1178E640BF8E831887AA57A163A043B24D077001D097CA2E85A4DBB90573E73D6E8CD5FEF86CA8C48B4B8C093A7F94E3A007E9962FA1324902E9AA49BC73C95C11C24CBA83F4F19A7F2BCC864C6FD7136BAFEC279271CE92A604466CD136F223C67FEA2C95AFB4BD94EF040596C6E6DDE5E58275B4300532EB70D6B6AC9D3D62AD0B92E3235046AF157FEE79E9E5497492B1C4E43F9A27EC1E684506DC7F0ECB89A5830966E1C56D0EF3F7A0EF548BDEA28F20F0DE3C5EC57883EC065ACFBC70E62531144D773F8A561AA2084CD02F2C36D4DDAEF191FB0FF2DE3D9631DC8C3188D2A2DAB66D486C592930C2FC8B5B00BB67CE9385C3610823794B37E83D122D2F696E6C380A5C105F132E66E9723138539E0192F5F718BFC094A93920A46FD8C288241D1DF8B8311C8A3E9E92526CA9D1AF1717FC5DA43C2755FD168F2804289CE5780487B806E0D676E45D38FFAB4236B9F53009106258C49582B938283BC55015F6F818C442EFBC90C54122DC620AA3F51AA4975E78FF28B50FC7E1809769F0E71F3EE4CD61AE4B52A845B1409D48BDFC41B93EC912613796CD27113F8AE65CFD5238EFCAB94B4F9DEEC70BBF7720C8EF6CE6647651EBB9086477C631CD77B698B3034E99D35B2F4FF8598BF410E83B21F89F8A9ABA8EC6A64130A052B6F6E5DA72F106261989A8F0B34D36BBE68F7A6C59489FE8B98B5720DF7A303B4438D5C8712B1CE40E8C10FF30ED466B49DD5FCB1BBE4B460D8896C654FD669CFFCC13858949BA8C474DCD7EBFFEDCD69F188B88ADDD92D062EB5F9B2F4B18389745F7CEB6269272A060EEB72B4A222CB038A65DC1927A08D49FD2F684275B39BD47ED52CC4D91C03775C73FE5A3BDB0380B93C57D4F20E442840C1FDB9082943527C7E1D222696354C0AA966E4B305061BF46EE7D8AC07822471D64C7A6E2B1F60D287FC268F39FC15E3905D88A81FEAA3D5ED19DB8C52CE60377B82A640F6244B0587996D41AD899D9382A1FDEC1721FE108E4BB92BEBB6546DC85A06ACDD6895A1BE45843D5C87931D8C71FB6BC90F74DA8D1F5BA641317904E71EC7C9EF99B73B72ECAFB6A25EB9FAA42574C99945A65C8924A7752B0FA0BC2C04162F82B03B79C31EE3995A0E3880586D3BD506806A0FC68AE17B4B0D1C8C165ECD20B6502DC19C20A326D8C93E40A2C82644EED06D6EB64DB93CB3F9666A9277B289CB473AD410D2CCAE54230A3394FC88CFF5B9DBA89AA12A442220B0ABCC4A16C85D4228B8AFEE3BE6E47F8BDF9B912A6E64869F3AA46E3B8BC52CB5D3665E0A3F51584399132396049B5B4684E7CE849C882775CC96693F5114198BB511851E36A70DCE388B95239B332F28D7BC13563536376BC7CE193E8F94E183D562EE39E147B3B0F96C475113E2530054C1D830EBA63A5017ED8B68987EA51BBA77B7745519135C802AA00982C7913E9C4BFEDEB61843988C75B26158C6AB4999F69287D532CB30004F7A7E5E36E515A760DE1519EF745D2FAD4EA6118ADE643AEF0934795A4658C9DA915D71FB4CB3FECE927A105FF6C9148C065DE220E248D5A080060682F3FE57AB36AE9B769D961D0C27F089DC1730B2B954ED5C6DF5D9EFD51F820A06060F2FDCAF2168173CEA8FA39958CEDBB202357963A03EE975CBC33A2A4D783BC90BADA5F2F807F06561FD7E0F5D6A566314B011F0641D27DA4E6A30C5F866A9CEB54B2E26924506A521923F72836BB5215E62E0541DF65166D70A075F2C866574CB0B03D187E80DD590D69D55EE760EFDE98AD91D29E75994976E2C642BB2CFB7091E02127844C71CE91BC3AAAC848677800BC3A51D0569A7C5CC5ED0861058B0C2E121C53E97046C547D81763FEE1061A8735B17AC985689921B801BEA18D55CED895AA87CA69AC4E078F8498146ABE0C211F7ED0C5684D0DB199B3117579C890B1F1A394F01DBA478228D9AEEE477CCBBACD7CBAB5FCEF477997FF491F87B34728A54BB6B9939168BF7170C40489B626B26E8295B00344DDE0662ADA35411D3155CB84A1FA4BD2FDFF5D76686FE6A7F26E5FAB2CB12917AE7737B612D253E273E5DAEE3C392BDA770331BA7CF084A5467704DF031FE3977E305F6D8B5CFB19C69E41F012A9888BFC9B9D543B90CD3B71EF5D8C5DE1E637C8F849923DAAE493AD05CF13FD88C617272674BCEFB24C9610F5D4E877D29B7EB2E4390857A85D37A3BF93B70A54D6B30B75FC03A863D0DC3D6CA5CCCB0A80C04C7B9973285DDED6B7DF03CD40291BF98B4787CBE3CC51C97A9F8EE6A2C2E24E94E9E59C458E008EF21E33D0BF0BB7B9EA356952ADE79B720BF6B67D3605D1B9A435BFB7A56F79595F26BC41C12DF1D34511C79165606CD5ABA0F76A367100388A0FA6AFEFBCFC9550DF799AC550774C8111765CBFD3FE1D6023D5BD1DDD05BB7C2BFCE2B834B73762727AFC74A002CDAFBB858B401B6F5E71C6DCF33D281644B7FEC398A711E7F22685D619304F12A27FABEB3BFDBDD3FA7359434B0E494871545A66F0FCF773466B0C5373C69910773068972094246C398AADD2962E9A9FF5E612D03922CC0AE53468A8B9DC6A80B89DE08DFB51E90D4B3F5F9116FE760201E6F39E33913A543E62F342111BE74A2265DDC1E2C007352614779B78D0604122595AD1DC042983203813C59FA309E67AE7A571BFFBEE653B1F7AE1D7D2C8E160E7793BB356601CBD75D5F307C2B61EDD2679DF7D17AB769DEFF728C213ED3E6EA282769C91C140D3853ABE925FE89A72BE0928ED3D8A4E78273D3BAFDD9F0E6760BBBF6B437CB1C906CC34BC00B127A6ACC54EEBF600D7CAAAC6B359F5CDCD287F5D45C098A4A907EE659837D0D5452251B86B0E3C0D57358F8108BF37E3AC19D0CDFD736E836592204B4EC2FBB4F1EE2E6294D659CF8589CF4ED512A0349EBEC7490988314B6C7173049EF12E7EDC9A1EBF57E78FB283C0AE885C2309C34C8E586BAFF053DC81F4722B649F92DA9E34C22124ABC757E129CF90956FF64449EB3499183ED3336E37F2452E97D97F6BF27A18B2BF621901AEC2A8AFB64E108A8BF609A09181FE7E044FA24827ADB342A7E77530C901846A96DF12512ABBD78A9292E9D7A415E988159E16A4355FE1C21110A5D5CCA98C22EA5D32D2C92431D0C8E9A98A10AD43FF5A975F1F068C90367C6FF101BAE08AD8C06ED5865916F4228233270B19EBAD74F6E58F528385F7A99A4B1861A255D75544F1A9E5989218499460621F6011B62B3F410E17608FF53CBD7E558304C6FAFE3E6ED5FBC23E9F17005BDB169921B9C345EC1BFA11F9A5AFF4E80C8B39F5BF3313C4ADA86112A1048D958040B7A45E6CAEFFD098230D5052C022802A231AAD9ACBAED05591A420C97CE2D72826FB6DD76048DBBFD85E38AC924C042C3A82D5FAA13D048EDC987F013501D6F66E256F43E71B8506C80378A4205A0B0DA994AFA05FC06C669C5423945539022017271CE8ACD55C5C6B1FC518AFB081680A7F6FF1786F4C03BC610D6B3CD23571D92F843EBDB7836CA72CDB6EAC87C6C60C3B54610C35C3DC7DE0113358C98BD7EE9AC0DCBBC740CC944B107B465008BDD4F3C7D7200A3989C6E5F9BB0B1826076F056A4DAD6DE2C01F9FBD7F7E44C1FAE23BAB8D02E98D299BBBF1510BAF0A8CAF3BD200DC2700A8A316F2650C9A7307F9E9B1BCA889132B779B4D070F7AA8ACFA9AECB6E4038F50AB00B07B8BD19765FA334ED11D816DFAE477A7FF93C974F2FA59274C381952AACDE0EFC91653051D39DBA21F4792CBC30CC8A2E7E45003FFE31085C5BA4BDCE497E6CD11EDEE66DA3798608DF0B7DAEF3E93964467744FF5E62A806EB1E0939053C122C0ECDFC03F75DAD532437B721D251931C67DF7D01817519DEB92E57406C2D51EE1EC3F65731EBBA02417830629D2A21E5A27394F14DFDA1A4C6E4EA60753E7C4DB9AED3FA5E192FC066F00C015C95B1C1991884835C457525C556FF16978247472ACA75C09A9D364351959AAC2A5909EA46CBE9DC67C5D8A7369B3755519DDBB76EE32FCE6CF45EAE5714AB3EF5F54E1BC6FDDEC5A2FB8FD426A1A1F6543F4C6E088E16570181762863C14D916579013A0564B2E9A936156307421D696D7D6999B98957B0B9802F1FF635E4AB217D65F9B23F28DD6B5D230B242F2DD890C63F4E112ACEFD222008C33E94686BD6113535CE23B9376BC122BDDAC3B921207D62BA019266A89E2629BE57752BC8E228A309FB7F112B3604B229BF11CA3F303D2C4B37DC73FE6158BB02A12831B167AB0100BB30669862570DA5EE7869058EA2FFB62A61FFF5DAB64540F5873C9A8CEFEBEE8C3006AD2C1BF7E65BA8CEE8BF1FF5BE4A2D915D7822AE8FB18F9F8B5F7C51B0EE95CE2FCB0DA4EEAAF8678A69BE84332B8605DA06424EE9E0A943D8A30B9D46E8833C078DDB159C61BA75B0B0914AD49CD28E18A692C56D4FE92657E2BCC4FA2D86F1A1FFFB001255FA0EF90844FC4B052715012124D386AC363C79701F4D881A7DEE7CB58CCAA015A53903AECA710F063887E926457917865A394E3DB3EBA6031614B570D851518DF42C45A0528DE6E7D1FD55E1C452057A391D61D0AD3DAC7AF973A32416C3D88A453C2D12F6662B9828BC0C802870A396EC2EB211084F1B2EA5361FCFBDD11BA2F5FAF711A2A215F0C059E150C3712D6693C12920C9386E371B0A0E3077BC4311E3A9C55B0695B69BA0A001D55EC5214CFDFA6D3BB3F61372F858E9DCE313CD36798D3E577E27252275986DC86C001FA2A324D2A556EC4531951B4134B77CA59F054583035978AB2F6B078463B7369AA76F6AB2939BCF3EE59B89A1ADB1EF9C1F25D1D90AD2F8B399428E86793A933CF3C017427E9C16B1F99EC3A2A5109FA0BBB70C0B93EB36F9F1CCE796F9B713B11D92808F08CB66C6EB980FCBC906852293F30AC612013DD392FF36763C7E481204BE72D80AB81909BC3AB19EE2DBBA79A7C3404CD0A5CCAF598CCE4CD7507F6B32EA29014EB77FF9E91F0A34F7DABAA0362BEA8C6A1093338956C4E46A02359C61B0656456890700412DA55F301EF0C6CED3C9B6AAE28490C74558D606C977411A8FA88F6EBCB963A9915D57F099A134AD5D773022779A1A7D576DFE78203EB45FDECFCEAE85B09D518C3C62DCDBCBAC54CC1AE8CBE3D9152683399E2DAABC0CDEC0EE945C54258F3B94AD3D6380F4BEE04D43F19CB5FFEED5423F68C320C99BA08A4A933EC316BF663F7A8A73A69494DCCCF9462CE868C3342525D4BE804D8069229BF001B543C47C69593350FEA648A5D3E5A48104412985FE21A27714879DC3A3D3773C88E3D944083C383831C2E99DDDD77EB54904A7E2B68145940754A1EC787C1FDD36B320FF03E1AFA8452A59AEB933C0625A8A32E024DF5545453947BC475932C0BBA5D7DDD37CEECE92B648C58F790C016E560F015E252C9F6703CAF9651C9D621A8053C4638561F2ACD1B2A821887F68A8CA7B9D85490D236D133A42949950925412A6E583027DFD56F98D5E42D39FB9148AB363594EC1BAE84E44887372756B7EFC859B579EABA02DE6910ECF67913B40B1AD2792BDF750B6AEC2A39A5FA0F8EAAB4C7AAFA6E2A4098141B9E667E0B9A5CB12B87890C86A21CE6A87DCFD20AB39A3475152E0FCECF6A6E3650A5E187164F5C9C860CCA89A024F160F97D40CAEE13D987CF5D14FB42CDEBC206121D725B397A9B3D8B9254B6AE25BF1309E48339CA4081A8B96A9163CC73D66EA239AF672B8DDF6FC96556C4C5C7507D5CE8C5539996665B71586995F448B13D40ECABB8B5C3ECE53419119D0224E55A3EA47D87FCE63D107618203BB02C0F9D3CE24181953CAE56926260068C6FF48C5C5ADB1E36EED6FAD7626E3391B0BCDC7897F20C605A6252CA12DA9839B54DD1CEF04C911142CBCCD14780C2A2BC6C1DF6EBEE8F12C4FB59EAE45195FC559066DC590D548519D853BD38F5DCF6A41BAFC070B800919354C26F21D3A76848FF4171C37446A6343BF608D6402B2CA3B0A0695E9598EB2A151B09E69B382811D7DBF4487B060EB94C3B05CFC47A78EECF84C8D72F66DB019EA36C72A7DE11E590ED191F594FDC343F2E1E1829B7BD436AD889DEF6FDC5F8620D04BF7E9F1A917F0DA478223377C7764180CA2AD89442D27487959C14642A40A55C875EEE5BCF3390F9F03390AC7E622F967FFDE0E30AC7F20F7C7684FC1936D2664D0D1C4E62E310939B539EAAFC46529A27EC0BC43C205922C62853495E791DEC2D0ADE7FF9998A955CA6D640B2AE67AFF3D1E079C9BA33F53409A4D7709F232D061568931C41B46F0B1FFC3999166B99AE0F6CB7F9D780BA697989B22AF32B984281EE9490D0A1033B3BF7AD94DB7CF6C0D614981CB21BCE0C0B70546E37FD9757EEC789015A4D8E1CA116C37FB26E43B035481528DA554DC36A445B1C61245D18183F5C3E9B47F8A18759A7BD7BAFCFB2BB7E0ACF149071038D003CDAECB3D285BE4A22A47BC88AE5E7E78B4BCE84B1E9FDF6EED3A7115E81927356C1FBD3FFE346A0D02CB1B837F5D660ACF63D84C70A08962C52A2C4D70DD4628E583F2FFFC244740D27C2BD2B4739985D4AFEECEB80653524C1E6A1733E84AC9D46DB61BE573EFEF87B52B7A51C3530086C69DD665BC875708521777DE2CAE8390F2DD56C4CF880EDDD48F90C2F739A53C10DFF9F49710F3193BD3819EE6DA109E72ECB44FB72D99D640E35483FE3CDB89EC0E591C6ACE2C694D6537D6F364481E58032CE4AC437412BB057743E7A2E6783CE24468F813B2E0BECC864B7A8494943EE0464B49467D600182EFAD1E8437C5F394F4BC16D36CCDE645B873ABA8F8857B4AC5052B280E70F7B835A46FE5683BA6206C1A5516AE2C9DC86A06BECE6D4C959684BE9BA8CF4024ED1C427882EB9BEEFD72EE6D1789600E5ED42596179BEB209D1A72085566C5D692F63BDA5C183D1C1A621EC87667C750DDBED8EBD1A9BCB9151EC58E099EF076A3DE473EA66B49A54342F5ECFCC5E549B51FF00AFF1A11A81651487661284E7BFA4BF6634637DCCE0D9EF916F0E4F192351E17AD14C604AB76E4DC05C00B7AF5DBB9990F839D08C1E2BAA9B613677F0C2FEA6B2346D5D2E8C9688BB393A7A25D7E3F2118D8B173309B0A208407F0E58F72A66924881355AEC3BD528429FBB1D2AFD0A77133AFAD8C70BC7745820D72DCCC999D8800B15D10CB27CBA0D7CD42D1E0961167D68384BC89A28F98B6ECE5D8488FA6E1388495ED11A184DAF01426E21BC0AE01EBCC563AC89B4693EBD90B9194BDC5DD73E818344A491D5D17E77D9FFDC3386C689E47CDBF5D96122D7796736A61B3C4F814DB7996C942C72C0E088E6CC012C7CA44BAE349ABF5A2C630BADC7473904883E2BBA567965E03C8D944B24961135B35DA1229AE16B6518E51630A4980C3A97E2B36A9F24D4DAE17EDEA6024C55F9AFC646CCB8F0147FBB6DF5B6F5E4AC85C4952E137014122AB5813D41385F37ADED70B581FFB9423DEAD43B0022A20BFF0706DE8ED62967226370B128EAC1B4F4B07F9EF3F56AFED7D3D62A19004B51548C289C91D9125F2568660C894EE62E083851127E61F9285EEAA7F869544226A7FA49D82524E3420DD439970D5DB78385ADDB663B86B79309067546071A2A8D2004F0455E04C69BC5E735F0E6B7A9866EE9719688F9DAC494C06A30C22D5199314EC9AC919F0DD6597F7A418E62DBB43D11BDE0913875246688A081E28FB3539F83D78F0CE6032F98C75F0B211144EBC8E52ADF3553573D07318348733301F00FC5CECABD64219390CCF048FCC661E885916B7DFF39705CA99AD381CB9FEF410D1652BF41BF4320374456989E7548416DCAF36D091FAFBDBBD6712E2CAB69F04A766433EBAC600604E4FEB25A193CA88BBF2408C5012308835BAD887161134801FC2EC3177CE0BF7B441EDA836CABC41FDCB5AA05E5E7D393E2DE03B4EA9692EBF14F5E785430E4D416F2E2A5E46E97894D38C249E167F4643151BD841D927B8B6A5E0D3B1E390D90409E7CA9C35256C53463A8A9631F63E32EBA217F4B44FFD83C5B726794CBC5327A682FFF4D887AB42CB2836494F8B13C4ED6B33C10355D01F3472A43226BF692AE3091DBEF8301174C40DC6C115F413ADFEA78DCC02BF769D297B19DB0EEBF83BADBFB5D033C1C72BC928234E7D5A04680497E868AB72153910F6F24002E2B4263AA39237622C74F8F5B912FCD63138DF37F93774A85811C5530D510EC0A81FD0728E1113A7DD4C68C24525B3EB5737485958C5BAAF6B41768A849416EB9B07FD4D48A173E4515EFF79FC68D0A29280FB0357E0F6306ACD8776FE72CDCA8A7ED33879691DDE6F182489DCB7C30715708462B6339C78BB7D269EBB3EA207FEA4E8B76623CD664AE302DDF99AE51C4BAE100EC5E3EABD04C6A35F74F28BD91C7048006B0CF5166EBE8E6BCC18B59605BE634BFFA12895CF5C2BA90A2311F6E4424FD5BF1A78D744BB9321E85B9D8CF2B19200F79AE65C18E08ADCA6C2F72A0E3CE4A97EC10C36800A377ED19C439F5EB317E1E7CB57F34C1D10FDB2CEC8A0ED12354EE94F618F0F48535033616EC44F9EFACC6EB227FB99E29185A55E49DA7D898C1B8B74C03C582F485DB5FA3CF11EE6E383912591876336DF1D1B1A51DC4C460344A689254B9DBC13597D5A29A974C212505DED6E944B9CDF63FECB2E90DDB82B3C55078C4F51B8F08028995C8CDF9F11E8276D8F2EE59AEFEC8F36F7FA87C0AB810A6E21A09B95B6CD11B3B9E2F295B870B328ADBA3EFCB63FB0A83E0DD33EB4063569D870037E7BF1A087BBDF4CF8734882E31AF8726FC63638B12C92C8E7EB82F6A6ED5C77EBEFA8F43E3D535C73F16C5834C44E3550795EA2DB3F0C93237C51CE93BFDEB25BF26919F54258FD4A2254A2642E57B6CEB447D438EB91D933D793812FD17DC6C019014CB5F4FC28BD06976894A503B357FD5255A3847440E1E5A90A5721211B61A594C4BB4D771F13C41F14D16384AEAB895F4E93A9CFA345AD70E794C84F5DD3B7607F88CE74ACF35A284449F38E429AF2140D2510E84E87236790C738874E0DD38CDA227CB123DDFFAB50412132637D179A33B652E66BD38AA2B58ECEEE08ED2530FE20114A73A7264D850CF468BEA0A5B543226BCB3A68E5AD7975B58564C9F65CA3D537D8B570334D1B97930A29616C58CB549A34361CE2EBCF526D497C49108837DD0594CD41EA6B7F0046E55DEF4E5B4F5937619849469816B4D3DDF7F0235D87FDFBD344E7C1BB8839DC72ED3C1BB6F1168C7D3008ECC5C6D276BDC3F706815910E62C160AB958DF39C706F2D723F26237E4161CD1E0E3376E97AD9D4AD3783C05787047761D038357C9F60AB9D838ADD618E83EB47808B203382E82C83A46CC41CE25E49A8152E43DFC9EBB5361E91EF9A08D70F6C6B6347DF4E61295DE245B23D7956921FF54FB39B9669B2D8924DCE83F231F9CC5AF0238A369A327C7A6264993AD13BC779A683B1C07ABE13573EBDC1B2E433194D013736322F827B3C21486AEB05968FE8BF8643D3716E1663037660BFF0D1E37D5E79935DFF6F303931A4C577D42A82166241F928E141A7C9A49440BC7FE2BA9DA1300F88CFDEA9D5AF6CB8C2EA4A881E12320C9DCDC8F2E49258E0B624BADA824D8A8B939D8FC1FE45E4F1C14F048AADEBB63DD9F02A60A00DF102CBBC69BE50B9567F1C019712377111A7A7D0AB9BD3F2E38014202ABFD23CAF1167E13358FBB7AA4A7E3E7583FB50BF640486E3410ECFAB96C98DC12947D10966CD13899378C8971B16872D09DFCDACBFD3A3187600D754C8C63885DB0183A9947F76FA8223D8AE18BB0BD90981DBD7FF2D8BFB0421CAF6FDD945E70E33FD6B9BFAF84483D1C3A22FCA0D4D54CCC5E52CEBD9D6C5ECD1F503464450849CBF72EA53BF20887EEDE40E85C0922E8FAA9258B073A76B28CE5F18160B720B2B5ED07B3218A66BC9E44B4908E03E19328D2A512597C56F672D8AEC934ACEFB27149AEBD1DFFCFD45597836F5CB2D7E6F973E9E2419164F8FFF92B2BA404A47DAC994343F0D79FF2A656EA4CD414F84B41AFBBA1BEF165F0A22F1973AB3F0881EEC38ACFFECCB2D5BDE6FFBBFDBC3367C2DEB517D4F32090B1E250A4EB207D9630C7E3E981504A786568A4A265AECE15C3F93B76D29988EEED845D87030FE9E3E687BF7FCCCA54C1AA2BA5A882FF7823DFBADF96BF13180DFE4AB00C60B45FB74F25DF4268103858F73E580E03033A5F1CAEABA579E26631832418D4B0459B2FDDA52D2F911BB67F9A9DB178A91C530042B014281DA07D31DFF57308AEF6275F6B4A84277B41025654C11AED2673EE4E0CE4702DEFEF31A72C14EB260FC9FBB84EFD4728E472C66BA2F40D5A2940B8887E1F07F829015D24D73E9AF7B4A4AA3346B7732CAF3CC61B87E92D8D33026B8A9CBD60D7E6D1A8A48616A98FBDB10E3A5139759F95781B481FFD7FCF9FF5AD7D20013FDBDC0DE2C5A75FE5BF55B01283523214B4B6EC93C97E5F5FC37C4F7B88E4E0281782C2BF448F368DEDA9F87514176D318C8E9A3B340F5BB18A6E0169DDBAC23A6376804E54EBF0787C285644494A91ED8135C1267CDE4A048B68AB44B9C824C0E2A2A3B2FB7FCB001B75F62D1F35EC8BCC2DAC4696B2E55A72395711DB6B14D7FF2199EEAC4DC0BE341AB2611DE723CDDB5B8070EB134FF70901D501D02E4ABD8E2B6B2CFA313904F8194A9DD10441300818F317CF167BB0E24C3CC948ABF81E5F8BB80CEE111B912C7F37C1CCF9020774D4AA43877861F2EF2603307FB2BDD2CF54A8532E1D5F88A942EE8BD596C9AB1E68BACC6521F04C63CB48AE8D3616CE7E6BDE0E50C68757292A48701BE1F3AF2CFA3185D63978DC42FB0605110BD387C9CFEF051D69B540D0B089C9BA637DA5F00136C03DD533B43C29EBD924A3FDA56E06C41C95B92B8BEF22C87E5A36C72DAEEF236E276E28CB816B0E37D929AD305F3F3C79D33674682AFA45CCFE31B9B5DF3DF2B9F543D1114A539FD8E79DA62E33F94567B4D304A4C14EA3FDE73C5DD2CA7444B9AA53B18875AC9F21AF4FCB50B0418C19DD4214F4670FFF98D762B467A96FAD7D3D30DA987A9645CE34C6A07CAF65B46A28251C927B9781A7E1C7D8C7AA9AB51073E5E23FAE788D583F732242A24D0AE6223936D445CDD4F9062FE53C525887E2E9CFE290FE816AFFDD1F4F415479254BC14293DAE114E32C21E16153D4D62DE8C7BBE2FA84FD8530B550CA64C607F9529F2550B12967FF265EA961105FD4596EA1578954603E51E1F65AEA090E0ABF9EC5F2586AF9D22A6274A3906800BF2C8AFB4FA062324FA8CE28F366C16D861BF3728CAEF71448D774FC785C6E191C5E4E5187A5F1419A15D026DDE1D99509DA3C33051063FC1040F9BAC9179FCB8295252D27068295F0C6E002575DC4B191341AE7DBE602E4B7E9A521D7587A55CFA8BEB1F0AC14BBE62FCD6E5A75495E6B435DCEDD62465079AD30A023ED1ECC7A05E49B982D0C5776FD6B716157C71B546BFD643AA1FB14B0DE2A8640BB3C28EF48C4AACFE0D3B9EE5FA18FF3FA80AD6AB3A3E19F3D8E35ED3DD1D86B90034D3BDE6F5A60F018CE5E90D04A10D6AF633C4B3E00CD88887EB1B5C927A54D8BB52DCA28868CFB933948D635F4E995E72AC3C31DCFE255E54BC620555D08801698DF5EEF1C4D1E6BD5A0A2C75E1848769029245BC0E3366BA60AB81F1D9DB9146F2FEF602534C7D97DBBACE7BF070331660E245EA57224F9F075819941987F0A2C82D7AF1CE7A91370EC5D3BB8ACA2193EAC8B23EBB6FCCC6F3ED879FEB33713C8B26FCD2DE8F795FBC74117F77D860B3A4F1117C32DCC01A8D3D12623DEBFEB99F0765F319A5D7C027E181431EA9AE0F6122E956B36ED4EFE48B4AF1212ED847E17718B46672D231D5B8131C50D65C633F2C968008098B68B0CCC99B5147F1B427E16F06C342CB451E7BF0D0BE671DC136FE6CB41C2CEDE6332CFACD7F6A1DF0ABD97A863D314ECBC6A5E3523A060DB11AFCE6550F8D67EDC126ACAF662A145CE83B47A2287EB410E1CF3074F37AD8D95BC48EEB27E717B5A7E333DFF46C41BA8F0C62AF1064C2247FEE5CFEC33C027A20DC70F0DDA4EC517BEE4A5183C2F892E60BF72439264DE8C5230492C1058F3C42C152773F5F1EFD2D0498376FE1FEED16B64B45CE3B41052932DB2CABFDF06BC11FE2C87805D5AA51FA5BCF5604DB4B0823B775F61A854619962DEFB7692935A18CFA94FCDB1EF39EE86743E3C17004D6E7E38E4C3BEBA899968C4790380FD0B2831FE5FDA6DFD8BA63F6A59460CB1CD88545449C6E6409C1DBD3CBC175B66C7B5EAF656B1465A65C66771B99ADD60E8A251B0E1C99B55DB874F73F80AF1C6551ABE954E5596D656BE06EACE4CABBA4C376FCE1969EAC174B5C104B68BDEDE470CC293DDA2CD5BF6F5B6DF0D0B9BD8499533ED9FA416404C8598D0B5C486A6072B6BB38C96AF8716BE503118F404CEB4E28E245ECF9B1E5AFD4095BA229212081E634071862D157AEDA7EEA4F8D3CE1BE3AF1630F84D910A354EA41F500C2B2ECB026D38A42274C4F0AAF3D8EB0713FE722B7041FE0A08D606427EB4D132BBFADA42E8F478BDBA3CF96B2374A74954A85FDC6CB788BFFF987A76546EFBF6FE5159DEE98C2B9B2ADA3BBE9225921FB27EFCF0BD2549599A23F798B76BCED10E4366D6F647FDF4C3D3F8A0A7E074B7C6F23E35D98EB3F3F3D8A147B57A29E2541D450AA85846376A7A053E2AD7FDB1A928379CCB7A71A48C9730E725362907AF172DC47E4654D0CB99DAA5A7CD3E44973ECE64FA52E80E4FDAE2C4EC629A9DC4ABB699A26F002C9A439B08AC1518068585B07220FB0A31968BAA22464D4B6715F5DED66B99B9C8961F9A7A357430083FCCB322A506CEEE6D3F134A1A87AA705C3BDAF7D17290598B2C964FFAFA0F23FA1FCEDB5C22F5D561A615F257BA5F7A41C161D8FDB3601D6B615114158BA07B9211836D26F9907F161DCDBBB382FA0CEB81C95151B3BFCDFC875798D7AA4EE0DDBF694B243C494A223C10561F4DEE9850E0918408F4D236231D854F44670CCBEAB370EB06B0BD7E65447D4AD219D10DAA7F0E707D36E5F4A6E69DB9D062E8F0A8090DBBDF047C8CEC55703DC363E30A3F51FE980C5B1B258E1F9EAE7368E0BAA1C267AC91594845FE68868C3FEEA28811964DD9BFDD4DD6749B6C2D98A81B083697DF6411EC18474CE9A7C2D17B8001A2604BA0155C7F90B67C9C4D84CDD22FB5D265E4D58710C233AE2F564E36D1FF97E1C1C054DFD4A44C5A4C895F0AA74E49AAE0282B8E20E122BE6FA292D64BEA12F002A64B6C042552C708D53C3A833698B147F0EB5EE91EE8EF1E5E44E7B1C19DAA2A4E5496F367903D5FA7ED3DA55615F0BB76E770E25EF217412D3057E1EC668F2936FAEC70721953C6B1C5BF2590CB590443051820F0E2CACDF8AC79722BF1F18C9E32FEC5B83262625730E663494904E6DD50B897056A79ED0596E36BC1865F2A24B90F30DAF420C045B5BEFCBB4FD46FD07463E30ABCCDBAB01FFB13BF8416A40E21560AF4CE0BDB82B914ECFCD33AF98FF4BC897312E54118E8EF3D3F63C6B0A953E54869B6C0D50E7C2AF7126646095EC1513129FA080728E323710257639B65960ACDCD8598AD9E4AE83A01D7FC40F37624E1B03537C886F07CE84A723DE9C6823C0388A0D2D9276CA8DF57F7C5360D4AC59AEAA9191BD60317822B726EAE4BB4966E963D2B3F259D4D3083E08B143287AA7ECA83F688609595FE5C7938BF9C72B1ED33F98608A49721B1829283443F51DCF9016B222859BDBE1D61253774B9E14551D7731633FA49D1F67506C4F8FFBBEA025A2C6D4529FD95D8CF79C2C0CBBD233902A30239F8A21FC7301C034206DBEFC32789C0B0EC2C6057FAF42DED1D2C51619713729C585F5D5914064A2F341B746A3D5F787C886B9D69E17FDB6C1DF6A2C00E2EF1F03EF6E058720D50A476940F4715CCD008BEFFBB7F6D6B32037513F67644AC8E2CB4214D194ABFF82411FCB59891F1AC3ADE10311849826168EEBD141C20B5A09F7866B7301FC46F41CD29086D2A81FC5143E4E6F33527668B0130C1561C2AC0D5946A3B1A5C079ED2D7C8E8C62CAFA4DDD0EA36DD3C27B6A5348FB4267F54BA53AB0A35F4266F7D7D598FAE9AD3CD60D3F9F69A501F295589B5873896FF70664D206C37D2AC423213166F3B4F8321C75BB21266C14DAE49669EAFC8413305DA01D0FDEE4A83A1BBC9D21027DAA5D2C033D8A6772181B9EA40AB4D58D1F46CA9594D3A8DFD7C521A40FB134511B2E5DFE346B44E0DB1C31B42BF01AE3502A867FCF61FE225E1342E8DB295C32AA69A45C7D2CFF0FB2211E1F086D7255821E0674127C0C9454AAE2AC9CFAFDF2B8F501318D5A7985ECC78B86050F4FBA27BBCD2FB0B498165F904EA15C17751ACF27CEBC00A1580DA2958E9058F7B5B9BCA03BF96CAF0EFC46AAECC4BF20C6F74E84414EC993B4D0AA6FB359D7F3927C800EC93C7249C417B2171CC10F14D044C3B10EC2F8D3677B49A2BA9E96DA098D2C3999A83DD62C00BF3A4A0C3DE6CB960283ADE9D5EAEA743EDEF25394041D68A1144B202692981035016C4E3834CE3900DC65B30EB8BE0186976ECB22823FDB614E3169F68D5903CD65CEAAAEF0F945307123AD614BE21ECCFC512A12A44C66D9DF73D051D00D55B473B02A507D75EA05D20AF626C276456BDB03D2D241351B465DAF10D9EE4A457BA885C1909D50EAFEAB25B13E80A8C8D6493D9C1F0A5F5775EF703F7B55796808474AE811285876F64CAEC10351AA044219657322CC850BA292C2D74ABD6B9CB17426177AD79F10F7529028ADD80F4F8532E5882B2E5C903D508BE07F6C39D045085FF79EF444F5BC0CC53B9F244AF72CDB9982EA838BA3181626F6114FDDF85E566F7F8C8891A97D1370A25D83BFDC774BE14F5120EB959BC969A42A561B88A7DBC0DB3655C8BD4FC75ABDD2D2F6A002532B3BFB55202AE30066ED48CE6A86EA8B65E3E77D44540D6FFDACB9336F3E2D49C8F0C30E934A1CFBD48D9C8F3DDA066BE7D5B75FF73F786AEB0BFD87626D38CE72F9168A4E202BC35FA5D76FD73332B926514C19AF5CCA67E37DA7F6B490570413B799A03A2CF91B0C635D1A5DFF5194C24E64031C216882FA9303A3F70578A65985804B06E82E4B04D68FE7F457479AE204E85504093D0432193E8EDB1F64378AB9E57ABDE8CDCB2D3778913FB88974045DDFE21E3DB50FBFCBAD90682788587FC9AA934A478389955756EAE2783BF0CC99FED274C4D66DE8E0859CB7B3482A5B4C2363E2863940131C1C4308CF6B4EF34417E28EBF6DEA5B48938EDA1737D41848EE35DFE1585A32BCA3D97F28503429081A74D4C2D83E61A5ECF8DC20E723899073F1F470F1540CCBDB7EA1E25165D6B21AA16D7E6AE7DA5B53F3648915DB760DE0D61C28649632C7EAE8C95EB98C736FE4F0D532EEF4FE4F45940E005582B53BF31C9B8BA27C6594D7B91942F99239ED97D54E1800B5A20D099E9D43F8EEB2AA6D98B9FFA28523B373E6732EA75D3B39C259E5F62F7FB5298E302248314D8D40CDCBF4253527514B079BE6B4D3962354EF2EE5CFFD9A343B64AF959E4E177412F89F726606F140328D29F38D37F2FEA9709E3076B0FB9D1208EDAFD113777AF1F1290B2DCF4CBA831565900BD63A68EFCB311FEDB1744AD8E0514FF25F0A8290001FE82E532276C756903A709E7547BACB2EC5617B5AB578DB09A332A4D4E16997BF058A1EAE1B05F53C182D2B69F547BE3C214A5580B25A178E9A845752E5D751F617D40DD553D783977EF314FDFBCD1A45B0952D222D7925673EC533EE32F084C508B52F94C38C1B08638EA1C3BAF56B23D2A9092F15B24977CB00897067AB0D056F2EEAC19A064AE71F9FFCC0CB26F7EDEAD575075BD07565705018B4B546C38DF95AE0EBF05E680337ECDC504AA18698B6C0A25937B1BA045A9E3982D2C09CF51388E4F9896D0F74C327EB85D1ED1E4E40F673CF04A4254E5E70D03E9482610A1695CADF823B55686CFA8CBE71702FC3DA80690F6EB1269431A351426D597764E64ED6688510231A6E22DA148AF7D04A340BB806B4E73F4173A2D1DDEA8E88E82BBF5A5BB8694F200435E9FE0F2995B483E9FDCB5ECE6C90D0D4690680DBAA5EF8208F4883D040BCB1E69F71F440341A6E179E6BAC97BF967FBB9C55A4D66586FD07C2E787D06415272C6136F8A68FB23755963D92F366A1C967BACCC125834E96A9EB5E84128C8B608DD2113BCDC615217D7967E0C8F386CD47DDE5A84BA61F2EAFB8C88B5650D93616F1D2924ED207634C8E506DFDBC8BC34E174F74E21F38A912F4306B07C01DC45C77F39422F2CFA5B8C3B45813F0858DD012C9221CDEEDD3CF5180707FA12EC0CCE9FFE45A06E48C4A873E3AF9396A91D0679C91390BB43E003F97F016C84C09F4C7E0013F39E4780600DF655E98D93CC2BF3E3D7AFDD60ED40635FBB56D3D43EA32ADB5BA1E80214BCDC213AFA39F688957139131418C299C0D20AB295B5B970E594A8FF9378AAD8170CC748A9B80CF949E57BB7EA66A02835EF3FFBAF20C3DEDF00555F8E01F41A71FFB8AAEFDAD7E1344117EE21F51D87E0D839CCB8CC64C1BBAE81637F11F44219642AD33FE34FD3130AB96A65E682DFADF2C7CD8DCD72212F3EBB59E810F08C9FF1003016293968F590D0C5D3285229F1DCD8413F78ADA997A43B2868AC2824939982F2F4C33B501438BA74546EEE76988E1756F5922054DB33BC37F0A74CBEE5F0F556E0E70818C0F7BF8EE0450363143161F4ED09115D2E3BCB15031A453B56A7666FA8DCF342F3B70933BB840913A95741B19B8A8F71EE0BB587367B5BD2E011A8D1EAA7FCADB97157A364BA676E87BE4CD7B8AB61DFC8890CDC8EA60DD316EA0A72A3316DBBD15F169306A491FD81E3A9E3AFA013D8618A9BAE0DF65C7C1657E2412AE6253850A2E8670F1F34BC1CC15F009E1F70F9CEFAD69AA6A4421DCB94918E872A9BF60255D236DE51C83FD8A086CCF705811E7B33886CB2F73D3C90F8607F8350880B539E58F4FF67D96A9F852A57E247E88D16315B6F1EED1B923098C0026C172808F73EDEE867B8E48C6ED232C582CDBF836D7C8870D814AFD55BA8B8F7BD2D44BA32DD82EDE244816CE32492669B5A76E2CCEC686CA7F85C76AB04E0FB20C4C9A252DB613CC5F815D513DBE3849428812BC201F2E0839668828ED9DF7D0B4525D5C308875B5AB6D072CB8ED44D4F3ED568130C149EDAD780FD4C055DDC41523CE06C5521FA10A3090E4C10D6EAD5BB9D96C889C356E0B436FC7D8CE26E10ECA58AA9134D000A47C44BF3F823776DDAF0F2C8BD0ADFD3745D6A6A106424C366E22257FA55A86FE183E03B04805E64B8C9AC0AC0BCDC6F2231C930AD0B3BAD3C7B445F8C2F0D7F5786F47EA6C8CF039243BFB28BD1C74748A2F12E0B383830D5ABE5ADC492378CE68B57E77726FE865C1F644D0DC278DDAA8D7D5F103158C93A77E8FEAEF761E2E0DB03AD2EFD60189690F84D8CF39966D856F68A2DC809C61DE351D35B9E5675477C5E3840BDCA0B759EE871272323E36E6ABA0E29765D01EE914A257BCE5B94B2716CF22644D5A0C41FC18A35D2BBC5777D34F1B76A4D141D6911ADC184CA81BC4CF6FF053F1EC8F02FD16B67D983CB19F3692A9AFA140BDDCD172B430F4810E209C67F7EDC4823A43663984D767A7745523A7A8519CCA7370F20FCD9FA8967FCFFCBB1528A99716984CA45C1DF8C8434E44999E05FB5152A5F7247F0BCB3B3C4D55BFD16625CB91004BC9DFE8B52274E3EF64E7185A489B02C4B39A8E6E8CEA8C143D8B85FC0459995DBE5087D9488A70311FBAFE1901C35EFEFE3105A30CD1CDCF70E1D298CF5298DD7FC7720657AC1068D617B1454A44764841E38CD9858E929D047B0C836E8AF052581951848B632AE9B9A583647AC376567D8BEBBD6C061591FC8942EF5307ABB5C5AA10C54E1DCE6BB274F42977435A25EFCD64D5293A365DFCD8194185E46E601D29CD93ABCD07439668DA8553BCFC0D8595726A1EF9BD971EB3038B30495158069873D0DFF9DFFD548AE67FBADADED3FAEE79E02FDDE49CA8E31A82AA9848902FF84C4EF30C5E2BDD8757D3D4011B8BF6E4EF941F0FC484D8CC1AA667473DDF23B5A33FFBEAEDEAAE4D434E3915A664C058ED6259A4D3F4730D6945CCADF55150C100935E35C399C30A9F66015D66839249D6AF398A678DDC7B8B89A57E\r
+00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\r00000000\rcleartomark\r\r
+%%EndResource\r
+\r
+32 0 0 50 50 0 0 0 34 /Koala-Normal font\r
+789 2361 347 (Sebastien BERNARD) 347 SB\r
+32 0 0 50 50 0 0 0 49 /NewCenturySchlbk-Roman /font23 ANSIFont font\r
+339 2651 650 (\340 Pau, le 12 Novembre 1992) 650 SB\r
+32 0 0 42 42 0 0 0 38 /Times-Roman /font32 ANSIFont font\r
+1193 3265 21 (4) 21 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Koala-Normal\r
+%%+ font NewCenturySchlbk-Italic\r
+%%+ font NewCenturySchlbk-Roman\r
+%%+ font Times-Roman\r
+%%Trailer\r
+SVDoc restore\r
+end\r
+%%Pages: 4\r
+% TrueType font name key:\r
+% MSTT31c15d = 23d7DTimes New RomanF0000002a000001900000\r
+%%DocumentSuppliedResources: procset Win35Dict 3 1\r
+%%+ font Koala-Normal\r
+\r
+%%DocumentNeededResources: font NewCenturySchlbk-Bold\r
+%%+ font NewCenturySchlbk-Italic\r
+%%+ font NewCenturySchlbk-Roman\r
+%%+ font Times-Roman\r
+\r
+%%EOF\r
+\ 4
\ No newline at end of file
--- /dev/null
+*******************************************************************************\r
+* *\r
+* LOGLAN-82 pour ATARI ST *\r
+* un language objet *\r
+* *\r
+*******************************************************************************\r
+Le loglan est un langage objet developpe a l'universite de varsovie.\r
+Il se compose de trois parties :\r
+ - un compilateur qui convertit un programme source en code-intermediaire\r
+ - un generateur de code qui convertit le code intermediaire en un code objet\r
+ destine a une machine virtuelle.\r
+ - un interpreteur servant a interpreter le code objet.\r
+Environnement necessaire pour pouvoir utiliser ce langage:\r
+L'ensemble des trois programmes necessitent que l'atari soit pourvu d'un Mo de\r
+RAM\r
--- /dev/null
+LOGLAN pour ATARI STE\r
+\r
+ \r
+\r
+Le langage LOGLAN-82 est maintenant disponible sous ATARI. Il se présente sous la forme de trois fichiers exécutables :\r
+ * LOGLAN.TTP : première partie du compilateur.\r
+ * GEN.TTP : générateur de code ( 2ème partie du compilateur).\r
+ * INTGEM.PRG : interprèteur du code.\r
+\r
+Ces trois fichiers sont à mettre en correspondance avec les fichiers LOGLAN.EXE, GEN.EXE et INT.EXE des IBM PC. Ils ont les memes fonctionnalité. Pour l'utilisation du compilateur se reporter au manuel de l'utilisateur pour LOGLAN sous DOS. Cet additif ne traite que des différences entre la version ATARI ST(E) et la version PC.\r
+\r
+La configuration minimale pour utiliser ces programmes est la suivante :\r
+ - 1 Mo de RAM.\r
+ - un lecteur double-face.\r
+\r
+Il est conseillé pour se servir plus facilement du compilateur d'avoir :\r
+ - 2 Mo de RAM ( ou plus )\r
+ - un disque dur ( ou deux lecteurs à la rigueur )\r
+\r
+Comment compiler un programme :\r
+ A la différence d'une machine sous DOS, l'atari ne possède aucun mode ligne qui permettrait d'entrer directement les commandes suivies de paramètres.\r
+A la place, le bureau propose des programmes dits TOS et TTP (tos avec paramètres) ce sont des programmes exploitables uniquement en mode texte. Les premiers n'ont pas besoin de paramètres (comme CLS du DOS) d'autres ont besoin que l'on spécifie un ou plusieurs paramètres (FORMAT A:).\r
+ En fait, la différence entre les deux programmes se situent simplement au niveau de leur extension. Les premiers se terminent par TOS et les seconds par TTP (on appellera un TOS ou un TTP un programme ayant l'extension correspondante).\r
+ La différence entre un programme texte et un programme dit GEM, c'est-à-direutilisant les bibliothèques graphiques situés dans les ROMS de votre ATARI (VDI et AES).\r
+ LOGLAN.TTP et GEN.TTP sont des programmes utilisant le mode texte.\r
+ INTGEM.PRG est un programme utilisant le mode GRAPHIQUE meme si à l'exécution de programmes n'utilisant pas les primitives graphiques du LOGLAN il ne présente pas de différence avec les deux autres programmes, il réalise en fait des initialisations que le bureau fait à la place des programmes TOS et TTP.\r
+ Cela est du au fait que ce programme peut à tout moment basculer en mode graphique, revenir au mode texte, etc...\r
+\r
+ Quand on lance un programme TOS, le bureau cache la souris, efface l'écran et donne la main au programme appelé.\r
+ Quand on lance un programme TTP, le bureau suppose que l'utilisateur veut passer des paramètres au programme appellé. C'est pour cela qu'il ouvre une boite de dialogue avec une ligne vide pour que l'utilisateur entre ce qu'il veut indiquer au programme.\r
+\r
+LOGLAN.TTP : Indiquez simplement ce que vous mettriez après la commande LOGLAN sous DOS.\r
+\r
+exemple : pour compiler un programme sous DOS vous pourriez entrer : \r
+\r
+ LOGLAN MONPROG.LOG L+ O-\r
+\r
+pour réaliser la meme chose sous ATARI, double-cliquez sur l'icone LOGLAN.TTP\r
+et entrez dans la boite de dialogue :\r
+\r
+ MONPROG.LOG L+ O-\r
+\r
+et cliquez enfin sur le bouton OK et le bureau lancera l'application LOGLAN.TTP avec 'MONPROG.LOG L+ O-' en paramètres.\r
+\r
+Si vous lancez LOGLAN.TTP sans aucun paramètres, l'application vous demandera le nom du fichier à compiler. Entrez à ce moment-là le nom complet (avec l'extension .LOG ) de votre fichier. Le compilateur supposera que vous voulez compiler ce fichier à l'aide des options standards.\r
+\r
+GEN.TTP: L'utilisation de fichier est identique à LOGLAN.TTP.\r
+GEN.TTP ne prend pas de paramètres, il convient simplement de lui donner le nom de votre application ( sans aucune extension ).\r
+\r
+INTGEM.PRG : Comme son extension l'indique, il s'agit d'un programme utilisantles graphiques. Le bureau considère que ce type de programme n'utilise pas de paramètres pour son exécution.\r
+En fait, INTGEM utilise les memes paramètres que son homologue sous DOS.\r
+Pour utiliser ce programme vous pouvez :\r
+ le lancer directement : Comme LOGLAN.TTP, il vous demandera le nom du proramme à exécuter et demarrera en supposant que vous voulez utiliser les options par défaut du compilateur. Cette utilisation ne provoque aucune restrictions.\r
+Cependant, pour la programmation des processus, les options par défaut doivent etre modifiees dans certains.\r
+ Le programme GSORT.LOG par exemple,utilise les processus pour trier un ensemble de valeurs et peut créer plus de 30 processus. Avec la taille mémoire standard qui est de 30000 mots mémoires par processus, c'est-à-dire 60000 octets il faudra 60000 * 30 = 1800000 octets (1.6 Mo ) de memoire disponible.\r
+Aussi l'utilisation de GSORT se fait-elle avec l'option -m 10000 ( voire 7000 ) pour pouvoir l'exécuter.\r
+\r
+ Pour remédier à ce problème, deux solutions :\r
+ Soit vous renommez INTGEM.PRG en INTGEM.TTP : Il devient pour le bureau un programme texte acceptant des paramètres. Dans ce cas, la souris sera inutilisable dans les applications.\r
+ Soit vous utilisez un bureau alternatif comme NEODESK ou les dernières version du bureau ATARI ( à partir des TOS 2.0 - MEGA STE ) qui elles connaissent les programmes GEM qui prennent des paramètres. Le problème est que soit il coutent cher, soit il consomment de la mémoire vive.\r
+ Pour une utilisation normale, l'utilisation de INTGEM.PRG suivant la première méthode est amplement suffisante.\r
+\r
+\r
+PROBLEMES :\r
+La est le plus délicat et c'est pourquoi je conseille une configuration avec deux lecteurs ou mieux, un disque dur.\r
+Voici le problème : LOGLAN.TTP pour créer un fichier LCD commence par créer deux ou trois fichiers temporaires qu'il efface à la fin de la compilation.\r
+Ces fichiers sont généralement proportionnels à la complexité et à la taille de vos programmes. Il peuvent aller de 30 Ko jusqu'à 100 Ko. Sans indications contraire, il les crée dans le répertoire courant (là où se trouve votre programme source ), un rapide calcul permet de s'apercevoir que l'ensemble des fichiers exécutables sources et fichiers intermédiaires ne tiennent pas sur une disquette double-face normale.\r
+Il arrive que pour les fichiers importants, le compilateur vous réponde par\r
+ 'I/O Trap 29'\r
+cela signifie qu'il n'y a plus de place sur la disquette et la compilation s'arretera. Il vous faudra faire de la place sur la disquette afin qu'il y ait assez de place.\r
+ Pour information, la compilation du programme TEST1 utilise 150 Ko d'espace disque ( à peu près ) alors que la compilation du programme LOGDEB utilise environ 600 Ko.\r
+\r
+Pour éviter ce genre de désagrément, plusieurs solutions :\r
+ - ACHETEZ UN DISQUE DUR : il ont beaucoup baissé alors n'hésitez plus...\r
+ - Indiquez à LOGLAN.TTP qu'il doit créer ses fichiers temporaires ailleurs ( sur le lecteur B: par exemple ou mieux dans un RAM disque ).\r
+ Pour cela, comme sous DOS, il faut positionner la variable d'environnement TEMP sur le chemin où créer les fichiers temporaires.\r
+\r
+Voilà, vous savez à peu près tout sur comment compiler un programme écrit en LOGLAN sur ATARI.\r
+J'aimerai attirer l'attention sur un dernier détail : le paramétrage des applications.\r
+ Cette option permet de démarrer une application automatiquement en double cliquant simplement sur un fichier ayant l'extension adéquate.\r
+ Un fichier DESKTOP.INF est compris dans les fichiers qui sont mis à votre disposition. Il contient la configuration pour les applications suivantes:\r
+\r
+ APPLICATION EXTENSION\r
+ =========== =========\r
+ LOGLAN.TTP .LOG\r
+ INTGEM.PRG .CCD\r
+\r
+Autre chose, il est fournis dans la distribution deux autres application :\r
+ME.TTP et MS.TOS\r
+\r
+ME.TTP est l'éditeur de texte micro-emacs donné pour que l'on puisse éditer des ourt et ne nécéssite pas un apprentissage très ardu.\r
+\r
+MS.TOS est un micro-shell qui vous permettra de lancer vos applications plus facilement qu'avec le bureau. Il est destiné à faciliter le cyclecompilation -> erreur -> correction(s) des erreurs -> compilation -> etc... \r
+Il ne permet pas de modifier les variables d'environnement mais il peut rendre quelque services quand meme...\r
+\r
+\r
+ BONNE PROGRAMMATION !!!\r
+\r
+ Sebastien BERNARD\r
+\r
+\r
+\r
+\r
+à Pau, le 12 Novembre 1992\r
--- /dev/null
+#a000000\r
+#b000000\r
+#c???000?000<000?00;;400;0;;;4440??0;;?0?;0;;;0??03111103\r
+#d \r
+#E 18 13 \r
+#W 00 00 12 0E 35 0B 00 @\r
+#W 00 00 0E 01 34 09 00 @\r
+#M 00 00 00 FF A DISQUE@ @ \r
+#M 00 01 00 FF B DISQUE@ @ \r
+#T 00 07 02 FF CORBEILLE@ @ \r
+#F FF 04 @ *.*@ \r
+#D FF 01 @ *.*@ \r
+#G 03 FF *.APP@ @ \r
+#G 03 FF *.PRG@ @ \r
+#P 03 FF *.TTP@ @ \r
+#F 03 04 *.TOS@ @ \r
+#P 03 04 A:\LOGLAN.TTP@ *.LOG@ \r
+#G 03 04 A:\INTGEM.PRG@ *.PCD@ \r
--- /dev/null
+; EMACS.RC: Startup file for MicroEMACS 3.9cs\r
+;\r
+; This file is executed every time the\r
+; editor is entered, but only if it can\r
+; be found on '.' or '$(PATH)'.\r
+;\r
+\r
+; if you want the 40 lines mode, then uncomment this line:\r
+; set $sres DENSE\r
+\r
+set $discmd FALSE\r
+write-message "[Setting up....]"\r
+\r
+; Micro emacs now simulates tabs with blanks in some files (.c, .asm etc.)\r
+; If you don't like this, then press "M-0 TAB" when inside the desired buffer.\r
+\r
+; have fun with the Help and Keypad keys. They are all harmless functions.\r
+\r
+; ***** Rebind the Function keys\r
+;\r
+; Since this are the standard settings on Atari, they need not be set !\r
+; They just give an impression on the syntax needed.\r
+;\r
+; The bind-fn-key command is new by CS.\r
+; Non-cs versions must use bind-to-key.\r
+;\r
+;bind-fn-key kill-to-end-of-line f1 ; non-shift f1\r
+;bind-fn-key yank f2\r
+;bind-fn-key search-forward f3\r
+;bind-fn-key query-replace-string f4\r
+;bind-fn-key search-reverse f5\r
+;bind-fn-key execute-file f6\r
+;bind-fn-key next-buffer f7\r
+;bind-fn-key find-file f8\r
+;bind-fn-key save-file f9\r
+;bind-fn-key quick-exit f10\r
+;bind-fn-key help S-F1 ; Shift-F1\r
+\r
+; Cursor-Block:\r
+;bind-fn-key help help\r
+;bind-fn-key exit-emacs undo ; undo\r
+;bind-fn-key previous-page pgup ; insert key on Atari\r
+;bind-fn-key next-page pgdown ; clr/home key on Atari\r
+\r
+; Mouse\r
+;bind-fn-key set-mark leftmouse\r
+;bind-fn-key copy-region rightmouse\r
+\r
+; Keypad\r
+;bind-fn-key move-window-up K(\r
+;bind-fn-key move-window-down K)\r
+;bind-fn-key split-current-window K/\r
+;bind-fn-key delete-other-windows K*\r
+;bind-fn-key previous-window K-\r
+;bind-fn-key next-window K+\r
+;bind-fn-key beginning-of-file K7\r
+;bind-fn-key end-of-file K9\r
+;bind-fn-key previous-word K4\r
+;bind-fn-key redraw-display K5\r
+;bind-fn-key next-word K6\r
+;bind-fn-key beginning-of-line K1\r
+;bind-fn-key end-of-line K3\r
+;bind-fn-key execute-macro K0\r
+;bind-fn-key goto-line K.\r
+\r
+;; >>>> note: you get the name of a key by pressing help c <key>\r
+\r
+; These are not standard:\r
+\r
+bind-to-key apropos FNV ; S-F3\r
+bind-to-key help FNW ; S-F4\r
+bind-to-key fill-paragraph FNX ; S-F5\r
+\r
+; set screen colors\r
+add-global-mode "White" ; foreground\r
+add-global-mode "blue" ; background\r
+add-mode "White" ; foreground\r
+add-mode "blue" ; background\r
+\r
+; toggle function key window off\r
+1 store-macro\r
+ save-window\r
+ 1 next-window\r
+ !if &sequal "Function Keys" $cbufname\r
+ delete-window\r
+ !endif\r
+ bind-to-key execute-macro-14 FNT ; S-F1\r
+!force restore-window\r
+ write-message "[Function key window OFF]"\r
+!endm\r
+\r
+; toggle function key window back on\r
+14 store-macro\r
+ 1 next-window\r
+ !if &sequal $cbufname "emacs.hlp"\r
+ execute-macro-11\r
+ !endif\r
+ !if ¬ &sequal $cbufname "Function Keys"\r
+ 1 split-current-window\r
+ select-buffer "Function Keys"\r
+ add-mode "red"\r
+!force 6 resize-window\r
+ beginning-of-file\r
+ !endif\r
+ bind-to-key execute-macro-1 FNT\r
+ 2 next-window\r
+ write-message "[Function key window ON]"\r
+!endm\r
+\r
+; Enter Help\r
+2 store-macro\r
+ 1 next-window ;Make sure the function key window isn't up!\r
+ !if &sequal $cbufname "Function Keys"\r
+ delete-window\r
+ bind-to-key execute-macro-14 FNT\r
+ !endif\r
+ help\r
+ 8 resize-window\r
+ bind-to-key execute-macro-12 FNh\r
+ bind-to-key execute-macro-13 FNn\r
+ bind-to-key execute-macro-11 FNU\r
+ bind-to-key execute-macro-15 ^XO\r
+ bind-to-key execute-macro-15 ^XP\r
+ bind-to-key execute-macro-15 FNu\r
+ add-mode "red"\r
+ beginning-of-file\r
+ 2 forward-character\r
+ clear-message-line\r
+!endm\r
+\r
+; Exit Help\r
+11 store-macro\r
+ bind-to-key previous-page FNh\r
+ bind-to-key next-page FNn\r
+ bind-to-key execute-macro-2 FNU\r
+ bind-to-key next-window ^XO\r
+ bind-to-key previous-window ^XP\r
+ bind-to-key next-window FNu\r
+ delete-window\r
+ clear-message-line\r
+!endm\r
+\r
+; don't allow these commands from within the HELP screen\r
+15 store-macro\r
+ write-message "[Use S-F2 to exit HELP (with SHIFT)]!!"\r
+!endm\r
+\r
+; last help page\r
+12 store-macro\r
+ beginning-of-line\r
+ search-reverse "=>"\r
+ 1 redraw-display\r
+!endm\r
+\r
+; next help page\r
+13 store-macro\r
+ beginning-of-line\r
+ 2 forward-character\r
+ search-forward "=>"\r
+ 1 redraw-display\r
+!endm\r
+\r
+; reformat indented paragraph\r
+\r
+6 store-macro\r
+ write-message " [Fixing paragraph]"\r
+ kill-region\r
+ 2 split-current-window\r
+ select-buffer "[temp]"\r
+ yank\r
+ beginning-of-file\r
+ replace-string "~n " "~n"\r
+ write-message " [Fixing paragraph]"\r
+ 66 set-fill-column\r
+ write-message " [Fixing paragraph]"\r
+ fill-paragraph\r
+ 77 set-fill-column\r
+ beginning-of-file\r
+ handle-tab\r
+ replace-string ~n "~n "\r
+ write-message " [Fixing paragraph]"\r
+ end-of-file\r
+ 2 delete-previous-character\r
+ beginning-of-file\r
+ set-mark\r
+ write-message " [Fixing paragraph]"\r
+ end-of-file\r
+ kill-region\r
+ unmark-buffer\r
+ delete-window\r
+ yank\r
+ delete-buffer "[temp]"\r
+ write-message " [Fixed paragraph]"\r
+!endm\r
+\r
+; indent region\r
+\r
+7 store-macro\r
+ write-message " [Indenting region]"\r
+ kill-region\r
+ 2 split-current-window\r
+ select-buffer "[temp]"\r
+ yank\r
+ beginning-of-file\r
+ handle-tab\r
+ replace-string "~n" "~n "\r
+ end-of-file\r
+ 4 delete-previous-character\r
+ beginning-of-file\r
+ set-mark\r
+ write-message " [Indenting region]"\r
+ end-of-file\r
+ kill-region\r
+ unmark-buffer\r
+ delete-window\r
+ yank\r
+ delete-buffer "[temp]"\r
+ write-message " [Region Indented]"\r
+!endm\r
+\r
+; undent region\r
+\r
+8 store-macro\r
+ write-message " [Undenting region]"\r
+ kill-region\r
+ 2 split-current-window\r
+ select-buffer "[temp]"\r
+ yank\r
+ beginning-of-file\r
+ delete-next-character\r
+ replace-string "~n " "~n"\r
+ end-of-file\r
+ 2 delete-previous-character\r
+ beginning-of-file\r
+ set-mark\r
+ write-message " [Undenting region]"\r
+ end-of-file\r
+ kill-region\r
+ unmark-buffer\r
+ delete-window\r
+ yank\r
+ delete-buffer "[temp]"\r
+ write-message " [Region undented]"\r
+!endm\r
+\r
+;\r
+; bring up the function key window\r
+\r
+ 1 split-current-window\r
+ select-buffer "Function Keys"\r
+ add-mode "red"\r
+ 6 resize-window\r
+ insert-string "f1 kill line f6 exec file | F1 toggle function list F7 indent region~n"\r
+ insert-string "f2 yank f7 select buf | F2 toggle help file F8 undent region~n"\r
+ insert-string "f3 search f8 find file | F3 find command/apropos ^X= where am I~n"\r
+ insert-string "f4 replace f9 save file | F4 general HELP ! M-G goto line (ESC-G)~n"\r
+ insert-string "f5 search back f10 exit emacs | F5 reformat paragraph M-< start of file~n"\r
+ insert-string "^G cancel command (Control+G) | F6 ref undented region M-O toggle OVER mode~n"\r
+ beginning-of-file\r
+ unmark-buffer\r
+ add-mode "view"\r
+ next-window\r
+\r
+set $discmd TRUE\r
+\r
+; -eof-\r
--- /dev/null
+As you can guess this are executables\r
+files for DOS.AT i.e. 16 bit word.\r
+Use: loglan ... h+\r
+ hgen\r
+ *hint for big sources.\r
+Use: ega(h)int for colour cards,\r
+ hgc(h)int for Hercules mono \r
+CGA directory is for unlucky guys in\r
+possession of CGA cards.
\ No newline at end of file
--- /dev/null
+What you should know?\r
+\r
+IF you have pc386 or 486 you may prefer the more appropriate versions.\r
+\r
+You need to install\r
+\r
+1. LOGLAN.EXE - the compiler of Loglan'82 programs.\r
+2. GEN.EXE or HGEN.EXE depending of the size of\r
+ your Loglan programs\r
+3. a version of INT.EXE \r
+ depending on the size of your programs\r
+ the name should contain H for huge\r
+ basically you can choose between\r
+ egaint (egahint) or hgcint (hgchint) for Hercules card\r
+ Choose egaint if you have EGA or VGA card.\r
+ \r
+Enclosed you will find versions for CGA card - if you are unlucky.\r
+\r
+Choose correctly.\r
+\r
+ ENJOY
\ No newline at end of file
--- /dev/null
+rem IF\r
+rem 1ø the programs loglan.exe, gen.exe, int.exe are visible (PATH ?)\r
+rem 2ø a file, say, sourc.log contains supposedly Loglan program\r
+rem THEN\r
+rem you may find it useful to call\r
+rem cc sourc\r
+\r
+loglan %1\r
+pause\r
+gen %1\r
+del %1.lcd\r
+int %1\r
--- /dev/null
+This directory contains the executa-\r
+bles for 386 based DOS systems.\r
--- /dev/null
+Program SystemedeFenetrage;\r
+Begin\r
+Pref iiuwgraph block\r
+ Begin\r
+ Pref mouse block\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* P r o g r a m m e P r i n c i p a l *)\r
+ (*****************************************************************************)\r
+ var v,p,h,i : integer,\r
+ l,r,c : integer,\r
+ rep : arrayof char,\r
+ d : boolean,\r
+ xx,yy : arrayof integer,\r
+ status,code,x,y,flags,button : integer;\r
+ \r
+ Begin\r
+ \r
+ call gron(0);\r
+ call init(1,0);\r
+ \r
+ call showcursor;\r
+ call patern(5,5,635,475,2,0);\r
+ call outstring(10,10,"x=",2,0);\r
+ call outstring(100,10,"y=",2,0);\r
+ call outstring(10,30,"status = ",2,0);\r
+ call outstring(10,50,"code = ",2,0);\r
+ call outstring(10,70,"flags = ",2,0);\r
+ call outstring(10,90,"button = ",2,0);\r
+ call patern(100,210,300,320,3,1);\r
+\r
+ array xx dim (1:6);\r
+ array yy dim (1:6);\r
+ xx(1):=410; yy(1):=10;\r
+ xx(2):=450; yy(2):=30;\r
+ xx(3):=460; yy(3):=50;\r
+ xx(4):=430; yy(4):=80;\r
+ xx(5):=420; yy(5):=40;\r
+ xx(6):=480; yy(6):=30;\r
+ call intens(6,xx,yy,8,1);\r
+ for i:=1 to 6\r
+ do\r
+ yy(i):=yy(i)+100;\r
+ od;\r
+ call intens(6,xx,yy,15,0);\r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0);\r
+ call cirb(400,400,40,40,600,4000,11,1);\r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); \r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); \r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15);\r
+ \r
+ call getmovement(1,1); \r
+ \r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if (d)\r
+ then call outstring(10,400,"Event",2,0);\r
+ call patern(80,25,130,100,0,1);\r
+ call track(40,10,v,0,4);\r
+ call track(140,10,p,0,4);\r
+ call track(80,30,h,0,4);\r
+ call track(80,50,l,0,4);\r
+ call track(80,70,r,0,4);\r
+ call track(80,90,c,0,4);\r
+ if((h=164 and l=27) or (c=3))\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call groff;\r
+ writeln("i=",i);\r
+ for i:=lower(rep) to upper(rep)\r
+ do\r
+ write(rep(i));\r
+ od;\r
+ writeln;\r
+ End\r
+ End\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+1. You may find it useful to rename the programs \r
+\r
+ logla386.exe --> loglan.exe\r
+ gen386.exe --> gen.exe\r
+ int386.exe --> int.exe\r
+ If you are going to use \lotek\LOTEK.exe it strongly advised!\r
+\r
+1a. Put go32.exe, emu387 and a chosen driver for your graphic card in a visible\r
+(PATH ?) directory.\r
+\r
+2. Make sure to execute \r
+ exec.bat\r
+before compiling your loglan sources. Once for the whole session.\r
+Adapt the file exec.bat to your environment.\r
+\r
+3. Make sure that the directory\r
+\r
+ c:\tmp\r
+exists. It is needed for the correct behaviour of programs.\r
+Don't worry. You have almost nothing to do in it! Just clean it of garbage\r
+once a month, week... It will depend of the number of broken sessions.\r
+\r
+(October 1993)\r
+(DEcember 1994)\r
+\r
+\r
--- /dev/null
+rem IF:\r
+rem 1ø the programs: loglan.exe, gen.exe, int.exe are visible here\r
+rem 2ø the first parameter %1 of this command is the file \r
+rem containing what you believe a source of Loglan program\r
+rem THEN it may be useful to use this command cc\r
+\r
+loglan %1\r
+pause\r
+gen %1\r
+del %1.lcd\r
+int %1\r
--- /dev/null
+c:\loglan\exe\loglan %1\r
+pause\r
+c:\loglan\exe\gen %1\r
+del %1.lcd\r
+c:\loglan\exe\int %1\r
--- /dev/null
+@ECHO OFF\r
+set TMPDIR=c:/tmp\r
+set GO32TMP=c:/tmp\r
+set GO32=driver emu387 c:/loglan/exe/stdvga.grn gw 640 gh 480\r
+rem path f:\loglan\exe\386;f:\loglan\lotek;%path%
\ No newline at end of file
--- /dev/null
+Make sure that the directory\r
+\r
+ c:\tmp\r
+exists. It is needed for the correct behaviour of programs.\r
+Don't worry. You have nothing to do in it!\r
+\r
+\r
+\r
+\r
--- /dev/null
+These are \r
+ Loglan -> C\r
+croscompiler part1 and part2. Written by Marek Wojtylak, Silesian University.\r
+\r
+They do not cover the whole Loglan (processes are not implemented).\r
+\r
+If I remember correctly one should use it as follows\r
+\r
+ 1. compile your loglan source file using "loglan"\r
+ 2. crosscompile using "l2c1" and then "l2c2" on .lcd file\r
+ 3. compile using your C compiler\r
+ (It was verified with Turbo C)\r
+\r
+\r
+ ENJOY!\r
+\r
+ \r
+Please report your problems.\r
+No guarantee however.\r
--- /dev/null
+What you should know?\r
+\r
+You need to install\r
+\r
+1. LOGLAN.EXE - the compiler of Loglan'82 programs.\r
+2. GEN.EXE or HGEN.EXE depending of the size of\r
+ your Loglan programs\r
+3. a version of INT.EXE \r
+ depending on the size of your programs\r
+ the name should contain H for huge\r
+ basically you can choose between\r
+ egaint (egahint) or hgcint (hgchint) for Hercules card\r
+ Choose egaint if you have EGA or VGA card.\r
+ \r
+Enclosed you will find versions for CGA card - if you are unlucky.\r
+\r
+Choose carefully.\r
+\r
+ ENJOY!
\ No newline at end of file
--- /dev/null
+
+This is an incomplete version of loglan.
+
+The classes IIUWGRAPH and MOUSE are not working here.
+We shall recompile the system soon.
+
+ Remark. Graphics for UNIX differs from those of DOS.
+
+
--- /dev/null
+<html>\r
+<head>\r
+<title> Loglan'82</title>\r
+</head>\r
+<body>\r
+<h1 align=center >
+
\r<IMG ALIGN=BOTTOM SRC = "/icons/loglanmm.gif" >
+ Biuletyn Loglanu
+</h1>
+<h5 align=center> ukazuje sie od czasu do czasu </h5>\r
+<h3 align=right>nr 1/96</h3>\r
+<IMG ALIGN=TOP SRC = "/icons/linecolor.gif" >
+<ul>\r
+<li><h2 > Polskie repozytorium Loglanu wreszcie dziala </h2>\r
+<p> Z przyjemnoscia ogloszamy, ze Loglan jest wreszcie dostepny z polskiego servera, a nawet dwu.\r
+<li><h1> Slowo wstepne </h1>\r
+<p> Biuletyn ma sluzyc jako forum dyskusyjne programowania obiektowego i inzynierii oprogramowania, takze jako zrodlo ciekawych wiadomosci.\r
+Z przyjemnoscia zamiescimy komentarze krytykujace Loglan. Informowac bedziemy o nowosciach. \r
+<li><h2> Zapraszamy do wspolpracy </h2>\r
+<center><img src="nieprzeg.jpg">\r</center>
+<h1 align=center> Spotkanie - dyskusja zainteresowanych praca w projekcie badawczym<br>
+LOGLAN'96 <br> 27 marca 1996 godz. 12.00 <br>
+sala 12 Instytutu Informatyki Politechniki Bialostockiej<br>
+ul. Wiejska 45 A </h1>
+<li><h2 >Zapraszamy do dyskusji </h2>\r
+\r
+Ja jestem przekonany, ze niewiele jezykow programowania dorownuje Loglanowi. Przez to moge sie wydawac smieszny. Ale nie jestem slepy ani gluchy. Uczciwie zaakceptuje argumenty przekonujace o wyzszosci innych rozwiazan, o przewadze innego jezyka programowania. <em> O ile takie argumenty zostana mi przedstawione! </em> W naszym wspolnym interesie jest dyskusja, scieranie sie pogladow i wyrabianie wlasnych pogladow na problemy informatyki. <br>\r
+<h7>UWAGA OSOBISTA.<br>\r
+Podczas blisko 40 lat pracy z "maszynami matematycznymi" wiele razy odkrywalem nowe zjawiska, nowe narzedzia i nowe pytania. Jest to zrodlo wielkich radosci i czasami zawstydzen. Np. na poczatku lat 70 przez pare miesiecy nieufnie podchodzilem do problematyki zlozonosci obliczeniowej. <br>\r
+KONIEC UWAGI<br></h7>\r
+\r
+A przeciez nie idzie tu o mnie tylko. Kazdy profesjonalista powinien posiadac swoj poglad na sprawy programowania obiektowego i swoj warsztat pracy. \r
+Inni moga uwazac ze tylko Smalltalk jest jezykiem prawdziwie obiektowym. Wiekszosc zna C++. Od niedawna modna jest Java. Co wybrac? Dlaczego? W natloku ofert pojawil sie Loglan. Dlaczego drogi czytelniku zaprzatamy Ci glowe tym narzedziem? \r
+Zapraszam wiec do dyskusji. \r
+ Dlaczego tak mysle?\r
+Czy jestem slepy i gluchy na racjonalne argumenty? Oczywiscie, ze <strong>nie</strong>.\r
+<p> <em>Czym jest Loglan?. </em> Loglan'82 jest uniwersalnym, kompletnym jezykiem programowania obiektowego. \r
+<ul>\r
+<li>Jesli interesujesz sie <strong>programowaniem obiektowym </strong> i chcesz zglebic jego wszelkie tajniki to zapoznaj sie z Loglanem. Nie wyobrazaj sobie ze znajac jeden tylko z jezykow programowania obiektowego np. Simula67, C++, Turbo Pascal z obiektami, Objective C, Modula3, Smalltalk, Eiffel, Beta czy Java, wiesz juz wszystko o obiektach.\r
+Znalazlem u Wergilego taki zwrot: <em>"Felix qui potuit rerum cognoscere causas"</em> co oznacza: "szczesliwy kto mogl poznac istote rzeczy". Dopiero poznanie Loglanu uczyni z Ciebie znawce spraw obiektowych. \r
+<li> Potem mozesz nadal programowac w swoim ulubionym jezyku XYZ, ale bedziesz przynajmniej wiedzial co tracisz. (A mowiac powazniej bedziesz wiedziec na co zwracac uwage.)\r
+<li> Bo tracisz! Loglan zawiera w sobie wiele oryginalnych idei. Myslalem, ze zostana one ponownie odkryte w Ameryce za lat 20. Ale pojawienie sie Javy dowodzi ze sie mylilem. Java zawiera czesc pomyslow jakie Loglan oferowal w 1988, a mianowicie procesy-obiekty \r
+rozproszone w sieci i (jeden tylko!) dodatkowy poziom zagniezdzenia modulow. Nie zawiera natomiast naszego pomyslu na komunikacje, synchronizacje procesow tzw. obce wywolywanie procedur (metod) jednego procesu przez inny proces.\r
+Mechanizm obcego wywolywania procedur (ang. <em>alien call</em>) umozliwia potraktowanie kazdego procesu jako servera - swiadczy on uslugi polegajace na wykonaniu swoich metod tzn. funkcji i procedur zadeklarowanych wewnatrz niego. Oczywiscie proces wywolujacy procedure obcego procesy jest jego klientem.\r
+<li> Inne rozwiazania znane w Loglanie i nadal czekajace na ponowne odkrycie to np.<br>\r
+- bezpieczna dealokacja, <br>\r
+- zagniezdzanie modulow (jak w Pascalu) i dziedziczenie,<br>\r
+- dziedziczyc moga nie tylko klasy, procedury, funkcje, wspolprogramy, procesy i bloki takze,<br> \r
+- dziedziczenie nie ogranicza sie tylko do modulow-braci w drzewie zagniezdzania modulow.\r
+<br>(Te mechanizmy znane sa tez w Becie).\r
+- \r
+<li> \r
+</ul>\r
+Jest to wynik prac naukowych prowadzonych przez prof. Antoniego Kreczmara, prof. Andrzeja Salwickiego i wielu innych, kiedys pracownikow Instytutu Informatyki Uniwersytetu Warszawskiego.\r
+<p>Od 6 lat domem dla Loglanu stalo sie laboratorium LITA w Uniwersytecie w Pau (Francja). Od 1993 LITA dystrybuuje Loglan w sieci Internet.\r
+<p>W listopadzie 1995 w Instytucie Informatyki Politechniki Bialostockiej uruchomiono w pelni sieciowa wersje <a href="all.htm"> Loglanu. </a> \r
+</ul>\r
+<IMG ALIGN=TOP SRC = "/icons/linecolor.gif" >\r
+<address>Last update </address>\r
+</body>\r
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//AdvaSoft//DTD HTML 2 extended 960415//EN">
+<HTML>
+<HEAD>
+ <TITLE>Loglan Biuletyn nr 2</TITLE>
+</HEAD>
+
+<BODY>
+<h1 align=center >
+ <IMG ALIGN=BOTTOM SRC = "/icons/loglanmm.gif" >
+ Biuletyn Loglanu
+</h1>
+<h5 align=center> ukazuje sie od czasu do czasu </h5>
+<h3 align=right>nr 2/96</h3>
+<IMG ALIGN=TOP SRC = "/icons/linecolor.gif" >
+<H1>Loglan dziala w sieci maszyn DOSowych</H1>
+
+<P>
+Milo nam doniesc, ze Loglan alokuje procesy w sieci maszyn DOSowych.<BR>
+Na razie wykorzystujemy biblioteke operacji sieciowych LanWorkPlace.<BR>
+W tej eksperymentalnej wersji nie dziala grafika.<BR>
+Z tych i innych powodow pracujemy nad wersja, ktora bedzie wykorzystywac
+platforme DJGPP, czyli 32 bitowa maszyne z dobra grafika etc.
+
+
+<HR>
+<ADDRESS>
+<A HREF="salwicki@aragorn.pb.bialystok.pl" METHODS="mailto">Andrzej Salwicki</A>
+</ADDRESS>
+<HR>
+<A HREF="biul1.html" TITLE="Biuletyn nr 1" METHODS="http">Poprzedni biuletyn</A>
+ </BODY>
+</HTML>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//AdvaSoft//DTD HTML 2 extended 960415//EN">
+<HTML>
+<HEAD>
+ <TITLE>Loglan Biuletyn nr 2</TITLE>
+</HEAD>
+
+<BODY>
+<h1 align=center >
+ <IMG ALIGN=BOTTOM SRC = "/icons/loglanmm.gif" >
+ Loglan's Bulletin
+</h1>
+<h5 align=center> appears from time to time </h5>
+<h3 align=right>nr 2/96</h3>
+<IMG ALIGN=TOP SRC = "/icons/linecolor.gif" >
+<H1>Loglan operates in a network of DOS machines</H1>
+
+
+
+<P>
+We are pleased to inform that a version of Loglan able to allocate processes on
+a network of DOS machines is running.<BR>
+It is an experimental version for it uses an older version of Loglan's compiler
+, a private property library LanWorkPlace of networking and has no graphic library.<BR>
+For these and other reasons we (<A HREF="mailto:swida@aragorn.pb.bialystok.pl">Oskar Swida</A>) are working on putting Loglan on the plateform of DJGPP
+ then you will have a 32 bit machine and a good library of graphic operations.<BR>
+<P>
+
+
+
+<HR>
+<ADDRESS>
+<A HREF="salwicki@aragorn.pb.bialystok.pl" METHODS="mailto">Andrzej Salwicki</A>
+Last update Tue 4 June 1996
+</ADDRESS>
+<HR>
+<A HREF="biul1.html" TITLE="Biuletyn nr 1" METHODS="http">Poprzedni biuletyn</A>
+ </BODY>
+</HTML>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//AdvaSoft//DTD HTML 2 extended 960415//EN">
+<HTML>
+<HEAD>
+ <TITLE>Loglan Biuletyn nr 2</TITLE>
+</HEAD>
+
+<BODY>
+<h1 align=center >
+ <IMG ALIGN=BOTTOM SRC = "/icons/loglanmm.gif" >
+ Loglan's Bulletin
+</h1>
+<h5 align=center> appears from time to time </h5>
+<h3 align=right>nr 2/96</h3>
+<IMG ALIGN=TOP SRC = "/icons/linecolor.gif" >
+<H1>Loglan operates in a network of DOS machines</H1>
+
+
+
+<P>
+We are pleased to inform that a version of Loglan able to allocate processes on
+a network of DOS machines is running.<BR>
+It is an experimental version for it uses an older version of Loglan's compiler
+, a private property library LanWorkPlace of networking and has no graphic library.<BR>
+For these and other reasons we (Oskar Swida) are working on putting Loglan on the plateform of DJGPP
+ then you will have a 32 bit machine and a good library of graphic operations.<BR>
+<P>
+
+
+
+<HR>
+<ADDRESS>
+<A HREF="salwicki@aragorn.pb.bialystok.pl" METHODS="mailto">Andrzej Salwicki</A>
+Last update Tue 4 June 1996
+</ADDRESS>
+<HR>
+<A HREF="biul1.html" TITLE="Biuletyn nr 1" METHODS="http">Poprzedni biuletyn</A>
+ </BODY>
+</HTML>
--- /dev/null
+<html>\r
+<head>\r
+<title> Loglan'82</title>\r
+</head>\r
+<body>\r
+<h1 align=center >
+
\r<IMG ALIGN=MIDDLE SRC = "http://aragorn.pb.bialystok.pl/../icons/loglanmm.gif" >
+ Biuletyn Loglanu
+</h1>
+<h5 align=center> ukazuje sie od czasu do czasu </h5>\r
+<h3 align=right>nr 1/96</h3>\r
+<IMG ALIGN=TOP SRC = "http://aragorn.pb.bialystok.pl/../icons/linecolor.gif" >
+<ul>\r
+<li><h2 > Polskie repozytorium Loglanu wreszcie dziala </h2>\r
+<p> Z przyjemnoscia ogloszamy, ze Loglan jest wreszcie dostepny z polskiego servera, a nawet dwu.\r
+<li><h1> Slowo wstepne </h1>\r
+<p> Biuletyn ma sluzyc jako forum dyskusyjne programowania obiektowego i inzynierii oprogramowania, takze jako zrodlo ciekawych wiadomosci.\r
+Z przyjemnoscia zamiescimy komentarze krytykujace Loglan. Informowac bedziemy o nowosciach. \r
+<li><h2> Zapraszamy do wspolpracy </h2>\r
+<center><img src="nieprzeg.jpg">\r</center>
+<h1 align=center> Spotkanie - dyskusja zainteresowanych praca w projekcie badawczym<br>
+LOGLAN'96 <br> 27 marca 1996 godz. 12.00 <br>
+sala 12 Instytutu Informatyki Politechniki Bialostockiej<br>
+ul. Wiejska 45 A </h1>
+<li><h2 >Zapraszamy do dyskusji </h2>\r
+\r
+Ja jestem przekonany, ze niewiele jezykow programowania dorownuje Loglanowi. Przez to moge sie wydawac smieszny. Ale nie jestem slepy ani gluchy. Uczciwie zaakceptuje argumenty przekonujace o wyzszosci innych rozwiazan, o przewadze innego jezyka programowania. <em> O ile takie argumenty zostana mi przedstawione! </em> W naszym wspolnym interesie jest dyskusja, scieranie sie pogladow i wyrabianie wlasnych pogladow na problemy informatyki. <br>\r
+<h7>UWAGA OSOBISTA.<br>\r
+Podczas blisko 40 lat pracy z "maszynami matematycznymi" wiele razy odkrywalem nowe zjawiska, nowe narzedzia i nowe pytania. Jest to zrodlo wielkich radosci i czasami zawstydzen. Np. na poczatku lat 70 przez pare miesiecy nieufnie podchodzilem do problematyki zlozonosci obliczeniowej. <br>\r
+KONIEC UWAGI<br></h7>\r
+\r
+A przeciez nie idzie tu o mnie tylko. Kazdy profesjonalista powinien posiadac swoj poglad na sprawy programowania obiektowego i swoj warsztat pracy. \r
+Inni moga uwazac ze tylko Smalltalk jest jezykiem prawdziwie obiektowym. Wiekszosc zna C++. Od niedawna modna jest Java. Co wybrac? Dlaczego? W natloku ofert pojawil sie Loglan. Dlaczego drogi czytelniku zaprzatamy Ci glowe tym narzedziem? \r
+Zapraszam wiec do dyskusji. \r
+ Dlaczego tak mysle?\r
+Czy jestem slepy i gluchy na racjonalne argumenty? Oczywiscie, ze <strong>nie</strong>.\r
+<p> <em>Czym jest Loglan?. </em> Loglan'82 jest uniwersalnym, kompletnym jezykiem programowania obiektowego. \r
+<ul>\r
+<li>Jesli interesujesz sie <strong>programowaniem obiektowym </strong> i chcesz zglebic jego wszelkie tajniki to zapoznaj sie z Loglanem. Nie wyobrazaj sobie ze znajac jeden tylko z jezykow programowania obiektowego np. Simula67, C++, Turbo Pascal z obiektami, Objective C, Modula3, Smalltalk, Eiffel, Beta czy Java, wiesz juz wszystko o obiektach.\r
+Znalazlem u Wergilego taki zwrot: <em>"Felix qui potuit rerum cognoscere causas"</em> co oznacza: "szczesliwy kto mogl poznac istote rzeczy". Dopiero poznanie Loglanu uczyni z Ciebie znawce spraw obiektowych. \r
+<li> Potem mozesz nadal programowac w swoim ulubionym jezyku XYZ, ale bedziesz przynajmniej wiedzial co tracisz. (A mowiac powazniej bedziesz wiedziec na co zwracac uwage.)\r
+<li> Bo tracisz! Loglan zawiera w sobie wiele oryginalnych idei. Myslalem, ze zostana one ponownie odkryte w Ameryce za lat 20. Ale pojawienie sie Javy dowodzi ze sie mylilem. Java zawiera czesc pomyslow jakie Loglan oferowal w 1988, a mianowicie procesy-obiekty \r
+rozproszone w sieci i (jeden tylko!) dodatkowy poziom zagniezdzenia modulow. Nie zawiera natomiast naszego pomyslu na komunikacje, synchronizacje procesow tzw. obce wywolywanie procedur (metod) jednego procesu przez inny proces.\r
+Mechanizm obcego wywolywania procedur (ang. <em>alien call</em>) umozliwia potraktowanie kazdego procesu jako servera - swiadczy on uslugi polegajace na wykonaniu swoich metod tzn. funkcji i procedur zadeklarowanych wewnatrz niego. Oczywiscie proces wywolujacy procedure obcego procesy jest jego klientem.\r
+<li> Inne rozwiazania znane w Loglanie i nadal czekajace na ponowne odkrycie to np.<br>\r
+- bezpieczna dealokacja, <br>\r
+- zagniezdzanie modulow (jak w Pascalu) i dziedziczenie,<br>\r
+- dziedziczyc moga nie tylko klasy, procedury, funkcje, wspolprogramy, procesy i bloki takze,<br> \r
+- dziedziczenie nie ogranicza sie tylko do modulow-braci w drzewie zagniezdzania modulow.\r
+<br>(Te mechanizmy znane sa tez w Becie).\r
+- \r
+<li> \r
+</ul>\r
+Jest to wynik prac naukowych prowadzonych przez prof. Antoniego Kreczmara, prof. Andrzeja Salwickiego i wielu innych, kiedys pracownikow Instytutu Informatyki Uniwersytetu Warszawskiego.\r
+<p>Od 6 lat domem dla Loglanu stalo sie laboratorium LITA w Uniwersytecie w Pau (Francja). Od 1993 LITA dystrybuuje Loglan w sieci Internet.\r
+<p>W listopadzie 1995 w Instytucie Informatyki Politechniki Bialostockiej uruchomiono w pelni sieciowa wersje <a href="all.htm"> Loglanu. </a> \r
+</ul>\r
+<IMG ALIGN=TOP SRC = "http://aragorn/pb.bialystok.pl/../icons/linecolor.gif" >\r
+<address>Last update </address>\r
+</body>\r
+</html>ÔÔ
\ No newline at end of file
--- /dev/null
+\ 4%!PS-Adobe-3.0\r
+%%Creator: Windows PSCRIPT\r
+%%Title: Microsoft Word - COMPTBLE.DOC\r
+%%BoundingBox: 12 14 602 780\r
+%%DocumentNeededResources: (atend)\r
+%%DocumentSuppliedResources: (atend)\r
+%%Pages: (atend)\r
+%%BeginResource: procset Win35Dict 3 1\r
+/Win35Dict 290 dict def Win35Dict begin/bd{bind def}bind def/in{72\r
+mul}bd/ed{exch def}bd/ld{load def}bd/tr/translate ld/gs/gsave ld/gr\r
+/grestore ld/M/moveto ld/L/lineto ld/rmt/rmoveto ld/rlt/rlineto ld\r
+/rct/rcurveto ld/st/stroke ld/n/newpath ld/sm/setmatrix ld/cm/currentmatrix\r
+ld/cp/closepath ld/ARC/arcn ld/TR{65536 div}bd/lj/setlinejoin ld/lc\r
+/setlinecap ld/ml/setmiterlimit ld/sl/setlinewidth ld/scignore false\r
+def/sc{scignore{pop pop pop}{0 index 2 index eq 2 index 4 index eq\r
+and{pop pop 255 div setgray}{3{255 div 3 1 roll}repeat setrgbcolor}ifelse}ifelse}bd\r
+/FC{bR bG bB sc}bd/fC{/bB ed/bG ed/bR ed}bd/HC{hR hG hB sc}bd/hC{\r
+/hB ed/hG ed/hR ed}bd/PC{pR pG pB sc}bd/pC{/pB ed/pG ed/pR ed}bd/sM\r
+matrix def/PenW 1 def/iPen 5 def/mxF matrix def/mxE matrix def/mxUE\r
+matrix def/mxUF matrix def/fBE false def/iDevRes 72 0 matrix defaultmatrix\r
+dtransform dup mul exch dup mul add sqrt def/fPP false def/SS{fPP{\r
+/SV save def}{gs}ifelse}bd/RS{fPP{SV restore}{gr}ifelse}bd/EJ{gsave\r
+showpage grestore}bd/#C{userdict begin/#copies ed end}bd/FEbuf 2 string\r
+def/FEglyph(G )def/FE{1 exch{dup 16 FEbuf cvrs FEglyph exch 1 exch\r
+putinterval 1 index exch FEglyph cvn put}for}bd/SM{/iRes ed/cyP ed\r
+/cxPg ed/cyM ed/cxM ed 72 100 div dup scale dup 0 ne{90 eq{cyM exch\r
+0 eq{cxM exch tr -90 rotate -1 1 scale}{cxM cxPg add exch tr +90 rotate}ifelse}{cyP\r
+cyM sub exch 0 ne{cxM exch tr -90 rotate}{cxM cxPg add exch tr -90\r
+rotate 1 -1 scale}ifelse}ifelse}{pop cyP cyM sub exch 0 ne{cxM cxPg\r
+add exch tr 180 rotate}{cxM exch tr 1 -1 scale}ifelse}ifelse 100 iRes\r
+div dup scale 0 0 transform .25 add round .25 sub exch .25 add round\r
+.25 sub exch itransform translate}bd/SJ{1 index 0 eq{pop pop/fBE false\r
+def}{1 index/Break ed div/dxBreak ed/fBE true def}ifelse}bd/ANSIVec[\r
+16#0/grave 16#1/acute 16#2/circumflex 16#3/tilde 16#4/macron 16#5/breve\r
+16#6/dotaccent 16#7/dieresis 16#8/ring 16#9/cedilla 16#A/hungarumlaut\r
+16#B/ogonek 16#C/caron 16#D/dotlessi 16#27/quotesingle 16#60/grave\r
+16#7C/bar 16#82/quotesinglbase 16#83/florin 16#84/quotedblbase 16#85\r
+/ellipsis 16#86/dagger 16#87/daggerdbl 16#89/perthousand 16#8A/Scaron\r
+16#8B/guilsinglleft 16#8C/OE 16#91/quoteleft 16#92/quoteright 16#93\r
+/quotedblleft 16#94/quotedblright 16#95/bullet 16#96/endash 16#97\r
+/emdash 16#99/trademark 16#9A/scaron 16#9B/guilsinglright 16#9C/oe\r
+16#9F/Ydieresis 16#A0/space 16#A4/currency 16#A6/brokenbar 16#A7/section\r
+16#A8/dieresis 16#A9/copyright 16#AA/ordfeminine 16#AB/guillemotleft\r
+16#AC/logicalnot 16#AD/hyphen 16#AE/registered 16#AF/macron 16#B0/degree\r
+16#B1/plusminus 16#B2/twosuperior 16#B3/threesuperior 16#B4/acute 16#B5\r
+/mu 16#B6/paragraph 16#B7/periodcentered 16#B8/cedilla 16#B9/onesuperior\r
+16#BA/ordmasculine 16#BB/guillemotright 16#BC/onequarter 16#BD/onehalf\r
+16#BE/threequarters 16#BF/questiondown 16#C0/Agrave 16#C1/Aacute 16#C2\r
+/Acircumflex 16#C3/Atilde 16#C4/Adieresis 16#C5/Aring 16#C6/AE 16#C7\r
+/Ccedilla 16#C8/Egrave 16#C9/Eacute 16#CA/Ecircumflex 16#CB/Edieresis\r
+16#CC/Igrave 16#CD/Iacute 16#CE/Icircumflex 16#CF/Idieresis 16#D0/Eth\r
+16#D1/Ntilde 16#D2/Ograve 16#D3/Oacute 16#D4/Ocircumflex 16#D5/Otilde\r
+16#D6/Odieresis 16#D7/multiply 16#D8/Oslash 16#D9/Ugrave 16#DA/Uacute\r
+16#DB/Ucircumflex 16#DC/Udieresis 16#DD/Yacute 16#DE/Thorn 16#DF/germandbls\r
+16#E0/agrave 16#E1/aacute 16#E2/acircumflex 16#E3/atilde 16#E4/adieresis\r
+16#E5/aring 16#E6/ae 16#E7/ccedilla 16#E8/egrave 16#E9/eacute 16#EA\r
+/ecircumflex 16#EB/edieresis 16#EC/igrave 16#ED/iacute 16#EE/icircumflex\r
+16#EF/idieresis 16#F0/eth 16#F1/ntilde 16#F2/ograve 16#F3/oacute 16#F4\r
+/ocircumflex 16#F5/otilde 16#F6/odieresis 16#F7/divide 16#F8/oslash\r
+16#F9/ugrave 16#FA/uacute 16#FB/ucircumflex 16#FC/udieresis 16#FD/yacute\r
+16#FE/thorn 16#FF/ydieresis ] def/reencdict 12 dict def/IsChar{basefontdict\r
+/CharStrings get exch known}bd/MapCh{dup IsChar not{pop/bullet}if\r
+newfont/Encoding get 3 1 roll put}bd/MapDegree{16#b0/degree IsChar{\r
+/degree}{/ring}ifelse MapCh}bd/MapBB{16#a6/brokenbar IsChar{/brokenbar}{\r
+/bar}ifelse MapCh}bd/ANSIFont{reencdict begin/newfontname ed/basefontname\r
+ed FontDirectory newfontname known not{/basefontdict basefontname findfont\r
+def/newfont basefontdict maxlength dict def basefontdict{exch dup/FID\r
+ne{dup/Encoding eq{exch dup length array copy newfont 3 1 roll put}{exch\r
+newfont 3 1 roll put}ifelse}{pop pop}ifelse}forall newfont/FontName\r
+newfontname put 127 1 159{newfont/Encoding get exch/bullet put}for\r
+ANSIVec aload pop ANSIVec length 2 idiv{MapCh}repeat MapDegree MapBB\r
+newfontname newfont definefont pop}if newfontname end}bd/SB{FC/ULlen\r
+ed/str ed str length fBE not{dup 1 gt{1 sub}if}if/cbStr ed/dxGdi ed\r
+/y0 ed/x0 ed str stringwidth dup 0 ne{/y1 ed/x1 ed y1 y1 mul x1 x1\r
+mul add sqrt dxGdi exch div 1 sub dup x1 mul cbStr div exch y1 mul\r
+cbStr div}{exch abs neg dxGdi add cbStr div exch}ifelse/dyExtra ed\r
+/dxExtra ed x0 y0 M fBE{dxBreak 0 BCh dxExtra dyExtra str awidthshow}{dxExtra\r
+dyExtra str ashow}ifelse fUL{x0 y0 M dxUL dyUL rmt ULlen fBE{Break\r
+add}if 0 mxUE transform gs rlt cyUL sl [] 0 setdash st gr}if fSO{x0\r
+y0 M dxSO dySO rmt ULlen fBE{Break add}if 0 mxUE transform gs rlt cyUL\r
+sl [] 0 setdash st gr}if n/fBE false def}bd/font{/name ed/Ascent ed\r
+0 ne/fT3 ed 0 ne/fSO ed 0 ne/fUL ed/Sy ed/Sx ed 10.0 div/ori ed -10.0\r
+div/esc ed/BCh ed name findfont/xAscent 0 def/yAscent Ascent def/ULesc\r
+esc def ULesc mxUE rotate pop fT3{/esc 0 def xAscent yAscent mxUE transform\r
+/yAscent ed/xAscent ed}if [Sx 0 0 Sy neg xAscent yAscent] esc mxE\r
+rotate mxF concatmatrix makefont setfont [Sx 0 0 Sy neg 0 Ascent] mxUE\r
+mxUF concatmatrix pop fUL{currentfont dup/FontInfo get/UnderlinePosition\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlinePosition get\r
+1000 div 0 exch mxUF transform/dyUL ed/dxUL ed}if fSO{0 .3 mxUF transform\r
+/dySO ed/dxSO ed}if fUL fSO or{currentfont dup/FontInfo get/UnderlineThickness\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlineThickness get\r
+1000 div Sy mul/cyUL ed}if}bd/min{2 copy gt{exch}if pop}bd/max{2 copy\r
+lt{exch}if pop}bd/CP{/ft ed{{ft 0 eq{clip}{eoclip}ifelse}stopped{currentflat\r
+1 add setflat}{exit}ifelse}loop}bd/patfont 10 dict def patfont begin\r
+/FontType 3 def/FontMatrix [1 0 0 -1 0 0] def/FontBBox [0 0 16 16]\r
+def/Encoding StandardEncoding def/BuildChar{pop pop 16 0 0 0 16 16\r
+setcachedevice 16 16 false [1 0 0 1 .25 .25]{pat}imagemask}bd end/p{\r
+/pat 32 string def{}forall 0 1 7{dup 2 mul pat exch 3 index put dup\r
+2 mul 1 add pat exch 3 index put dup 2 mul 16 add pat exch 3 index\r
+put 2 mul 17 add pat exch 2 index put pop}for}bd/pfill{/PatFont patfont\r
+definefont setfont/ch(AAAA)def X0 64 X1{Y1 -16 Y0{1 index exch M ch\r
+show}for pop}for}bd/vert{X0 w X1{dup Y0 M Y1 L st}for}bd/horz{Y0 w\r
+Y1{dup X0 exch M X1 exch L st}for}bd/fdiag{X0 w X1{Y0 M X1 X0 sub dup\r
+rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup rlt st}for}bd/bdiag{X0 w\r
+X1{Y1 M X1 X0 sub dup neg rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup\r
+neg rlt st}for}bd/AU{1 add cvi 15 or}bd/AD{1 sub cvi -16 and}bd/SHR{pathbbox\r
+AU/Y1 ed AU/X1 ed AD/Y0 ed AD/X0 ed}bd/hfill{/w iRes 37.5 div round\r
+def 0.1 sl [] 0 setdash n dup 0 eq{horz}if dup 1 eq{vert}if dup 2 eq{fdiag}if\r
+dup 3 eq{bdiag}if dup 4 eq{horz vert}if 5 eq{fdiag bdiag}if}bd/F{/ft\r
+ed fm 256 and 0 ne{gs FC ft 0 eq{fill}{eofill}ifelse gr}if fm 1536\r
+and 0 ne{SHR gs HC ft CP fm 1024 and 0 ne{/Tmp save def pfill Tmp restore}{fm\r
+15 and hfill}ifelse gr}if}bd/S{PenW sl PC st}bd/m matrix def/GW{iRes\r
+12 div PenW add cvi}bd/DoW{iRes 50 div PenW add cvi}bd/DW{iRes 8 div\r
+PenW add cvi}bd/SP{/PenW ed/iPen ed iPen 0 eq iPen 6 eq or{[] 0 setdash}if\r
+iPen 1 eq{[DW GW] 0 setdash}if iPen 2 eq{[DoW GW] 0 setdash}if iPen\r
+3 eq{[DW GW DoW GW] 0 setdash}if iPen 4 eq{[DW GW DoW GW DoW GW] 0\r
+setdash}if}bd/E{m cm pop tr scale 1 0 moveto 0 0 1 0 360 arc cp m sm}bd\r
+/AG{/sy ed/sx ed sx div 4 1 roll sy div 4 1 roll sx div 4 1 roll sy\r
+div 4 1 roll atan/a2 ed atan/a1 ed sx sy scale a1 a2 ARC}def/A{m cm\r
+pop tr AG m sm}def/P{m cm pop tr 0 0 M AG cp m sm}def/RRect{n 4 copy\r
+M 3 1 roll exch L 4 2 roll L L cp}bd/RRCC{/r ed/y1 ed/x1 ed/y0 ed/x0\r
+ed x0 x1 add 2 div y0 M x1 y0 x1 y1 r arcto 4{pop}repeat x1 y1 x0 y1\r
+r arcto 4{pop}repeat x0 y1 x0 y0 r arcto 4{pop}repeat x0 y0 x1 y0 r\r
+arcto 4{pop}repeat cp}bd/RR{2 copy 0 eq exch 0 eq or{pop pop RRect}{2\r
+copy eq{pop RRCC}{m cm pop/y2 ed/x2 ed/ys y2 x2 div 1 max def/xs x2\r
+y2 div 1 max def/y1 exch ys div def/x1 exch xs div def/y0 exch ys div\r
+def/x0 exch xs div def/r2 x2 y2 min def xs ys scale x0 x1 add 2 div\r
+y0 M x1 y0 x1 y1 r2 arcto 4{pop}repeat x1 y1 x0 y1 r2 arcto 4{pop}repeat\r
+x0 y1 x0 y0 r2 arcto 4{pop}repeat x0 y0 x1 y0 r2 arcto 4{pop}repeat\r
+m sm cp}ifelse}ifelse}bd/PP{{rlt}repeat}bd/OB{gs 0 ne{7 3 roll/y ed\r
+/x ed x y translate ULesc rotate x neg y neg translate x y 7 -3 roll}if\r
+sc B fill gr}bd/B{M/dy ed/dx ed dx 0 rlt 0 dy rlt dx neg 0 rlt cp}bd\r
+/CB{B clip n}bd/ErrHandler{errordict dup maxlength exch length gt\r
+dup{errordict begin}if/errhelpdict 12 dict def errhelpdict begin/stackunderflow(operand stack underflow)def\r
+/undefined(this name is not defined in a dictionary)def/VMerror(you have used up all the printer's memory)def\r
+/typecheck(operator was expecting a different type of operand)def\r
+/ioerror(input/output error occured)def end{end}if errordict begin\r
+/handleerror{$error begin newerror{/newerror false def showpage 72\r
+72 scale/x .25 def/y 9.6 def/Helvetica findfont .2 scalefont setfont\r
+x y moveto(Offending Command = )show/command load{dup type/stringtype\r
+ne{(max err string)cvs}if show}exec/y y .2 sub def x y moveto(Error = )show\r
+errorname{dup type dup( max err string )cvs show( : )show/stringtype\r
+ne{( max err string )cvs}if show}exec errordict begin errhelpdict errorname\r
+known{x 1 add y .2 sub moveto errhelpdict errorname get show}if end\r
+/y y .4 sub def x y moveto(Stack =)show ostack{/y y .2 sub def x 1\r
+add y moveto dup type/stringtype ne{( max err string )cvs}if show}forall\r
+showpage}if end}def end}bd end\r
+%%EndResource\r
+/SVDoc save def\r
+%%EndProlog\r
+%%BeginSetup\r
+Win35Dict begin\r
+ErrHandler\r
+statusdict begin 0 setjobtimeout end\r
+statusdict begin statusdict /jobname (Microsoft Word - COMPTBLE.DOC) put end\r
+/oldDictCnt countdictstack def {statusdict begin 0 setpapertray end\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+/oldDictCnt countdictstack def {letter\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+[{ }\r
+/exec load currenttransfer /exec load] cvx settransfer\r
+/setresolution where { pop 300 300 setresolution } if\r
+%%EndSetup\r
+%%Page: 1 1\r
+%%PageResources: (atend)\r
+SS\r
+0 0 16 16 820 1100 300 SM\r
+\r
+%%BeginResource: font MSTT31c1b9\r
+/GreNewFont{10 dict dup 3 1 roll def dup begin 6 1 roll/FontType 3\r
+def/FontMatrix exch def/FontBBox exch def/FontInfo 2 dict def FontInfo\r
+/UnderlinePosition 3 -1 roll put FontInfo/UnderlineThickness 3 -1\r
+roll put/Encoding 256 array def 0 1 255{Encoding exch/.notdef put}for\r
+/CharProcs 256 dict def CharProcs/.notdef{}put/Metrics 256 dict def\r
+Metrics/.notdef 3 -1 roll put/BuildChar{/char exch def/fontdict exch\r
+def/charname fontdict/Encoding get char get def fontdict/Metrics get\r
+charname get aload pop setcachedevice fontdict begin Encoding char\r
+get CharProcs exch get end exec}def end definefont pop}def/AddChar{begin\r
+Encoding 3 1 roll put CharProcs 3 1 roll put Metrics 3 1 roll put end}def\r
+/MSTT31c1b9 [54.0 0 0 0 0 0] 55 -108 [-54.0 -54.0 54.0 54.0] [1 54 div 0 0 1 54 div 0 0] /MSTT31c1b9 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 54 54 0 0 1 48 /MSTT31c1b9 font\r
+\r
+%%BeginResource: font MSTT31c1b9\r
+/G41 [38.0 0.0 0.0 0.0 38.0 37.0]\r
+/G41 {\r
+ 38 37 true [1 0 0 -1 0.0 37.0] {<000030000000003000000000380000000078000000007800000000fc00000000fc00000000fe0000\r
+0001be00000001bf000000031f000000031f000000071f800000060f800000060fc000000c07c000\r
+000c07c000001803e000001803e000001803f000003001f000003001f000006000f800007ffff800\r
+00fffffc0000c0007c0000c0007c000180003e000180003e000300003f000300001f000300001f80\r
+0600000f800e00000fc00e00000fc03f00001ff0ffe000fffc>} imagemask \r
+ }\r
+ 65 /G41 MSTT31c1b9 AddChar\r
+/G20 [14.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c1b9 AddChar\r
+/G73 [21.0 0.0 3.0 -1.0 19.0 25.0]\r
+/G73 {\r
+ 16 26 true [1 0 0 -1 -3.0 25.0] {<0fc41ffc387c701ce00ce00ce004f004f800fe007f007fe03ff00ffc03fe00fe007f001f801f800f\r
+c00fe00ef01efc3cfff88fe0>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c1b9 AddChar\r
+/G68 [27.0 0.0 0.0 0.0 27.0 38.0]\r
+/G68 {\r
+ 27 38 true [1 0 0 -1 0.0 38.0] {<038000000f8000007f800000ff8000000f8000000f8000000f8000000f8000000f8000000f800000\r
+0f8000000f8000000f8000000f81e0000f87f8000f9ffc000fb8fc000fe07c000fc03e000f803e00\r
+0f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e00\r
+0f803e000f803e000f803e000f803e000f803e000f803e001fc07f00fff9ffe0>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c1b9 AddChar\r
+/G6f [27.0 0.0 2.0 -1.0 25.0 25.0]\r
+/G6f {\r
+ 23 26 true [1 0 0 -1 -2.0 25.0] {<00fe0003ff800787e00e03f01c01f03c00f83c00fc78007c78007c78007ef8003ef8003ef8003ef8\r
+003ef8003ef8003efc003c7c003c7c003c7e00783e00781f00701f80e00fc1c003ff8000fe00>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c1b9 AddChar\r
+/G72 [18.0 0.0 0.0 0.0 18.0 25.0]\r
+/G72 {\r
+ 18 25 true [1 0 0 -1 0.0 25.0] {<0187800f8fc07f9fc0ffa7c00fe1800fc0000f80000f80000f80000f80000f80000f80000f80000f\r
+80000f80000f80000f80000f80000f80000f80000f80000f80000f80001fe000fff800>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c1b9 AddChar\r
+/G74 [15.0 0.0 0.0 -1.0 15.0 32.0]\r
+/G74 {\r
+ 15 33 true [1 0 0 -1 0.0 32.0] {<0080018001800380078007800f801f807ffefffe0f800f800f800f800f800f800f800f800f800f80\r
+0f800f800f800f800f800f800f800f800f820fc407fc07f801e0>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c1b9 AddChar\r
+/G63 [24.0 0.0 2.0 -1.0 22.0 25.0]\r
+/G63 {\r
+ 20 26 true [1 0 0 -1 -2.0 25.0] {<00fc0003ff000f0f801c07c01c03e03803e07803e07001c0700000f00000f00000f00000f00000f0\r
+0000f80000f80010f800307c00307e00607f00603f81c03fffc01fff800fff0007fe0001f800>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c1b9 AddChar\r
+/G6d [41.0 0.0 0.0 0.0 41.0 25.0]\r
+/G6d {\r
+ 41 25 true [1 0 0 -1 0.0 25.0] {<0381e00f80000f87f83fe0007f9ffc7ff000ffb0fce3f0000fe07f81f0000fc03f00f8000f803e00\r
+f8000f803e00f8000f803e00f8000f803e00f8000f803e00f8000f803e00f8000f803e00f8000f80\r
+3e00f8000f803e00f8000f803e00f8000f803e00f8000f803e00f8000f803e00f8000f803e00f800\r
+0f803e00f8000f803e00f8000f803e00f8001fc07f01fc00fff9ffe7ff80>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c1b9 AddChar\r
+/G70 [27.0 0.0 0.0 -12.0 25.0 25.0]\r
+/G70 {\r
+ 25 37 true [1 0 0 -1 0.0 25.0] {<0183e0000f8ff8007f9ffc00ffb0fe000fe07e000fc03f000f801f000f801f000f801f800f800f80\r
+0f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f000f800f000f801f00\r
+0f801e000fc03c000fe03c000ff0f8000fbff0000f8fc0000f8000000f8000000f8000000f800000\r
+0f8000000f8000000f8000000f8000000f8000001fc00000fff80000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c1b9 AddChar\r
+/G61 [24.0 0.0 2.0 -1.0 24.0 25.0]\r
+/G61 {\r
+ 22 26 true [1 0 0 -1 -2.0 25.0] {<03fc000fff001e1f803c0f807c07c07c07c07c07c07c07c03807c0000fc0007fc001f7c007c7c00f\r
+07c03e07c07c07c07807c0f807c0f807c0f807c0f807c0fc0fc47e37cc7fe7f83fc7f01f03c0>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c1b9 AddChar\r
+/G69 [15.0 0.0 1.0 0.0 14.0 38.0]\r
+/G69 {\r
+ 13 38 true [1 0 0 -1 -1.0 38.0] {<07000f800f800f8007000000000000000000000000000000000003800f807f80ff800f800f800f80\r
+0f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f801fc0fff8>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c1b9 AddChar\r
+/G6e [27.0 0.0 0.0 0.0 27.0 25.0]\r
+/G6e {\r
+ 27 25 true [1 0 0 -1 0.0 25.0] {<0381e0000f87f8007f9ffc00ffb8fc000fe07c000fc03e000f803e000f803e000f803e000f803e00\r
+0f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e00\r
+0f803e000f803e000f803e001fc07f00fff9ffe0>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c1b9 AddChar\r
+/G66 [18.0 0.0 1.0 0.0 23.0 38.0]\r
+/G66 {\r
+ 22 38 true [1 0 0 -1 -1.0 38.0] {<000fc0003ff00071f800e0fc01c07c03c03c03c01803c00007c00007c00007c00007c00007c00007\r
+c000ffff00ffff0007c00007c00007c00007c00007c00007c00007c00007c00007c00007c00007c0\r
+0007c00007c00007c00007c00007c00007c00007c00007c0000fe0001ff000ffff00>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c1b9 AddChar\r
+/G62 [27.0 0.0 0.0 -1.0 25.0 38.0]\r
+/G62 {\r
+ 25 39 true [1 0 0 -1 0.0 38.0] {<038000000f8000007f800000ff8000000f8000000f8000000f8000000f8000000f8000000f800000\r
+0f8000000f8000000f8000000f83e0000f8ff8000f9ffc000fb0fe000fc07e000f803f000f801f00\r
+0f801f000f801f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f00\r
+0f800f000f801f000f801e000f801e000f803c000fc0780007f0f00001ffc000007f0000>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c1b9 AddChar\r
+/G6a [15.0 0.0 -5.0 -12.0 11.0 38.0]\r
+/G6a {\r
+ 16 50 true [1 0 0 -1 5.0 38.0] {<000e001f001f001f000e000000000000000000000000000000000007001f00ff01ff001f001f001f\r
+001f001f001f001f001f001f001f001f001f001f001f001f001f001f001f001f001f001f001f001f\r
+001f001f001e001e001e781cfc38fe307fe03f80>} imagemask \r
+ }\r
+ 106 /G6a MSTT31c1b9 AddChar\r
+/G65 [24.0 0.0 2.0 -1.0 22.0 25.0]\r
+/G65 {\r
+ 20 26 true [1 0 0 -1 -2.0 25.0] {<00fc0007ff000f0f801c07c03803e03801e07001f07001f07ffff0fffff0f00000f00000f00000f0\r
+0000f80000f80000f80000fc00107c00307e00203f00603fe3c01fffc00fff8007ff0001f800>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c1b9 AddChar\r
+/G2d [18.0 0.0 2.0 10.0 16.0 15.0]\r
+/G2d {\r
+ 14 5 true [1 0 0 -1 -2.0 15.0] {<fffcfffcfffcfffcfffc>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c1b9 AddChar\r
+/G64 [27.0 0.0 2.0 -1.0 27.0 38.0]\r
+/G64 {\r
+ 25 39 true [1 0 0 -1 -2.0 38.0] {<000038000000f8000007f800000ff8000000f8000000f8000000f8000000f8000000f8000000f800\r
+0000f8000000f8000000f80000f8f80003fef8000787f8000f03f8001e01f8003c01f8003c00f800\r
+7c00f8007800f8007800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800\r
+fc00f8007c00f8007e00f8007e00f8003f01f8001fc7ff800ffeff0007fcf80001f0e000>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c1b9 AddChar\r
+/G6c [15.0 0.0 1.0 0.0 14.0 38.0]\r
+/G6c {\r
+ 13 38 true [1 0 0 -1 -1.0 38.0] {<03800f807f80ff800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f80\r
+0f800f800f800f800f800f800f800f800f800f800f800f800f800f800f800f801fc0fff8>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c1b9 AddChar\r
+/G67 [26.0 0.0 1.0 -12.0 25.0 25.0]\r
+/G67 {\r
+ 24 37 true [1 0 0 -1 -1.0 25.0] {<00fe000387800703ff0f01ff1e01f01e00f03e00f83e00f83e00f83e00f83e00f83e00f81f00f01f\r
+01e00f81e007c38003fe000600000c00001c00003e00003ffff03ffffc1ffffe07ffff0c000f1800\r
+03380003300003700002f00006f8000cfc001c7f00783fffe00fffc003fe00>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c1b9 AddChar\r
+/G75 [27.0 0.0 0.0 -1.0 27.0 24.0]\r
+/G75 {\r
+ 27 25 true [1 0 0 -1 0.0 24.0] {<ff83fe001f807e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e00\r
+0f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f803e000f807e00\r
+0fc0fe0007e3bfe007ff3fc003fc3e0000f03800>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c1b9 AddChar\r
+%%EndResource\r
+\r
+0 0 0 fC\r
+327 200 1053 (A short comparison of object-oriented languages) 1053 SB\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 82 307 286 CB\r
+327 305 501 ( Languages ) 501 SB\r
+gr\r
+32 0 0 58 58 0 0 0 59 /Symbol font\r
+gs 580 82 307 286 CB\r
+829 292 58 (\256) 58 SB\r
+gr\r
+gs 580 82 307 286 CB\r
+828 292 58 (\256) 58 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 66 307 482 CB\r
+327 488 325 ( Comparison) 325 SB\r
+gr\r
+gs 660 71 307 542 CB\r
+327 553 412 ( of main features ) 412 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 462 71 307 542 CB\r
+739 548 30 (\257) 30 SB\r
+gr\r
+32 0 0 50 50 0 0 0 41 /Courier-Bold /font9 ANSIFont font\r
+gs 112 62 973 286 CB\r
+1013 292 30 (S) 30 SB\r
+gr\r
+gs 112 62 973 342 CB\r
+1013 348 30 (i) 30 SB\r
+gr\r
+gs 112 62 973 398 CB\r
+1013 404 30 (m) 30 SB\r
+gr\r
+gs 112 62 973 454 CB\r
+1013 460 30 (u) 30 SB\r
+gr\r
+gs 112 62 973 510 CB\r
+1013 516 30 (l) 30 SB\r
+gr\r
+gs 112 62 973 566 CB\r
+1013 572 30 (a) 30 SB\r
+gr\r
+gs 112 62 973 622 CB\r
+1013 628 30 (-) 30 SB\r
+gr\r
+gs 112 62 973 678 CB\r
+1013 684 30 (6) 30 SB\r
+gr\r
+gs 112 62 973 734 CB\r
+1013 740 30 (7) 30 SB\r
+gr\r
+gs 112 62 1091 286 CB\r
+1131 292 30 (o) 30 SB\r
+gr\r
+gs 112 62 1091 342 CB\r
+1131 348 30 (b) 30 SB\r
+gr\r
+gs 112 62 1091 398 CB\r
+1131 404 30 (j) 30 SB\r
+gr\r
+gs 112 62 1091 454 CB\r
+1131 460 30 (.) 30 SB\r
+gr\r
+gs 112 62 1091 510 CB\r
+1131 516 30 (P) 30 SB\r
+gr\r
+gs 112 62 1091 566 CB\r
+1131 572 30 (a) 30 SB\r
+gr\r
+gs 112 62 1091 622 CB\r
+1131 628 30 (s) 30 SB\r
+gr\r
+gs 112 62 1091 678 CB\r
+1131 684 30 (c) 30 SB\r
+gr\r
+gs 112 62 1091 734 CB\r
+1131 740 30 (a) 30 SB\r
+gr\r
+gs 112 62 1091 790 CB\r
+1131 796 30 (l) 30 SB\r
+gr\r
+gs 112 62 1091 846 CB\r
+1131 852 30 (s) 30 SB\r
+gr\r
+gs 112 62 1209 286 CB\r
+1249 292 30 (C) 30 SB\r
+gr\r
+gs 112 62 1209 342 CB\r
+1249 348 30 (+) 30 SB\r
+gr\r
+gs 112 62 1209 398 CB\r
+1249 404 30 (+) 30 SB\r
+gr\r
+gs 112 62 1327 286 CB\r
+1368 292 30 (M) 30 SB\r
+gr\r
+gs 112 62 1327 342 CB\r
+1368 348 30 (o) 30 SB\r
+gr\r
+gs 112 62 1327 398 CB\r
+1368 404 30 (d) 30 SB\r
+gr\r
+gs 112 62 1327 454 CB\r
+1368 460 30 (u) 30 SB\r
+gr\r
+gs 112 62 1327 510 CB\r
+1368 516 30 (l) 30 SB\r
+gr\r
+gs 112 62 1327 566 CB\r
+1368 572 30 (a) 30 SB\r
+gr\r
+gs 112 62 1327 622 CB\r
+1368 628 30 (3) 30 SB\r
+gr\r
+gs 112 62 1445 286 CB\r
+1486 292 30 (S) 30 SB\r
+gr\r
+gs 112 62 1445 342 CB\r
+1486 348 30 (m) 30 SB\r
+gr\r
+gs 112 62 1445 398 CB\r
+1486 404 30 (a) 30 SB\r
+gr\r
+gs 112 62 1445 454 CB\r
+1486 460 30 (l) 30 SB\r
+gr\r
+gs 112 62 1445 510 CB\r
+1486 516 30 (l) 30 SB\r
+gr\r
+gs 112 62 1445 566 CB\r
+1486 572 30 (t) 30 SB\r
+gr\r
+gs 112 62 1445 622 CB\r
+1486 628 30 (a) 30 SB\r
+gr\r
+gs 112 62 1445 678 CB\r
+1486 684 30 (l) 30 SB\r
+gr\r
+gs 112 62 1445 734 CB\r
+1486 740 30 (k) 30 SB\r
+gr\r
+gs 112 62 1563 286 CB\r
+1604 292 30 (E) 30 SB\r
+gr\r
+gs 112 62 1563 342 CB\r
+1604 348 30 (i) 30 SB\r
+gr\r
+gs 112 62 1563 398 CB\r
+1604 404 30 (f) 30 SB\r
+gr\r
+gs 112 62 1563 454 CB\r
+1604 460 30 (f) 30 SB\r
+gr\r
+gs 112 62 1563 510 CB\r
+1604 516 30 (e) 30 SB\r
+gr\r
+gs 112 62 1563 566 CB\r
+1604 572 30 (l) 30 SB\r
+gr\r
+gs 112 62 1681 286 CB\r
+1722 292 30 (A) 30 SB\r
+gr\r
+gs 112 62 1681 342 CB\r
+1722 348 30 (d) 30 SB\r
+gr\r
+gs 112 62 1681 398 CB\r
+1722 404 30 (a) 30 SB\r
+gr\r
+gs 113 62 1799 286 CB\r
+1840 292 30 (B) 30 SB\r
+gr\r
+gs 113 62 1799 342 CB\r
+1840 348 30 (e) 30 SB\r
+gr\r
+gs 113 62 1799 398 CB\r
+1840 404 30 (t) 30 SB\r
+gr\r
+gs 113 62 1799 454 CB\r
+1840 460 30 (a) 30 SB\r
+gr\r
+gs 112 62 1918 286 CB\r
+1958 292 30 (L) 30 SB\r
+gr\r
+gs 112 62 1918 342 CB\r
+1958 348 30 (o) 30 SB\r
+gr\r
+gs 112 62 1918 398 CB\r
+1958 404 30 (g) 30 SB\r
+gr\r
+gs 112 62 1918 454 CB\r
+1958 460 30 (l) 30 SB\r
+gr\r
+gs 112 62 1918 510 CB\r
+1958 516 30 (a) 30 SB\r
+gr\r
+gs 112 62 1918 566 CB\r
+1958 572 30 (n) 30 SB\r
+gr\r
+gs 112 62 1918 622 CB\r
+1958 628 30 (') 30 SB\r
+gr\r
+gs 112 62 1918 678 CB\r
+1958 684 30 (8) 30 SB\r
+gr\r
+gs 112 62 1918 734 CB\r
+1958 740 30 (2) 30 SB\r
+gr\r
+0 0 0 fC\r
+/fm 256 def\r
+5 5 301 286 B\r
+1 F\r
+n\r
+5 5 301 286 B\r
+1 F\r
+n\r
+659 5 307 286 B\r
+1 F\r
+n\r
+5 5 967 286 B\r
+1 F\r
+n\r
+111 5 973 286 B\r
+1 F\r
+n\r
+5 5 1085 286 B\r
+1 F\r
+n\r
+111 5 1091 286 B\r
+1 F\r
+n\r
+5 5 1203 286 B\r
+1 F\r
+n\r
+111 5 1209 286 B\r
+1 F\r
+n\r
+5 5 1321 286 B\r
+1 F\r
+n\r
+111 5 1327 286 B\r
+1 F\r
+n\r
+5 5 1439 286 B\r
+1 F\r
+n\r
+111 5 1445 286 B\r
+1 F\r
+n\r
+5 5 1557 286 B\r
+1 F\r
+n\r
+111 5 1563 286 B\r
+1 F\r
+n\r
+5 5 1675 286 B\r
+1 F\r
+n\r
+111 5 1681 286 B\r
+1 F\r
+n\r
+5 5 1793 286 B\r
+1 F\r
+n\r
+112 5 1799 286 B\r
+1 F\r
+n\r
+5 5 1912 286 B\r
+1 F\r
+n\r
+111 5 1918 286 B\r
+1 F\r
+n\r
+5 5 2030 286 B\r
+1 F\r
+n\r
+5 5 2030 286 B\r
+1 F\r
+n\r
+5 615 301 292 B\r
+1 F\r
+n\r
+5 615 967 292 B\r
+1 F\r
+n\r
+5 615 1085 292 B\r
+1 F\r
+n\r
+5 615 1203 292 B\r
+1 F\r
+n\r
+5 615 1321 292 B\r
+1 F\r
+n\r
+5 615 1439 292 B\r
+1 F\r
+n\r
+5 615 1557 292 B\r
+1 F\r
+n\r
+5 615 1675 292 B\r
+1 F\r
+n\r
+5 615 1793 292 B\r
+1 F\r
+n\r
+5 615 1912 292 B\r
+1 F\r
+n\r
+5 615 2030 292 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 908 CB\r
+327 914 358 (Modularisation) 358 SB\r
+gr\r
+5 5 301 908 B\r
+1 F\r
+n\r
+659 5 307 908 B\r
+1 F\r
+n\r
+5 5 967 908 B\r
+1 F\r
+n\r
+111 5 973 908 B\r
+1 F\r
+n\r
+5 5 1085 908 B\r
+1 F\r
+n\r
+111 5 1091 908 B\r
+1 F\r
+n\r
+5 5 1203 908 B\r
+1 F\r
+n\r
+111 5 1209 908 B\r
+1 F\r
+n\r
+5 5 1321 908 B\r
+1 F\r
+n\r
+111 5 1327 908 B\r
+1 F\r
+n\r
+5 5 1439 908 B\r
+1 F\r
+n\r
+111 5 1445 908 B\r
+1 F\r
+n\r
+5 5 1557 908 B\r
+1 F\r
+n\r
+111 5 1563 908 B\r
+1 F\r
+n\r
+5 5 1675 908 B\r
+1 F\r
+n\r
+111 5 1681 908 B\r
+1 F\r
+n\r
+5 5 1793 908 B\r
+1 F\r
+n\r
+112 5 1799 908 B\r
+1 F\r
+n\r
+5 5 1912 908 B\r
+1 F\r
+n\r
+111 5 1918 908 B\r
+1 F\r
+n\r
+5 5 2030 908 B\r
+1 F\r
+n\r
+5 61 301 914 B\r
+1 F\r
+n\r
+5 61 967 914 B\r
+1 F\r
+n\r
+5 61 1085 914 B\r
+1 F\r
+n\r
+5 61 1203 914 B\r
+1 F\r
+n\r
+5 61 1321 914 B\r
+1 F\r
+n\r
+5 61 1439 914 B\r
+1 F\r
+n\r
+5 61 1557 914 B\r
+1 F\r
+n\r
+5 61 1675 914 B\r
+1 F\r
+n\r
+5 61 1793 914 B\r
+1 F\r
+n\r
+5 61 1912 914 B\r
+1 F\r
+n\r
+5 61 2030 914 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 66 307 976 CB\r
+327 982 463 ( nesting of modules) 463 SB\r
+gr\r
+gs 112 66 973 976 CB\r
+992 982 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 976 CB\r
+1110 982 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1209 976 CB\r
+1228 982 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 976 CB\r
+1346 982 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 976 CB\r
+1465 982 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 976 CB\r
+1583 982 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 976 CB\r
+1701 982 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 976 CB\r
+1819 982 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 976 CB\r
+1937 982 43 ( +) 43 SB\r
+gr\r
+5 5 301 976 B\r
+1 F\r
+n\r
+659 5 307 976 B\r
+1 F\r
+n\r
+5 5 967 976 B\r
+1 F\r
+n\r
+111 5 973 976 B\r
+1 F\r
+n\r
+5 5 1085 976 B\r
+1 F\r
+n\r
+111 5 1091 976 B\r
+1 F\r
+n\r
+5 5 1203 976 B\r
+1 F\r
+n\r
+111 5 1209 976 B\r
+1 F\r
+n\r
+5 5 1321 976 B\r
+1 F\r
+n\r
+111 5 1327 976 B\r
+1 F\r
+n\r
+5 5 1439 976 B\r
+1 F\r
+n\r
+111 5 1445 976 B\r
+1 F\r
+n\r
+5 5 1557 976 B\r
+1 F\r
+n\r
+111 5 1563 976 B\r
+1 F\r
+n\r
+5 5 1675 976 B\r
+1 F\r
+n\r
+111 5 1681 976 B\r
+1 F\r
+n\r
+5 5 1793 976 B\r
+1 F\r
+n\r
+112 5 1799 976 B\r
+1 F\r
+n\r
+5 5 1912 976 B\r
+1 F\r
+n\r
+111 5 1918 976 B\r
+1 F\r
+n\r
+5 5 2030 976 B\r
+1 F\r
+n\r
+5 59 301 982 B\r
+1 F\r
+n\r
+5 59 967 982 B\r
+1 F\r
+n\r
+5 59 1085 982 B\r
+1 F\r
+n\r
+5 59 1203 982 B\r
+1 F\r
+n\r
+5 59 1321 982 B\r
+1 F\r
+n\r
+5 59 1439 982 B\r
+1 F\r
+n\r
+5 59 1557 982 B\r
+1 F\r
+n\r
+5 59 1675 982 B\r
+1 F\r
+n\r
+5 59 1793 982 B\r
+1 F\r
+n\r
+5 59 1912 982 B\r
+1 F\r
+n\r
+5 59 2030 982 B\r
+1 F\r
+n\r
+gs 660 66 307 1042 CB\r
+327 1048 287 ( inheritance) 287 SB\r
+gr\r
+gs 112 66 973 1042 CB\r
+992 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 1042 CB\r
+1110 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1209 1042 CB\r
+1228 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1327 1042 CB\r
+1346 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 1042 CB\r
+1465 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1563 1042 CB\r
+1583 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1681 1042 CB\r
+1701 1048 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1042 CB\r
+1819 1048 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1042 CB\r
+1937 1048 43 ( +) 43 SB\r
+gr\r
+5 5 301 1042 B\r
+1 F\r
+n\r
+659 5 307 1042 B\r
+1 F\r
+n\r
+5 5 967 1042 B\r
+1 F\r
+n\r
+111 5 973 1042 B\r
+1 F\r
+n\r
+5 5 1085 1042 B\r
+1 F\r
+n\r
+111 5 1091 1042 B\r
+1 F\r
+n\r
+5 5 1203 1042 B\r
+1 F\r
+n\r
+111 5 1209 1042 B\r
+1 F\r
+n\r
+5 5 1321 1042 B\r
+1 F\r
+n\r
+111 5 1327 1042 B\r
+1 F\r
+n\r
+5 5 1439 1042 B\r
+1 F\r
+n\r
+111 5 1445 1042 B\r
+1 F\r
+n\r
+5 5 1557 1042 B\r
+1 F\r
+n\r
+111 5 1563 1042 B\r
+1 F\r
+n\r
+5 5 1675 1042 B\r
+1 F\r
+n\r
+111 5 1681 1042 B\r
+1 F\r
+n\r
+5 5 1793 1042 B\r
+1 F\r
+n\r
+112 5 1799 1042 B\r
+1 F\r
+n\r
+5 5 1912 1042 B\r
+1 F\r
+n\r
+111 5 1918 1042 B\r
+1 F\r
+n\r
+5 5 2030 1042 B\r
+1 F\r
+n\r
+5 59 301 1048 B\r
+1 F\r
+n\r
+5 59 967 1048 B\r
+1 F\r
+n\r
+5 59 1085 1048 B\r
+1 F\r
+n\r
+5 59 1203 1048 B\r
+1 F\r
+n\r
+5 59 1321 1048 B\r
+1 F\r
+n\r
+5 59 1439 1048 B\r
+1 F\r
+n\r
+5 59 1557 1048 B\r
+1 F\r
+n\r
+5 59 1675 1048 B\r
+1 F\r
+n\r
+5 59 1793 1048 B\r
+1 F\r
+n\r
+5 59 1912 1048 B\r
+1 F\r
+n\r
+5 59 2030 1048 B\r
+1 F\r
+n\r
+gs 660 66 307 1108 CB\r
+327 1114 595 ( - multilevel inheritance) 595 SB\r
+gr\r
+gs 112 66 973 1108 CB\r
+992 1114 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 1108 CB\r
+1110 1114 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1108 CB\r
+1228 1114 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1108 CB\r
+1346 1114 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 1108 CB\r
+1465 1114 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1108 CB\r
+1583 1114 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1108 CB\r
+1701 1114 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1108 CB\r
+1819 1114 65 ( +?) 65 SB\r
+gr\r
+gs 112 66 1918 1108 CB\r
+1937 1114 43 ( +) 43 SB\r
+gr\r
+5 5 301 1108 B\r
+1 F\r
+n\r
+659 5 307 1108 B\r
+1 F\r
+n\r
+5 5 967 1108 B\r
+1 F\r
+n\r
+111 5 973 1108 B\r
+1 F\r
+n\r
+5 5 1085 1108 B\r
+1 F\r
+n\r
+111 5 1091 1108 B\r
+1 F\r
+n\r
+5 5 1203 1108 B\r
+1 F\r
+n\r
+111 5 1209 1108 B\r
+1 F\r
+n\r
+5 5 1321 1108 B\r
+1 F\r
+n\r
+111 5 1327 1108 B\r
+1 F\r
+n\r
+5 5 1439 1108 B\r
+1 F\r
+n\r
+111 5 1445 1108 B\r
+1 F\r
+n\r
+5 5 1557 1108 B\r
+1 F\r
+n\r
+111 5 1563 1108 B\r
+1 F\r
+n\r
+5 5 1675 1108 B\r
+1 F\r
+n\r
+111 5 1681 1108 B\r
+1 F\r
+n\r
+5 5 1793 1108 B\r
+1 F\r
+n\r
+112 5 1799 1108 B\r
+1 F\r
+n\r
+5 5 1912 1108 B\r
+1 F\r
+n\r
+111 5 1918 1108 B\r
+1 F\r
+n\r
+5 5 2030 1108 B\r
+1 F\r
+n\r
+5 59 301 1114 B\r
+1 F\r
+n\r
+5 59 967 1114 B\r
+1 F\r
+n\r
+5 59 1085 1114 B\r
+1 F\r
+n\r
+5 59 1203 1114 B\r
+1 F\r
+n\r
+5 59 1321 1114 B\r
+1 F\r
+n\r
+5 59 1439 1114 B\r
+1 F\r
+n\r
+5 59 1557 1114 B\r
+1 F\r
+n\r
+5 59 1675 1114 B\r
+1 F\r
+n\r
+5 59 1793 1114 B\r
+1 F\r
+n\r
+5 59 1912 1114 B\r
+1 F\r
+n\r
+5 59 2030 1114 B\r
+1 F\r
+n\r
+gs 660 66 307 1174 CB\r
+327 1180 558 ( - multiple inheritance) 558 SB\r
+gr\r
+gs 112 66 973 1174 CB\r
+992 1180 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 1174 CB\r
+1110 1180 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1174 CB\r
+1228 1180 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1327 1174 CB\r
+1346 1180 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 1174 CB\r
+1465 1180 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1563 1174 CB\r
+1583 1180 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1681 1174 CB\r
+1701 1180 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1174 CB\r
+1819 1180 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1918 1174 CB\r
+1937 1180 43 ( +) 43 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c1d2\r
+/MSTT31c1d2 [33.0 0 0 0 0 0] 60 -120 [-33.0 -33.0 33.0 33.0] [1 33 div 0 0 1 33 div 0 0] /MSTT31c1d2 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 33 33 0 0 1 29 /MSTT31c1d2 font\r
+\r
+%%BeginResource: font MSTT31c1d2\r
+/G31 [17.0 0.0 4.0 0.0 13.0 22.0]\r
+/G31 {\r
+ 9 22 true [1 0 0 -1 -4.0 22.0] {<0c007c00fc001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c00\r
+1c00ff80>} imagemask \r
+ }\r
+ 49 /G31 MSTT31c1d2 AddChar\r
+%%EndResource\r
+\r
+gs 112 66 1918 1174 CB\r
+1980 1184 17 (1) 17 SB\r
+gr\r
+5 5 301 1174 B\r
+1 F\r
+n\r
+659 5 307 1174 B\r
+1 F\r
+n\r
+5 5 967 1174 B\r
+1 F\r
+n\r
+111 5 973 1174 B\r
+1 F\r
+n\r
+5 5 1085 1174 B\r
+1 F\r
+n\r
+111 5 1091 1174 B\r
+1 F\r
+n\r
+5 5 1203 1174 B\r
+1 F\r
+n\r
+111 5 1209 1174 B\r
+1 F\r
+n\r
+5 5 1321 1174 B\r
+1 F\r
+n\r
+111 5 1327 1174 B\r
+1 F\r
+n\r
+5 5 1439 1174 B\r
+1 F\r
+n\r
+111 5 1445 1174 B\r
+1 F\r
+n\r
+5 5 1557 1174 B\r
+1 F\r
+n\r
+111 5 1563 1174 B\r
+1 F\r
+n\r
+5 5 1675 1174 B\r
+1 F\r
+n\r
+111 5 1681 1174 B\r
+1 F\r
+n\r
+5 5 1793 1174 B\r
+1 F\r
+n\r
+112 5 1799 1174 B\r
+1 F\r
+n\r
+5 5 1912 1174 B\r
+1 F\r
+n\r
+111 5 1918 1174 B\r
+1 F\r
+n\r
+5 5 2030 1174 B\r
+1 F\r
+n\r
+5 59 301 1180 B\r
+1 F\r
+n\r
+5 59 967 1180 B\r
+1 F\r
+n\r
+5 59 1085 1180 B\r
+1 F\r
+n\r
+5 59 1203 1180 B\r
+1 F\r
+n\r
+5 59 1321 1180 B\r
+1 F\r
+n\r
+5 59 1439 1180 B\r
+1 F\r
+n\r
+5 59 1557 1180 B\r
+1 F\r
+n\r
+5 59 1675 1180 B\r
+1 F\r
+n\r
+5 59 1793 1180 B\r
+1 F\r
+n\r
+5 59 1912 1180 B\r
+1 F\r
+n\r
+5 59 2030 1180 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 66 307 1240 CB\r
+327 1246 591 ( inherit in other modules) 591 SB\r
+gr\r
+32 0 0 33 33 0 0 1 29 /MSTT31c1d2 font\r
+\r
+%%BeginResource: font MSTT31c1d2\r
+/G32 [17.0 0.0 1.0 0.0 15.0 22.0]\r
+/G32 {\r
+ 14 22 true [1 0 0 -1 -1.0 22.0] {<0f801fe03ff060f84078803880380038003000300060006000c001800180030006000c04180c3ff8\r
+7ff8fff8>} imagemask \r
+ }\r
+ 50 /G32 MSTT31c1d2 AddChar\r
+%%EndResource\r
+\r
+gs 660 66 307 1240 CB\r
+918 1250 17 (2) 17 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 112 66 973 1240 CB\r
+992 1246 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 1240 CB\r
+1110 1246 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1240 CB\r
+1228 1246 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1240 CB\r
+1346 1246 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 1240 CB\r
+1465 1246 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1240 CB\r
+1583 1246 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1240 CB\r
+1701 1246 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1240 CB\r
+1819 1246 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1240 CB\r
+1937 1246 43 ( +) 43 SB\r
+gr\r
+5 5 301 1240 B\r
+1 F\r
+n\r
+659 5 307 1240 B\r
+1 F\r
+n\r
+5 5 967 1240 B\r
+1 F\r
+n\r
+111 5 973 1240 B\r
+1 F\r
+n\r
+5 5 1085 1240 B\r
+1 F\r
+n\r
+111 5 1091 1240 B\r
+1 F\r
+n\r
+5 5 1203 1240 B\r
+1 F\r
+n\r
+111 5 1209 1240 B\r
+1 F\r
+n\r
+5 5 1321 1240 B\r
+1 F\r
+n\r
+111 5 1327 1240 B\r
+1 F\r
+n\r
+5 5 1439 1240 B\r
+1 F\r
+n\r
+111 5 1445 1240 B\r
+1 F\r
+n\r
+5 5 1557 1240 B\r
+1 F\r
+n\r
+111 5 1563 1240 B\r
+1 F\r
+n\r
+5 5 1675 1240 B\r
+1 F\r
+n\r
+111 5 1681 1240 B\r
+1 F\r
+n\r
+5 5 1793 1240 B\r
+1 F\r
+n\r
+112 5 1799 1240 B\r
+1 F\r
+n\r
+5 5 1912 1240 B\r
+1 F\r
+n\r
+111 5 1918 1240 B\r
+1 F\r
+n\r
+5 5 2030 1240 B\r
+1 F\r
+n\r
+5 59 301 1246 B\r
+1 F\r
+n\r
+5 59 967 1246 B\r
+1 F\r
+n\r
+5 59 1085 1246 B\r
+1 F\r
+n\r
+5 59 1203 1246 B\r
+1 F\r
+n\r
+5 59 1321 1246 B\r
+1 F\r
+n\r
+5 59 1439 1246 B\r
+1 F\r
+n\r
+5 59 1557 1246 B\r
+1 F\r
+n\r
+5 59 1675 1246 B\r
+1 F\r
+n\r
+5 59 1793 1246 B\r
+1 F\r
+n\r
+5 59 1912 1246 B\r
+1 F\r
+n\r
+5 59 2030 1246 B\r
+1 F\r
+n\r
+gs 660 66 307 1306 CB\r
+327 1312 555 ( static binding of names) 555 SB\r
+gr\r
+gs 112 66 973 1306 CB\r
+992 1312 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 1306 CB\r
+1110 1312 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1209 1306 CB\r
+1228 1312 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1306 CB\r
+1346 1312 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 1306 CB\r
+1465 1312 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1306 CB\r
+1583 1312 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1306 CB\r
+1701 1312 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 1306 CB\r
+1819 1312 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1306 CB\r
+1937 1312 43 ( +) 43 SB\r
+gr\r
+5 5 301 1306 B\r
+1 F\r
+n\r
+659 5 307 1306 B\r
+1 F\r
+n\r
+5 5 967 1306 B\r
+1 F\r
+n\r
+111 5 973 1306 B\r
+1 F\r
+n\r
+5 5 1085 1306 B\r
+1 F\r
+n\r
+111 5 1091 1306 B\r
+1 F\r
+n\r
+5 5 1203 1306 B\r
+1 F\r
+n\r
+111 5 1209 1306 B\r
+1 F\r
+n\r
+5 5 1321 1306 B\r
+1 F\r
+n\r
+111 5 1327 1306 B\r
+1 F\r
+n\r
+5 5 1439 1306 B\r
+1 F\r
+n\r
+111 5 1445 1306 B\r
+1 F\r
+n\r
+5 5 1557 1306 B\r
+1 F\r
+n\r
+111 5 1563 1306 B\r
+1 F\r
+n\r
+5 5 1675 1306 B\r
+1 F\r
+n\r
+111 5 1681 1306 B\r
+1 F\r
+n\r
+5 5 1793 1306 B\r
+1 F\r
+n\r
+112 5 1799 1306 B\r
+1 F\r
+n\r
+5 5 1912 1306 B\r
+1 F\r
+n\r
+111 5 1918 1306 B\r
+1 F\r
+n\r
+5 5 2030 1306 B\r
+1 F\r
+n\r
+5 59 301 1312 B\r
+1 F\r
+n\r
+5 59 967 1312 B\r
+1 F\r
+n\r
+5 59 1085 1312 B\r
+1 F\r
+n\r
+5 59 1203 1312 B\r
+1 F\r
+n\r
+5 59 1321 1312 B\r
+1 F\r
+n\r
+5 59 1439 1312 B\r
+1 F\r
+n\r
+5 59 1557 1312 B\r
+1 F\r
+n\r
+5 59 1675 1312 B\r
+1 F\r
+n\r
+5 59 1793 1312 B\r
+1 F\r
+n\r
+5 59 1912 1312 B\r
+1 F\r
+n\r
+5 59 2030 1312 B\r
+1 F\r
+n\r
+5 5 301 1372 B\r
+1 F\r
+n\r
+659 5 307 1372 B\r
+1 F\r
+n\r
+5 5 967 1372 B\r
+1 F\r
+n\r
+111 5 973 1372 B\r
+1 F\r
+n\r
+5 5 1085 1372 B\r
+1 F\r
+n\r
+111 5 1091 1372 B\r
+1 F\r
+n\r
+5 5 1203 1372 B\r
+1 F\r
+n\r
+111 5 1209 1372 B\r
+1 F\r
+n\r
+5 5 1321 1372 B\r
+1 F\r
+n\r
+111 5 1327 1372 B\r
+1 F\r
+n\r
+5 5 1439 1372 B\r
+1 F\r
+n\r
+111 5 1445 1372 B\r
+1 F\r
+n\r
+5 5 1557 1372 B\r
+1 F\r
+n\r
+111 5 1563 1372 B\r
+1 F\r
+n\r
+5 5 1675 1372 B\r
+1 F\r
+n\r
+111 5 1681 1372 B\r
+1 F\r
+n\r
+5 5 1793 1372 B\r
+1 F\r
+n\r
+112 5 1799 1372 B\r
+1 F\r
+n\r
+5 5 1912 1372 B\r
+1 F\r
+n\r
+111 5 1918 1372 B\r
+1 F\r
+n\r
+5 5 2030 1372 B\r
+1 F\r
+n\r
+5 43 301 1378 B\r
+1 F\r
+n\r
+5 43 967 1378 B\r
+1 F\r
+n\r
+5 43 1085 1378 B\r
+1 F\r
+n\r
+5 43 1203 1378 B\r
+1 F\r
+n\r
+5 43 1321 1378 B\r
+1 F\r
+n\r
+5 43 1439 1378 B\r
+1 F\r
+n\r
+5 43 1557 1378 B\r
+1 F\r
+n\r
+5 43 1675 1378 B\r
+1 F\r
+n\r
+5 43 1793 1378 B\r
+1 F\r
+n\r
+5 43 1912 1378 B\r
+1 F\r
+n\r
+5 43 2030 1378 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 1422 CB\r
+327 1428 413 (Classes & Objects) 413 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 112 66 973 1422 CB\r
+992 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 1422 CB\r
+1110 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1209 1422 CB\r
+1228 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1327 1422 CB\r
+1346 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 1422 CB\r
+1465 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1563 1422 CB\r
+1583 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1681 1422 CB\r
+1701 1428 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1422 CB\r
+1819 1428 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1422 CB\r
+1937 1428 43 ( +) 43 SB\r
+gr\r
+5 5 301 1422 B\r
+1 F\r
+n\r
+659 5 307 1422 B\r
+1 F\r
+n\r
+5 5 967 1422 B\r
+1 F\r
+n\r
+111 5 973 1422 B\r
+1 F\r
+n\r
+5 5 1085 1422 B\r
+1 F\r
+n\r
+111 5 1091 1422 B\r
+1 F\r
+n\r
+5 5 1203 1422 B\r
+1 F\r
+n\r
+111 5 1209 1422 B\r
+1 F\r
+n\r
+5 5 1321 1422 B\r
+1 F\r
+n\r
+111 5 1327 1422 B\r
+1 F\r
+n\r
+5 5 1439 1422 B\r
+1 F\r
+n\r
+111 5 1445 1422 B\r
+1 F\r
+n\r
+5 5 1557 1422 B\r
+1 F\r
+n\r
+111 5 1563 1422 B\r
+1 F\r
+n\r
+5 5 1675 1422 B\r
+1 F\r
+n\r
+111 5 1681 1422 B\r
+1 F\r
+n\r
+5 5 1793 1422 B\r
+1 F\r
+n\r
+112 5 1799 1422 B\r
+1 F\r
+n\r
+5 5 1912 1422 B\r
+1 F\r
+n\r
+111 5 1918 1422 B\r
+1 F\r
+n\r
+5 5 2030 1422 B\r
+1 F\r
+n\r
+5 61 301 1428 B\r
+1 F\r
+n\r
+5 61 967 1428 B\r
+1 F\r
+n\r
+5 61 1085 1428 B\r
+1 F\r
+n\r
+5 61 1203 1428 B\r
+1 F\r
+n\r
+5 61 1321 1428 B\r
+1 F\r
+n\r
+5 61 1439 1428 B\r
+1 F\r
+n\r
+5 61 1557 1428 B\r
+1 F\r
+n\r
+5 61 1675 1428 B\r
+1 F\r
+n\r
+5 61 1793 1428 B\r
+1 F\r
+n\r
+5 61 1912 1428 B\r
+1 F\r
+n\r
+5 61 2030 1428 B\r
+1 F\r
+n\r
+5 5 301 1490 B\r
+1 F\r
+n\r
+659 5 307 1490 B\r
+1 F\r
+n\r
+5 5 967 1490 B\r
+1 F\r
+n\r
+111 5 973 1490 B\r
+1 F\r
+n\r
+5 5 1085 1490 B\r
+1 F\r
+n\r
+111 5 1091 1490 B\r
+1 F\r
+n\r
+5 5 1203 1490 B\r
+1 F\r
+n\r
+111 5 1209 1490 B\r
+1 F\r
+n\r
+5 5 1321 1490 B\r
+1 F\r
+n\r
+111 5 1327 1490 B\r
+1 F\r
+n\r
+5 5 1439 1490 B\r
+1 F\r
+n\r
+111 5 1445 1490 B\r
+1 F\r
+n\r
+5 5 1557 1490 B\r
+1 F\r
+n\r
+111 5 1563 1490 B\r
+1 F\r
+n\r
+5 5 1675 1490 B\r
+1 F\r
+n\r
+111 5 1681 1490 B\r
+1 F\r
+n\r
+5 5 1793 1490 B\r
+1 F\r
+n\r
+112 5 1799 1490 B\r
+1 F\r
+n\r
+5 5 1912 1490 B\r
+1 F\r
+n\r
+111 5 1918 1490 B\r
+1 F\r
+n\r
+5 5 2030 1490 B\r
+1 F\r
+n\r
+5 43 301 1496 B\r
+1 F\r
+n\r
+5 43 967 1496 B\r
+1 F\r
+n\r
+5 43 1085 1496 B\r
+1 F\r
+n\r
+5 43 1203 1496 B\r
+1 F\r
+n\r
+5 43 1321 1496 B\r
+1 F\r
+n\r
+5 43 1439 1496 B\r
+1 F\r
+n\r
+5 43 1557 1496 B\r
+1 F\r
+n\r
+5 43 1675 1496 B\r
+1 F\r
+n\r
+5 43 1793 1496 B\r
+1 F\r
+n\r
+5 43 1912 1496 B\r
+1 F\r
+n\r
+5 43 2030 1496 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 1540 CB\r
+327 1546 254 (Coroutines) 254 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 112 66 973 1540 CB\r
+992 1546 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 1540 CB\r
+1110 1546 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1540 CB\r
+1228 1546 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1540 CB\r
+1346 1546 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 1540 CB\r
+1465 1546 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1540 CB\r
+1583 1546 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1540 CB\r
+1701 1546 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1540 CB\r
+1819 1546 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1540 CB\r
+1937 1546 43 ( +) 43 SB\r
+gr\r
+5 5 301 1540 B\r
+1 F\r
+n\r
+659 5 307 1540 B\r
+1 F\r
+n\r
+5 5 967 1540 B\r
+1 F\r
+n\r
+111 5 973 1540 B\r
+1 F\r
+n\r
+5 5 1085 1540 B\r
+1 F\r
+n\r
+111 5 1091 1540 B\r
+1 F\r
+n\r
+5 5 1203 1540 B\r
+1 F\r
+n\r
+111 5 1209 1540 B\r
+1 F\r
+n\r
+5 5 1321 1540 B\r
+1 F\r
+n\r
+111 5 1327 1540 B\r
+1 F\r
+n\r
+5 5 1439 1540 B\r
+1 F\r
+n\r
+111 5 1445 1540 B\r
+1 F\r
+n\r
+5 5 1557 1540 B\r
+1 F\r
+n\r
+111 5 1563 1540 B\r
+1 F\r
+n\r
+5 5 1675 1540 B\r
+1 F\r
+n\r
+111 5 1681 1540 B\r
+1 F\r
+n\r
+5 5 1793 1540 B\r
+1 F\r
+n\r
+112 5 1799 1540 B\r
+1 F\r
+n\r
+5 5 1912 1540 B\r
+1 F\r
+n\r
+111 5 1918 1540 B\r
+1 F\r
+n\r
+5 5 2030 1540 B\r
+1 F\r
+n\r
+5 61 301 1546 B\r
+1 F\r
+n\r
+5 61 967 1546 B\r
+1 F\r
+n\r
+5 61 1085 1546 B\r
+1 F\r
+n\r
+5 61 1203 1546 B\r
+1 F\r
+n\r
+5 61 1321 1546 B\r
+1 F\r
+n\r
+5 61 1439 1546 B\r
+1 F\r
+n\r
+5 61 1557 1546 B\r
+1 F\r
+n\r
+5 61 1675 1546 B\r
+1 F\r
+n\r
+5 61 1793 1546 B\r
+1 F\r
+n\r
+5 61 1912 1546 B\r
+1 F\r
+n\r
+5 61 2030 1546 B\r
+1 F\r
+n\r
+5 5 301 1608 B\r
+1 F\r
+n\r
+659 5 307 1608 B\r
+1 F\r
+n\r
+5 5 967 1608 B\r
+1 F\r
+n\r
+111 5 973 1608 B\r
+1 F\r
+n\r
+5 5 1085 1608 B\r
+1 F\r
+n\r
+111 5 1091 1608 B\r
+1 F\r
+n\r
+5 5 1203 1608 B\r
+1 F\r
+n\r
+111 5 1209 1608 B\r
+1 F\r
+n\r
+5 5 1321 1608 B\r
+1 F\r
+n\r
+111 5 1327 1608 B\r
+1 F\r
+n\r
+5 5 1439 1608 B\r
+1 F\r
+n\r
+111 5 1445 1608 B\r
+1 F\r
+n\r
+5 5 1557 1608 B\r
+1 F\r
+n\r
+111 5 1563 1608 B\r
+1 F\r
+n\r
+5 5 1675 1608 B\r
+1 F\r
+n\r
+111 5 1681 1608 B\r
+1 F\r
+n\r
+5 5 1793 1608 B\r
+1 F\r
+n\r
+112 5 1799 1608 B\r
+1 F\r
+n\r
+5 5 1912 1608 B\r
+1 F\r
+n\r
+111 5 1918 1608 B\r
+1 F\r
+n\r
+5 5 2030 1608 B\r
+1 F\r
+n\r
+5 43 301 1614 B\r
+1 F\r
+n\r
+5 43 967 1614 B\r
+1 F\r
+n\r
+5 43 1085 1614 B\r
+1 F\r
+n\r
+5 43 1203 1614 B\r
+1 F\r
+n\r
+5 43 1321 1614 B\r
+1 F\r
+n\r
+5 43 1439 1614 B\r
+1 F\r
+n\r
+5 43 1557 1614 B\r
+1 F\r
+n\r
+5 43 1675 1614 B\r
+1 F\r
+n\r
+5 43 1793 1614 B\r
+1 F\r
+n\r
+5 43 1912 1614 B\r
+1 F\r
+n\r
+5 43 2030 1614 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 1658 CB\r
+327 1664 216 (Processes) 216 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 112 66 973 1658 CB\r
+992 1664 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 1658 CB\r
+1110 1664 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1658 CB\r
+1228 1664 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1658 CB\r
+1346 1664 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 1658 CB\r
+1465 1664 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1658 CB\r
+1583 1664 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1658 CB\r
+1701 1664 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 1658 CB\r
+1819 1664 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1658 CB\r
+1937 1664 43 ( +) 43 SB\r
+gr\r
+5 5 301 1658 B\r
+1 F\r
+n\r
+659 5 307 1658 B\r
+1 F\r
+n\r
+5 5 967 1658 B\r
+1 F\r
+n\r
+111 5 973 1658 B\r
+1 F\r
+n\r
+5 5 1085 1658 B\r
+1 F\r
+n\r
+111 5 1091 1658 B\r
+1 F\r
+n\r
+5 5 1203 1658 B\r
+1 F\r
+n\r
+111 5 1209 1658 B\r
+1 F\r
+n\r
+5 5 1321 1658 B\r
+1 F\r
+n\r
+111 5 1327 1658 B\r
+1 F\r
+n\r
+5 5 1439 1658 B\r
+1 F\r
+n\r
+111 5 1445 1658 B\r
+1 F\r
+n\r
+5 5 1557 1658 B\r
+1 F\r
+n\r
+111 5 1563 1658 B\r
+1 F\r
+n\r
+5 5 1675 1658 B\r
+1 F\r
+n\r
+111 5 1681 1658 B\r
+1 F\r
+n\r
+5 5 1793 1658 B\r
+1 F\r
+n\r
+112 5 1799 1658 B\r
+1 F\r
+n\r
+5 5 1912 1658 B\r
+1 F\r
+n\r
+111 5 1918 1658 B\r
+1 F\r
+n\r
+5 5 2030 1658 B\r
+1 F\r
+n\r
+5 61 301 1664 B\r
+1 F\r
+n\r
+5 61 967 1664 B\r
+1 F\r
+n\r
+5 61 1085 1664 B\r
+1 F\r
+n\r
+5 61 1203 1664 B\r
+1 F\r
+n\r
+5 61 1321 1664 B\r
+1 F\r
+n\r
+5 61 1439 1664 B\r
+1 F\r
+n\r
+5 61 1557 1664 B\r
+1 F\r
+n\r
+5 61 1675 1664 B\r
+1 F\r
+n\r
+5 61 1793 1664 B\r
+1 F\r
+n\r
+5 61 1912 1664 B\r
+1 F\r
+n\r
+5 61 2030 1664 B\r
+1 F\r
+n\r
+gs 660 66 307 1726 CB\r
+327 1732 525 ( alien call of methods) 525 SB\r
+gr\r
+gs 112 66 973 1726 CB\r
+992 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 1726 CB\r
+1110 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1726 CB\r
+1228 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1726 CB\r
+1346 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 1726 CB\r
+1465 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1726 CB\r
+1583 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1726 CB\r
+1701 1732 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 1726 CB\r
+1819 1732 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1918 1726 CB\r
+1937 1732 43 ( +) 43 SB\r
+gr\r
+5 5 301 1726 B\r
+1 F\r
+n\r
+659 5 307 1726 B\r
+1 F\r
+n\r
+5 5 967 1726 B\r
+1 F\r
+n\r
+111 5 973 1726 B\r
+1 F\r
+n\r
+5 5 1085 1726 B\r
+1 F\r
+n\r
+111 5 1091 1726 B\r
+1 F\r
+n\r
+5 5 1203 1726 B\r
+1 F\r
+n\r
+111 5 1209 1726 B\r
+1 F\r
+n\r
+5 5 1321 1726 B\r
+1 F\r
+n\r
+111 5 1327 1726 B\r
+1 F\r
+n\r
+5 5 1439 1726 B\r
+1 F\r
+n\r
+111 5 1445 1726 B\r
+1 F\r
+n\r
+5 5 1557 1726 B\r
+1 F\r
+n\r
+111 5 1563 1726 B\r
+1 F\r
+n\r
+5 5 1675 1726 B\r
+1 F\r
+n\r
+111 5 1681 1726 B\r
+1 F\r
+n\r
+5 5 1793 1726 B\r
+1 F\r
+n\r
+112 5 1799 1726 B\r
+1 F\r
+n\r
+5 5 1912 1726 B\r
+1 F\r
+n\r
+111 5 1918 1726 B\r
+1 F\r
+n\r
+5 5 2030 1726 B\r
+1 F\r
+n\r
+5 59 301 1732 B\r
+1 F\r
+n\r
+5 59 967 1732 B\r
+1 F\r
+n\r
+5 59 1085 1732 B\r
+1 F\r
+n\r
+5 59 1203 1732 B\r
+1 F\r
+n\r
+5 59 1321 1732 B\r
+1 F\r
+n\r
+5 59 1439 1732 B\r
+1 F\r
+n\r
+5 59 1557 1732 B\r
+1 F\r
+n\r
+5 59 1675 1732 B\r
+1 F\r
+n\r
+5 59 1793 1732 B\r
+1 F\r
+n\r
+5 59 1912 1732 B\r
+1 F\r
+n\r
+5 59 2030 1732 B\r
+1 F\r
+n\r
+5 5 301 1792 B\r
+1 F\r
+n\r
+659 5 307 1792 B\r
+1 F\r
+n\r
+5 5 967 1792 B\r
+1 F\r
+n\r
+111 5 973 1792 B\r
+1 F\r
+n\r
+5 5 1085 1792 B\r
+1 F\r
+n\r
+111 5 1091 1792 B\r
+1 F\r
+n\r
+5 5 1203 1792 B\r
+1 F\r
+n\r
+111 5 1209 1792 B\r
+1 F\r
+n\r
+5 5 1321 1792 B\r
+1 F\r
+n\r
+111 5 1327 1792 B\r
+1 F\r
+n\r
+5 5 1439 1792 B\r
+1 F\r
+n\r
+111 5 1445 1792 B\r
+1 F\r
+n\r
+5 5 1557 1792 B\r
+1 F\r
+n\r
+111 5 1563 1792 B\r
+1 F\r
+n\r
+5 5 1675 1792 B\r
+1 F\r
+n\r
+111 5 1681 1792 B\r
+1 F\r
+n\r
+5 5 1793 1792 B\r
+1 F\r
+n\r
+112 5 1799 1792 B\r
+1 F\r
+n\r
+5 5 1912 1792 B\r
+1 F\r
+n\r
+111 5 1918 1792 B\r
+1 F\r
+n\r
+5 5 2030 1792 B\r
+1 F\r
+n\r
+5 43 301 1798 B\r
+1 F\r
+n\r
+5 43 967 1798 B\r
+1 F\r
+n\r
+5 43 1085 1798 B\r
+1 F\r
+n\r
+5 43 1203 1798 B\r
+1 F\r
+n\r
+5 43 1321 1798 B\r
+1 F\r
+n\r
+5 43 1439 1798 B\r
+1 F\r
+n\r
+5 43 1557 1798 B\r
+1 F\r
+n\r
+5 43 1675 1798 B\r
+1 F\r
+n\r
+5 43 1793 1798 B\r
+1 F\r
+n\r
+5 43 1912 1798 B\r
+1 F\r
+n\r
+5 43 2030 1798 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 1842 CB\r
+327 1848 488 (Signals & Exceptions) 488 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 112 66 973 1842 CB\r
+992 1848 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 1842 CB\r
+1110 1848 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 1842 CB\r
+1228 1848 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 1842 CB\r
+1346 1848 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 1842 CB\r
+1465 1848 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 1842 CB\r
+1583 1848 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 1842 CB\r
+1701 1848 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 1842 CB\r
+1819 1848 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 1842 CB\r
+1937 1848 43 ( +) 43 SB\r
+gr\r
+32 0 0 33 33 0 0 1 29 /MSTT31c1d2 font\r
+\r
+%%BeginResource: font MSTT31c1d2\r
+/G33 [17.0 0.0 1.0 0.0 14.0 22.0]\r
+/G33 {\r
+ 13 22 true [1 0 0 -1 -1.0 22.0] {<0f803fe061e040f080700070006000e000c003c00fe001f000f8007800380038003800300030e060\r
+f0c07f00>} imagemask \r
+ }\r
+ 51 /G33 MSTT31c1d2 AddChar\r
+%%EndResource\r
+\r
+gs 112 66 1918 1842 CB\r
+1980 1852 17 (3) 17 SB\r
+gr\r
+5 5 301 1842 B\r
+1 F\r
+n\r
+659 5 307 1842 B\r
+1 F\r
+n\r
+5 5 967 1842 B\r
+1 F\r
+n\r
+111 5 973 1842 B\r
+1 F\r
+n\r
+5 5 1085 1842 B\r
+1 F\r
+n\r
+111 5 1091 1842 B\r
+1 F\r
+n\r
+5 5 1203 1842 B\r
+1 F\r
+n\r
+111 5 1209 1842 B\r
+1 F\r
+n\r
+5 5 1321 1842 B\r
+1 F\r
+n\r
+111 5 1327 1842 B\r
+1 F\r
+n\r
+5 5 1439 1842 B\r
+1 F\r
+n\r
+111 5 1445 1842 B\r
+1 F\r
+n\r
+5 5 1557 1842 B\r
+1 F\r
+n\r
+111 5 1563 1842 B\r
+1 F\r
+n\r
+5 5 1675 1842 B\r
+1 F\r
+n\r
+111 5 1681 1842 B\r
+1 F\r
+n\r
+5 5 1793 1842 B\r
+1 F\r
+n\r
+112 5 1799 1842 B\r
+1 F\r
+n\r
+5 5 1912 1842 B\r
+1 F\r
+n\r
+111 5 1918 1842 B\r
+1 F\r
+n\r
+5 5 2030 1842 B\r
+1 F\r
+n\r
+5 61 301 1848 B\r
+1 F\r
+n\r
+5 61 967 1848 B\r
+1 F\r
+n\r
+5 61 1085 1848 B\r
+1 F\r
+n\r
+5 61 1203 1848 B\r
+1 F\r
+n\r
+5 61 1321 1848 B\r
+1 F\r
+n\r
+5 61 1439 1848 B\r
+1 F\r
+n\r
+5 61 1557 1848 B\r
+1 F\r
+n\r
+5 61 1675 1848 B\r
+1 F\r
+n\r
+5 61 1793 1848 B\r
+1 F\r
+n\r
+5 61 1912 1848 B\r
+1 F\r
+n\r
+5 61 2030 1848 B\r
+1 F\r
+n\r
+5 5 301 1910 B\r
+1 F\r
+n\r
+659 5 307 1910 B\r
+1 F\r
+n\r
+5 5 967 1910 B\r
+1 F\r
+n\r
+111 5 973 1910 B\r
+1 F\r
+n\r
+5 5 1085 1910 B\r
+1 F\r
+n\r
+111 5 1091 1910 B\r
+1 F\r
+n\r
+5 5 1203 1910 B\r
+1 F\r
+n\r
+111 5 1209 1910 B\r
+1 F\r
+n\r
+5 5 1321 1910 B\r
+1 F\r
+n\r
+111 5 1327 1910 B\r
+1 F\r
+n\r
+5 5 1439 1910 B\r
+1 F\r
+n\r
+111 5 1445 1910 B\r
+1 F\r
+n\r
+5 5 1557 1910 B\r
+1 F\r
+n\r
+111 5 1563 1910 B\r
+1 F\r
+n\r
+5 5 1675 1910 B\r
+1 F\r
+n\r
+111 5 1681 1910 B\r
+1 F\r
+n\r
+5 5 1793 1910 B\r
+1 F\r
+n\r
+112 5 1799 1910 B\r
+1 F\r
+n\r
+5 5 1912 1910 B\r
+1 F\r
+n\r
+111 5 1918 1910 B\r
+1 F\r
+n\r
+5 5 2030 1910 B\r
+1 F\r
+n\r
+5 43 301 1916 B\r
+1 F\r
+n\r
+5 43 967 1916 B\r
+1 F\r
+n\r
+5 43 1085 1916 B\r
+1 F\r
+n\r
+5 43 1203 1916 B\r
+1 F\r
+n\r
+5 43 1321 1916 B\r
+1 F\r
+n\r
+5 43 1439 1916 B\r
+1 F\r
+n\r
+5 43 1557 1916 B\r
+1 F\r
+n\r
+5 43 1675 1916 B\r
+1 F\r
+n\r
+5 43 1793 1916 B\r
+1 F\r
+n\r
+5 43 1912 1916 B\r
+1 F\r
+n\r
+5 43 2030 1916 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 1960 CB\r
+327 1966 145 (Safety) 145 SB\r
+gr\r
+5 5 301 1960 B\r
+1 F\r
+n\r
+659 5 307 1960 B\r
+1 F\r
+n\r
+5 5 967 1960 B\r
+1 F\r
+n\r
+111 5 973 1960 B\r
+1 F\r
+n\r
+5 5 1085 1960 B\r
+1 F\r
+n\r
+111 5 1091 1960 B\r
+1 F\r
+n\r
+5 5 1203 1960 B\r
+1 F\r
+n\r
+111 5 1209 1960 B\r
+1 F\r
+n\r
+5 5 1321 1960 B\r
+1 F\r
+n\r
+111 5 1327 1960 B\r
+1 F\r
+n\r
+5 5 1439 1960 B\r
+1 F\r
+n\r
+111 5 1445 1960 B\r
+1 F\r
+n\r
+5 5 1557 1960 B\r
+1 F\r
+n\r
+111 5 1563 1960 B\r
+1 F\r
+n\r
+5 5 1675 1960 B\r
+1 F\r
+n\r
+111 5 1681 1960 B\r
+1 F\r
+n\r
+5 5 1793 1960 B\r
+1 F\r
+n\r
+112 5 1799 1960 B\r
+1 F\r
+n\r
+5 5 1912 1960 B\r
+1 F\r
+n\r
+111 5 1918 1960 B\r
+1 F\r
+n\r
+5 5 2030 1960 B\r
+1 F\r
+n\r
+5 61 301 1966 B\r
+1 F\r
+n\r
+5 61 967 1966 B\r
+1 F\r
+n\r
+5 61 1085 1966 B\r
+1 F\r
+n\r
+5 61 1203 1966 B\r
+1 F\r
+n\r
+5 61 1321 1966 B\r
+1 F\r
+n\r
+5 61 1439 1966 B\r
+1 F\r
+n\r
+5 61 1557 1966 B\r
+1 F\r
+n\r
+5 61 1675 1966 B\r
+1 F\r
+n\r
+5 61 1793 1966 B\r
+1 F\r
+n\r
+5 61 1912 1966 B\r
+1 F\r
+n\r
+5 61 2030 1966 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 66 307 2028 CB\r
+327 2034 449 (safe deallocation i.e.) 449 SB\r
+gr\r
+gs 660 68 307 2088 CB\r
+327 2096 52 ( ) 52 SB\r
+gr\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 2088 CB\r
+379 2094 59 (no) 59 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 68 307 2088 CB\r
+438 2096 464 ( dangling references) 464 SB\r
+gr\r
+gs 112 66 973 2028 CB\r
+992 2034 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 2028 CB\r
+1110 2034 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 2028 CB\r
+1228 2034 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 2028 CB\r
+1346 2034 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 2028 CB\r
+1465 2034 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 2028 CB\r
+1583 2034 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 2028 CB\r
+1701 2034 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 2028 CB\r
+1819 2034 35 ( ?) 35 SB\r
+gr\r
+gs 112 66 1918 2028 CB\r
+1937 2034 43 ( +) 43 SB\r
+gr\r
+5 5 301 2028 B\r
+1 F\r
+n\r
+659 5 307 2028 B\r
+1 F\r
+n\r
+5 5 967 2028 B\r
+1 F\r
+n\r
+111 5 973 2028 B\r
+1 F\r
+n\r
+5 5 1085 2028 B\r
+1 F\r
+n\r
+111 5 1091 2028 B\r
+1 F\r
+n\r
+5 5 1203 2028 B\r
+1 F\r
+n\r
+111 5 1209 2028 B\r
+1 F\r
+n\r
+5 5 1321 2028 B\r
+1 F\r
+n\r
+111 5 1327 2028 B\r
+1 F\r
+n\r
+5 5 1439 2028 B\r
+1 F\r
+n\r
+111 5 1445 2028 B\r
+1 F\r
+n\r
+5 5 1557 2028 B\r
+1 F\r
+n\r
+111 5 1563 2028 B\r
+1 F\r
+n\r
+5 5 1675 2028 B\r
+1 F\r
+n\r
+111 5 1681 2028 B\r
+1 F\r
+n\r
+5 5 1793 2028 B\r
+1 F\r
+n\r
+112 5 1799 2028 B\r
+1 F\r
+n\r
+5 5 1912 2028 B\r
+1 F\r
+n\r
+111 5 1918 2028 B\r
+1 F\r
+n\r
+5 5 2030 2028 B\r
+1 F\r
+n\r
+5 121 301 2034 B\r
+1 F\r
+n\r
+5 121 967 2034 B\r
+1 F\r
+n\r
+5 121 1085 2034 B\r
+1 F\r
+n\r
+5 121 1203 2034 B\r
+1 F\r
+n\r
+5 121 1321 2034 B\r
+1 F\r
+n\r
+5 121 1439 2034 B\r
+1 F\r
+n\r
+5 121 1557 2034 B\r
+1 F\r
+n\r
+5 121 1675 2034 B\r
+1 F\r
+n\r
+5 121 1793 2034 B\r
+1 F\r
+n\r
+5 121 1912 2034 B\r
+1 F\r
+n\r
+5 121 2030 2034 B\r
+1 F\r
+n\r
+gs 660 66 307 2156 CB\r
+327 2162 334 ( type checking) 334 SB\r
+gr\r
+gs 112 66 973 2156 CB\r
+992 2162 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 2156 CB\r
+1110 2162 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1209 2156 CB\r
+1228 2162 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 2156 CB\r
+1346 2162 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 2156 CB\r
+1465 2162 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 2156 CB\r
+1583 2162 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 2156 CB\r
+1701 2162 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 2156 CB\r
+1819 2162 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 2156 CB\r
+1937 2162 43 ( +) 43 SB\r
+gr\r
+5 5 301 2156 B\r
+1 F\r
+n\r
+659 5 307 2156 B\r
+1 F\r
+n\r
+5 5 967 2156 B\r
+1 F\r
+n\r
+111 5 973 2156 B\r
+1 F\r
+n\r
+5 5 1085 2156 B\r
+1 F\r
+n\r
+111 5 1091 2156 B\r
+1 F\r
+n\r
+5 5 1203 2156 B\r
+1 F\r
+n\r
+111 5 1209 2156 B\r
+1 F\r
+n\r
+5 5 1321 2156 B\r
+1 F\r
+n\r
+111 5 1327 2156 B\r
+1 F\r
+n\r
+5 5 1439 2156 B\r
+1 F\r
+n\r
+111 5 1445 2156 B\r
+1 F\r
+n\r
+5 5 1557 2156 B\r
+1 F\r
+n\r
+111 5 1563 2156 B\r
+1 F\r
+n\r
+5 5 1675 2156 B\r
+1 F\r
+n\r
+111 5 1681 2156 B\r
+1 F\r
+n\r
+5 5 1793 2156 B\r
+1 F\r
+n\r
+112 5 1799 2156 B\r
+1 F\r
+n\r
+5 5 1912 2156 B\r
+1 F\r
+n\r
+111 5 1918 2156 B\r
+1 F\r
+n\r
+5 5 2030 2156 B\r
+1 F\r
+n\r
+5 59 301 2162 B\r
+1 F\r
+n\r
+5 59 967 2162 B\r
+1 F\r
+n\r
+5 59 1085 2162 B\r
+1 F\r
+n\r
+5 59 1203 2162 B\r
+1 F\r
+n\r
+5 59 1321 2162 B\r
+1 F\r
+n\r
+5 59 1439 2162 B\r
+1 F\r
+n\r
+5 59 1557 2162 B\r
+1 F\r
+n\r
+5 59 1675 2162 B\r
+1 F\r
+n\r
+5 59 1793 2162 B\r
+1 F\r
+n\r
+5 59 1912 2162 B\r
+1 F\r
+n\r
+5 59 2030 2162 B\r
+1 F\r
+n\r
+gs 660 66 307 2222 CB\r
+327 2228 493 ( protection of private) 493 SB\r
+gr\r
+gs 112 66 973 2222 CB\r
+992 2228 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1091 2222 CB\r
+1110 2228 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 2222 CB\r
+1228 2228 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 2222 CB\r
+1346 2228 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 2222 CB\r
+1465 2228 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 2222 CB\r
+1583 2228 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 2222 CB\r
+1701 2228 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 2222 CB\r
+1819 2228 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 2222 CB\r
+1937 2228 43 ( +) 43 SB\r
+gr\r
+5 5 301 2222 B\r
+1 F\r
+n\r
+659 5 307 2222 B\r
+1 F\r
+n\r
+5 5 967 2222 B\r
+1 F\r
+n\r
+111 5 973 2222 B\r
+1 F\r
+n\r
+5 5 1085 2222 B\r
+1 F\r
+n\r
+111 5 1091 2222 B\r
+1 F\r
+n\r
+5 5 1203 2222 B\r
+1 F\r
+n\r
+111 5 1209 2222 B\r
+1 F\r
+n\r
+5 5 1321 2222 B\r
+1 F\r
+n\r
+111 5 1327 2222 B\r
+1 F\r
+n\r
+5 5 1439 2222 B\r
+1 F\r
+n\r
+111 5 1445 2222 B\r
+1 F\r
+n\r
+5 5 1557 2222 B\r
+1 F\r
+n\r
+111 5 1563 2222 B\r
+1 F\r
+n\r
+5 5 1675 2222 B\r
+1 F\r
+n\r
+111 5 1681 2222 B\r
+1 F\r
+n\r
+5 5 1793 2222 B\r
+1 F\r
+n\r
+112 5 1799 2222 B\r
+1 F\r
+n\r
+5 5 1912 2222 B\r
+1 F\r
+n\r
+111 5 1918 2222 B\r
+1 F\r
+n\r
+5 5 2030 2222 B\r
+1 F\r
+n\r
+5 59 301 2228 B\r
+1 F\r
+n\r
+5 59 967 2228 B\r
+1 F\r
+n\r
+5 59 1085 2228 B\r
+1 F\r
+n\r
+5 59 1203 2228 B\r
+1 F\r
+n\r
+5 59 1321 2228 B\r
+1 F\r
+n\r
+5 59 1439 2228 B\r
+1 F\r
+n\r
+5 59 1557 2228 B\r
+1 F\r
+n\r
+5 59 1675 2228 B\r
+1 F\r
+n\r
+5 59 1793 2228 B\r
+1 F\r
+n\r
+5 59 1912 2228 B\r
+1 F\r
+n\r
+5 59 2030 2228 B\r
+1 F\r
+n\r
+5 5 301 2288 B\r
+1 F\r
+n\r
+659 5 307 2288 B\r
+1 F\r
+n\r
+5 5 967 2288 B\r
+1 F\r
+n\r
+111 5 973 2288 B\r
+1 F\r
+n\r
+5 5 1085 2288 B\r
+1 F\r
+n\r
+111 5 1091 2288 B\r
+1 F\r
+n\r
+5 5 1203 2288 B\r
+1 F\r
+n\r
+111 5 1209 2288 B\r
+1 F\r
+n\r
+5 5 1321 2288 B\r
+1 F\r
+n\r
+111 5 1327 2288 B\r
+1 F\r
+n\r
+5 5 1439 2288 B\r
+1 F\r
+n\r
+111 5 1445 2288 B\r
+1 F\r
+n\r
+5 5 1557 2288 B\r
+1 F\r
+n\r
+111 5 1563 2288 B\r
+1 F\r
+n\r
+5 5 1675 2288 B\r
+1 F\r
+n\r
+111 5 1681 2288 B\r
+1 F\r
+n\r
+5 5 1793 2288 B\r
+1 F\r
+n\r
+112 5 1799 2288 B\r
+1 F\r
+n\r
+5 5 1912 2288 B\r
+1 F\r
+n\r
+111 5 1918 2288 B\r
+1 F\r
+n\r
+5 5 2030 2288 B\r
+1 F\r
+n\r
+5 43 301 2294 B\r
+1 F\r
+n\r
+5 43 967 2294 B\r
+1 F\r
+n\r
+5 43 1085 2294 B\r
+1 F\r
+n\r
+5 43 1203 2294 B\r
+1 F\r
+n\r
+5 43 1321 2294 B\r
+1 F\r
+n\r
+5 43 1439 2294 B\r
+1 F\r
+n\r
+5 43 1557 2294 B\r
+1 F\r
+n\r
+5 43 1675 2294 B\r
+1 F\r
+n\r
+5 43 1793 2294 B\r
+1 F\r
+n\r
+5 43 1912 2294 B\r
+1 F\r
+n\r
+5 43 2030 2294 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 48 /Palatino-Bold /font24 ANSIFont font\r
+gs 660 68 307 2338 CB\r
+327 2344 614 (Genericity&Polimorphism) 614 SB\r
+gr\r
+5 5 301 2338 B\r
+1 F\r
+n\r
+659 5 307 2338 B\r
+1 F\r
+n\r
+5 5 967 2338 B\r
+1 F\r
+n\r
+111 5 973 2338 B\r
+1 F\r
+n\r
+5 5 1085 2338 B\r
+1 F\r
+n\r
+111 5 1091 2338 B\r
+1 F\r
+n\r
+5 5 1203 2338 B\r
+1 F\r
+n\r
+111 5 1209 2338 B\r
+1 F\r
+n\r
+5 5 1321 2338 B\r
+1 F\r
+n\r
+111 5 1327 2338 B\r
+1 F\r
+n\r
+5 5 1439 2338 B\r
+1 F\r
+n\r
+111 5 1445 2338 B\r
+1 F\r
+n\r
+5 5 1557 2338 B\r
+1 F\r
+n\r
+111 5 1563 2338 B\r
+1 F\r
+n\r
+5 5 1675 2338 B\r
+1 F\r
+n\r
+111 5 1681 2338 B\r
+1 F\r
+n\r
+5 5 1793 2338 B\r
+1 F\r
+n\r
+112 5 1799 2338 B\r
+1 F\r
+n\r
+5 5 1912 2338 B\r
+1 F\r
+n\r
+111 5 1918 2338 B\r
+1 F\r
+n\r
+5 5 2030 2338 B\r
+1 F\r
+n\r
+5 61 301 2344 B\r
+1 F\r
+n\r
+5 61 967 2344 B\r
+1 F\r
+n\r
+5 61 1085 2344 B\r
+1 F\r
+n\r
+5 61 1203 2344 B\r
+1 F\r
+n\r
+5 61 1321 2344 B\r
+1 F\r
+n\r
+5 61 1439 2344 B\r
+1 F\r
+n\r
+5 61 1557 2344 B\r
+1 F\r
+n\r
+5 61 1675 2344 B\r
+1 F\r
+n\r
+5 61 1793 2344 B\r
+1 F\r
+n\r
+5 61 1912 2344 B\r
+1 F\r
+n\r
+5 61 2030 2344 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 660 66 307 2406 CB\r
+327 2412 582 ( types as formal params.) 582 SB\r
+gr\r
+gs 112 66 973 2406 CB\r
+992 2412 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1091 2406 CB\r
+1110 2412 43 ( -) 43 SB\r
+gr\r
+gs 112 66 1209 2406 CB\r
+1228 2412 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1327 2406 CB\r
+1346 2412 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1445 2406 CB\r
+1465 2412 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1563 2406 CB\r
+1583 2412 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1681 2406 CB\r
+1701 2412 60 ( -+) 60 SB\r
+gr\r
+gs 113 66 1799 2406 CB\r
+1819 2412 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1918 2406 CB\r
+1937 2412 43 ( +) 43 SB\r
+gr\r
+5 5 301 2406 B\r
+1 F\r
+n\r
+659 5 307 2406 B\r
+1 F\r
+n\r
+5 5 967 2406 B\r
+1 F\r
+n\r
+111 5 973 2406 B\r
+1 F\r
+n\r
+5 5 1085 2406 B\r
+1 F\r
+n\r
+111 5 1091 2406 B\r
+1 F\r
+n\r
+5 5 1203 2406 B\r
+1 F\r
+n\r
+111 5 1209 2406 B\r
+1 F\r
+n\r
+5 5 1321 2406 B\r
+1 F\r
+n\r
+111 5 1327 2406 B\r
+1 F\r
+n\r
+5 5 1439 2406 B\r
+1 F\r
+n\r
+111 5 1445 2406 B\r
+1 F\r
+n\r
+5 5 1557 2406 B\r
+1 F\r
+n\r
+111 5 1563 2406 B\r
+1 F\r
+n\r
+5 5 1675 2406 B\r
+1 F\r
+n\r
+111 5 1681 2406 B\r
+1 F\r
+n\r
+5 5 1793 2406 B\r
+1 F\r
+n\r
+112 5 1799 2406 B\r
+1 F\r
+n\r
+5 5 1912 2406 B\r
+1 F\r
+n\r
+111 5 1918 2406 B\r
+1 F\r
+n\r
+5 5 2030 2406 B\r
+1 F\r
+n\r
+5 59 301 2412 B\r
+1 F\r
+n\r
+5 59 967 2412 B\r
+1 F\r
+n\r
+5 59 1085 2412 B\r
+1 F\r
+n\r
+5 59 1203 2412 B\r
+1 F\r
+n\r
+5 59 1321 2412 B\r
+1 F\r
+n\r
+5 59 1439 2412 B\r
+1 F\r
+n\r
+5 59 1557 2412 B\r
+1 F\r
+n\r
+5 59 1675 2412 B\r
+1 F\r
+n\r
+5 59 1793 2412 B\r
+1 F\r
+n\r
+5 59 1912 2412 B\r
+1 F\r
+n\r
+5 59 2030 2412 B\r
+1 F\r
+n\r
+gs 660 66 307 2472 CB\r
+327 2478 601 ( overloading of operators) 601 SB\r
+gr\r
+gs 112 66 973 2472 CB\r
+992 2478 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 2472 CB\r
+1228 2478 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1327 2472 CB\r
+1346 2478 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 2472 CB\r
+1465 2478 35 ( ?) 35 SB\r
+gr\r
+gs 112 66 1563 2472 CB\r
+1583 2478 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1681 2472 CB\r
+1701 2478 43 ( +) 43 SB\r
+gr\r
+gs 113 66 1799 2472 CB\r
+1819 2478 35 ( ?) 35 SB\r
+gr\r
+gs 112 66 1918 2472 CB\r
+1937 2478 30 ( -) 30 SB\r
+gr\r
+5 5 301 2472 B\r
+1 F\r
+n\r
+659 5 307 2472 B\r
+1 F\r
+n\r
+5 5 967 2472 B\r
+1 F\r
+n\r
+111 5 973 2472 B\r
+1 F\r
+n\r
+5 5 1085 2472 B\r
+1 F\r
+n\r
+111 5 1091 2472 B\r
+1 F\r
+n\r
+5 5 1203 2472 B\r
+1 F\r
+n\r
+111 5 1209 2472 B\r
+1 F\r
+n\r
+5 5 1321 2472 B\r
+1 F\r
+n\r
+111 5 1327 2472 B\r
+1 F\r
+n\r
+5 5 1439 2472 B\r
+1 F\r
+n\r
+111 5 1445 2472 B\r
+1 F\r
+n\r
+5 5 1557 2472 B\r
+1 F\r
+n\r
+111 5 1563 2472 B\r
+1 F\r
+n\r
+5 5 1675 2472 B\r
+1 F\r
+n\r
+111 5 1681 2472 B\r
+1 F\r
+n\r
+5 5 1793 2472 B\r
+1 F\r
+n\r
+112 5 1799 2472 B\r
+1 F\r
+n\r
+5 5 1912 2472 B\r
+1 F\r
+n\r
+111 5 1918 2472 B\r
+1 F\r
+n\r
+5 5 2030 2472 B\r
+1 F\r
+n\r
+5 59 301 2478 B\r
+1 F\r
+n\r
+5 59 967 2478 B\r
+1 F\r
+n\r
+5 59 1085 2478 B\r
+1 F\r
+n\r
+5 59 1203 2478 B\r
+1 F\r
+n\r
+5 59 1321 2478 B\r
+1 F\r
+n\r
+5 59 1439 2478 B\r
+1 F\r
+n\r
+5 59 1557 2478 B\r
+1 F\r
+n\r
+5 59 1675 2478 B\r
+1 F\r
+n\r
+5 59 1793 2478 B\r
+1 F\r
+n\r
+5 59 1912 2478 B\r
+1 F\r
+n\r
+5 59 2030 2478 B\r
+1 F\r
+n\r
+gs 660 66 307 2538 CB\r
+327 2544 406 ( virtual methods) 406 SB\r
+gr\r
+gs 112 66 973 2538 CB\r
+992 2544 30 ( -) 30 SB\r
+gr\r
+gs 112 66 1209 2538 CB\r
+1228 2544 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1445 2538 CB\r
+1465 2544 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1563 2538 CB\r
+1583 2544 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1681 2538 CB\r
+1701 2544 30 ( -) 30 SB\r
+gr\r
+gs 113 66 1799 2538 CB\r
+1819 2544 43 ( +) 43 SB\r
+gr\r
+gs 112 66 1918 2538 CB\r
+1937 2544 43 ( +) 43 SB\r
+gr\r
+5 5 301 2538 B\r
+1 F\r
+n\r
+659 5 307 2538 B\r
+1 F\r
+n\r
+5 5 967 2538 B\r
+1 F\r
+n\r
+111 5 973 2538 B\r
+1 F\r
+n\r
+5 5 1085 2538 B\r
+1 F\r
+n\r
+111 5 1091 2538 B\r
+1 F\r
+n\r
+5 5 1203 2538 B\r
+1 F\r
+n\r
+111 5 1209 2538 B\r
+1 F\r
+n\r
+5 5 1321 2538 B\r
+1 F\r
+n\r
+111 5 1327 2538 B\r
+1 F\r
+n\r
+5 5 1439 2538 B\r
+1 F\r
+n\r
+111 5 1445 2538 B\r
+1 F\r
+n\r
+5 5 1557 2538 B\r
+1 F\r
+n\r
+111 5 1563 2538 B\r
+1 F\r
+n\r
+5 5 1675 2538 B\r
+1 F\r
+n\r
+111 5 1681 2538 B\r
+1 F\r
+n\r
+5 5 1793 2538 B\r
+1 F\r
+n\r
+112 5 1799 2538 B\r
+1 F\r
+n\r
+5 5 1912 2538 B\r
+1 F\r
+n\r
+111 5 1918 2538 B\r
+1 F\r
+n\r
+5 5 2030 2538 B\r
+1 F\r
+n\r
+5 59 301 2544 B\r
+1 F\r
+n\r
+5 5 301 2604 B\r
+1 F\r
+n\r
+5 5 301 2604 B\r
+1 F\r
+n\r
+659 5 307 2604 B\r
+1 F\r
+n\r
+5 59 967 2544 B\r
+1 F\r
+n\r
+5 5 967 2604 B\r
+1 F\r
+n\r
+111 5 973 2604 B\r
+1 F\r
+n\r
+5 59 1085 2544 B\r
+1 F\r
+n\r
+5 5 1085 2604 B\r
+1 F\r
+n\r
+111 5 1091 2604 B\r
+1 F\r
+n\r
+5 59 1203 2544 B\r
+1 F\r
+n\r
+5 5 1203 2604 B\r
+1 F\r
+n\r
+111 5 1209 2604 B\r
+1 F\r
+n\r
+5 59 1321 2544 B\r
+1 F\r
+n\r
+5 5 1321 2604 B\r
+1 F\r
+n\r
+111 5 1327 2604 B\r
+1 F\r
+n\r
+5 59 1439 2544 B\r
+1 F\r
+n\r
+5 5 1439 2604 B\r
+1 F\r
+n\r
+111 5 1445 2604 B\r
+1 F\r
+n\r
+5 59 1557 2544 B\r
+1 F\r
+n\r
+5 5 1557 2604 B\r
+1 F\r
+n\r
+111 5 1563 2604 B\r
+1 F\r
+n\r
+5 59 1675 2544 B\r
+1 F\r
+n\r
+5 5 1675 2604 B\r
+1 F\r
+n\r
+111 5 1681 2604 B\r
+1 F\r
+n\r
+5 59 1793 2544 B\r
+1 F\r
+n\r
+5 5 1793 2604 B\r
+1 F\r
+n\r
+112 5 1799 2604 B\r
+1 F\r
+n\r
+5 59 1912 2544 B\r
+1 F\r
+n\r
+5 5 1912 2604 B\r
+1 F\r
+n\r
+111 5 1918 2604 B\r
+1 F\r
+n\r
+5 59 2030 2544 B\r
+1 F\r
+n\r
+5 5 2030 2604 B\r
+1 F\r
+n\r
+5 5 2030 2604 B\r
+1 F\r
+n\r
+\r
+%%BeginResource: font MSTT31c1df\r
+/MSTT31c1df [42.0 0 0 0 0 0] 47 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c1df GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 1 1 38 /MSTT31c1df font\r
+\r
+%%BeginResource: font MSTT31c1df\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c1df AddChar\r
+%%EndResource\r
+\r
+327 2824 220 ( ) 220 SB\r
+547 2824 220 ( ) 220 SB\r
+767 2824 165 ( ) 165 SB\r
+32 0 0 33 33 0 0 1 29 /MSTT31c1d2 font\r
+327 2868 17 (1) 17 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c1df font\r
+\r
+%%BeginResource: font MSTT31c1df\r
+/G6d [33.0 0.0 1.0 0.0 33.0 20.0]\r
+/G6d {\r
+ 32 20 true [1 0 0 -1 -1.0 20.0] {<061f03c03e7f8fe0fec798f01f07e0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c078\r
+1e03c0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c0783f03e07cffcff9ff\r
+>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c1df AddChar\r
+/G75 [21.0 0.0 0.0 -1.0 21.0 19.0]\r
+/G75 {\r
+ 21 20 true [1 0 0 -1 0.0 19.0] {<fe1fc03e07c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e\r
+03c01e03c01e03c01e07c00f1bf807f3e003c300>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c1df AddChar\r
+/G6c [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G6c {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<06003e00fe001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c1df AddChar\r
+/G74 [12.0 0.0 0.0 -1.0 12.0 25.0]\r
+/G74 {\r
+ 12 26 true [1 0 0 -1 0.0 25.0] {<0200060006000e001e003e00ffe01e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001f300fe00780>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c1df AddChar\r
+/G69 [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G69 {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<0c001e001e000c000000000000000000000006003e00fe001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c1df AddChar\r
+/G70 [21.0 0.0 0.0 -9.0 20.0 20.0]\r
+/G70 {\r
+ 20 29 true [1 0 0 -1 0.0 20.0] {<061e003e7f80feffc01e87c01f03e01e01e01e01f01e00f01e00f01e00f01e00f01e00f01e00f01e\r
+00f01e00e01e01e01e01c01f03c01f87801eff001e7c001e00001e00001e00001e00001e00001e00\r
+003f0000ffc000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c1df AddChar\r
+/G65 [18.0 0.0 1.0 -1.0 17.0 20.0]\r
+/G65 {\r
+ 16 21 true [1 0 0 -1 -1.0 20.0] {<03e00ff81c3c301e700e600f600fffffe000e000e000e000f000f00178017c037e063ffe1ffc0ff8\r
+03e0>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c1df AddChar\r
+/G6e [22.0 0.0 1.0 0.0 22.0 20.0]\r
+/G6e {\r
+ 21 20 true [1 0 0 -1 -1.0 20.0] {<061e003e7f00fec7801f07c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e\r
+03c01e03c01e03c01e03c01e03c03f03e0ffcff8>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c1df AddChar\r
+/G68 [22.0 0.0 1.0 0.0 22.0 29.0]\r
+/G68 {\r
+ 21 29 true [1 0 0 -1 -1.0 29.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e1e001e7f001ec7801f07801e\r
+03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03\r
+c03f03e0ffcff8>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c1df AddChar\r
+/G72 [15.0 0.0 1.0 0.0 15.0 20.0]\r
+/G72 {\r
+ 14 20 true [1 0 0 -1 -1.0 20.0] {<06383e7cfefc1f981f001e001e001e001e001e001e001e001e001e001e001e001e001e003f00ffc0\r
+>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c1df AddChar\r
+/G61 [19.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G61 {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<07f0001e7800383c00781e00781e00781e00301e00001e00003e0001de00071e001c1e00381e0070\r
+1e00f01e00f01e00f01e00f03e00787e407f9f801e0e00>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c1df AddChar\r
+/G63 [18.0 0.0 1.0 -1.0 17.0 20.0]\r
+/G63 {\r
+ 16 21 true [1 0 0 -1 -1.0 20.0] {<01f00ffc1c1e380f300f70076000e000e000e000e000e000f000f00178037c027e0e3ffc1ffc0ff8\r
+03e0>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c1df AddChar\r
+/G79 [19.0 0.0 -1.0 -9.0 19.0 19.0]\r
+/G79 {\r
+ 20 28 true [1 0 0 -1 1.0 19.0] {<ffc3f03f00c01e00801f00800f00800f010007810007810003c20003c20003e40001e40001f40000\r
+f80000f8000078000070000070000030000020000020000040000040000040003880007f00007e00\r
+003c0000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c1df AddChar\r
+/G62 [20.0 0.0 -1.0 -1.0 19.0 29.0]\r
+/G62 {\r
+ 20 30 true [1 0 0 -1 1.0 29.0] {<0600003e0000fe00001e00001e00001e00001e00001e00001e00001e1e001e7f801effc01f87c01f\r
+03e01e01e01e01f01e00f01e00f01e00f01e00f01e00f01e00f01e00e01e00e01e01e01e01c01f03\r
+800f870007fe0001f800>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c1df AddChar\r
+/G6f [20.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G6f {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<03f0000ffc001e3e00380f00380f80700780700780f003c0f003c0f003c0f003c0f003c0f003c0f8\r
+03c07803807803803c07003e07001f0e000ffc0003f000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c1df AddChar\r
+/G64 [21.0 0.0 1.0 -1.0 21.0 29.0]\r
+/G64 {\r
+ 20 30 true [1 0 0 -1 -1.0 29.0] {<000180000f80003f8000078000078000078000078000078000078003e7800ff7801e1f801c0f8038\r
+0f80780780700780700780f00780f00780f00780f00780f00780f00780f807807807807c0f803e1f\r
+803ff7f01fe7e007c700>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c1df AddChar\r
+/G66 [13.0 0.0 0.0 0.0 17.0 29.0]\r
+/G66 {\r
+ 17 29 true [1 0 0 -1 0.0 29.0] {<007c0001ff00038f800707800703000f00000f00000f00000f00000f0000fff8000f00000f00000f\r
+00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00\r
+001f8000fff000>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c1df AddChar\r
+/G2d [14.0 0.0 2.0 8.0 13.0 12.0]\r
+/G2d {\r
+ 11 4 true [1 0 0 -1 -2.0 12.0] {<ffe0ffe0ffe0ffe0>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c1df AddChar\r
+/G76 [20.0 0.0 -1.0 -1.0 20.0 19.0]\r
+/G76 {\r
+ 21 20 true [1 0 0 -1 1.0 19.0] {<ffc1f83f00601e00601f00400f00400f808007808007810003c10003c10003e20001e20001e40000\r
+f40000f400007800007800007000003000003000>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c1df AddChar\r
+/G73 [16.0 0.0 2.0 -1.0 15.0 20.0]\r
+/G73 {\r
+ 13 21 true [1 0 0 -1 -2.0 20.0] {<0f903ff07070e030e010e010f000f8007e007f803fe00ff003f000f880788038c038c030f070ffe0\r
+8f80>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c1df AddChar\r
+/G2c [11.0 0.0 2.0 -7.0 8.0 3.0]\r
+/G2c {\r
+ 6 10 true [1 0 0 -1 -2.0 3.0] {<70f8fc740404081020c0>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c1df AddChar\r
+%%EndResource\r
+\r
+344 2872 1396 ( multiple inheritance may be obtained from multi-level inheritance and coroutines,) 1396 SB\r
+32 0 0 33 33 0 0 1 29 /MSTT31c1d2 font\r
+327 2916 17 (2) 17 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c1df font\r
+\r
+%%BeginResource: font MSTT31c1df\r
+/G67 [21.0 0.0 1.0 -9.0 21.0 20.0]\r
+/G67 {\r
+ 20 29 true [1 0 0 -1 -1.0 20.0] {<01f800071ff00e0f001c0f803c07803c07803c07803c07803c07801e07001e0e000f1c0007f8000c\r
+00001800001800003c00003fff801fffc00fffe01800e0300060600060600060e000c0f001807c0f\r
+003ffe000ff000>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c1df AddChar\r
+/G6b [21.0 0.0 0.0 0.0 21.0 29.0]\r
+/G6b {\r
+ 21 29 true [1 0 0 -1 0.0 29.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e0ff01e07801e06001e\r
+0c001e18001e30001e60001ee0001ff0001ef0001e78001e3c001e1e001e1f001e0f001e07801e03\r
+c03f03e0ffcff8>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c1df AddChar\r
+%%EndResource\r
+\r
+344 2920 1431 ( enabling to inherit a class in a procedure, a function, a process, a coroutine, a block) 1431 SB\r
+32 0 0 33 33 0 0 1 29 /MSTT31c1d2 font\r
+327 2964 17 (3) 17 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c1df font\r
+\r
+%%BeginResource: font MSTT31c1df\r
+/G77 [29.0 0.0 0.0 -1.0 29.0 19.0]\r
+/G77 {\r
+ 29 20 true [1 0 0 -1 0.0 19.0] {<ff9ff0f87e07c0303e03c0201e03c0201e01e0400f01e0400f01e0400f02f0800782f0800784f100\r
+0784790003c8790003c87a0003d03e0001f03e0001f03c0001e01c0000e01c0000c0180000c00800\r
+>} imagemask \r
+ }\r
+ 119 /G77 MSTT31c1df AddChar\r
+%%EndResource\r
+\r
+344 2968 674 ( with continuations and last will actions) 674 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Courier-Bold\r
+%%+ font MSTT31c1b9\r
+%%+ font MSTT31c1d2\r
+%%+ font MSTT31c1df\r
+%%+ font Palatino-Bold\r
+%%+ font Palatino-Roman\r
+%%+ font Symbol\r
+%%Trailer\r
+SVDoc restore\r
+end\r
+%%Pages: 1\r
+% TrueType font name key:\r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT31c1b9 = 2207DTimes New RomanF00000036000001900000\r
+% MSTT31c1c6 = 2207DCourier NewF00000032000002bc0000\r
+% MSTT31c1d2 = 2207DTimes New RomanF00000021000001900000\r
+% MSTT31c1df = 2207DTimes New RomanF0000002a000001900000\r
+%%DocumentSuppliedResources: procset Win35Dict 3 1\r
+%%+ font MSTT31c1b9\r
+%%+ font MSTT31c1d2\r
+%%+ font MSTT31c1df\r
+\r
+%%DocumentNeededResources: font Courier-Bold\r
+%%+ font Palatino-Bold\r
+%%+ font Palatino-Roman\r
+%%+ font Symbol\r
+\r
+%%EOF\r
+\ 4
\ No newline at end of file
--- /dev/null
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ IIUWGRAF\r
+\r
+ biblioteczka podstawowych procedur graficznych\r
+\r
+ moze wspolpracowac z kompilatorami firmy Microsoft:\r
+\r
+ Fortran 77 wersja 3.31 i 4.00\r
+ Pascal wersja 3.31\r
+\r
+ oraz\r
+ \r
+ C (Lattice) wersja 3.10\r
+ Aztec C wersja 3.20d\r
+\r
+ \r
+\r
+ dla IBM PC/XT\r
+\r
+ obsluguje karty IBM color/graphics, Hercules II oraz EGA\r
+\r
+\r
+\r
+\r
+\r
+\r
+ wersja 2.2, grudzien 1987\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ Autorzy:\r
+\r
+ Piotr Carlson\r
+ Miroslawa Milkowska - procedury poziomu 1\r
+\r
+ Janina Jankowska\r
+ Michal Jankowski - procedury poziomu 2\r
+\r
+\r
+ Osrodek Obliczeniowy Instytutu Informatyki\r
+ Uniwersytet Warszawski\f\r
+\r
+\r
+ 2\r
+\r
+\r
+ \r
+ Spis tresci\r
+ \r
+ \r
+ Informacje ogolne 3\r
+ Procedury poziomu 1 4\r
+ Procedury ustawiania trybu 5\r
+ Procedury sterujace kolorami 8\r
+ Procedury ustawiania pozycji 11\r
+ Procedury obslugujace punkty 12\r
+ Procedury rysowania linii 13\r
+ Procedury operujace na fragmentach ekranu 15\r
+ Procedury wejscia/wyjscia dla pojedynczych znakow 16\r
+ Procedury wejscia/wyjscia dla linii 18\r
+ Procedury wejscia/wyjscia dla okienek 19\r
+ Procedury poziomu 2 20\r
+ Informacje dodatkowe 22\r
+ Procedury dodatkowe 22\r
+ \r
+ \r
+ \r
+ Dodatki\r
+ \r
+ A. Uzycie IIUWGRAFu z FORTRANem 77 23\r
+ B. Uzycie IIUWGRAFu z Pascalem 24\r
+ C. Uzycie IIUWGRAFu z Lattice C 25\r
+ D. Uzycie IIUWGRAFu z LOGLANem 26\r
+ E. Wykaz specyfikacji procedur IIUWGRAFu 27\r
+ F. Wartosci kodow klawiszy specjalnych 29\r
+ G. FEDIT - prosty program do edycji kroju znakow 30\r
+ H. Zmiany IIUWGRAFu w stosunku do poprzednich wersji 33\r
+ \f\r
+\r
+\r
+ 3\r
+\r
+\r
+ \r
+ Informacje ogolne\r
+ \r
+ \r
+\r
+ Rysunek jest tworzony na ekranie monitora za pomoca\r
+ szeregu wywolan procedur bibliotecznych IIUWGRAF. Modyfikuja\r
+ one zawartosc bufora mapy bitowej, ktora jest zwykle\r
+ bezposrednio wyswietlana na ekranie. Zmiany te sa wtedy\r
+ widoczne natychmiast. Umiejscowienie bufora roboczego moze\r
+ byc jednak zmienione, tak aby byl on zwiazany z obszarem\r
+ pamieci dostarczonym przez uzytkownika. W tym przypadku\r
+ zmiany jego zawartosci oczywiscie nie sa wyswietlane, a\r
+ nawet przestawienie monitora w tryb graficzny nie jest\r
+ konieczne. Rysunek moze byc wtedy skonstruowany w pamieci,\r
+ bez wyswietlania, przechowany na dysku w postaci binarnej i\r
+ odtworzony pozniej na ekranie. Omowiony tryb pracy jest\r
+ mozliwy jednak tylko dla karty Hercules II oraz karty IBM.\r
+ W opisie procedur slowo ekran, tam gdzie mowa o jego\r
+ zawartosci, nalezy rozumiec wlasnie jako bufor roboczy.\r
+\r
+ Karty Hercules II oraz EGA daja dodatkowa mozliwosc\r
+ blyskawicznego przelaczania pomiedzy dwiema\r
+ rownouprawnionymi stronami graficznymi.\r
+\r
+ W wersji podstawowej karta graficzna EGA posiada\r
+ 64K bajty pamieci. Pamiec ta moze byc zwiekszona do 128K\r
+ oraz 256K bajtow. Opisane ponizej procedury graficzne\r
+ dotycza w zasadzie karty EGA z pelna pamiecia 256K bajtow.\r
+ Tylko w tej wersji karty mozna bowiem uzywac 16 kolorow\r
+ ( z 64 istniejacych ) oraz dwoch stron graficznych. W obu\r
+ wersjach z mniejsza pamiecia istnieje tylko jedna strona\r
+ graficzna, a ponadto w wersji podstawowej uzytkownik ma\r
+ mozliwosc korzystania tylko z 4 kolorow (z 16 istniejacych).\r
+\r
+ Dostarczone sa cztery zestawy oddzielnych bibliotek\r
+ IIUWGRAF, kazda dla innego rodzaju ekranu:\r
+ \r
+ HGCMSF i HGCMSF4 dla karty Hercules\r
+ MGCMSF i MGCMSF4 dla karty IBM color/graphics\r
+ MGC64MSF i MGC64MF4 dla karty IBM w trybie mono\r
+ EGAMSF i EGAMSF4 dla karty EGA\r
+\r
+ Biblioteki HGCMSF, MGCMSF, MGC64MSF i EGAMSF zgodne\r
+ sa z konwencjami Fortranu ( wersja 3.31 ) i Pascala firmy\r
+ Microsoft. Natomiast biblioteki HGCMSF4, MGCMSF4, MGC64MF4 i\r
+ EGAMSF4 sa zgodne z konwencjami Fortranu ( wersja 4.00 )\r
+ firmy Microsoft. Dodatkowo, kazda biblioteka moze byc\r
+ dostarczona w konwencji Lattice C, oddzielnie dla czterech\r
+ modeli kodu S, P, D i L.\r
+\r
+ Programy uzytkowe komunikuja sie z IIUWGRAFem na\r
+ dwoch poziomach:\r
+ \r
+ poziom 1 - zarzadzanie ekranem na poziomie pixli,\r
+ przy uzyciu prawdziwych wspolrzednych na ekranie,\r
+ \r
+ poziom 2 - rysowanie punktow i linii we\r
+ wspolrzednych abstrakcyjnych.\r
+ \f\r
+\r
+\r
+ 4\r
+\r
+\r
+ \r
+ Procedury poziomu 1\r
+ \r
+ Wszystkie parametry bez podanej explicite\r
+ specyfikacji maja typ integer. Wszystkie parametry calkowite\r
+ powinny miec wartosci 16-bitowe (integer*2 w Fortranie,\r
+ integer w Pascalu, int w C)\r
+\r
+ \r
+ Zakresy wspolrzednych ekranu:\r
+ \r
+ 0 <= ix <= 719\r
+ 0 <= iy <= 347 dla karty Hercules\r
+ \r
+ 0 <= ix <= 319\r
+ 0 <= iy <= 199 dla karty IBM color/graphics\r
+ \r
+ 0 <= ix <= 639\r
+ 0 <= iy <= 199 dla karty IBM color/graphics\r
+ w trybie mono\r
+ 0 <= ix <= 639\r
+ 0 <= iy <= 349 dla karty EGA\r
+ \r
+ \r
+ \r
+ (0,0)-----------> (ix,0)\r
+ |\r
+ |\r
+ |\r
+ V\r
+ (0,iy)\r
+ \f\r
+\r
+\r
+ 5\r
+\r
+\r
+ \r
+ Procedury ustawiania trybu\r
+ \r
+ GRON(i)\r
+ \r
+ Procedura GRON ustawia monitor w graficznym trybie\r
+ pracy, czyszczac zawartosc jego ekranu, ktory jednoczesnie\r
+ staje sie buforem roboczym. Parametr i ma znaczenie jedynie\r
+ dla karty IBM w trybie 320*200: wartosc 1 wybiera normalne\r
+ kolory, wartosc 0 - kolory zmodyfikowane do pracy na\r
+ monitorach monochromatycznych. Dla kart Hercules, EGA oraz\r
+ karty IBM w trybie 640*200 wartosc parametru i jest\r
+ ignorowana. Przy przelaczaniu karty Hercules z trybu\r
+ tekstowego na graficzny i odwrotnie stosowane jest\r
+ programowo opoznienie ok. 3 sekund. Tryb karty IBM ustawiany\r
+ jest wprost, bez pomocy przerwania 10H, tak aby mozliwa byla\r
+ jednoczesna praca na monitorze kolorowym w trybie graficznym\r
+ z praca na monitorze monochromatycznym w trybie tekstowym.\r
+ Konsekwencja tego rozwiazania jest to, ze nie mozna\r
+ korzystac z komendy GRAPHICS. Natomiast tryb karty EGA jest\r
+ ustawiany wprost, za pomoca przerwania 10H.\r
+\r
+ \r
+ \r
+ NOCARD(ple)\r
+ \r
+ Funkcja NOCARD zwraca liczbe calkowita\r
+ identyfikujaca rodzaj monitora obslugiwanego przez biezaco\r
+ uzywana biblioteke:\r
+\r
+ 1 dla karty Hercules\r
+ 2 dla karty IBM w trybie kolor\r
+ 3 dla karty IBM w trybie mono 640*200\r
+ 4 dla karty IBM w trybie mono 320*200\r
+ 5 dla karty EGA\r
+\r
+ Funkcja NOCARD moze byc wywolana dopiero po\r
+ zainicjowaniu trybu graficznego za pomoca procedury GRON.\r
+ Parametr ple jest ignorowany.\r
+\r
+ \r
+ \r
+ GROFF\r
+ \r
+ Procedura GROFF przelacza monitor w tryb tekstowy,\r
+ wypelniajac zawartosc jego ekranu spacjami. Przed\r
+ zakonczeniem dzialania programu monitor, z ktorego byl\r
+ wywolany, nalezy zawsze ustawic z powrotem w tryb tekstowy.\r
+\r
+ \r
+ CLS\r
+ \r
+ Procedura CLS czysci ekran, wypelniajac go kolorem\r
+ 0. Czyszczenie odbywa sie bez wylaczania ekranu.\f\r
+\r
+\r
+ 6\r
+\r
+\r
+ \r
+ HPAGE(nr, tryb, zeruj)\r
+ \r
+ Procedura HPAGE ma zastosowanie jedynie dla kart\r
+ Hercules oraz EGA. Pozwala na dostep do drugiej strony\r
+ graficznej monitora. Wywolanie HPAGE wybiera strone o\r
+ numerze nr (0 lub 1), zeruje jej zawartosc, o ile parametr\r
+ zeruj ma wartosc <> 0, oraz ustawia jej tryb:\r
+\r
+ tryb = 0 wyswietla zawartosc strony alfanumerycznie\r
+ tryb = 1 wyswietla zawartosc strony graficznie\r
+ tryb =-1 przypisuje do tej strony bufor roboczy\r
+ \r
+\r
+ Przypisanie bufora roboczego trybem -1 nie zmienia\r
+ numeru ani sposobu wyswietlania biezacej strony. Tryb 0\r
+ wiaze bufor roboczy z wybrana wlasnie strona. Przelaczanie\r
+ stron odbywa sie bez opoznien, o ile nie ulega zmianie tryb\r
+ wyswietlania (alfanumeryka/grafika). Poza tym, wywolanie\r
+ HPAGE(0,1,1) jest ( tylko dla karty Hercules ) rownowazne\r
+ GRON(), a HPAGE(0,0,1) - wywolaniu GROFF.\r
+\r
+ Typowa petla animacyjna moze byc zatem rozwiazana na\r
+ przyklad tak:\r
+\r
+ VAR NR: INTEGER;\r
+ BEGIN\r
+ GRON(0);\r
+ NR := 1;\r
+ (* NARYSUJ PIERWOTNY OBRAZ *)\r
+ DRAW(...\r
+ ...\r
+ WHILE JESZCZE DO\r
+ HPAGE(1-NR,1,0); (* WYSWIETLANIE *)\r
+ HPAGE(NR,-1,1); (* BUFOROWANIE *)\r
+ (* NARYSUJ ZMODYFIKOWANY OBRAZ *)\r
+ DRAW(...\r
+ ...\r
+ NR := 1-NR\r
+ OD\r
+\r
+ \r
+ VIDEO(tablica)\r
+ \r
+ Procedura VIDEO przelacza bufor roboczy tak, aby\r
+ miescil sie on w tablicy podanej jako parametr jej\r
+ wywolania.\r
+ Samo wywolanie VIDEO nie zmienia zawartosci bufora. Obraz\r
+ wyswietlany na monitorze nie bedzie ulegal teraz zmianom\r
+ mimo wywolywania procedur modyfikujacych zawartosc ekranu.\r
+ Wszelkie odwolania do ekranu beda teraz dokonywane w\r
+ tablicy. Gotowy obraz moze byc przeniesiony na rzeczywisty\r
+ ekran za pomoca procedur GETMAP/PUTMAP lub zapisany binarnie\r
+ na dysku w celu pozniejszego odtworzenia. Tablica powinna\r
+ miec 16K bajtow przy wspolpracy z karta IBM i 32K bajtow\r
+ przy wspolpracy z karta Hercules.\r
+ Procedury VIDEO nie mozna stosowac dla karty EGA.\f\r
+\r
+\r
+ 7\r
+\r
+\r
+ Przyklad:\r
+\r
+ VAR BOK: ARRAY[1..32K] OF BYTE;\r
+ FRAGM: ARRAY[1..MAX] OF BYTE;\r
+ BEGIN\r
+ GRON(1);\r
+ (* NARYSUJ STRONE TYTULOWA *)\r
+ DRAW(...\r
+ ...\r
+ (* SKONSTRUUJ RYSUNEK "NA BOKU" *)\r
+ VIDEO(BOK);\r
+ DRAW(...\r
+ ...\r
+ (* ZAPAMIETAJ FRAGMENT GOTOWEGO RYSUNKU *)\r
+ MOVE(MINX,MINY);\r
+ GETMAP(MAXX,MAXY,FRAGM);\r
+ (* PRZYPISZ Z POWROTEM EKRAN DO MONITORA *)\r
+ GRON(1); (* NIESTETY, CZYSCI EKRAN *)\r
+ MOVE(MINX,MINY);\r
+ PUTMAP(FRAGM);\r
+ ...\r
+\r
+ Uwaga:\r
+ W przypadku wywolania VIDEO(tablica(adres)), wartosc\r
+ wyrazenia adres musi byc postaci 1+k*16, gdzie k=0,1,2,...\r
+ \f\r
+\r
+\r
+ 8\r
+\r
+\r
+ \r
+ Procedury sterujace kolorami\r
+ \r
+ \r
+ COLOR(kolor)\r
+ \r
+ Procedura COLOR ustawia biezacy kolor. W tym\r
+ kolorze beda odtad dokonywane zmiany zawartosci ekranu. Na\r
+ monitorach monochromatycznych kolor 0 oznacza czarny (pixel\r
+ wygaszony), kolor <> 0 oznacza bialy (pixel zapalony).\r
+ Na monitorach kolorowych, dla karty IBM color/graphics,\r
+ kolory maja nastepujace numery:\r
+ \r
+ 0 - tlo (czarny lub ustalony wywolaniem BORDER)\r
+ 1 - zielony lub turkusowy - cyan ( zaleznie od wyboru\r
+ palety)\r
+ 2 - czerwony lub purpurowy - magenta\r
+ 3 - zolty lub bialy\r
+ \r
+ Kolorem ustawionym poczatkowo jest 1.\r
+ \r
+\r
+ Dla karty EGA kolor moze przyjmowac wartosci od 0\r
+ do 15. Znaczenie tego parametru jest okreslone poprzez wybor\r
+ palety ( przyporzadkowanie kazdemu z 16 identyfikatorow\r
+ koloru dowolnego koloru z 64 istniejacych ), dokonywany za\r
+ pomoca procedury PALLET.\r
+ Kolorem ustawionym poczatkowo jest 7.\r
+\r
+ \r
+ STYLE(styl)\r
+ \r
+ Procedura STYLE ustawia biezacy styl, czyli\r
+ kombinacje kolorow uzywana do rysowania odcinkow (DRAW) i\r
+ wypelniania obszarow (HFILL,VFILL). Styl wybiera jeden z\r
+ szesciu nastepujacych sposobow mieszania tla (.) i biezacego\r
+ koloru (*):\r
+\r
+ 0 - ....\r
+ 1 - ****\r
+ 2 - ***.\r
+ 3 - **..\r
+ 4 - *.*.\r
+ 5 - *...\r
+\r
+ Przy rysowaniu odcinkow kolejne pixle beda mialy\r
+ kolor wyznaczony cyklicznie wzorcem stylu. Pierwszy i\r
+ ostatni pixel odcinka bedzie zawsze mial biezacy kolor.\r
+ Przy wypelnianiu, podany wzorzec dotyczy linii poziomych\r
+ (pionowych) ekranu o parzystej wspolrzednej y (x). Wzorzec\r
+ dla linii o wspolrzednych nieparzystych dobierany jest\r
+ automatycznie.\r
+ Inne sposoby mieszania, dopuszczajace uzycie wiekszej liczby\r
+ kolorow sa dostepne za pomoca procedury PATERN.\f\r
+\r
+\r
+ 9\r
+\r
+\r
+ PATERN(par,par1,par2,par3)\r
+ \r
+ Procedura PATERN pozwala rysowac odcinki i\r
+ wypelniac obszary dowolna kombinacja kolorow. Przy rysowaniu\r
+ odcinkow brany jest pod uwage tylko par. Przy wypelnianiu,\r
+ par oraz par2 dotycza linii poziomych (pionowych) o\r
+ wspolrzednych y (x) parzystych, par1 oraz par3 - linii o\r
+ wspolrzednych nieparzystych ( na zmiane kolejno par/par2\r
+ oraz par1/par3 ). Wartosci par,...,par3 przedstawione jako\r
+ czterocyfrowe liczby szesnastkowe daja wzorce mieszania\r
+ numerow kolorow. 0 oznacza tlo, inne cyfry - zob. opis\r
+ procedury COLOR.\r
+\r
+ Przyklad:\r
+\r
+ PATERN(#1100,#0011,#1100,#0011);\r
+ ODPOWIADA: COLOR(1); STYLE(3);\r
+\r
+ natomiast efekt:\r
+\r
+ PATERN(#1212,#0303,#2121,#3030);\r
+ NIE MOzE BYC UZYSKANY INACZEJ\r
+\r
+ \r
+ BORDER(kolor)\r
+ \r
+ Procedura BORDER ustawia biezacy kolor tla.\r
+ \r
+ kolor kolor\r
+ \r
+ 0 czarny\r
+ 1 niebieski\r
+ 2 zielony\r
+ 3 turkusowy - cyan (niebiesko-zielony)\r
+ 4 czerwony\r
+ 5 karmazynowy - magenta (czerwono-niebieski)\r
+ 6 zolty\r
+ 7 jasno szary\r
+ \r
+ Kolory 8 - 15 to jasniejsze odcienie kolorow 0 - 7, przy\r
+ czym kolor bialy ma numer 15.\r
+\r
+ Przedstawione powyzej kolory dotycza tylko karty IBM, dla\r
+ karty EGA natomiast parametr kolor moze przyjmowac wartosci\r
+ od 0 do 63.\r
+ \r
+ \r
+ PALLET(nr)\r
+ \r
+ Dla karty IBM color/graphics :\r
+ \r
+ procedura PALLET wybiera biezaca palete z dwu\r
+ mozliwych\r
+ \r
+\r
+ nr kolory\r
+ \r
+ 0 turkusowy,karmazynowy,bialy\r
+ 1 zielony,czerwony,zolty\r
+ \f\r
+\r
+\r
+ 10\r
+\r
+\r
+ Domyslna paleta jest paleta nr 0.\r
+\r
+ Dla karty EGA natomiast procedura PALLET sluzy do\r
+ wyboru dowolnych 16 kolorow z 64 ogolnie dostepnych.\r
+ Parametr nr powinien byc postaci\r
+ kolor16 * 256 + kolor64,\r
+ gdzie\r
+ kolor16 oznacza identyfikator koloru ( uzywany\r
+ przez procedure COLOR ), mogacy przyjmowac wartosci 0 - 15,\r
+ kolor64 oznacza wybrany kolor.\r
+ \r
+\r
+ Standardowa paleta ( przyjmowana domyslnie )\r
+ zawiera nastepujace kolory :\r
+ \r
+ identyfikator kolor numer koloru\r
+ \r
+ 0 czarny 0\r
+ 1 niebieski 1\r
+ 2 zielony 2\r
+ 3 turkusowy 3\r
+ 4 czerwony 4\r
+ 5 karmazynowy 5\r
+ 6 zolty 6\r
+ 7 bialy 7\r
+ 8 szary 56\r
+ 9 jasno-niebieski 57\r
+ 10 jasno-zielony 58\r
+ 11 jasno-turkusowy 59\r
+ 12 jasno-czerwony 60\r
+ 13 jasno-karmazynowy 61\r
+ 14 jasno-zolty 62\r
+ 15 intensywny bialy 63\r
+ \r
+\r
+ Wszystkie dostepne kolory mozna obejrzec oraz\r
+ poznac ich numery za pomoca programu demonstracyjnego\r
+ EGADEMO.EXE.\r
+\r
+ Procedura PALLET nie ma zastosowania dla karty\r
+ Hercules.\r
+\r
+ \r
+ \r
+ INTENS(i)\r
+ \r
+ Procedura INTENS wybiera intensywnosc kolorow.\r
+ Dla i rownego 0 intensywnosc jest wieksza, dla i rownego 1\r
+ mniejsza.\r
+ Domyslnie intensywnosc jest ustawiona na poziomie 0.\r
+ \r
+ Procedura INTENS ma zastosowanie tylko dla karty IBM.\f\r
+\r
+\r
+ 11\r
+\r
+\r
+ \r
+ Procedury ustawiania pozycji\r
+ \r
+ \r
+ MOVE(x,y)\r
+ \r
+ Procedura MOVE ustawia biezaca pozycje na ekranie\r
+ na pixel o wspolrzednych (x {kolumna}, y {wiersz}).\r
+\r
+ \r
+ INXPOS(ple), INYPOS(ple)\r
+ \r
+ Funkcje calkowite INXPOS i INYPOS zwracaja\r
+ odpowiednio wspolrzedne x i y biezacej pozycji. Parametr ple\r
+ jest ignorowany.\r
+\r
+ \r
+ PUSHXY\r
+ \r
+ Procedura PUSHXY powoduje przechowanie biezacej\r
+ pozycji, koloru i stylu na wierzcholku wewnetrznego stosu\r
+ IIUWGRAFu. Parametry te nie ulegaja przy tym zmianie.\r
+ Maksymalna glebokosc stosu wynosi 16.\r
+\r
+ \r
+ POPXY\r
+ \r
+ Procedura POPXY odtwarza biezacy styl, kolor i\r
+ pozycje z wierzcholka wewnetrznego stosu IIUWGRAFu.\r
+ Glebokosc stosu zmniejsza sie o 1.\r
+\r
+ \r
+ \r
+ Przyklad:\r
+ \r
+\r
+ PROCEDURE SKOS;\r
+ VAR IX,IY:INTEGER;\r
+ BEGIN\r
+ PUSHXY;\r
+ IX := INXPOS(0);\r
+ IY := INYPOS(0);\r
+ DRAW(IX+10,IY+10);\r
+ POPXY;\r
+ END;\f\r
+\r
+\r
+ 12\r
+\r
+\r
+ \r
+ TRACK(x,y)\r
+ \r
+ Procedura TRACK wyswietla na ekranie wskaznik w\r
+ ksztalcie malej (8*8 pixli) strzalki, skierowanej na punkt o\r
+ wspolrzednych (x,y). Wskaznik ten moze byc przesuwany po\r
+ ekranie za pomoca klawiszy kierunkowych. Nacisniecie\r
+ klawisza powoduje przesuniecie wskaznika o 5 pixli.\r
+ Nacisniecie odpowiedniego klawisza w trybie numerycznym\r
+ przesuwa wskaznik o 1 pixel. Klawisz "home" powoduje powrot\r
+ wskaznika do pozycji (x,y). Klawisz "End" usuwa wskaznik z\r
+ ekranu i powoduje powrot z procedury, pozostawiajac biezaca\r
+ pozycje w tym miejscu. Moze byc ona teraz odczytana za\r
+ pomoca funkcji INXPOS i INYPOS.\r
+\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ Procedury obslugujace punkty\r
+ \r
+ \r
+ POINT(x,y)\r
+ \r
+ Procedura POINT ustawia biezaca pozycje w punkcie\r
+ (x,y) i zmienia jego kolor na biezacy.\r
+\r
+ \r
+ INPIX(x,y)\r
+ \r
+ Funkcja INPIX ustawia biezaca pozycje w punkcie\r
+ (x,y) i zwraca jego kolor.\f\r
+\r
+\r
+ 13\r
+\r
+\r
+ \r
+ Procedury rysowania linii\r
+ \r
+ \r
+ DRAW(x,y)\r
+ \r
+ Procedura DRAW rysuje odcinek od biezacej pozycji\r
+ do pozycji o wspolrzednych (x,y). Rysowanie polega na\r
+ zmianie koloru pixli nalezacych, wedlug algorytmu\r
+ Bresenhama, do odcinka. Pixle te przyjmuja nowy stan\r
+ zaleznie od biezacego koloru i stylu.\r
+\r
+ \r
+ \r
+ CIRB(x,y,r,alfa,beta,kolb,wwyp,p,q)\r
+ \r
+ Procedura CIRB rysuje na ekranie wycinek okregu\r
+ lub elipsy, zaleznie od podanych wartosci p i q,\r
+ okreslajacych aspekt. Aspekt wyznaczony jest stosunkiem p/q.\r
+ Dla wartosci aspektu rownej 1 zostanie narysowany idealny\r
+ okrag. Srodek bedzie umieszczony w punkcie (x,y), promien\r
+ poziomy bedzie mial wielkosc r pixli, alfa i beta okreslaja,\r
+ odpowiednio kat poczatkowy i koncowy rysowanego wycinka. Dla\r
+ alfa = beta zostanie narysowany pelny okrag (lub elipsa).\r
+ Wartosci alfa i beta sa wyrazane w radianach, w zwyklym\r
+ ukladzie. Brzeg wycinka i jego promienie zostana narysowane\r
+ kolorem kolb, niezaleznie od stylu. Jesli wwyp <> 0, wnetrze\r
+ wycinka zostanie wypelnione biezacym kolorem i stylem.\r
+\r
+ \r
+ HFILL(x)\r
+ \r
+ Procedura HFILL rysuje, w biezacym kolorze i stylu,\r
+ odcinek poziomy od biezacej pozycji do punktu o\r
+ wspolrzednych\r
+ \r
+ (x,inypos(0))\r
+ \r
+ OSTROZNIE: HFILL nie zmienia biezacej pozycji.\r
+\r
+ Uzycie HFILL jest zalecane przy wypelnianiu\r
+ obszarow, gdyz dziala znacznie szybciej niz odpowiedni DRAW.\r
+ Rowniez mieszajac kolory w danym stylu, HFILL, w\r
+ przeciwienstwie do DRAW nie bierze pod uwage poczatkowego\r
+ punktu odcinka, co pozwala na uzyskanie substytutu\r
+ dodatkowych kolorow.\r
+\r
+ \f\r
+\r
+\r
+ 14\r
+\r
+\r
+ VFILL(y)\r
+ \r
+ \r
+ Procedura VFILL rysuje, w biezacym kolorze i stylu,\r
+ odcinek pionowy od biezacej pozycji do punktu o\r
+ wspolrzednych\r
+ \r
+ (inxpos(0),y)\r
+ \r
+ OSTROZNIE: VFILL nie zmienia biezacej pozycji.\f\r
+\r
+\r
+ 15\r
+\r
+\r
+ \r
+ Procedury operujace na fragmentach ekranu\r
+ \r
+ \r
+ GETMAP(x,y,tablica)\r
+ \r
+ Procedura GETMAP zapamietuje prostokatny obszar\r
+ ekranu pomiedzy biezaca pozycja jako lewym gornym rogiem a\r
+ punktem (x,y) jako prawym dolnym rogiem w tablicy. GETMAP\r
+ nie zmienia przy tym biezacej pozycji. Tablica powinna miec\r
+ co najmniej 4 + w*sufit(k/8)*kol bajtow, gdzie w i k sa,\r
+ odpowiednio, liczba wierszy i kolumn zapamietywanego\r
+ obszaru, natomiast wartosc wspolczynnika kol zalezy od\r
+ rodzaju karty graficznej i wynosi 1 dla karty Hercules,\r
+ 2 dla karty IBM oraz 4 dla karty EGA.\r
+\r
+ Przyklad: zapamietanie obszaru 101*101 polozonego w lewym\r
+ gornym rogu ekranu.\r
+\r
+ VAR OKNO: ARRAY[1..700] OF INTEGER;\r
+ \r
+ ...\r
+ MOVE(0,0);\r
+ GETMAP(100,100,OKNO);\r
+ ...\r
+ \r
+\r
+ \r
+ PUTMAP(tablica)\r
+ \r
+ Procedura PUTMAP ustawia prostokatny obszar ekranu\r
+ o lewym gornym rogu znajdujacym sie w biezacej pozycji\r
+ zgodnie z zawartoscia tablicy, w ktorej uprzednio\r
+ zapamietano fragment ekranu za pomoca procedury GETMAP.\r
+ Biezaca pozycja nie ulega zmianie. Odtworzeniu podlega caly\r
+ zapamietany obszar, ktory jest kopiowany w nowe miejsce.\r
+\r
+ \r
+ ORMAP(tablica)\r
+ \r
+ Procedura ORMAP dziala podobnie jak PUTMAP, lecz o\r
+ nowej zawartosci ekranu decyduje wynik zastosowania funkcji\r
+ or do elementow tablicy i ekranu.\r
+\r
+ \r
+ XORMAP(tablica)\r
+ \r
+ Procedura XORMAP dziala podobnie jak PUTMAP, lecz o\r
+ nowej zawartosci ekranu decyduje wynik zastosowania funkcji\r
+ xor do elementow tablicy i ekranu.\f\r
+\r
+\r
+ 16\r
+\r
+\r
+ \r
+ Procedury wejscia/wyjscia dla pojedynczych znakow\r
+ \r
+ \r
+ INKEY(ple)\r
+ \r
+ Funkcja calkowita INKEY podaje i usuwa nastepny\r
+ znak z bufora klawiatury. Czytanie odbywa sie bez echa.\r
+ Jesli bufor jest pusty, wynikiem jest 0. Klawisze specjalne\r
+ kodowane sa jako liczby ujemne wedlug zalaczonej tablicy.\r
+ Metoda ALT-NUM moze byc uzyta do wprowadzenia z klawiatury\r
+ kodow powyzej 127 jako zwyklych znakow. Uniemozliwia to,\r
+ niestety, korzystanie ze znakow specjalnych o kodach od 128\r
+ do 132.\r
+\r
+ Przyklad: zaczekaj na klawisz End.\r
+\r
+ PROCEDURE WAIT_FOR_END;\r
+ BEGIN\r
+ WHILE INKEY(0)<>-79 DO;\r
+ END;\r
+\r
+ Wartosci kodow klawiszy specjalnych podane sa w Dodatku F.\r
+ \r
+ \r
+ HASCII(kod)\r
+ \r
+ Procedura HASCII rysuje na ekranie znak\r
+ alfanumeryczny. Znak wpisany jest w raster 8*8. Gorny lewy\r
+ rog rastra umieszczony bedzie w biezacej pozycji, ktora\r
+ jednoczesnie przesunie sie o 8 pixli w prawo. Uzyta funkcja\r
+ rysujaca jest xor. Kroj znakow pobierany jest z tablicy\r
+ znajdujacej sie w ROM BIOS standardowo pod adresem\r
+ F000:FA6E. W przypadku niestandardowego ROM BIOSu obraz\r
+ znaku alfanumerycznego bedzie zly. Uzycie procedur HFONT i\r
+ HFONT8 pozwala uniezaleznic sie od wersji BIOSu a takze\r
+ korzystac z innych, rowniez wlasnorecznie zaprojektowanych\r
+ krojow znakow. Kod znaku 0 powoduje tylko wyczyszczenie\r
+ miejsca przeznaczonego na znak, bez zmiany biezacej pozycji.\r
+ Wszystkie kody maja tylko interpretacje graficzna, bez\r
+ funkcji sterujacych (NL, CR etc.).\r
+\r
+ Przyklad: napisanie slowa "oh" na gwarantowanie czystym tle.\r
+ \r
+\r
+ HASCII(0); HASCII('o'); HASCII(0); HASCII('h');\r
+\r
+ Uwaga:\r
+ Parametr procedury HASCII moze byc typu integer lub\r
+ znakowego ( character w Fortranie, char w Pascalu i C ).\r
+ \f\r
+\r
+\r
+ 17\r
+\r
+\r
+ \r
+ HFONT(segment,offset)\r
+ \r
+ Wywolanie procedury HFONT przelacza adres wzorca\r
+ znakow alfanumerycznych na segment:offset. Bez uzycia HFONT\r
+ uzywa sie adresu F000:FA6E.\r
+\r
+ \r
+ HFONT8(segment,offset)\r
+ \r
+ Uzycie procedury HFONT8 dolacza do programu\r
+ uzytkowego kopie tablicy kroju znakow z ROM BIOS i zwraca\r
+ adres tej kopii jako segment:offset (parametry wyjsciowe).\r
+\r
+ \f\r
+\r
+\r
+ 18\r
+\r
+\r
+ \r
+ Procedury wejscia/wyjscia dla linii\r
+ \r
+ \r
+ OUTHLINE(dlugosc,bufor)\r
+ \r
+ Procedura OUTHLINE wywoluje HASCII dlugosc razy,\r
+ wypisujac na ekran znaki, ktorych kody zawarte sa w buforze.\r
+ Przed narysowaniem kazdego znaku wywolywane jest HASCII(0).\r
+\r
+ \r
+ INHLINE(dlugosc,bufor)\r
+ \r
+ Procedura INHLINE wczytuje z klawiatury linie\r
+ zlozona z co najwyzej dlugosci znakow i umieszcza je w\r
+ buforze. Do wczytywania uzyta jest procedura INKEY.\r
+ Wyswietlane jest echo. Migajacy wskaznik oznacza oczekiwanie\r
+ na nacisniecie klawisza. Klawisz BACKSPACE dziala tak, jak\r
+ mozna tego oczekiwac. Linia moze byc zakonczona klawiszem CR\r
+ albo wyczerpaniem jej dlugosci. Znak CR konczacy linie nie\r
+ jest umieszczany w buforze. Przed rozpoczeciem czytania\r
+ bufor jest wypelniany spacjami. Po zakonczeniu czytania\r
+ parametr dlugosc zwraca liczbe wczytanych znakow.\r
+ Migajacy wskaznik jest zawsze rysowany kolorem numer 1,\r
+ wyswietlane znaki natomiast biezacym kolorem.\r
+\r
+ \r
+ Przyklad: echo wczytanej linii.\r
+\r
+ VAR LINIA: ARRAY[1:40] OF INTEGER;\r
+ N: INTEGER;\r
+ BEGIN\r
+ N:=80;\r
+ INHLINE(N,LINIA);\r
+ IF N=0 THEN MOVE(INXPOS(0),INYPOS(0)+10)\r
+ ELSE OUTHLINE(N,LINIA);\r
+ ...\r
+\r
+ \f\r
+\r
+\r
+ 19\r
+\r
+\r
+ \r
+ Procedury wejscia/wyjscia dla okienek\r
+ \r
+ \r
+ MKWNDW(x,y,kolumn,wierszy,okienko,rozmiar,ramka)\r
+ \r
+ Procedura MKWNDW urzadza na ekranie prostokatne\r
+ okienko do konwersacji. Lewy gorny rog okienka znajdzie sie\r
+ w punkcie (x,y). Zmiesci ono zadana liczbe kolumn i wierszy\r
+ tekstu alfanumerycznego. Opis okienka bedzie przechowany w\r
+ dostarczonej przez uzytkownika tablicy okienko. Parametr\r
+ rozmiar jest na razie ignorowany, a tablica powinna miec co\r
+ najmniej 20 bajtow, lub duzo wiecej, jesli okienko ma byc\r
+ zaslaniane i odslaniane ( patrz opis procedury BURY ). Jesli\r
+ parametr ramka ma wartosc rozna od 0, obszar okienka bedzie\r
+ obwiedziony ramka, co uczyni je nieco wiekszym.\r
+\r
+ \r
+ BURY(okienko)\r
+ \r
+ Wywolanie BURY usuwa okienko z ekranu, przechowujac\r
+ jego obraz w dalszej czesci tablicy okienko tak, aby moc\r
+ odtworzyc je pozniej za pomoca EXPOSE. Tablica okienko musi\r
+ miec odpowiednia wielkosc, aby GETMAP obszaru okienka\r
+ pozostawilo w niej jeszcze co najmniej 20 bajtow.\r
+\r
+ \r
+ EXPOSE(okienko,x,y)\r
+ \r
+ Wywolanie EXPOSE odtwarza okienko przechowane za\r
+ pomoca BURY umieszczajac jego gorny lewy rog w punkcie\r
+ (x,y).\r
+\r
+ \r
+ OUTWLINE(okienko,dlugosc,bufor)\r
+ \r
+ Procedura OUTWLINE dziala podobnie jak OUTHLINE,\r
+ wyswietlajac linie w ramach podanego okienka. Bufor o\r
+ dlugosci wiekszej niz rozmiar okienka wyswietli sie w kilku\r
+ liniach.\r
+\r
+ \r
+ INWLINE(okienko,dlugosc,bufor)\r
+ \r
+ Procedura INWLINE, podobnie jak INHLINE, wczytuje z\r
+ klawiatury linie tekstu. W przypadku INWLINE okienko\r
+ wskazuje na obszar ekranu, w ktorym ma pojawiac sie echo.\r
+ Jesli dlugosc bufora jest wieksza niz rozmiar okienka echo\r
+ moze zajac w nim kilka linii. Poprawianie wprowadzanego\r
+ tekstu przy uzyciu BACKSPACE jest mozliwe tylko w ostatniej\r
+ czesci linii. Dlugosc jako parametr wyjsciowy zwraca liczbe\r
+ wczytanych znakow, bez konczacego CR.\f\r
+\r
+\r
+ 20\r
+\r
+\r
+ \r
+ Procedury poziomu 2\r
+ \r
+ \r
+ Procedury te operuja wspolrzednymi wyrazonymi\r
+ liczbami rzeczywistymi odnoszacymi sie do abstrakcyjnego\r
+ okna o dowolnych rozmiarach.\r
+\r
+ \r
+ \r
+ Definiowanie okna\r
+ \r
+ \r
+ SWINDOW(rxy,ixy,skalowanie)\r
+ \r
+ Procedura SWINDOW urzadza na ekranie prostokatne\r
+ okno umieszczone pomiedzy punktami naroznikowymi podanymi w\r
+ tablicy ixy jako calkowite wspolrzedne prawdziwych pixli.\r
+ Program uzytkowy tworzacy rysunek w tym obszarze bedzie\r
+ okreslal polozenie punktow w sposob abstrakcyjny we\r
+ wspolrzednych rzeczywistych. Tablica rxy podaje zakresy tych\r
+ wspolrzednych. Jesli parametr skalowanie ma wartosc 0,\r
+ abstrakcyjny prostokat bedzie po prostu odwzorowany na\r
+ wskazana czesc ekranu bez zachowania proporcji miedzy\r
+ skalowaniem w pionie i w poziomie. Jesli natomiast parametr\r
+ skalowanie bedzie rozny od zera, wykorzystana zostanie\r
+ jedynie srodkowa czesc obszaru ekranu tak, aby zachowac\r
+ rzeczywiste proporcje rysunku, niezaleznie od aspektu danego\r
+ monitora.\r
+ Odwzorowanie stosowane przez IIUWGRAF odwraca tez kierunek\r
+ wzrastania wspolrzednej y do naturalnego ukladu:\r
+ \r
+ \r
+ (ixy(1),ixy(3))\r
+ /\r
+ (rxy(1),rxy(4))\r
+ ^\r
+ |\r
+ |\r
+ |\r
+ | (ixy(1),ixy(4)) (ixy(2),ixy(4))\r
+ | / /\r
+ (rxy(1),rxy(3))--------------------->(rxy(2),rxy(3))\r
+ \r
+ \r
+ Przyklad: przygotowanie rysunku sinusoidy w gornej polowie\r
+ ekranu Herculesa.\r
+\r
+\r
+ VAR RW:ARRAY [1:4] OF REAL INIT (0.,6.29,-1.,1.);\r
+ IW:ARRAY [1:4] OF INTEGER INIT (0,719,0,173);\r
+ BEGIN\r
+ SWINDOW(RW,IW,0);\r
+ \f\r
+\r
+\r
+ 21\r
+\r
+\r
+ RWINDOW(rxy,skalowanie)\r
+\r
+ Procedura RWINDOW jest skrotem wywolania SWINDOW\r
+ dla odwzorowania obejmujacego caly ekran.\r
+\r
+ \r
+ \r
+ RINXPOS(ple),RINYPOS(ple)\r
+ \r
+ Funkcje rzeczywiste RINXPOS i RINYPOS zwracaja,\r
+ odpowiednio wspolrzedne x i y biezacej pozycji w\r
+ abstrakcyjnym oknie urzadzonym przez ostatnie wywolanie\r
+ RWINDOW lub SWINDOW. Biezaca pozycja jest zawsze zaokraglana\r
+ do najblizszego pixla.\r
+\r
+ \r
+ \r
+ RMOVE(rx,ry)\r
+ \r
+ Wywolanie procedury RMOVE ustawia biezaca pozycje w\r
+ punkcie (rx,ry) w ostatnio urzadzonym oknie. Pozycja ta jest\r
+ zaokraglona do najblizszego pixla.\r
+\r
+ \r
+ \r
+ RDRAW(rx,ry)\r
+ \r
+ Wywolanie procedury RDRAW powoduje narysowanie w\r
+ biezacym kolorze i stylu odcinka od biezacej pozycji do\r
+ pixla najblizszego punktowi (rx,ry) w ostatnio urzadzonym\r
+ oknie.\r
+\r
+ \r
+ \r
+ RCIRB(rx,ry,rr,alfa,beta,kolb,wwyp,p,q)\r
+ \r
+ Procedura RCIRB odpowiada procedurze CIRB z poziomu\r
+ 1, z tym, ze wspolrzedne srodka (rx,ry) i promien rr\r
+ wyrazane sa, jako liczby rzeczywiste, w oknie urzadzonym\r
+ przez ostatnie wywolanie RWINDOW lub SWINDOW. Pozostale\r
+ parametry maja znaczenie takie, jak w CIRB.\f\r
+\r
+\r
+ 22\r
+\r
+\r
+ \r
+ Informacje dodatkowe\r
+ \r
+ \r
+ Pakiet IIUWGRAF zawiera dodatkowo dwa programy\r
+ HGCPRINT.EXE oraz MGCPRINT.EXE. Umozliwiaja one drukowanie\r
+ tworzonych obrazow graficznych na powszechnie dostepnych\r
+ drukarkach ( np. typu STAR GEMINI, EPSON ). W przypadku\r
+ uzywania karty Hercules nalezy stosowac program HGCPRINT, a\r
+ dla karty IBM color/graphics program MGCPRINT.\r
+\r
+ Programow tych powinno uzywac sie w nastepujacy\r
+ sposob :\r
+ przed zaladowaniem wlasnego programu nalezy wykonac\r
+ program HGCPRINT lub MGCPRINT, w zaleznosci od rodzaju\r
+ uzywanej karty graficznej. Kazdy z tych programow ustawia\r
+ znaczenie klawisza PrtSc. Kazdorazowe pozniejsze nacisniecie\r
+ klawisza PrtSc powoduje wydrukowanie graficznej zawartosci\r
+ ekranu.\r
+ \r
+ Uwaga. W przypadku karty Hercules drukowana jest\r
+ zawartosc pierwszej strony graficznej, niezaleznie od tego,\r
+ ktora strona jest aktualnie wyswietlana.\r
+ W przypadku karty IBM color/graphics klawisz PrtSc\r
+ zaklada, ze jest ustawiony tryb kolor 320*200. Wydruk obrazu\r
+ graficznego utworzonego w trybie mono 640*200 jest mozliwe\r
+ poprzez uzycie procedury PRTSCR.\r
+\r
+ Mozliwosc drukowania obrazu graficznego nie\r
+ istnieje dla karty EGA.\r
+\r
+ Autorem programow HGCPRINT oraz MGCPRINT jest\r
+ Krzysztof Studzinski.\r
+\r
+ \r
+ \r
+ \r
+ Procedury dodatkowe\r
+ \r
+ \r
+ PRTSCR(nr)\r
+ \r
+ Procedura PRTSCR umozliwia drukowanie obrazow\r
+ graficznych tworzonych na ekranie monitora pod kontrola\r
+ programu. Parametr nr okresla numer strony graficznej\r
+ (0 lub 1), ktorej zawartosc ma byc wydrukowana.\r
+\r
+ Wywolanie procedury PRTSCR z parametrem nr rownym\r
+ zeru jest rownowazne nacisnieciu klawisza PrtSc.\r
+\r
+ W celu poprawnego dzialania tej procedury nalezy,\r
+ analogicznie jak w przypadku klawisza PrtSc, uprzednio\r
+ wykonac dolaczony program :\r
+ - HGCPRINT.EXE w przypadku uzywania karty\r
+ Hercules lub\r
+ - MGCPRINT.EXE dla karty IBM.\r
+\r
+ Procedura PRTSCR nie dziala dla karty EGA.\r
+\r
+ \f\r
+\r
+\r
+ 23\r
+\r
+\r
+ \r
+\r
+ DODATEK A\r
+\r
+ Uzycie IIUWGRAFu z FORTRANem 77.\r
+ \r
+ \r
+ 1) Procedury IN?LINE i OUT?LINE dokonuja jedynie\r
+ transmisji tekstu, bez zadnej konwersji pomiedzy postacia\r
+ binarna i tekstowa. Aby takiej konwersji dokonac, mozna\r
+ posluzyc sie instrukcjami formatowanego wejscia/wyjscia\r
+ w polaczeniu z tzw. plikami wewnetrznymi (internal file).\r
+\r
+ Przyklad:\r
+\r
+\r
+ INTEGER*2 I,J,SUM,W(10)\r
+ CHARACTER*20 LINE\r
+ CHARACTER LINEL(20)\r
+ EQUIVALENCE (LINE,LINEL(1))\r
+ \r
+ ...\r
+ CALL MKWNDW(10,10,21,4,W,20,1)\r
+ CALL OUTWLINE(W,20,'PODAJ 2 LICZBY (2I3)')\r
+ CALL INWLINE(W,20,LINEL)\r
+ READ (LINE,'(2I3)') I,J\r
+ SUM=I+J\r
+ WRITE (LINE,'(8H SUMA = I4)') SUM\r
+ CALL OUTWLINE(W,12,LINEL) \f\r
+\r
+\r
+ 24\r
+\r
+\r
+\r
+ \r
+\r
+ DODATEK B\r
+\r
+ Uzycie IIUWGRAFu z PASCALem.\r
+ \r
+ \r
+ 1) Microsoft Pascal dopuszcza jedynie 6 znakow w nazwie\r
+ podprogramu, zatem nazwy: INHLIN(E), INWLIN(E), OUTHLI(NE),\r
+ OUTWLI(NE), RWINDO(W), SWINDO(W), RINXPO(S), RINYPO(S) musza\r
+ byc uzywane w skroconej postaci.\r
+ \r
+ 2) Niektore procedury IIUWGRAFu sa napisane w FORTRANie.\r
+ Przy linkowaniu LINK moze domagac sie dostarczenia\r
+ biblioteki FORTRAN.LIB. Zadanie to nalezy zignorowac.\r
+ \r
+ 3) Do linkowania nalezy uzywac LINK w wersji co najmniej\r
+ 3.04, do kompilacji Pascal w wersji co najmniej 3.31.\f\r
+\r
+\r
+ 25\r
+\r
+\r
+ \r
+\r
+ DODATEK C\r
+\r
+ Uzycie IIUWGRAFu z Lattice C.\r
+ \r
+ \r
+ 1) Nalezy unikac konfliktow z nazwami globalnych zmiennych\r
+ roboczych IIUWGRAFu. Zmienne te maja nazwy rozpoczynajace\r
+ sie od liter WIR... i PQASP...\r
+ \r
+ 2) W przypadku procedur majacych parametry wyjsciowe ( w\r
+ dodatku E sa one zaznaczone jako vars ) nalezy przy ich\r
+ wywolaniu przekazywac adres odpowiedniego parametru\r
+ aktualnego.\r
+ \r
+ Przyklad:\r
+ \r
+\r
+ CHAR LENGTH;\r
+ CHAR *TEXT;\r
+ ...\r
+ INHLINE(&LENGTH,TEXT)\r
+ \r
+\r
+\r
+ 3) Adresy parametrow aktualnych nalezy przekazywac rowniez\r
+ w przypadku parametrow bedacych tablicami znakowymi.\r
+\r
+\r
+ Przyklad:\r
+\r
+\r
+ INT LENGTH;\r
+ CHAR *TEXT; /* LUB NP. CHAR TEXT[40]; */\r
+ ...\r
+ OUTHLINE(LENGTH, &TEXT[3]);\r
+ /* WYPISZ ZNAKI Z TABLICY 'TEXT', ROZPOCZYNAJAC OD\r
+ CZWARTEGO */\r
+ \f\r
+\r
+\r
+ 26\r
+\r
+\r
+ \r
+\r
+ DODATEK D\r
+\r
+ Uzycie IIUWGRAFu z LOGLANem.\r
+ \r
+ \r
+ 1) W biezacej wersji LOGLANu dostepnych jest jedynie 7\r
+ podstawowych procedur: GRON, GROFF, MOVE, DRAW, HASCII,\r
+ HPAGE, INKEY obslugujacych wylacznie karte Hercules.\r
+ \r
+ 2) System okienek do konwersacji nie bedzie w LOGLANie\r
+ dostepny w postaci procedur standardowych. Podobnie okienka\r
+ o wspolrzednych rzeczywistych.\r
+ \r
+ 3) Niektore podprogramy dostepne jako funkcje standardowe\r
+ LOGLANu musza miec zmienione specyfikacje parametrow w\r
+ stosunku do oryginalnego IIUWGRAFu:\r
+ \r
+ IIUWGRAF LOGLAN\r
+ \r
+ GETMAP GETMAP:function:array of ?\r
+ INKEY INKEY:integer function; (* bez parametrow *)\r
+ INXPOS INXPOS:integer function;(* bez parametrow *)\r
+ INYPOS INYPOS:integer function;(* bez parametrow *)\r
+ \f\r
+\r
+\r
+ 27\r
+\r
+\r
+ \r
+\r
+ DODATEK E\r
+\r
+ Wykaz specyfikacji procedur IIUWGRAFu.\r
+ \r
+ \r
+ proc BORDER(consts b: integer);\r
+ L proc BURY(window: buffer);\r
+ proc CIRB(consts ix,iy,ir: integer;\r
+ consts alfa, beta: real;\r
+ consts cbord, bcint, p, q: integer);\r
+ proc CLS;\r
+ proc COLOR(consts c: integer);\r
+ proc DRAW(consts ix,iy: integer);\r
+ L proc EXPOSE(window: buffer; consts x,y: integer);\r
+ L proc GETMAP(consts x,y: integer; ekran: buffer);\r
+ L proc GROFF;\r
+ proc GRON(consts imode: integer);\r
+ proc HASCII(consts ic: integer);\r
+ proc HFILL(consts maxx: integer);\r
+ proc HFONT(consts seg, offs: integer);\r
+ proc HFONT8(vars seg, offs: integer);\r
+ proc HPAGE(consts page, mode, clear: integer);\r
+ P proc INHLINE(vars n:integer; line: tekst);\r
+ L func INKEY(consts idummy: integer): integer;\r
+ func INPIX(consts x,y: integer): integer;\r
+ proc INTENS(consts i: integer);\r
+ PL proc INWLINE(window: buffer; vars n: integer;\r
+ line: tekst);\r
+ L func INXPOS(consts idummy: integer): integer;\r
+ L func INYPOS(consts idummy: integer): integer;\r
+ L proc MKWNDW(consts x,y,icols,ilines: integer;\r
+ window: buffer;\r
+ consts iwndwsize,iborder: integer);\r
+ proc MOVE(consts ix,iy: integer);\r
+ L func NOCARD(consts idummy: integer): integer;\r
+ proc ORMAP(ekran: buffer);\r
+ PL proc OUTHLINE(consts n:integer; line: tekst);\r
+ PL proc OUTWLINE(window: buffer; consts n: integer;\r
+ line: tekst);\r
+ proc PALLET(consts p: integer);\r
+ proc PATERN(consts p1, p2, p3, p4: integer);\r
+ proc POINT(consts ix,iy: integer);\r
+ proc POPXY;\r
+ proc PRTSCR(consts nr: integer);\r
+ proc PUSHXY;\r
+ proc PUTMAP(ekran: buffer);\r
+ L proc RCIRB(consts ix,iy,ir: real;\r
+ consts alfa, beta: real;\r
+ consts cbord, bcint, p, q: integer);\r
+ L proc RDRAW(consts rx,ry: real);\r
+ PL func RINXPOS(consts dummy: real): real;\r
+ PL func RINYPOS(consts dummy: real): real;\r
+ L proc RMOVE(consts rx,ry: real);\r
+ PL proc RWINDOW(rw: array [1:4] of real;\r
+ consts s: integer);\r
+ proc STYLE(consts s: integer);\f\r
+\r
+\r
+ 28\r
+\r
+\r
+ PL proc SWINDOW(rw: array [1:4] of real;\r
+ iw: array [1:4] of integer;\r
+ consts s: integer);\r
+ proc TRACK(consts x,y: integer);\r
+ proc VFILL(consts maxy: integer);\r
+ proc VIDEO(ekran: buffer);\r
+ proc XORMAP(ekran: buffer);\r
+ \r
+ Uzyto notacji semi-pascalowej.\r
+ Specyfikacja consts oznacza parametr przekazywany przez\r
+ wartosc (tylko wejsciowy), vars - przez zmienna (wejsciowo-\r
+ wyjsciowy).\r
+ Typ buffer oznacza tablice bajtowa sluzaca do przechowania\r
+ zawartosci okreslonego obszaru ekranu ( rozmiar jej zalezy\r
+ od wielkosci tego obszaru ), typ tekst natomiast oznacza\r
+ tablice znakowa.\r
+ Litery w pierwszej kolumnie sugeruja dodatkowe wazne\r
+ informacje (roznice) w kontekscie konkretnych jezykow\r
+ (Fortran, Pascal, C, Loglan).\f\r
+\r
+\r
+ 29\r
+\r
+\r
+\r
+ DODATEK F\r
+\r
+ Wartosci kodow klawiszy specjalnych:\r
+ \r
+ \r
+ 3 - ctrl-2\r
+ 15 - back tab (shift-tab)\r
+ 16-25 - ALT-Q az do ALT-P\r
+ 30-38 - ALT-A az do ALT-L\r
+ 44-50 - ALT-Z az do ALT-M\r
+ 59-68 - F1 az do F10\r
+ 71 - Home\r
+ 72 - Cursor-Up\r
+ 73 - PgUp\r
+ 75 - Cursor-Left\r
+ 77 - Cursor-Right\r
+ 79 - End\r
+ 80 - Cursor-Down\r
+ 81 - PgDn\r
+ 82 - Ins\r
+ 83 - Del\r
+ 84-93 - Shift-F1 az do Shift-F10\r
+ 94-103 - Ctrl-F1 az do Ctrl-F10\r
+ 104-113 - Alt-F1 az do Alt-F10\r
+ 114 - Ctrl-PrtSc\r
+ 115 - Ctrl-Cursor-Left\r
+ 116 - Ctrl-Cursor-Right\r
+ 117 - Ctrl-End\r
+ 118 - Ctrl-PgDn\r
+ 119 - Ctrl-Home\r
+ 120-131 - Alt-1 az do Alt-=\r
+ 132 - Ctrl-PgUp\f\r
+\r
+\r
+ 30\r
+\r
+\r
+ \r
+\r
+ DODATEK G\r
+\r
+ FEDIT\r
+ \r
+ Prosty program do edycji kroju znakow.\r
+ Dodatek do biblioteki graficznej IIUWGRAF.\r
+ \r
+ FEDIT pozwala komponowac i modyfikowac uklady pixli o\r
+ wymiarze 8*8. Takie uklady moga byc wyswietlane razem z\r
+ grafika za pomoca procedury HASCII.\r
+ \r
+ FEDIT produkuje opisy tablic kroju znakow w dwoch\r
+ postaciach:\r
+ \r
+ - jako podprogram dostarczajacy adres tablicy kroju\r
+ w postaci odpowiedniej do przekazania procedurze HFONT,\r
+ \r
+ - jako niezalezny program umieszczajacy wskaznik do\r
+ tablicy kroju w wektorze przerwania 14H.\r
+ \r
+ Pierwszy format moze byc uzyty do zastapienia standardowego\r
+ zestawu znakow zwykle znajdujacego sie w ROM BIOS pod\r
+ adresem F000:FA6E. Jest on uzywany przez procedure HASCII do\r
+ rysowania znakow o kodach od 0 do 127. Stad jego nazwa :\r
+ "format 0".\r
+ \r
+ Podprogram wygenerowany przez FEDIT ma nazwe HFONT8. Po\r
+ przetlumaczeniu przez MACROASSEMBLER musi byc on linkowany\r
+ razem z programem uzytkowym. Jesli zajdzie potrzeba zmiany\r
+ nazwy (np. w celu dynamicznego przelaczania pomiedzy kilkoma\r
+ krojami znakow), nazwa moze byc zmieniona recznie w tekscie\r
+ zrodlowym.\r
+ \r
+ Drugi format jest uzywany do rysowania znakow z\r
+ rozszerzonego zakresu znakow o kodach od 128 do 255. Stad\r
+ nazwa:\r
+ "format 128".\r
+ \r
+ Opis zestawu znakow w tym formacie musi byc zaladowany do\r
+ pamieci przed rozpoczeciem wykonania programu, ktory z niego\r
+ korzysta. Wskaznik do tablicy kroju musi byc wpisany w\r
+ wektor przerwania 14H. Robi to program wygenerowany przez\r
+ FEDIT, ktory nastepnie zawiesza sie za pomoca przerwania 27H\r
+ (terminate but stay resident). W tym przypadku tekst\r
+ zrodlowy po przetlumaczeniu przez MACROASSEMBLER musi byc\r
+ zlinkowany (bez zadnych bibliotek) do postaci .EXE.\r
+ IIUWGRAF i FEDIT nie daja mozliwosci dynamicznego\r
+ przelaczania tablic znakow rozszerzonego zakresu.\r
+ \f\r
+\r
+\r
+ 31\r
+\r
+\r
+ Przyklad:\r
+ \r
+ VAR ISEG, IOFFS: INTEGER;\r
+ BEGIN\r
+ HFONT8(ISEG,IOFFS); (* ADRES TABLICY FORMATU 0 *)\r
+ ...\r
+ HASCII(45); (* UZYWA ROM BIOS *)\r
+ HASCII(145); (* UZYWA ROZSZERZONEGO ZESTAWU *)\r
+ ...\r
+ HFONT(ISEG,IOFFS);\r
+ HASCII(45); (* UZYWA TABLICY FORMATU 0 *)\r
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)\r
+ ...\r
+ HFONT(16#F000,16#FA6E);\r
+ HASCII(45); (* ZNOWU ROM BIOS *)\r
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)\r
+ \r
+ \r
+ FEDIT jest prostym programem konwersacyjnym o kilku\r
+ zaledwie rozkazach. Tablica kroju znakow zawiera wzorce\r
+ ukladow pixli rozmiaru 8*8. Wzorzec pojedynczego znaku moze\r
+ byc wyjety z tej tablicy w celu jego edycji i zapamietany z\r
+ powrotem, byc moze w innym miejscu tablicy. Sa dwie tablice\r
+ znakow: jedna dla kodow od 0 do 127, druga dla kodow od 128\r
+ do 255. Pierwsza z nich nie moze byc modyfikowana. Druga z\r
+ nich moze poczatkowo zawierac zaladowany wczesniej\r
+ rozszerzony zestaw lub zostac wyczyszczona. Mozna tez\r
+ wczytac do niej zestaw zawarty w pliku wygenerowanym\r
+ wczesniej przez FEDIT. Po dokonaniu modyfikacji, zawartosc\r
+ tej drugiej tablicy moze byc uzyta do generacji badz\r
+ "formatu 0" badz "128".\r
+ \r
+\r
+ Rozkazy FEDITu.\r
+\r
+ \r
+ Rozkazy FEDITu sa wprowadzane jako pojedyncze litery\r
+ wybierajace czynnosci wymienione w jadlospisie wyswietlonym\r
+ u gory ekranu. Dodatkowe parametry podaje sie po\r
+ przynagleniu przez FEDIT.\r
+ \r
+ Komendy FEDITu:\r
+ \r
+ < low odswieza tablice "0 do 127"\r
+ \r
+ > high odswieza tablice "128 do 255"\r
+ \r
+ i init inicjalizuje zerami tablice "128 do 255"\r
+ \r
+ l load laduje tablice "128 do 255" z pliku\r
+ dodatkowy parametr:\r
+ - nazwa pliku (musi istniec)\f\r
+\r
+\r
+ 32\r
+\r
+\r
+ \r
+ d dump wypisuje zawartosc tablicy "128 do 255"\r
+ na plik; dodatkowe parametry:\r
+ - nazwa pliku (bedzie zapisany)\r
+ - baza ( 0 albo 128),\r
+ zaleznie od formatu\r
+ - jezyk:\r
+ f - MS Fortran, MS Pascal\r
+ s - Lattice C, model S\r
+ p - Lattice C, model P\r
+ d - Lattice C, model D\r
+ l - Lattice C, model L\r
+ \r
+ e edit wyjmuje z tablicy pojedynczy znak\r
+ i umieszcza go w obszarze roboczym.\r
+ dodatkowy parametr:\r
+ - kod znaku (dziesietnie)\r
+ Po obszarze roboczym mozna poruszac sie\r
+ za pomoca klawiszy kierunkowych. Pixel\r
+ zapala klawisz Ins, gasi klawisz Del.\r
+ Klawisz End powoduje wyjscie z tego trybu.\r
+ \r
+ t text wyswietla tekst pomocny przy ocenie\r
+ jakosci ksztaltu znakow. Tekst, nie dluzszy\r
+ niz 40 znakow jest wprowadzany przez uzytkow-\r
+ nika. Dodatkowe parametry:\r
+ - vspace,\r
+ - hspace - odpowiednio, pionowy i poziomy\r
+ odstep w pixlach pomiedzy znakami. Normalnie,\r
+ vspace wynosi 2, hspace - 0.\r
+ \r
+ p put przechowuje wzorzec z obszaru roboczego pod\r
+ wskazanym kodem. Dodatkowy parametr:\r
+ - kod pozycji (dziesietnie),\r
+ powinien byc miedzy 128 a 255\r
+ \r
+ q quit konczy dzialanie FEDIT\r
+ \r
+ \r
+ Z FEDITem nalezy obchodzic sie ostroznie. Posiada on jedynie\r
+ minimalne wbudowane zabezpieczenia i np. bez ostrzezenia\r
+ zapisze nowa, nie wykonczona jeszcze wersje kroju znakow na\r
+ pliku zawierajacym jedyny egzemplarz poprzedniej, bardzo\r
+ potrzebnej wersji.\f\r
+\r
+\r
+ 33\r
+\r
+\r
+ \r
+ DODATEK H\r
+ \r
+ Zmiany IIUWGRAFu w stosunku do poprzednich wersji\r
+ \r
+ \r
+ \r
+ Zmiany IIUWGRAFu w stosunku do wersji 1.1\r
+ \r
+ \r
+ 1) Rozszerzenie zestawu obslugiwanych kart graficznych o\r
+ karte EGA ( IBM Enhanced Graphics Adapter ).\r
+ \r
+ 2) Niewielkie modyfikacje procedur IIUWGRAFu :\r
+ \r
+ - dodanie procedury PRTSCR,\r
+ - modyfikacja procedury PATERN polegajaca na :\r
+ zwiekszeniu liczby parametrow ( wzorcow ) z\r
+ dwoch do czterech oraz\r
+ zmianie postaci tych parametrow ( zamiast\r
+ liczb dziesietnych liczby szesnastkowe ),\r
+ ( rozszerzenie wzorcow oczywiscie oznacza rownoczesnie\r
+ modyfikacje procedur HFILL oraz VFILL ),\r
+ - zmiany nazw procedur GRAPH, TEXT, SCREEN\r
+ odpowiednio na GRON, GROFF, NOCARD.\r
+ \r
+ \r
+ \r
+ \r
+ Zmiany IIUWGRAFu w stosunku do wersji 2.1\r
+ \r
+ \r
+ 1) Udostepnienie procedur CIRB oraz RCIRB dla C.\r
+ \f
\ No newline at end of file
--- /dev/null
+\r
+unit IIUWGRAPH: class;\r
+\r
+{ this predefined class enables basic graphic operations }\r
+\r
+{ the early versions of library IIUWGRAPH have been elaborated by \r
+ Piotr Carlsson, Miroslawa Milkowska, Janina Jankowska, \r
+ Michal Jankowski at Institute of Informatics, \r
+ University of Warsaw 1987,\r
+ and added to Loglan system by Danuta Szczepanska 1987, \r
+ the recent versions were done at LITA, Pau,\r
+ by\r
+ Pawel Susicki (1991) for Unix\r
+ Sebastien Bernard (1992) for ATARI \r
+ \r
+\r
+fait à Pau, le {TIME \@ "d MMMM, yyyy"|6 August, 1993} A.S.}\r
+\r
+{ the predefined class IIUWGRAPH is included in all versions of interpreter of Loglan, with the exception of the present version of interpreter for VAX/VMS.\r
+ Each interpreter is equipped with one version of graphic library which corresponds to one of the following possibilities:\r
+- EGA card, (use egaint if you have a VGA card)\r
+\r
+- Hercules mono card,\r
+\r
+- IBM CGA card\r
+ several variants are offered\r
+ CGA colour,\r
+ CGA mono 320 x 200\r
+ CGA mono 640 x 200\r
+ all above versions were tested in DOS 3.3 environment\r
+\r
+- an emulation of Hercules in a Xwindow for UNIX environment,\r
+\r
+- an emulation of IIUWGRAPH in ATARI STE environment.\r
+\r
+NEW (october 1993)\r
+MM. Becourt et Larrieu did a multiwindow graphic co-process for the int Loglan interpreter in Unix & Xwindows environment. See the separate document on it.\r
+\r
+M. Larrieu did an experimental version of vgaint Loglan executor for the machines 386/486. }\r
+\r
+hidden MaxX, MaxY, current_X, current_Y, is_graphic_On, \r
+ current_Colour, current_Background_Colour, current_Style,\r
+ current_Palette, current_Pattern ;\r
+\r
+\r
+ { Hercules EGA/VGA CGA \r
+ Unix }\r
+\r
+const MaxX = 719 ; { 639 319 }\r
+ MaxY = 347 ; { 349 199 }\r
+\r
+{ the screen's coordinates are\r
+ \r
+ (0,0) ----------------------> (MaxX,0)\r
+ ¦\r
+ ¦\r
+ ¦\r
+ V\r
+ (0, MaxY) (MaxX,MaxY)\r
+\r
+}\r
+\r
+\r
+var currentDriver : integer, { see NOCARD below } \r
+ current_X, current_Y: integer { it is the current position }\r
+ is_graphic_On: Boolean, { evidently tells whether we are in graphics mode }\r
+ current_Colour : integer, { }\r
+ current_Background_Colour : integer,\r
+ current_Style : integer, { }\r
+ current_Palette : integer,\r
+ current_Pattern\r
+\r
+unit GRON : procedure (i: integer);\r
+ { procedure sets the monitor in graphic mode and clears the buffer of screen. The parameter is meaningless, the only exception is made for the IBM CGA card in this case if you have chosen the mode 320x200 pixels the the value 1 of the parameter means colours, the value 0 means a mono screen is connected to the card\r
+ }\r
+\r
+unit GROFF : procedure;\r
+ { the procedure sets the monitor in the text mode filling it with spaces.\r
+ DO NOT FORGET to set the monitor in the text mode before you terminate your program\r
+ }\r
+\r
+unit NOCARD : function : integer;\r
+ { the value given by this function determines the type of the currently used monitor and it is equal to\r
+ 1 for Hercules mono card,\r
+ 2 for IBM CGA color\r
+ 3 for IBM CGA mono 320 x 200\r
+ 4 for IBM CGA mono 640 x 200\r
+ 5 for EGA/VGA card\r
+ ?? 6 for ATARI STE\r
+ ?? 7 for Unix versions equipped with XWindows\r
+ You can not call the function nocard before GRON sets the graphic mode\r
+ }\r
+\r
+unit CLS : procedure;\r
+ { the screen will be cleared and filled with colour 0 }\r
+\r
+unit HPAGE : procedure(nr, : integer, clear : boolean);\r
+ { the procedure is applicable to the cards EGA/VGA and Hercules only!\r
+ it selects a page of video memory with the number = nr,\r
+ clears its contents if clear is set <>0,\r
+ and sets the mode\r
+ mode = 0 the content of the page is shown as text,\r
+ mode = 1 the content of the page is shown graphically,\r
+ mode = -1 a worktime buffer is associated with the page.\r
+ Mode -1 does not change the number not the way it is shown. Mode 0 links the buffer with the selected page. For card Hercules only call HPAGE(0, 1, 1) is equivalent to call GRON(99) and call HPAGE(0, 0, 1) is equivalent to call GROFF.\r
+\r
+Example of an animating loop\r
+\r
+var nr: integer;\r
+begin\r
+ call GRON(0);\r
+ nr := 1;\r
+ (* draw first image *)\r
+ call DRAW(...)\r
+ ...\r
+ while more \r
+ do\r
+ call HPAGE(1-nr, 1,0); (* displaying *)\r
+ call HPAGE(nr, -1,1); (* buffering *)\r
+ (* draw modified image *)\r
+ call DRAW( ...)\r
+ ...\r
+ nr := 1-nr\r
+ od\r
+end example\r
+ \r
+\r
+unit VIDEO : procedure( A: array of integer);\r
+ { this procedure can not be applied for the EGA/VGA card }\r
+ { the worktime buffer will be associated with the array A.\r
+ A call of VIDEO does not change the contents of the buffer. \r
+ All subsequent calls of the procedures modifying the screen will \r
+ concern the array A. The screen does not change.\r
+ A ready image can be moved to the screen with the help of GETMAP/PUTMAP procedures or it can be stored on disk.\r
+ The array should have 16 kBytes for IBM CGA card or \r
+ 32 kBytes for Hercules card.}\r
+\r
+{ PROCEDURES CONTROLLING THE COLOURS }\r
+\r
+unit COLOR : procedure(co : integer);\r
+{ sets current color to co \r
+ for monochrome displays, 0 means black, non-0 - white\r
+ for color displays, 0 means background\r
+ see PALLET\r
+} \r
+\r
+\r
+unit STYLE : procedure(styl : integer);\r
+{ sets style of lines and fill shades to a combination\r
+ of current color and background color (for mono -\r
+ white and black, respectively) according to 5 predefined\r
+ patterns:\r
+\r
+ 0 ....\r
+ 1 ****\r
+ 2 ***.\r
+ 3 **..\r
+ 4 *.*.\r
+ 5 *...\r
+\r
+ where '*' means current color, '.' background colour\r
+When drawing the segments the subsequent pixels will have colour determined by cyclic application of style pattern. The first and the last pixels of a segment will have always current colour.\r
+When filling contours the given style will be applied to horizontal lines with even coordinate. The style for odd lines is determined automatically.\r
+The same applies for perpendicular lines.\r
+There are other possibilities of mixing colours, cf procedure PATERN.\r
+}\r
+\r
+\r
+unit PATERN : procedure (par, par1, par2, par3 : integer);\r
+ { sets style of lines and fill shades to an explicitly specified\r
+ combination of colours. When drawing lines the only parameter of importance will be par. When filling the parameters par and par2 concern the horiwontal (resp. perpendicular) lines with the coordinate x (resp: y) even. lines\r
+ combination of colors : "iv" for even scan lines, "io" for odd.\r
+ Color encoding is decimal, allowing 4 pixels.\r
+ Lines are drawn always according to "iv".\r
+\r
+ Examples:\r
+\r
+ call patern(1100,0011)\r
+ is equivalent to \r
+ call color(1), call style(3)\r
+\r
+\r
+ call patern(1212,2121)\r
+ produces a shade that cannot be otherwise achieved\r
+ ( a dotted line consisting of pixels in colors 1 and 2 )\r
+\r
+\r
+\r
+unit BORDER : procedure (background_Colour: integer);\r
+ [ IBM color mode only ]\r
+\r
+ sets actual background color to i ( i = 0,1,...,15 )\r
+\r
+\r
+unit PALLET : procedure (nr : integer);\r
+ {\r
+\r
+the codes of colors are as follows\r
+ 0 black\r
+ 1 blue dark\r
+ 2 green dark\r
+ 3 turquoise dark\r
+ 4 red dark\r
+ 5 violet\r
+ 6 brown\r
+ 7 grey light\r
+ 8 grey dark \r
+ 9 blue\r
+ 10 green\r
+ 11 turquoise\r
+ 12 red light\r
+ 13 rose\r
+ 14 yellow\r
+ 15 white\r
+ \r
+ the procedure does not applies for Hercules card}\r
+\r
+\r
+unit INTENS : procedure (i : integer);\r
+\r
+{ changes current intensity, 1 means more intensity, 0 less;\r
+ default intensity is 1\r
+ Applies to IBM CGA only\r
+}\r
+\r
+{ PROCEDURES CONTROLLING POSITION }\r
+\r
+unit MOVE : procedure (x,y :integer);\r
+ { procedure MOVE sets the current position on the screen on the pixel with coordinates\r
+ x - column,\r
+ y - line }\r
+ { precondition of MOVE:\r
+ 0{SYMBOL 163 \f "Symbol"}x{SYMBOL 163 \f "Symbol"}MaxX & 0{SYMBOL 163 \f "Symbol"}y{SYMBOL 163 \f "Symbol"}MaxY \r
+ }\r
+\r
+unit INXPOS : function: integer;\r
+ { function INXPOS returns the x coordinate of the current position }\r
+\r
+\r
+unit INYPOS : function : integer;\r
+ { function INYPOS returns the y coordinate of the current position }\r
+\r
+\r
+unit PUSHXY : procedure;\r
+{ pushes current position, color & style onto the stack.\r
+ The stack is kept internally, max depth is 16\r
+}\r
+\r
+\r
+unit POPXY: procedure;\r
+\r
+{ restores position, color & style from internal stack }\r
+\r
+{ Example\r
+unit DIAGONAL : procedure;\r
+ var ix, iy : integer;\r
+begin\r
+ call PUSHXY;\r
+ ix := INXPOS;\r
+ iy := INYPOS;\r
+ call DRAW(ix+10, iy+10);\r
+ call POPXY\r
+end DIAGONAL;\r
+}\r
+\r
+\r
+unit TRACK : procedure (x,y : integer);\r
+{ displays a small (8*8) arrow-shaped cursor which can be moved around with cursor keys; a single keystroke moves\r
+ it by 5 pixels, in NUM mode step size is 1 pixel;\r
+ "home" key returns the cursor to the initial (x,y);\r
+ "end" removes cursor from screen, and returns - the new current\r
+ position can be read with "INXPOS" and "INYPOS" above.\r
+\r
+ATTENTION: if you have a mouse then read on the predefined class Mouse, which permits to control the mouse\r
+}\r
+\r
+{ PROCEDURES SERVING POINTS }\r
+\r
+unit POINT : procedure(x,y: integer);\r
+{ moves current position to pixel (x,y) and sets it to current color \r
+ }\r
+\r
+unit INPIX : function (x,y : integer) : integer;\r
+ { \r
+ moves to pixel (x,y) and returns its color setting;\r
+ }\r
+\r
+\r
+unit DRAW : procedure( x,y : integer);\r
+ { \r
+ draws a line from current screen position to (x,y);\r
+ sets current position to (x,y);\r
+ line is drawn in current color, with both terminal pixels\r
+ always turned white ( non-background) for non-black\r
+ ( non-background ) line color.\r
+ Bresenham's algorithm is used, pixels belonging to the segment change their state depending on current colour and style.\r
+ }\r
+\r
+unit CIRB : procedure (xi, yi, ri : integer, alfa, beta : real, \r
+ cbord, fill, p, q : integer);\r
+\r
+ {\r
+ draws a circle (or ellipse, depending on aspect value, see below),\r
+ optionally filling its interior; \r
+ does not preserve position;\r
+ (xi,yi) - are center coordinates\r
+ ri - radius in pixels (horizontally)\r
+ alfa, beta - starting & ending angles; if alfa=beta a full\r
+ circle is drawn; values should be given in radians;\r
+ cbord - border color,\r
+ fill - if fill <>0, interior is filled in current style&color\r
+ p,q - aspect ratio; if p/q=1, a perfect circle is drawn,\r
+ if p/q<1, the horizontal axis is longer, \r
+ if p/q>1 - the vertical axis is longer;\r
+ }\r
+\r
+unit HFILL : procedure(x: integer);\r
+ \r
+{ fills current row (horizontally) from current position\r
+ (INXPOS, INYPOS) up to (x,INYPOS) with bit pattern depending\r
+ on current color, style and/or pattern and position on\r
+ the screen in such a way that adjacent "hfill"ed" rows\r
+ will produce a shade simulating color;\r
+\r
+ ATTENTION hfill does not change current position;\r
+\r
+It is advised to use hfill when filling contours since it works faster then DRAW. Procedure hfill is capable to similate additional colours.\r
+}\r
+\r
+unit VFILL : procedure(y: integer);\r
+\r
+{ fills current column ( vertically ) from current\r
+ position (INXPOS, INYPOS) up to (INXPOS, y) in a similiar way\r
+ that "hfill" does;\r
+ rectangular area "vfill'ed" is not distinguishable\r
+ on the screen from same shape "hfill'ed", except that\r
+ it will take much longer to fill.\r
+ \r
+ ATTENTION hfill does not change current position;\r
+\r
+{ Procedures operating on bitmaps }\r
+\r
+unit GETMAP : function (x,y : integer) : arrayof integer;\r
+ {saves rectangular area between current position as\r
+ top left corner and (ix,iy) as bottom right corner,\r
+ including border lines;\r
+ position remains unchanged.\r
+ array of integer should have \r
+ 4+(rows{SYMBOL 215 \f "Symbol"}{SYMBOL 233 \f "Symbol"}columns/8{SYMBOL 249 \f "Symbol"} {SYMBOL 215 \f "Symbol"}coeff)\r
+ bytes. The coefficient coeff is 1 for Hercules, 2 for CGA, 4 for EGA card.\r
+ ATTENTION: in DOS environment the size of the array may necessitate the use of loglan with the option H+, see also memavail \r
+ }\r
+\r
+\r
+unit PUTMAP : procedure ( a: array of integer);\r
+ {sets rectangular area of screen pixels to that saved\r
+ by "getmap" in "iarray";\r
+ same size is restored, with top left corner in current\r
+ position;\r
+ position remains unchanged.\r
+ }\r
+unit ORMAP : procedure ( a : arrayof integer);\r
+ {same as putmap, but saved bitmap is or'ed into screen\r
+ rather than just set.\r
+ }\r
+\r
+unit XORMAP : procedure ( a: arrayof integer);\r
+ {same as putmap, but saved bitmap is xor'ed into screen\r
+ rather than just set.\r
+ }\r
+\r
+unit INKEY : function : integer;\r
+\r
+ {returns next character from keyboard buffer;\r
+ 0 is returned if buffer is empty;\r
+ special keys are returned as negative numbers;\r
+ ALT-NUM method may be used for entering character codes\r
+ above 127 (this makes entering special keys 128-132\r
+ impossible);\r
+ if a character is returned, it is also removed\r
+ from the buffer, so MS-DOS will not see it (CTRL-C!);\r
+ typeahead is allowed, echo is suppressed.\r
+ }\r
+\r
+unit HASCII : procedure\r
+ {'xor's the character in a 8*8 box with top left corner\r
+ in the current position;\r
+ moves current position by (8,0);\r
+ character code 0 sets complete box to black ( background ),\r
+ with no change in position.\r
+ BIOS ROM font for IBM color card is used. If the font\r
+ table is not at F000:FA6E, the character will probably\r
+ be unrecognizable, and most certainly wrong.\r
+ For codes >127, table pointed to by interrupt vector 31\r
+ is used. }\r
+\r
+unit HFONT\r
+ {sets 8*8 horizontal font table address to iseg:ioffs.}\r
+\r
+\r
+unit HFONT8\r
+{includes a copy of IBM ROM 8*8 font and returns address suitable for passing to "hfont";\r
+Use of "hfont8" makes program larger but quarantees BIOS ROM independence.}\r
+\r
+\r
+unit INHLINE : procedure (a: arrayof char; output n : integer);\r
+{ reads a line of at most "n" characters from the keyboard, storing them in the "a" array; characters are echoed at current position with "hascii" as they are typed in; a blinking cursor prompts for the next character;\r
+BACKSPACE works as expected, RETURN completes the reading;\r
+typing "n"-th character also completes the line;\r
+"l" is blank filled up to "n" bytes;\r
+on return "n" is the total number of characters read. }\r
+\r
+ \r
+unit OUTHLINE : procedure (a : arrayof char; n : integer);\r
+{ calls "hascii" "n" times with subsequent bytes from "a" array as arguments; before each character is written, "hascii(0)" is called. }\r
+\r
+\r
+end IIUWGRAPH;\r
+à Pau, le {DATE|06/08/93} {PAGE|4}\r
+\r
+Predefined class IIUWGRAPH {PAGE|3}\r
+\r
+\r
--- /dev/null
+\ 4%!PS-Adobe-3.0\r
+%%Creator: Windows PSCRIPT\r
+%%Title: Microsoft Word - IUWGRAF3.DOC\r
+%%BoundingBox: 9 15 584 830\r
+%%DocumentNeededResources: (atend)\r
+%%DocumentSuppliedResources: (atend)\r
+%%Pages: (atend)\r
+%%BeginResource: procset Win35Dict 3 1\r
+/Win35Dict 290 dict def Win35Dict begin/bd{bind def}bind def/in{72\r
+mul}bd/ed{exch def}bd/ld{load def}bd/tr/translate ld/gs/gsave ld/gr\r
+/grestore ld/M/moveto ld/L/lineto ld/rmt/rmoveto ld/rlt/rlineto ld\r
+/rct/rcurveto ld/st/stroke ld/n/newpath ld/sm/setmatrix ld/cm/currentmatrix\r
+ld/cp/closepath ld/ARC/arcn ld/TR{65536 div}bd/lj/setlinejoin ld/lc\r
+/setlinecap ld/ml/setmiterlimit ld/sl/setlinewidth ld/scignore false\r
+def/sc{scignore{pop pop pop}{0 index 2 index eq 2 index 4 index eq\r
+and{pop pop 255 div setgray}{3{255 div 3 1 roll}repeat setrgbcolor}ifelse}ifelse}bd\r
+/FC{bR bG bB sc}bd/fC{/bB ed/bG ed/bR ed}bd/HC{hR hG hB sc}bd/hC{\r
+/hB ed/hG ed/hR ed}bd/PC{pR pG pB sc}bd/pC{/pB ed/pG ed/pR ed}bd/sM\r
+matrix def/PenW 1 def/iPen 5 def/mxF matrix def/mxE matrix def/mxUE\r
+matrix def/mxUF matrix def/fBE false def/iDevRes 72 0 matrix defaultmatrix\r
+dtransform dup mul exch dup mul add sqrt def/fPP false def/SS{fPP{\r
+/SV save def}{gs}ifelse}bd/RS{fPP{SV restore}{gr}ifelse}bd/EJ{gsave\r
+showpage grestore}bd/#C{userdict begin/#copies ed end}bd/FEbuf 2 string\r
+def/FEglyph(G )def/FE{1 exch{dup 16 FEbuf cvrs FEglyph exch 1 exch\r
+putinterval 1 index exch FEglyph cvn put}for}bd/SM{/iRes ed/cyP ed\r
+/cxPg ed/cyM ed/cxM ed 72 100 div dup scale dup 0 ne{90 eq{cyM exch\r
+0 eq{cxM exch tr -90 rotate -1 1 scale}{cxM cxPg add exch tr +90 rotate}ifelse}{cyP\r
+cyM sub exch 0 ne{cxM exch tr -90 rotate}{cxM cxPg add exch tr -90\r
+rotate 1 -1 scale}ifelse}ifelse}{pop cyP cyM sub exch 0 ne{cxM cxPg\r
+add exch tr 180 rotate}{cxM exch tr 1 -1 scale}ifelse}ifelse 100 iRes\r
+div dup scale 0 0 transform .25 add round .25 sub exch .25 add round\r
+.25 sub exch itransform translate}bd/SJ{1 index 0 eq{pop pop/fBE false\r
+def}{1 index/Break ed div/dxBreak ed/fBE true def}ifelse}bd/ANSIVec[\r
+16#0/grave 16#1/acute 16#2/circumflex 16#3/tilde 16#4/macron 16#5/breve\r
+16#6/dotaccent 16#7/dieresis 16#8/ring 16#9/cedilla 16#A/hungarumlaut\r
+16#B/ogonek 16#C/caron 16#D/dotlessi 16#27/quotesingle 16#60/grave\r
+16#7C/bar 16#82/quotesinglbase 16#83/florin 16#84/quotedblbase 16#85\r
+/ellipsis 16#86/dagger 16#87/daggerdbl 16#89/perthousand 16#8A/Scaron\r
+16#8B/guilsinglleft 16#8C/OE 16#91/quoteleft 16#92/quoteright 16#93\r
+/quotedblleft 16#94/quotedblright 16#95/bullet 16#96/endash 16#97\r
+/emdash 16#99/trademark 16#9A/scaron 16#9B/guilsinglright 16#9C/oe\r
+16#9F/Ydieresis 16#A0/space 16#A4/currency 16#A6/brokenbar 16#A7/section\r
+16#A8/dieresis 16#A9/copyright 16#AA/ordfeminine 16#AB/guillemotleft\r
+16#AC/logicalnot 16#AD/hyphen 16#AE/registered 16#AF/macron 16#B0/degree\r
+16#B1/plusminus 16#B2/twosuperior 16#B3/threesuperior 16#B4/acute 16#B5\r
+/mu 16#B6/paragraph 16#B7/periodcentered 16#B8/cedilla 16#B9/onesuperior\r
+16#BA/ordmasculine 16#BB/guillemotright 16#BC/onequarter 16#BD/onehalf\r
+16#BE/threequarters 16#BF/questiondown 16#C0/Agrave 16#C1/Aacute 16#C2\r
+/Acircumflex 16#C3/Atilde 16#C4/Adieresis 16#C5/Aring 16#C6/AE 16#C7\r
+/Ccedilla 16#C8/Egrave 16#C9/Eacute 16#CA/Ecircumflex 16#CB/Edieresis\r
+16#CC/Igrave 16#CD/Iacute 16#CE/Icircumflex 16#CF/Idieresis 16#D0/Eth\r
+16#D1/Ntilde 16#D2/Ograve 16#D3/Oacute 16#D4/Ocircumflex 16#D5/Otilde\r
+16#D6/Odieresis 16#D7/multiply 16#D8/Oslash 16#D9/Ugrave 16#DA/Uacute\r
+16#DB/Ucircumflex 16#DC/Udieresis 16#DD/Yacute 16#DE/Thorn 16#DF/germandbls\r
+16#E0/agrave 16#E1/aacute 16#E2/acircumflex 16#E3/atilde 16#E4/adieresis\r
+16#E5/aring 16#E6/ae 16#E7/ccedilla 16#E8/egrave 16#E9/eacute 16#EA\r
+/ecircumflex 16#EB/edieresis 16#EC/igrave 16#ED/iacute 16#EE/icircumflex\r
+16#EF/idieresis 16#F0/eth 16#F1/ntilde 16#F2/ograve 16#F3/oacute 16#F4\r
+/ocircumflex 16#F5/otilde 16#F6/odieresis 16#F7/divide 16#F8/oslash\r
+16#F9/ugrave 16#FA/uacute 16#FB/ucircumflex 16#FC/udieresis 16#FD/yacute\r
+16#FE/thorn 16#FF/ydieresis ] def/reencdict 12 dict def/IsChar{basefontdict\r
+/CharStrings get exch known}bd/MapCh{dup IsChar not{pop/bullet}if\r
+newfont/Encoding get 3 1 roll put}bd/MapDegree{16#b0/degree IsChar{\r
+/degree}{/ring}ifelse MapCh}bd/MapBB{16#a6/brokenbar IsChar{/brokenbar}{\r
+/bar}ifelse MapCh}bd/ANSIFont{reencdict begin/newfontname ed/basefontname\r
+ed FontDirectory newfontname known not{/basefontdict basefontname findfont\r
+def/newfont basefontdict maxlength dict def basefontdict{exch dup/FID\r
+ne{dup/Encoding eq{exch dup length array copy newfont 3 1 roll put}{exch\r
+newfont 3 1 roll put}ifelse}{pop pop}ifelse}forall newfont/FontName\r
+newfontname put 127 1 159{newfont/Encoding get exch/bullet put}for\r
+ANSIVec aload pop ANSIVec length 2 idiv{MapCh}repeat MapDegree MapBB\r
+newfontname newfont definefont pop}if newfontname end}bd/SB{FC/ULlen\r
+ed/str ed str length fBE not{dup 1 gt{1 sub}if}if/cbStr ed/dxGdi ed\r
+/y0 ed/x0 ed str stringwidth dup 0 ne{/y1 ed/x1 ed y1 y1 mul x1 x1\r
+mul add sqrt dxGdi exch div 1 sub dup x1 mul cbStr div exch y1 mul\r
+cbStr div}{exch abs neg dxGdi add cbStr div exch}ifelse/dyExtra ed\r
+/dxExtra ed x0 y0 M fBE{dxBreak 0 BCh dxExtra dyExtra str awidthshow}{dxExtra\r
+dyExtra str ashow}ifelse fUL{x0 y0 M dxUL dyUL rmt ULlen fBE{Break\r
+add}if 0 mxUE transform gs rlt cyUL sl [] 0 setdash st gr}if fSO{x0\r
+y0 M dxSO dySO rmt ULlen fBE{Break add}if 0 mxUE transform gs rlt cyUL\r
+sl [] 0 setdash st gr}if n/fBE false def}bd/font{/name ed/Ascent ed\r
+0 ne/fT3 ed 0 ne/fSO ed 0 ne/fUL ed/Sy ed/Sx ed 10.0 div/ori ed -10.0\r
+div/esc ed/BCh ed name findfont/xAscent 0 def/yAscent Ascent def/ULesc\r
+esc def ULesc mxUE rotate pop fT3{/esc 0 def xAscent yAscent mxUE transform\r
+/yAscent ed/xAscent ed}if [Sx 0 0 Sy neg xAscent yAscent] esc mxE\r
+rotate mxF concatmatrix makefont setfont [Sx 0 0 Sy neg 0 Ascent] mxUE\r
+mxUF concatmatrix pop fUL{currentfont dup/FontInfo get/UnderlinePosition\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlinePosition get\r
+1000 div 0 exch mxUF transform/dyUL ed/dxUL ed}if fSO{0 .3 mxUF transform\r
+/dySO ed/dxSO ed}if fUL fSO or{currentfont dup/FontInfo get/UnderlineThickness\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlineThickness get\r
+1000 div Sy mul/cyUL ed}if}bd/min{2 copy gt{exch}if pop}bd/max{2 copy\r
+lt{exch}if pop}bd/CP{/ft ed{{ft 0 eq{clip}{eoclip}ifelse}stopped{currentflat\r
+1 add setflat}{exit}ifelse}loop}bd/patfont 10 dict def patfont begin\r
+/FontType 3 def/FontMatrix [1 0 0 -1 0 0] def/FontBBox [0 0 16 16]\r
+def/Encoding StandardEncoding def/BuildChar{pop pop 16 0 0 0 16 16\r
+setcachedevice 16 16 false [1 0 0 1 .25 .25]{pat}imagemask}bd end/p{\r
+/pat 32 string def{}forall 0 1 7{dup 2 mul pat exch 3 index put dup\r
+2 mul 1 add pat exch 3 index put dup 2 mul 16 add pat exch 3 index\r
+put 2 mul 17 add pat exch 2 index put pop}for}bd/pfill{/PatFont patfont\r
+definefont setfont/ch(AAAA)def X0 64 X1{Y1 -16 Y0{1 index exch M ch\r
+show}for pop}for}bd/vert{X0 w X1{dup Y0 M Y1 L st}for}bd/horz{Y0 w\r
+Y1{dup X0 exch M X1 exch L st}for}bd/fdiag{X0 w X1{Y0 M X1 X0 sub dup\r
+rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup rlt st}for}bd/bdiag{X0 w\r
+X1{Y1 M X1 X0 sub dup neg rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup\r
+neg rlt st}for}bd/AU{1 add cvi 15 or}bd/AD{1 sub cvi -16 and}bd/SHR{pathbbox\r
+AU/Y1 ed AU/X1 ed AD/Y0 ed AD/X0 ed}bd/hfill{/w iRes 37.5 div round\r
+def 0.1 sl [] 0 setdash n dup 0 eq{horz}if dup 1 eq{vert}if dup 2 eq{fdiag}if\r
+dup 3 eq{bdiag}if dup 4 eq{horz vert}if 5 eq{fdiag bdiag}if}bd/F{/ft\r
+ed fm 256 and 0 ne{gs FC ft 0 eq{fill}{eofill}ifelse gr}if fm 1536\r
+and 0 ne{SHR gs HC ft CP fm 1024 and 0 ne{/Tmp save def pfill Tmp restore}{fm\r
+15 and hfill}ifelse gr}if}bd/S{PenW sl PC st}bd/m matrix def/GW{iRes\r
+12 div PenW add cvi}bd/DoW{iRes 50 div PenW add cvi}bd/DW{iRes 8 div\r
+PenW add cvi}bd/SP{/PenW ed/iPen ed iPen 0 eq iPen 6 eq or{[] 0 setdash}if\r
+iPen 1 eq{[DW GW] 0 setdash}if iPen 2 eq{[DoW GW] 0 setdash}if iPen\r
+3 eq{[DW GW DoW GW] 0 setdash}if iPen 4 eq{[DW GW DoW GW DoW GW] 0\r
+setdash}if}bd/E{m cm pop tr scale 1 0 moveto 0 0 1 0 360 arc cp m sm}bd\r
+/AG{/sy ed/sx ed sx div 4 1 roll sy div 4 1 roll sx div 4 1 roll sy\r
+div 4 1 roll atan/a2 ed atan/a1 ed sx sy scale a1 a2 ARC}def/A{m cm\r
+pop tr AG m sm}def/P{m cm pop tr 0 0 M AG cp m sm}def/RRect{n 4 copy\r
+M 3 1 roll exch L 4 2 roll L L cp}bd/RRCC{/r ed/y1 ed/x1 ed/y0 ed/x0\r
+ed x0 x1 add 2 div y0 M x1 y0 x1 y1 r arcto 4{pop}repeat x1 y1 x0 y1\r
+r arcto 4{pop}repeat x0 y1 x0 y0 r arcto 4{pop}repeat x0 y0 x1 y0 r\r
+arcto 4{pop}repeat cp}bd/RR{2 copy 0 eq exch 0 eq or{pop pop RRect}{2\r
+copy eq{pop RRCC}{m cm pop/y2 ed/x2 ed/ys y2 x2 div 1 max def/xs x2\r
+y2 div 1 max def/y1 exch ys div def/x1 exch xs div def/y0 exch ys div\r
+def/x0 exch xs div def/r2 x2 y2 min def xs ys scale x0 x1 add 2 div\r
+y0 M x1 y0 x1 y1 r2 arcto 4{pop}repeat x1 y1 x0 y1 r2 arcto 4{pop}repeat\r
+x0 y1 x0 y0 r2 arcto 4{pop}repeat x0 y0 x1 y0 r2 arcto 4{pop}repeat\r
+m sm cp}ifelse}ifelse}bd/PP{{rlt}repeat}bd/OB{gs 0 ne{7 3 roll/y ed\r
+/x ed x y translate ULesc rotate x neg y neg translate x y 7 -3 roll}if\r
+sc B fill gr}bd/B{M/dy ed/dx ed dx 0 rlt 0 dy rlt dx neg 0 rlt cp}bd\r
+/CB{B clip n}bd/ErrHandler{errordict dup maxlength exch length gt\r
+dup{errordict begin}if/errhelpdict 12 dict def errhelpdict begin/stackunderflow(operand stack underflow)def\r
+/undefined(this name is not defined in a dictionary)def/VMerror(you have used up all the printer's memory)def\r
+/typecheck(operator was expecting a different type of operand)def\r
+/ioerror(input/output error occured)def end{end}if errordict begin\r
+/handleerror{$error begin newerror{/newerror false def showpage 72\r
+72 scale/x .25 def/y 9.6 def/Helvetica findfont .2 scalefont setfont\r
+x y moveto(Offending Command = )show/command load{dup type/stringtype\r
+ne{(max err string)cvs}if show}exec/y y .2 sub def x y moveto(Error = )show\r
+errorname{dup type dup( max err string )cvs show( : )show/stringtype\r
+ne{( max err string )cvs}if show}exec errordict begin errhelpdict errorname\r
+known{x 1 add y .2 sub moveto errhelpdict errorname get show}if end\r
+/y y .4 sub def x y moveto(Stack =)show ostack{/y y .2 sub def x 1\r
+add y moveto dup type/stringtype ne{( max err string )cvs}if show}forall\r
+showpage}if end}def end}bd end\r
+%%EndResource\r
+/SVDoc save def\r
+%%EndProlog\r
+%%BeginSetup\r
+Win35Dict begin\r
+ErrHandler\r
+statusdict begin 0 setjobtimeout end\r
+statusdict begin statusdict /jobname (Microsoft Word - IUWGRAF3.DOC) put end\r
+/oldDictCnt countdictstack def {statusdict begin 0 setpapertray end\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+/oldDictCnt countdictstack def {a4\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+[{ }\r
+/exec load currenttransfer /exec load] cvx settransfer\r
+/setresolution where { pop 300 300 setresolution } if\r
+%%EndSetup\r
+%%Page: 1 1\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+0 0 0 fC\r
+248 283 615 (unit IIUWGRAPH: class;) 615 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 401 1399 ({ this predefined class enables basic graphic operations) 1399 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+248 460 95 ( ) 95 SB\r
+32 0 0 58 58 0 0 0 52 /Bookman-LightItalic /font8 ANSIFont font\r
+343 462 17 ( ) 17 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+360 460 810 (for DOS machines based on ) 810 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Demi /font5 ANSIFont font\r
+1170 460 114 (486) 114 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+1284 460 560 ( or 386 processors }) 560 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 587 1726 ({ this document gives the specification of new version of IIUWGRAPH) 1726 SB\r
+398 647 773 (class made in October 1994 by ) 773 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-DemiItalic /font6 ANSIFont font\r
+1171 646 444 (Frederic Pataud ) 444 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1615 647 139 (\340 Pau) 139 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+248 707 15 ( ) 15 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+263 706 14 (}) 14 SB\r
+248 824 1672 ({ the early versions of library IIUWGRAPH have been elaborated by) 1672 SB\r
+248 883 1525 ( Piotr Carlsson, Miroslawa Milkowska, Janina Jankowska,) 1525 SB\r
+248 942 1244 ( Michal Jankowski at Institute of Informatics,) 1244 SB\r
+248 1001 785 ( University of Warsaw 1987,) 785 SB\r
+248 1060 1555 ( and added to Loglan system by Danuta Szczepanska 1987,) 1555 SB\r
+248 1178 1173 ( the recent versions were done at LITA, Pau,) 1173 SB\r
+248 1237 170 ( by) 170 SB\r
+248 1296 863 ( Pawel Susicki \(1991\) for Unix,) 863 SB\r
+248 1355 1641 ( Sebastien Bernard \(1992\) for ATARI, see a separate document,) 1641 SB\r
+248 1414 1795 ( Eric Becourt et Jer\364me Larrieu \(1993\) for Unix and Xwindows, see a ) 1795 SB\r
+398 1473 826 (separate document on Xiiuwgraf ,) 826 SB\r
+248 1709 1492 (fait \340 Pau, le 15 Novembre 1994, par Andrzej Salwicki, LITA}) 1492 SB\r
+248 1827 1875 ({ the predefined class IIUWGRAPH is included in all versions of interpreter of) 1875 SB\r
+248 1887 410 (Loglan, with the ) 410 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+658 1888 224 (exception) 224 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+882 1887 1259 ( of the present version of interpreter for VAX/VMS.}) 1259 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2131 179 (hidden) 179 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+427 2132 1311 ( MaxX, MaxY, current_X, current_Y, is_graphic_On,) 1311 SB\r
+248 2191 1712 ( current_Colour, current_Background_Colour, current_Style,) 1712 SB\r
+248 2250 1062 ( current_Palette, current_Pattern ;) 1062 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2486 143 (const) 143 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+391 2487 217 ( MaxX =) 217 SB\r
+248 2546 341 ( MaxY =) 341 SB\r
+248 2664 760 ({ the screen's coordinates are) 760 SB\r
+248 2782 986 ( \(0,0\) ----------------------> \(MaxX,0\)) 986 SB\r
+248 2841 206 ( \246) 206 SB\r
+248 2900 206 ( \246) 206 SB\r
+248 2959 206 ( \246) 206 SB\r
+248 3018 195 ( V) 195 SB\r
+248 3077 1108 ( \(0, MaxY\) \(MaxX,MaxY\)) 1108 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-DemiItalic\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%Page: 2 2\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+248 224 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 401 82 (var) 82 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+330 402 1466 ( currentDriver : integer, { see NOCARD below }) 1466 SB\r
+248 461 1640 ( current_X, current_Y: integer { it is the current position }) 1640 SB\r
+248 520 719 ( is_graphic_On: Boolean,) 719 SB\r
+998 520 881 ( { evidently tells whether we are in ) 881 SB\r
+698 579 387 (graphics mode }) 387 SB\r
+248 638 715 ( current_Colour : integer,) 715 SB\r
+1148 638 44 ({ }) 44 SB\r
+248 697 1038 ( current_Background_Colour : integer,) 1038 SB\r
+248 756 671 ( current_Style : integer,) 671 SB\r
+1148 756 44 ({ }) 44 SB\r
+248 815 716 ( current_Palette : integer,) 716 SB\r
+248 874 498 ( current_Pattern) 498 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 992 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 993 217 ( GRON : ) 217 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+573 992 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+834 993 277 ( \(i: integer\);) 277 SB\r
+248 1052 1754 ( { procedure sets the monitor in graphic mode and clears the buffer) 1754 SB\r
+248 1111 16 ( ) 16 SB\r
+398 1111 1739 (of screen. The parameter determines the resolution and the number of ) 1739 SB\r
+398 1170 195 (colours.) 195 SB\r
+248 1229 1887 (The user should assure that the resolution chosen should correspond to that) 1887 SB\r
+248 1288 801 (which set by means of command) 801 SB\r
+248 1347 1616 (SET go32 drivers {path}<driver.file> <width> <height><noColours>) 1616 SB\r
+248 1406 69 (eg.) 69 SB\r
+248 1465 1785 (set go32 drivers c:\\loglan\\svga\\drivers\\vesa.grn gw 1024 gh 480 nc 256) 1785 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+248 1525 861 ( An execution of instruction ) 861 SB\r
+32 0 0 58 58 1 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+1109 1525 98 (call) 98 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+1207 1525 216 ( gron\(i\) ) 216 SB\r
+32 0 0 58 58 0 0 0 55 /Bookman-DemiItalic /font6 ANSIFont font\r
+1423 1524 406 (must precede) 406 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Demi /font5 ANSIFont font\r
+1829 1525 20 ( ) 20 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+1849 1525 282 (any of the) 282 SB\r
+248 1593 1029 (graphic commands described below.) 1029 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 1661 126 ( }) 126 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1779 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1780 244 ( GROFF : ) 244 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+600 1779 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+861 1780 16 (;) 16 SB\r
+248 1839 1651 ( { the procedure sets the monitor in the text mode filling it with ) 1651 SB\r
+398 1898 180 (spaces.) 180 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+248 1957 1871 ( DO NOT FORGET to set the monitor in the text mode before) 1871 SB\r
+248 2025 820 (you terminate your program) 820 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 2093 126 ( }) 126 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 2211 825 (unit NOCARD : function : integer;) 825 SB\r
+248 2270 1923 ( { the value given by this function determines the type of the currently used) 1923 SB\r
+248 2329 620 (monitor and it is equal to) 620 SB\r
+248 2388 223 ( 1) 223 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+471 2388 80 ( ) 80 SB\r
+548 2388 589 (for Hercules mono card,) 589 SB\r
+248 2447 160 ( ) 160 SB\r
+398 2447 31 (2) 31 SB\r
+429 2447 128 ( ) 128 SB\r
+548 2447 444 (for IBM CGA color) 444 SB\r
+248 2506 160 ( ) 160 SB\r
+398 2506 31 (3) 31 SB\r
+429 2506 128 ( ) 128 SB\r
+548 2506 723 (for IBM CGA mono 320 x 200) 723 SB\r
+248 2565 160 ( ) 160 SB\r
+398 2565 31 (4) 31 SB\r
+429 2565 128 ( ) 128 SB\r
+548 2565 723 (for IBM CGA mono 640 x 200) 723 SB\r
+248 2624 160 ( ) 160 SB\r
+398 2624 31 (5) 31 SB\r
+429 2624 128 ( ) 128 SB\r
+548 2624 455 (for EGA/VGA card) 455 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 2683 717 ( 6 for ATARI STE) 717 SB\r
+248 2742 1431 ( 7 for Unix versions equipped with XWindows) 1431 SB\r
+32 0 0 50 50 0 1 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+248 2803 1888 ( You can not call the function nocard before GRON sets the graphic mode) 1888 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 2859 126 ( }) 126 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2977 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2978 164 ( CLS : ) 164 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+520 2977 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+781 2978 16 (;) 16 SB\r
+248 3037 1386 ( { the screen will be cleared and filled with colour 0 }) 1386 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-DemiItalic\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%Page: 3 3\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+248 224 1080 (unit VIDEO : procedure\( A: array of integer\);) 1080 SB\r
+248 283 80 ( ) 80 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+328 283 1636 ( { this procedure can not be applied with egaint = EGA/VGA card }) 1636 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 342 160 ( ) 160 SB\r
+398 342 1383 ({ the worktime buffer will be associated with the array A.) 1383 SB\r
+248 401 160 ( ) 160 SB\r
+398 401 1507 ( A call of VIDEO does not change the contents of the buffer.) 1507 SB\r
+248 460 160 ( ) 160 SB\r
+398 460 1621 ( All subsequent calls of the procedures modifying the screen will) 1621 SB\r
+248 519 160 ( ) 160 SB\r
+398 519 1273 ( concern the array A. The screen does not change.) 1273 SB\r
+248 578 160 ( ) 160 SB\r
+398 578 1505 ( A ready image can be moved to the screen with the help of ) 1505 SB\r
+1903 578 160 ( ) 160 SB\r
+2048 578 160 ( ) 160 SB\r
+248 637 160 ( ) 160 SB\r
+398 637 1421 (GETMAP/PUTMAP procedures or it can be stored on disk.) 1421 SB\r
+248 696 160 ( ) 160 SB\r
+398 696 1387 ( The array should have 16 kBytes for IBM CGA card or) 1387 SB\r
+248 755 160 ( ) 160 SB\r
+398 755 743 ( 32 kBytes for Hercules card.}) 743 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 881 30 ({ ) 30 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+278 873 1371 (PROCEDURES CONTROLLING THE COLOURS ) 1371 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1649 881 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1000 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1001 247 ( COLOR : ) 247 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+603 1000 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+864 1001 316 (\(co : integer\);) 316 SB\r
+248 1060 14 ({) 14 SB\r
+398 1060 563 (sets current color to co) 563 SB\r
+398 1119 1365 (for monochrome displays, 0 means black, non-0 - white) 1365 SB\r
+398 1178 965 (for color displays, 0 means background) 965 SB\r
+248 1237 366 ( see PALLET) 366 SB\r
+248 1296 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1414 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1415 226 ( STYLE : ) 226 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+582 1414 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+843 1415 349 (\(styl : integer\);) 349 SB\r
+248 1474 14 ({) 14 SB\r
+398 1474 1218 (sets style of lines and fill shades to a combination) 1218 SB\r
+398 1533 1214 (of current color and background color \(for mono -) 1214 SB\r
+398 1592 1357 (white and black, respectively\) according to 5 predefined) 1357 SB\r
+398 1651 221 (patterns:) 221 SB\r
+548 1769 31 (0) 31 SB\r
+698 1769 64 (....) 64 SB\r
+548 1828 31 (1) 31 SB\r
+698 1828 88 (****) 88 SB\r
+548 1887 31 (2) 31 SB\r
+698 1887 82 (***.) 82 SB\r
+548 1946 31 (3) 31 SB\r
+698 1946 76 (**..) 76 SB\r
+548 2005 31 (4) 31 SB\r
+698 2005 76 (*.*.) 76 SB\r
+548 2064 31 (5) 31 SB\r
+698 2064 70 (*...) 70 SB\r
+398 2182 1311 (where '*' means current color, '.' background colour) 1311 SB\r
+248 2241 1934 (When drawing the segments the subsequent pixels will have colour determined) 1934 SB\r
+248 2300 1906 (by cyclic application of style pattern. The first and the last pixels of a segment) 1906 SB\r
+248 2359 778 (will have always current colour.) 778 SB\r
+248 2418 1962 (When filling contours the given style will be applied to horizontal lines with even) 1962 SB\r
+248 2477 1540 (coordinate. The style for odd lines is determined automatically.) 1540 SB\r
+248 2536 1009 (The same applies for perpendicular lines.) 1009 SB\r
+248 2595 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2772 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2773 289 ( BORDER : ) 289 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+645 2772 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+906 2773 743 ( \(background_Colour: integer\);) 743 SB\r
+398 2891 1285 ({ sets actual background color to i \( i = 0,1,...,15 \) }) 1285 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 3068 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 3069 256 ( PALLET : ) 256 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+612 3068 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+873 3069 333 ( \(nr : integer\);) 333 SB\r
+398 3128 14 ({) 14 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-Light\r
+%%Page: 4 4\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+248 283 799 (the codes of colors are as follows) 799 SB\r
+548 342 31 (0) 31 SB\r
+698 342 132 (black) 132 SB\r
+548 401 31 (1) 31 SB\r
+698 401 235 (blue dark) 235 SB\r
+548 460 31 (2) 31 SB\r
+698 460 263 (green dark) 263 SB\r
+548 519 31 (3) 31 SB\r
+698 519 362 (turquoise dark) 362 SB\r
+548 578 31 (4) 31 SB\r
+698 578 208 (red dark) 208 SB\r
+548 637 31 (5) 31 SB\r
+698 637 129 (violet) 129 SB\r
+548 696 31 (6) 31 SB\r
+698 696 153 (brown) 153 SB\r
+548 755 31 (7) 31 SB\r
+698 755 227 (grey light) 227 SB\r
+548 814 31 (8) 31 SB\r
+698 814 231 (grey dark) 231 SB\r
+548 873 31 (9) 31 SB\r
+698 873 106 (blue) 106 SB\r
+548 932 62 (10) 62 SB\r
+698 932 134 (green) 134 SB\r
+548 991 62 (11) 62 SB\r
+698 991 233 (turquoise) 233 SB\r
+548 1050 62 (12) 62 SB\r
+698 1050 204 (red light) 204 SB\r
+548 1109 62 (13) 62 SB\r
+698 1109 102 (rose) 102 SB\r
+548 1168 62 (14) 62 SB\r
+698 1168 150 (yellow) 150 SB\r
+548 1227 62 (15) 62 SB\r
+698 1227 132 (white) 132 SB\r
+248 1345 110 ( }) 110 SB\r
+248 1589 30 ({ ) 30 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+278 1581 1180 (PROCEDURES CONTROLLING POSITION) 1180 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1458 1589 30 ( }) 30 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1708 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1709 221 ( MOVE : ) 221 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+577 1708 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+838 1709 333 ( \(x,y :integer\);) 333 SB\r
+248 1768 1857 ( { procedure MOVE sets the current position on the screen on the pixel ) 1857 SB\r
+398 1827 405 (with coordinates) 405 SB\r
+248 1886 503 ( x - column,) 503 SB\r
+248 1945 438 ( y - line }) 438 SB\r
+248 2004 746 ( { precondition of MOVE:) 746 SB\r
+248 2068 303 ( 0) 303 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 578 3396 0 0 CB\r
+551 2063 27 (\243) 27 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+578 2068 28 (x) 28 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 633 3396 0 0 CB\r
+606 2063 27 (\243) 27 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+633 2068 258 (MaxX & 0) 258 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 918 3396 0 0 CB\r
+891 2063 27 (\243) 27 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+918 2068 27 (y) 27 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 972 3396 0 0 CB\r
+945 2063 27 (\243) 27 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+972 2068 135 (MaxY) 135 SB\r
+248 2128 174 ( }) 174 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2246 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2247 258 ( INXPOS : ) 258 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+614 2246 221 (function) 221 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+835 2247 216 (: integer;) 216 SB\r
+248 2306 1758 ( { function INXPOS returns the x coordinate of the current position }) 1758 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2483 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2484 254 ( INYPOS : ) 254 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+610 2483 221 (function) 221 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+831 2484 232 ( : integer;) 232 SB\r
+248 2543 1769 ( { function INYPOS returns the y coordinate of the current position }) 1769 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2720 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2721 275 ( PUSHXY : ) 275 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+631 2720 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+892 2721 16 (;) 16 SB\r
+248 2780 14 ({) 14 SB\r
+398 2780 1302 (pushes current position, color & style onto the stack.) 1302 SB\r
+398 2839 1094 (The stack is kept internally, max depth is 16) 1094 SB\r
+248 2898 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 3075 125 (unit ) 125 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+373 3076 202 (POPXY: ) 202 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+575 3075 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+836 3076 16 (;) 16 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-Light\r
+%%+ font Symbol\r
+%%Page: 5 5\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+248 224 14 ({) 14 SB\r
+398 224 1288 (restores position, color & style from internal stack }) 1288 SB\r
+248 342 242 ({ Example) 242 SB\r
+248 401 699 (unit DIAGONAL : procedure;) 699 SB\r
+248 460 506 ( var ix, iy : integer;) 506 SB\r
+248 519 132 (begin) 132 SB\r
+398 578 328 (call PUSHXY;) 328 SB\r
+398 637 331 (ix := INXPOS;) 331 SB\r
+398 696 326 (iy := INYPOS;) 326 SB\r
+398 755 606 (call DRAW\(ix+10, iy+10\);) 606 SB\r
+398 814 271 (call POPXY) 271 SB\r
+248 873 394 (end DIAGONAL;) 394 SB\r
+248 932 14 (}) 14 SB\r
+248 1168 1088 ({ PROCEDURES SERVING POINTS & LINES}) 1088 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1286 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1287 220 ( POINT : ) 220 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+576 1286 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+837 1287 317 (\(x,y: integer\);) 317 SB\r
+248 1346 14 ({) 14 SB\r
+548 1346 1635 (moves current position to pixel \(x,y\) and sets it to the current color) 1635 SB\r
+248 1405 30 ( }) 30 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1523 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1524 202 ( INPIX : ) 202 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+558 1523 221 (function) 221 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+779 1524 565 ( \(x,y : integer\) : integer;) 565 SB\r
+398 1583 14 ({) 14 SB\r
+548 1642 1179 (moves to pixel \(x,y\) and returns its color setting;) 1179 SB\r
+398 1701 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1878 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1879 222 ( DRAW : ) 222 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+578 1878 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+839 1879 349 (\( x,y : integer\);) 349 SB\r
+398 1938 14 ({) 14 SB\r
+398 1998 1104 (draws a line from current screen position to \() 1104 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1502 1999 72 (x,y) 72 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1574 1998 31 (\);) 31 SB\r
+398 2058 600 (sets current position to \() 600 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+998 2059 72 (x,y) 72 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1070 2058 31 (\);) 31 SB\r
+398 2117 1357 (line is drawn in current color, with both terminal pixels) 1357 SB\r
+398 2176 1306 (always turned white \( non-background\) for non-black) 1306 SB\r
+398 2235 724 (\( non-background \) line color.) 724 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 2294 160 ( ) 160 SB\r
+398 2294 1558 (Bresenham's algorithm is used, pixels belonging to the segment) 1558 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+398 2353 1407 (change their state depending on current colour and style.) 1407 SB\r
+398 2412 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2530 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2531 200 ( intens: ) 200 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+556 2530 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+817 2531 1113 (\(Size :integer; xCoord,yCoord:arrayof integer, ) 1113 SB\r
+548 2590 545 (Colour,Filled :integer\);) 545 SB\r
+248 2649 491 (/* draw a polygon*/) 491 SB\r
+248 2708 1924 ({ draw a simple, closed polygon of Size points, the edges of the polygon go from) 1924 SB\r
+248 2768 15 (\() 15 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+263 2769 451 (xCoord[i], yCoord[i]) 451 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+714 2768 109 (\) to \() 109 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+823 2769 573 (xCoord[i+1], yCoord[i+1]) 573 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1396 2768 482 (\) for i = 1, ..., Size-1) 482 SB\r
+248 2828 581 (The colour used will be ) 581 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+829 2829 155 (Colour) 155 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+984 2828 713 (. The polygon will be filled iff ) 713 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1697 2829 132 (Filled) 132 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1829 2828 107 (<>0.) 107 SB\r
+248 2887 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 3005 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 3006 191 ( CIRB : ) 191 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+547 3005 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+808 3006 925 ( \(xi, yi, rx,ry : integer, alfa, beta : real,) 925 SB\r
+998 3065 622 ( cbord, fill : integer\);) 622 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%Page: 6 6\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+398 224 14 ({) 14 SB\r
+398 283 1566 (draws a circle \(or ellipse, depending on aspect value, see below\),) 1566 SB\r
+398 342 680 (optionally filling its interior;) 680 SB\r
+398 401 655 (does not preserve position;) 655 SB\r
+398 461 15 (\() 15 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+413 462 100 (xi,yi) 100 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+513 461 643 (\) - are center coordinates,) 643 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+398 522 47 (rx) 47 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+445 521 780 ( - radius in pixels \(horizontally\),) 780 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+398 582 50 (ry) 50 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+448 581 875 ( - radius in pixels \(perpendicularly\),) 875 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+398 642 228 (alfa, beta) 228 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+626 641 1095 ( - starting & ending angles; if alfa=beta a full) 1095 SB\r
+398 700 1337 ( circle is drawn; values should be given in radians;) 1337 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+398 761 133 (cbord) 133 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+531 760 363 ( - border color,) 363 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+398 821 59 (fill) 59 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+457 820 1220 ( - if fill <>0, interior is filled in current style&color) 1220 SB\r
+398 879 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 997 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 998 142 ( hfill: ) 142 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+498 997 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+759 998 306 (\( x : integer\);) 306 SB\r
+248 1057 1568 ( { draw an horizontal line between the current position and) 1568 SB\r
+398 1116 1513 (\(x,currentY\) with the current color, after it change the current) 1513 SB\r
+398 1175 578 (position to \(x, currentY\)) 578 SB\r
+248 1234 142 ( }) 142 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1352 125 (unit ) 125 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+373 1353 119 (vfill: ) 119 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+492 1352 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+753 1353 305 (\( y : integer\);) 305 SB\r
+248 1412 1467 ( { draw a vertical line between the current position and) 1467 SB\r
+398 1471 1516 (\(currentX,y\) with the current color, after it change the current) 1516 SB\r
+398 1530 565 (position to \(currentX,y\)) 565 SB\r
+248 1589 126 ( }) 126 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1707 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1708 208 ( patern: ) 208 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+564 1707 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+825 1708 649 (\( x1,y1,x2,y2,c,b : integer\);) 649 SB\r
+248 1768 356 ( { draw a ) 356 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-DemiItalic /font6 ANSIFont font\r
+604 1767 249 (rectangle) 249 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+853 1768 509 ( between the points \() 509 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1362 1769 134 (x1,y1) 134 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1496 1768 155 (\) and \() 155 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1651 1769 58 (x2) 58 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1709 1768 16 (,) 16 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1725 1769 61 (y2) 61 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1786 1768 231 (\) with the) 231 SB\r
+248 1828 16 ( ) 16 SB\r
+398 1828 135 (color ) 135 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+533 1829 24 (c) 24 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+557 1828 879 ( \(the current color is not change\). if ) 879 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1436 1829 30 (b) 30 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1466 1828 442 (=0 then the box is) 442 SB\r
+248 1887 16 ( ) 16 SB\r
+398 1887 516 (empty else it is filled.) 516 SB\r
+248 1946 126 ( }) 126 SB\r
+248 2072 30 ({ ) 30 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+278 2064 938 (Procedures operating on bitmaps) 938 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1216 2072 30 ( }) 30 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2191 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2192 282 ( GETMAP : ) 282 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+638 2191 221 (function) 221 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+859 2192 381 ( \(x,y : integer\) : ) 381 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+1240 2191 185 (arrayof) 185 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1425 2192 200 ( integer;) 200 SB\r
+248 2251 128 ( ) 128 SB\r
+398 2251 1263 ({saves rectangular area between current position as) 1263 SB\r
+398 2310 1179 (top left corner and \(ix,iy\) as bottom right corner,) 1179 SB\r
+398 2369 552 (including border lines;) 552 SB\r
+398 2428 713 (position remains unchanged.) 713 SB\r
+398 2487 686 (array of integer should have) 686 SB\r
+548 2551 191 (4+\(rows) 191 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 752 3396 0 0 CB\r
+739 2546 13 (\327) 13 SB\r
+gr\r
+gs 771 3396 0 0 CB\r
+752 2546 19 (\351) 19 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+771 2551 270 (columns/8) 270 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 1060 3396 0 0 CB\r
+1041 2546 19 (\371) 19 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1060 2551 16 ( ) 16 SB\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 1089 3396 0 0 CB\r
+1076 2546 13 (\327) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1089 2551 127 (coeff\)) 127 SB\r
+398 2611 1601 (bytes. The coefficient coeff is 1 for Hercules, 2 for CGA, 4 for EGA) 1601 SB\r
+248 2670 16 ( ) 16 SB\r
+398 2670 124 (card.) 124 SB\r
+248 2729 1830 ( ATTENTION: in DOS 286 environment a bigger size of the array may ) 1830 SB\r
+398 2789 543 (necessitate the use of ) 543 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+941 2790 145 (loglan) 145 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1086 2789 122 ( with) 122 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1208 2790 336 ( the option H+) 336 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1544 2789 474 (, see also memavail) 474 SB\r
+248 2848 190 ( }) 190 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2966 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2967 276 ( PUTMAP : ) 276 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+632 2966 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+893 2967 108 ( \( a: ) 108 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+1001 2966 185 (arrayof) 185 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1186 2967 215 ( integer\);) 215 SB\r
+398 3026 1256 ({sets rectangular area of screen pixels to that saved) 1256 SB\r
+398 3085 569 (by "getmap" in "iarray";) 569 SB\r
+398 3144 1267 (same size is restored, with top left corner in current) 1267 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-DemiItalic\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%+ font Symbol\r
+%%Page: 7 7\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+398 224 211 (position;) 211 SB\r
+398 283 713 (position remains unchanged.) 713 SB\r
+398 342 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 460 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 461 251 ( ORMAP : ) 251 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+607 460 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+868 461 124 ( \( a : ) 124 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+992 460 202 (arrayof ) 202 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1194 461 199 (integer\);) 199 SB\r
+398 520 1355 ({same as putmap, but saved bitmap is or'ed into screen) 1355 SB\r
+398 579 494 (rather than just set.) 494 SB\r
+398 638 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 756 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 757 287 ( XORMAP : ) 287 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+643 756 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+904 757 108 ( \( a: ) 108 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+1012 756 185 (arrayof) 185 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1197 757 215 ( integer\);) 215 SB\r
+398 816 1383 ({same as putmap, but saved bitmap is xor'ed into screen) 1383 SB\r
+398 875 494 (rather than just set.) 494 SB\r
+398 934 14 (}) 14 SB\r
+248 1119 14 ({) 14 SB\r
+32 0 0 58 58 0 0 0 54 /Bookman-Light /font7 ANSIFont font\r
+262 1111 1348 (Procedures operating on characters and strings) 1348 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1610 1119 14 (}) 14 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1238 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1239 271 ( outstring: ) 271 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+627 1238 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+888 1239 1236 (\(x,y: integer, s: string, back_col, front_col: integer\);) 1236 SB\r
+248 1299 78 ( { ) 78 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+326 1300 87 (x, y) 87 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+413 1299 1079 ( are the coordinates where to put the string,) 1079 SB\r
+248 1359 96 ( ) 96 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+344 1360 27 (s) 27 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+371 1359 780 ( is the string to be shown, in ) 780 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1151 1360 202 (front_col) 202 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1353 1359 525 ( colour letters on the ) 525 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1878 1360 205 (back_col) 205 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+398 1418 461 (colour background) 461 SB\r
+248 1477 78 ( }) 78 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1595 125 (unit ) 125 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+373 1596 175 ( track: ) 175 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+548 1595 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+809 1596 559 (\( x,y,c,valeur : integer\);) 559 SB\r
+248 1715 62 ( {) 62 SB\r
+398 1715 545 (write an integer value ) 545 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+943 1716 150 (valeur) 150 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1093 1715 400 ( at the position \() 400 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1493 1716 72 (x,y) 72 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1565 1715 382 (\) with the color ) 382 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1947 1716 24 (c) 24 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1971 1715 16 (.) 16 SB\r
+398 1774 1494 ( It does not change the current position nor the current color) 1494 SB\r
+248 1833 62 ( }) 62 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1951 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1952 196 ( inkey : ) 196 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+552 1951 221 (function) 221 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+773 1952 232 ( : integer;) 232 SB\r
+248 2070 1257 ( { returns next character from keyboard buffer;) 1257 SB\r
+398 2129 764 (0 is returned if buffer is empty;) 764 SB\r
+398 2188 1155 (special keys are returned as negative numbers;) 1155 SB\r
+398 2247 1462 (ALT-NUM method may be used for entering character codes) 1462 SB\r
+398 2306 1297 (above 127 \(this makes entering special keys 128-132) 1297 SB\r
+398 2365 291 (impossible\);) 291 SB\r
+398 2424 1069 (if a character is returned, it is also removed) 1069 SB\r
+398 2483 1290 (from the buffer, so MS-DOS will not see it \(CTRL-C!\);) 1290 SB\r
+398 2542 1020 (typeahead is allowed, echo is suppressed.) 1020 SB\r
+248 2601 62 ( }) 62 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2719 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 2720 242 ( HASCII : ) 242 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+598 2719 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+859 2720 272 (\(c: integer\);) 272 SB\r
+398 2779 806 ({'xor's the character = chr\(c\) in a ) 806 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+1204 2779 84 (8*8) 84 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1288 2779 584 ( box with top left corner) 584 SB\r
+398 2838 567 (in the current position;) 567 SB\r
+398 2897 652 (moves current position by ) 652 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+1050 2897 108 (\(8,0\)) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1158 2897 16 (;) 16 SB\r
+248 2956 16 ( ) 16 SB\r
+398 2956 1403 (call hascii\(0\)- sets complete box to black \( =background \),) 1403 SB\r
+398 3015 664 (with no change in position.) 664 SB\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 3074 160 ( ) 160 SB\r
+398 3074 1295 (BIOS ROM font for IBM color card is used. If the font) 1295 SB\r
+248 3133 160 ( ) 160 SB\r
+398 3133 1315 (table is not at F000:FA6E, the character will probably) 1315 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%Page: 8 8\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 1 0 46 /Bookman-Light /font7 ANSIFont font\r
+0 0 0 fC\r
+248 224 160 ( ) 160 SB\r
+398 224 1112 (be unrecognizable, and most certainly wrong.) 1112 SB\r
+248 283 160 ( ) 160 SB\r
+398 283 1340 (For codes >127, table pointed to by interrupt vector 31) 1340 SB\r
+248 342 160 ( ) 160 SB\r
+398 342 190 (is used.) 190 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+588 342 30 ( }) 30 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 578 125 (unit ) 125 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+373 579 161 (hfont: ) 161 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+534 578 221 (function) 221 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+755 579 1238 (\( x,y,lg,min,max,default,col_f,col_e,col_c : integer\): ) 1238 SB\r
+1298 638 344 ( integer;) 344 SB\r
+248 757 142 ( {) 142 SB\r
+398 757 832 (arrange a small 1 line window for ) 832 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-DemiItalic /font6 ANSIFont font\r
+1230 756 205 (reading) 205 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1435 757 646 ( an integer value from this) 646 SB\r
+248 816 201 (window,) 201 SB\r
+248 876 905 (the position of the window corner is \() 905 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1153 877 87 (x, y) 87 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1240 876 31 (\),) 31 SB\r
+248 936 675 (the length of the window is ) 675 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+923 937 42 (lg) 42 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+965 936 290 ( characters,) 290 SB\r
+248 996 855 (the value v should be greater than ) 855 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1103 997 89 (min) 89 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1192 996 451 ( and smaller than ) 451 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1643 997 102 (max) 102 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1745 996 16 (,) 16 SB\r
+248 1056 607 (the default value read is ) 607 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+855 1057 169 (default) 169 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1024 1056 16 (,) 16 SB\r
+248 1116 675 (the colour of the window is ) 675 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+923 1117 107 (col_f) 107 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1030 1116 16 (,) 16 SB\r
+248 1176 623 (the colour of the digits is ) 623 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+871 1177 132 (col_e,) 132 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 1236 554 (the colour of cursor is ) 554 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+802 1237 114 (col_c) 114 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+248 1354 1793 ( reads in graphic mode an integer in the window which begins at the \(x,y\)) 1793 SB\r
+398 1413 1609 (position, window is lg caracteres long. the maximum length of the) 1609 SB\r
+398 1472 1653 (integer that is read is 10. there is a default value, a minimum value) 1653 SB\r
+398 1531 1704 (and a maximum value. the window is drawn with the col_f color, the ) 1704 SB\r
+398 1590 1568 (cursor is in the col_c color and the integer is writing in the col_e) 1568 SB\r
+398 1649 1542 (color. you can use 0..9,+,-,backspace,escape and return keys. }) 1542 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 1826 108 (unit) 108 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+356 1827 245 ( HPAGE : ) 245 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+601 1826 261 (procedure) 261 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+862 1827 1332 (\(x,y,long: integer, A: arrayof char, back, front: integer\);) 1332 SB\r
+398 1887 1432 ({ this procedure arranges a 1-line high window in position ) 1432 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1830 1888 72 (x,y) 72 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1902 1887 245 ( of length ) 245 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+398 1948 100 (long) 100 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+498 1947 647 ( in which a portion of text ) 647 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1145 1948 35 (A) 35 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1180 1947 481 ( is shown in colour ) 481 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+1661 1948 112 (front) 112 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+1773 1947 187 ( on the ) 187 SB\r
+398 2007 477 (background colour ) 477 SB\r
+32 0 0 50 50 0 0 0 45 /Bookman-LightItalic /font8 ANSIFont font\r
+875 2008 115 (back) 115 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+990 2007 16 (.) 16 SB\r
+398 2066 1621 (Making use of keys controlling the cursor {left, right, PgUp, PgDn}) 1621 SB\r
+398 2125 1697 (the user can scroll the text \(horizontally\) in the window. Pressing the ) 1697 SB\r
+398 2184 884 (Enter key terminates the procedure}) 884 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 2302 95 (end) 95 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+343 2303 334 ( IIUWGRAPH;) 334 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-DemiItalic\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%Page: 9 9\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+0 0 0 fC\r
+248 283 125 (unit ) 125 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+373 284 226 (MOUSE: ) 226 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+599 283 127 (class) 127 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+726 284 16 (;) 16 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/GreNewFont{10 dict dup 3 1 roll def dup begin 6 1 roll/FontType 3\r
+def/FontMatrix exch def/FontBBox exch def/FontInfo 2 dict def FontInfo\r
+/UnderlinePosition 3 -1 roll put FontInfo/UnderlineThickness 3 -1\r
+roll put/Encoding 256 array def 0 1 255{Encoding exch/.notdef put}for\r
+/CharProcs 256 dict def CharProcs/.notdef{}put/Metrics 256 dict def\r
+Metrics/.notdef 3 -1 roll put/BuildChar{/char exch def/fontdict exch\r
+def/charname fontdict/Encoding get char get def fontdict/Metrics get\r
+charname get aload pop setcachedevice fontdict begin Encoding char\r
+get CharProcs exch get end exec}def end definefont pop}def/AddChar{begin\r
+Encoding 3 1 roll put CharProcs 3 1 roll put Metrics 3 1 roll put end}def\r
+/MSTT31c2a0 [42.0 0 0 0 0 0] 47 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c2a0 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G7b [20.0 0.0 3.0 -8.0 16.0 28.0]\r
+/G7b {\r
+ 13 36 true [1 0 0 -1 -3.0 28.0] {<003800e00180038007000f000f000f000f800f80078007800780070006000c003000c00070000c00\r
+0e0007000780078007800f800f800f000f000f000f000700038001c000e00018>} imagemask \r
+ }\r
+ 123 /G7b MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 402 20 ({) 20 SB\r
+\r
+%%BeginResource: font MSTT31c282\r
+/MSTT31c282 [42.0 0 0 0 0 0] 47 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c282 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+\r
+%%BeginResource: font MSTT31c282\r
+/G69 [12.0 0.0 1.0 0.0 10.0 26.0]\r
+/G69 {\r
+ 9 26 true [1 0 0 -1 -1.0 26.0] {<038003800380000000000000000007003f0007000e000e000e000e001c001c001c00380038003800\r
+7800700072007400f8007000>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c282 AddChar\r
+/G6e [21.0 0.0 0.0 0.0 19.0 19.0]\r
+/G6e {\r
+ 19 19 true [1 0 0 -1 0.0 19.0] {<0703c03f0fc00719e00e31e00e61c00e41c00c81c01d03c01e03801e03803c07803c070038070038\r
+0f00700e00700e40700e80e01f00e00e00>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c282 AddChar\r
+/G74 [12.0 0.0 1.0 0.0 13.0 25.0]\r
+/G74 {\r
+ 12 25 true [1 0 0 -1 -1.0 25.0] {<004000800180018003800f003ff00f000f000e000e001e001c001c001c003c003800380038007800\r
+700073007200fc007000>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c282 AddChar\r
+%%EndResource\r
+\r
+398 402 57 (init) 57 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c2a0 AddChar\r
+/G2d [14.0 0.0 2.0 8.0 13.0 12.0]\r
+/G2d {\r
+ 11 4 true [1 0 0 -1 -2.0 12.0] {<ffe0ffe0ffe0ffe0>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c2a0 AddChar\r
+/G6c [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G6c {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<06003e00fe001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c2a0 AddChar\r
+/G6f [20.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G6f {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<03f0000ffc001e3e00380f00380f80700780700780f003c0f003c0f003c0f003c0f003c0f003c0f8\r
+03c07803807803803c07003e07001f0e000ffc0003f000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c2a0 AddChar\r
+/G72 [15.0 0.0 1.0 0.0 15.0 20.0]\r
+/G72 {\r
+ 14 20 true [1 0 0 -1 -1.0 20.0] {<06383e7cfefc1f981f001e001e001e001e001e001e001e001e001e001e001e001e001e003f00ffc0\r
+>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c2a0 AddChar\r
+/G73 [16.0 0.0 2.0 -1.0 15.0 20.0]\r
+/G73 {\r
+ 13 21 true [1 0 0 -1 -2.0 20.0] {<0f903ff07070e030e010e010f000f8007e007f803fe00ff003f000f880788038c038c030f070ffe0\r
+8f80>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c2a0 AddChar\r
+/G64 [21.0 0.0 1.0 -1.0 21.0 29.0]\r
+/G64 {\r
+ 20 30 true [1 0 0 -1 -1.0 29.0] {<000180000f80003f8000078000078000078000078000078000078003e7800ff7801e1f801c0f8038\r
+0f80780780700780700780f00780f00780f00780f00780f00780f00780f807807807807c0f803e1f\r
+803ff7f01fe7e007c700>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c2a0 AddChar\r
+/G65 [18.0 0.0 1.0 -1.0 17.0 20.0]\r
+/G65 {\r
+ 16 21 true [1 0 0 -1 -1.0 20.0] {<03e00ff81c3c301e700e600f600fffffe000e000e000e000f000f00178017c037e063ffe1ffc0ff8\r
+03e0>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c2a0 AddChar\r
+/G27 [8.0 0.0 2.0 17.0 6.0 29.0]\r
+/G27 {\r
+ 4 12 true [1 0 0 -1 -2.0 29.0] {<60f0f0f0f0f0f0f060606060>} imagemask \r
+ }\r
+ 39 /G27 MSTT31c2a0 AddChar\r
+/G69 [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G69 {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<0c001e001e000c000000000000000000000006003e00fe001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c2a0 AddChar\r
+/G6e [22.0 0.0 1.0 0.0 22.0 20.0]\r
+/G6e {\r
+ 21 20 true [1 0 0 -1 -1.0 20.0] {<061e003e7f00fec7801f07c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e\r
+03c01e03c01e03c01e03c01e03c03f03e0ffcff8>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c2a0 AddChar\r
+/G74 [12.0 0.0 0.0 -1.0 12.0 25.0]\r
+/G74 {\r
+ 12 26 true [1 0 0 -1 0.0 25.0] {<0200060006000e001e003e00ffe01e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001f300fe00780>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c2a0 AddChar\r
+/G61 [19.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G61 {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<07f0001e7800383c00781e00781e00781e00301e00001e00003e0001de00071e001c1e00381e0070\r
+1e00f01e00f01e00f01e00f03e00787e407f9f801e0e00>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c2a0 AddChar\r
+/G75 [21.0 0.0 0.0 -1.0 21.0 19.0]\r
+/G75 {\r
+ 21 20 true [1 0 0 -1 0.0 19.0] {<fe1fc03e07c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e\r
+03c01e03c01e03c01e07c00f1bf807f3e003c300>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c2a0 AddChar\r
+/G2c [11.0 0.0 2.0 -7.0 8.0 3.0]\r
+/G2c {\r
+ 6 10 true [1 0 0 -1 -2.0 3.0] {<70f8fc740404081020c0>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c2a0 AddChar\r
+/G70 [21.0 0.0 0.0 -9.0 20.0 20.0]\r
+/G70 {\r
+ 20 29 true [1 0 0 -1 0.0 20.0] {<061e003e7f80feffc01e87c01f03e01e01e01e01f01e00f01e00f01e00f01e00f01e00f01e00f01e\r
+00f01e00e01e01e01e01c01f03c01f87801eff001e7c001e00001e00001e00001e00001e00001e00\r
+003f0000ffc000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c2a0 AddChar\r
+/Ge9 [18.0 0.0 1.0 -1.0 17.0 29.0]\r
+/Ge9 {\r
+ 16 30 true [1 0 0 -1 -1.0 29.0] {<003c003800700060006000c000800000000003e00ff81c3c301e700e600f600fffffe000e000e000\r
+e000f000f00178017c037e063ffe1ffc0ff803e0>} imagemask \r
+ }\r
+ 233 /Ge9 MSTT31c2a0 AddChar\r
+/G66 [13.0 0.0 0.0 0.0 17.0 29.0]\r
+/G66 {\r
+ 17 29 true [1 0 0 -1 0.0 29.0] {<007c0001ff00038f800707800703000f00000f00000f00000f00000f0000fff8000f00000f00000f\r
+00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00\r
+001f8000fff000>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c2a0 AddChar\r
+/G76 [20.0 0.0 -1.0 -1.0 20.0 19.0]\r
+/G76 {\r
+ 21 20 true [1 0 0 -1 1.0 19.0] {<ffc1f83f00601e00601f00400f00400f808007808007810003c10003c10003e20001e20001e40000\r
+f40000f400007800007800007000003000003000>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c2a0 AddChar\r
+/G6d [33.0 0.0 1.0 0.0 33.0 20.0]\r
+/G6d {\r
+ 32 20 true [1 0 0 -1 -1.0 20.0] {<061f03c03e7f8fe0fec798f01f07e0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c078\r
+1e03c0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c0783f03e07cffcff9ff\r
+>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c2a0 AddChar\r
+/G71 [21.0 0.0 1.0 -9.0 21.0 20.0]\r
+/G71 {\r
+ 20 29 true [1 0 0 -1 -1.0 20.0] {<01e18007fb801e1f803c0f80380780780780700780700780f00780f00780f00780f00780f00780f0\r
+0780f807807807807c07803c0f803f37801fe7800787800007800007800007800007800007800007\r
+80000fc0003ff0>} imagemask \r
+ }\r
+ 113 /G71 MSTT31c2a0 AddChar\r
+/G67 [21.0 0.0 1.0 -9.0 21.0 20.0]\r
+/G67 {\r
+ 20 29 true [1 0 0 -1 -1.0 20.0] {<01f800071ff00e0f001c0f803c07803c07803c07803c07803c07801e07001e0e000f1c0007f8000c\r
+00001800001800003c00003fff801fffc00fffe01800e0300060600060600060e000c0f001807c0f\r
+003ffe000ff000>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c2a0 AddChar\r
+/G63 [18.0 0.0 1.0 -1.0 17.0 20.0]\r
+/G63 {\r
+ 16 21 true [1 0 0 -1 -1.0 20.0] {<01f00ffc1c1e380f300f70076000e000e000e000e000e000f000f00178037c027e0e3ffc1ffc0ff8\r
+03e0>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+455 402 11 ( ) 16 SB\r
+471 402 88 (-lors ) 93 SB\r
+564 402 50 (de ) 55 SB\r
+619 402 245 (l'initialisation ) 250 SB\r
+869 402 50 (de ) 55 SB\r
+924 402 42 (la ) 47 SB\r
+971 402 122 (souris, ) 127 SB\r
+1098 402 53 (on ) 58 SB\r
+1156 402 83 (peut ) 88 SB\r
+1244 402 124 (d\351finir ) 129 SB\r
+1373 402 57 (les ) 63 SB\r
+1436 402 208 (\351v\351nements ) 214 SB\r
+1650 402 65 (qui ) 71 SB\r
+1721 402 85 (vont ) 91 SB\r
+1812 402 88 (faire ) 94 SB\r
+1906 402 111 (r\351agir ) 117 SB\r
+2023 402 42 (la ) 48 SB\r
+2071 402 139 (fonction) 139 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G3b [12.0 0.0 3.0 -7.0 9.0 20.0]\r
+/G3b {\r
+ 6 27 true [1 0 0 -1 -3.0 20.0] {<60f0f0600000000000000000000000000070f8fc7c0404081020c0>} imagemask \r
+ }\r
+ 59 /G3b MSTT31c2a0 AddChar\r
+/G78 [21.0 0.0 1.0 0.0 21.0 19.0]\r
+/G78 {\r
+ 20 19 true [1 0 0 -1 -1.0 19.0] {<ff0fe03e03801e03001f02000f840007c80003d00003e00001f00000f00000f800017c00023e0004\r
+1e00081f00100f803007807007c0fc1ff0>} imagemask \r
+ }\r
+ 120 /G78 MSTT31c2a0 AddChar\r
+/Ge8 [18.0 0.0 1.0 -1.0 17.0 29.0]\r
+/Ge8 {\r
+ 16 30 true [1 0 0 -1 -1.0 29.0] {<0f00070003800180018000c000400000000003e00ff81c3c301e700e600f600fffffe000e000e000\r
+e000f000f00178017c037e063ffe1ffc0ff803e0>} imagemask \r
+ }\r
+ 232 /Ge8 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 450 160 (getpress; ) 162 SB\r
+410 450 41 (le ) 43 SB\r
+453 450 143 (premier ) 145 SB\r
+598 450 41 (et ) 43 SB\r
+641 450 41 (le ) 43 SB\r
+684 450 173 (deuxi\350me ) 175 SB\r
+859 450 181 (param\350tre ) 183 SB\r
+1042 450 218 (repr\351sentent ) 220 SB\r
+1262 450 264 (respectivement ) 266 SB\r
+1528 450 42 (la ) 44 SB\r
+1572 450 111 (souris ) 113 SB\r
+1685 450 41 (et ) 43 SB\r
+1728 450 41 (le ) 43 SB\r
+1771 450 136 (clavier, ) 139 SB\r
+1910 450 39 (si ) 42 SB\r
+1952 450 72 (une ) 75 SB\r
+2027 450 116 (valeur ) 119 SB\r
+2146 450 64 (non) 64 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/Ge0 [19.0 0.0 1.0 -1.0 19.0 29.0]\r
+/Ge0 {\r
+ 18 30 true [1 0 0 -1 -1.0 29.0] {<07800003800001c00000c00000c00000600000200000000000000007f0001e7800383c00781e0078\r
+1e00781e00301e00001e00003e0001de00071e001c1e00381e00701e00f01e00f01e00f01e00f03e\r
+00787e407f9f801e0e00>} imagemask \r
+ }\r
+ 224 /Ge0 MSTT31c2a0 AddChar\r
+/G2e [11.0 0.0 3.0 -1.0 7.0 3.0]\r
+/G2e {\r
+ 4 4 true [1 0 0 -1 -3.0 3.0] {<60f0f060>} imagemask \r
+ }\r
+ 46 /G2e MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 498 1212 (nulle est donn\351e comme param\350tre alors getpress r\351agira \340 l'\351v\351nement.) 1212 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G55 [29.0 0.0 0.0 -1.0 29.0 28.0]\r
+/G55 {\r
+ 29 29 true [1 0 0 -1 0.0 28.0] {<fff01ff81f8003c00f0001800f0001800f0001800f0001800f0001800f0001800f0001800f000180\r
+0f0001800f0001800f0001800f0001800f0001800f0001800f0001800f0001800f0001800f000180\r
+0f0001800f00018007800300078003000780070003c00e0001f03c0000fff800003fc000>} imagemask \r
+ }\r
+ 85 /G55 MSTT31c2a0 AddChar\r
+/G28 [14.0 0.0 2.0 -8.0 13.0 28.0]\r
+/G28 {\r
+ 11 36 true [1 0 0 -1 -2.0 28.0] {<002000c00180030006000c001c001c00380038007800780070007000f000f000f000f000f000f000\r
+f000f0007000700078007800380038001c001c000e0006000300018000c00020>} imagemask \r
+ }\r
+ 40 /G28 MSTT31c2a0 AddChar\r
+/G31 [21.0 0.0 5.0 0.0 17.0 28.0]\r
+/G31 {\r
+ 12 28 true [1 0 0 -1 -5.0 28.0] {<07003f00df000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f00\r
+0f000f000f000f000f000f001f80fff0>} imagemask \r
+ }\r
+ 49 /G31 MSTT31c2a0 AddChar\r
+/G29 [14.0 0.0 1.0 -8.0 12.0 28.0]\r
+/G29 {\r
+ 11 36 true [1 0 0 -1 -1.0 28.0] {<80006000300018000c000e00070007000380038003c003c001c001e001e001e001e001e001e001e0\r
+01e001e001c001c003c003c0038003800700070006000c001800300060008000>} imagemask \r
+ }\r
+ 41 /G29 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+398 594 80 (Une ) 81 SB\r
+479 594 96 (paire ) 97 SB\r
+576 594 92 (\(1,1\) ) 93 SB\r
+669 594 50 (va ) 51 SB\r
+720 594 173 (permettre ) 174 SB\r
+894 594 50 (de ) 51 SB\r
+945 594 141 (prendre ) 142 SB\r
+1087 594 51 (en ) 52 SB\r
+1139 594 133 (compte ) 134 SB\r
+1273 594 30 (\340 ) 31 SB\r
+1304 594 42 (la ) 43 SB\r
+1347 594 72 (fois ) 73 SB\r
+1420 594 57 (les ) 58 SB\r
+1478 594 208 (\351v\351nements ) 209 SB\r
+1687 594 50 (de ) 51 SB\r
+1738 594 42 (la ) 44 SB\r
+1782 594 111 (souris ) 113 SB\r
+1895 594 41 (et ) 43 SB\r
+1938 594 89 (ceux ) 91 SB\r
+2029 594 53 (du ) 55 SB\r
+2084 594 126 (clavier;) 126 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G30 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G30 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<01e0000618000c0c001c0e00380700380700780780780380700380f003c0f003c0f003c0f003c0f0\r
+03c0f003c0f003c0f003c0f003c0f003c07003807003807807803807003807001c0e000c0c000618\r
+0003e000>} imagemask \r
+ }\r
+ 48 /G30 MSTT31c2a0 AddChar\r
+/G50 [23.0 0.0 0.0 0.0 22.0 28.0]\r
+/G50 {\r
+ 22 28 true [1 0 0 -1 0.0 28.0] {<ffff001fffc00f03f00f00f00f00780f007c0f003c0f003c0f003c0f003c0f007c0f00780f00f80f\r
+03f00fffe00f7f800f00000f00000f00000f00000f00000f00000f00000f00000f00000f00001f80\r
+00fff000>} imagemask \r
+ }\r
+ 80 /G50 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 642 72 (une ) 73 SB\r
+321 642 96 (paire ) 97 SB\r
+418 642 92 (\(1,0\) ) 93 SB\r
+511 642 115 (quand ) 116 SB\r
+627 642 30 (\340 ) 31 SB\r
+658 642 71 (elle ) 72 SB\r
+730 642 51 (ne ) 52 SB\r
+782 642 142 (prendra ) 144 SB\r
+926 642 51 (en ) 53 SB\r
+979 642 133 (compte ) 135 SB\r
+1114 642 71 (que ) 73 SB\r
+1187 642 42 (la ) 44 SB\r
+1231 642 122 (souris. ) 124 SB\r
+1355 642 90 (Pour ) 92 SB\r
+1447 642 72 (une ) 74 SB\r
+1521 642 81 (plus ) 83 SB\r
+1604 642 127 (grande ) 129 SB\r
+1733 642 169 (souplesse ) 171 SB\r
+1904 642 221 (d'utilisation, ) 223 SB\r
+2127 642 35 (il ) 37 SB\r
+2164 642 46 (est) 46 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G62 [20.0 0.0 -1.0 -1.0 19.0 29.0]\r
+/G62 {\r
+ 20 30 true [1 0 0 -1 1.0 29.0] {<0600003e0000fe00001e00001e00001e00001e00001e00001e00001e1e001e7f801effc01f87c01f\r
+03e01e01e01e01f01e00f01e00f01e00f01e00f01e00f01e00f01e00e01e00e01e01e01e01c01f03\r
+800f870007fe0001f800>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c2a0 AddChar\r
+/G68 [22.0 0.0 1.0 0.0 22.0 29.0]\r
+/G68 {\r
+ 21 29 true [1 0 0 -1 -1.0 29.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e1e001e7f001ec7801f07801e\r
+03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03\r
+c03f03e0ffcff8>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 690 146 (possible ) 150 SB\r
+398 690 74 (lors ) 78 SB\r
+476 690 53 (du ) 57 SB\r
+533 690 217 (programme, ) 222 SB\r
+755 690 100 (apr\350s ) 105 SB\r
+860 690 244 (l'initalisation, ) 249 SB\r
+1109 690 50 (de ) 55 SB\r
+1164 690 146 (changer ) 151 SB\r
+1315 690 89 (cette ) 94 SB\r
+1409 690 93 (prise ) 98 SB\r
+1507 690 51 (en ) 56 SB\r
+1563 690 144 (compte, ) 149 SB\r
+1712 690 78 (cela ) 83 SB\r
+1795 690 45 (se ) 50 SB\r
+1845 690 76 (fera ) 81 SB\r
+1926 690 66 (par ) 71 SB\r
+1997 690 122 (l'appel ) 127 SB\r
+2124 690 50 (de ) 55 SB\r
+2179 690 31 (la) 31 SB\r
+248 738 178 (procedure ) 178 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+\r
+%%BeginResource: font MSTT31c282\r
+/G67 [21.0 0.0 -2.0 -9.0 22.0 19.0]\r
+/G67 {\r
+ 24 28 true [1 0 0 -1 2.0 19.0] {<003f8000e1fe01c0fe0380700700700f00700f00f00e00f00e00e00e01c00703c003870001fc0000\r
+c00003000007000007c00007fc0003ff800c7fc03007e07000e0e00060e00060e000407000803c07\r
+0007f800>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c282 AddChar\r
+/G65 [19.0 0.0 1.0 0.0 17.0 19.0]\r
+/G65 {\r
+ 16 19 true [1 0 0 -1 -1.0 19.0] {<007c018f07070e071c07180e381e7038707073c0fc00e000e000e000f00470187c303fe01f00>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c282 AddChar\r
+/G6d [30.0 0.0 0.0 0.0 28.0 19.0]\r
+/G6d {\r
+ 28 19 true [1 0 0 -1 0.0 19.0] {<070781e03f0f83e00713c4f00e23c8f00e4390e00e83a0e00d03a1e01d0741e01e0781c01e0781c0\r
+3c0f03c03c0f0380380e0380380e0780701c0710701c0720701c0740e0380f80e0380700>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c282 AddChar\r
+/G6f [21.0 0.0 1.0 0.0 19.0 19.0]\r
+/G6f {\r
+ 18 19 true [1 0 0 -1 -1.0 19.0] {<007c000187000703800e01801c01c03c01c03801c07803c07003c0f003c0f00380f00780e00700e0\r
+0f00e00e00601c007038003860000f8000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c282 AddChar\r
+/G76 [19.0 0.0 0.0 0.0 18.0 19.0]\r
+/G76 {\r
+ 18 19 true [1 0 0 -1 0.0 19.0] {<1c0180fc03c01c03c01e01c00e00c00e00800e01800e01000e02000f06000f0c0007080007100007\r
+200007400007c000078000070000060000>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c282 AddChar\r
+%%EndResource\r
+\r
+426 738 223 (getmovement) 223 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G79 [19.0 0.0 -1.0 -9.0 19.0 19.0]\r
+/G79 {\r
+ 20 28 true [1 0 0 -1 1.0 19.0] {<ffc3f03f00c01e00801f00800f00800f010007810007810003c20003c20003e40001e40001f40000\r
+f80000f8000078000070000070000030000020000020000040000040000040003880007f00007e00\r
+003c0000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c2a0 AddChar\r
+/Gea [18.0 0.0 1.0 -1.0 17.0 29.0]\r
+/Gea {\r
+ 16 30 true [1 0 0 -1 -1.0 29.0] {<03e003e0077006300c18080810040000000003e00ff81c3c301e700e600f600fffffe000e000e000\r
+e000f000f00178017c037e063ffe1ffc0ff803e0>} imagemask \r
+ }\r
+ 234 /Gea MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+649 738 1385 (, proc\351dure ayant les m\352mes param\350tres \(avec le m\352me ordre\) que la fonction init.) 1385 SB\r
+398 834 869 (Pour detecter les \351v\351nements, on utilisa la fonction ) 870 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+\r
+%%BeginResource: font MSTT31c282\r
+/G70 [21.0 0.0 -4.0 -9.0 20.0 19.0]\r
+/G70 {\r
+ 24 28 true [1 0 0 -1 4.0 19.0] {<00387c01f9fe007b1e00760f007c0700780700700700f00700e00e00e00e01c00e01c01c01c01c01\r
+c0380380300380600380c007c38007fe000700000700000e00000e00000e00001c00001c00003e00\r
+00ff8000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c282 AddChar\r
+/G72 [16.0 0.0 0.0 0.0 16.0 19.0]\r
+/G72 {\r
+ 16 19 true [1 0 0 -1 0.0 19.0] {<07073f0f0f1f0e3f0e660e460e801d001d001e003c003c0038003800700070007000e000e000>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c282 AddChar\r
+/G73 [16.0 0.0 0.0 0.0 16.0 19.0]\r
+/G73 {\r
+ 16 19 true [1 0 0 -1 0.0 19.0] {<01f1070f06070e020e020f020f8007c003e001e001f000f8407840384038e038e030f0608f80>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c282 AddChar\r
+%%EndResource\r
+\r
+1268 834 140 (getpress) 140 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+1408 834 22 (, ) 23 SB\r
+1431 834 65 (qui ) 66 SB\r
+1497 834 152 (retourne ) 153 SB\r
+1650 834 54 (un ) 55 SB\r
+1705 834 141 (bool\351en ) 142 SB\r
+1847 834 173 (indiquant ) 174 SB\r
+2021 834 42 (la ) 43 SB\r
+2064 834 146 (pr\351sence) 146 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G49 [14.0 0.0 1.0 0.0 13.0 28.0]\r
+/G49 {\r
+ 12 28 true [1 0 0 -1 -1.0 28.0] {<fff01f800f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f00\r
+0f000f000f000f000f000f001f80fff0>} imagemask \r
+ }\r
+ 73 /G49 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 882 52 (ou ) 55 SB\r
+303 882 162 (l'absence ) 165 SB\r
+468 882 221 (d'\351v\351nement ) 224 SB\r
+692 882 278 (\(respectivement ) 281 SB\r
+973 882 57 (les ) 60 SB\r
+1033 882 132 (valeurs ) 136 SB\r
+1169 882 77 (true ) 81 SB\r
+1250 882 41 (et ) 45 SB\r
+1295 882 114 (false\). ) 118 SB\r
+1413 882 37 (Il ) 41 SB\r
+1454 882 57 (est ) 61 SB\r
+1515 882 73 (bon ) 77 SB\r
+1592 882 50 (de ) 54 SB\r
+1646 882 98 (noter ) 102 SB\r
+1748 882 142 (qu'ainsi ) 146 SB\r
+1894 882 127 (d\351finie ) 131 SB\r
+2025 882 42 (la ) 46 SB\r
+2071 882 139 (fonction) 139 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G4c [25.0 0.0 0.0 0.0 24.0 28.0]\r
+/G4c {\r
+ 24 28 true [1 0 0 -1 0.0 28.0] {<fff0001f80000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f\r
+00000f00000f00000f00000f00000f00000f00000f00010f00030f00020f00060f000e0f801e1fff\r
+fcfffffc>} imagemask \r
+ }\r
+ 76 /G4c MSTT31c2a0 AddChar\r
+/G3a [12.0 0.0 4.0 -1.0 8.0 20.0]\r
+/G3a {\r
+ 4 21 true [1 0 0 -1 -4.0 20.0] {<60f0f0600000000000000000000000000060f0f060>} imagemask \r
+ }\r
+ 58 /G3a MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 930 1790 (getpress n'est pas bloquante. Les param\350tres en retour sont soit nuls \(pas d'\351v\351nement\) soit correspondent:) 1790 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G3d [24.0 0.0 1.0 10.0 23.0 19.0]\r
+/G3d {\r
+ 22 9 true [1 0 0 -1 -1.0 19.0] {<fffffcfffffc000000000000000000000000000000fffffcfffffc>} imagemask \r
+ }\r
+ 61 /G3d MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+398 1026 600 (bool:=getpress\(v,p,h,l,r,c : integer\);) 600 SB\r
+548 1074 485 (v = position en y de la souris) 485 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G6b [21.0 0.0 0.0 0.0 21.0 29.0]\r
+/G6b {\r
+ 21 29 true [1 0 0 -1 0.0 29.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e0ff01e07801e06001e\r
+0c001e18001e30001e60001ee0001ff0001ef0001e78001e3c001e1e001e1f001e0f001e07801e03\r
+c03f03e0ffcff8>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c2a0 AddChar\r
+/G54 [26.0 0.0 1.0 0.0 25.0 28.0]\r
+/G54 {\r
+ 24 28 true [1 0 0 -1 -1.0 28.0] {<ffffffffffffe03c07c03c03c03c03803c01803c01003c00003c00003c00003c00003c00003c0000\r
+3c00003c00003c00003c00003c00003c00003c00003c00003c00003c00003c00003c00003c00007e\r
+0003ffc0>} imagemask \r
+ }\r
+ 84 /G54 MSTT31c2a0 AddChar\r
+/G5f [21.0 0.0 0.0 -9.0 21.0 -7.0]\r
+/G5f {\r
+ 21 2 true [1 0 0 -1 0.0 -7.0] {<fffff8fffff8>} imagemask \r
+ }\r
+ 95 /G5f MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+548 1122 1490 (p = keyboard status \(Touche control_left,control_right, alt, alt_gr, shift_left, shift_right\)) 1490 SB\r
+548 1170 489 (h = position en x de la souris) 489 SB\r
+548 1218 305 (l = touche clavier) 305 SB\r
+548 1266 142 (r = flags) 142 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G32 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G32 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<03e0000ff8001ffc00387e00303f00201f00400f00400f00000f00000f00000f00000e00000e0000\r
+1c00001c0000380000300000600000e00000c0000180000300000600000c00c01801803fff807fff\r
+00ffff00>} imagemask \r
+ }\r
+ 50 /G32 MSTT31c2a0 AddChar\r
+/G33 [21.0 0.0 2.0 0.0 17.0 28.0]\r
+/G33 {\r
+ 15 28 true [1 0 0 -1 -2.0 28.0] {<07c01ff03ff8707c403c801c001c001c001800300020004001f007f800fc007c003e001e001e000e\r
+000e000e000c000c0018e030f8607f80>} imagemask \r
+ }\r
+ 51 /G33 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+548 1314 1270 (c = boutons de la souris \(0=aucun, 1=gauche, 2=droite, 3=gauche et droite\)) 1270 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G4e [30.0 0.0 0.0 0.0 30.0 28.0]\r
+/G4e {\r
+ 30 28 true [1 0 0 -1 0.0 28.0] {<fe000ffc3f0001e00f8000c007c000c007c000c007e000c007f000c006f800c0067c00c0063e00c0\r
+063e00c0061f00c0060f80c00607c0c00603e0c00603e0c00601f0c00600f8c006007cc006003ec0\r
+06001fc006001fc006000fc0060007c0060003c0060001c00f0000c07fe000c0>} imagemask \r
+ }\r
+ 78 /G4e MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+698 1362 604 (Nb: le bouton central n'est pas g\351r\351.) 604 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G4f [30.0 0.0 1.0 -1.0 29.0 29.0]\r
+/G4f {\r
+ 28 30 true [1 0 0 -1 -1.0 29.0] {<003fc00000fff00003e07c0007801e000f000f001e0007803e0007c03c0003c07c0003e07c0003e0\r
+780001e0f80001f0f80001f0f80001f0f80001f0f80001f0f80001f0f80001f0f80001f0780001e0\r
+7c0003e07c0003e03c0003c03e0007c01e0007800f000f0007801e0003e07c0000fff000003fc000\r
+>} imagemask \r
+ }\r
+ 79 /G4f MSTT31c2a0 AddChar\r
+/G45 [26.0 0.0 0.0 0.0 25.0 28.0]\r
+/G45 {\r
+ 25 28 true [1 0 0 -1 0.0 28.0] {<fffffe001ffffe000f000e000f0006000f0002000f0002000f0000000f0000000f0010000f001000\r
+0f0030000f0030000ffff0000ffff0000f0030000f0030000f0010000f0010000f0000000f000000\r
+0f0000000f0000800f0001000f0003000f0007000f000e001ffffe00fffffe00>} imagemask \r
+ }\r
+ 69 /G45 MSTT31c2a0 AddChar\r
+/G5a [25.0 0.0 0.0 0.0 24.0 28.0]\r
+/G5a {\r
+ 24 28 true [1 0 0 -1 0.0 28.0] {<0fffff0ffffe0c003c08007c1800f81000f01001f00003e00007c0000780000f80001f00001e0000\r
+3e00007c0000f80000f00001f00003e00007c0000780010f80011f00031e00023e00067c000effff\r
+fefffffe>} imagemask \r
+ }\r
+ 90 /G5a MSTT31c2a0 AddChar\r
+/G42 [27.0 0.0 0.0 0.0 25.0 28.0]\r
+/G42 {\r
+ 25 28 true [1 0 0 -1 0.0 28.0] {<ffffc0001ffff8000f00fc000f003e000f001e000f000f000f000f000f000f000f000f000f001f00\r
+0f001e000f007c000ffff8000fffe0000f007c000f001e000f000f000f000f000f0007800f000780\r
+0f0007800f0007800f000f800f000f000f001f000f007e001ffff800ffffe000>} imagemask \r
+ }\r
+ 66 /G42 MSTT31c2a0 AddChar\r
+/G21 [14.0 0.0 5.0 -1.0 9.0 29.0]\r
+/G21 {\r
+ 4 30 true [1 0 0 -1 -5.0 29.0] {<60f0f0f0f0f0f0f0f0f0f0f0f06060606060606060606000000060f0f060>} imagemask \r
+ }\r
+ 33 /G21 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1459 148 (NOTEZ ) 150 SB\r
+398 1459 122 (BIEN! ) 124 SB\r
+522 1459 147 (Lorsque ) 149 SB\r
+671 1459 57 (les ) 59 SB\r
+730 1459 208 (\351v\351nements ) 210 SB\r
+940 1459 53 (du ) 55 SB\r
+995 1459 125 (clavier ) 127 SB\r
+1122 1459 81 (sont ) 83 SB\r
+1205 1459 75 (pris ) 77 SB\r
+1282 1459 51 (en ) 53 SB\r
+1335 1459 133 (compte ) 136 SB\r
+1471 1459 89 (dans ) 92 SB\r
+1563 1459 41 (le ) 44 SB\r
+1607 1459 229 (gestionnaire, ) 232 SB\r
+\r
+%%BeginResource: font MSTT31c2c7\r
+/MSTT31c2c7 [42.0 0 0 0 0 0] 95 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c2c7 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+\r
+%%BeginResource: font MSTT31c2c7\r
+/G69 [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G69 {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<1e003f003f003f003f001e000000000000000000ff003f003f003f003f003f003f003f003f003f00\r
+3f003f003f003f003f003f003f003f00ffc0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c2c7 AddChar\r
+/G6c [12.0 0.0 1.0 0.0 11.0 28.0]\r
+/G6c {\r
+ 10 28 true [1 0 0 -1 -1.0 28.0] {<ff003f003f003f003f003f003f003f003f003f003f003f003f003f003f003f003f003f003f003f00\r
+3f003f003f003f003f003f003f00ffc0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c2c7 AddChar\r
+%%EndResource\r
+\r
+1839 1458 24 (il) 24 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+1863 1459 11 ( ) 14 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+\r
+%%BeginResource: font MSTT31c2c7\r
+/G6e [23.0 0.0 1.0 0.0 22.0 20.0]\r
+/G6e {\r
+ 21 20 true [1 0 0 -1 -1.0 20.0] {<000f00ff3f803f7fc03fcfe03f87e03f87e03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f\r
+07e03f07e03f07e03f07e03f07e03f07e0ffdff8>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c2c7 AddChar\r
+/G65 [19.0 0.0 1.0 -1.0 18.0 20.0]\r
+/G65 {\r
+ 17 21 true [1 0 0 -1 -1.0 20.0] {<03f0000f3c001e3e003c1f003c1f007c1f007c1f80fc1f80ffff80fc0000fc0000fc0000fe0000fe\r
+0000fe00007f00807f01803fc7001ffe000ffc0003f000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c2c7 AddChar\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c2c7 AddChar\r
+/G66 [14.0 0.0 0.0 0.0 16.0 29.0]\r
+/G66 {\r
+ 16 29 true [1 0 0 -1 0.0 29.0] {<00fc039e079f0f9f0f9f1f8e1f801f801f801f80fff0fff01f801f801f801f801f801f801f801f80\r
+1f801f801f801f801f801f801f801f807fe0>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c2c7 AddChar\r
+/G61 [21.0 0.0 2.0 -1.0 21.0 20.0]\r
+/G61 {\r
+ 19 21 true [1 0 0 -1 -2.0 20.0] {<03f0000c7c00383e00383f007c3f007c3f007c3f00383f00007f0001bf00073f000e3f003e3f007c\r
+3f007c3f00fc3f00fc3f00fe7f00ffbfe07f1fc03c0f00>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c2c7 AddChar\r
+/G75 [22.0 0.0 0.0 -1.0 21.0 19.0]\r
+/G75 {\r
+ 21 20 true [1 0 0 -1 0.0 19.0] {<ff1fe03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f07e03f\r
+07e03f07e03f0fe03f9fe01ff7e00fe7f8078000>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c2c7 AddChar\r
+/G74 [14.0 0.0 0.0 -1.0 13.0 26.0]\r
+/G74 {\r
+ 13 27 true [1 0 0 -1 0.0 26.0] {<008001800180038007800f801f807ff8fff81f801f801f801f801f801f801f801f801f801f801f80\r
+1f801f801f881f980ff00fe003c0>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c2c7 AddChar\r
+/G70 [23.0 0.0 1.0 -9.0 21.0 20.0]\r
+/G70 {\r
+ 20 29 true [1 0 0 -1 -1.0 20.0] {<001e00ff3f803f4fc03f87c03f07e03f03e03f03f03f03f03f03f03f03f03f03f03f03f03f03f03f\r
+03f03f03f03f03e03f03e03f07c03f87c03f4f803f3e003f00003f00003f00003f00003f00003f00\r
+003f0000ffc000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c2c7 AddChar\r
+/G73 [16.0 0.0 2.0 -1.0 15.0 20.0]\r
+/G73 {\r
+ 13 21 true [1 0 0 -1 -2.0 20.0] {<1f1038f070707070f830fc30fe10ff00ffc07fe03ff01ff00ff807f881f8c0f8c078e070f070f8e0\r
+8f80>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c2c7 AddChar\r
+%%EndResource\r
+\r
+1877 1458 53 (ne ) 56 SB\r
+1933 1458 82 (faut ) 85 SB\r
+2018 1458 71 (pas ) 74 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+2092 1459 118 (utiliser) 118 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G38 [21.0 0.0 2.0 0.0 19.0 28.0]\r
+/G38 {\r
+ 17 28 true [1 0 0 -1 -2.0 28.0] {<07e0001c3800381e00700e00f00f00f00f00f00f00f80f00fc1e007e1c003f38001fb0000fc00007\r
+e00007f8000cfc00187e00383f00701f00f00f80f00f80f00780f00780f00780780700380e001e1c\r
+0007f000>} imagemask \r
+ }\r
+ 56 /G38 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1514 57 (les ) 69 SB\r
+317 1514 166 (fonctions ) 178 SB\r
+495 1514 159 (d'entr\351es ) 171 SB\r
+666 1514 125 (clavier ) 137 SB\r
+803 1514 107 (readl, ) 119 SB\r
+922 1514 129 (readln, ) 141 SB\r
+1063 1514 111 (hfont, ) 123 SB\r
+1186 1514 132 (hfont8, ) 145 SB\r
+1331 1514 123 (hpage, ) 136 SB\r
+1467 1514 161 (inkey,...\) ) 174 SB\r
+\r
+%%BeginResource: font MSTT31c2d4\r
+/MSTT31c2d4 [50.0 0 0 0 0 0] 40 -100 [-50.0 -50.0 50.0 50.0] [1 50 div 0 0 1 50 div 0 0] /MSTT31c2d4 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 50 50 0 0 1 45 /MSTT31c2d4 font\r
+\r
+%%BeginResource: font MSTT31c2d4\r
+/G73 [19.0 0.0 0.0 0.0 19.0 23.0]\r
+/G73 {\r
+ 19 23 true [1 0 0 -1 0.0 23.0] {<007c2001c3e00380e00780e007804007804007c04007e00003f00003f80001f80000fc00007e0000\r
+3e00003f00401f00400f00400f00600f00e00e00f01c00f8380087e000>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c2d4 AddChar\r
+/G6f [25.0 0.0 1.0 0.0 24.0 23.0]\r
+/G6f {\r
+ 23 23 true [1 0 0 -1 -1.0 23.0] {<000fc00070f001e03803c03c07801c0f001e1e001e3e001e3c003e7c003e7c003e78003cf8007cf8\r
+007cf80078f000f8f000f0f001e07803c0780780380f001e1c0007e000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c2d4 AddChar\r
+/G75 [25.0 0.0 1.0 0.0 24.0 23.0]\r
+/G75 {\r
+ 23 23 true [1 0 0 -1 -1.0 23.0] {<0380000fc03e1fc03c23c03c43c07cc7c0780780780780f80f80f00f01f00f01f01f03e01e03e01e\r
+05e03e05e03c0bc03c13c07c13c07827887847907887a07f07c03c0780>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c2d4 AddChar\r
+/G20 [13.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c2d4 AddChar\r
+/G70 [25.0 0.0 -7.0 -11.0 24.0 23.0]\r
+/G70 {\r
+ 31 34 true [1 0 0 -1 7.0 23.0] {<0003c1f0007fc7f800078c7c0007b03c0007e03e000f401e000f801e000f801e001f003e001f003e\r
+001e003c003e003c003c007c003c0078003c0070007800f0007800e0007801c000f8038000f00700\r
+00f80e0001fc3c0001efe00001e0000001e0000003c0000003c0000003c000000780000007800000\r
+078000000f8000001fc000007ff80000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c2d4 AddChar\r
+/G65 [22.0 0.0 1.0 0.0 20.0 23.0]\r
+/G65 {\r
+ 19 23 true [1 0 0 -1 -1.0 23.0] {<001f800063c00181e00301e00701e00e01e01c03c01c07803c0700781e00783c0079e000ff0000f0\r
+0000f00000f00000f80080f80100fc06007e1c003ff8003ff0000fc000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c2d4 AddChar\r
+/G69 [14.0 0.0 1.0 0.0 13.0 32.0]\r
+/G69 {\r
+ 12 32 true [1 0 0 -1 -1.0 32.0] {<006000f000f000600000000000000000000001e03fe003c003c003c00780078007800f000f000f00\r
+1f001e001e003e003c003c007c00788079007a00fc007800>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c2d4 AddChar\r
+/G6e [25.0 0.0 0.0 0.0 24.0 23.0]\r
+/G6e {\r
+ 24 23 true [1 0 0 -1 0.0 23.0] {<03e03c3fc0fe03c19f03c20f03c41f07881f07901e07b03e0f603e0f403e0f803c1f807c1f00781f\r
+00781e00f83e00f03c00f03c01f07801e27801e47801e8f803f0f001c0>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c2d4 AddChar\r
+/G64 [25.0 0.0 0.0 0.0 29.0 35.0]\r
+/G64 {\r
+ 29 35 true [1 0 0 -1 0.0 35.0] {<000000f800000ff0000001f0000001f0000001e0000001e0000001e0000003c0000003c0000003c0\r
+00000780000007800007c7800018778000603f0001c01f0003801f0007801e000f003e000e003e00\r
+1e003c003c003c003c007c007800f8007800f8007801f800f8037800f002f000f006f000f80cf000\r
+f819e100fc71e2007fe1e4003fc1f8001f01e000>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c2d4 AddChar\r
+/G6c [14.0 0.0 1.0 0.0 16.0 35.0]\r
+/G6c {\r
+ 15 35 true [1 0 0 -1 -1.0 35.0] {<003e03fc007c003c00780078007800f000f000f001f001e001e003e003c003c003c0078007800780\r
+0f000f000f001f001e001e003e003c003c007c40788078807900fe007800>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c2d4 AddChar\r
+/G61 [25.0 0.0 0.0 0.0 25.0 23.0]\r
+/G61 {\r
+ 25 23 true [1 0 0 -1 0.0 23.0] {<000f8180003ccf8000606f0001c02f0003803f0007803e000f003e000e003e001e003c003c003c00\r
+3c007c0078007c00780078007800f800f801f800f001f000f002f000f004f000f819e200fc31e400\r
+7fe1ec003fc1f8001f01e000>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c2d4 AddChar\r
+/G74 [14.0 0.0 2.0 0.0 15.0 29.0]\r
+/G74 {\r
+ 13 29 true [1 0 0 -1 -2.0 29.0] {<00300020006000e001c003c00fc07ff8078007800f800f000f001f001e001e003e003e003c003c00\r
+7c0078007800f800f180f100f200fc00f000>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c2d4 AddChar\r
+/G67 [25.0 0.0 -2.0 -11.0 27.0 23.0]\r
+/G67 {\r
+ 29 34 true [1 0 0 -1 2.0 23.0] {<000ff000003c3ff800f01ff001e01ff003e00f0003c00f0007c00f0007c01f0007801f0007801e00\r
+07803e0003c03c0003c0780001e1e000007f80000030000000e0000001c0000003c0000003f80000\r
+03ff000001ffe00003fff0000e0ff8003c01fc0078003c0070001c00f0001c00f0001800f0001800\r
+780030007c0060001f01800003fe0000>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c2d4 AddChar\r
+%%EndResource\r
+\r
+1641 1507 101 (sous ) 114 SB\r
+1755 1507 121 (peine ) 134 SB\r
+1889 1507 60 (de ) 73 SB\r
+1962 1507 188 (plantage ) 201 SB\r
+2163 1507 47 (de) 47 SB\r
+\r
+%%BeginResource: font MSTT31c2d4\r
+/G27 [11.0 0.0 6.0 21.0 13.0 35.0]\r
+/G27 {\r
+ 7 14 true [1 0 0 -1 -6.0 35.0] {<1c3e3e7c7c7c78707060e0c0c080>} imagemask \r
+ }\r
+ 39 /G27 MSTT31c2d4 AddChar\r
+/G72 [19.0 0.0 0.0 0.0 19.0 23.0]\r
+/G72 {\r
+ 19 23 true [1 0 0 -1 0.0 23.0] {<03e0e03fe1e007c3e003c7e007c9c00798c007900007a0000f40000f40000f80001f00001f00001e\r
+00001e00003e00003c00003c0000780000780000780000f80000f00000>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c2d4 AddChar\r
+%%EndResource\r
+\r
+248 1564 238 (l'ordinateur) 238 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+486 1571 11 (.) 11 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G7d [20.0 0.0 4.0 -8.0 17.0 28.0]\r
+/G7d {\r
+ 13 36 true [1 0 0 -1 -4.0 28.0] {<e00038000e000f0007000780078007800f800f800f000f000f000700030001800060001800700180\r
+038007000f000f000f000f800f80078007800780078007000e001c003800c000>} imagemask \r
+ }\r
+ 125 /G7d MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1621 20 (}) 20 SB\r
+248 1718 44 ( ) 44 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+292 1717 82 (unit ) 82 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+374 1718 81 (init: ) 81 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+\r
+%%BeginResource: font MSTT31c2c7\r
+/G72 [19.0 0.0 2.0 0.0 19.0 20.0]\r
+/G72 {\r
+ 17 20 true [1 0 0 -1 -2.0 20.0] {<000f00ff1f803f3f803f7f803f4f803f87003f80003f00003f00003f00003f00003f00003f00003f\r
+00003f00003f00003f00003f00003f8000ffc000>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c2c7 AddChar\r
+/G6f [20.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G6f {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<03f0000f3c001e1e003e0f003c0f807c0f807c0f80fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc\r
+0fc07c0f807c0f807c0f803c0f001e1e000f3c0003f000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c2c7 AddChar\r
+/G63 [19.0 0.0 1.0 -1.0 18.0 20.0]\r
+/G63 {\r
+ 17 21 true [1 0 0 -1 -1.0 20.0] {<03f0000f3c001e3e003c3f003c1f007c1f007c0e00fc0000fc0000fc0000fc0000fe0000fe0000fe\r
+00007e00007f00007f81803fc3001ffe000ffc0003f000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c2c7 AddChar\r
+/G64 [23.0 0.0 2.0 -1.0 22.0 28.0]\r
+/G64 {\r
+ 20 29 true [1 0 0 -1 -2.0 28.0] {<003fc0000fc0000fc0000fc0000fc0000fc0000fc0000fc007cfc00f2fc01e1fc03e1fc07c0fc07c\r
+0fc07c0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc0fc07c0fc07e0fc03e1fc03f3f\r
+c01feff0078f00>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c2c7 AddChar\r
+%%EndResource\r
+\r
+455 1717 183 (procedure) 183 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G4d [37.0 0.0 0.0 0.0 37.0 28.0]\r
+/G4d {\r
+ 37 28 true [1 0 0 -1 0.0 28.0] {<ff000007f81f80000fc00f80000f800fc0001f800fc0001f800fe0003f800de00037800df0003780\r
+0cf00067800cf80067800c7800c7800c7c00c7800c3c0187800c3e0187800c1e0307800c1e030780\r
+0c0f0607800c0f0607800c078c07800c078c07800c07dc07800c03d807800c03f807800c01f00780\r
+0c01f007800c00e007801e00e00fc0ffc0407ff8>} imagemask \r
+ }\r
+ 77 /G4d MSTT31c2a0 AddChar\r
+/G4b [30.0 0.0 0.0 0.0 30.0 28.0]\r
+/G4b {\r
+ 30 28 true [1 0 0 -1 0.0 28.0] {<fff07fe01f801f000f001e000f0018000f0030000f0060000f00c0000f0180000f0300000f060000\r
+0f1c00000f3000000f7000000ff800000f7c00000f3e00000f1f00000f0f80000f07c0000f03e000\r
+0f01f8000f00fc000f007e000f003f000f001f800f000fc01f801ff0fff07ffc>} imagemask \r
+ }\r
+ 75 /G4b MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+638 1718 671 (\(checkMouse, checkKeyboard: integer\);) 671 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G7a [19.0 0.0 1.0 0.0 18.0 19.0]\r
+/G7a {\r
+ 17 19 true [1 0 0 -1 -1.0 19.0] {<7fff80600f00401e00401e00003c0000780000780000f00001e00003c00003c0000780000f00000f\r
+00001e00803c0080780180780380ffff80>} imagemask \r
+ }\r
+ 122 /G7a MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1766 605 ( { initializes the Mouse driver.) 605 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G77 [29.0 0.0 0.0 -1.0 29.0 19.0]\r
+/G77 {\r
+ 29 20 true [1 0 0 -1 0.0 19.0] {<ff9ff0f87e07c0303e03c0201e03c0201e01e0400f01e0400f01e0400f02f0800782f0800784f100\r
+0784790003c8790003c87a0003d03e0001f03e0001f03c0001e01c0000e01c0000c0180000c00800\r
+>} imagemask \r
+ }\r
+ 119 /G77 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1814 717 ( tells which events will be checked:) 717 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G3c [24.0 0.0 1.0 4.0 23.0 25.0]\r
+/G3c {\r
+ 22 21 true [1 0 0 -1 -1.0 25.0] {<00000400001c0000780003e0000f80003c0000f00003c0000f00007c0000e000007c00000f000003\r
+c00000f000003c00000f800003e000007800001c000004>} imagemask \r
+ }\r
+ 60 /G3c MSTT31c2a0 AddChar\r
+/G3e [24.0 0.0 1.0 4.0 23.0 25.0]\r
+/G3e {\r
+ 22 21 true [1 0 0 -1 -1.0 25.0] {<800000e000007800001f000007c00000f000003c00000f000003c00000f800001c0000f80003c000\r
+0f00003c0000f00007c0001f0000780000e00000800000>} imagemask \r
+ }\r
+ 62 /G3e MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1862 1865 ( if checkMouse <>0 then the events of Mouse will be reported to getpress, see below otherwise ignored;) 1865 SB\r
+248 1910 1780 ( if checkKeyboard <>0 then the events of Keyboard will be reported to getpress, otherwise ignored) 1780 SB\r
+248 1958 187 ( ) 187 SB\r
+\r
+%%BeginResource: font MSTT31c2e1\r
+/MSTT31c2e1 [42.0 0 0 0 0 0] 95 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c2e1 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2e1 font\r
+\r
+%%BeginResource: font MSTT31c2e1\r
+/G41 [28.0 0.0 -3.0 0.0 25.0 29.0]\r
+/G41 {\r
+ 28 29 true [1 0 0 -1 3.0 29.0] {<00000040000000c0000001c0000003c0000007c000000fc000000fc000001fc000003fc000006fc0\r
+0000efc00001cfc000018fc000030fc000060fc0000c0fc0001c0fc000380fc0003fffc0007fffc0\r
+00c00fc001800fc003800fc007000fc006000fc00c000fc01c000fc07c001fe0ff00fff0>} imagemask \r
+ }\r
+ 65 /G41 MSTT31c2e1 AddChar\r
+/G74 [12.0 0.0 0.0 0.0 13.0 25.0]\r
+/G74 {\r
+ 13 25 true [1 0 0 -1 0.0 25.0] {<0030006000e001e003e00fc07ff87ff80f800f801f801f001f003f003e003e003e007e007c007c00\r
+fc40fcc0f980fe007c00>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c2e1 AddChar\r
+/G65 [19.0 0.0 1.0 0.0 19.0 19.0]\r
+/G65 {\r
+ 18 19 true [1 0 0 -1 -1.0 19.0] {<001f8000e7c00187c00787c00f0fc01e0f801e1f003c1e007c3c007cf000ff8000f80000f80000f8\r
+0000f80300fc0e007ffc007ff0001fc000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c2e1 AddChar\r
+/G6e [23.0 0.0 0.0 0.0 21.0 19.0]\r
+/G6e {\r
+ 21 19 true [1 0 0 -1 0.0 19.0] {<03c0f03fc3f00fc7f80fcff80f99f80fb1f00fa1f01f43f01fc3e01f83e03f07e03f07c03e07c03e\r
+0fc07c0f887c0f907c0fa0fc0fc0f80780>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c2e1 AddChar\r
+/G69 [12.0 0.0 1.0 0.0 12.0 29.0]\r
+/G69 {\r
+ 11 29 true [1 0 0 -1 -1.0 29.0] {<03c007e007e007e007e003c0000000000000000007807f801f800f801f001f001f003e003e003e00\r
+7e007c007c00fc40f880f980ff00fe007800>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c2e1 AddChar\r
+/G6f [21.0 0.0 1.0 0.0 20.0 19.0]\r
+/G6f {\r
+ 19 19 true [1 0 0 -1 -1.0 19.0] {<003e0000e78003c3c00783e00f03e01f03e03e03e03e07e07e07e07c07c0fc07c0fc0f80f80f80f8\r
+1f00f81e00f83c007878003c60001f8000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c2e1 AddChar\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c2e1 AddChar\r
+/G70 [21.0 0.0 -5.0 -9.0 20.0 19.0]\r
+/G70 {\r
+ 25 28 true [1 0 0 -1 5.0 19.0] {<001e1e0001fe7f00007eff80007f1f80007e0f80007c0f80007c0f8000f80f8000f80f8000f80f00\r
+01f81f0001f01e0001f01e0001f03c0003e0780003e0780003e0e00007f1c00007df000007c00000\r
+07c000000f8000000f8000000f8000001f8000001f8000003f800000ffe00000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c2e1 AddChar\r
+/G6c [12.0 0.0 1.0 0.0 13.0 29.0]\r
+/G6c {\r
+ 12 29 true [1 0 0 -1 -1.0 29.0] {<00f00ff003f003e003e003e007e007c007c007c00f800f800f801f801f001f003f003e003e003e00\r
+7c007c007c00fc00f840f880fb00fe007800>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c2e1 AddChar\r
+/G61 [21.0 0.0 1.0 0.0 21.0 19.0]\r
+/G61 {\r
+ 20 19 true [1 0 0 -1 -1.0 19.0] {<0073e001cbe00387e00707e00f07c01e07c03e0fc03c0f807c0f807c1f80781f80f83f00f83f00f8\r
+5f00f8fe20f9be40ff3f807e3f003c3e00>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c2e1 AddChar\r
+/G73 [16.0 0.0 0.0 0.0 16.0 19.0]\r
+/G73 {\r
+ 16 19 true [1 0 0 -1 0.0 19.0] {<03fb078f0f071f061f821f821fc00fe00ff007f803f801fc40fc40fc607ce078f078f8f08fc0>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c2e1 AddChar\r
+/G21 [16.0 0.0 2.0 0.0 14.0 29.0]\r
+/G21 {\r
+ 12 29 true [1 0 0 -1 -2.0 29.0] {<00e001f001f003f003f003e003e003c007c007c007800780070007000600060004000c000c000800\r
+0800000000007800fc00fc00fc00fc007800>} imagemask \r
+ }\r
+ 33 /G21 MSTT31c2e1 AddChar\r
+%%EndResource\r
+\r
+435 1958 297 (Attention please!) 297 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G57 [39.0 0.0 1.0 -1.0 39.0 28.0]\r
+/G57 {\r
+ 38 29 true [1 0 0 -1 -1.0 28.0] {<ffc7ff03fc3f01f800f01e00f800701e00f800601f007800600f007800c00f007c00c00f803c00c0\r
+07803c018007803e018007c07e018003c07e030003c04f030003e0cf030001e0cf060001e0878600\r
+00f187860000f1878c0000f103cc00007b03cc00007b03f800007a01f800003e01f800003e01f000\r
+003c00f000001c00f000001c00e00000180060000008006000>} imagemask \r
+ }\r
+ 87 /G57 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+732 1958 1041 ( While the events of the keyboard are taken under control by ) 1041 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+1773 1958 57 (init) 57 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+1830 1958 57 ( or ) 57 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+1887 1958 223 (getmovement) 223 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2e1 font\r
+\r
+%%BeginResource: font MSTT31c2e1\r
+/G64 [21.0 0.0 1.0 0.0 24.0 29.0]\r
+/G64 {\r
+ 23 29 true [1 0 0 -1 -1.0 29.0] {<00003c0003fc0000fc0000fc0000f80000f80000f80001f00001f00001f0007bf001c7e00387e007\r
+87e00f07c01e07c03e07c03e0fc07c0f807c0f807c1f80f81f00f83f00f85f00f87f20f8be40ff3f\r
+c07e3f003c1e00>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c2e1 AddChar\r
+/G75 [23.0 0.0 1.0 0.0 21.0 19.0]\r
+/G75 {\r
+ 20 19 true [1 0 0 -1 -1.0 19.0] {<0781f03f81f01f83f01f83e01f03e01f03e01f07e03e07c03e0fc03e1fc07e1f807c3f807c6f80fc\r
+df80f99f10ff1f20fe1fc0fc1f80701f00>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c2e1 AddChar\r
+%%EndResource\r
+\r
+548 2006 178 (do not use) 178 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+726 2006 1420 ( the functions or procedures: read, readln, hfont, hfont8, hpage, inkey that read keys) 1420 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G59 [30.0 0.0 0.0 0.0 30.0 28.0]\r
+/G59 {\r
+ 30 28 true [1 0 0 -1 0.0 28.0] {<fff00ffc3fc003e00f8001c00f80018007c0030003c0030001e0060001f00c0000f80c0000781800\r
+007c1800003e3000001e3000001f6000000fc0000007c00000078000000780000007800000078000\r
+000780000007800000078000000780000007800000078000000fc000007ff800>} imagemask \r
+ }\r
+ 89 /G59 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+548 2054 30 (Y) 30 SB\r
+\r
+%%BeginResource: font MSTT31c2ee\r
+/MSTT31c2ee [33.0 0 0 0 0 0] 60 -120 [-33.0 -33.0 33.0 33.0] [1 33 div 0 0 1 33 div 0 0] /MSTT31c2ee GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 33 33 0 0 1 29 /MSTT31c2ee font\r
+\r
+%%BeginResource: font MSTT31c2ee\r
+/G4f [24.0 0.0 1.0 0.0 23.0 22.0]\r
+/G4f {\r
+ 22 22 true [1 0 0 -1 -1.0 22.0] {<00fc000703800e01c01c00e0380070780078780078f00038f0003cf0003cf0003cf0003cf0003cf0\r
+003cf000387800387800783800701c00e00e01c007078000fc00>} imagemask \r
+ }\r
+ 79 /G4f MSTT31c2ee AddChar\r
+/G55 [23.0 0.0 0.0 0.0 23.0 22.0]\r
+/G55 {\r
+ 23 22 true [1 0 0 -1 0.0 22.0] {<ff80fe3e00381c00101c00101c00101c00101c00101c00101c00101c00101c00101c00101c00101c\r
+00101c00101c00101c00100e00200e002007004003818000fe00>} imagemask \r
+ }\r
+ 85 /G55 MSTT31c2ee AddChar\r
+/G20 [8.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c2ee AddChar\r
+/G52 [22.0 0.0 1.0 0.0 22.0 22.0]\r
+/G52 {\r
+ 21 22 true [1 0 0 -1 -1.0 22.0] {<fff8003e1e001c0f001c07001c07801c03801c03801c07801c07001c0f001c3c001ff0001c70001c\r
+78001c38001c1c001c1e001c0e001c07001c07803e03c0ff81f8>} imagemask \r
+ }\r
+ 82 /G52 MSTT31c2ee AddChar\r
+/G49 [11.0 0.0 1.0 0.0 10.0 22.0]\r
+/G49 {\r
+ 9 22 true [1 0 0 -1 -1.0 22.0] {<ff803e001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c001c00\r
+3e00ff80>} imagemask \r
+ }\r
+ 73 /G49 MSTT31c2ee AddChar\r
+/G53 [18.0 0.0 2.0 0.0 16.0 22.0]\r
+/G53 {\r
+ 14 22 true [1 0 0 -1 -2.0 22.0] {<0f8838f87038e018e018e008f008f8087e003f001fc00fe003f001f8807c803cc01cc01cc018e038\r
+f8708fc0>} imagemask \r
+ }\r
+ 83 /G53 MSTT31c2ee AddChar\r
+/G4b [23.0 0.0 1.0 0.0 23.0 22.0]\r
+/G4b {\r
+ 22 22 true [1 0 0 -1 -1.0 22.0] {<ff87f03e01c01c01001c02001c04001c08001c10001c20001c40001d80001fc0001de0001cf0001c\r
+78001c3c001c1e001c0f001c07801c03c01c01e03e01f0ff87fc>} imagemask \r
+ }\r
+ 75 /G4b MSTT31c2ee AddChar\r
+/G54 [21.0 0.0 1.0 0.0 20.0 22.0]\r
+/G54 {\r
+ 19 22 true [1 0 0 -1 -1.0 22.0] {<ffffe0e0e0e0c0e06080e02080e02000e00000e00000e00000e00000e00000e00000e00000e00000\r
+e00000e00000e00000e00000e00000e00000e00001f00007fc00>} imagemask \r
+ }\r
+ 84 /G54 MSTT31c2ee AddChar\r
+/G48 [24.0 0.0 1.0 0.0 23.0 22.0]\r
+/G48 {\r
+ 22 22 true [1 0 0 -1 -1.0 22.0] {<ff87fc3e01f01c00e01c00e01c00e01c00e01c00e01c00e01c00e01c00e01fffe01c00e01c00e01c\r
+00e01c00e01c00e01c00e01c00e01c00e01c00e03e01f0ff87fc>} imagemask \r
+ }\r
+ 72 /G48 MSTT31c2ee AddChar\r
+/G41 [23.0 0.0 1.0 0.0 24.0 22.0]\r
+/G41 {\r
+ 23 22 true [1 0 0 -1 -1.0 22.0] {<001000003800003800003c00005c00005c00008e00008e00010e0001070002070002038004038004\r
+038007ffc00801c00801c01000e01000e03000707000f8fc03fe>} imagemask \r
+ }\r
+ 65 /G41 MSTT31c2ee AddChar\r
+/G4e [24.0 0.0 0.0 0.0 23.0 22.0]\r
+/G4e {\r
+ 23 22 true [1 0 0 -1 0.0 22.0] {<fc00fe3e00381f00100f00100f80100bc01009e01008e01008f010087810083c10081e10080e1008\r
+0f100807900803d00801d00800f00800f00800701c00307f0010>} imagemask \r
+ }\r
+ 78 /G4e MSTT31c2ee AddChar\r
+/G47 [24.0 0.0 1.0 0.0 24.0 22.0]\r
+/G47 {\r
+ 23 22 true [1 0 0 -1 -1.0 22.0] {<00fe200381e00e00e01c00703c0030380030780010700000f00000f00000f003fef000f8f00070f0\r
+00707000707800707800703c00701e00700f007007c1e000ff80>} imagemask \r
+ }\r
+ 71 /G47 MSTT31c2ee AddChar\r
+/G59 [24.0 0.0 1.0 0.0 23.0 22.0]\r
+/G59 {\r
+ 22 22 true [1 0 0 -1 -1.0 22.0] {<ff01fc7c00f01c00401c00800e008007010007020003820001c40001c40000e80000700000700000\r
+700000700000700000700000700000700000700000f80003fe00>} imagemask \r
+ }\r
+ 89 /G59 MSTT31c2ee AddChar\r
+/G45 [20.0 0.0 1.0 0.0 19.0 22.0]\r
+/G45 {\r
+ 18 22 true [1 0 0 -1 -1.0 22.0] {<ffff003c03001c03001c01001c01001c00001c00001c08001c08001c18001ff8001c18001c08001c\r
+08001c00001c00001c00401c00c01c00801c01803c0380ffff00>} imagemask \r
+ }\r
+ 69 /G45 MSTT31c2ee AddChar\r
+/G4d [29.0 0.0 1.0 0.0 28.0 22.0]\r
+/G4d {\r
+ 27 22 true [1 0 0 -1 -1.0 22.0] {<fc0007e03c0007801e000f001e000f001e000f001700170017001700138027001380270011c04700\r
+11c0470011c0470010e0870010e087001071070010710700103a0700103a0700103e0700101c0700\r
+381c0f80fe083fe0>} imagemask \r
+ }\r
+ 77 /G4d MSTT31c2ee AddChar\r
+%%EndResource\r
+\r
+578 2063 524 (OU RISK TO HANG YOUR SYSTEM) 524 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+1102 2054 14 (!) 14 SB\r
+248 2102 119 ( }) 119 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 2150 109 ( end) 109 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+357 2151 69 ( init) 69 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 2247 126 ( unit ) 126 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+374 2248 250 (getmovement: ) 250 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+624 2247 183 (procedure) 183 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+807 2248 671 (\(checkMouse, checkKeyboard: integer\);) 671 SB\r
+398 2296 585 (tells which events will be checked:) 585 SB\r
+248 2344 1865 ( if checkMouse <>0 then the events of Mouse will be reported to getpress, see below otherwise ignored;) 1865 SB\r
+248 2392 1780 ( if checkKeyboard <>0 then the events of Keyboard will be reported to getpress, otherwise ignored) 1780 SB\r
+248 2440 187 ( ) 187 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2e1 font\r
+435 2440 297 (Attention please!) 297 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+732 2440 1041 ( While the events of the keyboard are taken under control by ) 1041 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+1773 2440 57 (init) 57 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+1830 2440 57 ( or ) 57 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+1887 2440 223 (getmovement) 223 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2e1 font\r
+548 2488 178 (do not use) 178 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+726 2488 1420 ( the functions or procedures: read, readln, hfont, hfont8, hpage, inkey that read keys) 1420 SB\r
+548 2536 30 (Y) 30 SB\r
+32 0 0 33 33 0 0 1 29 /MSTT31c2ee font\r
+578 2545 524 (OU RISK TO HANG YOUR SYSTEM) 524 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+1102 2536 14 (!) 14 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 2584 109 ( end) 109 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+357 2585 250 ( getmovement;) 250 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 2681 115 ( unit) 115 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+363 2682 171 ( getpress: ) 171 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+534 2681 147 (function) 147 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+681 2682 516 (\(v,p,h,l,r,c : integer\): Boolean;) 516 SB\r
+398 2730 42 ({ ) 42 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+440 2730 19 (v) 19 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+459 2730 498 ( = y coordinate of the cursor,) 498 SB\r
+398 2778 44 ( ) 44 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+\r
+%%BeginResource: font MSTT31c282\r
+/G68 [21.0 0.0 0.0 0.0 19.0 29.0]\r
+/G68 {\r
+ 19 29 true [1 0 0 -1 0.0 29.0] {<00e00007e00001e00001c00001c00001c0000380000380000380000380000703c0070fc00719e00e\r
+31e00e61c00e41c00e81c01d03c01f03801e03803c07803c0700380700380f00700e00700e40700e\r
+80e01f00e00e00>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c282 AddChar\r
+%%EndResource\r
+\r
+442 2778 21 (h) 21 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+463 2778 500 ( = x coordinate of the cursor,) 500 SB\r
+398 2826 44 ( ) 44 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+442 2826 21 (p) 21 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+463 2826 1297 ( = keybord status control_left,control_right, alt, alt_gr, shift_left, shift_right) 1297 SB\r
+248 2874 143 ( ) 143 SB\r
+398 2874 44 ( ) 44 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+\r
+%%BeginResource: font MSTT31c282\r
+/G6c [12.0 0.0 1.0 0.0 12.0 29.0]\r
+/G6c {\r
+ 11 29 true [1 0 0 -1 -1.0 29.0] {<00e007e000e001c001c001c003c00380038003800700070007000e000e000e001e001c001c001c00\r
+3800380038007800710072007400f8007000>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c282 AddChar\r
+%%EndResource\r
+\r
+442 2874 12 (l) 12 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+454 2874 383 ( = code of key pressed) 383 SB\r
+398 2922 44 ( ) 44 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+442 2922 16 (r) 16 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+458 2922 127 ( = flags) 127 SB\r
+398 2970 44 ( ) 44 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c282 font\r
+\r
+%%BeginResource: font MSTT31c282\r
+/G63 [19.0 0.0 1.0 0.0 18.0 19.0]\r
+/G63 {\r
+ 17 19 true [1 0 0 -1 -1.0 19.0] {<007e0001e1000381800f03801e03801c0300380000700000700000700000f00000e00000e00000e0\r
+0200f00600f00c007c38003fe0001f8000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c282 AddChar\r
+%%EndResource\r
+\r
+442 2970 19 (c) 19 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+461 2970 1177 ( = buttons pressed \(0=aucun, 1=gauche, 2=droite, 3=gauche et droite\)) 1177 SB\r
+698 3018 807 (Nb: the middle button is not taken into account.) 807 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 3066 120 ( end ) 120 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+368 3067 137 (getpress) 137 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-Light\r
+%%+ font MSTT31c282\r
+%%+ font MSTT31c2a0\r
+%%+ font MSTT31c2c7\r
+%%+ font MSTT31c2d4\r
+%%+ font MSTT31c2e1\r
+%%+ font MSTT31c2ee\r
+%%Page: 10 10\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+0 0 0 fC\r
+248 224 115 ( unit) 115 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+363 225 215 ( showcursor:) 215 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+\r
+%%BeginResource: font MSTT31c2c7\r
+/G3b [14.0 0.0 3.0 -7.0 11.0 20.0]\r
+/G3b {\r
+ 8 27 true [1 0 0 -1 -3.0 20.0] {<387cfefefe7c380000000000003c7efeffff7f7f07060e0c183040>} imagemask \r
+ }\r
+ 59 /G3b MSTT31c2c7 AddChar\r
+%%EndResource\r
+\r
+578 224 208 ( procedure;) 208 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+398 273 1181 ({the cursor becomes visible and follows the movements of the mouse}) 1181 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 321 109 ( end) 109 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+357 322 215 ( showcursor;) 215 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 418 126 ( unit ) 126 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+374 419 201 (hidecursor: ) 201 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+575 418 197 (procedure;) 197 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+398 467 517 ({the cursor becomes invisible}) 517 SB\r
+32 0 0 42 42 0 0 1 39 /MSTT31c2c7 font\r
+248 515 109 ( end) 109 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+357 516 201 ( hidecursor;) 201 SB\r
+32 0 0 50 50 0 0 0 47 /Bookman-Demi /font5 ANSIFont font\r
+248 612 95 (end) 95 SB\r
+32 0 0 50 50 0 0 0 46 /Bookman-Light /font7 ANSIFont font\r
+343 613 226 ( MOUSE;) 226 SB\r
+248 849 894 (Enclosed you find a sample program) 894 SB\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G53 [23.0 0.0 3.0 -1.0 21.0 29.0]\r
+/G53 {\r
+ 18 30 true [1 0 0 -1 -3.0 29.0] {<07e1001fff00383f00700f00600700e00300e00100e00100f00100f800007c00007f00003fc0003f\r
+f0000ff80007fe0001ff00007f80001f80000fc08003c08003c0c001c0c001c0c001c0e00380f003\r
+80fc0f008ffe0083f800>} imagemask \r
+ }\r
+ 83 /G53 MSTT31c2a0 AddChar\r
+/G47 [30.0 0.0 2.0 -1.0 30.0 29.0]\r
+/G47 {\r
+ 28 30 true [1 0 0 -1 -2.0 29.0] {<003fc10000fff10003f03f0007c00f000f8007801f0003801e0001803e0001807c0000807c000000\r
+78000000f8000000f8000000f8000000f8007ff0f8000fc0f8000780f8000780f80007807c000780\r
+7c0007807c0007803e0007803f0007801f0007800f80078007c0078003f81f8000fffe00001ff000\r
+>} imagemask \r
+ }\r
+ 71 /G47 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 967 415 (Program SystemeGraph;) 415 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G2a [21.0 0.0 3.0 11.0 18.0 29.0]\r
+/G2a {\r
+ 15 18 true [1 0 0 -1 -3.0 29.0] {<0180038003800380e38ef19ef93e3d7807c007c03d78f93ef39ee38e0380038003800180>} imagemask \r
+ }\r
+ 42 /G2a MSTT31c2a0 AddChar\r
+/G46 [23.0 0.0 0.0 0.0 22.0 28.0]\r
+/G46 {\r
+ 22 28 true [1 0 0 -1 0.0 28.0] {<fffffc1ffffc0f003c0f000c0f000c0f00040f00000f00000f00400f00400f00c00f00c00fffc00f\r
+ffc00f01c00f00c00f00400f00400f00000f00000f00000f00000f00000f00000f00000f00001f80\r
+00fff000>} imagemask \r
+ }\r
+ 70 /G46 MSTT31c2a0 AddChar\r
+/G39 [21.0 0.0 2.0 0.0 19.0 28.0]\r
+/G39 {\r
+ 17 28 true [1 0 0 -1 -2.0 28.0] {<03e0000c3800181c00380e00700e00700f00f00700f00780f00780f00780f00780f0078078078078\r
+07803c07801e1f000fef00000f00000e00001e00001c00003c0000780000f00001e0000380000f00\r
+00780000>} imagemask \r
+ }\r
+ 57 /G39 MSTT31c2a0 AddChar\r
+/G34 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G34 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<001c00003c00003c00007c00007c0000bc00013c00013c00023c00023c00043c00083c00083c0010\r
+3c00103c00203c00403c00403c00ffffc0ffffc0ffffc0003c00003c00003c00003c00003c00003c\r
+00003c00>} imagemask \r
+ }\r
+ 52 /G34 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1015 735 ( \(* by Frederic Pataud, October 1994 *\)) 735 SB\r
+248 1063 100 (Begin) 100 SB\r
+248 1111 983 (Pref iiuwgraph block \(* inherit the graphic functions *\)) 983 SB\r
+248 1159 111 ( Begin) 111 SB\r
+248 1207 301 ( Pref mouse block) 301 SB\r
+698 1207 554 (\(* inherit the mouse functions *\)) 554 SB\r
+248 1351 1678 ( \(*****************************************************************************\)) 1678 SB\r
+248 1399 1081 ( \(* P r o g r a m m e P r i n c i p a l *\)) 1081 SB\r
+248 1447 1678 ( \(*****************************************************************************\)) 1678 SB\r
+248 1495 369 ( var v,p,h,i : integer,) 369 SB\r
+248 1543 307 ( l,r,c : integer,) 307 SB\r
+248 1591 381 ( rep : arrayof char,) 381 SB\r
+248 1639 274 ( d : boolean,) 274 SB\r
+248 1687 462 ( xx,yy : arrayof integer,) 462 SB\r
+248 1735 697 ( status,code,x,y,flags,button : integer;) 697 SB\r
+248 1831 133 ( Begin) 133 SB\r
+248 1927 880 ( call gron\(0\); \(* enter the graphic mode *\)) 880 SB\r
+248 1975 1772 ( call init\(1,0\); \(* initialize the mouse, disregard the keyboard events, check for mouse events *\)) 1772 SB\r
+248 2071 331 ( call showcursor;) 331 SB\r
+848 2071 295 (\(* show cursor *\)) 295 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G35 [21.0 0.0 2.0 0.0 18.0 28.0]\r
+/G35 {\r
+ 16 28 true [1 0 0 -1 -2.0 28.0] {<03ff07fe07fe07fe0800080010001e003fc03ff07ff807fc00fe003e001e000f000f000700070007\r
+000700060006000c6018f830ffc03f00>} imagemask \r
+ }\r
+ 53 /G35 MSTT31c2a0 AddChar\r
+/G36 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G36 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<000f80003c0000f00001c0000380000700000e00001c00003c000038000078000079f8007e3e00f0\r
+0f00f00780f00780f007c0f003c0f003c0f003c0f003c07803c07803803803803c07001c0e000f1c\r
+0003f000>} imagemask \r
+ }\r
+ 54 /G36 MSTT31c2a0 AddChar\r
+/G37 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G37 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<1fffc01fffc03fffc03fff80600180400380800300000300000700000600000600000e00000c0000\r
+0c00001c0000180000180000380000300000300000700000600000600000e00000c00000c00001c0\r
+00018000>} imagemask \r
+ }\r
+ 55 /G37 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 2119 1270 ( call patern\(5,5,635,475,2,0\); \(* make a frame around the screen *\)) 1270 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G22 [17.0 0.0 3.0 17.0 14.0 29.0]\r
+/G22 {\r
+ 11 12 true [1 0 0 -1 -3.0 29.0] {<60c0f1e0f1e0f1e0f1e0f1e0f1e0f1e060c060c060c060c0>} imagemask \r
+ }\r
+ 34 /G22 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 2167 567 ( call outstring\(10,10,"x=",2,0\);) 567 SB\r
+248 2215 586 ( call outstring\(100,10,"y=",2,0\);) 586 SB\r
+248 2263 664 ( call outstring\(10,30,"status = ",2,0\);) 664 SB\r
+248 2311 667 ( call outstring\(10,50,"code = ",2,0\);) 667 SB\r
+248 2359 660 ( call outstring\(10,70,"flags = ",2,0\);) 660 SB\r
+248 2407 675 ( call outstring\(10,90,"button = ",2,0\);) 675 SB\r
+248 2455 1394 ( call patern\(100,210,300,320,3,1\); \(* make a rectangle filled in colour 3 *\)) 1394 SB\r
+248 2551 377 ( array xx dim \(1:6\);) 377 SB\r
+248 2599 373 ( array yy dim \(1:6\);) 373 SB\r
+248 2647 445 ( xx\(1\):=410; yy\(1\):=10;) 445 SB\r
+248 2695 445 ( xx\(2\):=450; yy\(2\):=30;) 445 SB\r
+248 2743 445 ( xx\(3\):=460; yy\(3\):=50;) 445 SB\r
+248 2791 445 ( xx\(4\):=430; yy\(4\):=80;) 445 SB\r
+248 2839 445 ( xx\(5\):=420; yy\(5\):=40;) 445 SB\r
+248 2887 445 ( xx\(6\):=480; yy\(6\):=30;) 445 SB\r
+248 2935 467 ( call intens\(6,xx,yy,8,1\); ) 467 SB\r
+998 2935 443 (\(* show a polygon filled*\)) 443 SB\r
+248 2983 258 ( for i:=1 to 6) 258 SB\r
+248 3031 107 ( do) 107 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G2b [24.0 0.0 1.0 3.0 23.0 25.0]\r
+/G2b {\r
+ 22 22 true [1 0 0 -1 -1.0 25.0] {<003000003000003000003000003000003000003000003000003000003000fffffcfffffc00300000\r
+3000003000003000003000003000003000003000003000003000>} imagemask \r
+ }\r
+ 43 /G2b MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 3079 368 ( yy\(i\):=yy\(i\)+100;) 368 SB\r
+248 3127 119 ( od;) 119 SB\r
+248 3175 477 ( call intens\(6,xx,yy,15,0\);) 477 SB\r
+998 3175 578 (\(* show another polygon empty *\)) 578 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Bookman-Demi\r
+%%+ font Bookman-Light\r
+%%+ font MSTT31c2a0\r
+%%+ font MSTT31c2c7\r
+%%Page: 11 11\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 42 42 0 0 1 38 /MSTT31c2a0 font\r
+0 0 0 fC\r
+248 272 729 ( call cirb\(500,300,50,40,100,3500,10,0\);) 729 SB\r
+998 272 647 (\(* draw an empty pie or camembert *\)) 647 SB\r
+248 320 1151 ( call cirb\(400,400,40,40,600,4000,11,1\); \(* draw a filled pie *\)) 1151 SB\r
+248 464 1548 ( i:=hfont\(100,350,6,-9999999,9999999,500,9,0,15\); \(* read integer from a window *\)) 1548 SB\r
+248 512 1613 ( call hpage\(100,400,10,unpack\("Il fait beau dans ma verte campagne"\),9,0\); \(* show text *\)) 1613 SB\r
+248 560 980 ( rep:=hfont8\(100,430,10,80,unpack\("tototutu"\),9,0,15\);) 980 SB\r
+1448 560 239 (\(* read text *\)) 239 SB\r
+248 656 1625 ( call getmovement\(1,1\); \(* take into consideration both key events and mouse events *\)) 1625 SB\r
+248 752 96 ( do) 96 SB\r
+248 800 463 ( d:=getpress\(v,p,h,l,r,c\);) 463 SB\r
+998 800 404 (\(* ask about an event *\)) 404 SB\r
+248 848 151 ( if \(d\)) 151 SB\r
+248 896 737 ( then call outstring\(10,400,"Event",2,0\);) 737 SB\r
+248 944 647 ( call patern\(80,25,130,100,0,1\);) 647 SB\r
+248 992 508 ( call track\(40,10,v,0,4\);) 508 SB\r
+998 992 303 (\(* print integer *\)) 303 SB\r
+248 1040 530 ( call track\(140,10,p,0,4\);) 530 SB\r
+248 1088 510 ( call track\(80,30,h,0,4\);) 510 SB\r
+248 1136 500 ( call track\(80,50,l,0,4\);) 500 SB\r
+248 1184 503 ( call track\(80,70,r,0,4\);) 503 SB\r
+248 1232 506 ( call track\(80,90,c,0,4\);) 506 SB\r
+\r
+%%BeginResource: font MSTT31c2a0\r
+/G43 [28.0 0.0 2.0 -1.0 27.0 29.0]\r
+/G43 {\r
+ 25 30 true [1 0 0 -1 -2.0 29.0] {<003f820000ffe60003e07e0007801e000f000e001e0007003e0003003c0003007c0003007c000100\r
+78000000f8000000f8000000f8000000f8000000f8000000f8000000f8000000f8000000f8000000\r
+7c0000007c0000007c0000003e0000801e0001001f0002000fc00c0003f0380001fff000003f8000\r
+>} imagemask \r
+ }\r
+ 67 /G43 MSTT31c2a0 AddChar\r
+%%EndResource\r
+\r
+248 1280 1891 ( if\(\(h=164 and l=27\) or \(c=3\)\) \(* exit if either two buttons were pressed c=3 or Ctrl+Esc key *\)) 1891 SB\r
+248 1328 281 ( then exit;) 281 SB\r
+248 1376 158 ( fi;) 158 SB\r
+248 1424 103 ( fi;) 103 SB\r
+248 1472 108 ( od;) 108 SB\r
+248 1520 221 ( call groff;) 221 SB\r
+998 1520 954 (\(* leave the graphic mode and return to the text mode *\)) 954 SB\r
+248 1568 308 ( writeln\("i=",i\);) 308 SB\r
+248 1616 570 ( for i:=lower\(rep\) to upper\(rep\)) 570 SB\r
+248 1664 107 ( do) 107 SB\r
+248 1712 297 ( write\(rep\(i\)\);) 297 SB\r
+248 1760 119 ( od;) 119 SB\r
+248 1808 187 ( writeln;) 187 SB\r
+248 1856 102 ( End) 102 SB\r
+248 1904 80 ( End) 80 SB\r
+248 1952 80 (End.) 80 SB\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font MSTT31c2a0\r
+%%Trailer\r
+SVDoc restore\r
+end\r
+%%Pages: 11\r
+% TrueType font name key:\r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT31c293 = 2fafDTimes New RomanF00000064000002bc0000\r
+% MSTT31c2a0 = 2fafDTimes New RomanF0000002a000001900000\r
+% MSTT31c2ad = 2fafDTimes New RomanF0000003a000001900000\r
+% MSTT31c2ba = 2fafDTimes New RomanF0000004b000001900000\r
+% MSTT31c282 = 2fafDTimes New RomanF0000002a000001900001\r
+% MSTT31c2c7 = 2fafDTimes New RomanF0000002a000002bc0000\r
+% MSTT31c2d4 = 2fafDTimes New RomanF00000032000001900001\r
+% MSTT31c2e1 = 2fafDTimes New RomanF0000002a000002bc0001\r
+% MSTT31c2ee = 2fafDTimes New RomanF00000021000001900000\r
+%%DocumentSuppliedResources: procset Win35Dict 3 1\r
+%%+ font MSTT31c282\r
+%%+ font MSTT31c2a0\r
+%%+ font MSTT31c2c7\r
+%%+ font MSTT31c2d4\r
+%%+ font MSTT31c2e1\r
+%%+ font MSTT31c2ee\r
+\r
+%%DocumentNeededResources: font Bookman-Demi\r
+%%+ font Bookman-DemiItalic\r
+%%+ font Bookman-Light\r
+%%+ font Bookman-LightItalic\r
+%%+ font Symbol\r
+\r
+%%EOF\r
+\ 4
\ No newline at end of file
--- /dev/null
+\r
+unit IIUWGRAPH: class;\r
+\r
+{ this predefined class enables basic graphic operations\r
+ for DOS machines based on 486 or 386 processors }\r
+\r
+{ this document gives the specification of new version of IIUWGRAPH \r
+ class made in October 1994 by Frederic Pataud à Pau\r
+ }\r
+\r
+{ the early versions of library IIUWGRAPH have been elaborated by \r
+ Piotr Carlsson, Miroslawa Milkowska, Janina Jankowska, \r
+ Michal Jankowski at Institute of Informatics, \r
+ University of Warsaw 1987,\r
+ and added to Loglan system by Danuta Szczepanska 1987, \r
+ \r
+ the recent versions were done at LITA, Pau,\r
+ by\r
+ Pawel Susicki (1991) for Unix,\r
+ Sebastien Bernard (1992) for ATARI, see a separate document,\r
+ Eric Becourt et Jerôme Larrieu (1993) for Unix and Xwindows, see a \r
+ separate document on Xiiuwgraf ,\r
+ \r
+ \r
+\r
+fait à Pau, le 15 Novembre 1994, par Andrzej Salwicki, LITA}\r
+\r
+{ the predefined class IIUWGRAPH is included in all versions of interpreter of \r
+Loglan, with the exception of the present version of interpreter for VAX/VMS.}\r
+ \r
+\r
+\r
+hidden MaxX, MaxY, current_X, current_Y, is_graphic_On, \r
+ current_Colour, current_Background_Colour, current_Style,\r
+ current_Palette, current_Pattern ;\r
+\r
+\r
+ \r
+const MaxX = \r
+ MaxY = \r
+\r
+{ the screen's coordinates are\r
+ \r
+ (0,0) ----------------------> (MaxX,0)\r
+ ¦\r
+ ¦\r
+ ¦\r
+ V\r
+ (0, MaxY) (MaxX,MaxY)\r
+\r
+}\r
+\r
+\r
+var currentDriver : integer, { see NOCARD below } \r
+ current_X, current_Y: integer { it is the current position }\r
+ is_graphic_On: Boolean, { evidently tells whether we are in \r
+ graphics mode }\r
+ current_Colour : integer, { }\r
+ current_Background_Colour : integer,\r
+ current_Style : integer, { }\r
+ current_Palette : integer,\r
+ current_Pattern \r
+\r
+unit GRON : procedure (i: integer);\r
+ { procedure sets the monitor in graphic mode and clears the buffer\r
+ of screen. The parameter determines the resolution and the number of \r
+ colours.\r
+The user should assure that the resolution chosen should correspond to that \r
+which set by means of command\r
+SET go32 drivers {path}<driver.file> <width> <height><noColours>\r
+eg.\r
+set go32 drivers c:\loglan\svga\drivers\vesa.grn gw 1024 gh 480 nc 256\r
+ An execution of instruction call gron(i) must precede any of the \r
+graphic commands described below.\r
+ }\r
+\r
+unit GROFF : procedure;\r
+ { the procedure sets the monitor in the text mode filling it with \r
+ spaces.\r
+ DO NOT FORGET to set the monitor in the text mode before \r
+you terminate your program\r
+ }\r
+\r
+unit NOCARD : function : integer;\r
+ { the value given by this function determines the type of the currently used \r
+monitor and it is equal to\r
+ 1 for Hercules mono card,\r
+ 2 for IBM CGA color\r
+ 3 for IBM CGA mono 320 x 200\r
+ 4 for IBM CGA mono 640 x 200\r
+ 5 for EGA/VGA card\r
+ 6 for ATARI STE\r
+ 7 for Unix versions equipped with XWindows\r
+ You can not call the function nocard before GRON sets the graphic mode\r
+ }\r
+\r
+unit CLS : procedure;\r
+ { the screen will be cleared and filled with colour 0 }\r
+\r
+\r
+unit VIDEO : procedure( A: array of integer);\r
+ { this procedure can not be applied with egaint = EGA/VGA card }\r
+ { the worktime buffer will be associated with the array A.\r
+ A call of VIDEO does not change the contents of the buffer. \r
+ All subsequent calls of the procedures modifying the screen will \r
+ concern the array A. The screen does not change.\r
+ A ready image can be moved to the screen with the help of \r
+ GETMAP/PUTMAP procedures or it can be stored on disk.\r
+ The array should have 16 kBytes for IBM CGA card or \r
+ 32 kBytes for Hercules card.}\r
+\r
+{ PROCEDURES CONTROLLING THE COLOURS }\r
+\r
+unit COLOR : procedure(co : integer);\r
+{ sets current color to co \r
+ for monochrome displays, 0 means black, non-0 - white\r
+ for color displays, 0 means background\r
+ see PALLET\r
+} \r
+\r
+unit STYLE : procedure(styl : integer);\r
+{ sets style of lines and fill shades to a combination\r
+ of current color and background color (for mono -\r
+ white and black, respectively) according to 5 predefined\r
+ patterns:\r
+\r
+ 0 ....\r
+ 1 ****\r
+ 2 ***.\r
+ 3 **..\r
+ 4 *.*.\r
+ 5 *...\r
+\r
+ where '*' means current color, '.' background colour\r
+When drawing the segments the subsequent pixels will have colour determined \r
+by cyclic application of style pattern. The first and the last pixels of a segment \r
+will have always current colour.\r
+When filling contours the given style will be applied to horizontal lines with even \r
+coordinate. The style for odd lines is determined automatically.\r
+The same applies for perpendicular lines.\r
+}\r
+\r
+\r
+unit BORDER : procedure (background_Colour: integer);\r
+ \r
+ { sets actual background color to i ( i = 0,1,...,15 ) }\r
+\r
+\r
+unit PALLET : procedure (nr : integer);\r
+ {\r
+\r
+the codes of colors are as follows\r
+ 0 black\r
+ 1 blue dark\r
+ 2 green dark\r
+ 3 turquoise dark\r
+ 4 red dark\r
+ 5 violet\r
+ 6 brown\r
+ 7 grey light\r
+ 8 grey dark \r
+ 9 blue\r
+ 10 green\r
+ 11 turquoise\r
+ 12 red light\r
+ 13 rose\r
+ 14 yellow\r
+ 15 white\r
+ \r
+ }\r
+\r
+\r
+\r
+{ PROCEDURES CONTROLLING POSITION }\r
+\r
+unit MOVE : procedure (x,y :integer);\r
+ { procedure MOVE sets the current position on the screen on the pixel \r
+ with coordinates\r
+ x - column,\r
+ y - line }\r
+ { precondition of MOVE:\r
+ 0*x*MaxX & 0*y*MaxY \r
+ }\r
+\r
+unit INXPOS : function: integer;\r
+ { function INXPOS returns the x coordinate of the current position }\r
+\r
+\r
+unit INYPOS : function : integer;\r
+ { function INYPOS returns the y coordinate of the current position }\r
+\r
+\r
+unit PUSHXY : procedure;\r
+{ pushes current position, color & style onto the stack.\r
+ The stack is kept internally, max depth is 16\r
+}\r
+\r
+\r
+unit POPXY: procedure;\r
+\r
+{ restores position, color & style from internal stack }\r
+\r
+{ Example\r
+unit DIAGONAL : procedure;\r
+ var ix, iy : integer;\r
+begin\r
+ call PUSHXY;\r
+ ix := INXPOS;\r
+ iy := INYPOS;\r
+ call DRAW(ix+10, iy+10);\r
+ call POPXY\r
+end DIAGONAL;\r
+}\r
+\r
+\r
+\r
+{ PROCEDURES SERVING POINTS & LINES}\r
+\r
+unit POINT : procedure(x,y: integer);\r
+{ moves current position to pixel (x,y) and sets it to the current color \r
+ }\r
+\r
+unit INPIX : function (x,y : integer) : integer;\r
+ { \r
+ moves to pixel (x,y) and returns its color setting;\r
+ }\r
+\r
+\r
+unit DRAW : procedure( x,y : integer);\r
+ { \r
+ draws a line from current screen position to (x,y);\r
+ sets current position to (x,y);\r
+ line is drawn in current color, with both terminal pixels\r
+ always turned white ( non-background) for non-black\r
+ ( non-background ) line color.\r
+ Bresenham's algorithm is used, pixels belonging to the segment \r
+ change their state depending on current colour and style.\r
+ }\r
+\r
+unit intens: procedure(Size :integer; xCoord,yCoord:arrayof integer, \r
+ Colour,Filled :integer); \r
+/* draw a polygon*/\r
+{ draw a simple, closed polygon of Size points, the edges of the polygon go from \r
+(xCoord[i], yCoord[i]) to (xCoord[i+1], yCoord[i+1]) for i = 1, ..., Size-1\r
+The colour used will be Colour. The polygon will be filled iff Filled<>0.\r
+}\r
+\r
+unit CIRB : procedure (xi, yi, rx,ry : integer, alfa, beta : real, \r
+ cbord, fill : integer);\r
+\r
+ {\r
+ draws a circle (or ellipse, depending on aspect value, see below),\r
+ optionally filling its interior; \r
+ does not preserve position;\r
+ (xi,yi) - are center coordinates,\r
+ rx - radius in pixels (horizontally),\r
+ ry - radius in pixels (perpendicularly),\r
+ alfa, beta - starting & ending angles; if alfa=beta a full\r
+ circle is drawn; values should be given in radians;\r
+ cbord - border color,\r
+ fill - if fill <>0, interior is filled in current style&color\r
+ }\r
+\r
+unit hfill: procedure( x : integer);\r
+ { draw an horizontal line between the current position and\r
+ (x,currentY) with the current color, after it change the current\r
+ position to (x, currentY)\r
+ }\r
+\r
+unit vfill: procedure( y : integer);\r
+ { draw a vertical line between the current position and\r
+ (currentX,y) with the current color, after it change the current\r
+ position to (currentX,y)\r
+ }\r
+\r
+unit patern: procedure( x1,y1,x2,y2,c,b : integer);\r
+ { draw a rectangle between the points (x1,y1) and (x2,y2) with the\r
+ color c (the current color is not change). if b=0 then the box is\r
+ empty else it is filled.\r
+ }\r
+\r
+{ Procedures operating on bitmaps }\r
+\r
+unit GETMAP : function (x,y : integer) : arrayof integer;\r
+ {saves rectangular area between current position as\r
+ top left corner and (ix,iy) as bottom right corner,\r
+ including border lines;\r
+ position remains unchanged.\r
+ array of integer should have \r
+ 4+(rows**columns/8* *coeff)\r
+ bytes. The coefficient coeff is 1 for Hercules, 2 for CGA, 4 for EGA\r
+ card.\r
+ ATTENTION: in DOS 286 environment a bigger size of the array may \r
+ necessitate the use of loglan with the option H+, see also memavail \r
+ }\r
+\r
+unit PUTMAP : procedure ( a: arrayof integer);\r
+ {sets rectangular area of screen pixels to that saved\r
+ by "getmap" in "iarray";\r
+ same size is restored, with top left corner in current\r
+ position;\r
+ position remains unchanged.\r
+ }\r
+\r
+unit ORMAP : procedure ( a : arrayof integer);\r
+ {same as putmap, but saved bitmap is or'ed into screen\r
+ rather than just set.\r
+ }\r
+\r
+unit XORMAP : procedure ( a: arrayof integer);\r
+ {same as putmap, but saved bitmap is xor'ed into screen\r
+ rather than just set.\r
+ }\r
+\r
+\r
+{Procedures operating on characters and strings}\r
+\r
+unit outstring: procedure(x,y: integer, s: string, back_col, front_col: integer);\r
+ { x, y are the coordinates where to put the string,\r
+ s is the string to be shown, in front_col colour letters on the back_col \r
+ colour background\r
+ }\r
+\r
+unit track: procedure( x,y,c,valeur : integer);\r
+\r
+ { write an integer value valeur at the position (x,y) with the color c.\r
+ It does not change the current position nor the current color\r
+ }\r
+\r
+unit inkey : function : integer;\r
+\r
+ { returns next character from keyboard buffer;\r
+ 0 is returned if buffer is empty;\r
+ special keys are returned as negative numbers;\r
+ ALT-NUM method may be used for entering character codes\r
+ above 127 (this makes entering special keys 128-132\r
+ impossible);\r
+ if a character is returned, it is also removed\r
+ from the buffer, so MS-DOS will not see it (CTRL-C!);\r
+ typeahead is allowed, echo is suppressed.\r
+ }\r
+\r
+unit HASCII : procedure(c: integer);\r
+ {'xor's the character = chr(c) in a 8*8 box with top left corner\r
+ in the current position;\r
+ moves current position by (8,0);\r
+ call hascii(0)- sets complete box to black ( =background ),\r
+ with no change in position.\r
+ BIOS ROM font for IBM color card is used. If the font\r
+ table is not at F000:FA6E, the character will probably\r
+ be unrecognizable, and most certainly wrong.\r
+ For codes >127, table pointed to by interrupt vector 31\r
+ is used. }\r
+\r
+\r
+\r
+unit hfont: function( x,y,lg,min,max,default,col_f,col_e,col_c : integer): \r
+ integer;\r
+\r
+ { arrange a small 1 line window for reading an integer value from this \r
+window,\r
+the position of the window corner is (x, y),\r
+the length of the window is lg characters,\r
+the value v should be greater than min and smaller than max,\r
+the default value read is default,\r
+the colour of the window is col_f,\r
+the colour of the digits is col_e,\r
+the colour of cursor is col_c\r
+\r
+ reads in graphic mode an integer in the window which begins at the (x,y)\r
+ position, window is lg caracteres long. the maximum length of the\r
+ integer that is read is 10. there is a default value, a minimum value\r
+ and a maximum value. the window is drawn with the col_f color, the \r
+ cursor is in the col_c color and the integer is writing in the col_e\r
+ color. you can use 0..9,+,-,backspace,escape and return keys. }\r
+\r
+\r
+unit HPAGE : procedure(x,y,long: integer, A: arrayof char, back, front: integer);\r
+ { this procedure arranges a 1-line high window in position x,y of length \r
+ long in which a portion of text A is shown in colour front on the \r
+ background colour back. \r
+ Making use of keys controlling the cursor {left, right, PgUp, PgDn}\r
+ the user can scroll the text (horizontally) in the window. Pressing the \r
+ Enter key terminates the procedure} \r
+\r
+end IIUWGRAPH;\r
+\r
+\r
+\r
+\r
+unit MOUSE: class;\r
+ \r
+{ init -lors de l'initialisation de la souris, on peut définir les événements qui vont faire réagir la fonction \r
+getpress; le premier et le deuxième paramètre représentent respectivement la souris et le clavier, si une valeur non \r
+nulle est donnée comme paramètre alors getpress réagira à l'événement.\r
+\r
+ Une paire (1,1) va permettre de prendre en compte à la fois les événements de la souris et ceux du clavier; \r
+une paire (1,0) quand à elle ne prendra en compte que la souris. Pour une plus grande souplesse d'utilisation, il est \r
+possible lors du programme, après l'initalisation, de changer cette prise en compte, cela se fera par l'appel de la \r
+procedure getmovement, procédure ayant les mêmes paramètres (avec le même ordre) que la fonction init.\r
+\r
+ Pour detecter les événements, on utilisa la fonction getpress, qui retourne un booléen indiquant la présence \r
+ou l'absence d'événement (respectivement les valeurs true et false). Il est bon de noter qu'ainsi définie la fonction \r
+getpress n'est pas bloquante. Les paramètres en retour sont soit nuls (pas d'événement) soit correspondent:\r
+\r
+ bool:=getpress(v,p,h,l,r,c : integer);\r
+ v = position en y de la souris\r
+ p = keyboard status (Touche control_left,control_right, alt, alt_gr, shift_left, shift_right)\r
+ h = position en x de la souris\r
+ l = touche clavier\r
+ r = flags\r
+ c = boutons de la souris (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)\r
+ Nb: le bouton central n'est pas géré.\r
+\r
+NOTEZ BIEN! Lorsque les événements du clavier sont pris en compte dans le gestionnaire, il ne faut pas utiliser \r
+les fonctions d'entrées clavier readl, readln, hfont, hfont8, hpage, inkey,...) sous peine de plantage de \r
+l'ordinateur.\r
+}\r
+\r
+ unit init: procedure(checkMouse, checkKeyboard: integer);\r
+ { initializes the Mouse driver.\r
+ tells which events will be checked:\r
+ if checkMouse <>0 then the events of Mouse will be reported to getpress, see below otherwise ignored;\r
+ if checkKeyboard <>0 then the events of Keyboard will be reported to getpress, otherwise ignored\r
+ Attention please! While the events of the keyboard are taken under control by init or getmovement\r
+ do not use the functions or procedures: read, readln, hfont, hfont8, hpage, inkey that read keys\r
+ YOU RISK TO HANG YOUR SYSTEM!\r
+ }\r
+ end init\r
+\r
+ unit getmovement: procedure(checkMouse, checkKeyboard: integer);\r
+ tells which events will be checked:\r
+ if checkMouse <>0 then the events of Mouse will be reported to getpress, see below otherwise ignored;\r
+ if checkKeyboard <>0 then the events of Keyboard will be reported to getpress, otherwise ignored\r
+ Attention please! While the events of the keyboard are taken under control by init or getmovement\r
+ do not use the functions or procedures: read, readln, hfont, hfont8, hpage, inkey that read keys\r
+ YOU RISK TO HANG YOUR SYSTEM!\r
+ end getmovement;\r
+\r
+ unit getpress: function(v,p,h,l,r,c : integer): Boolean;\r
+ { v = y coordinate of the cursor,\r
+ h = x coordinate of the cursor,\r
+ p = keybord status control_left,control_right, alt, alt_gr, shift_left, shift_right\r
+ l = code of key pressed\r
+ r = flags\r
+ c = buttons pressed (0=aucun, 1=gauche, 2=droite, 3=gauche et droite)\r
+ Nb: the middle button is not taken into account.\r
+ end getpress\r
+\r
+\r
+ unit showcursor: procedure;\r
+ {the cursor becomes visible and follows the movements of the mouse}\r
+ end showcursor;\r
+\r
+ unit hidecursor: procedure;\r
+ {the cursor becomes invisible}\r
+ end hidecursor;\r
+\r
+end MOUSE;\r
+\r
+\r
+\r
+Enclosed you find a sample program\r
+\r
+Program SystemeGraph;\r
+ (* by Frederic Pataud, October 1994 *)\r
+Begin\r
+Pref iiuwgraph block (* inherit the graphic functions *)\r
+ Begin\r
+ Pref mouse block (* inherit the mouse functions *)\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* P r o g r a m m e P r i n c i p a l *)\r
+ (*****************************************************************************)\r
+ var v,p,h,i : integer,\r
+ l,r,c : integer,\r
+ rep : arrayof char,\r
+ d : boolean,\r
+ xx,yy : arrayof integer,\r
+ status,code,x,y,flags,button : integer;\r
+ \r
+ Begin\r
+ \r
+ call gron(0); (* enter the graphic mode *)\r
+ call init(1,0); (* initialize the mouse, disregard the keyboard events, check for mouse events *)\r
+ \r
+ call showcursor; (* show cursor *)\r
+ call patern(5,5,635,475,2,0); (* make a frame around the screen *)\r
+ call outstring(10,10,"x=",2,0);\r
+ call outstring(100,10,"y=",2,0);\r
+ call outstring(10,30,"status = ",2,0);\r
+ call outstring(10,50,"code = ",2,0);\r
+ call outstring(10,70,"flags = ",2,0);\r
+ call outstring(10,90,"button = ",2,0);\r
+ call patern(100,210,300,320,3,1); (* make a rectangle filled in colour 3 *)\r
+\r
+ array xx dim (1:6);\r
+ array yy dim (1:6);\r
+ xx(1):=410; yy(1):=10;\r
+ xx(2):=450; yy(2):=30;\r
+ xx(3):=460; yy(3):=50;\r
+ xx(4):=430; yy(4):=80;\r
+ xx(5):=420; yy(5):=40;\r
+ xx(6):=480; yy(6):=30;\r
+ call intens(6,xx,yy,8,1); (* show a polygon filled*)\r
+ for i:=1 to 6\r
+ do\r
+ yy(i):=yy(i)+100;\r
+ od;\r
+ call intens(6,xx,yy,15,0); (* show another polygon empty *)\r
+ \r
+ call cirb(500,300,50,40,100,3500,10,0); (* draw an empty pie or camembert *)\r
+ call cirb(400,400,40,40,600,4000,11,1); (* draw a filled pie *)\r
+\r
+\r
+ i:=hfont(100,350,6,-9999999,9999999,500,9,0,15); (* read integer from a window *)\r
+ call hpage(100,400,10,unpack("Il fait beau dans ma verte campagne"),9,0); (* show text *)\r
+ rep:=hfont8(100,430,10,80,unpack("tototutu"),9,0,15); (* read text *)\r
+ \r
+ call getmovement(1,1); (* take into consideration both key events and mouse events *)\r
+ \r
+ do\r
+ d:=getpress(v,p,h,l,r,c); (* ask about an event *)\r
+ if (d)\r
+ then call outstring(10,400,"Event",2,0);\r
+ call patern(80,25,130,100,0,1);\r
+ call track(40,10,v,0,4); (* print integer *)\r
+ call track(140,10,p,0,4);\r
+ call track(80,30,h,0,4);\r
+ call track(80,50,l,0,4);\r
+ call track(80,70,r,0,4);\r
+ call track(80,90,c,0,4);\r
+ if((h=164 and l=27) or (c=3)) (* exit if either two buttons were pressed c=3 or Ctrl+Esc key *)\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call groff; (* leave the graphic mode and return to the text mode *)\r
+ writeln("i=",i);\r
+ for i:=lower(rep) to upper(rep)\r
+ do\r
+ write(rep(i));\r
+ od;\r
+ writeln;\r
+ End\r
+ End\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+Bonjour,\r
+\r
+LITA a le plaisir d'annoncer que vous pouvez acceder et utiliser\r
+les programmes suivants\r
+\r
+ loglan, gen, int, Xint\r
+ == le compilateur et l'interpretateur du Loglan'82\r
+ le langage de programmation par objets, avec les processus.\r
+ (le produit des LITA et l'Institut d'Informatique a Varsovie).\r
+\r
+ f2c\r
+ == le compilateur de Fortran vers C et C++\r
+ (le produit de GNU)\r
+\r
+ g++\r
+ == le compilateur de C++\r
+ (le produit de GNU)\r
+\r
+ et d'autres utilitaires de GNU\r
+\r
+Inserez \r
+ /home/r/lita/salwicki/bin\r
+dans votre ligne de PATH.\r
+\r
+Vous pouvez egalement recuperer un complet des fichiers Loglan'82:\r
+ - les executables,\r
+ - les sources,\r
+ - la documentation,\r
+ - les exemples,\r
+ - l'environnement DOS (editeurs etc.)\r
+\r
+par ftp\r
+\r
+ server: infpc1.univ-pau.fr (192.70.116.32)\r
+ user: anonymous\r
+ password: "votre adresse internet"\r
+\r
+N'hesitez pas nous consulter.\r
+\r
+Bonne programmation!\r
+\r
+\r
+ salwicki@infpc1.univ-pau.fr\r
+ mirkowsk@infpc1.univ-pau.fr\r
+ bernard@infpc1.univ-pau.fr\r
+\r
+\r
+ Pau, le 23 Septembre 1993\r
+\r
--- /dev/null
+\r
+\r
+\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ A micro-manual\r
+ \r
+ of \r
+ \r
+ the programming language\r
+ \r
+ \r
+ L O G L A N - 82\r
+ ================\r
+ \r
+ \r
+ \r
+ Basic constructs and facilities\r
+ \r
+ \r
+ Author: Antoni Kreczmar\r
+ Institute of Informatics, Warsaw University\r
+ September 1982 \r
+\r
+\r
+ LOGLAN-82 is a universal programming language designed at the\r
+Institute of Informatics, University of Warsaw. Its syntax is\r
+patterned upon Pascal's. Its rich semantics includes the classical\r
+constructs and facilities offered by the Algol-family programming\r
+languages as well as more modern facilities, such as concurrency and\r
+exception handling.\r
+ The basic constructs and facilities of the LOGLAN-82 programming\r
+language include:\r
+ \r
+1) A convenient set of structured statements,\r
+ \r
+2) Modularity (with the possibility of module nesting and extending),\r
+ \r
+3) Procedures and functions (fully recursive; procedures and functions\r
+ can be used also as formal parameters),\r
+ \r
+4) Classes (as a generalization of records) which enable to define\r
+ complex structured types, data structures, packages, etc.,\r
+ \r
+5) Adjustable arrays whose bounds are determined at run-time in such a\r
+ way that multidimensional arrays may be of various shapes, e.g.\r
+ triangular, k-diagonal, streaked, etc.,\r
+ \r
+6) Coroutines and semi-coroutines,\r
+ \r
+7) Prefixing - the facility borrowed from Simula-67, substantially\r
+ generalized in LOGLAN-82 - which enables to build up hierarchies of\r
+ types and data structures, problem-oriented languages, etc.,\r
+ \r
+8) Formal types treated as a method of module parametrization,\r
+ \r
+9) Module protection and encapsulation techniques,\r
+ \r
+10) Programmed deallocator - a tool for efficient and secure garbage\r
+ collection, which allows the user to implement the optimal\r
+ strategy of storage management,\r
+ \r
+11) Exception handling which provides facilities for dealing with\r
+ run-time errors and other exceptional situations raised by the\r
+ user,\r
+ \r
+12) Separate compilation techniques,\r
+ \r
+13) Concurrency easily adaptable to any operating system kernel and\r
+ allowing parallel programming in a natural and efficient way.\r
+ \r
+ The language covers system programming, data processing, and\r
+numerical computations. Its constructs represent the state-of-art and\r
+are efficiently implementable. Large systems consisting of many\r
+cooperating modules are easily decomposed and assembled, due to the\r
+class concept and prefixing.\r
+ LOGLAN-82 constructs and facilities have appeared and evolved\r
+simultaneously with the experiments on the first pilot compiler\r
+(implemented on Mera-400 Polish minicomputer). The research on\r
+LOGLAN-82 implementation engendered with new algorithms for static\r
+semantics, context analysis, code generation, data structures for\r
+storage management etc.\r
+ The LOGLAN-82 compiler provides a keen analysis of syntactic and\r
+semantic errors at compilation as well as at run time. The object code\r
+is very efficient with respect to time and space. The completeness of\r
+error checking guarantees full security and ease of program debugging.\r
+\r
+1. Compound statements\r
+######################\r
+\r
+ Compound statements in LOGLAN-82 are built up from simple statements\r
+(like assignment statement e.g. x:=y+0.5, call statement e.g. callP(7,x+5) e\r
+ The syntax of conditional statement is as follows:\r
+ \r
+ if boolean expression\r
+ then \r
+ sequence of statements\r
+ else \r
+ sequence of statements\r
+ fi \r
+ \r
+where "else part" may be omitted:\r
+ \r
+ if boolean expression \r
+ then \r
+ sequence of statements\r
+ fi \r
+ \r
+ The semantics of conditional statement is standard. The keyword fi \r
+allows to nest conditional statements without appearence of "dangling\r
+else" ambiguity.\r
+ \r
+Example:\r
+--------\r
+ \r
+ if delta>0 if \r
+ then \r
+ x2:=sqrt(delta)/a/2;\r
+ if b=0 \r
+ then \r
+ x1:=x2\r
+ else \r
+ x1:=-b/a/2+x2; x2:=x1-2*x2\r
+ fi \r
+ else \r
+ if delta=0 \r
+ then \r
+ x1:=-b/a/2; x2:=x1\r
+ else \r
+ write(" no real roots")\r
+ fi \r
+ fi \r
+ \r
+ The statements in a sequence of statements are separated with\r
+semicolons (semicolon may end a sequence , and then, the last\r
+statement in the sequence is the empty statement).\r
+\r
+ The short circuit control forms are realized in LOGLAN-82 by the\r
+conditional statements with orif (or andif) list. A conditional \r
+statement with orif list has the form: orif \r
+ \r
+ if wb1 orif wb2 ... orif wbk \r
+ then \r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi \r
+ \r
+and corresponds somehow to a conditional statement:\r
+ \r
+ if wb1 or wb2 ... or wbk \r
+ then \r
+ sequence of statements\r
+ else \r
+ sequence of statements\r
+ fi \r
+ \r
+ The above conditional statement (without orif list) selects for \r
+execution one of two sequences of statements, depending on the truth\r
+value of the boolean expression:\r
+ \r
+ wb1 or wb2 or ... wbk \r
+ \r
+which is always evaluated till the end. For the execution of the\r
+conditional statement with orif list the specified conditons \r
+wb1,...,wbk are evaluated in succession, until the first one evaluates\r
+to true. Then the rest of the sequence wb1,...,wbk is abandoned and\r
+"then part" is executed. If none of the conditions wb1,...,wbk\r
+evaluates to true "else part" is executed (if any).\r
+ Conditional statements with orif list facilitate to program those \r
+conditions, which evaluation to the end may raise a run-time error.\r
+ \r
+Example:\r
+--------\r
+ The execution of the statement:\r
+ \r
+ if i>n or A(i)=0 then i:=i-1 else A(i):=1 fi \r
+ \r
+where the value of i is greater than n, and A is an array with upper\r
+bound n, will raise the run-time error. Then the user can write:\r
+ \r
+ if i>n orif A(i)=0 then i:=i-1 else A(i):=1 fi\r
+ \r
+what allows to avoid this run-time error and probably agrees with his\r
+intension. \r
+\r
+ Conditional statement with andif list has the form:\r
+ \r
+ if wb1 andif wb2 ... andif wbk\r
+ then \r
+ sequence of statements\r
+ else \r
+ sequence of statements\r
+ fi \r
+ \r
+ For the execution of this kind of statements, the conditions\r
+wb1,...,wbk are evaluated in succession, until the first one evaluates\r
+to false; then "else part" (if any) is executed. Otherwise "then part"\r
+is executed.\r
+ \r
+ Iteration statement in LOGLAN-82 has the form:\r
+ \r
+ do sequence of statements od\r
+ An iteration statement specifies repeated execution of the sequence\r
+of statements and terminates with the execution of the simple\r
+statement exit\r
+ \r
+Example:\r
+--------\r
+ \r
+ s:=1; t:=1; i:=1;\r
+ do \r
+ i:=i+1; t:=t*x/i;\r
+ if abs(t) < 1.0E-10 then exit fi; \r
+ s:=s+t\r
+ od; \r
+ \r
+ If two iteration statements are nested, then double exit in the \r
+inner one terminates both of them.\r
+ \r
+Example:\r
+--------\r
+ \r
+ r,x:=0;\r
+ do \r
+ s,t:=1; i:=1; x:=x+0.2;\r
+ do \r
+ i:=i+1; t:=t*x/i;\r
+ if i > n then exit exit fi; (* termination of both loops *) \r
+ if t < 1 then exit fi; (* termination of the inner loop *) \r
+ s:=s+t\r
+ od \r
+ od \r
+ \r
+ In the example above simultaneous assignment statements are\r
+illustrated (e.g. r,x:=0) and comments, which begin with a left\r
+parenthesis immediately followed by an asterisk and end with an\r
+asterisk immediately followed by a right parenthesis.\r
+ \r
+ Triple exit terminates three nested iteration statements, four exit \r
+terminates four nested iteration statements etc.\r
+\r
+ The iteration statement with while condition: w\r
+ \r
+ while boolean expression \r
+ do \r
+ sequence of statements\r
+ od \r
+ \r
+is equivalent to:\r
+ \r
+ do \r
+ if not boolean expression then exit fi; \r
+ sequence of statements\r
+ od \r
+ \r
+ The iteration statements with controlled variables (for statements) \r
+have the forms:\r
+ \r
+ for j:=wa1 step wa2 to wa3 \r
+ do \r
+ sequence of statements\r
+ od \r
+ \r
+or\r
+ \r
+ for j:=wa1 step wa2 downto wa3 \r
+ do \r
+ sequence of statements\r
+ od \r
+ \r
+ The type of the controlled variable j must be discrete. The value of\r
+this variable in the case of the for statement with to is increased, \r
+and in the case of the for statement with downto is decreased. The \r
+discrete range begins with the value of wa1 and changes with the step\r
+equal to the value of wa2. The execution of the for statement with to\r
+terminates when the value of j for the first time becomes greater than\r
+the value of wa3 (with downto when the value of j for the first time \r
+becomes less than the value of wa3). After the for statement \r
+termination the value of its controlled variable is determined and\r
+equal to the first value exceeding the specified discrete range. The\r
+values of expressions wa1, wa2 and wa3 are evaluated once, upon entry\r
+to the iteration statement. Default value of wa2 is equal 1 (when the\r
+keyword step and expression wa2 are omitted).\r
+ for or while statements may be combined with exit statement. \r
+ \r
+Example:\r
+--------\r
+ \r
+ for j:=1 to n\r
+ do \r
+ if x=A(j) then exit fi; \r
+ od \r
+ \r
+ The above iteration statement terminates either for the least j,\r
+1<=j<=n, such that x=A(j) or for j=n+1 when x=/=A(j), j=1,...,n.\r
+\r
+ To enhance the user's comfort, the simple statement repeat is\r
+provided. It may appear in an iteration statement and causes the\r
+current iteration to be finished and the next one to be continued\r
+(something like jump to CONTINUE in Fortran's DO statements).\r
+ \r
+Example:\r
+--------\r
+ \r
+ i:=0; s:=0;\r
+ do \r
+ i:=i+1;\r
+ if A(i) < 0 then repeat fi; (* jump to od, iterations are continued *)\r
+ if i > m then exit fi; (* iteration statement is terminated *) \r
+ s:=s+sqrt(A(i));\r
+ od; \r
+ \r
+ Just as exit, repeat may appear in for statement or while statement. \r
+Then the next iteration begins with either the evaluation of a new\r
+value of the controlled variable (for statement) or with the \r
+evaluation of the condition (while statement). \r
+ \r
+ Case statement in LOGLAN-82 has the form:\r
+ \r
+ case WA \r
+ when L1 : I1 \r
+ when L2 : I2 \r
+ ...\r
+ when Lk : Ik \r
+ otherwise I \r
+ esac \r
+ \r
+where WA is an expression , L1,...,Lk are constants and I1,..., Ik,I\r
+are sequences of statements.\r
+ A case statement selects for execution a sequence of statements Ij,\r
+1<=j<=k, where the value of WA equals Lj. The choice otherwise covers \r
+all values (possibly none) not given in the previous choices. The\r
+execution of a case statement chooses one and only one alternative\r
+(since the choices are to be exhaustive and mutually exclusive).\r
+\r
+2. Modularity\r
+#############\r
+ \r
+ Modular structure of the language is gained due to the large set of\r
+means for module nesting and extending. Program modules (units) are\r
+blocks, procedures, functions, classes, coroutines and processes.\r
+Block is the simplest kind of unit. Its syntax is the following:\r
+ \r
+ block \r
+ lists of declarations\r
+ begin \r
+ sequence of statements\r
+ end \r
+ \r
+ The sequence of statements commences with the keyword begin (it may \r
+be omitted when this sequence is empty). The lists of declarations\r
+define the syntactic entities (variables, constants, other units),\r
+whose scope is that block. The syntactic entities are identified in\r
+the sequence of statements by means of names (identifiers).\r
+ \r
+Example:\r
+--------\r
+ \r
+ block \r
+ const n=250; \r
+ var x,y:real, i,j,k: integer, b: boolean; \r
+ const m=n+1; \r
+ begin \r
+ read(i,j); (* read two integers *)\r
+ x,y:=n/(i+j); (* simultaneous assignment *)\r
+ read(c) ; (* read a character *)\r
+ b:= c = 'a'; (* 'a' a character *)\r
+ for k:= 1 to m \r
+ do \r
+ write(x+y/k:10:4); (* print the value of x+y/k\r
+ in the field of 10 characters, 4 digits after the point *)\r
+ od \r
+ end \r
+ \r
+ In the lists of declarations semicolons terminate the whole lists,\r
+not the lists elements. Any declaration list must begin with the\r
+pertinent keyword (var for variables, const for constants etc.). The \r
+value of an expression defining a constant must be determinable\r
+statically (at compilation time).\r
+ Program in LOGLAN-82 may be a block or alternatively may be of the\r
+following form:\r
+ \r
+ program name; \r
+ lists of declarations\r
+ begin \r
+ sequence of statements\r
+ end \r
+ \r
+Then the whole program can be identified by that name (the source as\r
+well as the object code).\r
+\r
+ A block can appear in the sequence of statements (of any unit), thus\r
+it is a statement. (Main block is assumed to appear as a statement of\r
+the given job control language.)\r
+ For the execution of a block statement the object of block is\r
+created in a computer memory, and then, the sequence of statements is\r
+performed. The syntactic entities declared in the block are allocated\r
+in its object. After a block's termination its object is automatically\r
+deallocated (and the corresponding space may be immediately reused).\r
+ The modular structure of the language works "in full steam" when not\r
+only blocks, but the other kinds of units are also used. They will be\r
+described closer in the following points.\r
+ Unit nesting allows to build up hierarchies of units and supports\r
+security of programming. It follows from the general visibility rules;\r
+namely, a syntactic entity declared in an outer unit is visible in an\r
+inner one (unless hidden by an inner declaration). On the other hand,\r
+a syntactic entity declared in an inner unit is not visible from an\r
+outer one.\r
+ \r
+Example:\r
+--------\r
+ \r
+ program test; \r
+ var a,b,c:real, i,j,k:integer; \r
+ begin \r
+ read(a,b,c,i);\r
+ block \r
+ var j,k:real; \r
+ begin \r
+ j:=a; k:=j+b; write(" this is the inner block ",j,k)\r
+ end; \r
+ write(" this is the outer block ",i,a:20)\r
+ end; \r
+ \r
+ In this program, first the main block statement is executed (with\r
+variables a,b,c,i,j,k). Next, after the read statement, the inner\r
+block statement is executed (with variables j,k). In the inner block\r
+the global variables j,k are hidden by the local ones.\r
+ \r
+\r
+3. Procedures and functions\r
+###########################\r
+ \r
+ Procedures and functions are well-known kinds of units. Their syntax\r
+is modelled on Pascal's, though with some slight modifications.\r
+Procedure (function) declaration consists of a specification part and\r
+a body.\r
+ \r
+ Example:\r
+ --------\r
+ unit Euclid: function(i,j:integer):integer; \r
+ var k:integer;\r
+ begin \r
+ do \r
+ if j=0 then exit fi; \r
+ k:=i mod j; i:=j; j:=k \r
+ od; \r
+ result:=i\r
+ end; \r
+ \r
+ Procedure or function specification begins with its identifier\r
+preceded by the keyword unit. (The same syntax concerns any other module \r
+named unit.) Then follows its kind declaration, its formal parameters\r
+(if any), and the type of the returned value (only for functions). A\r
+body consists of declaration lists for local entities and a sequence\r
+of statements. The keyword begin commences the sequence of statements \r
+, and is omitted , if this sequence is empty. The value returned by a\r
+function equals to the most recent value of the standard variable\r
+"result", implicitly declared in any function. This variable can be\r
+used as a local auxiliary variable as well.\r
+ \r
+ Example:\r
+ --------\r
+ unit Newton: function(n,m:integer):integer; \r
+ var i:integer; \r
+ begin \r
+ if m > n then return fi; \r
+ result:=n;\r
+ for i:=2 to m do result:=result*(n-i+1) div i od \r
+ end Newton;\r
+ The optional identifier at the end of a unit must repeat the\r
+identifier of a unit. It is suggested that the compilers check the\r
+order of unit nesting, so these optional occurrences of identifiers\r
+would facilitate program debugging.\r
+ All the local variables of a unit are initialized (real with 0.0,\r
+integer with 0, boolean with false etc.). Thus , for instance, the\r
+value of function Newton is 0 for m>n, since "result" is also\r
+initialized, as any other local variable.\r
+ \r
+ The return statement (return) completes the execution of a procedure \r
+(function) body,i.e. return is made to the caller. If return does not \r
+appear explicitly, return is made with the execution of the final end \r
+of a unit. Upon return to the caller the procedure (function) object\r
+is deallocated.\r
+ Functions are invoked in expressions with the corresponding list of\r
+actual parameters. Procedures are invoked by call statement (also with\r
+the corresponding list of actual parameters).\r
+\r
+ Example:\r
+ --------\r
+ i:=i*Euclid(k,105)-Newton(n,m+1);\r
+ call P(x,y+3); \r
+ \r
+ Formal parameters are of four categories: variable parameters,\r
+procedure parameters, function parameters and type parameters (cf\r
+p.8). Variable parameters are considered local variables to the unit.\r
+A variable parameter has one of three transmission modes: input,\r
+output or inout. If no mode is explicitly given the input mode is\r
+assumed. For instance in the unit declaration:\r
+ \r
+ unit P: procedure(x,y:real,b:boolean;output c:char,i:integer;inout j:integer);\r
+ \r
+x,y,b are input parameters , c,i are output parameters , and j is\r
+inout parameter.\r
+ \r
+ Input parameter acts as a local variable whose value is initialized\r
+by the value of the corresponding actual parameter. Output parameter\r
+acts as a local variable initialized in the standard manner (real with\r
+0.0, integer with 0, boolean with false etc.). Upon return its value\r
+is assigned to the corresponding actual parameter, in which case it\r
+must be a variable. However the address of such an actual parameter is\r
+determined upon entry to the body. Inout parameter acts as an input\r
+parameter and output parameter together.\r
+ \r
+ Example:\r
+ --------\r
+ unit squareeq: procedure(a,b,c:real;output xr,xi,yr,yi:real); \r
+ (* given a,b,c the procedure solves square equation : ax*x+bx+c=0.\r
+ xr,xi- real and imaginary part of the first root\r
+ yr,yi- real and imaginary part of the second root *)\r
+ var delta: real; \r
+ begin (*a=/=0*) \r
+ a:=2*a; c:=2*c; delta:=b*b-a*c;\r
+ if delta <= 0 \r
+ then \r
+ xr,yr:=-b/a;\r
+ if delta=0 then return fi; (*xi=yi=0 by default*) \r
+ delta:=sqrt(-delta);\r
+ xi:=delta/a; yi:=-xi;\r
+ return \r
+ fi; \r
+ delta:=sqrt(delta);\r
+ if b=0 \r
+ then \r
+ xr:=delta/a; yr:=-xr;\r
+ return \r
+ fi; \r
+ if b>0 then b:=b+delta else b:=b-delta fi;\r
+ xr:=-b/a; yr:=-c/b;\r
+ end squareeq;\r
+\r
+ A procedure call to the above unit may be the following:\r
+ \r
+ call squareeq(3.75*H,b+7,3.14,g,gi,h,hi); \r
+where g,h,gi,hi are real variables.\r
+ \r
+ \r
+ No restriction is imposed on the order of declarations. In\r
+particular, recursive procedures and functions can be declared without\r
+additional announcements (in contrast to Pascal).\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ For two recursive sequences defined as:\r
+ \r
+ a(n)=b(n-1)+n+2 n>0\r
+ b(n)=a(n-1)+(n-1)*n n>0\r
+ a(0)=b(0)=0\r
+ \r
+one can declare two functions:\r
+ \r
+ unit a: function(n:integer):integer;\r
+ begin \r
+ if n>0 then result:=b(n-1)+n+2 fi\r
+ end a; \r
+ unit b: function(n:integer):integer; \r
+ begin \r
+ if n>0 then result:=a(n-1)+(n-1)*n fi \r
+ end b; \r
+ \r
+and invoke them:\r
+ \r
+ k:=a(100)*b(50)+a(15);\r
+ \r
+ Functions and procedures can be formal parameters as well.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+unit Bisec: procedure(a,b,eps:real;output x:real;function f(x:real):real);\r
+(*this procedures searches for zero of continous function f in segment (a,b) *)\r
+var h:real,s:integer;\r
+begin\r
+ s:=sign(f(a));\r
+ if sign(f(b))=s then return fi; (* wrong segment *) \r
+ h:=b-a;\r
+ do \r
+ h:=h/2; x:=a+h;\r
+ if h < eps then return fi;\r
+ if sign(f(x))=s then a:=x else b:=x fi\r
+ od \r
+end Bisec;\r
+\r
+ In the above declaration, after the input variable parameters\r
+a,b,eps and the output variable parameter x, a function parameter f\r
+appears. Note that its specification part is complete. Thus the check\r
+of actual-formal parameter compatibility is possible at compilation\r
+time. Making use of this syntactic facility is not possible in\r
+general, if a formal procedure (function) is again a formal parameter\r
+of a formal procedure (function). The second degree of formal\r
+procedures (functions) nesting is rather scarce, but LOGLAN-82 admits\r
+such a construct. Then formal procedure (function) has no\r
+specification part and the full check of actual-formal parameter\r
+compatibility is left to be done at run time.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit P: procedure(j:integer;procedure G(i:integer;procedure H));\r
+ ...\r
+ begin \r
+ ...\r
+ call G(j,P);\r
+ end P; \r
+ \r
+ Procedure G is a first degree parameter, therefore it occurs with\r
+complete specification part. Procedure H is a second degree parameter\r
+and has no specification part. In this case a procedure call can be\r
+strongly recursive:\r
+ \r
+ call P(i+10,P); \r
+\r
+4. Classes\r
+##########\r
+ \r
+ Class is a facility which covers such programming constructs as\r
+structured type, package, access type, data structure etc. To begin\r
+with the presentation of this construct, let us consider a structured\r
+type assembled from primitive ones:\r
+ \r
+ unit bill: class;\r
+ var dollars :real, \r
+ not_paid :boolean,\r
+ year,month,day :integer;\r
+ end bill; \r
+ \r
+ The above class declaration has the attributes : dollars (real),\r
+not_paid (boolean), and year,month,day (integer). Wherever class bill\r
+is visibile one can declare variables of type bill:\r
+ \r
+ var x,y,z:bill;\r
+ \r
+ The values of variables x, y, z can be the addresses of objects of\r
+class bill. These variables are called reference variables. With\r
+reference variable one can create and operate the objects of reference\r
+variable type.\r
+ \r
+ An object of a class is created by the class generation statement\r
+(new), and thereafter, its attributes are accessed through dot \r
+notation.\r
+ \r
+ x:=new bill; (* a new object of class bill is created *) \r
+ x.dollars:=500.5; (* define amount *)\r
+ x.year:=1982; (* define year *)\r
+ x.month:=3; (* define month *)\r
+ x.day:=8; (* define day *)\r
+ y:=new bill; (* create a new object *) \r
+ y.not_paid:=true; (* bill not_paid *)\r
+ z:=y; (* variable z points the same object as variable y *)\r
+ \r
+ If an object of class bill has been created (new bill) and its \r
+address has been assigned to variable x (x:=new bill), then the \r
+attributes of that object are accessible through dot notation (remote\r
+access). The expression x.dollars gives , for instance, the remote\r
+access to attribute dollars of the object referenced by x.\r
+ All attributes of class objects are initialized as usual. For the\r
+above example the object referenced by x, after the execution of the\r
+specified sequence of statements, has the following structure:\r
+ \r
+ ---------------\r
+ | 500.5 | dollars\r
+ ---------------\r
+ | false | not_paid\r
+ ---------------\r
+ | 1982 | year\r
+ ---------------\r
+ | 3 | month\r
+ ---------------\r
+ | 8 | day\r
+ ---------------\r
+ \r
+ The object referenced by y and z has the following structure:\r
+ \r
+ ---------------\r
+ | 0 | dollars\r
+ ---------------\r
+ | true | not_paid\r
+ ---------------\r
+ | 0 | year\r
+ ---------------\r
+ | 0 | month\r
+ ---------------\r
+ | 0 | day\r
+ ---------------\r
+ \r
+ The value none is the default initial value of any reference \r
+variable and denotes no object. A remote access to an attribute of\r
+none raises a run time error. \r
+ Class may have also formal parameters (as procedures and functions).\r
+Kinds and transmission modes of formal parameters are the same as in\r
+the case of procedures.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit node: class (a:integer);\r
+ var left,right:node; \r
+ end node; \r
+ \r
+ Let , for instance, variables z1, z2, z3 be of type node. Then the\r
+sequence of statements:\r
+ \r
+ z1:=new node(5);\r
+ z2:=new node(3); \r
+ z3:=new node(7); \r
+ z1.left:=z2; z1.right:=z3;\r
+ \r
+ creates the structure:\r
+ \r
+ -----------\r
+ z1----> | 5 |\r
+ -----------\r
+ <---- | left |\r
+ | -----------\r
+ | | right | ------->\r
+ | ----------- |\r
+ | |\r
+ ------------ ------------\r
+z2---->| 3 | | 7 | <----z3\r
+ ------------ ------------\r
+ | none | | none | \r
+ ------------ ------------\r
+ | none | | none | \r
+ ------------ ------------\r
+\r
+ \r
+where arrows denote the values of the reference variables.\r
+ \r
+ Class may also have a sequence of statements (as any other unit).\r
+That sequence can initialize the attributes of the class objects.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit complex:class(re,im:real); \r
+ var module:real; \r
+ begin \r
+ module:=sqrt(re*re+im*im)\r
+ end complex; \r
+ \r
+ Attribute module is evaluated for any object generation of class\r
+complex:\r
+ \r
+ z1:=new complex(0,1); (* z1.module equals 1 *) \r
+ z2:=new complex(2,0); (* z2.module equals 2 *) \r
+ \r
+ For the execution of a class generator, first a class object is\r
+created, then the input parameters are transmitted , and finally, the\r
+sequence of statements (if any) is performed. Return is made with the\r
+execution of return statement or the final end of a unit. Upon return\r
+the output parameters are transmitted.\r
+ Procedure object is automatically deallocated when return is made to\r
+the caller. Class object is not deallocated , its address can be\r
+assigned to a reference variable, and its attributes can be thereafter\r
+accessed via this variable.\r
+ \r
+ The classes presented so far had only variable attributes. In\r
+general, class attributes may be also other syntactic entities, such\r
+as constants, procedures, functions, classes etc. Classes with\r
+procedure and function attributes provide a good facility to define\r
+data structures.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ A push_down memory of integers may be implemented in the following\r
+way:\r
+ \r
+ unit push_down :class; \r
+ unit elem:class(value:integer,next:elem);\r
+ (* elem - stack element *)\r
+ end elem; \r
+ var top:elem; \r
+ unit pop: function :integer; \r
+ begin \r
+ if top=/= none \r
+ then \r
+ result:=top.value; top:=top.next\r
+ fi; \r
+ end pop; \r
+ unit push:procedure(x:integer); (* x - pushed integer *) \r
+\r
+ begin \r
+ top:=new elem(x,top);\r
+ end push; \r
+ end push_down;\r
+\r
+ Assume that somewhere in a program reference variables of type\r
+push_down are declared (of course, in place where push_down is\r
+visibile):\r
+ \r
+ var s,t,z:push_down; \r
+ \r
+ Three different push_down memories may be now generated:\r
+ \r
+ s:=new push_down(100); t:=new push_down(911); z:=new push_down(5); \r
+ \r
+ One can use these push_down memories as follows:\r
+ \r
+ call s.push(7); (* push 7 to s *) \r
+ call t.push(1); (* push 1 to t *) \r
+ i:=z.pop; (* pop an element from z *)\r
+ etc.\r
+\r
+5. Adjustable arrays\r
+####################\r
+ \r
+ In LOGLAN-82 arrays are adjustable at run time. They may be treated\r
+as objects of specified standard type with index instead of identifier\r
+selecting an attribute. An adjustable array should be declare\r
+somewhere among the lists of declarations and then may be generated in\r
+the sequence of statements.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ block \r
+ var n,j:integer; \r
+ var A:arrayof integer; (* here is the declaration of A *) \r
+ begin \r
+ read(n);\r
+ new_array A dim (1:n); (* here is the generation of A *) \r
+ for i:=1 to n \r
+ do \r
+ read(A(i));\r
+ od; \r
+ (* etc.*)\r
+ end \r
+ \r
+ A variable A is an array variable. Its value should be the reference\r
+to an integer array, i.e. a composite object consisting of integer\r
+components each one defined by an integer index. Array generation\r
+statement:\r
+ \r
+ new_array A dim (1:n); \r
+ \r
+allocates a one-dimensional integer array with the index bounds 1,n ,\r
+and assigns its address to variable A. The figure below illustrates\r
+this situation:\r
+ \r
+ ---------- -----------\r
+ | | | A(1) |\r
+ | | -----------\r
+ | ... | | A(2) |\r
+ ---------- -----------\r
+ | n | | |\r
+ ---------- ...\r
+ | j | | |\r
+ ---------- -----------\r
+ | A | ---------> | A(n) |\r
+ ---------- -----------\r
+ Block object Array object\r
+ \r
+ A general case of array generation statement has the form:\r
+ \r
+ new_array A dim (lower:upper) \r
+ \r
+where lower and upper are arithmetic expressions which define the\r
+range of the array index.\r
+\r
+ Example:\r
+ --------\r
+ \r
+ Two-dimensional array declaration :\r
+ \r
+ var A: arrayof arrayof integer; \r
+ \r
+and generation:\r
+ \r
+ new_array A dim (1:n) \r
+ for i:=1 to n do new_array A(i) dim (1:m) od; \r
+ \r
+create the structure:\r
+ \r
+ ----------\r
+ | A(1,1) |\r
+ ----------\r
+ | |\r
+ ...\r
+ | |\r
+ ------------ ----------\r
+ | A(1) | ---------> | A(1,m) |\r
+ ------------ ----------\r
+ | |\r
+ ...\r
+ | |\r
+ ------------ ----------\r
+ | A(n) | ---------> | A(n,1) |\r
+ ------------ ----------\r
+ | |\r
+ ...\r
+ | |\r
+ ----------\r
+ | A(n,m) |\r
+ ----------\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ block \r
+ var i,j:integer, A,B: arrayof arrayof real, n:integer; \r
+ begin \r
+ read(n);\r
+ new_array A dim (1:n); \r
+ for i:=1 to n do new_array A(i) dim (1:n) od; \r
+ (* A is square array *)\r
+ new_array B dim (1:n); \r
+ for i:=1 to n do new_array B(i) dim(1:i) od; \r
+ (* B is lower triangular array *)\r
+ A(n,n):=B(n,n);\r
+ B(1):=A(1);\r
+ B(1):=copy(A(1)); \r
+ end \r
+\r
+ Array A is the square array n by n. Each element A(i) , 1<=i<=n\r
+contains the address of row A(i,j), 1<=j<=n. Array B is the\r
+lower-triangular array. Each element B(i), 1<=i<=n, contains the\r
+address of row B(i,j), 1<=j<=i. Thus an assignment statement\r
+A(n,n):=B(n,n) transmits real value B(n,n) to real variable A(n,n).\r
+Assignment B(1):=A(1) transmits the address of the first row of A to\r
+variable B(1). Finally assignment B(1):=copy (A(1)) creates a copy of \r
+the first row of A and assigns its address to B(1).\r
+ \r
+ Upper and lower bounds of an adjustable array A are determined by\r
+standard operators lower(A) and upper(A).\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit sort: procedure(A:arrayof integer); (* insertion sort *) \r
+ var n,i,j:integer; var x:integer; \r
+ begin \r
+ n:=upper(A); (* assume lower bound is 1 *)\r
+ for i:=2 to n \r
+ do \r
+ x:=A(i); j:=i-1;\r
+ do \r
+ if x >= A(j) then exit fi; \r
+ A(j+1):=A(j); j:=j-1;\r
+ if j=0 then exit fi;\r
+ od; \r
+ A(j+1):=x\r
+ od; \r
+ end sort; \r
+ \r
+ If an array variable A refers to no array its value is equal none \r
+(the standard default value of any array variable). An attempt to\r
+access an array element (e.g. A(i)) or a bound (e.g. lower(A)), where\r
+A is none, raises a run time error. - 24 - \r
+\r
+\r
+6. Coroutines and semicoroutines\r
+################################\r
+ \r
+ Coroutine is a generalization of class. A coroutine object is an\r
+object such that the execution of its sequence of statements can be\r
+suspended and reactivated in a programmed manner. Consider first a\r
+simple class with a sequence of statements such that after return some \r
+non-executed statements remain. The generation of its object\r
+terminates with the execution of return statement, although the object\r
+can be later reactivated. If such a class is declared as a coroutine,\r
+then its objects may be reactivated. This can be realized by attach \r
+statement:\r
+ \r
+ attach(X) \r
+ \r
+where X is a reference variable designating the activating coroutine\r
+object.\r
+ In general, since the moment of generation a coroutine object is\r
+either active or suspended. Any reactivation of a suspended coroutine\r
+object X (by attach(X)) causes the active coroutine object to be \r
+suspended and continues the execution of X from the statement\r
+following the last executed one.\r
+ Main program is also a coroutine. It is accessed through the\r
+standard variable main and may be reactivated (if suspended) by the \r
+statement attach(main). \r
+ \r
+ Example:\r
+ --------\r
+ \r
+ In the example below the cooperation of two coroutines is presented.\r
+One reads the real values from an input device, another prints these\r
+values in columns on a line-printer, n numbers in a line. The input\r
+stream ends with 0.\r
+ \r
+program prodcons;\r
+ var prod:producer,cons:consumer,n:integer,mag:real,last:bool; \r
+ unit producer: coroutine; \r
+ begin \r
+ return; \r
+ do \r
+ read(mag); (* mag- nonlocal variable, common store *)\r
+ if mag=0 \r
+ then (* end of data *) \r
+ last:=true;\r
+ exit \r
+ fi; \r
+ attach(cons); \r
+ od; \r
+ attach(cons) \r
+ end producer; \r
+\r
+ unit consumer: coroutine(n:integer); \r
+ var Buf:arrayof real; \r
+ var i,j:integer; \r
+ begin \r
+ new_array Buf dim(1:n); \r
+ return; \r
+ do \r
+ for i:=1 to n \r
+ do \r
+ Buf(i):=mag;\r
+ attach(prod); \r
+ if last then exit exit fi; \r
+ od; \r
+ for i:=1 to n \r
+ do (* print Buf *) \r
+ write(' ',Buf(i):10:2)\r
+ od; \r
+ writeln;\r
+ od; \r
+ (* print the rest of Buf *)\r
+ for j:=1 to i do write(' ',Buf(j):10:2) od; \r
+ writeln;\r
+ attach(main); \r
+ end consumer; \r
+ \r
+ begin \r
+ prod:=new producer; \r
+ read(n);\r
+ cons:=new consumer(n); \r
+ attach(prod); \r
+ writeln;\r
+ end prodcons; \r
+ \r
+ The above task could be programmed without coroutines at all. The\r
+presented solution is, however, strictly modular, i.e. one unit\r
+realizes the input process, another realizes the output process, and\r
+both are ready to cooperate with each other.\r
+ \r
+ LOGLAN-82 provides also a facility for the semi-coroutine\r
+operations. This is gained by the simple statement detach. If X is the \r
+active coroutine object, then detach reactivates that coroutine object \r
+at where the last attach(X) was executed. This statement meets the \r
+need for the asymetric coroutine cooperations. (by so it is called\r
+semi-coroutine operation). Operation attach requires a reactivated \r
+coroutine to be defined explicitly by the user as an actual parameter.\r
+Operation detach corresponds in some manner to return in procedures.\r
+It gives the control back to a coroutine object where the last\r
+attach(X) was executed, and that coroutine object need not be known\r
+explicitly in X. This mechanism is, however, not so secure as the\r
+normal control transfers during procedure calls and returns.\r
+ \r
+ In fact, the user is able to loop two coroutines traces by :\r
+ \r
+ attach(Y) in X \r
+ attach(X) in Y \r
+\r
+\r
+Then detach in X reactivates Y, detach in Y reactivates X. \r
+ \r
+ In the example below the application of detach statement is\r
+illustrated.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ program reader_writers; \r
+ (* In this example a single input stream consisting of blocks of\r
+ numbers, each ending with 0, is printed on two printers of\r
+ different width. The choice of the printer is determined by the\r
+ block header which indicates the desired number of print\r
+ columns. The input stream ends with a double 0. m1 - the width\r
+ of printer_1, m2 - the width of printer_2 *)\r
+ const m1=10,m2=20; \r
+ var reader:reading,printer_1,printer_2:writing; \r
+ var n:integer,new_sequence:boolean,mag:real; \r
+ \r
+ unit writing:coroutine(n:integer); \r
+ var Buf: arrayof real, i,j:integer; \r
+ begin \r
+ new_array Buf dim (1:n); (* array generation *) \r
+ return; (* return terminates coroutine initialization *) \r
+ do \r
+ attach(reader); (* reactivates coroutine reader *) \r
+ if new_sequence \r
+ then (* a new sequence causes buffer Buf to be cleared up *) \r
+ for j:=1 to i do write(' ',Buf(j):10:2) od; writeln; \r
+ i:=0; new_sequence:=false; attach(main) \r
+ else \r
+ i:=i+1; Buf(i):=mag;\r
+ if i=n \r
+ then \r
+ for j:=1 to n do write(' ',Buf(j):10:2) od; writeln;\r
+ i:=0;\r
+ fi \r
+ fi \r
+ od \r
+ end writing; \r
+ \r
+ unit reading: coroutine; \r
+ begin \r
+ return; \r
+ do \r
+ read(mag);\r
+ if mag=0 then new_sequence:=true; fi; \r
+ detach; (* detach returns control to printer_1 or \r
+ od \r
+ end reading; \r
+ \r
+\r
+ begin \r
+ reader:=new reading; \r
+ printer_1:=new writing(m1); printer_2:=new writing(m2);\r
+ do \r
+ read(n);\r
+ case n \r
+ when 0: exit \r
+ when m1: attach(printer_1) \r
+ when m2: attach(printer_2) \r
+ otherwise write(" wrong data"); exit \r
+ esac \r
+ od \r
+ end; \r
+ \r
+ Coroutines play the substantial role in process simulation. Class\r
+Simulation provided in Simula-67 makes use of coroutines at most\r
+degree. LOGLAN-82 provides for easy simulation as well. The LOGLAN-82\r
+class Simulation is implemented on a heap what gives lg(n) time cost\r
+(in contrast with O(n) cost of the original implementation). It covers\r
+also various simulation problems of large size and degree of\r
+complexity.\r
+\r
+\r
+7. Prefixing\r
+############\r
+ \r
+ Classes and prefixing are ingenius inventions of Simula-67 (cf [1]).\r
+Unfortunately they are hardly ever known and, perhaps, by this have\r
+not been introduced into any other programming language. Moreover,\r
+implementation constraints of Simula-67 bind prefixing and classes\r
+workableness to such a degree that both facilities cannot be used in\r
+all respects. We hope that LOGLAN-82, adopting merits and rooting up\r
+deficiencies of these constructs, will smooth their variations and\r
+vivify theirs usefulness.\r
+ What is prefixing ? First of all it is a method for unit extending.\r
+Consider the simplest example:\r
+ \r
+ unit bill: class; \r
+ var dollars :real,\r
+ not_paid :boolean,\r
+ year,month,day :integer;\r
+ end bill; \r
+ \r
+Assume the user desires to extend this class with new attributes.\r
+Instead of writing a completely new class, he may enlarge the existing\r
+one:\r
+ \r
+ unit gas_bill:bill class; \r
+ var cube_meters: real; \r
+ end gas_bill; \r
+ \r
+ Class gas_bill is prefixed by class bill. This new declaration may\r
+appear anywhere within the scope of declaration of class bill. (In\r
+Simula-67 such a prefixing is forbidden in nested units.) Class\r
+gas_bill has all the attributes of class bill and additionally its own\r
+attributes (in this case the only one: cube_meters). The generation\r
+statement of this class has the form:\r
+ \r
+ z:=new gas_bill; \r
+where z is a reference variable of type gas_bill. Remote access to the\r
+attributes of prefixed class is standard:\r
+ \r
+ z.dollars:=500.5; z.year:=1982; z.month:=3; z.day:=8;\r
+ z.cube_meters:=100000;\r
+ \r
+ Consider now the example of a class with parameters.\r
+ \r
+ Assume that in a program a class:\r
+ \r
+ unit id_card: class(name:string,age:integer); \r
+ end id_card; \r
+ \r
+and its extension:\r
+ \r
+ unit idf_card:id card class(first name:string); \r
+ end idf_card; \r
+ \r
+\r
+\r
+are declared.\r
+\r
+\r
+ Then for variable z of type id_card and variable t of type idf_card\r
+the corresponding generation statement may be the following:\r
+ \r
+ z:=new id_card("kreczmar",37); \r
+ t:=new idf_card("Kreczmar",37,"Qntoni"); \r
+ \r
+Thus the formal parameters of a class are concatenated with the formal\r
+parameters of its prefix.\r
+ One can still extend class idf_card. For instance:\r
+ \r
+ unit idr_card:idf_card class; \r
+ var children_number:integer; \r
+ var birth_place:string; \r
+ end idr_card; \r
+ \r
+ Prefixing allows to build up hierarchies of classes. Each one\r
+hierarchy has a tree structure. A root of such a tree is a class\r
+without prefix. One class is a successor of another class iff the\r
+first is prefixed by the latter one.\r
+ \r
+ Consider the prefix structure:\r
+ \r
+ A\r
+ . . .\r
+ . . .\r
+ . . .\r
+ B. .C .D\r
+ .\r
+ .\r
+ .E\r
+ .\r
+ .\r
+ .F\r
+ . .\r
+ . .\r
+ G. .H\r
+ \r
+ Class H has a prefix sequence A, B, E, F, H. Let a, b, ... , h\r
+denote the corresponding unique attributes of classes A, B, ... , H,\r
+respectively. The objects of these classes have the following forms:\r
+ \r
+ ------------ ------------ ------------ ------------\r
+ | a | | a | | a | | a |\r
+ ------------ ------------ ------------ ------------\r
+ object A | b | | c | | d |\r
+ ------------ ------------ ------------\r
+ object B object C object D\r
+\r
+\r
+\r
+ ------------ ------------ ------------ ------------\r
+ | a | | a | | a | | a |\r
+ ------------ ------------ ------------ ------------\r
+ | b | | b | | b | | b |\r
+ ------------ ------------ ------------ ------------\r
+ | e | | e | | e | | e |\r
+ ------------ ------------ ------------ ------------\r
+ object E | f | | f | | f |\r
+ ------------ ------------ ------------\r
+ object F | g | | h |\r
+ ------------ ------------\r
+ object G object H\r
+ \r
+ Let Ra, Rb,..., Rh denote reference variables of types A, B,..., H,\r
+respectively. Then the following expressions are correct:\r
+ \r
+ Ra.a, Rb.b, Rb.a, Rg.g, Rg.f, Rh.h, Rh.f, Rh.e, Rh.b, Rh.a etc.\r
+ \r
+ Variable Ra may designate the object of class B (or C,..., H), i.e.\r
+the statement:\r
+ \r
+ Ra:=new B \r
+ \r
+is legal. But then attribute b is not accessible through dot via Ra,\r
+i.e. Ra.b is incorrect. This follows from insecurity of such a remote\r
+access. In fact, variable Ra may point any object of a class prefixed\r
+by A, in particular, Ra may point the object of A itself, which has no\r
+attribute b. If Ra.b had been correct, a compiler should have\r
+distiguish the cases Ra points to the object of A or not. But this, of\r
+course, is undistinguishable at compilation time.\r
+ To allow, however, the user's access to attribute b (after instruc tion Ra:= n\r
+ \r
+ Ra qua B \r
+\r
+ The correctness of this expression is checked at run time. If Ra\r
+designates an object of B or prefixed ba B, the type of the expression\r
+is B. Otherwise the expression is erroneous. Thus, for instance, the\r
+expressions:\r
+ \r
+ Ra qua G.b, Ra qua G.e etc. \r
+enable remote access to the attributes b, c, ... via Ra.\r
+ \r
+ So far the question of attribute concatenation was merely discussed.\r
+However the sequences of statements can be also concatenated.\r
+ Consider class B prefixed with class A. In the sequence of\r
+statements of class A the keyword inner may occur anywhere, but only\r
+once. The sequence of statements of class B consists of the sequence\r
+of statements of class A with inner replaced by the sequence of \r
+statements of class B.\r
+ \r
+ unit A :class unit B:A class \r
+ ... ...\r
+ begin begin \r
+ ... |---...\r
+ | \r
+ |\r
+ ... |---...\r
+ end A; end B; \r
+\r
+\r
+ In this case inner in class B is equivalent to the empty statement. \r
+If class B prefixes another class, say C, then inner in B is replaced \r
+by the sequence of statements of class C, and so on.\r
+ If inner does not occur explicitly, an implicit occurrence of inner \r
+before the final end of a class is assumed. \r
+ \r
+ Example\r
+ -------\r
+ \r
+ Let class complex be declared as usual:\r
+ \r
+ unit complex: class(re,im:real); \r
+ end complex; \r
+ \r
+and assume one desires to declare a class mcomplex with the additional\r
+attribute module. In order the generation of class mcomplex define the\r
+value of attribute module, one can declare a class:\r
+ \r
+ unit mcomplex:complex class; \r
+ var module:real; \r
+ begin \r
+ module:=sqrt(re*re+im*im)\r
+ end mcomplex; \r
+ \r
+ Class mcomplex may be still extended:\r
+ \r
+ unit pcomplex:mcomplex class; \r
+ var alfa:real; \r
+ begin \r
+ alfa:=arccos(re/module)\r
+ end pcomplex; \r
+ \r
+ For these declarations each generation of class mcomplex defines the\r
+value of attribute module, each generation of class pcomplex defines\r
+the values of attributes module and alfa.\r
+ For reference variables z1, z2 z3 of type complex, the following\r
+sequence of statements illustrates the presented constructs:\r
+ \r
+ z1:=new complex(0,1); \r
+ z2:=new mcomplex(4,7); \r
+ z3:=new pcomplex(-10,12); \r
+ if z2 qua mcomplex.module > 1 \r
+ then \r
+ z1:=z2;\r
+ fi; \r
+ if z3 qua pcomplex.alfa < 3.14 \r
+ then \r
+ z3.re:=-z3.re; z3.alfa:=z3.alfa+3.14;\r
+ fi; \r
+ z1 qua mcomplex.module:= 0; \r
+ z1.re,z1.im:=0; \r
+\r
+\r
+ Example:\r
+ --------\r
+ Binary search tree (Bst) is a binary tree where for each node x the\r
+nodes in the left subtree are less than x, the nodes in the right\r
+subtree are greater than x. It is the well-known exercise to program\r
+the algorithms for the following operations on Bst:\r
+ member(x) = true iff x belongs to Bst\r
+ insert(x), enlarge Bst with x, if x does not yet belong to Bst\r
+ \r
+ We define both these operations in a class:\r
+ \r
+ unit Bst: class; \r
+ unit node: class(value:integer); (* tree node *) \r
+ var left,right:node; \r
+ end node; \r
+ var root:node; \r
+ unit help: class(x:integer); (* auxiliary class *) \r
+ var p,q:node; \r
+ begin \r
+ q:=root;\r
+ while q=/= none \r
+ do \r
+ if x < q.value \r
+ then \r
+ p:=q; q:=q.left;\r
+ repeat (* jump to the beginning of a loop *) \r
+ fi; \r
+ if q.value < x \r
+ then \r
+ p:=q; q:=q.right; repeat \r
+ fi; \r
+ exit \r
+ od; \r
+ inner (* virtual instruction to be \r
+ end help; \r
+ unit member:help function:boolean; \r
+ (* x is a formal parameter derived from the prefix help *)\r
+ begin \r
+ result:=q=/=none \r
+ end member; \r
+ unit insert:help procedure; \r
+ (* x is a formal parameter derived from the prefix help *)\r
+ begin \r
+ if q=/=none then return fi; \r
+ q:=new node(x); \r
+ if p=none then root:=q; return fi; \r
+ if p.value < x then p.right:=q else p.left:=q fi; \r
+ end insert; \r
+ begin \r
+ inner; \r
+ end Bst; \r
+ \r
+ In the example the common actions of member and insert are\r
+programmed in class help. Then it suffices to use class help as a\r
+prefix of function member and procedure insert, instead of redundant\r
+occurrences of the corresponding sequence of statements in both units. \r
+\r
+\r
+ Class Bst may be applied as follows:\r
+ \r
+ var X,Y:Bst; \r
+ begin \r
+ X:=new Bst; Y:=new Bst; \r
+ call X.insert(5); \r
+ if Y.member(-17) then .... \r
+ end \r
+ \r
+ As shown in the declaration of Bst, class may prefix not only other\r
+classes but also procedures and functions. Class may prefix blocks as\r
+well.\r
+ \r
+ Example:\r
+ --------\r
+ Let class push_down (p. 5) prefix a block:\r
+ \r
+ pref push_down(1000) block \r
+ var ... \r
+ begin \r
+ ...\r
+ call push(50); ... \r
+ i:=pop;\r
+ ...\r
+ end \r
+ \r
+ In the above block prefixed with class push_down one can use pop and\r
+push as local attributes. (They are local since the block is embedded\r
+in the prefix push down.)\r
+ \r
+ Example:\r
+ --------\r
+ pref push down(1000) block \r
+ begin \r
+ ...\r
+ pref Bst block \r
+ begin \r
+ (* in this block both structures push down and Bst are visible *)\r
+ call push(50); \r
+ call insert(13); \r
+ if member(10) then ... \r
+ i:=pop;\r
+ ...\r
+ end \r
+ end \r
+ \r
+ In place where classes push_down and Bst are visible together a\r
+block prefixed with Bst may be nested in a block prefixed with\r
+push_down (or vice versa). In the inner block both data structures are\r
+directly accessible. Note that this construct is illegal in Simula 67. \r
+\r
+\r
+8. Formal types\r
+###############\r
+ \r
+ Formal types serve for unit parametrization with respect to any\r
+non-primitive type.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit Gsort:procedure(type T; A:arrayof T; function less(x,y:T):boolean); \r
+ var n,i,j:integer; var x:T; \r
+ begin \r
+ n:=upper(A);\r
+ for i:=2 to n \r
+ do \r
+ x:=A(i); j:=i-1;\r
+ do \r
+ if less(A(j),x) then exit fi; exit fi \r
+ A(j+1):=A(j); j:=j-1;\r
+ if j=0 then exit fi;\r
+ od; \r
+ A(j+1):=x;\r
+ od \r
+ end Gsort; \r
+ \r
+ Procedure Gsort (the generalization of procedure sort from p.4) has\r
+type parameter T. A corresponding actual parameter may be an arbitrary\r
+non-primitive type. An actual parameter corresponding to A should be\r
+an array of elements of the actual type T. Function less should define\r
+the linear ordering on the domain T.\r
+ For instance, the array A of type bill (cf p.7) may be sorted with\r
+respect to attribute dollars , if the function:\r
+ \r
+ unit less: function(t,u:bill):boolean; \r
+ begin \r
+ result:=t.dollars <= u.dollars\r
+ end less; \r
+ \r
+is used as an actual parameter:\r
+ \r
+ call Gsort(bill,A,less); \r
+ \r
+ If the user desires to sort A with respect to date, it is sufficient\r
+to declare :\r
+ \r
+ unit earlier:function(t,u:bill):boolean; \r
+ begin \r
+ if t.year < u.year then result:= true; return fi; \r
+ if t.year=u.year \r
+ then \r
+ if t.month < u.month then result:=true; return fi; \r
+ if t.month=u.month then result:=t.day<=u.day fi \r
+ fi; \r
+ end earlier; \r
+ \r
+and to call: call Gsort(bill,A,earlier); \r
+\r
+\r
+9. Protection techniques\r
+########################\r
+ \r
+ Protection techniques ease secure programming. If a program is\r
+large, uses some system classes, is designed by a team etc., this is\r
+important (and non-trivial) to impose some restrictions on access to\r
+non-local attributes.\r
+ Let us consider a data structure declared as a class. Some of its\r
+attributes should be accessible for the class users , the others\r
+should not. For instance, in class Bst (p.7) the attributes member and\r
+insert are to be accessible. On the other hand the attributes root,\r
+node and help should not be accessible, even for a meddlesome user. An\r
+improper use of them may jeopardize the data structure invariants.\r
+ To forbid the access to some class attributes the three following\r
+protection mechanisms are provided:\r
+ \r
+ close, hidden, and taken. \r
+ \r
+ The protection close defined in a class forbids remote access to the \r
+specified attributes. For example, consider the class declaration:\r
+ \r
+ unit A: class; \r
+ close x,y,z; \r
+ var x: integer, y,z:real; \r
+ ....\r
+ end \r
+ \r
+ Remote access to the attributes x,y,z from outside of A is\r
+forbidden.\r
+ \r
+ The protection hidden (with akin syntax) does not allow to use the \r
+specified attributes form outside of A neither by the remote access\r
+nor in the units prefixed by A. The only way to use a hidden attribute\r
+is to use it within the body of class A.\r
+ Protection taken defines these attributes derived from prefix, which \r
+the user wishes to use in the prefixed unit. Consider a unit B\r
+prefixed by a class A. In unit B one may specify the attributes of A\r
+which are used in B. This protects the user against an unconscious use\r
+of an attribute of class A in unit B (because of identifier conflict).\r
+When taken list does not occur , then by default, all non-hidden\r
+attributes of class A are accessible in unit B. \r
+\r
+\r
+10. Programmed deallocation\r
+###########################\r
+ \r
+ The classical methods implemented to deallocate class objects are\r
+based on reference counters or garbage collection. Sometimes the both\r
+methods may be combined. A reference counter is a system attribute\r
+holding the number of references pointing to the given object. Hence\r
+any change of the value of a reference variable X is followed by a\r
+corresponding increase or decrease of the value of its reference\r
+counter. When the reference counter becomes equals 0, the object can\r
+be deallocated.\r
+ The deallocation of class objects may also occur during the process\r
+of garbage collection. During this process all unreferenced objects\r
+are found and removed (while memory may be compactified). In order to\r
+keep the garbage collector able to collect all the garbage, the user\r
+should clear all reference variables , i.e. set to None, whenever\r
+possible. This system has many disadvantages. First of all, the\r
+programmer is forced to clear all reference variables, even those\r
+which are of auxiliary character. Moreover, garbage collector is a\r
+very expensive mechanism and thus it can be used only in emergency\r
+cases.\r
+ In LOGLAN a dual operation to the object generator, the so-called\r
+object deallocator is provided. Its syntactic form is as follows:\r
+ \r
+ kill(X) \r
+ \r
+where X is a reference expression. If the value of X points to no\r
+object (none) then kill(X) is equivalent to an empty statement. If the \r
+value of X points to an object O, then after the execution of kill(X), \r
+the object O is deallocated. Moreover all reference variables which\r
+pointed to O are set to none. This deallocator provides full security, \r
+i.e. the attempt to access the deallocated object O is checked and\r
+results in a run-time error.\r
+ For example:\r
+ \r
+ Y:=X; kill(X); Y.W:=Z; \r
+ \r
+causes the same run-time error as:\r
+ \r
+ X:=none; X.W:=Z; \r
+ \r
+ The system of storage management is arranged in such a way that the\r
+frames of killed objects may be immediately reused without the\r
+necessity of calling the garbage collector, i.e. the relocation is\r
+performed automatically. There is nothing for it but to remember not\r
+to use remote access to a killed object. (Note that the same problem\r
+appears when remote access X.W is used and X=none). \r
+\r
+ Example:\r
+ --------\r
+ \r
+ Below a practical example of the programmed deallocation is\r
+presented. Consider class Bst (p.7). Let us define a procedure that\r
+deallocates the whole tree and is called with the termination of the\r
+class Bst.\r
+ \r
+ unit Bst:class; \r
+ (* standard declarations list of Bst *)\r
+ unit kill_all:procedure(p:node); \r
+ (* procedure kill_all deallocates a tree with root p *)\r
+ begin \r
+ if p= none then return fi; \r
+ call kill_all(p.left); \r
+ call kill_all(p.right); \r
+ kill(p) \r
+ end kill_all; \r
+ begin \r
+ inner; \r
+ call kill_all(root) \r
+ end Bst; \r
+ \r
+ Bst may be applied as a prefix:\r
+ \r
+ pref Bst block \r
+ ...\r
+ end \r
+ \r
+and automatically will cause the deallocation of the whole tree after\r
+return to call kill_all(root) from the prefixed block. \r
+ \r
+ To use properly this structure by remote accessing one must call\r
+kill_all by himself:\r
+ \r
+ unit var X,Y:Bst; \r
+ ...\r
+ begin \r
+ X:=new Bst; Y:=new Bst; \r
+ ...\r
+ (* after the structures' application *)\r
+ call X.kill_all(X.root); \r
+ kill(X); \r
+ call Y.kill_all(Y.root); \r
+ kill(Y); \r
+ ...\r
+ end \r
+ \r
+ Finally note that deallocator kill enables deallocation of array \r
+objects, and suspended coroutines and processes as well (cf p.13). \r
+\r
+\r
+11. Exception handling\r
+#######################\r
+ \r
+ Exceptions are events that cause interruption of normal program\r
+execution. One kind of exceptions are those which are raised as a\r
+result of some run time errors. For instance, when an attempt is made\r
+to access a killed object, when the result of numeric operation does\r
+not lie within the range, when the dynamic storage allocated to a\r
+program is exceeded etc.\r
+ Another kind of exceptions are those which are raised explicitly by\r
+a user (with the execution of the raise statement).\r
+ The response to exceptions (one or more) is defined by an exception\r
+handler. A handler may appear at the end of declarations of any unit.\r
+The corresponding actions are defined as sequences of statements\r
+preceded by keyword when and an exception identifier. \r
+ \r
+ Example:\r
+ --------\r
+ \r
+ In procedure squareeq (p.3) we wish to include the case when a=0. It\r
+may be treated as an exception (division by zero).\r
+ \r
+ unit squareeq(a,b,c:real;output xr,xi,yr,yi:real); \r
+ var delta:real; \r
+ handlers \r
+ when division_by_zero: \r
+ if b =/= 0 \r
+ then \r
+ xi,yr,yi:=0; xr:=-c/b; terminate \r
+ else \r
+ raise Wrong_data(" no roots") \r
+ fi; \r
+ end \r
+ begin \r
+ ...\r
+ end squareeq; \r
+ \r
+ The handler declared in that procedure handles the only one\r
+exception (division_by_zero).\r
+ When an exception is raised, the corresponding handler is searched\r
+for, starting from the active object and going through return traces.\r
+If there is no object containing the declaration of the handler, then\r
+the program (or the corresponding process) is terminated. Otherwise\r
+the control is transferred to the first found handler. \r
+\r
+\r
+\r
+ In our example the handler is declared within the unit itself, so\r
+control is passed to a sequence:\r
+ \r
+ if b=/=0 \r
+ ...\r
+ \r
+ Therefore, when b=/=0, the unique root of square equation will be\r
+determined and the procedure will be normally terminated (terminate). \r
+ In general, terminate causes that all the objects are terminated, \r
+starting from that one where the exception was raised and ending on\r
+that one where the handler was found. Then the computation is\r
+continued in a normal way.\r
+ In our example, when b=0, a new exception is raised by the user. For\r
+this kind of exceptions , the exception itself should be declared\r
+(because it is not predefined as a run time error). Its declaration\r
+may have parameters which are transmitted to a handler. The exception\r
+declaration need not be visible by the exception handler. However the\r
+way the handler is searched for does not differ from the standard one.\r
+ Consider an example:\r
+ \r
+ block\r
+ signal Wrong_data(t:string); \r
+ unit squareeq: \r
+ ...\r
+ end squareeq;\r
+ ...\r
+ begin \r
+ ...\r
+ end \r
+ \r
+ Exception Wrong_data may be raised wherever its declaration (signal \r
+Wrong_data) is visible. When its handler is found the specified\r
+sequence of actions is performed. In the example above different\r
+handlers may be defined in inner units to the main block where\r
+squereeq is called.\r
+ The case a=0 could be included , of course, in a normal way, i.e. by\r
+a corresponding conditional statement occurring in the procedure body.\r
+But the case a=0 was assumed to be exceptional (happens scarcely).\r
+Thus the evaluation of condition a=0 would be mostly unnecessary. As\r
+can be noticed thanks to exceptions the above problem can be solved\r
+with the minimal waste of run time. \r
+ \r
+\r
+\r
+12. Separate compilation (this section does not apply to PC version)\r
+########################\r
+ \r
+\r
+\r
+13. Processes\r
+#############\r
+ \r
+ The implementation of processes is different (May 1988) c.f. user's manual. \r
+\r
+ Process in LOGLAN-82 is a natural generalization of coroutine (cf\r
+p.6). Coroutines are units which once generated may operate\r
+independently, each one treated as a separate process. For coroutines,\r
+however, an essential assumption is established; namely, when one\r
+coroutine object is reactivated, the active one must be suspended\r
+(i.e. there which is onle one control is switched between coroutine\r
+objects). When processes are used, the activation of a new process\r
+does not require the active one to be suspended. So many objects may\r
+be simultaneously active.\r
+ The statement that reactivates a suspended process X (without\r
+suspention of the active one) has the form:\r
+ \r
+ resume(X) \r
+ \r
+ The main problem of parallel programming is, of course,\r
+synchronization. Elementary synchronization in LOGLAN-82 is achieved\r
+by two-valued semaphores and some number of simple statements\r
+operating on them.\r
+ A semaphore variable controls the entry to a critical region, i.e. a\r
+sequence of statements that may be executed by the one process only.\r
+When a semaphore is open, the corresponding critical region is free.\r
+When a semaphore is closed, it means the corresponding critical region\r
+is just executed by a certain process.\r
+ \r
+ These are the simple indivisible statements that operate on\r
+semaphores:\r
+ \r
+ lock(S) - If semaphore S is open, the given process enters \r
+ the critical region guarded by S , and\r
+ simultaneously, semaphore S becomes closed. If\r
+ semaphore S is already closed, the given process\r
+ waits until the critical region is open (by another\r
+ process).\r
+ unlock(S)- If semaphore S is closed, then it becomes open. \r
+ Otherwise the statement is empty.\r
+ stop(S) - The statement causes semaphore S to be open, and \r
+ simultaneously, it stops the given process\r
+ execution. The statement may be used without a\r
+ parameter, and then, it stops the given process\r
+ execution.\r
+ Moreover, only those three above statements may change the values of\r
+semaphore variables.\r
+ In general, several processes may wait for an entry to the same\r
+critical region. When the process executing this critical region opens\r
+the semaphore (by unlock or stop), one of the waiting processes is \r
+reactivated and enters the region. The way such a process is selected\r
+is not defined by the language. The user must assume that this\r
+selection is performed arbitrarily. \r
+\r
+\r
+\r
+ Example:\r
+ --------\r
+ \r
+ In the example an input stream of real numbers is copied. The\r
+copying process is parallelized in such a way that when process get\r
+reads the next number, the process put writes simultaneously the\r
+number read in the preceding step. The input stream ends with 0.\r
+ \r
+ block \r
+ var in_buf,out_buf:real, completed:boolean, sem:semaphore; \r
+ var counter:integer,get:get_type,put:put_type; \r
+ unit cobegin:procedure; (* called by the main program *) \r
+ begin \r
+ lock(sem); (* critical region *) \r
+ resume(get); (* activate reading *) \r
+ resume(put); (* activate writing *) \r
+ stop(sem); (* exit from critical region *) \r
+ end cobegin; \r
+ unit coend: procedure; \r
+ begin (* called by get and put *) \r
+ lock(sem); (* entry to critical region *) \r
+ if counter=0 \r
+ then (* one process entered *) \r
+ counter:=1\r
+ else (* two processes entered *) \r
+ counter:=0;\r
+ resume(main) (* reactivate main program *) \r
+ fi;\r
+ stop(sem) (* exit from critical region *) \r
+ end coend;\r
+ \r
+ unit get_type:process; \r
+ begin \r
+ return;\r
+ do \r
+ read(in_buf);\r
+ if in_buf=0 \r
+ then (* end of data *) \r
+ completed:=true\r
+ fi; \r
+ call coend \r
+ od \r
+ end get_type;\r
+ \r
+ unit put_type:process; \r
+ begin\r
+ return; \r
+ do \r
+ write(out_buf);\r
+ call coend; \r
+ od \r
+ end put_type; \r
+\r
+ begin (* main process *) \r
+ read(in_buf);\r
+ get:=new get_type; \r
+ put:=new put_type; \r
+ do \r
+ out_buf:=in_buf;\r
+ call cobegin; \r
+ if completed then exit fi; \r
+ od; \r
+ kill(get); \r
+ kill(put); \r
+ end; \r
+ \r
+ Two procedures cobegin and coend synchronize the execution of the\r
+main loop. Procedure cobegin implements fork operator, procedure coend\r
+called from processes put and get implements the end of fork operator.\r
+Variable count defines the number of processes that called procedure\r
+coend. By an easy modification one can generalize these procedures in\r
+order to implement the general k-fork and end of k-fork operators (if\r
+count can assume the values 0,1,...,k-1).\r
+ \r
+ Finally, let us present an example of a class that realizes Hoare's\r
+monitors (cf. [2]). Monitor is a structure that synchronizes the\r
+access to a common pool of data. The number and kinds of these data\r
+are defined by the user. Monitor task is only to give non-conflict\r
+access to it. The access to a monitor is realized by the so-called\r
+entry procedures. Entry procedure has a prefix entry which guarantees\r
+that only one such a procedure may enter the monitor.\r
+ In order to allow scheduling of processes that entered the monitor,\r
+two specialized procedures operating on the inner monitor queues are\r
+provided.\r
+ \r
+ delay(Q) - stops the execution of the process and puts it\r
+ into a queue Q, the entry to the monitor is free,\r
+ continue(Q) - resumes the execution of the first process from a\r
+ queue Q (if Q is non-empty, otherwise the entry to\r
+ the monitor is free).\r
+ \r
+ As can be easily seen, the correct use of these constructs is\r
+achieved when continue is called as the last statement of an entry\r
+procedure.\r
+ \r
+ The declaration of the class Monitor is as follows: \r
+\r
+\r
+unit Monitor : queue class; \r
+ hidden sem,queue; (* hidden protects attributes sem and queue *) \r
+ var sem:semaphore; (* sem is the semaphore guarding the monitor entry *) \r
+ \r
+ unit entry: class; (* all entry procedures must have prefix entry \r
+ which realized non-conflict access to Monitor *)\r
+ var busy:boolean; (* busy is true iff continue(Q) was executed \r
+ hidden busy; \r
+ unit delay: procedure(Q:queue); \r
+ begin \r
+ call Q.into(this process);\r
+ (* put the active process into queue Q *) \r
+ stop(sem) \r
+ (* free the monitor access, halt the active process *) \r
+ end delay; \r
+ unit continue:procedure(Q:queue); \r
+ (* continue can be called as the last statement of an entry procedure *)\r
+ begin \r
+ if not Q.empty \r
+ then \r
+ busy:=true\r
+ resume(Q.out); (* resume the next process from queue Q *) \r
+ fi; \r
+ end continue;\r
+ begin (* beginning of the prefix entry *) \r
+ lock(sem); (* entry to the critical region *) \r
+ inner; (* the virtual body of an entry procedure *) \r
+ if not busy \r
+ then \r
+ unlock(sem) (* free the monitor access, unless continue \r
+ fi; \r
+ end entry; \r
+end Monitor; \r
+\r
+\r
+ The mail-box structure which receives and sends the items of type T\r
+may be implemented as the following class prefixed by Monitor:\r
+ \r
+ unit Buffering:Monitor class(type T;size:integer); \r
+ var Pool:arrayof T,count,in_index,out_index:integer; \r
+ var readers_queue,writers_queue:queue; \r
+ unit writer:entry procedure(r:T); \r
+ begin\r
+ if count=size then call delay(writers_queue) fi; in_index\r
+ Pool(in_index):=r; call continue(readers_queue); \r
+ end writer; \r
+ unit reader:entry procedure(output r:T); \r
+ begin\r
+ if count=0 then call delay(readers_queue) fi; \r
+ out_index:=out_index mod size +1; count:=count-1; \r
+ r:=Pool(out_index); call continue(writers_queue); \r
+ end reader; \r
+ begin\r
+ new_array Pool dim (1:size); \r
+ readers_queue:=new queue; writers_queue:=new queue; \r
+ end Buffering; \r
+\r
+\r
+References.\r
+###########\r
+ \r
+ [1] Dahl O-J.,Myhrhaug B,Nygaard K.: Common Base Language . NCC\r
+S-22, October 1970\r
+ [2] Hoare C.A.R.: Monitors, an operating system structuring concept.\r
+CACM,vol.17,N.10,October 1974,pp.549-57\r
+ [3] LOGLAN-82 Report , Warsaw, 1982\r
+\1a
\ No newline at end of file
--- /dev/null
+{\rtf1\ansi \deff0\deflang1024{\fonttbl{\f0\froman Times New Roman;}{\f1\froman Symbol;}{\f2\fswiss Arial;}{\f3\fswiss AvantGarde;}{\f4\froman Palatino;}{\f5\froman Bookman;}{\f6\fmodern MS LineDraw;}\r
+{\f7\fmodern Courier New;}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue127;\r
+\red0\green127\blue127;\red0\green127\blue0;\red127\green0\blue127;\red127\green0\blue0;\red127\green127\blue0;\red127\green127\blue127;\red192\green192\blue192;}{\stylesheet{\s232\ri850\tldot\tx8504\tqr\tx8640 \fs20\lang1036 \sbasedon0\snext0 toc 1;}{\r
+\s242\tqc\tx4252\tqr\tx8504 \fs20\lang1036 \sbasedon0\snext242 footer;}{\s243\tqc\tx4252\tqr\tx8504 \fs20\lang1036 \sbasedon0\snext243 header;}{\s254\sb840\sa480\keepn \b\f5\fs28\lang1036 \sbasedon2\snext0 heading 1;}{\fs20\lang1036 \snext0 Normal;}{\r
+\s2\sb840\sa480\keepn \f5\fs28\lang1036 \sbasedon0\snext2 section;}{\s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 \sbasedon0\snext3 program;}{\s4\qj \f5\lang1033 \r
+\sbasedon0\snext4 zwykly;}}{\info{\title Micro manual of Loglan'82}{\author Andrzej Salwicki}{\operator Andrzej Salwicki}{\creatim\yr1993\mo8\dy12\hr21\min1}{\revtim\yr1994\mo3\dy21\hr17\min55}{\printim\yr1994\mo3\dy21\hr17\min51}{\version34}{\edmins1094}\r
+{\nofpages40}{\nofwords9800}{\nofchars68634}{\vern16504}}\paperw12242\paperh15842\margl1701\margr1701\margt1361\margb1361\gutter0 \facingp\widowctrl\ftnbj\hyphhotz357\margmirror \sectd \linex0\headery709\footery709\colsx709\endnhere\titlepg {\headerl \r
+\pard\plain \s243\brdrb\brdrdb\brdrw15\brsp20 \tqc\tx4252\tqr\tx8789 \fs20\lang1036 {\field{\*\fldinst PAGE}{\fldrslt 34}}\tab A.Kreczmar\tab Nov.1990\r
+\par }{\headerr \pard\plain \s243\brdrb\brdrdb\brdrw15\brsp20 \tqc\tx4252\tqr\tx8789 \fs20\lang1036 \tab Loglan'82\tab {\field{\*\fldinst PAGE}{\fldrslt 33}}\r
+\par }\pard\plain \fs20\lang1036 {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }\pard \li4537 {\f5\fs28 A micro-manual\r
+\par }{\f5\fs28 \r
+\par }{\f5\fs28 of\r
+\par }{\f5\fs28 \r
+\par }{\f5\fs28 the programming language\r
+\par }{\f5\fs28 \r
+\par }{\f5\fs28 \r
+\par }{\f5\fs28 \r
+\par }\pard {\plain \f5\lang1036 \r
+\par }\pard \li709 {\f5\fs44 L O G L A N - 82\r
+\par }\pard \li709 {\plain \f5\lang1036 \r
+\par }\pard \li709 {\f5\fs28 Basic constructs and facilities\r
+\par }\pard \li709 {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 Author: Antoni Kreczmar\r
+\par }\pard {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }\pard \qc\brdrt\brdrs\brdrw30\brsp20 {\plain \f5\lang1036 Institute of Informatics, Warsaw University\r
+\par }\pard \qc {\plain \f5\lang1036 March 1990\r
+\par }{\plain \f5\lang1036 edited by A.Salwicki LITA Pau November 1990\r
+\par }{\plain \f5\lang1036 \r
+\par }\pard\plain \s232\ri851\sb840\sa480\tldot\tx8504\tqr\tx8640 \fs20\lang1036 {\b\fs28 Table of contents\r
+\par }\pard \s232\ri850\tldot\tx8504\tqr\tx8640 {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\field\fldedit{\*\fldinst {\plain \f5\lang1036 TOC \\o}}{\fldrslt {\plain \f5\lang1036 1. Compound statements\tab 4\r
+\par }{\plain \f5\lang1036 2. Modularity\tab 8\r
+\par }{\plain \f5\lang1036 3. Procedures and functions\tab 10\r
+\par }{\plain \f5\lang1036 4. Classes\tab 13\r
+\par }{\plain \f5\lang1036 5. Adjustable arrays\tab 16\r
+\par }{\plain \f5\lang1036 6. Coroutines and semicoroutines\tab 19\r
+\par }{\plain \f5\lang1036 7. Prefixing\tab 22\r
+\par }{\plain \f5\lang1036 8. Formal types\tab 28\r
+\par }{\plain \f5\lang1036 9. Protection techniques\tab 29\r
+\par }{\plain \f5\lang1036 10. Programmed deallocation\tab 30\r
+\par }{\plain \f5\lang1036 11. Exception handling\tab 32\r
+\par }{\plain \f5\lang1036 12. Concurrent processes.\tab 3}{\plain \f5\lang1036 3\r
+\par }{\plain \f5\lang1036 References.\tab 4}{\plain \f5\lang1036 0}{\plain \f5\lang1036 \r
+\par }\pard\plain \s4\qj \f5\lang1033 }}\pard\plain \s4\qj \f5\lang1033 \page LOGLAN-82 is a universal programming language designed at the Insti\-tu\-te of Informatics, University of Warsaw. Its syntax is patterned upon Pas\-\r
+cal's. Its rich semantics includes the classical constructs and facili\-ties offe\-red by the Algol-family programming languages as well as more modern facilities, such as concurrency and exception handling.\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 The basic constructs and facilities of the LOGLAN-82 programming lan\-gua\-ge include:\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 1) A convenient set of structured statements,\r
+\par }\pard\plain \s4\qj \f5\lang1033 2) Modularity (with the possibility of module nesting and extending),\r
+\par \pard\plain \qj\sb120 \fs20\lang1036 {\plain \f5\lang1036 4) Classes (as a generalization of records) which enable to define complex structured types, data structures, packages, etc.,\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 5) Adjustable arrays whose bounds are determined at run-time in such a way that multidimensional arrays may be of various shapes, e.g. triangu\-lar, k-diagonal, streaked, etc.,\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 6) Coroutines and semi-coroutines,\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 7) Prefixing - the facility borrowed from Simula-67, substantially generali\-zed in LOGLAN-82 }{\plain \f5\lang1036 \r
+- which enables to build up hierarchies of types and data structures, problem-oriented languages, etc.,\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 8) Formal types treated as a method of module parametrization,\r
+\par }{\plain \f5\lang1036 9) Module protection and encapsulation techniques,\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 10) Programmed deallocator - a tool for efficient and secure garbage col\-lection, which allows the user to implement the optimal strategy of sto\-rage ma\-nagement,\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 11) Exception handling which provides facilities for dealing with run-time errors and other exceptional situations rai}{\plain \f5\lang1036 sed by the user,\r
+\par }{\plain \f5\lang1036 12) Concurrency easily adaptable to any operating system kernel and al\-lo\-wing parallel programming in a natural and efficient way.\r
+\par }\pard \qj\sb120 {\plain \f5\lang1036 The language covers system programming, data processing, and nume\-ri\-cal computations. Its constructs represent the state-of-art and are effi\-ciently implementable. Large systems consisting of many cooperating mo\r
+\-dules are easily decomposed and assembled}{\plain \f5\lang1036 , due to the class concept and prefixing.\r
+\par }\pard \qj {\plain \f5\lang1036 LOGLAN-82 constructs and facilities have appeared and evo}{\plain \f5\lang1036 lved simul\-\r
+taneously with the experiments on the first pilot compiler (implemented on Mera-400 Polish minicomputer). The research on LOGLAN-82 imple\-men\-tation engendered with new algorithms for static semantics, context ana\-lysis, code generation, data }\r
+{\plain \f5\lang1036 structures for storage management etc.\r
+\par }\pard \qj {\plain \f5\lang1036 The LOGLAN-82 compiler provides a keen analysis of syntactic and se\-mantic errors at compilation as well as at run time. The object code is ve\-ry efficient with respect to time and space. The completeness of error ch}\r
+{\plain \f5\lang1036 eck\-ing guarantees full security and ease of program debugging.\r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 1. Compound statements\r
+\par \pard\plain \s4\qj \f5\lang1033 Compound statements in LOGLAN-82 are built up from simple statements (like assignment statement e.g. x:=y+0.5, call statement e.g. {\b call} P(7,x+5) etc.) by means of conditional, iteration and case statements.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 The syntax of conditional statement is as follows:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} boolean expression\line {\b then} \line sequence of statements\line {\b else} \line \r
+ sequence of statements\line {\b fi} \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 where "else part" may be omitted:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} boolean expression \line {\b then} \line sequence of statements\line {\b fi} \r
+\par \pard\plain \s4\qj \f5\lang1033 The semantics of conditional statement is standard. The keyword fi allows to nest conditional statements without appearence of "dangling else" ambi\-guity.\r
+\par \pard \s4\qj \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} delta>0 \line {\b then} \line x2:=sqrt(delta)/a/2;\line {\b if} b=0 \line {\b then} \line \r
+ x1:=x2\line {\b else} \line x1:=-b/a/2+x2; x2:=x1-2*x2\line {\b fi} \line {\b else} \line {\b if} delta=0 \line {\b then} \line x1:=-b/a/2; x2:=x1\line {\b else} \line write(" no real roots")\line {\b fi}\r
+ \line {\b fi} \r
+\par \pard\plain \s4\qj \f5\lang1033 The statements in a sequence of statements are separated with semicolons (semicolon may end a sequence , and then, the last statement in the sequence is the empty statement).\r
+\par The short circuit control forms are realized in LOGLAN-82 by the conditional statements with orif (or andif) list. A conditional statement with orif list has the form: orif \r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} wb1 {\b orif} wb2 ... {\b orif} wbk \line {\b then} \line sequence of statements\line {\b else}\line \r
+ sequence of statements\line {\b fi} \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 and corresponds somehow to a conditi}{\plain \f5\lang1036 onal statement:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} wb1 {\b or} wb2 ... {\b or} wbk \line {\b then} \line sequence of statements\line {\b else} \line \r
+ sequence of statements\line {\b fi} \r
+\par \pard\plain \s4\qj \f5\lang1033 The above conditional statement (without orif list) selects for execution one of two sequences of statements, depending on the truth value of the boolean expression:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 wb1 {\b or} wb2 {\b or} ... wbk \r
+\par \pard\plain \s4\qj \f5\lang1033 which is always evaluated till the end. For the execution of the conditional statement with orif list the specified conditons wb1,...,wbk are evaluated in succession, until the fir\r
+st one evaluates to true. Then the rest of the sequence wb1,...,wbk is abandoned and "then part" is executed. If none of the conditions wb1,...,wbk evaluates to true "else part" is executed (if any).\r
+\par \pard \s4\qj Conditional statements with orif list facilitate to program those con_ditions, which evaluation to the end may raise a run-time error.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }{\plain \f5\lang1036 The execution of the statement:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} i>n {\b or} A(i)=0 {\b then} i:=i-1 {\b else} A(i):=1 {\b fi} \r
+\par \pard\plain \s4\qj \f5\lang1033 where the value of i is greater than n, and A is an array with upper bound n, will raise the run-time error. Then the user can write:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} i>n {\b orif} A(i)=0 {\b then} i:=i-1 {\b else} A(i):=1 {\b fi}\r
+\par \pard\plain \s4\qj \f5\lang1033 what allows to avoid this run-time error and probably agrees with his intension. \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Conditional statement with andif list has the form:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} wb1 {\b andif} wb2 ... {\b andif} wbk\line {\b then} \line sequence of statements\line {\b else} \line \r
+ sequence of statements\line {\b fi} \r
+\par \pard\plain \s4\qj \f5\lang1033 For the execution of this kind of statements, the conditions wb1,...,wbk are evaluated in succession, until the first one evaluates to false; then "else part" (if any) is executed. Otherwise "then part" is executed.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Iteration statement in LOGLAN-82 has the form:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b do} sequence of statements {\b od}\r
+\par \pard\plain \s4\qj \f5\lang1033 An iteration statement specifies repeated execution of the sequence of statements and terminates with the execution of the simple statement exit\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 s:=1; t:=1; i:=1;\line {\b do} \line i:=i+1; t:=t*x/i;\line {\b if} abs(t) < 1.0E-10 {\b then exit fi}; \line \r
+ s:=s+t\line {\b od}; \r
+\par \pard\plain \s4\qj \f5\lang1033 If two iteration statements are nested, then double exit in the inner one terminates both of them.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 r,x:=0;\line {\b do} \line s,t:=1; i:=1; x:=x+0.2;\line {\b do} \line i:=i+1; t:=t*x/i;\line {\b if} i > n {\b \r
+then exit exit fi}; (* termination of both loops *) \line {\b if} t < 1 {\b then exit fi}; (* termination of the inner loop *)\line s:=s+t\line {\b od \line od} \r
+\par \pard\plain \s4\qj \f5\lang1033 In the example above simultaneous assignment statements are illustrated (e.g. r,x:=0) and comments, which begin with a left parenthesis immedi\-ately followed by an asterisk and end with an asterisk immediately fol\-\r
+lowed by a right parenthesis.\r
+\par \pard \s4\qj Triple exit terminates three nested iteration statements, four exit termi\-nates four nested iteration statements etc.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 The iteration statement with while condition: while \r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b while} boolean expression \line {\b do} \line sequence of statements\line {\b od} \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 is equivalent to:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b do} \line {\b if not} boolean expression {\b then exit fi}; \line sequence of statements\line {\b od} \r
+\r
+\par \pard\plain \s4\qj \f5\lang1033 The iteration statements with controlled variables (for statements) have the forms:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b for} j:=wa1 {\b step} wa2 {\b to} wa3 \line {\b do} \line sequence of statements\line {\b od } \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 or\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b for} j:=wa1 {\b step} wa2 {\b downto} wa3 \line {\b do} \line sequence of statements\line {\b od} \r
+\par \pard\plain \s4\qj \f5\lang1033 The type of the controlled variable j must be discrete. The value of this variable in the case of the for statement with to is increased, and in the case of the for statement with downto is decreased. The\r
+ discrete range begins with the value of wa1 and changes with the step equal to the value of wa2. The execution of the for statement with to terminates when the value of j for the first time becomes g\r
+reater than the value of wa3 (with downto when the value of j for the first time becomes less than the value of wa3). After the for statement termination the value of its controlled vari\-able is determined and equal to the first value exceeding the spec\r
+ified dis\-crete range. The values of expressions wa1, wa2 and wa3 are evaluated once, upon entry to the iteration statement. Default value of wa2 is equal 1 (when the keyword step and expression wa2 are omitted).\r
+\par \pard \s4\qj For or while statements may be combined with exit statement. \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b for} j:=1 {\b to} n\line {\b do} \line {\b if} x=A(j) {\b then exit fi}; \line {\b od} \r
+\par \pard\plain \s4\qj \f5\lang1033 The above iteration statement terminates either for the least j, 1<=j<=n, such that x=A(j) or for j=n+1 when x=/=A(j), j=1,...,n.\r
+\par \pard \s4\qj \r
+ To enhance the user's comfort, the simple statement repeat is provided. It may appear in an iteration statement and causes the current iteration to be finished and the next one to be continued (something like jump to CONTINUE in Fortran's DO statements).\r
+\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 i:=0; s:=0;\line {\b do} \line i:=i+1;\line {\b if} A(i)<0 {\b then repeat fi}\r
+; (* jump to od,iterations are contd.*)\line {\b if} i > m {\b then exit fi}; (* iteration statement is terminated*) \line s:=s+sqrt(A(i));\line {\b od}; \r
+\par \pard\plain \s4\qj \f5\lang1033 Just as exit, repeat may appear in for statement or while statement. Then the next iteration begins with either the evaluation of a new value of the controlled variable (for statement) or with the\r
+ evaluation of the condition (while statement). \r
+\par \pard \s4\qj Case statement in LOGLAN-82 has the form:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b case} WA \line {\b when} L1 : I1 \line {\b when} L2 : I2 \line {\b .}..\line {\b when} Lk : Ik\r
+ \line {\b otherwise} I \line {\b esac} \r
+\par \pard\plain \s4\qj \f5\lang1033 where WA is an expression , L1,...,Lk are constants and I1,..., Ik,I are se\-quences of statements.\r
+\par \pard \s4\qj A case statement selects for execution a sequence of statements Ij, 1{\field{\*\fldinst SYMBOL 163 \\f "Symbol"}{\fldrslt }}j{\field{\*\fldinst SYMBOL 163 \\f "Symbol"}{\fldrslt }}\r
+k, where the value of WA equals Lj. The choice otherwise covers all values (possibly none) not given in the previous choices. The execution of a case statement chooses one and only one al\r
+ternative (since the choices are to be exhaustive and mutually exclusive).\r
+\par \pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 2. Modularity\r
+\par \pard\plain \s4\qj \f5\lang1033 \r
+ Modular structure of the language is gained due to the large set of means for module nesting and extending. Program modules (units) are blocks, procedures, functions, classes, coroutines and processes. Block is the simplest kind of unit. Its syntax is th\r
+e following:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b block} \line lists of declarations\line {\b begin} \line sequence of statements\line {\b end} \r
+\par \pard\plain \s4\qj \f5\lang1033 The sequence of statements commences with the keyword begin (it may\r
+ be omitted when this sequence is empty). The lists of declarations define the syntactic entities (variables, constants, other units), whose scope is that block. The syntactic entities are identified in the sequence of state\-ments by means of names \r
+(identifiers).\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b block} \line {\b const} n=250; \line {\b var} x,y:real, i,j,k: integer, b: boolean; \line {\b const}\r
+ m=n+1; \line {\b begin} \line read(i,j); (* read two integers *)\line x,y:=n/(i+j); (* simultaneous assignment *)\line read(c) ; (* read a character *)\line b:= c = 'a'; (* 'a' a character *)\r
+\line {\b for} k:= 1 {\b to} m \line {\b do}\line write(x+y/k:10:4); (* print the value of x+y/k in the\line field of 10 characters, 4 digits after the point *)\line {\b od\line end } \r
+\par \pard\plain \s4\qj \f5\lang1033 In the lists of declarations semicolons terminate the whole lists, not the lists elements. Any declaration list must begin with the pertinent keyword (var for variables, const for constants etc.). The\r
+ value of an expression de\-fining a constant must be determinable statically (at compilation time).\r
+\par \pard \s4\qj Program in LOGLAN-82 may be a block or alternatively may be of the following form:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b program} name; \line lists of declarations\line {\b begin} \line sequence of statements\line {\b end}\r
+ \r
+\par \pard\plain \s4\qj \f5\lang1033 Then the whole program can be identified by that name (the source as well as the object code).\r
+\par \pard \s4\qj A block can appear in the sequence of statements (of any unit), thus it is a statement. (Main block is assumed to appear as a statement of the given job control language.)\r
+\par \pard \s4\qj \r
+ For the execution of a block statement the object of block is created in a computer memory, and then, the sequence of statements is performed. The syntactic entities declared in the block are allocated in its object. After a block's termination its objec\r
+t is automatically deallocated (and the corre\-sponding space may be immediately reused).\r
+\par \pard \s4\qj The modular structure of the language works "in full steam" when not only blocks, but the other kinds of units are also used. They will be de\-scribed closer in the following points.\r
+\par \pard \s4\qj Unit nesting allows to build up hierarchies of units and supports security of programming. It follows from the general visibility rules; namely, a syn\-\r
+tactic entity declared in an outer unit is visible in an inner one (unless hidden by an inner declaration). On the other hand, a syntactic entity de\-clared in an inner unit is not visible from an outer one.\line \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b program} test; \line {\b var} a,b,c:real, i,j,k:integer; \line {\b begin} \line read(a,b,c,i);\line {\b \r
+block} \line {\b var} j,k:real; \line {\b begin} \line j:=a; k:=j+b; write(" this is the inner block ",j,k)\line {\b end}; \line write(" this is the outer block ",i,a:20)\line {\b end}; \r
+\par \pard\plain \s4\qj \f5\lang1033 \r
+ In this program, first the main block statement is executed (with variables a,b,c,i,j,k). Next, after the read statement, the inner block statement is executed (with variables j,k). In the inner block the global variables j,k are hidden by the local ones\r
+.\r
+\par \pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 3. Procedures and functions\r
+\par \pard\plain \s4\qj \f5\lang1033 Procedures and functions are well-known kinds of units. Their syntax is mo\-del\-led on Pascal's, though with some slight modifications. Procedure (function) declaration consists of a specification part and a body.\tab \r
+\line \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} Euclid: {\b function}(i,j:integer):integer; \line {\b var} k:integer;\line {\b begin} \line {\b \r
+do} \line {\b if} j=0 {\b then exit fi}; \line k:=i {\b mod} j; i:=j; j:=k \line {\b od}; \line result:=i\line {\b end}; \r
+\par \pard\plain \s4\qj \f5\lang1033 Procedure or function specification begins with its identifier preceded by the keyword unit. (The same syntax concerns any other mod\-ul\r
+e named unit.) Then follows its kind declaration, its formal parameters (if any), and the type of the returned value (only for functions). A body con\-sists of decla\-ration lists for local entities and a sequence of statements. The keyword {\b begin}\r
+ commences the sequence of statements, and is omit\-ted, if this se\-quence is empty. The value returned by a function equals to the most re\-\r
+cent value of the standard variable "result", implicitly declared in any function. This variable can be used as a local auxiliary variable as well.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} Newton: {\b function}(n,m:integer):integer; \line \tab \tab {\b var} i:integer; \line {\b begin} \r
+\line {\b if} m > n {\b then return fi}; \line result:=n;\line {\b for} i:=2 {\b to} m {\b do} result:=result*(n-i+1) {\b div} i {\b od} \line {\b end} Newton;\r
+\par \pard\plain \s4\qj \f5\lang1033 \r
+ The optional identifier at the end of a unit must repeat the identifier of a unit. It is suggested that the compilers check the order of unit nesting, so these optional occurrences of identifiers would facilitate program debug\-ging.\r
+\par \pard \s4\qj All the local variables of a unit are initialized (real with 0.0, integer with 0, boolean with false etc.). Thus , for instance, the value of function Newton is 0 for m>n, since "result" is also initialized, as any other local variable.\r
+\r
+\par \pard \s4\qj The return statement (return) completes the execution of a procedure (function) body,i.e. return is made to the caller. If return does not appear explicitly, return is made with the execution of the final end\r
+ of a unit. Upon return to the caller the procedure (function) object is deallocated.\r
+\par \pard \s4\qj Functions are invoked in expressions with the corresponding list of actual parameters. Procedures are invoked by call statement (also with the corre\-sponding list of actual parameters).\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 i:=i*Euclid(k,105)-Newton(n,m+1);\line {\b call} P(x,y+3); \r
+\par \pard\plain \s4\qj \f5\lang1033 Formal parameters are of four categories: variable parameters, procedure parameters, function parameters and type parameters (cf p.8). Variable pa\-\r
+rameters are considered local variables to the unit. A variable parameter has one of three transmission modes: input, output or inout. If no mode is explicitly given the input mode is assumed. For instance in the unit decla\-ration:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} P: {\b procedure}(x,y:real,b:boolean;\line {\b output} c:char,i:integer;{\b inout} :integer);\r
+\par \pard\plain \s4\qj \f5\lang1033 x,y,b are input parameters , c,i are output parameters , and j is inout pa\-rameter.\r
+\par \pard \s4\qj Input parameter acts as a local variable whose value is initialized by the value of the corresponding actual parameter. Output parameter acts as a local variable initialized in the standard manner (\r
+real with 0.0, integer with 0, boolean with false etc.). Upon return its value is assigned to the corre\-\r
+sponding actual parameter, in which case it must be a variable. However the address of such an actual parameter is determined upon entry to the body. Inout parameter acts as an input parameter and output parameter together.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} squareeq: {\b procedure}(a,b,c:real;{\b output} xr,xi,yr,yi:real); \line \r
+ (* given a,b,c the procedure solves square equation :\line ax*x+bx+c=0.\line xr,xi- real and imaginary part of the first root\line yr,yi- real and imaginary part of the second root *)\line {\b var} delta: real; \line {\b begin\r
+} (*a=/=0*) \line a:=2*a; c:=2*c; delta:=b*b-a*c;\line {\b if} delta <= 0 \line {\b then} \line xr,yr:=-b/a;\line {\b if} delta=0 {\b then return fi}; (*xi=yi=0 by default*) \line delta:=sqrt(-delta);\line \r
+ xi:=delta/a; yi:=-xi;\line {\b return \line fi}; \line delta:=sqrt(delta);\line {\b if} b=0 \line {\b then} \line xr:=delta/a; yr:=-xr;\line {\b return \line fi}; \line {\b if} b>0 {\b \r
+then} b:=b+delta {\b else} b:=b-delta {\b fi};\line xr:=-b/a; yr:=-c/b;\line {\b end} squareeq;\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 A procedure call to the above unit may be the following:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b call} squareeq(3.75*H,b+7,3.14,g,gi,h,hi); \r
+\par \pard\plain \s4\qj \f5\lang1033 where g,h,gi,hi are real variables.\r
+\par \pard \s4\qj No restriction is imposed on the order of declarations. In particular, re\-cursive procedures and functions can be declared without additional an\-nouncements (in contrast to Pascal).\r
+\par \pard \s4\qj Example:\r
+\par For two recursive sequences defined as:\r
+\par \tab a(n)=b(n-1)+n+2 n>0\r
+\par \pard\plain \li567 \fs20\lang1036 {\plain \f5\lang1036 b(n)=a(n-1)+(n-1)*n }{\plain \f5\lang1036 n>0\r
+\par }{\plain \f5\lang1036 a(0)=b(0)=0\r
+\par }\pard {\plain \f5\lang1036 one can declare two functions:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} a: {\b function}(n:integer):integer;\line {\b begin} \line {\b if} n>0 {\b then} result:=b(n-1)+n+2 {\b fi}\r
+\line {\b end} a; \line {\b unit} b: {\b function}(n:integer):integer; \line {\b begin} \line {\b if} n>0 {\b then} result:=a(n-1)+(n-1)*n {\b fi} \line {\b end} b; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 and invoke them:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 k:=a(100)*b(50)+a(15);\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Functions and procedures can be formal parameters as well.\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} Bisec: {\b procedure}(a,b,eps:real;{\b output} x:real;{\b function} \tab \tab \tab \tab \tab \tab \tab \tab \tab \tab \r
+\tab \tab \tab f(x:real):real);\line (*this procedures searches for zero of the continous function f in \tab \tab \tab \tab \tab \tab \tab \tab \tab \tab \tab \tab the segment (a,b) *)\line {\b var} h:real,s:integer;\line {\b begin}\line s:=sign(f(a));\r
+\line {\b if} sign(f(b))=s {\b then return fi}; (* wrong segment *) \line h:=b-a;\line {\b do} \line h:=h/2; x:=a+h;\line {\b if} h < eps {\b then return fi};\line {\b if} sign(f(x))=s {\b then} a:=x {\b else} b:=x {\b fi}\line {\r
+\b od} \line {\b end} Bisec;\r
+\par \pard\plain \s4\qj \f5\lang1033 In the above declaration, after the input variable parameters a,b,eps and the output variable parameter x, a function parameter f appears. Note that its specification part is complete. Thus the check of actual-formal parame\r
+\-ter compatibility is possible at compilation time. Making use of this syn\-tactic facility is not possible in general, if a formal procedure (function) is again a formal parameter of a formal procedure (function). The second de\-gree of formal\r
+ procedures (functions) nesting is rather scarce, but LOGLAN-82 admits such a construct. Then formal procedure (function) has no specification part and the full check of actual-formal parameter compatibility is left to be done at run time.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Example:}{\plain \f5\lang1036 \r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} P: {\b procedure}(j:integer; {\b procedure} G (i:integer;\line {\b \r
+procedure} H));\line ...\line {\b begin} \line ...\line {\b call} G(j,P);\line {\b end} P; \r
+\par \pard\plain \s4\qj \f5\lang1033 \r
+ Procedure G is a first degree parameter, therefore it occurs with complete specification part. Procedure H is a second degree parameter and has no specification part. In this case a procedure call can be strongly recursive:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b call} P(i+10,P); \r
+\par \pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 4. Classes\r
+\par \pard\plain \s4\qj \f5\lang1033 Class is a facility which covers such programming constructs as struc\-tu\-red type, package, access type, data structure etc. To begin with the pre\-s\-\r
+entation of this construct, let us consider a structured type assembled from primitive ones:\r
+\par \pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} bill: {\b class};\line {\b var} dollars :real, \line not_paid :boolean,\line \r
+ year,month,day :integer;\line {\b end} bill; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 The above class declaration has the attributes : dollars (real), not_paid (boolean), and year,month,day (integer). Wherever class bill is visibile one can declare variables of type bill:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b var} x,y,z: bill;\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ The values of variables x, y, z can be the addresses of objects of class bill. These variables are called reference variables. With reference variable one can create and operate the objects of reference variable type.\r
+\par }\pard \qj {\plain \f5\lang1036 An object of a class is created by the class generation statement (new), and thereafter, its attributes are accessed through dot notation.\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 x:={\b new} bill; (* a new object of class bill is created *)\line x.dollars:=500.5; (* define amount *)\line \r
+ x.year:=1982; (* define year *)\line x.month:=3; (* define month *)\line x.day:=8; (* define day *)\line y:={\b new} bill; (* create a new object *) \line y.not_paid:=true; (* bill not_paid *)\line \r
+ z:=y; (* variable z points the same object as y *)\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 If an object of class bill has been created (new bill) and its address has been assigned to variable x (x:=new bill), then the\r
+ attributes of that object are accessible through dot notation (remote access). The expression x.dollars gives , for instance,}{\plain \f5\lang1036 }{\plain \f5\lang1036 \r
+the remote access to attribute dollars of the object referenced by x. All attributes of class objects are initialized as usual. For the above example the object referenced by x, after the execu\-\r
+tion of the specified sequence of statements, has the followi}{\plain \f5\lang1036 ng structure:\r
+\par }\pard \keep {\plain \f7\lang1036 \line }{\plain \f6\lang1036 \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf}{\plain \f7\lang1036 \line }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 500.5 }{\plain \f6\lang1036 \'b3}\r
+{\plain \f7\lang1036 dollars\line }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4}{\plain \f7\lang1036 \line }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 false }{\plain \f6\lang1036 \'b3}\r
+{\plain \f7\lang1036 not_paid\line }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4}{\plain \f7\lang1036 \line }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 1982 }{\plain \f6\lang1036 \'b3}\r
+{\plain \f7\lang1036 year\line }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4}{\plain \f7\lang1036 \line }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 3 }{\plain \f6\lang1036 \'b3}{\plain \r
+\f7\lang1036 month\line }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4}{\plain \f6\lang1036 \'b4}{\plain \f7\lang1036 \line }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 8 }{\plain \r
+\f6\lang1036 \'b3}{\plain \f7\lang1036 day\line }{\plain \f6\lang1036 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9}{\plain \f7\lang1036 \r
+\par }\pard {\plain \f5\lang1036 \line The object referenced by y and z has the following structure:\r
+\par }\pard \keep {\plain \f6\lang1036 \line \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 0 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 \r
+ dollars}{\plain \f6\lang1036 \line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 true }{\plain \r
+\f6\lang1036 \'b3}{\plain \f7\lang1036 not_paid}{\plain \f6\lang1036 \line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'b3}\r
+{\plain \f7\lang1036 0 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 year}{\plain \f6\lang1036 \line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \r
+\f7\lang1036 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 0 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 month}{\plain \f6\lang1036 \line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 0 }{\plain \f6\lang1036 \'b3}{\plain \f7\lang1036 day}{\plain \f6\lang1036 \line }{\plain \f7\lang1036 }{\plain \f6\lang1036 \r
+\'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\r
+\par }\pard \qj {\plain \f5\lang1036 The value none is the default initial value of any reference variable and denotes no objec}{\plain \f5\lang1036 t. A remote access to an attribute of none raises a run time error. \r
+\par }{\plain \f5\lang1036 Class may have also formal parameters (as procedures and functions). Kinds and transmission modes of formal parameters are the same as in the case of procedures.\r
+\par }\pard {\plain \f5\lang1036 \line \r
+\par }\pard {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} node: {\b class} (a:integer);\line var left,right:node; \line {\b end} node; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Let, for instance, variables z1, z2, z3 be of type node. Then the sequence of statements:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 z1:={\b new} node(5);\line z2:={\b new} node(3); \line z3:={\b new} node(7); \line z1.left:=z2\r
+; z1.right:=z3;\r
+\par \pard\plain \sa120 \fs20\lang1036 {\plain \f5\lang1036 creates the structure:\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \line \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line }{\plain \f7\lang1036 z1}{\plain \f6\lang1036 \'c4\'c4\'c4\'c4\'c4\'c4\'b4}{\plain \f7\lang1036 \r
+ 5 }{\plain \f6\lang1036 \'b3\line \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'da\'c4\'c4\'c4\'c4\'c4\'c4\'b4}{\plain \f7\lang1036 left }{\plain \f6\lang1036 \'b3\line \'b3 \'c3\'c4\'c4\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'b3 \'b3 }{\plain \f7\lang1036 right}{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line \'b3 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'b3\line \r
+\'b3 \'b3\line \'da\'c4\'c4\'c4\'c4\'c1\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c1\'c4\'c4\'c4\'c4\'bf\line }{\plain \f7\lang1036 z2}{\plain \f6\lang1036 \'c4\'c4\'c4\'c4\'c4\'b4 }{\plain \f7\lang1036 \r
+ 3 }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 7 }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4}{\plain \f7\lang1036 z3\line }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \r
+\'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'b3 }{\plain \f7\lang1036 none }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 none }{\plain \f6\lang1036 \'b3 \line }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'b3 }{\plain \f7\lang1036 none }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 none }{\plain \f6\lang1036 \'b3 \line \r
+\'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\r
+\par }\pard {\plain \f5\lang1036 \line where arrows denote the values of the reference variables.\r
+\par }\pard \qj {\plain \f5\lang1036 Class may also have a sequence of statements (as any other unit). That sequence can initialize the attributes of the class objects.\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} complex:{\b class}(re,im:real); \line {\b var} module:real; \line {\b begin} \line \r
+ module:=sqrt(re*re+im*im)\line {\b end} complex; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Attribute module is evaluated for any object gen}{\plain \f5\lang1036 eration of class complex:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 z1:={\b new} complex(0,1); (* z1.module equals 1 *) \line z2:={\b new} complex(2,0); (* z2.module equals 2 *) \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ For the execution of a class generator, first a class object is created, then the input parameters are transmitted , and finally, the sequence of statements (if any) is performed. Return is made with the execution of return statement or the final end of \r
+}{\plain \f5\lang1036 a unit. Upon return the output parameters are transmitted.\r
+\par }\pard \qj {\plain \f5\lang1036 Procedure object is automatically deallocated when return is ma}{\plain \f5\lang1036 \r
+de to the caller. Class object is not deallocated , its address can be assigned to a reference variable, and its attributes can be thereafter accessed via this variable. \r
+\par }{\plain \f5\lang1036 The classes presented so far had only variable attributes. In general, class attributes may be also other syntactic entities, such as constants, proce\-dures, functions, classes etc. Classes with procedure and function attribu\-\r
+tes provide a good facility}{\plain \f5\lang1036 to define data structures.\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard \qj {\plain \f5\lang1036 A push_down memory of integers may be impl}{\plain \f5\lang1036 emented in the following way:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} push_down :{\b class}; \line {\b unit} elem:{\b class}(value:integer,next:elem);\line \r
+ (* elem - stack element *)\line {\b end} elem; \line {\b var} top:elem; \line {\b unit} pop: {\b function} :integer; \line {\b begin} \line {\b if} top=/= {\b none} \line {\b then} \line \r
+ result:=top.value; top:=top.next\line {\b fi}; \line {\b end} pop; \line {\b unit} push:{\b procedure}(x:integer); (* x - pushed integer *)\line {\b begin} \line top:={\b new} elem(x,top);\line {\b end} push;\r
+ \line {\b end} push_down;\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Assume that somewhere}{\plain \f5\lang1036 in a program reference variables of type push_down are declared (of course, in place where push_down is visibile):\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b var} s,t,z:push_down; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Three different push_down memories may be now generated:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 s:={\b new} push_down(100); t:={\b new} push_down(911); z:={\b new} push_down(5); \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 One can use these push_down memories as follows:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b call} s.push(7); (* push 7 to s *) \line {\b call} t.push(1); (* push 1 to t *) \line \r
+ i:=z.pop; (* pop an element from z *)\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 etc.\r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 5. Adjustable arrays\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 In LOGLAN-82 arrays}{\plain \f5\lang1036 \r
+ are adjustable at run time. They may be treated as objects of specified standard type with index instead of identifier selecting an attribute. An adjustable array should be declare somewhere among the lists of declarations and then may be generated in th\r
+}{\plain \f5\lang1036 e sequence of state\-ments.\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b block} \line {\b var} n,j:integer; \line {\b var} A:{\b arrayof} integer; (* here is the declaration of A *) \line {\r
+\b begin \line } read(n);\line {\b array} A {\b dim} (1:n); (* here is the generation of A *) \line {\b for} i:=1 {\b to} n \line {\b do} \line read(A(i));\line {\b o}{\b d}; \line (* etc.*)\line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 A variable A is an array variable. Its value should be the reference to an integer array, i.e. a composite object consisting of integer components each one defined by an integer index. \tab \line \r
+Array generation statement:\r
+\par }\pard \qj {\plain \f5\lang1036 \tab array A dim (1:n); \r
+\par }\pard \qj {\plain \f5\lang1036 allocates a one-dimensional integer array with the index bounds 1,n , and assigns its address to variable A. \tab \line The figure below illustrates this situation:\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \line \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'b3 \'b3 \'b3 }{\plain \f7\lang1036 A(}{\plain \f7\lang1036 1) }{\plain \f6\lang1036 \'b3\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'b3 \'b3 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 ... }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 A(2)}{\plain \f6\lang1036 \'b3\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 n }{\plain \f6\lang1036 \'b3 \'b3 \'b3\r
+\par }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'b3 }{\plain \f7\lang1036 ... }{\plain \f6\lang1036 \'b3\r
+\par }{\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 j }{\plain \f6\lang1036 \'b3 \'b3 \'b3\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 A}{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 }{\plain \f7\lang1036 A(n)}{\plain \f6\lang1036 \r
+\'b3\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f6\lang1036 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\r
+\par }\pard \keep\box\brdrs\brdrw15\brsp20 \dxfrtext180 {\plain \f5\lang1036 }{\plain \f7\lang1036 Block object Array object\r
+\par }\pard {\plain \f5\lang1036 \line A general case of array generation statement has}{\plain \f5\lang1036 the form:}{\plain \f7\lang1036 \r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b array} A {\b dim} (lower:upper) \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 where lower and upper are arithmetic expressions which define the range of the array index.\r
+\par }\pard {\plain \f5\lang1036 Example:\r
+\par }{\plain \f5\lang1036 Two-dimensional array declaration :\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b var} A: {\b arrayof arrayof} integer; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 and generation:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b array} A {\b dim }(1:n)\line {\b for} i:=1 {\b to} n {\b do array} A(i) {\b dim} (1:m) {\b od}; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 create the structure:\r
+\par }\pard {\plain \f6\lang1036 \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line \'b3 }{\plain \f7\lang1036 A(1,1)}{\plain \f6\lang1036 \'b3\line \'c3\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \f6\lang1036 \'b3 \'b3\line \'b3 }{\plain \f7\lang1036 ...}{\plain \f6\lang1036 \'b3\line \r
+ \'b3 \'b3\line \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b3\line \'b3 }{\plain \f7\lang1036 A(1) }{\plain \f6\lang1036 \'c3\'c4\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 }{\plain \f7\lang1036 A(1,m) }{\plain \f6\lang1036 \'b3\line \'b3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\line \'b3\r
+ \'b3\line \'b3 }{\plain \f7\lang1036 ... }{\plain \f6\lang1036 \'b3\line \'b3 \'b3\line \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line \r
+ \'b3 }{\plain \f7\lang1036 A(n) }{\plain \f6\lang1036 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 }{\plain \f7\lang1036 A(n,1) }{\plain \f6\lang1036 \'b3\line \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\r
+ \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'b3 \'b3\line }{\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 ...}{\plain \f6\lang1036 \'b3\line \r
+ \'b3 \'b3\line \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'b3 }{\plain \f7\lang1036 A(n,m) }{\plain \f6\lang1036 \'b3\line \r
+ \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\line }{\plain \f5\lang1036 \r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b block} \line {\b var} i,j:integer, A,B: {\b arrayof arrayof} real, n:integer; \line {\b begin} \line read(n);\r
+\line {\b array} A {\b dim} (1:n); \line {\b for} i:=1 {\b to} n {\b do} {\b array} A(i) {\b dim} (1:n) {\b od}; \line (* A is square array *)\line {\b array} B {\b dim} (1:n); \line {\b for} i:=1 {\b to} n {\b do array} B(i) {\b \r
+dim}(1:i) {\b od}; \line (* B is lower triangular array *)\line A(n,n):=B(n,n);\line B(1):=A(1);\line B(1):={\b copy}(A(1)); \line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Array A is the square array n by n. Each element A(i) , 1}{\field{\*\fldinst {\plain \f5\lang1036 SYMBOL 163 \\f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 i}{\field{\*\fldinst {\plain \f5\lang1036 \r
+SYMBOL 163 \\f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 n contains the address of row A(i,j), 1}{\field{\*\fldinst {\plain \f5\lang1036 SYMBOL 163 \\f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 j}{\field{\*\fldinst {\plain \f5\lang1036 SYMBOL 163 \\\r
+f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 n. Array B is the lower-triangular array. Each element B(i), 1}{\field{\*\fldinst {\plain \f5\lang1036 SYMBOL 163 \\f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 i}{\field{\*\fldinst {\plain \f5\lang1036 \r
+SYMBOL 163 \\f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 n, contains the address of row B(i,j), 1}{\field{\*\fldinst {\plain \f5\lang1036 SYMBOL 163 \\f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 j}{\field{\*\fldinst {\plain \f5\lang1036 SYMBOL 163 \\\r
+f "Symbol"}}{\fldrslt }}{\plain \f5\lang1036 i. Thus an ass}{\plain \f5\lang1036 i\-gnment statement A(n,n):=B(n,n) transmits real value B(n,n) to real varia\-\r
+ble A(n,n). Assignment B(1):=A(1) transmits the address of the first row of A to variable B(1). Finally assignment B(1):=copy (A(1)) creates a copy of the first row of A and assi}{\plain \f5\lang1036 gns its address to B(1).\r
+\par }\pard \qj {\plain \f5\lang1036 Upper and lower bounds of an adjustable array A are determined by stan\-dard operators lower(A) and upper(A).\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} sort: {\b procedure}(A:{\b arrayof} integer);\line (* insertion sort *) \line {\b var}\r
+ n,i,j:integer; var x:integer; \line {\b begin} \line n:=upper(A); (* assume lower bound is 1 *)\line {\b for} i:=2 {\b to} n \line {\b do} \line x:=A(i); j:=i-1;\line {\b do} \line {\b if}\r
+ x >= A(j) {\b then exit fi}; \line A(j+1):=A(j); j:=j-1;\line {\b if} j=0 {\b then exit fi};\line {\b od}; \line A(j+1):=x\line {\b od}; \line {\b end} sort; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 If an array variable A refers to no array its value is equal none (the stan\-\r
+dard default value of any array variable). An attempt to access an array element (e.g. A(i)) or a bound (e.g. lower(A)), wher}{\plain \f5\lang1036 e A is none, raises a run time error.\r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 6. Coroutines and semicoroutines\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ Coroutine is a generalization of class. A coroutine object is an object such that the execution of its sequence of statements can be suspended and reactivated in a programmed manner. Consider first a simple class with a sequence of statements such that a\r
+}{\plain \f5\lang1036 fter return some non-executed state\-ments remain. The generation of its object terminates with the execution of return statement, although the object can be later reactivated. If}{\plain \f5\lang1036 \r
+ such a class is declared as a coroutine, then its objects may be reactivated. This can be realized by attach statement:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 attach(X) \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 where X is a reference variable designating the activating coroutine object.\r
+\par }\pard \qj {\plain \f5\lang1036 In general, since the moment of generation a coroutine object is either ac\-tive or suspended. Any reactivation of a suspended coroutine object X (by attach(X)) causes the active coroutine object to be suspended and conti\r
+\-nues the execution of X from th}{\plain \f5\lang1036 e statement following the last execut}{\plain \f5\lang1036 ed one.\r
+\par }\pard \qj {\plain \f5\lang1036 Main program is also a coroutine. It is accessed through the standard va\-riable main and may be reactivated (if suspended) by the statement atta\-ch(main). \r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard \qj {\plain \f5\lang1036 \r
+In the example below the cooperation of two coroutines is presented. One reads the real values from an input device, another prints these values in columns on a line-printer, n numbers in a line. The input stream ends with 0.\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b program} prodcons;\line {\b var} prod:producer,cons:consumer,n:integer,mag:real,last:bool; \line {\b unit} producer: {\r
+\b coroutine}; \line {\b begin} \line {\b return}; \line {\b do} \line read(mag); (* mag- nonlocal variable, common store *)\line {\b if} mag=0 \line {\b then} (* end of data *) \line last:={\r
+\b true};\line {\b exit} \line {\b fi}; \line attach(cons); \line {\b od}; \line attach(cons) \line {\b end} producer; \line {\b unit} consumer: {\b coroutine}(n:integer); \line {\b var} Buf:{\b \r
+arrayof} real; \line {\b var} i,j:integer; \line {\b begin} \line {\b array} Buf {\b dim}(1:n); \line {\b return}; \line {\b do} \line {\b for} i:=1 {\b to} n \line {\b do} \line Buf(i):=mag;\line \r
+ attach(prod); \line {\b if }last{\b then exit exit fi}; \line {\b od}; \line {\b for} i:=1 {\b to} n \line {\b do} (* print Buf *) \line write(' ',Buf(i):10:2)\line {\b od}; \line \r
+ writeln;\line {\b od}; \line (* print the rest of Buf *)\line {\b for} j:=1 {\b to} i {\b do} write(' ',Buf(j):10:2) {\b od}; \line writeln;\line attach(main); \line {\b end} consumer; \line {\b begin} \line prod:=\r
+{\b new} producer; \line read(n);\line cons:={\b new} consumer(n); \line attach(prod); \line writeln;\line {\b end} prodcons; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 The above task could be programmed without coroutines at all. The pre\-sented solution is, however, strictly modular, i.e. one unit realizes the in\-\r
+put process, another realizes the output process, and both are ready to cooperate with each other.\r
+\par }\pard \qj {\plain \f5\lang1036 LOGLAN-82 provides also a facility for the semi-coroutine operations. This is gained by the simple statement detach. If X is the active coroutine object, then detach reactivates that coroutine object\r
+ at where the last at\-tach(X) was executed. This }{\plain \f5\lang1036 statement meets the need for the asymetric co\-routine cooperations. (by so it is called semi-coroutine operation). Opera\-\r
+tion attach requires a reactivated coroutine to be defined explicitly by the user as an actual parameter. Operation detach correspond}{\plain \f5\lang1036 s in some man\-\r
+ner to return in procedures. It gives the control back to a coroutine object where the last attach(X) was executed, and that coroutine object need not be known explicitly in X. This mechanism is, however, not so secure as the normal control }{\plain \r
+\f5\lang1036 tr}{\plain \f5\lang1036 ansfers during procedure calls and returns.\r
+\par }\pard \qj {\plain \f5\lang1036 In fact, the user is able to loop two coroutines traces by :\r
+\par }\pard \qj {\plain \f5\lang1036 }{\plain \b\f5\lang1036 attach}{\plain \f5\lang1036 (Y) in X }{\plain \b\f5\lang1036 attach}{\plain \f5\lang1036 (X) in Y \r
+\par }{\plain \f5\lang1036 Then }{\plain \b\f5\lang1036 detach}{\plain \f5\lang1036 in X reactivates Y, }{\plain \b\f5\lang1036 detach}{\plain \f5\lang1036 in Y reactivates X. \r
+\par }\pard \qj {\plain \f5\lang1036 In the example below the application of detach statement is illustrated.\r
+\par }\pard {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b program} reader_writers; \line \r
+(* In this example a single input stream consisting of blocks of numbers, each ending with 0, is printed on two printers of different width. The choice of the printer is determined b\r
+y the block header which indicates the desired number of print columns. The input stream ends with a double 0. m1 - the width of printer_1, m2 - the width of printer_2 *)\line {\b const} m1=10,m2=20; \line {\b var}\r
+ reader:reading,printer_1,printer_2:writing; \line {\b var} n:integer,new_sequence:boolean,mag:real; \line \line {\b unit} writing:{\b coroutine}(n:integer); \line \r
+ {\b var} Buf: {\b arrayof} real, i,j:integer; \line {\b begin} \line {\b array} Buf {\b dim} (1:n); (* array generation *) \line {\b return};(* return terminates coroutine initialization *) \line {\b do} \line \r
+ attach(reader); (* reactivates coroutine reader *)\line {\b if} new_sequence \line {\b then} \line (* a new sequence causes buffer Buf to be cleared up *)\line {\b for} j:=1 {\b to} i {\b do}\r
+ write(' ',Buf(j):10:2) {\b od};\line writeln;\line i:=0; new_sequence:=false; attach(main) \line {\b else} \line i:=i+1; Buf(i):=mag;\line {\b if} i=n \line {\b then} \line {\b for} j:=1 \r
+{\b to} n {\b do} write(' ',Buf(j):10:2) {\b od};\line writeln;\line i:=0;\line {\b fi} \line {\b fi} \line {\b od} \line {\b end} writing; \line {\b unit} reading: {\b coroutine}; \line {\b begin} \r
+\line {\b return}; \line {\b do} \line read(mag);\line {\b if} mag=0 {\b then} new_sequence:={\b true}; {\b fi}; \line detach;\line (* detach returns control to printer_1 or printer_2 \tab \tab \tab \tab \tab \r
+\tab \tab depending which one reactivated the reader *)\line {\b od} \line {\b end} reading; \line {\b begin} \line reader:={\b new} reading; \line printer_1:={\b new} writing(m1); printer_2:={\b new} writing(m2);\line {\b do} \r
+\line read(n);\line {\b case} n \line {\b when} 0: exit \line {\b when} m1: attach(printer_1) \line {\b when} m2: attach(printer_2) \line {\b otherwise} write(" wrong data"); exit \line {\b esac\r
+ \line od \line end}; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \r
+\par }\pard \qj {\plain \f5\lang1036 Coroutines play the substantial role in process simulation. Class Simula\-tion provided in Simula-67 makes use of coroutines at most degree. LO\-GLAN-82 provides for easy simulation as well. The LOGLAN-82 class Simu\-\r
+lation is implemented on a heap what giv}{\plain \f5\lang1036 es lg(n) time cost}{\plain \f5\lang1036 (in contrast with O(n) cost of the original implementation). It covers also various simu\-lation problems of large size and degree of complexity.\r
+\r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 7. Prefixing\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Classes and prefixing are ingenius inventions of Simula-67(cf [1]). Unfor\-\r
+tunately they were hardly ever known and, perhaps, by this have not been introduced into many programming language that gained certain popularity. Moreover, implementa\-tion constra}{\plain \f5\lang1036 \r
+ints of Simula-67 bind prefixing and classes workableness to such a degree that both faciliti}{\plain \f5\lang1036 \r
+es cannot be used in all respects. We hope that LOGLAN-82, adopting merits and rooting up deficiencies of these constructs, will smooth their variations and vivify theirs usefulness.\r
+\par }\pard \qj {\plain \f5\lang1036 What is prefixing ? First of all it is a method for unit extending. Consider the simplest example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} bill: {\b class}; \line {\b var} dollars :real,\line not_paid :boolean,\line \r
+ year,month,day :integer;\line {\b end} bill; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Assume the user desires to extend this class with new attributes. Instea}{\plain \f5\lang1036 d of writing a completely new class, he may enlarge the existing one:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} gas_bill:bill {\b class}; \line {\b var} cube_meters: real; \line {\b end} gas_bill; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ Class gas_bill is prefixed by class bill. This new declaration may appear anywhere within the scope of declaration of class bill. (In Simula-67 such a prefixing is forbidden in nested units.) Class gas_bill has all the attributes of class bill and additi\r
+}{\plain \f5\lang1036 onally its own attributes (in this case the only one: cube_meters). The generation statement of this class}{\plain \f5\lang1036 has the form:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 z:={\b new} gas_bill; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 where z is a reference variable of type gas_bill. Remote access to the attri\-butes of prefixed class is standard:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 z.dollars:=500.5; z.year:=1982; z.month:=3; z.day:=8;\line z.cube_meters:=100000;\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \line Consider now the example of a class with parameters.\r
+\par }\pard {\plain \f5\lang1036 Assume that in a program a class:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} id_card: {\b class}(name:string,age:integer); \line {\b end} id_card; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 and its extension:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} idf_card:id card {\b class}(first name:string); \line {\b end} idf_card; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 are declared.\r
+\par }\pard \qj {\plain \f5\lang1036 Then for variabl}{\plain \f5\lang1036 e z of type id_card and variable t of type idf_card the cor\-responding generation statement may be the following:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 z:={\b new} id_card("kreczmar",37); \line t:={\b new} idf_card("Kreczmar",37,"Antoni"); \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Thus the formal parameters of a class are concatenated with the formal parameters of its prefix.\r
+\par }\pard \qj {\plain \f5\lang1036 One can still extend class idf_card. For instance:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} idr_card:idf_card {\b class}; \line {\b var} children_number:integer; \line {\b var} birth_place:string; \r
+\line {\b end} idr_card; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Prefixing allows to build up hierarchies}{\plain \f5\lang1036 \r
+ of classes. Each one hierarchy has a tree structure. A root of such a tree is a class without prefix. One class is a successor of another class iff the first is prefixed by the latter one.\r
+\par }\pard {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 Consider the prefix structure:\r
+\par }\pard \keep {\plain \f7\lang1036 A\r
+\par }{\plain \f7\lang1036 . . .\r
+\par }{\plain \f7\lang1036 . . .\r
+\par }{\plain \f7\lang1036 . . .\r
+\par }{\plain \f7\lang1036 B. .C .D\r
+\par }{\plain \f7\lang1036 .\r
+\par }{\plain \f7\lang1036 .\r
+\par }{\plain \f7\lang1036 .E\r
+\par }{\plain \f7\lang1036 .\r
+\par }{\plain \f7\lang1036 .\r
+\par }{\plain \f7\lang1036 .F\r
+\par }{\plain \f7\lang1036 . .\r
+\par }{\plain \f7\lang1036 }{\plain \f7\lang1036 . .\r
+\par }{\plain \f7\lang1036 G. .H\r
+\par }\pard \qj {\plain \f5\lang1036 Class H has a prefix sequence A, B, E, F, H. Let a, b, ... , h denote the cor\-responding unique attributes of classes A, B, ... , H, respectively. The ob\-jects of these classes have the following forms: \r
+\par }\pard {\plain \f5\lang1036 \r
+\par }\pard \keep {\plain \f6\lang1036 \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line \'b3\r
+ }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3\r
+\line \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \f7\lang1036 object A }\r
+{\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 b}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 c}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 d}{\plain \f6\lang1036 \'b3\line }{\plain \r
+\f6\lang1036 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9\line }{\plain \f7\lang1036 object B}{\plain \f6\lang1036 }\r
+{\plain \f7\lang1036 object C}{\plain \f6\lang1036 }{\plain \f7\lang1036 object D}{\plain \f6\lang1036 \line \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\r
+\'c4\'c4\'c4\'bf \'da\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'bf\line \'b3 }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 a}{\plain \r
+\f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 a}{\plain \f6\lang1036 \'b3\line \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line \'b3 }{\plain \f7\lang1036 b}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 b }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 b }{\plain \f6\lang1036 \'b3 \'b3 }\r
+{\plain \f7\lang1036 b}{\plain \f6\lang1036 \'b3\line \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\r
+\'c4\'b4\line \'b3 }{\plain \f7\lang1036 e}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 e}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 e }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 e}{\plain \r
+\f6\lang1036 \'b3\line \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'b3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4}{\plain \f6\lang1036 \'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\r
+\line }{\plain \f7\lang1036 object E}{\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 f }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 f}{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 f}{\plain \f6\lang1036 \r
+ \'b3\line \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4 \'c3\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'b4\line }{\plain \f7\lang1036 object F}{\plain \r
+\f6\lang1036 \'b3 }{\plain \f7\lang1036 g }{\plain \f6\lang1036 \'b3 \'b3 }{\plain \f7\lang1036 h}{\plain \f6\lang1036 \'b3\line \'c0\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'d9 \'c0\'c4\'c4\'c4\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'d9\line }{\plain \f5\lang1036 \tab \tab \tab \tab }{\plain \f7\lang1036 object G object H}{\plain \f5\lang1036 \r
+\par }\pard {\plain \f5\lang1036 \r
+\par }\pard \qj {\plain \f5\lang1036 Let Ra, Rb,..., Rh denote reference variables of types A, B,..., H, respecti\-vely. Then the following expressions are correct:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 Ra.a, Rb.b, Rb.a, Rg.g, Rg.f, Rh.h, Rh.f, Rh.e, Rh.b, Rh.a etc.\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Variable Ra may designate the object of class B (or C,..., H), i.e. the state\-ment:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 Ra:={\b new} B \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+is legal. But then attribute b is not accessible through dot via Ra, i.e. Ra.b is incorrect. This follows from insecurity of such a remote access. In fact, variable Ra may point any object of a class prefixed by A, in particular, Ra may point the object o\r
+}{\plain \f5\lang1036 f A itself, which has no attribute b. If Ra.b had been correct, a compiler should have distiguish the cases Ra points to the object }{\plain \f5\lang1036 of A or not. But this, of course, is undistinguishable at compilation time.\r
+\r
+\par }\pard \qj {\plain \f5\lang1036 To allow, however, the user's access to attribute b (after instruction }{\f7 Ra:=}{\b\f7 new}{\f7 B}{\plain \f5\lang1036 ), the instantaneous type modification is provided within the lan\-guage:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 Ra {\b qua} B \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ The correctness of this expression is checked at run time. If Ra designates an object of B or prefixed ba B, the type of the expression is B. Otherwise the expression is erroneous. Thus, for instance, the expressions:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 Ra {\b qua} G.b, Ra {\b qua} G.e etc. \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 enable remote access to the attributes b, c, ... via Ra.\r
+\par }\pard \qj {\plain \f5\lang1036 So far the question of attribute concatenation was merely discussed. Ho\-wever the sequences of statements can be also concatenated.\r
+\par }\pard \qj {\plain \f5\lang1036 Consider class B prefixed with class A. In the sequence of statements of class A the keyword inner may occur anywhere, but only once. The se\-\r
+quence of statements of class B consists of the sequence of statements of class A with inner replaced by the sequ}{\plain \f5\lang1036 ence of statements of class B.\r
+\par }\pard \keep {\plain \f6\lang1036 \line }{\plain \b\f7\lang1036 unit}{\plain \f7\lang1036 A :}{\plain \b\f7\lang1036 class}{\plain \f7\lang1036 }{\plain \f7\lang1036 }{\plain \b\f7\lang1036 unit}{\plain \f7\lang1036 B:A }{\plain \r
+\b\f7\lang1036 class}{\plain \f7\lang1036 \r
+\par }\pard \keep {\plain \f7\lang1036 ... ...\r
+\par }\pard \keep {\plain \f7\lang1036 }{\plain \b\f7\lang1036 begin}{\plain \f7\lang1036 }{\plain \b\f7\lang1036 begin}{\plain \f7\lang1036 \r
+\par }\pard \keep {\plain \f7\lang1036 ... }{\plain \f6\lang1036 \'da\'c4\'c4\'c4}{\plain \f7\lang1036 ...}{\plain \f6\lang1036 \r
+\par }\pard \keep {\plain \f6\lang1036 \'b3 }{\plain \f7\lang1036 \tab }{\plain \b\f7\lang1036 inner}{\plain \f6\lang1036 }{\f6\fs18 }{\plain \f6\lang1036 \'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\r
+\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4\'c4}{\f6\fs22 \'c4}{\plain \f6\lang1036 \'c4\'c4\'c4\'b4 }{\plain \b\f7\lang1036 inner}{\plain \f6\lang1036 \r
+\par }\pard \keep {\plain \f6\lang1036 \'b3\r
+\par }\pard \keep {\plain \f6\lang1036 }{\plain \f7\lang1036 ...}{\plain \f6\lang1036 \'c0\'c4\'c4\'c4...\r
+\par }\pard \keep {\plain \f6\lang1036 }{\plain \b\f7\lang1036 end}{\plain \f7\lang1036 A;}{\plain \f6\lang1036 }{\plain \b\f7\lang1036 end}{\plain \f7\lang1036 B; }{\plain \f6\lang1036 \r
+\par }\pard {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }\pard \qj {\plain \f5\lang1036 In this case inner in class B is equivalent to the empty statement}{\plain \f5\lang1036 . If class B prefixes another class, say C, then inner in B is replaced by the se\-\r
+quence of statements of class C, and so on. If inner does not occur expli\-citly, an implicit occurrence of inner before the final end of a class is as\-sumed. \r
+\par }\pard {\plain \f5\lang1036 \line Example\r
+\par }\pard {\plain \f5\lang1036 Let class complex be declared as usual:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} complex:{\b class}(re,im:real); \line {\b end} complex; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 and assume one desires to declare a class mcomplex with the additional attribute module. In order the generation of class mcomplex define the value of at}{\plain \f5\lang1036 \r
+tribute module, one can declare a class:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} mcomplex:complex {\b class}; \line {\b var} module:real; \line {\b begin} \line module:=sqrt(re*re+im*im)\r
+\line {\b end} mcomplex; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Class mcomplex may be still extended:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} pcomplex:mcomplex {\b class}; \line {\b var} alfa:real; \line {\b begin} \line alfa:=arccos(re/module)\r
+\line {\b end} pcomplex; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 For these declarations each generation of class mcomplex defines the va\-lue of attribute module, each generation of class pcomplex defines the va\-lues of attributes module and alfa.\r
+\par }\pard \qj {\plain \f5\lang1036 For reference v}{\plain \f5\lang1036 ariables z1, z2 z3 of type complex, the following sequence of statements illustrates the presented constructs:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 z1:={\b new} complex(0,1); \line z2:={\b new} mcomplex(4,7); \line z3:={\b new} pcomplex(-10,12); \line {\b if} z2 \r
+{\b qua} mcomplex.module > 1 \line {\b then} \line z1:=z2;\line {\b fi}; \line {\b if} z3 {\b qua} pcomplex.alfa < 3.14 \line {\b then} \line z3.re:=-z3.re; z3.alfa:=z3.alfa+3.14;\line {\b fi}; \line z1 {\b qua}\r
+ mcomplex.module:= 0; \line z1.re,z1.im:=0; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Example:\r
+\par }\pard \qj {\plain \f5\lang1036 Binary search tree (Bst) is a bina}{\plain \f5\lang1036 ry tree where for each node x the nodes in the left subtree are less than x, the nodes in the right subtree are grea\-\r
+ter than x. It is the well-known exercise to program the algorithms for the following operations on Bst: \tab \r
+\par }\pard {\plain \f5\lang1036 \tab member(x) = true iff x belongs to Bst\r
+\par }{\plain \f5\lang1036 \tab insert(x), enlarge Bst with x, if x does not yet belong to Bst\r
+\par }{\plain \f5\lang1036 We define both these operations in a class:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} Bst: {\b class}; \line {\b unit} node: {\b class}(value:integer); (* tree node *) \line {\b var}\r
+ left,right:node; \line {\b end} node; \line {\b var} root:node; \line {\b unit} help: {\b class}(x:integer); (* auxiliary class *) \line {\b var} p,q:node; \line {\b begin} \line q:=root;\line {\b while}\r
+ q=/= none \line {\b do} \line {\b if} x < q.value \line {\b then} \line p:=q; q:=q.left;\line {\b repeat} (* jump to the beginning of a loop *) \line {\b fi}; \line {\b if}\r
+ q.value < x \line {\b then} \line p:=q; q:=q.right; {\b repeat} \line {\b fi}; \line {\b exit} \line {\b od}; \line {\b inner}\line (* virtual instruction to be\'ffreplaced by the body of\line \r
+ a module prefixed by help *)\line {\b end} help; \line {\b unit} member:help {\b function}:boolean; \line (* x is a formal parameter derived from the prefix help *)\line {\b begin} \line {\b result}:=q=/=none \line {\b \r
+end} member; \line {\b unit} insert:help {\b procedure}; \line (* x is a formal parameter derived from the prefix help *)\line {\b begin} \line {\b if} q=/=none {\b then return fi}; \line q:={\b new} node(x); \line {\b if\r
+} p=none {\b then} root:=q; {\b return fi}; \line {\b if} p.value < x {\b then} p.right:=q {\b else} p.left:=q {\b fi}; \line {\b end} insert; \line {\b begin} \line {\b inner}; \line {\b end} Bst; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 In the example the common actions of member and insert are program\-\r
+med in class help. Then it suffices to use class help as a prefix of function member and procedure insert, instead of redundant occurrences of the corresponding sequence of statements in }{\plain \f5\lang1036 both units. \r
+\par }\pard {\plain \f5\lang1036 Class Bst may be applied as follows:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b var} X,Y:Bst; \line {\b begin} \line X:={\b new} Bst; Y:={\b new} Bst; \line {\b call} X.insert(5); \r
+\line {\b if} Y.member(-17) {\b then} .... \line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 As shown in the declaration of Bst, c}{\plain \f5\lang1036 lass may prefix not only other classes but also procedures and functions. Class may prefix blocks as well.\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard {\plain \f5\lang1036 Let class push_down (p. 5) prefix a block:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b pref} push_down(1000) {\b block} \line {\b var} ... \line {\b begin} \line ...\line {\b call}\r
+ push(50); ... \line i:=pop;\line ...\line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 In the above block prefixed with class push_down one can use pop and push as local attributes. (They are local since the block is embedded in the prefix push down.)\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b pref} push down(1000) {\b block} \line {\b begin} \line ...\line {\b pref} Bst {\b block} \line {\b \r
+begin} \line (* in this block both structures\line push down and Bst are visible *)\line {\b call} push(50); \line {\b call} insert(13); \line {\b if} member(10) {\b then} ... \line i:=pop;\line \r
+ ...\line {\b end \line end \r
+\par }\pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ In place where classes push_down and Bst are visible together a block prefixed with Bst may be nested in a block prefixed with push_down (or vice versa). In the inner block both data structures are directly accessible. Note that this}{\plain \r
+\f5\lang1036 construct is illegal in Simula 67. \r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 8. Formal types\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Formal types serve for unit parametrization with respect to any non-pri\-mitive type.\r
+\par }\pard {\plain \f5\lang1036 Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} Gsort:{\b procedure}({\b type} T; A:{\b arrayof} T; {\b function} less\line \tab \tab \tab \tab \tab \tab \tab \r
+ (x, y: T): boolean);\line {\b var} n,i,j:integer; var x:T; \line {\b begin } \line n:=upper(A);\line {\b for} i:=2 {\b to} n \line {\b do} \line x:=A(i); j:=i-1;\line {\b do} \line {\b if} less(A(j),x) {\b \r
+then exit fi}; \line A(j+1):=A(j); j:=j-1;\line {\b if} j=0 {\b then exit fi};\line {\b od}; \line A(j+1):=x;\line {\b od} \line {\b end} Gsort; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+Procedure Gsort (the generalization of procedure sort from p.4) has type parameter T. A corresponding actual parameter may be an arbitrary non-primitive type. An actual parameter corresponding to A should be an array of elements of the actual type T. Func\r
+}{\plain \f5\lang1036 tion less should define the linear or\-dering on the domain T.\r
+\par }\pard \qj {\plain \f5\lang1036 For instance, the array A of type bill (cf p.7) may be sorted with respect to attribute dollars , if the function:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} less: {\b function}(t,u:bill):boolean; \line {\b begin} \line {\b result}:=t.dollars <= u.dollars\line {\b \r
+ end} less;\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 is used as an actual parameter:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b call} Gsort(bill,A,less); \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 If the user desires to sort A with respect to date, it is sufficient to declare :\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} earlier:{\b function}(t,u:bill):boolean; \line {\b begin} \line {\b if} t.year < u.year {\b then result}\r
+:= true; {\b return fi}; \line {\b if} t.year=u.year \line {\b then} \line {\b if} t.month < u.month {\b then result}:=true; {\b return fi}; \line {\b if} t.month=u.month {\b then result}:=t.day<=u.day {\b fi} \line {\b fi}; \r
+\line {\b end} earlier; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 and to call: call Gsort(bill,A,ea}{\plain \f5\lang1036 rlier); \r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 9. Protection techniques\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ Protection techniques ease secure programming. If a program is large, uses some system classes, is designed by a team etc., this is important (and non-trivial) to impose some restrictions on access to non-local attri\-butes.\r
+\par }\pard \qj {\plain \f5\lang1036 Let us consider a data structure declared as a class. Some of its attributes should be accessible for the class users, the others should not. For ins\-\r
+tance, in class Bst (p.7) the attributes member and insert are to be acces\-sible. On the other }{\plain \f5\lang1036 hand the attributes root, node and help should not be accessible, even for a meddlesome user. An improper use of them may jeo\-\r
+pardize the data structure invariants.\r
+\par }\pard \qj {\plain \f5\lang1036 To forbid the access to some class attributes the three following protection mechanisms are provided:\r
+\par }\pard {\plain \b\f7\lang1036 close, hidden, }{\plain \f5\lang1036 and}{\plain \b\f7\lang1036 taken. \r
+\par }\pard \qj {\plain \f5\lang1036 The protection close defined in a class forbids remote access to the speci\-fied attributes. For example, consider the class declaration:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} A: {\b class}; \line {\b close} x,y,z; \line {\b var} x: integer, y,z:real; \line ....\line {\b end}\r
+ A \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Remote access to the attributes x,y,z from outside of A is forbidden.\r
+\par }\pard \qj {\plain \f5\lang1036 The protection hidden (with akin syntax) does not allow to use the speci\-fied attributes form outside of A neither by the remote access nor in the units prefixed by A. The only way to use a hidden attribute is to use it wi\r
+\-thin the body of class A.Prote}{\plain \f5\lang1036 ction taken defines these attributes derived from prefix, which the user wishes to use in the prefixed unit. Consider a unit B prefixed by a class A. In unit}{\plain \f5\lang1036 \r
+ B one may specify the attributes of A which are used in B. This protects the user against an unconscious use of an attribute of class A in unit B (because of identifier conflict). When taken list does not occur, then by default, all non-hidden attributes\r
+}{\plain \f5\lang1036 of class A are accessible in unit B. \r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 10. Programmed deallocation\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 The classical methods implemented to deallocate class objects are based on reference counters or garbage collection. Sometimes the both methods may be combined. A reference counter is }{\plain \r
+\f5\lang1036 \r
+a system attribute holding the number of references pointing to the given object. Hence any change of the value of a reference variable X is followed by a corresponding increase or decrease of the value of its reference counter. When the reference counter\r
+}{\plain \f5\lang1036 becomes equal 0, the object can be deallocated.\r
+\par }\pard \qj {\plain \f5\lang1036 The deallocation of class objects may also occur during the process of garbage collection. During this process all unreferenced objects are found and removed (while memory may be compactified). In order to}{\plain \r
+\f5\lang1036 keep the garbage collector able to collect all the garbage, the user should clear all reference variables , i.e. set to None, whenever possible. This system has many disadvantages. First of all, the programmer is forced to clear all refe\-\r
+rence variables,}{\plain \f5\lang1036 even those which are of auxiliary character. Moreover, garbage collector is a very expensive mechanism and thus it can be used only in emergency cases.\r
+\par }\pard \qj {\plain \f5\lang1036 In LOGLAN a dual operation to the object generator, the so-called object deallocator is provided. Its}{\plain \f5\lang1036 syntactic form is as follows:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 kill(X) \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 where X is a reference expression. If the value of X points to no object (none) then kill(X) is equivalent to an empty statement. If the\r
+ value of X points to an object O, then after the execution of kill(X), the object O is deallocated. Moreover all ref}{\plain \f5\lang1036 erence variables which pointed to O are set to none. This deallocator provides full }{\plain \i\f5\lang1036 security\r
+}{\plain \f5\lang1036 , i.e. the attempt to access the deallocated object O is checked and results in a run-time error.\r
+\par }\pard {\plain \f5\lang1036 For e}{\plain \f5\lang1036 xample:\r
+\par }\pard\plain \s3\qj\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 Y:=X; kill(X); Y.W:=Z; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 causes the same run-time error as:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 X:=none; X.W:=Z; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 \r
+ The system of storage management is arranged in such a way that the frames of killed objects may be immediately reused without the necessity of calling the garbage collector, i.e. the relocation is performed automati\-\r
+cally. There is nothing for it but to}{\plain \f5\lang1036 remember not to use remote access to a killed object. (Note that the same problem appears when remote access X.W is used and X=none). \r
+\par }\pard {\plain \f5\lang1036 \line \r
+\par }\pard {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 E}{\plain \f5\lang1036 xample:\r
+\par }\pard \qj {\plain \f5\lang1036 Below a practical example of the programmed deallocation is presented. Consider class Bst (p.7). Let us define a procedure that deallocates the whole tree and is called with the termination of the class Bst.\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} Bst:{\b class}; \line (* standard declarations list of Bst *)\line {\b unit} kill_all:{\b procedure}\r
+(p:node); \line (* procedure kill_all deallocates a tree with root p *)\line {\b begin} \line {\b if} p= none {\b then return fi}; \line {\b call} kill_all(p.left); \line {\b call} kill_all(p.right); \line kill(p) \line {\b \r
+end} kill_all; \line {\b begin \line inner}; \line {\b call} kill_all(root) \line {\b end} Bst; \r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 Bst may be applied as a prefix:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b pref} Bst {\b block} \line ...\line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 and automatically will cause the deallocation of the whole tree after return to call kill_all(root) from the prefixed block. \r
+\par }{\plain \f5\lang1036 To use properly this structure by remote accessing one must call kill_all by himself:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} var X,Y:Bst; \line ...\line {\b begin} \line X:={\b new} Bst; Y:={\b new} Bst; \line ...\line \r
+ (* after the structures' application *)\line {\b cal}{\b l} X.kill_all(X.root); \line kill(X); \line {\b call} Y.kill_all(Y.root); \line kill(Y); \line ...\line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Finally note that deallocator kill enables deallocation of array objects, and suspended coroutines and processes as well (cf p.13). \r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 11. Exception handling\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Exceptions are events that cause interruption of normal program execu\-\r
+tion. One kind of exceptions are those which are raised as a result of some run time errors. For instance, when an attempt is made to access a killed object, when the res}{\plain \f5\lang1036 \r
+ult of numeric operation does not lie within the range, when the dynamic storage allocated to a program is exceeded etc.\r
+\par }\pard \qj {\plain \f5\lang1036 Another kind of exceptions are those which are raised explicitly by a user (with the execution of the raise statement).\r
+\par }\pard \qj {\plain \f5\lang1036 The response to exceptions (one or more) is defined by an exception han\-dler. A handler may appear at the end of declarations of any unit. The cor\-\r
+responding actions are defined as sequences of statements preceded by keyword when and an exception identif}{\plain \f5\lang1036 ier. \r
+\par }\pard {\plain \f5\lang1036 Ex}{\plain \f5\lang1036 ample:\r
+\par }\pard \qj {\plain \f5\lang1036 In procedure squareeq (p.3) we wish to include the case when a=0. It may be treated as an exception (division by zero).\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} squareeq(a,b,c:real;{\b output} xr,xi,yr,yi:real); \line {\b var} delta:real; \line {\b handlers} \line \r
+ {\b when} division_by_zero: \line {\b if} b =/= 0 \line {\b then} \line xi,yr,yi:=0; xr:=-c/b; {\b terminate} \line {\b else} \line {\b raise} Wrong_data(" no roots") \line {\b fi}; \line {\b \r
+end} \line {\b begin} \line ...\line {\b end} squareeq; \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 The handler declared in that procedure handles the only }{\plain \f5\lang1036 one exception (division_by_zero).\r
+\par }\pard \qj {\plain \f5\lang1036 \r
+ When an exception is raised, the corresponding handler is searched for, starting from the active object and going through return traces. If there is no object containing the declaration of the handler, then the program (or the corresponding process) is t\r
+}{\plain \f5\lang1036 erminated. Otherwise the control is trans\-ferred to the first found handler. \r
+\par }\pard \qj {\plain \f5\lang1036 In our example the handler is declared within the unit itself, so control is passed to a sequence:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b if} b=/=0 ...\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Therefore, when b}{\plain \f5\lang1036 =/=0, the unique root of square equation will be deter\-mined and the procedure will be normally terminated (terminate). In ge\-\r
+neral, terminate causes that all the objects are terminated, starting from that one where the exception was raised and ending}{\plain \f5\lang1036 on that one where the handler was found. Then the computation is continued in a normal way.\r
+\par }\pard \qj {\plain \f5\lang1036 In our example, when b=0, a new exception is raised by the user. For this kind of exceptions , the exception itself should be declared (because it is not predefi}{\plain \f5\lang1036 \r
+ned as a run time error). Its declaration may have parameters which are transmitted to a handler. The exception declaration need not be visible by the exception handler. However the way the handler is searched for does not differ from the standard one. C\r
+}{\plain \f5\lang1036 onsider an example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b block}\line {\b signal} Wrong_data(t:string); \line {\b unit} squareeq: \line ...\r
+\line {\b end} squareeq;\line ...\line {\b begin} \line ...\line {\b end} \r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Exception Wrong_data may be raised wherever its declaration (signal Wrong_data) is v}{\plain \f5\lang1036 \r
+isible. When its handler is found the specified sequence of actions is performed. In the example above different handlers may be defi\-ned in inner units to the main block where squereeq is called.\r
+\par }\pard \qj {\plain \f5\lang1036 The case a=0 could be included}{\plain \f5\lang1036 , of course, in a normal way, i.e. by a cor\-\r
+responding conditional statement occurring in the procedure body. But the case a=0 was assumed to be exceptional (happens scarcely). Thus the eva\-luation of condition a=0 would be mostly unnecessary. As can be n}{\plain \f5\lang1036 \r
+oticed thanks to exception}{\plain \f5\lang1036 s the above problem can be solved with the minimal waste of run time. \r
+\par }\pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 12. Concurrent processes.\r
+\par \pard\plain \qj \fs20\lang1036 {\plain \f5\lang1036 Loglan allows to create and execute objects-processes. They can operate simultaneously on different computers linked into a LAN network or a few processes can share one processor (its time-slices).\r
+\r
+\par }\pard \qj {\plain \f5\lang1036 Process modules are different from the classes and coroutines for, they use the keyword process. The syntax of process modules is otherwise the same. In a process one can use a few more instructions: resum}{\plain \r
+\f5\lang1036 e (resume a process which is passive), stop - make the current process passive, etc. \r
+\par }\pard \qj {\plain \f5\lang1036 All processes (even those executed on the same computer) are implemen\-ted as distributed, i.e. without any shared memory. This fact implies some restrictions on how processes may be used. Not all restrictions are enfor\-\r
+ced by the present compiler, so it }{\plain \f5\lang1036 is the programmer's responsibility to respect them. For the details see the User's Manual.\r
+\par }\pard \qj {\plain \f5\lang1036 Semantics of the generator }{\plain \b\f5\lang1036 new}{\plain \f5\lang1036 is slightly modified when applied to the p}{\plain \f5\lang1036 rocesses. The first parameter of the first process unit in the prefix se\-\r
+quence must be of type INTEGER. This parameter denotes the node num\-ber of the computer on which this process will be created. For a single computer operation this parameter must be }{\plain \f5\lang1036 equal to 0.\r
+\par }\pard {\plain \f5\lang1036 \line Example:\r
+\par }\pard\plain \s3\li567\sb120\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b unit} A:{\b class}(msg:string);\line ...\line {\b end} A;\line {\b unit} P:A {\b process}(node:integer, pi:real);\line ...\r
+\line {\b end} P;\line ...\line {\b var} x:P;\line ...\line {\b begin}\line ...\line (* Create process on node 4. The first parameter is the *) \line (*string required by the prefix A, the second is the node number *)\line x := {\b new}\r
+ P("Hello", 4, 3.141592653);\line ...\line {\b end}\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 COMMUNICATION MECHANISM\r
+\par }{\plain \f5\lang1036 \r
+\par }\pard \qj {\plain \f5\lang1036 Processes may communicate and synchronize by a mechanism based on rendez-vous. It will be referred to as "alien call" in the following descrip\-tion.\r
+\par }\pard {\plain \f5\lang1036 \tab An alien call is either:\tab \r
+\par }{\plain \f5\lang1036 - a procedure call performed by a remote access to a process object, or\tab \r
+\par }{\plain \f5\lang1036 - a call of a procedure which is a formal parameter of a process, or\tab \r
+\par }\pard \ri-232 {\plain \f5\lang1036 - a call of a procedure which is a formal parameter of an alien-called pro}{\plain \f5\lang1036 \-ce\-du\-re (this is a recursive definition).\r
+\par }\pard \qj {\plain \f5\lang1036 Every process object has an enable mask. It is defined as a subset of all procedures declared directly inside a process unit or any unit from its pre\-fix sequence (i.e. subset of all procedures that may be alien-called).\r
+\r
+\par }\pard \qj {\plain \f5\lang1036 A procedure is enabled in a process if it belongs to that process' enable mask. A procedure is disabled if it does not belong to the enable mask. \r
+\par }{\plain \f5\lang1036 Immediately after generation of a process object its enable mask is empty (all procedures are }{\plain \f5\lang1036 disabled).\r
+\par }\pard \qj {\plain \f5\lang1036 Semantics of the alien call is different from the remote call described in the report. Both the calling process and the process in which the proce\-\r
+dure is declared (i.e. the called process) are involved in the alien call. This way the alien call may be us}{\plain \f5\lang1036 ed as a synchronization mechanism.\r
+\par }\pard \qj {\plain \f5\lang1036 The calling process passes the input parameters and waits for the call to be completed.\r
+\par }\pard \qj {\plain \f5\lang1036 The alien-called procedure is executed by the called process. Execution of the procedure will not begin before certai}{\plain \f5\lang1036 \r
+n conditions are satisfied. First, the called process must not be suspended in any way. The only exception is that it may be waiting during the ACCEPT statement (see below). Se\-cond, the procedure must be enabled in the called process.\r
+\par }\pard \qj {\plain \f5\lang1036 When the above two conditions are met the called process is interrupted and forced to execute the alien-called procedure (with parameters passed by the calling process).\r
+\par }\pard \qj {\plain \f5\lang1036 Upon entry to the alien-called procedure all procedures become disabled in the called process.\r
+\par }\pard \qj {\plain \f5\lang1036 Upo}{\plain \f5\lang1036 \r
+n exit the enable mask of the called process is restored to that from before the call (regardless of how it has been changed during the execution of the procedure). The called process is resumed at the point of the inter\-\r
+ruption. The execution of the ACCE}{\plain \f5\lang1036 PT statement is ended if the called pro\-\r
+cess was waiting during the ACCEPT (see below). At last the calling process reads back the output parameters and resumes its execution after the call statement.\r
+\par }\pard \qj {\plain \f5\lang1036 The process executing an alien-called procedure can }{\plain \f5\lang1036 easily be interrupted by another alien call if the enable mask is changed.\r
+\par }\pard \qj {\plain \f5\lang1036 There are some new language constructs associated with the alien call mechanism. The following statements change the enable mask of a pro\-cess:\tab \r
+\par }\pard \sb120\sa120 {\plain \f5\lang1036 \tab ENABLE p1, ..., pn\tab \r
+\par }\pard \qj {\plain \f5\lang1036 enables the procedures with identifiers p1, ..., pn. If there are any proces\-ses waiting for an alien call of one of these procedures, one of them is cho\-\r
+sen and its request is processed. The scheduling is done on a FIFO basis, so it is strongly fair. The}{\plain \f5\lang1036 statement}{\plain \f5\lang1036 :\tab \r
+\par }\pard \sb120\sa120 {\plain \f5\lang1036 DISABLE p1, ..., pn \tab \r
+\par }\pard {\plain \f5\lang1036 disables the procedures with identifiers p1, ..., pn.\r
+\par }{\plain \f5\lang1036 In addition a special form of the RETURN statement:\tab \r
+\par }\pard \sb120\sa120 {\plain \f5\lang1036 RETURN ENABLE p1, ..., pn DISABLE q1, ..., qn \tab \r
+\par }\pard \qj {\plain \f5\lang1036 \r
+allows to enable the procedures p1, ..., pn and disable the procedures q1,...,qn after the enable mask is restored on exit from the alien-called procedure. It is legal only in the alien-called procedures (the legality is not enforced by the compiler).}\r
+{\plain \f5\lang1036 \r
+\par }\pard \qj {\plain \f5\lang1036 A called process may avoid busy waiting for an alien call b}{\plain \f5\lang1036 y means of the ACCEPT statement:\tab \r
+\par }\pard \sb120\sa120 {\plain \f5\lang1036 \tab ACCEPT p1, ..., pn \tab \r
+\par }\pard \qj {\plain \f5\lang1036 adds the procedures p1, ..., pn to the current mask, and waits for an alien call of one of the currently enabled procedures. After the procedure return the enable mask is restored to that from before the ACCEPT statement.\r
+\r
+\par }\pard \qj {\plain \f5\lang1036 Note that the ACCEPT statement alone (i.e. without any ENABLE/DISABLE statements or options) provides a sufficient communi\-\r
+cation mechanism. In this case the called process may execute the alien-called procedure only during the A}{\plain \f5\lang1036 \r
+CCEPT statement (because otherwise all procedures are disabled). It means that the enable mask may be forgotten altogether and the alien call may be used as a pure totally synchronous rendez-vous. Other constructs are introduced to make partially asynchro\r
+}{\plain \f5\lang1036 \-nous communication patterns possible.\r
+\par }\pard \qj {\plain \f5\lang1036 \r
+\par }{\plain \f5\lang1036 Below find a complete listing of a simple example - monitors.\r
+\par }\pard {\plain \f5\lang1036 \r
+\par }\pard\plain \s3\li567\sb240\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 \f7\fs20\lang1033 {\b program} monitors;\line \line \r
+(* this an example showing 5 processes: two of them are in fact monitors, one controls the screen=ekran *)\line \line {\b unit} ANSI: {\b class}; \line (* CHECK whether config.sys contains a line\line device=ansi.sys\line \r
+ the class ANSI enables operations on cursor,\line and bold, blink, underscore etc. *) \line \line {\b unit} Bold : {\b procedure};\line {\b begin}\line write( chr(27), "[1m")\line {\b \r
+end} Bold;\line \line {\b unit} Blink : {\b procedure};\line {\b begin}\line write( chr(27), "[5m")\line {\b end} Blink;\line \line {\b unit} Reverse : {\b procedure};\line {\b begin}\line write( chr(27), "[7m")\line {\b end}\r
+ Reverse;\line \line {\b unit} Normal : {\b procedure};\line {\b begin}\line write( chr(27), "[0m")\line {\b en}{\b d} Normal;\line \line {\b unit} Underscore : {\b procedure};\line {\b begin}\line write( chr(27), "[4m")\line {\b end\r
+} Underscore;\line \line {\b unit} inchar : IIUWgraph {\b function} : integer;\line (*podaj nr znaku przeslanego z klawiatury *)\line {\b var} i : integer;\line {\b begin}\line {\b do}\line i := inkey;\line {\b if} i <> 0 {\b \r
+then exit fi};\line {\b od};\line {\b result} := i;\line {\b end} inchar;\line \line {\b unit }NewPage : {\b procedure};\line {\b begin}\line write( chr(27), "[2J")\line {\b end} NewPage;\line \line {\b unit} SetCursor : {\b \r
+procedure}(row, column : integer);\line {\b var} c,d,e,f : char,\line i,j : integer;\line {\b begin}\line i := row {\b div} 10;\line j := row {\b mod} 10;\line c := chr(48+i);\line d := chr(48+j);\line i := column {\b \r
+div} 10;\line j := column {\b mod} 10;\line e := chr(48+i);\line f := chr(48+j);\line write( chr(27), "[", c, d, ";", e, f, "H")\line {\b end} SetCursor; \line {\b end} ANSI;\line \line \line {\b unit} monitor: {\b process}\r
+(node:integer, size:integer,e: ekran);\line \line {\b var} buf: {\b arrayof} integer,\line nr,i,j,k1,k2,n1,n2: integer;\line \line \tab \line {\b unit }lire: {\b procedure}({\b output} k: integer);\line {\b begin}\line {\b \r
+call} e.druk(13,2+nr*30+k1,0,k2);\line {\b call} e.druk(13,2+nr*30+(i-1)*6,1,buf(i));\line k1:=(i-1)*6;\line k:=buf(i);\line k2:=k;\line i:= (i {\b mod} size)+1;\line {\b if} i=j\line {\b then}\line {\b \r
+call} e.printtext("i equal j")\line {\b fi}; \line {\b end} lire;\line \line {\b unit} ecrire: {\b procedure}(n:integer);\line {\b begin\line } {\b call} e.druk(13,2+nr*30+n1,0,n2);\line {\b call}\r
+ e.druk(13,2+nr*30+(j-1)*6,2,n);\line n1:=(j-1)*6;\line buf(j) := n;\line n2:=buf(j);\line j := (j{\b mod} size)+1;\line {\b if} i=j\line {\b then}\line {\b call} e.printtext("j equal i")\line {\b fi}; \r
+\line {\b end} ecrire;\line {\b begin}\line {\b arra}{\b y} buf {\b dim}(1:size);\line nr := size - 4;\line {\b for} i := 1 {\b to} size\line {\b do}\line buf(i) := i+nr*4;\line {\b call}\r
+ e.druk(13,2+nr*30+(i-1)*6,0,buf(i));\line {\b od};\line i:=1; \line j := size;\line k1:=0;\line k2:=buf(1);\line n1:=(size-1)*6;\line n2:=buf(size);\line (* end initialize buffer *)\line {\b return};\line \line \r
+ {\b do}\line {\b accept} lire, ecrire\line {\b od}\line {\b end} monitor;\line \line {\b unit} prcs: {\b process}(node,nr:integer, mleft,mright:\line \tab \tab \tab \tab \tab \tab \tab monitor, e: ekran);\line {\b var}\r
+ l,o: integer;\line \line {\b begin}\line {\b call} e.SetCursor(8+(nr-1)*10,29);\line {\b if} nr = 1\line {\b then}\line {\b call} e.printtext("<-- p1 <--");\line {\b else}\line {\b call} e.printtext("--> p2 -->");\line {\r
+\b fi; \line return;\line do}\line {\b call} mleft.lire(l) ;\line {\b call} e.druk(11+(nr-1)*4,31-(nr-1)*8,1,l);\line l:= l+1;\line {\b call} mright.ecrire(l) ; \line {\b call} e.druk(10+(nr-1)*6,23+(nr-1)*8,2,l);\r
+\line {\b if} l {\b mod} 15 = 0 \line {\b then}\line o:= e.inchar;\line \tab {\b if} o = -79 {\b then call endrun fi};\line {\b fi};\tab \line {\b od};\line {\b end }prcs;\line \r
+\par \pard \s3\li567\sb240\sa120\tx851\tx1134\tx1418\tx1701\tx1985\tx2268\tx2552\tqdec\tx2835\tqdec\tx3119 {\b unit} ekran : ANSI {\b process}(nrprocesora: integer);\line {\b unit }printtext{\b : procedure}(s:string);\line {\b begin}\line \r
+ write(s);\line {\b call} Normal;\line {\b end} printtext;\line \line {\b unit }druk: {\b procedure}(gdzieW,gdzieK,jak,co:integer);\line {\b begin}\line {\b call} SetCursor(gdzieW,gdzieK);\line write(" ");\line \r
+{\b if} jak=0 {\b then call} Normal {\b else}\line {\b if} jak=1 {\b then call} Reverse{\b else}\line {\b if} jak=2 {\b then call} Bold \line {\b fi}\line {\b fi}\line {\b fi};\line write(co:3);\line \r
+{\b call} Normal;\line {\b end} druk;\line \line {\b unit} print: {\b procedure} (i:integer);\line {\b begin}\line write(i:4)\line {\b end} print;\line {\b begin\line return};\line \line {\b do accept} inchar, \line \r
+ Normal,NewPage, SetCursor, Bold, Underscore,\line \tab Reverse, Blink, print, printtext, druk\line {\b od}\line {\b end} ekran;\line \line {\b var} m1,m2:monitor,\line e:ekran,\line p1,p2:prcs;\line \line {\b begin\r
+} (* ----- HERE IS THE MAIN PROGRAM ----- *)\line (* create a configuration *)\line e:= {\b new} ekran(0);\line {\b resume}(e);\line {\b call} e.Normal;\line {\b call} e.NewPage;\line m1 := {\b new} monitor(0,4,e);\line m2 := {\b new}\r
+ monitor(0,5,e);\line \line p1 := {\b new} prcs(0,1,m2,m1,e);\line p2 := {\b new} prcs(0,2,m1,m2,e);\line \line {\b resume}(m1);\line {\b resume}(m2);\line {\b resume}(p1);\line {\b resume}(p2);\line {\b end} monitors;\r
+\par \pard\plain \s254\sb840\sa480\keepn \b\f5\fs28\lang1036 {\plain \b\f5\lang1036 \page }References.\r
+\par \pard\plain \fs20\lang1036 {\plain \f5\lang1036 \r
+\par }\pard Bartol,W.M., et al.{\plain \f5\lang1036 \r
+\par }{\i Report on the Loglan 82 programming Language,}{\plain \f5\lang1036 \r
+\par }Warszawa-Lodz, PWN, 1984\r
+\par \pard {\f5 \r
+\par }\pard O.-J. Dahl, B. Myhrhaug, K. Nygaard, \line {\i Simula 67 Common Base Language, \line }Norwegian Computing Center, Oslo, 1970 {\plain \lang1036 the mother of object languages!!}\r
+\par \pard {\f5 \r
+\par }\pard {\f5 Hoare C.A.R.\line }{\i\f5 Monitors, an operating system structuring concept.\r
+\par }\pard {\f5 CACM,vol.17,N.10,October 1974,pp.549-57}\r
+\par \pard \r
+\par {\i Loglan'82 }\r
+\par {\i User's guide}\r
+\par Institute of Informatics, University of Warsaw 1983, 1988\r
+\par LITA, Universit\'e9 de Pau, 1993\r
+\par (distributed together with this package)\r
+\par \r
+\par A.Kreczmar, A.Salwicki, M. Warpechowski, \r
+\par {\i Loglan'88 - Report on the Programming Language,}\r
+\par Lecture Notes on Computer Science vol. 414, Springer Vlg, 1990,\r
+\par ISBN 3-540-52325-1\r
+\par \r
+\par /* if you can read polish, there is a good manual of Loglan */\r
+\par A.Szalas, J.Warpechowska,\r
+\par {\i LOGLAN, }\r
+\par Wydawnictwa Naukowo-Techniczne, Warszawa, 1991 ISBN 82-204-1295-1 \r
+\par \r
+\par \pard {\plain \lang1036 see also the Readings file of this distribution.\r
+\par }{\plain \lang1036 \r
+\par }}
\ No newline at end of file
--- /dev/null
+\r
+\r
+\r
+\r
+\r
+\r
+A micro-manual\r
+\r
+of\r
+\r
+the programming language\r\r
+\r
+\r
+\r
+\r
+L O G L A N - 82\r\r
+\r
+Basic constructs and facilities\r\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+Author: Antoni Kreczmar\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r\r
+Institute of Informatics, Warsaw University\r
+March 1990\r\r\r
+edited by A.Salwicki LITA Pau November 1990\r
+
+Table of contents\r
+\r
+\r
+{TOC \o|1. Compound statements 4\r
+2. Modularity 8\r
+3. Procedures and functions 10\r
+4. Classes 13\r
+5. Adjustable arrays 16\r
+6. Coroutines and semicoroutines 19\r
+7. Prefixing 22\r
+8. Formal types 28\r
+9. Protection techniques 29\r
+10. Programmed deallocation 30\r
+11. Exception handling 32\r
+12. Concurrent processes. 33\r
+References. 40\r
+}\r
+LOGLAN-82 is a universal programming language designed at the Institute of Informatics, University of Warsaw. Its syntax is patterned upon Pascal's. Its rich semantics includes the classical constructs and facilities offered by the Algol-family programming languages as well as more modern facilities, such as concurrency and exception handling.\r\r
+The basic constructs and facilities of the LOGLAN-82 programming language include:\r\r
+1) A convenient set of structured statements,\r\r
+2) Modularity (with the possibility of module nesting and extending),\r\r
+4) Classes (as a generalization of records) which enable to define complex structured types, data structures, packages, etc.,\r\r
+5) Adjustable arrays whose bounds are determined at run-time in such a way that multidimensional arrays may be of various shapes, e.g. triangular, k-diagonal, streaked, etc.,\r\r
+6) Coroutines and semi-coroutines,\r\r
+7) Prefixing - the facility borrowed from Simula-67, substantially generalized in LOGLAN-82 - which enables to build up hierarchies of types and data structures, problem-oriented languages, etc.,\r\r
+8) Formal types treated as a method of module parametrization,\r\r
+9) Module protection and encapsulation techniques,\r\r
+10) Programmed deallocator - a tool for efficient and secure garbage collection, which allows the user to implement the optimal strategy of storage management,\r\r
+11) Exception handling which provides facilities for dealing with run-time errors and other exceptional situations raised by the user,\r\r
+12) Concurrency easily adaptable to any operating system kernel and allowing parallel programming in a natural and efficient way.\r\r
+ The language covers system programming, data processing, and numerical computations. Its constructs represent the state-of-art and are efficiently implementable. Large systems consisting of many cooperating modules are easily decomposed and assembled, due to the class concept and prefixing.\r\r
+ LOGLAN-82 constructs and facilities have appeared and evolved simultaneously with the experiments on the first pilot compiler (implemented on Mera-400 Polish minicomputer). The research on LOGLAN-82 implementation engendered with new algorithms for static semantics, context analysis, code generation, data structures for storage management etc.\r\r
+The LOGLAN-82 compiler provides a keen analysis of syntactic and semantic errors at compilation as well as at run time. The object code is very efficient with respect to time and space. The completeness of error checking guarantees full security and ease of program debugging.\r\r
+1. Compound statements\r\r
+ Compound statements in LOGLAN-82 are built up from simple statements (like assignment statement e.g. x:=y+0.5, call statement e.g. call P(7,x+5) etc.) by means of conditional, iteration and case statements.\r\r
+ The syntax of conditional statement is as follows:\r\r
+ if boolean expression\r
+ then\r \r
+ sequence of statements\r
+ else\r \r
+ sequence of statements\r
+ fi\r \r\r
+where "else part" may be omitted:\r\r
+ if boolean expression\r \r
+ then\r \r
+ sequence of statements\r
+ fi\r \r\r
+ The semantics of conditional statement is standard. The keyword fi\r allows to nest conditional statements without appearence of "dangling else" ambiguity.\r\r\r
+
+Example:\r\r
+ if delta>0\r \r
+ then\r \r
+ x2:=sqrt(delta)/a/2;\r
+ if b=0\r \r
+ then\r \r
+ x1:=x2\r
+ else\r \r
+ x1:=-b/a/2+x2; x2:=x1-2*x2\r
+ fi\r \r
+ else\r \r
+ if delta=0\r \r
+ then\r \r
+ x1:=-b/a/2; x2:=x1\r
+ else\r \r
+ write(" no real roots")\r
+ fi\r \r
+ fi\r \r\r
+ The statements in a sequence of statements are separated with semicolons (semicolon may end a sequence , and then, the last statement in the sequence is the empty statement).\r\r
+ The short circuit control forms are realized in LOGLAN-82 by the conditional statements with orif (or andif) list. A conditional\r statement with orif list has the form:\r orif \r\r
+ if wb1 orif wb2 ... orif wbk\r \r
+ then\r \r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r \r\r
+and corresponds somehow to a conditional statement:\r\r
+ if wb1 or wb2 ... or wbk\r \r
+ then\r \r
+ sequence of statements\r
+ else\r \r
+ sequence of statements\r
+ fi\r \r\r
+ The above conditional statement (without orif list) selects for\r execution one of two sequences of statements, depending on the truth value of the boolean expression:\r\r
+wb1 or wb2 or ... wbk\r \r\r
+which is always evaluated till the end. For the execution of the conditional statement with orif list the specified conditons\r wb1,...,wbk are evaluated in succession, until the first one evaluates to true. Then the rest of the sequence wb1,...,wbk is abandoned and "then part" is executed. If none of the conditions wb1,...,wbk evaluates to true "else part" is executed (if any).\r\r
+ Conditional statements with orif list facilitate to program those con_ditions, which evaluation to the end may raise a run-time error.\r\r
+Example:\r\r
+ The execution of the statement:\r\r
+if i>n or A(i)=0 then i:=i-1 else A(i):=1 fi\r \r\r
+where the value of i is greater than n, and A is an array with upper bound n, will raise the run-time error. Then the user can write:\r\r
+if i>n orif A(i)=0 then i:=i-1 else A(i):=1 fi\r\r
+what allows to avoid this run-time error and probably agrees with his intension. \r\r
+ Conditional statement with andif list has the form:\r\r
+ if wb1 andif wb2 ... andif wbk\r
+ then\r \r
+ sequence of statements\r
+ else\r \r
+ sequence of statements\r
+ fi\r \r\r
+ For the execution of this kind of statements, the conditions wb1,...,wbk are evaluated in succession, until the first one evaluates to false; then "else part" (if any) is executed. Otherwise "then part" is executed.\r\r
+Iteration statement in LOGLAN-82 has the form:\r\r
+do sequence of statements od\r\r
+An iteration statement specifies repeated execution of the sequence of statements and terminates with the execution of the simple statement exit\r\r
+\r
+Example:\r\r
+ s:=1; t:=1; i:=1;\r
+ do\r \r
+ i:=i+1; t:=t*x/i;\r
+ if abs(t) < 1.0E-10 then exit fi; \r
+ s:=s+t\r
+ od;\r \r\r
+ If two iteration statements are nested, then double exit in the\r inner one terminates both of them.\r\r
+Example:\r\r
+r,x:=0;\r
+do\r \r
+ s,t:=1; i:=1; x:=x+0.2;\r
+ do\r \r
+ i:=i+1; t:=t*x/i;\r
+ if i > n then exit exit fi; (* termination of both loops *)\r \r
+ if t < 1 then exit fi; (* termination of the inner loop *)\r
+ s:=s+t\r
+ od\r \r
+od\r \r\r
+ In the example above simultaneous assignment statements are illustrated (e.g. r,x:=0) and comments, which begin with a left parenthesis immediately followed by an asterisk and end with an asterisk immediately followed by a right parenthesis.\r\r
+ Triple exit terminates three nested iteration statements, four exit terminates four nested iteration statements etc.\r\r
+The iteration statement with while condition:\r while \r\r
+ while boolean expression \r
+ do\r \r
+ sequence of statements\r
+ od\r \r\r
+is equivalent to:\r\r
+ do\r \r
+ if not boolean expression then exit fi; \r
+ sequence of statements\r
+ od\r \r\r
+ The iteration statements with controlled variables (for statements)\r have the forms:\r\r
+ for j:=wa1 step wa2 to wa3\r \r
+ do\r \r
+ sequence of statements\r
+ od\r \r\r
+or\r\r
+ for j:=wa1 step wa2 downto wa3 \r
+ do\r \r
+ sequence of statements\r
+ od\r \r\r
+ The type of the controlled variable j must be discrete. The value of this variable in the case of the for statement with to is increased, and in the case of the for statement with downto is decreased. The\r discrete range begins with the value of wa1 and changes with the step equal to the value of wa2. The execution of the for statement with to terminates when the value of j for the first time becomes greater than the value of wa3 (with downto when the value of j for the first time\r becomes less than the value of wa3). After the for statement\r termination the value of its controlled variable is determined and equal to the first value exceeding the specified discrete range. The values of expressions wa1, wa2 and wa3 are evaluated once, upon entry to the iteration statement. Default value of wa2 is equal 1 (when the keyword step and expression wa2 are omitted).\r\r
+ For or while statements may be combined with exit statement. \r\r
+\r
+Example:\r\r
+ for j:=1 to n\r
+ do\r \r
+ if x=A(j) then exit fi; \r
+ od\r \r\r
+ The above iteration statement terminates either for the least j, 1<=j<=n, such that x=A(j) or for j=n+1 when x=/=A(j), j=1,...,n.\r\r
+ To enhance the user's comfort, the simple statement repeat is provided. It may appear in an iteration statement and causes the current iteration to be finished and the next one to be continued (something like jump to CONTINUE in Fortran's DO statements).\r\r
+Example:\r\r
+ i:=0; s:=0;\r
+ do\r \r
+ i:=i+1;\r
+ if A(i)<0 then repeat fi; (* jump to od,iterations are contd.*)\r
+ if i > m then exit fi; (* iteration statement is terminated*) \r
+ s:=s+sqrt(A(i));\r
+ od;\r \r\r
+ Just as exit, repeat may appear in for statement or while statement. Then the next iteration begins with either the evaluation of a new value of the controlled variable (for statement) or with the\r evaluation of the condition (while statement). \r\r
+ Case statement in LOGLAN-82 has the form:\r\r
+ case WA\r \r
+ when L1 : I1\r \r
+ when L2 : I2\r \r
+ ...\r
+ when Lk : Ik\r \r
+ otherwise I\r \r
+ esac\r \r\r
+where WA is an expression , L1,...,Lk are constants and I1,..., Ik,I are sequences of statements.\r\r
+ A case statement selects for execution a sequence of statements Ij, 1{SYMBOL 163 \f "Symbol"}j{SYMBOL 163 \f "Symbol"}k, where the value of WA equals Lj. The choice otherwise covers\r all values (possibly none) not given in the previous choices. The execution of a case statement chooses one and only one alternative (since the choices are to be exhaustive and mutually exclusive).\r
+2. Modularity\r\r
+ Modular structure of the language is gained due to the large set of means for module nesting and extending. Program modules (units) are blocks, procedures, functions, classes, coroutines and processes. Block is the simplest kind of unit. Its syntax is the following:\r\r
+ block\r \r
+ lists of declarations\r
+ begin\r \r
+ sequence of statements\r
+ end\r \r\r
+ The sequence of statements commences with the keyword begin (it may\r be omitted when this sequence is empty). The lists of declarations define the syntactic entities (variables, constants, other units), whose scope is that block. The syntactic entities are identified in the sequence of statements by means of names (identifiers).\r\r
+\r
+Example:\r\r
+ block\r \r
+ const n=250;\r \r
+ var x,y:real, i,j,k: integer, b: boolean;\r \r
+ const m=n+1;\r \r
+ begin\r \r
+ read(i,j); (* read two integers *)\r
+ x,y:=n/(i+j); (* simultaneous assignment *)\r
+ read(c) ; (* read a character *)\r
+ b:= c = 'a'; (* 'a' a character *)\r
+ for k:= 1 to m\r \r
+ do\r
+ write(x+y/k:10:4); (* print the value of x+y/k in the\r
+ field of 10 characters, 4 digits after the point *)\r
+ od\r
+ end\r \r\r
+ In the lists of declarations semicolons terminate the whole lists, not the lists elements. Any declaration list must begin with the pertinent keyword (var for variables, const for constants etc.). The\r value of an expression defining a constant must be determinable statically (at compilation time).\r\r
+ Program in LOGLAN-82 may be a block or alternatively may be of the following form:\r\r
+ program name;\r \r
+ lists of declarations\r
+ begin\r \r
+ sequence of statements\r
+ end\r \r\r
+ Then the whole program can be identified by that name (the source as well as the object code).\r\r
+ A block can appear in the sequence of statements (of any unit), thus it is a statement. (Main block is assumed to appear as a statement of the given job control language.)\r\r
+ For the execution of a block statement the object of block is created in a computer memory, and then, the sequence of statements is performed. The syntactic entities declared in the block are allocated in its object. After a block's termination its object is automatically deallocated (and the corresponding space may be immediately reused).\r\r
+ The modular structure of the language works "in full steam" when not only blocks, but the other kinds of units are also used. They will be described closer in the following points.\r\r
+ Unit nesting allows to build up hierarchies of units and supports security of programming. It follows from the general visibility rules; namely, a syntactic entity declared in an outer unit is visible in an inner one (unless hidden by an inner declaration). On the other hand, a syntactic entity declared in an inner unit is not visible from an outer one.\r\r\r
+
+Example:\r\r
+ program test;\r \r
+ var a,b,c:real, i,j,k:integer;\r \r
+ begin\r \r
+ read(a,b,c,i);\r
+ block\r \r
+ var j,k:real;\r \r
+ begin\r \r
+ j:=a; k:=j+b; write(" this is the inner block ",j,k)\r
+ end;\r \r
+ write(" this is the outer block ",i,a:20)\r
+ end;\r \r\r
+ In this program, first the main block statement is executed (with variables a,b,c,i,j,k). Next, after the read statement, the inner block statement is executed (with variables j,k). In the inner block the global variables j,k are hidden by the local ones.\r\r
+3. Procedures and functions\r\r
+ Procedures and functions are well-known kinds of units. Their syntax is modelled on Pascal's, though with some slight modifications. Procedure (function) declaration consists of a specification part and a body.\r\r \r
+
+Example:\r\r
+ unit Euclid: function(i,j:integer):integer;\r \r
+ var k:integer;\r
+ begin\r \r
+ do\r \r
+ if j=0 then exit fi;\r \r
+ k:=i mod j; i:=j; j:=k\r \r
+ od;\r \r
+ result:=i\r
+ end;\r \r\r
+ Procedure or function specification begins with its identifier preceded by the keyword unit. (The same syntax concerns any other\r module named unit.) Then follows its kind declaration, its formal parameters (if any), and the type of the returned value (only for functions). A body consists of declaration lists for local entities and a sequence of statements. The keyword begin commences the sequence of statements, and is omitted, if this sequence is empty. The value returned by a function equals to the most recent value of the standard variable "result", implicitly declared in any function. This variable can be used as a local auxiliary variable as well.\r\r
+\r
+Example:\r\r
+ unit Newton: function(n,m:integer):integer;\r \r
+ var i:integer; \r
+ begin\r \r
+ if m > n then return fi;\r \r
+ result:=n;\r
+ for i:=2 to m do result:=result*(n-i+1) div i od\r \r
+ end Newton;\r\r
+ The optional identifier at the end of a unit must repeat the identifier of a unit. It is suggested that the compilers check the order of unit nesting, so these optional occurrences of identifiers would facilitate program debugging.\r\r
+ All the local variables of a unit are initialized (real with 0.0, integer with 0, boolean with false etc.). Thus , for instance, the value of function Newton is 0 for m>n, since "result" is also initialized, as any other local variable.\r\r
+ The return statement (return) completes the execution of a procedure (function) body,i.e. return is made to the caller. If return does not\r appear explicitly, return is made with the execution of the final end\r of a unit. Upon return to the caller the procedure (function) object is deallocated.\r\r
+ Functions are invoked in expressions with the corresponding list of actual parameters. Procedures are invoked by call statement (also with the corresponding list of actual parameters).\r\r
+\r
+Example:\r\r
+ i:=i*Euclid(k,105)-Newton(n,m+1);\r
+ call P(x,y+3);\r \r\r
+ Formal parameters are of four categories: variable parameters, procedure parameters, function parameters and type parameters (cf p.8). Variable parameters are considered local variables to the unit. A variable parameter has one of three transmission modes: input, output or inout. If no mode is explicitly given the input mode is assumed. For instance in the unit declaration:\r\r
+ unit P: procedure(x,y:real,b:boolean;\r
+ output c:char,i:integer;inout :integer);\r\r
+x,y,b are input parameters , c,i are output parameters , and j is inout parameter.\r\r
+ Input parameter acts as a local variable whose value is initialized by the value of the corresponding actual parameter. Output parameter acts as a local variable initialized in the standard manner (real with 0.0, integer with 0, boolean with false etc.). Upon return its value is assigned to the corresponding actual parameter, in which case it must be a variable. However the address of such an actual parameter is determined upon entry to the body. Inout parameter acts as an input parameter and output parameter together.\r\r
+\r
+Example:\r\r
+ unit squareeq: procedure(a,b,c:real;output xr,xi,yr,yi:real);\r \r
+ (* given a,b,c the procedure solves square equation :\r
+ ax*x+bx+c=0.\r
+ xr,xi- real and imaginary part of the first root\r
+ yr,yi- real and imaginary part of the second root *)\r
+ var delta: real;\r \r
+ begin (*a=/=0*)\r \r
+ a:=2*a; c:=2*c; delta:=b*b-a*c;\r
+ if delta <= 0\r \r
+ then\r \r
+ xr,yr:=-b/a;\r
+ if delta=0 then return fi; (*xi=yi=0 by default*)\r \r
+ delta:=sqrt(-delta);\r
+ xi:=delta/a; yi:=-xi;\r
+ return\r \r
+ fi;\r \r
+ delta:=sqrt(delta);\r
+ if b=0\r \r
+ then\r \r
+ xr:=delta/a; yr:=-xr;\r
+ return\r \r
+ fi;\r \r
+ if b>0 then b:=b+delta else b:=b-delta fi;\r
+ xr:=-b/a; yr:=-c/b;\r
+ end squareeq;\r\r
+ A procedure call to the above unit may be the following:\r\r
+ call squareeq(3.75*H,b+7,3.14,g,gi,h,hi); \r\r
+where g,h,gi,hi are real variables.\r\r
+ No restriction is imposed on the order of declarations. In particular, recursive procedures and functions can be declared without additional announcements (in contrast to Pascal).\r\r
+Example:\r\r
+ For two recursive sequences defined as:\r\r
+ a(n)=b(n-1)+n+2 n>0\r
+ b(n)=a(n-1)+(n-1)*n n>0\r
+ a(0)=b(0)=0\r\r
+one can declare two functions:\r\r
+ unit a: function(n:integer):integer;\r
+ begin\r \r
+ if n>0 then result:=b(n-1)+n+2 fi\r
+ end a;\r \r
+ unit b: function(n:integer):integer; \r
+ begin\r \r
+ if n>0 then result:=a(n-1)+(n-1)*n fi\r \r
+ end b;\r \r\r
+and invoke them:\r\r
+ k:=a(100)*b(50)+a(15);\r\r
+ Functions and procedures can be formal parameters as well.\r\r
+\r
+Example:\r\r
+unit Bisec: procedure(a,b,eps:real;output x:real;function f(x:real):real);\r
+(*this procedures searches for zero of the continous function f in the segment (a,b) *)\r
+var h:real,s:integer;\r
+begin\r
+ s:=sign(f(a));\r
+ if sign(f(b))=s then return fi; (* wrong segment *)\r \r
+ h:=b-a;\r
+ do\r \r
+ h:=h/2; x:=a+h;\r
+ if h < eps then return fi;\r
+ if sign(f(x))=s then a:=x else b:=x fi\r
+ od\r \r
+end Bisec;\r\r
+In the above declaration, after the input variable parameters a,b,eps and the output variable parameter x, a function parameter f appears. Note that its specification part is complete. Thus the check of actual-formal parameter compatibility is possible at compilation time. Making use of this syntactic facility is not possible in general, if a formal procedure (function) is again a formal parameter of a formal procedure (function). The second degree of formal procedures (functions) nesting is rather scarce, but LOGLAN-82 admits such a construct. Then formal procedure (function) has no specification part and the full check of actual-formal parameter compatibility is left to be done at run time.\r\r
+\r
+Example:\r\r
+ unit P: procedure(j:integer; procedure G (i:integer;\r
+ procedure H));\r
+ ...\r
+ begin\r \r
+ ...\r
+ call G(j,P);\r
+ end P;\r \r\r
+ Procedure G is a first degree parameter, therefore it occurs with complete specification part. Procedure H is a second degree parameter and has no specification part. In this case a procedure call can be strongly recursive:\r\r
+ call P(i+10,P);\r \r\r
+4. Classes\r\r
+ Class is a facility which covers such programming constructs as structured type, package, access type, data structure etc. To begin with the presentation of this construct, let us consider a structured type assembled from primitive ones:\r\r
+ unit bill: class;\r
+ var dollars :real, \r
+ not_paid :boolean,\r
+ year,month,day :integer;\r
+ end bill;\r \r\r
+ The above class declaration has the attributes : dollars (real), not_paid (boolean), and year,month,day (integer). Wherever class bill is visibile one can declare variables of type bill:\r\r
+ var x,y,z: bill;\r\r
+ The values of variables x, y, z can be the addresses of objects of class bill. These variables are called reference variables. With reference variable one can create and operate the objects of reference variable type.\r\r
+ An object of a class is created by the class generation statement (new), and thereafter, its attributes are accessed through dot\r notation.\r\r
+ x:=new bill; (* a new object of class bill is created *)\r
+ x.dollars:=500.5; (* define amount *)\r
+ x.year:=1982; (* define year *)\r
+ x.month:=3; (* define month *)\r
+ x.day:=8; (* define day *)\r
+ y:=new bill; (* create a new object *)\r \r
+ y.not_paid:=true; (* bill not_paid *)\r
+ z:=y; (* variable z points the same object as y *)\r\r
+ If an object of class bill has been created (new bill) and its\r address has been assigned to variable x (x:=new bill), then the\r attributes of that object are accessible through dot notation (remote access). The expression x.dollars gives , for instance, the remote access to attribute dollars of the object referenced by x. All attributes of class objects are initialized as usual. For the above example the object referenced by x, after the execution of the specified sequence of statements, has the following structure:\r\r
+\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿\r
+ ³ 500.5 ³ dollars\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ false ³ not_paid\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ 1982 ³ year\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ 3 ³ month\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ 8 ³ day\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ\r\r
+\r
+ The object referenced by y and z has the following structure:\r\r
+\r
+ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄ¿\r
+ ³ 0 ³ dollars\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ true ³ not_paid\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ 0 ³ year\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ 0 ³ month\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ 0 ³ day\r
+ ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÙ\r\r
+ The value none is the default initial value of any reference\r variable and denotes no object. A remote access to an attribute of none raises a run time error. \r\r
+ Class may have also formal parameters (as procedures and functions). Kinds and transmission modes of formal parameters are the same as in the case of procedures.\r\r
+\r
+\r
+\r
+Example:\r\r
+ unit node: class (a:integer);\r
+ var left,right:node;\r \r
+ end node; \r\r
+ Let, for instance, variables z1, z2, z3 be of type node. Then the sequence of statements:\r\r
+ z1:=new node(5);\r
+ z2:=new node(3);\r \r
+ z3:=new node(7);\r \r
+ z1.left:=z2; z1.right:=z3;\r\r
+ creates the structure:\r\r
+\r
+ ÚÄÄÄÄÄÄÄÄÄ¿\r
+ z1ÄÄÄÄÄÄ´ 5 ³\r
+ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ÚÄÄÄÄÄÄ´ left ³\r
+ ³ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ³ ³ right ÃÄÄÄÄÄÄÄÄ¿\r
+ ³ ÀÄÄÄÄÄÄÄÄÄÙ ³\r
+ ³ ³\r
+ ÚÄÄÄÄÁÄÄÄÄÄ¿ ÚÄÄÄÄÄÁÄÄÄÄ¿\r
+z2ÄÄÄÄÄ´ 3 ³ ³ 7 ÃÄÄÄÄÄÄz3\r
+ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ none ³ ³ none ³ \r
+ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ none ³ ³ none ³ \r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ\r\r
+\r
+where arrows denote the values of the reference variables.\r\r
+ Class may also have a sequence of statements (as any other unit). That sequence can initialize the attributes of the class objects.\r\r
+\r
+Example:\r\r
+ unit complex:class(re,im:real);\r \r
+ var module:real;\r \r
+ begin\r \r
+ module:=sqrt(re*re+im*im)\r
+ end complex;\r \r\r
+ Attribute module is evaluated for any object generation of class complex:\r\r
+ z1:=new complex(0,1); (* z1.module equals 1 *) \r
+ z2:=new complex(2,0); (* z2.module equals 2 *)\r \r\r
+ For the execution of a class generator, first a class object is created, then the input parameters are transmitted , and finally, the sequence of statements (if any) is performed. Return is made with the execution of return statement or the final end of a unit. Upon return the output parameters are transmitted.\r\r
+ Procedure object is automatically deallocated when return is made to the caller. Class object is not deallocated , its address can be assigned to a reference variable, and its attributes can be thereafter accessed via this variable. \r\r
+ The classes presented so far had only variable attributes. In general, class attributes may be also other syntactic entities, such as constants, procedures, functions, classes etc. Classes with procedure and function attributes provide a good facility to define data structures.\r\r
+\r
+Example:\r\r
+A push_down memory of integers may be implemented in the following way:\r\r
+ unit push_down :class;\r \r
+ unit elem:class(value:integer,next:elem);\r
+ (* elem - stack element *)\r
+ end elem;\r \r
+ var top:elem;\r \r
+ unit pop: function :integer;\r \r
+ begin\r \r
+ if top=/= none\r \r
+ then\r \r
+ result:=top.value; top:=top.next\r
+ fi;\r \r
+ end pop;\r \r
+ unit push:procedure(x:integer); (* x - pushed integer *)\r
+ begin\r \r
+ top:=new elem(x,top);\r
+ end push;\r \r
+ end push_down;\r\r
+ Assume that somewhere in a program reference variables of type push_down are declared (of course, in place where push_down is visibile):\r\r
+ var s,t,z:push_down;\r \r\r
+ Three different push_down memories may be now generated:\r\r
+ s:=new push_down(100); t:=new push_down(911); z:=new push_down(5);\r \r\r
+ One can use these push_down memories as follows:\r\r
+ call s.push(7); (* push 7 to s *)\r \r
+ call t.push(1); (* push 1 to t *)\r \r
+ i:=z.pop; (* pop an element from z *)\r
+ etc.\r\r
+5. Adjustable arrays\r\r
+ In LOGLAN-82 arrays are adjustable at run time. They may be treated as objects of specified standard type with index instead of identifier selecting an attribute. An adjustable array should be declare somewhere among the lists of declarations and then may be generated in the sequence of statements.\r\r
+\r
+Example:\r\r
+ block\r \r
+ var n,j:integer;\r \r
+ var A:arrayof integer; (* here is the declaration of A *) \r
+ begin\r \r
+ read(n);\r
+ array A dim (1:n); (* here is the generation of A *)\r \r
+ for i:=1 to n\r \r
+ do\r \r
+ read(A(i));\r
+ od;\r \r
+ (* etc.*)\r
+ end\r \r\r
+ A variable A is an array variable. Its value should be the reference to an integer array, i.e. a composite object consisting of integer components each one defined by an integer index. \r
+Array generation statement:\r\r
+ array A dim (1:n);\r \r\r
+allocates a one-dimensional integer array with the index bounds 1,n , and assigns its address to variable A. \r
+The figure below illustrates this situation:\r\r
+\r
+ ÚÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄ¿\r
+ ³ ³ ³ A(1) ³\r
+ ³ ³ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ³ ... ³ ³ A(2) ³\r
+ ÃÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ³ n ³ ³ ³\r
+ ÃÄÄÄÄÄÄÄÄ´ ³ ... ³\r
+ ³ j ³ ³ ³\r
+ ÃÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄ´\r
+ ³ A ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´ A(n) ³\r
+ ÀÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÙ\r
+ Block object Array object\r\r
+\r
+A general case of array generation statement has the form:\r
+ array A dim (lower:upper)\r \r\r
+where lower and upper are arithmetic expressions which define the range of the array index.\r\r
+Example:\r\r
+ Two-dimensional array declaration :\r\r
+ var A: arrayof arrayof integer;\r \r\r
+and generation:\r\r
+ array A dim (1:n)\r
+ for i:=1 to n do array A(i) dim (1:m) od;\r \r\r
+create the structure:\r
+ ÚÄÄÄÄÄÄÄÄ¿\r
+ ³ A(1,1) ³\r
+ ÃÄÄÄÄÄÄÄÄ´\r
+ ³ ³\r
+ ³ ... ³\r
+ ³ ³\r
+ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÃÄÄÄÄÄÄÄij\r
+ ³ A(1) ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´ A(1,m) ³\r
+ ³ÄÄÄÄÄÄÄÄÄÄ´ ÀÄÄÄÄÄÄÄÄÙ\r
+ ³ ³\r
+ ³ ... ³\r
+ ³ ³\r
+ ÃÄÄÄÄÄÄÄÄÄÄ´ ÚÄÄÄÄÄÄÄÄ¿\r
+ ³ A(n) ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´ A(n,1) ³\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ÃÄÄÄÄÄÄÄÄ´\r
+ ³ ³\r
+ ³ ... ³\r
+ ³ ³\r
+ ÃÄÄÄÄÄÄÄÄ´\r
+ ³ A(n,m) ³\r
+ ÀÄÄÄÄÄÄÄÄÙ\r\r
+\r
+ block\r \r
+ var i,j:integer, A,B: arrayof arrayof real, n:integer; \r
+ begin\r \r
+ read(n);\r
+ array A dim (1:n); \r
+ for i:=1 to n do array A(i) dim (1:n) od;\r \r
+ (* A is square array *)\r
+ array B dim (1:n);\r \r
+ for i:=1 to n do array B(i) dim(1:i) od; \r
+ (* B is lower triangular array *)\r
+ A(n,n):=B(n,n);\r
+ B(1):=A(1);\r
+ B(1):=copy(A(1)); \r
+ end\r \r\r
+ Array A is the square array n by n. Each element A(i) , 1{SYMBOL 163 \f "Symbol"}i{SYMBOL 163 \f "Symbol"}n contains the address of row A(i,j), 1{SYMBOL 163 \f "Symbol"}j{SYMBOL 163 \f "Symbol"}n. Array B is the lower-triangular array. Each element B(i), 1{SYMBOL 163 \f "Symbol"}i{SYMBOL 163 \f "Symbol"}n, contains the address of row B(i,j), 1{SYMBOL 163 \f "Symbol"}j{SYMBOL 163 \f "Symbol"}i. Thus an assignment statement A(n,n):=B(n,n) transmits real value B(n,n) to real variable A(n,n). Assignment B(1):=A(1) transmits the address of the first row of A to variable B(1). Finally assignment B(1):=copy (A(1)) creates a copy of\r the first row of A and assigns its address to B(1).\r\r
+ Upper and lower bounds of an adjustable array A are determined by standard operators lower(A) and upper(A).\r\r
+\r
+Example:\r\r
+ unit sort: procedure(A:arrayof integer);\r
+ (* insertion sort *) \r
+ var n,i,j:integer; var x:integer; \r
+ begin\r \r
+ n:=upper(A); (* assume lower bound is 1 *)\r
+ for i:=2 to n\r \r
+ do\r \r
+ x:=A(i); j:=i-1;\r
+ do\r \r
+ if x >= A(j) then exit fi;\r \r
+ A(j+1):=A(j); j:=j-1;\r
+ if j=0 then exit fi;\r
+ od;\r \r
+ A(j+1):=x\r
+ od;\r \r
+ end sort;\r \r\r
+ If an array variable A refers to no array its value is equal none\r (the standard default value of any array variable). An attempt to access an array element (e.g. A(i)) or a bound (e.g. lower(A)), where A is none, raises a run time error.\r\r
+6. Coroutines and semicoroutines\r\r
+ Coroutine is a generalization of class. A coroutine object is an object such that the execution of its sequence of statements can be suspended and reactivated in a programmed manner. Consider first a simple class with a sequence of statements such that after return some\r non-executed statements remain. The generation of its object terminates with the execution of return statement, although the object can be later reactivated. If such a class is declared as a coroutine, then its objects may be reactivated. This can be realized by attach\r statement:\r\r
+ attach(X)\r \r\r
+where X is a reference variable designating the activating coroutine object.\r\r
+ In general, since the moment of generation a coroutine object is either active or suspended. Any reactivation of a suspended coroutine object X (by attach(X)) causes the active coroutine object to be\r suspended and continues the execution of X from the statement following the last executed one.\r\r
+Main program is also a coroutine. It is accessed through the standard variable main and may be reactivated (if suspended) by the\r statement attach(main).\r \r\r
+\r
+Example:\r\r
+In the example below the cooperation of two coroutines is presented. One reads the real values from an input device, another prints these values in columns on a line-printer, n numbers in a line. The input stream ends with 0.\r\r
+program prodcons;\r
+ var prod:producer,cons:consumer,n:integer,mag:real,last:bool; \r
+ unit producer: coroutine; \r
+ begin\r \r
+ return;\r \r
+ do\r \r
+ read(mag); (* mag- nonlocal variable, common store *)\r
+ if mag=0\r \r
+ then (* end of data *) \r
+ last:=true;\r
+ exit\r \r
+ fi;\r \r
+ attach(cons);\r \r
+ od;\r \r
+ attach(cons)\r \r
+ end producer;\r \r\r
+ unit consumer: coroutine(n:integer); \r
+ var Buf:arrayof real; \r
+ var i,j:integer;\r \r
+ begin\r \r
+ array Buf dim(1:n); \r
+ return;\r \r
+ do\r \r
+ for i:=1 to n\r \r
+ do\r \r
+ Buf(i):=mag;\r
+ attach(prod);\r \r
+ if last then exit exit fi; \r
+ od;\r \r
+ for i:=1 to n\r \r
+ do (* print Buf *)\r \r
+ write(' ',Buf(i):10:2)\r
+ od;\r \r
+ writeln;\r
+ od;\r \r
+ (* print the rest of Buf *)\r
+ for j:=1 to i do write(' ',Buf(j):10:2) od;\r \r
+ writeln;\r
+ attach(main);\r \r
+ end consumer;\r \r\r
+ begin\r \r
+ prod:=new producer;\r \r
+ read(n);\r
+ cons:=new consumer(n);\r \r
+ attach(prod);\r \r
+ writeln;\r
+ end prodcons;\r \r\r
+ The above task could be programmed without coroutines at all. The presented solution is, however, strictly modular, i.e. one unit realizes the input process, another realizes the output process, and both are ready to cooperate with each other.\r\r
+ LOGLAN-82 provides also a facility for the semi-coroutine operations. This is gained by the simple statement detach. If X is the active coroutine object, then detach reactivates that coroutine object\r at where the last attach(X) was executed. This statement meets the\r need for the asymetric coroutine cooperations. (by so it is called semi-coroutine operation). Operation attach requires a reactivated coroutine to be defined explicitly by the user as an actual parameter. Operation detach corresponds in some manner to return in procedures. It gives the control back to a coroutine object where the last attach(X) was executed, and that coroutine object need not be known explicitly in X. This mechanism is, however, not so secure as the normal control transfers during procedure calls and returns.\r\r
+ In fact, the user is able to loop two coroutines traces by :\r\r
+ attach(Y) in X\r attach(X) in Y\r \r\r
+Then detach in X reactivates Y, detach in Y reactivates X. \r\r
+ In the example below the application of detach statement is illustrated.\r\r
+Example:\r\r
+program reader_writers; \r
+(* In this example a single input stream consisting of blocks of numbers, each ending with 0, is printed on two printers of different width. The choice of the printer is determined by the block header which indicates the desired number of print columns. The input stream ends with a double 0. m1 - the width of printer_1, m2 - the width of printer_2 *)\r
+ const m1=10,m2=20;\r \r
+ var reader:reading,printer_1,printer_2:writing;\r \r
+ var n:integer,new_sequence:boolean,mag:real;\r \r
+ \r
+ unit writing:coroutine(n:integer);\r \r
+ var Buf: arrayof real, i,j:integer;\r \r
+ begin\r \r
+ array Buf dim (1:n); (* array generation *)\r \r
+ return;(* return terminates coroutine initialization *)\r \r
+ do\r \r
+ attach(reader); (* reactivates coroutine reader *)\r
+ if new_sequence\r \r
+ then \r
+ (* a new sequence causes buffer Buf to be cleared up *)\r
+ for j:=1 to i do write(' ',Buf(j):10:2) od;\r
+ writeln;\r
+ i:=0; new_sequence:=false; attach(main)\r \r
+ else\r \r
+ i:=i+1; Buf(i):=mag;\r
+ if i=n\r \r
+ then\r \r
+ for j:=1 to n do write(' ',Buf(j):10:2) od;\r
+ writeln;\r
+ i:=0;\r
+ fi\r \r
+ fi\r \r
+ od\r \r
+ end writing;\r \r\r
+ unit reading: coroutine;\r \r
+ begin\r \r
+ return;\r \r
+ do\r \r
+ read(mag);\r
+ if mag=0 then new_sequence:=true; fi;\r \r
+ detach;\r
+ (* detach returns control to printer_1 or printer_2 depending which one reactivated the reader *)\r
+ od\r \r
+ end reading;\r \r\r
+ begin\r \r
+ reader:=new reading;\r \r
+ printer_1:=new writing(m1); printer_2:=new writing(m2);\r
+ do\r \r
+ read(n);\r
+ case n\r \r
+ when 0: exit\r \r
+ when m1: attach(printer_1)\r \r
+ when m2: attach(printer_2)\r \r
+ otherwise write(" wrong data"); exit\r \r
+ esac\r \r
+ od\r \r
+ end;\r \r\r
+\r\r
+ Coroutines play the substantial role in process simulation. Class Simulation provided in Simula-67 makes use of coroutines at most degree. LOGLAN-82 provides for easy simulation as well. The LOGLAN-82 class Simulation is implemented on a heap what gives lg(n) time cost (in contrast with O(n) cost of the original implementation). It covers also various simulation problems of large size and degree of complexity.\r\r
+7. Prefixing\r\r
+ Classes and prefixing are ingenius inventions of Simula-67(cf [1]). Unfortunately they were hardly ever known and, perhaps, by this have not been introduced into many programming language that gained certain popularity. Moreover, implementation constraints of Simula-67 bind prefixing and classes workableness to such a degree that both facilities cannot be used in all respects. We hope that LOGLAN-82, adopting merits and rooting up deficiencies of these constructs, will smooth their variations and vivify theirs usefulness.\r\r
+ What is prefixing ? First of all it is a method for unit extending. Consider the simplest example:\r\r
+ unit bill: class;\r \r
+ var\r dollars :real,\r
+ not_paid :boolean,\r
+ year,month,day :integer;\r
+ end bill;\r \r\r
+Assume the user desires to extend this class with new attributes. Instead of writing a completely new class, he may enlarge the existing one:\r\r
+ unit gas_bill:bill class;\r \r
+ var cube_meters: real;\r \r
+ end gas_bill;\r \r\r
+ Class gas_bill is prefixed by class bill. This new declaration may appear anywhere within the scope of declaration of class bill. (In Simula-67 such a prefixing is forbidden in nested units.) Class gas_bill has all the attributes of class bill and additionally its own attributes (in this case the only one: cube_meters). The generation statement of this class has the form:\r\r
+z:=new gas_bill;\r \r\r
+where z is a reference variable of type gas_bill. Remote access to the attributes of prefixed class is standard:\r\r
+z.dollars:=500.5; z.year:=1982; z.month:=3; z.day:=8;\r
+z.cube_meters:=100000;\r\r
+\r
+Consider now the example of a class with parameters.\r\r
+Assume that in a program a class:\r\r
+unit id_card: class(name:string,age:integer);\r \r
+end id_card;\r \r\r
+and its extension:\r\r
+unit idf_card:id card class(first name:string);\r \r
+end idf_card;\r \r\r
+are declared.\r\r
+ Then for variable z of type id_card and variable t of type idf_card the corresponding generation statement may be the following:\r\r
+ z:=new id_card("kreczmar",37);\r \r
+ t:=new idf_card("Kreczmar",37,"Antoni");\r \r\r
+Thus the formal parameters of a class are concatenated with the formal parameters of its prefix.\r\r
+One can still extend class idf_card. For instance:\r\r
+ unit idr_card:idf_card class;\r \r
+ var children_number:integer;\r \r
+ var birth_place:string;\r \r
+ end idr_card;\r \r\r
+ Prefixing allows to build up hierarchies of classes. Each one hierarchy has a tree structure. A root of such a tree is a class without prefix. One class is a successor of another class iff the first is prefixed by the latter one.\r\r
+\r
+ Consider the prefix structure:\r\r
+ A\r
+ . . .\r
+ . . .\r
+ . . .\r
+ B. .C .D\r
+ .\r
+ .\r
+ .E\r
+ .\r
+ .\r
+ .F\r
+ . .\r
+ . .\r
+ G. .H\r\r
+ Class H has a prefix sequence A, B, E, F, H. Let a, b, ... , h denote the corresponding unique attributes of classes A, B, ... , H, respectively. The objects of these classes have the following forms: \r\r
+\r\r
+ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ ³ a ³ ³ a ³ ³ a ³ ³ a ³\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ object A ³ b ³ ³ c ³ ³ d ³\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ object B object C object D\r\r
+ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄ¿\r
+ ³ a ³ ³ a ³ ³ a ³ ³ a ³\r
+ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ b ³ ³ b ³ ³ b ³ ³ b ³\r
+ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ e ³ ³ e ³ ³ e ³ ³ e ³\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ³ÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ object E ³ f ³ ³ f ³ ³ f ³\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ÃÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄ´\r
+ object F ³ g ³ ³ h ³\r
+ ÀÄÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÄÄÄÄÄÄÄÙ\r
+ object G object H\r\r
+\r
+Let Ra, Rb,..., Rh denote reference variables of types A, B,..., H, respectively. Then the following expressions are correct:\r\r
+ Ra.a, Rb.b, Rb.a, Rg.g, Rg.f, Rh.h, Rh.f, Rh.e, Rh.b, Rh.a etc.\r\r
+Variable Ra may designate the object of class B (or C,..., H), i.e. the statement:\r\r
+ Ra:=new B\r \r\r
+is legal. But then attribute b is not accessible through dot via Ra, i.e. Ra.b is incorrect. This follows from insecurity of such a remote access. In fact, variable Ra may point any object of a class prefixed by A, in particular, Ra may point the object of A itself, which has no attribute b. If Ra.b had been correct, a compiler should have distiguish the cases Ra points to the object of A or not. But this, of course, is undistinguishable at compilation time.\r\r
+ To allow, however, the user's access to attribute b (after instruction Ra:=new B), the instantaneous type modification is provided within the language:\r\r
+ Ra qua B\r \r\r
+ The correctness of this expression is checked at run time. If Ra designates an object of B or prefixed ba B, the type of the expression is B. Otherwise the expression is erroneous. Thus, for instance, the expressions:\r\r
+ Ra qua G.b, Ra qua G.e etc.\r \r\r
+enable remote access to the attributes b, c, ... via Ra.\r\r
+ So far the question of attribute concatenation was merely discussed. However the sequences of statements can be also concatenated.\r\r
+ Consider class B prefixed with class A. In the sequence of statements of class A the keyword inner may occur anywhere, but only once. The sequence of statements of class B consists of the sequence of statements of class A with inner replaced by the sequence of\r statements of class B.\r\r
+\r
+ unit A :class unit B:A class\r \r
+ ... ...\r
+ begin begin\r \r
+ ... ÚÄÄÄ...\r
+ ³ inner ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´ inner\r \r
+ ³\r
+ ... ÀÄÄÄ...\r
+ end A; end B;\r \r\r\r
+ \r\r
+
+ In this case inner in class B is equivalent to the empty statement.\r If class B prefixes another class, say C, then inner in B is replaced\r by the sequence of statements of class C, and so on. If inner does not occur explicitly, an implicit occurrence of inner\r before the final end of a class is assumed.\r \r\r
+\r
+Example\r\r
+ Let class complex be declared as usual:\r\r
+ unit complex: class(re,im:real);\r \r
+ end complex;\r \r\r
+and assume one desires to declare a class mcomplex with the additional attribute module. In order the generation of class mcomplex define the value of attribute module, one can declare a class:\r\r
+ unit mcomplex:complex class;\r \r
+ var module:real;\r \r
+ begin\r \r
+ module:=sqrt(re*re+im*im)\r
+ end mcomplex;\r \r\r
+ Class mcomplex may be still extended:\r\r
+ unit pcomplex:mcomplex class;\r \r
+ var alfa:real;\r \r
+ begin\r \r
+ alfa:=arccos(re/module)\r
+ end pcomplex;\r \r\r
+ For these declarations each generation of class mcomplex defines the value of attribute module, each generation of class pcomplex defines the values of attributes module and alfa.\r\r
+ For reference variables z1, z2 z3 of type complex, the following sequence of statements illustrates the presented constructs:\r\r
+ z1:=new complex(0,1);\r \r
+ z2:=new mcomplex(4,7);\r \r
+ z3:=new pcomplex(-10,12);\r \r
+ if z2 qua mcomplex.module > 1\r \r
+ then\r \r
+ z1:=z2;\r
+ fi;\r \r
+ if z3 qua pcomplex.alfa < 3.14\r \r
+ then\r \r
+ z3.re:=-z3.re; z3.alfa:=z3.alfa+3.14;\r
+ fi;\r \r
+ z1 qua mcomplex.module:= 0;\r \r
+ z1.re,z1.im:=0; \r\r
+Example:\r\r
+ Binary search tree (Bst) is a binary tree where for each node x the nodes in the left subtree are less than x, the nodes in the right subtree are greater than x. It is the well-known exercise to program the algorithms for the following operations on Bst: \r
+ member(x) = true iff x belongs to Bst\r
+ insert(x), enlarge Bst with x, if x does not yet belong to Bst\r\r
+We define both these operations in a class:\r\r
+ unit Bst: class;\r \r
+ unit node: class(value:integer); (* tree node *)\r \r
+ var left,right:node;\r \r
+ end node;\r \r
+ var root:node;\r \r
+ unit help: class(x:integer); (* auxiliary class *)\r \r
+ var p,q:node;\r \r
+ begin\r \r
+ q:=root;\r
+ while q=/= none\r \r
+ do\r \r
+ if x < q.value\r \r
+ then\r \r
+ p:=q; q:=q.left;\r
+ repeat (* jump to the beginning of a loop *)\r \r
+ fi;\r \r
+ if q.value < x\r \r
+ then\r \r
+ p:=q; q:=q.right; repeat\r \r
+ fi;\r \r
+ exit\r \r
+ od;\r \r
+ inner\r
+ (* virtual instruction to beÿreplaced\r by the body of\r
+ a module prefixed by help *)\r
+ end help;\r \r
+ unit member:help function:boolean;\r \r
+ (* x is a formal parameter derived from the prefix help *)\r
+ begin\r \r
+ result:=q=/=none\r \r
+ end member;\r \r
+ unit insert:help procedure;\r \r
+ (* x is a formal parameter derived from the prefix help *)\r
+ begin\r \r
+ if q=/=none then return fi;\r \r
+ q:=new node(x);\r \r
+ if p=none then root:=q; return fi;\r \r
+ if p.value < x then p.right:=q else p.left:=q fi;\r \r
+ end insert;\r \r
+ begin\r \r
+ inner;\r \r
+ end Bst;\r \r\r
+ In the example the common actions of member and insert are programmed in class help. Then it suffices to use class help as a prefix of function member and procedure insert, instead of redundant occurrences of the corresponding sequence of statements in both units. \r\r
+Class Bst may be applied as follows:\r\r
+ var X,Y:Bst;\r \r
+ begin\r \r
+ X:=new Bst; Y:=new Bst;\r \r
+ call X.insert(5);\r \r
+ if Y.member(-17) then ....\r \r
+ end\r \r\r
+ As shown in the declaration of Bst, class may prefix not only other classes but also procedures and functions. Class may prefix blocks as well.\r\r
+\r
+Example:\r\r
+ Let class push_down (p. 5) prefix a block:\r\r
+ pref push_down(1000) block\r \r
+ var ...\r \r
+ begin\r \r
+ ...\r
+ call push(50); ...\r \r
+ i:=pop;\r
+ ...\r
+ end\r \r\r
+ In the above block prefixed with class push_down one can use pop and push as local attributes. (They are local since the block is embedded in the prefix push down.)\r\r
+\r
+Example:\r\r
+ pref push down(1000) block\r \r
+ begin\r \r
+ ...\r
+ pref Bst block\r \r
+ begin\r \r
+ (* in this block both structures\r
+ push down and Bst are visible *)\r
+ call push(50);\r \r
+ call insert(13);\r \r
+ if member(10) then ...\r \r
+ i:=pop;\r
+ ...\r
+ end\r \r
+ end\r \r\r
+ In place where classes push_down and Bst are visible together a block prefixed with Bst may be nested in a block prefixed with push_down (or vice versa). In the inner block both data structures are directly accessible. Note that this construct is illegal in Simula 67. \r\r
+8. Formal types\r\r
+Formal types serve for unit parametrization with respect to any non-primitive type.\r\r
+Example:\r\r
+ unit Gsort:procedure(type T; A:arrayof T; function less\r
+ (x, y: T): boolean);\r
+ var n,i,j:integer; var x:T;\r \r
+ begin\r \r
+ n:=upper(A);\r
+ for i:=2 to n\r \r
+ do\r \r
+ x:=A(i); j:=i-1;\r
+ do\r \r
+ if less(A(j),x) then exit fi;\r \r
+ A(j+1):=A(j); j:=j-1;\r
+ if j=0 then exit fi;\r
+ od;\r \r
+ A(j+1):=x;\r
+ od\r \r
+ end Gsort;\r \r\r
+Procedure Gsort (the generalization of procedure sort from p.4) has type parameter T. A corresponding actual parameter may be an arbitrary non-primitive type. An actual parameter corresponding to A should be an array of elements of the actual type T. Function less should define the linear ordering on the domain T.\r\r
+ For instance, the array A of type bill (cf p.7) may be sorted with respect to attribute dollars , if the function:\r\r
+ unit less: function(t,u:bill):boolean;\r \r
+ begin\r \r
+ result:=t.dollars <= u.dollars\r
+ end less;\r
+is used as an actual parameter:\r\r
+ call Gsort(bill,A,less);\r \r\r
+If the user desires to sort A with respect to date, it is sufficient to declare :\r\r
+ unit earlier:function(t,u:bill):boolean;\r \r
+ begin\r \r
+ if t.year < u.year then result:= true; return fi;\r \r
+ if t.year=u.year\r \r
+ then\r \r
+ if t.month < u.month then result:=true; return fi;\r \r
+ if t.month=u.month then result:=t.day<=u.day fi\r \r
+ fi;\r \r
+ end earlier;\r \r\r
+and to call: call Gsort(bill,A,earlier);\r \r\r
+9. Protection techniques\r\r
+ Protection techniques ease secure programming. If a program is large, uses some system classes, is designed by a team etc., this is important (and non-trivial) to impose some restrictions on access to non-local attributes.\r\r
+ Let us consider a data structure declared as a class. Some of its attributes should be accessible for the class users, the others should not. For instance, in class Bst (p.7) the attributes member and insert are to be accessible. On the other hand the attributes root, node and help should not be accessible, even for a meddlesome user. An improper use of them may jeopardize the data structure invariants.\r\r
+ To forbid the access to some class attributes the three following protection mechanisms are provided:\r\r
+ close, hidden, and taken.\r \r\r
+ The protection close defined in a class forbids remote access to the\r specified attributes. For example, consider the class declaration:\r\r
+ unit A: class;\r \r
+ close x,y,z;\r \r
+ var x: integer, y,z:real;\r \r
+ ....\r
+ end A\r \r\r
+Remote access to the attributes x,y,z from outside of A is forbidden.\r\r
+The protection hidden (with akin syntax) does not allow to use the\r specified attributes form outside of A neither by the remote access nor in the units prefixed by A. The only way to use a hidden attribute is to use it within the body of class A.\rProtection taken defines these attributes derived from prefix, which\r the user wishes to use in the prefixed unit. Consider a unit B prefixed by a class A. In unit B one may specify the attributes of A which are used in B. This protects the user against an unconscious use of an attribute of class A in unit B (because of identifier conflict). When taken list does not occur, then by default, all non-hidden attributes of class A are accessible in unit B. \r\r
+10. Programmed deallocation\r\r
+ The classical methods implemented to deallocate class objects are based on reference counters or garbage collection. Sometimes the both methods may be combined. A reference counter is a system attribute holding the number of references pointing to the given object. Hence any change of the value of a reference variable X is followed by a corresponding increase or decrease of the value of its reference counter. When the reference counter becomes equal 0, the object can be deallocated.\r\r
+ The deallocation of class objects may also occur during the process of garbage collection. During this process all unreferenced objects are found and removed (while memory may be compactified). In order to keep the garbage collector able to collect all the garbage, the user should clear all reference variables , i.e. set to None, whenever possible. This system has many disadvantages. First of all, the programmer is forced to clear all reference variables, even those which are of auxiliary character. Moreover, garbage collector is a very expensive mechanism and thus it can be used only in emergency cases.\r\r
+ In LOGLAN a dual operation to the object generator, the so-called object deallocator is provided. Its syntactic form is as follows:\r\r
+ kill(X)\r \r\r
+where X is a reference expression. If the value of X points to no object (none) then kill(X) is equivalent to an empty statement. If the\r value of X points to an object O, then after the execution of kill(X),\r the object O is deallocated. Moreover all reference variables which pointed to O are set to none. This deallocator provides full security,\r i.e. the attempt to access the deallocated object O is checked and results in a run-time error.\r\r
+ For example:\r\r
+ Y:=X; kill(X); Y.W:=Z;\r \r\r
+causes the same run-time error as:\r\r
+ X:=none; X.W:=Z;\r \r\r
+ The system of storage management is arranged in such a way that the frames of killed objects may be immediately reused without the necessity of calling the garbage collector, i.e. the relocation is performed automatically. There is nothing for it but to remember not to use remote access to a killed object. (Note that the same problem appears when remote access X.W is used and X=none).\r \r\r
+\r
+\r
+\r
+Example:\r\r
+ Below a practical example of the programmed deallocation is presented. Consider class Bst (p.7). Let us define a procedure that deallocates the whole tree and is called with the termination of the class Bst.\r\r
+ unit Bst:class;\r \r
+ (* standard declarations list of Bst *)\r
+ unit kill_all:procedure(p:node);\r \r
+ (* procedure kill_all deallocates a tree with root p *)\r
+ begin\r \r
+ if p= none then return fi;\r \r
+ call kill_all(p.left);\r \r
+ call kill_all(p.right);\r \r
+ kill(p)\r \r
+ end kill_all;\r \r
+ begin\r \r
+ inner;\r \r
+ call kill_all(root)\r \r
+ end Bst;\r \r\r
+Bst may be applied as a prefix:\r\r
+ pref Bst block\r \r
+ ...\r
+ end\r \r\r
+and automatically will cause the deallocation of the whole tree after return to call kill_all(root) from the prefixed block.\r \r\r
+ To use properly this structure by remote accessing one must call kill_all by himself:\r\r
+ unit var X,Y:Bst;\r \r
+ ...\r
+ begin\r \r
+ X:=new Bst; Y:=new Bst;\r \r
+ ...\r
+ (* after the structures' application *)\r
+ call X.kill_all(X.root);\r \r
+ kill(X);\r \r
+ call Y.kill_all(Y.root);\r \r
+ kill(Y);\r \r
+ ...\r
+ end\r \r\r
+ Finally note that deallocator kill enables deallocation of array\r objects, and suspended coroutines and processes as well (cf p.13). \r\r
+11. Exception handling\r\r
+ Exceptions are events that cause interruption of normal program execution. One kind of exceptions are those which are raised as a result of some run time errors. For instance, when an attempt is made to access a killed object, when the result of numeric operation does not lie within the range, when the dynamic storage allocated to a program is exceeded etc.\r\r
+ Another kind of exceptions are those which are raised explicitly by a user (with the execution of the raise statement).\r\r
+ The response to exceptions (one or more) is defined by an exception handler. A handler may appear at the end of declarations of any unit. The corresponding actions are defined as sequences of statements preceded by keyword when and an exception identifier.\r \r\r
+Example:\r\r
+ In procedure squareeq (p.3) we wish to include the case when a=0. It may be treated as an exception (division by zero).\r\r
+ unit squareeq(a,b,c:real;output xr,xi,yr,yi:real);\r \r
+ var delta:real;\r \r
+ handlers\r \r
+ when division_by_zero:\r \r
+ if b =/= 0\r \r
+ then\r \r
+ xi,yr,yi:=0; xr:=-c/b; terminate\r \r
+ else\r \r
+ raise Wrong_data(" no roots")\r \r
+ fi; \r
+ end\r \r
+ begin\r \r
+ ...\r
+ end squareeq;\r \r\r
+ The handler declared in that procedure handles the only one exception (division_by_zero).\r\r
+ When an exception is raised, the corresponding handler is searched for, starting from the active object and going through return traces. If there is no object containing the declaration of the handler, then the program (or the corresponding process) is terminated. Otherwise the control is transferred to the first found handler. \r\r
+ In our example the handler is declared within the unit itself, so control is passed to a sequence:\r\r
+ if b=/=0\r ...\r\r
+ Therefore, when b=/=0, the unique root of square equation will be determined and the procedure will be normally terminated (terminate).\r In general, terminate causes that all the objects are terminated,\r starting from that one where the exception was raised and ending on that one where the handler was found. Then the computation is continued in a normal way.\r\r
+ In our example, when b=0, a new exception is raised by the user. For this kind of exceptions , the exception itself should be declared (because it is not predefined as a run time error). Its declaration may have parameters which are transmitted to a handler. The exception declaration need not be visible by the exception handler. However the way the handler is searched for does not differ from the standard one. Consider an example:\r\r
+ block\r
+ signal Wrong_data(t:string);\r \r
+ unit squareeq: \r
+ ...\r
+ end squareeq;\r
+ ...\r
+ begin\r \r
+ ...\r
+ end\r \r\r
+ Exception Wrong_data may be raised wherever its declaration (signal\r Wrong_data) is visible. When its handler is found the specified sequence of actions is performed. In the example above different handlers may be defined in inner units to the main block where squereeq is called.\r\r
+ The case a=0 could be included , of course, in a normal way, i.e. by a corresponding conditional statement occurring in the procedure body. But the case a=0 was assumed to be exceptional (happens scarcely). Thus the evaluation of condition a=0 would be mostly unnecessary. As can be noticed thanks to exceptions the above problem can be solved with the minimal waste of run time. \r\r
+12. Concurrent processes.\r\r
+ Loglan allows to create and execute objects-processes. They can operate simultaneously on different computers linked into a LAN network or a few processes can share one processor (its time-slices).\r\r
+ Process modules are different from the classes and coroutines for, they use the keyword process. The syntax of process modules is otherwise the same. In a process one can use a few more instructions: resume (resume a process which is passive), stop - make the current process passive, etc. \r\r
+ All processes (even those executed on the same computer) are implemented as distributed, i.e. without any shared memory. This fact implies some restrictions on how processes may be used. Not all restrictions are enforced by the present compiler, so it is the programmer's responsibility to respect them. For the details see the User's Manual.\r\r
+ Semantics of the generator new is slightly modified when applied to the processes. The first parameter of the first process unit in the prefix sequence must be of type INTEGER. This parameter denotes the node number of the computer on which this process will be created. For a single computer operation this parameter must be equal to 0.\r\r
+\r
+Example:\r\r
+unit A:class(msg:string);\r
+...\r
+end A;\r
+unit P:A process(node:integer, pi:real);\r
+...\r
+end P;\r
+...\r
+var x:P;\r
+...\r
+begin\r
+...\r
+ (* Create process on node 4. The first parameter is the *) \r
+ (*string required by the prefix A, the second is the node number *)\r
+ x := new P("Hello", 4, 3.141592653);\r
+...\r
+end\r\r
+\r
+\r
+\r
+ COMMUNICATION MECHANISM\r
+\r\r
+Processes may communicate and synchronize by a mechanism based on rendez-vous. It will be referred to as "alien call" in the following description.\r\r
+ An alien call is either: \r
+ - a procedure call performed by a remote access to a process object, or \r
+ - a call of a procedure which is a formal parameter of a process, or \r
+ - a call of a procedure which is a formal parameter of an alien-called procedure (this is a recursive definition).\r\r
+Every process object has an enable mask. It is defined as a subset of all procedures declared directly inside a process unit or any unit from its prefix sequence (i.e. subset of all procedures that may be alien-called).\r\r
+A procedure is enabled in a process if it belongs to that process' enable mask. A procedure is disabled if it does not belong to the enable mask. \r\r
+Immediately after generation of a process object its enable mask is empty (all procedures are disabled).\r\r
+Semantics of the alien call is different from the remote call described in the report. Both the calling process and the process in which the procedure is declared (i.e. the called process) are involved in the alien call. This way the alien call may be used as a synchronization mechanism.\r\r
+The calling process passes the input parameters and waits for the call to be completed.\r\r
+The alien-called procedure is executed by the called process. Execution of the procedure will not begin before certain conditions are satisfied. First, the called process must not be suspended in any way. The only exception is that it may be waiting during the ACCEPT statement (see below). Second, the procedure must be enabled in the called process.\r\r
+When the above two conditions are met the called process is interrupted and forced to execute the alien-called procedure (with parameters passed by the calling process).\r\r
+Upon entry to the alien-called procedure all procedures become disabled in the called process.\r\r
+ Upon exit the enable mask of the called process is restored to that from before the call (regardless of how it has been changed during the execution of the procedure). The called process is resumed at the point of the interruption. The execution of the ACCEPT statement is ended if the called process was waiting during the ACCEPT (see below). At last the calling process reads back the output parameters and resumes its execution after the call statement.\r\r
+ The process executing an alien-called procedure can easily be interrupted by another alien call if the enable mask is changed.\r\r
+ There are some new language constructs associated with the alien call mechanism. The following statements change the enable mask of a process: \r
+ ENABLE p1, ..., pn \r
+enables the procedures with identifiers p1, ..., pn. If there are any processes waiting for an alien call of one of these procedures, one of them is chosen and its request is processed. The scheduling is done on a FIFO basis, so it is strongly fair. The statement: \r
+ DISABLE p1, ..., pn \r
+disables the procedures with identifiers p1, ..., pn.\r\r
+ In addition a special form of the RETURN statement: \r
+ RETURN ENABLE p1, ..., pn DISABLE q1, ..., qn \r
+allows to enable the procedures p1, ..., pn and disable the procedures q1,...,qn after the enable mask is restored on exit from the alien-called procedure. It is legal only in the alien-called procedures (the legality is not enforced by the compiler).\r\r
+ A called process may avoid busy waiting for an alien call by means of the ACCEPT statement: \r
+ ACCEPT p1, ..., pn \r
+adds the procedures p1, ..., pn to the current mask, and waits for an alien call of one of the currently enabled procedures. After the procedure return the enable mask is restored to that from before the ACCEPT statement.\r\r
+ Note that the ACCEPT statement alone (i.e. without any ENABLE/DISABLE statements or options) provides a sufficient communication mechanism. In this case the called process may execute the alien-called procedure only during the ACCEPT statement (because otherwise all procedures are disabled). It means that the enable mask may be forgotten altogether and the alien call may be used as a pure totally synchronous rendez-vous. Other constructs are introduced to make partially asynchronous communication patterns possible.\r\r
+\r
+Below find a complete listing of a simple example - monitors.\r\r
+\r
+program monitors;\r
+ \r
+(* this an example showing 5 processes: two of them are in fact monitors, one controls the screen=ekran *)\r
+\r
+ unit ANSI: class; \r
+ (* CHECK whether config.sys contains a line\r
+ device=ansi.sys\r
+ the class ANSI enables operations on cursor,\r
+ and bold, blink, underscore etc. *) \r
+ \r
+ unit Bold : procedure;\r
+ begin\r
+ write( chr(27), "[1m")\r
+ end Bold;\r
+ \r
+ unit Blink : procedure;\r
+ begin\r
+ write( chr(27), "[5m")\r
+ end Blink;\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+\r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ unit Underscore : procedure;\r
+ begin\r
+ write( chr(27), "[4m")\r
+ end Underscore;\r
+\r
+ unit inchar : IIUWgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor; \r
+end ANSI;\r
+\r
+ \r
+ unit monitor: process(node:integer, size:integer,e: ekran);\r
+\r
+ var buf: arrayof integer,\r
+ nr,i,j,k1,k2,n1,n2: integer;\r
+\r
+ \r
+ unit lire: procedure(output k: integer);\r
+ begin\r
+ call e.druk(13,2+nr*30+k1,0,k2);\r
+ call e.druk(13,2+nr*30+(i-1)*6,1,buf(i));\r
+ k1:=(i-1)*6;\r
+ k:=buf(i);\r
+ k2:=k;\r
+ i:= (i mod size)+1;\r
+ if i=j\r
+ then\r
+ call e.printtext("i equal j")\r
+ fi; \r
+ end lire;\r
+ \r
+ unit ecrire: procedure(n:integer);\r
+ begin\r
+ call e.druk(13,2+nr*30+n1,0,n2);\r
+ call e.druk(13,2+nr*30+(j-1)*6,2,n);\r
+ n1:=(j-1)*6;\r
+ buf(j) := n;\r
+ n2:=buf(j);\r
+ j := (j mod size)+1;\r
+ if i=j\r
+ then\r
+ call e.printtext("j equal i")\r
+ fi; \r
+ end ecrire;\r
+ begin\r
+ array buf dim(1:size);\r
+ nr := size - 4;\r
+ for i := 1 to size\r
+ do\r
+ buf(i) := i+nr*4;\r
+ call e.druk(13,2+nr*30+(i-1)*6,0,buf(i));\r
+ od;\r
+ i:=1; \r
+ j := size;\r
+ k1:=0;\r
+ k2:=buf(1);\r
+ n1:=(size-1)*6;\r
+ n2:=buf(size);\r
+ (* end initialize buffer *)\r
+ return;\r
+ \r
+ do\r
+ accept lire, ecrire\r
+ od\r
+ end monitor;\r
+ \r
+ unit prcs: process(node,nr:integer, mleft,mright:\r
+ monitor, e: ekran);\r
+ var l,o: integer;\r
+\r
+ begin\r
+ call e.SetCursor(8+(nr-1)*10,29);\r
+ if nr = 1\r
+ then\r
+ call e.printtext("<-- p1 <--");\r
+ else\r
+ call e.printtext("--> p2 -->");\r
+ fi; \r
+ return;\r
+ do\r
+ call mleft.lire(l) ;\r
+ call e.druk(11+(nr-1)*4,31-(nr-1)*8,1,l);\r
+ l:= l+1;\r
+ call mright.ecrire(l) ; \r
+ call e.druk(10+(nr-1)*6,23+(nr-1)*8,2,l);\r
+ if l mod 15 = 0 \r
+ then\r
+ o:= e.inchar;\r
+ if o = -79 then call endrun fi;\r
+ fi; \r
+ od;\r
+ end prcs;\r
+ \r
+unit ekran : ANSI process(nrprocesora: integer);\r
+ unit printtext: procedure(s:string);\r
+ begin\r
+ write(s);\r
+ call Normal;\r
+ end printtext;\r
+\r
+ unit druk: procedure(gdzieW,gdzieK,jak,co:integer);\r
+ begin\r
+ call SetCursor(gdzieW,gdzieK);\r
+ write(" ");\r
+ if jak=0 then call Normal else\r
+ if jak=1 then call Reverse else\r
+ if jak=2 then call Bold \r
+ fi\r
+ fi\r
+ fi;\r
+ write(co:3);\r
+ call Normal;\r
+ end druk;\r
+\r
+ unit print: procedure (i:integer);\r
+ begin\r
+ write(i:4)\r
+ end print;\r
+ begin\r
+ return;\r
+ \r
+ do accept inchar, \r
+ Normal,NewPage, SetCursor, Bold, Underscore,\r
+ Reverse, Blink, print, printtext, druk\r
+ od\r
+ end ekran;\r
+ \r
+var m1,m2:monitor,\r
+ e:ekran,\r
+ p1,p2:prcs;\r
+ \r
+begin (* ----- HERE IS THE MAIN PROGRAM ----- *)\r
+ (* create a configuration *)\r
+ e:= new ekran(0);\r
+ resume(e);\r
+ call e.Normal;\r
+ call e.NewPage;\r
+ m1 := new monitor(0,4,e);\r
+ m2 := new monitor(0,5,e);\r
+ \r
+ p1 := new prcs(0,1,m2,m1,e);\r
+ p2 := new prcs(0,2,m1,m2,e);\r
+ \r
+ resume(m1);\r
+ resume(m2);\r
+ resume(p1);\r
+ resume(p2);\r
+end monitors;\r
+\r
+References.\r\r
+\r
+Bartol,W.M., et al.\r
+Report on the Loglan 82 programming Language,\r
+Warszawa-Lodz, PWN, 1984\r
+\r
+O.-J. Dahl, B. Myhrhaug, K. Nygaard, \r
+Simula 67 Common Base Language, \r
+Norwegian Computing Center, Oslo, 1970 the mother of object languages!!\r
+\r
+Hoare C.A.R.\r
+ Monitors, an operating system structuring concept.\r
+CACM,vol.17,N.10,October 1974,pp.549-57\r
+\r
+Loglan'82 \r
+User's guide\r
+Institute of Informatics, University of Warsaw 1983, 1988\r
+LITA, Université de Pau, 1993\r
+(distributed together with this package)\r
+\r
+A.Kreczmar, A.Salwicki, M. Warpechowski, \r
+Loglan'88 - Report on the Programming Language,\r
+Lecture Notes on Computer Science vol. 414, Springer Vlg, 1990,\r
+ISBN 3-540-52325-1\r
+\r
+/* if you can read polish, there is a good manual of Loglan */\r
+A.Szalas, J.Warpechowska,\r
+LOGLAN, \r
+Wydawnictwa Naukowo-Techniczne, Warszawa, 1991 ISBN 82-204-1295-1 \r
+ \r
+see also the Readings file of this distribution.\r
+\r
+{PAGE|34} A.Kreczmar Nov.1990\r
+\r
+ Loglan'82 {PAGE|33}\r
+\r
+\r
--- /dev/null
+(* Loglanizator Tekstowy wersja 1.0 1990 Warszawa Michal Pakier *)\r
+===============REKORD 1=======================================|===============\r
++ 22\r
+ Obsluga edytora LOglanizator TEKstowy wersja 1.0\r
+ \r
+^v<>.RUCHY KURSORA|O JEDNO SLOWO |F2.NAGRANIE PLIKU NA DYSK\r
+PRZESUWANIE TEKSTU|^>.........W PRAWO|F3.ROZNE OPERACJE PLIKOWE\r
+ O LINIE : |^<..........W LEWO|F4....WYSZUKIWANIE BLEDOW\r
+^U..........W GORE| WZGLEDEM WYZSZEJ|F8....PROGRAMY POMOCNICZE\r
+^D...........W DOL| LINII|F9....KOMPILACJA PROGRAMU\r
+ O STRONE : |^N.........W PRAWO|F10..WLACZANIE/WYLACZANIE\r
+PgDn........W GORE|^P..........W LEWO| WYSWIETLANIA MENU\r
+PgUp.........W DOL|------------------+------+------------------\r
+ZMIANA LINII |^K.......OPERACJE BLOKOWE|Enter...NOWA LINIA\r
+^PgDn.....POCZATEK|^Q.WYSZUKIWANIE I ZAMIANA|^Y.KASOWANIE LINII\r
+ TEKSTU|^J....SKAKANIE PO TEKSCIE|KASOWANIE ZNAKU\r
+^PgUp.......KONIEC|^W.....OPERACJE NA OKNACH|BackSpace...W LEWO\r
+ TEKSTU|^V...........MAKROROZKAZY|Del........W PRAWO\r
+^Home.....POCZATEK|-------------------------+------------------\r
+ OKIENKA|^A....................KASOWANIE LINII W LEWO\r
+^End........KONIEC|^S...................KASOWANIE LINII W PRAWO\r
+ OKIENKA|F1..........ZAWSZE WYJASNIA CO MOZEMY ZROBIC\r
+------------------+--------------------------------------------\r
+Tab......PRZESTAWIA KURSOR POD NASTEPNE SLOWO,PRZESUWA TO CO ZA\r
+^T.........................KASUJE SLOWO WSKAZYWANE PRZEZ KURSOR\r
+===============REKORD 2=======================================|===============\r
++ 11\r
+ INFORMACJA O POSLUGIWANIU SIE HELPEM.\r
+ \r
+ W kazdej sytuacji po nacisnieciu klawisza F1 mozemy otrzymac\r
+informacje o aktualnie dostepnych opcjach. Na wyswietlonym\r
+czesto moze byc wspomniane o mozliwosci uzyskania dokladniej-\r
+szych informacji na podany temat. Uzyskuje sie ja przez nacis-\r
+niecie jednego z klawiszy {0,1,2,3,4,5,6,7,8,9},co jest przed-\r
+stawione na ekranie przez wypisanie nazwy danego klawisza w na-\r
+wiasach trujkatnych.\r
+ Esc opuszczenie helpa\r
+ F1 przejscie do glownego okienka helpa\r
+===============REKORD 3=======================================|===============\r
++ 8 4\r
+ Nagrywanie pliku na dysk (F2,F3S)\r
+ \r
+Moze sie zdarzyc, ze z jakiegos powodu nie mozna nagrac pliku\r
+w katalogu, z ktorego go wgralismy. Wtedy nalezy przejsc (F3 L)\r
+do katalogu,w ktorym mamy wszystkie prawa i tam zgrac nasz plik\r
+opcja F3 W.\r
+ \r
+Aby dowiedziec sie wiecej o operacjach plikowych nacisnij <0>\r
+===============REKORD 4=======================================|===============\r
++ 15 23 3 24 25 26 41\r
+ Operacje plikowe (F3)\r
+ \r
+Przy pomocy znajdujacych sie tu funkcji mozemy wybrac dowolny\r
+plik do edycji.\r
+Mamy do dyspozycji nastepujace funkcje:\r
+ \r
+ L Ladowanie pliku z dysku <0>\r
+ S Nagrywanie pliku na dysk <1>\r
+ N Rozpoczynanie edycji nowego pliku <2>\r
+ W Zmiana nazwy pliku <3>\r
+ P Ostatnio uzywane pliki <4>\r
+ O Rozne opcje <5>\r
+ G Informacje o edytowanych plikach i ilosci\r
+ wolnej pamieci.\r
+ Q Wyjscie z programu\r
+===============REKORD 5=======================================|===============\r
++ 16\r
+ POPRAWIANIE BLEDOW\r
+ \r
+Ta opcja ulatwia poprawianie bledow w programie. W najnizszej\r
+linii pojawia sie numer linii, w ktorej wystapil blad, numer\r
+bledu i krotki opis. Kursor automatycznie ustawia sie w miejscu\r
+wystapinia. Dla niektorych bledow wskazuje dokladnie wiersz\r
+i kolumne,dla innych tylko wiersz i wtedy ustawia sie w pierw-\r
+szej kolumnie. Jesli ustawilismy opcje wyswietlania menu (F10)\r
+to nad linia z opisem bledu pojawia sie sciagawka o sposobie\r
+przegladania bledow.Dostepne sa nastepujace funkcje:\r
+ Ctrl F5 - Przejscie do pierwszego bledu\r
+ Ctrl F6 - Przejscie do ostatniego bledu\r
+ Ctrl F8 - Przejscie do nastepnego bledu\r
+ Ctrl F7 _ Przejscie do poprzedniego bledu\r
+ Ctrl F10 - Koniec poprawiania bledow\r
+Ponowne wcisniecie F4 powoduje wyjscie z opcji.\r
+===============REKORD 6=======================================|===============\r
++ 8\r
+ ZMIANA AKTUALNEGO OKNA\r
+ \r
+ Dzieki tej funkcji mozemy zmienic okienko robocze.\r
+Mamy do wyboru nastepujace funkcje:\r
+ F Kasuje wszystkie inne okienka widoczne na ekranie.\r
+ H Przechodzimy do okienka z baza danych o Loglanie.\r
+ A Przechodzimy do okienka dodatkowego\r
+ M przechodzimy do okienka glownego.\r
+===============REKORD 7=======================================|===============\r
++ 17\r
+ PRZECHODZENIE DO PROGRAMOW POMOCNICZYCH\r
+ \r
+Ta opcja umozliwia wykonywanie pewnych programow, bez wycho-\r
+dzenia z tego prograwu do systemu.To okienko mozemy zdefiniowac\r
+sobie sami w czasie instalacji edytora.Umozliwia ono miedzy\r
+innymi wykonywanie pewnych operacjii na edytowanym pliku(nazwa\r
+pliku jest umieszczana w parametrach wywolanego programu).\r
+Jako jedna z opcji mozna umiescic program LOTEKINS co pozwala\r
+na zmiane tego okienka w trakcie pracy.Wywolanie opcji tego\r
+okienka moze byc umieszczone w makroinstrukcji\r
+(Przyklad: Jesli mamy komputer z dwoma monitorami i zdefiniuje-\r
+my instrukcje:C COLOR (mode co80) i M MONO (mode mono)\r
+to makroinstrukcja <AltH> @8M@5H@5F spowoduje,ze bedziemy mogli\r
+ogladac baze danych na moanitorze z karta Hercules.\r
+ <AltM> @8C@5M@5F spowoduje,ze bedziemy mogli\r
+edytowac plik glowny na ekranie kolorowy(ale baza danych nie\r
+zniknie z ekranu monochromatycznego)\r
+===============REKORD 8=======================================|===============\r
++ 11 36\r
+ KOMPILOWANIE PROGRAMU\r
+ \r
+Tutaj mamy nastepujace opcje:\r
+ L: Pass 1 Pierwszy przebieg kompilacji (program Loglan) tu\r
+ sa miedzy innymi wykrywane popelnione przez nas bledy (F4)\r
+ G: Pass 2 Drugi lub pierwszy i drugi przebieg kompilacji\r
+ (program Gen) tu jest generowany gotowy do wykonania program\r
+ R: Run Wykonywanie programu (lub takze kompilacja).\r
+ D: Debuger Najpierw wykonujemy program,a potem mozemy prze-\r
+ sledzic instrukcja po instrukcji jak przebiegalo to wykonanie\r
+ O: Options<0> Tu ustawia sie rozne opcje zwiazane z kompilacja\r
+===============REKORD 9=======================================|===============\r
++ 17 27 28 29 30 31 32 33 34 35\r
+ OPERACJE BLOKOWE\r
+ \r
+Po nacisnieciu Ctrl_K wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie zrobimy to\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+ \r
+Mamy do dyspozycji nastepujaca funkcje:\r
+ \r
+ K,B,T,L -zaznaczanie bloku <0>\r
+ Y -kasowanie bloku <1>\r
+ C,V -zwyczajne przenoszenie bloku <2>\r
+ S,M -przenoszenie z wyrownywaniem <3>\r
+ R,W -blok z dysku i na dysk <4>\r
+ U,I -przesuwanie bloku <5>\r
+ H -chowanie bloku <6>\r
+ F -blok w ramke <7>\r
+ O -opcje <8>\r
+===============REKORD 10=======================================|===============\r
++ 13 37 38 39 40\r
+ OPERACJE KONTROLOWANEGO PRZEMIESZCZANIA SIE PO TEKSCIE\r
+\r
+Po nacisnieciu Ctrl_J wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie z\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+\r
+Mamy do dyspozycji nastepujace funkcje:\r
+\r
+ S -ustawienie miejsca dla skoku <0>\r
+ R -powrot do ostatnio ustawionego miejsca <1>\r
+ J -skok do ostatnio ustawionego miejsca <2>\r
+ L -skok do podanej linii\r
+ B,K -skoki do poczatku i konca bloku <3>\r
+===============REKORD 11=======================================|===============\r
++ 17 15 16 17 18 19 20\r
+ OPERACJE WYSZUKIWANIA I ZAMIANY SLOW\r
+ \r
+Po nacisnieciu Ctrl_Q wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie zrobimy to\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+\r
+Mamy do dyspozycji nastepujace opcje:\r
+ \r
+ F -znajdz podane slowo <0>\r
+ A -znajdz slowo i zamien je na inne <1>\r
+ C -zamien znaki <2>\r
+ K -zamien slowa kluczowe <3>\r
+ T -znajdz slowo wskazywane przez kursor <4>\r
+ R -znajdz i zamien slowo wskazywane przez kursor <5>\r
+ \r
+UWAGA:Naciskajac Ctrl L mozesz powtorzyc ostatnio wykonywana\r
+ funkcje wyszukiwania i zamiany.\r
+===============REKORD 12=======================================|===============\r
++ 13 14\r
+ SPIS TRESCI WIADOMOSCI O LOGLANIE\r
+ \r
+ Kazda linia jaka widzisz na ekranie oznacza jakis tekst.\r
+Podkreslenie oznacza linie,ktora mozna aktualnie wybrac.\r
+ \r
+ Enter -wybranie aktualnie wskazywanej linii\r
+ kursor w gore -poprzenia linia\r
+ kursor w dol -nastepna linia\r
+ Ctrl PgUp -do poczatku spisu\r
+ Ctrl PgDn -do konca spisu\r
+ PgUp,PgDn -o strone w gore lub w dol\r
+ Tab -wybieranie roznych innych rozdzialow <0>\r
+ Ctrl_Q_F -wyszukiwanie podanego slowa\r
+===============REKORD 13=======================================|===============\r
++ 11 12 14\r
+ TRESC PODROZDZIALU\r
+ \r
+ Enter -powrot do spisu tresci <0>\r
+ Tab -wybieranie roznych innych rozdzialow <1>\r
+ Up,Down,Left,Right -przemieszczanie kursora\r
+ Home,End -do poczatku i konca linii\r
+ Ctrl PgUp -do poczatku tekstu\r
+ Ctrl PgDn -do konca tekstu\r
+ PgUp,PgDn -o strone w gore lub w dol\r
+ Ctrl_K_B,K,L,T -zaznaczanie bloku\r
+ Ctrl_Q_F -wyszukiwanie slowa\r
+===============REKORD 14=======================================|===============\r
++ 9\r
+ WYBOR ROZDZIALU INFORMACJI O LOGLANIE\r
+ \r
+ Na ekranie widzimy okienko z wypisanymi nazwami rozdzialow\r
+jakie z niego mozemy otrzymac.Kursorami w gore i w dol wedru-\r
+jemy po okienku Home i End przenosi nas na poczatek lub koniec.\r
+Enter pozwala wybrac wskazywany rozdzial i odrazu przechodzimy\r
+do niego.Kursorami w lewo i w prawo przechodzimy do sasiednich\r
+okienek z innymi rozdzialami.Esc powoduje powrot do ostatnio\r
+ogladanego rozdzialu.\r
+===============REKORD 15=======================================|===============\r
++ 13\r
+ (F) SZUKANIE SLOWA W TEKSCIE\r
+ \r
+Najpierw podajemy tresc slowa, ktore chcemy znalezc (Find :?).\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+nastepnej pozycji za nim.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n............................Szukanie az do n-tego wystapienie.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+===============REKORD 16=======================================|===============\r
++ 16\r
+ (A) ZAMIANA WYSTAPIEN PODANEGO SLOWA W TEKSCIE\r
+ \r
+Najpierw podajemy tresc slowa, ktore chcemy znalezc. (Find :?)\r
+Potem podajemy na co chcemy zamienic to slowo. (Replace with :?)\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+tym slowia a w najwyzszej linii ekranu pojawia sie pytanie, czy\r
+zamienic to slowo,czy tez nie.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n...............................Zamiana pierwszych n wystapien.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ N...........Zamiana bezwarunkowa (bez pytania za kazdym razem).\r
+===============REKORD 17=======================================|===============\r
++ 11\r
+ (C) ZAMIANA ZNAKOW\r
+ \r
+Ta funkcja umozliwia zamiane duzych liter na male lub odwrotnie\r
+Dzialaja nastepujace opcje :\r
+ D.......................................Zamiana na duze litery.\r
+ S.......................................Zamiana na male litery.\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ C............................Zamiana tylko wewnatrz komentarzy.\r
+ T......................................Zamiana tylko w tekscie.\r
+===============REKORD 18=======================================|===============\r
++ 10\r
+ (K) ZAMIANA SLOW KLUCZOWYCH\r
+ \r
+Ta funkcja umozliwia nam zamiane wszystkich slow kluczowych\r
+jezyka Loglan.\r
+Dzialaja nastepujace opcje :\r
+ D.......................................Zamiana na duze litery.\r
+ S.......................................Zamiana na male litery.\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+===============REKORD 19=======================================|===============\r
++ 12\r
+ (T) SZUKANIE SLOWA WSKAZYWANEGO PRZEZ KURSOR\r
+ \r
+Najpierw podajemy opcje , a potem nastepuje szukanie.\r
+Jesli znaleziono podane slowo to kursor ustawia sie na\r
+nastepnej pozycji za nim.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n............................Szukanie az do n-tego wystapienie.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+===============REKORD 20=======================================|===============\r
++ 15\r
+ (R) SZUKANIE I ZAMIANA SLOWA WSKAZYWANEGO PRZEZ KURSOR\r
+\r
+Najpierw podajemy na co chcemy zamienic to slowo.\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+tym slowia a w najwyzszej linii ekranu pojawia sie pytanie, czy\r
+zamienic to slowo,czy tez nie.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n...............................Zamiana pierwszych n wystapien.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ N...........Zamiana bezwarunkowa (bez pytania za kazdym razem).\r
+===============REKORD 21=======================================|===============\r
++ 13 29 30\r
+ OPERACJE WYMIANY BLOKOW MIEDZY OKNAMI TEKSTOWYMI I INNE\r
+ \r
+Po nacisnieciu Ctrl_W wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie z\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+\r
+Mamy do dyspozycji nastepujace funkcje:\r
+ C -przekopiowanie bloku z drugiego widocznego na ekranie okna\r
+ V -przeniesienie bloku z drugiego widocznego na ekranie okna\r
+ S -przekopiowanie z przesunieciem z drugiego okna\r
+ M -przeniesienie z przesunieciem z drugiego okna\r
+ \r
+Patrz C,V <0> S,M <1>\r
+===============REKORD 22=======================================|===============\r
++ 19\r
+ DEFINIOWANIE MAKROROZKAZOW\r
+ \r
+Kazdemu klawiszowi odpowiadajacemu literze,cyfrze lub klawiszo-\r
+wi funkcyjnemu mozemy przyporzadkowac makroinstrukcje.\r
+Makroinstrukcje sa uruchamiane przez jednoczesne nacisniecie Alt\r
+i odpowiedniego klawisza.\r
+W definicji makrorozkazu moga wystapic oprucz zwyczajnych znakow\r
+ASCII zastepujace symbole:\r
+ ^.............Oznacza Ctrl + nastepny klawisz (A..Z oraz 0..9)\r
+ &..............Oznacza Alt + nastepny klawisz (A..Z oraz 0..9)\r
+ @........Oznacza klawisz funkcyjny.Nastepnym znakiem moze byc:\r
+ 1..0 - F1..F10 ³ <>^v - kursor ³ H - Home ³ E - End ³\r
+ U - PgUp ³ D - PgDn ³ I - Insert ³ L - Delete ³\r
+ S - Esc ³ B - Backspace ³ ³ ³\r
+ C - Enter ³ ³ ³ ³\r
+ #..Nastepny znak po ty nie jest interpretowany np.## oznacza #\r
+Nawiasy klamrowe oznaczaja powtorzenie ich zawartosci pewna\r
+liczbe razy . Np. {^C(* *)}12 spowoduje utworzenie 12 nowych\r
+linii zawierajacych napis "(* *)"\r
+===============REKORD 23=======================================|===============\r
++ 17\r
+ (L) WGRYWANIE PLIKU Z DYSKU\r
+ \r
+Pojawia sie okienko,w ktorym mozemy podac nazwe pliku,lub maske\r
+opisujaca grupe plikow. Jezeli podamy nazwe to dany plik jest\r
+wgrywany ( jesli nie istnieje to rozpoczynamy jego edycje ).\r
+Jezeli podamy maske to pojawiaja sie wszystkie odpowiadajace\r
+jej nazwy plikow oraz podkatalogow.\r
+>>>Mamy dostepne nastepujace klawisze:\r
+ Esc.........Powrot,bez wczytania pliku.Zostajemy w aktualnie\r
+ ustawionym podkatalogu.\r
+ \18 \19 < >......................Przemieszczanie sie po okienku.\r
+ Enter.........Jesli wskazywana jest nazwa pliku to dany plik\r
+ jest wczytywany i mozemy rozpoczac jego edycje.\r
+ Jezeli wskazywany jest podkatalog to jest on\r
+ dodawany do aktualnej sciezki.\r
+ PgUp,PgDn......Przejscie do poprzedniej lub nastepnej strony\r
+ (w okienku miesci sie tylko 20 nazw).\r
+===============REKORD 24=======================================|===============\r
++ 5\r
+ (N) ROZPOCZECIE EDYCJI NOWEGO PLIKU\r
+ \r
+Czysci bufor tekstu i rozpoczyna edycje pliku o domyslnej\r
+nazwie NONAME.LOG .Przy nagrywaniu na dysk program bedzie pro-\r
+ponowal zmiane tej nazwy na inna.\r
+===============REKORD 25=======================================|===============\r
++ 8\r
+ (W) ZMIANA NAZWY AKTUALNEGO PLIKU\r
+ \r
+Zmienia nazwe aktualnie edytowanego pliku i nagrywa go na dysk\r
+w aktualnym katalogu (ustawianie aktualnego katalogu funkcja L)\r
+Jesli byl juz plik o takiej nazwie to pyta, czy go skasowac\r
+UWAGA: Mozemy podac od razu nazwe nowego pliku lub maske\r
+i wtedy zastepujemy aktualnie edytowanym plikiem jakis juz\r
+istiejacy na dysku (Wybieranie tak jak w opcji L).\r
+===============REKORD 26=======================================|===============\r
++ 4\r
+ (P) OSTATNIO UZYWANE PLIKI\r
+ \r
+Pojawia sie okienko z ostatnio wgrywanymi plikami ponumerowanymi\r
+od 0 do 9 mozemy wybrac jakis plik lub przejsc do opcji Load (L)\r
+===============REKORD 27=======================================|===============\r
++ 6\r
+ ZAZNACZANIE BLOKU\r
+ \r
+ B -zaznaczenie poczatku bloku\r
+ K -zaznaczenie konca bloku\r
+ T -zaznaczenie slowa,na ktorym stoi kursor jako bloku\r
+ L -zaznaczenie linii,na ktorej stoi kursor jako bloku\r
+===============REKORD 28=======================================|===============\r
++ 3\r
+ KASOWANIE ZAZNACZONEGO BLOKU\r
+ \r
+ Jezeli zaznaczyles blok to mozesz go skasowac.\r
+===============REKORD 29=======================================|===============\r
++ 15 30\r
+ (C,V) KOPIOWANIE LUB PRZENOSZENIE ZAZNACZONEGO BLOKU\r
+ \r
+ Funkcja.C.kopiuje zaznaczony przez nas blok (Ctrl K + B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+Pierwsza linia bloku bedzie przesunieta tak , aby jej poczatek\r
+znajdowal sie w pozycji kursora natomiast pozostale linie nie\r
+zostana przesuniete.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+ Funkcja.V.przenosi zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+W poprzednim miejscu blok bedzie skasowany.\r
+Pierwsza linia bloku bedzie przesunieta tak , aby jej poczatek\r
+znajdowal sie w pozycji kursora natomiast pozostale linie nie\r
+zostana przesuniete.\r
+ ----> Ctrl K S,M <0>\r
+===============REKORD 30=======================================|===============\r
++ 18 29\r
+ (S) KOPIOWANIE LUB PRZENOSZENIE BLOKU Z WYROWNYWANIEM\r
+ \r
+ Funkcja.S. kopiuje zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+Jest jednak inna niz funkcja Ctrl K C.\r
+Wszystkie linie bloku zostana przesuniete tak,aby poczatek\r
+pierwszej linii znajdowal sie w pozycji kursora.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+ Funkcja.M.przenosi zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+W poprzednim miejscu blok bedzie skasowany.\r
+Jest jednak inna niz funkcja Ctrl K M.\r
+Wszystkie linie bloku zostana przesuniete tak,aby poczatek\r
+pierwszej linii znajdowal sie w pozycji kursora.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+W tym przypadku spowoduje to, ze blok nie przesunie sie w pionie\r
+tylko w poziomie.Jego poczatek ustawi sie w kolumnie kursora.\r
+ -----> Ctrl K C,V <0>\r
+===============REKORD 31=======================================|===============\r
++ 10 23\r
+ (R,W) WCZYTANIE I ZGRYWANIE BLOKU Z DYSKU\r
+ \r
+ Funkcja.R. umozliwia dolaczenie do naszego tekstu dowolnego\r
+pliku z dysku.Plik jest dolaczany w miejscu wskazywanym przez\r
+kursor,bez wyrownywania (tak jak Ctrl K C).\r
+Pojawia sie okienko,w ktorym mozemy podac nazwe zbioru lub maske\r
+i wtedy wybieramy odpowiedni plik tak jak w funkcji F3 L <0>\r
+ Funkcja.W. umozliwia zgranie zaznaczonego bloku na dysk.\r
+Pojawia sie okienko,w ktorym mozemy podac nazwe zbioru lub maske\r
+i wtedy wybieramy odpowiedni plik tak jak w funkcji F3 L <0>\r
+===============REKORD 32=======================================|===============\r
++ 8\r
+ (I,U) PRZESUNIECIE BLOKU O JEDEN ZNAK W PRAWO LUB W LEWO\r
+ \r
+ Funkcja.I. przesuwa wszystkie linie zawierajace blok o jeden\r
+znak w prawo.Przesuwane jest takze to co jest przed blokiem\r
+w pierwszej linii bloku oraz za blokiem w ostatniej linii bloku\r
+ Funkcja.U. przesuwa wszystkie linie zawierajace blok o jeden\r
+znak w lewo.Przesuwane jest takze to co jest przed blokiem\r
+w pierwszej linii bloku oraz za blokiem w ostatniej linii bloku\r
+===============REKORD 33=======================================|===============\r
++ 5\r
+ CHOWANIE ZAZNACZONEGO BLOKU\r
+ \r
+ Wybranie tej funkcji powoduje,ze blok staje sie niewidoczny.\r
+Ponowne jej wybranie ustawia blok taki,jaki byl przed zaslo-\r
+nieciem.\r
+===============REKORD 34=======================================|===============\r
++ 6 35\r
+ (F) TWORZENIE RAMKI\r
+ \r
+ Dookola linii zawierajacych blok tworzona jest ramka.\r
+W opcjach mozemy sobie ustawic wszelkie mozliwe parametry\r
+ramki.\r
+ -----> Ctrl K O <0>\r
+===============REKORD 35=======================================|===============\r
++ 19\r
+ (O) ROZNE CIEKAWE PARAMETRY\r
+ \r
+Te opcje dotycza przede wszystkim ksztaltu ramki ale nie tylko\r
+ 3 nastepne linie to wzor ramki.\r
+ - lewy gorny , srodkowy gorny , prawy gorny\r
+ - lewy , srodkowy , prawy\r
+ - lewy dolny , srodkowy dolny , prawy dolny\r
+ F.......................................Pierwsza kolumna ramki.\r
+ - musi byc z przedzialu 0..255\r
+ - musi byc mniejsza niz ostatnia kolumna ramki\r
+ - 0 ma specjalne znaczenie : ramka zacznie sie tam,gdzie\r
+ zaczyna sie zaznaczony tekst.\r
+ L.......................................Ostatnia kolumna ramki.\r
+ - musi byc z przedzialu 0..255\r
+ - musi byc wieksza niz pierwsza kolumna ramki\r
+ - 0 ma specjalne znaczenie : ramka zkonczy sie tam,gdzie\r
+ zaczyna sie zaznaczony tekst.\r
+ T.....Wyrownywanie tekstu w ramce.Moze o n byc z lewej,z prawej\r
+ lub w srodku ramki.\r
+===============REKORD 36=======================================|===============\r
++ 14\r
+ OPCJE DLA KOMPILACJI\r
+ \r
+Tu mozna wplynac na pewne parametry kompilacji i wykonywania\r
+programu.\r
+D: Debug info on/off Wlaczenie powoduje,ze przy wykonywaniu\r
+ programu na specjalny plik sa wyprowadzane numery kolejno\r
+ wykonywanych instrukcji.Zwalnia to wykonywanie programu ale\r
+ umozliwia jego puzniejsze przesledzenie (patrz opcja DEBUGER)\r
+M: Memory ______ Jest to podzielona przez 4 ilosc\r
+ pamieci zarezerwowana dla naszego programu.Moze ona przyjac\r
+ wartosc od 16384 do 100000. Korzystnie jest ustawiac 16384\r
+ bo wtedy program szybciej sie wykonuje.\r
+C: Cursor on/off Jest to opcja dla koneserow.Wlaczenie\r
+ jej powoduje,ze na czas wykonywania programu znika kursor\r
+===============REKORD 37=======================================|===============\r
++ 4\r
+ (S) ZAZNACZANIE POZYCJI DLA SKOKOW\r
+ \r
+Ta funkcja zapamietuje aktualna pozycje kursora i umozliwia\r
+wykonanie w przyszlosci skoku do tego miejsca.\r
+===============REKORD 38=======================================|===============\r
++ 5\r
+ (R) POWROT DO ZAZNACZONEGO WCZESNIEJ MIEJSCA\r
+ \r
+Podobnie jak Ctrl J J skacze do zaznaczonego wczesniej miejsca\r
+z ta roznica,ze zanim skoczy zaznacza aktualna pozycje tak , aby\r
+potem mozna bylo do niej wrocic opcjami Ctrl J J/R.\r
+===============REKORD 39=======================================|===============\r
++ 4\r
+ (J) SKOK DO ZAZNACZONEGO PRZEDTEM MIEJSCA W TEKSCIE\r
+ \r
+Kursor jest przenoszony do miejsca,ktore wczesniej zaznaczylismy\r
+opcja Ctrl J S\r
+===============REKORD 40=======================================|===============\r
++ 4\r
+ SKOKI DO BLOKU\r
+ \r
+ B -skok do poczatku zaznaczonego bloku\r
+ K -skok do konca zaznaczonego bloku\r
+===============REKORD 41=======================================|===============\r
++ 20\r
+ OPCJE PLIKOWE (F3O)\r
+ \r
+Tutaj mozemy ustawiac rozne opcje wplywajace na dzialanie prog-\r
+ramu.\r
+ S..Jest to numer linii bedacej granica miedzy okienkami\r
+ (np. miedzy plikiem glownym i dodatkowym lub plikiem glownym\r
+ i baza danych)\r
+ B..Czy maja byc robione kopie bezpiczenstwa plikow.\r
+ Jesli jest wlaczone,to przy kazdym nagraniu pliku na dysk\r
+ poprzednia wersja tego pliku nie jest kasowana tylko dosta-\r
+ je rozszerzenie BAK\r
+ D..Opuznienie odswierzania ekranu.\r
+ Jesli przez jakis czas (ustawiony w tym miejscu) nie zosta-\r
+ nie wcisniety zaden klawisz to na ekranie pojawia sie mru-\r
+ gajace niebo.\r
+ W..Opuznienie pojawiania sie okienek.\r
+ Po wybraniu funkcji edytora pojawia sie najpierw sam naglo-\r
+ a dopiero po pewnym czasie jesli nie wybierzemy zadnej\r
+ opcji okienko menu.Tutaj mamy mozliwosc ustawic czas,jaki\r
+ minie od pojawienia sie naglowka do wyswietlenia okienka.\r
+=============KONIEC============================================|==============\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+\1a
\ No newline at end of file
--- /dev/null
+\r
+Voila un manuel electronique de Loglan.\r
+\r
+\r
+\r
+Pour l'installer il vous faut avoir soit NortonGuide\r
+ (les programmes ng.exe,ngc.exe,ngml.exe)\r
+soit le "clone".\r
+On peut se procurer d'une version de clone par reseau, voir readme.\r
+\r
+Si vous voulez contribuer a developpement de LOGLAN.NG\r
+contactez moi.\r
+ A.Salwicki\r
+\r
--- /dev/null
+{$R+,I+}\r
+{$M 45000,0,655360}\r
+unit BufIO;\r
+\r
+interface\r
+\r
+procedure bread(var f:file; var buf; count:word; var result:word);\r
+procedure bskip(var f:file; n:longint);\r
+procedure bseek(var f:file; p:longint);\r
+function bpos(var f:file):longint;\r
+\r
+implementation\r
+\r
+{$define Buffered}\r
+\r
+{$ifdef Buffered}\r
+\r
+const MaxFbuf = 1024;\r
+\r
+var fbuf : array [1..MaxFbuf] of byte;\r
+ inbuf : 0..MaxFbuf;\r
+ curbuf : 1..MaxFbuf+1;\r
+\r
+procedure bread( var f:file; var buf; count:word; var result:word);\r
+type ByteArray = array [1..maxint] of byte;\r
+var done,n:word;\r
+ abuf : ByteArray absolute buf;\r
+begin\r
+ result := 0;\r
+ if (count > inbuf) or (inbuf = 0) then begin\r
+ if (inbuf > 0)\r
+ then move(fbuf[curbuf], buf, inbuf);\r
+ done := inbuf;\r
+ while (done < count) do begin\r
+ blockread(f, fbuf, MaxFbuf, result);\r
+ inbuf := result;\r
+ if (inbuf < 1) then begin\r
+{ writeln('BufIO.bread: unexpected eof.'); }\r
+ FillChar(buf, count, 0);\r
+ result := 0;\r
+ exit;\r
+ end;\r
+ curbuf := 1;\r
+ n := count - done;\r
+ if (n > inbuf) then n := inbuf;\r
+ move(fbuf[curbuf], abuf[done+1], n);\r
+ inc(done, n);\r
+ dec(inbuf, n);\r
+ inc(curbuf, n);\r
+ end;\r
+ end\r
+ else begin\r
+ move(fbuf[curbuf], buf, count);\r
+ dec(inbuf, count);\r
+ inc(curbuf);\r
+ end;\r
+ result := count;\r
+end;\r
+\r
+procedure bseek(var f:file; p:longint);\r
+begin\r
+ seek(f, p);\r
+ inbuf := 0; curbuf := 1; { flush buffer }\r
+end;\r
+\r
+function bpos(var f:file):longint;\r
+begin\r
+ bpos := filepos(f) - inbuf;\r
+end;\r
+\r
+procedure bskip(var f:file; n:longint);\r
+begin\r
+ if (n < inbuf) then begin\r
+ dec(inbuf, n);\r
+ inc(curbuf, n);\r
+ end\r
+ else begin\r
+ bseek(f, bpos(f)+n);\r
+ end;\r
+end;\r
+\r
+{$else}\r
+\r
+procedure bread( var f:file; var buf; count:word; var result:word);\r
+begin\r
+ blockread(f, buf, count, result);\r
+ if (result < 1) then begin\r
+ writeln('BufIO.bread: unexpected eof.');\r
+ end;\r
+end;\r
+\r
+procedure bseek(var f:file; p:longint);\r
+begin\r
+ seek(f, p);\r
+end;\r
+\r
+function bpos(var f:file):longint;\r
+begin\r
+ bpos := filepos(f);\r
+end;\r
+\r
+procedure bskip(var f:file; n:longint);\r
+begin\r
+ bseek(f, filepos(f)+n);\r
+end;\r
+\r
+{$endif}\r
+\r
+(*\r
+var SaveExitProc : Pointer;\r
+\r
+{$F+} procedure MyExitProc; {$F-}\r
+begin\r
+ ExitProc := SaveExitProc;\r
+end;\r
+*)\r
+\r
+begin\r
+{$ifdef Buffered}\r
+ inbuf := 0;\r
+ curbuf := 1;\r
+{$endif}\r
+end.\r
+\1a
\ No newline at end of file
--- /dev/null
+{$R+,I+,V-}\r
+\r
+program ngdump;\r
+\r
+uses crt, dos,\r
+ BufIO;\r
+\r
+const progname = 'NGDUMP';\r
+ version = 'V1.0';\r
+ copyright = 'Copyright 1989 J.P.Pedersen, 1990 E.v.Asperen';\r
+\r
+ MaxNameLen = 40;\r
+ MaxLineLen = 160;\r
+\r
+type gentry = record {General entry type}\r
+ filptr:longint;\r
+ name:string[MaxNameLen];\r
+ end;\r
+ line = string[MaxLineLen];\r
+\r
+var\r
+ mennu:array[0..3,0..8] of gentry; {Buffer to hold variable part of guide menu structure}\r
+ itemlist:array[0..3] of byte; {Menu structure info}\r
+ errorinfo:array[3..6] of string[14]; {Buffer for error messages}\r
+ f:file; {The guide file}\r
+ propath,homedir,streng:string; {String variables, mostly for path and file use}\r
+ erro,\r
+ seealsonum,\r
+ menuantal,\r
+ menunr : byte; {Byte variables}\r
+ entrytype : (et_misc, et_short, et_long);\r
+ guidename : line;\r
+\r
+const MaxLevel = 10;\r
+ OutBufSize = 4096;\r
+\r
+type FileBuffer = array [1..OutBufSize] of byte;\r
+\r
+var outf : array [1..MaxLevel] of text;\r
+ flevel : 1..MaxLevel;\r
+ OutBuf : array [1..MaxLevel] of ^FileBuffer;\r
+ Nfiles : word;\r
+ numentries : longint;\r
+\r
+\r
+\r
+procedure threenitvars; {Initialize variables}\r
+begin\r
+ menunr := 0;\r
+end;\r
+\r
+procedure twonitvars; {Initialize variables}\r
+begin\r
+ threenitvars;\r
+end;\r
+\r
+procedure initvars; {Initialize variables}\r
+var str5:string;\r
+begin\r
+ twonitvars;\r
+ errorinfo[3] := 'File not found';\r
+ errorinfo[4] := 'Not an NG file';\r
+ errorinfo[5] := 'Unexpected EOF';\r
+ errorinfo[6] := 'Corrupted file';\r
+ str5 := '';propath := paramstr(0);\r
+ while (pos('\',propath) > 0) do begin\r
+ str5 := str5+copy(propath,1,pos('\',propath));\r
+ propath := copy(propath,pos('\',propath)+1,length(propath)-(pos('\',propath)+1));\r
+ end;\r
+ propath := str5;\r
+end;\r
+\r
+var attr, startattr : byte;\r
+\r
+procedure WriteNgString(var outf:text; s:string);\r
+var i,j:byte;\r
+ c:char;\r
+begin\r
+ i := 1;\r
+ attr := startattr;\r
+ while (i <= length(s)) do begin\r
+ c := s[i];\r
+ if c = #255 then begin\r
+ {Expand spaces}\r
+ inc(i);\r
+ c := s[i];\r
+ for j := 1 to ord(c) do begin\r
+ write(outf, ' ');\r
+ end;\r
+ end\r
+ else begin\r
+ if (c = '!') and (i = 1) then write(outf, c);\r
+ write(outf, c);\r
+ end;\r
+ inc(i);\r
+ end;\r
+\r
+ writeln(outf);\r
+end;\r
+\r
+procedure WriteString(s:string);\r
+begin\r
+ WriteNgString(outf[flevel], s);\r
+end;\r
+\r
+const Fx = 10; Fy = 2;\r
+ Gx = 10; Gy = 3;\r
+ Mx = 10; My = 5;\r
+ Cx = 10; Cy = 7;\r
+ Lx = 10; Ly = 8;\r
+ Sx = 10; Sy = 10;\r
+\r
+\r
+procedure ShowShort(s:string);\r
+begin\r
+ gotoxy(Sx, Sy); ClrEol;\r
+ gotoxy(1, Sy+1); ClrEol;\r
+ gotoxy(Sx, Sy); WriteNgString(Output, s);\r
+end;\r
+\r
+procedure ShowLong(n:longint);\r
+begin\r
+ gotoxy(Lx, Ly); write(n:7);\r
+end;\r
+\r
+procedure ShowEndLong;\r
+begin\r
+ gotoxy(Lx, Ly); ClrEol;\r
+end;\r
+\r
+procedure ShowFile(s:string);\r
+begin\r
+ gotoxy(Fx, Fy); ClrEol; write(s);\r
+end;\r
+\r
+procedure ShowGuide(s:string);\r
+begin\r
+ gotoxy(Gx, Gy); ClrEol; write(s);\r
+end;\r
+\r
+procedure ShowCount(n:longint);\r
+begin\r
+ gotoxy(Cx, Cy); write(n:7);\r
+end;\r
+\r
+procedure ShowMenu(s:string);\r
+begin\r
+ gotoxy(Mx, My); ClrEol; WriteNgString(output, s);\r
+end;\r
+\r
+procedure ScreenInit;\r
+begin\r
+ ClrScr;\r
+ gotoxy(Fx-8, Fy); write(' file:');\r
+ gotoxy(Gx-8, Gy); write('guide:');\r
+ gotoxy(Mx-8, My); write(' menu:');\r
+ gotoxy(Cx-8, Cy); write('count:');\r
+ gotoxy(Lx-8, Ly); write('lines:');\r
+ gotoxy(Sx-8, Sy); write('entry:');\r
+end;\r
+\r
+procedure ScreenExit;\r
+begin\r
+ gotoxy(1, Sy+3); ClrScr;\r
+end;\r
+\r
+procedure Usage; {Write usage info}\r
+begin\r
+ writeln;\r
+ writeln('usage: ngdump filename');\r
+ writeln;\r
+ Halt(1);\r
+end;\r
+\r
+procedure slutlort(b:byte); {Exit on error and display relevant error message}\r
+begin\r
+ if b > 3 then close(f);\r
+ if b > 2 then begin\r
+ writeln('NGDUMP ERROR #', b, ': '+errorinfo[b]+', cannot proceed');\r
+ end;\r
+ if b < 3 then usage;\r
+ halt(0);\r
+end;\r
+\r
+procedure sllut(b:byte); {Error handler without exit, just indicating the error type}\r
+var sl:byte;\r
+begin\r
+ sl := 0;\r
+ if b > 3 then close(f);\r
+ writeln(' ',errorinfo[b],' - Press any key');\r
+ erro := 1;\r
+end;\r
+\r
+function decrypt(b:byte):byte; {Decrypt byte from NG format}\r
+begin\r
+(*\r
+ if ((b mod 32)>=16) then b := b-16 else b := b+16;\r
+ if ((b mod 16)>=8) then b := b-8 else b := b+8;\r
+ if ((b mod 4)>=2) then b := b-2 else b := b+2;\r
+ decrypt := b;\r
+*)\r
+ decrypt := b xor (16+8+2); { this is somewhat more efficient... EVAS}\r
+end;\r
+\r
+function read_byte:byte; {Read and decrypt byte}\r
+var tb:byte;\r
+ numread:word;\r
+begin\r
+ bread(f, tb, 1, numread);\r
+ read_byte := tb xor 26;\r
+end;\r
+\r
+function read_word:word; {Read and decrypt word}\r
+var tb:byte;\r
+begin\r
+ tb := read_byte;\r
+ read_word := word(tb) or (word(read_byte) shl 8);\r
+end;\r
+\r
+function read_long:longint; {Read and decrypt longint}\r
+var tw:word;\r
+begin\r
+ tw := read_word;\r
+ read_long := longint(tw) or (longint(read_word) shl 16);\r
+end;\r
+\r
+type BigStr = string[255];\r
+\r
+procedure read_string(maxlen:byte; var s:BigStr);\r
+var c,j:byte;\r
+begin\r
+ j := 0;\r
+ repeat\r
+ c := read_byte;\r
+ inc(j);\r
+ s[j] := chr(c);\r
+ until (c = 0) or (j = maxlen);\r
+ s[0] := chr(j-1);\r
+end;\r
+\r
+procedure read_menu; {Read a menu structure into the menu buffer}\r
+var items,i,j:word;\r
+begin\r
+ mennu[menunr,0].filptr := bpos(f)-2;\r
+ bskip(f, 2);\r
+ items := read_word;\r
+ itemlist[menunr] := items;\r
+ bskip(f, 20);\r
+ for i := 1 to items-1 do begin\r
+ mennu[menunr,i].filptr := read_long;\r
+ end;\r
+ bskip(f, items * 8);\r
+ for i := 0 to items-1 do begin\r
+ with mennu[menunr, i] do begin\r
+ read_string( 40, name );\r
+ end;\r
+ end;\r
+ bskip(f, 1);\r
+end;\r
+\r
+procedure skip_short_long; {Skip procedure for the initial menu bseek}\r
+var length:word;\r
+begin\r
+ length := read_word;\r
+ bskip(f, length + 22);\r
+end;\r
+\r
+procedure read_header(modf:byte); {Read NG file header and enter the guide name in the screen template}\r
+var buf : array[0..377] of byte;\r
+ i,numread : word;\r
+begin\r
+ bread(f, buf, sizeof(buf), numread);\r
+ if ((buf[0]<>ord('N')) or (buf[1]<>ord('G'))) then begin\r
+ {If the two first characters in the file are not 'NG', the file is no guide}\r
+ if modf = 0\r
+ then slutlort(4)\r
+ else sllut(4);\r
+ end;\r
+\r
+ menuantal := buf[6];\r
+ i := 0;\r
+ repeat\r
+ guidename[i+1] := chr(buf[i+8]);\r
+ inc(i);\r
+ until (buf[i+8] = 0);\r
+ guidename[0] := chr(i);\r
+\r
+ ShowGuide( guidename );\r
+ bseek(f, 378);\r
+end;\r
+\r
+procedure read_menus(modf:boolean); {Initial menu bseek, indexing the whole file}\r
+var id : word;\r
+begin\r
+ repeat\r
+ id := read_word;\r
+ if (id < 2) then begin\r
+ skip_short_long\r
+ end\r
+ else if (id = 2) then begin\r
+ read_menu;\r
+ inc(menunr);\r
+ end\r
+ else if (id <> 5) then begin\r
+ if (filesize(f) <> bpos(f)) then begin\r
+ if (not modf)\r
+ then slutlort(5)\r
+ else sllut(5); {NG file error}\r
+ end\r
+ else id := 5;\r
+ end;\r
+ until (id = 5);\r
+\r
+ if (menunr <> menuantal) then begin\r
+ if (not modf)\r
+ then slutlort(6)\r
+ else sllut(6); {Incomplete file}\r
+ end;\r
+end;\r
+\r
+function MakeName:Dos.PathStr;\r
+var fname:Dos.PathStr;\r
+begin\r
+ inc(Nfiles);\r
+ str(Nfiles, fname);\r
+ MakeName := fname;\r
+end;\r
+\r
+procedure OpenOutFile(n:word; s:Dos.PathStr);\r
+begin\r
+ assign(outf[n], s); rewrite(outf[n]);\r
+ SetTextBuf(outf[n], OutBuf[n]^, OutBufSize);\r
+end;\r
+\r
+procedure read_entry(level:byte; fp:longint); forward;\r
+\r
+procedure read_short_entry(level:byte);\r
+{Read short entry from file and wring some information out of it}\r
+var i, items: word;\r
+ subject : line;\r
+ entrypos, subj_pos, p0, p : longint;\r
+begin\r
+ bskip(f, 2);\r
+ items := read_word;\r
+ bskip(f, 20);\r
+ p0 := bpos(f);\r
+ subj_pos := p0 + longint(items) * 6;\r
+ for i := 1 to items do begin\r
+ bskip(f, 2);\r
+ entrypos := read_long;\r
+ p := bpos(f);\r
+ bseek(f, subj_pos);\r
+ read_string( MaxLineLen, subject );\r
+ subj_pos := bpos(f);\r
+ write(outf[flevel], '!short:'); WriteString(subject);\r
+{} ShowShort(subject);\r
+ read_entry(level+1, entrypos);\r
+ bseek(f, p);\r
+ end;\r
+end;\r
+\r
+procedure read_long_entry;\r
+{Read long entry information}\r
+const MaxSeeAlso = 20;\r
+var i, linens, dlength, seealso_num : word;\r
+ s : line;\r
+begin\r
+ bskip(f, 2);\r
+ linens := read_word;\r
+ dlength := read_word;\r
+{} ShowLong(linens);\r
+ bskip(f, 18); { 10 + links to prev/next entry (long's) }\r
+ for i := 1 to linens do begin\r
+ read_string( MaxLineLen, s );\r
+ WriteString(s);\r
+ end;\r
+\r
+ if dlength <> 0 then begin {If there are seealso entries, read them}\r
+ seealso_num := read_word;\r
+ { skip the offsets for the SeeAlso-items; }\r
+ bskip(f, seealso_num * 4);\r
+ { read the items; }\r
+ for i := 1 to seealso_num do begin\r
+ if i <= MaxSeeAlso then begin\r
+ read_string( MaxLineLen, s );\r
+ writeln(outf[flevel], '!seealso: "', s, '"');\r
+ end;\r
+ end;\r
+ end;\r
+{} ShowEndLong;\r
+end;\r
+\r
+procedure read_entry(level:byte; fp:longint); {Read some kind of file entry}\r
+var id:word; fname:dos.pathstr;\r
+begin\r
+ inc(numentries); ShowCount(numentries);\r
+ bseek(f, fp);\r
+ id := read_word;\r
+ case id of\r
+ 0: begin\r
+ if (level > 0) then begin\r
+ fname := MakeName;\r
+ writeln(outf[flevel], '!file: ',fname+'.NGO');\r
+ inc(flevel);\r
+{$ifdef Debug}\r
+ assign(outf[flevel], 'CON'); rewrite(outf[flevel]);\r
+{$else}\r
+ OpenOutFile(flevel, fname+'.DAT');\r
+{$endif}\r
+ read_short_entry(level);\r
+ close(outf[flevel]);\r
+ dec(flevel);\r
+ end\r
+ else begin\r
+ read_short_entry(level);\r
+ end;\r
+ end;\r
+ 1: begin\r
+(*\r
+ if (level > 0) and (not odd(level)) then begin\r
+ fname := MakeName;\r
+ writeln(outf[flevel], '!long: ',fname+'.NGO');\r
+ inc(flevel);\r
+{$ifdef Debug}\r
+ assign(outf[flevel], 'CON'); rewrite(outf[flevel]);\r
+{$else}\r
+ OpenOutFile(flevel, fname+'.DAT');\r
+{$endif}\r
+ read_long_entry;\r
+ close(outf[flevel]);\r
+ dec(flevel);\r
+ end\r
+ else begin\r
+ read_long_entry;\r
+ end;\r
+*)\r
+ read_long_entry;\r
+ end;\r
+ end;\r
+end;\r
+\r
+\r
+procedure Main;\r
+label Next;\r
+var i,j,k:word;\r
+ linkf : text;\r
+ fname : Dos.PathStr;\r
+begin\r
+ numentries := 0;\r
+\r
+ { create Menu Link Control File; }\r
+ assign(linkf, 'GUIDE.LCF'); rewrite(linkf);\r
+ writeln(linkf, '!name:'^i, guidename);\r
+ writeln(linkf);\r
+\r
+ for i := 0 to menuantal-1 do begin\r
+ writeln(linkf, '!menu:'^i, mennu[i,0].name);\r
+ ShowMenu(mennu[i,0].name);\r
+ for j := 1 to itemlist[i]-1 do begin\r
+ close(outf[flevel]);\r
+ fname := MakeName;\r
+ OpenOutFile(flevel, fname+'.dat');\r
+ ShowMenu(mennu[i,j].name);\r
+ writeln(linkf, ^i, mennu[i,j].name, ^i, fname+'.ngo');\r
+ read_entry( 0, mennu[i,j].filptr );\r
+Next:\r
+ end;\r
+ end;\r
+\r
+ close(linkf);\r
+\r
+ { write a makefile; }\r
+ assign(linkf, 'MAKEGUID'); rewrite(linkf);\r
+ writeln(linkf, '.dat.ngo:');\r
+ writeln(linkf, ^i'ngc $<');\r
+ writeln(linkf);\r
+ write(linkf, 'OBJECTS=');\r
+ j := 0;\r
+ for i := 1 to Nfiles do begin\r
+ str(i, fname);\r
+ fname := fname + '.ngo ';\r
+ write(linkf, fname);\r
+ inc(j, length(fname));\r
+ if (j > 65) then begin\r
+ write(linkf, '\'^m^j^i);\r
+ j := 0;\r
+ end;\r
+ end;\r
+ writeln(linkf);\r
+ writeln(linkf);\r
+ writeln(linkf, 'guide.ng: $(OBJECTS)');\r
+ writeln(linkf, ^i'ngml guide.lcf');\r
+ close(linkf);\r
+end;\r
+\r
+var i:byte;\r
+begin {Main loop and command-line parser}\r
+ flevel := 1;\r
+ Nfiles := 0;\r
+ for i := 1 to MaxLevel do begin\r
+ new(OutBuf[i]);\r
+ end;\r
+\r
+{$ifndef Debug}\r
+ assign(outf[flevel], 'CON');\r
+{$else}\r
+ assign(outf[flevel], 'GUIDE.DAT');\r
+{$endif}\r
+ rewrite(outf[flevel]);\r
+ SetTextBuf(outf[flevel], OutBuf[flevel]^, OutBufSize);\r
+\r
+ writeln(progname,' ',version,'. ',copyright,'.');\r
+ initvars; {Initialize global variables}\r
+\r
+ if ((paramstr(1)='/?') or (paramstr(1)='/h') or (paramstr(1)='/H')) then begin\r
+ Usage;\r
+ end;\r
+\r
+ if (ParamCount <> 1) then begin\r
+ Usage;\r
+ end;\r
+\r
+ streng := paramstr(1);\r
+\r
+ if pos('.',streng)=0\r
+ then streng := streng+'.NG'; {Expand file name}\r
+\r
+ assign(f, streng);\r
+{$I-}\r
+ reset(f, 1);\r
+ if ioresult<>0 then slutlort(3); {If file does not exist, terminate and write cause of death}\r
+{$I+}\r
+\r
+ ScreenInit;\r
+ ShowFile(streng);\r
+ ShowMenu('reading menu-info...');\r
+ read_header(0);\r
+ read_menus(False);\r
+ Main;\r
+\r
+ close(f);\r
+ close(outf[flevel]);\r
+ ScreenExit;\r
+end.\r
+\1a
\ No newline at end of file
--- /dev/null
+21/06/1990\r
+\r
+\r
+This is the README for NGDUMP, a decompiler for Norton Guides Database\r
+files. NGDUMP is based on NG_CLONE, a clone of the NG program I found\r
+on SIMTEL (<msdos.txtutl>ng_clone.zip). I modified the program to emit\r
+source code for the NG compiler.\r
+\r
+usage: ngdump databasefile[.ng]\r
+\r
+NGDUMP creates numbered data-files (1.dat, 2.dat, etc.) with the text,\r
+a NG linker control file (GUIDE.LCF), and a makefile (MAKEGUID).\r
+\r
+Enjoy\r
+\r
+Eelco van Asperen\r
+evas@cs.eur.nl (asperen@hroeur5.bitnet)\r
+Erasmus University Rotterdam, The Netherlands\r
--- /dev/null
+21/06/1990\r
+\r
+\r
+This is the README for NGDUMP, a decompiler for Norton Guides Database\r
+files. NGDUMP is based on NG_CLONE, a clone of the NG program I found\r
+on SIMTEL (<msdos.txtutl>ng_clone.zip). I modified the program to emit\r
+source code for the NG compiler.\r
+\r
+usage: ngdump databasefile[.ng]\r
+\r
+NGDUMP creates numbered data-files (1.dat, 2.dat, etc.) with the text,\r
+a NG linker control file (GUIDE.LCF), and a makefile (MAKEGUID).\r
+\r
+Enjoy\r
+\r
+Eelco van Asperen\r
+evas@cs.eur.nl (asperen@hroeur5.bitnet)\r
+Erasmus University Rotterdam, The Netherlands\r
--- /dev/null
+IIUWGRAPH:\r
+procedure gron(mode :integer);\r
+procedure groff;\r
+procedure cls;\r
+procedure point(x,y :integer);\r
+procedure move(x,y :integer);\r
+procedure draw(x,y,c :integer); /* lineto */\r
+procedure hfill(x :integer); /* Hline */\r
+procedure vfill(y :integer); /* Vline */\r
+procedure color(c :integer); /* setfgcolor */\r
+procedure patern(x1,y1,x2,y2,c,motif :integer); /* box */\r
+procedure intens(num :integer; x,y:arrayof integer; c,motif :integer); /* polygon*/\r
+procedure palett(x :integer);\r
+procedure border(c :integer); /* setbgcolor */\r
+function inxpos : integer;\r
+function inypos : integer;\r
+procedure inpix( output x,y :integer);\r
+function getmap(x,y :integer):arrayof integer;\r
+procedure putmap(map :arrayof integer);\r
+procedure ormap(map :arrayof integer);\r
+procedure xormap(map :arrayof integer);\r
+procedure track(x,y,c,val :integer); /* writint */\r
+function inkey : integer;\r
+procedure hascii(car : integer);\r
+function hfont(x,y,lg,min,max,defaut,col_f,col_e,col_c :integer):integer /* gscnum */\r
+function hfont8(x,y,lg,lgmax :integer;defaut :string; col_f,col_e,col_c :integer):arrayof char /* gschar */\r
+procedure outstring(x,y :integer;texte :string;col_e,col_f :integer);\r
+procedure cirb(x,y,rx,ry,start,end,c,motif : integer); /* ellipse */\r
+MOUSE:\r
+procedure init(mo,kb : integer); \r
+procedure getmovement(mo,kb : integer); /* changevtype */\r
+function getpress(v,p,h,l,r,c : integer): boolean;\r
+procedure showcursor;\r
+procedure hidecursor;\r
--- /dev/null
+\ 4%!PS-Adobe-3.0\r
+%%Creator: Windows PSCRIPT\r
+%%Title: Microsoft Word - QUICKREF.DOC\r
+%%BoundingBox: 9 15 584 830\r
+%%DocumentNeededResources: (atend)\r
+%%DocumentSuppliedResources: (atend)\r
+%%Pages: (atend)\r
+%%BeginResource: procset Win35Dict 3 1\r
+/Win35Dict 290 dict def Win35Dict begin/bd{bind def}bind def/in{72\r
+mul}bd/ed{exch def}bd/ld{load def}bd/tr/translate ld/gs/gsave ld/gr\r
+/grestore ld/M/moveto ld/L/lineto ld/rmt/rmoveto ld/rlt/rlineto ld\r
+/rct/rcurveto ld/st/stroke ld/n/newpath ld/sm/setmatrix ld/cm/currentmatrix\r
+ld/cp/closepath ld/ARC/arcn ld/TR{65536 div}bd/lj/setlinejoin ld/lc\r
+/setlinecap ld/ml/setmiterlimit ld/sl/setlinewidth ld/scignore false\r
+def/sc{scignore{pop pop pop}{0 index 2 index eq 2 index 4 index eq\r
+and{pop pop 255 div setgray}{3{255 div 3 1 roll}repeat setrgbcolor}ifelse}ifelse}bd\r
+/FC{bR bG bB sc}bd/fC{/bB ed/bG ed/bR ed}bd/HC{hR hG hB sc}bd/hC{\r
+/hB ed/hG ed/hR ed}bd/PC{pR pG pB sc}bd/pC{/pB ed/pG ed/pR ed}bd/sM\r
+matrix def/PenW 1 def/iPen 5 def/mxF matrix def/mxE matrix def/mxUE\r
+matrix def/mxUF matrix def/fBE false def/iDevRes 72 0 matrix defaultmatrix\r
+dtransform dup mul exch dup mul add sqrt def/fPP false def/SS{fPP{\r
+/SV save def}{gs}ifelse}bd/RS{fPP{SV restore}{gr}ifelse}bd/EJ{gsave\r
+showpage grestore}bd/#C{userdict begin/#copies ed end}bd/FEbuf 2 string\r
+def/FEglyph(G )def/FE{1 exch{dup 16 FEbuf cvrs FEglyph exch 1 exch\r
+putinterval 1 index exch FEglyph cvn put}for}bd/SM{/iRes ed/cyP ed\r
+/cxPg ed/cyM ed/cxM ed 72 100 div dup scale dup 0 ne{90 eq{cyM exch\r
+0 eq{cxM exch tr -90 rotate -1 1 scale}{cxM cxPg add exch tr +90 rotate}ifelse}{cyP\r
+cyM sub exch 0 ne{cxM exch tr -90 rotate}{cxM cxPg add exch tr -90\r
+rotate 1 -1 scale}ifelse}ifelse}{pop cyP cyM sub exch 0 ne{cxM cxPg\r
+add exch tr 180 rotate}{cxM exch tr 1 -1 scale}ifelse}ifelse 100 iRes\r
+div dup scale 0 0 transform .25 add round .25 sub exch .25 add round\r
+.25 sub exch itransform translate}bd/SJ{1 index 0 eq{pop pop/fBE false\r
+def}{1 index/Break ed div/dxBreak ed/fBE true def}ifelse}bd/ANSIVec[\r
+16#0/grave 16#1/acute 16#2/circumflex 16#3/tilde 16#4/macron 16#5/breve\r
+16#6/dotaccent 16#7/dieresis 16#8/ring 16#9/cedilla 16#A/hungarumlaut\r
+16#B/ogonek 16#C/caron 16#D/dotlessi 16#27/quotesingle 16#60/grave\r
+16#7C/bar 16#82/quotesinglbase 16#83/florin 16#84/quotedblbase 16#85\r
+/ellipsis 16#86/dagger 16#87/daggerdbl 16#89/perthousand 16#8A/Scaron\r
+16#8B/guilsinglleft 16#8C/OE 16#91/quoteleft 16#92/quoteright 16#93\r
+/quotedblleft 16#94/quotedblright 16#95/bullet 16#96/endash 16#97\r
+/emdash 16#99/trademark 16#9A/scaron 16#9B/guilsinglright 16#9C/oe\r
+16#9F/Ydieresis 16#A0/space 16#A4/currency 16#A6/brokenbar 16#A7/section\r
+16#A8/dieresis 16#A9/copyright 16#AA/ordfeminine 16#AB/guillemotleft\r
+16#AC/logicalnot 16#AD/hyphen 16#AE/registered 16#AF/macron 16#B0/degree\r
+16#B1/plusminus 16#B2/twosuperior 16#B3/threesuperior 16#B4/acute 16#B5\r
+/mu 16#B6/paragraph 16#B7/periodcentered 16#B8/cedilla 16#B9/onesuperior\r
+16#BA/ordmasculine 16#BB/guillemotright 16#BC/onequarter 16#BD/onehalf\r
+16#BE/threequarters 16#BF/questiondown 16#C0/Agrave 16#C1/Aacute 16#C2\r
+/Acircumflex 16#C3/Atilde 16#C4/Adieresis 16#C5/Aring 16#C6/AE 16#C7\r
+/Ccedilla 16#C8/Egrave 16#C9/Eacute 16#CA/Ecircumflex 16#CB/Edieresis\r
+16#CC/Igrave 16#CD/Iacute 16#CE/Icircumflex 16#CF/Idieresis 16#D0/Eth\r
+16#D1/Ntilde 16#D2/Ograve 16#D3/Oacute 16#D4/Ocircumflex 16#D5/Otilde\r
+16#D6/Odieresis 16#D7/multiply 16#D8/Oslash 16#D9/Ugrave 16#DA/Uacute\r
+16#DB/Ucircumflex 16#DC/Udieresis 16#DD/Yacute 16#DE/Thorn 16#DF/germandbls\r
+16#E0/agrave 16#E1/aacute 16#E2/acircumflex 16#E3/atilde 16#E4/adieresis\r
+16#E5/aring 16#E6/ae 16#E7/ccedilla 16#E8/egrave 16#E9/eacute 16#EA\r
+/ecircumflex 16#EB/edieresis 16#EC/igrave 16#ED/iacute 16#EE/icircumflex\r
+16#EF/idieresis 16#F0/eth 16#F1/ntilde 16#F2/ograve 16#F3/oacute 16#F4\r
+/ocircumflex 16#F5/otilde 16#F6/odieresis 16#F7/divide 16#F8/oslash\r
+16#F9/ugrave 16#FA/uacute 16#FB/ucircumflex 16#FC/udieresis 16#FD/yacute\r
+16#FE/thorn 16#FF/ydieresis ] def/reencdict 12 dict def/IsChar{basefontdict\r
+/CharStrings get exch known}bd/MapCh{dup IsChar not{pop/bullet}if\r
+newfont/Encoding get 3 1 roll put}bd/MapDegree{16#b0/degree IsChar{\r
+/degree}{/ring}ifelse MapCh}bd/MapBB{16#a6/brokenbar IsChar{/brokenbar}{\r
+/bar}ifelse MapCh}bd/ANSIFont{reencdict begin/newfontname ed/basefontname\r
+ed FontDirectory newfontname known not{/basefontdict basefontname findfont\r
+def/newfont basefontdict maxlength dict def basefontdict{exch dup/FID\r
+ne{dup/Encoding eq{exch dup length array copy newfont 3 1 roll put}{exch\r
+newfont 3 1 roll put}ifelse}{pop pop}ifelse}forall newfont/FontName\r
+newfontname put 127 1 159{newfont/Encoding get exch/bullet put}for\r
+ANSIVec aload pop ANSIVec length 2 idiv{MapCh}repeat MapDegree MapBB\r
+newfontname newfont definefont pop}if newfontname end}bd/SB{FC/ULlen\r
+ed/str ed str length fBE not{dup 1 gt{1 sub}if}if/cbStr ed/dxGdi ed\r
+/y0 ed/x0 ed str stringwidth dup 0 ne{/y1 ed/x1 ed y1 y1 mul x1 x1\r
+mul add sqrt dxGdi exch div 1 sub dup x1 mul cbStr div exch y1 mul\r
+cbStr div}{exch abs neg dxGdi add cbStr div exch}ifelse/dyExtra ed\r
+/dxExtra ed x0 y0 M fBE{dxBreak 0 BCh dxExtra dyExtra str awidthshow}{dxExtra\r
+dyExtra str ashow}ifelse fUL{x0 y0 M dxUL dyUL rmt ULlen fBE{Break\r
+add}if 0 mxUE transform gs rlt cyUL sl [] 0 setdash st gr}if fSO{x0\r
+y0 M dxSO dySO rmt ULlen fBE{Break add}if 0 mxUE transform gs rlt cyUL\r
+sl [] 0 setdash st gr}if n/fBE false def}bd/font{/name ed/Ascent ed\r
+0 ne/fT3 ed 0 ne/fSO ed 0 ne/fUL ed/Sy ed/Sx ed 10.0 div/ori ed -10.0\r
+div/esc ed/BCh ed name findfont/xAscent 0 def/yAscent Ascent def/ULesc\r
+esc def ULesc mxUE rotate pop fT3{/esc 0 def xAscent yAscent mxUE transform\r
+/yAscent ed/xAscent ed}if [Sx 0 0 Sy neg xAscent yAscent] esc mxE\r
+rotate mxF concatmatrix makefont setfont [Sx 0 0 Sy neg 0 Ascent] mxUE\r
+mxUF concatmatrix pop fUL{currentfont dup/FontInfo get/UnderlinePosition\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlinePosition get\r
+1000 div 0 exch mxUF transform/dyUL ed/dxUL ed}if fSO{0 .3 mxUF transform\r
+/dySO ed/dxSO ed}if fUL fSO or{currentfont dup/FontInfo get/UnderlineThickness\r
+known not{pop/Courier findfont}if/FontInfo get/UnderlineThickness get\r
+1000 div Sy mul/cyUL ed}if}bd/min{2 copy gt{exch}if pop}bd/max{2 copy\r
+lt{exch}if pop}bd/CP{/ft ed{{ft 0 eq{clip}{eoclip}ifelse}stopped{currentflat\r
+1 add setflat}{exit}ifelse}loop}bd/patfont 10 dict def patfont begin\r
+/FontType 3 def/FontMatrix [1 0 0 -1 0 0] def/FontBBox [0 0 16 16]\r
+def/Encoding StandardEncoding def/BuildChar{pop pop 16 0 0 0 16 16\r
+setcachedevice 16 16 false [1 0 0 1 .25 .25]{pat}imagemask}bd end/p{\r
+/pat 32 string def{}forall 0 1 7{dup 2 mul pat exch 3 index put dup\r
+2 mul 1 add pat exch 3 index put dup 2 mul 16 add pat exch 3 index\r
+put 2 mul 17 add pat exch 2 index put pop}for}bd/pfill{/PatFont patfont\r
+definefont setfont/ch(AAAA)def X0 64 X1{Y1 -16 Y0{1 index exch M ch\r
+show}for pop}for}bd/vert{X0 w X1{dup Y0 M Y1 L st}for}bd/horz{Y0 w\r
+Y1{dup X0 exch M X1 exch L st}for}bd/fdiag{X0 w X1{Y0 M X1 X0 sub dup\r
+rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup rlt st}for}bd/bdiag{X0 w\r
+X1{Y1 M X1 X0 sub dup neg rlt st}for Y0 w Y1{X0 exch M Y1 Y0 sub dup\r
+neg rlt st}for}bd/AU{1 add cvi 15 or}bd/AD{1 sub cvi -16 and}bd/SHR{pathbbox\r
+AU/Y1 ed AU/X1 ed AD/Y0 ed AD/X0 ed}bd/hfill{/w iRes 37.5 div round\r
+def 0.1 sl [] 0 setdash n dup 0 eq{horz}if dup 1 eq{vert}if dup 2 eq{fdiag}if\r
+dup 3 eq{bdiag}if dup 4 eq{horz vert}if 5 eq{fdiag bdiag}if}bd/F{/ft\r
+ed fm 256 and 0 ne{gs FC ft 0 eq{fill}{eofill}ifelse gr}if fm 1536\r
+and 0 ne{SHR gs HC ft CP fm 1024 and 0 ne{/Tmp save def pfill Tmp restore}{fm\r
+15 and hfill}ifelse gr}if}bd/S{PenW sl PC st}bd/m matrix def/GW{iRes\r
+12 div PenW add cvi}bd/DoW{iRes 50 div PenW add cvi}bd/DW{iRes 8 div\r
+PenW add cvi}bd/SP{/PenW ed/iPen ed iPen 0 eq iPen 6 eq or{[] 0 setdash}if\r
+iPen 1 eq{[DW GW] 0 setdash}if iPen 2 eq{[DoW GW] 0 setdash}if iPen\r
+3 eq{[DW GW DoW GW] 0 setdash}if iPen 4 eq{[DW GW DoW GW DoW GW] 0\r
+setdash}if}bd/E{m cm pop tr scale 1 0 moveto 0 0 1 0 360 arc cp m sm}bd\r
+/AG{/sy ed/sx ed sx div 4 1 roll sy div 4 1 roll sx div 4 1 roll sy\r
+div 4 1 roll atan/a2 ed atan/a1 ed sx sy scale a1 a2 ARC}def/A{m cm\r
+pop tr AG m sm}def/P{m cm pop tr 0 0 M AG cp m sm}def/RRect{n 4 copy\r
+M 3 1 roll exch L 4 2 roll L L cp}bd/RRCC{/r ed/y1 ed/x1 ed/y0 ed/x0\r
+ed x0 x1 add 2 div y0 M x1 y0 x1 y1 r arcto 4{pop}repeat x1 y1 x0 y1\r
+r arcto 4{pop}repeat x0 y1 x0 y0 r arcto 4{pop}repeat x0 y0 x1 y0 r\r
+arcto 4{pop}repeat cp}bd/RR{2 copy 0 eq exch 0 eq or{pop pop RRect}{2\r
+copy eq{pop RRCC}{m cm pop/y2 ed/x2 ed/ys y2 x2 div 1 max def/xs x2\r
+y2 div 1 max def/y1 exch ys div def/x1 exch xs div def/y0 exch ys div\r
+def/x0 exch xs div def/r2 x2 y2 min def xs ys scale x0 x1 add 2 div\r
+y0 M x1 y0 x1 y1 r2 arcto 4{pop}repeat x1 y1 x0 y1 r2 arcto 4{pop}repeat\r
+x0 y1 x0 y0 r2 arcto 4{pop}repeat x0 y0 x1 y0 r2 arcto 4{pop}repeat\r
+m sm cp}ifelse}ifelse}bd/PP{{rlt}repeat}bd/OB{gs 0 ne{7 3 roll/y ed\r
+/x ed x y translate ULesc rotate x neg y neg translate x y 7 -3 roll}if\r
+sc B fill gr}bd/B{M/dy ed/dx ed dx 0 rlt 0 dy rlt dx neg 0 rlt cp}bd\r
+/CB{B clip n}bd/ErrHandler{errordict dup maxlength exch length gt\r
+dup{errordict begin}if/errhelpdict 12 dict def errhelpdict begin/stackunderflow(operand stack underflow)def\r
+/undefined(this name is not defined in a dictionary)def/VMerror(you have used up all the printer's memory)def\r
+/typecheck(operator was expecting a different type of operand)def\r
+/ioerror(input/output error occured)def end{end}if errordict begin\r
+/handleerror{$error begin newerror{/newerror false def showpage 72\r
+72 scale/x .25 def/y 9.6 def/Helvetica findfont .2 scalefont setfont\r
+x y moveto(Offending Command = )show/command load{dup type/stringtype\r
+ne{(max err string)cvs}if show}exec/y y .2 sub def x y moveto(Error = )show\r
+errorname{dup type dup( max err string )cvs show( : )show/stringtype\r
+ne{( max err string )cvs}if show}exec errordict begin errhelpdict errorname\r
+known{x 1 add y .2 sub moveto errhelpdict errorname get show}if end\r
+/y y .4 sub def x y moveto(Stack =)show ostack{/y y .2 sub def x 1\r
+add y moveto dup type/stringtype ne{( max err string )cvs}if show}forall\r
+showpage}if end}def end}bd end\r
+%%EndResource\r
+/SVDoc save def\r
+%%EndProlog\r
+%%BeginSetup\r
+Win35Dict begin\r
+ErrHandler\r
+statusdict begin 0 setjobtimeout end\r
+statusdict begin statusdict /jobname (Microsoft Word - QUICKREF.DOC) put end\r
+/oldDictCnt countdictstack def {statusdict begin 0 setpapertray end\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+/oldDictCnt countdictstack def {a4\r
+}stopped \r
+{ countdictstack oldDictCnt lt { Win35Dict begin } \r
+{1 1 countdictstack oldDictCnt sub {pop end } for } ifelse } if \r
+[{ }\r
+/exec load currenttransfer /exec load] cvx settransfer\r
+/setresolution where { pop 300 300 setresolution } if\r
+%%EndSetup\r
+%%Page: 1 1\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+\r
+%%BeginResource: font MSTT31c4bd\r
+/GreNewFont{10 dict dup 3 1 roll def dup begin 6 1 roll/FontType 3\r
+def/FontMatrix exch def/FontBBox exch def/FontInfo 2 dict def FontInfo\r
+/UnderlinePosition 3 -1 roll put FontInfo/UnderlineThickness 3 -1\r
+roll put/Encoding 256 array def 0 1 255{Encoding exch/.notdef put}for\r
+/CharProcs 256 dict def CharProcs/.notdef{}put/Metrics 256 dict def\r
+Metrics/.notdef 3 -1 roll put/BuildChar{/char exch def/fontdict exch\r
+def/charname fontdict/Encoding get char get def fontdict/Metrics get\r
+charname get aload pop setcachedevice fontdict begin Encoding char\r
+get CharProcs exch get end exec}def end definefont pop}def/AddChar{begin\r
+Encoding 3 1 roll put CharProcs 3 1 roll put Metrics 3 1 roll put end}def\r
+/MSTT31c4bd [75.0 0 0 0 0 0] 93 -104 [-75.0 -75.0 75.0 75.0] [1 75 div 0 0 1 75 div 0 0] /MSTT31c4bd GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 75 75 0 0 1 69 /MSTT31c4bd font\r
+\r
+%%BeginResource: font MSTT31c4bd\r
+/G4c [50.0 0.0 2.0 0.0 48.0 50.0]\r
+/G4c {\r
+ 46 50 true [1 0 0 -1 -2.0 50.0] {<ffffffc000000ffff800000003fff000000003fff000000001ffe000000001ffe000000001ffe000\r
+000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000000001ff\r
+e000000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000000001ffe0000000\r
+01ffe000000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000\r
+000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000000001ffe000000c01ff\r
+e000000c01ffe000001c01ffe000001c01ffe000001c01ffe000003801ffe000003801ffe0000078\r
+01ffe000007801ffe00000f801ffe00001f801ffe00001f801ffe00003f801fff0000ff803fff800\r
+3ff003fffffffff00ffffffffff0fffffffffff0>} imagemask \r
+ }\r
+ 76 /G4c MSTT31c4bd AddChar\r
+/G4f [58.0 0.0 3.0 -1.0 55.0 51.0]\r
+/G4f {\r
+ 52 52 true [1 0 0 -1 -3.0 51.0] {<00001fff0000000000fffff000000003fffffe0000000ffe03ff0000003ff800ffc000007fe0007f\r
+e00000ffc0003ff00001ff80001ff80003ff80000ffc0007ff00000ffe0007ff000007ff000ffe00\r
+0007ff001ffe000007ff801ffc000003ff803ffc000003ffc03ffc000003ffc07ffc000003ffe07f\r
+fc000003ffe07ff8000001ffe07ff8000001ffe0fff8000001fff0fff8000001fff0fff8000001ff\r
+f0fff8000001fff0fff8000001fff0fff8000001fff0fff8000001fff0fff8000001fff0fff80000\r
+01fff0fff8000001fff0fff8000001fff07ff8000001ffe07ff8000001ffe07ff8000001ffe07ffc\r
+000003ffe03ffc000003ffc03ffc000003ffc03ffc000003ff801ffc000003ff801ffe000007ff00\r
+0ffe000007ff0007ff000007fe0007ff00000ffc0003ff80001ffc0001ff80001ff80000ffc0003f\r
+f000007fe0007fe000001ff000ff8000000ffe03ff00000003fffffc000000007ffff0000000000f\r
+ff000000>} imagemask \r
+ }\r
+ 79 /G4f MSTT31c4bd AddChar\r
+/G47 [58.0 0.0 3.0 -1.0 57.0 51.0]\r
+/G47 {\r
+ 54 52 true [1 0 0 -1 -3.0 51.0] {<000003ffc0010000003ffffc03000001ffffff87000007ff807fff00000ffc000fff00003ff80003\r
+ff00007fe00000ff0000ffc000007f0001ffc000003f0003ff8000001f0007ff0000000f0007ff00\r
+00000f000ffe00000007001ffe00000007001ffe00000003003ffc00000003003ffc00000001003f\r
+fc00000000007ffc00000000007ffc00000000007ff80000000000fff80000000000fff800000000\r
+00fff80000000000fff80000000000fff80000000000fff80000000000fff80000000000fff80000\r
+000000fff80000000000fff80007fffffcfff800007fffe07ff800001fff807ffc00000fff007ffc\r
+00000fff007ffc00000fff003ffc00000fff003ffc00000fff001ffe00000fff001ffe00000fff00\r
+0ffe00000fff0007ff00000fff0003ff00000fff0003ff80000fff0000ffc0000fff00007fe0000f\r
+ff00003ff0000fff00001ffc000fff000007ff807ffc000001ffffffe00000007fffff0000000007\r
+ffe00000>} imagemask \r
+ }\r
+ 71 /G47 MSTT31c4bd AddChar\r
+/G41 [54.0 0.0 0.0 0.0 52.0 51.0]\r
+/G41 {\r
+ 52 51 true [1 0 0 -1 0.0 51.0] {<000000200000000000006000000000000070000000000000f0000000000000f8000000000001f800\r
+0000000001fc000000000003fc000000000003fc000000000003fe000000000007fe000000000007\r
+ff00000000000fff00000000000fff80000000001fff80000000001fff80000000001fffc0000000\r
+003fffc0000000003bffe00000000073ffe00000000071fff000000000e1fff000000000e1fff000\r
+000000e0fff800000001c0fff800000001c07ffc00000003807ffc00000003803ffe00000007003f\r
+fe00000007003ffe00000007001fff0000000e001fff0000000e000fff8000001c000fff8000001f\r
+ffffffc000003fffffffc000003fffffffc00000380003ffe00000700003ffe00000700001fff000\r
+00e00001fff00000e00000fff80001c00000fff80001c00000fff80003c000007ffc0003c000007f\r
+fc0007c000007ffe000fc000003fff001fe000007fff003ff80000ffffc0ffff000ffffff0>} imagemask \r
+ }\r
+ 65 /G41 MSTT31c4bd AddChar\r
+/G4e [54.0 0.0 1.0 -1.0 53.0 50.0]\r
+/G4e {\r
+ 52 51 true [1 0 0 -1 -1.0 50.0] {<ffffc0001ffff01fffe00003ff800ffff00000fe0007fff000007c0003fff800007c0001fffc0000\r
+380001fffe0000380001ffff0000380001ffff0000380001ffff8000380001dfffc000380001cfff\r
+e000380001c7fff000380001c7fff000380001c3fff800380001c1fffc00380001c0fffe00380001\r
+c07fff00380001c07fff00380001c03fff80380001c01fffc0380001c00fffe0380001c007fff038\r
+0001c007fff8380001c003fff8380001c001fffc380001c000fffe380001c0007fff380001c0003f\r
+ffb80001c0003fffb80001c0001ffff80001c0000ffff80001c00007fff80001c00003fff80001c0\r
+0003fff80001c00001fff80001c00000fff80001c000007ff80001c000003ff80001c000003ff800\r
+01c000001ff80001c000000ff80001c0000007f80001c0000003f80001c0000003f80003e0000001\r
+f80003e0000000f80007f000000078001ffc0000003800ffff800000380000000000001800>} imagemask \r
+ }\r
+ 78 /G4e MSTT31c4bd AddChar\r
+/G27 [21.0 0.0 5.0 27.0 15.0 51.0]\r
+/G27 {\r
+ 10 24 true [1 0 0 -1 -5.0 51.0] {<1e003f807f80ffc0ffc0ffc0ffc0ffc0ffc07f807f807f807f803f003f003f003f001e001e001e00\r
+1e000c000c000c00>} imagemask \r
+ }\r
+ 39 /G27 MSTT31c4bd AddChar\r
+/G38 [38.0 0.0 2.0 -1.0 35.0 51.0]\r
+/G38 {\r
+ 33 52 true [1 0 0 -1 -2.0 51.0] {<000ffc0000007fff800001ffffe00003fe0ff00007f807f8000ff003fc001fe001fe003fe001fe00\r
+3fe000ff007fe000ff007fe000ff007ff000ff007ff000ff007ff800ff007ffc00ff007ffe00fe00\r
+3fff01fe003fff81fc003fffc3f8001ffff3f8000fffffe0000fffffc00007ffff000003ffff8000\r
+00ffffc000007fffe000003ffff000007ffff80001fffffc0007f3fffe000fe0fffe001fc07fff00\r
+3fc03fff003f801fff007f800fff807f000fff80ff0007ff80ff0003ff80ff0003ff80ff0003ff80\r
+ff0001ff80ff0001ff00ff0001ff007f8001ff007f8001fe003f8003fc003fc003fc001fe00ff800\r
+0ff81ff00003ffffc00000ffff0000001ff80000>} imagemask \r
+ }\r
+ 56 /G38 MSTT31c4bd AddChar\r
+/G32 [38.0 0.0 1.0 0.0 34.0 51.0]\r
+/G32 {\r
+ 33 51 true [1 0 0 -1 -1.0 51.0] {<000ff00000003ffe000000ffff000001ffffc00003ffffe00007fffff0000ffffff0000ffffff800\r
+1ffffff8001f03fffc003c00fffc0038007ffc0070003ffc0060001ffc0000001ffc0000000ffc00\r
+00000ff80000000ff80000000ff80000000ff80000000ff00000000ff00000001fe00000001fe000\r
+00001fc00000003f800000003f800000003f000000007e000000007c00000000f800000001f80000\r
+0001f000000003e000000007c00000000f800000001f000180001e000180003c0003000078000700\r
+00f0000f0001ffffff0001ffffff0003fffffe0007fffffe000ffffffe001ffffffe003ffffffc00\r
+7ffffffc007ffffffc00fffffffc00>} imagemask \r
+ }\r
+ 50 /G32 MSTT31c4bd AddChar\r
+%%EndResource\r
+\r
+0 0 0 fC\r
+248 324 421 (LOGLAN'82) 421 SB\r
+\r
+%%BeginResource: font MSTT31c4bd\r
+/G51 [59.0 0.0 3.0 -12.0 56.0 51.0]\r
+/G51 {\r
+ 53 63 true [1 0 0 -1 -3.0 51.0] {<000007ff00000000007ffff000000001fffffe00000007fe03ff0000001ff800ffc000003fe0003f\r
+e00000ffc0001ff80001ffc0000ffc0003ff80000ffe0003ff000007fe0007ff000007ff000ffe00\r
+0003ff801ffe000003ffc01ffe000001ffc03ffc000001ffe03ffc000001ffe03ffc000001ffe07f\r
+fc000001fff07ff8000000fff07ff8000000fff0fff8000000fff8fff8000000fff8fff8000000ff\r
+f8fff8000000fff8fff8000000fff8fff8000000fff8fff8000000fff8fff8000000fff8fff80000\r
+00fff8fff8000000fff8fff8000000fff87ff8000000fff07ff8000000fff07ff8000000fff07ffc\r
+000001fff03ffc000001ffe03ffc000001ffe01ffc000001ffc01ffe000003ffc00ffe000003ff80\r
+0ffe000003ff8007ff000007ff0003ff000007fe0001ff80000ffc0000ff80000ff800007fc0001f\r
+f000003fe0003fe000001ff800ffc0000007fe03ff00000001fffffc000000003fffe0000000000f\r
+ff800000000007ffc00000000007ffc00000000003ffe00000000001fff00000000000fff8000000\r
+00007ffc00000000003fff00000000001fffe00000000007ffffc000000001ffffc0000000001fff\r
+c0>} imagemask \r
+ }\r
+ 81 /G51 MSTT31c4bd AddChar\r
+/G75 [41.0 0.0 3.0 -1.0 38.0 34.0]\r
+/G75 {\r
+ 35 35 true [1 0 0 -1 -3.0 34.0] {<fff81fff003ff807ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff00\r
+1ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff00\r
+1ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff00\r
+1ff803ff001ff803ff001ff807ff001ff80fff000ffc1fff000ffe3fff000ffffbff0007fff3ff00\r
+03ffe3ff8001ff83ffe0007e000000>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c4bd AddChar\r
+/G69 [21.0 0.0 3.0 0.0 19.0 51.0]\r
+/G69 {\r
+ 16 51 true [1 0 0 -1 -3.0 51.0] {<03c00ff00ff01ff81ff81ff81ff80ff00ff003c00000000000000000000000000000fff83ff81ff8\r
+1ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff81ff8\r
+1ff81ff81ff81ff81ff81ff81ff81ff81ff83ffcffff>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c4bd AddChar\r
+/G63 [33.0 0.0 3.0 -1.0 31.0 35.0]\r
+/G63 {\r
+ 28 36 true [1 0 0 -1 -3.0 35.0] {<000ff000007ffc0001ffff0003f8ff8007f07fc00ff07fc00fe03fe01fe03fe03fc03fe03fc03fe0\r
+7fc03fe07fc01fc07fc00f807fc00000ffc00000ffc00000ffc00000ffc00000ffc00000ffe00000\r
+ffe00000ffe00000ffe000007ff000007ff000007ff800007ff800003ffc00303ffe00701fff00e0\r
+0fff83c007ffff8007ffff0001fffe0000fff800001fc000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c4bd AddChar\r
+/G6b [40.0 0.0 3.0 0.0 42.0 50.0]\r
+/G6b {\r
+ 39 50 true [1 0 0 -1 -3.0 50.0] {<fff80000003ff80000001ff80000001ff80000001ff80000001ff80000001ff80000001ff8000000\r
+1ff80000001ff80000001ff80000001ff80000001ff80000001ff80000001ff80000001ff8000000\r
+1ff807ffe01ff801ff801ff800fe001ff8007c001ff80078001ff800f0001ff800e0001ff801c000\r
+1ff80380001ff80780001ff80f00001ff81e00001ff83e00001ff87f00001ff8ff80001ff9ff8000\r
+1ffbffc0001fffffc0001fffffe0001ffcfff0001ff87ff0001ff87ff8001ff83ffc001ff83ffc00\r
+1ff81ffe001ff80ffe001ff80fff001ff807ff801ff803ff801ff803ffc01ff801ffe01ff801fff0\r
+3ffc01fff8ffff07fffe>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c4bd AddChar\r
+/G20 [19.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c4bd AddChar\r
+/G52 [54.0 0.0 1.0 0.0 54.0 50.0]\r
+/G52 {\r
+ 53 50 true [1 0 0 -1 -1.0 50.0] {<ffffffff8000000ffffffff8000003fffffffe000001ffe01fff800001ffe003ffc00001ffe001ff\r
+e00001ffe000fff00001ffe0007ff80001ffe0007ff80001ffe0007ff80001ffe0003ffc0001ffe0\r
+003ffc0001ffe0003ffc0001ffe0003ffc0001ffe0003ffc0001ffe0003ffc0001ffe0003ffc0001\r
+ffe0003ff80001ffe0007ff80001ffe0007ff00001ffe000fff00001ffe001ffe00001ffe003ffc0\r
+0001ffe01fff800001fffffffe000001fffffff0000001fffffff0000001ffe1fff8000001ffe1ff\r
+fc000001ffe0fffc000001ffe07ffe000001ffe07fff000001ffe03fff000001ffe01fff800001ff\r
+e01fffc00001ffe00fffc00001ffe007ffe00001ffe007fff00001ffe003fff80001ffe001fff800\r
+01ffe000fffc0001ffe000fffe0001ffe0007ffe0001ffe0003fff0001ffe0003fff8001ffe0001f\r
+ff8003fff0000fffc003fff0000fffe00ffffc0007fff8ffffffc003fff8>} imagemask \r
+ }\r
+ 82 /G52 MSTT31c4bd AddChar\r
+/G65 [33.0 0.0 3.0 -1.0 31.0 35.0]\r
+/G65 {\r
+ 28 36 true [1 0 0 -1 -3.0 35.0] {<000fc000007ff80001fffc0003f8fe0007f07f000fe07f801fe07fc01fe03fc03fc03fc03fc03fe0\r
+7fc03fe07fc03fe07fc03ff0ffc03ff0fffffff0fffffff0fffffff0ffc00000ffc00000ffc00000\r
+ffc00000ffe00000ffe00000ffe000007ff000207ff000307ff800603ffc00e03ffe01c01fff83c0\r
+1fffff800fffff0007fffe0003fffc0000fff000003fc000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c4bd AddChar\r
+/G66 [25.0 0.0 3.0 0.0 31.0 51.0]\r
+/G66 {\r
+ 28 51 true [1 0 0 -1 -3.0 51.0] {<0001fe00000fff80003fffe0007f1fe000fe1ff001fe1ff001fe1ff003fe1ff003fe0fe007fe07c0\r
+07fe000007fe000007fe000007fe000007fe000007fe000007fe0000fffff000fffff000fffff000\r
+fffff00007fe000007fe000007fe000007fe000007fe000007fe000007fe000007fe000007fe0000\r
+07fe000007fe000007fe000007fe000007fe000007fe000007fe000007fe000007fe000007fe0000\r
+07fe000007fe000007fe000007fe000007fe000007fe000007fe000007fe00000fff00001fff8000\r
+fffff000>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c4bd AddChar\r
+/G72 [33.0 0.0 3.0 0.0 31.0 35.0]\r
+/G72 {\r
+ 28 35 true [1 0 0 -1 -3.0 35.0] {<00000780fff81fe03ff83ff03ff87ff01ff8fff01ff9fff01ffbfff01ffb8fe01fff07e01ffe0380\r
+1ffe00001ffc00001ffc00001ffc00001ff800001ff800001ff800001ff800001ff800001ff80000\r
+1ff800001ff800001ff800001ff800001ff800001ff800001ff800001ff800001ff800001ff80000\r
+1ff800001ff800001ff800003ffc0000ffff0000>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c4bd AddChar\r
+/G6e [41.0 0.0 3.0 0.0 38.0 35.0]\r
+/G6e {\r
+ 35 35 true [1 0 0 -1 -3.0 35.0] {<00000fc000fff83ff0003ff8fff8001ff9fffc001ffbfffe001fff8ffe001fff07fe001ffe03ff00\r
+1ffc03ff001ffc03ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff00\r
+1ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff00\r
+1ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff001ff803ff00\r
+1ffc07ff003ffc0fff80ffff1fffe0>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c4bd AddChar\r
+/G43 [54.0 0.0 3.0 -1.0 50.0 51.0]\r
+/G43 {\r
+ 47 52 true [1 0 0 -1 -3.0 51.0] {<000003ff800200001ffff8060000ffffff8e0003ffc03ffe000ffe0007fe001ff80003fe003ff000\r
+00fe00ffe000007e01ffc000003e01ff8000001e03ff8000001e07ff0000000e0fff0000000e0ffe\r
+000000061ffe000000061ffc000000023ffc000000023ffc000000007ffc000000007ff800000000\r
+7ff8000000007ff800000000fff800000000fff800000000fff800000000fff800000000fff80000\r
+0000fff800000000fff800000000fff800000000fff800000000fff8000000007ffc000000007ffc\r
+000000007ffc000000003ffc000000003ffc000000003ffe000000001ffe000000001ffe00000000\r
+0fff0000000407ff0000000c07ff8000001c03ffc000003c01ffc000007c00ffe00000f0007ff800\r
+03e0001ffc0007c0000fff803f000003fffffe0000007ffff000000007ff8000>} imagemask \r
+ }\r
+ 67 /G43 MSTT31c4bd AddChar\r
+/G61 [37.0 0.0 3.0 -1.0 35.0 35.0]\r
+/G61 {\r
+ 32 36 true [1 0 0 -1 -3.0 35.0] {<000ff80000fffe0003ffff0007e0ffc00f807fc01f803fe03f803fe03fc03ff07fe03ff07fe03ff0\r
+7fe03ff07fe03ff03fe03ff03fc03ff00f807ff00001fff00007fff0001fbff0007e3ff001fc3ff0\r
+03f83ff00ff03ff01fe03ff03fe03ff03fc03ff07fc03ff07fc03ff0ffc03ff0ffc07ff0ffe0fff0\r
+fff1bff0ffff3fff7ffe1ffe7ffc1ffc3ff00ff80fc007e0>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c4bd AddChar\r
+/G64 [41.0 0.0 3.0 -1.0 38.0 50.0]\r
+/G64 {\r
+ 35 51 true [1 0 0 -1 -3.0 50.0] {<00007fff0000000fff00000007ff00000003ff00000003ff00000003ff00000003ff00000003ff00\r
+000003ff00000003ff00000003ff00000003ff00000003ff00000003ff00000003ff00003f83ff00\r
+00ffe3ff0001fff3ff0007fc7bff000ff01fff000ff00fff001fe00fff003fe007ff003fe007ff00\r
+3fe003ff007fc003ff007fc003ff007fc003ff00ffc003ff00ffc003ff00ffc003ff00ffc003ff00\r
+ffc003ff00ffc003ff00ffc003ff00ffc003ff00ffc003ff00ffc003ff00ffc003ff007fe003ff00\r
+7fe003ff007fe003ff003fe003ff003ff007ff001ff00fff001ff81fff000ffc3bff8007fff3ffe0\r
+03ffe3ff8001ffc3f800003f030000>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c4bd AddChar\r
+%%EndResource\r
+\r
+248 409 715 (Quick Reference Card) 715 SB\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 866 57 225 569 CB\r
+248 569 284 (Syntax Form) 284 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Helvetica /font12 ANSIFont font\r
+gs 1059 57 1097 569 CB\r
+1117 569 14 ( ) 14 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 1059 57 1097 569 CB\r
+1131 569 286 (its meaning \() 286 SB\r
+gr\r
+32 0 0 46 46 0 0 0 42 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 1059 57 1097 569 CB\r
+1417 573 164 (informal) 164 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 1059 57 1097 569 CB\r
+1581 569 17 (\)) 17 SB\r
+gr\r
+0 0 0 fC\r
+/fm 256 def\r
+5 56 1091 569 B\r
+1 F\r
+n\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/MSTT31c4a3 [50.0 0 0 0 0 0] 40 -100 [-50.0 -50.0 50.0 50.0] [1 50 div 0 0 1 50 div 0 0] /MSTT31c4a3 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G20 [13.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 64 225 626 CB\r
+248 633 52 ( ) 52 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/MSTT31c4eb [50.0 0 0 0 0 0] 100 -100 [-50.0 -50.0 50.0 50.0] [1 50 div 0 0 1 50 div 0 0] /MSTT31c4eb GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G70 [28.0 0.0 2.0 -11.0 26.0 23.0]\r
+/G70 {\r
+ 24 34 true [1 0 0 -1 -2.0 23.0] {<0007c0ff9ff07fbff83fe1fc3fc0fc3fc0fe3f80fe3f807e3f807f3f807f3f807f3f807f3f807f3f\r
+807f3f807f3f807f3f807e3f807e3f80fe3f80fc3fc0fc3ff1f83f9ff03f8fc03f80003f80003f80\r
+003f80003f80003f80003f80003f80007fc000ffe000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c4eb AddChar\r
+/G72 [21.0 0.0 2.0 0.0 21.0 23.0]\r
+/G72 {\r
+ 19 23 true [1 0 0 -1 -2.0 23.0] {<0003c0ff87e07f8fe03f9fe03fbfe03fe3e03fc1c03fc0003fc0003f80003f80003f80003f80003f\r
+80003f80003f80003f80003f80003f80003f80003f80007fc000ffe000>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c4eb AddChar\r
+/G6f [25.0 0.0 2.0 -1.0 23.0 23.0]\r
+/G6f {\r
+ 21 24 true [1 0 0 -1 -2.0 23.0] {<01fc0007ff000f8f801f07c03f07e03e03f07e03f07e03f0fe03f8fe03f8fe03f8fe03f8fe03f8fe\r
+03f8fe03f8fe03f87e03f07e03f03e03f03f07e01f07c00f8f8007ff0001fc00>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c4eb AddChar\r
+/G67 [25.0 0.0 2.0 -11.0 24.0 23.0]\r
+/G67 {\r
+ 22 34 true [1 0 0 -1 -2.0 23.0] {<03f8000ffffc1f8ffc3f0ffc7e07c0fe07e0fe07f0fe07f0fe07f0fe07f07e07f07e07e03f0fe01f\r
+9fc007ff0003fc000e00001c00003c00007e00007fffc07ffff07ffff87ffff83ffffc1ffffc7000\r
+7ce0001ce0001ce00018f000307c01e03fffc007fe00>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c4eb AddChar\r
+/G61 [25.0 0.0 2.0 -1.0 24.0 23.0]\r
+/G61 {\r
+ 22 24 true [1 0 0 -1 -2.0 23.0] {<00fc0007ff001e1f803c0fc03e0fe07e0fe07f0fe07f0fe03e0fe01c0fe0003fe000efe003cfe00f\r
+8fe01f0fe03f0fe07e0fe0fe0fe0fe0fe0fe1fe0ff2fe0ffcffc7f87f83e03e0>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c4eb AddChar\r
+/G6d [41.0 0.0 2.0 0.0 39.0 23.0]\r
+/G6d {\r
+ 37 23 true [1 0 0 -1 -2.0 23.0] {<0007c03f00ff9ff0ff807fbff9ffc03fe3fb1fc03fc1fe0fe03f81fc0fe03f81fc0fe03f81fc0fe0\r
+3f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe0\r
+3f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe03f81fc0fe07fc3fe1ff0ffe7ff3ff8>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c4eb AddChar\r
+/G20 [13.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 64 225 626 CB\r
+300 632 199 (program ) 199 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/MSTT31c4f8 [50.0 0 0 0 0 0] 40 -100 [-50.0 -50.0 50.0 50.0] [1 50 div 0 0 1 50 div 0 0] /MSTT31c4f8 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G3c [34.0 0.0 3.0 5.0 30.0 30.0]\r
+/G3c {\r
+ 27 25 true [1 0 0 -1 -3.0 30.0] {<00000020000000c000000700000018000000600000018000000e00000030000000c0000003000000\r
+1c0000006000000080000000600000001c0000000300000000c0000000300000000e000000018000\r
+000060000000180000000700000000c000000020>} imagemask \r
+ }\r
+ 60 /G3c MSTT31c4f8 AddChar\r
+/G6e [25.0 0.0 0.0 0.0 24.0 23.0]\r
+/G6e {\r
+ 24 23 true [1 0 0 -1 0.0 23.0] {<03e03c3fc0fe03c19f03c20f03c41f07881f07901e07b03e0f603e0f403e0f803c1f807c1f00781f\r
+00781e00f83e00f03c00f03c01f07801e27801e47801e8f803f0f001c0>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c4f8 AddChar\r
+/G61 [25.0 0.0 0.0 0.0 25.0 23.0]\r
+/G61 {\r
+ 25 23 true [1 0 0 -1 0.0 23.0] {<000f8180003ccf8000606f0001c02f0003803f0007803e000f003e000e003e001e003c003c003c00\r
+3c007c0078007c00780078007800f800f801f800f001f000f002f000f004f000f819e200fc31e400\r
+7fe1ec003fc1f8001f01e000>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c4f8 AddChar\r
+/G6d [36.0 0.0 0.0 0.0 34.0 23.0]\r
+/G6d {\r
+ 34 23 true [1 0 0 -1 0.0 23.0] {<01e07007803fc1f81f8003c3fc3fc003c67c67c0038c7cc7c007987c87c007b079078007a07a0780\r
+0f40fa0f800fc0f40f800f80f80f001f00f81f001f01f01f001e01f01e001e01e03e003e03e03c00\r
+3c03c03c003c03c07c007c07c0788078078079007807807a00f80f80fc00f00f007000>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c4f8 AddChar\r
+/G65 [22.0 0.0 1.0 0.0 20.0 23.0]\r
+/G65 {\r
+ 19 23 true [1 0 0 -1 -1.0 23.0] {<001f800063c00181e00301e00701e00e01e01c03c01c07803c0700781e00783c0079e000ff0000f0\r
+0000f00000f00000f80080f80100fc06007e1c003ff8003ff0000fc000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c4f8 AddChar\r
+/G3e [34.0 0.0 3.0 5.0 30.0 30.0]\r
+/G3e {\r
+ 27 25 true [1 0 0 -1 -3.0 30.0] {<80000000600000001c0000000300000000c0000000300000000e0000000180000000600000001800\r
+00000700000000c000000020000000c000000700000018000000600000018000000e000000300000\r
+00c00000030000001c0000006000000080000000>} imagemask \r
+ }\r
+ 62 /G3e MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 64 225 626 CB\r
+499 633 176 (<name>) 176 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G3b [13.0 0.0 3.0 -9.0 10.0 23.0]\r
+/G3b {\r
+ 7 32 true [1 0 0 -1 -3.0 23.0] {<307878300000000000000000000000000000000078fcfe7e0606060c0c186080>} imagemask \r
+ }\r
+ 59 /G3b MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 64 225 626 CB\r
+675 633 13 (;) 13 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G3c [28.0 0.0 1.0 5.0 27.0 30.0]\r
+/G3c {\r
+ 26 25 true [1 0 0 -1 -1.0 30.0] {<00000040000001c00000078000003e000000f8000003c000000f0000003c000000f0000007c00000\r
+1f00000078000000e0000000780000001f00000007c0000000f00000003c0000000f00000003c000\r
+0000f80000003e0000000780000001c000000040>} imagemask \r
+ }\r
+ 60 /G3c MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 63 225 684 CB\r
+248 690 145 ( <) 145 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G64 [25.0 0.0 0.0 0.0 29.0 35.0]\r
+/G64 {\r
+ 29 35 true [1 0 0 -1 0.0 35.0] {<000000f800000ff0000001f0000001f0000001e0000001e0000001e0000003c0000003c0000003c0\r
+00000780000007800007c7800018778000603f0001c01f0003801f0007801e000f003e000e003e00\r
+1e003c003c003c003c007c007800f8007800f8007801f800f8037800f002f000f006f000f80cf000\r
+f819e100fc71e2007fe1e4003fc1f8001f01e000>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c4f8 AddChar\r
+/G63 [22.0 0.0 1.0 0.0 21.0 23.0]\r
+/G63 {\r
+ 20 23 true [1 0 0 -1 -1.0 23.0] {<000fc000706001c0700380700700f00e00f01e00e01c00003c0000780000780000780000f80000f0\r
+0000f00000f00000f800c0f80180fc03007e0e003ffc001ff0000fc000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c4f8 AddChar\r
+/G6c [14.0 0.0 1.0 0.0 16.0 35.0]\r
+/G6c {\r
+ 15 35 true [1 0 0 -1 -1.0 35.0] {<003e03fc007c003c00780078007800f000f000f001f001e001e003e003c003c003c0078007800780\r
+0f000f000f001f001e001e003e003c003c007c40788078807900fe007800>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c4f8 AddChar\r
+/G72 [19.0 0.0 0.0 0.0 19.0 23.0]\r
+/G72 {\r
+ 19 23 true [1 0 0 -1 0.0 23.0] {<03e0e03fe1e007c3e003c7e007c9c00798c007900007a0000f40000f40000f80001f00001f00001e\r
+00001e00003e00003c00003c0000780000780000780000f80000f00000>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c4f8 AddChar\r
+/G74 [14.0 0.0 2.0 0.0 15.0 29.0]\r
+/G74 {\r
+ 13 29 true [1 0 0 -1 -2.0 29.0] {<00300020006000e001c003c00fc07ff8078007800f800f000f001f001e001e003e003e003c003c00\r
+7c0078007800f800f180f100f200fc00f000>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c4f8 AddChar\r
+/G69 [14.0 0.0 1.0 0.0 13.0 32.0]\r
+/G69 {\r
+ 12 32 true [1 0 0 -1 -1.0 32.0] {<006000f000f000600000000000000000000001e03fe003c003c003c00780078007800f000f000f00\r
+1f001e001e003e003c003c007c00788079007a00fc007800>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c4f8 AddChar\r
+/G6f [25.0 0.0 1.0 0.0 24.0 23.0]\r
+/G6f {\r
+ 23 23 true [1 0 0 -1 -1.0 23.0] {<000fc00070f001e03803c03c07801c0f001e1e001e3e001e3c003e7c003e7c003e78003cf8007cf8\r
+007cf80078f000f8f000f0f001e07803c0780780380f001e1c0007e000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c4f8 AddChar\r
+/G73 [19.0 0.0 0.0 0.0 19.0 23.0]\r
+/G73 {\r
+ 19 23 true [1 0 0 -1 0.0 23.0] {<007c2001c3e00380e00780e007804007804007c04007e00003f00003f80001f80000fc00007e0000\r
+3e00003f00401f00400f00400f00600f00e00e00f01c00f8380087e000>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 63 225 684 CB\r
+393 690 283 (declarations>) 283 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 63 225 741 CB\r
+248 748 52 ( ) 52 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G62 [28.0 0.0 2.0 -1.0 26.0 33.0]\r
+/G62 {\r
+ 24 34 true [1 0 0 -1 -2.0 33.0] {<ff80007f80003f80003f80003f80003f80003f80003f80003f80003f80003f87c03f9ff03fbff83f\r
+e1fc3fc0fc3f80fe3f807e3f807f3f807f3f807f3f807f3f807f3f807f3f807f3f807f3f807e3f80\r
+7e3f807e3f80fc3f80fc3fc0f83fe1f03cffc0303f00>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c4eb AddChar\r
+/G65 [22.0 0.0 2.0 -1.0 21.0 23.0]\r
+/G65 {\r
+ 19 24 true [1 0 0 -1 -2.0 23.0] {<01f80007fe000f9f001f1f803e0f803e0fc07e0fc07e0fe0fe0fe0ffffe0ffffe0fe0000fe0000fe\r
+0000fe0000ff00007f00007f80207f80603fc0c03fe1801fff000ffe0003f800>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c4eb AddChar\r
+/G69 [14.0 0.0 2.0 0.0 13.0 34.0]\r
+/G69 {\r
+ 11 34 true [1 0 0 -1 -2.0 34.0] {<0e001f003f803f803f801f000e0000000000000000000000ff807f803f803f803f803f803f803f80\r
+3f803f803f803f803f803f803f803f803f803f803f803f807fc0ffe0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c4eb AddChar\r
+/G6e [28.0 0.0 2.0 0.0 26.0 23.0]\r
+/G6e {\r
+ 24 23 true [1 0 0 -1 -2.0 23.0] {<0007c0ff8ff07fbff83fe3f83fc1fc3fc1fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f\r
+81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc7fc3feffe7ff>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 63 225 741 CB\r
+300 747 117 (begin) 117 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 63 225 798 CB\r
+248 804 145 ( <) 145 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G75 [25.0 0.0 1.0 0.0 24.0 23.0]\r
+/G75 {\r
+ 23 23 true [1 0 0 -1 -1.0 23.0] {<0380000fc03e1fc03c23c03c43c07cc7c0780780780780f80f80f00f01f00f01f01f03e01e03e01e\r
+05e03e05e03c0bc03c13c07c13c07827887847907887a07f07c03c0780>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c4f8 AddChar\r
+/G3b [17.0 0.0 2.0 -6.0 13.0 23.0]\r
+/G3b {\r
+ 11 29 true [1 0 0 -1 -2.0 23.0] {<01c003e003e003e001c0000000000000000000000000000000000000000000000000000038007c00\r
+7c007c003c001c0018001000300060008000>} imagemask \r
+ }\r
+ 59 /G3b MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 63 225 798 CB\r
+393 804 286 (instructions>;) 286 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G20 [13.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 63 225 855 CB\r
+248 862 26 ( ) 26 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G64 [28.0 0.0 2.0 -1.0 26.0 33.0]\r
+/G64 {\r
+ 24 34 true [1 0 0 -1 -2.0 33.0] {<0007fc0003fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc01f1fc07fdfc1f8ffc1f\r
+07fc3f03fc7f01fc7e01fc7e01fcfe01fcfe01fcfe01fcfe01fcfe01fcfe01fcfe01fcfe01fcfe01\r
+fc7f01fc7f03fc3f83fc3f8ffe1ffdff0ff9fc03e180>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 63 225 855 CB\r
+274 861 78 (end) 78 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G50 [28.0 0.0 0.0 0.0 26.0 33.0]\r
+/G50 {\r
+ 26 33 true [1 0 0 -1 0.0 33.0] {<ffffc0000ffff80007c0fc0007c03f0007c03f0007c01f8007c01f8007c00fc007c00fc007c00fc0\r
+07c00fc007c00fc007c00fc007c01f8007c01f8007c03f0007c0fe0007fffc0007dfe00007c00000\r
+07c0000007c0000007c0000007c0000007c0000007c0000007c0000007c0000007c0000007c00000\r
+07c000001fe00000fffe0000>} imagemask \r
+ }\r
+ 80 /G50 MSTT31c4a3 AddChar\r
+/G72 [17.0 0.0 1.0 0.0 17.0 23.0]\r
+/G72 {\r
+ 16 23 true [1 0 0 -1 -1.0 23.0] {<061e1e7f7effff8e1f001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e003f00ffc0>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c4a3 AddChar\r
+/G6f [26.0 0.0 2.0 -1.0 24.0 23.0]\r
+/G6f {\r
+ 22 24 true [1 0 0 -1 -2.0 23.0] {<00fc0003ff800f07c01e03e03c01f03800f07800f878007870007cf0007cf0007cf0003cf0003cf8\r
+003cf8003cf800387800787c00783c00703e00e01f00e00f83c007ff0001fc00>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c4a3 AddChar\r
+/G67 [25.0 0.0 1.0 -11.0 24.0 23.0]\r
+/G67 {\r
+ 23 34 true [1 0 0 -1 -1.0 23.0] {<00fc000387000f03fe0e01fe1e01e03c01e03c00f03c00f03c00f03c00f03e00f01e01e01f01e00f\r
+03c007c78003fc000c00001800001800003fffe03ffff81ffffc07fffe08001e1000063000066000\r
+0660000ce0000cf80038fe00f07fffe01fff8003fc00>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c4a3 AddChar\r
+/G61 [22.0 0.0 2.0 -1.0 22.0 23.0]\r
+/G61 {\r
+ 20 24 true [1 0 0 -1 -2.0 23.0] {<07f0001ffc003c3e00381f00780f00780f00780f00300f00001f0000ff0003ef000f8f001e0f003c\r
+0f00780f00700f00f00f00f00f00f00f00f81f10fc7f307fcfe03f8fc01e0780>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c4a3 AddChar\r
+/G6d [37.0 0.0 1.0 0.0 37.0 23.0]\r
+/G6d {\r
+ 36 23 true [1 0 0 -1 -1.0 23.0] {<060f807c001e3fc1fe007e7fe3ff00fec3e61f001f81fc0f801e00f807801e00f007801e00f00780\r
+1e00f007801e00f007801e00f007801e00f007801e00f007801e00f007801e00f007801e00f00780\r
+1e00f007801e00f007801e00f007801e00f007801e00f007803f01f80fc0ffc7fe3ff0>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c4a3 AddChar\r
+/G69 [12.0 0.0 1.0 0.0 11.0 35.0]\r
+/G69 {\r
+ 10 35 true [1 0 0 -1 -1.0 35.0] {<1c003e003e003e001c00000000000000000000000000000006001e007e00fe001e001e001e001e00\r
+1e001e001e001e001e001e001e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c4a3 AddChar\r
+/G73 [19.0 0.0 3.0 -1.0 18.0 23.0]\r
+/G73 {\r
+ 15 24 true [1 0 0 -1 -3.0 23.0] {<0f883ff870786038e018e018f008f008fc007f007fc03fe00ff803fc00fc007e803e801ec01ee01c\r
+e01cf838fff08fc0>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c4a3 AddChar\r
+/G75 [25.0 0.0 0.0 -1.0 24.0 22.0]\r
+/G75 {\r
+ 24 23 true [1 0 0 -1 0.0 22.0] {<fe03f83e00f81e00781e00781e00781e00781e00781e00781e00781e00781e00781e00781e00781e\r
+00781e00781e00781e00781e00f81f01f80f877f0ffe7e07f87801f060>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c4a3 AddChar\r
+/G6e [24.0 0.0 1.0 0.0 24.0 23.0]\r
+/G6e {\r
+ 23 23 true [1 0 0 -1 -1.0 23.0] {<060f801e3fc07e7fe0fee3e01f81f01f00f01e00f01e00f01e00f01e00f01e00f01e00f01e00f01e\r
+00f01e00f01e00f01e00f01e00f01e00f01e00f01e00f03f01f8ffc7fe>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c4a3 AddChar\r
+/G74 [15.0 0.0 0.0 -1.0 14.0 29.0]\r
+/G74 {\r
+ 14 30 true [1 0 0 -1 0.0 29.0] {<010003000300070007000f001f007ff8fff80f000f000f000f000f000f000f000f000f000f000f00\r
+0f000f000f000f000f000f040f880ff807f003c0>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c4a3 AddChar\r
+/G2e [13.0 0.0 4.0 -1.0 8.0 3.0]\r
+/G2e {\r
+ 4 4 true [1 0 0 -1 -4.0 3.0] {<60f0f060>} imagemask \r
+ }\r
+ 46 /G2e MSTT31c4a3 AddChar\r
+/G49 [17.0 0.0 1.0 0.0 16.0 33.0]\r
+/G49 {\r
+ 15 33 true [1 0 0 -1 -1.0 33.0] {<fffe1ff007c007c007c007c007c007c007c007c007c007c007c007c007c007c007c007c007c007c0\r
+07c007c007c007c007c007c007c007c007c007c007c01ff0fffe>} imagemask \r
+ }\r
+ 73 /G49 MSTT31c4a3 AddChar\r
+/G68 [24.0 0.0 1.0 0.0 24.0 35.0]\r
+/G68 {\r
+ 23 35 true [1 0 0 -1 -1.0 35.0] {<0600001e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e00001e0f801e\r
+3fc01e7fe01ec3e01f81f01f00f01e00f01e00f01e00f01e00f01e00f01e00f01e00f01e00f01e00\r
+f01e00f01e00f01e00f01e00f01e00f01e00f03f01f8ffc7fe>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c4a3 AddChar\r
+/G65 [22.0 0.0 2.0 -1.0 21.0 23.0]\r
+/G65 {\r
+ 19 24 true [1 0 0 -1 -2.0 23.0] {<01f80007fe000e1f001c07803807c07803c07003e07003e0ffffe0ffffe0f00000f00000f00000f0\r
+0000f80000f800207c00607c00607f00c03f81c01fff800fff0007fe0001f800>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c4a3 AddChar\r
+/G66 [15.0 0.0 1.0 0.0 21.0 35.0]\r
+/G66 {\r
+ 20 35 true [1 0 0 -1 -1.0 35.0] {<001f00007fc001c7e00383f00301f00700f00700600f00000f00000f00000f00000f00000f0000ff\r
+fc00fffc000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00\r
+000f00000f00000f00000f00000f00001f80003fc000fff800>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 626 CB\r
+1117 632 966 (Program is a unit. It is the root of a tree of units.) 966 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G44 [36.0 0.0 0.0 0.0 34.0 33.0]\r
+/G44 {\r
+ 34 33 true [1 0 0 -1 0.0 33.0] {<fffff800000fffff800007e01fe00007c007f00007c001f80007c000fc0007c0007e0007c0003f00\r
+07c0003f0007c0001f8007c0001f8007c0001f8007c0000fc007c0000fc007c0000fc007c0000fc0\r
+07c0000fc007c0000fc007c0000fc007c0000fc007c0000fc007c0001f8007c0001f8007c0001f80\r
+07c0003f0007c0003f0007c0007e0007c000fc0007c001f80007c007f00007e01fc0001fffff0000\r
+fffff80000>} imagemask \r
+ }\r
+ 68 /G44 MSTT31c4a3 AddChar\r
+/G78 [24.0 0.0 0.0 0.0 24.0 22.0]\r
+/G78 {\r
+ 24 22 true [1 0 0 -1 0.0 22.0] {<ffc3fe3f00f81f00e00f80c007c18007c30003e60001f60000fc00007800007c00007e00007f0000\r
+cf00018f800307c00603e00401e00c01f01800f83c00fc7e07ff>} imagemask \r
+ }\r
+ 120 /G78 MSTT31c4a3 AddChar\r
+/G63 [22.0 0.0 2.0 -1.0 21.0 23.0]\r
+/G63 {\r
+ 19 24 true [1 0 0 -1 -2.0 23.0] {<00fc0007ff000f0f801c07c03807c03807c0700380700000f00000f00000f00000f00000f00000f0\r
+0000f80020f800607c00407c00c07e00c03f83801fff800fff0007fc0001f000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c4a3 AddChar\r
+/G70 [25.0 0.0 1.0 -11.0 23.0 23.0]\r
+/G70 {\r
+ 22 34 true [1 0 0 -1 -1.0 23.0] {<061f001e3fc07e7fe0fec3f01f81f81f00f81e00781e007c1e007c1e003c1e003c1e003c1e003c1e\r
+003c1e003c1e00381e00381e00781e00701f00f01f00e01fc3c01eff801e3e001e00001e00001e00\r
+001e00001e00001e00001e00001e00003f0000ffc000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 683 CB\r
+1117 689 929 (During an execution of the program this tree is) 929 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G64 [25.0 0.0 2.0 -1.0 24.0 35.0]\r
+/G64 {\r
+ 22 36 true [1 0 0 -1 -2.0 35.0] {<0000600001e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e001f1e007\r
+fde00f0fe01e07e03c03e03803e07801e07001e07001e0f001e0f001e0f001e0f001e0f001e0f001\r
+e0f801e0f801e07c01e07c01e03e03e03f87fc1ffdf80ff9e003e180>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c4a3 AddChar\r
+/G6c [12.0 0.0 1.0 0.0 11.0 35.0]\r
+/G6c {\r
+ 10 35 true [1 0 0 -1 -1.0 35.0] {<06001e007e00fe001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 740 CB\r
+1117 746 696 (used as a collection of patterns for ) 696 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 63 1095 740 CB\r
+1813 746 185 (instances) 185 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G41 [35.0 0.0 1.0 0.0 36.0 34.0]\r
+/G41 {\r
+ 35 34 true [1 0 0 -1 -1.0 34.0] {<0000c000000000c000000000e000000001e000000001f000000003f000000003f000000007f80000\r
+0006f800000006fc0000000c7c0000000c7c000000187e000000183e000000183f000000301f0000\r
+00301f000000600f800000600f800000e00fc00000c007c00000ffffc00001ffffe000018003e000\r
+038003f000030001f000030001f800060000f800060000f8000c0000fc000c00007c001c00007e00\r
+3e0000ff80ffc007ffe0>} imagemask \r
+ }\r
+ 65 /G41 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 740 CB\r
+1998 746 85 (. An) 85 SB\r
+gr\r
+gs 1061 63 1095 797 CB\r
+1117 803 579 (instance of a unit is either an ) 579 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G76 [22.0 0.0 1.0 0.0 22.0 23.0]\r
+/G76 {\r
+ 21 23 true [1 0 0 -1 -1.0 23.0] {<0e0070ff00f81f00f80f00780f80380f80380780300780300780200780600780c007c08007c10007\r
+c30003c60003c40003c80003d00003e00003c000038000030000020000>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 797 CB\r
+1696 803 358 (activation record ) 358 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G28 [17.0 0.0 2.0 -11.0 16.0 35.0]\r
+/G28 {\r
+ 14 46 true [1 0 0 -1 -2.0 35.0] {<00040018003000e001c00380030007000e000e001e001c003c003c007c007c0078007800f800f800\r
+f800f800f800f800f800f800f800f800780078007c007c003c003c001c001e000e000e0007000380\r
+018000c00060003000180004>} imagemask \r
+ }\r
+ 40 /G28 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 797 CB\r
+2054 803 58 (\(of) 58 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G29 [17.0 0.0 1.0 -11.0 15.0 35.0]\r
+/G29 {\r
+ 14 46 true [1 0 0 -1 -1.0 35.0] {<80006000300018000e0006000700038001c001c001e000e000f000f000f800f800780078007c007c\r
+007c007c007c007c007c007c007c007c0078007800f800f800f000f000e001e001c001c003800300\r
+07000e001c00300060008000>} imagemask \r
+ }\r
+ 41 /G29 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 854 CB\r
+1117 860 253 (a procedure\)) 253 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 63 1095 854 CB\r
+1370 860 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 63 1095 854 CB\r
+1383 860 115 (or an ) 115 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G62 [25.0 0.0 2.0 0.0 23.0 35.0]\r
+/G62 {\r
+ 21 35 true [1 0 0 -1 -2.0 35.0] {<007c000ff80000f80000f80000f00000f00000f00001e00001e00001e00003c00003c00003c7c007\r
+8fe007bff007a1f007c0f80f80f80f00780f00781e00781e00781e00f83c00f03c00f03c00e07801\r
+e07801c07803c0f00380f00700f00e00f01c003830000fc000>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c4f8 AddChar\r
+/G6a [14.0 0.0 -9.0 -11.0 14.0 32.0]\r
+/G6a {\r
+ 23 43 true [1 0 0 -1 9.0 32.0] {<00000c00001e00001e00000c00000000000000000000000000000000007c0007f800007800007800\r
+00700000f00000f00000f00001e00001e00001e00003c00003c00003c00003c00007800007800007\r
+80000f00000f00000f00001f00001e00001e00001e00003c00003c0000380000780000700070e000\r
+f1c000e380007c0000>} imagemask \r
+ }\r
+ 106 /G6a MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 63 1095 854 CB\r
+1498 860 122 (object) 122 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 63 1095 854 CB\r
+1620 860 230 (\(of a class\).) 230 SB\r
+gr\r
+866 5 224 626 B\r
+1 F\r
+n\r
+5 5 1091 626 B\r
+1 F\r
+n\r
+5 5 1097 626 B\r
+1 F\r
+n\r
+1052 5 1103 626 B\r
+1 F\r
+n\r
+2 285 1092 632 B\r
+1 F\r
+n\r
+32 0 0 63 63 0 0 0 58 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 75 225 918 CB\r
+248 921 378 (Declarations) 378 SB\r
+gr\r
+32 0 0 46 46 0 0 0 42 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 868 56 225 1096 CB\r
+248 1099 743 (there are five forms of a declaration:) 743 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G76 [25.0 0.0 0.0 -1.0 24.0 22.0]\r
+/G76 {\r
+ 24 23 true [1 0 0 -1 0.0 22.0] {<fff07f7fc03e3fc01c3fc0181fc0181fe0300fe0300ff03007f06007f06007f8c003f8c003fd8001\r
+fd8001ff0000ff0000ff0000fe00007e00007c00003c00003800001800>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c4eb AddChar\r
+/G2c [13.0 0.0 2.0 -8.0 11.0 8.0]\r
+/G2c {\r
+ 9 16 true [1 0 0 -1 -2.0 8.0] {<3c007e00ff00ff80ff80ff807f803b8003800300030006000e001c0030004000>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c4eb AddChar\r
+/G63 [22.0 0.0 2.0 -1.0 21.0 23.0]\r
+/G63 {\r
+ 19 24 true [1 0 0 -1 -2.0 23.0] {<01fc0007ff000f9f801f0fc03f0fc03e0fc07e0fc07e07807e0000fe0000fe0000fe0000fe0000fe\r
+0000ff0000ff00007f00007f80007f80203fc0401fe1c00fff8007fe0001f800>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c4eb AddChar\r
+/G73 [19.0 0.0 2.0 -1.0 17.0 23.0]\r
+/G73 {\r
+ 15 24 true [1 0 0 -1 -2.0 23.0] {<0fc43ffc7c7c783cf81cfc0cfe0cff04ff807fc07ff03ff81ffc0ffc07fe01fe80fec07ec03ee03c\r
+f03cf878fff08fc0>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c4eb AddChar\r
+/G74 [17.0 0.0 1.0 -1.0 16.0 30.0]\r
+/G74 {\r
+ 15 31 true [1 0 0 -1 -1.0 30.0] {<004000c001c001c003c007c00fc03fc07ffefffe1fc01fc01fc01fc01fc01fc01fc01fc01fc01fc0\r
+1fc01fc01fc01fc01fc01fc01fc21fe60ffc07f803e0>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c4eb AddChar\r
+/G75 [28.0 0.0 2.0 -1.0 26.0 22.0]\r
+/G75 {\r
+ 24 23 true [1 0 0 -1 -2.0 22.0] {<ff87fc7f83fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f\r
+81fc3f81fc3f81fc3f81fc3f81fc3f83fc1fc5fc1ffdfe0ff1ff03e000>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c4eb AddChar\r
+/G6c [13.0 0.0 1.0 0.0 12.0 33.0]\r
+/G6c {\r
+ 11 33 true [1 0 0 -1 -1.0 33.0] {<ff807f803f803f803f803f803f803f803f803f803f803f803f803f803f803f803f803f803f803f80\r
+3f803f803f803f803f803f803f803f803f803f803f807fc0ffe0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c4eb AddChar\r
+/G68 [28.0 0.0 2.0 0.0 26.0 33.0]\r
+/G68 {\r
+ 24 33 true [1 0 0 -1 -2.0 33.0] {<ff80007f80003f80003f80003f80003f80003f80003f80003f80003f80003f87c03f9ff03fbff83f\r
+e3f83fc1fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81fc3f81\r
+fc3f81fc3f81fc3f81fc3f81fc7fc3feffe7ff>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 926 60 1094 1089 CB\r
+1117 1092 681 (var, const, unit, signal, handlers) 681 SB\r
+gr\r
+867 2 224 918 B\r
+1 F\r
+n\r
+2 2 1092 918 B\r
+1 F\r
+n\r
+2 2 1095 918 B\r
+1 F\r
+n\r
+921 2 1098 918 B\r
+1 F\r
+n\r
+2 2 2020 918 B\r
+1 F\r
+n\r
+2 2 2021 918 B\r
+1 F\r
+n\r
+131 2 2024 918 B\r
+1 F\r
+n\r
+gs 867 61 225 1152 CB\r
+248 1155 110 ( var) 110 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G3a [14.0 0.0 5.0 -1.0 9.0 23.0]\r
+/G3a {\r
+ 4 24 true [1 0 0 -1 -5.0 23.0] {<60f0f0600000000000000000000000000000000060f0f060>} imagemask \r
+ }\r
+ 58 /G3a MSTT31c4a3 AddChar\r
+/G54 [31.0 0.0 2.0 0.0 29.0 33.0]\r
+/G54 {\r
+ 27 33 true [1 0 0 -1 -2.0 33.0] {<ffffffe0ffffffe0f01f01e0c01f00e0c01f0060801f0020801f0020801f0020001f0000001f0000\r
+001f0000001f0000001f0000001f0000001f0000001f0000001f0000001f0000001f0000001f0000\r
+001f0000001f0000001f0000001f0000001f0000001f0000001f0000001f0000001f0000001f0000\r
+001f0000007f800003fff800>} imagemask \r
+ }\r
+ 84 /G54 MSTT31c4a3 AddChar\r
+/G2c [13.0 0.0 2.0 -9.0 9.0 3.0]\r
+/G2c {\r
+ 7 12 true [1 0 0 -1 -2.0 3.0] {<78fcfe760606060c0c186080>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c4a3 AddChar\r
+/G79 [23.0 0.0 0.0 -11.0 23.0 22.0]\r
+/G79 {\r
+ 23 33 true [1 0 0 -1 0.0 22.0] {<ffc0fe7f003c3e00381e00301f00300f00300f80600780600780c003c0c003c0c003e18001e18001\r
+f18000f30000fb00007e00007e00003e00003c00001c00001c000018000018000030000030000030\r
+0000600000600038c0007f80007f00003c0000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c4a3 AddChar\r
+/G7a [22.0 0.0 1.0 0.0 21.0 22.0]\r
+/G7a {\r
+ 20 22 true [1 0 0 -1 -1.0 22.0] {<3ffff03ffff03803e03007c0200780000f80001f00003e00007c00007c0000f80001f00003e00003\r
+e00007c0000f80101f00101e00103e00307c0070fffff0fffff0>} imagemask \r
+ }\r
+ 122 /G7a MSTT31c4a3 AddChar\r
+/G55 [36.0 0.0 0.0 -1.0 36.0 33.0]\r
+/G55 {\r
+ 36 34 true [1 0 0 -1 0.0 33.0] {<fffe00fff00ff0000f800fe000070007c000060007c000060007c000060007c000060007c0000600\r
+07c000060007c000060007c000060007c000060007c000060007c000060007c000060007c0000600\r
+07c000060007c000060007c000060007c000060007c000060007c000060007c000060007c0000600\r
+07c000060007c0000c0003e0000c0003e0000c0003e000180001f000380000f8007000007e03e000\r
+001fff80000007fe0000>} imagemask \r
+ }\r
+ 85 /G55 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1152 CB\r
+358 1156 255 ( x: T, y,z: U;) 255 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G76 [24.0 0.0 0.0 -1.0 24.0 22.0]\r
+/G76 {\r
+ 24 23 true [1 0 0 -1 0.0 22.0] {<ffc07f7f001e1e000c1e00180f00180f003007803007802003c06003c06003e0c001e0c001f18000\r
+f18000f180007b00007b00003e00003e00003c00001c00001c00000800>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c4a3 AddChar\r
+/G62 [24.0 0.0 0.0 -1.0 22.0 35.0]\r
+/G62 {\r
+ 22 36 true [1 0 0 -1 0.0 35.0] {<0600001e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e00001e1f001e\r
+3fc01effe01fc3f01f01f81e00f81e00781e007c1e003c1e003c1e003c1e003c1e003c1e003c1e00\r
+3c1e00381e00781e00781e00701e00e01f01c00fc38007ff0000fc00>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 1152 CB\r
+1117 1155 978 (declaration of variables x of type T, y,z of type U) 978 SB\r
+gr\r
+867 2 224 1152 B\r
+1 F\r
+n\r
+2 2 1092 1152 B\r
+1 F\r
+n\r
+2 2 1095 1152 B\r
+1 F\r
+n\r
+921 2 1098 1152 B\r
+1 F\r
+n\r
+2 2 2020 1152 B\r
+1 F\r
+n\r
+2 2 2021 1152 B\r
+1 F\r
+n\r
+131 2 2024 1152 B\r
+1 F\r
+n\r
+2 57 1092 1155 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1213 CB\r
+248 1216 126 ( unit) 126 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G42 [33.0 0.0 0.0 0.0 30.0 33.0]\r
+/G42 {\r
+ 30 33 true [1 0 0 -1 0.0 33.0] {<fffff0001ffffe0007c03f8007c00fc007c007e007c003e007c001f007c001f007c001f007c001f0\r
+07c001f007c003f007c003e007c007c007c01f8007ffff0007ffff0007c01fc007c007e007c003f0\r
+07c001f807c001fc07c000fc07c000fc07c000fc07c000fc07c000fc07c001f807c003f807c007f0\r
+0fe01fe01fffff80fffffc00>} imagemask \r
+ }\r
+ 66 /G42 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1213 CB\r
+374 1217 108 ( A: B) 108 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c510\r
+/MSTT31c510 [50.0 0 0 0 0 0] 100 -100 [-50.0 -50.0 50.0 50.0] [1 50 div 0 0 1 50 div 0 0] /MSTT31c510 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 50 50 0 0 1 46 /MSTT31c510 font\r
+\r
+%%BeginResource: font MSTT31c510\r
+/G3c [28.0 0.0 2.0 5.0 28.0 28.0]\r
+/G3c {\r
+ 26 23 true [1 0 0 -1 -2.0 28.0] {<00000040000003c000000fc000003f800001fe000007f800001fc00000ff000003f800000fe00000\r
+7f800000fc0000007f8000000fe0000003f8000000ff0000001fc0000007f8000001fe0000003f80\r
+00000fc0000003c000000040>} imagemask \r
+ }\r
+ 60 /G3c MSTT31c510 AddChar\r
+/G6b [25.0 0.0 0.0 0.0 25.0 35.0]\r
+/G6b {\r
+ 25 35 true [1 0 0 -1 0.0 35.0] {<003f000003fe000000fe000000fe000000fc000000fc000000fc000001fc000001f8000001f80000\r
+01f8000003f8000003f1ff8003f03e0003f0380007e0300007e0600007e0c0000fe180000fc38000\r
+0fc780000fcf80001fdf80001fbfc0001fefc0001f8fc0003f0fc0003f0fc0003f07e2007f07e400\r
+7e07ec007e07f8007e03f000fe03e000fc01c000>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c510 AddChar\r
+/G69 [14.0 0.0 1.0 0.0 14.0 35.0]\r
+/G69 {\r
+ 13 35 true [1 0 0 -1 -1.0 35.0] {<00e001f003f803f803f801f000e00000000000000000000007e07fe00fe00fc00fc00fc00fc01f80\r
+1f801f803f003f003f007f007e007e007e20fe40fcc0ff80ff00fe007800>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c510 AddChar\r
+/G6e [28.0 0.0 1.0 0.0 26.0 23.0]\r
+/G6e {\r
+ 25 23 true [1 0 0 -1 -1.0 23.0] {<01f01e001ff07f0007f0ff0007e1ff0007e3ff0007e73f000fee3f000fcc7f000fd87e000ff07e00\r
+1fe0fe001fe0fc001fc0fc001f80fc003f81fc003f01f8003f01f8007f03f8807e03f1007e03f300\r
+7e03fe00fe03f800fc01f000>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c510 AddChar\r
+/G64 [25.0 0.0 1.0 0.0 28.0 35.0]\r
+/G64 {\r
+ 27 35 true [1 0 0 -1 -1.0 35.0] {<000007e00000ffc000001fc000001fc000001f8000001f8000001f8000001f8000003f0000003f00\r
+00003f0000007f00001e7e0000717e0001e0fe0003e0fc0007c0fc000f80fc000f81fc001f81f800\r
+3f01f8003f01f8007e03f0007e03f0007e07f000fe07f000fc0fe000fc0fe000fc17e000fc17e200\r
+fc2fc400fe4fcc007f8ff8007f0fe0003e07c000>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c510 AddChar\r
+/G3e [28.0 0.0 2.0 5.0 28.0 28.0]\r
+/G3e {\r
+ 26 23 true [1 0 0 -1 -2.0 28.0] {<80000000f0000000fc0000007f0000001fe0000007f8000000fe0000003fc0000007f0000001fc00\r
+00007f8000000fc000007f800001fc000007f000003fc00000fe000007f800001fe000007f000000\r
+fc000000f000000080000000>} imagemask \r
+ }\r
+ 62 /G3e MSTT31c510 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1213 CB\r
+482 1216 148 (<kind>) 148 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1213 CB\r
+630 1217 17 (\() 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G70 [25.0 0.0 -7.0 -11.0 24.0 23.0]\r
+/G70 {\r
+ 31 34 true [1 0 0 -1 7.0 23.0] {<0003c1f0007fc7f800078c7c0007b03c0007e03e000f401e000f801e000f801e001f003e001f003e\r
+001e003c003e003c003c007c003c0078003c0070007800f0007800e0007801c000f8038000f00700\r
+00f80e0001fc3c0001efe00001e0000001e0000003c0000003c0000003c000000780000007800000\r
+078000000f8000001fc000007ff80000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1213 CB\r
+647 1217 149 (params) 149 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1213 CB\r
+796 1217 30 (\);) 30 SB\r
+gr\r
+gs 867 60 225 1271 CB\r
+248 1274 106 ( <) 106 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 60 225 1271 CB\r
+354 1274 249 (declarations) 249 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G3e [28.0 0.0 1.0 5.0 27.0 30.0]\r
+/G3e {\r
+ 26 25 true [1 0 0 -1 -1.0 30.0] {<80000000e0000000780000001f00000007c0000000f00000003c0000000f00000003c0000000f800\r
+00003e0000000780000001c00000078000003e000000f8000003c000000f0000003c000000f00000\r
+07c000001f00000078000000e000000080000000>} imagemask \r
+ }\r
+ 62 /G3e MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 60 225 1271 CB\r
+603 1274 28 (>) 28 SB\r
+gr\r
+gs 867 60 225 1328 CB\r
+248 1332 39 ( ) 39 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 1328 CB\r
+287 1331 117 (begin) 117 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 60 225 1385 CB\r
+248 1388 119 ( <) 119 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 60 225 1385 CB\r
+367 1388 235 (instructions) 235 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 60 225 1385 CB\r
+602 1388 41 (>;) 41 SB\r
+gr\r
+gs 867 61 225 1442 CB\r
+248 1446 91 ( ) 91 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G5f [25.0 0.0 -1.0 -11.0 25.0 -8.0]\r
+/G5f {\r
+ 26 3 true [1 0 0 -1 1.0 -8.0] {<ffffffc0ffffffc0ffffffc0>} imagemask \r
+ }\r
+ 95 /G5f MSTT31c4eb AddChar\r
+/G77 [36.0 0.0 0.0 -1.0 35.0 22.0]\r
+/G77 {\r
+ 35 23 true [1 0 0 -1 0.0 22.0] {<ffe7ff8fe07fc3fe03c03f81fe03803fc0fe03001fc0fe03001fe0ff06000fe0ff06000fe0ff0600\r
+0ff1ff8c0007f1bf8c0007f33fcc0007fb1fd80003fb1fd80003fe1ff00001fe0ff00001fe0ff000\r
+01fc0fe00000fc07e00000fc07c000007807c000007803c00000780380000030038000>} imagemask \r
+ }\r
+ 119 /G77 MSTT31c4eb AddChar\r
+/G3a [17.0 0.0 4.0 -1.0 12.0 23.0]\r
+/G3a {\r
+ 8 24 true [1 0 0 -1 -4.0 23.0] {<3c7effffffff7e3c00000000000000003c7effffffff7e3c>} imagemask \r
+ }\r
+ 58 /G3a MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1442 CB\r
+339 1445 192 (last_will:) 192 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c510 font\r
+\r
+%%BeginResource: font MSTT31c510\r
+/G20 [13.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c510 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1442 CB\r
+531 1445 41 ( <) 41 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 225 1442 CB\r
+572 1446 269 (instructions>) 269 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1500 CB\r
+248 1504 39 ( ) 39 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1500 CB\r
+287 1503 91 (end ) 91 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1500 CB\r
+378 1504 48 (A;) 48 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c51d\r
+/MSTT31c51d [42.0 0 0 0 0 0] 47 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c51d GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 38 /MSTT31c51d font\r
+\r
+%%BeginResource: font MSTT31c51d\r
+/G65 [18.0 0.0 1.0 -1.0 17.0 20.0]\r
+/G65 {\r
+ 16 21 true [1 0 0 -1 -1.0 20.0] {<03e00ff81c3c301e700e600f600fffffe000e000e000e000f000f00178017c037e063ffe1ffc0ff8\r
+03e0>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c51d AddChar\r
+/G76 [20.0 0.0 -1.0 -1.0 20.0 19.0]\r
+/G76 {\r
+ 21 20 true [1 0 0 -1 1.0 19.0] {<ffc1f83f00601e00601f00400f00400f808007808007810003c10003c10003e20001e20001e40000\r
+f40000f400007800007800007000003000003000>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c51d AddChar\r
+/G69 [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G69 {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<0c001e001e000c000000000000000000000006003e00fe001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c51d AddChar\r
+/G64 [21.0 0.0 1.0 -1.0 21.0 29.0]\r
+/G64 {\r
+ 20 30 true [1 0 0 -1 -1.0 29.0] {<000180000f80003f8000078000078000078000078000078000078003e7800ff7801e1f801c0f8038\r
+0f80780780700780700780f00780f00780f00780f00780f00780f00780f807807807807c0f803e1f\r
+803ff7f01fe7e007c700>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c51d AddChar\r
+/G6e [22.0 0.0 1.0 0.0 22.0 20.0]\r
+/G6e {\r
+ 21 20 true [1 0 0 -1 -1.0 20.0] {<061e003e7f00fec7801f07c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e\r
+03c01e03c01e03c01e03c01e03c03f03e0ffcff8>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c51d AddChar\r
+/G74 [12.0 0.0 0.0 -1.0 12.0 25.0]\r
+/G74 {\r
+ 12 26 true [1 0 0 -1 0.0 25.0] {<0200060006000e001e003e00ffe01e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001f300fe00780>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c51d AddChar\r
+/G6c [12.0 0.0 1.0 0.0 11.0 29.0]\r
+/G6c {\r
+ 10 29 true [1 0 0 -1 -1.0 29.0] {<06003e00fe001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c51d AddChar\r
+/G79 [19.0 0.0 -1.0 -9.0 19.0 19.0]\r
+/G79 {\r
+ 20 28 true [1 0 0 -1 1.0 19.0] {<ffc3f03f00c01e00801f00800f00800f010007810007810003c20003c20003e40001e40001f40000\r
+f80000f8000078000070000070000030000020000020000040000040000040003880007f00007e00\r
+003c0000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c51d AddChar\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c51d AddChar\r
+/G6f [20.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G6f {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<03f0000ffc001e3e00380f00380f80700780700780f003c0f003c0f003c0f003c0f003c0f003c0f8\r
+03c07803807803803c07003e07001f0e000ffc0003f000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c51d AddChar\r
+/G75 [21.0 0.0 0.0 -1.0 21.0 19.0]\r
+/G75 {\r
+ 21 20 true [1 0 0 -1 0.0 19.0] {<fe1fc03e07c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e\r
+03c01e03c01e03c01e07c00f1bf807f3e003c300>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c51d AddChar\r
+/G68 [22.0 0.0 1.0 0.0 22.0 29.0]\r
+/G68 {\r
+ 21 29 true [1 0 0 -1 -1.0 29.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e1e001e7f001ec7801f07801e\r
+03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03c01e03\r
+c03f03e0ffcff8>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c51d AddChar\r
+/G72 [15.0 0.0 1.0 0.0 15.0 20.0]\r
+/G72 {\r
+ 14 20 true [1 0 0 -1 -1.0 20.0] {<06383e7cfefc1f981f001e001e001e001e001e001e001e001e001e001e001e001e001e003f00ffc0\r
+>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c51d AddChar\r
+/G66 [13.0 0.0 0.0 0.0 17.0 29.0]\r
+/G66 {\r
+ 17 29 true [1 0 0 -1 0.0 29.0] {<007c0001ff00038f800707800703000f00000f00000f00000f00000f0000fff8000f00000f00000f\r
+00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00\r
+001f8000fff000>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c51d AddChar\r
+/G6d [33.0 0.0 1.0 0.0 33.0 20.0]\r
+/G6d {\r
+ 32 20 true [1 0 0 -1 -1.0 20.0] {<061f03c03e7f8fe0fec798f01f07e0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c078\r
+1e03c0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c0781e03c0783f03e07cffcff9ff\r
+>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c51d AddChar\r
+/G61 [19.0 0.0 1.0 -1.0 19.0 20.0]\r
+/G61 {\r
+ 18 21 true [1 0 0 -1 -1.0 20.0] {<07f0001e7800383c00781e00781e00781e00301e00001e00003e0001de00071e001c1e00381e0070\r
+1e00f01e00f01e00f01e00f03e00787e407f9f801e0e00>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c51d AddChar\r
+%%EndResource\r
+\r
+gs 867 51 225 1615 CB\r
+248 1618 805 (evidently you need not to inherit from a module) 805 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G77 [36.0 0.0 0.0 -1.0 36.0 22.0]\r
+/G77 {\r
+ 36 23 true [1 0 0 -1 0.0 22.0] {<ffc7fe07f03f00f800e01f007800c00f007800800f007801800f803c018007803c030007803e0300\r
+03c07e060003c06f060003c0cf060001e0cf0c0001e1878c0001e1878c0000f303d80000f303d800\r
+00fe03f800007c01f000007c01f000007800e000003800e000003000e0000010004000>} imagemask \r
+ }\r
+ 119 /G77 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 1213 CB\r
+1117 1216 972 (declaration of a module A which inherits from B.) 972 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c510 font\r
+gs 1061 61 1095 1270 CB\r
+1117 1273 92 (kind) 92 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1270 CB\r
+1209 1274 320 ( may be one of: ) 320 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1270 CB\r
+1529 1273 582 (procedure, class, coroutine,) 582 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G6b [27.0 0.0 2.0 0.0 28.0 33.0]\r
+/G6b {\r
+ 26 33 true [1 0 0 -1 -2.0 33.0] {<ff8000007f8000003f8000003f8000003f8000003f8000003f8000003f8000003f8000003f800000\r
+3f8000003f83ff003f80fc003f8070003f8060003f80c0003f81c0003f8300003f8700003f9f8000\r
+3fbf80003fffc0003fdfe0003f9fe0003f8ff0003f87f8003f87f8003f83fc003f83fc003f81fe00\r
+3f80ff007fc0ff80ffe3ffc0>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c4eb AddChar\r
+/G66 [16.0 0.0 1.0 0.0 20.0 34.0]\r
+/G66 {\r
+ 19 34 true [1 0 0 -1 -1.0 34.0] {<007f0001ffc003e7e007c7e00fc7e00fc7e01fc3c01fc0001fc0001fc0001fc0001fc000fff800ff\r
+f8001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0001fc0\r
+001fc0001fc0001fc0001fc0001fc0003fe0007ff000>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 1328 CB\r
+1117 1331 692 (process, block, handler, function) 692 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1095 1385 CB\r
+1117 1388 149 (params) 149 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 1385 CB\r
+1266 1388 590 ( is a list of formal parameters,) 590 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G52 [33.0 0.0 0.0 0.0 34.0 33.0]\r
+/G52 {\r
+ 34 33 true [1 0 0 -1 0.0 33.0] {<ffffe000000ffffc000007c0fe000007c03f000007c01f800007c01f800007c00fc00007c00fc000\r
+07c00fc00007c00fc00007c00fc00007c00f800007c01f800007c03f000007c07e000007c1f80000\r
+07ffe0000007ffe0000007c3f0000007c1f8000007c0fc000007c0fc000007c07e000007c03f0000\r
+07c01f800007c01f800007c00fc00007c007e00007c003f00007c003f80007c001fc001fe000ff00\r
+fffe007fc0>} imagemask \r
+ }\r
+ 82 /G52 MSTT31c4a3 AddChar\r
+/G45 [31.0 0.0 0.0 0.0 30.0 33.0]\r
+/G45 {\r
+ 30 33 true [1 0 0 -1 0.0 33.0] {<ffffffe00fffffe007c001e007c0006007c0006007c0002007c0002007c0000007c0000007c00000\r
+07c0010007c0010007c0010007c0030007c0070007ffff0007ffff0007c0070007c0030007c00100\r
+07c0010007c0010007c0000007c0000007c0000007c0000407c0000807c0001807c0003807c00070\r
+07e001f01ffffff0ffffffe0>} imagemask \r
+ }\r
+ 69 /G45 MSTT31c4a3 AddChar\r
+/G4d [44.0 0.0 0.0 0.0 44.0 33.0]\r
+/G4d {\r
+ 44 33 true [1 0 0 -1 0.0 33.0] {<ffc000003ff01fe000003f800fe000007e0007f000007e0007f00000fe0007f80000fe0006f80001\r
+be0006f80001be00067c00033e00067c00033e00067e00073e00063e00063e00063f000e3e00061f\r
+000c3e00061f800c3e00060f80183e00060fc0183e000607c0303e000607e0303e000603e0603e00\r
+0603f0603e000601f0c03e000601f0c03e000600f9803e000600f9803e000600ff803e0006007f00\r
+3e0006007f003e0006003e003e0006003e003e0006001c003e001f001c00ff00fff00807fff0>} imagemask \r
+ }\r
+ 77 /G4d MSTT31c4a3 AddChar\r
+/G4b [35.0 0.0 0.0 0.0 35.0 33.0]\r
+/G4b {\r
+ 35 33 true [1 0 0 -1 0.0 33.0] {<fffe0fff001ff001f80007c001f00007c001c00007c003800007c007000007c00e000007c01c0000\r
+07c038000007c070000007c0e0000007c1c0000007c380000007c700000007ce00000007df000000\r
+07ff80000007dfc0000007cfe0000007c7f0000007c3f8000007c1fc000007c0fe000007c07f0000\r
+07c03f800007c01fc00007c00fe00007c007f00007c003f80007c001fc0007c000fe001ff001ff80\r
+fffe07ffe0>} imagemask \r
+ }\r
+ 75 /G4b MSTT31c4a3 AddChar\r
+/G53 [28.0 0.0 4.0 -1.0 25.0 34.0]\r
+/G53 {\r
+ 21 35 true [1 0 0 -1 -4.0 34.0] {<03f0200ffe601e0fe03c03e07801e07000e0f00060f00060f00020f80020fc0020fe00007f00007f\r
+c0003fe0001ff8000ffe0007ff0001ffc000ffe0003fe0000ff00007f00001f88000f88000f8c000\r
+78c00078c00078e00070f000f0f801e0fe07c08fff8081fc00>} imagemask \r
+ }\r
+ 83 /G53 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 1442 CB\r
+1117 1445 239 (REMARKS) 239 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G2d [17.0 0.0 2.0 9.0 15.0 13.0]\r
+/G2d {\r
+ 13 4 true [1 0 0 -1 -2.0 13.0] {<fff8fff8fff8fff8>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c4a3 AddChar\r
+/G6b [25.0 0.0 1.0 0.0 25.0 35.0]\r
+/G6b {\r
+ 24 35 true [1 0 0 -1 -1.0 35.0] {<0600001e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e00001e00001e\r
+07fe1e01f01e01c01e03001e06001e0c001e18001e30001ee0001ff0001ef8001ef8001e7c001e3e\r
+001e1f001e0f801e07801e07c01e03e01e01f03f01f8ffc7ff>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 1499 CB\r
+1117 1502 398 (- block has no name) 398 SB\r
+gr\r
+gs 1061 61 1095 1556 CB\r
+1117 1560 382 ( its first line is: ) 382 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1556 CB\r
+1499 1559 128 (block ) 128 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1556 CB\r
+1627 1560 69 ( or ) 69 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1556 CB\r
+1696 1559 100 (pref ) 100 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G43 [33.0 0.0 2.0 -1.0 31.0 34.0]\r
+/G43 {\r
+ 29 35 true [1 0 0 -1 -2.0 34.0] {<000ff020007ffe6000fc0fe003f003e007c001e00f8000f01f8000701f0000303f0000303e000030\r
+7e0000107e0000007e000000fc000000fc000000fc000000fc000000fc000000fc000000fc000000\r
+fc000000fc000000fc0000007e0000007e0000007e0000003f0000083f0000101f8000200f800060\r
+07c000c003f0018001fc0700007ffc00000ff000>} imagemask \r
+ }\r
+ 67 /G43 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1095 1556 CB\r
+1796 1560 46 (C ) 46 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1556 CB\r
+1842 1559 115 (block) 115 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G2d [17.0 0.0 1.0 9.0 15.0 14.0]\r
+/G2d {\r
+ 14 5 true [1 0 0 -1 -1.0 14.0] {<fffcfffcfffcfffcfffc>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1095 1614 CB\r
+1117 1617 30 (- ) 30 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1614 CB\r
+1147 1618 899 (function has a type of result after parameters,) 899 SB\r
+gr\r
+gs 1061 60 1095 1672 CB\r
+1117 1675 616 (- handler has a different form., ) 616 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c52a\r
+/MSTT31c52a [46.0 0 0 0 0 0] 43 -105 [-46.0 -46.0 46.0 46.0] [1 46 div 0 0 1 46 div 0 0] /MSTT31c52a GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 46 46 0 0 1 42 /MSTT31c52a font\r
+\r
+%%BeginResource: font MSTT31c52a\r
+/G73 [18.0 0.0 2.0 -1.0 16.0 21.0]\r
+/G73 {\r
+ 14 22 true [1 0 0 -1 -2.0 21.0] {<0f883ff870786038e018e018f008f8007e007f803fe00ff003f800f8007c803cc01cc01ce018f838\r
+fff08fc0>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c52a AddChar\r
+/G65 [19.0 0.0 1.0 -1.0 18.0 21.0]\r
+/G65 {\r
+ 17 22 true [1 0 0 -1 -1.0 21.0] {<03f0000e7c00181e00300f00300f00600780600780ffff80e00000e00000e00000e00000f00000f0\r
+0080f801807801807c03007f07003ffe001ffc000ff80003e000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c52a AddChar\r
+/G20 [12.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c52a AddChar\r
+/G62 [23.0 0.0 0.0 -1.0 21.0 32.0]\r
+/G62 {\r
+ 21 33 true [1 0 0 -1 0.0 32.0] {<0600003e0000fe00001e00001e00001e00001e00001e00001e00001e00001e00001e1f001e7f801e\r
+ffc01f87e01f01f01e00f01e00f81e00781e00781e00781e00781e00781e00781e00781e00701e00\r
+f01e00e01e01e01f01c00f878007ff0000f800>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c52a AddChar\r
+/G6c [12.0 0.0 1.0 0.0 11.0 32.0]\r
+/G6c {\r
+ 10 32 true [1 0 0 -1 -1.0 32.0] {<06003e00fe001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c52a AddChar\r
+/G6f [22.0 0.0 1.0 -1.0 21.0 21.0]\r
+/G6f {\r
+ 20 22 true [1 0 0 -1 -1.0 21.0] {<01f80007fe000e0f801c07c03803c07803e07001e07001f0f000f0f000f0f000f0f000f0f000f0f0\r
+00f0f800e07800e07c01e03c01c01e03801f870007fe0001f800>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c52a AddChar\r
+/G77 [32.0 0.0 0.0 -1.0 32.0 20.0]\r
+/G77 {\r
+ 32 21 true [1 0 0 -1 0.0 20.0] {<ff8ffc3f7e03e0063e01e0041e01e0081e00f0080f00f0080f00f0100f8178100781781007823c20\r
+07c23c2003c21e2003c41e4001e40f4001e80f4001f80fc000f0078000f007800070038000600300\r
+00600100>} imagemask \r
+ }\r
+ 119 /G77 MSTT31c52a AddChar\r
+/G2c [12.0 0.0 2.0 -8.0 9.0 3.0]\r
+/G2c {\r
+ 7 11 true [1 0 0 -1 -2.0 3.0] {<78fcfe7e020204041830c0>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c52a AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 1672 CB\r
+1733 1678 188 (see below,) 188 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c52a\r
+/G2d [15.0 0.0 2.0 9.0 14.0 13.0]\r
+/G2d {\r
+ 12 4 true [1 0 0 -1 -2.0 13.0] {<fff0fff0fff0fff0>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c52a AddChar\r
+/G61 [21.0 0.0 1.0 -1.0 21.0 21.0]\r
+/G61 {\r
+ 20 22 true [1 0 0 -1 -1.0 21.0] {<07f0001ffc003c3e00781f00780f00780f00300f00000f00001f0000ef00038f000e0f00380f0078\r
+0f00700f00f00f00f00f00f81f10fc7f307fcfe07f8fc01e0780>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c52a AddChar\r
+/G74 [13.0 0.0 -1.0 -1.0 13.0 27.0]\r
+/G74 {\r
+ 14 28 true [1 0 0 -1 1.0 27.0] {<010003000300070007000f003ff8fff80f000f000f000f000f000f000f000f000f000f000f000f00\r
+0f000f000f000f040f880ff807f003c0>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c52a AddChar\r
+/G5f [23.0 0.0 0.0 -10.0 24.0 -8.0]\r
+/G5f {\r
+ 24 2 true [1 0 0 -1 0.0 -8.0] {<ffffffffffff>} imagemask \r
+ }\r
+ 95 /G5f MSTT31c52a AddChar\r
+/G69 [12.0 0.0 1.0 0.0 11.0 32.0]\r
+/G69 {\r
+ 10 32 true [1 0 0 -1 -1.0 32.0] {<0c001e001e000c00000000000000000000000000000006003e00fe001e001e001e001e001e001e00\r
+1e001e001e001e001e001e001e001e001e001e003f00ffc0>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c52a AddChar\r
+/G6e [22.0 0.0 0.0 0.0 22.0 21.0]\r
+/G6e {\r
+ 22 21 true [1 0 0 -1 0.0 21.0] {<060f003e3f80fe7fc01ec3e01f03e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e\r
+01e01e01e01e01e01e01e01e01e01e01e03f03f0ffcffc>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c52a AddChar\r
+/G72 [16.0 0.0 1.0 0.0 16.0 21.0]\r
+/G72 {\r
+ 15 21 true [1 0 0 -1 -1.0 21.0] {<063c3e7efefe1f9c1f001e001e001e001e001e001e001e001e001e001e001e001e001e001e003f00\r
+ffc0>} imagemask \r
+ }\r
+ 114 /G72 MSTT31c52a AddChar\r
+/G75 [23.0 0.0 0.0 -1.0 22.0 20.0]\r
+/G75 {\r
+ 22 21 true [1 0 0 -1 0.0 20.0] {<fe0fe03e03e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e\r
+01e01e01e01e01e01f03e01f0de00ff9fc07f1f003c180>} imagemask \r
+ }\r
+ 117 /G75 MSTT31c52a AddChar\r
+/G63 [20.0 0.0 1.0 -1.0 19.0 21.0]\r
+/G63 {\r
+ 18 22 true [1 0 0 -1 -1.0 21.0] {<00f80007fe000e1f001c0f80380f80380780700300700000700000700000f00000f00000f8000078\r
+00407800c07c00807e01803f03801fff001ffe0007fc0001f000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c52a AddChar\r
+/G78 [23.0 0.0 0.0 0.0 23.0 20.0]\r
+/G78 {\r
+ 23 20 true [1 0 0 -1 0.0 20.0] {<ffc3f83f00e00f00c00f818007c30003c20001e40001f80000f800007c00007c0000be00011f0001\r
+0f800207800407c00803e01801f03801f87e0ffe>} imagemask \r
+ }\r
+ 120 /G78 MSTT31c52a AddChar\r
+/G64 [22.0 0.0 1.0 -1.0 22.0 32.0]\r
+/G64 {\r
+ 21 33 true [1 0 0 -1 -1.0 32.0] {<0000c00007c0001fc00003c00003c00003c00003c00003c00003c00003c00003c001f3c007fbc01e\r
+1fc01c07c03807c07803c07003c07003c0f003c0f003c0f003c0f003c0f003c0f003c0f803c0f803\r
+c07c03c07c07c03f0fc01ffbf80ff3f003c380>} imagemask \r
+ }\r
+ 100 /G64 MSTT31c52a AddChar\r
+%%EndResource\r
+\r
+gs 1061 56 1095 1729 CB\r
+1117 1732 637 (- last_will instruction are executed ) 637 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c537\r
+/MSTT31c537 [46.0 0 0 0 0 0] 43 -105 [-46.0 -46.0 46.0 46.0] [1 46 div 0 0 1 46 div 0 0] /MSTT31c537 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 46 46 0 0 1 42 /MSTT31c537 font\r
+\r
+%%BeginResource: font MSTT31c537\r
+/G65 [20.0 0.0 1.0 0.0 18.0 21.0]\r
+/G65 {\r
+ 17 21 true [1 0 0 -1 -1.0 21.0] {<003e0001c7000303800603800e03801c0700380700380e00781c0070700073c000fe0000f00000f0\r
+0000f00000f00200f80c007c18007ff0003fe0000f8000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c537 AddChar\r
+/G78 [20.0 0.0 -1.0 0.0 20.0 21.0]\r
+/G78 {\r
+ 21 21 true [1 0 0 -1 1.0 21.0] {<0700703f81f80783f803c63001cc0001c80001d00000f00000e00000e00000f00000f00000f00001\r
+f000017800023800063860ec38c0f83d80f81f00601e00>} imagemask \r
+ }\r
+ 120 /G78 MSTT31c537 AddChar\r
+/G63 [20.0 0.0 1.0 0.0 19.0 21.0]\r
+/G63 {\r
+ 18 21 true [1 0 0 -1 -1.0 21.0] {<003f0000e1800381c00701c00e01c01c01c01c0180380000780000700000700000f00000f00000f0\r
+0000f00300f00600f80c007c38007ff0003fe0000f8000>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c537 AddChar\r
+/G70 [23.0 0.0 -5.0 -10.0 22.0 21.0]\r
+/G70 {\r
+ 27 31 true [1 0 0 -1 5.0 21.0] {<001e1f0000fe3f80001cc3c0001d81e0001f01e0003e01e0003c01e0003c01e0003801e0007801c0\r
+007001c0007003c000f0038000e0078000e0070000e00e0001c01c0001c0180001c0700003e0e000\r
+03bf800003800000038000000700000007000000070000000f0000000e0000000e0000001f000000\r
+ffc00000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c537 AddChar\r
+/G74 [13.0 0.0 2.0 0.0 14.0 26.0]\r
+/G74 {\r
+ 12 26 true [1 0 0 -1 -2.0 26.0] {<00c000800180038007001f007ff00e000e001e001e001c003c003c00380038007800780070007000\r
+f000e200e400e400f800e000>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c537 AddChar\r
+/G69 [13.0 0.0 1.0 0.0 11.0 28.0]\r
+/G69 {\r
+ 10 28 true [1 0 0 -1 -1.0 28.0] {<01c001c001c0000000000000000007807f800700070007000f000e000e000e001c001c001c003c00\r
+380038007800720076007400f8007000>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c537 AddChar\r
+/G6f [23.0 0.0 1.0 0.0 21.0 21.0]\r
+/G6f {\r
+ 20 21 true [1 0 0 -1 -1.0 21.0] {<003f0000e3c00380e00700e00e00f01e00f03c00f03c00f07800f07800f07000f0f001e0f001e0f0\r
+03c0f003c0f00780f00700700e00381c001c30000fc000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c537 AddChar\r
+/G6e [23.0 0.0 0.0 0.0 21.0 21.0]\r
+/G6e {\r
+ 21 21 true [1 0 0 -1 0.0 21.0] {<0780f03f83f80707f8070e380718380e30380e60780ec0700e80701d80f01f00e01e00e03c01e03c\r
+01c03801c03803c07003887003907003a0f007c0e00380>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c537 AddChar\r
+/G61 [23.0 0.0 0.0 0.0 22.0 21.0]\r
+/G61 {\r
+ 22 21 true [1 0 0 -1 0.0 21.0] {<001f0c007b9c00c0b80380780700780e00780e00701c00703800f03800e07800e07001e07003e0f0\r
+03c0f005c0f009c0f01380f863907fc3a07f83c01e0380>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c537 AddChar\r
+/G6c [13.0 0.0 1.0 0.0 13.0 32.0]\r
+/G6c {\r
+ 12 32 true [1 0 0 -1 -1.0 32.0] {<00f007f000f000e000e000e001c001c001c001c00380038003800700070007000f000e000e000e00\r
+1c001c001c003800380038007800718071007200fc007000>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c537 AddChar\r
+/G79 [20.0 0.0 -4.0 -10.0 20.0 21.0]\r
+/G79 {\r
+ 24 31 true [1 0 0 -1 4.0 21.0] {<00f00607f00f00f00f00780f00780300380300380200380600380400380c00380800381000383000\r
+3c20003c40003cc0001c80001d00001e00001e00001c0000180000100000200000400000c0006180\r
+00f70000fe0000f80000700000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c537 AddChar\r
+/G2e [12.0 0.0 1.0 0.0 5.0 4.0]\r
+/G2e {\r
+ 4 4 true [1 0 0 -1 -1.0 4.0] {<60f0f060>} imagemask \r
+ }\r
+ 46 /G2e MSTT31c537 AddChar\r
+%%EndResource\r
+\r
+gs 1061 56 1095 1729 CB\r
+1754 1732 256 (exceptionally.) 256 SB\r
+gr\r
+867 2 224 1213 B\r
+1 F\r
+n\r
+2 2 1092 1213 B\r
+1 F\r
+n\r
+1060 2 1095 1213 B\r
+1 F\r
+n\r
+2 568 1092 1216 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1785 CB\r
+248 1788 163 ( const ) 163 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G3d [28.0 0.0 1.0 12.0 27.0 22.0]\r
+/G3d {\r
+ 26 10 true [1 0 0 -1 -1.0 22.0] {<ffffffc0ffffffc0000000000000000000000000000000000000000000000000ffffffc0ffffffc0\r
+>} imagemask \r
+ }\r
+ 61 /G3d MSTT31c4a3 AddChar\r
+/G38 [25.0 0.0 3.0 0.0 22.0 33.0]\r
+/G38 {\r
+ 19 33 true [1 0 0 -1 -3.0 33.0] {<03f8000ffe003e1f00780780700780f003c0f003c0f003c0f803c0f803807c07807e0f003f8e001f\r
+d8000ff00007f00003fc0007fe000c7f001c3f80381fc0780fc07007e0f003e0f001e0f001e0f001\r
+e0f801e07803c03c03803e0f000ffe0003f800>} imagemask \r
+ }\r
+ 56 /G38 MSTT31c4a3 AddChar\r
+/G30 [25.0 0.0 2.0 0.0 23.0 33.0]\r
+/G30 {\r
+ 21 33 true [1 0 0 -1 -2.0 33.0] {<00f80003fe000787000e03801c01c01c01c03800e03800e07800f0780070780070f00078f00078f0\r
+0078f00078f00078f00078f00078f00078f00078f00078f000787000707800f07800f03800e03800\r
+e01c01c01c01c00e0380070f0003fe0000f800>} imagemask \r
+ }\r
+ 48 /G30 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1785 CB\r
+411 1789 122 (cc=80) 122 SB\r
+gr\r
+gs 1061 60 1095 1785 CB\r
+1117 1788 488 (declaration of a constant) 488 SB\r
+gr\r
+867 2 224 1785 B\r
+1 F\r
+n\r
+2 2 1092 1785 B\r
+1 F\r
+n\r
+1060 2 1095 1785 B\r
+1 F\r
+n\r
+2 57 1092 1788 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1846 CB\r
+248 1849 176 ( signal ) 176 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1846 CB\r
+424 1850 41 (S;) 41 SB\r
+gr\r
+gs 867 61 225 1904 CB\r
+248 1908 39 ( ) 39 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1904 CB\r
+287 1907 124 (signal) 124 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G51 [36.0 0.0 2.0 -9.0 34.0 34.0]\r
+/G51 {\r
+ 32 43 true [1 0 0 -1 -2.0 34.0] {<000ff000007ffe0000f81f8003e007c007c003e00f8001f01f0000f81f0000f83e0000fc3e00007c\r
+7e00007e7e00007e7c00003efc00003ffc00003ffc00003ffc00003ffc00003ffc00003ffc00003f\r
+fc00003ffc00003f7c00003e7e00003e7e00007e3e00007c3f00007c1f0000f80f0000f0078001e0\r
+03c003c001e0078000781e00001ff8000007f0000003f8000001fc000000fe0000003f0000000f80\r
+000003e0000000f80000000f>} imagemask \r
+ }\r
+ 81 /G51 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 1904 CB\r
+411 1908 377 ( Alarm\(x: T, y: Q\);) 377 SB\r
+gr\r
+gs 1061 60 1095 1846 CB\r
+1117 1849 476 (declaration of a signal S) 476 SB\r
+gr\r
+gs 1061 60 1095 1903 CB\r
+1117 1906 760 (it may have a list of formal parameters) 760 SB\r
+gr\r
+867 2 224 1846 B\r
+1 F\r
+n\r
+2 2 1092 1846 B\r
+1 F\r
+n\r
+1060 2 1095 1846 B\r
+1 F\r
+n\r
+2 170 1092 1849 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 2020 CB\r
+248 2023 223 ( handlers) 223 SB\r
+gr\r
+gs 867 61 225 2077 CB\r
+248 2080 192 ( when) 192 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2077 CB\r
+440 2081 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G67 [25.0 0.0 -2.0 -11.0 27.0 23.0]\r
+/G67 {\r
+ 29 34 true [1 0 0 -1 2.0 23.0] {<000ff000003c3ff800f01ff001e01ff003e00f0003c00f0007c00f0007c01f0007801f0007801e00\r
+07803e0003c03c0003c0780001e1e000007f80000030000000e0000001c0000003c0000003f80000\r
+03ff000001ffe00003fff0000e0ff8003c01fc0078003c0070001c00f0001c00f0001800f0001800\r
+780030007c0060001f01800003fe0000>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c4f8 AddChar\r
+/G31 [25.0 0.0 3.0 0.0 22.0 33.0]\r
+/G31 {\r
+ 19 33 true [1 0 0 -1 -3.0 33.0] {<0003e0003fc00007c00007c0000780000780000780000f00000f00000f00001e00001e00001e0000\r
+3c00003c00003c00007c0000780000780000f80000f00000f00000f00001e00001e00001e00003c0\r
+0003c00003c00007c00007c0001fe000fff800>} imagemask \r
+ }\r
+ 49 /G31 MSTT31c4f8 AddChar\r
+/G2c [13.0 0.0 0.0 -7.0 6.0 4.0]\r
+/G2c {\r
+ 6 11 true [1 0 0 -1 0.0 4.0] {<387c7c7c3c1c1818306080>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c4f8 AddChar\r
+/G53 [25.0 0.0 0.0 -1.0 27.0 35.0]\r
+/G53 {\r
+ 27 36 true [1 0 0 -1 0.0 35.0] {<0007e020001c1c60003807c0007003c000e003c000e001c001e0018001e0018001e0018001f00100\r
+01f0010000f8000000fc0000007e0000007f0000003f0000001f8000000fc0000007e0000003f000\r
+0003f0000001f8000000f80000007c0010007c0010003c0030003c0030003c0030003c0030003800\r
+70003800780070007c0070007e00e000c783800080fe0000>} imagemask \r
+ }\r
+ 83 /G53 MSTT31c4f8 AddChar\r
+/G49 [17.0 0.0 -2.0 0.0 20.0 34.0]\r
+/G49 {\r
+ 22 34 true [1 0 0 -1 2.0 34.0] {<007ffc000fe00007c0000780000780000f80000f00000f00000f00001f00001e00001e00003e0000\r
+3c00003c00003c0000780000780000780000f80000f00000f00000f00001e00001e00001e00003c0\r
+0003c00003c00007c0000780000f80001fc000fff800>} imagemask \r
+ }\r
+ 73 /G49 MSTT31c4f8 AddChar\r
+/G47 [36.0 0.0 2.0 -1.0 36.0 35.0]\r
+/G47 {\r
+ 34 36 true [1 0 0 -1 -2.0 35.0] {<00007fc1800003807f80000e001f000038000f000070000f0001e000060003c00006000780000600\r
+07800004000f000004001e000000001e000000003c000000003c000000007c000000007800000000\r
+7800000000f800000000f80007ffc0f80000fe00f800007c00f800007c00f000007800f800007800\r
+f80000f800f80000f000780000f000780000f0003c0001e0003c0001e0001e0001e0000e0003e000\r
+070003c00003c007c00000f03e0000001ff00000>} imagemask \r
+ }\r
+ 71 /G47 MSTT31c4f8 AddChar\r
+/G4e [33.0 0.0 -2.0 -1.0 38.0 34.0]\r
+/G4e {\r
+ 40 35 true [1 0 0 -1 2.0 34.0] {<00ff0007ff003f8000f8000f8000e000078000e00007c000c00007c000c0000fc000c0000de000c0\r
+000de00180000df001800018f001800018f003000018f803000030780300003078020000303c0600\r
+00603c060000603c060000601e0c0000601e0c0000c01f0c0000c00f180000c00f180001800f9800\r
+0180079800018007b000030003f000030003f000030003e000070001e000070001e0000f0001c000\r
+1f0000c000ffe000c000000000c000>} imagemask \r
+ }\r
+ 78 /G4e MSTT31c4f8 AddChar\r
+/G33 [25.0 0.0 2.0 0.0 23.0 33.0]\r
+/G33 {\r
+ 21 33 true [1 0 0 -1 -2.0 33.0] {<000f80003fe0007ff000e1f80080f80100780000780000780000700000f00001e0000380000e0000\r
+7e0003ff00007f80001fc00007c00003e00003e00001e00001e00001e00001e00001c00001c00003\r
+80000380780700fe0e00fffc007ff0003f8000>} imagemask \r
+ }\r
+ 51 /G33 MSTT31c4f8 AddChar\r
+/G3a [17.0 0.0 3.0 0.0 13.0 23.0]\r
+/G3a {\r
+ 10 23 true [1 0 0 -1 -3.0 23.0] {<038007c007c007c0038000000000000000000000000000000000000000000000000000007000f800\r
+f800f8007000>} imagemask \r
+ }\r
+ 58 /G3a MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 2077 CB\r
+453 2081 508 (sig1,SIGN3: Inst; return;) 508 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 2135 CB\r
+248 2138 192 ( when) 192 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2135 CB\r
+440 2139 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G32 [25.0 0.0 1.0 0.0 23.0 33.0]\r
+/G32 {\r
+ 22 33 true [1 0 0 -1 -1.0 33.0] {<000f80003fe0007ff000fff801c1f80100fc02007c00003c00003c00003c00003800003800003800\r
+00700000600000e00001c0000180000300000600000c0000180000300000600000c0000180000300\r
+200400400800c01fffc03fff807fff80ffff00>} imagemask \r
+ }\r
+ 50 /G32 MSTT31c4f8 AddChar\r
+/G77 [31.0 0.0 -1.0 0.0 30.0 23.0]\r
+/G77 {\r
+ 31 23 true [1 0 0 -1 1.0 23.0] {<0f00180cff00380e0f00380e0f80780e078078060780f8040780f80c0781f80c0781780807827810\r
+07c6783003c4782003cc784003c878c003d0788003d0790003e07a0003c07a0003c07c0003807800\r
+038070000300600002004000>} imagemask \r
+ }\r
+ 119 /G77 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 2135 CB\r
+453 2139 515 (sig2: instructions2; wind;) 515 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 2193 CB\r
+248 2196 223 ( others ) 223 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2193 CB\r
+471 2197 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 225 2193 CB\r
+484 2197 260 (in; terminate) 260 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 2251 CB\r
+248 2254 314 ( end handlers) 314 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 2020 CB\r
+1117 2023 886 (declaration of a module handling exceptions,) 886 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1095 2077 CB\r
+1117 2080 367 (sig1, sig2, SIGN3 ) 367 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 2077 CB\r
+1484 2080 476 (are names of exceptions) 476 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1095 2077 CB\r
+1960 2080 13 (,) 13 SB\r
+gr\r
+gs 1061 60 1095 2134 CB\r
+1117 2137 413 (Inst, instructions2,in) 413 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G71 [25.0 0.0 2.0 -11.0 24.0 23.0]\r
+/G71 {\r
+ 22 34 true [1 0 0 -1 -2.0 23.0] {<00f86003fee00f0fe01e03e03c03e03801e07801e07001e07001e0f001e0f001e0f001e0f001e0f0\r
+01e0f001e0f001e0f801e07801e07c01e07e03e03f05e01ff9e00ff1e003c1e00001e00001e00001\r
+e00001e00001e00001e00001e00001e00003f0000ffc>} imagemask \r
+ }\r
+ 113 /G71 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 2134 CB\r
+1530 2137 584 ( are sequences of instructions) 584 SB\r
+gr\r
+gs 1061 60 1095 2248 CB\r
+1117 2251 452 (handlers appear as the ) 452 SB\r
+gr\r
+32 0 0 50 50 1 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 2248 CB\r
+1569 2251 68 (last) 68 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 2248 CB\r
+1637 2251 405 ( declaration in a unit) 405 SB\r
+gr\r
+867 2 224 2020 B\r
+1 F\r
+n\r
+2 2 1092 2020 B\r
+1 F\r
+n\r
+1060 2 1095 2020 B\r
+1 F\r
+n\r
+2 287 1092 2023 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 868 60 225 2482 CB\r
+248 2485 533 (Parametrisation of Units) 533 SB\r
+gr\r
+867 2 224 2311 B\r
+1 F\r
+n\r
+2 2 1092 2311 B\r
+1 F\r
+n\r
+2 2 1095 2311 B\r
+1 F\r
+n\r
+1057 2 1098 2311 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 868 60 225 2542 CB\r
+248 2545 140 (modes ) 140 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 868 60 225 2542 CB\r
+388 2545 314 (of transmission:) 314 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1062 61 1094 2542 CB\r
+1117 2545 435 (input, output, inout ) 435 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1062 61 1094 2542 CB\r
+1552 2546 433 ( values of expressions) 433 SB\r
+gr\r
+868 2 224 2542 B\r
+1 F\r
+n\r
+2 2 1093 2542 B\r
+1 F\r
+n\r
+1059 2 1096 2542 B\r
+1 F\r
+n\r
+gs 867 61 225 2603 CB\r
+248 2607 105 (also ) 105 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G79 [25.0 0.0 0.0 -11.0 24.0 22.0]\r
+/G79 {\r
+ 24 33 true [1 0 0 -1 0.0 22.0] {<fff8ff7fe03e3fc01c1fe0180fe0180ff0300ff03007f03007f86003f86003fcc001fcc001fec000\r
+ff8000ff80007f00007f00007f00003e00003e00001e00001c00000c000018000018000018003c30\r
+007e30007e60007e60007fc0003f80001f0000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 2603 CB\r
+353 2606 552 (procedure, function, type ) 552 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2603 CB\r
+905 2607 127 (can be) 127 SB\r
+gr\r
+gs 867 60 225 2661 CB\r
+248 2664 524 (transmitted as a parameter) 524 SB\r
+gr\r
+gs 1061 60 1095 2603 CB\r
+1117 2606 968 (formal procedures\(functions\) should be specified) 968 SB\r
+gr\r
+gs 1061 60 1095 2660 CB\r
+1117 2663 953 (i.e. the types of arguments and results should be) 953 SB\r
+gr\r
+gs 1061 60 1095 2717 CB\r
+1117 2720 120 (given.) 120 SB\r
+gr\r
+gs 1061 60 1095 2774 CB\r
+1117 2777 987 (a formal type T alone is of limited use, however it) 987 SB\r
+gr\r
+gs 1061 60 1095 2831 CB\r
+1117 2834 841 (may accompany other parameters using T.) 841 SB\r
+gr\r
+867 2 224 2603 B\r
+1 F\r
+n\r
+2 2 1092 2603 B\r
+1 F\r
+n\r
+2 2 1095 2603 B\r
+1 F\r
+n\r
+1057 2 1098 2603 B\r
+1 F\r
+n\r
+2 284 1092 2606 B\r
+1 F\r
+n\r
+gs 868 60 225 2891 CB\r
+248 2894 281 (Processes are ) 281 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 868 60 225 2891 CB\r
+529 2894 216 (distributed) 216 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 868 60 225 2891 CB\r
+745 2894 266 ( it means that) 266 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G6a [12.0 0.0 -4.0 -11.0 8.0 35.0]\r
+/G6a {\r
+ 12 46 true [1 0 0 -1 4.0 35.0] {<00e001f001f001f000e00000000000000000000000000000003000f003f007f000f000f000f000f0\r
+00f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000e0\r
+00e000e070c0f980ff007e00>} imagemask \r
+ }\r
+ 106 /G6a MSTT31c4a3 AddChar\r
+/G59 [36.0 0.0 1.0 0.0 36.0 33.0]\r
+/G59 {\r
+ 35 33 true [1 0 0 -1 -1.0 33.0] {<fffc01ffe03fe0003f001fc0003e000fc0001c0007e000380007e000300003f000700001f8006000\r
+01f800c00000fc01c000007c018000007e030000003f070000001f060000001f8c0000000fdc0000\r
+0007d800000007f000000003f000000003f000000001f000000001f000000001f000000001f00000\r
+0001f000000001f000000001f000000001f000000001f000000001f000000001f000000007fc0000\r
+003fff8000>} imagemask \r
+ }\r
+ 89 /G59 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 868 60 225 2948 CB\r
+248 2951 694 (they cannot share objects. You can) 694 SB\r
+gr\r
+gs 868 60 225 3005 CB\r
+248 3008 791 (transmit only values of simple types and) 791 SB\r
+gr\r
+gs 868 60 225 3062 CB\r
+248 3065 813 (names of processes or formal procedures) 813 SB\r
+gr\r
+gs 868 60 225 3119 CB\r
+248 3122 461 (to be used for alien call) 461 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G2e [13.0 0.0 1.0 0.0 6.0 5.0]\r
+/G2e {\r
+ 5 5 true [1 0 0 -1 -1.0 5.0] {<70f8f8f870>} imagemask \r
+ }\r
+ 46 /G2e MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 868 60 225 3119 CB\r
+709 3122 32 (s.) 32 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1062 60 1094 2891 CB\r
+1117 2894 973 (Processes can reside on different systems of your) 973 SB\r
+gr\r
+gs 1062 60 1094 2948 CB\r
+1117 2951 831 (network. This explains the reasons for the) 831 SB\r
+gr\r
+gs 1062 60 1094 3005 CB\r
+1117 3008 233 (restrictions.) 233 SB\r
+gr\r
+gs 1062 60 1094 3062 CB\r
+1117 3065 888 (The present implementation of processes has) 888 SB\r
+gr\r
+gs 1062 60 1094 3119 CB\r
+1117 3122 507 (several limitations. Sorry.) 507 SB\r
+gr\r
+867 2 224 2891 B\r
+1 F\r
+n\r
+2 2 1092 2891 B\r
+1 F\r
+n\r
+2 2 1095 2891 B\r
+1 F\r
+n\r
+1057 2 1098 2891 B\r
+1 F\r
+n\r
+868 2 224 3179 B\r
+1 F\r
+n\r
+2 2 1093 3179 B\r
+1 F\r
+n\r
+1059 2 1096 3179 B\r
+1 F\r
+n\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Helvetica\r
+%%+ font Helvetica-BoldOblique\r
+%%+ font Helvetica-Oblique\r
+%%+ font MSTT31c4a3\r
+%%+ font MSTT31c4bd\r
+%%+ font MSTT31c4eb\r
+%%+ font MSTT31c4f8\r
+%%+ font MSTT31c510\r
+%%+ font MSTT31c51d\r
+%%+ font MSTT31c52a\r
+%%+ font MSTT31c537\r
+%%Page: 2 2\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 63 63 0 0 0 58 /Helvetica-BoldOblique /font14 ANSIFont font\r
+0 0 0 fC\r
+gs 868 72 177 224 CB\r
+200 224 359 (Instructions) 359 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 60 177 296 CB\r
+200 299 473 (Atomic instructions) 473 SB\r
+gr\r
+0 0 0 fC\r
+/fm 256 def\r
+868 2 176 296 B\r
+1 F\r
+n\r
+2 2 1045 296 B\r
+1 F\r
+n\r
+1059 2 1048 296 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 60 177 356 CB\r
+200 359 159 ( x := <) 159 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G78 [22.0 0.0 -1.0 0.0 22.0 23.0]\r
+/G78 {\r
+ 23 23 true [1 0 0 -1 1.0 23.0] {<07801c3fc07e07c0fe03c1fe01e39c01e30001e60000fc0000f80000f80000f80000780000780000\r
+7c00007c0000bc0001bc00033e18021e10e61e20fc1fc0f80f80700700>} imagemask \r
+ }\r
+ 120 /G78 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 60 177 356 CB\r
+359 359 212 (expression) 212 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 60 177 356 CB\r
+571 359 28 (>) 28 SB\r
+gr\r
+gs 1061 60 1047 356 CB\r
+1069 359 443 (assignment instruction) 443 SB\r
+gr\r
+867 2 176 356 B\r
+1 F\r
+n\r
+2 2 1044 356 B\r
+1 F\r
+n\r
+2 2 1047 356 B\r
+1 F\r
+n\r
+1057 2 1050 356 B\r
+1 F\r
+n\r
+2 56 1044 359 B\r
+1 F\r
+n\r
+gs 867 61 177 416 CB\r
+200 420 131 ( x := ) 131 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 416 CB\r
+331 419 113 (copy ) 113 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 416 CB\r
+444 420 45 (\(<) 45 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 416 CB\r
+489 420 212 (expression) 212 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 416 CB\r
+701 420 45 (>\)) 45 SB\r
+gr\r
+gs 1061 60 1047 416 CB\r
+1069 419 992 (copying assignment instruction, has sense only for) 992 SB\r
+gr\r
+gs 1061 60 1047 473 CB\r
+1069 476 363 (object expressions) 363 SB\r
+gr\r
+867 2 176 416 B\r
+1 F\r
+n\r
+2 2 1044 416 B\r
+1 F\r
+n\r
+1060 2 1047 416 B\r
+1 F\r
+n\r
+2 113 1044 419 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 533 CB\r
+200 536 125 ( call ) 125 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 533 CB\r
+325 537 412 (Aprocedure\(params\)) 412 SB\r
+gr\r
+gs 1061 60 1047 533 CB\r
+1069 536 506 (procedure call instruction) 506 SB\r
+gr\r
+867 2 176 533 B\r
+1 F\r
+n\r
+2 2 1044 533 B\r
+1 F\r
+n\r
+1060 2 1047 533 B\r
+1 F\r
+n\r
+2 57 1044 536 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 177 594 CB\r
+200 597 176 ( return) 176 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 594 CB\r
+1069 597 587 (leaving procedure or function) 587 SB\r
+gr\r
+867 2 176 594 B\r
+1 F\r
+n\r
+2 2 1044 594 B\r
+1 F\r
+n\r
+1060 2 1047 594 B\r
+1 F\r
+n\r
+2 56 1044 597 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G78 [24.0 0.0 1.0 0.0 24.0 22.0]\r
+/G78 {\r
+ 23 22 true [1 0 0 -1 -1.0 22.0] {<fff7f87fe1e01fe1c01fe1800ff30007f60007fe0003fc0003fc0001fe0001fe0000ff0000ff0000\r
+ff8001ff8001bfc0033fc0061fe00e0fe01c0ff03e0ff8ffbffe>} imagemask \r
+ }\r
+ 120 /G78 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 654 CB\r
+200 657 142 ( exit ) 142 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 654 CB\r
+342 658 69 ( or ) 69 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 654 CB\r
+411 657 193 ( exit exit ) 193 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 654 CB\r
+604 658 69 (or ) 69 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 654 CB\r
+673 657 257 (exit exit exit) 257 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1047 654 CB\r
+1069 658 772 (leaving one, two or three nested loops ) 772 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1047 654 CB\r
+1841 657 145 (do od) 145 SB\r
+gr\r
+867 2 176 654 B\r
+1 F\r
+n\r
+2 2 1044 654 B\r
+1 F\r
+n\r
+1060 2 1047 654 B\r
+1 F\r
+n\r
+2 57 1044 657 B\r
+1 F\r
+n\r
+gs 867 61 177 715 CB\r
+200 718 138 ( new ) 138 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 715 CB\r
+338 719 305 (Aclass\(params\)) 305 SB\r
+gr\r
+gs 1061 60 1047 715 CB\r
+1069 718 625 (instruction generating an object) 625 SB\r
+gr\r
+867 2 176 715 B\r
+1 F\r
+n\r
+2 2 1044 715 B\r
+1 F\r
+n\r
+1060 2 1047 715 B\r
+1 F\r
+n\r
+2 57 1044 718 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 60 177 776 CB\r
+200 779 213 ( Objects) 213 SB\r
+gr\r
+867 2 176 776 B\r
+1 F\r
+n\r
+2 2 1044 776 B\r
+1 F\r
+n\r
+2 2 1047 776 B\r
+1 F\r
+n\r
+1057 2 1050 776 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 836 CB\r
+200 840 131 ( x := ) 131 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 836 CB\r
+331 839 86 (new) 86 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 836 CB\r
+417 840 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G41 [31.0 0.0 -3.0 0.0 27.0 35.0]\r
+/G41 {\r
+ 30 35 true [1 0 0 -1 3.0 35.0] {<000000100000003000000070000000f0000000f0000001f0000003f0000003e0000007e000000de0\r
+00001de0000019e0000031e0000061e0000061e00000c1e0000181e0000181e0000301e0000601e0\r
+000c01e0000c01e0001fffc0003fffc0003003c0006003c000c003c001c003c0018003c0030003c0\r
+060003c00e0003c01e0007c03f000fe0ffc07ffc>} imagemask \r
+ }\r
+ 65 /G41 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 836 CB\r
+430 840 130 (Aclass) 130 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 836 CB\r
+560 840 17 (\() 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 836 CB\r
+577 840 149 (params) 149 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 836 CB\r
+726 840 17 (\)) 17 SB\r
+gr\r
+gs 1061 60 1047 836 CB\r
+1069 839 506 (creates an object of class ) 506 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 836 CB\r
+1575 839 130 (Aclass) 130 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 836 CB\r
+1705 839 113 ( with ) 113 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 836 CB\r
+1818 839 149 (params) 149 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 893 CB\r
+1069 896 651 (and stores it under the name of x) 651 SB\r
+gr\r
+867 2 176 836 B\r
+1 F\r
+n\r
+2 2 1044 836 B\r
+1 F\r
+n\r
+2 2 1047 836 B\r
+1 F\r
+n\r
+1057 2 1050 836 B\r
+1 F\r
+n\r
+2 113 1044 839 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 953 CB\r
+200 956 130 ( end ) 130 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 953 CB\r
+330 957 130 (Aclass) 130 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 953 CB\r
+460 957 186 ( or ) 186 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 953 CB\r
+646 956 137 (return) 137 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 953 CB\r
+1069 956 988 (terminating initialisation of a newly created object) 988 SB\r
+gr\r
+867 2 176 953 B\r
+1 F\r
+n\r
+2 2 1044 953 B\r
+1 F\r
+n\r
+1060 2 1047 953 B\r
+1 F\r
+n\r
+2 57 1044 956 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 1014 CB\r
+200 1017 106 ( kill) 106 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1014 CB\r
+306 1018 17 (\() 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 1014 CB\r
+323 1018 22 (x) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1014 CB\r
+345 1018 17 (\)) 17 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G7b [24.0 0.0 5.0 -11.0 19.0 35.0]\r
+/G7b {\r
+ 14 46 true [1 0 0 -1 -5.0 35.0] {<000c007000c001800380070007000f000f000f000f000f800f800f80078007800780070007000600\r
+0e0018003000c00030001c000e000700070007800780078007800f800f800f800f000f000f000700\r
+07000380018000c00070000c>} imagemask \r
+ }\r
+ 123 /G7b MSTT31c4a3 AddChar\r
+/G7d [24.0 0.0 5.0 -11.0 19.0 35.0]\r
+/G7d {\r
+ 14 46 true [1 0 0 -1 -5.0 35.0] {<c00038000c00060007000380038003c003c003c007c007c007c007800780078007800380038001c0\r
+00e00030000c003000e001c001800380038007800780078007c007c007c003c003c003c003c00380\r
+0380070006000c003800c000>} imagemask \r
+ }\r
+ 125 /G7d MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1047 1014 CB\r
+1069 1017 992 (deallocation instruction, causes{x=none}and kills ) 992 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1014 CB\r
+2061 1017 22 (x) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G4e [36.0 0.0 -1.0 -1.0 36.0 33.0]\r
+/G4e {\r
+ 37 34 true [1 0 0 -1 1.0 33.0] {<ffc0007ff80fe00007c007f000030003f800030001f800030001fc00030001fe00030001bf000300\r
+019f800300018f800300018fc003000187e003000183f003000181f803000180f803000180fc0300\r
+01807e030001803f030001801f830001800f8300018007c300018007e300018003f300018001fb00\r
+018000fb000180007f000180007f000180003f000180001f000180000f00018000070007c0000300\r
+3ffc0003000000000100>} imagemask \r
+ }\r
+ 78 /G4e MSTT31c4a3 AddChar\r
+/G21 [16.0 0.0 6.0 -1.0 10.0 34.0]\r
+/G21 {\r
+ 4 35 true [1 0 0 -1 -6.0 34.0] {<60f0f0f0f0f0f0f0f0f0f0f0f0f0f0e060606060606060606060600000000060f0f060>} imagemask \r
+ }\r
+ 33 /G21 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1047 1071 CB\r
+1069 1074 712 (REMARK. No dangling references!) 712 SB\r
+gr\r
+gs 1061 60 1047 1128 CB\r
+1069 1131 24 ({) 24 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1128 CB\r
+1093 1131 22 (x) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1115 1131 28 (=) 28 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G79 [22.0 0.0 -5.0 -11.0 22.0 23.0]\r
+/G79 {\r
+ 27 34 true [1 0 0 -1 5.0 23.0] {<003800c003fc01e0007c01e0003c01e0003e00e0003e0060001e0040001e00c0001e0080001e0180\r
+001e0100001e0300001e0200001e0400001f0c00000f1800000f1000000f3000000f6000000f4000\r
+000f8000000f0000000f0000000e0000000c000000180000003000000060000000c0000071800000\r
+f3000000fe000000fc00000070000000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1047 1128 CB\r
+1143 1131 22 (y) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G26 [38.0 0.0 1.0 -1.0 36.0 34.0]\r
+/G26 {\r
+ 35 35 true [1 0 0 -1 -1.0 34.0] {<0007e00000001ff80000003c3c000000781c000000700e000000f00e000000f00e000000f00e0000\r
+00f01e000000f81c000000f8780000007cf00000007fe0ffc0007fc07f00003f003c00007e003c00\r
+01ff00380003df003000078f8030000f0f8060001e07c0c0003e07e0c0007c03e180007c01f30000\r
+fc01f60000fc00fc0000fc00780000fc007c0000fe003e0020fe007f80607f00dfe0c07f838fffc0\r
+3fff03ff801ffc01ff0007f0007c00>} imagemask \r
+ }\r
+ 38 /G26 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1047 1128 CB\r
+1165 1131 38 (&) 38 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1128 CB\r
+1203 1131 22 (x) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1225 1131 28 (=) 28 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G7a [19.0 0.0 -1.0 0.0 19.0 22.0]\r
+/G7a {\r
+ 20 22 true [1 0 0 -1 1.0 22.0] {<03fff007fff007ffe007ffc00601800c0300080600000c0000180000100000200000400000800001\r
+80000300000600800c01801803003fff007fff00fffe00fffe00>} imagemask \r
+ }\r
+ 122 /G7a MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1047 1128 CB\r
+1253 1131 19 (z) 19 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1272 1131 184 (} => kill\() 184 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1128 CB\r
+1456 1131 22 (x) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1478 1131 54 (\) {) 54 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1128 CB\r
+1532 1131 22 (x) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1554 1131 162 (=none&) 162 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1128 CB\r
+1716 1131 22 (y) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1738 1131 162 (=none&) 162 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1128 CB\r
+1900 1131 19 (z) 19 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1128 CB\r
+1919 1131 148 (=none}) 148 SB\r
+gr\r
+867 2 176 1014 B\r
+1 F\r
+n\r
+2 2 1044 1014 B\r
+1 F\r
+n\r
+1060 2 1047 1014 B\r
+1 F\r
+n\r
+2 170 1044 1017 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 867 60 177 1188 CB\r
+200 1191 42 ( ) 42 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 177 1188 CB\r
+242 1191 113 (inner) 113 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1188 CB\r
+1069 1191 988 (pseudoinstruction: a slot for the instructions of an) 988 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G68 [25.0 0.0 0.0 0.0 24.0 35.0]\r
+/G68 {\r
+ 24 35 true [1 0 0 -1 0.0 35.0] {<003c0003fc00007c00003c0000780000780000780000f00000f00000f00001e00001e00001e03c01\r
+e0fe03c1ff03c39f03c60f078c1f07981f07b01e0f203e0f603e0fc03c1f807c1f007c1f00781e00\r
+f83e00f83c00f03c01f07801f27801e47801e8f803f0f001c0>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1047 1245 CB\r
+1069 1248 197 (inheriting) 197 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1245 CB\r
+1266 1248 89 ( unit) 89 SB\r
+gr\r
+867 2 176 1188 B\r
+1 F\r
+n\r
+2 2 1044 1188 B\r
+1 F\r
+n\r
+1060 2 1047 1188 B\r
+1 F\r
+n\r
+2 113 1044 1191 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 60 177 1305 CB\r
+200 1308 294 ( Coroutines) 294 SB\r
+gr\r
+867 2 176 1305 B\r
+1 F\r
+n\r
+2 2 1044 1305 B\r
+1 F\r
+n\r
+2 2 1047 1305 B\r
+1 F\r
+n\r
+1057 2 1050 1305 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1408 CB\r
+200 1412 131 ( x := ) 131 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 1408 CB\r
+331 1411 86 (new) 86 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1408 CB\r
+417 1412 265 ( Cor\(params\)) 265 SB\r
+gr\r
+gs 1061 60 1047 1408 CB\r
+1069 1411 788 (creates a coroutine object x of type Cor) 788 SB\r
+gr\r
+867 2 176 1408 B\r
+1 F\r
+n\r
+2 2 1044 1408 B\r
+1 F\r
+n\r
+2 2 1047 1408 B\r
+1 F\r
+n\r
+1057 2 1050 1408 B\r
+1 F\r
+n\r
+2 57 1044 1411 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 1469 CB\r
+200 1472 173 ( attach) 173 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1469 CB\r
+373 1473 58 (\(x\)) 58 SB\r
+gr\r
+gs 1061 60 1047 1469 CB\r
+1069 1472 1000 (activates coroutine x, and then makes the current) 1000 SB\r
+gr\r
+gs 1061 60 1047 1526 CB\r
+1069 1529 462 (coroutine chain passive) 462 SB\r
+gr\r
+867 2 176 1469 B\r
+1 F\r
+n\r
+2 2 1044 1469 B\r
+1 F\r
+n\r
+1060 2 1047 1469 B\r
+1 F\r
+n\r
+2 113 1044 1472 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 177 1586 CB\r
+200 1589 181 ( detach) 181 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1586 CB\r
+1069 1589 429 (undoes the last attach) 429 SB\r
+gr\r
+867 2 176 1586 B\r
+1 F\r
+n\r
+2 2 1044 1586 B\r
+1 F\r
+n\r
+1060 2 1047 1586 B\r
+1 F\r
+n\r
+2 56 1044 1589 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 60 177 1646 CB\r
+200 1649 653 ( Processes & Concurrency) 653 SB\r
+gr\r
+32 0 0 46 46 0 0 1 42 /MSTT31c52a font\r
+\r
+%%BeginResource: font MSTT31c52a\r
+/G79 [22.0 0.0 0.0 -10.0 22.0 20.0]\r
+/G79 {\r
+ 22 30 true [1 0 0 -1 0.0 20.0] {<ffc0fc7f00303e00301e00201f00200f00400f804007808007c08003c08003e10001e10001f20000\r
+f20000fa00007c00007c000038000038000010000010000010000020000020000040000040003880\r
+007f80007f00003c0000>} imagemask \r
+ }\r
+ 121 /G79 MSTT31c52a AddChar\r
+/G6a [12.0 0.0 -4.0 -10.0 8.0 32.0]\r
+/G6a {\r
+ 12 42 true [1 0 0 -1 4.0 32.0] {<006000f000f000600000000000000000000000000000003001f007f000f000f000f000f000f000f0\r
+00f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000f000e000e070c0f8c0\r
+fd807e00>} imagemask \r
+ }\r
+ 106 /G6a MSTT31c52a AddChar\r
+/G70 [23.0 0.0 0.0 -10.0 21.0 21.0]\r
+/G70 {\r
+ 21 31 true [1 0 0 -1 0.0 21.0] {<061f003e3fc0fe7fe01ec3e01f01f01e00f01e00f81e00781e00781e00781e00781e00781e00781e\r
+00781e00701e00701e00f01e00e01f01c01f83c01eff001e7e001e00001e00001e00001e00001e00\r
+001e00001e00003f0000ffc000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c52a AddChar\r
+/G76 [22.0 0.0 0.0 -1.0 22.0 20.0]\r
+/G76 {\r
+ 22 21 true [1 0 0 -1 0.0 20.0] {<ffc0fc3f00301f00300f00200f00600f00400780c007808003c08003c18003c10001e30001e20001\r
+f60000f40000f400007c00007800007800003000003000>} imagemask \r
+ }\r
+ 118 /G76 MSTT31c52a AddChar\r
+/G6d [34.0 0.0 0.0 0.0 34.0 21.0]\r
+/G6d {\r
+ 34 21 true [1 0 0 -1 0.0 21.0] {<060f00f0003e3f83f800fe7fc7fc001ec7ec3e001f03f01e001e01e01e001e01e01e001e01e01e00\r
+1e01e01e001e01e01e001e01e01e001e01e01e001e01e01e001e01e01e001e01e01e001e01e01e00\r
+1e01e01e001e01e01e001e01e01e003f03f03f00ffc7fc7fc0>} imagemask \r
+ }\r
+ 109 /G6d MSTT31c52a AddChar\r
+%%EndResource\r
+\r
+gs 1062 56 1046 1646 CB\r
+1069 1649 958 (truly object oriented processes and an objective com-) 958 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c52a\r
+/G68 [22.0 0.0 0.0 0.0 22.0 32.0]\r
+/G68 {\r
+ 22 32 true [1 0 0 -1 0.0 32.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e00001e0f001e3f801e\r
+7fc01ec3c01f03e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01e01\r
+e01e01e01e01e01e01e03f03f0ffcffc>} imagemask \r
+ }\r
+ 104 /G68 MSTT31c52a AddChar\r
+/G67 [22.0 0.0 0.0 -10.0 21.0 21.0]\r
+/G67 {\r
+ 21 31 true [1 0 0 -1 0.0 21.0] {<01f800071e000e0ff81c07f81c07803c03c03c03c03c03c03c03c03c03c01e03c01e03800f070007\r
+8e0007f8000c00001800003800003fffc03ffff00ffff0080038100018200018600018e00030f000\r
+70fe01e07fffc01fff0007f800>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c52a AddChar\r
+/G66 [15.0 0.0 1.0 0.0 20.0 32.0]\r
+/G66 {\r
+ 19 32 true [1 0 0 -1 -1.0 32.0] {<003f0000ff8001c7c00383e00701e00700c00700000f00000f00000f00000f00000f0000fffc00ff\r
+fc000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00\r
+000f00000f00000f00001f8000fff800>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c52a AddChar\r
+%%EndResource\r
+\r
+gs 1062 56 1046 1699 CB\r
+1069 1702 939 (munication mechanism just by calling methods of a) 939 SB\r
+gr\r
+gs 1062 56 1046 1752 CB\r
+1069 1755 269 (distant process) 269 SB\r
+gr\r
+867 2 176 1646 B\r
+1 F\r
+n\r
+2 2 1044 1646 B\r
+1 F\r
+n\r
+2 2 1047 1646 B\r
+1 F\r
+n\r
+1057 2 1050 1646 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G35 [25.0 0.0 1.0 0.0 24.0 33.0]\r
+/G35 {\r
+ 23 33 true [1 0 0 -1 -1.0 33.0] {<001ffe001ffe003ffc003ffc00200000400000400000800000f00001fe0001ff0003ff80007fc000\r
+0fe00007e00003f00001f00001f00000f00000f00000f00000f00000e00000e00001c00001c00003\r
+80000300f80f00fc1c00fff8007fe0003f8000>} imagemask \r
+ }\r
+ 53 /G35 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 1808 CB\r
+200 1812 209 ( proces5) 209 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1808 CB\r
+409 1812 42 (:=) 42 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 1808 CB\r
+451 1811 86 (new) 86 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1808 CB\r
+537 1812 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G54 [28.0 0.0 4.0 0.0 33.0 34.0]\r
+/G54 {\r
+ 29 34 true [1 0 0 -1 -4.0 34.0] {<0ffffff80f03c0781c03c0301803c030100780302007802020078020200f0020000f0000000f0000\r
+001f0000001e0000001e0000001e0000003c0000003c0000003c0000007800000078000000780000\r
+00f8000000f0000000f0000000f0000001e0000001e0000001e0000003c0000003c0000003c00000\r
+07c0000007c000000fc00000fffc0000>} imagemask \r
+ }\r
+ 84 /G54 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 1808 CB\r
+550 1812 229 (procesType) 229 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1808 CB\r
+779 1812 86 (\(...\);) 86 SB\r
+gr\r
+gs 1061 60 1047 1808 CB\r
+1069 1811 386 (creates an object of) 386 SB\r
+gr\r
+gs 1061 61 1047 1865 CB\r
+1069 1869 39 ( ) 39 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1047 1865 CB\r
+1108 1868 100 (unit ) 100 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 61 1047 1865 CB\r
+1208 1869 229 (procesType) 229 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1047 1865 CB\r
+1437 1869 27 (: ) 27 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1047 1865 CB\r
+1464 1868 156 (process) 156 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1047 1865 CB\r
+1620 1869 45 (\(<) 45 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G66 [15.0 0.0 -9.0 -11.0 23.0 35.0]\r
+/G66 {\r
+ 32 46 true [1 0 0 -1 9.0 35.0] {<0000003c000000e6000001c70000038f0000078e0000070000000f0000000e0000001e0000001e00\r
+00003c0000003c000000fc00000fff80000fff8000007800000078000000f0000000f0000000f000\r
+0001f0000001e0000001e0000003e0000003c0000003c0000003c000000780000007800000078000\r
+000f0000000f0000000f0000001e0000001e0000001c0000001c0000003800000038000000300000\r
+0070000070600000f0c00000f1800000e30000007c000000>} imagemask \r
+ }\r
+ 102 /G66 MSTT31c4f8 AddChar\r
+/G50 [30.0 0.0 -2.0 0.0 30.0 34.0]\r
+/G50 {\r
+ 32 34 true [1 0 0 -1 2.0 34.0] {<007fffc0000fc0f00007803c0007801e0007801e000f001f000f001f000f000f000f001f001e001f\r
+001e001e001e001e003e003c003c007c003c0078003c01e0007e07c0007bfe000078000000f80000\r
+00f0000000f0000000f0000001e0000001e0000001e0000003c0000003c0000003c0000007c00000\r
+078000000f8000001fc00000fff80000>} imagemask \r
+ }\r
+ 80 /G50 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1047 1865 CB\r
+1665 1869 249 (formParams) 249 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1047 1865 CB\r
+1914 1869 110 (>\); ...) 110 SB\r
+gr\r
+867 2 176 1808 B\r
+1 F\r
+n\r
+2 2 1044 1808 B\r
+1 F\r
+n\r
+2 2 1047 1808 B\r
+1 F\r
+n\r
+1057 2 1050 1808 B\r
+1 F\r
+n\r
+2 114 1044 1811 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 1926 CB\r
+200 1929 192 ( resume) 192 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1926 CB\r
+392 1930 17 (\() 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 1926 CB\r
+409 1930 157 (proces5) 157 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 1926 CB\r
+566 1930 17 (\)) 17 SB\r
+gr\r
+gs 1061 60 1047 1926 CB\r
+1069 1929 521 (activate a passive process ) 521 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 1926 CB\r
+1590 1929 176 (process5) 176 SB\r
+gr\r
+867 2 176 1926 B\r
+1 F\r
+n\r
+2 2 1044 1926 B\r
+1 F\r
+n\r
+1060 2 1047 1926 B\r
+1 F\r
+n\r
+2 57 1044 1929 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 177 1987 CB\r
+200 1990 128 ( stop) 128 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 1987 CB\r
+1069 1990 591 (the current process passivates) 591 SB\r
+gr\r
+867 2 176 1987 B\r
+1 F\r
+n\r
+2 2 1044 1987 B\r
+1 F\r
+n\r
+1060 2 1047 1987 B\r
+1 F\r
+n\r
+2 56 1044 1990 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 2047 CB\r
+200 2050 190 ( enable ) 190 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 2047 CB\r
+390 2051 262 (hisprocedure) 262 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2047 CB\r
+1069 2050 296 (adds the name ) 296 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2047 CB\r
+1365 2050 314 (hisprocedure to) 314 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2047 CB\r
+1679 2050 357 ( the MASK of the) 357 SB\r
+gr\r
+gs 1061 60 1047 2104 CB\r
+1069 2107 993 (process, enabling other processes to communicate) 993 SB\r
+gr\r
+gs 1061 60 1047 2161 CB\r
+1069 2164 588 (with the process by means of ) 588 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2161 CB\r
+1657 2164 262 (hisprocedure) 262 SB\r
+gr\r
+867 2 176 2047 B\r
+1 F\r
+n\r
+2 2 1044 2047 B\r
+1 F\r
+n\r
+1060 2 1047 2047 B\r
+1 F\r
+n\r
+2 170 1044 2050 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 2221 CB\r
+200 2224 201 ( disable ) 201 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G46 [30.0 0.0 -2.0 0.0 33.0 34.0]\r
+/G46 {\r
+ 35 34 true [1 0 0 -1 2.0 34.0] {<007fffffe0000fc001e000078000e000078000600007800040000f800040000f000040000f000000\r
+000f000000001e000000001e000000001e002000003e006000003c004000003c00c000003c03c000\r
+007fffc0000078078000007801800000f801800000f001800000f001000000f001000001e0000000\r
+01e000000001e000000003c000000003c000000003c000000007c000000007800000000780000000\r
+1fc0000000fff8000000>} imagemask \r
+ }\r
+ 70 /G46 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 2221 CB\r
+401 2225 452 (aProcedure,aFunction) 452 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2221 CB\r
+1069 2224 150 (deletes ) 150 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2221 CB\r
+1219 2224 465 (aProcedure,aFunction ) 465 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2221 CB\r
+1684 2224 324 (from the MASK) 324 SB\r
+gr\r
+867 2 176 2221 B\r
+1 F\r
+n\r
+2 2 1044 2221 B\r
+1 F\r
+n\r
+1060 2 1047 2221 B\r
+1 F\r
+n\r
+2 57 1044 2224 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 2282 CB\r
+200 2285 188 ( accept ) 188 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 177 2282 CB\r
+388 2286 485 (aProc1, aProc2, aFnctn) 485 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2282 CB\r
+1069 2285 297 (process waits \() 297 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2282 CB\r
+1366 2285 194 (inactively) 194 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2282 CB\r
+1560 2285 414 (\) for another process) 414 SB\r
+gr\r
+gs 1061 60 1047 2339 CB\r
+1069 2342 339 (calling a method;) 339 SB\r
+gr\r
+gs 1061 60 1047 2396 CB\r
+1069 2399 994 (accept makes possible rendez-vous of this process) 994 SB\r
+gr\r
+gs 1061 60 1047 2453 CB\r
+1069 2456 769 (and another process calling his method) 769 SB\r
+gr\r
+867 2 176 2282 B\r
+1 F\r
+n\r
+2 2 1044 2282 B\r
+1 F\r
+n\r
+1060 2 1047 2282 B\r
+1 F\r
+n\r
+2 227 1044 2285 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 2513 CB\r
+200 2516 351 ( return disable ) 351 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G31 [25.0 0.0 6.0 0.0 19.0 33.0]\r
+/G31 {\r
+ 13 33 true [1 0 0 -1 -6.0 33.0] {<01800f807f80cf800780078007800780078007800780078007800780078007800780078007800780\r
+078007800780078007800780078007800780078007800fc07ff8>} imagemask \r
+ }\r
+ 49 /G31 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 2513 CB\r
+551 2517 140 (aProc1) 140 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 2513 CB\r
+691 2516 151 ( enable) 151 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 177 2513 CB\r
+842 2517 71 ( aQ) 71 SB\r
+gr\r
+gs 1061 60 1047 2513 CB\r
+1069 2516 1010 (return from a rendez-vous reestablishes the MASK) 1010 SB\r
+gr\r
+gs 1061 60 1047 2570 CB\r
+1069 2573 920 (of the called process; it is posible to modify its) 920 SB\r
+gr\r
+gs 1061 60 1047 2627 CB\r
+1069 2630 942 (MASK disabling some procedures and enabling) 942 SB\r
+gr\r
+gs 1061 60 1047 2684 CB\r
+1069 2687 123 (others) 123 SB\r
+gr\r
+867 2 176 2513 B\r
+1 F\r
+n\r
+2 2 1044 2513 B\r
+1 F\r
+n\r
+1060 2 1047 2513 B\r
+1 F\r
+n\r
+2 227 1044 2516 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 177 2744 CB\r
+200 2747 125 ( call ) 125 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G28 [16.0 0.0 3.0 -10.0 22.0 35.0]\r
+/G28 {\r
+ 19 45 true [1 0 0 -1 -3.0 35.0] {<0000600000c0000180000300000e00001c0000380000700000e00001e00001c0000380000780000f\r
+00000f00001e00001e00003c00003c00007c0000780000780000780000f80000f00000f00000f000\r
+00f00000e00000e00000e00000e00000e00000e00000600000600000600000600000200000300000\r
+300000100000100000180000080000>} imagemask \r
+ }\r
+ 40 /G28 MSTT31c4f8 AddChar\r
+/G29 [17.0 0.0 -6.0 -10.0 13.0 35.0]\r
+/G29 {\r
+ 19 45 true [1 0 0 -1 6.0 35.0] {<0002000003000001000001000001800001800000800000c00000c00000c00000c00000e00000e000\r
+00e00000e00000e00000e00001e00001e00001e00001e00001e00003c00003c00003c00007c00007\r
+80000780000f00000f00001e00001e00003c0000380000700000f00000e00001c000038000070000\r
+0e0000180000300000600000c00000>} imagemask \r
+ }\r
+ 41 /G29 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 177 2744 CB\r
+325 2748 534 (proces5.hisprocedure\(par\)) 534 SB\r
+gr\r
+gs 867 68 177 2859 CB\r
+200 2868 208 ( ) 208 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 258 68 177 2859 CB\r
+408 2862 27 (\255) 27 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 63 177 2981 CB\r
+200 2985 65 ( ) 65 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 63 177 2981 CB\r
+265 2985 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Palatino-Roman /font27 ANSIFont font\r
+gs 867 63 177 2981 CB\r
+278 2984 143 (this is ) 143 SB\r
+gr\r
+32 0 0 40 40 0 0 0 37 /Palatino-Roman /font27 ANSIFont font\r
+gs 867 63 177 2981 CB\r
+421 2993 242 (ALIEN CALL) 242 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2744 CB\r
+1069 2747 579 (the current process demands ) 579 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2744 CB\r
+1648 2747 176 (process5) 176 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2744 CB\r
+1824 2747 217 ( process to) 217 SB\r
+gr\r
+gs 1061 60 1047 2801 CB\r
+1069 2804 165 (execute ) 165 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2801 CB\r
+1234 2804 262 (hisprocedure) 262 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2801 CB\r
+1496 2804 423 ( with the transmitted ) 423 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2801 CB\r
+1919 2804 69 (par) 69 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2858 CB\r
+1069 2861 919 (parameters and waits for the eventual outputs;) 919 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/Gb0 [19.0 0.0 2.0 19.0 17.0 34.0]\r
+/Gb0 {\r
+ 15 15 true [1 0 0 -1 -2.0 34.0] {<07c01ff03838701c600cc006c006c006c006c006600c701c38381ff007c0>} imagemask \r
+ }\r
+ 176 /Gb0 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1047 2915 CB\r
+1069 2919 740 (1\260 this instruction may meet with an ) 740 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1047 2915 CB\r
+1809 2918 136 (accept) 136 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2973 CB\r
+1069 2976 278 (instruction of ) 278 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 2973 CB\r
+1347 2976 189 (process5 ) 189 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 2973 CB\r
+1536 2976 543 (process - in such case there) 543 SB\r
+gr\r
+gs 1061 60 1047 3030 CB\r
+1069 3033 642 (is a rendez-vous of two process,) 642 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G32 [25.0 0.0 1.0 0.0 23.0 33.0]\r
+/G32 {\r
+ 22 33 true [1 0 0 -1 -1.0 33.0] {<00fc0007ff000fff801fffc01e0fe03803e03001f06001f06000f04000f00000f00000e00000e000\r
+01c00001c0000180000380000300000600000e00001c0000180000300000600000c0000180000300\r
+0406000c0c00381ffff83ffff87ffff0fffff0>} imagemask \r
+ }\r
+ 50 /G32 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1047 3087 CB\r
+1069 3091 350 (2\260 otherwise the ) 350 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1047 3087 CB\r
+1419 3090 73 (call) 73 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1047 3087 CB\r
+1492 3091 572 ( tents to interrupt the normal) 572 SB\r
+gr\r
+gs 1061 60 1047 3145 CB\r
+1069 3148 617 (flow of execution of the called ) 617 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1047 3145 CB\r
+1686 3148 176 (process5) 176 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1047 3145 CB\r
+1862 3148 176 ( process.) 176 SB\r
+gr\r
+867 2 176 2744 B\r
+1 F\r
+n\r
+2 2 1044 2744 B\r
+1 F\r
+n\r
+1060 2 1047 2744 B\r
+1 F\r
+n\r
+2 457 1044 2747 B\r
+1 F\r
+n\r
+32 0 0 42 42 0 0 1 38 /MSTT31c51d font\r
+\r
+%%BeginResource: font MSTT31c51d\r
+/G4c [25.0 0.0 0.0 0.0 24.0 28.0]\r
+/G4c {\r
+ 24 28 true [1 0 0 -1 0.0 28.0] {<fff0001f80000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f00000f\r
+00000f00000f00000f00000f00000f00000f00000f00010f00030f00020f00060f000e0f801e1fff\r
+fcfffffc>} imagemask \r
+ }\r
+ 76 /G4c MSTT31c51d AddChar\r
+/G67 [21.0 0.0 1.0 -9.0 21.0 20.0]\r
+/G67 {\r
+ 20 29 true [1 0 0 -1 -1.0 20.0] {<01f800071ff00e0f001c0f803c07803c07803c07803c07803c07801e07001e0e000f1c0007f8000c\r
+00001800001800003c00003fff801fffc00fffe01800e0300060600060600060e000c0f001807c0f\r
+003ffe000ff000>} imagemask \r
+ }\r
+ 103 /G67 MSTT31c51d AddChar\r
+/G27 [8.0 0.0 2.0 17.0 6.0 29.0]\r
+/G27 {\r
+ 4 12 true [1 0 0 -1 -2.0 29.0] {<60f0f0f0f0f0f0f060606060>} imagemask \r
+ }\r
+ 39 /G27 MSTT31c51d AddChar\r
+/G38 [21.0 0.0 2.0 0.0 19.0 28.0]\r
+/G38 {\r
+ 17 28 true [1 0 0 -1 -2.0 28.0] {<07e0001c3800381e00700e00f00f00f00f00f00f00f80f00fc1e007e1c003f38001fb0000fc00007\r
+e00007f8000cfc00187e00383f00701f00f00f80f00f80f00780f00780f00780780700380e001e1c\r
+0007f000>} imagemask \r
+ }\r
+ 56 /G38 MSTT31c51d AddChar\r
+/G32 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G32 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<03e0000ff8001ffc00387e00303f00201f00400f00400f00000f00000f00000f00000e00000e0000\r
+1c00001c0000380000300000600000e00000c0000180000300000600000c00c01801803fff807fff\r
+00ffff00>} imagemask \r
+ }\r
+ 50 /G32 MSTT31c51d AddChar\r
+/G51 [30.0 0.0 1.0 -8.0 29.0 29.0]\r
+/G51 {\r
+ 28 37 true [1 0 0 -1 -1.0 29.0] {<003fc00000fff00003e07c0007801e000f000f001e0007803e0007c03c0003c07c0003e07c0003e0\r
+780001e0f80001f0f80001f0f80001f0f80001f0f80001f0f80001f0f80001f0f80001e0780001e0\r
+7c0003e07c0003c03c0003c01e0007801e0007000f000e0007801c0001e07000007fc000001f8000\r
+000fc0000007e0000001f0000000f80000003e0000000780000000f0>} imagemask \r
+ }\r
+ 81 /G51 MSTT31c51d AddChar\r
+/G63 [18.0 0.0 1.0 -1.0 17.0 20.0]\r
+/G63 {\r
+ 16 21 true [1 0 0 -1 -1.0 20.0] {<01f00ffc1c1e380f300f70076000e000e000e000e000e000f000f00178037c027e0e3ffc1ffc0ff8\r
+03e0>} imagemask \r
+ }\r
+ 99 /G63 MSTT31c51d AddChar\r
+/G6b [21.0 0.0 0.0 0.0 21.0 29.0]\r
+/G6b {\r
+ 21 29 true [1 0 0 -1 0.0 29.0] {<0e00007e0000fe00001e00001e00001e00001e00001e00001e00001e00001e0ff01e07801e06001e\r
+0c001e18001e30001e60001ee0001ff0001ef0001e78001e3c001e1e001e1f001e0f001e07801e03\r
+c03f03e0ffcff8>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c51d AddChar\r
+/G52 [27.0 0.0 0.0 0.0 28.0 28.0]\r
+/G52 {\r
+ 28 28 true [1 0 0 -1 0.0 28.0] {<ffff00001fffe0000f03f0000f00f8000f0078000f007c000f003c000f003c000f003c000f007c00\r
+0f007c000f00f8000f01f0000f07e0000fffc0000fff00000f0780000f07c0000f03c0000f01e000\r
+0f00f0000f00f8000f0078000f003c000f003e000f001f001f800fc0fff007f0>} imagemask \r
+ }\r
+ 82 /G52 MSTT31c51d AddChar\r
+/G43 [28.0 0.0 2.0 -1.0 27.0 29.0]\r
+/G43 {\r
+ 25 30 true [1 0 0 -1 -2.0 29.0] {<003f820000ffe60003e07e0007801e000f000e001e0007003e0003003c0003007c0003007c000100\r
+78000000f8000000f8000000f8000000f8000000f8000000f8000000f8000000f8000000f8000000\r
+7c0000007c0000007c0000003e0000801e0001001f0002000fc00c0003f0380001fff000003f8000\r
+>} imagemask \r
+ }\r
+ 67 /G43 MSTT31c51d AddChar\r
+%%EndResource\r
+\r
+200 3263 554 (Loglan'82 Quick Reference Card) 554 SB\r
+\r
+%%BeginResource: font MSTT31c51d\r
+/G2d [14.0 0.0 2.0 8.0 13.0 12.0]\r
+/G2d {\r
+ 11 4 true [1 0 0 -1 -2.0 12.0] {<ffe0ffe0ffe0ffe0>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c51d AddChar\r
+%%EndResource\r
+\r
+1050 3263 25 (- ) 25 SB\r
+1075 3263 21 (2) 21 SB\r
+1096 3263 25 ( -) 25 SB\r
+\r
+%%BeginResource: font MSTT31c51d\r
+/G4e [30.0 0.0 0.0 0.0 30.0 28.0]\r
+/G4e {\r
+ 30 28 true [1 0 0 -1 0.0 28.0] {<fe000ffc3f0001e00f8000c007c000c007c000c007e000c007f000c006f800c0067c00c0063e00c0\r
+063e00c0061f00c0060f80c00607c0c00603e0c00603e0c00601f0c00600f8c006007cc006003ec0\r
+06001fc006001fc006000fc0060007c0060003c0060001c00f0000c07fe000c0>} imagemask \r
+ }\r
+ 78 /G4e MSTT31c51d AddChar\r
+/G62 [20.0 0.0 -1.0 -1.0 19.0 29.0]\r
+/G62 {\r
+ 20 30 true [1 0 0 -1 1.0 29.0] {<0600003e0000fe00001e00001e00001e00001e00001e00001e00001e1e001e7f801effc01f87c01f\r
+03e01e01e01e01f01e00f01e00f01e00f01e00f01e00f01e00f01e00e01e00e01e01e01e01c01f03\r
+800f870007fe0001f800>} imagemask \r
+ }\r
+ 98 /G62 MSTT31c51d AddChar\r
+/G2c [11.0 0.0 2.0 -7.0 8.0 3.0]\r
+/G2c {\r
+ 6 10 true [1 0 0 -1 -2.0 3.0] {<70f8fc740404081020c0>} imagemask \r
+ }\r
+ 44 /G2c MSTT31c51d AddChar\r
+/G39 [21.0 0.0 2.0 0.0 19.0 28.0]\r
+/G39 {\r
+ 17 28 true [1 0 0 -1 -2.0 28.0] {<03e0000c3800181c00380e00700e00700f00f00700f00780f00780f00780f00780f0078078078078\r
+07803c07801e1f000fef00000f00000e00001e00001c00003c0000780000f00001e0000380000f00\r
+00780000>} imagemask \r
+ }\r
+ 57 /G39 MSTT31c51d AddChar\r
+/G34 [21.0 0.0 1.0 0.0 19.0 28.0]\r
+/G34 {\r
+ 18 28 true [1 0 0 -1 -1.0 28.0] {<001c00003c00003c00007c00007c0000bc00013c00013c00023c00023c00043c00083c00083c0010\r
+3c00103c00203c00403c00403c00ffffc0ffffc0ffffc0003c00003c00003c00003c00003c00003c\r
+00003c00>} imagemask \r
+ }\r
+ 52 /G34 MSTT31c51d AddChar\r
+%%EndResource\r
+\r
+1734 3263 238 (November, 94) 238 SB\r
+255 255 255 fC\r
+1973 3 194 3259 B\r
+1 F\r
+n\r
+0 0 0 fC\r
+1973 2 194 3256 B\r
+1 F\r
+n\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Helvetica-BoldOblique\r
+%%+ font MSTT31c4a3\r
+%%+ font MSTT31c4eb\r
+%%+ font MSTT31c4f8\r
+%%+ font MSTT31c51d\r
+%%+ font MSTT31c52a\r
+%%+ font Palatino-Roman\r
+%%+ font Symbol\r
+%%Page: 3 3\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+0 0 0 fC\r
+gs 868 57 225 281 CB\r
+248 281 480 ( Exception handling) 480 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 338 CB\r
+248 341 140 ( raise) 140 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 338 CB\r
+388 342 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 61 225 338 CB\r
+401 342 153 (Asignal) 153 SB\r
+gr\r
+gs 1061 60 1095 338 CB\r
+1117 341 153 (Asignal) 153 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 338 CB\r
+1270 341 761 ( is raised. This lances the research of a) 761 SB\r
+gr\r
+gs 1061 61 1095 395 CB\r
+1117 399 160 (module ) 160 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 395 CB\r
+1277 398 189 (handling) 189 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G4c [30.0 0.0 0.0 0.0 29.0 33.0]\r
+/G4c {\r
+ 29 33 true [1 0 0 -1 0.0 33.0] {<fffe00000ff0000007c0000007c0000007c0000007c0000007c0000007c0000007c0000007c00000\r
+07c0000007c0000007c0000007c0000007c0000007c0000007c0000007c0000007c0000007c00000\r
+07c0000007c0000007c0000007c0000007c0000807c0001807c0001007c0003007c0007007c000e0\r
+07e003e01fffffe0ffffffc0>} imagemask \r
+ }\r
+ 76 /G4c MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1095 395 CB\r
+1466 399 647 ( the signal along the chain of DL) 647 SB\r
+gr\r
+gs 1061 60 1095 453 CB\r
+1117 456 871 (links i.e. along dynamic fathers of instances.) 871 SB\r
+gr\r
+0 0 0 fC\r
+/fm 256 def\r
+867 2 224 338 B\r
+1 F\r
+n\r
+2 2 1092 338 B\r
+1 F\r
+n\r
+2 2 1095 338 B\r
+1 F\r
+n\r
+1057 2 1098 338 B\r
+1 F\r
+n\r
+2 171 1092 341 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 513 CB\r
+248 516 176 ( return) 176 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 49 68 1095 513 CB\r
+1118 516 26 (\374) 26 SB\r
+gr\r
+gs 49 68 1095 513 CB\r
+1117 516 26 (\374) 26 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 68 1095 513 CB\r
+1144 521 299 ( ) 299 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 68 1095 513 CB\r
+1443 522 606 (returns to after raise statement) 606 SB\r
+gr\r
+867 2 224 513 B\r
+1 F\r
+n\r
+2 2 1092 513 B\r
+1 F\r
+n\r
+1060 2 1095 513 B\r
+1 F\r
+n\r
+2 64 1092 516 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 581 CB\r
+248 584 145 ( wind) 145 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 49 68 1095 581 CB\r
+1118 584 26 (\375) 26 SB\r
+gr\r
+gs 49 68 1095 581 CB\r
+1117 584 26 (\375) 26 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 68 1095 581 CB\r
+1144 589 39 ( ) 39 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G33 [25.0 0.0 2.0 0.0 20.0 33.0]\r
+/G33 {\r
+ 18 33 true [1 0 0 -1 -2.0 33.0] {<03f0000ffc001ffe00383f00601f80400f80800780000780000780000700000600000c0000080000\r
+1000003c0000fe0003ff00007f80001f80000fc00007c00007c00003c00003c00003c00003800003\r
+80000780000700700e00fc1c00fff0003fc000>} imagemask \r
+ }\r
+ 51 /G33 MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 1061 68 1095 581 CB\r
+1183 590 902 (3 forms of terminating an exception handling) 902 SB\r
+gr\r
+867 2 224 581 B\r
+1 F\r
+n\r
+2 2 1092 581 B\r
+1 F\r
+n\r
+1060 2 1095 581 B\r
+1 F\r
+n\r
+2 64 1092 584 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 649 CB\r
+248 652 246 ( terminate) 246 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 49 68 1095 649 CB\r
+1118 652 26 (\376) 26 SB\r
+gr\r
+gs 49 68 1095 649 CB\r
+1117 652 26 (\376) 26 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 68 1095 649 CB\r
+1144 657 78 ( ) 78 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 68 1095 649 CB\r
+1222 658 871 (destructs \(lastwill\) several instances of units) 871 SB\r
+gr\r
+867 2 224 649 B\r
+1 F\r
+n\r
+2 2 1092 649 B\r
+1 F\r
+n\r
+1060 2 1095 649 B\r
+1 F\r
+n\r
+2 64 1092 652 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 60 225 774 CB\r
+248 777 563 (Composed instructions) 563 SB\r
+gr\r
+867 2 224 717 B\r
+1 F\r
+n\r
+2 2 1092 717 B\r
+1 F\r
+n\r
+2 2 1095 717 B\r
+1 F\r
+n\r
+1057 2 1098 717 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 834 CB\r
+248 842 82 ( if ) 82 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 126 68 225 834 CB\r
+330 837 21 (g) 21 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 834 CB\r
+351 842 121 ( then ) 121 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 68 225 834 CB\r
+472 843 17 (I) 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 834 CB\r
+489 842 102 ( else ) 102 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G4a [19.0 0.0 1.0 -1.0 19.0 33.0]\r
+/G4a {\r
+ 18 34 true [1 0 0 -1 -1.0 33.0] {<1fffc003fe0000f80000f80000f80000f80000f80000f80000f80000f80000f80000f80000f80000\r
+f80000f80000f80000f80000f80000f80000f80000f80000f80000f80000f80000f80000f80000f8\r
+0000f00070f000f0f000f8e000f9c0007f80003e0000>} imagemask \r
+ }\r
+ 74 /G4a MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 68 225 834 CB\r
+591 843 19 (J) 19 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 834 CB\r
+610 842 43 ( fi) 43 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 43 68 1095 834 CB\r
+1117 837 21 (g) 21 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 68 1095 834 CB\r
+1138 843 480 ( is a Boolean expression) 480 SB\r
+gr\r
+gs 1061 60 1095 899 CB\r
+1117 902 659 (I, J are sequences of instructions ) 659 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c54f\r
+/MSTT31c54f [42.0 0 0 0 0 0] 47 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c54f GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 38 /MSTT31c54f font\r
+\r
+%%BeginResource: font MSTT31c54f\r
+/G7b [17.0 0.0 3.0 -9.0 20.0 29.0]\r
+/G7b {\r
+ 17 38 true [1 0 0 -1 -3.0 29.0] {<000180000e0000180000300000600000e00001c00001c00001c00001c00003c00003c00003800003\r
+80000300000600000c0000300000c000006000003800001800001c00001c00003c00003c00003c00\r
+00780000780000f00000f00000e00000e00000e000006000007000003800000c0000>} imagemask \r
+ }\r
+ 123 /G7b MSTT31c54f AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 899 CB\r
+1776 909 17 ({) 17 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c55c\r
+/MSTT31c55c [42.0 0 0 0 0 0] 95 -115 [-42.0 -42.0 42.0 42.0] [1 42 div 0 0 1 42 div 0 0] /MSTT31c55c GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 42 42 0 0 1 38 /MSTT31c55c font\r
+\r
+%%BeginResource: font MSTT31c55c\r
+/G65 [19.0 0.0 1.0 0.0 19.0 19.0]\r
+/G65 {\r
+ 18 19 true [1 0 0 -1 -1.0 19.0] {<001f8000e7c00187c00787c00f0fc01e0f801e1f003c1e007c3c007cf000ff8000f80000f80000f8\r
+0000f80300fc0e007ffc007ff0001fc000>} imagemask \r
+ }\r
+ 101 /G65 MSTT31c55c AddChar\r
+/G6c [12.0 0.0 1.0 0.0 13.0 29.0]\r
+/G6c {\r
+ 12 29 true [1 0 0 -1 -1.0 29.0] {<00f00ff003f003e003e003e007e007c007c007c00f800f800f801f801f001f003f003e003e003e00\r
+7c007c007c00fc00f840f880fb00fe007800>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c55c AddChar\r
+/G73 [16.0 0.0 0.0 0.0 16.0 19.0]\r
+/G73 {\r
+ 16 19 true [1 0 0 -1 0.0 19.0] {<03fb078f0f071f061f821f821fc00fe00ff007f803f801fc40fc40fc607ce078f078f8f08fc0>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c55c AddChar\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c55c AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 899 CB\r
+1793 909 77 (else ) 77 SB\r
+gr\r
+32 0 0 42 42 0 0 1 38 /MSTT31c54f font\r
+\r
+%%BeginResource: font MSTT31c54f\r
+/G4a [19.0 0.0 -2.0 0.0 22.0 28.0]\r
+/G4a {\r
+ 24 28 true [1 0 0 -1 2.0 28.0] {<0007ff0000f80000f00000f00000e00000e00000e00001c00001c00001c00001c000038000038000\r
+0380000700000700000700000700000e00000e00000e00601c00f01c00f03800f07000e0e00061c0\r
+003f0000>} imagemask \r
+ }\r
+ 74 /G4a MSTT31c54f AddChar\r
+/G20 [11.0 0.0 0.0 0.0 0.0 0.0]\r
+/G20 {\r
+} \r
+ 32 /G20 MSTT31c54f AddChar\r
+/G69 [12.0 0.0 1.0 0.0 10.0 26.0]\r
+/G69 {\r
+ 9 26 true [1 0 0 -1 -1.0 26.0] {<038003800380000000000000000007003f0007000e000e000e000e001c001c001c00380038003800\r
+7800700072007400f8007000>} imagemask \r
+ }\r
+ 105 /G69 MSTT31c54f AddChar\r
+/G73 [16.0 0.0 0.0 0.0 16.0 19.0]\r
+/G73 {\r
+ 16 19 true [1 0 0 -1 0.0 19.0] {<01f1070f06070e020e020f020f8007c003e001e001f000f8407840384038e038e030f0608f80>} imagemask \r
+ }\r
+ 115 /G73 MSTT31c54f AddChar\r
+/G6f [21.0 0.0 1.0 0.0 19.0 19.0]\r
+/G6f {\r
+ 18 19 true [1 0 0 -1 -1.0 19.0] {<007c000187000703800e01801c01c03c01c03801c07803c07003c0f003c0f00380f00780e00700e0\r
+0f00e00e00601c007038003860000f8000>} imagemask \r
+ }\r
+ 111 /G6f MSTT31c54f AddChar\r
+/G70 [21.0 0.0 -4.0 -9.0 20.0 19.0]\r
+/G70 {\r
+ 24 28 true [1 0 0 -1 4.0 19.0] {<00387c01f9fe007b1e00760f007c0700780700700700f00700e00e00e00e01c00e01c01c01c01c01\r
+c0380380300380600380c007c38007fe000700000700000e00000e00000e00001c00001c00003e00\r
+00ff8000>} imagemask \r
+ }\r
+ 112 /G70 MSTT31c54f AddChar\r
+/G74 [12.0 0.0 1.0 0.0 13.0 25.0]\r
+/G74 {\r
+ 12 25 true [1 0 0 -1 -1.0 25.0] {<004000800180018003800f003ff00f000f000e000e001e001c001c001c003c003800380038007800\r
+700073007200fc007000>} imagemask \r
+ }\r
+ 116 /G74 MSTT31c54f AddChar\r
+/G6e [21.0 0.0 0.0 0.0 19.0 19.0]\r
+/G6e {\r
+ 19 19 true [1 0 0 -1 0.0 19.0] {<0703c03f0fc00719e00e31e00e61c00e41c00c81c01d03c01e03801e03803c07803c070038070038\r
+0f00700e00700e40700e80e01f00e00e00>} imagemask \r
+ }\r
+ 110 /G6e MSTT31c54f AddChar\r
+/G61 [21.0 0.0 1.0 0.0 20.0 19.0]\r
+/G61 {\r
+ 19 19 true [1 0 0 -1 -1.0 19.0] {<003c2000eee00382e00703c00e01c01c03c01c03c0380380380380700380700700f00700e00f00e0\r
+1700e03e00f06e40f08e807f0f003c0e00>} imagemask \r
+ }\r
+ 97 /G61 MSTT31c54f AddChar\r
+/G6c [12.0 0.0 1.0 0.0 12.0 29.0]\r
+/G6c {\r
+ 11 29 true [1 0 0 -1 -1.0 29.0] {<00e007e000e001c001c001c003c00380038003800700070007000e000e000e001e001c001c001c00\r
+3800380038007800710072007400f8007000>} imagemask \r
+ }\r
+ 108 /G6c MSTT31c54f AddChar\r
+/G7d [17.0 0.0 -3.0 -9.0 14.0 29.0]\r
+/G7d {\r
+ 17 38 true [1 0 0 -1 3.0 29.0] {<001800000e00000700000300000380000380000380000780000780000f00000f00001e00001e0000\r
+1e00001c00001c00000c00000e0000030000008000070000180000300000600000e00000e00001e0\r
+0001e00001c00001c00001c00001c0000380000300000600000c0000380000c00000>} imagemask \r
+ }\r
+ 125 /G7d MSTT31c54f AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 899 CB\r
+1870 909 227 (J is optional}) 227 SB\r
+gr\r
+867 2 224 834 B\r
+1 F\r
+n\r
+2 2 1092 834 B\r
+1 F\r
+n\r
+2 2 1095 834 B\r
+1 F\r
+n\r
+1057 2 1098 834 B\r
+1 F\r
+n\r
+2 121 1092 837 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 959 CB\r
+248 962 118 ( do ) 118 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 959 CB\r
+366 963 17 (I) 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 959 CB\r
+383 962 79 ( od) 79 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 959 CB\r
+1117 963 885 (looping instruction; it is suggested to put an ) 885 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 959 CB\r
+2002 962 77 (exit) 77 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 1017 CB\r
+1117 1020 927 (instruction among the instructions I, see below) 927 SB\r
+gr\r
+867 2 224 959 B\r
+1 F\r
+n\r
+2 2 1092 959 B\r
+1 F\r
+n\r
+1060 2 1095 959 B\r
+1 F\r
+n\r
+2 114 1092 962 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 1077 CB\r
+248 1085 165 ( while ) 165 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 209 68 225 1077 CB\r
+413 1080 21 (g) 21 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 1077 CB\r
+434 1085 79 ( do ) 79 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 68 225 1077 CB\r
+513 1086 17 (I) 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 68 225 1077 CB\r
+530 1085 66 ( od) 66 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 43 68 1095 1077 CB\r
+1117 1080 21 (g) 21 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 68 1095 1077 CB\r
+1138 1086 480 ( is a Boolean expression) 480 SB\r
+gr\r
+gs 1061 60 1095 1142 CB\r
+1117 1145 543 (I a sequence of instructions) 543 SB\r
+gr\r
+gs 1061 60 1095 1199 CB\r
+1117 1202 257 (equivalent to) 257 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 60 1095 1256 CB\r
+1117 1259 53 (do) 53 SB\r
+gr\r
+gs 1061 68 1095 1313 CB\r
+1117 1321 82 ( if ) 82 SB\r
+gr\r
+32 0 0 50 50 0 0 0 51 /Symbol font\r
+gs 125 68 1095 1313 CB\r
+1199 1316 21 (g) 21 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 68 1095 1313 CB\r
+1220 1321 121 ( then ) 121 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 68 1095 1313 CB\r
+1341 1322 17 (I) 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 68 1095 1313 CB\r
+1358 1321 222 ( else exit fi) 222 SB\r
+gr\r
+gs 1061 60 1095 1378 CB\r
+1117 1381 53 (od) 53 SB\r
+gr\r
+867 2 224 1077 B\r
+1 F\r
+n\r
+2 2 1092 1077 B\r
+1 F\r
+n\r
+1060 2 1095 1077 B\r
+1 F\r
+n\r
+2 357 1092 1080 B\r
+1 F\r
+n\r
+gs 867 61 225 1438 CB\r
+248 1441 114 ( for ) 114 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1438 CB\r
+362 1442 54 (i:=) 54 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1438 CB\r
+416 1441 13 ( ) 13 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1438 CB\r
+429 1442 48 (A ) 48 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1438 CB\r
+477 1441 55 (to ) 55 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1438 CB\r
+532 1442 33 (B) 33 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1438 CB\r
+565 1441 79 ( do ) 79 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1438 CB\r
+644 1442 17 (I) 17 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1438 CB\r
+661 1441 66 ( od) 66 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 1438 CB\r
+1117 1441 855 (i integer variable, A, B integer expressions,) 855 SB\r
+gr\r
+gs 1061 60 1095 1495 CB\r
+1117 1498 543 (I a sequence of instructions) 543 SB\r
+gr\r
+867 2 224 1438 B\r
+1 F\r
+n\r
+2 2 1092 1438 B\r
+1 F\r
+n\r
+1060 2 1095 1438 B\r
+1 F\r
+n\r
+2 113 1092 1441 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1555 CB\r
+248 1558 140 ( case ) 140 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1555 CB\r
+388 1559 22 (c) 22 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1613 CB\r
+248 1616 205 ( when ) 205 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1613 CB\r
+453 1617 104 (c1: I;) 104 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 1671 CB\r
+248 1674 308 ( otherwise ) 308 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 1671 CB\r
+556 1675 19 (J) 19 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 60 225 1729 CB\r
+248 1732 127 ( esac) 127 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 1555 CB\r
+1117 1558 309 (case instruction) 309 SB\r
+gr\r
+gs 1061 60 1095 1612 CB\r
+1117 1615 646 (I, J are sequences of instructions) 646 SB\r
+gr\r
+gs 1061 60 1095 1669 CB\r
+1117 1672 680 (c is an expression, c1 is a constant) 680 SB\r
+gr\r
+867 2 224 1555 B\r
+1 F\r
+n\r
+2 2 1092 1555 B\r
+1 F\r
+n\r
+1060 2 1095 1555 B\r
+1 F\r
+n\r
+2 230 1092 1558 B\r
+1 F\r
+n\r
+32 0 0 63 63 0 0 0 58 /Helvetica-BoldOblique /font14 ANSIFont font\r
+gs 868 75 225 1861 CB\r
+248 1864 374 (Expressions) 374 SB\r
+gr\r
+867 2 224 1789 B\r
+1 F\r
+n\r
+2 2 1092 1789 B\r
+1 F\r
+n\r
+2 2 1095 1789 B\r
+1 F\r
+n\r
+1057 2 1098 1789 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 867 60 225 1936 CB\r
+248 1939 501 (Arithmetic expressions) 501 SB\r
+gr\r
+867 2 224 1936 B\r
+1 F\r
+n\r
+2 2 1092 1936 B\r
+1 F\r
+n\r
+2 2 1095 1936 B\r
+1 F\r
+n\r
+1057 2 1098 1936 B\r
+1 F\r
+n\r
+2 56 1092 1939 B\r
+1 F\r
+n\r
+gs 867 60 225 1996 CB\r
+248 1999 464 (Boolean expressions) 464 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1996 CB\r
+1117 2000 153 (remark ) 153 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1996 CB\r
+1270 1999 42 (in) 42 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1996 CB\r
+1312 2000 97 ( and ) 97 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1996 CB\r
+1409 1999 33 (is) 33 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1996 CB\r
+1442 2000 428 ( object relations, e.g. ) 428 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1996 CB\r
+1870 1999 30 (if) 30 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1996 CB\r
+1900 2000 37 ( x) 37 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 1996 CB\r
+1937 1999 55 ( in) 55 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 1996 CB\r
+1992 2000 124 ( Clas2) 124 SB\r
+gr\r
+867 2 224 1996 B\r
+1 F\r
+n\r
+2 2 1092 1996 B\r
+1 F\r
+n\r
+1060 2 1095 1996 B\r
+1 F\r
+n\r
+2 57 1092 1999 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 867 60 225 2057 CB\r
+248 2060 425 (Object expressions) 425 SB\r
+gr\r
+867 2 224 2057 B\r
+1 F\r
+n\r
+2 2 1092 2057 B\r
+1 F\r
+n\r
+1060 2 1095 2057 B\r
+1 F\r
+n\r
+2 56 1092 2060 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 2117 CB\r
+248 2120 125 ( new) 125 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+\r
+%%BeginResource: font MSTT31c4a3\r
+/G5f [25.0 0.0 0.0 -11.0 26.0 -9.0]\r
+/G5f {\r
+ 26 2 true [1 0 0 -1 0.0 -9.0] {<ffffffc0ffffffc0>} imagemask \r
+ }\r
+ 95 /G5f MSTT31c4a3 AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 2117 CB\r
+373 2121 363 ( T\(actual_params\)) 363 SB\r
+gr\r
+gs 1061 60 1095 2117 CB\r
+1117 2120 966 (create new object of class \(coroutine, process\) T) 966 SB\r
+gr\r
+gs 1061 60 1095 2174 CB\r
+1117 2177 683 (passing the actual_params list to it) 683 SB\r
+gr\r
+867 2 224 2117 B\r
+1 F\r
+n\r
+2 2 1092 2117 B\r
+1 F\r
+n\r
+1060 2 1095 2117 B\r
+1 F\r
+n\r
+2 113 1092 2120 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 2234 CB\r
+248 2237 130 ( this ) 130 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2234 CB\r
+378 2238 31 (T) 31 SB\r
+gr\r
+gs 1061 60 1095 2234 CB\r
+1117 2237 969 (returns as a value the object of type T containing) 969 SB\r
+gr\r
+gs 1061 60 1095 2291 CB\r
+1117 2294 293 (this expression) 293 SB\r
+gr\r
+867 2 224 2234 B\r
+1 F\r
+n\r
+2 2 1092 2234 B\r
+1 F\r
+n\r
+1060 2 1095 2234 B\r
+1 F\r
+n\r
+2 113 1092 2237 B\r
+1 F\r
+n\r
+gs 867 61 225 2351 CB\r
+248 2355 83 ( E ) 83 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+\r
+%%BeginResource: font MSTT31c4eb\r
+/G71 [28.0 0.0 2.0 -11.0 26.0 23.0]\r
+/G71 {\r
+ 24 34 true [1 0 0 -1 -2.0 23.0] {<00fc0c03ff3c0fc7fc1f83fc1f01fc3f01fc7f01fc7e01fc7e01fcfe01fcfe01fcfe01fcfe01fcfe\r
+01fcfe01fcfe01fcfe01fc7f01fc7f01fc3f03fc3f87fc1ffdfc0ff9fc03e1fc0001fc0001fc0001\r
+fc0001fc0001fc0001fc0001fc0001fc0003fe0007ff>} imagemask \r
+ }\r
+ 113 /G71 MSTT31c4eb AddChar\r
+%%EndResource\r
+\r
+gs 867 61 225 2351 CB\r
+331 2354 94 (qua ) 94 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2351 CB\r
+425 2355 35 (A) 35 SB\r
+gr\r
+gs 1061 60 1095 2351 CB\r
+1117 2354 708 (qualifies the value of E as of type A) 708 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G52 [31.0 0.0 -2.0 0.0 30.0 34.0]\r
+/G52 {\r
+ 32 34 true [1 0 0 -1 2.0 34.0] {<007fffc0001fc0f8000f803c0007803e0007801e000f001f000f001f000f001f000f001f001e001f\r
+001e001e001e003e003e003c003c0078003c01f0003c07e0007fff0000781e0000781e0000f01e00\r
+00f00f0000f00f0000f00f0001e0078001e0078001e0078003c003c003c003c003c003e007c001e0\r
+078001e00fc001f01fc000fcfff800ff>} imagemask \r
+ }\r
+ 82 /G52 MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 61 1095 2408 CB\r
+1117 2412 260 (Raises error ) 260 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 2408 CB\r
+1377 2412 162 (if not E ) 162 SB\r
+gr\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 1061 61 1095 2408 CB\r
+1539 2411 42 (in) 42 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 61 1095 2408 CB\r
+1581 2412 48 ( A) 48 SB\r
+gr\r
+867 2 224 2351 B\r
+1 F\r
+n\r
+2 2 1092 2351 B\r
+1 F\r
+n\r
+1060 2 1095 2351 B\r
+1 F\r
+n\r
+2 114 1092 2354 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 46 /MSTT31c4eb font\r
+gs 867 61 225 2469 CB\r
+248 2472 139 ( copy) 139 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 61 225 2469 CB\r
+387 2473 65 (\(E\)) 65 SB\r
+gr\r
+gs 1061 60 1095 2469 CB\r
+1117 2472 984 (returns a copy of value of the object expression E) 984 SB\r
+gr\r
+867 2 224 2469 B\r
+1 F\r
+n\r
+2 2 1092 2469 B\r
+1 F\r
+n\r
+1060 2 1095 2469 B\r
+1 F\r
+n\r
+2 57 1092 2472 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 867 60 225 2530 CB\r
+248 2533 501 (Character expressions) 501 SB\r
+gr\r
+867 2 224 2530 B\r
+1 F\r
+n\r
+2 2 1092 2530 B\r
+1 F\r
+n\r
+1060 2 1095 2530 B\r
+1 F\r
+n\r
+2 56 1092 2533 B\r
+1 F\r
+n\r
+gs 867 60 225 2590 CB\r
+248 2593 410 (String expressions) 410 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 2590 CB\r
+1117 2593 425 (only constant strings!) 425 SB\r
+gr\r
+867 2 224 2590 B\r
+1 F\r
+n\r
+2 2 1092 2590 B\r
+1 F\r
+n\r
+1060 2 1095 2590 B\r
+1 F\r
+n\r
+2 56 1092 2593 B\r
+1 F\r
+n\r
+32 0 0 58 58 0 0 0 52 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 866 72 225 2715 CB\r
+248 2722 552 (Inheritance & Nesting) 552 SB\r
+gr\r
+32 0 0 63 63 0 0 0 52 /ZapfDingbats font\r
+gs 866 72 225 2715 CB\r
+800 2722 36 ( ) 36 SB\r
+gr\r
+\r
+%%BeginResource: font MSTT31c574\r
+/MSTT31c574 [63.0 0 0 0 0 0] 47 -90 [-63.0 -63.0 63.0 63.0] [1 63 div 0 0 1 63 div 0 0] /MSTT31c574 GreNewFont\r
+%%EndResource\r
+\r
+32 0 0 63 63 0 0 1 56 /MSTT31c574 font\r
+\r
+%%BeginResource: font MSTT31c574\r
+/G5b [56.0 0.0 5.0 0.0 51.0 46.0]\r
+/G5b {\r
+ 46 46 true [1 0 0 -1 -5.0 46.0] {<00003ff000000001fffe0000000fc01fc000001c0001e00000700000780000e000003c0001800000\r
+0e000300000007000600000003800c00000001c00c00000000c01800000000e0307e0000007033ff\r
+c000003027ffe00000306ffff00000187ffff80000185ffff8000018dffffc00000cffc3fc00000c\r
+ffc3fc00f00cff81fe01f80cff81fe01f80cff81fe01f80cffc3fe01f80cffc3fe00f00cfffffe00\r
+001cffffff00001c7fffff0000187fffff8000387fffffc000783fffffe000f03ffffff001f03fff\r
+fffc07f01fffffffffe00fffffffffc00fffffffffc007ffffffff8003ffffffff0001fffffffe00\r
+00fffffffc00007ffffff800001fffffe000000fffffc0000001fffe000000003ff00000>} imagemask \r
+ }\r
+ 91 /G5b MSTT31c574 AddChar\r
+%%EndResource\r
+\r
+gs 667 72 225 2715 CB\r
+836 2718 56 ([) 56 SB\r
+gr\r
+32 0 0 63 63 0 0 0 56 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 1061 73 1092 2707 CB\r
+1114 2710 35 (2) 35 SB\r
+gr\r
+32 0 0 50 50 0 0 0 46 /Helvetica-Oblique /font19 ANSIFont font\r
+gs 1061 73 1092 2707 CB\r
+1149 2720 963 ( fundamental methods of unit's composition) 963 SB\r
+gr\r
+866 2 224 2650 B\r
+1 F\r
+n\r
+2 2 1091 2650 B\r
+1 F\r
+n\r
+2 2 1092 2650 B\r
+1 F\r
+n\r
+1057 2 1095 2650 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G4d [42.0 0.0 -4.0 0.0 47.0 34.0]\r
+/G4d {\r
+ 51 34 true [1 0 0 -1 4.0 34.0] {<007f8000000fe0000f8000000f0000078000001e000007c000003c000007c000007c000007c00000\r
+fc00000fc00000f800000fc00001f800000fc0000378000019e00006f8000019e0000cf0000019e0\r
+000cf0000039e00018f0000031e00031e0000031e00061e0000031e000c1e0000060f000c3c00000\r
+60f00183c0000060f00303c00000c0f00607c00000c0f00c07800000c0f01c078000018078180f80\r
+00018078300f0000018078600f0000018078c00f0000030079801e0000030079801e000003007b00\r
+1e000006003e003e000006003c003c00000e0038007c00001f003800fe0000ffe03007ffc000>} imagemask \r
+ }\r
+ 77 /G4d MSTT31c4f8 AddChar\r
+/G2d [17.0 0.0 1.0 9.0 16.0 13.0]\r
+/G2d {\r
+ 15 4 true [1 0 0 -1 -1.0 13.0] {<7ffe7ffefffcfffc>} imagemask \r
+ }\r
+ 45 /G2d MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 867 60 225 2803 CB\r
+248 2806 460 (Multi-level inheritance) 460 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 60 225 2803 CB\r
+708 2806 333 ( permits to make) 333 SB\r
+gr\r
+gs 867 60 225 2860 CB\r
+248 2863 656 (extensions of classes, coroutines,) 656 SB\r
+gr\r
+gs 867 60 225 2917 CB\r
+248 2920 751 (processes defined on different level of) 751 SB\r
+gr\r
+gs 867 60 225 2974 CB\r
+248 2977 580 (the nesting structure of units.) 580 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+\r
+%%BeginResource: font MSTT31c4f8\r
+/G6b [22.0 0.0 0.0 0.0 24.0 35.0]\r
+/G6b {\r
+ 24 35 true [1 0 0 -1 0.0 35.0] {<001e0003fc00007c00007c0000780000780000780000f00000f00000f00001f00001e00001e00001\r
+e3ff03c0fc03c0f003c0c0078180078700078e000f1c000f3c000f7c001ffc001fbc001f1e001e1e\r
+003c1e003c1e083c1f10780f10780f20780fc0f80f80f00700>} imagemask \r
+ }\r
+ 107 /G6b MSTT31c4f8 AddChar\r
+%%EndResource\r
+\r
+gs 1061 60 1095 2803 CB\r
+1117 2806 452 (Multi-kind inheritance) 452 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 2803 CB\r
+1569 2806 437 ( permits to inherit in a) 437 SB\r
+gr\r
+gs 1061 60 1095 2860 CB\r
+1117 2863 916 (block, procedure, function, class, coroutine or) 916 SB\r
+gr\r
+gs 1061 60 1095 2917 CB\r
+1117 2920 163 (process.) 163 SB\r
+gr\r
+866 2 224 2803 B\r
+1 F\r
+n\r
+2 2 1091 2803 B\r
+1 F\r
+n\r
+2 2 1092 2803 B\r
+1 F\r
+n\r
+1057 2 1095 2803 B\r
+1 F\r
+n\r
+2 2 2153 2803 B\r
+1 F\r
+n\r
+2 2 2154 2803 B\r
+1 F\r
+n\r
+2 227 1092 2806 B\r
+1 F\r
+n\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 867 60 225 3034 CB\r
+248 3037 410 (Multiple inheritance) 410 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 867 60 225 3034 CB\r
+658 3037 385 ( is doable by means) 385 SB\r
+gr\r
+gs 867 60 225 3091 CB\r
+248 3094 707 (of multi-level inheritance and other) 707 SB\r
+gr\r
+gs 867 60 225 3148 CB\r
+248 3151 436 (ingredients of Loglan.) 436 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1095 3034 CB\r
+1117 3037 339 (Generic modules) 339 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 3034 CB\r
+1456 3037 612 ( are doable in various ways: by) 612 SB\r
+gr\r
+gs 1061 60 1095 3091 CB\r
+1117 3094 976 (formal types, by multi-level inheritance combined) 976 SB\r
+gr\r
+gs 1061 60 1095 3148 CB\r
+1117 3151 686 (with nesting, to say nothing about ) 686 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4f8 font\r
+gs 1061 60 1095 3148 CB\r
+1803 3151 133 (virtual) 133 SB\r
+gr\r
+32 0 0 50 50 0 0 1 45 /MSTT31c4a3 font\r
+gs 1061 60 1095 3148 CB\r
+1936 3151 32 (s.) 32 SB\r
+gr\r
+867 2 224 3034 B\r
+1 F\r
+n\r
+2 2 1092 3034 B\r
+1 F\r
+n\r
+1060 2 1095 3034 B\r
+1 F\r
+n\r
+867 2 224 3208 B\r
+1 F\r
+n\r
+2 170 1092 3037 B\r
+1 F\r
+n\r
+2 2 1092 3208 B\r
+1 F\r
+n\r
+1060 2 1095 3208 B\r
+1 F\r
+n\r
+32 0 0 42 42 0 0 1 38 /MSTT31c51d font\r
+248 3263 554 (Loglan'82 Quick Reference Card) 554 SB\r
+1098 3263 25 (- ) 25 SB\r
+\r
+%%BeginResource: font MSTT31c51d\r
+/G33 [21.0 0.0 2.0 0.0 17.0 28.0]\r
+/G33 {\r
+ 15 28 true [1 0 0 -1 -2.0 28.0] {<07c01ff03ff8707c403c801c001c001c001800300020004001f007f800fc007c003e001e001e000e\r
+000e000e000c000c0018e030f8607f80>} imagemask \r
+ }\r
+ 51 /G33 MSTT31c51d AddChar\r
+%%EndResource\r
+\r
+1123 3263 21 (3) 21 SB\r
+1144 3263 25 ( -) 25 SB\r
+1782 3263 238 (November, 94) 238 SB\r
+255 255 255 fC\r
+1973 3 242 3259 B\r
+1 F\r
+n\r
+0 0 0 fC\r
+1973 2 242 3256 B\r
+1 F\r
+n\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font Helvetica-BoldOblique\r
+%%+ font Helvetica-Oblique\r
+%%+ font MSTT31c4a3\r
+%%+ font MSTT31c4eb\r
+%%+ font MSTT31c4f8\r
+%%+ font MSTT31c51d\r
+%%+ font MSTT31c54f\r
+%%+ font MSTT31c55c\r
+%%+ font MSTT31c574\r
+%%+ font Symbol\r
+%%+ font ZapfDingbats\r
+%%Page: 4 4\r
+%%PageResources: (atend)\r
+SS\r
+0 0 12 16 799 1169 300 SM\r
+32 0 0 42 42 0 0 1 38 /MSTT31c51d font\r
+0 0 0 fC\r
+200 3263 554 (Loglan'82 Quick Reference Card) 554 SB\r
+1050 3263 25 (- ) 25 SB\r
+1075 3263 21 (4) 21 SB\r
+1096 3263 25 ( -) 25 SB\r
+1734 3263 238 (November, 94) 238 SB\r
+255 255 255 fC\r
+/fm 256 def\r
+1973 3 194 3259 B\r
+1 F\r
+n\r
+0 0 0 fC\r
+1973 2 194 3256 B\r
+1 F\r
+n\r
+1 #C\r
+statusdict begin /manualfeed false store end\r
+EJ RS\r
+%%PageTrailer\r
+%%PageResources: font MSTT31c51d\r
+%%Trailer\r
+SVDoc restore\r
+end\r
+%%Pages: 4\r
+% TrueType font name key:\r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT310000 = \r
+% MSTT31c4a3 = 2027DTimes New RomanF00000032000001900000\r
+% MSTT31c4b0 = 2027DTimes New RomanF0000003f000001900000\r
+% MSTT31c4bd = 2027DTimes New RomanF0000004b000002bc0000\r
+% MSTT31c4ca = 2027DArialF00000032000001900001\r
+% MSTT31c4d5 = 2027DArialF00000032000001900000\r
+% MSTT31c4e0 = 2027DArialF0000002e000001900001\r
+% MSTT31c4eb = 2027DTimes New RomanF00000032000002bc0000\r
+% MSTT31c4f8 = 2027DTimes New RomanF00000032000001900001\r
+% MSTT31c505 = 2027DArialF0000003f000002bc0001\r
+% MSTT31c510 = 2027DTimes New RomanF00000032000002bc0001\r
+% MSTT31c51d = 2027DTimes New RomanF0000002a000001900000\r
+% MSTT31c52a = 2027DTimes New RomanF0000002e000001900000\r
+% MSTT31c537 = 2027DTimes New RomanF0000002e000001900001\r
+% MSTT31c544 = 2027DArialF00000032000002bc0001\r
+% MSTT31c54f = 2027DTimes New RomanF0000002a000001900001\r
+% MSTT31c55c = 2027DTimes New RomanF0000002a000002bc0001\r
+% MSTT31c569 = 2027DArialF0000003a000001900001\r
+% MSTT31c574 = 2027DWingdingsF0000003f000001900000\r
+% MSTT31c580 = 2027DArialF0000003f000001900001\r
+% MSTT31c58b = 2027DTimes New RomanF0000003f000001900001\r
+%%DocumentSuppliedResources: procset Win35Dict 3 1\r
+%%+ font MSTT31c4a3\r
+%%+ font MSTT31c4bd\r
+%%+ font MSTT31c4eb\r
+%%+ font MSTT31c4f8\r
+%%+ font MSTT31c510\r
+%%+ font MSTT31c51d\r
+%%+ font MSTT31c52a\r
+%%+ font MSTT31c537\r
+%%+ font MSTT31c54f\r
+%%+ font MSTT31c55c\r
+%%+ font MSTT31c574\r
+\r
+%%DocumentNeededResources: font Helvetica\r
+%%+ font Helvetica-BoldOblique\r
+%%+ font Helvetica-Oblique\r
+%%+ font Palatino-Roman\r
+%%+ font Symbol\r
+%%+ font ZapfDingbats\r
+\r
+%%EOF\r
+\ 4
\ No newline at end of file
--- /dev/null
+LOGLAN'82\r
+Quick Reference Card\r
+Syntax Form\r
+ its meaning (informal)\r
+\r
+ program <name>;\r
+ <declarations>\r
+ begin\r
+ <instructions>;\r
+ end\r
+Program is a unit. It is the root of a tree of units.\r
+During an execution of the program this tree is \r
+used as a collection of patterns for instances. An \r
+instance of a unit is either an activation record (of \r
+a procedure) or an object(of a class).\r
+\r
+Declarations\r
+\r
+\r
+there are five forms of a declaration: \r
+\r
+\r
+\r
+var, const, unit, signal, handlers \r
+\r
+ var x: T, y,z: U;\r
+declaration of variables x of type T, y,z of type U\r
+\r
+ unit A: B<kind>(params);\r
+ <declarations>\r
+ begin\r
+ <instructions>;\r
+ last_will: <instructions>\r
+ end A;\r
+\r
+evidently you need not to inherit from a module \r
+declaration of a module A which inherits from B. \r
+kind may be one of: procedure, class, coroutine, \r
+process, block, handler, function\r
+params is a list of formal parameters,\r
+REMARKS\r
+- block has no name \r
+ its first line is: block or pref C block\r
+- function has a type of result after parameters,\r
+- handler has a different form., see below,\r
+- last_will instruction are executed exceptionally.\r
+\r
+ const cc=80\r
+declaration of a constant\r
+\r
+ signal S;\r
+ signal Alarm(x: T, y: Q);\r
+declaration of a signal S\r
+it may have a list of formal parameters \r
+\r
+\r
+ handlers\r
+ when sig1,SIGN3: Inst; return;\r
+ when sig2: instructions2; wind;\r
+ others in; terminate\r
+ end handlers\r
+declaration of a module handling exceptions,\r
+sig1, sig2, SIGN3 are names of exceptions,\r
+Inst, instructions2,in are sequences of instructions\r
+\r
+handlers appear as the last declaration in a unit\r
+\r
+\r
+\r
+\r
+Parametrisation of Units\r
+\r
+\r
+modes of transmission: \r
+input, output, inout values of expressions\r
+\r
+also procedure, function, type can be \r
+transmitted as a parameter\r
+formal procedures(functions) should be specified \r
+i.e. the types of arguments and results should be \r
+given.\r
+a formal type T alone is of limited use, however it \r
+may accompany other parameters using T.\r
+\r
+Processes are distributed it means that \r
+they cannot share objects. You can \r
+transmit only values of simple types and \r
+names of processes or formal procedures \r
+to be used for alien calls.\r
+Processes can reside on different systems of your \r
+network. This explains the reasons for the \r
+restrictions. \r
+The present implementation of processes has \r
+several limitations. Sorry.\r
+\r
+Instructions\r
+\r
+\r
+Atomic instructions\r
+\r
+\r
+ x := <expression>\r
+assignment instruction\r
+\r
+ x := copy (<expression>)\r
+copying assignment instruction, has sense only for \r
+object expressions\r
+\r
+ call Aprocedure(params)\r
+procedure call instruction\r
+\r
+ return\r
+leaving procedure or function\r
+\r
+ exit or exit exit or exit exit exit\r
+leaving one, two or three nested loops do od\r
+\r
+ new Aclass(params) \r
+instruction generating an object\r
+\r
+ Objects\r
+\r
+\r
+ x := new Aclass(params)\r
+creates an object of class Aclass with params\r
+and stores it under the name of x\r
+\r
+ end Aclass or return\r
+terminating initialisation of a newly created object\r
+\r
+ kill(x)\r
+deallocation instruction, causes{x=none}and kills x\r
+REMARK. No dangling references!\r
+{x=y&x=z} => kill(x) {x=none&y=none&z=none}\r
+\r
+ inner\r
+pseudoinstruction: a slot for the instructions of an \r
+inheriting unit\r
+\r
+ Coroutines\r
+\r
+\r
+ x := new Cor(params)\r
+creates a coroutine object x of type Cor\r
+\r
+ attach(x)\r
+activates coroutine x, and then makes the current \r
+coroutine chain passive \r
+\r
+ detach\r
+undoes the last attach \r
+\r
+ Processes & Concurrency\r
+truly object oriented processes and an objective com-\r
+munication mechanism just by calling methods of a \r
+distant process\r
+\r
+ proces5:=new procesType(...);\r
+creates an object of \r
+ unit procesType: process(<formParams>); ...\r
+\r
+ resume(proces5)\r
+activate a passive process process5\r
+\r
+ stop\r
+the current process passivates\r
+\r
+ enable hisprocedure\r
+adds the name hisprocedure to the MASK of the \r
+process, enabling other processes to communicate \r
+with the process by means of hisprocedure\r
+\r
+ disable aProcedure,aFunction\r
+deletes aProcedure,aFunction from the MASK\r
+\r
+ accept aProc1, aProc2, aFnctn\r
+process waits (inactively) for another process \r
+calling a method; \r
+accept makes possible rendez-vous of this process \r
+and another process calling his method\r
+\r
+ return disable aProc1 enable aQ\r
+return from a rendez-vous reestablishes the MASK \r
+of the called process; it is posible to modify its \r
+MASK disabling some procedures and enabling \r
+others\r
+\r
+ call proces5.hisprocedure(par)\r
+\r
+ *\r
+\r
+ this is ALIEN CALL\r
+the current process demands process5 process to \r
+execute hisprocedure with the transmitted par \r
+parameters and waits for the eventual outputs;\r
+1 this instruction may meet with an accept \r
+instruction of process5 process - in such case there \r
+is a rendez-vous of two process,\r
+2 otherwise the call tents to interrupt the normal \r
+flow of execution of the called process5 process.\r
+\r
+ \r
+ Exception handling\r
+\r
+\r
+ raise Asignal\r
+Asignal is raised. This lances the research of a \r
+module handling the signal along the chain of DL \r
+links i.e. along dynamic fathers of instances. \r
+\r
+ return\r
+* returns to after raise statement\r
+\r
+ wind\r
+* 3 forms of terminating an exception handling\r
+\r
+ terminate\r
+* destructs (lastwill) several instances of units\r
+\r
+\r
+Composed instructions\r
+\r
+\r
+ if * then I else J fi\r
+* is a Boolean expression\r
+I, J are sequences of instructions {else J is optional}\r
+\r
+ do I od\r
+looping instruction; it is suggested to put an exit \r
+instruction among the instructions I, see below\r
+\r
+ while * do I od\r
+* is a Boolean expression\r
+I a sequence of instructions\r
+equivalent to\r
+do\r
+ if * then I else exit fi\r
+od\r
+\r
+ for i:= A to B do I od\r
+i integer variable, A, B integer expressions,\r
+I a sequence of instructions\r
+\r
+ case c\r
+ when c1: I;\r
+ otherwise J\r
+ esac\r
+case instruction\r
+I, J are sequences of instructions\r
+c is an expression, c1 is a constant\r
+ \r
+\r
+\r
+Expressions\r
+\r
+\r
+Arithmetic expressions\r
+\r
+\r
+Boolean expressions\r
+remark in and is object relations, e.g. if x in Clas2 \r
+\r
+Object expressions\r
+\r
+\r
+ new T(actual_params)\r
+create new object of class (coroutine, process) T \r
+passing the actual_params list to it\r
+\r
+ this T\r
+returns as a value the object of type T containing \r
+this expression\r
+\r
+ E qua A\r
+qualifies the value of E as of type A\r
+Raises error if not E in A\r
+\r
+ copy(E)\r
+returns a copy of value of the object expression E \r
+\r
+Character expressions\r
+\r
+\r
+String expressions\r
+only constant strings!\r
+\r
+\r
+Inheritance & Nesting * \r
+\r
+2 fundamental methods of unit's composition\r
+\r
+Multi-level inheritance permits to make \r
+extensions of classes, coroutines, \r
+processes defined on different level of \r
+the nesting structure of units.\r
+Multi-kind inheritance permits to inherit in a \r
+block, procedure, function, class, coroutine or \r
+process.\r
+\r
+\r
+Multiple inheritance is doable by means \r
+of multi-level inheritance and other \r
+ingredients of Loglan.\r
+Generic modules are doable in various ways: by \r
+formal types, by multi-level inheritance combined \r
+with nesting, to say nothing about virtuals.\r
+\r
+\r
+Loglan'82 Quick Reference Card - 3 - December, 94\r
+\r
+\r
--- /dev/null
+The files put here are\r
+either Word2forWindows files .doc\r
+or PostscriptFiles .ps\r
+or ASCII text files .txt and all other extensions\r
+\r
+_________________________________________________________________\r
+\r
+userman contains the USER'S Manual\r
+loglan contains the micromanual\r
+*rep82* different parts of Report on Loglan'82 language\r
--- /dev/null
+1\r
+ \r
+ \r
+ INSTITUTE OF INFORMATICS, UNIVERSITY OF WARSAW\r
+ \r
+ \r
+ \r
+ \r
+ REPORT ON THE\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ # ###### ###### # ###### # # #### ####\r
+ # # # # # # # ## # # # # #\r
+ # # # # # # # # # # #### #\r
+ # # # # ## # ###### # # # # # #\r
+ # # # # # # # # # ## # # #\r
+ ###### ###### ###### ###### # # # # #### ######\r
+ \r
+ \r
+ \r
+ \r
+ PROGRAMMING LANGUAGE (*)\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ W.M.BARTOL, P.GBURZYNSKI, P.FINDEISEN, A.KRECZMAR, M.LAO, A.LITWINIUK\r
+ \r
+ T.MULDNER, W.NYKOWSKI, H.OKTABA, A.SALWICKI, D.SZCZEPANSKA-WASERSZTRUM\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ ---------------------------------------------------------\r
+ (*) Supported in part by Zjednoczenie "MERA", POLAND\r
+ \r
+ \r
+ \r
+1\r
+ \r
+ \r
+ FOREWORD\r
+ --------\r
+ \r
+ \r
+ \r
+ We submit to the reader the report of a language whose design is still in\r
+ progress. Therefore any remarks and comments are very desirable. They can\r
+ be sent to:\r
+ \r
+ \r
+ UNIVERSITY OF WARSAW\r
+ INSTITUTE OF INFORMATICS\r
+ PKIN 8TH FLOOR\r
+ 00-901 WARSAW\r
+ POLAND\r
+ \7f\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ The edition has been produced by using the editor program (prepared by\r
+ P.Gburzynski, University of Warsaw) on minicomputer MERA 400. This original\r
+ Polish minicomputer was used for the first implementation of LOGLAN-82.\r
+ \r
+ \r
+ \r
+ Warszawa, June, 1982\r
+1 - 1 -\r
+ \r
+ \r
+ CONTENTS.\r
+ #########\r
+ \r
+ List of symbols...................................................3\r
+ \r
+ 1. Preface........................................................4\r
+ \r
+ 2. The basic characteristics of LOGLAN-82.........................8\r
+ 2.1. Control structure.........................................8\r
+ 2.2. Block structure...........................................11\r
+ 2.3. Procedures and functions..................................13\r
+ 2.4. Classes...................................................14\r
+ 2.5. Prefixing.................................................15\r
+ 2.6. Object deallocator........................................17\r
+ 2.7. Arrays....................................................18\r
+ 2.8. Parameters................................................19\r
+ 2.9. Coroutines................................................20\r
+ 2.10. Processes.................................................21\r
+ 2.11. Other important features..................................22\r
+ \r
+ 3. Lexical and textual structure..................................23\r
+ \r
+ 4. Types..........................................................26\r
+ 4.1. Primitive types............................................27\r
+ 4.2. System types...............................................28\r
+ 4.3. Compound types and objects.................................29\r
+ 4.3.1. Array type.............................................29\r
+ 4.3.2. Class type.............................................30\r
+ 4.4. Formal types...............................................30\r
+ \r
+ 5.Declarations....................................................31\r
+ 5.1. Constant declaration.......................................31\r
+ 5.2. Variable declaration.......................................32\r
+ 5.3. Unit declaration...........................................33\r
+ 5.3.1. Class declaration (introduction).......................33\r
+ 5.3.2. Subprogram declaration (introduction)..................34\r
+ 5.3.3. Block..................................................35\r
+ 5.3.4. Prefixing..............................................36\r
+ 5.3.5. Formal parameters......................................37\r
+ 5.3.6. Unit body..............................................40\r
+ \r
+ 6. Static and dynamic locations . Visibility rules................42\r
+ 6.1. Unit attributes............................................42\r
+ 6.2. Protected attributes.......................................43\r
+ 6.2.1. Hidden attributes......................................43\r
+ 6.2.2. Taken attributes.......................................44\r
+ 6.2.3. Legal and illegal identifiers .........................44\r
+ 6.2.4. Close attributes.......................................45\r
+ 6.3. Static location............................................46\r
+ 6.4. Objects....................................................48\r
+ 6.4.1.ements..........................................71\r
+ 9.1. Sequential primitive statements............................71\r
+ 9.1.1. Evaluation statement...................................72\r
+ 9.1.2. Configuration statement................................75\r
+ 9.1.2.1. Allocation statement...............................75\r
+ 9.1.2.2. Deallocation statement.............................83\r
+ 9.1.3. Simple control statement...............................84\r
+ 9.1.4. Coroutine statement....................................86\r
+ 9.2. Compound statements.......................................87\r
+ 9.2.1. Conditional statement..................................87\r
+ 9.2.2. Case statement.........................................89\r
+1 - 2 -\r
+ \r
+ \r
+ 9.2.3. Iteration statement....................................90\r
+ \r
+ 10. Exception handling............................................96\r
+ 10.1. Signal specification.......................................96\r
+ 10.2. Signal handlers............................................97\r
+ 10.3. Signal raising.............................................98\r
+ 10.4. Handler execution.........................................101\r
+ 10.5. System signals............................................103\r
+ \r
+ 11. Processes....................................................104\r
+ 11.1. Transition state statement...............................106\r
+ 11.2. Primitive synchronizing statement........................109\r
+ 11.3. Monitors (compound synchronization facilities)...........112\r
+ \r
+ 12. Separate compilation of units................................115\r
+ 12.1. Library items............................................117\r
+ 12.1.1. Interface............................................118\r
+ 12.1.2. Using languages......................................121\r
+ 12.1.3. Using externals......................................122\r
+ 12.1.4. Using sl-virtuals....................................122\r
+ 12.2. Linking library items....................................123\r
+ 12.2.1. Connecting the interface.............................123\r
+ 12.3. Binary items.............................................126\r
+ 12.4. Processing libraries.....................................127\r
+ 12.4.1. Recompilation........................................127\r
+ 12.4.2. Insertions and deletions.............................128\r
+ \r
+ 13. File processing..............................................129\r
+ 13.1. External and internal files..............................129\r
+ 13.2. File generation and deallocation.........................130\r
+ 13.3. Binary input-output......................................132\r
+ 13.4. Other predefined operations..............................133\r
+ 13.5. Text input-output........................................134\r
+ 13.6. Example of high-level file processing....................136\r
+ \r
+ Bibliography.....................................................137\r
+ Index............................................................139\r
+1 - 3 -\r
+ \r
+ \r
+ List of symbols\r
+ ***************\r
+ \r
+ \r
+ \r
+ We shall use the following symbols (with indices if necessary):\r
+ \r
+ A - arithmetic expression,\r
+ B - boolean expression,\r
+ C - character expression,\r
+ D - string expression,\r
+ E - arbitrary expression,\r
+ F - function/procedure,\r
+ G, H - statement (or sequence of statements),\r
+ i, j, k, l, u - integer variable or index,\r
+ M, N, P, R, S, T - type or unit identifier,\r
+ O - object,\r
+ Q - constant,\r
+ V - valuation,\r
+ W - arbitrary identifier,\r
+ X - object expression,\r
+ Y - arbitrary variable,\r
+ Z - simple variable,\r
+ Pf - formal parameter,\r
+ Pa - actual parameter,\r
+ VE - the value of an expression E.\r
+1 - 4 -\r
+ \r
+ \r
+ 1. PREFACE\r
+ ###########\r
+ \r
+ LOGLAN-82 #) is a universal programming language designed at the\r
+ Institute of Informatics, University of Warsaw. The shortest, informal\r
+ characterization of the language would read as follows. LOGLAN-82 belongs\r
+ to the Algol family of programming languages. Its syntax, however, is\r
+ patterned upon Pascal's. Many ideas are borrowed from SIMULA-67 [3]. The\r
+ language includes also some modern facilities such as concurrency and\r
+ exception handling.\r
+ \r
+ The characteristic programming constructs and facilities of the language\r
+ are as follows:\r
+ \r
+ - a convenient set of structured statements,\r
+ - block structure,\r
+ - procedures an functions,\r
+ - classes,\r
+ - prefixing,\r
+ - programmed deallocation,\r
+ - adjustable arrays,\r
+ - formal types and formal procedures,\r
+ - coroutines,\r
+ - processes,\r
+ - encapsulation techniques,\r
+ - exception handling,\r
+ - separate compilation techniques,\r
+ - file processing.\r
+ \r
+ \r
+ LOGLAN-82 history\r
+ -----------------\r
+ \r
+ In the early seventies the Institute of Mathematical Machines "MERA"\r
+ (with two members of the present team of authors) and the Institute of\r
+ Informatics of Warsaw University initiated the design of a new high level\r
+ programming language. There were two main inspirations for taking up this\r
+ research. First the awareness that the SIMULA 67 programming language was a\r
+ substantial contribution to the software methodology and second that the\r
+ fast development of multiprocessor hardware will change the software\r
+ practice.\r
+ We began our work with analytical studies, seminars and lectures dealing\r
+ with the basic constructs and features of the known programming languages.\r
+ This helped us to establish the goals a new programming language should\r
+ reach. By then, however, we decided that the design of the programming\r
+ language would be a component of a broader software project, called LOGLAN.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ -------------------------------------------------------------------------\r
+ #) Recently we received information about another LOGLAN - an\r
+ esperanto-like language developed in US.\r
+1 - 5 -\r
+ \r
+ \r
+ There is no doubt that the environment in which our investigations have\r
+ been carried out has shed a new light on these goals. In particular, the\r
+ experience accumulated by a big part of our team in the field of\r
+ Algorithmic Logic [15] influenced the form of the solutions accepted.\r
+ The first step of our work was finished in 1977 with the report on the\r
+ LOGLAN programming language [12]. The report provides a general outline of\r
+ a universal programming language. Among its most important features let us\r
+ mention a new approach to arrays, assignments, parameter transmission and\r
+ parallel computations. This version was not implemented. It constituted the\r
+ base for the agreement between the University of Warsaw and the State\r
+ Industrial Trust MERA, signed a year later.\r
+ A careful analysis of the constructs suggested in the primary project\r
+ preceded an actual implementation. With the intention of attaining this,\r
+ the interpreter of the language was designed. At that stage a number of\r
+ important modifications were introduced to the proposed outline. They\r
+ resulted from experiments with the interpreter which proved the usefulness\r
+ of some constructs and the uselessness of some others.\r
+ At the next stage of research the language was implemented on the\r
+ original Polish two-processor minicomputer MERA 400. The design was\r
+ restricted in several points because of the implementation constraints.\r
+ Some constructs were rejected, the decision concerning some others was put\r
+ off until a more elaborate analysis was carried out.\r
+ The experience of the team in the field of abstract data types and\r
+ computational complexity helped us to solve one of the most fundamental\r
+ implementation problems - a proper structure for secure and fast storage\r
+ management. In consequence, the language is furnished with a programmed\r
+ deallocator which allows the user to design the best strategy of storage\r
+ management at run time.\r
+ The implementation of unrestricted prefixing needed a completely new\r
+ approach. The well-known mechanisms like Dijkstra's display do not allow us\r
+ to release the SIMULA restrictions (the most important forbids the use\r
+ prefixing at different levels of unit nesting). Such a solution was found\r
+ and the LOGLAN-82 users may apply prefixing at an arbitrary level of unit\r
+ nesting.\r
+ Of the results we have obtained so far let us mention paper [1], which\r
+ deals with the principles of an efficient implementation of programming\r
+ languages with prefixing at many levels. The paper introduces the\r
+ generalized display mechanism and proves the correctness of an\r
+ update-display algorithm. A new data structure for efficient and secure\r
+ storage management is also provided.\r
+ Paper [2] deals with the design and implementation of class Simulation\r
+ (improving that provided in SIMULA 67).\r
+ The concurency problems are described in the special mathematical model\r
+ [19]. The correctness of the monitor implementation is proved in [20]. The\r
+ semantics of an assignment statement for subscripted variables is defined\r
+ and carefully examined in [21]. Paper [16] describes the semantics of\r
+ allocation, deallocation and control statements.\r
+ A comprehensive survey about LOGLAN-82 and its applications is supplied\r
+ in [8]. Let us mention the close connections between the development of the\r
+ language itself and of Algorithmic Logic, see [15, 22, 23, 24, 25, 26].\r
+1 - 6 -\r
+ \r
+ \r
+ LOGLAN-82 high points\r
+ ---------------------\r
+ \r
+ \r
+ - An orderly and intellectually manageable fashion of program design.\r
+ \r
+ - Clean, modular extensibility (by means of the above mentioned\r
+ facilities, in particular by prefixing). An algorithm employing an\r
+ abstract data structure can be prefixed by a class realizing that\r
+ structure. The class may be programmed by the user himself or by\r
+ another user, taken from the system library etc. In this way,\r
+ programs may be developed by teams of programmers.\r
+ \r
+ - An environment for distributed and safe development of large\r
+ programs and systems with easy inter-communication between members\r
+ of software teams, i.e., different parts of the design are easy to\r
+ read, check and modify. The modifications do not entail unexpected\r
+ interactions.\r
+ \r
+ - Possibility of systematic debugging in a way which contributes to\r
+ confidence in the overall program correctness.\r
+ \r
+ - The separate compilation facility.\r
+ \r
+ - Type checking, especially of references to objects, which\r
+ substantially reduces the need for run-time checks and increases the\r
+ safety of handling pointers.\r
+ \r
+ - Efficient storage management by means of well-tailored allocation/\r
+ deallocation operations.\r
+ \r
+ - Clear visibility rules with the capability of unit encapsulation\r
+ techniques.\r
+ \r
+ - Concurrent computations in which several processes are\r
+ simultaneously and independently executed by any number of\r
+ processors. The concurrent multiprocessor computations were treated\r
+ with due care. We reached the necessary foundations for the\r
+ description of atomic operations for the concurrent statements. The\r
+ atomic operations may be efficiently implemented in any operating\r
+ system kernel. It is well known that concurrent computations have to\r
+ be synchronized and scheduled. We do not prejudge which facilities\r
+ are to be used for those purposes. In LOGLAN-82 all known\r
+ synchronization methods may be declared as predefined classes. For\r
+ example, let us mention that it is possible to define:\r
+ \r
+ - monitoring dialect similar to CONCURRENT PASCAL,\r
+ cf.[5], with the main notions: process, monitor, entry\r
+ procedure, delay, continue,\r
+ - tasking dialect similar to ADA's tasks, cf.[11], with\r
+ the main notions: task, accept, select, rendez-vous.\r
+ \r
+1 - 7 -\r
+ \r
+ \r
+ First implementation of LOGLAN-82\r
+ ---------------------------------\r
+ \r
+ \r
+ The first implementation of the language was finished in December 1981 on\r
+ the two processors Polish minicomputer MERA-400 (uni-bus architecture). The\r
+ whole compiler was programmed in FORTRAN IV Standard. The run-time system\r
+ and file processing were coded in the Mera Assembly Language GASS.\r
+ The implementation team was headed by Antoni Kreczmar (who is the author\r
+ of Running System) and included Pawel Gburzynski (File Processing), Marek\r
+ Lao (Semantic Analysis), Andrzej Litwiniuk (Code Generation), Wojtek\r
+ Nykowski (Parsing) and Danuta Szczepanska-Wasersztrum (Static Semantics).\r
+ \r
+ \r
+ \r
+ \r
+ Further work on LOGLAN-82\r
+ -------------------------\r
+ \r
+ Although we are convinced that LOGLAN-82 will prove to be useful for an\r
+ average user, we would like to stress that we were interested mainly in\r
+ finding answers to research questions. Our approach is more scientific than\r
+ commercial.\r
+ Among the studies that are planned for the nearest future, let us mention\r
+ further research on LOGLAN-82 itself and on its first compiler. The\r
+ portability of the compiler seems to be the main target of our team.\r
+ Moreover, LOGLAN-82 will be used in several applications. In this way the\r
+ language will be verified and its usefulness will be analyzed. We are\r
+ convinced that the new computer architecture and multiprocessor environment\r
+ should be taken into account. Therefore, we plan studies which could\r
+ support an efficient implementation of the language with richer semantics\r
+ are planned. It seems that the crucial point of the future hardware would\r
+ be the efficient implementation of the storage management.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ Acknowledgments\r
+ ---------------\r
+ \r
+ \r
+ We wish to express our gratitude to all institutions and persons who\r
+ supported us materially or morally. Thanks are due to the State Industrial\r
+ Trust "MERA" and to its deputy director A.Janicki for the arrangements that\r
+ enabled us to realize the LOGLAN-82 project.\r
+ The LOGLAN-82 team wishes to thank all colleagues in Warsaw for criticism\r
+ and helpful remarks. This report has been carefully read by a number of\r
+ people, including J.Deminet, F.Kluzniak, A.Janicki, J.Rudzinski,\r
+ W.M.Turski. Their critical comments helped us to avoid numerous mistakes.\r
+1 - 8 -\r
+ \r
+ \r
+ 2. The basic characteristics of LOGLAN-82\r
+ #########################################\r
+ \r
+ 2.1. Control structure\r
+ **********************\r
+ \r
+ \r
+ Compound statements in LOGLAN-82 are built up from simple statements\r
+ (like assignment or call statement) by means of conditional, iteration and\r
+ case statements.\r
+ \r
+ \r
+ The syntax of a conditional statement is as follows:\r
+ \r
+ if boolean expression\r
+ then\r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r
+ \r
+ The semantics of a conditional statement is standard. The keyword fi\r
+ allows us to nest conditional statements without the appearence of the\r
+ "dangling else" ambiguity. The "else" part in a conditional statement may\r
+ be omitted:\r
+ \r
+ if boolean expression\r
+ then\r
+ sequence of statements\r
+ fi\r
+ \r
+ Another version of a conditonal statement has the form:\r
+ \r
+ if B1 orif ... orif Bk\r
+ then\r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r
+ \r
+ For the execution of a conditional statement with the orif list the\r
+ specified conditions B1, ..., Bk are evaluated in succession, until the\r
+ first one evaluates to true. Then the rest of the sequence is abandoned and\r
+ the "then" part is executed. If none of the conditions evaluates to true,\r
+ the "else" part is executed (if any). The orif construction provides a good\r
+ method for a short circuit technique, since the boolean expression\r
+ controling the conditional statement execution need not be evaluated till\r
+ the end.\r
+1 - 9 -\r
+ \r
+ \r
+ Similarly, a conditional statement with the andif list has the form:\r
+ \r
+ if B1 andif ...andif Bk\r
+ then\r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r
+ \r
+ For the execution of this kind of statement the conditions B1, ..., Bk\r
+ are evaluated in succession until the first one evaluates to false. Then\r
+ the "else" part is executed (if any). Otherwise the "then" part is\r
+ executed.\r
+ \r
+ \r
+ The basic form of an iteration statement in LOGLAN-82 is the following:\r
+ \r
+ do\r
+ sequence of statements\r
+ od;\r
+ \r
+ To terminate the iteration statement one can use the simple control\r
+ statement exit, which has the following syntactic form:\r
+ \r
+ exit ..... exit\r
+ \r
+ repeated an arbitrary number of times. It may occur in a nested loop\r
+ statement. The execution of exit.....exit (i - times) statement consists in\r
+ the control transfer to the statement immediately following the i-th od\r
+ after the exit statement, (where in counting the od's, the pairs do-od are\r
+ disregarded). In particular, when exit occurs in a simple loop the control\r
+ is transferred to the statement immediately following the od symbol, which\r
+ allows us to terminate the loop. Similarly, a double exit terminates two\r
+ nested loops, a triple exit terminates three nested loops etc. Moreover, a\r
+ LOGLAN-82 iteration statement allows us to place many loop exit points in\r
+ arbitrary configurations, e.g., exit may appear in nested conditional\r
+ statements, case statements, etc.\r
+ \r
+ Iteration statements with controlled variables (for statements) have the\r
+ forms:\r
+ \r
+ for j := A1 step A2 to (or downto) A3\r
+ do\r
+ sequence of statements\r
+ od;\r
+1 - 10 -\r
+ \r
+ \r
+ The type of the controlled variable j must be discrete. The value of this\r
+ variable in the case of the for statement with to is increased, and in the\r
+ case of the for statement with downto is decreased. The discrete range\r
+ begins with the value of A1 and changes with the step equal to the value of\r
+ A2. The execution of the for statement with to terminates when the value of\r
+ j becomes for the first time greater than A3 (with downto when the value of\r
+ j becomes for the first time less than A3). The values of the expressions\r
+ A1, A2, A3 are evaluated once, upon entry to the iteration statement. The\r
+ default value of A2 is equal to 1 (when the keyword step and A2 are\r
+ omitted).\r
+ \r
+ \r
+ An iteration statement with the while condition has the form:\r
+ \r
+ while boolean expression\r
+ do\r
+ sequence of statements\r
+ od;\r
+ \r
+ and is equivalent to\r
+ \r
+ do\r
+ if not boolean expression then exit fi;\r
+ sequence of statements\r
+ od;\r
+ \r
+ To enhance the users's comfort, the simple statement repeat is provided.\r
+ It may appear in an iteration statement and causes the current iteration to\r
+ be finished and the next one to be continued (something like jump to\r
+ CONTINUE in Fortran's DO statement). In general, this statement has the\r
+ form:\r
+ \r
+ exit ... exit repeat\r
+ \r
+ and causes the current iteration of the corresponding enclosing iteration\r
+ statement to be finished and the next one to be continued.\r
+ \r
+ A case statement in LOGLAN-82 has the form:\r
+ \r
+ case A\r
+ when Q1 : G1\r
+ when Q2 : G2\r
+ ...\r
+ when Qk : Gk\r
+ others G\r
+ esac\r
+ \r
+ where A is an arithmetic expression, Q1, ..., Qk are constants and G1, ...,\r
+ Gk are sequences of statements. A case statement selects for execution a\r
+ sequence Gj where the value of A equals Qj. The choice others covers all\r
+ values (possibly none) not given in the previous choices.\r
+1 - 11 -\r
+ \r
+ \r
+ 2.2. Block structure\r
+ ********************\r
+ \r
+ \r
+ \r
+ LOGLAN-82 adopts and extends the main semantic features of the ALGOL\r
+ family programming languages (ALGOL-60, ALGOL-68, SIMULA-67) i.e., the\r
+ block structure. The block concept of ALGOL-60 is a fundamental example of\r
+ this mechanism. The syntactic structure of a block is as follows:\r
+ \r
+ block\r
+ list of declarations\r
+ begin\r
+ sequence of statements\r
+ end\r
+ \r
+ The list of declarations defines some syntactic entities, e.g. constants,\r
+ variables, procedures, functions etc., whose scope is that block. The\r
+ syntactic entities occurring in the sequence of statements are identified\r
+ by means of identifiers which are introduced in the declaration lists. For\r
+ every identifier occurrence it must be possible to identify the\r
+ corresponding syntactic entity. This kind of correspondence between\r
+ occurrences of identifiers and syntactic entities is necessary to define\r
+ the semantics of a block statement. The block statement semantics may be\r
+ described as follows.\r
+ \r
+ When a block is entered, a dynamic instance of the block is generated. In\r
+ a computer, a block instance takes the form of a memory frame containing\r
+ syntactic entities declared in that block. All local syntactic entities of\r
+ an instance will be called its attributes .\r
+ \r
+ The frame of a block instance may be viewed as a box (with displayed\r
+ attributes when necessary).\r
+ \r
+ ------------------------\r
+ ! attribute k !\r
+ ------------------------\r
+ ! ... !\r
+ ------------------------\r
+ ! ... !\r
+ ------------------------\r
+ ! attribute 1 !\r
+ ------------------------\r
+ block instance\r
+1 - 12 -\r
+ \r
+ \r
+ A block is a statement, and so other blocks may occur in its sequence of\r
+ statement (i.e., blocks may be nested). Observe, that the occurrences of\r
+ identifiers in an inner block need not be local. They can refer to entities\r
+ declared in the outer block. For a non-local occurrence of identifier, the\r
+ corresponding attribute of a non-local instance should be identified. That\r
+ identification is possible thanks to an auxiliary notion of a syntactic\r
+ father.\r
+ \r
+ Consider the following block structure:\r
+ \r
+ --------------\r
+ ! block[1] !\r
+ ! !\r
+ ! -----------!\r
+ ! ! block[2]!!\r
+ ! -----------!\r
+ --------------\r
+ \r
+ \r
+ \r
+ \r
+ When the statements of block[2] are executed, the following two dynamic\r
+ block instances are created:\r
+ \r
+ \r
+ -------- --------\r
+ ! O[2] !=============>! O[1] !\r
+ -------- SL --------\r
+ \r
+ Here O[1] is an instance of the block[1], and O[2] is an instance of the\r
+ block[2].\r
+ \r
+ The instance O[1] is called the syntactic father of O[2] (or\r
+ alternatively the instance O[2] is syntactically linked by the SL-link with\r
+ the instance O[1]). During a program's execution the sequence of syntactic\r
+ fathers determined by an active instance forms a chain, called an SL-chain.\r
+ The instances forming the SL-chain correspond to the consequtive enclosing\r
+ units of the program, starting from the active one and ending on the main\r
+ block. Thus, this chain allows us to identify all non-local occurrences of\r
+ identifiers.\r
+ \r
+ A block statement terminates when the control reaches its final end, and\r
+ then its instance is automatically deallocated.\r
+1 - 13 -\r
+ \r
+ \r
+ 2.3. Procedures and functions\r
+ *****************************\r
+ \r
+ \r
+ A block is the simplest example of a unit. Blocks are syntactic units\r
+ generated by means of a block statement and deallocated automatically when\r
+ the end symbol is reached. Procedures and functions constitute the next\r
+ step of know-how in high level programming languages.\r
+ \r
+ The syntactic form of a procedure declaration is as follows:\r
+ \r
+ unit name: procedure(formal parameters);\r
+ list of declarations\r
+ begin\r
+ sequence of statements\r
+ end;\r
+ \r
+ A procedure is a named syntactic unit which may be invoked only via its\r
+ identifier by means of a call statement:\r
+ \r
+ call name (actual parameters);\r
+ \r
+ (Procedures differ from blocks also in that they can have parameters, but\r
+ this question will be discussed later.)\r
+ \r
+ When a procedure is called, its instance is created, as in the case of a\r
+ block. All local attributes are allocated in the new frame. A syntactic\r
+ father of such a newly generated instance is defined as usual, and allows\r
+ us to identify all non-local attributes.\r
+ \r
+ A procedure call is terminated when the control reaches return statement\r
+ or the final end. Then the control returns to the instance where the\r
+ procedure was called. That instance is referred to by another system\r
+ pointer (DL-link).\r
+ \r
+ After the termination of a procedure call there is no syntactic means to\r
+ access its local attributes, hence its instance is automatically\r
+ deallocated.\r
+ \r
+ Functions differ from procedures only in that they return a value and are\r
+ invoked in the expressions.\r
+1 - 14 -\r
+ \r
+ \r
+ 2.4. Classes\r
+ ************\r
+ \r
+ To meet the need for permanent data structures LOGLAN-82 introduces the\r
+ notion of class (cf [3]). Class is declared in a similar way to procedure.\r
+ It is named and may have parameters:\r
+ \r
+ unit M :class(formal parameters);\r
+ list of declarations\r
+ begin\r
+ sequence of statements\r
+ end;\r
+ \r
+ The main difference between classes and procedures consists in the way\r
+ the instances of these syntactic units are treated. (To distiguish class\r
+ instances from those of blocks, functions and procedures they will be\r
+ called class objects or simply objects). The class generation yields a\r
+ class object which is a permanent data unlike the vanishing procedure\r
+ (function, block) instance. The object O of class M is generated by the\r
+ object generator statement:\r
+ \r
+ new M\r
+ \r
+ This statement invokes the same sequence of actions as a procedure call,\r
+ i.e., it opens a new object, transmits parameters and executes the sequence\r
+ of statements of M. Return to the caller is made by the execution of a\r
+ return statement or when the final end is reached.\r
+ The access to such an object is then possible if its address is set to a\r
+ variable. The variables whose values point to class objects are called\r
+ reference variables.\r
+ A reference variable of type M is declared as follows:\r
+ \r
+ var X:M;\r
+ \r
+ and may point to any object of class M, for instance, the statement:\r
+ \r
+ X:=new M\r
+ \r
+ generates an object O of class M and assigns its address (reference) to X.\r
+ The default value of any reference variable is none, which denotes\r
+ fictitious non-existing object.\r
+ What is left behind is a structure of attributes which can be accessed by\r
+ means of dot-notation. These accessible attributes are either formal\r
+ parameters or local entities. If X is a reference variable of type M and W\r
+ is an attribute of class M, then the remote access to the attribute W has\r
+ the form:\r
+ \r
+ X.W\r
+ \r
+ The above remote access is correct if X points to an object O of class M.\r
+ Otherwise a run time error is raised (for instance when the value of X is\r
+ none).\r
+1 - 15 -\r
+ \r
+ \r
+ 2.5. Prefixing\r
+ ***************\r
+ \r
+ Prefixing is another important programming facility borrowed from\r
+ SIMULA-67. Its most important feature consists in the possibility of unit\r
+ extension. Consider the following example. Let M be a class:\r
+ \r
+ unit M: class;\r
+ list of declarations of M\r
+ begin\r
+ sequence of statements of M\r
+ end ;\r
+ \r
+ Now let N be a class:\r
+ \r
+ unit N: M class\r
+ list of declarations of N\r
+ begin\r
+ sequence of statements of N\r
+ end ;\r
+ \r
+ Class N is prefixed by class M. The name of the prefix is located\r
+ immediately before the symbol class. Class N is treated as an extension of\r
+ M, i.e., the object of class N has a compact frame consisting of the\r
+ attributes of N as well as the attributes of M:\r
+ \r
+ ---------------\r
+ ! !\r
+ ! ... ! M-attributes\r
+ ! !\r
+ --------------- - - - - - -\r
+ ! !\r
+ ! !\r
+ ! ... ! N-attributes\r
+ ! !\r
+ ---------------\r
+ \r
+ object of N\r
+ \r
+ The structure of such an object is determined by the class M as well as\r
+ by N (thus containing both M-attributes and N-attributes).\r
+ The statement\r
+ \r
+ X:=new N ,\r
+ \r
+ where X is a variable of type N, creates an object of class N.\r
+1 - 16 -\r
+ \r
+ \r
+ The sequences of statements of classes M and N are also concatenated. In\r
+ the sequence of statements of a class the keyword inner may occur anywhere,\r
+ but once only. The sequence of statements of N consists of the sequence of\r
+ statements of M with inner replaced by the sequence of statements of N\r
+ (inner in N is equivalent to an empty statement). If class N prefixes\r
+ another class P, then inner in N is replaced by the sequence of statements\r
+ of P, and so on. If inner does not occur explicitly, an implicit occurrence\r
+ of inner just before the final end of class is assumed.\r
+ \r
+ Prefixing allows the programmer to extend units. Assume, for instance,\r
+ that STACK is the data structure which defines a push-down memory:\r
+ \r
+ unit STACK :class;\r
+ ...\r
+ unit pop: function...\r
+ end;\r
+ ...\r
+ unit push: procedure...\r
+ end;\r
+ ...\r
+ begin\r
+ ...\r
+ end STACK;\r
+ \r
+ Any class prefixed by STACK inherits the operations on stack. For\r
+ instance, in a class declaration\r
+ \r
+ unit N: STACK class;\r
+ ...\r
+ begin\r
+ ...\r
+ call push;\r
+ ...\r
+ end ;\r
+ \r
+ the function pop and the procedure push may be used as any other local\r
+ attribute.\r
+ \r
+ A class may also be used to prefix blocks, procedures and functions. An\r
+ instance of a prefixed block is a compound object and is created upon entry\r
+ to the block and deallocated after its termination, as in the case of a\r
+ simple block. Similarly, an instance of a prefixed procedure (function) is\r
+ a compound object which is created when a procedure (function) is called\r
+ and deallocated after its termination.\r
+1 - 17 -\r
+ \r
+ \r
+ 2.6. Object deallocator\r
+ ***********************\r
+ \r
+ The classical methods used to deallocate class objects are based on\r
+ reference counters or garbage collection. Sometimes both methods may be\r
+ combined. The reference counter is a system attribute holding the number of\r
+ references pointing to the given object. Hence any change of the value of a\r
+ reference variable X is followed by a corresponding increase or decrease of\r
+ the value of its reference counter. When the reference counter becomes\r
+ equal to 0, the object can be deallocated.\r
+ \r
+ The deallocation of class objects may also occur during the process of\r
+ garbage collection. During this process all unreferenced objects are found\r
+ and removed (while memory may be compactified). In order to keep the\r
+ garbage collector able to collect all the garbage, the user should clear\r
+ all reference variables, i.e., set to none, whenever possible. This system\r
+ has many disadvantages. First of all, the programmer is forced to clear all\r
+ reference variables, even those which are of auxiliary character. Moreover,\r
+ the garbage collector is a very expensive mechanism and thus can be used\r
+ only in emergency cases.\r
+ \r
+ In LOGLAN-82 a dual operation to the object generator, the so-called\r
+ object deallocator is provided. Its syntactic form is as follows:\r
+ \r
+ kill(X)\r
+ \r
+ where X is a reference expression. If the value of X points to no object\r
+ (none) then kill(X) is equivalent to an empty statement. If the value of X\r
+ points to an object O, then after the execution of kill(X) the object O is\r
+ deallocated. Moreover, all reference variables which pointed to O are set\r
+ to none., This deallocator provides full security, i.e., the attempt to\r
+ access the deallocated object O is checked and results in a run-time error.\r
+ For example,\r
+ \r
+ Y:=X; kill(X); Y.W:=Z;\r
+ \r
+ causes the same run-time error as\r
+ \r
+ X:=none; X.W:=Z;\r
+ \r
+ The system of storage management is arranged in such a way that the\r
+ frames of killed objects may be immediately reused without the necessity of\r
+ calling the garbage collector, i.e., the relocation is performed\r
+ automatically.\r
+1 - 18 -\r
+ \r
+ \r
+ 2.7. Arrays\r
+ ***********\r
+ \r
+ LOGLAN-82's array is a kind of a class with indices instead of\r
+ identifiers selecting the attributes. A variable of an array type is a\r
+ reference variable pointing to an object which contains components of a\r
+ one-dimensional array. The components of such an array may also point to\r
+ one-dimensional arrays and so forth, hence multi-dimensional arrays may be\r
+ generated as well.\r
+ \r
+ The declaration of a variable Y of array type has the following form:\r
+ \r
+ var Y : array_of ... array_of T\r
+ \r
+ where the number of array_of defines the dimension of Y. The declaration of\r
+ a variable Y fixes its dimension, while the bound pairs are still\r
+ undetermined. The array generation statement has the form\r
+ \r
+ new_array Y dim (l : u)\r
+ \r
+ where l, u are arithmetic expressions determining the lower and upper\r
+ bounds of the first index. The object O of an array is generated and the\r
+ reference to O is assigned to Y.\r
+ \r
+ If Y is declared as a two-dimensional array, then one can generate a\r
+ two-dimensional array by means of the statements\r
+ \r
+ new_array Y dim (l:u);\r
+ \r
+ for i:=l to u\r
+ do\r
+ new_array Y(i) dim (li:ui)\r
+ od;\r
+ \r
+ where the shape of each row is determined by the bounds li, ui. Hence\r
+ triangular, tridiagonal, streaked arrays, etc. may be generated. Moreover,\r
+ the assignment statements allow us to interchange array references that are\r
+ of the same dimension and the same type, e.g. Y(i):=Y(j). In consequence,\r
+ the user may operate on array slices. The default value of any array\r
+ variable is none, as in the case of a reference variable.\r
+ \r
+1 - 19 -\r
+ \r
+ \r
+ 2.8. Parameters\r
+ ****************\r
+ \r
+ In LOGLAN-82 there are four categories of parameters: variable\r
+ parameters, procedure parameters, function parameters and type parameters.\r
+ \r
+ Variable parameters\r
+ -------------------\r
+ \r
+ Variable parameter transmission is simplified in comparison with ALGOL-60\r
+ and SIMULA-67. There are three transmission modes of variable parameters:\r
+ input mode, output mode and inout mode. In the syntactic unit which is a\r
+ procedure, a function or a class, the formal input parameters are preceded\r
+ by the symbol input, the formal output parameters are preceded by the\r
+ symbol output and the formal inout parameters are preceded by the symbol\r
+ inout. The default transmission mode is input. Input parameters are treated\r
+ as local variables initialized by the values of the corresponding actual\r
+ ones. Output parameters are treated as local variables initialized in the\r
+ standard manner (real with 0.0, integer with 0, reference with none, etc.).\r
+ Upon return their values are assigned to the corresponding actual\r
+ parameters, which in this case must be the variables. Inout parameters act\r
+ as input and output parameters together.\r
+ \r
+ Procedure and function parameters\r
+ ---------------------------------\r
+ \r
+ In LOGLAN-82 procedures and functions may also be formal parameters. This\r
+ category of parameters allows us to parametrize a unit with respect to some\r
+ operations. A formal procedure (function) has the full specification part,\r
+ i.e., the parameter list (and the function type), for instance :\r
+ \r
+ unit Bisec: procedure(function f(x: real): real; a, b, eps:real);\r
+ begin\r
+ ...\r
+ end;\r
+ \r
+ Type parameters\r
+ ---------------\r
+ \r
+ Types are also allowed to be transmitted as parameters. This kind of\r
+ parameters enables us to parametrize a unit with respect to some types. For\r
+ instance consider the following declaration:\r
+ \r
+ unit sort:procedure(type T;A:arrayof T; function less(x, y:T):boolean);\r
+ begin\r
+ ...\r
+ end\r
+ \r
+ The actual parameter corresponding to the formal T must be a\r
+ non-primitive type. The array A must be the array of elements of the actual\r
+ type.\r
+ If function less defines the ordering relation on the elements of the\r
+ actual type, then this procedure may be invoked to sort the array A.\r
+1 - 20 -\r
+ \r
+ \r
+ 2.9. Coroutines\r
+ ***************\r
+ \r
+ Coroutine is a generalization of class. A coroutine object is an object\r
+ whose sequence of statements can be suspended and reactivated in the\r
+ programmed manner. The generation of a coroutine object terminates with the\r
+ execution of the return statement (then the control is passed to the caller\r
+ as in the case of classes). A coroutine object after the execution of the\r
+ return statement is suspended. A suspended coroutine object may be\r
+ reactivated with the help of the attach statement:\r
+ \r
+ attach(X)\r
+ \r
+ where X is a reference variable designating the activating object.\r
+ \r
+ In general, from the moment of generation a coroutine object is either\r
+ active or suspended. Any reactivation of a suspended coroutine object O\r
+ causes the active coroutine object to be suspended and continues the\r
+ execution of O from the statement following the last executed one.\r
+ \r
+ During a coroutine execution some other unit instances may be generated.\r
+ They are dynamically dependent on that coroutine object. Thus, an active\r
+ coroutine (in particular the main program) can be illustrated by the\r
+ following chain:\r
+ \r
+ -------- -------- --------\r
+ ! O[k] ! ---> !O[k-1]! --->...---> ! O[1] !--->\r
+ -------- -------- --------\r
+ coroutine head\r
+ \r
+ where the arrows denote the DL-links.\r
+ \r
+ This DL-chain is transformed into the DL-cycle when the control is\r
+ transferred to another coroutine as the result of the attach statement.\r
+ \r
+ -------- -------- --------\r
+ ! O[k] ! ---> !O[k-1]! --->...---> ! O[1] !--->\r
+ -------- -------- -------- !\r
+ ! !\r
+ <----------------------------------------------!\r
+ \r
+ \r
+1 - 21 -\r
+ \r
+ \r
+ 2.10. Processes\r
+ ***************\r
+ \r
+ The concept of process in LOGLAN-82 is a natural extension of coroutine.\r
+ Coroutines are units which once generated may operate independently, each\r
+ one treated as a separate process. For coroutines, however, an essential\r
+ assumption is established; namely, when one coroutine object is activated,\r
+ the active one must be suspended. When processes are used, the activation\r
+ of a new process does not require the active one to be suspended. Thus\r
+ during a program's execution many processes may be active simultaneously.\r
+ Their statements are computed in parallel.\r
+ There are two operations, stop and resume, which concern the control of\r
+ processes.\r
+ \r
+ stop Operation which causes the active process to be\r
+ stopped.\r
+ resume(X) Operation which reactivates the process referenced by X.\r
+ \r
+ Synchronization and scheduling.\r
+ \r
+ Elementary synchronization in LOGLAN-82 is achieved by two-valued\r
+ semaphores and a number of simple indivisible statements operating on them.\r
+ These statements are the following (where Z denotes a variable of semaphore\r
+ type):\r
+ \r
+ \r
+ ts(Z) Test-and-set boolean function which closes semaphore Z\r
+ and returns the value true if Z was open and false if Z\r
+ was closed.\r
+ lock(Z) Operation which tests the value of the semaphore Z and\r
+ either enables the given process to enter the critical\r
+ region guarded by Z (if Z is open) or suspends the\r
+ process (in the opposite case) until another one opens\r
+ that critical region.\r
+ unlock(Z) Operation the execution of which opens the critical\r
+ region guarded by Z.\r
+ stop(Z) Operation that opens the critical region guarded by Z\r
+ and stops the execution of the given process.\r
+ \r
+ The above operations are implemented in the kernel of the operating\r
+ system. One can use them to define any complex synchronization facility,\r
+ e.g., monitors (cf. 11.3.). Once defined and stored in the library, the\r
+ facility can be used by any user. Moreover, using the high level\r
+ synchronizing tools, the user can cover the low level, primitive ones\r
+ (therefore the properties of high level tools cannot be disturbed).\r
+ \r
+ There is also a parameterless function wait. If wait is called in the\r
+ given process X, then process X waits for the termination of any of its son\r
+ (a son of X is a process which was generated in X). The returned value of\r
+ wait points to the first terminated son, and then, the computation of\r
+ process X is continued. If there is no such son, the returned value of wait\r
+ is none.\r
+1 - 22 -\r
+ \r
+ \r
+ 2.11. Other important features\r
+ ******************************\r
+ \r
+ In LOGLAN-82 the access control mechanism is enlarged so that it supports\r
+ the data encapsulation technique and the protection of attributes in\r
+ different environments. The mode of accessibility to attributes of a class\r
+ can be controlled by means of the specification hidden and close. On the\r
+ other hand, the mode of accessibility to attributes of a unit that are\r
+ inherited from its prefix can be controlled by means of the specifification\r
+ taken. This permits more flexible communication across the unit boundary as\r
+ well as defining of abstract behaviour with a hidden auxiliary structure.\r
+ (For details see 6).\r
+ \r
+ The language provides facilities for dealing with run time errors and\r
+ other exceptional situations raised by the user. These events are called\r
+ exceptions. So, the exceptions cause interruption of a normal program\r
+ execution. The response to an exception is defined by an exception handler.\r
+ The user is allowed to define the actions that should be raised when an\r
+ exception is encountered.\r
+ (For details see 10).\r
+ \r
+ Program units can be compiled separately. Two kinds of separately\r
+ compiled units are provided: binary items ready to be executed, and library\r
+ items. The purposes of separate compilation are the following: creating\r
+ user libraries, handling system and user libraries, compiling program\r
+ components during program testing, and program overlaying.\r
+ (For details see 12).\r
+ \r
+ Input-output facilities and file processing are defined by means of some\r
+ simple primitives. The user is able, however, to declare in the language\r
+ any class that provides high-level and secure file operations. Examples of\r
+ system classes that deal with high-level file operations are also given.\r
+ (For details see 13).\r
+1 - 23 -\r
+ \r
+ \r
+ 3. Lexical and textual structure\r
+ ################################\r
+ \r
+ \r
+ The basic character set consists of\r
+ \r
+ (a) 26 upper case letters:\r
+ \r
+ a b c d e f g h i j k l m n o p q r s t u v w x y z\r
+ \r
+ (b) 10 digits:\r
+ \r
+ 0 1 2 3 4 5 6 7 8 9\r
+ \r
+ (c) 16 auxiliary characters:\r
+ \r
+ . : , ; _ = / + - * < > ' " ( )\r
+ \r
+ (d) the space character\r
+ \r
+ This set can be extended with the following characters:\r
+ \r
+ (e) lower case letters\r
+ \r
+ (f) other special ASCII characters, e.g.:\r
+ \r
+ # $ ? % ^\r
+ \r
+ (lower case letters are equivalent to the corresponding upper case ones.)\r
+ \r
+ A finite sequence of characters is called a word. The words called\r
+ identifiers have a special meaning. They are composed of letters, digits,\r
+ and underscores and start with a letter:\r
+ \r
+ \r
+ \r
+ <identifier>:\r
+ \r
+ ----------> <letter> -------------------------->\r
+ ^ ^ !\r
+ ! ! !\r
+ !---> <digit> ----> ! !\r
+ ! !\r
+ ! !\r
+ !--- _ -----> !\r
+ ! ! !\r
+ <-------------------------------\r
+ \r
+ \r
+ \r
+1 - 24 -\r
+ \r
+ \r
+ Identifiers serve to identify program entities, i.e., constants, variables,\r
+ types, functions, procedures, classes, coroutines and processes. There are\r
+ a certain number of predefined system identifiers which have special\r
+ significance in the language. The following system identifiers are reserved\r
+ words (these identifiers cannot be declared by the programmer).\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ and_if detach if od taken\r
+ and dim in open terminate\r
+ array_of div inner or then\r
+ attach do input or_if this\r
+ downto inout others to\r
+ is output type\r
+ begin else\r
+ block end kill pref unit\r
+ esac procedure unlock\r
+ exit last_will process\r
+ lock put var\r
+ call fi virtual\r
+ case for main qua\r
+ class function mod wait\r
+ close raise wind\r
+ const get new read when\r
+ copy new_array repeat while\r
+ coroutine hidden none repeat write\r
+ handlers not return writeln\r
+ \r
+ signal\r
+ step\r
+ stop\r
+ \r
+ \r
+ \r
+1 - 25 -\r
+ \r
+ \r
+ The lexical entities are identifiers, numbers, strings and delimiters.\r
+ The delimiters from the basic character set are:\r
+ \r
+ , ; = / + - * > < . ( ) :\r
+ \r
+ and the compound symbols are :\r
+ \r
+ =/= >= <= :=\r
+ \r
+ Spaces play the role of separators, i.e., at least one space must\r
+ separate adjacent identifiers or numbers. The end of each line is\r
+ equivalent to a space.\r
+ \r
+ A comment starts with a left parenthesis and an asterisk and is\r
+ terminated by an asterisk and a right parenthesis. It may only appear\r
+ following a lexical unit or at the beginning or end of a program entity.\r
+ Comments have no effect on the meaning of a program and are used solely for\r
+ program documentation.\r
+ \r
+ By an identifier definition we mean a declaration or description in the\r
+ list of formal parameters.\r
+ \r
+ The notion of a unit is explained by the following diagram:\r
+ \r
+ \r
+ ---------------------- unit ----------------------\r
+ ! ! !\r
+ ! ! !\r
+ ! ! !\r
+ -----subprogram---- generalized class !\r
+ ! ! ! ! ! !\r
+ ! ! ! ! ! !\r
+ function procedure class coroutine process block\r
+1 - 26 -\r
+ \r
+ \r
+ 4. Types\r
+ ########\r
+ \r
+ \r
+ A type T determines a set !T! of values and a family of operations\r
+ applicable to the elements of the set. Three kinds of types are\r
+ distinguished: primitive types, system types and compound types. Variables\r
+ may be declared to be of type T. Depending on the kind of type T we have to\r
+ distinguish two cases.\r
+ \r
+ \r
+ a) T is a primitive type. The value assigned to a variable Y of type\r
+ T must belong to the set !T!.\r
+ \r
+ \r
+ b) T is a compound or system type. The value assigned to a variable\r
+ Y of type T must be a reference pointing to an object in the set\r
+ !T! (for the notion of reference cf 4.3. and 6.3.)\r
+ \r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <type identifier>:\r
+ \r
+ -----> <primitive type> ------>\r
+ ! ^\r
+ !-> <system type> ----->!\r
+ ! !\r
+ !-> <compound type> --->!\r
+ ! !\r
+ !-> <formal type> ----->!\r
+ ! !\r
+ !-> <file type> ------->!\r
+ \r
+ \r
+ \r
+ Primitive and system types are pre-defined, compound types are defined by\r
+ the user. For file type see section 13.\r
+1 - 27 -\r
+ \r
+ \r
+ 4.1. Primitive types\r
+ ********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <primitive type>:\r
+ \r
+ -----> integer -------->\r
+ ! ^\r
+ !---> real ---->!\r
+ ! !\r
+ !--> boolean -->!\r
+ ! !\r
+ !-> character -->!\r
+ ! !\r
+ !---> string -->!\r
+ ! !\r
+ !-> semaphore -->!\r
+ \r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ A primitive type determines a finite set of values which can be effectively\r
+ represented in a computer memory:\r
+ \r
+ !integer! - a subset of integers;\r
+ !real! - a subset of reals;\r
+ !boolean! - the set consisting of logical values T (true) and F (false);\r
+ !semaphore! - the set consisting of two values (closed and open);\r
+ !character! - a set of characters;\r
+ !string! - a subset of strings;\r
+ \r
+ These sets will be precisely defined in a concrete implementation. The\r
+ way in which the primitive type values are represented in a computer memory\r
+ is not essential for the description of semantics; however, the values of\r
+ integer and real types are differently represented. Namely, integers are\r
+ represented in the fixed-point form with a point after the last significant\r
+ digit, reals are represented in the floating-point form. So they will be\r
+ denoted differently, e.g., 2 and 2.0. Those values can be mutually\r
+ converted: the value of type integer is converted to type real by means of\r
+ conversion into the floating point form; the conversion into the opposite\r
+ direction truncates and transforms the real value into the fixed-point\r
+ form.\r
+1 - 28 -\r
+ \r
+ \r
+ 4.2. System types\r
+ #################\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <system type>:\r
+ \r
+ --------> coroutine -------->\r
+ ! ^\r
+ !----> process --->!\r
+ \r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The set !coroutine! is equal to the union of sets !T! for every type T\r
+ declared as:\r
+ \r
+ - unit T : coroutine\r
+ - unit T : process\r
+ - unit T : S class\r
+ where !S! is already a subset of the set !coroutine!.\r
+ \r
+ The set !process! is equal to the union of sets !T! for every type T\r
+ declared as:\r
+ \r
+ - unit T : process\r
+ - unit T : S class\r
+ where !S! is already a subset of the set !process!.\r
+ \r
+ The user may declare a variable of coroutine (process) type, e.g. of the\r
+ form\r
+ \r
+ var X : coroutine;\r
+ (var X : process;)\r
+ \r
+ and then to assign:\r
+ X:=new T\r
+ \r
+ where T belongs to the set !coroutine! (!process!).\r
+ \r
+ The main block belongs to both sets - !coroutine! and !process!. The\r
+ system variable main gives the reference to the main block. The variable\r
+ main may occur in the statements attach(main) and resume(main) only.\r
+1 - 29 -\r
+ \r
+ \r
+ 4.3. Compound types and objects\r
+ *******************************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <compound type>:\r
+ \r
+ --------> <array type> ---------->\r
+ ! ^\r
+ !----> <class type> --->!\r
+ \r
+ 4.3.1. Array type\r
+ *****************\r
+ \r
+ \r
+ Objects of array type will be called array objects or shortly arrays. An\r
+ array can be considered as a vector; the access to its components is\r
+ provided by means of indexing.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <array type>:\r
+ \r
+ ------> array_of -----> <type identifier> ---->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ LOGLAN-82 types can be uniformly denoted in the following way\r
+ \r
+ \r
+ !! array_of ... array_of T for i>0\r
+ !! i - times\r
+ (array_of)<i>T= !!\r
+ !!\r
+ !! T for i=0\r
+ \r
+ where T is a type identifier.\r
+ \r
+ For i>0, the set !(array_of)<i>T! consists of the array objects. Every\r
+ array object has the attributes accessed via indices l, l+1, ..., u where\r
+ l, u are the values of the lower and upper bounds, respectively, and l<=u.\r
+ The attributes with the indices l, ..., u are of type (array_of)<i-1>T.\r
+ \r
+ Let O be an arbitrary fixed array object and let Y be a variable whose\r
+ value points to O. The operations related to the object O are:\r
+ \r
+ - Y(j), where l<=j<=u, gives the j-th attribute of the object O,\r
+ - lower(Y) and upper(Y), which give the value l and u,\r
+ respectively.\r
+1 - 30 -\r
+ \r
+ \r
+ 4.3.2. Class type\r
+ *****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <class type>:\r
+ \r
+ -----> <class identifier> ----->\r
+ \r
+ \r
+ <class identifier>:\r
+ \r
+ ------> <identifier> ---------->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ A class T is a description of a data structure consisting of attributes\r
+ i.e., types, functions, procedures, variables, and a sequence of\r
+ statements. The family of admissible operations on the objects from the set\r
+ !T! contains the operations defined in the sequence of statements and those\r
+ defined in the declarations of functions and procedures. The other\r
+ operations are related to the notion of remote access. They allow us to\r
+ operate on the objects of type !T! from outside of them.\r
+ \r
+ \r
+ \r
+ 4.4. Formal types\r
+ *****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <formal type>:\r
+ \r
+ -----> <formal type identifier> ----->\r
+ \r
+ \r
+ <formal type identifier>:\r
+ \r
+ -----> <identifier> ------------------>\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ A formal type is a formal parameter of a unit and can be treated as the\r
+ name of an abstract data structure without any attribute. The corresponding\r
+ actual type must be a system type or a compound type. The set of objects of\r
+ the formal type T from a dynamic object O is equal to the set of objects of\r
+ the actual type which occurs in the actual parameter list of O.\r
+1 - 31 -\r
+ \r
+ \r
+ 5. Declarations\r
+ ###############\r
+ \r
+ \r
+ Every identifier which is to be used in a program must be defined. System\r
+ identifiers are pre-defined, other identifiers are pre-compiled, (see 12.)\r
+ or they are defined by means of a declaration or description in the formal\r
+ parameter list. LOGLAN-82 is not strongly typed in the sense that sometimes\r
+ the type of variable and function value cannot be determined at compilation\r
+ time. The user may balance the generality and convenience given by the\r
+ formal types mechanism and the risk of reduced efficiency of his program\r
+ execution. The compiler option, however, allows us to supress the run time\r
+ checking with respect to the type compatibility.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <declaration>:\r
+ \r
+ ------> <constant declaration> -------->\r
+ ! ^\r
+ !--> <variable declaration> -->!\r
+ ! !\r
+ !--> <unit declaration> ------>!\r
+ ! !\r
+ !--> <signal declaration> ---->!\r
+ ! !\r
+ !--> <linked item specific.>-->!\r
+ \r
+ \r
+ (For the definition of a signal declaration see 10.\r
+ For the definition of linked item specification see 12.)\r
+ \r
+ \r
+ 5.1. Constant declaration\r
+ *************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <constant declaration>:\r
+ \r
+ --> const ---> <identifier> ---> = ---> <expression> ------------------->\r
+ ! !\r
+ <------------------------ , ---------------------\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The expression defining the constant must be determinable at compilation\r
+ time. The type and the value of the constant is given by its declaration.\r
+ They are always primitive.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ const pi=3.1415926, pihalf=pi/2;\r
+ \r
+1 - 32 -\r
+ \r
+ \r
+ 5.2. Variable declaration\r
+ *************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <variable declaration>:\r
+ \r
+ ---> var ---><specification list>--->\r
+ \r
+ \r
+ <specification list>:\r
+ \r
+ ----> <identifier list> ---> : ---> <type identifier> ------>\r
+ ^ !\r
+ !<------------------ , <--------------------------------!\r
+ \r
+ \r
+ <identifier list>:\r
+ \r
+ -----> <identifier> ------->\r
+ ^ !\r
+ !<---- , <---------!\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ A variable is of a type given in a variable declaration. A declaration is\r
+ elaborated at the instant of generation of a unit object which contains\r
+ that declaration. An elaboration determines an initial value for every\r
+ variable. This value depends on the type identifier :\r
+ \r
+ integer - 0\r
+ real - 0.0\r
+ boolean - F\r
+ semaphore - open\r
+ character and string - defined in concrete implementation\r
+ any compound and system type- none\r
+ \r
+ The value of the variable may be modified by means of an assignment\r
+ statement (see 9.1.1.), but the variables of type T may only point to the\r
+ object from the set !T!.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ var left, right: node, counter: integer, cycle: array_of boolean;\r
+ \r
+ \r
+1 - 33 -\r
+ \r
+ \r
+ 5.3. Unit declaration\r
+ *********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <unit declaration>:\r
+ \r
+ ----> unit -------> <class declaration> ---------------------->\r
+ ! !\r
+ !----> <subprogram declaration> --->!\r
+ \r
+ \r
+ 5.3.1. Class declaration (introduction)\r
+ ***************************************\r
+ \r
+ \r
+ A class declaration is understood as a declaration of a class itself, as\r
+ well as a declaration of a coroutine or a process. The prefixing will be\r
+ described in 5.3.4..\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <class declaration>:\r
+ \r
+ ----------><class identifier> : ---> <prefix> -----> class ----->!\r
+ ! ^ !\r
+ ------------->!-><system type>->!\r
+ !\r
+ !<------------------------------------------------------------!\r
+ ! !\r
+ !-> <formal parameter list> ------------------------------->!\r
+ !\r
+ !<------------------------------ ; ----------!\r
+ !\r
+ !--> <class body> ----------------------------->\r
+ ! ^\r
+ !-> <class identifier> ->!\r
+ \r
+ \r
+ <prefix>:\r
+ \r
+ ----------------> <class identifier> ------>\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ unit complex: class(re, im:real);\r
+ var module:real;\r
+ begin\r
+ module:=sqrt(re*re+im*im)\r
+ end ;\r
+1 - 34 -\r
+ \r
+ \r
+ 5.3.2. Subprogram declaration (introduction)\r
+ ********************************************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <procedure declaration>:\r
+ \r
+ --> virtual --> <procedure identifier>--> : --><prefix> ---> procedure\r
+ ! ^ ! ^ !\r
+ !----------! !------------! !\r
+ !\r
+ <-------------------------------------------------------!\r
+ ! !\r
+ !--> <formal parameter list> -------------------------->!\r
+ !\r
+ <------------------------- ; ---------------------!\r
+ !\r
+ !--> <subprogram body> ------------------------------>\r
+ ! ^\r
+ !-> <procedure identifier>->!\r
+ \r
+ \r
+ \r
+ <procedure identifier> :\r
+ \r
+ ---- <identifier> ------->\r
+ \r
+ \r
+ <function declaration>:\r
+ \r
+ --> virtual --> <function identifier>--> : --> <prefix> --> function\r
+ ! ^ ! ^ !\r
+ !----------! !-----------! !\r
+ !\r
+ !<------------------------------------------------------------!\r
+ ! !\r
+ !-> <formal parameter list> ---------> : ----> <type identifier>->\r
+ !\r
+ !<-------------------- ; ----------------------------!\r
+ !\r
+ !-> <subprogram body> ------------------------------->\r
+ ! ^\r
+ !-> <function identifier>->!\r
+ \r
+ \r
+ \r
+ <function identifier>:\r
+ \r
+ -----> <identifier> ---------->\r
+ \r
+ \r
+ \r
+ \r
+ Class (function, procedure) identifier may optionally follow the end\r
+ symbol (and if present must match the unit name).\r
+1 - 35 -\r
+ \r
+ \r
+ Example.\r
+ --------\r
+ \r
+ unit Euclid: function(n, m:integer):integer;\r
+ var k:integer;\r
+ begin\r
+ do\r
+ k:=n mod m;\r
+ if k=0 then result:=m; return fi;\r
+ n:=m; m:=k;\r
+ od;\r
+ end Euclid;\r
+ \r
+ \r
+ \r
+ 5.3.3. Block\r
+ ************\r
+ \r
+ \r
+ In order to complete the description of LOGLAN-82 units the block syntax\r
+ is given here, however the occurrence of a block results in the execution\r
+ of its statements - see 9.1.2..\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <block>:\r
+ \r
+ --> pref --> <prefix> ---> <actual parameter list> ---> block ---->\r
+ ! ^ ^ !\r
+ !-------------------->!--------------------------->! !\r
+ !\r
+ !<------------------------------------------!\r
+ !\r
+ !--> <subprogram body>------>\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ block\r
+ var a, b, c, p, S:real;\r
+ begin\r
+ read(a, b, c);\r
+ p:=(a+b+c)/2;\r
+ S:=sqrt(p*(p-a)*(p-b)*(p-c));\r
+ write(S)\r
+ end\r
+1 - 36 -\r
+ \r
+ \r
+ 5.3.4. Prefixing\r
+ ****************\r
+ \r
+ \r
+ A unit which is a specialized form of a certain class (i.e., which has\r
+ all the properties of that class and some additional properties defined in\r
+ the unit) can be defined by means of prefixing. An identifier of the\r
+ prefixed unit may serve as a prefix for another unit, and so tree\r
+ structured hierarchies of units can be created. By a prefix sequence of a\r
+ unit M we mean a sequence M1, ..., Mk of units such that Mk = M, the unit\r
+ M1 has no prefix; for i = 1, ..., k-1, the unit Mi+1 is prefixed by Mi. Any\r
+ unit may be prefixed by a class without changing its character (e.g., a\r
+ prefixed procedure still remains a procedure). Procedures, functions, and\r
+ blocks cannot be used as prefixes. Process and coroutine, as special cases\r
+ of class, may also serve as prefixes, but not for procedures, functions or\r
+ blocks.\r
+ \r
+ If a coroutine (a process) occurs in a prefix sequence of a unit then\r
+ this unit is treated as a coroutine (a process), and so it has all the\r
+ properties of a coroutine (a process). Therefore, if a prefix sequence of a\r
+ unit M contains both a coroutine and a process then M has the properties of\r
+ a coroutine as well as those of a process.\r
+ \r
+ No unit is allowed to occur more than once in its prefix sequence.\r
+ \r
+ Put T pref* S if a unit T belongs to the prefix sequence of the unit S.\r
+ Unit S is called a subunit of unit T. As one can see from the definition of\r
+ object, any object of S has the attributes of the units S and T. Moreover,\r
+ the statements of that object come from the body of the unit T as well as\r
+ from that of the unit S.\r
+ \r
+ From the way of implementation it follows that prefixing is not a\r
+ macro-definition and so it does not require any pre-processing.\r
+1 - 37 -\r
+ \r
+ \r
+ 5.3.5. Formal parameters\r
+ ************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <formal parameter list>:\r
+ \r
+ ---> ( -----> <input parameters> ---------------> ) ---->\r
+ ^ ! ^ !\r
+ ! !--> <output parameters> -->! !\r
+ ! ! ! !\r
+ ! !--> <inout parameters> --->! !\r
+ ! ! ! !\r
+ ! !--> <type parameters> ---->! !\r
+ ! ! ! !\r
+ ! !--> <procedure parameter>->! !\r
+ ! ! ! !\r
+ ! !--> <function parameter> ->! !\r
+ ! !\r
+ !<----------- ; <------------------!\r
+ \r
+ \r
+ <input parameters>:\r
+ \r
+ ----> input -----> <specification list> ------->\r
+ ! ^\r
+ !----------->!\r
+ \r
+ \r
+ <output parameters>:\r
+ \r
+ ----> output ----> <specification list> ------->\r
+ \r
+ \r
+ <inout parameters>:\r
+ \r
+ ----> inout ----> <specification list> ------->\r
+ \r
+ \r
+ <type parameters>:\r
+ \r
+ ----> type ------> <identifier list> ----------->\r
+ \r
+ \r
+1 - 38 -\r
+ \r
+ \r
+ <procedure parameter>:\r
+ \r
+ ----> procedure ---> <procedure identifier> ---->!\r
+ !\r
+ !<-----------------------------------------!\r
+ !\r
+ !---> <formal parameter simp. list> ------>\r
+ ! ^\r
+ !----------------------------------->!\r
+ \r
+ <function parameter>:\r
+ \r
+ ---> function --> <function identifier> ------>!\r
+ !\r
+ !<----------------------------------------------!\r
+ !\r
+ !--> <formal parameter simp. list> --> : --> <type identifier> -->\r
+ ! ^\r
+ !-------------------------------->!\r
+ \r
+ \r
+ <formal parameter simp. list>:\r
+ \r
+ -------> ( --------> <input parameters> -----------------> ) ----->\r
+ ^ ! ^ !\r
+ ! !--> <output parameters> ->! !\r
+ ! ! ! !\r
+ ! !--> <inout parameters> -->! !\r
+ ! ! ! !\r
+ ! !--> <type parameters> --->! !\r
+ ! ! ! !\r
+ ! !-> <proc. simp. param.>-->! !\r
+ ! ! ! !\r
+ ! !--> <func. simp. param.>->! !\r
+ ! !\r
+ <----------------- ; <-------------------!\r
+ \r
+ \r
+ <procedure simp. parameter>:\r
+ \r
+ ----> procedure -----> <procedure identifier> ------>\r
+ \r
+ \r
+ <function simp. parameter>:\r
+ \r
+ ----> function -------> <function identifier> ------->\r
+1 - 39 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ \r
+ By a formal parameter list of a unit M we shall mean a concatenated list\r
+ of formal parameters of the bodies of all units M1, ...., Mk = M from the\r
+ prefix sequence of unit M (successively from 1 to k). The parameters\r
+ occurring in a unit declaration are called formal parameters to stress that\r
+ they constitute a pattern for parameters occurring in the unit body. At the\r
+ instant of object generation the actual parameters for this generation are\r
+ fixed. The relations between formal and actual parameters depend on the\r
+ transmission mode which is specified in the formal parameter list.\r
+ \r
+ Those relations make possible the communication between a unit and its\r
+ environment. The first mode of transmission rectricts the communication to\r
+ the input (as the beginning of the body) of the actual parameter value for\r
+ the corresponding formal parameter. The second mode restricts the\r
+ communication to the output (as the end of the body) of the formal\r
+ parameter value for the corresponding actual parameter. The third mode\r
+ possesses both possibilities of the input and output transmission modes. In\r
+ all three cases, the formal parameters are considered to be declared in the\r
+ unit body.\r
+ \r
+ The next two modes of transmission are designed for subprograms and\r
+ types. The occurrence of a formal subprogram/type in the unit body is\r
+ matched with the corresponding actual subprogram/type (which is assigned at\r
+ the beginning of the body execution). In the case of a formal subprogram, a\r
+ simplified description of its parameters is required.\r
+ \r
+ Hence a LOGLAN-82 unit may be parametrized and designates the union of\r
+ all units definable by assigning specific actual types to the formal ones.\r
+ The actual type cannot be a primitive one. Parametrized units make possible\r
+ the design of universal algorithms, which will be defined in detail at\r
+ lower levels of program nesting.\r
+1 - 40 -\r
+ \r
+ \r
+ 5.3.6. Unit body\r
+ ****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <class body>:\r
+ \r
+ ---> <inheritance list> ---> <protection list> ---> <body> ----->\r
+ ! ^ ! ^\r
+ !--------------------->! !------------------->!\r
+ \r
+ \r
+ <subprogram body>:\r
+ \r
+ ----> <inheritance list> ------> <body> ------>\r
+ ! ^\r
+ !---------------------->!\r
+ \r
+ \r
+ <inheritance list>:\r
+ \r
+ ----> taken -----> <identifier list> -----> ; ---->\r
+ ! ^\r
+ !-----------------------!\r
+ \r
+ \r
+ <protection list>:\r
+ \r
+ ------------> hidden -------------------> <identifier list> --> ; --->\r
+ ! ! !\r
+ !---------> close ------------>! !\r
+ ! !\r
+ !<--------------------------------------------------------------!\r
+ \r
+ \r
+ \r
+ <body>:\r
+ \r
+ ----> <declaration list> ---->!\r
+ ! !\r
+ <handlers' declaration> ---> begin --> <statement list> --> end -->\r
+ ! ^\r
+ !---------------------------!\r
+1 - 41 -\r
+ \r
+ \r
+ <declaration list>:\r
+ \r
+ !------------------------------------>!\r
+ ! !\r
+ --------> <declaration> -------> ; ---------------->\r
+ ^ !\r
+ !<------------------------------!\r
+ \r
+ \r
+ <statement list>:\r
+ \r
+ ------> <statement > ------->\r
+ ^ !\r
+ !<----- ; ------------!\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ In a unit body, a sequence of statements (if any) starts from the begin\r
+ symbol. Declarations/statements are separated by semicolons. An execution\r
+ of the unit body begins at the time of the generation of an object (of that\r
+ unit), see 9.1.2.. A declaration of a unit M is restricted at several\r
+ points :\r
+ \r
+ Restrictions\r
+ ------------\r
+ \r
+ (i) The least (textual) unit containing an occurrence of a\r
+ control statement inner (see 9.1.3.) must be a generalized\r
+ class. An inner statement may occur in the class body at\r
+ the most once. If it does not occur explicitly then the\r
+ body of unit M is assumed to contain the inner statement as\r
+ the last one (preceding the end symbol).\r
+ \r
+ (ii) All identifiers defined in the body of unit M are\r
+ different.\r
+ \r
+ (iii) The input/output formal parameters of unit M cannot be of a\r
+ type declared in unit M.\r
+ \r
+ (iv) If a type T is a formal parameter of unit M then its\r
+ occurrence in the list of parameters must precede the\r
+ occurrences of other parameters whose description makes use\r
+ of T;\r
+1 - 42 -\r
+ \r
+ \r
+ 6. Static and dynamic locations of identifiers. Visibility rules.\r
+ #################################################################\r
+ \r
+ \r
+ As noted before, a non-system identifier used in a program must be\r
+ defined in the program by a declaration or by a description in a formal\r
+ parameter list. An identifier need not correspond, however, to only one\r
+ syntactic entity. A program is composed of units, and so the user designing\r
+ a unit must pay attention to the relationship between a given unit and the\r
+ other ones. He should feel free to define his own attributes with the same\r
+ identifiers as those used in the other units as long as he is not\r
+ interested in the entities they describe. Therefore some strict rules of\r
+ correspondence between the identifier and the attribute as well as its\r
+ valuation are necessary. The first correspondence is called the static\r
+ location of an identifier, and the second is called the dynamic location.\r
+ The static location is determined by the syntactic structure of a program.\r
+ The dynamic location depends on the dynamic configuration of objects.\r
+ \r
+ \r
+ 6.1. Unit attributes\r
+ *********************\r
+ \r
+ \r
+ A set of attributes is assigned to each unit M. This set consists of all\r
+ syntactic entities defined in M and in the prefix sequence of M. Most of\r
+ them form the set of attributes which belong to each object of the unit,\r
+ i.e., they are dynamic. Virtual functions and procedures are attributes of\r
+ a very special kind. They are presented separately in 6.4.1. Some other\r
+ attributes, like constants, are static, i.e., they are not attrributes of\r
+ the objects of the unit but of the unit itself. Therefore static attributes\r
+ cannot be accessed by means of dot notation (cf 8.2.3.).\r
+ The user may protect attributes. The protection mechanisms are introduced\r
+ in the following sections and discussed in 8.2.3.\r
+ LOGLAN-82 identifiers cannot be overloaded, i.e., an identifier used in\r
+ the given unit corresponds to "exactly one" attribute determined by the\r
+ context. However, identifiers may be redefined. Therefore strict\r
+ correspondence between the occurrences of the identifiers and the\r
+ attributes must de defined.\r
+ Let W be a syntactic entity and M a syntactic unit. We say that W is\r
+ defined in M iff W is a formal parameter of M (but not of the prefix of M)\r
+ or W is declared in M. If W is defined in M, the entity it denotes is the\r
+ meaning of W. From now on we shall use interchangeably the notions of an\r
+ identifier and of an attribute.\r
+ Let W be an identifier and M a unit. If W is defined in M or in a unit\r
+ from M's prefix sequence, then W corresponds to an attribute of M. More\r
+ precisely, the corresponding attribute is the one defined in M, if it\r
+ exists, or the one defined in the prefix sequence. That means that the\r
+ redefinition of an identifier in a prefixed unit covers the attribute\r
+ corresponding to that identifier.\r
+1 - 43 -\r
+ \r
+ \r
+ 6.2. Protected attributes\r
+ *************************\r
+ \r
+ Let us consider a declaration of a prefixed unit. Let M be such a unit\r
+ and N its prefix. The attributes of N are visible in M (unless covered by\r
+ the local redefinition). The user, however, can restrict the use of N's\r
+ attributes in M. The protection may be specified already in unit N as well\r
+ as in M. The first way corresponds to the hidden specification while the\r
+ second to the taken specification.\r
+ \r
+ \r
+ 6.2.1. Hidden attributes\r
+ ************************\r
+ \r
+ \r
+ A list of hidden attributes is a filter from the prefixing unit. The user\r
+ may specify within prefix N the attributes whose occurrence is illegal in\r
+ any unit prefixed by N (unless the identifiers of these attributes are\r
+ covered by the redeclarations). Remote access to such attributes is\r
+ forbidden as well (cf 6.2). The absence of hidden specification denotes the\r
+ empty list.\r
+ Consider an example:\r
+ \r
+ unit N : class;\r
+ hidden x, y, z;\r
+ var x, y, z:integer;\r
+ ...\r
+ end N;\r
+ \r
+ unit M:N class;\r
+ hidden x, t;\r
+ var x, y, t:integer;\r
+ ...\r
+ end M;\r
+ \r
+ Variables x, y declared in N are redeclared in M, and so the identifiers\r
+ x, y in M refer to the local entities. Variable t is declared in M and is\r
+ hidden in the units prefixed by M. Variable z is hidden in N, hence it\r
+ cannot be used in M.\r
+1 - 44 -\r
+ \r
+ \r
+ 6.2.2. Taken attributes\r
+ ***********************\r
+ \r
+ \r
+ The list of taken attributes is a filter on the prefixed unit. In unit M\r
+ the user may specify explicitly the attributes from prefix N which are used\r
+ in M. Then in M the only attributes accessible from N are those from the\r
+ taken list. The occurrence of another attribute from N in M's body is\r
+ illegal. The absence of taken specification denotes the list of all (legal\r
+ and not hidden) identifiers from N. This means that the user is not\r
+ interested in the specification of this kind of filtering.\r
+ The identifiers in the taken list must be defined in the prefix sequence,\r
+ not in unit M. An exception is an identifier of a virtual attribute (cf\r
+ 6.4.).\r
+ \r
+ \r
+ 6.2.3. Legal and illegal identifiers\r
+ ************************************\r
+ \r
+ In this section we consider only identifiers corresponding to the\r
+ attributes of a given unit.\r
+ \r
+ All identifiers defined in a unit are legal in that unit. In particular,\r
+ all identifiers declared in a non-prefixed unit are legal.\r
+ \r
+ Now let M be a unit, N its prefix and W an identifier not defined in M.\r
+ Then W is a legal identifier corresponding to an attribute of M iff\r
+ \r
+ \r
+ - W is legal in N\r
+ - W does not occur in the hidden list in N\r
+ - W occurs in the taken list in M or this list is absent\r
+ \r
+ \r
+ All identifiers specified in every context in a unit must be legal in\r
+ that unit. All identifiers specified in the taken list must be legal in the\r
+ prefix.\r
+ \r
+ An identifier is illegal in a unit iff it denotes an attribute of the\r
+ unit (according to 6.1) and that attribute is not legal.\r
+1 - 45 -\r
+ \r
+ \r
+ 6.2.4. Close attributes\r
+ ***********************\r
+ \r
+ \r
+ Close attributes are not accessible by means of remote access (cf.\r
+ 8.2.3.) outside the unit.\r
+ \r
+ Let M be a unit with the prefix sequence M1, ..., Mk=M. An attribute W of\r
+ unit M is called a close attribute if W occurs in the close list of Mj for\r
+ some j, 1<=j<=k, and W is not redefined in any unit following that Mj in\r
+ the prefix sequence. However, remote access to a close attribute W is\r
+ allowed within the text of the unit M specifying it to be close, i.e., if\r
+ the static qualification of the object expression is equal to M, remote\r
+ access to W is allowed in all the units declared (directly or indirectly)\r
+ in M.\r
+ \r
+ The list of close attributes must consist of legal identifiers. All\r
+ hidden attributes are simultaneously close attributes.\r
+ \r
+ \r
+ Example\r
+ -------\r
+ \r
+ block\r
+ var v:A;\r
+ unit A: class;\r
+ hidden z;\r
+ close x;\r
+ var x, z:real, y:A;\r
+ \r
+ unit B:A class;\r
+ var t:B;\r
+ begin\r
+ \r
+ ... z ... (* is illegal since hidden in A *)\r
+ ... x ... (* is legal *)\r
+ .. y.x+y.z .. (* is legal since y is qualified by A\r
+ and the expression is within A *)\r
+ ... t.x .. (* is illegal since t is qualified by B *)\r
+ \r
+ end B;\r
+ begin\r
+ \r
+ ... v.x+y.x .... (* is legal *)\r
+ \r
+ end A;\r
+ \r
+ begin (* outside A *)\r
+ \r
+ ... v.z .. (* is illegal since hidden, and so close as well *)\r
+ ... v.y.x ... (* is illegal since x is close *)\r
+ end\r
+1 - 46 -\r
+ \r
+ \r
+ 6.3. Static location\r
+ *********************\r
+ \r
+ \r
+ We say that the occurrence of an identifier W is in a unit M if M is the\r
+ syntactic unit most tightly enclosing that occurrence. On the basis of the\r
+ program structure every occurrence of an identifier W in a unit M can be\r
+ unequivocally related to a unit N, where the corresponding attribute W is\r
+ defined. The unit N is called the static container for that occurrence of W\r
+ in M and is denoted by SC(W, M).\r
+ More precisely, by a static container of an occurrence of an identifier W\r
+ in a unit M we mean a syntactic unit N such that:\r
+ \r
+ - W is defined in N\r
+ \r
+ - there exists a unit P satisfying the following conditons:\r
+ \r
+ \r
+ (1) N belongs to the prefix sequence of P (or is P),\r
+ (2) M is declared in P directly or indirectly,\r
+ (3) there is no other unit closer to M than P satisfying (2) in\r
+ which W is an attribute,\r
+ (4) N is P's nearest prefix defining W\r
+ (5) if W is illegal (hidden or not taken) in P, then the static\r
+ container is undefined.\r
+ \r
+ The following figure illustrates this definition\r
+ \r
+ the prefix sequence of P\r
+ P <-------- R <------------ SC(W,M)=N ... declaration of W ...\r
+ ^\r
+ !\r
+ .\r
+ .\r
+ .\r
+ ^\r
+ !\r
+ M ... the occurrence of W ...\r
+ \r
+ \r
+ The static location of an identifier W is defined for the occurrence of W\r
+ in a unit M iff there exists a static container SC(W, M). Every program\r
+ must be an expression in which the static location is defined for all\r
+ occurring identifiers.\r
+ The static container is sufficient to determine the static attribute of a\r
+ unit (constant).\r
+1 - 47 -\r
+ \r
+ \r
+ Example.\r
+ --------\r
+ \r
+ Consider the following program\r
+ \r
+ block\r
+ unit M: class; var X ... end M;\r
+ unit N: M class; var X ... end N;\r
+ begin\r
+ pref N block (* P *)\r
+ var Y : ...;\r
+ unit R: class;\r
+ ... X ... Y ...\r
+ end R;\r
+ begin\r
+ new R;\r
+ ...\r
+ pref N block (* S *)\r
+ var Y : ...,\r
+ unit T: R class;\r
+ ... X ... Y ...\r
+ end T;\r
+ begin\r
+ new T;\r
+ ...\r
+ end S;\r
+ end P;\r
+ end\r
+ \r
+ \r
+ Here we have\r
+ \r
+ SC(X, R)=SC(X, T)=N\r
+ and SC(Y, R)=P, SC(Y, T)=S.\r
+1 - 48 -\r
+ \r
+ \r
+ 6.4. Objects\r
+ *************\r
+ \r
+ \r
+ \r
+ \r
+ An object O of type M with the prefix sequence M1, ..., Mk=M (k=>1) is:\r
+ \r
+ - a k-tuple of the form O = (<V1, M1>, ... <Vk, Mk>) where Vi\r
+ is the valuation of non-static attributes defined in the\r
+ unit Mi,\r
+ \r
+ \r
+ - and a unique reference pointing to this k-tuple.\r
+ \r
+ \r
+ Since the references are unique, two objects are different even if their\r
+ tuples are identical.\r
+ \r
+ Now let us define the valuation of an attribute of object O, depending on\r
+ the kind of that attribute:\r
+ \r
+ - the valuation of variables and variable parameters gives\r
+ their values,\r
+ \r
+ - the valuation of an attribute which is a subprogram is the\r
+ text of its declaration and an environment. (The environment\r
+ is the object containing the declaration of the subprogram.\r
+ In the case of a formal subprogram the value is determined\r
+ by the actual one (see 9.1.2.). The case of virtuals is\r
+ discussed below.)\r
+ \r
+ - an attribute which is a type has the value of the form:\r
+ (array_of)<j> text of declaration.\r
+1 - 49 -\r
+ \r
+ \r
+ 6.4.1. Virtual attributes\r
+ *************************\r
+ \r
+ \r
+ The main feature of virtual atributes is that a redeclaration of an\r
+ identifier denoting a virtual subprogram in a prefixed unit does not cover\r
+ the declaration in the prefix but replaces it in all occurrences. The\r
+ replacement takes place in the so-called virtual chains of identifiers. We\r
+ define this notion below.\r
+ Let F be a subprogram and M a unit. By a virtual chain of F in M we mean\r
+ a sequence of virtuals corresponding to the maximal subsequence N1, ..., Nk\r
+ of the prefix sequence of M such that:\r
+ \r
+ (1) F is a legal identifier in every Ni and denotes an attribute\r
+ specified as virtual (unit virtual F: ...)\r
+ (2) In all the units Ni except Nk, F must not occur in the\r
+ hidden list\r
+ (3) In all the units except N1, F must occur in the taken list\r
+ unless the list is not specified. F must not occur in the\r
+ taken list in N1 if the list is specified.\r
+ (4) After removing the declaration of F from N1, F should be an\r
+ illegal attribute in N1 (hidden in the prefix, not taken) or\r
+ should denote a non-virtual attribute\r
+ (5) If Nk is not M, then one of the following conditions must be\r
+ satisfied:\r
+ - F occurs in the hidden list in Nk,\r
+ - F does not occur in the taken list in the unit\r
+ prefixed directly by Nk if the list is\r
+ specified,\r
+ - F is redefined in the unit prefixed directly\r
+ by Nk as a non-virtual attribute (then it must\r
+ not occur in the taken list either).\r
+ The class Nk from the definition is called the end of the virtual chain.\r
+ For a given unit and an identifier there may exist more than one virtual\r
+ chain.\r
+1 - 50 -\r
+ \r
+ \r
+ Example 1.\r
+ ----------\r
+ \r
+ \r
+ M unit virtual F: <M-body>\r
+ \r
+ N unit virtual F: <N-body>\r
+ \r
+ P .... F ....\r
+ \r
+ R unit F: <R-body>\r
+ \r
+ S unit virtual F: <S-body>\r
+ hidden F;\r
+ \r
+ T unit F: <T-body>\r
+ \r
+ We have three virtual chains of F with respect to T. One is for F from the\r
+ classes M and N:\r
+ (F: <M-body>), (F: <N-body>),\r
+ The second is for F from the class S:\r
+ (F: <S-body>)\r
+ And the third one is for F in T:\r
+ (F: <T-body>)\r
+ \r
+ \r
+ Restrictions\r
+ ------------\r
+ \r
+ (i) All virtual attributes belonging to the same virtual chain must be of\r
+ the same kind (either function or procedure),\r
+ \r
+ (ii) All the declarations of the virtuals belonging to the same virtual\r
+ chain must have formal parameter lists of the same pattern, in particular:\r
+ \r
+ - the lists may use different names of formal parameters,\r
+ but the correspondence between formal types must remain\r
+ valid,\r
+ \r
+ - the class types of corresponding formal variables or\r
+ functions must belong to the same prefix sequence,\r
+ \r
+ - the types of variable parameters or formal functions in\r
+ the ending of the virtual chain must not be less strongly\r
+ defined than the types of the corresponding parameters in\r
+ the beginning, i.e., a formal or system type against a\r
+ statically defined type,\r
+ \r
+ - the types of virtual functions must be identical or the\r
+ type of the function from the beginning of the virtual\r
+ chain must be a prefix of the type of the function from\r
+ the ending,\r
+ \r
+ (iii) The compatibility of virtuals must be defined statically.\r
+1 - 51 -\r
+ \r
+ \r
+ Example 2.\r
+ ----------\r
+ \r
+ (1)\r
+ The following lists are not compatible\r
+ .... (type T; type P; X: T; Y: P) ....\r
+ .... (type R; type S; X: S; Y: R) ....\r
+ \r
+ \r
+ (2)\r
+ The following lists are compatible iff M and N belong to the same prefix\r
+ sequence (and both are classes)\r
+ .... (type T; Z: T; Z1: M) ....\r
+ .... (type P; X: P; Y: N) ....\r
+ \r
+ \r
+ (3)\r
+ The following lists are compatible iff M denotes a system type (coroutine\r
+ or process) or is a formal type\r
+ \r
+ at the beginning: (X: M; Y: real)\r
+ at the ending: (X:coroutine; Y:real)\r
+ \r
+ (4)\r
+ The following lists are not compatible:\r
+ \r
+ ... (Y:integer)\r
+ ... (Y:real)\r
+ \r
+ (5)\r
+ The lists of the function from the beginning of the chain\r
+ \r
+ ... function (Z:integer; Z1:P) : M\r
+ \r
+ and from the ending\r
+ \r
+ ... function (Z:integer; Z1:P) :N\r
+ \r
+ are compatible iff M is a prefix of N.\r
+1 - 52 -\r
+ \r
+ \r
+ 6.4.2. Valuation of virtuals\r
+ ****************************\r
+ \r
+ \r
+ Let O be an object of type M with the prefix sequence M1, ..., Mk=M. The\r
+ value of virtual attribute F declared in Mi is:\r
+ \r
+ - the text of the declaration taken from the end of the virtual chain,\r
+ - the environment of the object O.\r
+ \r
+ Example\r
+ -------\r
+ An object of the class T given in the example 1 from 6.4.1 is of the\r
+ following form:\r
+ \r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from N ! M !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from N ! N !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! ! P !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from R ! R !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from S ! S !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from T ! T !\r
+ ---------------------------------------------\r
+ \r
+ \r
+ The name "virtual subprogram" is derived from the features of virtual\r
+ entities, i.e., in any class a virtual subprogram F with an empty statement\r
+ list can be declared and then used as a virtual entity within the body of\r
+ the class. The user can assume the results of its execution without\r
+ knowledge of its internal structure. He can declare in a subclass a virtual\r
+ subprogram F again. This declaration replaces the previous one. So, during\r
+ the calls of the subprogram F in the body of the class as well as in the\r
+ body of the subclass, the subprogram with the text defined in the subclass\r
+ will be executed. This replacement is done only if F is a virtual attribute\r
+ of the subclass. Otherwise the new declaration of F covers the virtual\r
+ attribute of the class.\r
+1 - 53 -\r
+ \r
+ \r
+ \r
+ \r
+ Abstention from those rules permits us:\r
+ \r
+ (i) to define the types of the parameters of a virtual subprogram and to\r
+ check them already at compilation time,\r
+ \r
+ (ii) to execute the virtual subprogram declared at the beginning of the\r
+ prefix sequence; its body may be empty, but it is always defined,\r
+ \r
+ (iii) to end the virtual chain and to cover a virtual identifier by a\r
+ redeclaration.\r
+ \r
+ The possibilities (ii) and (iii) can be used in the following case. Let M\r
+ and N be system classes of the form :\r
+ \r
+ unit M: class;\r
+ unit virtual error: procedure;\r
+ (* virtual procedure to be defined in M's subclasses*)\r
+ end error;\r
+ begin\r
+ ...\r
+ if B1 then call error fi;\r
+ end M;\r
+ \r
+ unit N: M class;\r
+ unit virtual error: procedure;\r
+ (* the definition of the body of error. It\r
+ will be executed during the calls within N\r
+ as well as in M *)\r
+ end error;\r
+ begin\r
+ ...\r
+ if B2 then call error fi;\r
+ end N\r
+ \r
+ If the programmer prefixes his own units by class M, he can declare his\r
+ own virtual procedure error. If he does not intend to signalize any errors,\r
+ he is able to use M without a redeclaration. Then if the condition B1 is\r
+ satisfied, the procedure with an empty body will be called, i.e., no\r
+ statement will be executed. On the other hand, if the programmer uses N as\r
+ a prefix of his own units, he can redeclare his own non-virtual procedure\r
+ error. In consequence, during the execution of statements of the classes M\r
+ and N the procedure defined by this system in the class N will be executed.\r
+ However during the execution of the user's units the procedures defined by\r
+ himself will be executed.\r
+1 - 54 -\r
+ \r
+ \r
+ 6.5. Dynamic location\r
+ **********************\r
+ \r
+ An executable program must always be a well-formed expression. During its\r
+ execution we can deal with many objects of the same syntactic unit even at\r
+ the same time. Hence an execution of a statement (in an object) requires\r
+ identification and access to all the syntactic entities used. In order to\r
+ define the syntactic environment of object O (of unit M) a static link (SL)\r
+ is introduced. This link always points to an object O1 of a unit N such\r
+ that M is declared in N.\r
+ Let us consider the occurrence of identifier W within a body of class N\r
+ from the prefix sequence of M. Let SL(M) denote the SL-chain of objects\r
+ starting from an object of unit M. This means that SL(M) is a sequence of\r
+ objects O1, ..., Ok such that O1 is an object of unit M, Ok is an object of\r
+ the main program, the SL-link of object Oi points to object Oi+1, for every\r
+ i=1, ..., k-1.\r
+ \r
+ The dynamic container of the occurrence of W in a body of class N with\r
+ respect to an object O1 (denoted by DC(W, N, O1)) is an object Oi from\r
+ SL(M) such that:\r
+ \r
+ (*) Oi is an object of the unit prefixed by the static container SC(W,\r
+ N);\r
+ (**) Oi is the nearest object in the SL-chain such that Oi satisfies (*).\r
+ \r
+ Hence the dynamic container is the unique object which contains the\r
+ valuation of the entity W related to the occurrence of this entity. Let us\r
+ return to the example from 6.3.; after the creation (new T) of an object O\r
+ of the class T the SL-chain of O is as follows:\r
+ \r
+ -------------- ------------ ---------------\r
+ ! X ! M ! ! X ! M ! ! ! R !\r
+ <----- !------!-----! <------- !-----!----! <------ !-------!-----!\r
+ ! X ! N ! SL ! X ! N ! SL ! ! !\r
+ !------!-----! !-----!----! ! ! T !\r
+ OP ! Y,R ! P ! OS ! Y,T ! S ! O ! ! !\r
+ -------------- ------------ ---------------\r
+ \r
+ Because SC(X, R)=SC(X, T)=N , we have DC(X, R, O)=DC(X, T, O)=OS. Since\r
+ SC(Y, T)=S , we have DC(Y, T, O)=OS. On the other hand SC(Y, R)=P and DC(Y,\r
+ R, O)=OP.\r
+ The syntactic environment of an object is determined by the SL chain. Its\r
+ main property is that for each identifier occurrence in the statements of\r
+ the given object exists its dynamic container in the chain. In order to\r
+ define the dynamic location of identifier W occurring in object O of unit M\r
+ in a body of unit R (which belongs to the prefix sequence of M), the\r
+ following steps are performed:\r
+ \r
+ - a static container N=SC(W, R) is defined;\r
+ - a dynamic container O1=DC(W, R, O) is defined (in the SL chain of object\r
+ O, the nearest object O1 is found such that this object has a "layer" <V,\r
+ N>);\r
+ - a valuation V1(W) is found in the layers <V1, N1> of the object O1 such\r
+ that N1 is the nearest N's prefix.\r
+1 - 55 -\r
+ \r
+ \r
+ 7. Consistency of types\r
+ #######################\r
+ \r
+ In order to determine the context-sensitive correctness of an assignment\r
+ statement and parameter transmission it is necessary to introduce the\r
+ notion of the static consistency of types. Nevertheless this notion is not\r
+ sufficient to determine the correctness of the executions of those\r
+ constructs. Therefore, the notion of the dynamic consistency of types will\r
+ be introduced to define the semantic correctness of program. The introduced\r
+ distinction follows from the implementation constraints; namely, static\r
+ consistency is verified at compilation time, dynamic consistency is\r
+ verified at run time.\r
+ \r
+ \r
+ Static consistency of types\r
+ ---------------------------\r
+ \r
+ The type (array_of)<i>T is statically consistent with the type\r
+ (array_of)<j>S, where T and S are not array types, iff one of the following\r
+ conditions holds:\r
+ - i=j and T=S,\r
+ - i=j=0 and T, S are integer or real types,\r
+ - both T and S are formal types,\r
+ - T is a formal type, S is not a formal type and i<=j,\r
+ - S is a formal type, T is not a formal type and j<=i,\r
+ - i=j=0 and T, S are generalized class types and T pref* S or\r
+ S pref* T,\r
+ - i=j=0 and T and S are one of them a system type and the other a\r
+ generalized class or system type.\r
+ \r
+ \r
+ Dynamic consistency of types.\r
+ -----------------------------\r
+ \r
+ The type (array_of)<i>T is dynamically consistent with the type\r
+ (array_of)<j>S, where T and S are not array types, iff one of the following\r
+ conditions holds:\r
+ - i=j and T=S,\r
+ - i=j=0 and T, S are integer or real types,\r
+ - i=j=0 and T, S are generalized class types and T pref* S,\r
+ - i=j=0, T = coroutine, and S is declared as:\r
+ unit S: ... coroutine ...; or\r
+ unit S: ... process .....; or\r
+ unit S: R class..., where T is dynamically consistent with R,\r
+ - i=j=0, T = process, and S is declared as:\r
+ unit S: ... process .......; or\r
+ unit S: R class..., where T is dynamically consistent with R.\r
+ \r
+ At run time all formal types are replaced by actual non-formal ones.\r
+ Therefore, there is no reason to define dynamic consistency for formal\r
+ types.\r
+ Dynamic consistency is a subrelation of static consistency. Thus the\r
+ dynamic consistency is checked at compilation time, if possible. In other\r
+ cases the check is made at run-time.\r
+ From now on we shall use the following notation:\r
+ - for the desription of context properties, an occurrence of an\r
+ expression E is considered to be contained in the body of unit M,\r
+ - for the desription of semantic properties, an occurrence of an\r
+ expression E is considered to be contained in the body of unit M, with\r
+ respect to an object O of type M0 such that M pref* M0.\r
+1 - 56 -\r
+ \r
+ \r
+ 8. Expressions\r
+ ##############\r
+ \r
+ \r
+ Expressions are composed of primitive expressions - constants and\r
+ variables by means of system operators and functions. They serve as\r
+ patterns for computing a certain value. Two kinds of expression properties\r
+ have to be considered: context (static) and semantic (dynamic) ones.\r
+ \r
+ \r
+ \r
+ \r
+ Context properties.\r
+ -------------------\r
+ \r
+ We consider two context properties of each expression:\r
+ - to be a well-formed formula,\r
+ - to have a static type.\r
+ \r
+ The context correctness of an expression is examined at compilation time.\r
+ From now on, an expression is said to be a well-formed formula (shortly :\r
+ WFF) if it is statically correct. The static type of an expression is\r
+ determined by the program text.\r
+ \r
+ \r
+ \r
+ \r
+ Semantic properties.\r
+ --------------------\r
+ \r
+ We consider three semantic properties of each expression:\r
+ - to be defined,\r
+ - to have a dynamic type,\r
+ - to have the type of its value.\r
+ \r
+ In some cases (for expressions of formal types) type must be determined\r
+ at run-time. Replacing formal types by the corresponding actual ones in the\r
+ static types of expressions, we obtain the dynamic types of those\r
+ expressions. Notice, that the actual type may not be accessible, if the\r
+ dynamic container for the formal type of the expression was killed. The\r
+ dynamic type will be defined only for the expressions which may occur on\r
+ the left side of an assignment, i.e., for variables. When the value and the\r
+ type of the value are computed, the semantic correctness of the expression\r
+ is established.\r
+ From now on an expression is said to be defined if it is dynamically\r
+ correct at run-time. The correctness of an expression will be examined\r
+ under the assumption that it is a WFF. Five kinds of expressions are\r
+ distinguished: arithmetic, boolean, character, string, and object\r
+ expressions.\r
+1 - 57 -\r
+ \r
+ \r
+ 8.1. Constant\r
+ *************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <constant>:\r
+ \r
+ -----> <identifier> ----->\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ Let E be a constant Q. The expression Q is a WFF if the static container\r
+ SC(Q, M) exists. The static type of Q is determined by its declaration (see\r
+ 5.1.). A constant cannot occur on the left side of an assignment statement,\r
+ as an actual output parameter, or in an expression X.Q, where X is an\r
+ object expression.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The constant Q is always defined. The value of the constant is fixed from\r
+ the declaration of that constant and cannot be modified. The type of the\r
+ value is equal to the static type.\r
+ \r
+ \r
+ \r
+ 8.2. Variable\r
+ *************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <variable>:\r
+ \r
+ --------> <simple variable> ------------>\r
+ ! ^\r
+ !---> <subscripted variable>->!\r
+ ! !\r
+ !----> <dotted variable> ---->!\r
+ ! !\r
+ !----> <system variable> ---->!\r
+ \r
+ \r
+ For each kind of variables its context and semantic correctness will be\r
+ defined. Additionally the dynamic address of a variable will be defined as\r
+ a pair: (reference to an object, attribute of that object).\r
+1 - 58 -\r
+ \r
+ \r
+ 8.2.1. Simple variable\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ (simple variable>:\r
+ \r
+ ----> <identifier> ----->\r
+ \r
+ \r
+ Let E be a variable Z.\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ The variable Z is a WFF if the static container SC(Z, M) = R exists. The\r
+ static type of Z is determined by the declaration of Z and may be a formal\r
+ one.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The variable Z is defined if the dynamic container O1 = DC(Z, M, O)\r
+ exists. Let the static type of Z be: (array_of)<i>S. The dynamic type of Z\r
+ is equal to (array_of)<i>S in the case where S is not formal, otherwise it\r
+ is (array_of)<i+k>T, where the actual type corresponding to the formal one\r
+ is (array_of)<k>T.\r
+ The actual type is taken from the dynamic container DC(S, R, O1), i.e.,\r
+ from an object belonging to the SL chain of the object O1. The value of Z\r
+ is given by the corresponding valuation of Z in the object O1. The address\r
+ of Z is a pair: (the reference to O1, attribute Z of O1).\r
+1 - 59 -\r
+ \r
+ \r
+ 8.2.2. Subscripted variable\r
+ ***************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <subscripted variable>:\r
+ \r
+ --> <simple variable> --> ( -> <arithmetic expression> -----> ) -->\r
+ ^ !\r
+ !<----------- , --------------!\r
+ \r
+ \r
+ Let E be an expression of the form Z(A1, ..., Ak), where Z is a simple\r
+ variable and A1, ..., Ak are arithmetic expressions.\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ Let (array_of)<i>S denote a static type of Z. The expression Z(A1, ...,\r
+ Ak) is a WFF if:\r
+ - Z and A1, ..., Ak are WFFs,\r
+ - static types of A1, ..., Ak are integer or real,\r
+ - 1<=k<=i.\r
+ The static type of E is (array_of)<i-k>S.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The expression E is defined if:\r
+ - the expression Z(A1, ..., Ak-1) is defined and its value equals the\r
+ reference to a non-empty array object O1 with the bounds l and u, l<=u.\r
+ - the value of Ak is defined and its truncation l1 satisfies: l<=l1<=u.\r
+ The dynamic type of E is equal to the static one if S is not formal,\r
+ otherwise it is (array_of)<i-k+j>T where the actual type corresponding to\r
+ the formal one is (array_of)<j>T. The actual type is determined as for a\r
+ simple variable (see 8.2.1.). The value of E is that of the attribute (l1)\r
+ of the object O1. The address of E is the pair: (the reference to O1,\r
+ attribute (l1)).\r
+1 - 60 -\r
+ \r
+ \r
+ 8.2.3. Dotted variable\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <dotted variable>:\r
+ \r
+ -> <qualified object expression> -->. --> <variable> ---->\r
+ \r
+ \r
+ It is sufficient to consider the expression E of the form X.Y, where Y is\r
+ a simple or subscripted variable.\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ The expression E is a WFF if:\r
+ \r
+ \r
+ - X, Y are WFFs, X is the qualified object expression,\r
+ - the static type of X is a generalized class type,\r
+ - Y is a non-closed attribute of the static type of X.\r
+ \r
+ \r
+ The static type of E is the same as the static type of Y. Notice that the\r
+ static type of X cannot be a formal type.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The expression E is defined if:\r
+ \r
+ \r
+ - the expression X is defined,\r
+ - the value of X is a reference to a non-empty object O1.\r
+ \r
+ \r
+ The dynamic type of E is the same as the dynamic type of Y would be if Y\r
+ occurred in the object O1. The value of X.Y is that of the attribute Y of\r
+ the object O1. The address of X.Y is the address of Y would be if Y\r
+ occurred in O1.\r
+1 - 61 -\r
+ \r
+ \r
+ 8.2.4. System variable\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <system variable>:\r
+ \r
+ ------> result ---------------------------------------->\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ For every function F there is an implicitly declared variable result of\r
+ type T of the value of function F. The initial value of that variable\r
+ depends on type T (is equal to the default value of type T), the final\r
+ value (after completion of a function call) is also the value of function F\r
+ for the given call (see 9.1.2.). An occurrence of the variable result is\r
+ matched with the smallest unit F which contains that occurrence and which\r
+ is a function.\r
+ \r
+ \r
+ Example.\r
+ --------\r
+ \r
+ unit Newton_symbol: function (i, k:integer): integer;\r
+ var j: integer;\r
+ begin\r
+ if i>= k and k>=0\r
+ then result:=1;\r
+ for j:=0 to k-1\r
+ do\r
+ result:=result*(i-j)div(j+1)\r
+ od\r
+ fi\r
+ end Newton_symbol;\r
+1 - 62 -\r
+ \r
+ \r
+ 8.3. Arithmetic expression\r
+ **************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <arithmetic expression>:\r
+ \r
+ !------------------->!\r
+ ! !\r
+ -----------> <sign> --------> <term> ------->\r
+ ^ !\r
+ !<--------------------------------!\r
+ \r
+ \r
+ \r
+ <sign>:\r
+ \r
+ -----> + ----->\r
+ ! ^\r
+ !-> - -->!\r
+ \r
+ \r
+ \r
+ <term>:\r
+ \r
+ ---------> <factor> ----------------->\r
+ ^ !\r
+ ! !<-------------------!\r
+ ! ! ! ! !\r
+ ! ! ! ! !\r
+ ! * / div mod\r
+ ! ! ! ! !\r
+ ! ! ! ! !\r
+ !<-----------------!\r
+ \r
+ \r
+ \r
+ <factor>:\r
+ \r
+ ------------------ <integer> -------------------------------->\r
+ ! ^ ! ^\r
+ !-<abs>-! !---> <real> ---------------------------->!\r
+ ! !\r
+ !--> <constant> ------------------------->!\r
+ ! !\r
+ !--> <variable> ------------------------->!\r
+ ! !\r
+ !------> <function call> ---------------->!\r
+ ! !\r
+ !-> ( -><arithmetic expression>-> ) ----->!\r
+1 - 63 -\r
+ \r
+ \r
+ <integer>:\r
+ \r
+ -----> <digit> ------>\r
+ ^ !\r
+ !<------------!\r
+ \r
+ \r
+ <real>:\r
+ \r
+ !-------->!\r
+ ! !\r
+ ---> <integer>--> . ---> <integer>----->E --> <sign>--> <integer> -->\r
+ ! ^ ! ^\r
+ !------------------>! !---------------------------->!\r
+ \r
+ \r
+ (function call will be defined in 9.1.2.).\r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ The type of the value of an arithmetic expression is always equal to its\r
+ static type. The dynamic type is not to be defined. The context and\r
+ semantic properties of arithmetic expressions will be defined inductively.\r
+ \r
+ Factors.\r
+ The type of an integer is integer, the type of a real is real, their\r
+ values are given directly. Constant, variable, and function call must be\r
+ WFFs (in the meaning of 8.1., 8.2 and 9.1.2.), and of type integer or real\r
+ (in order to create a well-formed factor). The factor is defined iff the\r
+ variable and the function call are defined. The context and semantic\r
+ properties of the factors of the form " abs A1 ", and " (A2) " are the same\r
+ as those of arithmetic expressions A1 and A2, respectively. The value of "\r
+ abs A1 " is the absolute value of A1.\r
+ \r
+ \r
+ Terms.\r
+ The operators *, /, div, mod are interpreted as multiplication, division,\r
+ integer division and remaindering, respectively. The last two operators are\r
+ defined for integer arguments only, " A1 div A2 " is equal to the\r
+ truncation of A1/A2; " A1 mod A2 " is equal to the remainder of A1/A2. The\r
+ type of a term of the form <factor> <operator> <factor> is real if the\r
+ operator is /, or at least one of the arguments is of type real. The term "\r
+ A1/A2 " is defined if the value of A2 is different from 0. The value is\r
+ defined inductively if Av1 and Av2 are the values of factor A1 and term A2\r
+ respectively, and <W> is an interpretation of operator W, then the value of\r
+ a term of the form " A1 W A2 " is Av1 <W> Av2. If one of the arguments is\r
+ of type integer and the other is of type real then for the operators *, /\r
+ the integer type value is converted into a real type one.\r
+ \r
+ \r
+ Arithmetic expression.\r
+ An arithmetic expression of the form <term> <sign> <term> is of type\r
+ integer if both terms are of that type and it is of type real in the\r
+ opposite case. A value is defined inductively: if Av1 and Av2 are the\r
+ values of term A1 and arithmetic expression A2, respectively, then the\r
+ value of an expression A1+(-)A2 is Av1+(-)Av2, the value of +(-)A1 is\r
+ +(-)Av1. If one of the arguments is of type integer and the other is of\r
+ type real, then the integer type value is converted into a real type one.\r
+1 - 64 -\r
+ \r
+ \r
+ 8.4. Boolean expression\r
+ ***********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <boolean expression>:\r
+ \r
+ -------> <boolean term> ---------------->\r
+ ^ !\r
+ !<---- or <---------------!\r
+ \r
+ \r
+ <boolean term>:\r
+ \r
+ ------> <boolean factor> ---------->\r
+ ^ !\r
+ !<---- and <------------!\r
+ \r
+ \r
+ <boolean factor>:\r
+ \r
+ ----> not ----> <boolean primary> ------------>\r
+ ! ^\r
+ !-------->!\r
+ \r
+ \r
+ <boolean primary>:\r
+ \r
+ --------> <boolean constant> -------------------->\r
+ ! ^\r
+ !----> <constant> -------------------->!\r
+ ! !\r
+ !----> <variable> -------------------->!\r
+ ! !\r
+ !----> <function call> --------------->!\r
+ ! !\r
+ !----> <relation> -------------------->!\r
+ ! !\r
+ !--> ( --> <boolean expression> ->)--->!\r
+ \r
+ \r
+ <relation>:\r
+ \r
+ -----> <arithmetic relation> --------------->\r
+ ! ^\r
+ !-> <boolean relation> ----------->!\r
+ ! !\r
+ !-> <character relation> --------->!\r
+ ! !\r
+ !-> <reference relation> --------->!\r
+ ! !\r
+ !-> <object relation> ------------>!\r
+ \r
+ \r
+ <boolean constant>:\r
+ \r
+ -----> false -------->\r
+ ! ^\r
+ !--> true --->!\r
+1 - 65 -\r
+ \r
+ \r
+ <arithmetic relation>:\r
+ \r
+ ---> <arithmetic expression> --> <arithmetic relational operator>\r
+ !\r
+ !<-----------------------!\r
+ !\r
+ !---> <arithmetic expression> ---->\r
+ \r
+ \r
+ <arithmetic relational operator>:\r
+ \r
+ ----> <equality operator> --------->\r
+ ! ^\r
+ !-> <inequality operator> -->!\r
+ \r
+ \r
+ <equality operator>:\r
+ \r
+ ----------> = ---------------->\r
+ ! ^\r
+ !------> =/= ------->!\r
+ \r
+ \r
+ <inequality operator>:\r
+ \r
+ --------------------------------->!\r
+ ! ! ! !\r
+ < > <= >=\r
+ ! ! ! !\r
+ !------------------------------->\r
+ \r
+ \r
+ <character relation>:\r
+ \r
+ ---> <character expression> --> <equality operator> -->\r
+ !\r
+ !<-----------------------------------------!\r
+ !\r
+ !---> <character expression> ----->\r
+ \r
+ \r
+ <reference relation>:\r
+ \r
+ ---> <object expression> --> <equality operator> -->\r
+ !\r
+ !<----------------------------------------------!\r
+ !\r
+ !---> <object expression> ------>\r
+ \r
+ \r
+ <object relation>:\r
+ \r
+ ---> <object expression> ----> is ------> <system type> ------->\r
+ ! ^ ! ^\r
+ !--> in -->! !--> <class type> ---->!\r
+1 - 66 -\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ The context and semantic properties of boolean expressions can be defined\r
+ in the same way as those of arithmetic ones. A boolean expression is of\r
+ type boolean.\r
+ \r
+ Boolean primary.\r
+ The value of a boolean constant true and false is T and F, respectively.\r
+ The equality and inequality operators have the usual interpretation. Let\r
+ A1, A2 be two defined arithmetic expressions and let Av1, Av2 be their\r
+ values. Let <W> be an interpretation of the arithmetic relational operator\r
+ W. Then the value of arithmetic relation " A1 W A2 " is Av1 <W> Av2. If one\r
+ of the expressions is of type integer and the other is of type real then\r
+ the integer type value is converted into real type one.\r
+ \r
+ Let C1, C2 be two defined character expressions and let Cv1, Cv2 be their\r
+ values. Then the value of the character relation " C1=C2 " (" C1=/=C2 ") is\r
+ true iff the characters Cv1, Cv2 are identical (different). For string type\r
+ there are no relations, even no equality.\r
+ \r
+ A reference relation " X1=X2 " (" X1=/=X2 ") is a WFF if X1 and X2 are\r
+ well-formed object expression. The static types of the expressions have to\r
+ be statically consistent. The relation is defined if X1 and X2 are defined.\r
+ The value of that relation is true iff the values of both expressions are\r
+ equal to (different from) the same reference; in particular, if they are\r
+ both equal to none, then the value of " X1=X2 " is T.\r
+ An object relation "X is S" is a WFF if S is a generalized class\r
+ identifier, X is a WFF, and the static type of X is statically consistent\r
+ with S. An object relation "X in S" is a WFF if S is a generalized class or\r
+ system type identifier, X is a WFF, and the static type of X is statically\r
+ consistent with S. The value of the relation "X is S" is T iff the value of\r
+ the expression X is the reference to an object of class S. The value of the\r
+ relation "X in S" is T iff the value of X belongs to the set !S! .\r
+ \r
+ Boolean factor.\r
+ The value of a boolean factor "not B", where B is a boolean primary, is T\r
+ iff the value of B is F.\r
+ \r
+ Boolean term.\r
+ Let Bv2 and Bv1 be the values of boolean factor B2 and boolean term B1,\r
+ respectively. Then the value of a term of the form "B1 and B2" is T iff\r
+ Bv2=Bv1=T.\r
+ \r
+ Boolean expression\r
+ Let Bv1 and Bv2 be the values of boolean term B1 and boolean expression\r
+ B2, respectively. Then the value of an expression of the form "B1 or B2" is\r
+ F iff Bv1=Bv2=F.\r
+ \r
+ The value of the arithmetic and boolean expression is computed from left\r
+ to right with the following operator priorities:\r
+ (1) parentheses (, ), abs\r
+ (2) *, /, div, mod\r
+ (3) +, -\r
+ (4) <, <=, >, >=, =, =/=\r
+ (5) not\r
+ (6) and\r
+ (7) or.\r
+1 - 67 -\r
+ \r
+ \r
+ 8.5. Character expression\r
+ *************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <character expression>:\r
+ \r
+ ----> <character constant> --------------------->\r
+ ! ^\r
+ !---> <constant> --------------->!\r
+ ! !\r
+ !---> <variable> --------------->!\r
+ ! !\r
+ !---> <function call> ---------->!\r
+ \r
+ \r
+ <character constant>:\r
+ \r
+ ----> ' -----> <symbol> -----> ' ------>\r
+ \r
+ \r
+ <symbol>:\r
+ \r
+ -------> <letter> ---------------------------->\r
+ ! ^\r
+ !---> <digit> --------------->!\r
+ ! !\r
+ !---> <auxiliary sign> ------>!\r
+ ! !\r
+ !--> <other characters> ----->!\r
+ ! !\r
+ !-> (: --> <integer> --> :) ->!\r
+ \r
+ \r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ Constant, variable and function call are WFFs if they are of type\r
+ character. The standard function ord is defined for a character expression\r
+ and gives an integer value (dependent on implementation).\r
+1 - 68 -\r
+ \r
+ \r
+ 8.6. String expression\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <string expression>:\r
+ \r
+ -----> <string constant> -------->\r
+ ! ^\r
+ !---> <constant> ------->!\r
+ ! !\r
+ !---> <variable> ------->!\r
+ ! !\r
+ !---> <function call> -->!\r
+ \r
+ \r
+ \r
+ <string constant>:\r
+ \r
+ ---> " -------> <character> ---------------------> " ----->\r
+ ! !\r
+ !<-------------------------------------!\r
+ \r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ Constant, variable and function call are WFFs if they are of string type.\r
+ The quotation mark " in the string constant is written twice "".\r
+ \r
+ Remark\r
+ ------\r
+ The string type is a constant type in the sense that the universe is\r
+ defined at compilation time and there are no string operations predefined\r
+ in the language. However, a standard function may transform a string into\r
+ an array of characters. Then the user can treat the array of character as a\r
+ text type and can define any set of suitable text operations.\r
+ \r
+ End of remark\r
+ -------------\r
+1 - 69 -\r
+ \r
+ \r
+ 8.7. Object expression\r
+ **********************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <qualified object expression>:\r
+ \r
+ --------> <object expression>--------------------------------------->\r
+ ! ^\r
+ !--> <variable>--------> qua -> <class type identifier> -->!\r
+ ! ^\r
+ !--> <function call> -!\r
+ \r
+ <object expression>:\r
+ \r
+ ----------> <object constant> --------------------->\r
+ ! ^\r
+ !-----> <variable> ------------>!\r
+ ! !\r
+ !---> <function call> --------->!\r
+ ! !\r
+ !---> <object generator> ------>!\r
+ ! !\r
+ !----> <local object> --------->!\r
+ ! !\r
+ !-----> <process waiting> ----->!\r
+ \r
+ <object constant>:\r
+ \r
+ -----> none -------- >\r
+ \r
+ <local object>:\r
+ \r
+ ----> this ----> <class type> --------->\r
+ \r
+ \r
+ (Function call and object generator will be defined in 9.1.2, process\r
+ waiting will be defined in 11.1. Variable is described in 8.2.).\r
+1 - 70 -\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ The constant none is of a fictitious type statically consistent with any\r
+ non-primitive type.\r
+ To define the context of a local expression let us recall that the\r
+ occurrence of the expression E is considered in the unit M. Let E be the\r
+ local object "this T", then E is a WFF if there exists a unit N such that M\r
+ decl* N and T pref* N, (i.e., there exists a unit N statically enclosing M\r
+ and containing T in its prefix sequence). The static type of the expression\r
+ E is T.\r
+ The qualified object expression of the form "X qua T" is a WFF if X is a\r
+ WFF and the static type of X is statically consistent with T. The static\r
+ type of this expression is T.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ The constant none is always defined as an empty object. Every compound\r
+ and system type is dynamically consistent with the fictitious type of none.\r
+ The value of the local object "this T" is the nearest object of the type T1\r
+ belonging to the SL chain of the object O such that T1 is prefixed by T,\r
+ (recall that O contains the given occurrence of the local object). The\r
+ expression "this T" is defined if its value exists. The dynamic type is not\r
+ to be defined. The type of the value is S. The qualified object expression\r
+ of the form "X qua T" is defined if X is defined, its value is different\r
+ from none, and the dynamic type of X as well as the type of its value are\r
+ dynamically consistent with T. The value of this expression is equal to the\r
+ value of X. The dynamic type is not to be defined.\r
+1 - 71 -\r
+ \r
+ \r
+ 9. Sequential statements.\r
+ ##########################\r
+ \r
+ \r
+ Sequential statements are patterns for the sequencing of primitive actions.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <sequential statement>:\r
+ \r
+ --------> <primitive statement> ------------>\r
+ ! ^\r
+ !-------> <compound statement> ---->!\r
+ \r
+ \r
+ \r
+ In a similar way to that followed in the description of expressions we\r
+ shall consider context and semantic properties of statements. A statement\r
+ will be called a WFF if it is correct at compilation time, and said to be\r
+ defined if it is correct at run time.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ 9.1. Sequential primitive statements\r
+ *************************************\r
+ \r
+ \r
+ The result of an execution of a primitive statement consists in the\r
+ modification of:\r
+ - the valuation (assignment statement);\r
+ - the configuration (allocation and deallocation statement);\r
+ - the control (control statement).\r
+ \r
+ By a configuration we mean the set of all objects existing at a given state\r
+ of computation.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <primitive statement>:\r
+ \r
+ --------> <evaluation statement> ------------->\r
+ ! ^\r
+ !----> <configuration statement> ---->!\r
+ ! !\r
+ !----> <simple control statement> --->!\r
+ ! !\r
+ !----> <coroutine statement> -------->!\r
+ \r
+ \r
+1 - 72 -\r
+ \r
+ \r
+ 9.1.1. Evaluation statement\r
+ ****************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <evaluation statement>:\r
+ \r
+ --------> <empty statement> ---------------------->\r
+ ! ^\r
+ !----> <assignment statement> ------>!\r
+ ! !\r
+ !----> <copying statement> --------->!\r
+ \r
+ \r
+ \r
+ <empty statement>:\r
+ \r
+ --------------------------->\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ An execution of an empty statement has no effect.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <assignment statement>:\r
+ \r
+ ------> <variable list> ---> := --> <expression> ---->\r
+ \r
+ \r
+ <variable list>:\r
+ \r
+ ----------> <variable> ------> , --------------->\r
+ ! !\r
+ ! !\r
+ <---------------------------------\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ An assignment statement of the form y1, ..., yk:=e is a WFF if:\r
+ - variables y1, ..., yk and expression E are WFFs;\r
+ - the static types T1, ..., Tk of variables y1, ..., yk are statically\r
+ consistent with the static type S of the expression E.\r
+1 - 73 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The execution of a statement consists of three steps : prologue, body and\r
+ epilogue.\r
+ \r
+ In the prologue the computation of the addresses of variables y1, ..., yk\r
+ is performed, i.e.:\r
+ \r
+ - For a dotted variable of the form X.z, the value of the expression X is\r
+ computed;\r
+ - For a subscripted variable of the form Z(i1, ..., ij) the value of the\r
+ expression Z(i1, ..., ij-1) is computed. If Z is of a formal type, then the\r
+ dynamic type T of the variable Z is determined. Finally the value of the\r
+ expression ij is computed.\r
+ \r
+ The above actions are performed from left to right.\r
+ \r
+ \r
+ During the body the computation of the type and the value of expression E\r
+ is performed.\r
+ \r
+ \r
+ The epilogue checks if the statement is well-defined and assigns the\r
+ values to the attributes determined by the addresses evaluated during the\r
+ prologue.\r
+ \r
+ An assignment is defined, if:\r
+ - the expressions y1, .., yk, E are defined;\r
+ - the dynamic types of y1, .., yk are defined and are dynamically\r
+ consistent with the type of the value of E.\r
+ \r
+ The values are assigned from right to left, i.e., at first the value of E\r
+ is assigned to yk (with possible conversion to the type of yk), next the\r
+ value of yk is assigned to yk-1 (with appropriate conversion), and so on.\r
+ For example, when r is real, n is integer, then:\r
+ \r
+ after r, n:=2.5 we have n=2, r=2.0,\r
+ after n, r:=2.5 we have r=2.5, n=2.\r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ The value of the expression Z computed at prologue may point to a non-empty\r
+ object O, but it could be changed to none as a result of the deallocation\r
+ of the object O (during the execution of the statement). It will be\r
+ detected at epilogue and will result in a run-time error.\r
+ \r
+ End of remark.\r
+ --------------\r
+1 - 74 -\r
+ \r
+ \r
+ An object of a compound type can be simultanously referenced by a number\r
+ of variables. If X and Y are the variables of such a type, then after\r
+ assignment X:=Y, both variables reference the same object. Hence some\r
+ side-effects may occur: the value of an attribute of the object referenced\r
+ by variable X can be changed as a result of an access to that object by\r
+ means of variable Y. In order to avoid such effects, one can use a copying\r
+ statement:\r
+ \r
+ X:=copy(Y)\r
+ \r
+ after which both variables reference identical objects but not the very\r
+ same one.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <copying statement>:\r
+ \r
+ -> <variable list> -> := -> copy -> ( -> <object expression> -> ) ->\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ The semantics of the copying statement differs from that of the assignment\r
+ statement in the following points:\r
+ \r
+ \r
+ - The copying statement is defined if the value of the right side object\r
+ expression E is a reference to a terminated class object (i.e., an object\r
+ whose all statements were completed, see 9.1.3). Coroutine or process\r
+ objects must not be copied.\r
+ \r
+ \r
+ - During the epilogue, the copy of the value of the expression E is\r
+ assigned (a copy of none is none).\r
+1 - 75 -\r
+ \r
+ \r
+ 9.1.2. Configuration statement\r
+ *******************************\r
+ \r
+ \r
+ Configuration statements correspond to the generation and deallocation of\r
+ units and arrays. Allocation of an array object is a result of array\r
+ generation, allocation of a unit object is a result of a subprogram call,\r
+ generation of a generalized class object or block statement.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <configuration statement>:\r
+ \r
+ -----> <object allocation> ------->\r
+ ! ^\r
+ !--> <object deallocation> -->!\r
+ \r
+ \r
+ 9.1.2.1. Allocation statement\r
+ *****************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <object allocation>:\r
+ \r
+ ------> <function call> ----------------->\r
+ ! ^\r
+ !--> <procedure call> -------->!\r
+ ! !\r
+ !--> <object generation> ----->!\r
+ ! !\r
+ !---> <block statement>------->!\r
+ ! !\r
+ !--> <array generation> ------>!\r
+ \r
+ \r
+ <function call>:\r
+ \r
+ ---> <remote function identifier> ---> <actual parameter list> ---->\r
+ ! ^\r
+ !--------------------------->!\r
+ \r
+ \r
+ <procedure call>:\r
+ \r
+ --> call --> <remote procedure identifier> -->!\r
+ !\r
+ !<-----------------------!\r
+ !\r
+ !---> < actual parameter list> ------------>\r
+ ! ^\r
+ !----------------------------------->!\r
+1 - 76 -\r
+ \r
+ \r
+ <object generation>:\r
+ \r
+ --> <qualified object expression> --> . --> new -----!\r
+ ! ^\r
+ !--------------------------------------! !\r
+ !\r
+ !--------------------------------------------------!\r
+ !\r
+ !--> <class identifier>---> <actual parameter list> -------->\r
+ ! ^\r
+ !---------------------------!\r
+ \r
+ \r
+ <remote function identifier>:\r
+ \r
+ ----> <qualified object expression> --> . -->!\r
+ ! ^ !\r
+ !----------------------------------------! !\r
+ !\r
+ !--------------------------------------------!\r
+ !\r
+ !---> <function identifier> --->\r
+ \r
+ \r
+ <remote procedure identifier>:\r
+ \r
+ ----> <qualified object expression> --> . -->!\r
+ ! ^ !\r
+ !----------------------------------------! !\r
+ !\r
+ !--------------------------------------------!\r
+ !\r
+ !---> <procedure identifier> --->\r
+ \r
+ \r
+ <actual parameter list>:\r
+ \r
+ ---->(----------------> <expression> ----------------> ) ---->\r
+ ^ ! ^ !\r
+ ! !-><remote function identifier>-------->! !\r
+ ! ! ! !\r
+ ! !-><remote procedure identifier>------->! !\r
+ ! ! ! !\r
+ ! !-><type identifier>------------------->! !\r
+ ! !\r
+ !--------------- , <---------------------------!\r
+1 - 77 -\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ We shall start with an allocation of a unit object O, i.e., subprogram\r
+ call, object generation and block statement. The execution of those\r
+ statements causes the generation of the new object O. Let Pa1, ..., Pak\r
+ denote actual parameters, k>=0, and let X be an object expression. The\r
+ allocation of an object of unit M is of one of the following forms:\r
+ \r
+ - for function M: M(Pa1, ..., Pak) or X.M(Pa1, ..., Pak)\r
+ (a function call must occur in an expression; it is not allowed as an\r
+ independent statement);\r
+ \r
+ - for procedure M: call M(Pa1, ..., Pak) or call X.M(Pa1, ..., Pak);\r
+ \r
+ - for class M: new M(Pa1, ..., Pak) or X.new M(Pa1, ..., Pak);\r
+ (an object generator may occur in an expression and it is also allowed as\r
+ an independent statement).\r
+ \r
+ - for block statement: pref M(Pa1, ..., Pak) block...end or block... end\r
+ (a block can be considered as an unnamed unit and a generation of its\r
+ object is the result of an occurrence of that block statement).\r
+ \r
+ \r
+ The allocation of a unit object is a WFF if:\r
+ \r
+ - a unit identifier M is visible (in the sense of the rules\r
+ used for the variables, see 8.2.),\r
+ - the actual parameters are WFFs,\r
+ - the formal parameter list and the actual parameter list\r
+ are statically compatible in the sense given below.\r
+ \r
+ Let us recall (5.3.5.) that a formal parameter list of a unit M is\r
+ defined as a concatenation of the lists of units belonging to the prefix\r
+ sequence of M.\r
+ \r
+ Static compatibility of parameters.\r
+ \r
+ The list of formal parameters (Pf1, ..., Pfj) is statically compatible\r
+ with the list of actual parameters (Pa1, ..., Pak) if j=k and for i=1, ...,\r
+ k the following conditions hold:\r
+ \r
+ - if Pfi is an input/output formal parameter then Pai is a\r
+ WFF of a static type which is statically compatible with\r
+ the static type of parameter Pfi,\r
+ - if Pfi is an output/inout parameter then Pai is a\r
+ variable,\r
+ - if Pfi is a formal function (procedure) then Pai is a\r
+ function (procedure) identifier,\r
+ - if Pfi is a formal type then Pai is a non-primitive type\r
+ identifier.\r
+1 - 78 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The allocation of a unit object O is defined if:\r
+ - the unit and its environment are determined,\r
+ - the list of formal parameters is dynamically compatible\r
+ with that of actual parameters (in the sense provided\r
+ below),\r
+ - three steps of actions, called prologue, body, and\r
+ epilogue, are determined.\r
+ \r
+ Note the difference between the unit identifier and the unit itself. The\r
+ environment is the object which becomes the syntactic father of O. In the\r
+ case of a formal subprogram, the unit identifier may be replaced by one of\r
+ many existing units. Denote by O1 the object containing the given unit\r
+ object allocation statement. The prologue computes the values for input\r
+ formal parameters, determines the addresses of output actual parameters,\r
+ and determines actual subprograms/types. The prologue is executed in the\r
+ environment of the object O1. The body transfers the control to the\r
+ statements from the prefix sequence of the given unit. Those statements are\r
+ executed in the environment of the object O.\r
+ The epilogue transmits the values of output formal parameters (in the\r
+ environment of the object O1).\r
+ \r
+ Unit environment\r
+ \r
+ Consider the allocation of a unit which is not a block. A unit identifier\r
+ has one of the following forms:\r
+ \r
+ (a) M,\r
+ (b) X.M or X.new M .\r
+ \r
+ Ad (a). Let the static location of the given occurrence of M be\r
+ determined by the attribute M of the unit T. Consider three cases:\r
+ \r
+ (a1) M is an attribute of T and it is neither a virtual attribute nor a\r
+ formal parameter. Then the declaration of M is determined as (at\r
+ compilation time) as the declaration of the attribute M of unit T. The\r
+ environment of the unit M is the dynamic container of identifier M with\r
+ respect to the object O1.\r
+ \r
+ (a2) M is a virtual attribute of T. Then the declaration of M is\r
+ determined at run-time by the dynamic location of identifier M with respect\r
+ to the given occurrence (see 6.1.5.). The environment is determined as in\r
+ (a1).\r
+ \r
+ (a3) M is a formal subprogram of T. Then the declaration of M and its\r
+ environment are taken from the dynamic container of the identifier M. The\r
+ dynamic container is determined with respect to the object O1.\r
+ \r
+ Ad (b). Let X be a well-formed object expression of type R, let M be a\r
+ not close attribute of R, and let the expression X be defined. Denote by O2\r
+ the non-empty object of unit R0 (R pref* R0) which is pointed to by X. The\r
+ cases (a1)-(a3) have to be considered in the same way as the above ones.\r
+ The descriptions differ in that the environments are determined with\r
+ respect to the object O2. Note that the environment of the object becomes\r
+ the syntactic father of the object O.\r
+1 - 79 -\r
+ \r
+ \r
+ Dynamic compatibility of parameters.\r
+ \r
+ First let us note the difference between the determination of dynamic type\r
+ for the actual parameter Pa and the formal parameter Pf. The dynamic type\r
+ of Pa is determined in the environment of the object O1 (containing the\r
+ given allocation). It means that for the formal type S the actual type is\r
+ taken from the dynamic container with respect to O1. Recall that it\r
+ corresponds to the determination of the valuation of identifier S in the\r
+ SL-chain of O1 (according to the visibility rules) and taking the text of\r
+ declaration assigned to S (cf. 6.1.5.).\r
+ The dynamic type of Pf is determined in the corresponding environment. It\r
+ means that for the formal type S the actual type is taken from the\r
+ corresponding dynamic container. In other words, the valuation of\r
+ identifier S is searched for in the SL-chain of the environment (according\r
+ to the visibility rules).\r
+ \r
+ The list of formal parameters is dynamically compatible with the list of\r
+ actual parameters if the following conditions hold:\r
+ \r
+ - if Pfi is an input formal parameter, then Pai is defined and\r
+ the dynamic type of Pfi is dynamically consistent with the\r
+ type of the value of Pai,\r
+ - if Pfi is an output/inout formal parameter, then Pai is\r
+ defined and the dynamic type of Pai is statically consistent\r
+ (!) with the dynamic type of Pfi,\r
+ - if Pfi is a formal function (procedure), then the lists of\r
+ formal parameters of Pfi and that of Pai must be of the same\r
+ pattern (disregarding the descriptions of subprogram\r
+ parameters). They may differ in the parameter identifiers, and\r
+ they may differ in the class types of corresponding parameters\r
+ (however, the class types must belong to the same prefix\r
+ sequence),\r
+ - if Pfi is a formal function, then the dynamic type of Pfi\r
+ prefixes the dynamic type of Pai, or the two types are\r
+ identical.\r
+ \r
+ The above conditions are checked from left to right (i.e., for i=1, ...,\r
+ k).\r
+ \r
+ Recall that in the following description of prologue and epilogue the\r
+ computations of the values and addresses for formal parameters and actual\r
+ ones are performed in the syntactic environment of the object O1.\r
+1 - 80 -\r
+ \r
+ \r
+ Prologue.\r
+ \r
+ The prologue consists of the following steps:\r
+ \r
+ (i) The frame for a new object O is allocated, the object O1 is called\r
+ the dynamic father of the object O. The sequence of dynamic fathers creates\r
+ a chain called the DL chain (DL for dynamic links);\r
+ \r
+ (ii) For the input and inout formal parameter Pf, the value of the\r
+ corresponding actual parameter is computed and assigned to Pf;\r
+ \r
+ (iii) For the output and inout formal parameter Pf, the address of the\r
+ corresponding actual parameter Pa is computed (in other words, the prologue\r
+ of the assignment of Pf to Pa is performed);\r
+ \r
+ (iv) For the formal type parameter Pf, the corresponding actual type Pa\r
+ is determined. According to 6.1.5. the valuation of the object O assigns\r
+ the text of the determined type Pa to the identifier Pf. Therefore as long\r
+ as that object exists the access to Pf is well-defined and connected with\r
+ Pa;\r
+ \r
+ (v) For the formal subprogram parameter, the actual subprogram is fixed\r
+ (in the same way as the determination of the allocated unit and its\r
+ environment).\r
+ \r
+ \r
+ After the execution of the epilogue the control is transferred to the\r
+ object O. Let M1, ..., Mk=M be the prefix sequence of M. The execution of\r
+ the statements from the object O begins from the first statement of the\r
+ unit M1 (for the description of the further progress of computation, see\r
+ inner statement, 9.1.3.). Note that those statements are executed in the\r
+ syntactic environment of the object O. When the control returns to the\r
+ calling object O1, the actions of the epilogue are performed.\r
+1 - 81 -\r
+ \r
+ \r
+ Epilogue.\r
+ \r
+ The epilogue consists of the following steps:\r
+ \r
+ (i) For the output and inout formal parameter Pf the actions of the\r
+ epilogue for the assignment Pa:=Pf are performed, where Pa is the actual\r
+ parameter corresponding to Pf. It means that the value of Pf (computed\r
+ during the execution of the body) is assigned to Pa (this address was\r
+ computed during the prologue);\r
+ \r
+ (ii) If the unit is a function, then the result of the given call is\r
+ determined by the current value of the corresponding variable result,\r
+ \r
+ (iii) If the unit is a generalized class, then the result of a new M is a\r
+ reference to the object O;\r
+ \r
+ (iv) A terminated object (cf. 9.1.3.) of a block or a subprogram is\r
+ deallocated. However, the terminated object of a generalized class is\r
+ accessible as long as there is a reference pointing to it (unless it is\r
+ directly deallocated by means of the kill statement).\r
+ \r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ Note that for the input formal parameter Pf of non-primitive type, the\r
+ value of the corresponding actual variable parameter Pa may be updated\r
+ (both the formal parameter and the actual one point to the same object). In\r
+ order to access the value of Pa without the possibility of its modification\r
+ one can use the copying statement Pf:=copy(Pf) at the end of the unit body.\r
+ \r
+ End of remark.\r
+ --------------\r
+1 - 82 -\r
+ \r
+ \r
+ Array generation.\r
+ -----------------\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <array generation>:\r
+ \r
+ ----> new_array -----> <variable > -----> ( -->!\r
+ !\r
+ !<----------------------------------------------!\r
+ !\r
+ !--> <arithmetic expression> --> : --> <arithmetic expression>--> ) -->\r
+ \r
+ \r
+ A declaration of a variable of an array type fixes the type of the array\r
+ elements; bound pairs are fixed at the time of generation.\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ A statement new_array Y dim (l:u) is a WFF if:\r
+ \r
+ - Y is a variable of the type (array_of)<i>T, where i>0, T is a type\r
+ identifier;\r
+ \r
+ - l, u are WFFs and arithmetic expressions.\r
+ \r
+ The above statement is considered to be an assignment of a reference (to a\r
+ newly created object) on the variable Y.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The following actions are performed:\r
+ \r
+ - determine the address of variable Y;\r
+ - compute the values l1, u1 of expressions l, u;\r
+ - put l0, u0 truncations of l1, u1 respectively;\r
+ - check the condition l0<=u0;\r
+ - generate an array object and assign its address to Y.\r
+ \r
+ The initial values of attributes (l0), ..., (u0) depend on their type of\r
+ the form (array_of)<i-1>T.\r
+ The value of an array type variable may be changed by means of\r
+ assignment, copying, and generation statements. The generation of an\r
+ n-dimensional array consists of n steps. The first dimension is generated:\r
+ e.g. new_array Y dim (l1:u1),\r
+ next the second dimension:\r
+ e.g. for i:=l1 to u1 do new_array Y(i) dim (li2:ui2) od\r
+ and so on. Unregular arrays can be generated in this way.\r
+1 - 83 -\r
+ \r
+ \r
+ 9.1.2.2. Deallocation statement\r
+ *******************************\r
+ SYNTAX.\r
+ -------\r
+ <object deallocation>:\r
+ \r
+ ----> kill ----> ( ----> <object expression> ----> ) --->\r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ A statement kill(X) is a WFF if X is a well formed object expression of\r
+ compound type. The statement kill(none) is always WFF and it is equivalent\r
+ to the empty statement.\r
+ The statement is defined if X points to an object O not belonging to the\r
+ SL chain or DL chain of an active object. By an active object we mean the\r
+ object containing the statement currently being executed (notice that in\r
+ the case of parallelism there may co-exist several active objects).\r
+ The execution of the statement results in the deallocation of object O,\r
+ all variables pointing to O are set to none. The deallocation of an object\r
+ which belongs to the SL chain or DL chain of an active object results in a\r
+ run-time error.\r
+ The statement kill(X) where X points to a coroutine head is described in\r
+ 9.1.4. The statement kill(X) where X points to a process is described in\r
+ 11.1.\r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ After a block or subprogram termination, the corresponding object is\r
+ automatically deallocated. On the other hand, the array, class, coroutine,\r
+ or process objects are not automatically deallocated. The computer memory\r
+ may be overloaded with such objects even if they are no longer referenced.\r
+ Those objects are recovered with the help of the system program called the\r
+ garbage collector. The user can help in the execution of that system\r
+ program and increase the efficiency of his program execution if he\r
+ deallocates unnecessary objects. One should realize, however, what are the\r
+ effects of deallocation (in particular, a side effect consisting in the\r
+ modification of the values of all variables which point to the same\r
+ deallocated object).\r
+ \r
+ End of remark.\r
+ --------------\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ The deallocation of a binary tree can be performed by means of the\r
+ following recursive procedure:\r
+ \r
+ unit tree_kill: procedure (n:node);\r
+ begin\r
+ if n.l=/=none then call tree_kill(n.l) fi;\r
+ if n.r=/=none then call tree_kill(n.r) fi ;\r
+ kill(n)\r
+ end tree_kill\r
+ \r
+ where the class node has the form\r
+ \r
+ unit node: class;\r
+ var l, r: node ;\r
+1 - 84 -\r
+ \r
+ \r
+ end node;\r
+1 - 85 -\r
+ \r
+ \r
+ 9.1.3. Simple control statement\r
+ ********************************\r
+ \r
+ \r
+ There are two kinds of simple control statements: a textual control\r
+ statement and a dynamic control statement. In this section we shall\r
+ consider the occurrence of a control statement in the object O of the unit\r
+ M, in the body of the unit Mj, where M has the prefix sequence M1, ...,\r
+ Mk=M, and 1<=j<=k.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <simple control statement>:\r
+ \r
+ -----> <textual control statement> -------->\r
+ ! ^\r
+ !--> <dynamic control statement> --->!\r
+ \r
+ <textual control statement>:\r
+ \r
+ -------> inner ----->\r
+ ! !\r
+ ! !\r
+ !-----> exit ----->!\r
+ ! ! ! !\r
+ ! !<------! !\r
+ ! ! !\r
+ !---> repeat ----->!\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ For j=1, ..., k-1 the execution of the inner statement results in the\r
+ commencement of the execution of the unit Mj+1. The inner statement in the\r
+ body of the unit Mk=M is empty.\r
+ \r
+ ------- ------- ------- -------\r
+ ! ! ! ! ! ! ! !\r
+ inner < inner < ........ < inner < .....\r
+ ! ! ! ! ! ! ! !\r
+ ------- ------- ------- -------\r
+ \r
+ body of M1 body of M2 body of Mk-1 body of Mk\r
+ \r
+ The semantics of repeat and exit statements will be defined jointly with\r
+ the semantics of a loop statement, see 9.2.3..\r
+1 - 86 -\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <dynamic control statement>:\r
+ \r
+ ---------> return ----------->\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ In this section we shall describe the semantics of a return statement and\r
+ a pseudo-statement end (which bound a unit declaration).\r
+ An object may be in one of the following three states: non-generated,\r
+ generated, terminated. An object is non-generated until the control reaches\r
+ the first return statement. From that moment an object becomes generated.\r
+ An object is terminated after the execution of its end statement. The main\r
+ program is considered to be always generated. A generated object is\r
+ considered to have no dynamic father (its DL is none). Note that the\r
+ execution of a terminated object cannot be resumed. However, the execution\r
+ of the generated object of a coroutine or a process can be resumed and\r
+ suspended. The return statement is empty if M is a coroutine and O is\r
+ generated. If M is a block, subprogram, or generalized class and O is\r
+ non-generated then O becomes generated. The control returns to the dynamic\r
+ father of O. For a coroutine or process the statement following the return\r
+ statement is a reactivation point.\r
+ \r
+ Now we shall consider the execution of the final end. For j=2, ..., k the\r
+ execution of the final end results in the control transfer to the statement\r
+ following the inner statement from the unit Mj-1. Suppose that j=1. If O is\r
+ a non-generated object of a coroutine, then O becomes generated and the\r
+ control returns to the dynamic father of O. Otherwise (O is a\r
+ coroutine/process object) the object O becomes terminated. The control\r
+ transfer is the same as in the case of detach statement. Moreover, if M is\r
+ a process, then the control becomes idle (and the corresponding processor\r
+ may be released, see 11).\r
+1 - 87 -\r
+ \r
+ \r
+ 9.1.4. Coroutine statement\r
+ ***************************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <coroutine statement>:\r
+ \r
+ ------> detach ---------------------------------------------->\r
+ ! ^\r
+ !-----> attach ----> ( ---> <object expression>--> ) -->!\r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ By a chain of coroutine N with the head Ol we shall mean the DL chain of\r
+ objects O1, ..., Ol such that:\r
+ - for i=1, ..., l-1 the object Oi+1 is the dynamic father of Oi;\r
+ - Ol is the generated object of the coroutine N;\r
+ - Ol is non-terminated.\r
+ Thus the chain contains non-generated objects with the exception of the\r
+ head, which is generated but non-terminated.\r
+ The execution of a kill(X) statement where X points to the head Ol of the\r
+ coroutine chain results in a deallocation of the entire chain.\r
+ \r
+ The chain may be in one of the following two states:\r
+ - detached - the execution of the statements contained in this\r
+ chain is suspended, the object O1 contains a distinguished\r
+ point, called the reactivation point of the chain;\r
+ - attached - a statement from the object O1 is currently\r
+ executed.\r
+ \r
+ In the case of a sequential program exactly one chain is operational,\r
+ i.e., in the attached state. Note that a coroutine head may be the main\r
+ program. Coroutine control statements change the states of coroutine\r
+ chains. A reference to the coroutine chain W1 which has recently\r
+ transferred the control to the chain W is associated with chain W. Let us\r
+ denote this reference by CL (coroutine link). This link is then used by the\r
+ detach statement. Suppose that the object O (containing the occurrence of\r
+ the coroutine control statement) belongs to the chain W of the coroutine N\r
+ with the head Ol.\r
+ The statement attach(X) is a WFF if X is a well formed object expression\r
+ or the system variable main. The statement is defined if X points to the\r
+ head O1 of a coroutine chain W1. The execution of the statement results in\r
+ changing the state of W to a detached one and that of W1 to an attached\r
+ one. The statement determined by the reactivation point of the chain W1\r
+ starts its execution. The CL link to the chain W is associated with the\r
+ chain W1. If O=O1 then the statement is empty.\r
+ The statement detach is defined except the case where the CL link of\r
+ chain W is none. The execution of the statement results in detaching the\r
+ chain W and attaching the chain W1 determined by the corresponding CL link\r
+ associated with W. The statement following the detach statement is the\r
+ reactivation point of the chain W. The execution of the chain W1 is resumed\r
+ at its reactivation point.\r
+1 - 88 -\r
+ \r
+ \r
+ 9.2. Compound statements\r
+ *************************\r
+ \r
+ Compound statements define case analysis (conditional and case statement)\r
+ and iteration (loop statements).\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <compound statement):\r
+ \r
+ ----------> <conditional statement> -------->\r
+ ! ^\r
+ !-----> <case statement> ------->!\r
+ ! !\r
+ !-----> <loop statement> ------->!\r
+ \r
+ \r
+ \r
+ \r
+ 9.2.1. Conditional statement\r
+ *****************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <conditional statement>:\r
+ \r
+ ---> if --> <boolean expression> --> then --> <statement list>\r
+ ! ! !\r
+ !---> <orif list> ------->! !\r
+ ! ! !\r
+ !---> <andif list> ------>! !\r
+ !\r
+ !\r
+ !\r
+ <-----------------------------------------------!\r
+ ! !\r
+ !------> else --> <statement list> --------> fi ---------->\r
+ \r
+ \r
+ \r
+ \r
+1 - 89 -\r
+ \r
+ \r
+ <orif list>:\r
+ \r
+ ---- <boolean expression> ----------------->\r
+ ! !\r
+ !<------- or_if <----------!\r
+ \r
+ \r
+ <andif list>:\r
+ \r
+ ---- <boolean expression> ----------------->\r
+ ! !\r
+ !<------ and_if <----------!\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ \r
+ For the execution of an if statement of the form:\r
+ \r
+ if B1 or_if B2 ... or_if Bj\r
+ then\r
+ G\r
+ else\r
+ H\r
+ fi\r
+ \r
+ \r
+ the boolean expressions B1, .., Bj are evaluated in succession until the\r
+ first one evaluates to true, then the sequence G of statements is executed.\r
+ If none of the boolean expressions evaluates to true, then the sequence H\r
+ is executed. The conditional statement with the "else" part omitted is\r
+ equivalent to the conditional statement with the empty statement following\r
+ the else symbol. If the "andif" list occurs instead of the "orif" list,\r
+ then the expressions B1, ..., Bj are evaluated in succession until the\r
+ first one evaluates to false; then the sequence H is executed. Otherwise\r
+ the sequence G is executed. When a boolean expression occurs instead of an\r
+ "orif" or "andif" list, then its value controls the execution of the\r
+ conditional statement in the standard manner.\r
+1 - 90 -\r
+ \r
+ \r
+ 9.2.2. Case statement\r
+ **********************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <case statement>:\r
+ \r
+ ----> case --!\r
+ !\r
+ !-----------!\r
+ ! !-------------------->!\r
+ ! ! !\r
+ ! <---- <statement list> <--- : -----! !\r
+ ! ! ! !\r
+ !-> <arithmetic expression> ---> when ---> ---<integer>-------->! !\r
+ ! ^ ! ^ ! !\r
+ ! ! -> <constant> ->! ! !\r
+ ! ! ! !\r
+ ! <----- , -------------! !\r
+ ! !\r
+ !-> <character expression> ---> when ---><character constant>->:-! !\r
+ ^ ^ ! ^ ! ! !\r
+ ! ! !-> <constant> ->! ! ! !\r
+ ! ! ! ! !\r
+ ! !<--------- , --------! ! !\r
+ ! ! !\r
+ !<------ <statement list> <----------! !\r
+ ! !\r
+ ! !\r
+ <------------------------------------------------------------!\r
+ ! !\r
+ ! !\r
+ !-> others ----> <statement list> ---------> esac ---->\r
+ \r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ A statement:\r
+ \r
+ case E\r
+ when l1:G1\r
+ ...\r
+ when lk:Gk\r
+ others H\r
+ esac\r
+ \r
+ is a WFF if E is an arithmetic or character expression and l1, ..., lk are\r
+ sequences of different constants. If the list H is empty, then the "others"\r
+ part can be omitted.\r
+ The case statement selects for execution a sequence Gi where the value of\r
+ E belongs to the sequence li. The choice others covers all values (possibly\r
+ none) not given in the previous choices. The choices in a case statement\r
+ must be mutually disjoint and if the "others" part is not present they must\r
+ exhaust all the possibile values of the expression E.\r
+ \r
+ \r
+ \r
+1 - 91 -\r
+ \r
+ \r
+ 9.2.3. Iteration statement\r
+ ***************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <iteration statement>:\r
+ \r
+ \r
+ -------> <loop statement> ---------------------------------------->\r
+ ! ^\r
+ !---> <loop statement with condition> --------------------->!\r
+ ! !\r
+ !---> <loop statement with control variable> -------------->!\r
+ \r
+ \r
+ <loop statement>:\r
+ \r
+ \r
+ ---> do -----> <statement list> ----> od --->\r
+ \r
+ \r
+ <loop statement with condition>:\r
+ \r
+ \r
+ --> while --> <boolean expression> --> do --> <statement list>--> od -->\r
+ \r
+ \r
+ <loop statement with control variable>:\r
+ \r
+ ---> for ---> <simple variable> -->:= --> <arithmetic expression> -->!\r
+ !\r
+ <------------------------------------------------------------------!\r
+ ! !\r
+ !--> step --> <arithmetic expression>----> to ----->!\r
+ ! !\r
+ !-->downto-->!\r
+ !\r
+ <---------------------------------------------------!\r
+ !\r
+ !-> <arithmetic expression> -->do--> <statement list>--->od -->\r
+1 - 92 -\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ Let us start from the semantics of loop and exit statements. The loop\r
+ statement:\r
+ \r
+ do\r
+ G\r
+ od\r
+ \r
+ causes the iteration of the sequence G until an exit statement is\r
+ encoutered.\r
+ Consider the occurrence of the exit statement exit ... exit(k-times)\r
+ where k >=1 . Let us denote this statement by H. Suppose that statement H\r
+ occurs in l (l>=0) nested iteration statements G1, ..., Gl, i.e., the\r
+ statement G2 is nested in G1, G3 in G2, etc. Let M be the smallest unit\r
+ enclosing that occurrence of H.\r
+ If k>l then the execution of H causes the termination of the unit body M\r
+ (jump to the final end). Otherwise the iteration statement Gk terminates,\r
+ and either the execution of the iteration statement Gk-1 is continued if\r
+ k<l or the execution of the outermost iteration statement G1 terminates if\r
+ k=l.\r
+ The keyword repeat may occur just after the sequence of exit's. Then the\r
+ iteration statement Gk is continued (if k<=l), i.e., the control is\r
+ switched not outside but to the beginning of the loop without the execution\r
+ of the statements occurring after repeat. If the statement Gk is a loop\r
+ statement with the while condition, then the consequtive iteration starts\r
+ from the condition evaluation. If it is a for statement, then the\r
+ consequtive iteration starts with the change of the controlled variable\r
+ value.\r
+ \r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ The goto statement is totally deleted from LOGLAN-82 (contrary to other\r
+ languages, like ADA where goto within a single unit is allowed). The\r
+ structured statements defined above were applied to many examples of known\r
+ algorithms. These exercises showed that the proposed structured statements\r
+ constitute a good balance point between a non structured goto-label\r
+ statement and a classical while statement (which often requires auxiliary\r
+ control boolean variables).\r
+ Notice that the above unit M body is considered to be "non-concatenated",\r
+ i.e., in the case of the jump to end symbol, this end is taken from the\r
+ body of M, not from the body of M concatenated with its prefix sequence. We\r
+ stress that the textual control statements do not lead outside one unit.\r
+ \r
+ End of remark.\r
+ --------------\r
+1 - 93 -\r
+ \r
+ \r
+ A loop statement with condition:\r
+ \r
+ while B\r
+ do\r
+ G\r
+ od\r
+ \r
+ is equivalent to a loop statement of the form:\r
+ \r
+ do\r
+ if not B then exit fi;\r
+ G\r
+ od\r
+ \r
+ A loop statements with controlled variables are of the forms:\r
+ \r
+ (*) for i:=A1 step A2 to A3 do G od\r
+ (**) for i:=A1 step A2 downto A3 do G od\r
+ \r
+ The controlled variable i must be of discrete type. The statement (*) is\r
+ equivalent to the following sequence of statements:\r
+ \r
+ Av1:=A1; Av2:=A2; Av3:=A3; i:=Av1;\r
+ while Av3>=i\r
+ do\r
+ G;\r
+ i:=i+Av2\r
+ od\r
+ \r
+ The statement (**) is equivalent to the above sequence of statements with\r
+ the condition Av3>=i replaced by Av3<=i and the assignment i:=i+Av2\r
+ replaced by i:=i-Av2. The variables Av1, Av2, Av3 are fictitious variables\r
+ introduced only in order to define the semantics. The expression step A2\r
+ may be omitted if the value of A2 equals 1. The value of the controlled\r
+ variable i should not be modified inside the loop (however, the result of\r
+ such a modification would be well-defined). Moreover, its value is\r
+ determined when loop is terminated according to the introduced semantics.\r
+1 - 94 -\r
+ \r
+ \r
+ Examples.\r
+ ---------\r
+ \r
+ \r
+ (1) A palindrome is a word which is identical when written from left to\r
+ right and conversely. The given algorithm looks for the first occurrence of\r
+ a palindrome in a text and writes its length, (if found).\r
+ \r
+ unit palindrome: procedure;\r
+ var i, j, k: integer,\r
+ text: array_of character;\r
+ begin\r
+ read(j);\r
+ new_array text dim (1:j);\r
+ for k:=1 to j\r
+ do\r
+ read (text(k))\r
+ od;\r
+ for i:=2 to j\r
+ do\r
+ k:=1;\r
+ while text(k)=text(i-k+1)\r
+ do\r
+ k:=k+1;\r
+ if k>i-k+1\r
+ then\r
+ write ("found at i-th item");\r
+ return\r
+ fi\r
+ od\r
+ od;\r
+ write ("not found")\r
+ end palindrome;\r
+1 - 95 -\r
+ \r
+ \r
+ (2) A dictionary is a data structure S with the following operations:\r
+ \r
+ member(x, S) - determines whether x is a member of S\r
+ insert(x, S) - replaces S by the union of S and (x)\r
+ delete(x, S) - replaces S by the difference of S and (x)\r
+ \r
+ The elements of the set S are assumed to be of the same type T and to be\r
+ ordered by the relation less. A dictionary will be implemented by means of\r
+ binary search trees. The user has the access to the operations member,\r
+ insert, and delete and does not have to bother about the way of their\r
+ implementation. Below we propose how to accomplish these operations as\r
+ coroutines.\r
+ \r
+ unit bst: class (type t; function less(x, y:t):boolean);\r
+ hidden root, e, i, d;\r
+ var root: node, member: e, insert: i, delete: d;\r
+ unit node: class (value: t);\r
+ var l, r: node;\r
+ end node;\r
+ \r
+ unit e: coroutine; (*elem- output attribute*)\r
+ close trick, q, v;\r
+ var trick, elem: boolean, q, v: node, x:t;\r
+ begin\r
+ return;\r
+ do trick, elem:=false; (* loop for member *)\r
+ q:=root;\r
+ v:=none;\r
+ while q=/=none\r
+ do\r
+ if less(x, q.value)\r
+ then v:=q; q:=q.l\r
+ else\r
+ if less(q.value, x)\r
+ then v:=q; q:=q.r\r
+ else elem:=true; exit\r
+ fi\r
+ fi\r
+ od;\r
+ inner; (* elem=true iff x belongs to S *)\r
+ detach;\r
+ od\r
+ end e;\r
+ \r
+ unit help: E coroutine;\r
+ taken trick, elem, q, v, x;\r
+ begin\r
+ inner; (* trick=true iff x does not belong to S *)\r
+ if not trick then exit fi;\r
+ if v=none\r
+ then root:=q\r
+ else\r
+ if less(x, v.value)\r
+ then v.l:=q\r
+ else v.r:=q\r
+ fi (* after insert or delete *)\r
+ fi (* attach new node q to its father v *)\r
+ end help;\r
+1 - 96 -\r
+ \r
+ \r
+ unit i: help coroutine;\r
+ taken trick, elem, q, x;\r
+ begin\r
+ trick:=true;\r
+ if elem then exit fi;\r
+ q:=new node(x) (* insert is a dummy if x belongs to S *)\r
+ end i;\r
+ \r
+ unit d: help coroutine;\r
+ taken elem, q;\r
+ hidden close w, u, s;\r
+ var w, u, s: node;\r
+ begin (* delete is a dummy if x does belong to S *)\r
+ if not elem then exit fi;\r
+ w:=q;\r
+ if q.r=none\r
+ then q:=q.l\r
+ else\r
+ if q.l=none\r
+ then q:=q.r\r
+ else u:=q.r;\r
+ if u.l=none\r
+ then u.l:=q.l; q:=u\r
+ else\r
+ do s:=u.l;\r
+ if s.l=none then exit fi;\r
+ u:=s\r
+ od;\r
+ s.l.:=w.l; u.l:=s.r;\r
+ s.r:=w.r; q:=s\r
+ fi\r
+ fi\r
+ fi;\r
+ kill(w)\r
+ end d;\r
+ \r
+ begin\r
+ member:=new e; insert:=new i; delete:=new d;\r
+ inner;\r
+ kill(member); kill(insert); kill(delete)\r
+ end bst;\r
+ \r
+ pref bst(t, less) block\r
+ taken member, insert, delete;\r
+ var y:t;\r
+ ...\r
+ begin\r
+ ...\r
+ member.x:=y;\r
+ attach(member);\r
+ if member.elem then ... fi;\r
+ ...\r
+ insert.x:=y;\r
+ attach(insert);\r
+ ...\r
+ delete.x:=y;\r
+ attach(delete);\r
+ ...\r
+ end;\r
+1 - 97 -\r
+ \r
+ \r
+ 10. Exception handling\r
+ #######################\r
+ \r
+ \r
+ This section defines the facilities for dealing with errors or other\r
+ exceptional situations that may arise during program execution. An\r
+ exception is an event that causes a suspention of normal program execution.\r
+ The occurrence of an exception is expressed by raising a signal. Executing\r
+ some actions in response to the arising of an exceptional situation, is\r
+ called signal handling.\r
+ \r
+ Signal names are introduced by signal specifications. Signals can be\r
+ raised by raise statements, or alternatively, their raising is caused by an\r
+ occurrence of a run-time error. When an exception arises, the control can\r
+ be passed to a user-pointed handler associated with the raised signal. The\r
+ principles of determining a handler that responds to the raised signals are\r
+ presented in 10.3.\r
+ \r
+ \r
+ 10.1 Signal specification\r
+ *************************\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <signal specification>:\r
+ \r
+ ----> signal ---> <signal name> ---> ( --> <formal par. list> --> ) -->; -->\r
+ ! ! !!\r
+ ! !-------------------------------->!!\r
+ !<---------------------- , ---------------------------!\r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ The signal specification defines signals which can appear in raise\r
+ statements and in signal handlers within the scope of the specification.\r
+ The identifiers of system signals, i.e., signals associated with run-time\r
+ errors, are not specified in the signal specification.\r
+ Signal identifiers are not accessible by remote access. They can occur,\r
+ however, in a hidden, close or taken list of a unit.\r
+1 - 98 -\r
+ \r
+ \r
+ 10.2 Signal handlers\r
+ ********************\r
+ \r
+ The response to one or more signals is specified by a signal handler.\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <handlers' declaration>:\r
+ \r
+ ---> handlers\r
+ !\r
+ !-----------> when ---> <signal name> --> : --> <statement list> --!\r
+ ! ! ! !\r
+ ! !<------ , -------! !\r
+ ! !\r
+ !--------<------------------------------------------------------!\r
+ !\r
+ !-----------> others ----> <statement list> --!\r
+ ! !\r
+ !----------------------------------------> end handlers\r
+ ! !\r
+ !-------------->\r
+ CONTEXT\r
+ -------\r
+ \r
+ Handlers' declaration may appear at the end of the declaration part of a\r
+ unit. All identifiers visible in the unit and the signal formal parameters\r
+ may be used in the handler statements. A handler can handle the named\r
+ signals. A handler corresponding to the choice others handles all signals\r
+ not listed in the previously specified handlers, including those whose\r
+ identifiers are not visible within the unit.\r
+ \r
+ Any statement (except inner) whose occurrence in a unit is legal may\r
+ occur in the handler.\r
+ \r
+ Restrictions\r
+ ------------\r
+ \r
+ The formal parameter lists of signals associated with the same handler\r
+ must be identical.\r
+ \r
+ Example\r
+ -------\r
+ \r
+ \r
+ handlers\r
+ when emptytree: T:=new treelem; return;\r
+ others write(" signal not handled"); raise Error;\r
+ end handlers\r
+1 - 99 -\r
+ \r
+ \r
+ 10.3. Signal raising\r
+ ********************\r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ \r
+ ----> raise ---> <signal name> --> ( --> <actual par. list> --> ) ----->\r
+ ! !\r
+ !----------------------------------->!\r
+ \r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ The signal name in the raise statement ought to be visible in the unit in\r
+ which the raise statement appears. The formal and actual parameter lists of\r
+ the signal must be compatible.\r
+ \r
+ Example\r
+ -------\r
+ \r
+ raise empty(exprstack);\r
+ raise end_of_file (input);\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ When a signal is raised, the normal process execution is suspended and\r
+ the control is passed to a signal handler. The actual parameters are\r
+ transmitted to the handler, as in the case of a procedure. However, the\r
+ crucial point of exception handling is the way in which such a handler is\r
+ searched for and activated. Below we present the principles of handler\r
+ determination.\r
+ \r
+ Let us assume that signal f is raised in object Ok. This object and its\r
+ corresponding DL-chain may be illustrated as follows:\r
+ \r
+ \r
+ ------------ ------------ ------------\r
+ ! ! ! ! ! !\r
+ ! ! !handlers ! ! !\r
+ ! !<---...........<---!when f !<---........<---!raise f !\r
+ ! ! ! ! ! !\r
+ ! ! ! ! ! !\r
+ ------------ ------------ ------------\r
+ O1 Oi Ok\r
+ \r
+ where O1 is the object of a coroutine or a process.\r
+1 - 100 -\r
+ \r
+ \r
+ The objects in the DL-chain of Ok are successively checked whether they\r
+ contain a handler for signal f or a handler corresponding to the choice\r
+ others. The object Ok is checked first, next the object Ok-1 is checked and\r
+ so on. This search stops when the first object Oi containing the handler\r
+ for f or the handler for others is found. If such a handler is not found in\r
+ this DL-chain, then the system trap handler is executed and the process\r
+ terminates.\r
+ For the situation presented in the figure, the handler from object Oi is\r
+ executed, provided that none of the objetcs Oi+1, ..., Ok contains a\r
+ handler for signal f or the handler for others.\r
+ \r
+ In a concatenated object, i.e., in an object corresponding to a unit with\r
+ a non-empty prefix, the handlers declared in the prefixing unit are covered\r
+ by the handlers declared in the prefixed unit if they have the same\r
+ identifiers. Thus the signal raised during the execution of the prefix\r
+ statements may be handled by a handler declared in the prefixed unit. The\r
+ handler corresponding to the choice others responds to all the signals not\r
+ listed in the handlers declared in the units from the prefix sequence. The\r
+ handler for the choice others is taken from the innermost unit (with\r
+ respect to prefixing).\r
+ \r
+ Example\r
+ -------\r
+ \r
+ block\r
+ unit A: procedure;\r
+ begin\r
+ ...\r
+ raise f\r
+ ...\r
+ end A;\r
+ unit B: procedure;\r
+ handlers\r
+ when f: .....; (* <----------- handler H1 *)\r
+ end handlers\r
+ begin\r
+ ...\r
+ call A;\r
+ ...\r
+ raise f;\r
+ ...\r
+ end B;\r
+ signal f;\r
+ handlers\r
+ when f: .....; (* <----------- handler H2 *)\r
+ end handlers;\r
+ begin\r
+ ...\r
+ raise f;\r
+ ...\r
+ call B;\r
+ ...\r
+ end\r
+ \r
+ If signal f is raised in the block satement, hanlder H2 will be executed.\r
+ If signal f is raised in procedure B or in procedure A, handler H1 will be\r
+ executed.\r
+1 - 101 -\r
+ \r
+ \r
+ block\r
+ signal f;\r
+ unit A:class;\r
+ signal g;\r
+ handers\r
+ when g: .....; (* <---------- handler G1 *)\r
+ end handlers;\r
+ begin\r
+ ...\r
+ raise f;\r
+ ...\r
+ raise g;\r
+ ...\r
+ end A;\r
+ unit B:A class;\r
+ handlers\r
+ when f: .....; (* <---------- handler F1 *)\r
+ when g: .....; (* <---------- hadller G2 *)\r
+ end handlers;\r
+ begin\r
+ ...\r
+ raise f;\r
+ ...\r
+ raise g;\r
+ ...\r
+ end B;\r
+ begin\r
+ ...\r
+ end;\r
+ \r
+ If signal f is raised in an object of class B, handler F1 will be\r
+ executed. If signal g is raised in an object of class B, handler G2 will be\r
+ executed even if the signal is raised in the statements of class A.\r
+1 - 102 -\r
+ \r
+ \r
+ 10.4. Handler execution\r
+ ***********************\r
+ \r
+ A handler execution terminates if one of the special control statements\r
+ is executed.\r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <handler termination>:\r
+ \r
+ ------> return ----->!\r
+ ! !\r
+ --->!---> wind --------------->\r
+ ! !\r
+ !---> terminate ---->!\r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ The statements wind and terminate may appear only within a handler\r
+ declaration. If none of them occurs in a handler statement list, the\r
+ statement terminate is assumed to be the last statement in such a list.\r
+ The execution of the statements wind and terminate causes an abnormal\r
+ termination of the corresponding objects from the DL-chain (see below). In\r
+ that case, the "last-will" statements are executed before the termination\r
+ of the objects.\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <last-will statements>:\r
+ \r
+ -----> last_will ----> : ---> <statement list> ----------->\r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ Any unit body may be terminated with a sequence of statements labelled by\r
+ last_will. They are not executed during normal program execution. The\r
+ statement inner must not occur within the "last-will" statements.\r
+1 - 103 -\r
+ \r
+ \r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ Let us assume that a signal f raised in an object Ok is handled by a\r
+ handler H from an object Oi:\r
+ \r
+ \r
+ O1 Oi-1 Oi Oi+1 Ok\r
+ ----- ----- ----- ----- -----\r
+ ! ! <---...<---! !<---! !<----! !<---........<---! !\r
+ ----- DL ----- DL ----- DL ----- DL -----\r
+ ! !\r
+ ! SL !\r
+ ----- !\r
+ ! ! H-------------------------------->!\r
+ -----\r
+ \r
+ The statement return in a handler has a similar effect to that of the\r
+ statement return in a procedure. The handler object is deallocated and the\r
+ control is passed to the statement just following the corresponding raise\r
+ f.\r
+ The execution of the statement wind causes the termination and the\r
+ deallocation of the objects H, Ok, ..., Oi+1. Before the termination of\r
+ each of them, the "last-will" statements, if any, are executed. They\r
+ complete the object execution. In the prefixed object the "last-will"\r
+ statements of each prefix are successively executed, starting from the\r
+ innermost and ending on the outermost prefix. When the termination and\r
+ deallocation of these objects is completed, the control is passed to object\r
+ Oi, where the computation is continued in a normal way. Note that the wind\r
+ statement in the case of k=i is equivalent to return.\r
+ \r
+ The statement terminate causes the termination and the deallocation of\r
+ the objects H, Ok, ..., Oi+1, Oi. They are completed as in the case of\r
+ wind, i.e., the "last-will" statements are executed as well. The control is\r
+ passed to Oi-1, if such an object exists. If Oi-1 does not exists, i.e., Oi\r
+ is the head of the DL-chain, then this head is terminated (cf. the\r
+ semantics of the end statement of coroutine and process).\r
+ \r
+ \r
+ Remark\r
+ ------\r
+ \r
+ If any control statement (raise, detach, attach, etc.) is executed within\r
+ the "last-will" statements and the control returns to the interrupted\r
+ object, the execution of the "last-will" statements as well as the\r
+ termination of the remaining objects in the DL-chain will be continued.\r
+ \r
+ End of remark\r
+ -------------\r
+1 - 104 -\r
+ \r
+ \r
+ 10.5. System signals\r
+ ********************\r
+ \r
+ Some of the signals, called system signals, are predefined in the\r
+ language. They are raised automatically when a run-time error or another\r
+ exceptional system situation appears.\r
+ System signals have no parameters. They are not declared in the signal\r
+ specification, but the user may declare handlers for them. The execution of\r
+ the statement return is not allowed in the handler responding to such a\r
+ signal (note that sometimes the statement wind is equivallent to return).\r
+ \r
+ The following signals are predefined in the language:\r
+ \r
+ acc_error\r
+ A remote access to a non-existing object or an error in the\r
+ expression ...x qua A (x does not exist or the type of the object\r
+ pointed to by x is not prefixed by the type A).\r
+ mem_error\r
+ There is no free space for the allocation of a new object.\r
+ num_error\r
+ A numerical error, such as for instance integer overflow,\r
+ floating-point overflow, division by zero etc.\r
+ log_error\r
+ Any kind of the LOGLAN Running System error (except access error)\r
+ like e.g., an attempt to pass the control in a way inconsistent\r
+ with the LOGLAN-82 rules, an attempt to kill an active object, etc.\r
+ con_error\r
+ The value of an index expression exceeds the range of array indices\r
+ or the array bounds are incorrect.\r
+ sys_error\r
+ Any kind of system error like e.g., input-output error, parity\r
+ error, etc.\r
+ \r
+ Some other errors may also be introduced as system errors but are not\r
+ predefined in the language.\r
+1 - 105 -\r
+ \r
+ \r
+ 11. Processes\r
+ ##############\r
+ \r
+ \r
+ Let us consider a snap-shot of a program's computation. This snap-shot is\r
+ called a configuration. Up till now a configuration has consisted of a\r
+ finite number of objects creating a number of coroutine chains. The main\r
+ program is the only chain with the head of process type.\r
+ Moreover, exactly one object has been considered "active" - i.e., its\r
+ statements have been executed by a physical processor. By a physical\r
+ processor we mean here an actual processor as well as the portion of time\r
+ of a central unit.\r
+ A configuration with many active objects illustrates the computation of a\r
+ program with parallel statements. Concurrent computation to some extent\r
+ generalizes coroutines, i.e., a configuration may contain many coroutine\r
+ chains with heads of coroutine type and many process chains with heads of\r
+ process type.\r
+ The fundamental notion is that of a process. A process may be treated as\r
+ a sequential program - only one statement of a process is being executed at\r
+ a time. A parallel program consists of a number of processes. In LOGLAN-82\r
+ a process is a system type. A process object may be generated by means of\r
+ the new statement. The generated process object is suspended with the\r
+ execution of the return statement. This process may be resumed by means of\r
+ the resume statement. After resumption, process statements are executed by\r
+ a new processor, concurrently with the other active processes. During its\r
+ computations, the process may suspend its actions (but not the actions of\r
+ other processes) by means of the stop statement, then it may be resumed\r
+ again, and so on.\r
+ Observe that the attach and detach statements switch the processors from\r
+ one object to another, while the resume and stop statements acquire and\r
+ release a processor respectively. Resumption of a coroutine chain is\r
+ connected with the control transfer from the active coroutine chain.\r
+ Resumption of a process chain acquires new processor for that chain.\r
+ Similarly, suspension of a coroutine chain gives the control back to\r
+ another chain, while suspension of a process chain releases the processor.\r
+ Note that a process object is more complex than a coroutine object. So\r
+ coroutine operations are more efficient with respect to time and space.\r
+ Therefore the user should use processes only when they are indispensable.\r
+1 - 106 -\r
+ \r
+ \r
+ In order to deal with communication among processes (e.g., by messages)\r
+ as well as their competition in acquiring a resource (such as a shared\r
+ variable) one should have the ability to define some synchronizing\r
+ operations. Those operations arise from the following constrains:\r
+ \r
+ - timing, i.e., mutual exclusion of actions;\r
+ - scheduling i.e., stating which of the waiting processes is to be resumed\r
+ as the first one.\r
+ \r
+ \r
+ For this purpose some synchronizing facilities are provided. One may think\r
+ of many such facilities, from low level ones, such as Dijkstra's semaphores\r
+ to high level ones, such as Hoare's monitors. The decision which one of the\r
+ synchronization methods should be chosen and incorporated into the language\r
+ is weighty. The primitive tools are difficult to use, but they are\r
+ efficient. The high-level constructs are safer, but they often limit\r
+ parallelism (because of the strong synchronizing constraints).\r
+ The synchronizing facilities introduced in LOGLAN-82 are elementary (low\r
+ level). Therefore they are implemented efficiently in the kernel of the\r
+ operating system. However, the high-level facilities e.g., monitors (see\r
+ [5], [6]), can be defined with their help. The user can, for a concrete\r
+ synchronization problem, make a choice between the pre-defined facilities\r
+ or program other ones. The low-level facilities are hidden when the high\r
+ level facilities are used. Thus, the properties of the latter cannot be\r
+ disturbed.\r
+ In any case, speaking about a parallel execution of processes, we mean\r
+ that they are executed really in parallel, independently of the relations\r
+ between a number of "ready" processes and a number of available processors\r
+ (the details of processor management are hidden in an operating system).\r
+ \r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <parallel statement>:\r
+ \r
+ ------> <process state transition> ----------------->\r
+ ! ^\r
+ !--> <primitive synchronizing statement> ----->!\r
+ \r
+ \r
+1 - 107 -\r
+ \r
+ \r
+ 11.1. Transition state statement\r
+ *********************************\r
+ \r
+ \r
+ Each process can be in one of five states: active, suspended, locked,\r
+ awaiting, terminated. The transitions among these states are described by\r
+ the following graph (where X denotes the reference to the given process and\r
+ Z a semaphore):\r
+ \r
+ \r
+ \r
+ ****************\r
+ * awaiting *\r
+ **************** X:=new\r
+ ! ! !\r
+ ! ! !\r
+ end of son! ! wait !\r
+ ! ! !\r
+ lock(Z) v ! v\r
+ ************* <------ ************* ------------> ***************\r
+ * locked * * active * stop * suspended *\r
+ ************* -------> ************* <----------- ***************\r
+ unlock(Z) ! resume(X)\r
+ !\r
+ ! end of X\r
+ !\r
+ v\r
+ ******************\r
+ * terminated *\r
+ ******************\r
+ \r
+ \r
+ \r
+ We shall now present the syntax and semantics of object expressions and\r
+ statements connected with the transitions of the process states:\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <process state transition>:\r
+ \r
+ !---> <process suspension> ------------>\r
+ ! !\r
+ !---> <process resumption> ------->!\r
+ ! !\r
+ !------> <process waiting> ------->!\r
+1 - 108 -\r
+ \r
+ \r
+ \r
+ \r
+ <process suspension>:\r
+ \r
+ -----> stop --------> ( ---> <variable> ----> ) ------->\r
+ ! ^\r
+ !--------------------------------->!\r
+ \r
+ \r
+ <process resumption>:\r
+ \r
+ ----> resume -----> ( ---> <object expression> ---> ) ------>\r
+ \r
+ \r
+ <process waiting>:\r
+ \r
+ -----> wait -------------------------------------------->\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ \r
+ From now on we shall consider the occurrence of the transition state\r
+ statement in the object O which belongs to the process R (i.e., there\r
+ exists a DL chain connecting the object O with the object O(R) of the\r
+ process R). If the process O(P) is generated in the process O(R), then the\r
+ process object O(R) is called the father of the process object O(P), and\r
+ O(P) is called a son of O(R).\r
+ The execution of the statement resume(X), where X points to the process\r
+ object, causes resumption of that process, providing that it was previously\r
+ suspended. Otherwise a run-time error occurs.\r
+1 - 109 -\r
+ \r
+ \r
+ The statement stop suspends the process R. The statement stop(Z) is a\r
+ WFF if Z is a variable of type semaphore. The execution of this statement\r
+ suspends the given process and simultaneously opens semaphore Z. The\r
+ indivisibility of those actions means that no other process can refer to\r
+ the variable Z in the meantime (the statement stop(Z) is useful in the\r
+ synchronization of processes, see 11.2.).\r
+ \r
+ A process may wait for the termination of its son with the help of the\r
+ wait expression. The execution of the expression wait in an object\r
+ belonging to the process R causes waiting for the termination of any son of\r
+ the process R. When the first such son terminates its actions, the\r
+ reference to that son is returned as the value of wait and process R\r
+ continues its computation. If the process S does not embrace a\r
+ non-terminated son, the value of the expression wait is none. Thus the\r
+ execution of the statement\r
+ \r
+ while wait =/= none do od\r
+ \r
+ causes waiting for the termination of all the sons of the given process.\r
+ \r
+ The execution of the deallocation statement kill(X) where X points to a\r
+ process depends on its state. When that process is suspended or terminated,\r
+ then the execution of this statement is the same as in the case of a\r
+ coroutine. Otherwise it results in a run-time error.\r
+ \r
+ \r
+ Relations between parallel and coroutine computations.\r
+ \r
+ LOGLAN-82's coroutine computations can easily be simulated by means of\r
+ parallel computations. Coroutine computations are provided in LOGLAN-82,\r
+ nevertheless, in order to deal with the case of interleaving processes.\r
+ With coroutines instead of processes, one can avoid unnecessary memory\r
+ overloading by data structures inherited for processes and, moreover,\r
+ unnecessary scheduler activations.\r
+ Each process is also a coroutine, and so a process may also be subject to\r
+ the coroutine operations detach and attach. Therefore, the description of\r
+ possible state transitions provided above should be extended to transitions\r
+ caused by coroutine operations.\r
+ The execution of attach(Y) in the active process X results in the control\r
+ transfer from process X to process Y, i.e., if Y is not suspended then the\r
+ statement is illegal, otherwise process X becomes suspended and process Y\r
+ becomes active.\r
+ The execution of the detach statement in the active process X has the\r
+ effect as the execution of attach(Y), where Y is the coroutine (process)\r
+ recently resumed (by means of attach statement) by process X.\r
+1 - 110 -\r
+ \r
+ \r
+ 11.2. Primitive synchronizing statement\r
+ ****************************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <primitive synchronizing statement>:\r
+ \r
+ ----> lock ----> ( ---> <variable> ---> ) ---->\r
+ ! ^\r
+ !-> unlock -!\r
+ \r
+ \r
+ The expression test-and-set (ts) is a boolean expression (see 8.4.).\r
+ \r
+ \r
+ <test-and-set>:\r
+ \r
+ -----> ts ---> (--><variable> ---> ) --->\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The variable Z occurring in the expression ts(Z) has to be of type\r
+ semaphore. Evaluation of the expression consists in indivisible actions: Z\r
+ is closed and the returned value is true iff Z was open.\r
+ The statement lock(Z) is a WFF provided Z is a variable of type\r
+ semaphore. If Z is closed then the process which executes this statement is\r
+ suspended until Z becomes open. If Z is open then exactly one process of\r
+ those waiting for this event (having executed the lock instruction) will be\r
+ able to perform its actions. The others remain suspended as long as Z\r
+ becomes open again. Then exactly one process is allowed to proceed and Z\r
+ becomes closed.\r
+ The statement lock(Z) guards the entry into a critical region, i.e., a\r
+ sequence of statements, which are to be executed by only one process . The\r
+ entrance into a critical region may be of the form\r
+ \r
+ while ts(Z) do od\r
+ \r
+ as well, but it would cause busy waiting of processes awaiting for the\r
+ entrance. The statement lock is implemented in the operating system kernel\r
+ and its execution does not engage the processors by delayed processes.\r
+ \r
+ The exit from a critical region is offered by one of the following two\r
+ statements: stop(Z) or unlock(Z). The former statement is described in\r
+ 11.1. The unlock statement is a WFF provided Z is a variable of type\r
+ semaphore. The execution of this statement brings about the following\r
+ indivisible actions: Z becomes open, and if there are processes waiting for\r
+ entrance, then exactly one of the waiting processes enters the region. The\r
+ scheduling of the waiting processes is assumed to be fair.\r
+ \r
+ Thus a critical region may be written as follows:\r
+ \r
+ \r
+ lock (Z) lock (Z)\r
+ ............ or ............\r
+ unlock(Z) stop (Z)\r
+ \r
+1 - 111 -\r
+ \r
+ \r
+ Example 1.\r
+ ----------\r
+ \r
+ Suppose that the following statements occur in two processes executed in\r
+ parallel:\r
+ \r
+ process P: process Q:\r
+ lock (sem); lock (sem);\r
+ x:=(x+4)*x; x:=-3;\r
+ unlock(sem) unlock(sem)\r
+ \r
+ and the initial value of the variable x is equal to 0. The execution of the\r
+ statement x:=(x+4)*x will not be interleaved by the execution of the\r
+ statement x:=-3, irrespectively of the succession of the arrival of\r
+ processes P and Q at their regions. Thus, these statements will be executed\r
+ in sequence and, independently of the succession, the final value of the\r
+ variable x after executing both those statements is equal to -3.\r
+ If the given statements did not occur in the critical regions, their\r
+ concurrent execution might be the following: compute x+4 - (yielding 4),\r
+ assign x:=-3, compute x*(x+4) - (yielding -12) and assign this value to x.\r
+ The presented critical regions make timing possible. For the description\r
+ of scheduling one should use more complex tools, presented in the next\r
+ section.\r
+ \r
+ Example 2.\r
+ ----------\r
+ \r
+ Consider an algorithm which performs the copying of records from the\r
+ input queue to the output queue (comp. [5]). The algorithm gets the first\r
+ record from the input queue and stores it in the input buffer, next copies\r
+ the input buffer into the output buffer, and finally puts the output buffer\r
+ to the output queue and at the same time gets the next record from the\r
+ input queue, as in the following diagram:\r
+ \r
+ get 1\r
+ ,\r
+ ,\r
+ copy 1\r
+ ,\r
+ , ,\r
+ , ,\r
+ get 2 put 1\r
+ , ,\r
+ , ,\r
+ ,\r
+ .\r
+ .\r
+ copy k\r
+ ,\r
+ ,\r
+ put k\r
+ \r
+ In order to program a parallel execution of get and put operations one\r
+ can use the cobegin-coend program connectives. A particular case of these\r
+ connectives is implemented in the copying procedure given below. We assume\r
+ that in the environment of this procedure the type T and the attributes of\r
+ class queue are visible.\r
+1 - 112 -\r
+ \r
+ \r
+ unit copying: procedure (input_queue, output_queue: head);\r
+ var input_buffer, output_buffer:T, completed:boolean, sem:semaphore,\r
+ counter:integer, getr:get_type, putr:put_type;\r
+ unit cobegin: procedure;\r
+ (*resumes the processes putr and getr, suspends the calling process*)\r
+ begin\r
+ lock(sem);\r
+ resume(putr);\r
+ resume(getr);\r
+ stop(sem)\r
+ end cobegin;\r
+ unit coend: procedure;\r
+ (*suspends the calling process, if both processes\r
+ are suspended then the main program is resumed*)\r
+ begin\r
+ lock(sem);\r
+ if counter=0\r
+ then\r
+ counter:=1\r
+ else\r
+ counter:=0; resume(main)\r
+ fi;\r
+ stop(sem)\r
+ end coend;\r
+ \r
+ unit get_type: process;\r
+ begin\r
+ return;\r
+ do\r
+ if empty(input_queue)\r
+ then completed:=true\r
+ else (*get next record*)\r
+ input_buffer := out(input_queue)\r
+ fi;\r
+ call coend;\r
+ od\r
+ end get_type;\r
+ \r
+ unit put_type: process;\r
+ begin\r
+ return;\r
+ do\r
+ call output_buffer.into(output_queue);\r
+ call coend;\r
+ od\r
+ end put_type;\r
+ \r
+ begin\r
+ if not empty(input_queue)\r
+ then\r
+ input_buffer:=out(input_queue);\r
+ getr:=new get_type; putr:=new put_type;\r
+ do (*copying*)\r
+ output_buffer:=copy(input_buffer);\r
+ call cobegin;\r
+ if completed then exit fi\r
+ od;\r
+ kill(getr); kill(putr)\r
+ fi\r
+ end copying;\r
+1 - 113 -\r
+ \r
+ \r
+ 11.3. Monitors (compound synchronization facilities)\r
+ *****************************************************\r
+ \r
+ \r
+ In this section we shall describe Hoare's monitors ([6]). A monitor is a\r
+ data structure shared by many processes and a set of procedures operating\r
+ on this structure. Access to the shared monitor data is possible only via\r
+ these procedures, and so their bodies constitute critical regions.\r
+ Let us present an example of a class that realizes Hoare's monitors.\r
+ Non-conflict access to the monitor data is realized by the so-called entry\r
+ procedures. An entry procedure has a prefix entry which guarantees that\r
+ only one such procedure may enter the monitor.\r
+ In order to permit scheduling of processes that have entered the monitor,\r
+ two specialized procedures operating on the inner monitor queues are\r
+ provided.\r
+ \r
+ delay(Q) -stops the execution of the process and puts it\r
+ into a queue Q, the entry to the monitor is free,\r
+ continue(Q) -resumes the execution of the first process from a\r
+ queue Q (if Q is non-empty, otherwise the entry to\r
+ the monitor is free).\r
+ \r
+ As can easily be seen, correct use of these constructs is achieved when\r
+ continue is called as the last statement of an entry procedure.\r
+ \r
+ The declaration of the class Monitor is as follows:\r
+ \r
+ unit Monitor : queue class;\r
+ hidden sem, queue;\r
+ var sem:semaphore;\r
+ \r
+ unit entry: class; (* all entry procedures must have prefix entry *)\r
+ hidden busy;\r
+ var busy:boolean;\r
+ unit delay: procedure(Q:queue);\r
+ begin\r
+ call Q.into(this process);\r
+ stop(sem)\r
+ end delay;\r
+ unit continue:procedure(Q:queue);\r
+ (* continue can be called as the last statement of an entry procedure *)\r
+ begin\r
+ if not Q.empty\r
+ then\r
+ busy:=true\r
+ resume(Q.out);\r
+ fi;\r
+ end continue;\r
+ begin (* beginning of the prefix entry *)\r
+ lock(sem); (* entry to the critical region *)\r
+ inner;\r
+ if not busy\r
+ then\r
+ unlock(sem)\r
+ fi;\r
+ end entry;\r
+ end Monitor;\r
+1 - 114 -\r
+ \r
+ \r
+ Example 1\r
+ ---------\r
+ \r
+ A simple mail-box system with a circular buffer may be defined as the\r
+ following class prefixed by a Monitor:\r
+ \r
+ unit Mailbox:Monitor class(type T; size: integer);\r
+ var pool: arrayof T, count, in_index, out_index: integer;\r
+ var readers_queue, writers_queue:queue;\r
+ unit writer:entry procedure (r:T);\r
+ begin\r
+ if count=size then call delay(writers_queue) fi;\r
+ in_index:=in_index mod size +1; count:=count+1;\r
+ pool(in_index):=r; call continue(readers_queue)\r
+ end writer;\r
+ unit reader:entry procedure (output r: T);\r
+ begin\r
+ if count=0 then call delay(readers_queue) fi;\r
+ out_index:=out_index mod size +1; count:=count-1;\r
+ r:=pool(out_index); call continue(writers_queue)\r
+ end reader;\r
+ begin\r
+ new_array pool dim (1:size);\r
+ redears_queue:=new queue; writers_queue:=new queue;\r
+ end mailbox;\r
+ \r
+ Example 2\r
+ ---------\r
+ Let W be a non-singular k to k matrix such that the norm of W is less than\r
+ 1. In order to solve the system of linear equations\r
+ \r
+ W*x = B\r
+ \r
+ one can use the Jacobi iteration method, i.e., for a given approximation Y\r
+ of a solution, the next approximation will be of the form:\r
+ \r
+ x(i)= -(W(i, 1)*y(1)+...+W(i, i-1)*y(i-1)+W(i, i+1)*y(i+1)+...+W(i, k)*y(k))+B(i)\r
+ \r
+ (without loss of generality one can assume that W(i, i)=1.)\r
+ \r
+ We shall use k parallel processes to compute the corresponding components\r
+ of the vector x. When the computation of all the components is completed,\r
+ the next approximation starts. Suppose that vector B is included in the\r
+ array W, i.e., it is the last column of W. In general, array W has many\r
+ zeros, and so instead of this array the user delivers the functions\r
+ computing the values\r
+ \r
+ -(W(i, 1)*y(1)+...+W(i, i-1)*y(i-1)+W(i, i+1)*y(i+1)+...+W(i, k)*y(k))+W(i, k+1)\r
+ \r
+ for the given vector y.\r
+1 - 115 -\r
+ \r
+ \r
+ unit Jacobi : procedure(k:integer;eps:real;inout x:array_of real;\r
+ function W(i:integer; y:array_of real):real);\r
+ (* eps-accuracy, the starting point of the iteration should be\r
+ the actual parameter corresponding to x, the final value of x\r
+ will be equal to the solution found *)\r
+ \r
+ unit jac_unit :Monitor class;\r
+ taken entry;\r
+ var dist:real, q:queue;\r
+ \r
+ unit puti: entry procedure(i:integer);\r
+ taken delay, continue;\r
+ begin\r
+ dist:=dist+abs(x(i)-y(i));\r
+ (*y-new iteration, x-old one*)\r
+ if q.cardinal<k-1 (*q.cardinal<k always*)\r
+ then (*wait for others*)\r
+ call delay(q)\r
+ else (*test stop condition*)\r
+ if dist<=eps\r
+ then\r
+ stop(done)\r
+ else\r
+ z:=x; x:=y; y:=z;\r
+ dist:=0; call continue(q)\r
+ fi\r
+ fi;\r
+ end puti;\r
+ \r
+ begin\r
+ q:=new queue;\r
+ end jac_unit;\r
+ \r
+ unit jac: process(i:integer);\r
+ begin\r
+ if i=1 then lock(done) fi;\r
+ return;\r
+ do\r
+ y(i):=W(i, x);\r
+ call jac_mon.puti(i);\r
+ od\r
+ end jac;\r
+ \r
+ var y, z:array_of real, jac_mon:jac_unit, j:integer, done: semaphore;\r
+ var jacob: array_of jac;\r
+ \r
+ begin\r
+ new_array y dim(1:k); new_array jacob dim(1:k);\r
+ jac_mon:=new jac_unit;\r
+ for j:=1 to k do\r
+ jacob(j):= new jac(j); resume(jacob(j))\r
+ od;\r
+ lock(done);\r
+ for j:=1 to k do kill(jacob(j)) od;\r
+ kill(y); kill(jacob); kill(jac_mon)\r
+ end Jacobi;\r
+1 - 116 -\r
+ \r
+ \r
+ \r
+ 12. Separate compilation of units\r
+ #################################\r
+ \r
+ \r
+ Prefixing is a very convenient way of designing large programs and systems.\r
+ These are constructed by linking together individual units and by using\r
+ prefixes as languages in which the programs are written. There are two\r
+ distinct purposes for compiling modules:\r
+ \r
+ -producing an object module, linking it with some units stored in\r
+ libraries and then executing it\r
+ -producing a library item which in turn may be connected with other\r
+ modules.\r
+ \r
+ \r
+ \r
+ Therefore LOGLAN-82 distnguishes two kinds of compilation units:\r
+ \r
+ -binary items ready to be executed, and\r
+ -library items.\r
+ \r
+ \r
+ By an item we mean the basic unit of compilation, i.e., the smallest and\r
+ self-contained class, coroutine, process, function or procedure. It defines\r
+ also the minimum interface, i.e., units which have to be accessible at run\r
+ time. Most of this section deals with how separately compiled units are put\r
+ together to build large systems.\r
+ Because of checking many context-sensitive conditions, LOGLAN-82 requires\r
+ access to system and user libraries; therefore the language provides tools\r
+ for processing them. The form of a library depends upon a given\r
+ implementation. However, the library has to store some necessary\r
+ information about the interface of a module, its source (or slightly\r
+ preprocessed) code and its object code. Each library posesses its own\r
+ identifier, built with respect to ordinary LOGLAN-82 rules. Any library\r
+ item is identified by its own identifier and the name of the library where\r
+ it is stored. A unit identifier must be unique within the library.\r
+ \r
+ \r
+ \r
+ Library items may be used by another module in two main ways:\r
+ \r
+ -as if they were declared within the module, or\r
+ -as if they were only accessible as non-local attributes from the\r
+ SL-chain of the module.\r
+ The first manner we shall call linking a library item, the other forms the\r
+ interface needed by the module.\r
+1 - 117 -\r
+ \r
+ \r
+ Example\r
+ -------\r
+ \r
+ Let M be an already compiled item stored in a library. And let N be an\r
+ item being compiled.\r
+ Linking means that the program tree of N is the following:\r
+ \r
+ \r
+ O <- N\r
+ . .\r
+ . .\r
+ O O <- linking point of M\r
+ . . .\r
+ O O .----\r
+ ! . !\r
+ ! O <- M - item from the library\r
+ ! !\r
+ -----\r
+ \r
+ If the item N specifies M in its interface, it is expected that the\r
+ module which links N is of the form:\r
+ \r
+ \r
+ .\r
+ .\r
+ O <- linking point of M\r
+ . .\r
+ ----. .\r
+ ! . ! .\r
+ M -> O ! .\r
+ ! ! .\r
+ ----- .\r
+ O\r
+ . .\r
+ . .\r
+ O O <- linking point of N\r
+ . .\r
+ . .\r
+ O .----\r
+ ! . !\r
+ ! O <- N\r
+ ! !\r
+ -----\r
+ \r
+ Indeed, in n's SL-chain-to-come the module N will also be linked.\r
+ \r
+ \r
+ The SL-chain-to-come of an item being compiled will be called the\r
+ environment of the linking point of the item.\r
+1 - 118 -\r
+ \r
+ \r
+ 12.1. Library items\r
+ *******************\r
+ \r
+ \r
+ A library item consists of the interface specification and the body. The\r
+ interface is a connector between separate units: it allows us to code in\r
+ the item the access parts of other units and to use other units as prefixes\r
+ or data types.\r
+ The interface defines three kinds of units needed in order to execute the\r
+ item:\r
+ -externals - these are already compiled units stored in libraries. They\r
+ are expected to be visible in the environment of the linking point,\r
+ -languages- these are also already compiled units stored in libraries.\r
+ They must prefix some module in the SL-chain-to-come,\r
+ -sl_virtuals - functions and procedures which will use the item being\r
+ compiled and its environment whatever links the item. They are not known\r
+ during the compilation of the item.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <compilation of a library item>:\r
+ \r
+ --------->library item -->into <library identifier>-->;--->!\r
+ ! ! !\r
+ !--------------------------->-! !\r
+ !\r
+ <-----------------------------------------------!\r
+ !\r
+ !\r
+ !------> <interface specification> --->!\r
+ ! !\r
+ ! <------------------------------------!\r
+ !\r
+ !--> compile ---> <unit declaration> ---------------->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ The item is compiled and then stored in a given library. If in the library\r
+ there is already a module of the same name, it is replaced by the one being\r
+ compiled .\r
+ The default library identifier is the userlib.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into mathlib;\r
+ compile\r
+ unit sin : function (input x: real) : real;\r
+ .\r
+ .\r
+ end sin\r
+1 - 119 -\r
+ \r
+ \r
+ 12.1.1. Interface\r
+ *****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <interface specification>:\r
+ \r
+ ---------->languages--> <language specification> --> ; ----->!\r
+ ! ^ ! !\r
+ ! !<----------- , ------------! !\r
+ ! !\r
+ ! <---------------------------------------------------!\r
+ !\r
+ !----> externals --> <external specification> --> ; ->!\r
+ ! ^ ! !\r
+ ! !<----------- , ------------! !\r
+ ! !\r
+ ! <---------------------------------------------------!\r
+ !\r
+ !----> sl_virtuals --> <sl_virtual specif. > --> ; -->!\r
+ ! ^ ! !\r
+ ! !<---------- , -----------! !\r
+ ! !\r
+ ! <---------------------------------------------------!\r
+ !\r
+ !------------------->\r
+ \r
+ \r
+ <language specification>:\r
+ \r
+ -----> <lib. item identifier> -----> from <library ident.> ------>\r
+ ^ ! ^ !\r
+ !<-------------- , -----------! !------------------------> !\r
+ \r
+ \r
+ <external specification>:\r
+ \r
+ ------> unit <lib. item identifier> : ----> class ------------>!\r
+ ! ^ !\r
+ !-> coroutine -->! !\r
+ ! ! !\r
+ !-> process ---->! !\r
+ ! ! !\r
+ !-> function --->! !\r
+ ! ! !\r
+ !-> procedure -->! !\r
+ !\r
+ ! <--------------------------------------------------------!\r
+ ! !\r
+ !---> from <library identifier> -------------------------> !\r
+ !->\r
+ \r
+ \r
+ The default library identifier is the userlib.\r
+1 - 120 -\r
+ \r
+ \r
+ <sl_virtual specification>:\r
+ \r
+ -> unit <identifier> : -> function -> <form. par. simp. list> ->!\r
+ ! !\r
+ ! !<-------------------------------!\r
+ ! !\r
+ ! !--> : <type identifier> -------->!\r
+ ! !\r
+ !--> <form. par. simp. list> ------------>!\r
+ !\r
+ !->\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ \r
+ The interface defines a minimum environment of the point at which the item\r
+ being compiled is to be linked. It is used to code the item and also to\r
+ check its static properties. Therefore, changing externals or languages in\r
+ the library, the user has to recompile also units depending on them.\r
+ Identifiers of externals may be used in sl_virtual specification to\r
+ define types of parameters and by the compiled unit as prefixes, types of\r
+ data and so on. Interface specification is not redundant, i.e., if an\r
+ external or language uses some other library items in its own interface,\r
+ they do not have to be specified again. However, only identifiers of the\r
+ specified units are accessible in the item being compiled.\r
+ \r
+ Example 1.\r
+ ----------\r
+ \r
+ library item into datalib;\r
+ compile\r
+ unit heap : class....\r
+ ...\r
+ end heap;\r
+ \r
+ library item into datalib;\r
+ externals\r
+ unit heap: class from datalib;\r
+ compile\r
+ unit priority_queue: heap class ...\r
+ var z: heap...\r
+ end priority_queue;\r
+ \r
+ library item into proglib;\r
+ externals\r
+ unit priority_queue: class from datalib;\r
+ compile\r
+ unit prog1: class;\r
+ var x: priority_queue;\r
+ ...\r
+ end prog1;\r
+ \r
+ Within the body of prog1 we can use the identifier of the priority_queue.\r
+ Class heap will be automatically connected, we are not allowed, however, to\r
+ use the identifier of heap. To make it possible we should define another\r
+ interface:\r
+1 - 121 -\r
+ \r
+ \r
+ library item into proglib;\r
+ externals\r
+ unit priority_queue: class from datalib;\r
+ unit heap: class from datalib;\r
+ compile\r
+ unit prog2: class...\r
+ var x: priority_queue;\r
+ var y: heap;\r
+ ...\r
+ y:=x;\r
+ ...\r
+ X qua heap\r
+ end prog2;\r
+ \r
+ \r
+ Example 2.\r
+ ----------\r
+ \r
+ library item into datalib;\r
+ externals\r
+ unit heap: class from datalib;\r
+ compile\r
+ unit test: class;\r
+ var z: heap\r
+ ...\r
+ end test;\r
+ \r
+ library item into proglib;\r
+ externals\r
+ unit priority_queue: class from datalib;\r
+ unit test: class from datalib;\r
+ compile\r
+ unit prog3: class;\r
+ var p: priority_queue, e: test;\r
+ ...\r
+ p.z:=e.z\r
+ ...\r
+ end prog3;\r
+ \r
+ \r
+ In this interface heap means the same class for both the priority_queue\r
+ and the test.\r
+1 - 122 -\r
+ \r
+ \r
+ 12.1.2. Using languages\r
+ ***********************\r
+ \r
+ Languages are classes (coroutines, processes) already compiled. They are\r
+ expected to prefix modules in the SL-chain of the point of linking the item\r
+ being compiled. Their attributes may be used within the body of the\r
+ compiled item by means of the construction:\r
+ this <language identifier>.<attribute>\r
+ If it does not lead to any confusion, the phrase\r
+ this <language identifier>.\r
+ may be omitted. The rules of accessing attributes in the case of regular\r
+ units are also valid in the case of languages. A language may also be used\r
+ like any of the specified externals.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into syslib;\r
+ compile\r
+ unit math: class;\r
+ ...\r
+ unit sin ...\r
+ end math;\r
+ library item into syslib;\r
+ compile\r
+ unit basicio: class;\r
+ ...\r
+ unit writereal...\r
+ end basicio;\r
+ library item;\r
+ languages math, basicio from syslib;\r
+ compile\r
+ unit prog: class...\r
+ ...\r
+ this math.sin (* or simply sin *)\r
+ this basicio.writereal (*or simply writereal *)\r
+ end prog;\r
+ \r
+ A correct use of the unit prog may be of the following form:\r
+ \r
+ library item;\r
+ externals\r
+ unit math: class from syslib,\r
+ unit basicio: class from syslib;\r
+ compile\r
+ unit user: class;...\r
+ basicio block...\r
+ math block...\r
+ class\r
+ external unit prog from userlib\r
+ (* this is linking prog- see 12.2 *)\r
+ ...\r
+ end user;\r
+1 - 123 -\r
+ \r
+ \r
+ 12.1.3. Using externals\r
+ ***********************\r
+ \r
+ \r
+ External items are expected to be linked by the environment of the linking\r
+ point of the item being compiled. They may be used like units which are\r
+ declared and visible in the environment of a regular object. Some simple\r
+ examples have been given in 12.1.1. Some others are given in 12.2.\r
+ \r
+ \r
+ \r
+ 12.1.4. Using sl_virtuals\r
+ *************************\r
+ \r
+ \r
+ The main purpose of sl_virtuals is to permit communication between the\r
+ compiled item and the modules which will use it. Communication may depend\r
+ upon the modules and there may be many fairly distinct of them. Sl_virtuals\r
+ and the modules are not previously compiled, i.e., they are not other\r
+ library items. Sl_virtuals are very similar to formal parameters or\r
+ external subroutines in FORTRAN.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ This is an example of a procedure which sorts real numbers stored in any\r
+ structure with operations put_real and get_real.\r
+ \r
+ library item into sortlib;\r
+ sl_virtuals\r
+ unit empty : function : boolean,\r
+ unit get_real : function : real,\r
+ unit put_real : procedure (input X : real),\r
+ unit clear : procedure;\r
+ compile\r
+ unit sqsetort : procedure;\r
+ ...\r
+ begin\r
+ (*reading numbers*)\r
+ while not empty\r
+ do\r
+ ...\r
+ get_real;\r
+ ... ...\r
+ od;\r
+ ...\r
+ (*writing numbers*)\r
+ clear;\r
+ do\r
+ ...\r
+ call put_real(Z);\r
+ ...\r
+ od;\r
+ ...\r
+ end sqsetsort;\r
+1 - 124 -\r
+ \r
+ \r
+ 12.2. Linking library items\r
+ ***************************\r
+ \r
+ \r
+ Declarations within a module may include specification of a library item to\r
+ be linked at that point.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <linked item specification>:\r
+ \r
+ ----------> external <external specification> ---------->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ The object code of the linked item is added to the object code of the item\r
+ being compiled. Adding the same item a few times we create some unrelated\r
+ copies of the item as if the same source code occurred many times in\r
+ different places.\r
+ \r
+ \r
+ 12.2.1.Connecting the interface\r
+ *******************************\r
+ \r
+ \r
+ Languages and sl_virtuals.\r
+ --------------------------\r
+ \r
+ Languages and sl_virtuals specified by the linked item are looked for in\r
+ the environment of the linking point. If they are not found there, they\r
+ must be explicitly specified in the interface of the item being compiled.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into lib;\r
+ compile\r
+ unit M : class;\r
+ ...\r
+ end M;\r
+ \r
+ library item into lib;\r
+ compile\r
+ unit N : class;\r
+ ...\r
+ end N ;\r
+ \r
+ library item into lib;\r
+ languages M, N from lib;\r
+ compile\r
+ unit P : class;\r
+ ...\r
+ end P;\r
+1 - 125 -\r
+ \r
+ \r
+ library item into lib;\r
+ languages M from lib;\r
+ compile\r
+ unit R : class;\r
+ ...\r
+ block\r
+ external unit N : class from lib;\r
+ ...\r
+ N block\r
+ ...\r
+ block\r
+ external unit P : class from lib;\r
+ ...\r
+ end r;\r
+ \r
+ Sl_virtual specification must be compatible in terms of the usual LOGLAN-82\r
+ rules with the actual version or with the specification in the interface of\r
+ the item being compiled.\r
+ \r
+ EXTERNALS\r
+ ---------\r
+ \r
+ The externals specified in the added item are taken from the SL-chain of\r
+ the linking point or from the interface of the item being compiled. If they\r
+ do not occur there, they are linked together with the specified linked item\r
+ at the same point.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into lib;\r
+ compile\r
+ unit M : class;\r
+ ...\r
+ end M;\r
+ \r
+ library item into lib;\r
+ externals\r
+ unit M : class from lib;\r
+ compile\r
+ unit N : class;\r
+ var X : M\r
+ ...\r
+ end N;\r
+ (a)\r
+ library item into lib;\r
+ externals\r
+ unit M : class from lib;\r
+ compile\r
+ unit P : class;\r
+ external unit N : class from lib;\r
+ ...\r
+ end P;\r
+ \r
+ The actual version of the module M used by the module N is taken from the\r
+ interface of the module p. The SL-link of M is not known.\r
+1 - 126 -\r
+ \r
+ \r
+ (b)\r
+ library item into lib;\r
+ compile\r
+ unit P : class;\r
+ ...\r
+ external unit M : class from lib;\r
+ ...\r
+ block\r
+ ...\r
+ external unit N : class from lib;\r
+ ...\r
+ end P;\r
+ The module M used by the module N comes from P where it is linked. The\r
+ SL-link of M is P.\r
+ Notice that if the program tree is the following:\r
+ \r
+ \r
+ O <- P\r
+ . . .\r
+ . . .\r
+ ----. O O\r
+ ! . ! . .\r
+ M -> O ! . .\r
+ ! ! . .\r
+ ----- .---- .----\r
+ !. ! ! . !\r
+ N1 - copy of N-> O ! ! O <- N2 - copy of N\r
+ ! ! ! !\r
+ ----- -----\r
+ \r
+ Then the attributes X in both copies are compatible, i.e., they are of the\r
+ same type.\r
+ \r
+ \r
+ (c)\r
+ library item into lib;\r
+ compile\r
+ unit P : class;\r
+ unit R : class;\r
+ external unit N : class from lib;\r
+ ...\r
+ end R;\r
+ unit S : class;\r
+ external unit N : class from lib;\r
+ ...\r
+ end S;\r
+ ...\r
+ end P;\r
+ \r
+ In this case two copies of N are formed. Because there occurs no copy of M\r
+ in the SL-chain or in the interface of P, two copies of M are also added.\r
+ The attributes X in the copies of N are of different types and are not\r
+ compatible. The copies of M are "own" copies for each N.\r
+1 - 127 -\r
+ \r
+ \r
+ 12.3. Binary items\r
+ ******************\r
+ \r
+ \r
+ A binary item consists of a very simple interface specification and the\r
+ body. The interface defines languages in which the program is written. A\r
+ binary compiled program is embedded in a number of blocks prefixed by these\r
+ languages. There is also a block containing definitions of linked library\r
+ items.\r
+ Compilation of a binary item results in an object code ready for\r
+ execution.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <compilation of a binary item>:\r
+ \r
+ -----> binary item ---> into <library identifier> ---> ; ------>!\r
+ ! ^ !\r
+ !---------------------------->! !\r
+ !\r
+ !<------------------------------------------------------------!\r
+ !\r
+ !-----> languages ---> <language specification> --> ; --->!\r
+ ! ^ ! !\r
+ ! !<------------ , ------------! !\r
+ ! !\r
+ ! <-------------------------------------------------------!\r
+ !\r
+ !------> externals ---> <external specification> --> ; -->!\r
+ ! ^ ! !\r
+ ! !<------------- , ------------! !\r
+ ! !\r
+ ! <-------------------------------------------------------!\r
+ !\r
+ !---> compile <declaration of a program unit> ----------------->\r
+ \r
+ \r
+ The rules of using languages and externals are the same as for library\r
+ items.\r
+ The default library identifier is bin.\r
+1 - 128 -\r
+ \r
+ \r
+ 12.4. Processing libraries\r
+ **************************\r
+ \r
+ \r
+ 12.4.1. Recompilation\r
+ *********************\r
+ \r
+ \r
+ LOGLAN-82 guarantees uniqueness for types and units. The compiler\r
+ associates a "time stamp" (time of definition and compilation) with each\r
+ compiled unit. Compiling a module twice (even if no changes are made in its\r
+ source code) makes all units defined in the module different\r
+ (non-equivalent). Therefore after some changes in the library we should\r
+ recompile all modules connecting the changed items.\r
+ For example, consider the case where defs1 is used by defs2, and defs2 is\r
+ linked with the user. Suppose that defs1 is recompiled for some reason,\r
+ then defs2 is recompiled, too. Then the user should also be recompiled,\r
+ because recompiling defs2 invalidated the version of the user.\r
+ \r
+ Compilations and recompilations must occur in a specific order.\r
+ To recompile a module storedin the library, LOGLAN-82 commands the\r
+ following syntax:\r
+ \r
+ \r
+ --> recompile --> <lib. item identifier> --> from <library ident.> -->\r
+ ^ !\r
+ !<------------ , ----------!\r
+ \r
+ It is suggested that the LOGLAN-82 compiler makes the necessary\r
+ recompilations automatically.\r
+1 - 129 -\r
+ \r
+ \r
+ 12.4.2. Insertions and deletions\r
+ ********************************\r
+ \r
+ \r
+ To insert an item into a library the programmer writes only the source code\r
+ of the item. It is a code between\r
+ \r
+ \r
+ \r
+ library binary item into <library identifier>;\r
+ ...\r
+ end\r
+ \r
+ \r
+ This code results in the insertion of the module into a given library. If\r
+ in the given library there already exists a module of the same name, the\r
+ new one replaces the old one.\r
+ \r
+ Deletions are made by using the following syntax:\r
+ \r
+ \r
+ --> delete ---> <lib. item identifier> ---> from <library ident.> ---->\r
+ ^ !\r
+ !<------------ , -----------!\r
+ \r
+ A linked item may be deleted from the library. However, the linking module\r
+ cannot be recompiled after that.\r
+1 - 130 -\r
+ \r
+ \r
+ 13. File processing\r
+ ####################\r
+ \r
+ \r
+ 13.1. External and internal files\r
+ *********************************\r
+ \r
+ External files are named after character strings and denote peripheral\r
+ devices or data sets. The logical and the physical structure of an external\r
+ file depend on the given computer and its file system, and so, for the\r
+ users of LOGLAN-82, external files are accessible via internal files only.\r
+ \r
+ \r
+ An internal file is an object of the predefined class type file. When an\r
+ internal file is generated, it may be associated with an appropriate\r
+ external file. Sometimes the user wish to generate an internal file not\r
+ associated with any specified external one. Such a file is called a local\r
+ file and its life-time is not longer than the life-time of the program\r
+ where it has been generated.\r
+ \r
+ \r
+ A file is always treated as an unbounded sequence of bytes. A file can be\r
+ read or written, and can be set to a required position. Each transmission\r
+ from or on a file starts at the byte pointed out by the so-called current\r
+ file position advanced by the number of transmitted bytes. File size is\r
+ defined as the greatest number of a byte transmitted on the file.\r
+ \r
+ There are some primitive facilities in the language which enable the user\r
+ to read or write a specified number of bytes, to change the current file\r
+ position, to obtain the file size, etc. All these facilities are in some\r
+ sense low-level, since they operate on bytes. The user is able, however, to\r
+ declare a class for file processing with high-level operations.\r
+ \r
+ An example of a system class which defines a set of input-output\r
+ operations applicable to files containing elements of a single type is\r
+ shown in 13.6. Moreover this is not the only way to define high-level file\r
+ processing. The user can declare, for instance, a class which defines\r
+ operations applicable to files containing elements of mixed types, a class\r
+ which defines operations on a file of arrays of various lengths, etc.\r
+1 - 131 -\r
+ \r
+ \r
+ 13.2. File generation and deallocation\r
+ **************************************\r
+ \r
+ \r
+ Before any operation on a file can be carried out, an internal file must\r
+ be generated. If the user wishes to communicate with an external file, then\r
+ the generated internal file must be associated with that external one. When\r
+ the generation of an internal file is in effect, the file is said to be\r
+ open.\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ <file declaration>:\r
+ \r
+ -----> <variable list> ----> : file -------------->\r
+ \r
+ <file generation>:\r
+ \r
+ --> open\r
+ !\r
+ !\r
+ (\r
+ !\r
+ <object expression> ---> , ---> <string> ----> ) ------->\r
+ ! !\r
+ !-------------------->!\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ Variables of file type are declared as any other variables of class type.\r
+ An object of file type (internal file) has no attributes visible to the\r
+ programmer.\r
+ File generation differs from class generation. It is performed by an open\r
+ statement. If the second argument appears, then a new internal file\r
+ associated with an external one (identified by the string) is generated.\r
+ The reference to such an internal file is set to the variable of type file\r
+ occurring as the first argument. If there is only one argument, then a new\r
+ local file is generated and the reference to the corresponding internal\r
+ file is set to the variable of type file occurring as the argument of the\r
+ operation. For instance:\r
+ \r
+ open(X, "teletype")\r
+ \r
+ generates a new internal file associated with the external file "teletype".\r
+ Similarly\r
+ \r
+ open(Y)\r
+ \r
+ generates a new local file referenced by Y.\r
+1 - 132 -\r
+ \r
+ \r
+ Thus the operation new is not applicable to files. Moreover, remote\r
+ access to internal files is not permissible (no attributes visible to the\r
+ user).\r
+ Except file generation, remote access and prefixing, file type can be\r
+ applied as any other class type. In particular, expressions of file type\r
+ may be compared, assignments on variables of type file are allowed, the\r
+ user can declare a function of type file, etc.\r
+ \r
+ \r
+ Remark\r
+ ------\r
+ \r
+ External file processing is not predefined in the language. The\r
+ operations on external files, such as file creation, file deletion, file\r
+ protection and so on, depend on the given file system. They may be\r
+ introduced into the language as standard functions or procedures in the\r
+ individual implementation.\r
+ \r
+ End of remark\r
+ -------------\r
+ \r
+ \r
+ \r
+ After processing has been completed on a file, it can be closed and the\r
+ corresponding internal file may be deallocated. These actions are performed\r
+ by the kill statement, where the argument points to the corresponding\r
+ internal file.\r
+1 - 133 -\r
+ \r
+ \r
+ 13.3. Binary input-output\r
+ *************************\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ \r
+ < binary input-output operations>:\r
+ \r
+ ---> put ---> (---> <object expression>-> , ---> <expression list> --> ) ---->\r
+ \r
+ ---> get ---> (---> <object expression>-> , ---> <expression list> --> ) ---->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ \r
+ Operation put transmits a sequence of bytes from memory to an open file\r
+ (defined by the first parameter) at the current file position. This\r
+ sequence of bytes is defined by the list of expressions. For any list\r
+ element, going from left to right, the value of the expression is computed.\r
+ If this value is primitive, then the transmitted bytes correspond exactly\r
+ to the internal representation of the value. If the value is a reference to\r
+ an object, then the transmitted bytes cover all non-system attributes of\r
+ the referenced object. If this value is none, then no transmission is\r
+ performed.\r
+ Operation get transmits a sequence of bytes from an open file (defined by\r
+ the first parameter) to the memory. If a list element is an object\r
+ expression, then the transmitted bytes cover all non-system attributes of\r
+ the referenced object (hence, if the value of this expression is none, then\r
+ no transmission is performed). Otherwise, list element must be a variable\r
+ of primitive type, and then the transmitted bytes cover exactly its\r
+ internal representation. The sequence of transmitted bytes starts at the\r
+ current file position.\r
+ \r
+ For instance, let x be a real, i an integer and Y a reference variable to\r
+ an object of type A:\r
+ \r
+ unit A:class(j:integer);\r
+ var u, v, w:real;\r
+ end A;\r
+ \r
+ Then the statement\r
+ \r
+ put(F, x, i, x+i, "nothing", Y)\r
+ \r
+ transmits to file F the internal representation of the values of x, i, x+i,\r
+ the internal representation of the text "nothing" (i.e., the sequence of\r
+ characters) and the internal representation of the attributes j, u, v, w\r
+ from the object referenced by Y.\r
+1 - 134 -\r
+ \r
+ \r
+ 13.4. Other predefined operations\r
+ *********************************\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ <size operator>:\r
+ \r
+ !-----> <type> ----------->!\r
+ ! !\r
+ ------> size ---> ( -! !---> ) -------->\r
+ ! !\r
+ !----> < expression> ----->!\r
+ \r
+ <eof operator>:\r
+ \r
+ ------> eof -----> ( ---> <object expression> ----> ) ------------------>\r
+ \r
+ <position operator>:\r
+ \r
+ ----> position ---> ( ---> <object expression> -----> ) --------------->\r
+ \r
+ <seek operation>:\r
+ \r
+ --> seek --> ( --> <object expression> --> , --> <arithmetic expression> --> ) -->\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ \r
+ The size operator of integer type gives the number of bytes of the\r
+ internal representation of an argument. If the argument is an expression of\r
+ primitive type, then the returned value may be computed at compilation time\r
+ and equals the number of bytes of the internal representation of that\r
+ primitive type. If the argument is an expression of class or array type,\r
+ then the returned value gives the number of bytes of the object referenced\r
+ by the argument (except system-attributes). If the object none is\r
+ referenced, then the returned value is 0.\r
+ Another kind of argument of size operator is type. It may be either an\r
+ explicitly written type or a formal type. If the argument is a primitive\r
+ type or a class type, then its length in bytes computed at compilation time\r
+ is returned. If the argument is an array type, then its size cannot be\r
+ established and so the expression is incorrect. If the argument is a formal\r
+ type, the returned value is defined similarly but computed at run time.\r
+ Thus when the actual type is array the run time error is raised.\r
+ In all these cases size operator informs the user about the length in\r
+ bytes of the internal representation of the argument (if possible). In\r
+ particular, the argument may be a file and then the length in bytes of the\r
+ corresponding external or local file is returned.\r
+ \r
+ The argument of the boolean operator eof must be a file. It returns the\r
+ value true iff the current position of the file exceeds or equals its size.\r
+ The argument of the integer operator position must also be a file. It\r
+ returns the current position of the file.\r
+ The first argument of the seek operation must be a file. Then the current\r
+ position of this file is set to the value defined by the second argument of\r
+ the operation.\r
+1 - 135 -\r
+ \r
+ \r
+ 13.5. Text input-output\r
+ ***********************\r
+ \r
+ \r
+ Besides binary input-output LOGLAN-82 provides text input-output\r
+ operations also. The operations read and write are available for input and\r
+ output in human readable form. Namely, operation read decodes a sequence of\r
+ bytes into the internal representation of the corresponding value before\r
+ the transmission is performed. Similarly operation write encodes the\r
+ internal representation of a value into the corresponding sequence of bytes\r
+ before transmission is performed.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <text input-output statement>:\r
+ \r
+ !--------------------------->!\r
+ ! !\r
+ --> read --> ( --> <object expression> ---> , --> <variable list> --> ) ---->\r
+ \r
+ \r
+ !------------------------------------>!\r
+ ! !\r
+ ->writeln --> ( --> <object expression> --> ) ------------------------->\r
+ !\r
+ !\r
+ ->write --> ( -------------->!\r
+ ! !\r
+ <object expression>-> , -> <expression> ----> <format> ---> ) -------->\r
+ ^ !\r
+ !<--------- , ------------!\r
+ \r
+ \r
+ <format>:\r
+ \r
+ ------------------------------------------------------------------->\r
+ ! ^ ^\r
+ !-> : -> <arithmetic expression>-!- : -> <arithmetic expression> -!\r
+1 - 136 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ An input statement read(F, y1, ..., yk) is correct if F is a file and y1,\r
+ ..., yk are variables of integer, real, or character type. File F is\r
+ treated as a sequence of symbols. The execution of that statement causes\r
+ the input data represented as the corresponding sequence of symbols from\r
+ file F to be read, decoded and assigned to y1, ..., yk respectively. The\r
+ input statement is defined if the assignments are defined (going from left\r
+ to right).\r
+ An output statement write(F, E:A1) is correct if F is a file, E is an\r
+ expression of a primitive type, and A1 is an arithmetic expression of\r
+ integer type.\r
+ Consider first the case where expression E is of integer type. The value\r
+ of expression A1 determines the number of symbols to be outputed on file F.\r
+ If the specified number of symbols is greater (less) than the number of\r
+ symbols required for the representation of the value of expression E, then\r
+ the value of E is preceded by the appropriate number of blanks (then the\r
+ least significant digits are omitted). The absence of format indicates a\r
+ standard one (dependent on an individual implementation).\r
+ If expression E is of real type, then the output statement may be of the\r
+ form write(F, E:A1:A2), where A1 and A2 are arithmetic expressions of\r
+ integer type. The meaning of the expression A1 is that described above, the\r
+ value of the expression A2 determines the number of digits following the\r
+ decimal point. In case of an output statement of the form write(F, E:A1),\r
+ where E is of real type, the exponent part is always present. The absence\r
+ of format indicates a standard one (dependent on an individual\r
+ implementation).\r
+ An output statement of the form write(F, E) where E is an expression of\r
+ character type causes the external representation of E to be outputed on\r
+ file F.\r
+ If E is an expression of string type, then its external representation is\r
+ outputed on file F. In this case format A1 may appear and defines the\r
+ maximal number of symbols which may be outputed, i.e., if the length of a\r
+ string exceeds the defined format, then the last symbols are dropped.\r
+ In the statement write(F, E:A1:A2) format A2 is computed first (if\r
+ present), format A1 is computed next (if present), and finally the value of\r
+ E is computed and outputed according to the defined formats.\r
+ The execution of an output statement with a list results in the\r
+ successive evaluations of the expressions A2, A1, E, and in the output of\r
+ the computed value.\r
+ Statement writeln outputs the end of line symbol after output is\r
+ completed. If writeln has only the file parameter, then the end of the line\r
+ symbol is outputed on file F.\r
+ If no file is specified, a default standard input or standard output file\r
+ is used. At the beginning of program execution, these files are open and\r
+ associated with two implementation defined external files.\r
+1 - 137 -\r
+ \r
+ \r
+ 13.6. Example of high-level file processing\r
+ *******************************************\r
+ \r
+ A class defining high-level file processing is presented below. The user\r
+ can prefix the main block of his program by such a class, and then, the\r
+ high-level file operations are provided automatically.\r
+ \r
+ unit input_output class;\r
+ hidden uni_file;\r
+ unit uni_file :class(type T);\r
+ hidden element_size;\r
+ var F:file, element_size:integer;\r
+ unit set_position:procedure(i:integer);\r
+ begin\r
+ call seek(F, i*element_size)\r
+ end set_position;\r
+ unit file_position:function:integer;\r
+ begin\r
+ result:=position(F) div element_size\r
+ end file_position;\r
+ unit end_of_file:function:boolean;\r
+ begin\r
+ result:=eof(F)\r
+ end end_of_file;\r
+ unit file_size:function:integer;\r
+ begin\r
+ result:=size(F) div element_size\r
+ end file_size;\r
+ unit read_element:procedure(output x:T);\r
+ begin\r
+ get(F, x)\r
+ end read_element;\r
+ unit write_element:procedure(x:T);\r
+ begin\r
+ put(F, x)\r
+ end write_element;\r
+ begin\r
+ element_size:=size(T)\r
+ end uni_file;\r
+ unit inout_file:uni_file class(S:string);\r
+ hidden F;\r
+ begin\r
+ open(F, S)\r
+ end inout_file;\r
+ unit in_file:inout_file class;\r
+ hidden write_element;\r
+ end in_file;\r
+ unit out_file:inout_file class;\r
+ hidden read_element;\r
+ end out_file;\r
+ unit local_file:uni_file class;\r
+ hiddden F;\r
+ begin\r
+ open(F)\r
+ end local_file;\r
+ unit close_file:procedure(E:uni_file);\r
+ begin\r
+ kill(E.F); kill(E)\r
+ end close_file;\r
+ end input_output;\r
+1 - 138 -\r
+ \r
+ \r
+ Bibliography.\r
+ #############\r
+ \r
+ Part A: the papers related to the language itself.\r
+ \r
+ [1] Bartol W.M, Kreczmar A., Litwiniuk A., Oktaba H.: Semantics and\r
+ implementation of prefixing at many levels, Ins.Inf.U.W. reports, nr 94.,\r
+ 1980.\r
+ \r
+ [2] Bartol-Ratajczak W.M., Szczepanska-Wasersztrum D.: Data structure for\r
+ simulation purposes in LOGLAN. ICS PAS report 373, 1979.\r
+ \r
+ [3] Dahl O-J., Myhrhaug B., Nygaard K.: Common base language. NCC s-22,\r
+ October 1970.\r
+ \r
+ [4] Dahl O-J., Wang A.: Coroutine sequencing in a block structured\r
+ environment. BIT 11, 1971, pp.425-49.\r
+ \r
+ [5] Hansen P.B.: CONCURRENT PASCAL, a programming language for operating\r
+ system design. IST report no.10 April 1974.\r
+ \r
+ [6] Hoare C.A.R.: Monitors, an operating system structuring concept. CACM,\r
+ vol.17, n.10, October 1974, pp.549-57.\r
+ \r
+ [7] Muldner T.: On the properties of ADA's rendez-vous and an\r
+ implementation of its counterpart in LOGLAN. To appear.\r
+ \r
+ [8] Muldner T.: LOGLAN-82 programmer's manual (in Polish), pp.1-417.\r
+ \r
+ [9] Myhre O.: Protecting attributes of a local class. SIMULA Newsletters,\r
+ vol.5, n.4. November 1977.\r
+ \r
+ [10] Naur P.(ed): Revised report on the algorithmic language ALGOL 60. ACM\r
+ 6, 1963, pp.1-7.\r
+ \r
+ [11] Preliminary ADA reference manual. Sigplan Notices, vol.14 n.6, June\r
+ 1979.\r
+ \r
+ [12] Salwicki A., Muldner T., Oktaba H., Bartol-Ratajczak W.M.: Base\r
+ machine language. General outline. (in Polish). Archiwum opracowan nr 20,\r
+ 1977, IMM MERA.\r
+ \r
+ [13] Wirth N.: The programming language PASCAL, Acta Informatica, 1971, 1,\r
+ pp. 35-63.\r
+1 - 139 -\r
+ \r
+ \r
+ Part B: The papers related to the general project LOGLAN-82\r
+ \r
+ [14] Aho A.V., Hopcroft J.E., Ullman J.D.: The design and analysis of\r
+ computer algorithms. Addison-Wesley. 1974.\r
+ \r
+ [15] Banachowski L., Kreczmar A., Mirkowska G., Rasiowa H., Salwicki A.: An\r
+ introduction to algorithmic logic. Mathematiccal investigations in the\r
+ theory of programs. In Banach Center publications, Warsaw 1977.\r
+ \r
+ [16] Bartol W.M.: The definition of the semantics of some statements of a\r
+ block structured language with type prefixing. To appear in: Lect.Notes in\r
+ Comp. Sc. Proc. Poznan 1980, Symp. on algorithmic logic and LOGLAN.\r
+ \r
+ [17] Burkhard H.D.: On priorities of parallelism: Petri nets under the\r
+ maximum firing strategy. To appear in Lect. Notes in Comp.Sc. Proc. Poznan\r
+ 1980, Symp. on algorithmic logic and LOGLAN.\r
+ \r
+ [18] Dahl O-J., Dijkstra E.W., Hoare C.A.R.: Structured programming.\r
+ London. Academic Press 1972.\r
+ \r
+ [19] Muldner T.: On the semantics of parallel programs. ICS PAS report 348,\r
+ 1979, extended version to appear in Fund. Informaticae.\r
+ \r
+ [20] Muldner T.: Implementation and properties of certain tools for\r
+ parallel programs. ICS PAS report 356, 1979. see also FCT' 77,\r
+ Lect.Not.Comp.Sc.56.\r
+ \r
+ [21] Oktaba H.: On the algorithmic theory of references. To appear in:\r
+ Lect.Not. in Comp.Sc. Proc. Poznan 1980, Algorithmic logic and LOGLAN.\r
+ \r
+ [22] Salwicki A.: Programmability and recursiveness, to appear.\r
+ \r
+ [23] Salwicki A.: Formalized algorithmic languages. Bull.Acad. Polon.Sci.\r
+ 18, 1970, pp.227-232.\r
+ \r
+ [24] Salwicki A.: Applied algorithmic logic. Proc. MFCS' 77. Lect.Not. of\r
+ Comp.Sc. 53, 1977, pp.122-134.\r
+ \r
+ [25] Salwicki A.: An algorithmic approach to set theory. Proc.FCT'77. Lect.\r
+ Not. in Comp. Sc. 56, 1977.\r
+ \r
+ [26] Salwicki A.: On the algorithmic theory of stacks. Proc. MFCS' 78\r
+ Lect.Not. in Comp.Sc. 64, 1978.\r
+1 - 140 -\r
+ \r
+ \r
+ \r
+ Index\r
+ #####\r
+ \r
+ \r
+ A D\r
+ actual paratemetr list, 76 deallocation, 17, 83\r
+ allocation statement, 75-81 - statement, 83\r
+ andif, 9 declaration list, 41\r
+ arithmetic expression, 64-66 detach, 86,104,108\r
+ array, 18,29,75,82 dotted variable, 60\r
+ - generation statement 18,75,82 dynamic compatibility\r
+ - object, 29 of parameters, 79\r
+ - type, 29 dynamic consistency\r
+ assignment statement, 72 of types, 55\r
+ attach, 20,86,104,108 dynamic control statements, 85\r
+ attribute, 11,30,42 dynamic instance, 11,13\r
+ dynamic location, 42,54\r
+ \r
+ B E\r
+ binary item, 126 evaluation statement, 71-73\r
+ block statement, 11-12,35,75 exception, 22,96\r
+ block structure,11 - handler, 22,97\r
+ - handling, 96\r
+ exit, 9,84,91\r
+ C expressions, 56\r
+ call statement, 13 external, 122-123\r
+ case statement, 10,87,89 external file, 129\r
+ character, 23\r
+ character expression, 67 F\r
+ class, 14,33 file, 129,136\r
+ - declaration, 33 - declaration, 130\r
+ - object, 14,17 - generation, 130\r
+ close, 22,40,45 formal\r
+ comment, 25 - function parameter, 38-39\r
+ compound statement, 8,71,87-88 - input parameter, 37-39\r
+ conditional statement, 8,87 - output parameter, 37-39\r
+ configuration statement, 71 - parameter, 37-39\r
+ consistency of types, 55 - procedure parameter, 38-39,41\r
+ constant ,31,57 - type, 30\r
+ - declaration, 31 - type parameter, 37-39\r
+ context properties, 56 function, 13\r
+ copy, 74 - call, 75-81\r
+ copying statement, 72,74\r
+ coroutine, 20,28,36,86\r
+ - object, 20\r
+ - statement, 86\r
+1 - 141 -\r
+ \r
+ \r
+ G O\r
+ garbage collection, 17 object, 14,48\r
+ get, 132 - deallocation, 75,83\r
+ - deallocator, 17\r
+ H - expression, 69-70\r
+ handler - generation, 75\r
+ - declaration, 40 - generator statement, 14\r
+ - execution, 101-102 orif, 8\r
+ - termination, 101-102\r
+ hidden, 22,40,43\r
+ \r
+ I P\r
+ identifier definition, 25 parallel statement, 105\r
+ illegal identifier, 44 prefix 15-16,36\r
+ inheritance list, 40 - sequence, 36\r
+ inner, 16,41,84 prefixing, 15,36\r
+ interface, 118 primitive statement, 71\r
+ internal file, 129 primitive synchronizing\r
+ iteration statement, 9,10,90-92 statement, 105,109\r
+ procedure, 13\r
+ K - call, 75-81\r
+ kill, 17,83 process, 21,28,36,104\r
+ - state transition, 105\r
+ L protection list, 40\r
+ languages, 118,121-123 protection of attributes, 22,43\r
+ last_will, 101-102 put, 132\r
+ - statement, 101-102\r
+ legal identifier, 44 Q\r
+ lexical entity, 25 qua, 70\r
+ library items, 115,117 qualified object expression, 69-70,76\r
+ linked item specification, 31\r
+ lock, 21,109 R\r
+ loop statement, 87,91 raise, 98\r
+ read, 134-135\r
+ M recompilation, 127\r
+ main, 28 reference variable, 14\r
+ monitor, 112 remote\r
+ - access, 14\r
+ N - function identifier, 76\r
+ none, 69 - procedure identifier, 76\r
+ repeat, 10,84,91\r
+ resume, 21,104,107-108\r
+ return, 84\r
+ run-time error, 22\r
+1 - 142 -\r
+ \r
+ \r
+ S T\r
+ scheduling, 21,105 taken, 40,44\r
+ semantic properties, 56 terminate, 101-102\r
+ semaphore, 27 textual control statement, 84\r
+ separate compilation, 22,115-128 this, 70\r
+ sequential statements, 71 ts, 21,109\r
+ signal, 96 type, 26\r
+ - declaration, 31 - class, 30\r
+ - handler, 97 - compound, 26,29\r
+ - raising, 98 - primitive, 26-27\r
+ - specification, 96\r
+ simple control statement, 84 U\r
+ simple variable, 58 unit, 13,25,31\r
+ sl-virtual, 118,122-123 - attributes, 42\r
+ statement list, 41 - body, 40-41\r
+ static attribute, 46 - declaration, 31\r
+ static compatibility unlock, 21,109\r
+ of parameters, 77\r
+ static consistency V\r
+ of types, 55 variable, 32,57\r
+ static container, 46 - declaration, 31\r
+ static location, 42,46 virtual\r
+ storage management, 17 - attribute, 49-53\r
+ stop, 21,104,107-108 - chain, 49-53\r
+ string, 27 - subprogram, 49-53\r
+ - constant, 68 visibility rules, 42,44\r
+ - expression, 68\r
+ subprogram declaration, 34 W\r
+ - body, 40 wait, 21,107-108\r
+ subscripted variable, 59 wind, 101-102\r
+ synchronization, 21,105 write, 134-135\r
+ syntactic writeln, 134-135\r
+ - entity, 42\r
+ - father, 12\r
+ - unit, 13,42\r
+ system signals, 103\r
+ system variable, 61\r
--- /dev/null
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ LOGLAN'82\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ USER'S GUIDE \r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ \r
+\r
+ Institute of Informatics\r
+ University of Warsaw\r
+ January 1988\r
+\r
+ revised October 1993\r
+ LITA\r
+ Université de Pau\r
+\r
+TABLE of CONTENTS\r
+\r
+\r
+\r
+{TOC \o|0. PREFACE 3\r
+1. USING LOGLAN-82 SYSTEM 3\r
+1.1. COMPILATION 3\r
+1.2. COMPILER SWITCHES 4\r
+1.3. CODE GENERATION 4\r
+1.4. PROGRAM INTERPRETATION 5\r
+1.5. COMPILE TIME ERRORS 6\r
+1.6. RUN-TIME ERRORS 6\r
+2. COMPILER OPTIONS 6\r
+2.1. OPTION FORMAT 7\r
+2.2. OPTIONS LIST 7\r
+3. CURRENT LOGLAN-82 IMPLEMENTATION SPECIFICATION 8\r
+3.1. IMPLEMENTED SUBSET OF LOGLAN 8\r
+3.2. PREDEFINED LANGUAGE ELEMENTS 8\r
+3.3. FILE SYSTEM 8\r
+3.3.1. FILE VARIABLES 8\r
+3.3.2. FILE GENERATION 9\r
+3.3.3. FILE DEALLOCATION 9\r
+3.3.4. GENERAL FILE OPERATIONS 9\r
+3.3.5. TEXT FILES 10\r
+3.3.6. BINARY SEQUENTIAL FILES 10\r
+3.3.7 DIRECT ACCESS BINARY FILES 10\r
+3.4. CONCURRENCY 11\r
+3.4.1. INVOKING THE LOGLAN INTERPRETER FOR CONCURRENT PROGRAMS 11\r
+3.4.2. RESTRICTIONS AND DIFFERENCES FROM THE REPORT 12\r
+3.4.3. COMMUNICATION MECHANISM 13\r
+3.5. SYSTEM SIGNALS 15\r
+3.6. IMPLEMENTATION RESTRICTIONS 15\r
+\r
+APPENDICES\r
+ A : PREDEFINED CONSTANTS 16\r
+ B : PREDEFINED CLASSES 16\r
+ C : PREDEFINED PROCEDURES AND FUNCTIONS 20\r
+ D : ERROR CODES 22\r
+ E : LOGLAN RUNTIME ERRORS 34\r
+ F : CHARACTER SET 36\r
+\r
+BIBLIOGRAPHY 37\r
+I. LOGLAN'82 37\r
+II. Algorithmic Logic 39\r
+III. Related literature 40\r
+}\r
+0. PREFACE \r
+ This document provides information necessary to compile and execute Loglan programs. \r
+ This manual assumes basic knowledge of Loglan-82 language, described in "Report on the Loglan Programming Language" (see Bibliography). \r
+1. USING LOGLAN-82 SYSTEM \r
+The following three steps are required to execute a Loglan program: \r
+ {SYMBOL 183 \f "Symbol" \s 10 \h} Compilation (to intermediate code), \r
+ {SYMBOL 183 \f "Symbol" \s 10 \h} Generation of the interpreted code (from intermediate code), \r
+ {SYMBOL 183 \f "Symbol" \s 10 \h} Interpretation (i.e. execution of program). \r
+\r
+\r
+ Compilation is accomplished by invoking Loglan compiler. This step creates two destination files: the intermediate code file and the listing file. The intermediate code file is the input file for the second step: generation of the code accepted by interpreter.In this step two files containing object code are produced. They are the input files for the third step: interpretation. This step is equivalent to execution of a program.\r
+\r
+1.1. COMPILATION \r
+To invoke the Loglan compiler without specifying any command line parameters, type: \r
+ LOGLAN \r
+Then the prompt appears on your terminal: \r
+ File name: \r
+and the compiler waits for file specification.The default extension is LOG. \r
+The compiler will produce (optionally) listing file with the same file name and the extension LST and will produce, if no error occurs, the code file with the extension LCD. Destination files will be stored on the same drive and directory as the source file. \r
+\r
+\r
+Examples:\r
+ $ LOGLAN \r
+\r
+ File name: PROGRAM <ENTER> \r
+\r
+ Loglan compiler compiles program from PROGRAM.LOG file and creates PROGRAM.LCD. \r
+\r
+\r
+ $ LOGLAN A:PROGRAM1 or\r
+\r
+\r
+In this case the source file is A:PROGRAM.DAT. The file PROGRAM.LCD will be created on drive A. \r
+\r
+ $ LOGLAN /home/vous/PROGRAM2\r
+\r
+If any error occurs, the code file is not produced. At the end of compilation the following message is printed: \r
+ <number of errors> error(s) detected {SYMBOL 168 \f "ZapfDingbats"}\r
+1.2. COMPILER SWITCHES \r
+ There are two possibilities to specify compiler's options: by compiler switches (i.e. external options) or by comments in the source program (see chapter 2.). You may enter the compiler switches in command line after file name in the following format:\r
+ sw1 sw2... swk <return>\r
+where swi consists of character that designates the name of the option and either '+' or '-'.\r
+\r
+\r
+\r
+Examples:\r
+ \r
+ $ LOGLAN PROGRAM L- T+ \r
+\r
+ $ LOGLAN PROGRAM \r
+\r
+ In this case the default switches values are assumed. {SYMBOL 168 \f "ZapfDingbats"}\r
+\r
+\r
+ Scope of the switch is the entire program. All switches ,except H, correspond to options. A switch has greater priority then options: when you specify switch, all corresponding options inside source program will be ignored. Full description of each option is given in chapter 2.2. Switch L has additional significance. When this switch is set off no listing file is produced. \r
+1.3. CODE GENERATION \r
+ In this step information from the intermediate code file is read and two destination files containing the code are produced. No switch is permitted for this step. To generate code files, type: \r
+ GEN <file name>\r
+ or HGEN <file name>, if the switch H+ was specified for the compiler.(DOS/AT only)\r
+\r
+You type file name without extension (extension is ignored). \r
+\r
+\r
+Examples: \r
+\r
+\r
+ $ GEN \r
+ FILE_NAME: PROGRAM \r
+Information is read from file PROGRAM.LCD from default drive and directory. Two destination files are produced: PROGRAM.CCD and PROGRAM.PCD and stored in the same directory as the input file. \r
+\r
+\r
+ $ GEN /home/vous/PROGRAM2\r
+\r
+ Files PROGRAM.CCD and PROGRAM.PCD are stored on drive A. {SYMBOL 169 \f "Symbol"}\r
+1.4. PROGRAM INTERPRETATION \r
+ To interprete (execute) the Loglan program you must invoke the interpreter INT or HINT (if the switch H+ was specified). File name must be specified in command line. The file extension is ignored. The interpreter reads input files with the given name and extensions CCD and PCD and executes the Loglan program.\r
+The syntax for calling the interpreter is\r
+\r
+ INT <options> <file name> \r
+ or\r
+ HINT <options> <file name> (DOS/AT only)\r
+\r
+The following options are supported:\r
+\r
+ /m < n > set memory size for Loglan program (in 16 bit words for small and 32 bit words for huge memory). For concurrent programs it means memory size for every process.\r
+ /i information about garbage collection-compactification is printed.\r
+ /r < n > used to invoke interpreter on nodes different from console (see 3.4.). option parameter is console node number (as defined by D-Link Network).\r
+ /d causes trace to be printed to the file with .TRD extension provided that the option or switch D+ was used during compiling.\r
+\r
+\r
+ At the end of interpretation the following message is printed: \r
+\r
+ End of LOGLAN-82 program execution \r
+\r
+\r
+Examples: \r
+\r
+ $ LOGLAN \DAT\EXAMP.SRC, L+ \r
+\r
+\r
+ The file \DAT\EXAMP.LCD and \DAT\EXAMP.LST are generated. \r
+\r
+ $ GEN \DAT\EXAMP \r
+\r
+ The files \DAT\EXAMP.CCD and \DAT\EXAMP.PCD are created. {SYMBOL 168 \f "ZapfDingbats"}\r
+\r
+Then the program can be interpreted by: \r
+\r
+ $ INT \DAT\EXAMP \r
+1.5. COMPILE TIME ERRORS\r
+ The errors detected during the compilation are printed on the listing file, if this file is created. In the scope of option L- or if the switch L is set off only the incorrect lines and errors messages are printed . When the switch ( not option !) L is set off then listing file is not produced and incorrect lines and error messages are printed on the user's terminal. \r
+ Error message has the following format: \r
+\r
+ *** ln ERROR en txt id \r
+where: \r
+\r
+ ln - index of incorrect line, \r
+ en - error code (see Appendix B), \r
+ txt- text that explain type of the error, \r
+ id - identifier helpful to situate the error. \r
+\r
+Error messages are printed in the source listing after incorrect lines. \r
+For syntax errors (numbered 101-147, 201-212), sign '?' indicates the error's position in the line. \r
+Error may be detected beyond the line containing it. \r
+Identifier helpful to find an error is printed as soon as possible. \r
+\r
+For codes 331-338 error message is printed after first line of virtual module declaration. \r
+Errors like "undeclared identifier" are printed in each module once, after first reference to this identifier. Further references are ignored. \r
+The errors related to case instruction may appear before the incorrect line. \r
+1.6. RUN-TIME ERRORS \r
+ Loglan run-time errors are detected by Loglan run-time system. When any of these errors occurs, the appropriate system signal is raised and error message is printed if handler is not found. All of these error messages are described in Appendix C. moreover the line number of the last executed statement is printed on the user's terminal. \r
+2. COMPILER OPTIONS \r
+Options, like switches are used to pass some information to the compiler. Options are placed in source program in comments. Scope of options in source program is textual. Option may appear in any place of source program, but it is active from the beginning of the nearest instruction. Listing option L is active from the next line after line containing setting this option on up to the line containing setting this option off. Options overwrite defaults, but are overwritten by switches (external options). Option definition is not allowed before the keyword program. \r
+2.1. OPTION FORMAT \r
+ Options may be placed in source program in comments in the following format: \r
+ (*$opt1,opt2,...*)\r
+where opti consists of character that designates the option and either '+' or '-' e.g.: (*$L-,T+*). Options in one comment should be separated by commas. Spaces in such comment are not allowed. \r
+\r
+\r
+\r
+2.2. OPTIONS LIST \r
+ D - trace \r
+ D+ - causes the line numbers of the executed instruction to be printed, \r
+ D- - default, \r
+ L - listing \r
+ L- - default, only incorrect lines are printed on the terminal\r
+ L+ - all lines are printed on the listing file\r
+ O - optimization \r
+ O+ - optimization of some arithmetical and logical expressions are included to generated code (default), \r
+ O- - generate code without optimization, \r
+ T - type conflict checking \r
+ T+ - default, dynamic checking of type conflict in assignment instructions and in parameter transmissions, \r
+ T- - no dynamic checking \r
+ H - memory model (switch only) APPLIES ONLY to PC/AT/XT !!\r
+ H- - default, small memory\r
+ H+ - huge memory\r
+\r
+ PC/AT/XT When H- is specified all code and data must fit into 64K \r
+ bytes. When H+ is specified all memory available on IBM PC \r
+ may be utilized, with the cost of increased execution time.\r
+3. CURRENT LOGLAN-82 IMPLEMENTATION SPECIFICATION\r
+3.1. IMPLEMENTED SUBSET OF LOGLAN \r
+ The following constructions described in the report of Loglan-82 have not been implemented: \r
+ - local attributes, \r
+ - separate compilation, \r
+File system is described in 3.3. \r
+3.2. PREDEFINED LANGUAGE ELEMENTS \r
+ Predefined constants, procedures and functions are added to the language (see Appendix A). Moreover keywords char (short form of character) and bool (short form of boolean) are added. \r
+ The character set, defined in the report of Loglan-82, is extended by lower-case letters and the tabulation character (decimal code 9). It is possible to use operator '<>' which stands for 'not equal'. \r
+3.3. FILE SYSTEM \r
+Loglan contains the predefined reference type file and a set of statements and standard procedures to manipulate files. \r
+Both sequential and direct access files are implemented.\r
+3.3.1. FILE VARIABLES \r
+ Variables of the type file can be declared in the Loglan program and can be used as any variables of a reference type. \r
+\r
+Example: \r
+\r
+ var f:file, \r
+ A:arrayof file; \r
+\r
+ unit p:procedure(f:file); ... end p; \r
+ begin \r
+ ...... \r
+ f := A(i); \r
+ ...... \r
+ end; \r
+3.3.2. FILE GENERATION \r
+A file object is generated by open statement of the form: \r
+\r
+ open(f,T) for internal files or \r
+\r
+ open(f,T,A) for external files \r
+\r
+where \r
+ f is a file variable, \r
+\r
+ T = text for text files, \r
+ char for binary sequential files of character,\r
+ integer integer or\r
+ real real values\r
+ direct for direct access binary files.\r
+ \r
+A is an expression of the type arrayof char designating external file name. After execution of open statement the new file object is created and it becomes a value of the file variable f. If the file is opened as an external one, then it references to the file A.\r
+\r
+\r
+Example: \r
+\r
+ open(data,text) - new internal text file data is opened\r
+ open(num ,integer) - new internal binary file num is opened\r
+ (the file components are integer numbers)\r
+ open(f,text,unpack("my.dat")) - external text file f is opened;\r
+ it references to the file my.dat stored on the default drive and directory.\r
+ open(f,direct,A) - an external direct access file with name in array A is opened.\r
+3.3.3. FILE DEALLOCATION \r
+ The file can be closed and deallocated by execution of the statement kill. \r
+3.3.4. GENERAL FILE OPERATIONS \r
+ There are three standard procedures associated with files: RESET, REWRITE and UNLINK. \r
+\r
+call RESET(f) rewinds the file f. After execution of RESET on sequential files only read/get operations are available. \r
+\r
+call REWRITE(f) creates a new empty file. After execution of REWRITE on sequential files only write/put operations are available.\r
+\r
+call UNLINK(f) closes and deletes file f. File object is deallocated and f is set to one.\r
+\r
+ RESET or REWRITE must be performed on the file opening before the first I/O operation on it. \r
+3.3.5. TEXT FILES \r
+ The following operations are available to text files: read, readln, eoln, write, writeln, eof. The first parameter of the operation is a file variable. If it is omitted, then a standard input/output file assigned to user's terminal is used.\r
+\r
+\r
+\r
+\r
+\r
+Example: \r
+\r
+ read(f,a,b); \r
+ read(c); \r
+ writeln(g," .... "); \r
+ if eof(f) then .... \r
+\r
+\r
+For more information see [1]. \r
+3.3.6. BINARY SEQUENTIAL FILES\r
+ Any file created with the parameter T = integer, real or char is a binary one. It is a sequence of components of the type T. Only objects of type T can be read from or written to this file. \r
+ The following operations are available to binary files:\r
+ put(f, w1, ..., wn) \r
+ get(f, x1, ..., xn) \r
+ eof(f) \r
+\r
+where f is a file opened with the type T, wi is an expression of the type T and xi is a variable of the type T. \r
+ The statement put(f, w1, ..., wn) writes the components w1, ...,wn to the file f. The statement get(f, x1, ..., xn) reads the next n components from the file f and assigns them to the variables x1, ..., xn. The statement eof is the same as for text files. \r
+3.3.7 DIRECT ACCESS BINARY FILES\r
+Direct access files are treated as a sequence of bytes without any interpretation. Operations RESET and REWRITE prepare a file for both reading and writing. RESET is used for existing files, \r
+ REWRITE for the new ones. \r
+The following additional operations are available:\r
+\r
+call SEEK(f, offset, base) - moves the file pointer to the position designated by offset relative to base. \r
+ Offset is a signed integer specifying the number of bytes. \r
+Possible values for base are:\r
+ 0 - begining of file,\r
+ 1 - current position of file pointer,\r
+ 2 - end of the file.\r
+\r
+Examples:\r
+\r
+call SEEK(f, 0, 0) - rewinds file f,\r
+call SEEK(f, -3, 1) - backspaces file f by 3 bytes,\r
+call SEEK(f, 0, 2) - moves the file pointer to the first byte after end of file\r
+\r
+POSITION(f) - returns current position of the file pointer associated with f.\r
+\r
+PUTREC(f, A, n) - where A is an array of any primitive type and n is an integer variable. Let k be the number of bytes occupied by elements of array A. This operation writes min(k, n) bytes from A to the file f and advances file pointer by the number of written bytes. The number of bytes written to the file is returned in the variable n.\r
+\r
+\r
+GETREC(f, A, n) - where A is an existing array of any primitive type and n is an integer variable. Let k be the number of bytes occupied by elements of array A This operation reads min(k,n) bytes (or less, if end of file is encountered) from the file and advances the file pointer by the number of read bytes. The number of bytes read from the file is returned in the variable n.\r
+3.4. CONCURRENCY\r
+ Implemented concurrency mechanisms differ much from those described in the LOGLAN-82 report []. In particular, only distributed processes are implemented, so they cannot communicate through shared variables. For this reason semaphores had to be replaced by an entirely new communication mechanism. Such a mechanism has been designed and it is based on the rendez-vous schema.\r
+3.4.1. INVOKING THE LOGLAN INTERPRETER FOR CONCURRENT ROGRAMS\r
+ A concurrent LOGLAN program may run on a single computer with concurrency simulated by time slicing. In this case LOGLAN interpreter is invoked as usual. One must only remember that /m optional parameter (see 1.4.) denotes memory size for each process rather than for the whole program.\r
+To achieve true parallel (multiprocessor) execution, a network of IBM PC computers may be used. For the time being, only D-Link Network Version 3.21 is supported. In order to run a LOGLAN program in the network environment take the following steps:\r
+ 1) make sure that every node is logged on,\r
+ 2) select arbitrarily one node as a console,\r
+ 3) invoke the LOGLAN interpreter on every node except the console, giving it /r option with the console node number (see 1.4.). You must give the same program file to all interpreters. Most conveniently it may be achieved by accessing a file on a disk connected through the network to each node.\r
+ 4) invoke the interpreter on the console without the /r option (in the usual way). Give it the same program file as above.\r
+\r
+After the last step the main program process begins its execution on the console node. Other processes may be created dynamically on any node on which an interpreter is running.\r
+\r
+Regardless of the fact whether the network is used or not, more than one process may be executed on the same computer.\r
+\r
+3.4.2. RESTRICTIONS AND DIFFERENCES FROM THE REPORT\r
+All processes (even those executed on the same computer) are implemented as distributed, i.e. without any shared memory. This fact implies some restrictions on how processes may be used. Not all restrictions are enforced by the present compiler, so it is the programmer's responsibility to respect them. This is the list of restrictions:\r
+\r
+ 1) all process units must be declared as global, i.e. directly inside the main program, \r
+ 2) a process cannot access global variables (except for the main program process),\r
+ 3) any remote access to a process object other than a procedure call is inhibited\r
+ 4) each parameter of\r
+ {SYMBOL 183 \f "Symbol" \s 10 \h} a process,\r
+ {SYMBOL 183 \f "Symbol" \s 10 \h} a procedure called by remote access to a process object,\r
+ {SYMBOL 183 \f "Symbol" \s 10 \h} a procedure parameter of a process,\r
+ must be one of the following:\r
+ {SYMBOL 183 \f "Symbol"} a value of the primitive type (Integer, Real, Char, Boolean, String)\r
+ {SYMBOL 183 \f "Symbol"} a procedure declared directly inside a process\r
+ {SYMBOL 183 \f "Symbol"} a procedure which is a formal parameter of a process\r
+ {SYMBOL 183 \f "Symbol"} any reference to a process object.\r
+ This restriction implies that references to objects other than processes have only local meaning (in a single process) and cannot be passed among the processes.\r
+ 5) comparisons, IS, IN and QUA operations are not allowed for the references to processes. \r
+ 6) operations which require dynamic type checking on the references to processes are not allowed.\r
+ 7) a process may be attached only by a proper coroutine generated by it.\r
+ 8) the variable MAIN is accesible only in the main program process.\r
+\r
+ The following concurrent constructs described in the report are not implemented at all:\r
+\r
+ - semaphores and all operations on them\r
+ - the WAIT expression.\r
+\r
+ Semantics of the NEW generator is slightly modified when applied to the processes. The first parameter of the first process unit in the prefix sequence must be of type INTEGER. This parameter denotes the node number of the computer on which this process will be created. For a single computer operation this parameter must be equal to 0.\r
+\r
+Example:\r
+\r
+unit A:class(msg:string);\r
+...\r
+end A;\r
+unit P:A process(node:integer, pi:real);\r
+...\r
+end P;\r
+...\r
+var x:P;\r
+...\r
+begin\r
+...\r
+ (* Create process on node 4. The first parameter is the *) \r
+ (* string required by the prefix A, the second is the node number *)\r
+ x := new P("Hello", 4, 3.141592653);\r
+...\r
+end\r
+\r
+\r
+ The following parallel constructs are implemented as defined in the report:\r
+\r
+ - KILL operation for a process\r
+ - RESUME statement\r
+ - STOP statement without parameter.\r
+3.4.3. COMMUNICATION MECHANISM\r
+ Processes may communicate and synchronize by a mechanism based on rendez-vous. It will be referred to as "alien call" in the following description.\r
+\r
+ An alien call is either:\r
+ - a procedure (or function) call performed by a remote access to a process object, or\r
+ - a call of a procedure which is a formal parameter of a process, or\r
+ - a call of a procedure which is a formal parameter of an alien-called procedure (this is a recursive definition).\r
+\r
+ Every process object has an enable mask. It is defined as a subset of all procedures declared directly inside a process unit or any unit from its prefix sequence (i.e. subset of all procedures that may be alien-called).\r
+ A procedure is enabled in a process if it belongs to that process' enable mask. A procedure is disabled if it does not belong to the enable mask. \r
+ Immediately after generation of a process object its enable mask is empty (all procedures are disabled).\r
+ Semantics of the alien call is different from the remote call described in the report. Both the calling process and the process in which the procedure is declared (i.e. the called process) are involved in the alien call. This way the alien call may be used as a synchronization mechanism.\r
+ The calling process passes the input parameters and waits for the call to be completed.\r
+ The alien-called procedure is executed by the called process. Execution of the procedure will not begin before certain conditions are satisfied. First, the called process must not be suspended in any way. The only exception is that it may be waiting during the ACCEPT statement (see below). Second, the procedure must be enabled in the called process.\r
+ When the above two conditions are met the called process is interrupted and forced to execute the alien-called procedure (with parameters passed by the calling process).\r
+Upon entry to the alien-called procedure all procedures become disabled in the called process.\r
+Upon exit the enable mask of the called process is restored to that from before the call (regardless of how it has been changed during the execution of the procedure). The called process is resumed at the point of the interruption. The execution of the ACCEPT statement is ended if the called process was waiting during the ACCEPT (see below). \r
+At last the calling process reads back the output parameters and resumes its execution after the call statement.\r
+\r
+The process executing an alien-called procedure can easily be interrupted by another alien call if the enable mask is changed.\r
+\r
+There are some new language constructs associated with the alien call mechanism. The following statements change the enable mask of a process:\r
+ ENABLE p1, ..., pn\r
+enables the procedures with identifiers p1, ..., pn. If there are any processes waiting for an alien call of one of these procedures, one of them is chosen and its request is processed. The scheduling is done on a FIFO basis, so it is strongly fair. The statement:\r
+ DISABLE p1, ..., pn\r
+disables the procedures with identifiers p1, ..., pn.\r
+In addition a special form of the RETURN statement:\r
+ RETURN ENABLE p1, ..., pn DISABLE q1, ..., qn\r
+allows to enable the procedures p1, ..., pn and disable the procedures q1,...,qn after the enable mask is restored on exit from the alien-called procedure. It is legal only in the alien-called procedures (the legality is not enforced by the compiler).\r
+A called process may avoid busy waiting for an alien call by means of the ACCEPT statement:\r
+ ACCEPT p1, ..., pn\r
+adds the procedures p1, ..., pn to the current mask, and waits for an alien call of one of the currently enabled procedures. After the procedure return the enable mask is restored to that from before the ACCEPT statement.\r
+\r
+ Note that the ACCEPT statement alone (i.e. without any ENABLE/DISABLE statements or options) provides a sufficient communication mechanism. In this case the called process may execute the alien-called procedure only during the ACCEPT statement (because otherwise all procedures are disabled). It means that the enable mask may be forgotten altogether and the alien call may be used as a pure totally synchronous rendez-vous. Other constructs are introduced to make partially asynchronous communication patterns possible.\r
+\r
+\r
+3.5. SYSTEM SIGNALS \r
+ System signals are connected to runtime errors (see APPENDIX C). \r
+\r
+These signals are the following: \r
+\r
+ ACCERROR - reference to non existing object, \r
+ CONERROR - array index outside the range or lower bound is greater than upper bound during array object generation, \r
+ LOGERROR - errors related to control transfer, \r
+ MEMERROR - memory overflow, \r
+ NUMERROR - errors related to arithmentic operations like division by zero, floating point overflow, \r
+ TYPERROR - type conflict in assignment statement, during parameter transmission or headline conflict for actual parameter function and procedure. \r
+ SYSERROR - errors related to file system, like reading after writing, too many files etc. \r
+3.6. IMPLEMENTATION RESTRICTIONS \r
+ - Text line in source program can't be longer than 80 characters. \r
+ - Maximal length of identifier is 20 characters, but entire length of all identifiers and keywords should be less than 3000 characters. \r
+ - String constant can't be longer than 260 characters. \r
+ - For case instructions: \r
+ - up to 6 levels of nested case instructions are allowed, \r
+ - range of labels can't be greater than 160. \r
+ - Number of formal parameters can't be greater than 40, whereas up to 35 output or input parameters are allowed. Total number of formal parameters and variables declared in one module can't be greater than 130. \r
+ - Number of array indices (i.e. arrayof) can't be greater than 63, \r
+ - Standard type integer has the range (-32767,+32767) for small memory (16 - bit word). For huge memory (32-bit word) the range is (-2147483647,+2147483647), but values of constant expressions in a program must lie within the range (-2767, 32767).\r
+ - Real numbers have the range (-8.43E-37, 3.37E+38) with 24-bit mantissa and 8-bit exponenet for small memory , giving about 7 digits of precision. For huge memory the range is (4.19E-307, 1.67E+308) with 53-bit mantissa and 11-bit exponent, giving about 15 digits of precision.Values of constant expression in a program must lie in the range (-8.43E-37, 3.37E+38).\r
+\r
+\r
+\r
+Warning \r
+\r
+Compiler computes values of expressions built from constants without range checking. It means, that integer overflow, floating point overflow or underflow cause incorrect result without any message. \r
+\r
+\r
+\r
+APPENDIX A : PREDEFINED CONSTANTS\r
+\r
+\r
+ INTSIZE\r
+ The size in bytes of integer variables (2 for small memory, 4 for huge memory)\r
+\r
+ REALSIZE\r
+ The size in bytes of real variables (4 for small memory, 8 for huge memory)\r
+\r
+APPENDIX B : PREDEFINED CLASSES\r
+IIUWGRAPH\r
+\r
+{Applies for DOS/AT versions, see a separate document IIUWGRAPH for details} \r
+\r
+{For Unix, see the separate document XIIUWGRAF} \r
+\r
+Class IIUWGRAPH defines the set of graphics procedures. The full description of these procedures is contained in the description of the library IIUWGRAF (Institute of Informatics, University of Warsaw). The following procedures are available in Loglan (heads are specified if they are different from these in IIUWGRAF description): \r
+\r
+ gron - graphics on 1 parameter to be ignored integer\r
+ groff - GRAPHICS OFF, no parameters\r
+ cls - Clear screen, no pamrameters\r
+ point - set current position to (x,y) and give it current colour\r
+ move - set current position to (x,y)\r
+ draw \r
+ hfill \r
+ vfill \r
+ color \r
+ style \r
+ patern \r
+ intens \r
+ pallet \r
+ border \r
+ video \r
+ hpage \r
+ nocard : function: integer; \r
+ pushxy \r
+ popxy \r
+ inxpos : function: integer; \r
+ inypos : function: integer; \r
+ inpix \r
+ getmap : function(input x,y:integer): arrayof integer; \r
+ putmap \r
+ ormap \r
+ xormap \r
+ track \r
+ inkey : function : integer; \r
+ hascii \r
+ hfont \r
+ hfont8 \r
+ outstring \r
+ cirb\r
+\r
+\r
+\r
+\r
+MOUSE\r
+\r
+{Applies only to DOS/AT versions} \r
+{For UNIX and 386 versions see the corresponding documents}\r
+\r
+A predefined class MOUSE provides basic support for mouse. An external resident Microsoft compatible mouse driver (such as MOUSE.SYS) must be installed to use this class. MOUSE contains following procedures and functions:\r
+\r
+unit MOUSE: class;\r
+\r
+init:function(output b:integer):boolean\r
+{Initializes mouse driver. Number of mouse buttons is returned in b. Returns true iff mouse hardware and software are installed.}\r
+\r
+showcursor:procedure\r
+{This procedure increments the internal cursor counter. If the counter is 0 it displays the cursor on the screen. The cursor tracks the motion of the mouse, changing position as the mouse changes position.}\r
+\r
+hidecursor:procedure\r
+{This procedure removes the cursor from the screen and decrements the internal cursor counter. Although the cursor is hidden it still tracks the motion of the mouse, changing position as the mouse changes position.}\r
+\r
+status:procedure(output h, v:integer, l, r, c:boolean)\r
+{This procedure reports the status of the buttons and cursor. l, r, c are true iff respectively left, right and center (if it exists) buttons are down when the procedure is called. Also position of cursor is returned in h and v. Position is expressed in Color Graphics Adapter pixels (with resolution 640x200).}\r
+\r
+setposition:procedure(h, v:integer)\r
+{This procedure sets the cursor to the specified horizontal and vertical positions on the screen. The new values must be within the specified ranges of the virtual screen. The values are rounded to the nearest values permitted by the screen for horizontal and vertical positions.}\r
+\r
+getpress:procedure(b:integer; output h, v, p:integer, l, r, c:boolean)\r
+{This procedure gives a count of selected button presses (on p) since the last call to it and the position of the cursor (on h and v) the last time the button was pressed. Parameter b selects button to be checked: 0 - left, 1 - right, 2 - center. In addition current button status is returned in l, r and c (see procedure status).}\r
+\r
+getrelease:procedure(b:integer; output h, v, p:integer, l, r, c:boolean)\r
+{This procedure gives a count of selected button releases (on p) since the last call to it and the position of the cursor (on h and v) the last time the button was released. Parameter b selects button to be checked: 0 - left, 1 - right, 2 - center. In addition current button status is returned in l, r and c (see procedure status).}\r
+\r
+setwindow:procedure(l, r, t, b:integer)\r
+{Restricts the cursor movement to window described by l, r, t, b. L and r are minimum and maximum horizontal cursor position, t and b are minimum and maximum vertical cursor position (in pixels)}\r
+\r
+defcursor:procedure(s, x, y:integer)\r
+{Selects text mode cursor characteristics. When s is 0, software cursor is selected and x, y define masks to be used when modifying character-attribute word in screen memory associated with position under cursor. This word is logicaly ANDed with x and the result is XORed with y. When s is 1, a hardware cursor is selected and x, y define first and last scan lines of the cursor box within character box. X must be not greater than y and both must be in range 0-7 for Color Graphics Adapter or 0-13 for Monochrome Display Adapter, Hercules Graphics Card and Enhanced Graphics Adapter.\r
+Examples:\r
+call defcursor(0, -1, 30464) \r
+ - selects standard (reverse video) software cursor \r
+call defcursor(1, 11, 12) \r
+ - selects standard hardware cursor for HGC}\r
+\r
+getmovement:procedure(output h, v:integer)\r
+{Returns relative mouse movement since last call (in 1/200 inches).}\r
+\r
+setspeed:procedure(h, v:integer)\r
+{H and v specify horizontal and vertical cursor speed relative to mouse speed. It is expressed in mouse steps (1/200 inch) corresponding to 8 pixels on screen. Default is 8 horizontaly and 16 verticaly.\r
+Examples: \r
+call setspeed(1, 1) \r
+ - set maximum cursor speed \r
+call setspeed(16, 32) \r
+ - set cursor speed two times slower than default}\r
+\r
+setthreshold:procedure(s:integer)\r
+{sets threshold speed for double speed feature. If the mouse moves faster than the threshold, the cursor speed on the screen is doubled. Default threshold is 64 mouse steps/second. \r
+ \r
+Example: \r
+call setthreshold(10000) \r
+ - efectively disable double speed feature.}\r
+\r
+\r
+end MOUSE;\r
+\r
+APPENDIX C : PREDEFINED PROCEDURES AND FUNCTIONS \r
+ ENDRUN:procedure; \r
+ Terminates program execution (ABORT). \r
+\r
+ RANSET:procedure(x:real); \r
+ Initializes random generator (for RANDOM function) \r
+\r
+ RANDOM:function:real; \r
+ Generates uniformly distributed pseudo-random numbers in the interval (0,1). \r
+\r
+ SQRT:function(x:real):real; \r
+ Computes square root of parameter x. \r
+\r
+ SIN:function(x:real):real; \r
+ Computes sinus of parameter x. \r
+\r
+ COS:function(x:real):real; \r
+ Computes cosinus of parameter x. \r
+\r
+ TAN:function(x:real):real; \r
+ Computes tangens of parameter x. \r
+\r
+ EXP:function(x:real):real; \r
+ Computes e**x. \r
+\r
+ LN:function(x:real):real; \r
+ Computes natural logarithmus of parameter x. \r
+\r
+ ATAN:function(x:real):real; \r
+ Computes arcus tangens of parameter x. \r
+\r
+ ENTIER:function(x:real):integer; \r
+ Computes entier part of parameter x. \r
+\r
+ ROUND:function(x:real):integer; \r
+ Computes rounded value of parameter x: ROUND(x)=ENTIER(x+0.5). \r
+\r
+ IMIN:function(x, y:integer):integer; \r
+ Computes minimum of two parameters. \r
+\r
+ IMAX:function(x, y:integer):integer; \r
+ Computes maximum of two parameters. \r
+\r
+ IMIN3:function(x, y, z:integer):integer; \r
+ Returns the minimum of three parameters. \r
+\r
+ IMAX3:function(x, y, z:integer):integer; \r
+ Returns maximum of three parameters. \r
+\r
+ ISHFT:function(x, k:integer):integer; \r
+ Logically shifts x by k bits: left, when k is positive, right otherwise. \r
+\r
+ IAND:function(n, k:integer):integer; \r
+ Returns logical product of parameters (on all bits). \r
+\r
+ IOR:function(n, k:integer):integer; \r
+ Returns logical sum of parameters (on all bits). \r
+\r
+ XOR:function(n, k:integer):integer; \r
+ Returns exlusive sum of parameters (on all bits). \r
+\r
+ INOT:function(n:integer):integer; \r
+ Returns logical complement of parameters (on all bits). \r
+\r
+ ORD:function(c:char):integer; \r
+ Returns number that represents character c (see APPENDIX F). \r
+ The following equations are satisfied: CHR(ORD(c)) = c &ORD(CHR(n)) = n \r
+\r
+ CHR:function(n:integer):char; \r
+ Returns character represented by parameter n (see APPENDIX F). \r
+\r
+ UNPACK:function(s:string):arrayof char; \r
+ Returns address of new array object containing characters of the string s. \r
+\r
+ MEMAVAIL:function:integer;\r
+ Returns the size of available memory in the current process (in words).\r
+\r
+ EXEC:function(cmd:arrayof char):integer; \r
+ Calls secondary command processor with cmd as a command string. Exit code is returned as a value of EXEC. \r
+ \r
+ TIME:function: integer; \r
+ Returns an integer value indicating the amount of central processor time in seconds used by current process. \r
+ \r
+ RESET:procedure(f:file); \r
+ Positionnes file f at the first component and readies it to reading. \r
+\r
+ REWRITE:procedure(f:file); \r
+ Positionnes file f at the first component and readies it for output. \r
+ The file f becomes empty (eof(f) = true). \r
+\r
+ UNLINK:procedure(f:file);\r
+ Closes and deletes file f (see 3.3.4)\r
+\r
+ SEEK:procedure(f:file; offset, base:integer);\r
+ Positiones file pointer (see 3.3.7)\r
+\r
+ POSITION:function(f:file):real;\r
+ Reads position of file pointer (see 3.3.7)\r
+\r
+\r
+APPENDIX D : ERROR CODES\r
+ 0 - ***declaration part overloaded \r
+Overflow of compiler data structure of declaration part. Possible reasons: too complicated program structure (too many classes, protection lists, parameter lists,...), too complicated function expressions e.g. f(g(h(...))). It is possible that removing some errors e.g. "unvisible identifier" causes shortening of the program. \r
+ 10 - ***too many errors \r
+Overflow of error diagnostic table. 1024 first detected errors are printed, but global number of error is equal to number of all detected errors. \r
+ 41 - ***declaration part overloaded \r
+Comments as for 0. \r
+ 101 - ':=' expected \r
+ 102 - ';' expected \r
+ 103 - 'then' expected \r
+ 104 - 'fi'/'else' expected \r
+ 105 - 'od' expected \r
+ 106 - '(' expected \r
+ 107 - ')' expected \r
+ 108 - 'do' expected \r
+ 109 - identifier expected \r
+ 110 - too many exits found \r
+ Length of sequence exit exit ...exit exceeds level of loop nesting +1. \r
+ 111 - illegal character \r
+ 112 - wrong structure of 'if'-statement \r
+ 113 - 'end' missing \r
+ 114 - '.' expected \r
+ 115 - illegal constant in expression \r
+ Character constant or text appears in logical or arithmetical expression. \r
+ 116 - '=' expected \r
+ 117 - constant expected \r
+ 118 - ':' expected \r
+ 119 - unit kind specification expected \r
+Keywords: class, procedure, function, coroutine or process missing in module headline. \r
+ 120 - 'hidden' or 'close' occurred twice \r
+ 121 - 'hidden' or 'close' out of a class \r
+ 122 - 'block' expected \r
+ 123 - object expression is not a generator \r
+Object expression appearing as instruction is not a generator e.g. new (a).b \r
+ 124 - 'dim' expected \r
+ 125 - 'to'/'downto' expected \r
+ 126 - illegal arithmetic operator \r
+ 127 - declaration part expected \r
+ 128 - incorrect identifier at 'end' \r
+Module name after end does not correspond to name in module headline. \r
+ 129 - wrong structure of 'case'-statement \r
+ 130 - wrong structure of 'do'-statement \r
+ 131 - illegal use of 'main' \r
+ Name main may be used only as an argument of attach operator; in other cases it is illegal. \r
+ 132 - 'when' expected \r
+ 133 - too many branches in 'case'-statement \r
+Number of branches in case instruction is greater than 160. \r
+ 134 - 'begin' missed \r
+ 135 - bad option \r
+ 136 - is it really a loglan program??? \r
+There is no Loglan keyword found in source program like: begin, block, unit, class,... \r
+ 137 - 'block' missed - parsing began \r
+There is no keyword block or program at the beginning of the Loglan program. This message indicates the source line, that is the first compiled line. \r
+ 138 - 'repeat' out of a loop \r
+ The length of sequence: (exit)*repeat exceeds nested depth of the loop. \r
+ 139 - there is no path to this statement \r
+ 140 - 'andif'/'orif' mixed \r
+ 141 - array of 'semaphore' is illegal \r
+ 142 - wrong handler end \r
+Handler declaration is not ended by instruction end or end handlers. \r
+ 143 - lastwill inside a structured statement \r
+ 144 - repeated lastwill \r
+Label LASTWILL appears more than once in the same module. \r
+ 145 - no parameter specification \r
+ 146 - wrong register specification \r
+ 147 - "," expected\r
+ 191 - ***null program \r
+There is no source program on the input file or there is no module declaration. Causes termination of program compilation. \r
+ 196 - ***too many identifiers \r
+Entire length of all identifiers and keywords is greater than 3000 characters. This overflow terminates program compilation. \r
+ 197 - ***too many formal parameters \r
+The length of formal parameter list and declared local variables (in actual module) is greater than 130. This error terminates program compilation. \r
+ 198 - ***parsing stack overloaded \r
+Too complicated (nested) program structure. This error terminates program compilation. \r
+ 199 - ***too many prototypes \r
+Too many declarations in program caused overflow of the compiler data structure. This error terminates program compilation. \r
+ 201 - wrong real constant \r
+ 202 - wrong comment \r
+ 203 - wrong character constant \r
+ 204 - wrong integer constant \r
+ 205 - integer overflow \r
+Integer constant out of range. \r
+ 206 - real overflow \r
+Real constant out of range. \r
+ 211 - identifier too long \r
+Length of identifier is greater than 20 characters. \r
+ 212 - string too long \r
+Length of string constant is greater than 260 characters. \r
+ 301 - prefix is not a class id \r
+Prefix name ID is not a class name. It may appear when identifier ID is used earlier (declared more than once). \r
+ 303 - coroutine/process illegal here as prefix id \r
+Procedure, function or block can't be prefixed by coroutine or process. \r
+ 304 - hidden identifier cannot be taken id \r
+Identifier ID placed on taken list is on hidden list in the prefixing module. \r
+ 305 - undeclared identifier id \r
+ 306 - undeclared type identifier id \r
+ 307 - type identifier expected id \r
+Identifier ID used in variable or function declaration as a type name, is not declared earlier as a type (but name has been used earlier). \r
+ 308 - undeclared prefix identifier id \r
+ 309 - declared more than once id \r
+ 310 - taken list in unprefixed unit \r
+ 316 - formal type specification after use id \r
+Formal type ID appears in the parameter list after using this identifier as parameter type e.g. (... x: ID; type ID, ...). \r
+ 317 - hidden type identifier id \r
+Type name ID is on hidden list in a prefix of one of the modules from SL chain of actual module and it is a nearest declaration of this identifier. \r
+ 318 - type identifier not taken id \r
+Type name ID is not on taken list in a prefix of one of the modules from SL chain of actual module. \r
+ 319 - hidden identifier in the list id \r
+Identifier ID from hidden or close list is on hidden list in one of the prefixing modules. \r
+ 320 - identifier in the list not taken id \r
+Identifer ID from hidden or close list is not placed on taken list in none of the prefixing modules. \r
+ 321 - identifier cannot be taken id \r
+Identifer ID from taken list is placed on taken list in none of the prefixes. \r
+ 322 - hidden prefix identifier id \r
+Analogical to 317 error. \r
+ 323 - prefix identifier not taken id \r
+Analogical to 318 error. \r
+ 329 - only procedure and function may be virtual \r
+ virtual specification appears with class specification. \r
+ 330 - virtual in unprefixed block/procedure/function \r
+ 331 - incompatible kinds of virtuals id \r
+Kind of virtual module ID is different from kind of replaced module (e.g. one of them is a function, the other one is a procedure). \r
+ 332 - incompatible types of virtuals id \r
+ Type of virtual function ID is different from type of replaced function. \r
+ 333 - different lengths of form.param.lists in virtuals id \r
+Virtual module ID and replaced module have different number of formal parameters. \r
+ 334 - conflict kinds of the 1st level parameters id \r
+In the headline of virtual module ID kind of formal parameter differs from corresponding formal parameter in the headline of replaced module (e.g. type and variable, input and output parameters,.). \r
+ 335 - incompatible types of the 1st level parameters id \r
+There are formal parameters of different types (function, procedure) in the headline of virtual module ID and in the headline of replaced module on the same position. \r
+ 336 - different lengths of the 2nd level params lists id \r
+There are formal procedures/functions with different numbers of parameters in the headline of virtual module ID and in the headline of replaced module on the same position. \r
+ 337 - incompatible kinds of the 2nd level parameters id \r
+There are parameters of different kinds on the same position in the corresponding procedure or function parameters in the headline of virtual module ID and in the headline of replaced module. \r
+ 338 - incompatible types of the 2nd level parameters id \r
+There are parameters of different types on the same position in the corresponding procedure or function in the headline of virtual module ID and in the headline of replaced module. \r
+ 341 - ***declaration part overloaded \r
+Analogical to error 0. \r
+ 342 - ***too many classes declared \r
+ 343 - ***too many prototypes \r
+Too many modules declared on the same level. \r
+ 350 - undeclared signal identifier id \r
+ 351 - hidden signal identifier id \r
+Analogical to error 317. \r
+ 352 - signal identifier not taken id \r
+Analogical to error 318. \r
+ 353 - signal identifier expected id \r
+Identifier ID placed in handler declaration as a signal name has not been declared as a signal. \r
+ 354 - different types of parameters id \r
+In the headlines of signals, that have common handler, parameters of the different types appear on the same position. ID is one of these parameters. \r
+ 355 - incompatible kinds of parameters id \r
+In the headlines of signals that have common handler, parameters of different kinds appear on the same position. ID is one of these parameters. \r
+ 356 - different identifiers of parameters id \r
+In the headlines of signals that have common handler parameters of different names appear on the same position. ID is one of these parameters. \r
+ 357 - incompatible kinds of the 2nd level parameters id \r
+Analogous to error 355 for 2-nd level parameters. \r
+ 358 - different types of the 2nd level parameters id \r
+Analogous to error 354 for the 2-nd level parameters. \r
+ 359 - different lengths of the 2nd level params lists id \r
+There are formal procedures or formal functions with different number of parameters on the same position in the headlines of signals this have common handler. ID is one of these formal parameters/functions. \r
+ 360 - different lengths of form. param. lists in signals id \r
+There are different number of formal parameters in the signals that have common handler. ID is one of these signals. \r
+ 361 - non-local formal type cannot be used id \r
+Formal parameter ID of signal is of non local formal type. \r
+ 362 - repeated handler for signal id \r
+There are more than one handler for signal ID in the same module. \r
+ 370 - only 'input' is legal here \r
+Formal parameter output or inout is illegal in process. \r
+ 398 - class prefixed by itself id \r
+Construction unit ID: ID class is not allowed. \r
+ 399 - cycle in prefix sequence id \r
+ID is a class identifier used in cyclic prefixing i.e. ID prefixes a, a prefixes b, ... , z prefixes ID. This construction is not allowed. \r
+ 401 - wrong label in 'case' id \r
+Label in case instruction is not a constant. \r
+ 402 - 'case' statement nested too deeply \r
+Nesting level in case instruction is greater than 6. \r
+ 403 - too long span of 'case' labels \r
+Range of branches in case instruction is greater than 160. \r
+ 404 - repeated label in 'case'-statement id \r
+Label ID appears more than once in case instruction. \r
+ 405 - illegal type of 'case' expression id \r
+Control expression in case statement is not of \r
+ integer or char type. \r
+ 406 - different types of labels and 'case' expression \r
+ 407 - non-logical expression after 'if'/'while' id \r
+ 408 - real constant out of integer range \r
+Error during conversion of real constant to integer constant. \r
+ 410 - simple variable expected id \r
+Control variable in for loop is not a simple variable. \r
+ 411 - non-integer control variable id \r
+Control variable ID in for loop is not of integer type. \r
+ 412 - non-integer expression id \r
+Expression placed as array index or bound limit in array generation or as step in for loop or as format in write statement should be reducable to integer type. \r
+ 413 - file expression expected id \r
+ 414 - string expression expected id \r
+ 415 - reference expression expected id \r
+Expression placed before dot (remote access), before qua or as a argument of kill or copy statement is not of class type. \r
+ 416 - array expression expected id \r
+ 417 - boolean expression expected id \r
+ 418 - semaphore variable expected \r
+ 419 - illegal type in 'open' \r
+The type name placed in open is different than TEXT, REAL, INTEGER, CHAR and DIRECT. \r
+ 420 - variable expected id \r
+Expression placed on the left side of assignment statement or as an argument of read instruction or in array instruction is not a variable. \r
+ 421 - class identifier after 'new' expected id \r
+Identifier ID placed after new is not a class identifier. \r
+ 422 - procedure identifier after 'call' expected id \r
+ 423 - 'new' missing id \r
+Keyword new doesn't appear before class identifier for object generation. \r
+ 424 - 'call' missing id \r
+Keyword call doesn't appear before procedure identifier for procedure call. \r
+ 425 - 'inner' out of a class \r
+ 426 - 'inner' occurred more than once \r
+ 427 - 'wind'/'terminate' out of a handler \r
+ 428 - 'inner' inside lastwill \r
+ 429 - definition cannot be reduced to constant id \r
+Identifier ID placed in constant definition is not a constant. \r
+ 430 - undefined constant in the definition id \r
+ 431 - wrong number of indices id \r
+Number of indices in referencing to array element is different from declared number of indices. \r
+ 432 - index out of range id \r
+ 433 - upper bound less than lower bound id \r
+ 434 - too many subscripts id \r
+Dimension of static array ID is greater than 7. \r
+ 435 - variable is not array id \r
+ 440 - type identifier expected after 'arrayof' id \r
+Identifier ID placed after arrayof in actual parameter list, corresponding to type parameter is not a type name. \r
+ 441 - incorrect format in 'write' \r
+There is format for expression of char type or there is double format for expression of type integer or string. \r
+ 442 - illegal expression in 'write' \r
+Argument of write statement is not of type char, string, integer or real. \r
+ 443 - illegal type of variable in 'read' id \r
+Argument of read statement is not of type char, integer or real. \r
+ 444 - no data for i/o transfer \r
+There is only file identifier in I/O instruction. \r
+ 445 - illegal expression in 'put' \r
+ 446 - illegal expression in 'get' \r
+ 448 - 'raise' missing id \r
+There is signal identifier without keyword raise in the context of signal raising. \r
+ 449 - signal identifier expected id \r
+Identifer ID after keyword raise is not a signal identifier. \r
+ 450 - illegal procedure occurrence id \r
+Procedure name ID appears in illegal context. \r
+ 451 - illegal class occurrence id \r
+Class name ID appears in illegal context. \r
+ 452 - illegal type occurrence id \r
+Type name ID appears in illegal context. \r
+ 453 - illegal signal occurrence id \r
+Signal name ID appears in illegal context. \r
+ 454 - illegal operator occurence \r
+ 455 - wrong number of operands \r
+ 460 - divided by zero \r
+ 470 - illegal input parameter id \r
+Actual parameter associated with input parameter is not expression that may have any value: it is e.g. procedure name \r
+ 471 - illegal output parameter id \r
+Actual parameter corredponded to output parameter is not a variable. \r
+ 472 - illegal type parameter id \r
+Actual parameter ID associated with type parameter is not a type name. \r
+ 473 - illegal procedure parameter id \r
+Actual parameter ID associated with procedure parameter is not a procedure name. \r
+ 474 - illegal function parameter id \r
+Actual parameter ID associated with function parameter is not a function name. \r
+ 475 - illegal left side of 'is'/'in' id \r
+Left side argument ID of is/in is not a reference expression. \r
+ 476 - illegal right side od 'is'/'in' id \r
+Right side argument ID of is / in is not a class name. \r
+ 477 - illegal parameter of 'attach' id \r
+Parameter ID of attach statement is not a reference variable of class object. \r
+ 478 - illegal type of expression\r
+ 479 - negative step value\r
+ 550 - ***stack overloaded \r
+This error may be removed by dividing expressions into subexpressions, making simpler nested callings of arrays, functions, classes and for loops. This error terminates compilation of current module, but other modules will be compiled. \r
+ 551 - ***too many auxiliary variables needed \r
+Too complicated expressions. This error may be removed by declaration of additional variables and using them as auxiliary variables in expressions. \r
+ 552 - ***too many auxiliary reference variable needed \r
+Analogical to error 551. \r
+ 553 - ***statement sequence too long or too complicated \r
+This error may be removed by adding 'goto' statement into sequence of instructions e.g. if false then exit fi, inner, ... or by dividing complicated expression into subexpressions. \r
+ 554 - ***real constants dictionary overflow \r
+Too many real constant, maybe because of evaluation of expressions built from real constants. \r
+ 600 - undeclared identifier id \r
+ 601 - illegal type before '.' id \r
+Expression placed before dot (remote access) is not of class type. \r
+ 602 - close identifier after '.' id \r
+Identifier ID placed after dot is on close list in the class or its prefix that construct expression before dot. \r
+ 603 - undeclared identifier after '.' id \r
+Identifier ID placed after dot is not attribute of expression placed before dot. It may be caused by missing declaration or using bad prefix for class constructing expression before dot. \r
+ 604 - illegal operand type id \r
+One of the arguments in arithmetical expression or in relation is not of arithmetical type. \r
+ 605 - illegal type in 'div/'mod' term id \r
+Expression identified by ID used as argument of div or mode operation is not of integer type. \r
+ 606 - incompatible types in comparison id \r
+ID is an identifier of left argument of relation. \r
+ 607 - unrelated class types in comparison id \r
+ID is an identifier of left argument of relation. Both arguments are of class type and none of these classes prefixes the other one. \r
+ 608 - string cannot be compared id \r
+ID identifies a string. \r
+ 609 - incompatible types in assignment/transmission id \r
+ID is an identifier of left side of assignment statement or an identifier of actual parameter in object generation. Types of both sides of instruction or type of formal parameter and type of actual parameter are incompatible. \r
+ 610 - unrelated class types in assignment/transmission id \r
+Analogical to errors 609 and 607. \r
+ 611 - constant after '.' id \r
+An attempt to remote access to constant. \r
+ 612 - this class does not occur in sl-chain id \r
+ Class ID appeared in expression this ID, but ID dosn't prefix any module in SL chain of actual module. It may be a cycle. \r
+ 613,614 - class identifier expected id \r
+For error 613: identifier ID used in expression this ID is not of class type. For error 614: identifier ID used in expression this ID is not name of any type. \r
+ 615 - illegal type before 'qua' id \r
+ Object expression before qua should be of one of the types: class, coroutine, process or simple (not array) formal type. \r
+ 616,617 - illegal type after 'qua' id \r
+For error 616: identifier ID used after qua is not of any type. \r
+For error 617: identifier ID used after qua is not of class type. \r
+ 618 - unrelated types in 'qua'-expression id \r
+Identifier ID is a name of class type used after qua. This class type and class type used before qua doesn't prefix each other. \r
+ 619 - hidden identifier id \r
+Identifier ID used in construction qua ID or this ID is on hidden list in the prefix of one of the module from SL chain of actual module. \r
+ 620 - not taken identifier id \r
+Identifier ID used in construction qua ID or this ID is not on taken list in any prefix of any module of actual module. \r
+ 621 - invisible identifier after '.' id \r
+Identifier ID placed after dot is on hidden list or is not on taken list in prefix. \r
+ 622 - formal parameter list is shorter id \r
+Identifier ID identifies generated object: class, procedure or function. Formal parameters list of this object is shorter than actual parameters list. \r
+ 623 - formal parameter list is longer id \r
+Analogical to error 622. \r
+ 624 - actual parameter is not a reference type id \r
+Actual parameter identified by ID in generated object can't be of primitive type: integer, real, boolean or string. \r
+ 625 - actual parameter is not a type id \r
+Actual parameter identified by ID is not a type, so it can't replace formal type parameter. \r
+ 626 - procedure-function conflict between parameters id \r
+Actual parameter, identified by ID, that replaced formal parameter in generated object is function whereas formal parameter is a procedure or vice versa. \r
+ 627 - unmatched heads-wrong kinds of parameters id \r
+ID identifies actual module that replaced formal module. There are parameters of different kinds on the same position in the headlines of these modules. For input - output conflict the agreement of parameter types is checked also. \r
+ 628 - unmatched heads-incompatible types in lists id \r
+ID identifies actual module that replaced formal module. There are input /output parameters of different types on the same position in the headlines of actual and formal module. \r
+ 629 - unmatched heads-unrelated class types in lists id \r
+ID identifies actual module that replaced formal module. There are input/output parameters specifying classes of disjointed prefix sequences \r
+in the headlines of actual and formal module. \r
+ 630 - unmatched heads-different numbers of parameters id \r
+There are different lengths of headlines in actual module identified by ID and formal module. \r
+ 631 - incompatible types of function parameters id \r
+There are different types of actual function specified by identifier ID and formal function in generated object. \r
+ 632 - function/procedure expected id \r
+Actual parameter identified by identifier ID is not function/procedure, whereas corresponding formal parameter is function/procedure. \r
+ 633 - actual function type defined weaker than formal id \r
+Type of actual function identified by ID is weaker defined than formal function type e.g. formal function type is statically defined, whereas actual function type is formal (external) or formal function is class, whereas actual function type is coroutine or process. \r
+ 634 - unmatched heads-too weak type in actual list id \r
+There are input/output parameters on the same position in the headlines of actual module identified by identifier ID and formal module, but ID is weaker defined than corresponding formal module parameter (see error 633). \r
+ 635 - standard function/procedure cannot be actual par. id \r
+ID identifies standard procedure/function used as actual parameter. \r
+ 636 - illegal use of semaphore id \r
+ 637 - 'semaphore' cannot be used id \r
+\r
+\r
+APPENDIX E : LOGLAN RUNTIME ERRORS \r
+ In the following list system signal name, raised after detection of runtime error, is placed in brackets. \r
+\r
+ARRAY INDEX ERROR (CONERROR) \r
+Index outside range during reference to array variable. \r
+NEGATIVE STEP VALUE (CONERROR)\r
+\r
+SL CHAIN CUT OFF (LOGERROR) \r
+Control transfer to object that has SL link cut off earlier in the consequence of kill operation. \r
+ILLEGAL ATTACH (LOGERROR) \r
+The value of parameter of attach instruction is none or object differs from coroutine. \r
+ILLEGAL DETACH (LOGERROR) \r
+An attempt to return by detach to coroutine that has been dealocated (by kill). \r
+ILLEGAL RESUME (LOGERROR)\r
+An attempt to resume an object which is not a process or a process which is running.\r
+TOO MANY PROCESSES ON ONE MACHINE (SYSERROR)\r
+Number of processes existing on one computer is greater than 64.\r
+INVALID NODE NUMBER (SYSERROR)\r
+An attempt to create a process on a computer which is not connected to network.\r
+IMPROPER QUA (LOGERROR) \r
+Error during computing expression of the form: ...x qua a, when 'x' references to none or 'a' doesn't prefix dynamic type object, which is value of 'x'. \r
+ILLEGAL ASSIGNMENT (TYPERROR) \r
+Type conflict between left and right side of assignment instruction. \r
+FORMAL TYPE MISSING (LOGERROR) \r
+Formal type is not accessible because of SL cut off. \r
+ILLEGAL KILL (LOGERROR) \r
+An attempt to deallocate object in SL chain of active object. \r
+ILLEGAL COPY (LOGERROR) \r
+An attempt to copy non terminated object (i.e. class before execution of return statement, coroutine before execution of end statement...). \r
+REFERENCE TO NONE (ACCERROR) \r
+An attempt to remote access (by dot) to attributes of non existing object: dealocated or not generated. \r
+MEMORY OVERFLOW (MEMERROR) \r
+\r
+INCOMPATIBLE HEADERS (TYPERROR) \r
+Actual parameter list of generated object (procedure, function or class) is incompatible with formal parameter list from module declaration or formal function type is incompatible with actual function type. \r
+\r
+INCORRECT ARRAY BOUNDS (CONERROR) \r
+An attempt to generate dynamic array object, when lower bound of \r
+ index range is greater than upper bound. \r
+DIVISION BY ZERO (NUMERROR) \r
+\r
+COROUTINE TERMINATED (LOGERROR) \r
+An attempt to transfer control to a terminated coroutine. \r
+COROUTINE ACTIVE (LOGERROR) \r
+An attempt to transfer control to an active coroutine. \r
+HANDLER NOT FOUND (LOGERROR) \r
+There is no handler for signal declared by user. \r
+ILLEGAL RETURN (LOGERROR) \r
+An attempt to execute return instruction in handler serving system signal. \r
+UNIMPLEMENTED STANDARD PRC. (LOGERROR) \r
+Standard procedure or function is not implemented. \r
+FORMAL LIST TOO LONG (MEMERROR) \r
+Formal parameter list is greater than 40. \r
+ILLEGAL I/O OPERATION (SYSERROR) \r
+Reading after writing, the type of the read/write parameter does not match the type of the file etc. \r
+I/O ERROR (SYSERROR)\r
+ System error during I/O.\r
+CANNOT OPEN FILE (SYSERROR)\r
+\r
+INPUT DATA FORMAT BAD (SYSERROR)\r
+\r
+SYSTEM ERROR (SYSERROR)\r
+Should not occur.\r
+UNRECOGNIZED ERROR\r
+\r
+APPENDIX F : CHARACTER SET \r
+At the top of the table are hexadecimal digits (0 to 7), and to the left of the table are hexadecimal digits (0 to F). Hexadecimal code of ASCII character is constructed by contatenation of column label and row label. For example, the value of character representing the plus sign is 2B. \r
+\r
+ 0 1 2 3 4 5 6 7 \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 0 ! NUL ! DLE ! SP ! 0 ! @ ! P ! ! p ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 1 ! SOH ! DC1 ! ! ! 1 ! A ! Q ! a ! q ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 2 ! STX ! DC2 ! " ! 2 ! B ! R ! b ! r ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 3 ! ETX ! DC3 ! # ! 3 ! C ! S ! c ! s ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 4 ! EOT ! DC4 ! $ ! 4 ! D ! T ! d ! t ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 5 ! ENQ ! NAK ! % ! 5 ! E ! U ! e ! u ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 6 ! ACK ! SYN ! & ! 6 ! F ! V ! f ! v ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 7 ! BEL ! ETB ! ' ! 7 ! G ! W ! g ! w ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 8 ! BS ! CAN ! ( ! 8 ! H ! X ! h ! x ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 9 ! HT ! EM ! ) ! 9 ! I ! Y ! i ! y ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ A ! LF ! SUB ! * ! : ! J ! Z ! j ! z ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ B ! VT ! ESC ! + ! ; ! K ! [ ! k ! { ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ C ! FF ! FS ! , ! < ! L ! \ ! l ! | ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ D ! CR ! GS ! - ! = ! M ! ] ! m ! } ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ E ! SO ! RS ! . ! > ! N ! ^ ! n ! ~ ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ F ! SI ! US ! / ! ? ! O ! _ ! o ! DEL ! \r
+ _________________________________________________ \r
+\r
+\r
+where: \r
+ NUL Null DLE Data Link Escape \r
+ SOH Start of Heading DC1 Device Control 1 \r
+ STX Start of Text DC2 Device Control 2 \r
+ ETX End of Text DC3 Device Control 3 \r
+ EOT End of Transmission DC4 Device Control 4 \r
+ ENQ Enquiry NAK Negative Acknowledge \r
+ ACK Acknowledge SYN Synchronous Idle \r
+ BEL Bell ETB End of Transmission Block \r
+ BS Backspace CAN Cancel \r
+ HT Horizontal Tabulation EM End of Medium \r
+ LF Line Feed SUB Substitute \r
+ VF Vertical Tab ESC Escape \r
+ FF Form Feed FS File Separator \r
+ CR Carriage Return GS Group Separator \r
+ SO Shift Out RS Record Separator \r
+ SI Shift In US Unit Separator \r
+ SP Space DEL Delete \r
+BIBLIOGRAPHY \r
+Last update: {TIME \@ "MMMM d, yyyy"|March 21, 1994}\r
+\r
+Should you like to read on Loglan and its companion Algorithmic Logic, here it is, a short list of more important papers.\r
+ I. LOGLAN'82\r
+Bartol,W.M., et al.\r
+Report on the Loglan 82 programming Language,\r
+Warszawa-Lodz, PWN, 1984\r
+\r
+A.Kreczmar\r
+A micro-manual of the programming language LOGLAN-82,\r
+Institute of Informatics, University of Warsaw, 1984\r
+(there exists a french translation of the above manual)\r
+(both texts are distributed together with this package)\r
+\r
+A.Kreczmar, A.Salwicki, M. Warpechowski, \r
+Loglan'88 - Report on the Programming Language,\r
+Lecture Notes on Computer Science vol. 414, Springer Vlg, 1990,\r
+ISBN 3-540-52325-1\r
+\r
+/* do you know polish? istnieje dobry podrecznik Loglanu! */\r
+A.Szalas, J.Warpechowska,\r
+LOGLAN, \r
+Wydawnictwa Naukowo-Techniczne, Warszawa, 1991 ISBN 82-204-1295-1 \r
+ \r
+\r
+Some papers devoted to the problems and challenges of Loglan.\r
+\r
+Bartol,W.M., Kreczmar, A., Litwiniuk, A., Oktaba, H.,\r
+Semantic and Implementation of Prefixing at Many Levels, \r
+in Lecture Notes in Computer Science vol.148, Springer Verlag, Berlin,\r
+1983, pp.45-80\r
+\r
+Krause,M., Kreczmar, A., Langmaack, H., Salwicki,A.,\r
+Specification and Implementation Problems of Programming Languaages\r
+Proper for Hierarchical Data Types,\r
+Report 8410 of Institut fuer Informatik und Praktische Mathematik\r
+Christian-Albrechts-Universitaet Kiel, 1984, pp.1-68\r
+\r
+Kreczmar,A., Salwicki,A.,\r
+Concatenable Type Declarations, Their Application and Implementation\r
+in: Programming Languages and System Design, in Programming, Languages and System Design Proc. IFIP TC2 Conference (J.Bormann ed.) Dresden, 1983 \r
+North Holland, Amsterdam, 1983, pp.29-41\r
+\r
+\r
+Cioni, G., Kreczmar, A.,\r
+Modules in high level programming languages\r
+in: Advanced Programming Methodologies (G.Cioni, A.Salwicki eds.)\r
+Academic Press, London, 1989, 247-340\r
+\r
+Kreczmar, A.,\r
+On inheritance Rule in Object Oriented Programming\r
+in: Advanced Programming Methodologies\r
+Academic Press, London, 1989, pp. 141-164\r
+\r
+Cioni,G., Kreczmar,A., Vitale, R.,\r
+Storage Management\r
+in: Advanced Programming Methodologies\r
+Academic Press, London, 1989, pp.341-366\r
+\r
+\r
+Cioni, G., Kreczmar, A.,\r
+Programmed deallocation without Dangling References,\r
+IPL, vol. 18 1984, pp. 179-185\r
+\r
+Krause, M., Kreczmar, A., Langmaack, H., Warpechowski, M.,\r
+Concatenation of program modules, an Algebraic Approach to the Semantic and Implementation Problems,\r
+in: Proc. Computation Theory, LNCS 208, Springer Vlg, Berlin, 1986, pp. 134-156\r
+full text in: Report 8701 of Institut fuer Informatik und Praktische Mathematik\r
+Christian-Albrechts-Universitaet Kiel, 1987, pp.1-48\r
+\r
+Krause, M.,\r
+Die Korrektheit einer Implementation der Modulpraefigerung mit reiner Static Scope Semantik,\r
+Report 8616 of Institut fuer Informatik und Praktische Mathematik\r
+Christian-Albrechts-Universitaet Kiel, 1986, pp.1-139\r
+\r
+Langmaack, H.,\r
+On static Semantic of Prefixing (=inheritance),\r
+Talk delivered during the Summer School on Loglan'82, Zaborow, September 1983\r
+\r
+\r
+Ph.D. thesis (in polish!) related somehow to Loglan project.\r
+\r
+Szalas, A., \r
+On parallel processes, 1984\r
+\r
+Gburzynski, P.,\r
+GPR - theorem prover 1982\r
+\r
+Petermann, U.,\r
+On file system and signalling exceptions between processes 1987\r
+\r
+Oktaba, H.\r
+On Formalisation of the Notion of Reference and its Applications in Theory of Data Structures, 1982\r
+\r
+Bartol, W.M., \r
+Application of Static Structure of Type Declarations and the System of Dynamic Configurations in a Definition of Semantics of a Universal Programming Language 1981\r
+\r
+Szczepanska-Wasersztrum, D.,\r
+A logical system for reasoning about exceptions,1990\r
+\r
+Litwiniuk, A.I.,\r
+Several algorithms for optimisation of code in presence of nesting, 1988\r
+\r
+Jankowska-Puchalka B.\r
+A code genarator generator for an object oriented language, 1992\r
+II. Algorithmic Logic\r
+There is a monograph:\r
+\r
+G.Mirkowska, A.Salwicki, \r
+Algorithmic Logic, \r
+D.Reidel & Polish Scientific Publ., Dordrecht & Warszawa, 1987, ISBN 83-01-06859-0\r
+ the book contains a chapter devoted to certain problems of Loglan.\r
+\r
+A new book on AL appeared in polish\r
+G.Mirkowska, A.Salwicki, \r
+Logika algorytmiczna dla programistow,\r
+Wydawnictwa Naukowo-Techniczne, Warszawa, 1993 (ISBN 83-204-1296-X). \r
+An english version in preparation.\r
+\r
+\r
+There are many papers discussing the applications of AL in programming.\r
+\r
+Salwicki, A.,\r
+Development of Software from Algorithmic Specifications\r
+in: Advanced Programming Methodologies\r
+Academic Press, London, 1989, pp.1-40\r
+\r
+Salwicki, A.,\r
+On algorithmic theory of Stacks,\r
+in Proc. MFCS'78 (J.Winnkowski ed.), LNCS 63, Springer Berlin 1978, pp.\r
+\r
+Salwicki, A.,\r
+On algorithmic theory of dictionaries,\r
+Proc. Logic of Programs (E.Engeler ed.), LNCS 125, Springer, Berlin 1981 pp.145-168\r
+\r
+Müldner, T., Salwicki, A.,\r
+On algorithmic Properties of Concurrent Programs,\r
+in: Proc. Logic of Programs (E.Engeler ed.), LNCS 125, Springer, Berlin 1981 pp.170-193\r
+\r
+Mirkowska,G., Salwicki, A.,\r
+On applications of Algorithmic Logic,\r
+in: Proc. CAAP'86 (P. Franchi-Zanetacci ed.) Springer, 1986 pp.288-306\r
+\r
+Mirkowska,G., Salwicki, A.,\r
+Axiomatic definability of programming language semantics,\r
+in: Proc. IFIP Working Conf on Formal Description of Programming Concepts\r
+Ebberup 1986 (M. Wirsing ed.)\r
+Noth Holland, Amsterdam, 1986, pp1-15\r
+\r
+Mirkowska,G., Salwicki, A.,\r
+On Axiomatic Definition of Max-model of concurrency,\r
+in Proc. Advanced School on Mathematical Models of Parallelism Rome 1986\r
+(M. Venturini-Zilli ed.) LNCS Springer Berlin\r
+\r
+Salwicki, A.,\r
+Algorithmic Theories of Data Structures,\r
+in Proc. ICALP'82 (M.Nilsen, E.Schmidt eds.) LNCS 140 Springer, Berlin, 1982, pp. 458-472\r
+III. Related literature \r
+on object programming is immense.\r
+\r
+Let us quote a few books:\r
+\r
+E. Horowitz, \r
+Fundamentals of Programming Languages, \r
+Springer, New York, 1983\r
+\r
+\r
+O.-J. Dahl, B. Myhrhaug, K. Nygaard, \r
+Simula 67 Common Base Language, \r
+Norwegian Computing Center, Oslo, 1970 the mother of object languages!!\r
+\r
+B. Meyer,\r
+Object-oriented software construction,\r
+Prentice Hall, 1988\r
+\r
+B. Stroustrup \r
+The C++ Programming Language, \r
+Addison-Wesley, Reading, Mass., 1991\r
+\r
+on logics of programs:\r
+\r
+see a survey\r
+\r
+D. Kozen, J. Tiuryn\r
+Logics of Programs,\r
+in: Handbook of Theoretical Computer Science, vol.B, Formal Models and Semantics\r
+Elsevier, Amsterdam, 1990, pp. 789-998\r
+{PAGE|40} Loglan'82 user's manual\r
+\r
+Loglan'82 users's manual {PAGE|39}\r
+\r
+\r
--- /dev/null
+\r\r
+\r\r
+ DOCUMENTATION SUR XIIUWGRAF\r\r
+ ---------------------------\r\r
+\r\r
+ Gestion de graphismes en multifen\88trage sous XWindows.\r\r
+\r\r
+\r\r
+ 1 : Diff\82rences essentielles avec la librairie graphique\r\r
+ IIUWGRAPH\r\r
+\r\r
+\r\r
+ 2 : Ouvrir et fermer une fen\88tre avec XIIUWGRAF\r\r
+\r\r
+ 2.1 : Proc\82dure HPAGE\r\r
+ 2.2 : Proc\82dure GRON\r\r
+ 2.3 : Proc\82dure GROFF\r\r
+\r\r
+\r\r
+ 3 : Description des diverses commandes d\82di\82es aux graphismes\r\r
+ utilisables par l'interpr\88teur LOGLAN\r\r
+\r\r
+ 3.1 : Proc\82dure COLOR\r\r
+ 3.2 : Proc\82dure BORDER\r\r
+ 3.3 : Proc\82dure MOVE\r\r
+ 3.4 : Fonction CLS\r\r
+ 3.5 : Proc\82dure POINT\r\r
+ 3.6 : Proc\82dure DRAW\r\r
+ 3.7 : Proc\82dure CIRB\r\r
+ 3.8 : Proc\82dure HFILL\r\r
+ 3.9 : Proc\82dure VFILL\r\r
+ 3.10 : Fonction INXPOS\r\r
+ 3.11 : Fonction INYPOS\r\r
+\r\r
+\r\r
+ 3.12 : Commandes de saisie et de restition d'une partie d'une\r\r
+ fen\88tre\r\r
+ 3.12.1 : Fonction GETMAP\r\r
+ 3.12.2 : Proc\82dure PUTMAP\r\r
+ 3.12.3 : Proc\82dure ORMAP\r\r
+ 3.12.4 : Proc\82dure XORMAP\r\r
+\r\r
+ 3.13 : Proc\82dure INPIX\r\r
+ 3.14 : Proc\82dure STYLE\r\r
+\r\r
+ 3.15 : Commandes de saisie et d'affichage de caract\8ares\r\r
+ 3.15.1 : Fonction INKEY\r\r
+ 3.15.2 : Proc\82dure HASCII\r\r
+ 3.15.3 : Proc\82dure OUTSTRING\r\r
+\r\r
+ 3.16 : Proc\82dure PUSHXY\r\r
+ 3.17 : Proc\82dure POPXY\r\r
+\r\r
+ 4 : Description des commandes de gestion de la souris\r\r
+\r\r
+ 4.1 : Proc\82dure STATUS\r\r
+ 4.2 : Proc\82dure GETPRESS\r\r
+ 4.3 : Proc\82dure GETRELEASE\r\r
+ 4.4 : Proc\82dure GETMOVEMENT\r\r
+\r\r
+\r\r
+\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+\r\r
+ 1 : Diff\82rences essentielles entre XIIUWGRAF et IIUWGRAPH\r\r
+ -----------------------------------------------------\r\r
+\r\r
+ Ce paragraphe a pour objet de donner certaines particularit\82s de\r\r
+ XIIUWGRAF,ceci afin de comprendre son fonctionnement g\82n\82ral.\r\r
+\r\r
+ Tout d'abord il est important de signaler qu'\85 la diff\82rence de\r\r
+ IIUWGRAPH, XIIUWGRAF est un programme \85 part enti\8are (plus exactement un\r\r
+ processus cr\82e par l'interpr\88teur LOGLAN).C'est pour cela qu'il est\r\r
+ d\82conseill\82 (sauf cas de force majeure) de faire CONTROL-C pour terminer\r\r
+ un programme : en effet, ceci a pour effet de terminer l'ex\82cution de\r\r
+ l'interpr\88teur sans terminer XIIUWGRAF (cr\82ation d'un processus zombie).\r\r
+ Pour terminer une session graphique, il faudra donc automatiquement taper\r\r
+ dans le programme en LOGLAN la commande GROFF car elle va terminer\r\r
+ l'ex\82cution de XIIUWGRAF.\r\r
+\r\r
+ Certaines commandes de IIUWGRAPH n'ont pas \82t\82 impl\82ment\82es (par\r\r
+ exemple HIDECURSOR,SHOWCURSOR,PALLET, ...), soit parce qu'elles seraient\r\r
+ d'un int\82r\88t tr\8as faible dans la gestion de XWindows,soit parce qu'elles\r\r
+ seraient difficilement r\82alisables, soit parce que les programmeurs ont \82t\82\r\r
+ atteints de fain\82antise chronique.\r\r
+\r\r
+ Enfin, dans vos programmes il faudra imp\82rativement que vos unit\82s\r\r
+ g\82rant le graphisme h\82ritent de la classe IIUWGRAPH sous peine d'erreurs \85\r\r
+ la compilation .\r\r
+\r\r
+\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+\r\r
+\r\r
+ 2 : Ouvrir et fermer une fen\88tre avec XIIUWGRAF\r\r
+ -------------------------------------------\r\r
+\r\r
+ XIIUWGRAF permet \85 l'utilisateur d'ouvrir jusqu'\85 seize fen\88tres \85\r\r
+ l'\82cran.Ces fen\88tres sont s\82lectionnables dans le programme en LOGLAN par\r\r
+ la commande GRON d\82crite plus loin.\r\r
+\r\r
+ 2.1 : La proc\82dure HPAGE\r\r
+ ------------------\r\r
+\r\r
+ CALL HPAGE(numerofenetre,x,y);\r\r
+ VAR numerofenetre,x,y : INTEGER;\r\r
+\r\r
+ Cette proc\82dure a pour r\93le de donner la position \85 laquelle\r\r
+ sera affich\82e la fen\88tre dans l'\82cran, de donner la taille de cette\r\r
+ fen\88tre et de l'effacer quand le besoin s'en fait sentir. Cette proc\82dure\r\r
+ devra \88tre appel\82e deux fois pour ouvrir une fen\88tre.\r\r
+\r\r
+ HPAGE re\87oit trois param\88tres : le premier est le num\82ro de la\r\r
+ fen\88tre (un entier compris entre 0 et 15),les deux suivants sont soit les\r\r
+ coordonn\82es de la fen\88tre \85 l'\82cran, soit la taille de cette fen\88tre.\r\r
+ Un troisi\8ame appel de HPAGE avec l'un des deux derniers param\88tres\r\r
+ nuls aura pour effet de l'effacer.\r\r
+\r\r
+ Exemple : CALL HPAGE(0,posx,posy);\r\r
+ ------- CALL HPAGE(0,longueur,hauteur);\r\r
+\r\r
+ Le coin en haut \85 gauche de la fen\88tre 0 sera aux coordonn\82es\r\r
+ (posx,posy) et la fen\88tre aura une taille de longueur X hauteur.\r\r
+\r\r
+ CALL HPAGE(0,0,valeur)\r\r
+ ou CALL HPAGE(0,valeur,0)\r\r
+ ou CALL HPAGE(0,0,0)\r\r
+\r\r
+ La fen\88tre 0 est effac\82e.\r\r
+\r\r
+ 2.2 : La proc\82dure GRON\r\r
+ -----------------\r\r
+\r\r
+ CALL GRON(numerofenetre);\r\r
+ VAR numerofenetre : INTEGER;\r\r
+\r\r
+ La proc\82dure GRON affiche la fen\88tre de num\82ro numerofenetre \85\r\r
+ l'\82cran. Ensuite pour s\82lectionner la fen\88tre dans laquelle on veut\r\r
+ travailler, on refait un deuxi\8ame appel de cette commande.\r\r
+\r\r
+ Exemple : CALL HPAGE(0,0,0);\r\r
+ CALL HPAGE(1,150,0);\r\r
+ CALL HPAGE(0,100,100);\r\r
+ CALL HPAGE(1,200,150);\r\r
+ CALL GRON(0); Affichage de la fen\88tre 0\r\r
+ CALL GRON(1); Affichage de la fen\88tre 1\r\r
+ ...\r\r
+ CALL GRON(0); S\82lection de la fen\88tre 1\r\r
+ ...\r\r
+\r\r
+\r\r
+ 2.3 : La proc\82dure GROFF\r\r
+ ------------------\r\r
+\r\r
+ CALL GROFF;\r\r
+\r\r
+ L'appel \85 cette commande a pour cons\82quence l'effa\87age de toutes les\r\r
+ fen\88tres et la fin d'ex\82cution du processus XIIUWGRAF.\r\r
+\r\r
+\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+\r\r
+\r\r
+ 3 : Description des diff\82rentes commandes graphiques\r\r
+ ------------------------------------------------\r\r
+\r\r
+ 3.1 : Proc\82dure COLOR\r\r
+ ---------------\r\r
+\r\r
+ CALL COLOR(couleur);\r\r
+ VAR couleur : INTEGER;\r\r
+\r\r
+ Permet de d\82terminer la couleur d'avant plan (0 pour noir et une\r\r
+ valeur sup\82rieure ou \82gale \85 1 pour blanc). Cette commande a une\r\r
+ action locale \85 la fen\88tre s\82lectionn\82e par GRON.\r\r
+\r\r
+ 3.2 : Proc\82dure BORDER\r\r
+ ----------------\r\r
+\r\r
+ CALL BORDER(couleur);\r\r
+ VAR couleur : INTEGER;\r\r
+\r\r
+ Commande qui s\82lectionne la couleur de fond.\r\r
+\r\r
+ 3.3 : Proc\82dure MOVE\r\r
+ --------------\r\r
+\r\r
+ CALL MOVE(posx,posy);\r\r
+ VAR posx,posy : INTEGER;\r\r
+\r\r
+ posx et posy deviennent les coordonn\82es courantes dans la fen\88tre.\r\r
+ Comme COLOR, MOVE n'agit que sur la fen\88tre s\82lectionn\82e.\r\r
+\r\r
+ 3.4 : Proc\82dure CLS\r\r
+ -------------\r\r
+\r\r
+ CALL CLS;\r\r
+\r\r
+ Efface la fen\88tre en blanc par d\82faut ou de la couleur sp\82cifi\82e par\r\r
+ la commande BORDER.\r\r
+\r\r
+ 3.5 : Prc\82dure POINT\r\r
+ --------------\r\r
+\r\r
+ CALL POINT(x,y);\r\r
+ VAR x,y : INTEGER;\r\r
+\r\r
+ Affiche un point aux coordonn\82es (x,y) de la couleur sp\82cifi\82e par la\r\r
+ commande COLOR ou noir par d\82faut. La position courante dans la fen\88tre\r\r
+ devient (x,y).\r\r
+\r\r
+ 3.6 : Proc\82dure DRAW\r\r
+ --------------\r\r
+\r\r
+ CALL DRAW(x,y);\r\r
+ VAR x,y : INTEGER;\r\r
+\r\r
+ Affiche une ligne qui part de la position courante dans la fen\88tre\r\r
+ vers la position (x,y). La position courante dans la fen\88tre devient\r\r
+ (x,y). Elle est affich\82e avec la couleur courante (s\82lectionn\82e avec\r\r
+ COLOR) et avec le style de trac\82 courant (s\82lectionn\82e par la commande\r\r
+ STYLE d\82crite plus loin);\r\r
+\r\r
+ 3.7 : Proc\82dure CIRB\r\r
+ --------------\r\r
+\r\r
+ CALL CIRB(posx,posy,rayon,alpha,beta,cbord,style,p,q);\r\r
+ VAR posx,posy,rayon,p,q,cbord,style : INTEGER;\r\r
+ VAR alpha,beta : REAL;\r\r
+\r\r
+ Si style a pour valeur 0, CIRB affiche un arc de centre (posx,posy),\r\r
+ de rayon rayon. alpha et beta sont les angles de d\82part et d'arriv\82e de\r\r
+ l'arc en question. Si alpha=beta alors un cercle (ou une ellipse) est\r\r
+ dessin\82. Si p=q alors on obtient un cercle, si p>q une ellipse allong\82e\r\r
+ dans le sens vertical est obtenue, sinon si p>q on a pour r\82sultat une\r\r
+ ellipse allong\82e dans le sens horizontal. Cet affichage est fait avec\r\r
+ la couleur d'avant plan courante et le style de trac\82 courant.\r\r
+\r\r
+ Si style vaut 1, CIRB affiche un arc rempli ressemblant \85 une portion\r\r
+ de camenbert avec la couleur d'avant plan courante.\r\r
+\r\r
+ Si style vaut 2, l'int\82rieur de l'arc d\82limit\82 par sa courbure et la\r\r
+ corde joignant ses deux extr\88mit\82s est rempli avec la couleur d'avant\r\r
+ plan courante.\r\r
+\r\r
+ Si l'on choisi pour style une valeur <0 ou >3, la valeur 0 est prise.\r\r
+\r\r
+ 3.8 : Proc\82dure HFILL\r\r
+ ---------------\r\r
+\r\r
+ CALL HFILL(y);\r\r
+ VAR y : INTEGER;\r\r
+\r\r
+ Trace une ligne horizontale de la position courante (posx,posy) vers\r\r
+ les coordonn\82es (posx,y) avec la couleur d'avant plan courante et le\r\r
+ style de trac\82 courant. La position courante dans la fen\88tre devient\r\r
+ (posx,y).\r\r
+\r\r
+ 3.9 : Proc\82dure VFILL\r\r
+ ---------------\r\r
+\r\r
+ CALL VFILL(x);\r\r
+ VAR x : INTEGER;\r\r
+\r\r
+ Trace une ligne verticale de la position courante (posx,posy) vers\r\r
+ les coordonn\82es (x,posy) avec la couleur d'avant plan courante et le\r\r
+ style de trac\82 courant. La position courante dans la fen\88tre devient\r\r
+ (x,posy).\r\r
+\r\r
+ 3.10 : Fonction INXPOS\r\r
+ ---------------\r\r
+\r\r
+ posx:=INXPOS;\r\r
+ VAR posx : INTEGER;\r\r
+\r\r
+ Retourne la position courante sur l'axe des abscisses de la fen\88tre\r\r
+ courante.\r\r
+\r\r
+ 3.11 : Fonction INYPOS\r\r
+ ---------------\r\r
+\r\r
+ posy:=INYPOS;\r\r
+ VAR posy : INTEGER;\r\r
+\r\r
+ Retourne la position courante sur l'axe des ordonn\82es de la fen\88tre\r\r
+ courante.\r\r
+\r\r
+ 3.12 : Commandes de saisie et de restitution d'une partie d'une\r\r
+ --------------------------------------------------------\r\r
+ fen\88tre.\r\r
+ --------\r\r
+\r\r
+ 3.12.1 : Fonction GETMAP\r\r
+ ---------------\r\r
+\r\r
+ tab:=GETMAP(x,y);\r\r
+ VAR x,y : INTEGER;\r\r
+ VAR tab : ARRAYOF INTEGER;\r\r
+\r\r
+ Sauve dans le tableau tab une partie rectanguraire de la fen\88tre\r\r
+ courante, le coin en haut \85 gauche \82tant la position courante dans la\r\r
+ fen\88tre et le coin en bas \85 droite \82tant la position (x,y).\r\r
+ Le tableau devrait avoir une taille minimum de :\r\r
+ 4 + (nbrelignes * (3 + nbrecol div 8)) octets\r\r
+\r\r
+ En sachant qu'en LOGLAN un entier tient sur 4 octets, il ne vous\r\r
+ reste plus qu'\85 faire votre cuisine.\r\r
+\r\r
+ 3.12.2 : Proc\82dure PUTMAP\r\r
+ ----------------\r\r
+\r\r
+ CALL PUTMAP(tab);\r\r
+ VAR tab : ARRAYOF INTEGER;\r\r
+\r\r
+ Affiche la portion d'image sauv\82e dans tab \85 la position\r\r
+ courante dans la fen\88tre. Ce qu'il y avait \85 cette m\88me position avant\r\r
+ l'affichage est totalement effa\87\82.\r\r
+\r\r
+ 3.12.3 : Proc\82dure ORMAP\r\r
+ ---------------\r\r
+\r\r
+ CALL ORMAP(tab);\r\r
+ VAR tab : ARRAYOF INTEGER;\r\r
+\r\r
+ Lors de l'affichage, une op\82ration OR est faite avec la portion\r\r
+ d'image sauv\82e dans tab et celle \85 la position courante dans la\r\r
+ fen\8atre : l'image est donc affich\82e en "transparence".\r\r
+\r\r
+ 3.12.4 : Proc\82dure XORMAP\r\r
+ ----------------\r\r
+\r\r
+ CALL XORMAP(tab);\r\r
+ VAR tab : ARRAYOF INTEGER;\r\r
+\r\r
+ M\88me chose qu'avec ORMAP \85 la diff\82rence qu'une op\82ration XOR est\r\r
+ faite avec l'image sauv\82e dans tab et celle \85 la position courante\r\r
+ dans la fen\88tre.\r\r
+\r\r
+ 3.13 : Fonction INPIX\r\r
+ --------------\r\r
+\r\r
+ couleur:=INPIX(x,y);\r\r
+ VAR couleur,x,y : INTEGER;\r\r
+\r\r
+ Cette fonction met la postion courante dans la fen\88tre \85 (x,y) et\r\r
+ renvoie la couleur du point de la fen\88tre \85 cette position(0 pour\r\r
+ noir et 1 pour blanc).\r\r
+\r\r
+ 3.14 : Proc\82dure STYLE\r\r
+ ---------------\r\r
+\r\r
+ CALL STYLE(style);\r\r
+ VAR style : INTEGER;\r\r
+\r\r
+ D\82finit le style de trac\82 dans la fen\88tre courante.\r\r
+\r\r
+ Si style vaut 0, le trac\82 sera fait avec la couleur de fond.\r\r
+ Si style vaut 1, le trac\82 sera fait avec la couleur d'avant plan.\r\r
+ Si style vaut 2,3,4 ou 5, le trac\82 sera fait avec les motif suivant :\r\r
+\r\r
+ 2 : ******...******...******\r\r
+\r\r
+ 3 : ****......****......****\r\r
+\r\r
+ 4 : **...**...**...**\r\r
+\r\r
+ 5 : **.........**.........**\r\r
+\r\r
+ * : couleur d'avant plan\r\r
+ . : couleur de fond\r\r
+\r\r
+ 3.15 : Commandes de saisie et d'affichage de caract\8ares\r\r
+ ------------------------------------------------\r\r
+\r\r
+ 3.15.1 : Fonction INKEY\r\r
+ --------------\r\r
+\r\r
+ ascii:=INKEY;\r\r
+ VAR ascii : INTEGER;\r\r
+\r\r
+ Retourne le code ascii de la touche tap\82e au clavier ou la\r\r
+ valeur 0 sinon. L'appui sur les touches sp\82ciales (comme SHIFT,\r\r
+ les touche F1,F2,...,CONTROL,...) renvoient des valeurs\r\r
+ n\82gatives. Vous verrez bien par vous-m\88me quelles sont ces\r\r
+ valeurs en faisant un petit programme test.\r\r
+\r\r
+ 3.15.2 : Proc\82dure HASCII\r\r
+ ----------------\r\r
+\r\r
+ CALL HASCII(code);\r\r
+ VAR code : INTEGER;\r\r
+\r\r
+ Affiche le caract\8are de code ascii code avec le coin en haut\r\r
+ \85 gauche du caract\8are \85 la position courante (posx,posy) dans la\r\r
+ fen\88tre. La position courante devient (posx+largeur,posy).\r\r
+\r\r
+ Si code=0, une partie rectangulaire de largeurXhauteur est\r\r
+ affich\82e avec la couleur de fond de la fen\88tre courante et\r\r
+ position courante dans la fen\88tre reste inchang\82e.\r\r
+\r\r
+ En g\82n\82ral la fonte par d\82faut qui est utilis\82e sous\r\r
+ XWindows a une hauteur de dix points et une largeur de six points.\r\r
+\r\r
+ 3.15.3 : Proc\82dure OUTSTRING\r\r
+ -------------------\r\r
+\r\r
+ CALL OUTSTRING(tab);\r\r
+ VAR tab : ARRAYOF CHAR;\r\r
+\r\r
+ Affiche la chaine de caract\8are tab \85 la position courante\r\r
+ (posx,posy) de la fen\88tre. La position courante devient\r\r
+ (posx+largeur*longueur_chaine,posy) o\97 largeur est la largeur\r\r
+ de la fonte utilis\82e.\r\r
+\r\r
+ 3.16 : Proc\82dure PUSHXY\r\r
+ ----------------\r\r
+\r\r
+ CALL PUSHXY;\r\r
+\r\r
+ Sauvegarde le contexte graphique dans une pile, c'est \85 dire la\r\r
+ position courante dans la fen\88tre,les couleurs de fond et d'avant plan\r\r
+ et le style de trac\82 s\82lectionn\82 pour cette fen\88tre.\r\r
+\r\r
+ Chaque Fen\88tre est dot\82e de sa pile de sauvegarde qui lui est propre\r\r
+ et chaque pile a une profondeur maximale de 16.\r\r
+\r\r
+ 3.17 : Proc\82dure POPXY\r\r
+ ---------------\r\r
+\r\r
+ CALL POPXY;\r\r
+\r\r
+ Restore dans la fen\88tre courante le contexte graphique situ\82 en haut\r\r
+ de la pile de sauvegarde et ce contexte est enlev\82 de la pile.\r\r
+\r\r
+\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+|----------------------------------------------------------------------------|\r\r
+\r\r
+\r\r
+ 4 : Description des commandes de gestion de la souris\r\r
+ -------------------------------------------------\r\r
+\r\r
+ 4.1 : Proc\82dure STATUS\r\r
+ ----------------\r\r
+\r\r
+ CALL STATUS(h,v,l,r,c);\r\r
+ VAR h,v : INTEGER;\r\r
+ VAR l,r,c : BOOLEAN;\r\r
+\r\r
+ Cette proc\82dure renvoie la position courante (h,v) du pointeur de la\r\r
+ souris ainsi que l'\82tat des boutons de la souris.\r\r
+ l,r,c sont respectivement les boutons gauche, droit et du centre de la\r\r
+ souris.\r\r
+\r\r
+ Ces valeurs bool\82ennes ont la valeur TRUE si le bouton correspondant\r\r
+ est appuy\82.\r\r
+\r\r
+ 4.2 : Proc\82dure GETPRESS\r\r
+ ------------------\r\r
+\r\r
+ CALL GETPRESS(b,h,v,p,l,r,c);\r\r
+ VAR b,h,v,p : INTEGER;\r\r
+ VAR l,r,c : BOOLEAN;\r\r
+\r\r
+ Cette proc\82dure renvoie le nombre de fois o\97 le bouton s\82lectionn\82 a\r\r
+ \82t\82 appuy\82 depuis le dernier appel \85 cette commande, ainsi que la\r\r
+ position (h,v) du curseur la derni\8are fois que le bouton consid\82r\82 a\r\r
+ \82t\82 appuy\82.\r\r
+\r\r
+ Le param\88tre b permet de s\82lectionner le bouton \85 tester :\r\r
+ - 0 : bouton gauche\r\r
+ - 1 : bouton droit\r\r
+ - 2 : bouton du milieu\r\r
+\r\r
+ En sus, la proc\82dure renvoie l'\82tat courant des trois boutons l,r,c.\r\r
+\r\r
+ 4.3 : Proc\82dure GETRELEASE\r\r
+ --------------------\r\r
+\r\r
+ CALL GETRELEASE(b,h,v,p,l,r,c);\r\r
+ VAR b,h,v,p : INTEGER;\r\r
+ VAR l,r,c : BOOLEAN;\r\r
+\r\r
+ Cette proc\82dure a la m\88me fonction que GETPRESS \85 la diff\82rence\r\r
+ qu'elle teste le nombre de rel\83chements du bouton s\82lectionn\82 et non\r\r
+ l'appui.\r\r
+\r\r
+ 4.4 : Proc\82dure GETMOVEMENT\r\r
+ ---------------------\r\r
+\r\r
+ CALL GETMOVEMENT(h,v);\r\r
+ VAR h,v : INTEGER;\r\r
+\r\r
+ Cette proc\82dure renvoie le mouvement relatif (h,v) du curseur de la\r\r
+ souris depuis son dernier appel.\r\r
+\r\r
+\r\r
+ Zatsolfolcs...\r\r
+\1a
\ No newline at end of file
--- /dev/null
+(***************************************************************)\r
+ unit Bold : procedure;\r
+ begin\r
+ write( chr(27), "[1m")\r
+ end Bold;\r
+ \r
+ unit Blink : procedure;\r
+ begin\r
+ write( chr(27), "[5m")\r
+ end Blink;\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+ \r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ unit Underscore : procedure;\r
+ begin\r
+ write( chr(27), "[4m")\r
+ end Underscore;\r
+ \r
+ \r
+ \r
+ unit inchar : IIuwgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
--- /dev/null
+PROGRAM BACKTRACKING ;\r
+\r
+(*************************************************************************)\r
+(* Programme : BACKTRAC.LOG *)\r
+(* Date : 04/03/93 *)\r
+(* Auteur : SIMON Philippe LICENCE INFORMATIQUE 1992/93 *)\r
+(* *)\r
+(* Ce programme permet d'effectuer des op\82rations de retour arri\8are *)\r
+(* de fa\87on intelligente. Pour cela 2 exemples de BACKTRACKING ont \82t\82 *)\r
+(* choisi. La Gestion du Planning d'une Semaine et le Probl\8ame des Pions *)\r
+(* Noirs et Blancs. Le choix de ces 2 exemples ce faisant par un MENU *)\r
+(* principal. *)\r
+(*************************************************************************)\r
+\r
+\r
+\r
+ VAR choix,touche : integer,\r
+ r : SEM,\r
+ pi :pion;\r
+\r
+(*************************************************************************)\r
+(* METHODES USUELLES *)\r
+(* *)\r
+(* Cette partie contient des m\82thodes usuelles de travail (BIBLIOTHEQUE) *)\r
+(*************************************************************************)\r
+\r
+\r
+ UNIT eff : PROCEDURE ;\r
+ (* envoie un ordre d'\82ffacer l'\82cran *)\r
+ var i : integer ;\r
+ BEGIN\r
+ WRITE( chr(27), "[2J");\r
+ END ;\r
+\r
+\r
+ UNIT GetCar : IIuwgraph FUNCTION : INTEGER;\r
+ (* attend que l'utilisateur tape une touche et renvoie le code ASCII *)\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ i := 0;\r
+ WHILE i=0\r
+ DO\r
+ i := INKEY;\r
+ Result := i;\r
+ OD;\r
+ END GetCar;\r
+\r
+\r
+ UNIT attendre : PROCEDURE(t : integer);\r
+ (* Procedure permettant d'attendre pendant 't' seconde(s) *)\r
+\r
+ VAR j : integer;\r
+\r
+ BEGIN\r
+ j := TIME;\r
+ while (ABS(j - TIME) < t) do od;\r
+ END;\r
+\r
+\r
+ (*--------------------------------------------------------------*)\r
+ (* PROCEDURE li\82es la gestion du MENU Principal *)\r
+ (*--------------------------------------------------------------*)\r
+\r
+ UNIT menu : PROCEDURE ;\r
+ (* Appelle les m\82thodes correspondantes au choix de l'utilisateur *)\r
+\r
+ VAR boucle : BOOLEAN;\r
+\r
+ BEGIN\r
+ boucle := TRUE;\r
+ WHILE (boucle)\r
+ DO\r
+ CALL eff;\r
+ WRITELN;\r
+ WRITELN (" ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿");\r
+ WRITELN (" ³ M E N U ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ 'BACKTRACKING INTELLIGENT' ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ 0.......... QUITTER ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ 1 ..... Gestion du planning de la ³");\r
+ WRITELN (" ³ semaine. ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ 2 ..... Probl\8ame des pions noirs ³");\r
+ WRITELN (" ³ et blancs. ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ³ ³");\r
+ WRITELN (" ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ");\r
+ WRITELN;WRITELN;\r
+ WRITE (" Entrez votre choix : ");\r
+ READLN (choix);\r
+\r
+ CASE choix\r
+ WHEN 0 : boucle := FALSE;\r
+\r
+ WHEN 1 : CALL eff;\r
+ r := NEW SEM;\r
+\r
+ WHEN 2 : CALL eff;\r
+ pi := NEW pion;\r
+ ESAC;\r
+ choix := 0;\r
+ OD;\r
+ END menu;\r
+\r
+(***************************************************************************)\r
+(* LA PARTIE GESTION DU PLANNING DE LA SEMAINE *)\r
+(* *)\r
+(* il s'agit ici de la DECLARATION de l'objet SEM *)\r
+(* (utilise la biblioth\8aque Graphique IIugraph) *)\r
+(***************************************************************************)\r
+\r
+\r
+ UNIT SEM : IIuwgraph CLASS;\r
+\r
+ VAR i,cpt,ex,pl,et,arg,retour,val,N,N2,M : integer,\r
+ exercice,plaisir,argent,etude,interv,interv2,interv3 : integer,\r
+ MA,ME,JE,res : ARRAYOF integer,\r
+ L1,L2,V1,V2 : ARRAYOF ARRAYOF integer,\r
+ solution_possible : boolean;\r
+\r
+ UNIT recurs : PROCEDURE(i : integer, res : ARRAYOF integer);\r
+ (* recurs est la proc\82dure principale, appel\82e de fa\87on recursive *)\r
+ (* afin de cr\82er l'arboresence de tous les cas possibles d'une *)\r
+ (* Gestion de Semaine. A l'interieur de cette proc\82dure nous avons *)\r
+ (* 6 autres sous_proc\82dures li\82es aux 6 premiers jours de la *)\r
+ (* semaine (LUNDI MARDI MERCREDI JEUDI VENDREDI). Chacune de ces *)\r
+ (* proc\82dures est propre \85 un test, \85 des affectation et \85 des *)\r
+ (* retours arri\8ares particuliers. *)\r
+ (* Chaque solution trouv\82e est rang\82e dans le tableau 'res'. *)\r
+\r
+\r
+\r
+ VAR j,w : integer;\r
+\r
+\r
+ UNIT lundi : PROCEDURE;\r
+ (* La proc\82dure lundi correspond en quelque sorte \85 la racine *)\r
+ (* de l'arbre de gestion de la semaine. Les affectations *)\r
+ (* touchent ici les exercices, le plaisir, et l'argent. De plus *)\r
+ (* on g\8are, grace \85 la variable retour, les retours arri\8ares *)\r
+ (* afin de calculer les branches de l'arbre \85 \82laguer. *)\r
+\r
+\r
+ BEGIN\r
+ FOR w := 1 TO N\r
+ DO\r
+ FOR j := 1 TO M\r
+ DO\r
+ (* on initialise les variables de travail li\82es\r
+ aux exercices, aux plaisirs, et \85 l'argent *)\r
+ ex := 0; pl := 0; arg := 0; et := 0;\r
+ res(i) := L1(2,w);\r
+ res(i+1) := L2(2,j);\r
+ res(i+2) := L1(1,w) + L2(1,j);\r
+ (* On incr\82mente les variables de travail *)\r
+ ex := ex + res(i);\r
+ pl := pl + res(i+1);\r
+ arg := arg + res(i+2);\r
+\r
+ (* appel de la procedure recurs correspondant au mardi *)\r
+ CALL recurs(i+1,res);\r
+\r
+ (* On decrement les variable de travail *)\r
+ ex := ex - res(i);\r
+ pl := pl - res(i+1);\r
+ arg := arg - res(i+2);\r
+\r
+ (* retour = 4 ou 5 correspond au vendredi *)\r
+ IF retour = 4 THEN w := (exercice - val)/interv2;\r
+ j := M;\r
+ FI;\r
+ IF retour = 5 THEN j := (plaisir - val);\r
+ FI;\r
+ retour := 0;\r
+\r
+ OD;\r
+ OD;\r
+ solution_possible := FALSE;\r
+ END lundi;\r
+\r
+ UNIT mardi : PROCEDURE;\r
+ (* La proc\82dure mardi correspond \85 la seconde tranche de l'arbre*)\r
+ (* de gestion de la semaine. Les affectations touchent ici les *)\r
+ (* \82tudes. *)\r
+ (* On g\8are, grace \85 la variable retour, les retours arri\8ares du *)\r
+ (* mercredi afin de calculer les branches de l'arbre \85 \82laguer. *)\r
+\r
+ BEGIN\r
+ FOR w := 1 TO N\r
+ DO\r
+ res(i+2) := MA(w);\r
+ et := 0;\r
+ IF retour = 0 THEN\r
+ (* On incremente les variable de travail *)\r
+ et := et + res(i+2);\r
+\r
+ (* appel de la procedure recurs correspondant au mercredi *)\r
+ CALL recurs(i+1,res);\r
+\r
+ (* On decremente les variable de travail *)\r
+ et := et - res(i+2);\r
+ FI;\r
+ (* retour = 2 correspond au mercredi *)\r
+ IF retour = 2 THEN w := (etude - val)/interv;\r
+ IF w >= N THEN retour := 1;\r
+ ELSE retour := 0;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ solution_possible := FALSE;\r
+ END mardi;\r
+\r
+\r
+\r
+ UNIT mercredi : PROCEDURE;\r
+ (* La proc\82dure mercredi correspond \85 la troisi\8ame tranche de *)\r
+ (* l'arbre de gestion de la semaine. Les affectations touchent *)\r
+ (* ici les \82tudes. *)\r
+ (* On g\8are, grace \85 la variable retour, les retours arri\8ares du *)\r
+ (* jeudi afin de calculer les branches de l'arbre \85 \82laguer. *)\r
+\r
+ BEGIN\r
+ FOR w := 1 TO N\r
+ DO\r
+ res(i+2) := ME(w);\r
+ IF retour = 0 THEN\r
+ (* On incremente les variable de travail *)\r
+ et := et + res(i+2);\r
+\r
+ (* appel de la procedure recurs correspondant au jeudi *)\r
+ CALL recurs(i+1,res);\r
+\r
+ (* On decremente les variable de travail *)\r
+ et := et - res(i+2);\r
+ FI;\r
+ (* retour = 3 correspond au jeudi *)\r
+ IF retour = 3 THEN w := (etude - val)/interv;\r
+ IF w >= N THEN retour := 2;\r
+ val := val + ME(N);\r
+ ELSE retour := 0;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ solution_possible := FALSE;\r
+ END mercredi;\r
+\r
+\r
+ UNIT jeudi : PROCEDURE;\r
+ (* La proc\82dure jeudi correspond \85 la quartri\8ame tranche de *)\r
+ (* l'arbre de gestion de la semaine. Les affectations touchent *)\r
+ (* ici les \82tudes. *)\r
+ (* On g\8are, grace \85 la variable retour, les retours arri\8ares du *)\r
+ (* jeudi au mercredi afin de calculer les branches de l'arbre \85 *)\r
+ (* \82laguer. *)\r
+\r
+ BEGIN\r
+ FOR w := 1 TO N\r
+ DO\r
+ res(i+2) := JE(w);\r
+ IF retour = 0 THEN\r
+ (* On incremente les variable de travail *)\r
+ et := et + res(i+2);\r
+ IF et < etude THEN\r
+ (* si aucun cas n'est trouv\82 on indique un\r
+ retour arri\8are et on calcul grace \85 la\r
+ variable val et a l'indice de boucle w\r
+ les branches \85 \82laguer. *)\r
+\r
+ IF w = N THEN retour := 3;\r
+ val := et;\r
+ ELSE w := (etude - et)/interv;\r
+ IF w>=N THEN w := N - 1 FI;\r
+ FI;\r
+ ELSE\r
+ (* appel de la procedure recurs correspondant\r
+ au vendredi *)\r
+ CALL recurs(i+1,res);\r
+ FI;\r
+ (* On decremente les variable de travail *)\r
+ et := et - res(i+2);\r
+ FI;\r
+ OD;\r
+ solution_possible := FALSE;\r
+ END jeudi;\r
+\r
+\r
+ UNIT vendredi : PROCEDURE;\r
+ (* La proc\82dure vendredi correspond \85 la cinqui\8ame tranche de *)\r
+ (* l'arbre de gestion de la semaine. Les affectations touchent *)\r
+ (* ici les exercices, le plaisir, et l'argent. *)\r
+ (* On g\8are, grace \85 la variable retour, les retours arri\8ares du *)\r
+ (* lundi afin de calculer les branches de l'arbre \85 \82laguer. *)\r
+\r
+ BEGIN\r
+ FOR w := 1 TO N\r
+ DO\r
+ FOR j := 1 TO M\r
+ DO\r
+ res(i+2) := V1(2,w);\r
+ res(i+3) := V2(2,j);\r
+ res(i+4) := V1(1,w) + V2(1,j);\r
+ (* On incremente les variable de travail *)\r
+ ex := ex + res(i+2);\r
+ pl := pl + res(i+3);\r
+ arg := arg + res(i+4);\r
+ IF arg > argent THEN j := M;\r
+ ELSE\r
+ IF ex < exercice THEN\r
+ (* si aucun cas n'est trouv\82 on indique un\r
+ retour arri\8are et on calcul grace \85 la\r
+ variable val et \85 l'indice de boucle w\r
+ les branches \85 \82laguer. *)\r
+\r
+ IF w = N THEN retour := 4;\r
+ val := ex;\r
+ exit;\r
+ ELSE w := ((exercice - ex)/interv2);\r
+ IF w >= N THEN w := N-1 FI;\r
+ j := M;\r
+ FI\r
+ ELSE\r
+ IF pl < plaisir THEN\r
+ (* si aucun cas n'est trouv\82 on indique un\r
+ retour arri\8are et on calcul grace \85 la\r
+ variable val et a l'indice de boucle j\r
+ les branches \85 \82laguer. *)\r
+\r
+ IF j = M THEN retour := 5;\r
+ val := pl;\r
+ ELSE j := (plaisir - pl)/interv3;\r
+ FI;\r
+ (* appel de la procedure recurs correspondant\r
+ \85 une solution trouv\82e *)\r
+ ELSE CALL recurs(i+1,res);\r
+ FI\r
+ FI\r
+ FI;\r
+ (* On decremente les variable de travail *)\r
+ ex := ex - res(i+2);\r
+ pl := pl - res(i+3);\r
+ arg := arg - res(i+4);\r
+ OD;\r
+ OD;\r
+ solution_possible := FALSE;\r
+ END vendredi;\r
+\r
+\r
+\r
+ BEGIN\r
+\r
+ retour := 0;\r
+ solution_possible := TRUE;\r
+\r
+ CASE i\r
+\r
+ WHEN 1 : CALL lundi;\r
+\r
+ WHEN 2 : CALL mardi;\r
+\r
+ WHEN 3 : CALL mercredi;\r
+\r
+ WHEN 4 : CALL jeudi;\r
+\r
+ WHEN 5 : CALL vendredi;\r
+\r
+ ESAC;\r
+\r
+ (* si une solution est trouv\82e on l'imprime \85 l'\82cran *)\r
+ IF solution_possible THEN CALL imprim(res) FI;\r
+\r
+ END recurs;\r
+\r
+\r
+ (*------------------------------------------------------------------*)\r
+ (* PROCEDURE li\82es la gestion du MENU de la Gestion de la Semaine *)\r
+ (*------------------------------------------------------------------*)\r
+\r
+ UNIT menu_ps : PROCEDURE;\r
+ VAR i : integer;\r
+\r
+ BEGIN\r
+ WRITELN(" ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ WRITELN(" ³ PLANNING DE LA SEMAINE AVEC CONTRAINTES ³ ");\r
+ WRITELN(" ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ");\r
+ WRITELN(" Chaque jour implique un choix particulier :");\r
+ WRITELN;\r
+ WRITELN(" * LUNDI :");\r
+ FOR i := 1 TO N DO\r
+ WRITE(" $",L1(1,i):2," Exercice ",L1(2,i):2);\r
+ IF i > M THEN WRITELN;\r
+ ELSE WRITELN(" $",L2(1,i):2," Plaisir ",L2(2,i));\r
+ FI;\r
+ OD;\r
+ WRITELN;\r
+ WRITELN(" * MARDI MERCREDI JEUDI :");\r
+ FOR i := 1 TO N DO\r
+ WRITELN(" Etude ",MA(i):2," ",ME(i):2," ",JE(i));\r
+ OD;\r
+ WRITELN;\r
+ WRITELN(" * VENDREDI :");\r
+ FOR i := 1 TO N DO\r
+ WRITE(" $",V1(1,i):2," Exercice ",V1(2,i):2);\r
+ IF i > M THEN WRITELN;\r
+ ELSE WRITELN(" $",V2(1,i):2," Plaisir ",V2(2,i));\r
+ FI;\r
+ OD;\r
+ WRITELN;\r
+ WRITE(" CONTRAINTES : ");\r
+ WRITE(" Exercice >= ",exercice:2," Argent ($) =< ",argent:2);\r
+ WRITELN(" Etude >= ",etude:2," Plaisir >= ",plaisir:2);\r
+ touche := Getcar;\r
+ END;\r
+\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+ (* PROCEDURES li\82es la gestion de l'AFFICHAGE \85 l'\82cran des resultats *)\r
+ (*---------------------------------------------------------------------*)\r
+\r
+\r
+ UNIT imprim : PROCEDURE(res : ARRAYOF integer);\r
+ (* La proc\82dure imprim permet d'afficher toutes les solutions *)\r
+ (* possibles (les unes a la suite des autres) pages par pages \85 *)\r
+ (* l'\82cran, sous forme de tableau de resultat. *)\r
+\r
+ VAR j : integer;\r
+\r
+ BEGIN\r
+ IF cpt = 0 THEN CALL eff;\r
+ (* affichage de l'entete \85 l'\82cran *)\r
+ CALL entete;\r
+ FI;\r
+ WRITE ("³",res(1):4,"³",res(2):4,"³",res(3):4);\r
+ WRITE ("³",res(4):6," ³",res(5):6," ³",res(6):6);\r
+ WRITE (" ³",res(7):4,"³",res(8):4,"³",res(9):4);\r
+ WRITE ("º",ex:4,"³",pl:4,"³",arg:4,"³",et:4,"³");\r
+ WRITELN;\r
+ cpt := cpt + 1;\r
+ IF cpt = 16 THEN WRITELN ("Appuyez sur une touche pour continuer...");\r
+ touche := Getcar;\r
+ cpt := 0;\r
+ FI;\r
+\r
+ END imprim;\r
+\r
+\r
+ UNIT entete : PROCEDURE;\r
+ (* Affiche l'entete du tableau de resultat \85 l'\82cran. *)\r
+ BEGIN\r
+ WRITELN("CONTRAINTES : ");\r
+ WRITE("Exercice >= ",exercice:2," Argent ($) =< ",argent:2);\r
+ WRITELN(" Etude >= ",etude:2," Plaisir >= ",plaisir:2);\r
+ WRITE("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÂÄÄÄÄÄ");\r
+ WRITELN("ÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄËÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿");\r
+ WRITE("³ LUNDI ³ MARDI ³MERCREDI³ JEUD");\r
+ WRITELN("I ³ VENDREDI º TOTAL ³");\r
+ WRITE("ÃÄÄÄÄÂÄÄÄÄÂÄÄÄÄÅÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÅÄÄÄÄÄ");\r
+ WRITELN("ÄÄÄÅÄÄÄÄÂÄÄÄÄÂÄÄÄÄÎÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄ´");\r
+ WRITE("³Exer³Plai³ $ ³ Etude ³ Etude ³ Etud");\r
+ WRITELN("e ³Exer³Plai³ $ ºExer³Plai³ $ ³Etud³");\r
+ WRITE("ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÅÄÄÄÄÄ");\r
+ WRITELN("ÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÎÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+ END entete;\r
+\r
+\r
+ UNIT fin : PROCEDURE;\r
+ (* Affiche la fin du tableau de resultat \85 l'\82cran. *)\r
+\r
+ BEGIN\r
+ WRITE("ÀÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÁÄÄÄÄÄ");\r
+ WRITELN("ÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÙ");\r
+ WRITELN ("Appuyez sur une touche pour continuer...");\r
+ touche := Getcar;\r
+ END fin;\r
+\r
+\r
+ BEGIN\r
+ PREF IIUWGraph block;\r
+ BEGIN\r
+ (* Initialisation des tableaux et des variables de JEUX D'ESSAI *)\r
+\r
+ N := 4;\r
+ M := 3;\r
+ N2 := 2;\r
+ (* D\82claration d'intervalles *)\r
+ interv := 2;\r
+ interv2 := 5;\r
+ interv3 := 1;\r
+ ARRAY res DIM (1:9);\r
+ ARRAY L1 DIM (1:N2);\r
+ FOR i := 1 TO N2\r
+ DO\r
+ ARRAY L1(i) DIM (1:N);\r
+ OD;\r
+ ARRAY L2 DIM (1:N2);\r
+ FOR i := 1 TO N2\r
+ DO\r
+ ARRAY L2(i) DIM (1:M);\r
+ OD;\r
+ ARRAY MA DIM (1:N);\r
+ ARRAY ME DIM (1:N);\r
+ ARRAY JE DIM (1:N);\r
+ ARRAY V1 DIM (1:N2);\r
+ FOR i := 1 TO N2\r
+ DO\r
+ ARRAY V1(i) DIM (1:N);\r
+ OD;\r
+ ARRAY V2 DIM (1:N2);\r
+ FOR i := 1 TO N2\r
+ DO\r
+ ARRAY V2(i) DIM (1:M);\r
+ OD;\r
+\r
+ (* Initialisation des tableaux jeux d'essai du mardi,mercredi et\r
+ jeudi concernant les \82tudes. *)\r
+\r
+ FOR i := 1 TO N\r
+ DO\r
+ MA(i),ME(i),JE(i) := (i-1) * interv;\r
+ OD;\r
+\r
+ (* Initialisation des tableaux jeux d'essai du lundi et vendredi\r
+ concernant l'argent. *)\r
+\r
+ L1(1,1),V1(1,1) := 0;\r
+ L1(1,2),V1(1,2) := 0;\r
+ L1(1,3),V1(1,3) := 0;\r
+ L1(1,4),V1(1,4) := 20;\r
+\r
+ (* Initialisation des tableaux jeux d'essai du lundi et vendredi\r
+ concernant les exercices. *)\r
+\r
+ FOR i := 1 TO N\r
+ DO\r
+ L1(2,i),V1(2,i) := (i-1) * interv2;\r
+ OD;\r
+\r
+ (* Initialisation des tableaux jeux d'essai du lundi et vendredi\r
+ concernant les plaisirs ou divertissements. *)\r
+\r
+ L2(1,1),V2(1,1) := 0;\r
+ L2(1,2),V2(1,2) := 0;\r
+ L2(1,3),V2(1,3) := 20;\r
+\r
+ FOR i := 1 TO M\r
+ DO\r
+ L2(2,i),V2(2,i) := (i-1) * interv3;\r
+ OD;\r
+\r
+ (* Les contraintes d'une semaine \82quilibr\82e sont les suivantes : *)\r
+\r
+ argent := 30;\r
+ etude := 14;\r
+ exercice := 20;\r
+ plaisir := 2;\r
+\r
+ cpt := 0;\r
+ CALL GRON(1);\r
+ CALL menu_ps;\r
+ CALL recurs(1,res);\r
+ CALL fin;\r
+ CALL GROFF;\r
+ END;\r
+ END SEM;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* LA PARTIE GESTION DU JEU DES PIONS NOIRS ET BLANCS *)\r
+(* *)\r
+(* il s'agit ici de la DECLARATION de l'objet PION *)\r
+(* (utilise la biblioth\8aque Graphique IIugraph) *)\r
+(***************************************************************************)\r
+\r
+\r
+ UNIT PION : IIuwgraph CLASS;\r
+\r
+ VAR n,i,M : integer,\r
+ tab : ARRAYOF char,\r
+ trouve,manuel: boolean;\r
+\r
+\r
+ UNIT procent : PROCEDURE(A,B : char, P,NN : integer);\r
+ (* La procedure procent permet de parcourir l'arbre des solutions *)\r
+ (* en anticipant le meilleur des chemins c'est a dire en parcourant*)\r
+ (* le moins de chemin possible. *)\r
+ (* Les param\8atres d'entr\82s A et B prennent soit la valeur Noir et *)\r
+ (* Blanc ou Blanc et Noir. Idem pour les 2 entier P et NN qui *)\r
+ (* prennent en fonction de la couleur des pions soit la valeur 1 et*)\r
+ (* M (2*n+1) ou -1 et 1. (P indique le sens de deplacement). *)\r
+\r
+ VAR bo : boolean,\r
+ j, k : integer;\r
+\r
+ UNIT proc : PROCEDURE(X : char);\r
+ (* La proc\82dure proc permet de connaitre si l'on se trouve dans *)\r
+ (* position de blocage ou bien si l'on peut continuer dans ce *)\r
+ (* chemin. (Cas o\97 l'on place un pion \85 cot\82 d'un autre pion de *)\r
+ (* m\88me couleur). *)\r
+\r
+ BEGIN\r
+ bo := TRUE;\r
+ k := 2;\r
+ j := i + 2*P;\r
+ IF (j >= 1) AND (j <= M) THEN\r
+ WHILE ((bo) AND (j <> NN+P))\r
+ DO\r
+ (* On test si tous les pions suivants sont\r
+ de m\88me couleur. Si oui alors on poursuit\r
+ le chemin dans l'arbre, sinon on se trouve\r
+ bloqu\82. *)\r
+\r
+ IF tab(j) <> X THEN bo := FALSE;\r
+ ELSE k := k + 1;\r
+ FI;\r
+ j := j + P;\r
+ OD;\r
+ FI;\r
+ END proc;\r
+\r
+\r
+ UNIT affect2 : PROCEDURE;\r
+ (* La proc\82dure affect2 permet de d\82placer un pion en sautant *)\r
+ (* par dessus un pion de couleur adverse. *)\r
+ (* Le sens du d\82placement \82tant indiquer par l'entier P. *)\r
+\r
+ BEGIN\r
+ tab(i) := tab(i-2*P);\r
+ tab(i-2*P) := ' ';\r
+ i := i - 2*P;\r
+ (* appel de la proc\82dure principale tentative *)\r
+ CALL tentative;\r
+ i := i + 2*P;\r
+ tab(i-2*P) := tab(i);\r
+ tab(i) := ' ';\r
+ END affect2;\r
+\r
+\r
+\r
+ UNIT affect1 : PROCEDURE;\r
+ (* La procedure affect1 permet de d\82placer un pion d'une *)\r
+ (* case en avant (pion avance dans la case vide). *)\r
+ (* Le sens du d\82placement \82tant indiquer par l'entier P. *)\r
+\r
+ BEGIN\r
+ tab(i) := tab(i-P);\r
+ tab(i-P) := ' ';\r
+ i := i - P;\r
+ (* appel de la proc\82dure principale tentative *)\r
+ CALL tentative;\r
+ i := i + P;\r
+ tab(i-P) := tab(i);\r
+ tab(i) := ' ';\r
+ END affect1;\r
+\r
+\r
+\r
+ BEGIN\r
+ (* On test si l'on se trouve en bordures du jeux (du tableau)\r
+ C'est a dire que l'on verifie que les indices de tables\r
+ sont toujours valide pour continuer les tests suivants. *)\r
+ IF ((i-P) > 0) AND ((i-P) <= M) THEN\r
+\r
+ (* On test si l'on peut avancer le pion dans la case vide en\r
+ fonction de P (indique le sens du d\82placement). *)\r
+ IF tab(i-P) = A THEN\r
+\r
+ (* On test si l'on se trouve en bordures du jeux, en\r
+ fonction du sens du d\82pacement. *)\r
+ IF ((i+P) > 0) AND ((i+P) <= M) THEN\r
+\r
+ (* On test si le pion situ\82 apr\8as la case vide est de\r
+ m\88me couleur que celui plac\82 avant. *)\r
+ IF tab(i+P) = A THEN\r
+ (* Si oui on appele la proc\82dure proc *)\r
+ CALL proc(A);\r
+ (* On test si l'on poursuit le chemin *)\r
+ IF bo THEN\r
+ CALL affect1;\r
+ (* On test si l'on se trouve dans\r
+ l'\82tat final du jeux. (k=n) *)\r
+ IF k = n THEN trouve := FALSE FI;\r
+ IF trouve THEN CALL aff_retour_ar FI;\r
+ FI;\r
+ ELSE\r
+ (* Sinon on appele la proc\82dure d'affectation\r
+ affect1, et on poursuit le chemin. *)\r
+ CALL affect1;\r
+ IF trouve THEN CALL aff_retour_ar FI;\r
+ FI;\r
+ ELSE\r
+ (* Sinon on appele la proc\82dure d'affectation affect1 *)\r
+ CALL affect1;\r
+ IF trouve THEN CALL aff_retour_ar FI;\r
+ FI;\r
+ ELSE\r
+\r
+ (* On test si l'on se trouve en bordures du jeux (du tableau)\r
+ C'est a dire que l'on verifie que les indices de tables\r
+ sont toujours valide pour continuer les tests suivants. *)\r
+ IF ((i-2*P) > 0) AND ((i-2*P) <= M) THEN\r
+\r
+ (* On test si l'on peut avancer le pion plac\82 2 cases\r
+ avant la case vide en sautant un pion de couleur\r
+ adverse plac\82 une case avant la case vide, toujours\r
+ en fonction du sens P. *)\r
+ IF (tab(i-2*P) = A) AND (tab(i-P) = B) THEN\r
+\r
+ (* On test si l'on se trouve en bordures du jeux, en\r
+ fonction du sens du d\82pacement. *)\r
+ IF ((i+P) > 0) AND ((i+P) <= M) THEN\r
+\r
+ (* On test si le pion situ\82 apr\8as la case vide\r
+ est de m\88me couleur que celui plac\82 2 cases\r
+ avant la case vide. *)\r
+ IF tab(i+P) = A THEN\r
+ (* Si oui on appele la proc\82dure proc *)\r
+ CALL proc(A);\r
+ (* On test si l'on poursuit le chemin *)\r
+ IF bo THEN\r
+ CALL affect2;\r
+ (* On test si l'on se trouve dans\r
+ l'\82tat final du jeux. (k=n) *)\r
+ IF k = n THEN trouve := FALSE; FI;\r
+ IF trouve THEN CALL aff_retour_ar FI;\r
+ FI;\r
+ ELSE\r
+ (* Sinon appel de la proc\82dure d'affectation\r
+ affect2, et on poursuit le chemin. *)\r
+ CALL affect2;\r
+ IF trouve THEN CALL aff_retour_ar FI;\r
+ FI;\r
+ ELSE\r
+ (* appel de la proc\82dure d'affectation affect2 *)\r
+ CALL affect2;\r
+ IF trouve THEN CALL aff_retour_ar FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ END procent;\r
+\r
+\r
+\r
+\r
+ UNIT tentative : PROCEDURE;\r
+ (* Cette proc\82dure permet de parcourir l'arbre du jeux des pions. *)\r
+ (* En faisant d'abord avancer les pions Noirs puis les pions Blancs*)\r
+ (* Tant que l'\82tat final n'est pas atteint on affiche l'\82volution *)\r
+ (* du d\82placement dans l'arbre. *)\r
+\r
+ BEGIN\r
+ IF trouve THEN\r
+ CALL cls;\r
+ (* On imprime le resultat a l'instant t *)\r
+ CALL imprim;\r
+ (* On d\82place les pions Noirs *)\r
+ CALL procent('N','B',1,M);\r
+ (* On d\82place les pions Blancs *)\r
+ CALL procent('B','N',-1,1);\r
+\r
+ FI;\r
+ END tentative;\r
+\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+ (* PROCEDURES li\82es la gestion de l'AFFICHAGE \85 l'\82cran des resultats *)\r
+ (*---------------------------------------------------------------------*)\r
+\r
+\r
+ UNIT aff_retour_ar : PROCEDURE;\r
+ (* Proc\82dure permettant d'indiquer \85 l'\82cran que l'on effectue *)\r
+ (* un retour arri\8are (BACKTRACKING). *)\r
+\r
+ BEGIN\r
+ CALL CLS;\r
+ CALL move(150,220); CALL draw(360,220);\r
+ CALL move(150,260); CALL draw(360,260);\r
+ CALL move(150,220); CALL draw(150,260);\r
+ CALL move(360,220); CALL draw(360,260);\r
+ CALL move(180,237);\r
+ CALL outstring("RETOUR ARRIERE ...");\r
+ CALL imprim;\r
+ END;\r
+\r
+\r
+\r
+\r
+ UNIT imprim : PROCEDURE;\r
+ (* Proc\82dure permettant d'afficher de mani\8are graphique les *)\r
+ (* pions Noirs et Blancs dans un tableaux proportionnel au *)\r
+ (* nombre de pions. *)\r
+ (* Les proc\82dures graphiques utilis\82es : outstring, move, draw *)\r
+ (* cirb. *)\r
+\r
+ VAR l,col,xi,touche : integer;\r
+\r
+ BEGIN\r
+ CALL move(100,10);\r
+ CALL outstring("LE PROBLEME DES PIONS NOIRS ET BLANCS");\r
+\r
+ (* Affichage du tableau de jeux *)\r
+ CALL move(70,80); CALL draw(70+60*(2*n+1),80);\r
+ CALL move(70,120); CALL draw(70+60*(2*n+1),120);\r
+ FOR l := 0 TO ((n+1)*2-1) DO\r
+ CALL move(70+(60*l),80); CALL draw(70+(60*l),120);\r
+ OD;\r
+\r
+ (* Affichage des pions Noirs et Blancs *)\r
+ FOR l := 1 TO M\r
+ DO\r
+ xi := 100 + ((l-1) * 60);\r
+ IF tab(l) <> ' '\r
+ THEN IF tab(l) = 'B' THEN col := 15;\r
+ ELSE col := 0;\r
+ FI;\r
+ CALL cirb(xi,100,20,10,10,15,col,2,2);\r
+ FI;\r
+ OD;\r
+ IF manuel THEN\r
+ CALL move(50,300);\r
+ CALL outstring("Appuyez sur une touche pour continuer...");\r
+ touche := Getcar;\r
+ ELSE CALL attendre(2);\r
+ FI;\r
+ END imprim;\r
+\r
+\r
+ UNIT menu_p : PROCEDURE;\r
+ VAR choix : integer;\r
+\r
+ BEGIN\r
+ manuel := TRUE;\r
+ CALL eff;\r
+ WRITELN(" ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ WRITELN(" ³ PROBLEME DES PIONS NOIRS ET BLANCS ³ ");\r
+ WRITELN(" ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ");\r
+ WRITELN; WRITELN;\r
+ WRITELN (" A partir d'un etat initial qui est le suivant :");\r
+ WRITELN (" NNN*BBB");\r
+ WRITELN (" Il faut aboutir \85 un etat final qui est le suivant :");\r
+ WRITELN (" BBB*NNN");\r
+ WRITELN;\r
+ WRITELN (" Sachant que l'on \85 des r\8agles fix\82es :");\r
+ WRITELN (" ÄÄ> <ÄÄ");\r
+ WRITELN (" - Les sens sont fix\82s : NNN*BBB");\r
+ WRITELN (" - Un pion peut avancer dans une case vide '*' si :");\r
+ WRITELN (" * Elle est juste devant. ");\r
+ WRITELN (" * Il l'atteint en sautant par dessus un pion");\r
+ WRITELN (" de couleur adverse.");\r
+ WRITELN;\r
+ WRITELN (" D\82sirez vous un traitement :");\r
+ WRITELN;\r
+ WRITELN (" 1 ......... MANUEL");\r
+ WRITELN (" 2 ......... AUTOMATIQUE");\r
+ WRITELN;\r
+ WRITE (" Votre choix : ");\r
+ READLN (choix);\r
+ IF choix = 2 THEN manuel := FALSE FI;\r
+ CALL eff;\r
+ WRITELN; WRITELN; WRITELN; WRITELN;\r
+ n := 0;\r
+ WHILE ((n < 2) OR (n > 4))\r
+ DO\r
+ WRITE(" Donnez le Nombre de Pions (2,3 ou 4) : ");\r
+ READLN (n);\r
+ OD;\r
+ END;\r
+\r
+\r
+\r
+ BEGIN\r
+ (* On utilise pour repr\82senter de fa\87on graphique \85 l'\82cran les pions *)\r
+ (* Noirs et Blancs la Biblioth\82que graphique IIugraph. *)\r
+\r
+ PREF IIUWGraph block;\r
+ BEGIN\r
+ CALL GRON(1);\r
+ CALL menu_p;\r
+\r
+ (* initialisation \85 l'\82tat initial du tableau de jeux en fonction *)\r
+ (* du nombres de pions entr\82s pr\82alablement. ex: NNN BBB *)\r
+\r
+ ARRAY tab DIM (1:(n*2)+1);\r
+\r
+ FOR i := 1 TO n DO tab(i) := 'N' OD;\r
+ tab(n+1) := ' ';\r
+ FOR i := (n+2) TO (n*2)+1 DO tab(i) := 'B' OD;\r
+\r
+ i := n + 1;\r
+\r
+ (* La variable M repr\82sente l'indice maximum du tableau du jeux *)\r
+ (* en fonction du nombres de pions. ex: si n=3 ÄÄ> M=7 *)\r
+ M := 2*n + 1;\r
+\r
+ trouve := TRUE;\r
+ (* Appel de la proc\82dure principale 'tentative' de parcours\r
+ d'arbre. *)\r
+ CALL tentative;\r
+ CALL GROFF;\r
+ END;\r
+ END PION;\r
+\r
+\r
+\r
+(*******************************)\r
+(*** PROGRAMME PRICIPAL *****)\r
+(*******************************)\r
+\r
+BEGIN\r
+ (* Appel du menu principal *)\r
+ CALL menu;\r
+END BACTRACKING;\r
+\1a
\ No newline at end of file
--- /dev/null
+PROGRAM DERIVATION;\r
+\r
+(**********************************************************)\r
+(* permet de saisir caract\8are par caract\8are *)\r
+\r
+ UNIT readkey : IIUWgraph function : integer;\r
+ begin\r
+ do\r
+ result := inkey;\r
+ if result > 0 then exit fi\r
+ od\r
+ end readkey;\r
+\r
+ unit gotoxy : procedure(lig, col : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := lig div 10; j := lig mod 10;\r
+ c := chr(48+i); d := chr(48+j);\r
+ i := col div 10; j := col mod 10;\r
+ e := chr(48+i); f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end gotoxy;\r
+\r
+ Unit mesg : procedure (message1, message2 : string);\r
+ begin\r
+ call gotoxy(23,1);\r
+ write(message1);\r
+ call gotoxy(24,1);\r
+ write(message2);\r
+ return;\r
+ end mesg;\r
+\r
+ Unit charint : function (c : char) : integer;\r
+ begin\r
+ result := ord(c) - 48 ;\r
+ end charint;\r
+\r
+(**********************************************************)\r
+(* UNITE IMPLANTATION DES PILES POUR EMPILER LES OPERANDES *)\r
+\r
+ UNIT pile1 : class;\r
+ const max = 100;\r
+ var premier : integer,\r
+ stack : arrayof expr;\r
+\r
+ UNIT empiler : procedure (car : expr);\r
+ BEGIN\r
+ premier := premier + 1;\r
+ stack(premier) := car;\r
+ call display("stak = ",stack(premier));\r
+ END empiler;\r
+\r
+ UNIT empty : function : boolean;\r
+ BEGIN\r
+ result := premier = 0;\r
+ END EMPTY;\r
+\r
+ UNIT sommet : function: expr;\r
+ BEGIN\r
+ IF not empty then result := stack(premier);\r
+ (* else call error (raise pile-vide) *)\r
+ FI;\r
+ END sommet;\r
+\r
+ UNIT depiler : procedure;\r
+ BEGIN\r
+ IF not empty then premier := premier - 1;\r
+ writeln(premier);\r
+ FI;\r
+ END depiler;\r
+\r
+BEGIN\r
+ premier := 0;\r
+ array stack dim (1 : max);\r
+END pile1;\r
+\r
+(**********************************************************)\r
+(* UNITE IMPLANTATION DES PILES POUR LES OPERATEURS *)\r
+\r
+ UNIT pile2 : class;\r
+ const max = 100;\r
+ var premier : integer,\r
+ stack : arrayof char;\r
+ \r
+\r
+ UNIT empiler : procedure (car : char);\r
+ BEGIN\r
+ premier := premier + 1;\r
+ stack(premier) := car;\r
+ END empiler;\r
+\r
+ UNIT empty : function : boolean;\r
+ BEGIN\r
+ result := premier = 0;\r
+ END EMPTY;\r
+\r
+ UNIT sommet : function: char;\r
+ BEGIN\r
+ IF not empty then result := stack(premier);\r
+ (* else call error (raise pile-vide) *)\r
+ FI;\r
+ END sommet;\r
+\r
+ UNIT depiler : procedure;\r
+ BEGIN\r
+ IF not empty then premier := premier - 1;\r
+ writeln(premier);\r
+ FI;\r
+ END depiler;\r
+BEGIN\r
+ premier := 0;\r
+ array stack dim (1 : max);\r
+END pile2;\r
+\r
+ \r
+UNIT EXPR:CLASS; (* OUR FUNCTIONS WILL BE EXPRESSIONS *)\r
+ UNIT VIRTUAL DERIV:FUNCTION(X:VARIABLE):EXPR;\r
+ END DERIV;\r
+END EXPR;\r
+\r
+ UNIT VARIABLE:EXPR CLASS(ID:char);\r
+ (* DIFFERENTIATED EXPRESSION WILL OBVIOUSLY CONSIST OF VARIABLES*)\r
+ UNIT VIRTUAL DERIV:FUNCTION(X:VARIABLE):EXPR;\r
+ BEGIN\r
+ writeln("je suis dans variable");\r
+ IF X.ID=ID THEN\r
+ RESULT:=ONE\r
+ ELSE\r
+ RESULT:=ZERO\r
+ (*THIS IS THE DERIVATIVE OF A VARIABLE\r
+ OTHER THEN X WITH RESPECT TO X *)\r
+ FI\r
+ END DERIV;\r
+ END VARIABLE;\r
+\r
+ (* DIFFERENTIATION OF A FUNCTION OF A VARIABLE X *)\r
+\r
+ \r
+ UNIT CONSTANT:EXPR CLASS(K:REAL);\r
+ (* DIFFERENTIATED EXPRESSION WILL CONSIST OF CONSTANT *)\r
+ UNIT VIRTUAL DERIV:FUNCTION(X:VARIABLE):EXPR;\r
+ BEGIN\r
+ writeln("je suis dans constant ");\r
+ RESULT:=ZERO;\r
+ END DERIV;\r
+ END CONSTANT;\r
+\r
+ UNIT PAIRE:EXPR CLASS(L,R:EXPR);\r
+ (* WE WILL ALSO COMPUTE DERIVATIVES OF EXPRESSIONS WITH TWO\r
+ ARGUMENT OPERATORS *)\r
+ UNIT VIRTUAL DERIV: FUNCTION(X:VARIABLE):EXPR;\r
+ END;\r
+ END PAIRE;\r
+ \r
+ \r
+ UNIT SOMME : PAIRE CLASS;\r
+ (* WE DIFFERENTIATE THE SUM OF TWO EXPRESSIONS *)\r
+ UNIT VIRTUAL DERIV:FUNCTION(X:VARIABLE):EXPR;\r
+ VAR LPRIM,RPRIM:EXPR;\r
+ BEGIN\r
+ writeln("je suis sum");\r
+ LPRIM:=L.DERIV(X);\r
+ RPRIM:=R.DERIV(X);\r
+ (*WE DELETE 0 AS THE NEUTRAL ELEMENT OF\r
+ ADDITION *)\r
+ IF LPRIM=ZERO THEN\r
+ RESULT:=RPRIM\r
+ ELSE\r
+ IF RPRIM=ZERO THEN\r
+ RESULT:=LPRIM\r
+ ELSE\r
+ RESULT:=NEW SOMME(LPRIM,RPRIM)\r
+ FI\r
+ FI;\r
+ END DERIV;\r
+ END SOMME;\r
+ \r
+ \r
+ UNIT DIFF:PAIRE CLASS;\r
+ (* WE DIFFERENTIATE THE DIFFERECE OF TWO EXPRESSIONS *)\r
+ UNIT VIRTUAL DERIV:FUNCTION(X:VARIABLE):EXPR;\r
+ VAR LPRIM,RPRIM: EXPR;\r
+ BEGIN\r
+ LPRIM:=L.DERIV(X);\r
+ RPRIM:=R.DERIV(X);\r
+ (* WE DELETE THE SUBTRACTED ZERO *)\r
+ IF RPRIM=ZERO THEN\r
+ RESULT:=LPRIM\r
+ ELSE\r
+ RESULT:=NEW DIFF(LPRIM,RPRIM)\r
+ FI\r
+ END DERIV;\r
+ END DIFF;\r
+\r
+ UNIT PRODUIT : paire class;\r
+ UNIT VIRTUAL deriv : function (X : variable) : expr;\r
+ VAR UPRIMV, UVPRIM : expr;\r
+ BEGIN\r
+ UPRIMV := new produit(L.deriv(X), R);\r
+ UVPRIM := new produit(L, R.deriv(x));\r
+ result := new somme (UPRIMV, UVPRIM);\r
+ END DERIV;\r
+ END PRODUIT;\r
+\r
+ UNIT DIVISE : PAIRE class;\r
+ UNIT virtual deriv : function (X : variable): expr;\r
+ VAR UPRIMV, UVPRIM, VCARRE, NUMERA : EXPR;\r
+ BEGIN\r
+ UPRIMV := new produit (L.deriv(X), R);\r
+ UVPRIM := new produit (L, R.deriv(X));\r
+ NUMERA := new diff (UPRIMV, UVPRIM);\r
+ VCARRE := new produit (R, R);\r
+ result := new divise (NUMERA, VCARRE);\r
+ END DERIV;\r
+ END DIVISE;\r
+\r
+ UNIT SINUS : EXPR class (L : EXPR);\r
+ UNIT virtual deriv : function (X:variable) : expr;\r
+ VAR LPRIM : EXPR;\r
+ BEGIN\r
+ LPRIM := new cosinus (L);\r
+ result := new produit (L.deriv(X), LPRIM);\r
+ END deriv;\r
+ END sinus;\r
+\r
+ UNIT cosinus : expr class (L:expr);\r
+ UNIT virtual deriv : function (X:variable) : expr;\r
+ VAR LPRIM : expr;\r
+ BEGIN\r
+ LPRIM := new produit (new constant(-1), new sinus (L));\r
+ result := new produit (L.deriv(X) , LPRIM);\r
+ END deriv;\r
+ END cosinus;\r
+\r
+ UNIT LOGN : expr class (L : expr);\r
+ UNIT virtual deriv : function (X:variable): expr;\r
+ BEGIN\r
+ result := new divise (L.DERIV(X), L);\r
+ END DERIV;\r
+ END logn;\r
+\r
+ UNIT expon : expr class (L:expr);\r
+ UNIT virtual deriv : function(X : variable) : expr;\r
+ BEGIN\r
+ result := new produit (L.deriv(X), L);\r
+ END deriv;\r
+ END expon;\r
+\r
+ UNIT racine : expr class (L:expr);\r
+ UNIT virtual deriv : function (X : variable) : expr;\r
+ VAR prod, rac : expr;\r
+ BEGIN\r
+ RAC := new racine(L);\r
+ prod := new produit (new constant (2), rac);\r
+ result := new diff(L.deriv(X), prod);\r
+ END deriv;\r
+ END racine;\r
+\r
+\r
+ UNIT DISPLAY:PROCEDURE(T:STRING,E:EXPR);\r
+ (* DISPLAY THE EXPRESSION TREE IN A READABLE FORM *)\r
+ \r
+ UNIT SCAN:PROCEDURE(E:EXPR);\r
+ BEGIN\r
+ IF E IS SOMME THEN\r
+ WRITE(" ("); CALL SCAN(E QUA PAIRE.L);\r
+ WRITE("+");\r
+ CALL SCAN(E QUA PAIRE.R);\r
+ WRITE(" )");\r
+ ELSE\r
+ IF E IS DIFF THEN\r
+ WRITE(" (");\r
+ CALL SCAN(E QUA PAIRE.L);WRITE("-");\r
+ CALL SCAN(E QUA PAIRE.R);\r
+ WRITE(" )")\r
+ ELSE\r
+ IF E is PRODUIT then\r
+ write(" (");\r
+ call scan (E QUA PAIRE.L);\r
+ write("*");\r
+ call scan (E QUA PAIRE.R);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS DIVISE then\r
+ write(" (");\r
+ call scan (E QUA PAIRE.L);\r
+ write("/");\r
+ call scan (E QUA PAIRE.R);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS SINUS then\r
+ write(" ( sin(");\r
+ call scan (E QUA SINUS.L);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS COSINUS then\r
+ write(" ( cos(");\r
+ call scan (E QUA COSINUS.L);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS LOGN then\r
+ write(" ( LN(");\r
+ call scan (E QUA LOGN.L);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS EXPON then\r
+ write(" ( EXP(");\r
+ call scan (E QUA EXPON.L);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS RACINE then\r
+ write(" ( û (");\r
+ call scan (E QUA RACINE.L);\r
+ write(" )");\r
+ ELSE\r
+ IF E IS CONSTANT THEN\r
+ WRITE(E QUA CONSTANT.K:6:2)\r
+ ELSE\r
+ IF E IS VARIABLE THEN\r
+ WRITE(E QUA VARIABLE.ID);\r
+ FI FI FI FI FI FI FI FI FI FI FI;\r
+ END SCAN;\r
+ \r
+ BEGIN\r
+ WRITE(T);\r
+ CALL SCAN(E);\r
+ WRITELN;\r
+ END DISPLAY;\r
+ \r
+\r
+(*********************************************************)\r
+(******* calcul de la d\82riv\82e **********)\r
+(******* les op\82rateurs vont dans P2 ****)\r
+(******* et les op\82randes vont dans P1 ****)\r
+\r
+UNIT expderivee : procedure (express : arrayof char,\r
+ taille : integer);\r
+ CONST max = 100;\r
+ VAR opaux , c: char,\r
+ P1 : pile1,\r
+ P2 : pile2,\r
+ const1, auxreel : real,\r
+ decim, saisie : boolean,\r
+ X, Y, Z, T , arg1, arg2, consta, E,U,V, F : expr,\r
+ compt, j, cptcons : integer;\r
+\r
+ BEGIN\r
+ compt := 0;\r
+ P1 := new pile1;\r
+ P2 := new pile2;\r
+ decim, saisie := false;\r
+ FOR j := 1 to taille\r
+ do\r
+ write(express(j));\r
+ od;\r
+ j := 1;\r
+ DO\r
+ if j = taille + 1 then exit fi;\r
+ case express(j)\r
+ when '(' : j := j + 1;\r
+\r
+ when 'X','x': X := new variable('X');\r
+ call P1.empiler(X);\r
+ j := j + 1;\r
+\r
+ when 'Y','y': E := new variable('Y');\r
+ call P1.empiler(E);\r
+ j := j + 1;\r
+\r
+ when 'Z','z': E := new variable('Z');\r
+ call P1.empiler(E);\r
+ j := j + 1;\r
+\r
+ when 'T','t': E := new variable('T');\r
+ call P1.empiler(E);\r
+ j := j + 1;\r
+\r
+ when '0','1','2','3','4','5','6','7','8','9','.' :\r
+ cptcons := 100;\r
+ auxreel := charint(express(j));\r
+ const1 := auxreel * cptcons;\r
+ j := j + 1;\r
+ writeln("j = ",j);\r
+ writeln("avant test");\r
+ while not saisie do\r
+ writeln("dans test");\r
+ c := express(j);\r
+ IF (c = '0' or c = '1' or c = '2' or c='3'\r
+ or c='4' or c='5' or c= '6' or c = '7' or\r
+ c = '8' or c='9')\r
+ THEN\r
+ writeln("test0");\r
+ cptcons := cptcons div 10;\r
+ auxreel := charint(express(j));\r
+ const1 := const1 + (auxreel * cptcons);\r
+ j := j + 1;\r
+ ELSE\r
+ IF ( c ='.' )\r
+ THEN writeln("test1");\r
+ const1 := const1 / cptcons;\r
+ cptcons := 1;\r
+ j := j + 1;\r
+ decim := true;\r
+ ELSE\r
+ writeln("test2");\r
+ IF not decim then const1 := const1 / cptcons;FI;\r
+ E := new constant (const1);\r
+ writeln("avant empile");\r
+ call p1.empiler(E);\r
+ writeln("apres empile");\r
+ saisie := true;\r
+ writeln("j = ",j);\r
+ FI;\r
+ FI;\r
+ OD;\r
+\r
+ when ' ' : j := j + 1;\r
+\r
+ when 'C', 'S','E','R','L','c','s','e','r','l','+','-',\r
+ '*','/' : writeln(express(j));\r
+ call P2.empiler(express(j));\r
+ j := j + 1;\r
+\r
+ when ')' : opaux := P2.sommet ;\r
+ call P2.depiler;\r
+ case opaux\r
+ when '+','-','*','/' :\r
+ arg2 := P1.sommet;\r
+ call display("arg2 = ",arg2);\r
+ call P1.depiler;\r
+ arg1 :=P1.sommet;\r
+ call display("arg1 = ",arg1);\r
+ call P1.depiler;\r
+ case opaux\r
+ when '+' : E := new somme(arg1, arg2);\r
+ call display("E = ",E);\r
+ when '-' : E := new diff (arg1, arg2);\r
+ call display("E = ",E);\r
+ when '*': E := new produit (arg1,arg2);\r
+ when '/': E := new divise (arg1, arg2);\r
+ esac;\r
+ call P1.empiler (E);\r
+\r
+ when 'C','c','e','E','s','S','r','R','l','L' :\r
+ arg2 := P1.sommet;\r
+ call display("arg2 = ",arg2);\r
+ call P1.depiler;\r
+\r
+\r
+ esac;\r
+ j := j + 1;\r
+\r
+ esac;\r
+ od;\r
+ call display ("fonction = ", E);\r
+ F := E.deriv(X);\r
+ call display("Derivee = ", F);\r
+ readln;\r
+END expderivee;\r
+\r
+\r
+(**********************************************************)\r
+(*********** Saisie de la fonction \85 d\82river **********)\r
+\r
+UNIT expsaisie : procedure (output express : arrayof char,\r
+ taille : integer);\r
+VAR expression : arrayof char,\r
+ car : char,\r
+ opbool, cstbool, varbool, decibool : boolean,\r
+ i, touche, opcpt, ligne, pouvcpt, pfermcpt : integer;\r
+\r
+BEGIN\r
+ array expression dim (1:maxi);\r
+ ligne := 5;\r
+ writeln("Saisissez votre expression en parenth\82sant convenablement");\r
+ i := 1;\r
+ call gotoxy(ligne,1);\r
+ DO\r
+ touche := readkey;\r
+ car := chr (touche);\r
+ case car\r
+ when 'v','V': (* l'utilisateur veut valider l'expression *)\r
+ IF (pouvcpt =/= pfermcpt)\r
+ then\r
+ mes1 := "Expression incorrecte, il manque des parenth\8ases.";\r
+ mes2 := "Expression ignor\82e.";\r
+ ELSE\r
+ IF pouvcpt =/= opcpt\r
+ THEN mes1 := "Expression incorrecte. Il manque des parenth\8ases ou des op\82rateurs.";\r
+ mes2 := "Expression ignor\82e.";\r
+ ELSE\r
+ sais := true;\r
+ taille := i - 1;\r
+ express := expression;\r
+ mes1 := "Expression valid\82e.";\r
+ mes2 := blanc;\r
+ FI;\r
+ FI;\r
+ call mesg(mes1, mes2);\r
+ call gotoxy(25,1);\r
+ write(" <Appuyer sur une touche pour continuer>");\r
+ readln;\r
+ exit;\r
+\r
+ when 'i','I': mes1 := "Expression ignor\82e";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(25,1);\r
+ write(" <Appuyer sur une touche pour continuer>");\r
+ readln;\r
+ exit;\r
+\r
+ when ' ': (*rien*)\r
+ IF decibool\r
+ THEN mes1 := "Erreur : il manque la partie d\82cimale.";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(ligne, i);\r
+ FI;\r
+\r
+ when '(': write(car);\r
+ IF decibool\r
+ THEN mes1 := "Erreur : il manque la partie d\82cimale.";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ pouvcpt := pouvcpt + 1;\r
+ opbool := false;\r
+ cstbool := false;\r
+ varbool := false;\r
+ expression(i) := car;\r
+ i := i + 1;\r
+ call gotoxy(ligne,i);\r
+ FI;\r
+\r
+ when ')' : IF decibool\r
+ THEN mes1 := "Erreur : il manque la partie d\82cimale.";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ pfermcpt := pfermcpt +1;\r
+ opbool := false;\r
+ cstbool := false;\r
+ varbool := false;\r
+ write(car);\r
+ expression(i) := car;\r
+ i := i + 1;\r
+ call gotoxy(ligne,i);\r
+ FI;\r
+\r
+ when '+', '-', '*', '/', 'C', 'c','E','e','L','l','R','r','S','s' :\r
+ write(car);\r
+ IF opbool\r
+ then mes1 := "2 op\82rateurs ne peuvent pas \88tre cons\82cutifs.";\r
+ mes2 := "Resaisissez le caract\8are.";\r
+ call mesg (mes1,mes2);\r
+ call gotoxy(ligne,i);\r
+ ELSE\r
+ IF decibool\r
+ THEN mes1 := "Erreur : il manque la partie d\82cimale.";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ opbool := true;\r
+ varbool := false;\r
+ cstbool := false;\r
+ expression (i) := car;\r
+ i := i + 1;\r
+ opcpt := opcpt + 1;\r
+ call mesg(blanc,blanc);\r
+ call gotoxy(ligne,i);\r
+ FI;\r
+ FI;\r
+\r
+ when '0','1','2', '3','4','5','6','7','8','9' :\r
+ write(car);\r
+ IF varbool\r
+ then mes1 := "Il manque un op\82rateur ou une parenth\8ase";\r
+ mes2 := "Resaisissez le caract\8are.";\r
+ call mesg(mes1, mes2);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ decibool := false;\r
+ cstbool := true;\r
+ varbool := false;\r
+ opbool := false;\r
+ expression(i) := car;\r
+ i := i + 1;\r
+ call mesg (blanc, blanc);\r
+ call gotoxy(ligne,i);\r
+ FI;\r
+\r
+ when '.' : IF decibool\r
+ THEN mes1 := "Erreur : il manque la partie d\82cimale.";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ IF (varbool or opbool or not cstbool)\r
+ THEN\r
+ mes1 := "Expression incorrecte.";\r
+ mes2 := "Resaisissez le caract\8are.";\r
+ call mesg(mes1, mes2);\r
+ call gotoxy(ligne,i);\r
+ ELSE\r
+ (* cstbool est \85 vraie *)\r
+ decibool := true;\r
+ cstbool := false;\r
+ expression(i) := car;\r
+ i := i + 1;\r
+ call mesg(blanc, blanc);\r
+ call gotoxy(ligne, i);\r
+ FI;\r
+ FI;\r
+\r
+ when 'x','y','z','t','X','Y','Z','T':\r
+ write(car);\r
+ IF varbool\r
+ then mes1 := "On ne peut pas avoir 2 variables cons\82cutives.";\r
+ mes2 := "Il manque un op\82rateur ou une parenth\8ase.";\r
+ call mesg (mes1, mes2);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ IF cstbool\r
+ then mes1 := "Il manque un op\82rateur ou une parenth\8ase.";\r
+ mes2 := "Resaisissez le caract\8are." ;\r
+ call mesg(mes1, mes2);\r
+ call gotoxy(ligne,i);\r
+ ELSE\r
+ IF decibool\r
+ THEN mes1 := "Erreur : il manque la partie d\82cimale.";\r
+ call mesg(mes1, blanc);\r
+ call gotoxy(ligne, i);\r
+ ELSE\r
+ cstbool := false;\r
+ opbool := false;\r
+ varbool := true;\r
+ expression(i) := car;\r
+ i := i + 1;\r
+ call mesg(blanc, blanc);\r
+ call gotoxy(ligne,i);\r
+ FI;\r
+ FI;\r
+ FI;\r
+\r
+ otherwise write(car);\r
+ mes1 := "Caract\8are invalide. Corrigez le.";\r
+ call mesg(mes1,blanc);\r
+ call gotoxy(ligne,i);\r
+ esac;\r
+ OD;\r
+END expsaisie;\r
+\r
+\r
+(**********************************************************)\r
+(***** GUIDE UTILISATION *****)\r
+Unit guideutil : procedure;\r
+BEGIN\r
+END guideutil;\r
+\r
+\r
+(*********************************************************************)\r
+(***************** EFFACEMENT DE L'ECRAN *****************************)\r
+UNIT Newpage : procedure;\r
+begin\r
+ write(chr(27), "[2J")\r
+end newpage;\r
+\r
+\r
+(**********************************************************)\r
+(****** MENU ******)\r
+UNIT MENU : PROCEDURE;\r
+VAR choix, k : integer;\r
+ \r
+BEGIN\r
+DO\r
+ call newpage; \r
+ Write (" Ú");\r
+ For k:= 3 to 61 DO\r
+ Write("Ä");\r
+ OD;\r
+ writeln("¿");\r
+ Writeln(" ³ ³");\r
+ Writeln(" ³ **** CE PROGRAMME DONNE L'EXPRESSION DE LA **** ³");\r
+ WRITELN(" ³ **** DERIVEE CORRESPONDANT A UNE FONCTION **** ³");\r
+ Writeln(" ³ **** DONNEE **** ³");\r
+ writeln(" ³ ³");\r
+ writeln(" ³ ³");\r
+ writeln(" ³ 1 : Saisir une fonction ³");\r
+ Writeln(" ³ 2 : Calculer la d\82riv\82e d'une fonction ³");\r
+ Writeln(" ³ 3 : Visualiser le guide d'utilisation ³");\r
+ Writeln(" ³ 4 : Quitter ³");\r
+ writeln(" ³ ³");\r
+ Write (" À");\r
+ For k := 2 to 60 DO\r
+ write ("Ä");\r
+ OD;\r
+ writeln("Ù");\r
+ writeln;\r
+ write(" votre choix :");\r
+ readln (choix);\r
+ call newpage;\r
+ CASE choix\r
+ When 1 : taille := 0;\r
+ call expsaisie (express,taille);\r
+\r
+ WHEN 2 : IF not sais\r
+ then write("coucou");\r
+ mes1 := "Aucune expression correcte n'a \82t\82 saisie";\r
+ mes2 := blanc;\r
+ call mesg (mes1, mes2);\r
+ write("<Appuyer sur une touche pour continuer>");\r
+ readln;\r
+ call menu;\r
+ ELSE call expderivee(express, taille);\r
+ FI;\r
+\r
+ WHEN 3 : call guideutil;\r
+\r
+ WHEN 4 : exit ;\r
+ OTHERWISE mes1 :="le choix demand\82 est incorrect ";\r
+ call mesg(mes1, blanc);\r
+ write("<Appuyer sur une touche pour continuer>");\r
+ readln;\r
+ ESAC;\r
+OD;\r
+END MENU;\r
+\r
+\r
+(**********************************************************)\r
+(***** PROGRAMME PRINCIPAL *****)\r
+(**********************************************************)\r
+CONST MAXI = 80,\r
+ MAX = 50,\r
+ BLANC = " ";\r
+\r
+VAR sais : boolean,\r
+ express : arrayof char,\r
+ mes1, mes2 : string,\r
+ taille : integer,\r
+ ZERO,ONE:CONSTANT;\r
+ \r
+\r
+BEGIN\r
+ ZERO:=NEW CONSTANT(0);\r
+ ONE:=NEW CONSTANT(1);\r
+ sais := false;\r
+ call menu;\r
+END;\r
--- /dev/null
+BLOCK\r
+\r
+ Const noir = 0 ,\r
+ rouge = 1 ,\r
+ vert = 2 ,\r
+ jaune = 3 ,\r
+ bleu = 4 ,\r
+ magenta = 5 ,\r
+ cyan = 6 ,\r
+ blanc = 7 ;\r
+\r
+(* Fonction qui attend qu'un caract\8are soit tap\82 au clavier *)\r
+(* et le renvoie *)\r
+ UNIT GetChar:function:char;\r
+ var a:integer;\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ a:=0;\r
+ while a=0\r
+ do\r
+ a:=inkey;\r
+ od;\r
+ result:=chr(a);\r
+ end;\r
+ End GetChar;\r
+\r
+(* Fonction qui saisit une chaine de caract\8ares et la place dans un tableau *)\r
+(* de caract\8ares *)\r
+ UNIT SaisieString : function : arrayof char ;\r
+ var a : char ,\r
+ s , tmp : arrayof char ,\r
+ i , long : integer ;\r
+ Begin\r
+ a:=getchar;\r
+ array tmp dim (1:255);\r
+ long:=1;\r
+ while (ord(a)<>13)\r
+ do\r
+ write(a);\r
+ tmp(long):=a;\r
+ long:=long+1;\r
+ a:=getchar;\r
+ od;\r
+ writeln;\r
+ long:=long-1;\r
+ array s dim (1:long);\r
+ for i:=1 to long do s(i):=tmp(i); od ;\r
+ result:=s;\r
+ End saisiestring;\r
+\r
+(* Procedure permettant de choisir la couleur d'\82criture et de fond du texte *)\r
+ UNIT Couleur : procedure ( texte,fond : integer);\r
+ var t , f : char ;\r
+ Begin\r
+ t:=chr(48+texte);\r
+ f:=chr(48+fond);\r
+ Write ( chr(27) , "[1;3",t,";4",f,"m");\r
+ End couleur;\r
+\r
+(* Procedure permettant d'effacer la ligne courante *)\r
+ UNIT EraseLine : procedure;\r
+ Begin\r
+ Write( chr(27), "[K")\r
+ End EraseLine;\r
+\r
+(* Procedure permettant d'effacer enti\8arement l'\82cran *)\r
+ UNIT Cls : procedure;\r
+ Begin\r
+ Write( chr(27), "[2J");\r
+ Write( chr(27), "[H");\r
+ End Cls;\r
+\r
+(* Procedure permettant de positionner le curseur sur l'\82cran *)\r
+ UNIT SetCursor : procedure(column, row : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ Begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ Write( chr(27), "[", c, d, ";", e, f, "H")\r
+ End SetCursor;\r
+\r
+\r
+(* Procedure permettant de calculer a exposant b *)\r
+UNIT exposant : function (a,b:integer) : integer ;\r
+ Begin\r
+ result:=round(exp(b*ln(a)));\r
+ End exposant;\r
+\r
+(* Procedure affichant le r\82sultat d'un essai de pattern matching *)\r
+UNIT afficheresultat : procedure (resultat : boolean);\r
+Begin\r
+ call couleur(cyan,noir);\r
+ call setcursor(18,18);\r
+ if resultat then\r
+ Writeln("Le pattern a ete trouve dans la chaine");\r
+ else\r
+ Writeln("Le pattern n'a pas ete trouve dans la chaine");\r
+ fi;\r
+ call couleur(blanc,noir);\r
+ call setcursor(55,24);\r
+ Write("Appuyez sur ENTREE");\r
+ readln;\r
+End afficheresultat;\r
+\r
+(* Procedure mettant en place les differents textes sur l'\82cran *)\r
+UNIT afficheecran : procedure (p , s : arrayof char);\r
+var t : integer ;\r
+ Begin\r
+ call couleur(blanc,noir);\r
+ call Cls;\r
+ Write("Pattern : ");\r
+ call couleur(jaune,noir);\r
+ for t:=1 to upper(p)\r
+ do\r
+ Write(p(t));\r
+ od ;\r
+ writeln;\r
+ call couleur(blanc,noir);\r
+ Writeln;\r
+ Writeln("Chaine ou on cherche le pattern :");\r
+ call couleur(jaune,noir);\r
+ for t:=1 to upper(s)\r
+ do\r
+ Write(s(t));\r
+ od ;\r
+ End afficheecran ;\r
+\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME SIMPLE *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoSimple : procedure ( p , s : arrayof char) ;\r
+\r
+(* Procedure ecrivant diff\82rents textes sur l'\82cran *)\r
+\r
+ UNIT ecran : procedure ;\r
+ Begin\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,10);\r
+ Writeln("On compare la premiere lettre de : ");\r
+ Writeln(" avec la premiere lettre de : ");\r
+ Writeln;\r
+ Writeln("Si elles sont egales, on reduit le pattern de 1 caractere");\r
+ End ecran ;\r
+\r
+(* Procedure permettant d'afficher les diff\82rentes \82tapes de l'ex\82cution de *)\r
+(* l'algorithme *)\r
+\r
+ UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);\r
+ Var t , longs , longp , posx , longtest : integer ;\r
+ var car : char\r
+ Begin\r
+ posx:=35;\r
+ longp:=upper(p);\r
+ longs:=upper(s);\r
+ longtest:=longp-posp+1;\r
+ call couleur(jaune,bleu);\r
+ call setcursor(35,10);\r
+ for t:=posp to longp\r
+ do\r
+ Write(p(t));\r
+ od;\r
+ call couleur(jaune,noir);\r
+ Write(" ");\r
+ for t:=1 to longs\r
+ do\r
+ if ( (t>=poss) and (t<poss+longtest) ) then\r
+ call couleur(jaune,bleu);\r
+ call setcursor(posx,11);\r
+ Write(s(t));\r
+ posx:=posx+1;\r
+ call couleur(jaune,noir);\r
+ Write(" ");\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ call setcursor(t,4);\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+ Var i , j , m , n : integer ,\r
+ resultat : boolean ;\r
+\r
+(* corps de l'algorithme simple *)\r
+ Begin\r
+ (* initialisations *)\r
+ call afficheecran (p,s);\r
+ call ecran ;\r
+ m:=upper(p);\r
+ n:=upper(s);\r
+ i:=1;\r
+ j:=1;\r
+\r
+ (* boucle principale *)\r
+ while ((i<=m) and (j<=n))\r
+ do\r
+ call AfficheChaine(p,s,i,j);\r
+ if p(i)=s(j) then\r
+ i:=i+1;\r
+ j:=j+1;\r
+ else\r
+ i:=1;\r
+ j:=j-i+2;\r
+ fi;\r
+ resultat:=(i>m);\r
+ od;\r
+ call afficheresultat(resultat) ;\r
+End AlgoSimple;\r
+\r
+\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME DE KNUTH, MORRIS et PRATT *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoKMP : procedure(p , s : arrayof char) ;\r
+\r
+(* procedure permettant d'effectuer les affichages *)\r
+\r
+ UNIT ecran : procedure (h:arrayof integer) ;\r
+ var i : integer ;\r
+ begin\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,7);\r
+ writeln("On compare le caractere en surbrillance du pattern avec celui de la chaine.");\r
+ writeln("Quand on trouve un caractere non correspondant, on revient en arriere dans le");\r
+ writeln("pattern d'un nombre n de positions.");\r
+ writeln("n est donn\82 par la table suivante:");\r
+ writeln("caractere num :");\r
+ writeln("hash code (=n) :");\r
+ call couleur(jaune,noir);\r
+ for i:=1 to upper(h)\r
+ do\r
+ call setcursor(13+i*4,11);\r
+ write(i:4);\r
+ call setcursor(13+i*4,12);\r
+ write(h(i):4);\r
+ od;\r
+ end ecran ;\r
+\r
+(* procedure d'affichage du texte *)\r
+\r
+ UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);\r
+ Var t , longs , longp : integer ;\r
+ Var car : char ;\r
+ Begin\r
+ longp:=upper(p);\r
+ longs:=upper(s);\r
+ call setcursor(11,1);\r
+ for t:=1 to longp\r
+ do\r
+ if (t=posp) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(p(t));\r
+ od;\r
+ call setcursor(1,4);\r
+ for t:=1 to longs\r
+ do\r
+ if (t=poss) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+(* Procedure de calcul de la hash function, stockee dans une table *)\r
+\r
+ UNIT KMPhash : function(p : arrayof char) : arrayof integer;\r
+ var i, j : integer,\r
+ h : arrayof integer ,\r
+ sortie: boolean ;\r
+\r
+ Begin\r
+ (* initialisations *)\r
+ i := 1;\r
+ j := 0;\r
+ m := upper(p);\r
+ array h dim (1:m);\r
+ h(1) := 0;\r
+\r
+ (* boucle principale *)\r
+ while (i < m)\r
+ do\r
+ sortie:=false ;\r
+ while (not sortie)\r
+ do\r
+ sortie:=true;\r
+ if (j>0) then\r
+ if (p(j) <> p(i)) then\r
+ sortie:=false ;\r
+ j:=h(j);\r
+ fi ;\r
+ fi ;\r
+ od;\r
+\r
+ i := i+1;\r
+ j := j+1;\r
+ if (p(i) = p(j)) then h(i) := h(j);\r
+ else h(i) := j;\r
+ fi;\r
+ od;\r
+ result:=h;\r
+ End KMPhash;\r
+\r
+var i, j, m, n : integer,\r
+ h : arrayof integer,\r
+ sortie , resultat : boolean;\r
+\r
+(* Corps de l'algorithme KMP *******************)\r
+\r
+Begin\r
+ call afficheecran(p,s);\r
+\r
+ (* initialisations *)\r
+ m := upper(p);\r
+ n := upper(s);\r
+ array h dim(1:m);\r
+ h := KMPhash(p);\r
+ call ecran(h);\r
+ i := 1;\r
+ j := 1;\r
+\r
+ (* boucle principale *)\r
+ while ((i <= m) and (j <= n))\r
+ do\r
+ sortie:=false;\r
+ while (not sortie)\r
+ do\r
+ sortie:=true;\r
+ if (i>0) then\r
+ if (p(i) <> s(j)) then\r
+ sortie:=false ;\r
+ i:=h(i);\r
+ call setcursor(1,14);\r
+ call couleur(blanc,noir);\r
+ write("On se deplace a la position : ",i);\r
+ fi ;\r
+ if (i>0) then\r
+ call affichechaine(p,s,i,j);\r
+ else\r
+ call setcursor(1,14);\r
+ call couleur(blanc,noir);\r
+ call eraseline;\r
+ call affichechaine(p,s,i+1,j);\r
+ fi;\r
+ fi;\r
+ od;\r
+ i := i+1;\r
+ j := j+1;\r
+ od;\r
+ resultat := (i > m);\r
+ call afficheresultat(resultat);\r
+ End AlgoKMP;\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME DE KARP et RABIN *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoKarpRabin : procedure (p , s : arrayof char);\r
+\r
+(* Affichage de l'ecran et des commentaires *)\r
+\r
+ UNIT Ecran : Procedure (hash : integer);\r
+ begin\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,8);\r
+ write("Hash code du pattern :");\r
+ call couleur(jaune,noir);\r
+ writeln(hash);\r
+ call couleur(blanc,noir);\r
+ writeln("Hash code du texte selectionne :");\r
+ end ecran ;\r
+\r
+(* procedure d'affichage du texte *)\r
+\r
+ UNIT AfficheChaine : procedure (s:arrayof char ; poss ,longp,hash:integer);\r
+ Var t , longs : integer ;\r
+ Var car : char ;\r
+ Begin\r
+ longs:=upper(s);\r
+ call couleur(jaune,noir);\r
+ call setcursor(33,9);\r
+ write(hash);\r
+ call setcursor(1,4);\r
+ for t:=1 to longs\r
+ do\r
+ if ( (t>=poss) and (t<poss+longp) ) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+(* Procedure de calcul de la premiere valeur de la hash function *)\r
+\r
+ UNIT hashfunction : function( str : arrayof char, m : integer ):integer;\r
+ var a : integer;\r
+ Begin\r
+ result := 0;\r
+ for a := 1 to m do\r
+ result := result + ord(str(a)) ;\r
+ od;\r
+ End hashfunction;\r
+\r
+(* Procedure de calcul des valeurs suivantes de la hash function *)\r
+\r
+ UNIT newhash : function( oldh , m ,j:integer, str : arrayof char ): integer;\r
+ Begin\r
+ result:=oldh + ord(str(j+m)) - ord(str(j)) ;\r
+ End newhash;\r
+\r
+var j, m, n, a , d : integer,\r
+ hpat, hstr : integer ,\r
+ trouve : boolean;\r
+\r
+(* Corps de l'algorithme KR ************************)\r
+\r
+ Begin\r
+\r
+ (* initialisations *)\r
+ call afficheecran(p,s);\r
+ j := 1;\r
+ trouve := false;\r
+ m := upper(p);\r
+ n := upper(s);\r
+ hpat := hashfunction(p,m);\r
+ hstr := hashfunction(s,m);\r
+ call ecran(hpat);\r
+ j:=1;\r
+\r
+ (* boucle principale *)\r
+ do\r
+ if ( hpat = hstr ) then\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,12);\r
+ write("Les deux hashcodes correspondent, on compare le pattern et la selection");\r
+ a := 1;\r
+ trouve := true;\r
+ while ((trouve) and (a <= m))\r
+ do\r
+ if ( p(a) = s(j+a-1) ) then\r
+ a := a+1\r
+ else\r
+ trouve := false;\r
+ fi\r
+ od;\r
+ else\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,12);\r
+ call eraseline;\r
+ fi;\r
+ call affichechaine(s,j,m,hstr);\r
+ if ( (j>= (n-m+1)) or ( trouve) ) then exit fi;\r
+ hstr := newhash(hstr , m , j , s);\r
+ j:=j+1;\r
+\r
+ od;\r
+ call afficheresultat(trouve);\r
+ End AlgoKarpRabin;\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME DE BOYER et MOORE (modifi\82 HORSPOOL) *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoBoyerMoore : procedure ( p , s : arrayof char);\r
+\r
+(* procedure d'affichage du texte *)\r
+\r
+ UNIT AfficheChaine : procedure (s:arrayof char; poss : integer);\r
+ Var t , longs : integer ;\r
+ Var car : char ;\r
+ Begin\r
+ longs:=upper(s);\r
+ call setcursor(1,4);\r
+ for t:=1 to longs\r
+ do\r
+ if (t=poss) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+(* Procedure de remplissage de la table Delta *)\r
+\r
+UNIT Delta : function (p : arrayof char) : arrayof integer ;\r
+\r
+Var d : arrayof integer,\r
+ a : integer;\r
+\r
+Begin\r
+ array d dim(1:127);\r
+ m:=upper(p);\r
+ (* initialisation *)\r
+ for a:=1 to 127 do\r
+ d(a):=m;\r
+ od;\r
+ (* calcul pour le pattern *)\r
+ for a:=1 to m-1 do\r
+ d(ord(p(a))):=m-a;\r
+ od;\r
+ result:=d;\r
+End Delta;\r
+\r
+var j, m, n, a : integer,\r
+ trouve : boolean,\r
+ d : arrayof integer;\r
+\r
+\r
+(* Corps de l'algorithme BM ************************)\r
+\r
+Begin\r
+ (* initialisations *)\r
+ call afficheecran(p,s);\r
+ m:=upper(p);\r
+ n:=upper(s);\r
+ d:=Delta(p);\r
+ j:=m;\r
+ trouve:=false;\r
+\r
+ (* boucle principale *)\r
+ while ( (j<=n) and (not trouve) )\r
+ do\r
+ call affichechaine(s,j);\r
+ if (s(j) = p(m)) then\r
+ trouve:=true;\r
+ for a:=1 to m\r
+ do\r
+ if (p(a)<>s(j-m+a)) then\r
+ trouve:=false;\r
+ fi;\r
+ od;\r
+ fi;\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,8);\r
+ if (not trouve) then\r
+ writeln("La derniere lettre du pattern ne correspond pas avec la lettre de la chaine");\r
+ writeln("en surbrillance, alors on se deplace de ",d(ord(s(j))):2," positions");\r
+ else\r
+ call eraseline;\r
+ writeln;\r
+ call eraseline;\r
+ fi;\r
+ j:=j+d(ord(s(j)));\r
+ od;\r
+ call afficheresultat(trouve);\r
+\r
+End AlgoBoyerMoore ;\r
+\r
+\r
+(* Procedure affichant le premier ecran et saisissant les choix *)\r
+\r
+UNIT EcranPrincipal : procedure ;\r
+var choix : integer ,\r
+ p , s : arrayof char ;\r
+ Begin\r
+ choix:=0;\r
+ while (choix<>5)\r
+ do\r
+ call couleur(blanc,noir);\r
+ call cls;\r
+ call setcursor(27,1);\r
+ Write("Programme Pattern Matcher");\r
+ call setcursor(27,2);\r
+ Write("-------------------------");\r
+ call setcursor(1,22);\r
+ writeln("Tous les algorithmes s'executent en pas a pas, il faut appuyer sur une touche");\r
+ write("pour faire s'executer le pas suivant...");\r
+\r
+ call setcursor(1,6);\r
+ writeln(" 1) Algorithme simple");\r
+ writeln(" 2) Algorithme de Karp et Rabin");\r
+ writeln(" 3) Algorithme de Knuth, Morris et Pratt");\r
+ writeln(" 4) Algorithme de Boyer et Moore");\r
+ writeln(" 5) Quitter le programme");\r
+ writeln;\r
+ write("Votre choix : ");\r
+ readln(choix);\r
+ if (choix < 5) then\r
+ writeln;\r
+ writeln("Saisie de la chaine ou on recherche le pattern :");\r
+ call couleur(jaune,noir);\r
+ s:=saisiestring;\r
+ call couleur(blanc,noir);\r
+ writeln("Saisie du pattern a rechercher :");\r
+ call couleur(jaune,noir);\r
+ p:=saisiestring;\r
+ call couleur(blanc,noir);\r
+ case choix\r
+ when 1 : call algoSimple(p,s);\r
+ when 2 : call algoKarpRabin(p,s);\r
+ when 3 : call algoKMP(p,s);\r
+ when 4 : call algoBoyerMoore(p,s);\r
+ esac ;\r
+ fi;\r
+ od;\r
+ End EcranPrincipal;\r
+\r
+\r
+(***************************************************************************)\r
+(* PROGRAMME PRINCIPAL *)\r
+(***************************************************************************)\r
+\r
+\r
+Begin\r
+ call ecranprincipal;\r
+End;\1a
\ No newline at end of file
--- /dev/null
+BLOCK\r
+(* auteurs V.Borry et V.Iriart *)\r
+(* Licence GR2. 1993/94 *)\r
+\r
+ Const noir = 0 ,\r
+ rouge = 1 ,\r
+ vert = 2 ,\r
+ jaune = 3 ,\r
+ bleu = 4 ,\r
+ magenta = 5 ,\r
+ cyan = 6 ,\r
+ blanc = 7 ;\r
+\r
+(* Fonction qui attend qu'un caract\8are soit tap\82 au clavier *)\r
+(* et le renvoie *)\r
+ UNIT GetChar:function:char;\r
+ var a:integer;\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ a:=0;\r
+ while a=0\r
+ do\r
+ a:=inkey;\r
+ od;\r
+ result:=chr(a);\r
+ end;\r
+ End GetChar;\r
+\r
+(* Fonction qui saisit une chaine de caract\8ares et la place dans un tableau *)\r
+(* de caract\8ares *)\r
+ UNIT SaisieString : function : arrayof char ;\r
+ var a : char ,\r
+ s , tmp : arrayof char ,\r
+ i , long : integer ;\r
+ Begin\r
+ a:=getchar;\r
+ array tmp dim (1:255);\r
+ long:=1;\r
+ while (ord(a)<>13)\r
+ do\r
+ write(a);\r
+ tmp(long):=a;\r
+ long:=long+1;\r
+ a:=getchar;\r
+ od;\r
+ writeln;\r
+ long:=long-1;\r
+ array s dim (1:long);\r
+ for i:=1 to long do s(i):=tmp(i); od ;\r
+ result:=s;\r
+ End saisiestring;\r
+\r
+(* Procedure permettant de choisir la couleur d'\82criture et de fond du texte *)\r
+ UNIT Couleur : procedure ( texte,fond : integer);\r
+ var t , f : char ;\r
+ Begin\r
+ t:=chr(48+texte);\r
+ f:=chr(48+fond);\r
+ Write ( chr(27) , "[1;3",t,";4",f,"m");\r
+ End couleur;\r
+\r
+(* Procedure permettant d'effacer la ligne courante *)\r
+ UNIT EraseLine : procedure;\r
+ Begin\r
+ Write( chr(27), "[K")\r
+ End EraseLine;\r
+\r
+(* Procedure permettant d'effacer enti\8arement l'\82cran *)\r
+ UNIT Cls : procedure;\r
+ Begin\r
+ Write( chr(27), "[2J");\r
+ Write( chr(27), "[H");\r
+ End Cls;\r
+\r
+(* Procedure permettant de positionner le curseur sur l'\82cran *)\r
+ UNIT SetCursor : procedure(column, row : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ Begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ Write( chr(27), "[", c, d, ";", e, f, "H")\r
+ End SetCursor;\r
+\r
+\r
+(* Procedure permettant de calculer a exposant b *)\r
+UNIT exposant : function (a,b:integer) : integer ;\r
+ Begin\r
+ result:=round(exp(b*ln(a)));\r
+ End exposant;\r
+\r
+(* Procedure affichant le r\82sultat d'un essai de pattern matching *)\r
+UNIT afficheresultat : procedure (resultat : boolean);\r
+Begin\r
+ call couleur(cyan,noir);\r
+ call setcursor(18,18);\r
+ if resultat then\r
+ Writeln("Le pattern a ete trouve dans la chaine");\r
+ else\r
+ Writeln("Le pattern n'a pas ete trouve dans la chaine");\r
+ fi;\r
+ call couleur(blanc,noir);\r
+ call setcursor(55,24);\r
+ Write("Appuyez sur ENTREE");\r
+ readln;\r
+End afficheresultat;\r
+\r
+(* Procedure mettant en place les differents textes sur l'\82cran *)\r
+UNIT afficheecran : procedure (p , s : arrayof char);\r
+var t : integer ;\r
+ Begin\r
+ call couleur(blanc,noir);\r
+ call Cls;\r
+ Write("Pattern : ");\r
+ call couleur(jaune,noir);\r
+ for t:=1 to upper(p)\r
+ do\r
+ Write(p(t));\r
+ od ;\r
+ writeln;\r
+ call couleur(blanc,noir);\r
+ Writeln;\r
+ Writeln("Chaine ou on cherche le pattern :");\r
+ call couleur(jaune,noir);\r
+ for t:=1 to upper(s)\r
+ do\r
+ Write(s(t));\r
+ od ;\r
+ End afficheecran ;\r
+\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME SIMPLE *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoSimple : procedure ( p , s : arrayof char) ;\r
+\r
+(* Procedure ecrivant diff\82rents textes sur l'\82cran *)\r
+\r
+ UNIT ecran : procedure ;\r
+ Begin\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,10);\r
+ Writeln("On compare la premiere lettre de : ");\r
+ Writeln(" avec la premiere lettre de : ");\r
+ Writeln;\r
+ Writeln("Si elles sont egales, on reduit le pattern de 1 caractere");\r
+ End ecran ;\r
+\r
+(* Procedure permettant d'afficher les diff\82rentes \82tapes de l'ex\82cution de *)\r
+(* l'algorithme *)\r
+\r
+ UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);\r
+ Var t , longs , longp , posx , longtest : integer ;\r
+ var car : char\r
+ Begin\r
+ posx:=35;\r
+ longp:=upper(p);\r
+ longs:=upper(s);\r
+ longtest:=longp-posp+1;\r
+ call couleur(jaune,bleu);\r
+ call setcursor(35,10);\r
+ for t:=posp to longp\r
+ do\r
+ Write(p(t));\r
+ od;\r
+ call couleur(jaune,noir);\r
+ Write(" ");\r
+ for t:=1 to longs\r
+ do\r
+ if ( (t>=poss) and (t<poss+longtest) ) then\r
+ call couleur(jaune,bleu);\r
+ call setcursor(posx,11);\r
+ Write(s(t));\r
+ posx:=posx+1;\r
+ call couleur(jaune,noir);\r
+ Write(" ");\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ call setcursor(t,4);\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+ Var i , j , m , n : integer ,\r
+ resultat : boolean ;\r
+\r
+(* corps de l'algorithme simple *)\r
+ Begin\r
+ (* initialisations *)\r
+ call afficheecran (p,s);\r
+ call ecran ;\r
+ m:=upper(p);\r
+ n:=upper(s);\r
+ i:=1;\r
+ j:=1;\r
+\r
+ (* boucle principale *)\r
+ while ((i<=m) and (j<=n))\r
+ do\r
+ call AfficheChaine(p,s,i,j);\r
+ if p(i)=s(j) then\r
+ i:=i+1;\r
+ j:=j+1;\r
+ else\r
+ i:=1;\r
+ j:=j-i+2;\r
+ fi;\r
+ resultat:=(i>m);\r
+ od;\r
+ call afficheresultat(resultat) ;\r
+End AlgoSimple;\r
+\r
+\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME DE KNUTH, MORRIS et PRATT *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoKMP : procedure(p , s : arrayof char) ;\r
+\r
+(* procedure permettant d'effectuer les affichages *)\r
+\r
+ UNIT ecran : procedure (h:arrayof integer) ;\r
+ var i : integer ;\r
+ begin\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,7);\r
+ writeln("On compare le caractere en surbrillance du pattern avec celui de la chaine.");\r
+ writeln("Quand on trouve un caractere non correspondant, on revient en arriere dans le");\r
+ writeln("pattern d'un nombre n de positions.");\r
+ writeln("n est donn\82 par la table suivante:");\r
+ writeln("caractere num :");\r
+ writeln("hash code (=n) :");\r
+ call couleur(jaune,noir);\r
+ for i:=1 to upper(h)\r
+ do\r
+ call setcursor(13+i*4,11);\r
+ write(i:4);\r
+ call setcursor(13+i*4,12);\r
+ write(h(i):4);\r
+ od;\r
+ end ecran ;\r
+\r
+(* procedure d'affichage du texte *)\r
+\r
+ UNIT AfficheChaine : procedure (p,s:arrayof char; posp,poss : integer);\r
+ Var t , longs , longp : integer ;\r
+ Var car : char ;\r
+ Begin\r
+ longp:=upper(p);\r
+ longs:=upper(s);\r
+ call setcursor(11,1);\r
+ for t:=1 to longp\r
+ do\r
+ if (t=posp) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(p(t));\r
+ od;\r
+ call setcursor(1,4);\r
+ for t:=1 to longs\r
+ do\r
+ if (t=poss) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+(* Procedure de calcul de la hash function, stockee dans une table *)\r
+\r
+ UNIT KMPhash : function(p : arrayof char) : arrayof integer;\r
+ var i, j : integer,\r
+ h : arrayof integer ,\r
+ sortie: boolean ;\r
+\r
+ Begin\r
+ (* initialisations *)\r
+ i := 1;\r
+ j := 0;\r
+ m := upper(p);\r
+ array h dim (1:m);\r
+ h(1) := 0;\r
+\r
+ (* boucle principale *)\r
+ while (i < m)\r
+ do\r
+ sortie:=false ;\r
+ while (not sortie)\r
+ do\r
+ sortie:=true;\r
+ if (j>0) then\r
+ if (p(j) <> p(i)) then\r
+ sortie:=false ;\r
+ j:=h(j);\r
+ fi ;\r
+ fi ;\r
+ od;\r
+\r
+ i := i+1;\r
+ j := j+1;\r
+ if (p(i) = p(j)) then h(i) := h(j);\r
+ else h(i) := j;\r
+ fi;\r
+ od;\r
+ result:=h;\r
+ End KMPhash;\r
+\r
+var i, j, m, n : integer,\r
+ h : arrayof integer,\r
+ sortie , resultat : boolean;\r
+\r
+(* Corps de l'algorithme KMP *******************)\r
+\r
+Begin\r
+ call afficheecran(p,s);\r
+\r
+ (* initialisations *)\r
+ m := upper(p);\r
+ n := upper(s);\r
+ array h dim(1:m);\r
+ h := KMPhash(p);\r
+ call ecran(h);\r
+ i := 1;\r
+ j := 1;\r
+\r
+ (* boucle principale *)\r
+ while ((i <= m) and (j <= n))\r
+ do\r
+ sortie:=false;\r
+ while (not sortie)\r
+ do\r
+ sortie:=true;\r
+ if (i>0) then\r
+ if (p(i) <> s(j)) then\r
+ sortie:=false ;\r
+ i:=h(i);\r
+ call setcursor(1,14);\r
+ call couleur(blanc,noir);\r
+ write("On se deplace a la position : ",i);\r
+ fi ;\r
+ if (i>0) then\r
+ call affichechaine(p,s,i,j);\r
+ else\r
+ call setcursor(1,14);\r
+ call couleur(blanc,noir);\r
+ call eraseline;\r
+ call affichechaine(p,s,i+1,j);\r
+ fi;\r
+ fi;\r
+ od;\r
+ i := i+1;\r
+ j := j+1;\r
+ od;\r
+ resultat := (i > m);\r
+ call afficheresultat(resultat);\r
+ End AlgoKMP;\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME DE KARP et RABIN *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoKarpRabin : procedure (p , s : arrayof char);\r
+\r
+(* Affichage de l'ecran et des commentaires *)\r
+\r
+ UNIT Ecran : Procedure (hash : integer);\r
+ begin\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,8);\r
+ write("Hash code du pattern :");\r
+ call couleur(jaune,noir);\r
+ writeln(hash);\r
+ call couleur(blanc,noir);\r
+ writeln("Hash code du texte selectionne :");\r
+ end ecran ;\r
+\r
+(* procedure d'affichage du texte *)\r
+\r
+ UNIT AfficheChaine : procedure (s:arrayof char ; poss ,longp,hash:integer);\r
+ Var t , longs : integer ;\r
+ Var car : char ;\r
+ Begin\r
+ longs:=upper(s);\r
+ call couleur(jaune,noir);\r
+ call setcursor(33,9);\r
+ write(hash);\r
+ call setcursor(1,4);\r
+ for t:=1 to longs\r
+ do\r
+ if ( (t>=poss) and (t<poss+longp) ) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+(* Procedure de calcul de la premiere valeur de la hash function *)\r
+\r
+ UNIT hashfunction : function( str : arrayof char, m : integer ):integer;\r
+ var a : integer;\r
+ Begin\r
+ result := 0;\r
+ for a := 1 to m do\r
+ result := result + ord(str(a)) ;\r
+ od;\r
+ End hashfunction;\r
+\r
+(* Procedure de calcul des valeurs suivantes de la hash function *)\r
+\r
+ UNIT newhash : function( oldh , m ,j:integer, str : arrayof char ): integer;\r
+ Begin\r
+ result:=oldh + ord(str(j+m)) - ord(str(j)) ;\r
+ End newhash;\r
+\r
+var j, m, n, a , d : integer,\r
+ hpat, hstr : integer ,\r
+ trouve : boolean;\r
+\r
+(* Corps de l'algorithme KR ************************)\r
+\r
+ Begin\r
+\r
+ (* initialisations *)\r
+ call afficheecran(p,s);\r
+ j := 1;\r
+ trouve := false;\r
+ m := upper(p);\r
+ n := upper(s);\r
+ hpat := hashfunction(p,m);\r
+ hstr := hashfunction(s,m);\r
+ call ecran(hpat);\r
+ j:=1;\r
+\r
+ (* boucle principale *)\r
+ do\r
+ if ( hpat = hstr ) then\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,12);\r
+ write("Les deux hashcodes correspondent, on compare le pattern et la selection");\r
+ a := 1;\r
+ trouve := true;\r
+ while ((trouve) and (a <= m))\r
+ do\r
+ if ( p(a) = s(j+a-1) ) then\r
+ a := a+1\r
+ else\r
+ trouve := false;\r
+ fi\r
+ od;\r
+ else\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,12);\r
+ call eraseline;\r
+ fi;\r
+ call affichechaine(s,j,m,hstr);\r
+ if ( (j>= (n-m+1)) or ( trouve) ) then exit fi;\r
+ hstr := newhash(hstr , m , j , s);\r
+ j:=j+1;\r
+\r
+ od;\r
+ call afficheresultat(trouve);\r
+ End AlgoKarpRabin;\r
+\r
+(**************************************************************************)\r
+(* *)\r
+(* ALGORITHME DE BOYER et MOORE (modifi\82 HORSPOOL) *)\r
+(* *)\r
+(**************************************************************************)\r
+UNIT AlgoBoyerMoore : procedure ( p , s : arrayof char);\r
+\r
+(* procedure d'affichage du texte *)\r
+\r
+ UNIT AfficheChaine : procedure (s:arrayof char; poss : integer);\r
+ Var t , longs : integer ;\r
+ Var car : char ;\r
+ Begin\r
+ longs:=upper(s);\r
+ call setcursor(1,4);\r
+ for t:=1 to longs\r
+ do\r
+ if (t=poss) then\r
+ call couleur(jaune,bleu);\r
+ else\r
+ call couleur(jaune,noir);\r
+ fi;\r
+ Write(s(t));\r
+ od;\r
+ car:=getchar;\r
+ End AfficheChaine;\r
+\r
+(* Procedure de remplissage de la table Delta *)\r
+\r
+UNIT Delta : function (p : arrayof char) : arrayof integer ;\r
+\r
+Var d : arrayof integer,\r
+ a : integer;\r
+\r
+Begin\r
+ array d dim(1:127);\r
+ m:=upper(p);\r
+ (* initialisation *)\r
+ for a:=1 to 127 do\r
+ d(a):=m;\r
+ od;\r
+ (* calcul pour le pattern *)\r
+ for a:=1 to m-1 do\r
+ d(ord(p(a))):=m-a;\r
+ od;\r
+ result:=d;\r
+End Delta;\r
+\r
+var j, m, n, a : integer,\r
+ trouve : boolean,\r
+ d : arrayof integer;\r
+\r
+\r
+(* Corps de l'algorithme BM ************************)\r
+\r
+Begin\r
+ (* initialisations *)\r
+ call afficheecran(p,s);\r
+ m:=upper(p);\r
+ n:=upper(s);\r
+ d:=Delta(p);\r
+ j:=m;\r
+ trouve:=false;\r
+\r
+ (* boucle principale *)\r
+ while ( (j<=n) and (not trouve) )\r
+ do\r
+ call affichechaine(s,j);\r
+ if (s(j) = p(m)) then\r
+ trouve:=true;\r
+ for a:=1 to m\r
+ do\r
+ if (p(a)<>s(j-m+a)) then\r
+ trouve:=false;\r
+ fi;\r
+ od;\r
+ fi;\r
+ call couleur(blanc,noir);\r
+ call setcursor(1,8);\r
+ if (not trouve) then\r
+ writeln("La derniere lettre du pattern ne correspond pas avec la lettre de la chaine");\r
+ writeln("en surbrillance, alors on se deplace de ",d(ord(s(j))):2," positions");\r
+ else\r
+ call eraseline;\r
+ writeln;\r
+ call eraseline;\r
+ fi;\r
+ j:=j+d(ord(s(j)));\r
+ od;\r
+ call afficheresultat(trouve);\r
+\r
+End AlgoBoyerMoore ;\r
+\r
+\r
+(* Procedure affichant le premier ecran et saisissant les choix *)\r
+\r
+UNIT EcranPrincipal : procedure ;\r
+var choix : integer ,\r
+ p , s : arrayof char ;\r
+ Begin\r
+ choix:=0;\r
+ while (choix<>5)\r
+ do\r
+ call couleur(blanc,noir);\r
+ call cls;\r
+ call setcursor(27,1);\r
+ Write("Programme Pattern Matcher");\r
+ call setcursor(27,2);\r
+ Write("-------------------------");\r
+ call setcursor(1,22);\r
+ writeln("Tous les algorithmes s'executent en pas a pas, il faut appuyer sur une touche");\r
+ write("pour faire s'executer le pas suivant...");\r
+\r
+ call setcursor(1,6);\r
+ writeln(" 1) Algorithme simple");\r
+ writeln(" 2) Algorithme de Karp et Rabin");\r
+ writeln(" 3) Algorithme de Knuth, Morris et Pratt");\r
+ writeln(" 4) Algorithme de Boyer et Moore");\r
+ writeln(" 5) Quitter le programme");\r
+ writeln;\r
+ write("Votre choix : ");\r
+ readln(choix);\r
+ if (choix < 5) then\r
+ writeln;\r
+ writeln("Saisie de la chaine ou on recherche le pattern :");\r
+ call couleur(jaune,noir);\r
+ s:=saisiestring;\r
+ call couleur(blanc,noir);\r
+ writeln("Saisie du pattern a rechercher :");\r
+ call couleur(jaune,noir);\r
+ p:=saisiestring;\r
+ call couleur(blanc,noir);\r
+ case choix\r
+ when 1 : call algoSimple(p,s);\r
+ when 2 : call algoKarpRabin(p,s);\r
+ when 3 : call algoKMP(p,s);\r
+ when 4 : call algoBoyerMoore(p,s);\r
+ esac ;\r
+ fi;\r
+ od;\r
+ End EcranPrincipal;\r
+\r
+\r
+(***************************************************************************)\r
+(* PROGRAMME PRINCIPAL *)\r
+(***************************************************************************)\r
+\r
+\r
+Begin\r
+ call ecranprincipal;\r
+End;\1a
\ No newline at end of file
--- /dev/null
+program test;\r
+(*_________________________________________________________*)\r
+(* For a given sequence of integers A1, ...,An *)\r
+(* find a subsequence k1,k2,... ki such that *)\r
+(* SUM( 0<i<n+1 : Aki) = v *)\r
+(* (Take A(i) such that SUM(i:Ai)<250 and A(i)<100.) *)\r
+(*_________________________________________________________*)\r
+ \r
+const left = 360 ,\r
+ right = 600 ;\r
+var level : integer;\r
+ \r
+begin\r
+ pref iiuwGRAPH block;\r
+ \r
+ unit dolej : procedure(kolor,ile:integer);\r
+ var i,j:integer;\r
+ begin\r
+ call color(kolor);\r
+ for i := Level-1 downto Level-ile\r
+ do\r
+ call move(left,i);\r
+ call draw(right,i);\r
+ for j :=1 to 300 do j:=j od;\r
+ od;\r
+ level := level-ile;\r
+ end dolej;\r
+ \r
+ unit odlej : procedure(ile: integer);\r
+ var i,j : integer;\r
+ begin\r
+ call color(0);\r
+ for i := Level to Level+ile do\r
+ call move(left,i);\r
+ call draw(right,i);\r
+ for j := 1 to 300 do j:=j od;\r
+ od;\r
+ level := level+ile\r
+ end odlej;\r
+ \r
+ unit sac_a_dos : procedure(A:arrayof integer,v: integer);\r
+ signal trouve;\r
+ var i : integer;\r
+ unit p : procedure(s,k : integer);\r
+ var i : integer;\r
+ begin\r
+ call dolej(k,A(k));\r
+ if s+ A(k)>v then\r
+ call odlej(A(k));\r
+ return\r
+ fi;\r
+ if s+A(k)=v then raise trouve fi;\r
+ s := s+A(k);\r
+ for i := k+1 to upper(A) do call p(s,i) od;\r
+ call odlej(A(k));\r
+ \r
+ last_will : call MyWrite(k);\r
+ call affich(inXpos,inYpos,", ");\r
+ end p;\r
+ handlers\r
+ when trouve : call affich(10,300,"press any key");\r
+ i := inchar;\r
+ call affich(10,300,"RESULT:: ");\r
+ call move(80,300);\r
+ terminate;\r
+ end handlers;\r
+ \r
+ begin\r
+ for i := lower(A) to upper(A) do call p(0,i) od;\r
+ call affich(10,315,"There is no such sequence !!! ");\r
+ \r
+ last_will : call affich(10,325,"END of EXECUTION");\r
+ end sac_a_dos;\r
+ \r
+ unit affich : procedure(x,y:integer,s:string);\r
+ var TAB : arrayof char,i:integer;\r
+ begin\r
+ call color(14);\r
+ TAB:= unpack(s);\r
+ call move(x,y);\r
+ for i := lower(TAB) to upper(TAB) do\r
+ call HASCII(0);\r
+ call HASCII(ord(TAB(i)));\r
+ od;\r
+ end affich;\r
+ \r
+ unit inchar : function : integer;\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i<>0 then exit fi;\r
+ od;\r
+ result :=i;\r
+ end inchar;\r
+ \r
+ unit MyRead : function : integer;\r
+ var OrdN : integer;\r
+ begin\r
+ result := 0;\r
+ do\r
+ OrdN:=inchar;\r
+ if OrdN=13 then exit fi;\r
+ if (ordN<58 and ordN>47)\r
+ then\r
+ call hascii(0);\r
+ call hascii(OrdN);\r
+ result := result*10+ (OrdN - 48)\r
+ else\r
+ if ordN=8 then result := result div 10;\r
+ call move(inXpos-8,inYpos);call hascii(0);\r
+ fi;\r
+ fi;\r
+ od;\r
+ end MyRead;\r
+ \r
+ unit MyWrite : procedure( Number : integer );\r
+ var i, j, n : integer,\r
+ Chiffres:arrayof integer;\r
+ begin\r
+ array Chiffres dim(1:10);\r
+ n:=0;\r
+ if Number=0 then n:=1; Chiffres(1):=0\r
+ else\r
+ while Number>0\r
+ do\r
+ n := n+1;\r
+ i := Number div 10;\r
+ Chiffres(n) := Number - i*10;\r
+ Number := i;\r
+ od;\r
+ for i := n downto 1\r
+ do\r
+ call HASCII(0);\r
+ call Hascii(Chiffres(i)+48);\r
+ od;\r
+ fi;\r
+ end MyWrite;\r
+ \r
+ unit dzban : procedure(x,y,z,v:integer);\r
+ var j : integer;\r
+ begin\r
+ call color(14);\r
+ for j :=1 to 3 do\r
+ call move(y+6+j,x);\r
+ call draw(y+6+j,x-v);\r
+ call move(z+j,x);\r
+ call draw(z+j,x-v);\r
+ od;\r
+ for j :=y to z+10 do\r
+ call move(j,x);\r
+ call draw(j,x+10)\r
+ od;\r
+ for j :=1 to 3 do\r
+ call move(y-5,x+10+j);\r
+ call draw(z+15,x+10+j)\r
+ od;\r
+ end dzban;\r
+ \r
+ var A : arrayof integer,\r
+ v,i,j,n : integer;\r
+begin\r
+ call GRON(0);\r
+ call aFFich(150,15,"KNAPSACK PROBLEM");\r
+ call affich(10,40,"Given a sequence A[1],...,A[n] of integers");\r
+ call affich(10,55,"find a subsequence i1,...,ij of the indices ");\r
+ call affich(10,70,"such that A[i1] +...+ A[ij] = v ");\r
+ call affich(10,110,"n = ");\r
+ n := MyRead;\r
+ call affich(10,130,"Elements of A :: ");\r
+ array A dim (1:n);\r
+ call move(10,145);\r
+ for i := 1 to n do\r
+ call color(i);\r
+ A(i):= MyRead;\r
+ call affich(inXpos,inYpos,", ")\r
+ od;\r
+ call affich(10,165,"v = ");\r
+ v := MyRead;\r
+ level := 300;\r
+ call dzban( level,350,600,v);\r
+ \r
+ call sac_a_dos(A,v);\r
+ v := inchar;\r
+ call GROFF;\r
+ end;\r
+ \r
+end test;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+program test;\r
+(*_________________________________________________________*)\r
+(* Donnee un sequence des nombres entier a1, ... an . *)\r
+(* Trouver un sequence k1,k2,... ki tel que *)\r
+(* SOMME( 0<i<n+1 : aki) = v *)\r
+(* (wersja bez rysowania) *)\r
+(*_________________________________________________________*)\r
+ \r
+ unit sac_a_dos : procedure(A:arrayof integer,v: integer);\r
+ signal trouve;\r
+ var i : integer;\r
+ unit p : procedure(s,k : integer);\r
+ var i : integer;\r
+ begin\r
+ if s+ A(k)>v then return fi;\r
+ if s+A(k)=v then raise trouve fi;\r
+ s := s+A(k);\r
+ for i := k+1 to upper(A) do call p(s,i) od;\r
+ last_will : writeln(k);\r
+ end p;\r
+ handlers\r
+ when trouve : writeln("RESULTAT :: ");\r
+ terminate;\r
+ end handlers;\r
+ \r
+begin\r
+ for i := lower(A) to upper(A) do call p(0,i) od;\r
+ writeln("il n'y a pas sequence i1,..ik tel que le somme est v ");\r
+ \r
+ last_will : writeln("Fin du sequence");\r
+end sac_a_dos;\r
+ \r
+var A: arrayof integer, v,i,n : integer;\r
+ \r
+begin\r
+ write(" n= ");\r
+ readln(n);\r
+ array A dim (1:n);\r
+ for i := 1 to n do read(A(i)) od;\r
+ write("v = ");\r
+ readln(v);\r
+ call sac_a_dos(A,v);\r
+ writeln("et fin d'execution.");\r
+ \r
+end test;\r
+ \r
+Dla danych 1 2 3 4 5 6 7 8 9 10, v=12\r
+Wynik : sequence : 6 3 2 1 ( w takiej wlasnie kolejnosci !)\r
+ Fin de sequence\r
+et fin d'execution.\r
+ \r
+ (* jezeli uzyje wind zamiast terminate to nawet gdy znajde rozwiazanie *)\r
+ (* instrukcja for jest w tej procedurze kontynuowana az do konca, a potem *)\r
+ (* wydrukuje sie " il n'ya pas sequence ...." *)\r
+ (* czyli wind "zwija" obiekty az do tego w ktorym jest odpowiedni handler *)\r
+ (* ale nie usuwa tego ostatniego (w przeciwienstwie do terminate) *)\r
+ (* ten tekst jest drukowany w obu przypadkach i wind i terminate *)\r
+ \r
+ \r
+ \r
+program TTT;\r
+signal f(inout x,y : integer),g;\r
+unit ppass : procedure( inout x,y : integer);\r
+ begin\r
+ raise f(x,y);\r
+ call ppass(x,y);\r
+end ppass;\r
+var x,y,z,s : integer;\r
+ \r
+handlers\r
+ when g : s := s+s;\r
+ wind\r
+end handlers;\r
+begin\r
+ block;\r
+ handlers\r
+ when f : if y=0 then raise g fi;\r
+ s := s+x;\r
+ y := y-1;\r
+ return;\r
+ end handlers;\r
+ begin\r
+ readln(x,y);\r
+ z := y;\r
+ call ppass(x,z);\r
+ write("to sie nie wydrukuje , bo wind zwija ten obiert bloku!");\r
+ end;\r
+ writeln("s= :" ,s);\r
+end TT\r
--- /dev/null
+131343131\1a
\ No newline at end of file
--- /dev/null
+000111000001110000000011100001010100010010100001010010010010010100010001010010001100010001000110001100011000\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+program RESNEURONAL;\r
+\r
+(*-------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+(*------------------------------------------------- Definition des outils de gestion de l'envirronement graphique --------------------------------------------------*)\r
+\r
+unit ekran: iiuwgraph class;\r
+ \r
+\r
+ (* Tracage d'une boite *) \r
+ unit box : procedure(x,y,xl,yl,co : integer);\r
+ begin\r
+ call color(co);\r
+ call move(x,y);\r
+ call draw(x+xl,y);\r
+ call draw(x+xl,y+yl);\r
+ call draw(x,y+yl);\r
+ call draw(x,y);\r
+ end box; \r
+ \r
+\r
+\r
+ (* Impression des coefficients non nuls d'une matrice (n*n) *) \r
+ unit circles_in_box : procedure( invers_img,x,y,n:integer , boite :mat );\r
+ var i,j : integer;\r
+ \r
+ begin\r
+ \r
+ for i:=1 to n do\r
+ for j:=1 to n do \r
+ \r
+ (* teste le mode d'impression ("inverse motif" ou non) *)\r
+ if (invers_img=1) then\r
+ if (boite.tab(j,i)=/=0) then call color(1)\r
+ else call color(0) fi\r
+ else \r
+ if (boite.tab(j,i)=/=0) then call color(0)\r
+ else call color(1) fi\r
+ fi; \r
+\r
+ call cirb(x+(i-1)*10,y+(j-1)*10,5,0,0,0,1,1,1);\r
+ call cirb(x+(i-1)*10+1,y+(j-1)*10+1,4,0,0,0,1,1,1); \r
+ call cirb(x+(i-1)*10+2,y+(j-1)*10+2,3,0,0,0,1,1,1);\r
+ call cirb(x+(i-1)*10+3,y+(j-1)*10+3,2,0,0,0,1,1,1);\r
+ call cirb(x+(i-1)*10+4,y+(j-1)*10+4,1,0,0,0,1,1,1)\r
+ \r
+ od\r
+ od\r
+\r
+ end circles_in_box;\r
+\r
+\r
+ \r
+ (* Tracage d'un graphique a partir d'une matrice de reels donnee a une echelle donnee *)\r
+ unit graphique : procedure( tab_don:arrayof integer , posx,posy:integer ,\r
+ val_initx,pasx, val_inity,pasy:real ,\r
+ leg_absc,leg_ord : string );\r
+ var i,j,transl,nouvelx,nouvely : integer;\r
+ begin\r
+ (* Trace des axes *)\r
+ call move(posx,posy); call draw(posx,posy-150);\r
+ call move(posx,posy); call draw(posx+400,posy);\r
+ call move(posx,posy-150); call draw(posx+5,posy-140); \r
+ call move(posx,posy-150); call draw(posx-5,posy-140);\r
+ call move(posx+400,posy); call draw(posx+390,posy-5);\r
+ call move(posx+400,posy); call draw(posx+390,posy+5);\r
+ call grstrwrite(posx+410,posy,leg_absc);\r
+ call grstrwrite(posx,posy-160,leg_ord); \r
+\r
+\r
+ (* Impression du pas *)\r
+ nouvelx:=posx;nouvely:=posy;\r
+ j:=upper(tab_don)-lower(tab_don); transl:=0;\r
+ for i:=0 to j do\r
+ call grintwrite(1,posx+i*(400 DIV j),posy+20,val_inity+i*pasy);\r
+ call grintwrite(1,posx-20,posy-i*(150 DIV j),val_initx+i*pasx);\r
+ call move(nouvelx,nouvely);\r
+ call draw(posx+i*(400 DIV j),posy-tab_don(i+1)*(150 DIV j));\r
+ nouvelx:=posx+i*(400 DIV j); nouvely:=posy-tab_don(i+1)*(150 DIV j);\r
+ transl:=tab_don(i+1)\r
+ od\r
+ end graphique;\r
+\r
+\r
+\r
+\r
+\r
+ (* Ecriture d'un texte *) \r
+ unit grstrwrite : procedure( x,y : real , s:string);\r
+ var a:arrayof char, i:integer;\r
+ begin\r
+ call move(x,y); \r
+ a:=unpack(s);\r
+ for i:=lower(a) to upper(a) do call HASCII(ORD(a(i))) od; \r
+ end grstrwrite ;\r
+\r
+\r
+ (* Ecriture d'un reel quelconque < 10 *)\r
+ unit grintwrite : procedure( co,x,y:integer , nbe:real );\r
+ var i,j:integer;\r
+ begin\r
+ call color(co);\r
+ \r
+ (* On rend d'abord le reel entier *)\r
+ j:=nbe*1000; \r
+\r
+ (* Puis on l'affiche en (x,y) *)\r
+ for i:=0 to 4 do\r
+ call move(x-i*8,y);\r
+ if i=3 then call HASCII(ORD('.'))\r
+ else call HASCII(j MOD 10 +48) ; j:=j DIV 10 fi\r
+ od \r
+ end grintwrite;\r
+\r
+\r
+\r
+\r
+ (* Saisie a la souris des formes proposees par l'utilisateur *) \r
+ unit souris:mouse procedure;\r
+ var b,h,hs,hg,v,vs,vg,p,i,j,val:integer,l,r,c,ecrire,gommer: boolean;\r
+ begin\r
+ val:=1; ecrire:=false; gommer:=false;\r
+\r
+ call box(117,87,196,208,1);\r
+ call grstrwrite(175,285,"F I G U R E");\r
+ call box(119,89,192,192,1);\r
+ call showcursor;\r
+ call box(400,125,140,100,1);\r
+ call grstrwrite(425,210,"S O U R I S");\r
+ call box(403,128,134,75,1);\r
+ call grstrwrite(410,140,"BOUTON 1: LEVE");\r
+ call grstrwrite(410,160,"BOUTON 2: STYLO");\r
+ call grstrwrite(410,180,"BOUTON 3: FIN ");\r
+ \r
+ do\r
+ \r
+ call status(h,v,l,r,c);\r
+ if not(ecrire) then call move(h,v) fi;\r
+ if ecrire then \r
+ j:=entier((h-130) DIV 10)+1;i:=entier((v-100) DIV 10)+1;\r
+ hg:=(j*10)+125;vg:=(i*10)+95; \r
+ if (hg>=135 and hg<=295 and vg>=105 and vg<=265) then\r
+ forme.tab(i+1,j+1):=val;\r
+ call cirb(hg-5,vg-5,5,0,0,0,1,1,1);\r
+ call cirb(hg-4,vg-4,4,0,0,0,1,1,1); \r
+ call cirb(hg-3,vg-3,3,0,0,0,1,1,1);\r
+ call cirb(hg-2,vg-2,2,0,0,0,1,1,1);\r
+ call cirb(hg-1,vg-1,1,0,0,0,1,1,1)\r
+ fi \r
+ fi;\r
+\r
+ hs:=inxpos;vs:=inypos;\r
+ call getpress(0,h,v,p,l,r,c);\r
+ if p=1 then \r
+ ecrire:=not(ecrire);\r
+ if ecrire then\r
+ call color(0); \r
+ call grstrwrite(410,140,"BOUTON 1: LEVE");\r
+ call color(1);\r
+ call grstrwrite(410,140,"BOUTON 1: BAISSE")\r
+ else \r
+ call color(0);\r
+ call grstrwrite(410,140,"BOUTON 1: BAISSE");\r
+ call color(1);\r
+ call grstrwrite(410,140,"BOUTON 1: LEVE") \r
+ fi;\r
+ if gommer then call color(0) fi\r
+ fi;\r
+ call move(hs,vs); \r
+ \r
+ hs:=inxpos;vs:=inypos;\r
+ call getpress(2,h,v,p,l,r,c);\r
+ if p=1 then \r
+ gommer:=not(gommer);\r
+ if gommer then\r
+ val:=0;\r
+ call color(0);\r
+ call grstrwrite(410,160,"BOUTON 2: STYLO");\r
+ call color(1);\r
+ call grstrwrite(410,160,"BOUTON 2: GOMME");\r
+ call color(0) \r
+ else\r
+ val:=1; \r
+ call color(0);\r
+ call grstrwrite(410,160,"BOUTON 2: GOMME");\r
+ call color(1);\r
+ call grstrwrite(410,160,"BOUTON 2: STYLO");\r
+ call color(1)\r
+ fi\r
+ fi; \r
+ call move(hs,vs);\r
+\r
+ call getpress(1,h,v,p,l,r,c);\r
+ if p=1 then exit fi\r
+ od\r
+\r
+ end souris;\r
+\r
+ \r
+ unit introduction : mouse procedure;\r
+ var f:file,\r
+ i,j,hg,vg,p,h,v:integer,\r
+ l,r,c : boolean,\r
+ figure:arrayof arrayof integer;\r
+ begin\r
+ array figure dim (1:35);\r
+ for i:=1 to 35 do array figure(i) dim (1:72) od;\r
+\r
+ open(f,integer,unpack("PRESENTATION"));\r
+ call reset(f);\r
+ for i:=1 to 35 do for j:=1 to 72 do \r
+ get(f,figure(i,j)) \r
+ od od; \r
+ kill(f);\r
+ \r
+ call cls;\r
+ call color(1);\r
+ for j:=1 to 72 do for i:=1 to 35 do \r
+ call move(360,30); \r
+ hg:=((j-1)*10)+5;vg:=((i-1)*10)+5; \r
+ if figure(i,j)=1 then \r
+ call draw(hg-1,vg-1); call draw(hg+1,vg-1);\r
+ call draw(hg+1,vg+1); call draw(hg-1,vg+1);\r
+ call draw(hg-1,vg-1); call draw(hg,vg);\r
+\r
+ call cirb(hg-5,vg-5,5,0,0,0,1,1,1);\r
+ call cirb(hg-4,vg-4,4,0,0,0,1,1,1);\r
+ call cirb(hg-3,vg-3,3,0,0,0,1,1,1);\r
+ call cirb(hg-2,vg-2,2,0,0,0,1,1,1);\r
+ call cirb(hg-1,vg-1,1,0,0,0,1,1,1);\r
+ fi \r
+ od od; \r
+ call grstrwrite(110,40,"TOTAL Jaimie");\r
+ call grstrwrite(520,40,"SAINT-JEAN Patrick");\r
+ call grstrwrite(335,310,"CLIQUER"); \r
+ call box(300,300,120,30,1);\r
+ \r
+ do\r
+ call getpress(0,h,v,p,l,r,c);\r
+ if p=1 then exit fi;\r
+ call getpress(1,h,v,p,l,r,c);\r
+ if p=1 then exit fi;\r
+ call getpress(2,h,v,p,l,r,c);\r
+ if p=1 then exit fi;\r
+ od\r
+\r
+ end introduction;\r
+\r
+\r
+\r
+\r
+\r
+ unit presentation : procedure;\r
+ begin \r
+ call cls;\r
+ call box(40,20,600,60,1);\r
+ call box(42,22,596,56,1);\r
+ call box(17,5,646,340,1);\r
+ call box(20,8,640,295,1);\r
+ call box(20,312,480,30,1);\r
+ call grstrwrite(155,325,"R E S E A U N E U R O N A L");\r
+ call box(502,312,158,30,1); \r
+ call grstrwrite(567,318,"TOTAL");\r
+ call grstrwrite(542,330,"SAINT - JEAN")\r
+ end presentation;\r
+\r
+\r
+\r
+ unit parties : procedure ( s:string );\r
+ begin\r
+ call cls;\r
+ call box(200,140,320,68,1); call grstrwrite(286,173,s);\r
+ for i:=1 to 50000 do od;\r
+ end;\r
+\r
+\r
+\r
+ unit affichage : procedure ( num : integer );\r
+ var i,j:integer;\r
+ begin\r
+ case num \r
+ when 1 :\r
+ (* Presentation graphique de l'apprentissage : *)\r
+ call presentation;\r
+ call grstrwrite(135,45,"APPRENTISSAGE DES MOTIFS DE LA PREMIERE COUCHE");\r
+ call box(40,260,600,20,1);\r
+ call grstrwrite(185,267,"niveau d'apprentissage de chaque motif");\r
+\r
+ (* Affichage du 1er motif *)\r
+ call box(55,200,20,40,1); call box(49,129,32,32,1);\r
+ call circles_in_box(1,50,130,3,motif(1))\r
+\r
+\r
+\r
+ when 2 :\r
+ for i:=1 to 25000 do od;\r
+ call presentation;\r
+ call grstrwrite(120,45,\r
+ "FIN DE L'APPRENTISSAGE DES MOTIFS DE LA PREMIERE COUCHE");\r
+ call grstrwrite(100,180,\r
+ "Le reseau est a meme de reconnaitre l'ensemble de ces motifs");\r
+\r
+ for i:=1 to 100000 do od;\r
+\r
+\r
+\r
+ when 3 :\r
+ call presentation;\r
+ call grstrwrite(225,45,"CONTROLE DES CONNAISSANCES");\r
+ \r
+\r
+\r
+ when 4:\r
+ (* Affichage des formes saisis *) \r
+ call box(220,105,220,20,1);\r
+ call grstrwrite(240,112,"FORME A RECONNAITRE ...");\r
+ call box(324,129,32,32,1); \r
+ call circles_in_box(1,325,130,3,motif(1));\r
+ call box(180,170,310,20,1);\r
+ call grstrwrite(200,176,"... PARMIS LES FORMES PRESENTEES");\r
+ call box(100,250,410,20,1);\r
+ call grstrwrite(120,256,"... AVEC UN COEFFICIENT DE SELECTIVITE DE :");\r
+ call box(520,250,50,20,1);\r
+ \r
+ for i:=1 to 9 do \r
+ (* Affichage des motifs *) \r
+ call box(65*i-1,199,32,32,1);\r
+ call circles_in_box(1,65*i,200,3,formes_test(i))\r
+ od; \r
+\r
+ for i:=1 to 15000 do od\r
+\r
+\r
+\r
+ when 5:\r
+ call grintwrite(1,560,256,k_selectivite);\r
+ for i:=1 to 4 do\r
+ call box(518,248,54,24,1);call box(519,249,52,22,1);\r
+ for k:=1 to 2000 do od;\r
+ call box(518,248,54,24,0);call box(519,249,52,22,0);\r
+ for k:=1 to 2000 do od\r
+ od\r
+\r
+\r
+\r
+ when 7 :\r
+ for i:=1 to 30000 do od;\r
+\r
+ call presentation;\r
+ call grstrwrite(200,45,"CONCLUSIONS SUR LE TEST");\r
+ call grstrwrite(60,100,\r
+ " Nous nous apercevons donc que, plus le coefficient de selectivite");\r
+ call grstrwrite(60,130,\r
+ "augmente, et moins les formes sont considerees comme proche du modele");\r
+ call grstrwrite(60,160,"presente .");\r
+ call grstrwrite(60,190,\r
+ "De plus, cela permet de supposer que le NEOCOGNITRON reconnait ( en");\r
+ call grstrwrite(60,220,\r
+ "generalisant a tous les motifs de l'apprentissage ) des formes pro-");\r
+ call grstrwrite(60,250,"ches des modeles qui lui sont connus .");\r
+ call grstrwrite(60,280,\r
+ " Choisissons la valeur du coefficient a partir de cette etude ...");\r
+\r
+ for i:=1 to 300000 do od;\r
+\r
+ call presentation;\r
+ call grstrwrite(140,45,"VISUALISATION GRAPHIQUE DES RESULTATS DU TEST")\r
+ \r
+\r
+\r
+ when 8 :\r
+ (* Impression du graphique *)\r
+ call graphique(tab_result,100,250,0,1,1.125,0.125,"K_SELECTIVITE",\r
+ "NBE DE FORMES RECONNUES"); \r
+\r
+ for i:=1 to 150000 do od;\r
+ \r
+ call box(300,100,320,40,1);\r
+ call grstrwrite(340,110,"On choisira un coefficient de:");\r
+ call grstrwrite(340,125," 2.0");\r
+\r
+ for i:=1 to 150000 do od\r
+ \r
+\r
+ \r
+ when 9 :\r
+ call presentation;\r
+ call grstrwrite(180,45,"APPLICATION A UN MOTIF PLUS COMPLEXE");\r
+ for i:=1 to 30000 do od;\r
+\r
+ call presentation;\r
+ call grstrwrite(200,45,"SAISIE DE LA FORME A LA SOURIS");\r
+ call souris; \r
+\r
+ (* Saisie de la visualisation graphique du motif *)\r
+ call move(117,87);tab_graph:=fenetre.getmap(313,295);\r
+\r
+ (* Recherche des parties proche d'un des motifs connus de la 1ere couche *)\r
+ call presentation;\r
+ call grstrwrite(100,45,\r
+ "RECHERCHE DE CHACUN DES MOTIFS SUR LA FORME PRESENTEE");\r
+ \r
+ (* Mise en place graphique de la forme,du motif cherche sur la forme et de la matrice de sortie de la 1ere couche *)\r
+ call move(90,87); call putmap(tab_graph);\r
+ call box(400,97,176,188,1); call box(402,99,172,172,1);\r
+ call grstrwrite(442,275,"SORTIE PLAN");\r
+ call box(303,166,80,60,1); call box(303,236,80,40,1);\r
+ call grstrwrite(318,262,"CHERCHE");\r
+ call grstrwrite(325,245,"MOTIF");\r
+ call move(400,97); tab_graph:=getmap(576,285) \r
+\r
+\r
+ \r
+ when 10 : \r
+ (* Superposition des 12 plans *)\r
+ call presentation;\r
+ call grstrwrite(50,45,\r
+ "RECAPITULATIF DES SORTIES DES 12 PLANS DE NEURONES DE LA COUCHE");\r
+ \r
+ (* Recapitulatif graphique des sorties de chacun des 12 plans *)\r
+ for i:=1 to 12 do\r
+ call move(225,97);call putmap(res_final(i));\r
+ for j:=1 to 3000 do od; \r
+ call move(225,97);call putmap(tab_graph); \r
+ od;\r
+\r
+ for i:=1 to 20000 do od;\r
+\r
+ call presentation;\r
+ call grstrwrite(100,45,\r
+ "SUPERPOSITION DES 12 PLANS DE SORTIE DE LA PREMIERE COUCHE");\r
+ \r
+ for i:=1 to 15000 do od;\r
+\r
+ (* Superposition des 12 plans *) \r
+ for i:=1 to 12 do\r
+ call move(225,97);call ormap(res_final(i));\r
+ for j:=1 to 5000 do od; \r
+ od;\r
+\r
+ for i:=1 to 50000 do od; \r
+\r
+ call presentation;\r
+ call grstrwrite(290,45,"CONCLUSIONS");\r
+ call grstrwrite(250,150,\r
+ "ON OBTIENT BIEN LA FIGURE DONNEE");\r
+ call grstrwrite(200,200, \r
+ "SEULEMENT A L'AIDE DE CES 12 MOTIFS ELEMENTAIRES");\r
+ \r
+ for i:=1 to 100000 do od\r
+\r
+\r
+\r
+\r
+ when 11 : call parties("P A R T I E A")\r
+ when 12 : call parties("P A R T I E B") \r
+ when 13 : call parties("P A R T I E C")\r
+\r
+ when 14 : call parties(" F I N")\r
+\r
+ esac\r
+\r
+ end affichage;\r
+\r
+begin\r
+\r
+ call gron(2);call border(0);call color(1);\r
+\r
+\r
+end ekran;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+\r
+(* Definition d'une matrice (n*n) *)\r
+unit mat : class (n : integer);\r
+ var tab : arrayof arrayof real,\r
+ i : integer; \r
+begin\r
+ array tab dim (1:n);\r
+ for i:=1 to n do array tab(i) dim (1:n) od;\r
+end mat;\r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+(* Definition du resultat du test presente apres l'apprentissage *)\r
+unit resultat_test : class;\r
+\r
+ unit elem2 : class;\r
+ var nb_rec : integer,\r
+ forme : arrayof integer;\r
+ begin\r
+ array forme dim (1:9)\r
+ end elem2;\r
+\r
+ var i:integer,\r
+ tab : arrayof elem2;\r
+begin\r
+ array tab dim (1:10);\r
+ for i:=1 to 10 do tab(i):=new elem2 od\r
+end resultat_test;\r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+\r
+(* Definition de la premiere couche *)\r
+unit tabcouche1 : class;\r
+\r
+ unit elem : class;\r
+ (* Matrice des poids du motif du plan considere *)\r
+ var tpoids1 : mat;\r
+\r
+ (* Valeur d'inhibition du motif *)\r
+ var poidsinhibe1 : real;\r
+ \r
+ (* Sorties de la premiere couche *)\r
+ var sortie1 : arrayof arrayof integer;\r
+ end elem;\r
+\r
+ \r
+ (* structure de la table des neurones *)\r
+ var plans1 : arrayof elem;\r
+ \r
+ (* Plans d'inhibition *)\r
+ var distance1 : arrayof mat;\r
+ \r
+ (* Fichier contenant les valeurs de pre-initialisation de la matrice des distances *)\r
+ var i,j: integer,\r
+ c : char;\r
+\r
+(* initialisation des differentes tables *) \r
+begin\r
+\r
+\r
+ (* La 1ere couche est constituee de 12 plans (12 motifs differents) *)\r
+ array plans1 dim (1:12);\r
+\r
+\r
+ (* initialisation des elements de la table des plans *)\r
+ for i:=1 to 12\r
+ do\r
+ plans1(i):= new elem;\r
+ (* initialisation de la matrice des poids de chacun des 12 plans *)\r
+ plans1(i).tpoids1 := new mat(3);\r
+ \r
+ (* initialisation de la valeur d'inhibition de chaque plan *)\r
+ plans1(i).poidsinhibe1 := 0; \r
+ \r
+ (* initialisation de la table des neurones de la couche *)\r
+ array plans1(i).sortie1 dim (1:17); \r
+ for j:=1 to 17 do array plans1(i).sortie1(j) dim (1:17) od;\r
+\r
+ od; \r
+\r
+ \r
+ (* Saisie de la matrice des distances , cette matrice est initialisee une fois pour toute .\r
+ On observe une ponderation decroissante du centre vers l'exterieur. \r
+ La matrice des distance est initialisee a des petites valeurs en la normant *)\r
+\r
+ distance1 := saisie(1,"D");\r
+ call fenetre.cls;\r
+\r
+ for i:=1 to 3 do\r
+ for j:=1 to 3 do\r
+ distance1(1).tab(i,j) := distance1(1).tab(i,j)/(2*SQRT(17))\r
+ od\r
+ od\r
+ \r
+ \r
+ \r
+end tabcouche1;\r
+\r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+(* Fonction de saisie de fichiers texte .\r
+ Pour simplifier la saisie,le nom du fichier sera arrete a 1 seul caractere \r
+ -----------------------------------------------------------------------------*)\r
+ \r
+unit saisie : function (tail_tab : integer,nom_fic: string) : arrayof mat;\r
+\r
+ var f:file,\r
+ i,j,k : integer,\r
+ c : char; \r
+\r
+\r
+begin\r
+\r
+ (* ouverture du fichier contenant les motifs en lecture *)\r
+ open(f,text,unpack(nom_fic));\r
+ (* Positionnement en debut de fichier *)\r
+ call RESET(f);\r
+\r
+\r
+ (* Initialisation du tableau des motifs :\r
+ il y a tail_tab motifs differents ... *)\r
+ array result dim (1:tail_tab);\r
+ (* ... et chaque motif est constitue d'un tableau (3*3) de reels *) \r
+ for k:=1 to tail_tab do result(k):=new mat(3) od;\r
+ \r
+ \r
+\r
+ (* Remplissage de la table des motifs saisis *) \r
+ for k:=1 to tail_tab do\r
+ for i:=1 to 3 do for j:=1 to 3 do \r
+ read(f,c);result(k).tab(i,j):=ord(c)-48\r
+ od od\r
+ od;\r
+ \r
+ (* Fermeture fichier *)\r
+ kill(f) \r
+\r
+end saisie;\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+ \r
+(* En plus d'initialiser la 1ere couche , cette coroutine effectue l'apprentissage des formes qui doivent etre connues . \r
+ -----------------------------------------------------------------------------------------------------------------------*)\r
+\r
+unit ajuste_poids_1 : coroutine(nb_cor:integer);\r
+\r
+ var i,j,k,t : integer,\r
+ total,som_inhib : real,\r
+ c : char,\r
+\r
+ cor : ajuste_poids_1;\r
+ \r
+begin\r
+\r
+ (* initialisation du poids d'inhibition *)\r
+ som_inhib:=0;\r
+ for i:=1 to 3 do for j:=1 to 3 do \r
+ som_inhib := som_inhib + (motif(nb_cor).tab(i,j)*couche.distance1(1).tab(i,j))\r
+ od od;\r
+ som_inhib := SQRT(som_inhib);\r
+\r
+\r
+ (* Creation de toutes les coroutines ,1 pour l'apprentissage de chacun des 12 motifs *)\r
+ if nb_cor<12 then\r
+\r
+ (* Creation de la coroutine d'apprentissage du motif (nb_cor + 1) *)\r
+ cor:=new ajuste_poids_1(nb_cor+1);\r
+\r
+ (* Affichage des motifs *) \r
+ call fenetre.box(50*(nb_cor+1)+5,200,20,40,1);\r
+ call fenetre.box(50*(nb_cor+1)-1,129,32,32,1);\r
+ call fenetre.circles_in_box(1,50*(nb_cor+1),130,3,motif(nb_cor+1));\r
+\r
+ fi;\r
+\r
+ return;\r
+\r
+ t:=239;\r
+ (* Apprentissage du motif nb_cor *)\r
+ for k:=1 to 200 do\r
+ \r
+ (* Impression physique de la coroutine traitee *)\r
+ call fenetre.box(50*nb_cor-3,127,36,36,1);\r
+ (* Impression du pourcentage d'apprentissage *)\r
+ if (k MOD 5)=0 then \r
+ call fenetre.move(50*nb_cor+5,t);\r
+ call fenetre.draw(50*nb_cor+25,t);\r
+ t:=t-1\r
+ fi; \r
+ \r
+ (* On attend la fin de l'execution des coroutines suivantes *)\r
+ if nb_cor<12 then\r
+ attach(cor)\r
+ fi;\r
+\r
+ (* Renforcement des poids du motif etudie *)\r
+ for i:=1 to 3 do\r
+ for j:=1 to 3 do\r
+ couche.plans1(nb_cor).tpoids1.tab(i,j) := couche.plans1(nb_cor).tpoids1.tab(i,j)\r
+ + ( k_appr*motif(nb_cor).tab(i,j) * couche.distance1(1).tab(i,j) );\r
+ od\r
+ od;\r
+\r
+ (* calcul du poids d'inhibition *)\r
+ couche.plans1(nb_cor).poidsinhibe1 := couche.plans1(nb_cor).poidsinhibe1 \r
+ + k_appr*som_inhib;\r
+\r
+ call fenetre.box(50*nb_cor-3,127,36,36,0);\r
+ \r
+ \r
+ detach\r
+ \r
+ od\r
+\r
+\r
+\r
+end ajuste_poids_1;\r
+\r
+\r
+\r
+\r
+ \r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+(* Cette coroutine effectue le traitement de la reconnaissance des motifs\r
+ de la 1ere couche .\r
+ Elle effectue 2 traitements : celui du test de fiabilite de la methode\r
+ sur des formes simples , puis la reconnaissance de formes donnees plus\r
+ complexes .\r
+ -------------------------------------------------------------------------*)\r
+\r
+unit filtre : coroutine (num_essai,nb_cor,cor_traite,plan : integer);\r
+ \r
+\r
+ (* Cette fonction calcule la valeur de sortie d'un neurone de la couche *)\r
+ unit calcul_sortie : function(forme : mat , plan_traite : integer):integer;\r
+ var i,j : integer,\r
+ valeur,som,som_inhib: real;\r
+ begin\r
+\r
+ som,som_inhib := 0;\r
+ for i:=1 to 3 do for j:=1 to 3 do\r
+ som:= som + forme.tab(i,j)*couche.plans1(plan_traite).tpoids1.tab(i,j);\r
+ som_inhib := som_inhib + forme.tab(i,j)*couche.distance1(1).tab(i,j) \r
+ od od;\r
+ som_inhib := couche.plans1(plan_traite).poidsinhibe1*SQRT(som_inhib);\r
+\r
+\r
+ (* Valeur de sortie du neurone considere *)\r
+ valeur := (1 + som)/(1 + k_selectivite/(1 + k_selectivite)*som_inhib) - 1;\r
+\r
+ if valeur>0 then \r
+ result:=1\r
+ fi \r
+ \r
+ end calcul_sortie;\r
+ \r
+\r
+ \r
+ var i1,i2,j1,j2 : integer,\r
+ c : char,\r
+\r
+ mat_traite,bidon : mat,\r
+ cor : filtre;\r
+\r
+begin\r
+ \r
+ (* Creation des filtres correspondant au nombre de plans *)\r
+ if (nb_cor>cor_traite) then\r
+ cor := new filtre(num_essai,nb_cor,cor_traite+1,plan+1);\r
+ fi;\r
+\r
+ return;\r
+\r
+\r
+ if (nb_cor>cor_traite) then attach(cor) fi;\r
+\r
+ mat_traite := new mat(3);\r
+ if nb_cor=12 then\r
+ (* Formes compliquees *)\r
+\r
+ (* Affichage du motif recherche sur la forme proposee *)\r
+ call fenetre.box(328,180,32,32,1);\r
+ call fenetre.circles_in_box(1,329,181,3,motif(cor_traite));\r
+ \r
+ (* Creation d'une matrice d'entiers bidon de taille 1 afin d'utiliser la fonction 'circle_in_box' *)\r
+ bidon:=new mat(1);\r
+\r
+ for i1:=1 to 17 do\r
+ for j1:=1 to 17 do\r
+ \r
+ for i2:=1 to 3 do for j2:=1 to 3 do\r
+ mat_traite.tab(i2,j2) := forme.tab(i1+i2-1,j1+j2-1) \r
+ od od;\r
+ \r
+ if calcul_sortie(mat_traite,plan)=1 then\r
+ couche.plans1(plan).sortie1(i1,j1) := 1; bidon.tab(1,1):=1;\r
+ for i2:=1 to 3 do \r
+ call fenetre.circles_in_box(0,83+(j1*10),80+(i1*10),3,mat_traite);\r
+ call fenetre.circles_in_box(1,83+(j1*10),80+(i1*10),3,mat_traite);\r
+ od;\r
+ call fenetre.circles_in_box(1,393+(j1*10),90+(i1*10),1,bidon)\r
+ fi; \r
+\r
+ od\r
+ od;\r
+\r
+ for i1:=1 to 30000 do od;\r
+\r
+ (* Sauvegarde graphique de la matrice de sortie du plan traite *)\r
+ call fenetre.move(400,97);res_final(cor_traite):=fenetre.getmap(576,285); \r
+\r
+ (* Nettoyage graphique de la matrice de sortie du plan 'cor_traite' *) \r
+ call fenetre.move(400,97); call fenetre.putmap(tab_graph)\r
+\r
+ else\r
+\r
+ (* Formes simples du fichier de test *)\r
+ mat_traite := formes_test(plan);\r
+\r
+ if calcul_sortie(mat_traite,plan)=1 then\r
+ (* Nombre de formes considerees comme proche du 1er motif (celui presente) par le reseau *)\r
+ resultat.tab(num_essai).nb_rec := resultat.tab(num_essai).nb_rec + 1; \r
+ (* Permet de savoir si la forme nb_cor du jeu de test est consideree comme proche du 1er motif *)\r
+ resultat.tab(num_essai).forme(cor_traite):=1\r
+ fi;\r
+\r
+ fi;\r
+\r
+ detach\r
+\r
+end filtre;\r
+ \r
+ \r
+ \r
+\r
+\r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------------------------------------------------------------------------------------------------------*)\r
+\r
+\r
+ var c : char,\r
+ k_selectivite : real,\r
+ i,j,k,k_appr : integer,\r
+\r
+ tab_result,tab_graph : arrayof integer,\r
+ res_final : arrayof arrayof integer,\r
+ resultat : resultat_test,\r
+ forme : mat,\r
+ motif,formes_test : arrayof mat,\r
+ apprend : ajuste_poids_1,\r
+ verif,chercher : filtre,\r
+ couche : tabcouche1,\r
+ fenetre : ekran;\r
+ \r
+\r
+\r
+\r
+\r
+(*------------------------------------------------------------------ Programme principal ---------------------------------------------------------------------------*)\r
+\r
+begin\r
+\r
+ (* les constantes d'apprentissage et de selectivite des formes sont fixees arbitrairement *)\r
+ k_appr := 10;\r
+\r
+ write(chr(27),"[2J",chr(27),"[H");\r
+ \r
+ (* ouverture d'une fenetre *)\r
+ fenetre := new ekran;\r
+\r
+ call fenetre.introduction;\r
+\r
+ (* Saisie de la table des motifs *) \r
+ motif := saisie(12,"M");\r
+ \r
+ (* Creation de la premiere couche *)\r
+ couche := new tabcouche1;\r
+\r
+ \r
+\r
+ (*------------------------------------------- Phases d'initialisation de la 1ere couche et apprentissage des motifs ---------------------------------------------*)\r
+\r
+ call fenetre.affichage(11); call fenetre.affichage(1);\r
+ \r
+ apprend := new ajuste_poids_1(1);\r
+ for i:=1 to 200 do attach(apprend) od;\r
+\r
+ call fenetre.affichage(2);\r
+ \r
+\r
+ (*------------------------------------------------------------------- Filtrage des formes ----------------------------------------------------------------------*) \r
+\r
+ (*------------------------------------------- D'abord ,on verifie la methode sur des exemples simples -----------------------------------------------------*) \r
+\r
+ \r
+ call fenetre.affichage(12); call fenetre.affichage(3); \r
+ \r
+ (* Saisie du fichier contenant les formes simples *)\r
+ formes_test := saisie(9,"T");\r
+\r
+ call fenetre.affichage(4);\r
+ \r
+\r
+ (* Verification de la methode et modulation du coefficient de selectivite,\r
+ afin de montrer que plus le coefficient est important et plus les formes reconnus sont proches du motif recherche *) \r
+ \r
+ (* Creation de la matrice des resultats *)\r
+ resultat:=new resultat_test; \r
+\r
+ for j:=1 to 10 do\r
+ k_selectivite:=1+j/8;\r
+ call fenetre.affichage(5);\r
+ verif := new filtre(j,9,1,1); \r
+ attach(verif);\r
+\r
+ (* Presentation du resultat avec ce coefficient de selectivite k_selectivite *)\r
+ for i:=1 to 9 do \r
+ if resultat.tab(j).forme(i)=1 then\r
+ call fenetre.box( (65*i)-2,198,34,34,1);\r
+ call fenetre.box( (65*i)-3,197,36,36,1)\r
+ fi\r
+ od;\r
+\r
+ for i:=1 to 30000 do od;\r
+ call fenetre.grintwrite(0,560,256,k_selectivite);\r
+ for i:=1 to 9 do \r
+ if resultat.tab(j).forme(i)=1 then\r
+ call fenetre.box( (65*i)-2,198,34,34,0);\r
+ call fenetre.box( (65*i)-3,197,36,36,0)\r
+ fi\r
+ od\r
+ od;\r
+\r
+ call fenetre.affichage(7); \r
+ \r
+ (* Recuperation des resultats dans une table d'entiers *)\r
+ array tab_result dim(1:10);\r
+ for i:=1 to 10 do \r
+ tab_result(i):=resultat.tab(i).nb_rec;\r
+ od;\r
+\r
+ call fenetre.affichage(8);\r
+\r
+\r
+ (*------------------------------------------------ Application a un motif plus complexe ----------------------------------*)\r
+\r
+ (* Creation de la retine *) \r
+ forme := new mat(19);\r
+ \r
+ call fenetre.affichage(13); call fenetre.affichage(9);\r
+\r
+ (* Creation matrice des resultats pour affichage final *)\r
+ array res_final dim (1:12);\r
+\r
+ (* Mise en place de la reconnaissance des 12 motifs dans la forme proposee *)\r
+ chercher := new filtre(1,12,1,1);\r
+ \r
+ k_selectivite := 2;\r
+ attach(chercher);\r
+ \r
+ call fenetre.affichage(10);\r
+\r
+ call fenetre.affichage(14);\r
+\r
+ (* Fermeture de la fenetre *)\r
+ call fenetre.groff;\r
+\r
+end RESNEURONAL;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+000111000111000000100011000100111000110111000111111000111111100111111110101010000\1a
\ No newline at end of file
--- /dev/null
+PROGRAM TestWindow;\r
+\r
+BEGIN\r
+ PREF IIUWGRAPH BLOCK\r
+\r
+(* -------------------- Limites de l'\82cran -------------------- *)\r
+\r
+ CONST XTailleEcran=638, YTailleEcran=348;\r
+\r
+\r
+(* ================================================================== *)\r
+(* CLASSE Fenetre *) \r
+(* ================================================================== *)\r
+\r
+UNIT Fenetre : CLASS (x,y,largeur,hauteur,numero : INTEGER);\r
+ \r
+ VAR ArrierePlan : ARRAYOF INTEGER,\r
+ BufferFenetre : ARRAYOF INTEGER,\r
+ ContenuFenetre : ARRAYOF INTEGER,\r
+ Buffer : ARRAYOF INTEGER,\r
+ Titre : ARRAYOF CHAR,\r
+ Active : BOOLEAN,\r
+ CurseurX,CurseurY,x1,y1 : INTEGER;\r
+\r
+\r
+(* -------------------- PROCEDURE InitFenetre -------------------- *)\r
+\r
+UNIT InitFenetre : PROCEDURE;\r
+ VAR Cx, Cy, i, k : INTEGER;\r
+\r
+BEGIN\r
+ IF Active\r
+ THEN \r
+ Cx:=CurseurX; Cy:=CurseurY;\r
+ CALL MettreCurseur(0,0);\r
+ CALL OUTSTRING("Fen\88tre ");\r
+ CALL HASCII(0); CALL HASCII(numero+48);\r
+ CurseurX:=Cx; CurseurY:=Cy;\r
+ k:=8*9;\r
+ CALL COLOR(1);\r
+ CALL STYLE(4);\r
+ FOR i:=1 TO 7\r
+ DO\r
+ CALL MOVE(x+k,y+i); CALL HFILL(x1-8);\r
+ CALL MOVE(x1-i,y+1); CALL VFILL(y1-1); \r
+ CALL MOVE(x+1,y1-i); CALL HFILL(x1-1);\r
+ CALL MOVE(x+i,y+10); CALL VFILL(y1-1);\r
+ OD;\r
+ CALL STYLE(1);\r
+ FI;\r
+END InitFenetre;\r
+\r
+\r
+(* -------------------- PROCEDURE MettreCurseur -------------------- *)\r
+\r
+UNIT MettreCurseur : PROCEDURE (ligne, colonne : INTEGER);\r
+\r
+BEGIN\r
+ CurseurX:=x+8*colonne;\r
+ CurseurY:=y+10*ligne;\r
+ IF Active \r
+ THEN CALL MOVE(CurseurX,CurseurY);\r
+ FI;\r
+END MettreCurseur;\r
+\r
+\r
+(* -------------------- PROCEDURE SauveFenetre -------------------- *)\r
+\r
+UNIT SauveFenetre : PROCEDURE;\r
+\r
+BEGIN\r
+ IF Active\r
+ THEN\r
+ CALL MOVE(x,y);\r
+ BufferFenetre:=GETMAP(x1,y1);\r
+ Active:=FALSE;\r
+ FI;\r
+END SauveFenetre;\r
+\r
+\r
+(* -------------------- PROCEDURE CacheFenetre -------------------- *)\r
+\r
+UNIT CacheFenetre : PROCEDURE;\r
+\r
+BEGIN\r
+ IF Active \r
+ THEN CALL MOVE(x,y);\r
+ BufferFenetre:=GETMAP(x1,y1);\r
+ CALL XORMAP(BufferFenetre);\r
+ CALL MOVE(x,y);\r
+ CALL PUTMAP(ArrierePlan);\r
+ KILL(ArrierePlan);\r
+ Active:=FALSE;\r
+ FI;\r
+END CacheFenetre;\r
+ \r
+\r
+(* -------------------- PROCEDURE AfficheFenetre -------------------- *)\r
+\r
+UNIT AfficheFenetre : PROCEDURE;\r
+\r
+BEGIN\r
+ IF NOT Active\r
+ THEN\r
+ CALL MOVE(x,y);\r
+ ArrierePlan:=GETMAP(x1,y1);\r
+ CALL XORMAP(ArrierePlan);\r
+ CALL MOVE(x,y);\r
+ CALL PUTMAP(BufferFenetre);\r
+ KILL(BufferFenetre);\r
+ Active:=TRUE;\r
+ FI;\r
+END AfficheFenetre;\r
+\r
+\r
+(* -------------------- PROCEDURE EffaceFenetre -------------------- *)\r
+\r
+UNIT EffaceFenetre : PROCEDURE;\r
+\r
+BEGIN\r
+ IF Active\r
+ THEN\r
+ CALL MOVE(x+8,y+8);\r
+ ContenuFenetre:=GETMAP(x1-8,y1-8);\r
+ CALL XORMAP(ContenuFenetre);\r
+ KILL(ContenuFenetre);\r
+ CALL MettreCurseur(1,1);\r
+ FI;\r
+END EffaceFenetre;\r
+\r
+\r
+(* -------------------- PROCEDURE DeplaceFenetre -------------------- *)\r
+\r
+UNIT DeplaceFenetre : PROCEDURE (dx, dy : INTEGER);\r
+\r
+BEGIN\r
+ IF x=0 AND dx<0 THEN EXIT FI;\r
+ IF y=0 AND dy<0 THEN EXIT FI;\r
+ IF x1=XTailleEcran AND dx>0 THEN EXIT FI;\r
+ IF y1=YTailleEcran AND dy>0 THEN EXIT FI;\r
+ IF x+dx<0 THEN dx:=-x FI;\r
+ IF y+dy<0 THEN dy:=-y FI;\r
+ CurseurX:=(CurseurX-x)/8;\r
+ CurseurY:=(CurseurY-y)/10;\r
+ IF Active\r
+ THEN\r
+ CALL MOVE(x,y);\r
+ IF ContenuFenetre=/=none THEN KILL(ContenuFenetre) FI;\r
+ BufferFenetre:=GETMAP(x1,y1);\r
+ FI;\r
+ IF x1+dx>XTailleEcran THEN dx:=XTailleEcran-x1 FI;\r
+ IF y1+dy>YTailleEcran THEN dy:=YTailleEcran-y1 FI;\r
+ x:=x+dx;\r
+ y:=y+dy;\r
+ x1:=x1+dx;\r
+ y1:=y1+dy;\r
+ IF Active\r
+ THEN\r
+ CALL XORMAP(BufferFenetre);\r
+ CALL MOVE(x,y);\r
+ CALL PUTMAP(BufferFenetre);\r
+ KILL(BufferFenetre);\r
+ FI;\r
+ CALL MettreCurseur(CurseurY,CurseurX);\r
+END DeplaceFenetre;\r
+\r
+\r
+(* -------------------- PROCEDURE ChangeTaille -------------------- *)\r
+\r
+UNIT ChangeTaille : PROCEDURE (dc, dl : INTEGER);\r
+ \r
+ VAR x2,y2 : INTEGER;\r
+\r
+BEGIN\r
+ IF Active\r
+ THEN\r
+ IF x1+8>XTailleEcran AND dc>0 THEN EXIT FI;\r
+ IF y1+10>YTailleEcran AND dl>0 THEN EXIT FI;\r
+ x2:=x1+8*dc;\r
+ y2:=y1+10*dl;\r
+ IF x2<x+24 \r
+ THEN largeur:=3\r
+ ELSE IF x2>XTailleEcran\r
+ THEN largeur:=(XTailleEcran-x)/8\r
+ ELSE \r
+ largeur:=largeur+dc\r
+ FI;\r
+ FI;\r
+ IF y2<y+30\r
+ THEN hauteur:=2 \r
+ ELSE IF y2>YTailleEcran \r
+ THEN hauteur:=(YTailleEcran-y)/10\r
+ ELSE\r
+ hauteur:=hauteur+dl\r
+ FI;\r
+ FI;\r
+ x2:=x+8*largeur;\r
+ y2:=y+10*hauteur;\r
+ IF x2<x1 THEN CurseurX:=x+8 FI;\r
+ IF y2<y1 THEN CurseurY:=y+10 FI;\r
+ CALL MOVE(IMIN(x1,x2)-8,y);\r
+ Buffer:=GETMAP(IMAX(x1,x2),IMAX(y1,y2));\r
+ CALL XORMAP(Buffer);\r
+ KILL(Buffer);\r
+ CALL MOVE(x,IMIN(y1,y2)-10);\r
+ Buffer:=GETMAP(IMIN(x1,x2),IMAX(y1,y2));\r
+ CALL XORMAP(Buffer);\r
+ KILL(Buffer);\r
+ x1:=x2;\r
+ y1:=y2;\r
+ CALL InitFenetre;\r
+ FI;\r
+END ChangeTaille;\r
+\r
+\r
+(* -------------------- PROCEDURE SaisirChaine -------------------- *)\r
+\r
+UNIT SaisirChaine : PROCEDURE (INOUT chaine : ARRAYOF CHAR;\r
+ OUTPUT long : INTEGER);\r
+ VAR touche,i,col,lig : INTEGER;\r
+\r
+BEGIN\r
+ IF Active\r
+ THEN\r
+ i:=LOWER(chaine);\r
+ CALL MOVE(CurseurX,CurseurY);\r
+ col:=(CurseurX-x)/8;\r
+ lig:=(CurseurY-y)/10;\r
+ DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(0);\r
+ CALL HASCII(95);\r
+ CALL MOVE(INXPOS-8,INYPOS);\r
+ touche:=INKEY;\r
+ IF touche<>0 THEN EXIT FI;\r
+ OD;\r
+ WHILE touche<>13\r
+ DO\r
+ CALL HASCII(0);\r
+ IF touche=8\r
+ THEN\r
+ IF i>LOWER(chaine) THEN i:=i-1 FI;\r
+ CALL MOVE(INXPOS-8,INYPOS);\r
+ col:=col-1;\r
+ IF col=0\r
+ THEN\r
+ col:=largeur-2;\r
+ lig:=lig-1;\r
+ IF lig=0 THEN lig:=1; col:=1 FI;\r
+ CALL MettreCurseur(lig,col);\r
+ FI;\r
+ CALL HASCII(0);\r
+ CALL MettreCurseur(lig,col);\r
+ ELSE\r
+ CALL HASCII(touche);\r
+ chaine(i):=CHR(touche);\r
+ i:=i+1;\r
+ IF i>UPPER(chaine) THEN EXIT FI;\r
+ col:=col+1;\r
+ IF col=largeur-1\r
+ THEN\r
+ col:=1;\r
+ lig:=lig+1;\r
+ if lig=hauteur-1 THEN EXIT FI;\r
+ CALL MettreCurseur(lig,col);\r
+ ELSE\r
+ CurseurX:=CurseurX+8;\r
+ FI;\r
+ FI;\r
+ DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(0);\r
+ CALL HASCII(95);\r
+ CALL MOVE(INXPOS-8,INYPOS);\r
+ touche:=INKEY;\r
+ IF touche<>0 THEN EXIT FI;\r
+ OD;\r
+ OD;\r
+ IF touche=13\r
+ THEN\r
+ CALL MOVE(INXPOS-8,INYPOS);\r
+ CALL HASCII(32);\r
+ chaine(touche):=CHR(13);\r
+ long:=i;\r
+ FI;\r
+ FI;\r
+END SaisirChaine;\r
+\r
+\r
+(* -------------------- PROCEDURE AfficheChaine -------------------- *)\r
+\r
+UNIT AfficheChaine : PROCEDURE (chaine : ARRAYOF CHAR);\r
+\r
+ VAR lig, col, i : INTEGER;\r
+\r
+BEGIN\r
+ col:=(CurseurX-x)/8;\r
+ lig:=(CurseurY-y)/10;\r
+ FOR i:=LOWER(chaine) TO UPPER(chaine)\r
+ DO\r
+ CALL MOVE(CurseurX,CurseurY);\r
+ IF chaine(i)=CHR(13) THEN EXIT FI;\r
+ CALL HASCII(0);\r
+ CALL HASCII(ORD(chaine(i)));\r
+ col:=col+1;\r
+ IF col=largeur-1\r
+ THEN\r
+ col:=1;\r
+ CurseurX:=x+8;\r
+ CurseurY:=y+10;\r
+ IF CurseurY>y1-12 THEN CurseurY:=y+10 FI;\r
+ lig:=lig+1;\r
+ IF lig=hauteur-1 THEN EXIT FI;\r
+ ELSE\r
+ CurseurX:=CurseurX+8;\r
+ FI;\r
+ OD;\r
+END AfficheChaine;\r
+ \r
+\r
+(* -------------------- INITIALISATION Fenetre -------------------- *)\r
+\r
+BEGIN\r
+ IF x<0\r
+ THEN x:=0;\r
+ ELSE IF x>XTailleEcran\r
+ THEN x:=0;\r
+ FI;\r
+ FI;\r
+ IF y<0\r
+ THEN y:=0;\r
+ ELSE IF y>YTailleEcran\r
+ THEN y:=0;\r
+ FI;\r
+ FI;\r
+ IF x+8*largeur>XTailleEcran\r
+ THEN largeur:=ENTIER((XtailleEcran-x)/8);\r
+ FI;\r
+ IF y+10*hauteur>YTailleEcran\r
+ THEN hauteur:=ENTIER((YTailleEcran-y)/10);\r
+ FI;\r
+ x1:=x+8*largeur;\r
+ y1:=y+10*hauteur;\r
+ CALL MOVE(x,y);\r
+ ArrierePlan:=GETMAP(x1,y1);\r
+ CALL XORMAP(ArrierePlan);\r
+ Active:=TRUE;\r
+ CALL InitFenetre;\r
+ CurseurX:=x+8;\r
+ CurseurY:=y+10;\r
+END Fenetre;\r
+\r
+\r
+(* ==================== PROGRAMME PRINCIPAL ==================== *)\r
+\r
+ BEGIN\r
+ PREF MOUSE BLOCK\r
+\r
+UNIT Coord : PROCEDURE (posx,posy : INTEGER); \r
+ VAR tourx,toury,i : INTEGER,\r
+ xx,yy : ARRAYOF INTEGER;\r
+\r
+BEGIN\r
+ CALL COLOR(6);\r
+ CALL MOVE(0,0);\r
+ CALL OUTSTRING(" ");\r
+ CALL MOVE(0,0);\r
+ CALL OUTSTRING("COORDONNEES : ");\r
+ ARRAY xx DIM (1:3);\r
+ ARRAY yy DIM (1:3);\r
+ IF posx<10 THEN tourx:=1;\r
+ ELSE IF posx<100 THEN tourx:=2;\r
+ ELSE tourx:=3;\r
+ FI; FI;\r
+ IF posy<10 THEN toury:=1;\r
+ ELSE IF posy<100 THEN toury:=2;\r
+ ELSE toury:=3;\r
+ FI; FI;\r
+ FOR i:=tourx DOWNTO 1\r
+ DO \r
+ xx(i):=posx MOD 10; \r
+ posx:= posx DIV 10;\r
+ OD;\r
+ FOR i:=toury DOWNTO 1\r
+ DO\r
+ yy(i):=posy MOD 10;\r
+ posy:=posy DIV 10;\r
+ OD;\r
+ FOR i:=1 TO tourx\r
+ DO\r
+ CALL HASCII(xx(i)+48);\r
+ OD;\r
+ CALL OUTSTRING(" ");\r
+ FOR i:=1 to toury\r
+ DO \r
+ CALL HASCII(yy(i)+48);\r
+ OD;\r
+END Coord;\r
+\r
+\r
+(* -------------------- PROCEDURE Deplace -------------------- *)\r
+\r
+UNIT Deplace : PROCEDURE (i : INTEGER);\r
+ \r
+ VAR touche : INTEGER;\r
+\r
+BEGIN\r
+ DO touche:=INKEY; IF touche<>0 THEN EXIT FI; OD;\r
+ WHILE touche=/=102 \r
+ DO\r
+ IF touche=-72 \r
+ THEN CALL fen(i).DeplaceFenetre(0,-5); \r
+ ELSE IF touche=-80 \r
+ THEN CALL fen(i).DeplaceFenetre(0,5);\r
+ ELSE IF touche=-75 \r
+ THEN CALL fen(i).DeplaceFenetre(-5,0);\r
+ ELSE IF touche=-77 \r
+ THEN CALL fen(i).DeplaceFenetre(5,0);\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ DO touche:=INKEY; IF touche<>0 THEN EXIT FI; OD;\r
+ OD;\r
+END Deplace; \r
+\r
+\r
+(* -------------------- PROCEDURE taille -------------------- *)\r
+\r
+UNIT Taille : PROCEDURE (i : INTEGER);\r
+ \r
+ VAR touche : INTEGER;\r
+\r
+BEGIN\r
+ DO touche:=INKEY; IF touche<>0 THEN EXIT FI; OD;\r
+ WHILE touche=/=102 \r
+ DO\r
+ IF touche=-72 \r
+ THEN CALL fen(i).ChangeTaille(0,-1); \r
+ ELSE IF touche=-80 \r
+ THEN CALL fen(i).ChangeTaille(0,1);\r
+ ELSE IF touche=-75 \r
+ THEN CALL fen(i).ChangeTaille(-1,0);\r
+ ELSE IF touche=-77 \r
+ THEN CALL fen(i).ChangeTaille(1,0);\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ DO touche:=INKEY; IF touche<>0 THEN EXIT FI; OD;\r
+ OD;\r
+END Taille; \r
+ \r
+\r
+(* -------------------- PROCEDURE Saisir -------------------- *)\r
+\r
+UNIT Saisir : PROCEDURE (i : INTEGER);\r
+\r
+BEGIN\r
+ CALL COLOR(4);\r
+ CALL fen(i).SaisirChaine(chaines,longueur);\r
+ CALL COLOR(16);\r
+END Saisir;\r
+\r
+\r
+(* -------------------- PROCEDURE Affiche -------------------- *)\r
+\r
+UNIT Affiche : PROCEDURE (i : INTEGER);\r
+\r
+BEGIN\r
+ CALL COLOR(8);\r
+ CALL fen(i).AfficheChaine(chaines);\r
+ CALL COLOR(16);\r
+END Affiche;\r
+\r
+\r
+(* -------------------- PROCEDURE AfFen -------------------- *)\r
+\r
+UNIT AfFen : PROCEDURE (INOUT k : INTEGER; i : INTEGER);\r
+\r
+ VAR touche : INTEGER;\r
+\r
+BEGIN\r
+ CALL COLOR(10);\r
+ k:=i-1;\r
+ DO\r
+ touche:=INKEY;\r
+ IF touche=102 THEN EXIT FI;\r
+ IF touche=115 THEN\r
+ CALL fen(k).SauveFenetre;\r
+ k:=k-1;\r
+ IF k=0 THEN k:=i-1 FI;\r
+ CALL fen(k).AfficheFenetre;\r
+ FI;\r
+ OD;\r
+END AfFen;\r
+\r
+\r
+(* -------------------- MAIN ------------------- *)\r
+\r
+VAR\r
+ fen : ARRAYOF Fenetre,\r
+ h,v,p : INTEGER,\r
+ l,r,c : BOOLEAN,\r
+ chaines : ARRAYOF CHAR,\r
+ i,cour,touche,longueur : INTEGER;\r
+\r
+\r
+BEGIN\r
+ CALL GRON(2);\r
+ CALL CLS;\r
+ CALL COLOR(16);\r
+ CALL BORDER(15);\r
+ CALL DEFCURSOR(0,1,13);\r
+ CALL SHOWCURSOR;\r
+ ARRAY fen DIM (1:50);\r
+ ARRAY chaines DIM (1:50);\r
+ i:=1;\r
+ DO\r
+ touche:=INKEY;\r
+ CALL GETPRESS(1,h,v,p,l,r,c);\r
+ IF l AND r THEN EXIT FI;\r
+ CALL GETPRESS(0,h,v,p,l,r,c);\r
+ IF l\r
+ THEN \r
+ CALL HIDECURSOR;\r
+ CALL MOVE(0,0); CALL Coord(h,v);\r
+ fen(i):=NEW Fenetre(h,v,20,7,1);\r
+ CALL SHOWCURSOR;\r
+ i:=i+1;\r
+ cour:=i-1;\r
+ FI;\r
+ CASE touche \r
+ WHEN 100 : CALL Deplace(cour);\r
+ WHEN 115 : CALL Saisir(cour);\r
+ WHEN 116 : CALL Taille(cour);\r
+ WHEN 99 : CALL Affiche(cour);\r
+ WHEN 101 : CALL fen(cour).EffaceFenetre;\r
+ WHEN 32 : CALL fen(cour).CacheFenetre;\r
+ WHEN 97 : CALL fen(cour).AfficheFenetre;\r
+ WHEN 109 : CALL AfFen(cour,i);\r
+ ESAC;\r
+ OD;\r
+ CALL GROFF;\r
+END;END;END\r
+\r
--- /dev/null
+PROGRAM GraphColoring;\r
+ UNIT BACKTRACK: CLASS;\r
+ HIDDEN SE,ELEM,TOP;\r
+ VAR ROOT:NODE,SEARCH:SE,FOUND,OPT:NODE,\r
+ NUMBER_OF_NODES,NUMBER_OF_LEAVES,NUMBER_OF_ANSWERS:INTEGER,\r
+ NUMERO_DE_NOEUDS: INTEGER;\r
+ \r
+ UNIT NODE: COROUTINE(FATHER:NODE);\r
+ VAR NSONS,LEVEL,MY_NUMBER: INTEGER , DEADEND:BOOLEAN;\r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ END LEAF;\r
+ UNIT VIRTUAL ANSWER :FUNCTION :BOOLEAN;\r
+ END ANSWER;\r
+ UNIT VIRTUAL LASTSON: FUNCTION : BOOLEAN;\r
+ END LASTSON;\r
+ UNIT VIRTUAL NEXTSON: FUNCTION : NODE;\r
+ END NEXTSON;\r
+ UNIT VIRTUAL EQUAL : FUNCTION (W:NODE):BOOLEAN;\r
+ END EQUAL;\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ END COST;\r
+ BEGIN\r
+ NUMERO_DE_NOEUDS := NUMERO_DE_NOEUDS + 1;\r
+ MY_NUMBER := NUMERO_DE_NOEUDS;\r
+ IF FATHER =/= NONE\r
+ THEN\r
+ LEVEL:=FATHER.LEVEL+1\r
+ ELSE\r
+ LEVEL:=0\r
+ FI;\r
+ END NODE;\r
+ \r
+ UNIT OK: FUNCTION (V:NODE):BOOLEAN;\r
+ VAR W:NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RESULT:=FALSE; RETURN FI;\r
+ RESULT:=TRUE; W:=V.FATHER;\r
+ WHILE W =/= NONE\r
+ DO\r
+ IF V.EQUAL(W) THEN RESULT:=FALSE; RETURN FI;\r
+ W:=W.FATHER\r
+ OD\r
+ END OK;\r
+ \r
+ UNIT PURGE: PROCEDURE (V:NODE);\r
+ VAR W: NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RETURN FI;\r
+ DO\r
+ W:=V.FATHER; KILL(V);\r
+ IF W=NONE THEN RETURN FI;\r
+ W.NSONS:=W.NSONS-1;\r
+ IF W.NSONS =/= 0 THEN RETURN FI;\r
+ V:=W\r
+ OD;\r
+ END PURGE;\r
+\r
+ VAR TOP:ELEM;\r
+\r
+ UNIT ELEM: CLASS (NEXT:ELEM, V:NODE);\r
+ END ELEM;\r
+ \r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ BEGIN\r
+ TOP:=NEW ELEM(TOP,V); \r
+ END INSERT;\r
+ \r
+ UNIT VIRTUAL DELETE: FUNCTION :NODE;\r
+ VAR E:ELEM;\r
+ BEGIN\r
+ IF TOP =/= NONE\r
+ THEN\r
+ RESULT:=TOP.V; \r
+ E:=TOP; TOP:=TOP.NEXT; KILL(E);\r
+ FI; \r
+ END DELETE;\r
+ \r
+ UNIT SE: COROUTINE ;\r
+ VAR I:INTEGER,V,W:NODE;\r
+ BEGIN\r
+ RETURN; CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE; \r
+ IF V=NONE THEN EXIT FI;\r
+ ATTACH(V); \r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ FOUND:=V;\r
+ IF OPT=NONE ORIF V.COST < OPT.COST\r
+ THEN\r
+ OPT:=V\r
+ FI;\r
+ DETACH;\r
+ (* HERE THE USER OF BACKTRACK MAY UNDERTAKE SOME ACTIONS\r
+ ON THE ANSWER NODES. IF NOT NECESSARY DO ATTACH *) \r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V);\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ NUMBER_OF_NODES:=NUMBER_OF_NODES+1; \r
+ IF OK(W)\r
+ THEN \r
+ W.DEADEND:=W.LEAF; CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI; \r
+ OD;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FOUND:=NONE;\r
+ END SE;\r
+ \r
+ \r
+ UNIT KILLALL :PROCEDURE;\r
+ VAR V:NODE;\r
+ BEGIN\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN RETURN FI;\r
+ CALL PURGE(V);\r
+ OD;\r
+ END KILLALL;\r
+\r
+ BEGIN\r
+ NUMBER_OF_NODES := 1;\r
+ SEARCH:=NEW SE;\r
+ INNER;\r
+ KILL(SEARCH); CALL KILLALL;\r
+ END BACKTRACK;\r
+ \r
+ \r
+ VAR N,M,I,J:INTEGER,H1,H2,H3:CHAR;\r
+ VAR INC: ARRAYOF ARRAYOF BOOLEAN,\r
+ f: file; \r
+ BEGIN \r
+ open(f, text, unpack("colourng.his"));\r
+ DO\r
+ \r
+ writeln; writeln;\r
+ writeln("An aplication of Backtracking to Graph Colouring");\r
+ WRITE(" NUMBER OF VERTICES= (exit on zero) ");\r
+ \r
+ READLN(N);\r
+ \r
+ IF N=0 THEN EXIT FI;\r
+ call rewrite(f);\r
+ WRITEln(f," NUMBER OF VERTICES= ",N); \r
+ WRITE(" NUMBER OF COLOURS= ");\r
+ READLN(M);\r
+ WRITEln(f," NUMBER OF COLOURS= ",M); \r
+ ARRAY INC DIM (1:N);\r
+ FOR I:=1 TO N DO ARRAY INC(I) DIM (1:I); OD;\r
+ writeln;writeln;\r
+ WRITELN(" GIVE A GRAPH BY DEFINING SUCCESSIVE EDGES");\r
+ WRITELN(" For each vertex give a list of adjacent vertices");\r
+ WRITELN(" Don't give numbers less than number of current vertex");\r
+ WRITELN(" TO END A LIST WRITE 0");\r
+ Writeln(" Example: for i-th vertex give i+2,i+3 avoid i-5");\r
+ FOR I:=1 TO N\r
+ DO\r
+ WRITELN(" VERTEX ",I:3," IS INCIDENT WITH VERTICES=");\r
+ WRITELN(f," VERTEX ",I:3," IS INCIDENT WITH VERTICES="); \r
+ DO\r
+ READ(J); WRITE(f,J);\r
+ IF J>1 AND J<=N THEN INC(J,I):=TRUE ELSE EXIT FI;\r
+ OD;\r
+ WRITELN(" END OF EDGES WITH VERTEX", I:3);\r
+ WRITELN(f," END OF EDGES WITH VERTEX", I:3);\r
+ OD;\r
+ WRITELN(" GRAPH HAS THE FOLLOWING INCIDENCE MATRIX");\r
+ WRITELN(f," GRAPH HAS THE FOLLOWING INCIDENCE MATRIX");\r
+ FOR I:=1 TO N\r
+ DO\r
+ FOR J:=1 TO I\r
+ DO\r
+ IF INC(I,J) \r
+ THEN WRITE(1:2); write(f,1:2) \r
+ ELSE WRITE(0:2); write(f,0:2) \r
+ FI;\r
+ OD;\r
+ WRITELN; writeln(f);\r
+ OD; \r
+ PREF BACKTRACK BLOCK\r
+ VAR K:INTEGER;\r
+ UNIT STATE: NODE CLASS(I,J,NC:INTEGER);\r
+ \r
+ (*I- VERTEX, J-COLOUR, NC-NUMBER OF COLOURS *)\r
+\r
+ UNIT VIRTUAL ANSWER: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= I=N AND OKGO(THIS STATE)\r
+ END ANSWER;\r
+ \r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:=I=N OR NOT OKGO(THIS STATE)\r
+ END LEAF;\r
+ \r
+ UNIT OKGO: FUNCTION(V:STATE) : BOOLEAN;\r
+ VAR I,J:INTEGER;\r
+ BEGIN\r
+ I:=V.I; J:=V.J;\r
+ DO\r
+ V:=V.FATHER;\r
+ IF V=NONE THEN RESULT:=TRUE; EXIT FI;\r
+ IF V.J=J AND INC(I,V.I) THEN EXIT FI;\r
+ OD;\r
+ END OKGO;\r
+\r
+ \r
+ UNIT VIRTUAL LASTSON: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ IF K=M\r
+ THEN\r
+ RESULT:=TRUE;\r
+ K:=0;\r
+ FI; \r
+ END LASTSON;\r
+ \r
+ UNIT VIRTUAL NEXTSON : FUNCTION :STATE;\r
+ VAR V:STATE,NCK:INTEGER;\r
+ BEGIN\r
+ V:=THIS STATE;\r
+ K:=K+1;\r
+ NCK:=NC;\r
+ DO\r
+ IF V=NONE THEN NCK:=NCK+1; EXIT FI;\r
+ IF V.J=K THEN EXIT FI;\r
+ V:=V.FATHER;\r
+ OD; \r
+ RESULT:=NEW STATE(THIS STATE,I+1,K,NCK);\r
+ call DISPLAY(result);\r
+ END NEXTSON;\r
+\r
+ UNIT VIRTUAL EQUAL: FUNCTION(S:STATE):BOOLEAN;\r
+ BEGIN\r
+ RESULT:=I=S.I AND J=S.J\r
+ END EQUAL;\r
+ \r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ BEGIN\r
+ RESULT:=NC\r
+ END COST;\r
+ \r
+ \r
+ BEGIN\r
+ RETURN;\r
+ DO\r
+ DETACH \r
+ OD;\r
+ END STATE;\r
+\r
+ \r
+ UNIT DISPLAY: PROCEDURE(V:STATE);\r
+ BEGIN\r
+ IF V=NONE \r
+ THEN WRITELN(" NO SOLUTIONS"); writeln(f,"no solutions"); RETURN \r
+ FI;\r
+ WRITE("State no:",V.MY_NUMBER);\r
+ if V.FATHER <>none then WRITE(" son of state:",V.FATHER.MY_NUMBER) fi;\r
+ if V.ANSWER then WRITELN(" SOLUTION! ") \r
+ else\r
+ if V.LEAF then WRITELN(" DEADEND ")\r
+ else WRITELN\r
+ fi\r
+ fi;\r
+ WRITE(f,"State no:",V.MY_NUMBER);\r
+ if V.FATHER <>none then WRITE(f," son of state:",V.FATHER.MY_NUMBER) fi;\r
+ if V.ANSWER then WRITELN(f," SOLUTION! ") \r
+ else\r
+ if V.LEAF then WRITELN(f," DEADEND ")\r
+ else WRITELN(f)\r
+ fi\r
+ fi;\r
+ WRITELN("VERTEX COLOUR");\r
+ WRITELN(f,"VERTEX COLOUR");\r
+ DO\r
+ WRITE(V.I); WRITE(" "); WRITELN(V.J);\r
+ WRITE(f,V.I); WRITE(f," "); WRITELN(f,V.J);\r
+ V:=V.FATHER;\r
+ IF V=NONE THEN EXIT FI \r
+ OD;\r
+ WRITELN;\r
+ END DISPLAY;\r
+ \r
+ BEGIN\r
+ READLN;\r
+ ROOT:=NEW STATE(NONE,1,1,1); \r
+ call DISPLAY(ROOT);\r
+ WRITE("DO YOU WANT TO OPTIMIZE ");\r
+ WRITELN("OR TO PRINT ALL THE SOLUTIONS ?");\r
+ WRITELN(" (ANSWER OPT OR ALL)");\r
+ READLN(H1,H2,H3);\r
+ IF H1='O' AND H2='P' AND H3='T'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ IF OPT =/= NONE ANDIF OPT.COST<FOUND.COST\r
+ THEN\r
+ EXIT\r
+ FI; \r
+ OD;\r
+ IF OPT =/= NONE\r
+ THEN\r
+ CALL DISPLAY(OPT);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ WRITELN(f,"NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN(f,"NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN(f,"NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+\r
+ ELSE\r
+ WRITELN("NO SOLUTIONS");\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN(f,"NO SOLUTIONS");\r
+ WRITELN(f,"NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN(f,"NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+\r
+ FI;\r
+ ELSE \r
+ IF H1='A' AND H2='L' AND H3='L'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH); \r
+ (* CALL DISPLAY(FOUND); *)\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ WRITELN(f,"NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN(f,"NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN(f,"NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ WRITELN("DO YOU WANT TO CONTINUE?");\r
+ READ(H1,H2);\r
+ IF H1=/='Y' ORIF H2=/='E' THEN EXIT FI;\r
+ READLN(H3);\r
+ IF H3=/='S' THEN EXIT FI;\r
+ OD;\r
+ FI\r
+ FI;\r
+ END (* of PREFIXED block *) ;\r
+ OD;\r
+\r
+ \r
+ \r
+ END; (* of program *)\r
+ \r
+\r
+ \r
--- /dev/null
+PROGRAM BACKTRACKING;\r
+ UNIT BACKTRACK: CLASS;\r
+ HIDDEN SE;\r
+ VAR ROOT:NODE,SEARCH:SE,FOUND:NODE,\r
+ NUMBER_OF_LEAVES,NUMBER_OF_ANSWERS:INTEGER;\r
+\r
+ UNIT NODE: CLASS(FATHER:NODE);\r
+ VAR NSONS,LEVEL: INTEGER , DEADEND:BOOLEAN;\r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ END LEAF;\r
+ UNIT VIRTUAL ANSWER :FUNCTION :BOOLEAN;\r
+ END ANSWER;\r
+ UNIT VIRTUAL LASTSON: FUNCTION : BOOLEAN;\r
+ END LASTSON;\r
+ UNIT VIRTUAL NEXTSON: FUNCTION : NODE;\r
+ END NEXTSON;\r
+ UNIT VIRTUAL EQUAL : FUNCTION (W:NODE):BOOLEAN;\r
+ END EQUAL;\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ END COST;\r
+ BEGIN\r
+ IF FATHER =/= NONE\r
+ THEN\r
+ LEVEL:=FATHER.LEVEL+1\r
+ ELSE\r
+ LEVEL:=0\r
+ FI;\r
+ END NODE;\r
+\r
+ UNIT OK: FUNCTION (V:NODE):BOOLEAN;\r
+ VAR W:NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RESULT:=FALSE; RETURN FI;\r
+ RESULT:=TRUE; W:=V.FATHER;\r
+ WHILE W =/= NONE\r
+ DO\r
+ IF V.EQUAL(W) THEN RESULT:=FALSE; RETURN FI;\r
+ W:=W.FATHER\r
+ OD\r
+ END OK;\r
+\r
+ UNIT PURGE: PROCEDURE (V:NODE);\r
+ VAR W: NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RETURN FI;\r
+ DO\r
+ W:=V.FATHER; KILL(V);\r
+ IF W=NONE THEN RETURN FI;\r
+ W.NSONS:=W.NSONS-1;\r
+ IF W.NSONS =/= 0 THEN RETURN FI;\r
+ V:=W\r
+ OD;\r
+ END PURGE;\r
+\r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ END INSERT;\r
+\r
+ UNIT VIRTUAL DELETE : FUNCTION :NODE;\r
+ END DELETE;\r
+\r
+ UNIT SE: COROUTINE ;\r
+ VAR I:INTEGER,V,W:NODE;\r
+ BEGIN\r
+ RETURN; CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN EXIT FI;\r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ FOUND:=V; DETACH; CALL PURGE(V);\r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V);\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ IF OK(W)\r
+ THEN\r
+ W.DEADEND:=W.LEAF; CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI;\r
+ OD;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FOUND:=NONE;\r
+ END SE;\r
+\r
+ UNIT OPTIMIZE: FUNCTION: NODE;\r
+ VAR V,W:NODE;\r
+ BEGIN\r
+ CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN EXIT FI;\r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ IF RESULT=NONE ORIF RESULT.COST > V.COST\r
+ THEN\r
+ CALL PURGE(RESULT); RESULT:=V\r
+ FI;\r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V)\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ IF OK(W)\r
+ THEN\r
+ W.DEADEND:=W.LEAF; CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI;\r
+ OD;\r
+ FI\r
+ FI;\r
+ OD;\r
+ END OPTIMIZE;\r
+\r
+\r
+ UNIT KILLALL :PROCEDURE;\r
+ VAR V:NODE;\r
+ BEGIN\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN RETURN FI;\r
+ CALL PURGE(V);\r
+ OD;\r
+ END KILLALL;\r
+\r
+ BEGIN\r
+ SEARCH:=NEW SE;\r
+ INNER;\r
+ KILL(SEARCH);\r
+ END BACKTRACK;\r
+\r
+ UNIT DFS :BACKTRACK CLASS;\r
+ VAR TOP:ELEM;\r
+\r
+ UNIT ELEM: CLASS (NEXT:ELEM, V:NODE);\r
+ END ELEM;\r
+\r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ BEGIN\r
+ TOP:=NEW ELEM(TOP,V);\r
+ END INSERT;\r
+\r
+ UNIT VIRTUAL DELETE: FUNCTION :NODE;\r
+ VAR E:ELEM;\r
+ BEGIN\r
+ IF TOP =/= NONE\r
+ THEN\r
+ RESULT:=TOP.V;\r
+ E:=TOP; TOP:=TOP.NEXT; KILL(E);\r
+ FI;\r
+ END DELETE;\r
+\r
+ END DFS;\r
+\r
+ VAR N,BC:INTEGER,H1,H2,H3:CHAR;\r
+ BEGIN\r
+ DO\r
+ WRITE(" N= ");\r
+ READLN(N);\r
+ IF N=0 THEN EXIT FI;\r
+ WRITE(" BOAT CAPACITY=");\r
+ READLN(BC);\r
+\r
+ PREF DFS BLOCK\r
+ VAR M,C:INTEGER; (* BC - BOAT CAPACITY, N- NUMBER OF CANNIBALS\r
+ N- NUMBER OF MISSIONARS *)\r
+ UNIT STATE: NODE CLASS(M1,C1:INTEGER);\r
+ VAR M2,C2:INTEGER, LEFT:BOOLEAN;\r
+ (* M1,M2 NUMBER OF MISSIONARS ON BOTH SIDES OF THE RIVER\r
+ C1,C2 NUMBER OF CANNIBALS ON BOTH SIDES OF THE RIVER *)\r
+\r
+ UNIT VIRTUAL ANSWER: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:=M1=0 AND C1=0\r
+ END ANSWER;\r
+\r
+ UNIT VIRTUAL LEAF: FUNCTION : BOOLEAN;\r
+ BEGIN\r
+ IF M1<0 ORIF M2<0 ORIF C1<0 ORIF C2<0 ORIF\r
+ M1>N ORIF M2>N ORIF C1>N ORIF C2>N ORIF\r
+ M1<C1 AND M1>0 ORIF M2<C2 AND M2>0\r
+ THEN\r
+ RESULT:=TRUE\r
+ FI\r
+ END LEAF;\r
+\r
+\r
+ UNIT VIRTUAL LASTSON: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ IF C=0 AND M=BC\r
+ THEN\r
+ RESULT:=TRUE; M:=0; C:=0;\r
+ FI;\r
+ END;\r
+\r
+ UNIT VIRTUAL NEXTSON : FUNCTION :STATE;\r
+ BEGIN\r
+ C:=C+1;\r
+ IF M=0\r
+ THEN\r
+ IF C>BC\r
+ THEN\r
+ C:=0; M:=1\r
+ FI\r
+ ELSE\r
+ IF M<C ORIF M+C>BC\r
+ THEN\r
+ C:=0; M:=M+1;\r
+ FI\r
+ FI;\r
+ IF LEFT\r
+ THEN\r
+ IF C+M<BC\r
+ THEN\r
+ RESULT:=NONE\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,M1-M,C1-C)\r
+ FI\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,M1+M,C1+C)\r
+ FI;\r
+ END NEXTSON;\r
+\r
+ UNIT VIRTUAL EQUAL: FUNCTION(W:STATE):BOOLEAN;\r
+ BEGIN\r
+ RESULT:=LEFT=W.LEFT AND M1=W.M1 AND C1=W.C1;\r
+ END EQUAL;\r
+\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ BEGIN\r
+ RESULT:=LEVEL\r
+ END COST;\r
+\r
+\r
+ BEGIN\r
+ LEFT:=LEVEL MOD 2 = 0;\r
+ M2:=N-M1; C2:=N-C1;\r
+ END STATE;\r
+\r
+\r
+ UNIT DISPLAY: PROCEDURE(V:STATE);\r
+ VAR J,I:INTEGER, W:STATE,AT: ARRAYOF STATE;\r
+ BEGIN\r
+ IF V=NONE THEN WRITELN(" NO MORE SOLUTIONS"); RETURN FI;\r
+ I:=V.LEVEL;\r
+ ARRAY AT DIM (0:I);\r
+ W:=V;\r
+ FOR J:=I DOWNTO 0\r
+ DO\r
+ AT(J):=W; W:=W.FATHER\r
+ OD;\r
+ WRITELN("MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE");\r
+ FOR J:=0 TO I\r
+ DO\r
+ WRITE(J); WRITE(" ");\r
+ W:=AT(J);\r
+ WRITE(W.M1,W.C1," ");\r
+ IF W.LEFT\r
+ THEN\r
+ WRITE("->");\r
+ ELSE\r
+ WRITE("<-");\r
+ FI;\r
+ WRITELN(" ",W.M2,W.C2);\r
+ OD;\r
+ KILL(AT);\r
+ END DISPLAY;\r
+\r
+ BEGIN\r
+ ROOT:=NEW STATE(NONE,N,N);\r
+ WRITE("DO YOU WANT TO OPTIMIZE ");\r
+ WRITELN("OR TO PRINT ALL THE SOLUTIONS ?");\r
+ WRITELN(" (ANSWER OPT OR ALL)");\r
+ READLN(H1,H2,H3);\r
+ IF H1='O' AND H2='P' AND H3='T'\r
+ THEN\r
+ FOUND:=OPTIMIZE;\r
+ IF FOUND =/= NONE\r
+ THEN\r
+ CALL DISPLAY(FOUND);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ ELSE\r
+ WRITELN(" NO SOLUTIONS");\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ FI;\r
+ CALL KILLALL;\r
+ ELSE\r
+ IF H1='A' AND H2='L' AND H3='L'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ CALL DISPLAY(FOUND);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ IF FOUND=NONE THEN EXIT FI\r
+ OD;\r
+ CALL KILLALL;\r
+ FI\r
+ FI;\r
+ END;\r
+ OD;\r
+\r
+\r
+\r
+ END;\r
+\r
+END\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+PROGRAM BACKTRACKING;\r
+ UNIT BACKTRACK: CLASS;\r
+ HIDDEN SE,ELEM,TOP;\r
+ VAR ROOT:NODE,SEARCH:SE,FOUND,OPT:NODE,\r
+ NUMBER_OF_NODES,NUMBER_OF_LEAVES,NUMBER_OF_ANSWERS:INTEGER;\r
+\r
+ UNIT NODE: COROUTINE(FATHER:NODE);\r
+ VAR NSONS,LEVEL: INTEGER , DEADEND:BOOLEAN;\r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ END LEAF;\r
+ UNIT VIRTUAL ANSWER :FUNCTION :BOOLEAN;\r
+ END ANSWER;\r
+ UNIT VIRTUAL LASTSON: FUNCTION : BOOLEAN;\r
+ END LASTSON;\r
+ UNIT VIRTUAL NEXTSON: FUNCTION : NODE;\r
+ END NEXTSON;\r
+ UNIT VIRTUAL EQUAL : FUNCTION (W:NODE):BOOLEAN;\r
+ END EQUAL;\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ END COST;\r
+ BEGIN\r
+ IF FATHER =/= NONE\r
+ THEN\r
+ LEVEL:=FATHER.LEVEL+1\r
+ ELSE\r
+ LEVEL:=0\r
+ FI;\r
+ END NODE;\r
+\r
+ UNIT OK: FUNCTION (V:NODE):BOOLEAN;\r
+ VAR W:NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RESULT:=FALSE; RETURN FI;\r
+ RESULT:=TRUE; W:=V.FATHER;\r
+ WHILE W =/= NONE\r
+ DO\r
+ IF V.EQUAL(W) THEN RESULT:=FALSE; RETURN FI;\r
+ W:=W.FATHER\r
+ OD\r
+ END OK;\r
+\r
+ UNIT PURGE: PROCEDURE (V:NODE);\r
+ VAR W: NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RETURN FI;\r
+ DO\r
+ W:=V.FATHER; KILL(V);\r
+ IF W=NONE THEN RETURN FI;\r
+ W.NSONS:=W.NSONS-1;\r
+ IF W.NSONS =/= 0 THEN RETURN FI;\r
+ V:=W\r
+ OD;\r
+ END PURGE;\r
+\r
+ VAR TOP:ELEM;\r
+\r
+ UNIT ELEM: CLASS (NEXT:ELEM, V:NODE);\r
+ END ELEM;\r
+\r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ BEGIN\r
+ TOP:=NEW ELEM(TOP,V);\r
+ END INSERT;\r
+\r
+ UNIT VIRTUAL DELETE: FUNCTION :NODE;\r
+ VAR E:ELEM;\r
+ BEGIN\r
+ IF TOP =/= NONE\r
+ THEN\r
+ RESULT:=TOP.V;\r
+ E:=TOP; TOP:=TOP.NEXT; KILL(E);\r
+ FI;\r
+ END DELETE;\r
+\r
+ UNIT SE: COROUTINE ;\r
+ VAR I:INTEGER,V,W:NODE;\r
+ BEGIN\r
+ RETURN; CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN EXIT FI;\r
+ ATTACH(V);\r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ FOUND:=V;\r
+ IF OPT=NONE ORIF V.COST < OPT.COST\r
+ THEN\r
+ OPT:=V\r
+ FI;\r
+ DETACH;\r
+ (* HERE THE USER OF BACKTRACK MAY UNDERTAKE SOME ACTIONS\r
+ ON THE ANSWER NODES. IF NOT NECESSARY DO ATTACH *)\r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V);\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ NUMBER_OF_NODES:=NUMBER_OF_NODES+1;\r
+ IF OK(W)\r
+ THEN\r
+ W.DEADEND:=W.LEAF; CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI;\r
+ OD;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FOUND:=NONE;\r
+ END SE;\r
+\r
+\r
+ UNIT KILLALL :PROCEDURE;\r
+ VAR V:NODE;\r
+ BEGIN\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN RETURN FI;\r
+ CALL PURGE(V);\r
+ OD;\r
+ END KILLALL;\r
+\r
+ BEGIN\r
+ SEARCH:=NEW SE;\r
+ INNER;\r
+ KILL(SEARCH); CALL KILLALL;\r
+ END BACKTRACK;\r
+\r
+\r
+UNIT BESTSEARCH: BACKTRACK CLASS;\r
+ (* BESTSEARCH USES A PRIORITY QUEUE FOR NODES.\r
+ QUEUE IS ORGANIZED AS A HEAP IN THE ARRAY A.\r
+ THE FIRST ELEMENT A(1) IS THE LEAST ONE. *)\r
+ HIDDEN A,B,X,K,M,I,J;\r
+ VAR A,B:ARRAYOF EX_NODE, X : EX_NODE, K,M,I,J:INTEGER;\r
+ (*M- CURRENT ARRAY A LENTGTH\r
+ K- CURRENT HEAP LENGTH\r
+ B- SRATCH ARRAY *)\r
+\r
+ UNIT EX_NODE : NODE CLASS;\r
+ UNIT VIRTUAL LESS : FUNCTION (X: EX_NODE) : BOOLEAN;\r
+ END LESS;\r
+ END EX_NODE;\r
+\r
+ UNIT VIRTUAL DELETE: FUNCTION :EX_NODE;\r
+\r
+ BEGIN\r
+ IF K=0 THEN RETURN FI;\r
+ RESULT:=A(1); X:=A(K); K:=K-1;\r
+ IF K=0\r
+ THEN\r
+ KILL(A); RETURN\r
+ FI;\r
+ IF K*2<M\r
+ THEN\r
+ ARRAY B DIM (1: M DIV 2);\r
+ FOR I:=1 TO K DO B(I):=A(I) OD;\r
+ KILL(A); M:=M DIV 2; A:=B\r
+ FI;\r
+ I:=1; J:=2;\r
+ WHILE J <= K\r
+ DO\r
+ IF J+1 <= K ANDIF A(J+1).LESS( A(J))\r
+ THEN\r
+ J:=J+1\r
+ FI;\r
+ IF X.LESS( A(J)) THEN EXIT FI;\r
+ A(I):=A(J); I:=J; J:=2*I\r
+ OD;\r
+ A(I):=X\r
+ END DELETE;\r
+\r
+\r
+ UNIT VIRTUAL INSERT : PROCEDURE(X: EX_NODE);\r
+ BEGIN\r
+ IF K=0\r
+ THEN\r
+ ARRAY A DIM (1:2); M:=2;\r
+ FI;\r
+ IF K=M\r
+ THEN\r
+ ARRAY B DIM(1:2*M); FOR I:=1 TO M DO B(I):=A(I) OD;\r
+ KILL(A); M:=2*M; A:=B;\r
+ FI;\r
+ K,J:=K+1;\r
+ IF K=1 THEN A(1):=X; RETURN; FI;\r
+ I:= J DIV 2;\r
+ WHILE I>=1\r
+ DO\r
+ IF A(I).LESS( X ) THEN EXIT FI;\r
+ A(J):=A(I); J:=I; I:= J DIV 2\r
+ OD;\r
+ A(J):=X\r
+ END INSERT;\r
+\r
+ BEGIN\r
+ INNER;\r
+ CALL KILLALL;\r
+ END BESTSEARCH;\r
+\r
+\r
+\r
+ VAR N,Q:INTEGER,H1,H2,H3:CHAR;\r
+ (* Q - BOAT CAPACITY, N- NUMBER OF CANNIBALS, N- NUMBER OF MISSIONARIES *)\r
+\r
+BEGIN\r
+ DO\r
+ WRITE(" NUMBER OF PERSONS ");\r
+ WRITE(" (IF END OF SESSION WRITE 0) =");\r
+ READLN(N);\r
+ IF N=0 THEN EXIT FI;\r
+ WRITE(" BOAT CAPACITY=");\r
+ READLN(Q);\r
+\r
+ PREF BESTSEARCH BLOCK\r
+ VAR M,C:INTEGER;\r
+ (* M- NUMBER OF MISSIONARIES, C- NUMBER OF CANNIBALS ON THE BOAT *)\r
+\r
+ UNIT STATE: EX_NODE CLASS(ML,CL:INTEGER);\r
+ VAR MR,CR:INTEGER, LEFT:BOOLEAN;\r
+\r
+ (* ML- NUMBER OF MISSIONARIES ON THE LEFT BANK OF THE RIVER\r
+ MR- NUMBER OF MISSIONARIES ON THE RIGHT BANK OF THE RIVER\r
+ CL- NUMBER OF CANNIBALS ON THE LEFT BANK OF THE RIVER\r
+ CR- NUMBER OF CANNIBALS ON THE RIGHT BANK OF THE RIVER\r
+ LEFT- TRUE IFF THE BOAT IS ON THE LEFT BANK OF THE RIVER *)\r
+\r
+ UNIT VIRTUAL ANSWER: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:=ML=0 AND CL=0\r
+ END ANSWER;\r
+\r
+ UNIT VIRTUAL LEAF: FUNCTION : BOOLEAN;\r
+ BEGIN\r
+ IF ML<0 ORIF MR<0 ORIF CL<0 ORIF CR<0 ORIF\r
+ ML>N ORIF MR>N ORIF CL>N ORIF CR>N ORIF\r
+ ML<CL AND ML>0 ORIF MR<CR AND MR>0\r
+ THEN\r
+ RESULT:=TRUE\r
+ FI\r
+ END LEAF;\r
+\r
+\r
+ UNIT VIRTUAL LASTSON: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ IF C=0 AND M=Q\r
+ THEN\r
+ RESULT:=TRUE; M:=0; C:=0;\r
+ FI;\r
+ END;\r
+\r
+ UNIT VIRTUAL NEXTSON : FUNCTION :STATE;\r
+ BEGIN\r
+ C:=C+1;\r
+ IF M=0\r
+ THEN\r
+ IF C>Q\r
+ THEN\r
+ C:=0; M:=1\r
+ FI\r
+ ELSE\r
+ IF M<C ORIF M+C>Q\r
+ THEN\r
+ C:=0; M:=M+1;\r
+ FI\r
+ FI;\r
+ IF LEFT\r
+ THEN\r
+ IF C+M<Q\r
+ THEN\r
+ RESULT:=NONE\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,ML-M,CL-C)\r
+ FI\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,ML+M,CL+C)\r
+ FI;\r
+ END NEXTSON;\r
+\r
+ UNIT VIRTUAL EQUAL: FUNCTION(S:STATE):BOOLEAN;\r
+ BEGIN\r
+ RESULT:=LEFT=S.LEFT AND ML=S.ML AND CL=S.CL;\r
+ END EQUAL;\r
+\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ BEGIN\r
+ RESULT:=LEVEL\r
+ END COST;\r
+\r
+ UNIT VIRTUAL LESS: FUNCTION (S:STATE): BOOLEAN;\r
+ BEGIN\r
+ RESULT:=ML+CL<S.ML+S.CL\r
+ END LESS;\r
+\r
+\r
+\r
+ BEGIN\r
+ LEFT:=LEVEL MOD 2 = 0;\r
+ MR:=N-ML; CR:=N-CL;\r
+ RETURN;\r
+ DO\r
+ IF BOOL1 THEN CALL DISPLAY(THIS STATE) FI;\r
+ DETACH;\r
+ OD;\r
+ END STATE;\r
+\r
+\r
+ UNIT DISPLAY: PROCEDURE(V:STATE);\r
+ VAR J,I:INTEGER, W:STATE,AT: ARRAYOF STATE;\r
+ BEGIN\r
+ IF V=NONE THEN WRITELN(" NO MORE SOLUTIONS"); RETURN FI;\r
+ I:=V.LEVEL;\r
+ ARRAY AT DIM (0:I);\r
+ W:=V;\r
+ FOR J:=I DOWNTO 0\r
+ DO\r
+ AT(J):=W; W:=W.FATHER\r
+ OD;\r
+ WRITELN("MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE");\r
+ FOR J:=0 TO I\r
+ DO\r
+ WRITE(J); WRITE(" ");\r
+ W:=AT(J);\r
+ WRITE(W.ML,W.CL," ");\r
+ IF W.LEFT\r
+ THEN\r
+ WRITE("->");\r
+ ELSE\r
+ WRITE("<-");\r
+ FI;\r
+ WRITELN(" ",W.MR,W.CR);\r
+ OD;\r
+ KILL(AT);\r
+ END DISPLAY;\r
+\r
+ VAR BOOL1:BOOLEAN;\r
+\r
+ BEGIN\r
+ ROOT:=NEW STATE(NONE,N,N);\r
+ WRITE("DO YOU WANT TO OPTIMIZE ");\r
+ WRITELN("OR TO PRINT ALL THE SOLUTIONS ?");\r
+ WRITELN(" (ANSWER OPT OR ALL)");\r
+ READLN(H1,H2,H3);\r
+ IF H1='O' AND H2='P' AND H3='T'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ IF OPT =/= NONE ANDIF OPT.COST<FOUND.COST\r
+ THEN\r
+ EXIT\r
+ FI;\r
+ OD;\r
+ IF OPT =/= NONE\r
+ THEN\r
+ CALL DISPLAY(OPT);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ ELSE\r
+ WRITELN("NO SOLUTIONS");\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ FI;\r
+ ELSE\r
+ IF H1='A' AND H2='L' AND H3='L'\r
+ THEN\r
+ WRITELN("DO YOU WANT TO PRINT PARTIAL RESULTS?");\r
+ READLN(H1,H2,H3);\r
+ IF H1='Y' AND H2='E' AND H3='S'\r
+ THEN\r
+ BOOL1:=TRUE\r
+ FI;\r
+ DO\r
+ ATTACH(SEARCH);\r
+ CALL DISPLAY(FOUND);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ WRITELN("DO YOU WANT TO CONTINUE?");\r
+ READ(H1,H2);\r
+ IF H1=/='Y' ORIF H2=/='E' THEN EXIT FI;\r
+ READLN(H3);\r
+ IF H3=/='S' THEN EXIT FI;\r
+ OD;\r
+ ELSE\r
+ EXIT\r
+ FI\r
+ FI;\r
+ END;\r
+ OD;\r
+\r
+ END;\r
+\r
+END\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+ N= 5\r
+Boat capacity= 3\r
+\r
+State no: 0\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 <- 0 0\r
+\r
+State no: 1 son of state: 0\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 0\r
+\r
+State no: 2 son of state: 0 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 3 4 <- 0 0\r
+\r
+State no: 3 son of state: 0 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 2 5 <- 0 0\r
+\r
+State no: 4 son of state: 1\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 <- 0 0\r
+\r
+State no: 5 son of state: 1\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 <- 0 0\r
+\r
+State no: 6 son of state: 1\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 5 <- 0 0\r
+\r
+State no: 7 son of state: 1 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 6 2 <- 0 0\r
+\r
+State no: 8 son of state: 1 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 6 3 <- 0 0\r
+\r
+State no: 9 son of state: 1 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 7 2 <- 0 0\r
+\r
+State no: 10 son of state: 1 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 7 3 <- 0 0\r
+\r
+State no: 11 son of state: 1 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 8 2 <- 0 0\r
+\r
+State no: 12 son of state: 5\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 0\r
+\r
+State no: 13 son of state: 5\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 0 0\r
+\r
+State no: 14 son of state: 5 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 2 4 <- 0 0\r
+\r
+State no: 15 son of state: 13 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 3 4 <- 0 0\r
+\r
+State no: 16 son of state: 13 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 3 5 <- 0 0\r
+\r
+State no: 17 son of state: 13 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 3 6 <- 0 0\r
+\r
+State no: 18 son of state: 13\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 4 3 <- 0 0\r
+\r
+State no: 19 son of state: 13\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 4 4 <- 0 0\r
+\r
+State no: 20 son of state: 13\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 <- 0 0\r
+\r
+State no: 21 son of state: 13\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 4 <- 0 0\r
+\r
+State no: 22 son of state: 13 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 6 3 <- 0 0\r
+\r
+State no: 23 son of state: 20\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 0\r
+\r
+State no: 24 son of state: 20\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 3 2 <- 0 0\r
+\r
+State no: 25 son of state: 20 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 2 3 <- 0 0\r
+\r
+State no: 26 son of state: 23\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 <- 0 0\r
+\r
+State no: 27 son of state: 23 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 <- 0 0\r
+\r
+State no: 28 son of state: 23\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 3 <- 0 0\r
+\r
+State no: 29 son of state: 23 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 6 0 <- 0 0\r
+\r
+State no: 30 son of state: 23 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 6 1 <- 0 0\r
+\r
+State no: 31 son of state: 23 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 7 0 <- 0 0\r
+\r
+State no: 32 son of state: 23 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 7 1 <- 0 0\r
+\r
+State no: 33 son of state: 23 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 8 0 <- 0 0\r
+\r
+State no: 34 son of state: 27 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 5 -1 <- 0 0\r
+\r
+State no: 35 son of state: 27\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 3 1 <- 0 0\r
+\r
+State no: 36 son of state: 27\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 0 0\r
+\r
+State no: 37 son of state: 36 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 2 3 <- 0 0\r
+\r
+State no: 38 son of state: 36 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 2 4 <- 0 0\r
+\r
+State no: 39 son of state: 36 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 2 5 <- 0 0\r
+\r
+State no: 40 son of state: 36\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 2 <- 0 0\r
+\r
+State no: 41 son of state: 36 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 <- 0 0\r
+\r
+State no: 42 son of state: 36\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 4 2 <- 0 0\r
+\r
+State no: 43 son of state: 36\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 4 3 <- 0 0\r
+\r
+State no: 44 son of state: 36 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 5 2 <- 0 0\r
+\r
+State no: 45 son of state: 41\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 3 0 <- 0 0\r
+\r
+State no: 46 son of state: 41 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 1 2 <- 0 0\r
+\r
+State no: 47 son of state: 41\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 0 0\r
+\r
+State no: 48 son of state: 47\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 <- 0 0\r
+\r
+State no: 49 son of state: 47\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 <- 0 0\r
+\r
+State no: 50 son of state: 47 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 6 <- 0 0\r
+\r
+State no: 51 son of state: 47 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 1 3 <- 0 0\r
+\r
+State no: 52 son of state: 47 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 1 4 <- 0 0\r
+\r
+State no: 53 son of state: 47 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 2 3 <- 0 0\r
+\r
+State no: 54 son of state: 47 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 2 4 <- 0 0\r
+\r
+State no: 55 son of state: 47 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 3 3 <- 0 0\r
+\r
+State no: 56 son of state: 49\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 0 0\r
+\r
+State no: 57 son of state: 49 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 -2 4 <- 0 0\r
+\r
+State no: 58 son of state: 49 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 -3 5 <- 0 0\r
+\r
+State no: 59 son of state: 56 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 60 son of state: 56\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 61 son of state: 56\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 5 <- 0 0\r
+\r
+State no: 62 son of state: 56 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 63 son of state: 56 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 1 3 <- 0 0\r
+\r
+State no: 64 son of state: 56 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 65 son of state: 56 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 3 <- 0 0\r
+\r
+State no: 66 son of state: 56\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 3 2 <- 0 0\r
+\r
+State no: 67 son of state: 64 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 2 -1 <- 0 0\r
+\r
+State no: 68 son of state: 64\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 69 son of state: 64 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 -1 2 <- 0 0\r
+\r
+State no: 70 son of state: 68 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 <- 0 0\r
+\r
+State no: 71 son of state: 68 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 <- 0 0\r
+\r
+State no: 72 son of state: 68\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 <- 0 0\r
+\r
+State no: 73 son of state: 68\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 <- 0 0\r
+\r
+State no: 74 son of state: 68 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 2 <- 0 0\r
+\r
+State no: 75 son of state: 68\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 2 1 <- 0 0\r
+\r
+State no: 76 son of state: 68 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 <- 0 0\r
+\r
+State no: 77 son of state: 68\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 3 1 <- 0 0\r
+\r
+State no: 78 son of state: 73 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 1 -2 <- 0 0\r
+\r
+State no: 79 son of state: 73 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -1 0 <- 0 0\r
+\r
+State no: 80 son of state: 73 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 81 son of state: 72 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 -> 5 1\r
+ 15 0 1 <- 0 0\r
+\r
+State no: 82 son of state: 72 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 -> 5 1\r
+ 15 -2 3 <- 0 0\r
+\r
+State no: 83 son of state: 72 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 -> 5 1\r
+ 15 -3 4 <- 0 0\r
+\r
+State no: 84 son of state: 71 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 0 0 <- 0 0\r
+\r
+State no: 85 son of state: 71 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -2 2 <- 0 0\r
+\r
+State no: 86 son of state: 71 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -3 3 <- 0 0\r
+\r
+State no: 87 son of state: 70 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 0 -1 <- 0 0\r
+\r
+State no: 88 son of state: 70 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 89 son of state: 70 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -3 2 <- 0 0\r
+\r
+State no: 90 son of state: 60\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 91 son of state: 60 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 -2 3 <- 0 0\r
+\r
+State no: 92 son of state: 60 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 -3 4 <- 0 0\r
+\r
+State no: 93 son of state: 90 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 <- 0 0\r
+\r
+State no: 94 son of state: 90 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 <- 0 0\r
+\r
+State no: 95 son of state: 90\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 <- 0 0\r
+\r
+State no: 96 son of state: 90\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 <- 0 0\r
+\r
+State no: 97 son of state: 90 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 2 <- 0 0\r
+\r
+State no: 98 son of state: 90\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 1 <- 0 0\r
+\r
+State no: 99 son of state: 90 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 <- 0 0\r
+\r
+State no: 100 son of state: 90\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 3 1 <- 0 0\r
+\r
+State no: 101 son of state: 99 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 -> 3 3\r
+ 15 2 -1 <- 0 0\r
+\r
+State no: 102 son of state: 99 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 -> 3 3\r
+ 15 0 1 <- 0 0\r
+\r
+State no: 103 son of state: 99 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 -> 3 3\r
+ 15 -1 2 <- 0 0\r
+\r
+State no: 104 son of state: 96 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 1 -2 <- 0 0\r
+\r
+State no: 105 son of state: 96 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -1 0 <- 0 0\r
+\r
+State no: 106 son of state: 96 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 107 son of state: 94 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 0 0 <- 0 0\r
+\r
+State no: 108 son of state: 94 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -2 2 <- 0 0\r
+\r
+State no: 109 son of state: 94 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -3 3 <- 0 0\r
+\r
+State no: 110 son of state: 93 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 0 -1 <- 0 0\r
+\r
+State no: 111 son of state: 93 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 112 son of state: 93 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -3 2 <- 0 0\r
+\r
+State no: 113 son of state: 59 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 114 son of state: 59 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 115 son of state: 59 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 116 son of state: 48\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 117 son of state: 48 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 -2 3 <- 0 0\r
+\r
+State no: 118 son of state: 48 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 -3 4 <- 0 0\r
+\r
+State no: 119 son of state: 116\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 <- 0 0\r
+\r
+State no: 120 son of state: 116 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 121 son of state: 116\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 122 son of state: 116\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 <- 0 0\r
+\r
+State no: 123 son of state: 116 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 124 son of state: 116\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 1 <- 0 0\r
+\r
+State no: 125 son of state: 116 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 126 son of state: 116\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 3 1 <- 0 0\r
+\r
+State no: 127 son of state: 125 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 2 -1 <- 0 0\r
+\r
+State no: 128 son of state: 125 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 129 son of state: 125 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 -1 2 <- 0 0\r
+\r
+State no: 130 son of state: 122 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 1 -2 <- 0 0\r
+\r
+State no: 131 son of state: 122 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -1 0 <- 0 0\r
+\r
+State no: 132 son of state: 122 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 133 son of state: 120 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 134 son of state: 120 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 135 son of state: 120 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 136 son of state: 119 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 0 -1 <- 0 0\r
+\r
+State no: 137 son of state: 119 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 138 son of state: 119 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -3 2 <- 0 0\r
+\r
+State no: 139 son of state: 26 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 -> 0 4\r
+ 7 5 -2 <- 0 0\r
+\r
+State no: 140 son of state: 26\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 -> 0 4\r
+ 7 3 0 <- 0 0\r
+\r
+State no: 141 son of state: 26\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 -> 0 4\r
+ 7 2 1 <- 0 0\r
+\r
+State no: 142 son of state: 19\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 4 4 -> 1 1\r
+ 5 4 1 <- 0 0\r
+\r
+State no: 143 son of state: 19 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 4 4 -> 1 1\r
+ 5 2 3 <- 0 0\r
+\r
+State no: 144 son of state: 19 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 3 3 <- 2 2\r
+ 4 4 4 -> 1 1\r
+ 5 1 4 <- 0 0\r
+\r
+State no: 145 son of state: 12 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 <- 0 0\r
+\r
+State no: 146 son of state: 12\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 <- 0 0\r
+\r
+State no: 147 son of state: 12\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 4 <- 0 0\r
+\r
+State no: 148 son of state: 12 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 6 1 <- 0 0\r
+\r
+State no: 149 son of state: 12 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 6 2 <- 0 0\r
+\r
+State no: 150 son of state: 12 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 7 1 <- 0 0\r
+\r
+State no: 151 son of state: 12 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 7 2 <- 0 0\r
+\r
+State no: 152 son of state: 12 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 8 1 <- 0 0\r
+\r
+State no: 153 son of state: 146\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 0\r
+\r
+State no: 154 son of state: 146\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 3 2 <- 0 0\r
+\r
+State no: 155 son of state: 146 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 2 3 <- 0 0\r
+\r
+State no: 156 son of state: 153 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 <- 0 0\r
+\r
+State no: 157 son of state: 153 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 <- 0 0\r
+\r
+State no: 158 son of state: 153\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 3 <- 0 0\r
+\r
+State no: 159 son of state: 153 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 6 0 <- 0 0\r
+\r
+State no: 160 son of state: 153 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 6 1 <- 0 0\r
+\r
+State no: 161 son of state: 153 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 7 0 <- 0 0\r
+\r
+State no: 162 son of state: 153 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 7 1 <- 0 0\r
+\r
+State no: 163 son of state: 153 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 8 0 <- 0 0\r
+\r
+State no: 164 son of state: 157 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 5 -1 <- 0 0\r
+\r
+State no: 165 son of state: 157\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 3 1 <- 0 0\r
+\r
+State no: 166 son of state: 157\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 0 0\r
+\r
+State no: 167 son of state: 166 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 2 3 <- 0 0\r
+\r
+State no: 168 son of state: 166 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 2 4 <- 0 0\r
+\r
+State no: 169 son of state: 166 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 2 5 <- 0 0\r
+\r
+State no: 170 son of state: 166\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 2 <- 0 0\r
+\r
+State no: 171 son of state: 166\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 <- 0 0\r
+\r
+State no: 172 son of state: 166\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 4 2 <- 0 0\r
+\r
+State no: 173 son of state: 166\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 4 3 <- 0 0\r
+\r
+State no: 174 son of state: 166 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 5 2 <- 0 0\r
+\r
+State no: 175 son of state: 171\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 3 0 <- 0 0\r
+\r
+State no: 176 son of state: 171 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 1 2 <- 0 0\r
+\r
+State no: 177 son of state: 171\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 0 0\r
+\r
+State no: 178 son of state: 177\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 <- 0 0\r
+\r
+State no: 179 son of state: 177\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 <- 0 0\r
+\r
+State no: 180 son of state: 177 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 6 <- 0 0\r
+\r
+State no: 181 son of state: 177 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 1 3 <- 0 0\r
+\r
+State no: 182 son of state: 177 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 1 4 <- 0 0\r
+\r
+State no: 183 son of state: 177 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 2 3 <- 0 0\r
+\r
+State no: 184 son of state: 177 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 2 4 <- 0 0\r
+\r
+State no: 185 son of state: 177\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 3 3 <- 0 0\r
+\r
+State no: 186 son of state: 179\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 0 0\r
+\r
+State no: 187 son of state: 179 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 -2 4 <- 0 0\r
+\r
+State no: 188 son of state: 179 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 -3 5 <- 0 0\r
+\r
+State no: 189 son of state: 186 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 190 son of state: 186\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 191 son of state: 186\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 5 <- 0 0\r
+\r
+State no: 192 son of state: 186 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 193 son of state: 186 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 1 3 <- 0 0\r
+\r
+State no: 194 son of state: 186 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 195 son of state: 186 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 3 <- 0 0\r
+\r
+State no: 196 son of state: 186\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 3 2 <- 0 0\r
+\r
+State no: 197 son of state: 194 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 2 -1 <- 0 0\r
+\r
+State no: 198 son of state: 194\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 199 son of state: 194 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 -1 2 <- 0 0\r
+\r
+State no: 200 son of state: 198 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 <- 0 0\r
+\r
+State no: 201 son of state: 198 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 <- 0 0\r
+\r
+State no: 202 son of state: 198\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 <- 0 0\r
+\r
+State no: 203 son of state: 198\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 <- 0 0\r
+\r
+State no: 204 son of state: 198 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 2 <- 0 0\r
+\r
+State no: 205 son of state: 198\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 2 1 <- 0 0\r
+\r
+State no: 206 son of state: 198 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 <- 0 0\r
+\r
+State no: 207 son of state: 198\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 3 1 <- 0 0\r
+\r
+State no: 208 son of state: 203 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 1 -2 <- 0 0\r
+\r
+State no: 209 son of state: 203 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -1 0 <- 0 0\r
+\r
+State no: 210 son of state: 203 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 211 son of state: 202 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 -> 5 1\r
+ 15 0 1 <- 0 0\r
+\r
+State no: 212 son of state: 202 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 -> 5 1\r
+ 15 -2 3 <- 0 0\r
+\r
+State no: 213 son of state: 202 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 -> 5 1\r
+ 15 -3 4 <- 0 0\r
+\r
+State no: 214 son of state: 201 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 0 0 <- 0 0\r
+\r
+State no: 215 son of state: 201 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -2 2 <- 0 0\r
+\r
+State no: 216 son of state: 201 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -3 3 <- 0 0\r
+\r
+State no: 217 son of state: 200 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 0 -1 <- 0 0\r
+\r
+State no: 218 son of state: 200 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 219 son of state: 200 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -3 2 <- 0 0\r
+\r
+State no: 220 son of state: 190\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 221 son of state: 190 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 -2 3 <- 0 0\r
+\r
+State no: 222 son of state: 190 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 -3 4 <- 0 0\r
+\r
+State no: 223 son of state: 220 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 <- 0 0\r
+\r
+State no: 224 son of state: 220 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 <- 0 0\r
+\r
+State no: 225 son of state: 220\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 4 <- 0 0\r
+\r
+State no: 226 son of state: 220\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 <- 0 0\r
+\r
+State no: 227 son of state: 220 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 2 <- 0 0\r
+\r
+State no: 228 son of state: 220\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 1 <- 0 0\r
+\r
+State no: 229 son of state: 220 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 <- 0 0\r
+\r
+State no: 230 son of state: 220\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 3 1 <- 0 0\r
+\r
+State no: 231 son of state: 229 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 -> 3 3\r
+ 15 2 -1 <- 0 0\r
+\r
+State no: 232 son of state: 229 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 -> 3 3\r
+ 15 0 1 <- 0 0\r
+\r
+State no: 233 son of state: 229 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 2 2 -> 3 3\r
+ 15 -1 2 <- 0 0\r
+\r
+State no: 234 son of state: 226 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 1 -2 <- 0 0\r
+\r
+State no: 235 son of state: 226 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -1 0 <- 0 0\r
+\r
+State no: 236 son of state: 226 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 1 1 -> 4 4\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 237 son of state: 224 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 0 0 <- 0 0\r
+\r
+State no: 238 son of state: 224 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -2 2 <- 0 0\r
+\r
+State no: 239 son of state: 224 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 3 -> 5 2\r
+ 15 -3 3 <- 0 0\r
+\r
+State no: 240 son of state: 223 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 0 -1 <- 0 0\r
+\r
+State no: 241 son of state: 223 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -2 1 <- 0 0\r
+\r
+State no: 242 son of state: 223 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 5 4\r
+ 14 0 2 -> 5 3\r
+ 15 -3 2 <- 0 0\r
+\r
+State no: 243 son of state: 189 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 244 son of state: 189 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 245 son of state: 189 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 5 -> 5 0\r
+ 11 0 2 <- 5 3\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 246 son of state: 178\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 247 son of state: 178 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 -2 3 <- 0 0\r
+\r
+State no: 248 son of state: 178 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 -3 4 <- 0 0\r
+\r
+State no: 249 son of state: 246\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 <- 0 0\r
+\r
+State no: 250 son of state: 246 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 251 son of state: 246\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 252 son of state: 246\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 <- 0 0\r
+\r
+State no: 253 son of state: 246 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 254 son of state: 246\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 1 <- 0 0\r
+\r
+State no: 255 son of state: 246 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 256 son of state: 246\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 3 1 <- 0 0\r
+\r
+State no: 257 son of state: 255 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 2 -1 <- 0 0\r
+\r
+State no: 258 son of state: 255 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 259 son of state: 255 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 -1 2 <- 0 0\r
+\r
+State no: 260 son of state: 252 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 1 -2 <- 0 0\r
+\r
+State no: 261 son of state: 252 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -1 0 <- 0 0\r
+\r
+State no: 262 son of state: 252 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 263 son of state: 250 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 264 son of state: 250 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 265 son of state: 250 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 266 son of state: 249 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 0 -1 <- 0 0\r
+\r
+State no: 267 son of state: 249 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 268 son of state: 249 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 2 -> 0 3\r
+ 7 2 2 <- 3 3\r
+ 8 3 3 -> 2 2\r
+ 9 0 3 <- 5 2\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -3 2 <- 0 0\r
+\r
+State no: 269 son of state: 156 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 -> 0 4\r
+ 7 5 -2 <- 0 0\r
+\r
+State no: 270 son of state: 156\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 -> 0 4\r
+ 7 3 0 <- 0 0\r
+\r
+State no: 271 son of state: 156\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 3 -> 0 2\r
+ 5 5 0 <- 0 5\r
+ 6 5 1 -> 0 4\r
+ 7 2 1 <- 0 0\r
+\r
+State no: 272 son of state: 145 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 5 -1 <- 0 0\r
+\r
+State no: 273 son of state: 145\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 3 1 <- 0 0\r
+\r
+State no: 274 son of state: 145\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 0 0\r
+\r
+State no: 275 son of state: 274 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 2 3 <- 0 0\r
+\r
+State no: 276 son of state: 274 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 2 4 <- 0 0\r
+\r
+State no: 277 son of state: 274 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 2 5 <- 0 0\r
+\r
+State no: 278 son of state: 274\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 2 <- 0 0\r
+\r
+State no: 279 son of state: 274\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 <- 0 0\r
+\r
+State no: 280 son of state: 274\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 4 2 <- 0 0\r
+\r
+State no: 281 son of state: 274\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 4 3 <- 0 0\r
+\r
+State no: 282 son of state: 274 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 5 2 <- 0 0\r
+\r
+State no: 283 son of state: 279\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 3 0 <- 0 0\r
+\r
+State no: 284 son of state: 279 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 1 2 <- 0 0\r
+\r
+State no: 285 son of state: 279\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 0 0\r
+\r
+State no: 286 son of state: 285\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 <- 0 0\r
+\r
+State no: 287 son of state: 285\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 <- 0 0\r
+\r
+State no: 288 son of state: 285 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 6 <- 0 0\r
+\r
+State no: 289 son of state: 285 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 1 3 <- 0 0\r
+\r
+State no: 290 son of state: 285 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 1 4 <- 0 0\r
+\r
+State no: 291 son of state: 285 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 2 3 <- 0 0\r
+\r
+State no: 292 son of state: 285 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 2 4 <- 0 0\r
+\r
+State no: 293 son of state: 285\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 3 3 <- 0 0\r
+\r
+State no: 294 son of state: 287\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 0 0\r
+\r
+State no: 295 son of state: 287 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 -2 4 <- 0 0\r
+\r
+State no: 296 son of state: 287 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 -3 5 <- 0 0\r
+\r
+State no: 297 son of state: 294 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 <- 0 0\r
+\r
+State no: 298 son of state: 294\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 <- 0 0\r
+\r
+State no: 299 son of state: 294\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 5 <- 0 0\r
+\r
+State no: 300 son of state: 294 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 1 2 <- 0 0\r
+\r
+State no: 301 son of state: 294 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 1 3 <- 0 0\r
+\r
+State no: 302 son of state: 294 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 <- 0 0\r
+\r
+State no: 303 son of state: 294 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 3 <- 0 0\r
+\r
+State no: 304 son of state: 294\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 3 2 <- 0 0\r
+\r
+State no: 305 son of state: 302 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 2 -1 <- 0 0\r
+\r
+State no: 306 son of state: 302\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 307 son of state: 302 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 -1 2 <- 0 0\r
+\r
+State no: 308 son of state: 306 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 <- 0 0\r
+\r
+State no: 309 son of state: 306 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 310 son of state: 306\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 311 son of state: 306\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 <- 0 0\r
+\r
+State no: 312 son of state: 306 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 313 son of state: 306\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 2 1 <- 0 0\r
+\r
+State no: 314 son of state: 306 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 315 son of state: 306\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 3 1 <- 0 0\r
+\r
+State no: 316 son of state: 311 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 1 -2 <- 0 0\r
+\r
+State no: 317 son of state: 311 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -1 0 <- 0 0\r
+\r
+State no: 318 son of state: 311 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 319 son of state: 310 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 320 son of state: 310 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 -> 5 1\r
+ 13 -2 3 <- 0 0\r
+\r
+State no: 321 son of state: 310 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 -> 5 1\r
+ 13 -3 4 <- 0 0\r
+\r
+State no: 322 son of state: 309 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 323 son of state: 309 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 324 son of state: 309 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 325 son of state: 308 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 0 -1 <- 0 0\r
+\r
+State no: 326 son of state: 308 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 327 son of state: 308 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -3 2 <- 0 0\r
+\r
+State no: 328 son of state: 298\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 329 son of state: 298 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 -2 3 <- 0 0\r
+\r
+State no: 330 son of state: 298 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 -3 4 <- 0 0\r
+\r
+State no: 331 son of state: 328 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 <- 0 0\r
+\r
+State no: 332 son of state: 328 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 333 son of state: 328\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 334 son of state: 328\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 <- 0 0\r
+\r
+State no: 335 son of state: 328 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 336 son of state: 328\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 1 <- 0 0\r
+\r
+State no: 337 son of state: 328 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 338 son of state: 328\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 3 1 <- 0 0\r
+\r
+State no: 339 son of state: 337 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 2 -1 <- 0 0\r
+\r
+State no: 340 son of state: 337 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 341 son of state: 337 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 -1 2 <- 0 0\r
+\r
+State no: 342 son of state: 334 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 1 -2 <- 0 0\r
+\r
+State no: 343 son of state: 334 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -1 0 <- 0 0\r
+\r
+State no: 344 son of state: 334 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 345 son of state: 332 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 346 son of state: 332 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 347 son of state: 332 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 348 son of state: 331 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 0 -1 <- 0 0\r
+\r
+State no: 349 son of state: 331 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 350 son of state: 331 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -3 2 <- 0 0\r
+\r
+State no: 351 son of state: 297 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 -> 5 2\r
+ 11 0 0 <- 0 0\r
+\r
+State no: 352 son of state: 297 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 -> 5 2\r
+ 11 -2 2 <- 0 0\r
+\r
+State no: 353 son of state: 297 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 -> 5 2\r
+ 11 -3 3 <- 0 0\r
+\r
+State no: 354 son of state: 286\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 0 0\r
+\r
+State no: 355 son of state: 286 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 -2 3 <- 0 0\r
+\r
+State no: 356 son of state: 286 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 -3 4 <- 0 0\r
+\r
+State no: 357 son of state: 354\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 <- 0 0\r
+\r
+State no: 358 son of state: 354 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 <- 0 0\r
+\r
+State no: 359 son of state: 354\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 4 <- 0 0\r
+\r
+State no: 360 son of state: 354\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 <- 0 0\r
+\r
+State no: 361 son of state: 354 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 2 <- 0 0\r
+\r
+State no: 362 son of state: 354\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 1 <- 0 0\r
+\r
+State no: 363 son of state: 354 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 <- 0 0\r
+\r
+State no: 364 son of state: 354\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 3 1 <- 0 0\r
+\r
+State no: 365 son of state: 363 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 -> 3 3\r
+ 11 2 -1 <- 0 0\r
+\r
+State no: 366 son of state: 363 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 367 son of state: 363 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 -> 3 3\r
+ 11 -1 2 <- 0 0\r
+\r
+State no: 368 son of state: 360 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 -> 4 4\r
+ 11 1 -2 <- 0 0\r
+\r
+State no: 369 son of state: 360 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 -> 4 4\r
+ 11 -1 0 <- 0 0\r
+\r
+State no: 370 son of state: 360 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 -> 4 4\r
+ 11 -2 1 <- 0 0\r
+\r
+State no: 371 son of state: 358 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 -> 5 2\r
+ 11 0 0 <- 0 0\r
+\r
+State no: 372 son of state: 358 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 -> 5 2\r
+ 11 -2 2 <- 0 0\r
+\r
+State no: 373 son of state: 358 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 -> 5 2\r
+ 11 -3 3 <- 0 0\r
+\r
+State no: 374 son of state: 357 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 -> 5 3\r
+ 11 0 -1 <- 0 0\r
+\r
+State no: 375 son of state: 357 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 -> 5 3\r
+ 11 -2 1 <- 0 0\r
+\r
+State no: 376 son of state: 357 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 4 -> 0 1\r
+ 3 5 1 <- 0 4\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 -> 5 3\r
+ 11 -3 2 <- 0 0\r
+\r
+State no: 377 son of state: 4\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 0\r
+\r
+State no: 378 son of state: 4\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 3 2 <- 0 0\r
+\r
+State no: 379 son of state: 4 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 2 3 <- 0 0\r
+\r
+State no: 380 son of state: 377\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 1 <- 0 0\r
+\r
+State no: 381 son of state: 377 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 <- 0 0\r
+\r
+State no: 382 son of state: 377\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 3 <- 0 0\r
+\r
+State no: 383 son of state: 377 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 6 0 <- 0 0\r
+\r
+State no: 384 son of state: 377 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 6 1 <- 0 0\r
+\r
+State no: 385 son of state: 377 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 7 0 <- 0 0\r
+\r
+State no: 386 son of state: 377 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 7 1 <- 0 0\r
+\r
+State no: 387 son of state: 377 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 8 0 <- 0 0\r
+\r
+State no: 388 son of state: 381 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 5 -1 <- 0 0\r
+\r
+State no: 389 son of state: 381\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 3 1 <- 0 0\r
+\r
+State no: 390 son of state: 381\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 0 0\r
+\r
+State no: 391 son of state: 390 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 2 3 <- 0 0\r
+\r
+State no: 392 son of state: 390 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 2 4 <- 0 0\r
+\r
+State no: 393 son of state: 390 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 2 5 <- 0 0\r
+\r
+State no: 394 son of state: 390\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 2 <- 0 0\r
+\r
+State no: 395 son of state: 390\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 <- 0 0\r
+\r
+State no: 396 son of state: 390\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 4 2 <- 0 0\r
+\r
+State no: 397 son of state: 390\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 4 3 <- 0 0\r
+\r
+State no: 398 son of state: 390 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 5 2 <- 0 0\r
+\r
+State no: 399 son of state: 395\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 3 0 <- 0 0\r
+\r
+State no: 400 son of state: 395 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 1 2 <- 0 0\r
+\r
+State no: 401 son of state: 395\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 0 0\r
+\r
+State no: 402 son of state: 401\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 <- 0 0\r
+\r
+State no: 403 son of state: 401\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 <- 0 0\r
+\r
+State no: 404 son of state: 401 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 6 <- 0 0\r
+\r
+State no: 405 son of state: 401 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 1 3 <- 0 0\r
+\r
+State no: 406 son of state: 401 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 1 4 <- 0 0\r
+\r
+State no: 407 son of state: 401 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 2 3 <- 0 0\r
+\r
+State no: 408 son of state: 401 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 2 4 <- 0 0\r
+\r
+State no: 409 son of state: 401\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 3 3 <- 0 0\r
+\r
+State no: 410 son of state: 403\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 0 0\r
+\r
+State no: 411 son of state: 403 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 -2 4 <- 0 0\r
+\r
+State no: 412 son of state: 403 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 -3 5 <- 0 0\r
+\r
+State no: 413 son of state: 410 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 <- 0 0\r
+\r
+State no: 414 son of state: 410\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 <- 0 0\r
+\r
+State no: 415 son of state: 410\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 5 <- 0 0\r
+\r
+State no: 416 son of state: 410 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 1 2 <- 0 0\r
+\r
+State no: 417 son of state: 410 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 1 3 <- 0 0\r
+\r
+State no: 418 son of state: 410 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 <- 0 0\r
+\r
+State no: 419 son of state: 410 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 3 <- 0 0\r
+\r
+State no: 420 son of state: 410\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 3 2 <- 0 0\r
+\r
+State no: 421 son of state: 418 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 2 -1 <- 0 0\r
+\r
+State no: 422 son of state: 418\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 423 son of state: 418 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 -1 2 <- 0 0\r
+\r
+State no: 424 son of state: 422 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 <- 0 0\r
+\r
+State no: 425 son of state: 422 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 426 son of state: 422\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 427 son of state: 422\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 <- 0 0\r
+\r
+State no: 428 son of state: 422 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 429 son of state: 422\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 2 1 <- 0 0\r
+\r
+State no: 430 son of state: 422 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 431 son of state: 422\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 3 1 <- 0 0\r
+\r
+State no: 432 son of state: 427 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 1 -2 <- 0 0\r
+\r
+State no: 433 son of state: 427 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -1 0 <- 0 0\r
+\r
+State no: 434 son of state: 427 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 435 son of state: 426 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 -> 5 1\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 436 son of state: 426 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 -> 5 1\r
+ 13 -2 3 <- 0 0\r
+\r
+State no: 437 son of state: 426 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 -> 5 1\r
+ 13 -3 4 <- 0 0\r
+\r
+State no: 438 son of state: 425 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 439 son of state: 425 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 440 son of state: 425 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 441 son of state: 424 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 0 -1 <- 0 0\r
+\r
+State no: 442 son of state: 424 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 443 son of state: 424 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -3 2 <- 0 0\r
+\r
+State no: 444 son of state: 414\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 445 son of state: 414 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 -2 3 <- 0 0\r
+\r
+State no: 446 son of state: 414 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 -3 4 <- 0 0\r
+\r
+State no: 447 son of state: 444 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 <- 0 0\r
+\r
+State no: 448 son of state: 444 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 <- 0 0\r
+\r
+State no: 449 son of state: 444\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 4 <- 0 0\r
+\r
+State no: 450 son of state: 444\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 <- 0 0\r
+\r
+State no: 451 son of state: 444 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 2 <- 0 0\r
+\r
+State no: 452 son of state: 444\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 1 <- 0 0\r
+\r
+State no: 453 son of state: 444 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 <- 0 0\r
+\r
+State no: 454 son of state: 444\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 3 1 <- 0 0\r
+\r
+State no: 455 son of state: 453 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 2 -1 <- 0 0\r
+\r
+State no: 456 son of state: 453 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 0 1 <- 0 0\r
+\r
+State no: 457 son of state: 453 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 2 2 -> 3 3\r
+ 13 -1 2 <- 0 0\r
+\r
+State no: 458 son of state: 450 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 1 -2 <- 0 0\r
+\r
+State no: 459 son of state: 450 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -1 0 <- 0 0\r
+\r
+State no: 460 son of state: 450 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 1 1 -> 4 4\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 461 son of state: 448 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 0 0 <- 0 0\r
+\r
+State no: 462 son of state: 448 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -2 2 <- 0 0\r
+\r
+State no: 463 son of state: 448 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 3 -> 5 2\r
+ 13 -3 3 <- 0 0\r
+\r
+State no: 464 son of state: 447 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 0 -1 <- 0 0\r
+\r
+State no: 465 son of state: 447 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -2 1 <- 0 0\r
+\r
+State no: 466 son of state: 447 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 4 -> 5 1\r
+ 11 0 1 <- 5 4\r
+ 12 0 2 -> 5 3\r
+ 13 -3 2 <- 0 0\r
+\r
+State no: 467 son of state: 413 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 -> 5 2\r
+ 11 0 0 <- 0 0\r
+\r
+State no: 468 son of state: 413 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 -> 5 2\r
+ 11 -2 2 <- 0 0\r
+\r
+State no: 469 son of state: 413 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 5 -> 5 0\r
+ 9 0 2 <- 5 3\r
+ 10 0 3 -> 5 2\r
+ 11 -3 3 <- 0 0\r
+\r
+State no: 470 son of state: 402\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 0 0\r
+\r
+State no: 471 son of state: 402 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 -2 3 <- 0 0\r
+\r
+State no: 472 son of state: 402 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 -3 4 <- 0 0\r
+\r
+State no: 473 son of state: 470\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 <- 0 0\r
+\r
+State no: 474 son of state: 470 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 <- 0 0\r
+\r
+State no: 475 son of state: 470\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 4 <- 0 0\r
+\r
+State no: 476 son of state: 470\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 <- 0 0\r
+\r
+State no: 477 son of state: 470 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 2 <- 0 0\r
+\r
+State no: 478 son of state: 470\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 1 <- 0 0\r
+\r
+State no: 479 son of state: 470 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 <- 0 0\r
+\r
+State no: 480 son of state: 470\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 3 1 <- 0 0\r
+\r
+State no: 481 son of state: 479 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 -> 3 3\r
+ 11 2 -1 <- 0 0\r
+\r
+State no: 482 son of state: 479 REDUNDANT STATE\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 -> 3 3\r
+ 11 0 1 <- 0 0\r
+\r
+State no: 483 son of state: 479 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 2 2 -> 3 3\r
+ 11 -1 2 <- 0 0\r
+\r
+State no: 484 son of state: 476 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 -> 4 4\r
+ 11 1 -2 <- 0 0\r
+\r
+State no: 485 son of state: 476 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 -> 4 4\r
+ 11 -1 0 <- 0 0\r
+\r
+State no: 486 son of state: 476 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 1 1 -> 4 4\r
+ 11 -2 1 <- 0 0\r
+\r
+State no: 487 son of state: 474 SOLUTION!\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 -> 5 2\r
+ 11 0 0 <- 0 0\r
+\r
+State no: 488 son of state: 474 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 -> 5 2\r
+ 11 -2 2 <- 0 0\r
+\r
+State no: 489 son of state: 474 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 3 -> 5 2\r
+ 11 -3 3 <- 0 0\r
+\r
+State no: 490 son of state: 473 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 -> 5 3\r
+ 11 0 -1 <- 0 0\r
+\r
+State no: 491 son of state: 473 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 -> 5 3\r
+ 11 -2 1 <- 0 0\r
+\r
+State no: 492 son of state: 473 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 2 -> 0 3\r
+ 5 2 2 <- 3 3\r
+ 6 3 3 -> 2 2\r
+ 7 0 3 <- 5 2\r
+ 8 0 4 -> 5 1\r
+ 9 0 1 <- 5 4\r
+ 10 0 2 -> 5 3\r
+ 11 -3 2 <- 0 0\r
+\r
+State no: 493 son of state: 380 DEADEND\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 1 -> 0 4\r
+ 5 5 -2 <- 0 0\r
+\r
+State no: 494 son of state: 380\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 1 -> 0 4\r
+ 5 3 0 <- 0 0\r
+\r
+State no: 495 son of state: 380\r
+MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE\r
+ 0 5 5 -> 0 0\r
+ 1 5 2 <- 0 3\r
+ 2 5 3 -> 0 2\r
+ 3 5 0 <- 0 5\r
+ 4 5 1 -> 0 4\r
+ 5 2 1 <- 0 0\r
--- /dev/null
+PROGRAM STSEARCH;\r
+ \r
+ UNIT BACKTRACK: CLASS;\r
+ HIDDEN SE,ELEM,TOP;\r
+ VAR ROOT:NODE,SEARCH:SE,FOUND,OPT:NODE,\r
+ NUMBER_OF_NODES,NUMBER_OF_LEAVES,NUMBER_OF_ANSWERS:INTEGER;\r
+ \r
+\r
+ UNIT NODE: COROUTINE(FATHER:NODE);\r
+ VAR NSONS,LEVEL, MY_NUMBER: INTEGER , DEADEND:BOOLEAN;\r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ END LEAF;\r
+ UNIT VIRTUAL ANSWER :FUNCTION :BOOLEAN;\r
+ END ANSWER;\r
+ UNIT VIRTUAL LASTSON: FUNCTION : BOOLEAN;\r
+ END LASTSON;\r
+ UNIT VIRTUAL NEXTSON: FUNCTION : NODE;\r
+ END NEXTSON;\r
+ UNIT VIRTUAL EQUAL : FUNCTION (W:NODE):BOOLEAN;\r
+ END EQUAL;\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ END COST;\r
+ UNIT VIRTUAL Display: PROCEDURE;\r
+ END DISPLAY;\r
+ BEGIN\r
+ MY_NUMBER := NUMBER_OF_NODES;\r
+ NUMBER_OF_NODES := NUMBER_OF_NODES+1;\r
+ IF FATHER =/= NONE\r
+ THEN\r
+ LEVEL:=FATHER.LEVEL+1\r
+ ELSE\r
+ LEVEL:=0\r
+ FI;\r
+ call this NODE.DISPLAY;\r
+ END NODE;\r
+\r
+ UNIT OK: FUNCTION (V:NODE):BOOLEAN;\r
+ VAR W:NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RESULT:=FALSE; RETURN FI;\r
+ RESULT:=TRUE; W:=V.FATHER;\r
+ WHILE W =/= NONE\r
+ DO\r
+ IF V.EQUAL(W) THEN RESULT:=FALSE; RETURN FI;\r
+ W:=W.FATHER\r
+ OD\r
+ END OK;\r
+\r
+ UNIT PURGE: PROCEDURE (V:NODE);\r
+ VAR W: NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RETURN FI;\r
+ DO\r
+ W:=V.FATHER; KILL(V);\r
+ IF W=NONE THEN RETURN FI;\r
+ W.NSONS:=W.NSONS-1;\r
+ IF W.NSONS =/= 0 THEN RETURN FI;\r
+ V:=W\r
+ OD;\r
+ END PURGE;\r
+\r
+ VAR TOP:ELEM;\r
+\r
+ UNIT ELEM: CLASS (NEXT:ELEM, V:NODE);\r
+ END ELEM;\r
+\r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ BEGIN\r
+ TOP:=NEW ELEM(TOP,V);\r
+ END INSERT;\r
+\r
+ UNIT VIRTUAL DELETE: FUNCTION :NODE;\r
+ VAR E:ELEM;\r
+ BEGIN\r
+ IF TOP =/= NONE\r
+ THEN\r
+ RESULT:=TOP.V;\r
+ E:=TOP; TOP:=TOP.NEXT; KILL(E);\r
+ FI;\r
+ END DELETE;\r
+\r
+ UNIT SE: COROUTINE ;\r
+ VAR I:INTEGER,V,W:NODE;\r
+ BEGIN\r
+ RETURN; CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN EXIT FI;\r
+ ATTACH(V);\r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ FOUND:=V;\r
+ IF OPT=NONE ORIF V.COST < OPT.COST\r
+ THEN\r
+ OPT:=V\r
+ FI;\r
+ DETACH;\r
+ (* HERE THE USER OF BACKTRACK MAY UNDERTAKE SOME ACTIONS\r
+ ON THE ANSWER NODES. IF NOT NECESSARY DO ATTACH *)\r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V);\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ (* NUMBER_OF_NODES:=NUMBER_OF_NODES+1; *)\r
+ IF OK(W)\r
+ THEN\r
+ W.DEADEND:=W.LEAF; \r
+ CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI;\r
+ OD;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FOUND:=NONE;\r
+ END SE;\r
+\r
+\r
+ UNIT KILLALL :PROCEDURE;\r
+ VAR V:NODE;\r
+ BEGIN\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN RETURN FI;\r
+ CALL PURGE(V);\r
+ OD;\r
+ END KILLALL;\r
+\r
+ BEGIN\r
+ SEARCH:=NEW SE;\r
+ INNER;\r
+ KILL(SEARCH); CALL KILLALL;\r
+ END BACKTRACK;\r
+\r
+\r
+ VAR N,Q:INTEGER,\r
+ H1,H2,H3:CHAR,\r
+ f: file;\r
+ (* Q - BOAT CAPACITY, N- NUMBER OF CANNIBALS, N- NUMBER OF MISSIONARIES *)\r
+\r
+ BEGIN\r
+ open(f,text,unpack("stsearch.his"));\r
+ call rewrite(f);\r
+ DO\r
+ writeln; writeln;\r
+ writeln("N Cannibals and N Missionars are to traverse a river in a boat");\r
+\r
+ WRITE(" N= (tape 0 to stop program)");\r
+ READLN(N);\r
+ IF N=0 THEN EXIT FI;\r
+ writeln("Cannibals & Missionars - program STSEARCH.LOG of 26.05.94 ");\r
+ WRITELN(f," N= ",N);\r
+ WRITE(" BOAT CAPACITY=");\r
+ READLN(Q);\r
+ WRITELN(f,"Boat capacity=",Q);\r
+ PREF BACKTRACK BLOCK\r
+ VAR M,C:INTEGER;\r
+ (* M- NUMBER OF MISSIONARIES, C- NUMBER OF CANNIBALS ON THE BOAT *)\r
+\r
+ UNIT STATE: NODE CLASS(ML,CL:INTEGER);\r
+ VAR MR,CR:INTEGER, LEFT:BOOLEAN;\r
+\r
+ (* ML- NUMBER OF MISSIONARIES ON THE LEFT BANK OF THE RIVER\r
+ MR- NUMBER OF MISSIONARIES ON THE RIGHT BANK OF THE RIVER\r
+ CL- NUMBER OF CANNIBALS ON THE LEFT BANK OF THE RIVER\r
+ CR- NUMBER OF CANNIBALS ON THE RIGHT BANK OF THE RIVER\r
+ LEFT- TRUE IFF THE BOAT IS ON THE LEFT BANK OF THE RIVER *)\r
+\r
+ UNIT VIRTUAL ANSWER: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:=ML=0 AND CL=0\r
+ END ANSWER;\r
+\r
+ UNIT VIRTUAL LEAF: FUNCTION : BOOLEAN;\r
+ BEGIN\r
+ IF ML<0 ORIF MR<0 ORIF CL<0 ORIF CR<0 ORIF\r
+ ML>N ORIF MR>N ORIF CL>N ORIF CR>N ORIF\r
+ ML<CL AND ML>0 ORIF MR<CR AND MR>0\r
+ THEN\r
+ RESULT:=TRUE\r
+ FI\r
+ END LEAF;\r
+\r
+\r
+ UNIT VIRTUAL LASTSON: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ IF C=0 AND M=Q\r
+ THEN\r
+ RESULT:=TRUE; M:=0; C:=0;\r
+ FI;\r
+ END;\r
+\r
+ UNIT VIRTUAL NEXTSON : FUNCTION :STATE;\r
+ BEGIN\r
+ C:=C+1;\r
+ IF M=0\r
+ THEN\r
+ IF C>Q\r
+ THEN\r
+ C:=0; M:=1\r
+ FI\r
+ ELSE\r
+ IF M<C ORIF M+C>Q\r
+ THEN\r
+ C:=0; M:=M+1;\r
+ FI\r
+ FI;\r
+ IF LEFT\r
+ THEN\r
+ IF C+M<Q\r
+ THEN\r
+ RESULT:=NONE\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,ML-M,CL-C)\r
+ FI\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,ML+M,CL+C)\r
+ FI;\r
+ END NEXTSON;\r
+\r
+ UNIT VIRTUAL EQUAL: FUNCTION(S:STATE):BOOLEAN;\r
+ BEGIN\r
+ RESULT:=LEFT=S.LEFT AND ML=S.ML AND CL=S.CL;\r
+ END EQUAL;\r
+\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ BEGIN\r
+ RESULT:=LEVEL\r
+ END COST;\r
+ \r
+ UNIT VIRTUAL DISPLAY: PROCEDURE;\r
+ VAR J,I:INTEGER, \r
+ V, W:STATE,\r
+ AT: ARRAYOF STATE;\r
+ BEGIN\r
+ V := this STATE;\r
+ I:=V.LEVEL;\r
+ ARRAY AT DIM (0:I);\r
+ W:=V;\r
+ FOR J:=I DOWNTO 0\r
+ DO\r
+ AT(J):=W; W:=W.FATHER\r
+ OD;\r
+ WRITELN(f);\r
+ WRITE(f,"State no:",MY_NUMBER:4);\r
+ if FATHER <> none then WRITE(f," son of state: ",FATHER.MY_NUMBER:4) fi;\r
+ if ANSWER then WRITELN(f, " SOLUTION!") \r
+ else if LEAF then WRITELN(f," DEADEND")\r
+ else if not OK(V) then WRITELN(f," REDUNDANT STATE")\r
+ else WRITELN(f)\r
+ fi\r
+ fi\r
+ fi;\r
+\r
+ WRITELN(f,"MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE");\r
+ FOR J:=0 TO I\r
+ DO\r
+ WRITE(f,J); WRITE(f," ");\r
+ W:=AT(J);\r
+ WRITE(f,W.ML,W.CL," ");\r
+ IF W.LEFT\r
+ THEN\r
+ WRITE(f,"->");\r
+ ELSE\r
+ WRITE(f,"<-");\r
+ FI;\r
+ WRITELN(f," ",W.MR,W.CR);\r
+ OD;\r
+ KILL(AT);\r
+ END DISPLAY;\r
+\r
+\r
+ BEGIN\r
+ LEFT:=LEVEL MOD 2 = 0;\r
+ MR:=N-ML; CR:=N-CL;\r
+ RETURN;\r
+ DO\r
+ DETACH\r
+ OD;\r
+ END STATE;\r
+\r
+\r
+ UNIT DISPLAY: PROCEDURE(V:STATE);\r
+ VAR J,I:INTEGER, W:STATE,AT: ARRAYOF STATE;\r
+ BEGIN\r
+ IF V=NONE THEN WRITELN(" NO MORE SOLUTIONS"); RETURN FI;\r
+ I:=V.LEVEL;\r
+ ARRAY AT DIM (0:I);\r
+ W:=V;\r
+ FOR J:=I DOWNTO 0\r
+ DO\r
+ AT(J):=W; W:=W.FATHER\r
+ OD;\r
+ WRITELN("MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE");\r
+ FOR J:=0 TO I\r
+ DO\r
+ WRITE(J); WRITE(" ");\r
+ W:=AT(J);\r
+ WRITE(W.ML,W.CL," ");\r
+ IF W.LEFT\r
+ THEN\r
+ WRITE("->");\r
+ ELSE\r
+ WRITE("<-");\r
+ FI;\r
+ WRITELN(" ",W.MR,W.CR);\r
+ OD;\r
+ KILL(AT);\r
+ END DISPLAY;\r
+\r
+ BEGIN\r
+ ROOT:=NEW STATE(NONE,N,N);\r
+ WRITE("DO YOU WANT TO OPTIMIZE ");\r
+ WRITELN("OR TO PRINT ALL THE SOLUTIONS ?");\r
+ WRITELN(" (ANSWER OPT OR ALL)");\r
+ READLN(H1,H2,H3);\r
+ IF H1='O' AND H2='P' AND H3='T'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ (* IF OPT =/= NONE ANDIF OPT.COST<FOUND.COST\r
+ THEN\r
+ EXIT\r
+ FI; *)\r
+ OD;\r
+ IF OPT =/= NONE\r
+ THEN\r
+ CALL DISPLAY(OPT);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ ELSE\r
+ WRITELN("NO SOLUTIONS");\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ FI;\r
+ ELSE\r
+ IF H1='A' AND H2='L' AND H3='L'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ CALL DISPLAY(FOUND);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ WRITELN("DO YOU WANT TO CONTINUE?");\r
+ READ(H1,H2);\r
+ IF H1=/='Y' ORIF H2=/='E' THEN EXIT FI;\r
+ READLN(H3);\r
+ IF H3=/='S' THEN EXIT FI;\r
+ OD;\r
+ FI\r
+ FI;\r
+ END; (* of prefixed block*)\r
+ OD;\r
+ kill(f);\r
+ writeln("the tree is in the file STSEARCH.HIS");\r
+\r
+ END; (* of program *)\r
+\r
+\r
+\r
--- /dev/null
+BLOCK
+(* BANK DEPARTMENT SERVICE SIMULATION *)
+
+
+
+UNIT PRIORITYQUEUE: CLASS;
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)
+
+
+
+ UNIT QUEUEHEAD: CLASS;
+ (* HEAP ACCESING MODULE *)
+ VAR LAST,ROOT:NODE;
+
+ UNIT MIN: FUNCTION: ELEM;
+ BEGIN
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;
+ END MIN;
+
+ UNIT INSERT: PROCEDURE(R:ELEM);
+ (* INSERTION INTO HEAP *)
+ VAR X,Z:NODE;
+ BEGIN
+ X:= R.LAB;
+ IF LAST=NONE THEN
+ ROOT:=X;
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT
+ ELSE
+ IF LAST.NS=0 THEN
+ LAST.NS:=1;
+ Z:=LAST.LEFT;
+ LAST.LEFT:=X;
+ X.UP:=LAST;
+ X.LEFT:=Z;
+ Z.RIGHT:=X;
+ ELSE
+ LAST.NS:=2;
+ Z:=LAST.RIGHT;
+ LAST.RIGHT:=X;
+ X.RIGHT:=Z;
+ X.UP:=LAST;
+ Z.LEFT:=X;
+ LAST.LEFT.RIGHT:=X;
+ X.LEFT:=LAST.LEFT;
+ LAST:=Z;
+ FI
+ FI;
+ CALL CORRECT(R,FALSE)
+ END INSERT;
+
+UNIT DELETE: PROCEDURE(R: ELEM);
+ VAR X,Y,Z:NODE;
+ BEGIN
+ X:=R.LAB;
+ Z:=LAST.LEFT;
+ IF LAST.NS =0 THEN
+ Y:= Z.UP;
+ Y.RIGHT:= LAST;
+ LAST.LEFT:=Y;
+ LAST:=Y;
+ ELSE
+ Y:= Z.LEFT;
+ Y.RIGHT:= LAST;
+ LAST.LEFT:= Y;
+ FI;
+ Z.EL.LAB:=X;
+ X.EL:= Z.EL;
+ LAST.NS:= LAST.NS-1;
+ R.LAB:=Z;
+ Z.EL:=R;
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)
+ ELSE CALL CORRECT(X.EL,TRUE) FI;
+ END DELETE;
+
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;
+ BEGIN
+ Z:=R.LAB;
+ IF DOWN THEN
+ WHILE NOT FIN DO
+ IF Z.NS =0 THEN FIN:=TRUE ELSE
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT
+ FI; FI;
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE
+ T:=X.EL;
+ X.EL:=Z.EL;
+ Z.EL:=T;
+ Z.EL.LAB:=Z;
+ X.EL.LAB:=X
+ FI; FI;
+ Z:=X;
+ OD
+ ELSE
+ X:=Z.UP;
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;
+ WHILE NOT LOG DO
+ T:=Z.EL;
+ Z.EL:=X.EL;
+ X.EL:=T;
+ X.EL.LAB:=X;
+ Z.EL.LAB:=Z;
+ Z:=X;
+ X:=Z.UP;
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);
+ FI;
+ OD
+ FI;
+ END CORRECT;
+
+END QUEUEHEAD;
+
+
+UNIT NODE: CLASS (EL:ELEM);
+ (* ELEMENT OF THE HEAP *)
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;
+ BEGIN
+ IF X= NONE THEN RESULT:=FALSE
+ ELSE RESULT:=EL.LESS(X.EL) FI;
+ END LESS;
+ END NODE;
+
+
+UNIT ELEM: CLASS(PRIOR:REAL);
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)
+ VAR LAB: NODE;
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;
+ BEGIN
+ IF X=NONE THEN RESULT:= FALSE ELSE
+ RESULT:= PRIOR< X.PRIOR FI;
+ END LESS;
+ BEGIN
+ LAB:= NEW NODE(THIS ELEM);
+ END ELEM;
+
+
+END PRIORITYQUEUE;
+
+
+
+UNIT SIMULATION: PRIORITYQUEUE CLASS;
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)
+
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)
+ MAINPR: MAINPROGRAM;
+
+
+ UNIT SIMPROCESS: COROUTINE;
+ (* USER PROCESS PREFIX *)
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)
+ EVENTAUX: EVENTNOTICE,
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)
+ FINISH: BOOLEAN;
+
+ UNIT IDLE: FUNCTION: BOOLEAN;
+ BEGIN
+ RESULT:= EVENT= NONE;
+ END IDLE;
+
+ UNIT TERMINATED: FUNCTION :BOOLEAN;
+ BEGIN
+ RESULT:= FINISH;
+ END TERMINATED;
+
+ UNIT EVTIME: FUNCTION: REAL;
+ (* TIME OF ACTIVATION *)
+ BEGIN
+ IF IDLE THEN CALL ERROR1;
+ FI;
+ RESULT:= EVENT.EVENTTIME;
+ END EVTIME;
+
+ UNIT ERROR1:PROCEDURE;
+ BEGIN
+ ATTACH(MAIN);
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");
+ END ERROR1;
+
+ UNIT ERROR2:PROCEDURE;
+ BEGIN
+ ATTACH(MAIN);
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");
+ END ERROR2;
+ BEGIN
+
+ RETURN;
+ INNER;
+ FINISH:=TRUE;
+ CALL PASSIVATE;
+ CALL ERROR2;
+ END SIMPROCESS;
+
+
+UNIT EVENTNOTICE: ELEM CLASS;
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;
+
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)
+ BEGIN
+ IF X=NONE THEN RESULT:= FALSE ELSE
+ RESULT:= EVENTTIME< X.EVENTTIME OR
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;
+
+ END LESS;
+ END EVENTNOTICE;
+
+
+UNIT MAINPROGRAM: SIMPROCESS CLASS;
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)
+ BEGIN
+ DO ATTACH(MAIN) OD;
+ END MAINPROGRAM;
+
+UNIT TIME:FUNCTION:REAL;
+ (* CURRENT VALUE OF SIMULATION TIME *)
+ BEGIN
+ RESULT:=CURRENT.EVTIME
+ END TIME;
+
+UNIT CURRENT: FUNCTION: SIMPROCESS;
+ (* THE FIRST PROCESS ON THE TIME AXIS *)
+ BEGIN
+ RESULT:=CURR;
+ END CURRENT;
+
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)
+ (* WITHIN TIME MOMENT T *)
+ BEGIN
+ IF T<TIME THEN T:= TIME FI;
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);
+ P.EVENT.PROC:= P;
+ ELSE
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN
+ P.EVENT:= P.EVENTAUX;
+ P.EVENT.PRIOR:=RANDOM;
+ ELSE
+ (* NEW SCHEDULING *)
+ P.EVENT.PRIOR:=RANDOM;
+ CALL PQ.DELETE(P.EVENT)
+ FI; FI;
+ P.EVENT.EVENTTIME:= T;
+ CALL PQ.INSERT(P.EVENT) FI;
+END SCHEDULE;
+
+UNIT HOLD:PROCEDURE(T:REAL);
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)
+ (* REDEFINE PRIOR *)
+ BEGIN
+ CALL PQ.DELETE(CURRENT.EVENT);
+ CURRENT.EVENT.PRIOR:=RANDOM;
+ IF T<0 THEN T:=0; FI;
+ CURRENT.EVENT.EVENTTIME:=TIME+T;
+ CALL PQ.INSERT(CURRENT.EVENT);
+ CALL CHOICEPROCESS;
+ END HOLD;
+
+UNIT PASSIVATE: PROCEDURE;
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)
+ BEGIN
+ CALL PQ.DELETE(CURRENT.EVENT);
+ CURRENT.EVENT:=NONE;
+ CALL CHOICEPROCESS
+ END PASSIVATE;
+
+UNIT RUN: PROCEDURE(P:SIMPROCESS);
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)
+ (* PRIOR *)
+ BEGIN
+ CURRENT.EVENT.PRIOR:=RANDOM;
+ IF NOT P.IDLE THEN
+ P.EVENT.PRIOR:=0;
+ P.EVENT.EVENTTIME:=TIME;
+ CALL PQ.CORRECT(P.EVENT,FALSE)
+ ELSE
+ IF P.EVENTAUX=NONE THEN
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);
+ P.EVENT.EVENTTIME:=TIME;
+ P.EVENT.PROC:=P;
+ CALL PQ.INSERT(P.EVENT)
+ ELSE
+ P.EVENT:=P.EVENTAUX;
+ P.EVENT.PRIOR:=0;
+ P.EVENT.EVENTTIME:=TIME;
+ P.EVENT.PROC:=P;
+ CALL PQ.INSERT(P.EVENT);
+ FI;FI;
+ CALL CHOICEPROCESS;
+END RUN;
+
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)
+ BEGIN
+ IF P= CURRENT THEN CALL PASSIVATE ELSE
+ CALL PQ.DELETE(P.EVENT);
+ P.EVENT:=NONE; FI;
+ END CANCEL;
+
+UNIT CHOICEPROCESS:PROCEDURE;
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)
+ VAR P:SIMPROCESS;
+ BEGIN
+ P:=CURR;
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;
+ ATTACH(MAIN);
+ ELSE ATTACH(CURR); FI;
+END CHOICEPROCESS;
+
+BEGIN
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)
+ CURR,MAINPR:=NEW MAINPROGRAM;
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);
+ MAINPR.EVENT.EVENTTIME:=0;
+ MAINPR.EVENT.PROC:=MAINPR;
+ CALL PQ.INSERT(MAINPR.EVENT);
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)
+ INNER;
+ PQ:=NONE;
+END SIMULATION;
+
+
+
+UNIT LISTS:SIMULATION CLASS;
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)
+
+ UNIT LINKAGE:CLASS;
+ (*WE WILL USE TWO WAY LISTS *)
+ VAR SUC1,PRED1:LINKAGE;
+ END LINKAGE;
+ UNIT HEAD:LINKAGE CLASS;
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)
+ UNIT FIRST:FUNCTION:LINK;
+ BEGIN
+ IF SUC1 IN LINK THEN RESULT:=SUC1
+ ELSE RESULT:=NONE FI;
+ END;
+ UNIT EMPTY:FUNCTION:BOOLEAN;
+ BEGIN
+ RESULT:=SUC1=THIS LINKAGE;
+ END EMPTY;
+ BEGIN
+ SUC1,PRED1:=THIS LINKAGE;
+ END HEAD;
+
+ UNIT LINK:LINKAGE CLASS;
+ (* ORDINARY LIST ELEMENT PREFIX *)
+ UNIT OUT:PROCEDURE;
+ BEGIN
+ IF SUC1=/=NONE THEN
+ SUC1.PRED1:=PRED1;
+ PRED1.SUC1:=SUC1;
+ SUC1,PRED1:=NONE FI;
+ END OUT;
+ UNIT INTO:PROCEDURE(S:HEAD);
+ BEGIN
+
+ CALL OUT;
+ IF S=/= NONE THEN
+ IF S.SUC1=/=NONE THEN
+ SUC1:=S;
+ PRED1:=S.PRED1;
+ PRED1.SUC1:=THIS LINKAGE;
+ S.PRED1:=THIS LINKAGE;
+ FI FI;
+ END INTO;
+ END LINK;
+
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)
+ END ELEM;
+
+ END LISTS;
+
+
+
+
+
+ (*BEGIN OF BANK DEPARTMENT SIMULATION*)
+
+
+ UNIT OFFICE:LISTS CLASS; (*AN OFFICE*)
+
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);
+ (* TELLER WITH CUSTOMERS QUEUEING UP *)
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ (* SERVICE OF THIS TELLER WILL BE PRECISED LATER *)
+ END SERVICE;
+ VAR CSTM:CUSTOMER, (*THE CUSTOMER BEING SERVED*)
+ REST,PAUSE:REAL;
+
+ BEGIN
+ PAUSE:=TIME;
+ DO
+ REST:=REST+TIME-PAUSE;
+ WHILE NOT QUEUE.EMPTY DO
+ (* SERVE ALL QUEUE *)
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;
+ CALL SERVICE;
+ CALL SCHEDULE(CSTM,TIME);
+ OD;
+ PAUSE:=TIME;
+ CALL PASSIVATE
+ OD;
+ END TILL;
+
+ UNIT CUSTOMER:SIMPROCESS CLASS;
+
+ VAR ELLIST:ELEM, K:INTEGER;
+ UNIT ARRIVAL:PROCEDURE(S:TILL);
+ (* ATTACHING TELLER S *)
+ BEGIN
+ IF S=/=NONE THEN
+ ELLIST:=NEW ELEM(THIS CUSTOMER);
+ CALL ELLIST.INTO(S.QUEUE);
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME) FI;
+ CALL PASSIVATE; FI;
+ END ARRIVAL;
+ END CUSTOMER;
+
+ END OFFICE;
+
+
+
+UNIT BANKDEPARTMENT:OFFICE CLASS;
+
+
+ UNIT COUNTER:TILL CLASS;
+ VAR PAYTIME:REAL; (*RANDOM SERVICE TIME*)
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ BEGIN
+ WRITELN(" THE PAY DESK SERVES CUSTOMER NO",CSTM.K,
+ " AT",TIME:10:4);
+ CALL CSTM.ELLIST.OUT;
+ PAYTIME:=RANDOM*2+2;
+ CALL HOLD(PAYTIME);
+ END SERVICE;
+ END COUNTER;
+
+
+ UNIT TELLER:TILL CLASS(NUMBER:INTEGER);
+ VAR SERVICETIME:REAL;
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ VAR N:INTEGER;
+ BEGIN
+ WRITELN(" THE TELLER NO",NUMBER," WAS IDLE FOR",REST:10:4,
+ " SEC");
+ CALL CSTM.ELLIST.OUT;
+ N:=CSTM QUA BANKCUSTOMER.NO;
+ WRITELN(" THE CUSTOMER NO",CSTM.K,
+ " BEGINS TO BE SERVED BY THE TELLER NO",NUMBER,
+ " AT",TIME:10:4);
+ ACCOUNT(N):=ACCOUNT(N)+CSTM QUA BANKCUSTOMER.AMOUNT;
+ IF ACCOUNT(N)<0 THEN CALL CSTM.ARRIVAL(CONTROL);FI;
+ SERVICETIME:=RANDOM*7+3;
+ CALL HOLD(SERVICETIME);
+
+ END SERVICE;
+ END TELLER;
+
+
+ UNIT BANKCUSTOMER:CUSTOMER CLASS(NO:INTEGER,AMOUNT:REAL);
+ (* BANK CUSTOMER. AMOUNT- THE MONEY TO BE PAID AT THE BANK *)
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOOSETELLER:INTEGER;
+ BEGIN
+ I:=I+1;
+ K:=I;
+ ARRIVALTIME:=TIME;
+ WRITELN(" THE CUSTOMER NO",K," ARRIVED AT",TIME:10:4);
+ CHOOSETELLER:=RANDOM*5+1;
+ CALL ARRIVAL(TELLERS(CHOOSETELLER));
+ IF AMOUNT<0 THEN CALL ARRIVAL(CTR); FI;
+ STAYTIME:=TIME-ARRIVALTIME;
+ WRITELN(" THE CUSTOMER NO",K," STAYED AT THE BANK FOR",
+ STAYTIME:10:4," SEC; STATE OF ACCOUNT",ACCOUNT(NO):10:4);
+ END BANKCUSTOMER;
+
+ VAR TELLERS:ARRAYOF TELLER,ACCOUNT:ARRAYOF REAL;
+ VAR CTR:COUNTER, CONTROL:TILL,I:INTEGER;
+
+ BEGIN (* NEW BANK DEPARTMENT GENERATION *)
+ CTR:=NEW COUNTER(NEW HEAD);
+ ARRAY TELLERS DIM(1:5); (* WE DEAL WITH 5 TELLES *)
+ FOR I:=1 TO 5 DO TELLERS(I):=NEW TELLER(NEW HEAD,I); OD;
+ ARRAY ACCOUNT DIM(1:100);
+ (* WE DEAL WITH 100 ACOUNTS IN THIS BANK DEPARTMENT *)
+ FOR I:=1 TO 100 DO ACCOUNT(I):=RANDOM*901+100; OD;
+ (* AN ACCOUNT VALUE CAN FLUCTUATE FROM 100 TO 1000$ *)
+ I:=0;
+ END BANKDEPARTMENT;
+
+
+
+ BEGIN (* OF PROGRAM *)
+ PREF BANKDEPARTMENT BLOCK
+ UNIT GENERATOR:SIMPROCESS CLASS;
+ (* CUSTOMERS GENERATION *)
+ BEGIN
+ DO
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,
+ RANDOM*9996+5),TIME);
+ CALL HOLD(RANDOM*10);
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,
+ -(RANDOM*900+5)),TIME);
+ CALL HOLD(RANDOM*10);
+ OD
+ END GENERATOR;
+ BEGIN
+ WRITELN(" BANK DEPARTMENT SERVICE SIMULATION");
+ WRITELN;
+ CALL SCHEDULE(NEW GENERATOR,TIME);
+ CALL HOLD (40);
+ END
+END
--- /dev/null
+PROGRAM RETRPROV;\r
+\r
+(**************************************************************************** \r
+* * \r
+* RETRIEVAL P R O V E R LOOKING FOR AXIOMS * \r
+* All rights reserved * \r
+* *\r
+****************************************************************************)\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* CONSTANTS, VARIABLES AND OBJECTS USED IN PROGRAM *)\r
+(***************************************************************************)\r
+\r
+(* CONST *)\r
+\r
+CONST\r
+\r
+(* CHARACTER CODES <IN ASCII> *)\r
+\r
+CHRNEG = 78, (* NEGATION 'N' *)\r
+CHREQU = 69, (* EXISTENTIAL QUANTIFIER : 'E' *)\r
+CHRITG = 64, (* ITERATION GREAT QUANTIFIER: '@' *) \r
+CHRGQU = 65, (* GLOBAL QUANTIFIER : 'A' *) \r
+CHRITE = 85, (* EXISTENTIAL ITERATION QUANTIFIER: 'U' *) \r
+CHROR = 86, (* DISJUNCTION : 'V' *) \r
+CHRAND = 38, (* CONJUNCTION : '&' *) \r
+CHRCOM = 44, (* COMMA *) \r
+CHRLPA = 40, (* LEFT PARENTHESIS *)\r
+CHRRPA = 41, (* RIGHT PARENTHESIS *) \r
+CHRBLK = 32, (* BLANK *) \r
+CHREND = 63, (* FORMULA TERMINATOR : '?' *)\r
+CHRCRT = 10, (* CARRIAGE RETURN *) \r
+CHREQS = 61, (* "EQUALS" SIGN - FOR IMPLICATION *) \r
+CHRGTR = 62, (* "GREATER" SIGN - ALSO FOR IMPLICATION *) \r
+CHRLSS = 60, (* "<" -SIGN FOR EQUIVALENCE *) \r
+\r
+(* FORMULA NODE TYPES *)\r
+\r
+LOGKIND = 01, (* LOGICAL CONSTANT *)\r
+VARKIND = 02, (* VARIABLE *)\r
+EQVKIND = 03, (* EQUIVALENCE *) \r
+CONKIND = 04, (* CONJUNCTION *) \r
+DISKIND = 05, (* DISJUNCTION *) \r
+IMPKIND = 06, (* IMPLICATION *) \r
+NEGKIND = 07, (* NEGATION *)\r
+IGQKIND = 08, (* ITERATION GREAT QUANTIFIER *) \r
+ITEKIND = 09, (* ITERATION EXISTENTIAL QUANTIFIER *)\r
+IFFKIND = 10, (* BRANCHING *) \r
+BEGKIND = 11, (* BEGINNING OF A COMPOSITION *) \r
+WHIKIND = 12, (* CONDITIONAL ITERATION *) \r
+QUAKIND = 13, (* QUANTIFIER *) \r
+ENDKIND = 14, (* END OF COMPOSITION *) \r
+THNKIND = 15, (* POSITIVE CHOICE *) \r
+ELSKIND = 16, (* NEGATIVE CHOICE *) \r
+FIFKIND = 17, (* END OF BRANCHING *)\r
+DOFKIND = 18, (* POSITIVE CONDITIONAL ITERATION *) \r
+ODFKIND = 19, (* END OF CONDITIONAL ITERATION *)\r
+SEMKIND = 20, (* SEMICOLON *) \r
+VARPROG = 21, (* SUBSTITUTION FOR TERMS X:=TERM *) \r
+BVARPRO = 22, (* SUBSTITUTION FOR BOOLEAN VARIABLE A:=FORMULA *)\r
+LITKIND = 23, (* LITERAL *) \r
+LT1KIND = 24, (* RELATION DEFINED BY PROCEDURE *)\r
+FUNKIND = 25, (* FUNCTION OR CONSTANT *)\r
+FN1KIND = 26, (* FUNCTION DEFINED BY PROCEDURE *) \r
+CNTKIND = 27, (* CONSTANT - NUMBER *) \r
+CN1KIND = 28, (* FALSE CONSTANT *) \r
+VRUKIND = 29, (* SPECIAL KIND OF VARIABLE - U *)\r
+SUBKIND = 30, (* VARIABLE TO BE SUBSTITUTED ON *) \r
+CN2KIND = 31, (* CONSTANT -NOT NUMBER -OF THE FORM N *) \r
+ARIKIND = 32, (* ARITHMETIC OPERATORS *)\r
+BVAKIND = 33, (* LOGICAL VARIABLE TO BE SUBSTITUTED ON *)\r
+EQUKIND = 34, (* EQUALITY *)\r
+SIGNTRM = 35, (* TRACE OF TERM *)\r
+\r
+LINLNG = 80;\r
+\r
+UNIT TNODE:CLASS; \r
+VAR KIND,IDENT:INTEGER, \r
+ LEFT,RIGHT:TNODE; \r
+END;\r
+\r
+UNIT SEQUENT:CLASS; \r
+VAR PLEAF,LLEAF:TNODE, \r
+ NEXT:SEQUENT; \r
+END;\r
+\r
+UNIT POINTER:CLASS; \r
+VAR NEXT:SEQUENT, \r
+ DOWN:POINTER, \r
+ USED:INTEGER; \r
+END;\r
+\r
+UNIT LIST_TERM:CLASS; \r
+VAR T:TNODE,\r
+ NEXT:LIST_TERM; \r
+END;\r
+\r
+UNIT LIST_AXIOMS:CLASS; \r
+VAR AXIOM:TNODE,\r
+ NEXT:LIST_AXIOMS; \r
+END;\r
+\r
+UNIT DEF : CLASS;\r
+VAR FUN_REL : TNODE,\r
+ NEXT : DEF;\r
+END;\r
+\r
+VAR M : POINTER, \r
+ M1 : DEF,\r
+ TERM:LIST_TERM, \r
+ AX:LIST_AXIOMS, \r
+ SQNT:SEQUENT, \r
+ G:FILE, \r
+ ALFA:BOOLEAN,\r
+ DEF_LIT : INTEGER,\r
+ EQU_NUMBER:INTEGER, (* CURRENT EQUATION *) \r
+ K_MN_K:INTEGER, (* CURRENT NUMBER OF ITERATIONS *) \r
+ LAST_S:INTEGER, (* MAXIMAL NUMBER OF VARPROG *)\r
+ LAST_Q:INTEGER, (* MAXIMAL NUMBER OF BVARPRO *)\r
+ LAST_X:INTEGER, (* MAXIMAL NUMBER OF VARKIND *)\r
+ LAST_D:INTEGER, (* MAXIMAL NUMBER OF TERM SIGN *)\r
+ C,PEEKCH:INTEGER, (* CODES OF CURRENT CHAR FROM INPUT FILE *)\r
+ L:INTEGER, (* NUMBER OF LAST READ CHAR FROM INPUT FILE *) \r
+ CHARSH:INTEGER, (* CURRENT NUMBER IN LINE *) \r
+ DIF:INTEGER, (* DISTINGUISH KINDS OF FORMULAS TO PROVE *) \r
+ CHI:BOOLEAN, (* SHOW IF FORMULA FROM WHILE WAS PROVED *) \r
+ LOGIC:BOOLEAN, (* TELLS WHETHER WHILE HAS ALREADY BEEN USED *)\r
+ LL,LR:INTEGER; (* COUNTS LEFT AND RIGHT PROGRAM BRACKETS *) \r
+ \r
+(***************************************************************************)\r
+\r
+\r
+(***************************************************************************)\r
+(* GENERATE TREE OF THE FORMULA *)\r
+(***************************************************************************)\r
+ \r
+(***************************************************************************)\r
+(* LOOKS AT NEXT NON-BLANK ON INPUT *) \r
+\r
+UNIT PNC:FUNCTION:INTEGER; \r
+VAR D : CHARACTER; \r
+BEGIN \r
+ PEEKCH:=0;\r
+(* FILL PEEKCHAR IGNORING BLANKS AND CR'S *) \r
+ WHILE PEEKCH=0 OR PEEKCH=CHRBLK OR PEEKCH=CHRCRT \r
+ DO\r
+ READ(G,D); \r
+ PEEKCH:=ORD(D);\r
+ L:=L+1; \r
+ OD; \r
+ RESULT := PEEKCH; \r
+END PNC;\r
+\r
+(****************************************************************************) \r
+(* MOVES FORWARD N STEPS AND READS CHARACTER *) \r
+\r
+UNIT LOOKN:PROCEDURE(N:INTEGER);\r
+VAR I:INTEGER; \r
+BEGIN \r
+ FOR I:=1 TO N\r
+ DO \r
+ C:=PNC; \r
+ OD; \r
+END LOOKN; \r
+\r
+(****************************************************************************) \r
+(* READS N-TH POSITION IN FILE *) \r
+UNIT RETN:PROCEDURE(N:INTEGER); \r
+VAR I:INTEGER; \r
+BEGIN \r
+ L:=0;\r
+ CALL RESET(G); \r
+ FOR I:=1 TO N\r
+ DO \r
+ C:=PNC; \r
+ OD; \r
+END RETN; \r
+\r
+(****************************************************************************) \r
+(* DISTINGUISH PROGRAMS WRITTEN IN LOGLAN *)\r
+\r
+UNIT PRKEY : FUNCTION(N:INTEGER) : INTEGER; \r
+VAR V,W : ARRAYOF CHARACTER,\r
+ I,C : INTEGER; \r
+BEGIN \r
+ ARRAY V DIM(1:26);\r
+ ARRAY W DIM(1:N); \r
+ V(1):='I';V(2):='F';V(3):='T';V(4):='H';V(5):='E';V(6):='N';\r
+ V(7):= 'L'; V(8):= 'S'; V(9):= 'B'; V(10):= 'G'; V(11):= 'D'; \r
+ V(12):= 'W'; V(13):= 'O';V(14):= 'i'; V(15):= 'f'; V(16):= 't'; \r
+ V(17):= 'h'; V(18):= 'e'; V(19):= 'n'; V(20):= 'l'; V(21):= 's'; \r
+ V(22):= 'b'; V(23):= 'g'; V(24):= 'd'; V(25):='w'; V(26):= 'o'; \r
+ FOR I:=1 TO N \r
+ DO \r
+ IF NOT EOF(G) THEN \r
+ C:=PNC \r
+ ELSE \r
+ RESULT:=0;\r
+ L:=L+N-I+1;\r
+ RETURN;\r
+ FI; \r
+ W(I):=CHR(C); \r
+ OD; \r
+ CASE N\r
+ WHEN \r
+ 2:IF V(1) = W(1) OR V(14) = W(1) THEN \r
+ IF V(2) = W(2) OR V(15) = W(2) THEN RESULT:=1 FI (* 'IF' *)\r
+ FI;\r
+ IF V(2) = W(1) OR V(15) = W(1) THEN \r
+ IF V(1) = W(2) OR V(14) = W(2) THEN RESULT:=2 FI (* 'FI' *)\r
+ FI;\r
+ IF V(11) = W(1) OR V(24) = W(1) THEN\r
+ IF V(13) = W(2) OR V(26) = W(2) THEN RESULT:=3 FI (* 'DO' *)\r
+ FI; \r
+ IF V(13) = W(1) OR V(26) = W(1) THEN\r
+ IF V(11) = W(2) OR V(24) = W(2) THEN RESULT:=4 FI (* 'OD' *)\r
+ FI; \r
+ WHEN\r
+ 3:IF V(5) = W(1) OR V(18) = W(1) THEN \r
+ IF ((V(6) = W(2)) OR (V(19) = W(2))) AND ((V(11)=W(3)) \r
+ OR (V(24)=W(3))) THEN RESULT:=5 FI (* 'END' *)\r
+ FI; \r
+ WHEN\r
+ 4:IF V(3) = W(1) OR V(16) = W(1) THEN \r
+ IF ((V(4) = W(2)) OR (V(17)=W(2))) AND ((V(5)=W(3))\r
+ OR (V(18)=W(3))) THEN\r
+ IF V(6) = W(4) OR V(19) = W(4) THEN RESULT:=6 FI (* 'THEN' *) \r
+ FI\r
+ FI;\r
+ IF V(5) = W(1) OR V(18) = W(1) THEN\r
+ IF ((V(7) = W(2)) OR (V(20)=W(2))) AND ((V(8)=W(3)) \r
+ OR (V(21)=W(3))) THEN IF V(5) = W(4) OR V(18) = W(4) THEN \r
+ RESULT:=7 FI (* 'ELSE' *)\r
+ FI\r
+ FI;\r
+ WHEN\r
+ 5:IF V(9) = W(1) OR V(22) = W(1) THEN \r
+ IF ((V(5) = W(2)) OR (V(18)=W(2))) AND ((V(10)=W(3)) \r
+ OR (V(23)=W(3))) THEN \r
+ IF ((V(1)=W(4)) OR (V(14)=W(4))) AND ((V(6)=W(5)) \r
+ OR (V(19)=W(5))) THEN RESULT:=8 FI (* 'BEGIN' *) \r
+ FI\r
+ FI;\r
+ IF V(12) = W(1) OR V(25) = W(1) THEN\r
+ IF ((V(4) = W(2)) OR (V(17)=W(2))) AND ((V(1)=W(3))\r
+ OR (V(14)=W(3))) THEN \r
+ IF ((V(7)=W(4)) OR (V(20)=W(4))) AND ((V(5)=W(5)) \r
+ OR (V(18)=W(5))) THEN RESULT:=9 (* 'WHILE' *)\r
+ FI \r
+ FI;\r
+ FI;\r
+ ESAC; \r
+ KILL(W);\r
+ KILL(V);\r
+END PRKEY; \r
+\r
+(*****************************************************************************) \r
+(* READS FORMULA FROM INPUT AND CONSTRUCT A TNODE *)\r
+\r
+UNIT GEN_TREE : FUNCTION : TNODE; \r
+\r
+VAR T,S:TNODE;\r
+ \r
+BEGIN \r
+ T:=ARG_TREE; (* READ FIRST ARGUMENT *) \r
+ C:=PNC; (* NEXT INPUT CHARACTER *) \r
+ WHILE C=CHROR OR C=CHRAND OR C=CHREQS OR C=CHRLSS OR C=118\r
+ DO (* LOOP FOR MORE *) \r
+ S:=NEW TNODE; (* ARGUMENTS *) \r
+ IF T=NONE THEN CALL EXCEPTIONS(1) FI; (* NULL ARGUMENT *)\r
+ CASE C \r
+ WHEN CHROR,118 : S.KIND:=DISKIND; \r
+ WHEN CHRAND: S.KIND:=CONKIND; \r
+ WHEN CHRLSS: IF PNC<>61 ORIF PNC<>62 THEN CALL EXCEPTIONS(1) FI; \r
+ S.KIND:=EQVKIND; \r
+ WHEN CHREQS: IF PNC<>CHRGTR THEN CALL EXCEPTIONS(1) FI; \r
+ S.KIND:=IMPKIND; \r
+ ESAC; \r
+ S.RIGHT:=ARG_TREE; (* NEXT ARGUMENT *)\r
+ S.LEFT:=T; \r
+ IF S.RIGHT=NONE THEN CALL EXCEPTIONS(1) FI; \r
+ T:=S; \r
+ C:=PNC; \r
+ OD; \r
+ RESULT := T;\r
+END GEN_TREE; \r
+\r
+(****************************************************************************)\r
+(* READS ONE ARGUMENT OF INPUT FORMULA *) \r
+\r
+UNIT ARG_TREE : FUNCTION : TNODE; \r
+\r
+VAR T,S,U : TNODE,\r
+ Q : BOOLEAN; \r
+ \r
+BEGIN \r
+ C:=PNC;\r
+ IF C=CHREND THEN RETURN FI; (* RETURN NONE *) \r
+ T:=NEW TNODE; \r
+ RESULT:=T;\r
+ Q:=TRUE; \r
+ CASE C\r
+ WHEN CHRNEG,110 :T.KIND:=NEGKIND; (* NEGATION *)\r
+ WHEN CHRGQU :T.KIND:=QUAKIND; (* GLOBAL QUANTIFIER *)\r
+ C:=PNC; (* FOLLOWING VARIABLE *) \r
+ CALL SEARCH_NUM(T.IDENT,TRUE); (* NUMBER *) \r
+ WHEN CHREQU :S:=NEW TNODE; (* EXISTENTIAL QUANTIFIER *)\r
+ U:=NEW TNODE; (* CONVERT TO -'A'- *)\r
+ S.KIND:=NEGKIND; \r
+ S.LEFT:=U;\r
+ U.KIND:=QUAKIND; \r
+ C:=PNC; (* VARIABLE NAME *) \r
+ CALL SEARCH_NUM(U.IDENT,TRUE); (* VARIABLE NUMBER *) \r
+ U.LEFT:=T;\r
+ T.KIND:=NEGKIND; \r
+ RESULT := S \r
+ OTHERWISE Q:=FALSE \r
+ ESAC; \r
+ IF Q THEN \r
+ T.LEFT:=ARG_TREE; (* CONTINUE DEPTH SEARCH *)\r
+ IF T.LEFT=NONE THEN CALL EXCEPTIONS(1) FI; \r
+ RETURN \r
+ FI; \r
+ IF C=CHROR ORIF C=CHRRPA ORIF C=CHRAND ORIF C=CHREQS ORIF C=CHRGTR ORIF \r
+ C=CHRLSS THEN \r
+ IF C=CHREQS THEN\r
+ C:=PNC;\r
+ IF C<>CHRGTR THEN \r
+ CALL RETN(L-1);\r
+ ELSE \r
+ CALL EXCEPTIONS(1);\r
+ FI\r
+ ELSE\r
+ CALL EXCEPTIONS(1); \r
+ FI;\r
+ FI; \r
+ IF C=CHRLPA THEN \r
+ RESULT := GEN_TREE \r
+ ELSE (* LITERAL ONLY *)\r
+ RESULT := LIT_ARG (* SO READ IT *)\r
+ FI; \r
+ KILL (T) \r
+END ARG_TREE; \r
+\r
+(****************************************************************************)\r
+(* SEARCH FOR A NUMBER *)\r
+\r
+UNIT SEARCH_NUM:PROCEDURE(INOUT B:INTEGER;ALEF:BOOLEAN);\r
+BEGIN\r
+ C:=PNC; \r
+ IF C<48 OR C>57 THEN \r
+ IF ALEF THEN\r
+ B:=-1\r
+ ELSE \r
+ CALL RETN(L-1); \r
+ B:=VAL(CHR(C));\r
+ RETURN;\r
+ FI;\r
+ FI; \r
+ IF NOT ALEF THEN CALL RETN(L-1) FI;\r
+ WHILE C>47 AND C<58 \r
+ DO \r
+ B:=B*10+C-48; \r
+ C:=PNC;\r
+ OD; \r
+ IF ALEF THEN B:=B+1 FI;\r
+ CALL RETN(L-1);\r
+END SEARCH_NUM;\r
+ \r
+(****************************************************************************)\r
+(* CONSTRUCT PREDICATE *)\r
+\r
+UNIT PRED : PROCEDURE ( INOUT A, B : INTEGER ; ALEF : BOOLEAN );\r
+BEGIN\r
+ CASE C\r
+ WHEN 61 : A := EQUKIND;\r
+ WHEN 33 : A := LT1KIND; \r
+ OTHERWISE A := LITKIND;\r
+ CALL SEARCH_NUM ( B, ALEF ); (* SEARCH A NUMBER OF *)\r
+ ESAC; (* PREDICATE *)\r
+END PRED;\r
+\r
+(***************************************************************************)\r
+(* CONSTRUCT TERM *)\r
+\r
+UNIT MAKE_TERM : PROCEDURE ( INOUT A, B : INTEGER; C : INTEGER, ALEF : BOOLEAN );\r
+BEGIN\r
+ A := C;\r
+ CALL SEARCH_NUM ( B, ALEF ); (* SEARCH A NUMBER OF *)\r
+END MAKE_TERM; (* TERM *)\r
+\r
+(***************************************************************************)\r
+(* GIVES A LENGTH OF PATTERN OF 'S' *)\r
+\r
+UNIT LEN_SUB : FUNCTION : INTEGER;\r
+VAR I,J : INTEGER,\r
+ ALFA : BOOLEAN;\r
+BEGIN\r
+ IF C=83 OR C=115 OR C=81 OR C=113 THEN (* CHECK -S:=... OR -Q:=... *)\r
+ FOR I := 1 TO 3 \r
+ DO\r
+ FOR J := 1 TO I \r
+ DO\r
+ IF NOT EOF(G) THEN \r
+ C:=PNC\r
+ ELSE\r
+ CALL RETN(L-J+1);\r
+ ALFA:=TRUE;\r
+ RESULT:=0;\r
+ RETURN\r
+ FI;\r
+ OD;\r
+ IF ALFA THEN EXIT FI; \r
+ IF C=ORD(':') THEN \r
+ RESULT:=I; \r
+ CALL RETN(L-I); \r
+ RETURN\r
+ FI;\r
+ CALL RETN(L-I);\r
+ OD;\r
+ FI;\r
+ RESULT:=0;\r
+END LEN_SUB;\r
+\r
+(***************************************************************************)\r
+(* MAKES A SUBSTITUTION *)\r
+\r
+UNIT SUBSTITUTION:FUNCTION:TNODE;\r
+VAR T:TNODE;\r
+BEGIN\r
+ T:=NEW TNODE;\r
+ IF C=83 OR C=115 THEN\r
+ T.KIND:=VARPROG (* READ S *)\r
+ ELSE \r
+ T.KIND:=BVARPRO (* READ A *)\r
+ FI;\r
+ CALL SEARCH_NUM(T.IDENT,TRUE); (* NUMBER OF 'S' *)\r
+ CALL LOOKN(3);\r
+ CASE T.KIND\r
+ WHEN VARPROG:T.LEFT:=LIT_ARG;\r
+ WHEN BVARPRO:CALL RETN(L-1);T.LEFT:=GEN_TREE;CALL RETN(L-1);\r
+ ESAC;\r
+ RESULT:=T;\r
+END SUBSTITUTION;\r
+\r
+(***************************************************************************)\r
+(* CONSTRUCT IF-ALFA-THEN-K-ELSE-M-FI PROGRAM *)\r
+\r
+UNIT PROG_IF:FUNCTION:TNODE;\r
+VAR U,S,P,T:TNODE;\r
+BEGIN\r
+ T:=NEW TNODE; \r
+ T.KIND:=IFFKIND; (* 'IF' *)\r
+ LL:=LL+1;\r
+ T.LEFT:=GEN_TREE; (* ALFA *)\r
+ CALL RETN(L-1); (* BACK BEFORE 'T' *)\r
+ IF PRKEY(4)<>6 THEN CALL EXCEPTIONS(1) FI;\r
+ S:=NEW TNODE;\r
+ T.RIGHT:=S;\r
+ S.KIND:=THNKIND; (* 'THEN '*)\r
+ C:=PNC;\r
+ S.LEFT:=CONSUB; (* PROGRAM 'K' *)\r
+ U:=NEW TNODE;\r
+ S.RIGHT:=U;\r
+ IF PRKEY(4)=7 THEN (* 'ELSE' *)\r
+ U.KIND:=ELSKIND;\r
+ C:=PNC;\r
+ U.LEFT:=CONSUB (* PROGRAM 'M' *)\r
+ ELSE \r
+ CALL RETN(L-4);\r
+ FI;\r
+ IF PRKEY(2)<>2 THEN CALL EXCEPTIONS(1) FI;\r
+ U.IDENT:=FIFKIND;\r
+ LR:=LR+1;\r
+ IF LL=LR THEN (* AFTER NESTING DO *)\r
+ (* 'WHILE ETC ' PROGRAM ON *)\r
+ U.RIGHT:=GEN_TREE; (* FORMULA BETA *)\r
+ CALL RETN(L-1)\r
+ FI; (* OR TERM TAU *)\r
+ RESULT:=T; \r
+END PROG_IF;\r
+\r
+(***************************************************************************) \r
+\r
+(* CONSTRUCT BEGIN-K;M;N; -OR MORE PROGRAMS- END PROGRAM *)\r
+\r
+UNIT PROG_BEGIN:FUNCTION:TNODE;\r
+VAR V,T,S:TNODE;\r
+BEGIN\r
+ T:=NEW TNODE;\r
+ T.KIND:=BEGKIND; (* 'BEGIN' *)\r
+ LL:=LL+1;\r
+ IF PRKEY(3)<>5 THEN (* IF NOT 'END' *)\r
+ CALL RETN(L-3);\r
+ V:=NEW TNODE;\r
+ T.LEFT:=V;\r
+ C:=PNC;\r
+ V.LEFT:=CONSUB; (* FIRST PROGRAM *)\r
+ WRITELN("1");\r
+ writeln("pekch=", peekch);\r
+ WHILE (PNC=59 OR PEEKCH = 36 ) (* LOOP FOR PROGRAMS *)\r
+ DO\r
+ WRITELN("2");\r
+ IF PEEKCH = 36 THEN V.IDENT := 1 FI; (* UNIQUELY SUBSTITUTION *)\r
+ C:=PNC;\r
+ V.RIGHT:=CONSUB; (* NEXT PROGRAM *) \r
+ V.KIND:=SEMKIND; (* 'SEMICOLON' *)\r
+ IF PNC=59 THEN \r
+ S:=NEW TNODE;\r
+ S.LEFT:=V.RIGHT;\r
+ V.RIGHT:=S;\r
+ V:=V.RIGHT\r
+ FI;\r
+ CALL RETN(L-1);\r
+ OD;\r
+ writeln (peekch );\r
+ FI;\r
+ CALL RETN(L-1);\r
+ WRITELN("3");\r
+ IF PRKEY(3)<>5 THEN CALL EXCEPTIONS(1) FI;\r
+ WRITELN("4");\r
+ T.IDENT:=ENDKIND; (* 'END' *)\r
+ LR:=LR+1;\r
+ IF LL=LR THEN (* AFTER NESTING DO *)\r
+ (* 'WHILE ETC ' PROGRAM ON *)\r
+ T.RIGHT:=GEN_TREE; (* FORMULA BETA *)\r
+ CALL RETN(L-1)\r
+ FI; (* OR TERM TAU *)\r
+ RESULT:=T;\r
+END PROG_BEGIN;\r
+\r
+(***************************************************************************)\r
+(* CONSTRUCT WHILE-ALFA-D0-K-OD PROGRAM *)\r
+\r
+UNIT PROG_WHILE:FUNCTION:TNODE;\r
+VAR V,T:TNODE;\r
+BEGIN\r
+ T:=NEW TNODE;\r
+ T.KIND:=WHIKIND; (* 'WHILE' *)\r
+ T.LEFT:=GEN_TREE; (* ALFA *)\r
+ CALL RETN(L-1); (* BACK BEFORE 'D' *) \r
+ V:=NEW TNODE;\r
+ T.RIGHT:=V;\r
+ IF PRKEY(2)<>3 THEN CALL EXCEPTIONS(1) FI;\r
+ V.KIND:=DOFKIND; (* 'DO' *)\r
+ C:=PNC;\r
+ LL:=LL+1;\r
+ V.LEFT:=CONSUB; (* PROGRAM 'K' *)\r
+ IF PRKEY(2)<>4 THEN CALL EXCEPTIONS(1) FI;\r
+ V.IDENT:=ODFKIND; (* 'OD' *)\r
+ LR:=LR+1; \r
+ IF LL=LR THEN (* AFTER NESTING DO *)\r
+ (* 'WHILE ETC ' PROGRAM ON *)\r
+ V.RIGHT:=GEN_TREE; (* FORMULA BETA *)\r
+ CALL RETN(L-1);\r
+ FI; (* OR TERM TAU *)\r
+ RESULT:=T;\r
+END PROG_WHILE;\r
+ \r
+(***************************************************************************)\r
+(* SEARCH FOR PROGRAMS *)\r
+\r
+UNIT PROG:FUNCTION:TNODE;\r
+BEGIN\r
+ IF PRKEY(2)=1 THEN RESULT:=PROG_IF \r
+ ELSE \r
+ CALL RETN(L-2);\r
+ CASE PRKEY(5)\r
+ WHEN 8: RESULT:=PROG_BEGIN;\r
+ WHEN 9: RESULT:=PROG_WHILE;\r
+ OTHERWISE CALL RETN(L-5);\r
+ ESAC;\r
+ FI;\r
+END PROG;\r
+\r
+(***************************************************************************)\r
+(* CONSTRUCT ITERATION EXISTENTIAL QUANTIFIER *)\r
+\r
+UNIT ITE_EX_Q:FUNCTION:TNODE;\r
+VAR T:TNODE;\r
+BEGIN\r
+ T:=NEW TNODE;\r
+ T.KIND:=ITEKIND; (* T.IDENT=0-IT MEANS *)\r
+ C:=PNC; (* THAT RULE WAS NOT ACTIVE *)\r
+ T.RIGHT:=LIT_ARG;\r
+ RESULT:=T;\r
+END ITE_EX_Q;\r
+\r
+(***************************************************************************)\r
+(* CONSTRUCT ITERATION GREAT QUANTIFIER *)\r
+ \r
+UNIT ITE_GR_Q:FUNCTION:TNODE;\r
+VAR T:TNODE;\r
+BEGIN\r
+ T:=NEW TNODE;\r
+ T.KIND:=IGQKIND; (* T.IDENT=0-IT MEANS *)\r
+ C:=PNC; (* THAT RULE WAS NOT ACTIVE *)\r
+ T.RIGHT:=LIT_ARG;\r
+ RESULT:=T;\r
+END ITE_GR_Q;\r
+\r
+(*****************************************************************************)\r
+(* CONSTRUCT SUBSTITUTION AND READS NUMBER OF S *)\r
+\r
+UNIT CONSUB:FUNCTION:TNODE;\r
+VAR T:TNODE,\r
+ I,J:INTEGER;\r
+ BEGIN\r
+ T:=NEW TNODE;\r
+ IF C=83 ORIF C=115 ORIF C=81 ORIF C=113 THEN\r
+ CASE C\r
+ WHEN 83,115: T.KIND:=VARPROG;\r
+ WHEN 81,113: T.KIND:=BVARPRO;\r
+ ESAC;\r
+ CALL SEARCH_NUM(T.IDENT,TRUE);\r
+ CALL LOOKN(3);\r
+ CASE T.KIND\r
+ WHEN VARPROG : T.LEFT:=LIT_ARG;\r
+ WHEN BVARPRO : CALL RETN(L-1);\r
+ T.LEFT:=GEN_TREE;\r
+ CALL RETN(L-1);\r
+ ESAC;\r
+ FOR I:=2 TO 4 (* IF NOT 'FI' AND NOT 'OD' *)\r
+ DO (* AND NOT 'END' AND *)\r
+ J:=PRKEY(I);\r
+ CALL RETN(L-I);\r
+ IF J<>0 THEN EXIT FI; (* NOT 'ELSE' THEN REPEAT *)\r
+ OD; (* CONSUB *)\r
+ IF (PNC<>59 AND PEEKCH<>36) THEN\r
+ IF J=0 THEN T.RIGHT:=CONSUB ELSE CALL RETN(L-1); FI\r
+ ELSE\r
+ CALL RETN(L-1)\r
+ FI \r
+ ELSE \r
+ T:=LIT_ARG; (* IF NOT SUB THEN PROGRAM *)\r
+ FI;\r
+ RESULT:=T;\r
+END CONSUB;\r
+ \r
+(***************************************************************************)\r
+(* READS INPUT LITERAL *) \r
+\r
+UNIT LIT_ARG : FUNCTION : TNODE;\r
+VAR T,U:TNODE;\r
+ \r
+BEGIN \r
+ T:=NEW TNODE; (* RESERVE NODE *)\r
+ IF LEN_SUB<>0 THEN \r
+ T:=SUBSTITUTION;\r
+ C:=PNC; (* OMITED LEFT PAR *)\r
+ T.RIGHT:=GEN_TREE;\r
+ RESULT:=T;\r
+ RETURN\r
+ ELSE\r
+ CASE C\r
+ WHEN 67,99 : CALL MAKE_TERM(T.KIND,T.IDENT,CN2KIND,TRUE);\r
+ RESULT:=T;\r
+ RETURN; (* CONSTANT 'C' *)\r
+ WHEN 85 : T:=ITE_EX_Q; \r
+ RESULT:=T;\r
+ RETURN; (* ITEKIND 'U' *)\r
+ WHEN 64 : T:=ITE_GR_Q;\r
+ RESULT:=T;\r
+ RETURN; (* IGQKIND '@' *)\r
+ WHEN 88,120 : CALL MAKE_TERM(T.KIND,T.IDENT,VARKIND,TRUE);\r
+ RESULT:=T;\r
+ RETURN; (* VARIABLE 'X' *)\r
+ WHEN 117 : CALL MAKE_TERM(T.KIND,T.IDENT,VRUKIND,TRUE);\r
+ RESULT:=T;\r
+ RETURN; (* VRUKIND 'u' *)\r
+ WHEN 81,113 : CALL MAKE_TERM(T.KIND,T.IDENT,BVAKIND,TRUE);\r
+ RESULT:=T; \r
+ RETURN; (* BVAKIND 'Q'*)\r
+ WHEN 83,115 : CALL MAKE_TERM(T.KIND,T.IDENT,SUBKIND,TRUE);\r
+ RESULT:=T;\r
+ RETURN; (* SUBKIND 'S' *)\r
+ WHEN 61,33, (* EQUKIND '=' *)\r
+ 80,112 : CALL PRED(T.KIND,T.IDENT,TRUE);\r
+ (* LITKIND 'P' *)\r
+ (* LT1KIND '!' *)\r
+ WHEN 71,103 : CALL MAKE_TERM ( T.KIND, T.IDENT, FUNKIND, TRUE );\r
+ (* FUNKIND 'G' *)\r
+ WHEN 35 : CALL MAKE_TERM ( T.KIND, T.IDENT, FN1KIND, TRUE );\r
+ (* FN1KIND '#' *)\r
+ WHEN 70,102 : CALL MAKE_TERM ( T.KIND,T.IDENT,LOGKIND,TRUE );\r
+ T.IDENT := 0; (* LOGICAL FALSE 'F' *)\r
+ RESULT := T;\r
+ RETURN;\r
+ WHEN 84,116 : CALL MAKE_TERM ( T.KIND,T.IDENT,LOGKIND,TRUE );\r
+ T.IDENT := 1; (* LOGICAL TRUE 'T' *)\r
+ RESULT := T;\r
+ RETURN; \r
+ WHEN 48,49,50,51,52,53,54,55,56,57\r
+ : CALL MAKE_TERM(T.KIND,T.IDENT,CNTKIND,FALSE);\r
+ RESULT:=T;\r
+ RETURN; (* DIGITS E.G. '2' *)\r
+ WHEN 42,43,45,47,94 (* '*','+','-','/,'^' *)\r
+ : CALL MAKE_TERM(T.KIND,T.IDENT,ARIKIND,TRUE);\r
+ T.IDENT:=C;\r
+ WHEN 37 : CALL MAKE_TERM ( T.KIND, T.IDENT, CN1KIND, TRUE );\r
+ RESULT := T;\r
+ RETURN; (* FALSE CONSTANT *) \r
+ WHEN 68,100 : CALL MAKE_TERM ( T.KIND, T.IDENT, SIGNTRM, TRUE );\r
+ (* DUMKIND 'D' *)\r
+ OTHERWISE CALL RETN(L-1);\r
+ T:=PROG; (* PROGRAMS *)\r
+ RESULT:=T;\r
+ RETURN;\r
+ ESAC;\r
+ C:=PNC;\r
+ IF C=CHRLPA THEN (* LEFT PAR '(' *)\r
+ C:=PNC; (* EXPECT SOME ARGUMENTS *)\r
+ T.LEFT:=LIT_ARG; (* READ ARGUMENTS *)\r
+ U:=T.LEFT; (* FIRST ON LEFT *)\r
+ WHILE PNC=CHRCOM (* COMMA *)\r
+ DO \r
+ C:=PNC; (* LOOP FOR MORE *) \r
+ WHILE U.RIGHT<>NONE (* OMIT PROGRAMS ON RIGHT *)\r
+ DO\r
+ U:=U.RIGHT;\r
+ OD;\r
+ U.RIGHT:=LIT_ARG; (* NEXT ON RIGHT *)\r
+ U:=U.RIGHT\r
+ OD; \r
+ C:=PEEKCH;\r
+ IF C<>CHRRPA THEN CALL EXCEPTIONS(1) FI;(* EXPECT ')' *)\r
+ ELSE \r
+ CALL RETN(L-1); \r
+ FI;\r
+ RESULT:=T; \r
+ RETURN;\r
+ FI;\r
+END LIT_ARG;\r
+\r
+(****************************************************************************)\r
+(* STOPS EXECUTION IF THERE IS AN ERROR *)\r
+\r
+UNIT EXCEPTIONS:PROCEDURE(N:INTEGER);\r
+BEGIN\r
+ CASE N\r
+ WHEN 1:WRITELN("SYNTAX ERROR");\r
+ WHEN 2:WRITELN("0/0");\r
+ WHEN 3:WRITELN("DIVISION BY ZERO");\r
+ WHEN 4:WRITELN("0^0");\r
+ ESAC;\r
+ RAISE ENDRUN\r
+END EXCEPTIONS;\r
+\r
+(***************************************************************************) \r
+(* PRINT FORMULA ON SCREEN AND TO FILE *)\r
+(***************************************************************************)\r
+ \r
+(***************************************************************************)\r
+(* PRINT FORMULA ON SCREEN *)\r
+UNIT WR_FOR : PROCEDURE ( C : TNODE );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ CASE C.KIND \r
+ WHEN CONKIND : CALL WR_FOR_HELP ( C, '&' ); (* CONJUCTION *)\r
+ WHEN DISKIND : CALL WR_FOR_HELP ( C, 'v' ); (* DISJUNCTION *)\r
+ WHEN IMPKIND : CALL WR_FOR_HELP ( C, '=' ); (* IMPLICATION *)\r
+ WHEN EQVKIND : CALL WR_FOR_HELP ( C, '<' ); (* EQUIVALENCE *)\r
+ WHEN NEGKIND : CALL PUTCH ( 'n' ); \r
+ CALL WR_FOR ( C.LEFT ); (* NEGATION *)\r
+ WHEN LOGKIND : IF C.IDENT = 0 THEN CALL PUTCH ( 'F' ) \r
+ ELSE CALL PUTCH ( 'T' ); (* LOGICAL CONSTANTS *)\r
+ FI;\r
+ WHEN VARKIND : CALL PUTCH ( 'x' ); (* VARIABLE *)\r
+ CALL PNUM ( C.IDENT ); (* AND ITS IDENTIFIER *)\r
+ WHEN IGQKIND : CALL PUTCH ( '@' ); (* ITERATION GREAT QUANTIFIER *)\r
+ CALL WR_FOR ( C.RIGHT ); \r
+ WHEN ITEKIND : CALL PUTCH ( 'U' ); (* EXISTENTIAL ITERATION QUANTIFIER *)\r
+ CALL WR_FOR ( C.RIGHT );\r
+ WHEN IFFKIND : CALL PUTCH ( 'I' ); (* IF *)\r
+ CALL PUTCH ( 'F' );\r
+ CALL WR_FOR ( C.LEFT ); (* ALFA *)\r
+ CALL PUTCH ( 'T' ); (* THEN *)\r
+ CALL PUTCH ( 'H' );\r
+ CALL PUTCH ( 'E' );\r
+ CALL PUTCH ( 'N' );\r
+ CALL WR_FOR ( C.RIGHT.LEFT ); (* K *)\r
+ IF C.RIGHT.RIGHT.KIND = ELSKIND THEN \r
+ CALL PUTCH ( 'E' );\r
+ CALL PUTCH ( 'L' );\r
+ CALL PUTCH ( 'S' );\r
+ CALL PUTCH ( 'E' ); (* ELSE *)\r
+ CALL WR_FOR ( C.RIGHT.RIGHT.LEFT ); (* M *)\r
+ FI;\r
+ CALL PUTCH ( 'F' ); (* FI *)\r
+ CALL PUTCH ( 'I' );\r
+ CALL WR_FOR ( C.RIGHT.RIGHT.RIGHT ); (* BETA *)\r
+ WHEN BEGKIND : CALL PUTCH ( 'B' );\r
+ CALL PUTCH ( 'E' );\r
+ CALL PUTCH ( 'G' );\r
+ CALL PUTCH ( 'I' );\r
+ CALL PUTCH ( 'N' ); (* BEGIN *)\r
+ CALL WR_FOR ( C.LEFT ); (* K *)\r
+ CALL PUTCH ( 'E' );\r
+ CALL PUTCH ( 'N' );\r
+ CALL PUTCH ( 'D' ); (* END *)\r
+ CALL WR_FOR ( C.RIGHT ); (* BETA *)\r
+ WHEN SEMKIND : CALL WR_FOR ( C.LEFT ); (* K1 *)\r
+ IF C.IDENT = 1 THEN \r
+ CALL PUTCH ( '$' ) (* UNIQUELY SUBSTITUTION *)\r
+ ELSE \r
+ CALL PUTCH ( ';' ) (* SEMICOLON *)\r
+ FI;\r
+ CALL WR_FOR ( C.RIGHT ); (* K2 *)\r
+ WHEN WHIKIND : CALL PUTCH ( 'W' );\r
+ CALL PUTCH ( 'H' );\r
+ CALL PUTCH ( 'I' );\r
+ CALL PUTCH ( 'L' );\r
+ CALL PUTCH ( 'E' ); (* WHILE *)\r
+ CALL WR_FOR ( C.LEFT ); (* ALFA *)\r
+ CALL PUTCH ( 'D' );\r
+ CALL PUTCH ( 'O' ); (* DO *)\r
+ CALL WR_FOR ( C.RIGHT.LEFT );(* K *)\r
+ CALL PUTCH ( 'O' );\r
+ CALL PUTCH ( 'D' ); (* OD *)\r
+ CALL WR_FOR ( C.RIGHT.RIGHT ); (* BETA *)\r
+ WHEN QUAKIND : CALL PUTCH ( 'A' ); (* GREAT QUANTIFIER *)\r
+ CALL PUTCH ( 'x' ); (* VARIABLE *)\r
+ CALL PNUM ( C.IDENT ); (* ITS NUMBER *)\r
+ CALL WR_FOR ( C.LEFT ); (* ALFA *)\r
+ WHEN EQUKIND,\r
+ LITKIND,\r
+ FUNKIND,\r
+ LT1KIND,\r
+ FN1KIND : CASE C.KIND \r
+ WHEN EQUKIND : CALL PUTCH ( '=' );\r
+ WHEN LITKIND : CALL PUTCH ( 'P' ); \r
+ WHEN FUNKIND : CALL PUTCH ( 'G' );\r
+ WHEN LT1KIND : CALL PUTCH ( '!' );\r
+ WHEN FN1KIND : CALL PUTCH ( '#' );\r
+ ESAC; (* PREDICATE OR FUNCTION *)\r
+ CALL PNUM ( C.IDENT );\r
+ IF C.LEFT = NONE THEN RETURN FI;\r
+ CALL PUTCH ( '(' );\r
+ C := C.LEFT;\r
+ WHILE C <> NONE \r
+ DO\r
+ CALL WR_FOR ( C ); (* ARGUMENT *)\r
+ C := C.RIGHT; (* TAKE NEXT ARGUMENT *)\r
+ IF C <> NONE THEN CALL PUTCH ( ',' ) FI;\r
+ OD;\r
+ CALL PUTCH ( ')' );\r
+ WHEN CNTKIND : CALL PNUM ( C.IDENT + 1 ); (* NUMERIC CONSTANT *)\r
+ WHEN CN1KIND : CALL PUTCH ( '%' ); (* FALSE CONSTANT *)\r
+ CALL PNUM ( C.IDENT + 1 );\r
+ WHEN CN2KIND : CALL PUTCH ( 'C' ); (* CONSTANT OF THE FORM 'C' *)\r
+ CALL PNUM ( C.IDENT );\r
+ WHEN ARIKIND : CALL PUTCH ( CHR ( C.IDENT ) ); (* ARITHMETIC OPERATION *)\r
+ IF C.LEFT.RIGHT = NONE THEN \r
+ CALL WR_FOR ( C.LEFT );\r
+ RETURN \r
+ FI;\r
+ CALL PUTCH ( '(' );\r
+ CALL WR_FOR ( C.LEFT );\r
+ CALL PUTCH ( ',' );\r
+ CALL WR_FOR ( C.LEFT.RIGHT );\r
+ CALL PUTCH ( ')' );\r
+ WHEN VRUKIND : CALL PUTCH ( 'u' ); (* SPECIAL KIND OF VARIABLE *)\r
+ CALL PNUM ( C.IDENT );\r
+ WHEN BVAKIND : CALL PUTCH ( 'Q' ); (* LOGICAL VARIABLE *)\r
+ CALL PNUM ( C.IDENT );\r
+ WHEN SUBKIND : CALL PUTCH ( 'S' ); (* VARABLE TO BE SUBSTITUTED ON *)\r
+ CALL PNUM ( C.IDENT );\r
+ WHEN VARPROG,\r
+ BVARPRO : IF C.KIND = VARPROG THEN \r
+ CALL PUTCH ( 'S' ) (* SUBSTITUTION S:= *)\r
+ ELSE \r
+ CALL PUTCH ( 'Q' ); (* Q:= *)\r
+ FI;\r
+ CALL PNUM ( C.IDENT );\r
+ CALL PUTCH ( ':' );\r
+ CALL PUTCH ( '=' );\r
+ CALL WR_FOR ( C.LEFT ); (* TAU OR ALFA*)\r
+ IF C.RIGHT = NONE THEN RETURN FI;\r
+ CALL PUTCH ( '(' ); (* NEXT FORMULA *)\r
+ CALL WR_FOR ( C.RIGHT );\r
+ CALL PUTCH ( ')' );\r
+ WHEN SIGNTRM : CALL PUTCH ( 'D' ); (* DUMKIND *)\r
+ CALL PNUM ( C.IDENT );\r
+ ESAC; \r
+END WR_FOR; \r
+\r
+(***************************************************************************)\r
+(* HELP FOR WR_FOR PROCEDURE *)\r
+\r
+UNIT WR_FOR_HELP : PROCEDURE ( C : TNODE, CH : CHARACTER );\r
+BEGIN\r
+ CALL PUTCH ( '(' );\r
+ CALL WR_FOR ( C.LEFT );\r
+ CALL PUTCH ( CH );\r
+ CASE CH\r
+ WHEN '=' : CALL PUTCH ( '>' );\r
+ WHEN '<' : CALL PUTCH ( '=' );\r
+ CALL PUTCH ( '>' );\r
+ ESAC; \r
+ CALL WR_FOR ( C.RIGHT );\r
+ CALL PUTCH ( ')' );\r
+END WR_FOR_HELP;\r
+\r
+(***************************************************************************)\r
+(* ADDITIONAL PROCEDURES AND FUNCTIONS *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+(* GIVES A VALUE OF CHARACTER *)\r
+\r
+UNIT VAL:FUNCTION(A:CHARACTER):INTEGER; \r
+BEGIN \r
+ RESULT:=ORD(A)-48 \r
+END VAL;\r
+\r
+(*****************************************************************************)\r
+(* PRINTS ALL TREES IN A SEQUENT *)\r
+\r
+UNIT SHOW_SEQ : PROCEDURE ( A : SEQUENT );\r
+BEGIN\r
+ IF A <> NONE THEN \r
+ WRITELN("P");\r
+ CALL WR_FOR ( A.PLEAF ); (* SHOW_TREE ( A.PLEAF); *)\r
+ WRITELN("L");\r
+ CALL WR_FOR ( A.LLEAF ); (* SHOW_TREE ( A.LLEAF ); *)\r
+ WRITELN;\r
+ CALL SHOW_SEQ ( A.NEXT );\r
+ FI;\r
+END SHOW_SEQ;\r
+ \r
+(*****************************************************************************)\r
+(* PRINTS TREE *)\r
+\r
+UNIT SHOW_TREE : PROCEDURE ( A : TNODE );\r
+BEGIN\r
+ IF A<>NONE THEN\r
+ WRITELN(A.KIND,"=K",A.IDENT,"=I");\r
+ CALL SHOW_TREE(A.LEFT);\r
+ CALL SHOW_TREE(A.RIGHT);\r
+ FI;\r
+END SHOW_TREE;\r
+\r
+(****************************************************************************)\r
+(* MOVE UP I TNODES FROM RIGHT (P=1) OR LEFT (P=0) SIDE *)\r
+\r
+UNIT LIFT : PROCEDURE ( T : TNODE; I, P : INTEGER );\r
+VAR A : TNODE;\r
+BEGIN\r
+ WHILE I>0\r
+ DO\r
+ CASE P\r
+ WHEN 1: A := T.RIGHT;\r
+ WHEN 0: A := T.LEFT;\r
+ ESAC;\r
+ T.KIND := A.KIND;\r
+ T.IDENT := A.IDENT;\r
+ T.RIGHT := A.RIGHT;\r
+ T.LEFT := A.LEFT;\r
+ KILL ( A );\r
+ I := I - 1\r
+ OD;\r
+END LIFT;\r
+\r
+(****************************************************************************)\r
+(* MOVE UP POINTER *)\r
+\r
+UNIT LIFT_PNTR : PROCEDURE ( INOUT M1 : POINTER );\r
+VAR M2 : POINTER;\r
+BEGIN\r
+ IF M1 <> NONE THEN\r
+ M2 := M1.DOWN;\r
+ CALL ERASE_SEQ ( M1.NEXT );\r
+ IF M1.DOWN <> NONE THEN\r
+ M1.NEXT := M1.DOWN.NEXT;\r
+ M1.DOWN := M1.DOWN.DOWN;\r
+ KILL ( M2 )\r
+ ELSE\r
+ KILL ( M1 )\r
+ FI; \r
+ FI;\r
+END LIFT_PNTR;\r
+ \r
+(****************************************************************************)\r
+(* MOVE LAST NON-EMPTY RIGHT OR LEFT TNODE OF A SEQUENT TO THE BEGINNING *)\r
+\r
+UNIT MOVE : PROCEDURE ( INOUT M : POINTER; P , R : INTEGER);\r
+VAR HEAD1,TAIL : SEQUENT,\r
+ S : INTEGER;\r
+BEGIN\r
+ HEAD1 := NEW SEQUENT;\r
+ TAIL := LAST ( M , P );\r
+ IF P=1 THEN R := R + 1 FI;\r
+ S := R + P;\r
+ CASE S\r
+ WHEN 0:HEAD1.LLEAF:=TAIL.LLEAF; (* LEFT TO LEFT *)\r
+ TAIL.LLEAF:=NONE ; (* P=0,R=0 *)\r
+ WHEN 3:HEAD1.PLEAF:=TAIL.PLEAF; (* RIGHT TO RIGHT *)\r
+ TAIL.PLEAF:=NONE; (* P=1,R=1 *)\r
+ WHEN 1:HEAD1.PLEAF:=TAIL.LLEAF; (* LEFT TO RIGHT *)\r
+ TAIL.LLEAF:=NONE; (* P=0,R=1 *)\r
+ WHEN 2:HEAD1.LLEAF:=TAIL.PLEAF; (* RIGHT TO LEFT *)\r
+ TAIL.PLEAF:=NONE; (* P=1,R=0 *)\r
+ ESAC;\r
+ HEAD1.NEXT := M.NEXT;\r
+ M.NEXT := HEAD1;\r
+END MOVE;\r
+\r
+(****************************************************************************)\r
+(* GIVES THE LAST NON EMPTY P-SIDE SEQUENT *)\r
+\r
+UNIT LAST:FUNCTION(M:POINTER;P:INTEGER):SEQUENT;\r
+VAR HEAD1:SEQUENT;\r
+BEGIN\r
+ IF M=NONE ORIF M.NEXT=NONE THEN \r
+ RESULT:=NONE;\r
+ RETURN;\r
+ FI;\r
+ IF P=1 THEN\r
+ HEAD1:=M.NEXT;\r
+ IF HEAD1.PLEAF<>NONE THEN RESULT:=HEAD1 FI;\r
+ WHILE HEAD1.NEXT<>NONE\r
+ DO\r
+ IF HEAD1.NEXT.PLEAF<>NONE THEN\r
+ RESULT:=HEAD1.NEXT\r
+ FI;\r
+ HEAD1:=HEAD1.NEXT\r
+ OD;\r
+ ELSE\r
+ HEAD1:=M.NEXT;\r
+ IF HEAD1.LLEAF<>NONE THEN RESULT:=HEAD1 FI;\r
+ WHILE HEAD1.NEXT<>NONE\r
+ DO\r
+ IF HEAD1.NEXT.LLEAF<>NONE THEN\r
+ RESULT:=HEAD1.NEXT;\r
+ FI;\r
+ HEAD1:=HEAD1.NEXT\r
+ OD;\r
+ FI;\r
+END LAST;\r
+\r
+(****************************************************************************)\r
+(* GO TO THE END OF A PROGRAM WITH TAU *)\r
+\r
+UNIT END_OF_PRG : PROCEDURE ( INOUT C : TNODE );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ WHILE C.RIGHT <> NONE \r
+ DO \r
+ C := C.RIGHT;\r
+ OD;\r
+END END_OF_PRG;\r
+\r
+(*****************************************************************************)\r
+(* GO TO THE END OF PROGRAM *)\r
+\r
+UNIT END_OF_P : PROCEDURE ( INOUT C : TNODE );\r
+VAR D : TNODE;\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ WHILE C.RIGHT <> NONE \r
+ DO\r
+ D := C;\r
+ C := C.RIGHT;\r
+ OD;\r
+ C := D;\r
+END END_OF_P;\r
+\r
+(*****************************************************************************)\r
+(* GO TO THE END OF AXIOMS LIST *)\r
+ \r
+UNIT END_OF_AX : PROCEDURE ( INOUT AX1 : LIST_AXIOMS );\r
+BEGIN\r
+ IF AX = NONE THEN RETURN FI;\r
+ AX1 := AX;\r
+ WHILE AX1.NEXT <> NONE\r
+ DO\r
+ AX1 := AX1.NEXT;\r
+ OD;\r
+END END_OF_AX;\r
+ \r
+(*****************************************************************************)\r
+(* GO TO THE END OF POINTERS *)\r
+\r
+UNIT END_OF_M : PROCEDURE ( INOUT M : POINTER , A : SEQUENT );\r
+VAR M1 : POINTER;\r
+BEGIN\r
+ IF M = NONE THEN RETURN FI;\r
+ M.NEXT := NONE;\r
+ WHILE M.DOWN <> NONE \r
+ DO\r
+ M := M.DOWN;\r
+ OD;\r
+ M1 := NEW POINTER;\r
+ M.DOWN := M1;\r
+ CALL SQUEEZE ( M1 , 0 );\r
+ CALL SQUEEZE ( M1 , 1 );\r
+ M1.NEXT := A;\r
+ CALL CUT_SEQ ( M1.NEXT );\r
+ M1.DOWN := NONE;\r
+END END_OF_M;\r
+ \r
+(*****************************************************************************)\r
+(* ERASE A TREE *)\r
+\r
+UNIT ERASE : PROCEDURE ( A : TNODE );\r
+BEGIN\r
+ IF A <> NONE THEN\r
+ CALL ERASE ( A.LEFT ); (* GO TO LAST LEFT TNODE *)\r
+ CALL ERASE ( A.RIGHT ); (* GO TO LAST RIGHT TNODE *)\r
+ KILL ( A ); (* REMOVE TNODE *)\r
+ FI;\r
+END ERASE;\r
+\r
+(*****************************************************************************)\r
+(* ERASE A SEQUENT *)\r
+\r
+UNIT ERASE_SEQ : PROCEDURE ( A : SEQUENT );\r
+BEGIN\r
+ IF A <> NONE THEN\r
+ CALL ERASE_SEQ ( A.NEXT ); (* GO TO THE LAST SEQUENT *)\r
+ CALL ERASE ( A.LLEAF ); (* REMOVE LEFT TREE *)\r
+ CALL ERASE ( A.PLEAF ); (* REMOVE RIGHT TREE *)\r
+ KILL ( A ); (* REMOVE SEQUENT *)\r
+ FI;\r
+END ERASE_SEQ;\r
+\r
+(*****************************************************************************)\r
+(* ERASE AN EMPTY POINTER, I.E. LINKED TO THE EMPTY FORMULA ' |- ' *)\r
+\r
+UNIT ERASE_PNTR : PROCEDURE ( INOUT M1 : POINTER );\r
+BEGIN\r
+ IF M1 = NONE THEN RETURN FI; (* SEQUENT IS EMPTY *)\r
+ CALL LIFT_PNTR ( M1 ); (* REMOVE POINTER *)\r
+ CALL ERASE_PNTR ( M1 ); (* REMOVE NEXT POINTER *)\r
+END ERASE_PNTR;\r
+\r
+(*****************************************************************************)\r
+(* REMOVE LIST OF AXIOMS *)\r
+\r
+UNIT ERASE_AX : PROCEDURE ( AX : LIST_AXIOMS );\r
+BEGIN\r
+ IF AX = NONE THEN RETURN FI;\r
+ CALL ERASE_AX ( AX.NEXT );\r
+ CALL ERASE ( AX.AXIOM );\r
+END;\r
+\r
+(*****************************************************************************)\r
+(* GO TO THE END OF SUBSTITUTION *)\r
+\r
+UNIT END_OF_S : PROCEDURE ( INOUT A , B : TNODE );\r
+BEGIN\r
+ IF A = NONE THEN RETURN FI;\r
+ WHILE A.KIND=VARPROG OR A.KIND=BVARPRO \r
+ DO\r
+ B:=A;\r
+ A:=A.RIGHT;\r
+ IF A = NONE THEN EXIT FI ;\r
+ OD;\r
+END END_OF_S;\r
+\r
+(****************************************************************************)\r
+(* MAKES A COPY OF TNODE TREE *)\r
+\r
+UNIT COPYTNODE : FUNCTION ( X : TNODE ) : TNODE;\r
+BEGIN\r
+ IF X <> NONE THEN\r
+ RESULT := COPY ( X );\r
+ RESULT.LEFT := COPYTNODE ( X.LEFT );\r
+ RESULT.RIGHT := COPYTNODE ( X.RIGHT );\r
+ FI;\r
+END COPYTNODE;\r
+\r
+(****************************************************************************)\r
+(* MAKES A COPY OF ALL SEQUENTS IN A TREE , INCLUDING TNODES *)\r
+\r
+UNIT COPYSEQUENT : FUNCTION ( X : SEQUENT ) : SEQUENT;\r
+BEGIN\r
+ IF X <> NONE THEN \r
+ RESULT := COPY ( X );\r
+ RESULT.PLEAF := COPYTNODE ( X.PLEAF );\r
+ RESULT.LLEAF := COPYTNODE ( X.LLEAF );\r
+ RESULT.NEXT := COPYSEQUENT ( X.NEXT );\r
+ FI;\r
+END COPYSEQUENT;\r
+\r
+(*****************************************************************************)\r
+(* UPDATE THE GREATEST NUMBER OF VARIABLE *)\r
+ \r
+UNIT LAST1_X : PROCEDURE ( A : TNODE );\r
+BEGIN\r
+ IF A=NONE THEN RETURN FI;\r
+ IF A.KIND=VARKIND THEN\r
+ IF LAST_X < A.IDENT THEN LAST_X := A.IDENT FI;\r
+ FI;\r
+ CALL LAST1_X ( A.LEFT );\r
+ CALL LAST1_X ( A.RIGHT );\r
+END LAST1_X;\r
+\r
+(****************************************************************************)\r
+(* LOOKING FOR THE GREATEST BVARPRO SUBSTITUTION *)\r
+\r
+UNIT LAST1_Q:PROCEDURE(A:TNODE);\r
+BEGIN\r
+ IF A=NONE THEN RETURN FI;\r
+ IF A.KIND=BVARPRO THEN\r
+ IF LAST_Q < A.IDENT THEN LAST_Q:=A.IDENT FI;\r
+ FI;\r
+ CALL LAST1_Q(A.RIGHT);\r
+ CALL LAST1_Q(A.LEFT);\r
+END LAST1_Q;\r
+\r
+(****************************************************************************)\r
+(* UPDATE THE GREATEST NUMBER OF VARPROG *)\r
+\r
+UNIT LAST1_S : PROCEDURE ( A : TNODE );\r
+BEGIN \r
+ IF A=NONE THEN RETURN FI;\r
+ IF A.KIND=VARPROG THEN\r
+ IF LAST_S < A.IDENT THEN LAST_S := A.IDENT FI;\r
+ FI;\r
+ CALL LAST1_S ( A.LEFT );\r
+ CALL LAST1_S ( A.RIGHT ); \r
+END LAST1_S;\r
+\r
+(****************************************************************************)\r
+(* UPDATE THE GREATEST NUMBER OF VARKIND IN THE DIFINITION TREE AND CHANGE IT \r
+ INTO SUBKIND *)\r
+ \r
+UNIT LAST2_S : FUNCTION ( A1 : TNODE, I : INTEGER ) : INTEGER;\r
+VAR A : TNODE,\r
+ K : INTEGER;\r
+BEGIN\r
+ A := M1.FUN_REL.LEFT;\r
+ FOR K := 1 TO I\r
+ DO\r
+ IF K=1 THEN A := A.LEFT\r
+ ELSE A := A.RIGHT;\r
+ FI;\r
+ OD;\r
+ IF A.KIND=SUBKIND THEN RESULT := A.IDENT\r
+ ELSE LAST_S := LAST_S+1;\r
+ RESULT := LAST_S;\r
+ CALL RENAME ( A1,A.KIND,A.IDENT );\r
+ FI;\r
+END LAST2_S;\r
+\r
+(****************************************************************************)\r
+(* CHANGE VARKIND TO SUBKIND RESPECTIVELY *)\r
+\r
+UNIT RENAME : PROCEDURE ( A1 : TNODE, I,J : INTEGER );\r
+BEGIN\r
+ IF A1=NONE THEN RETURN FI;\r
+ IF A1.KIND=I AND A1.IDENT=J THEN A1.KIND := SUBKIND;\r
+ A1.IDENT := LAST_S\r
+ FI;\r
+ CALL RENAME ( A1.LEFT,I,J );\r
+ CALL RENAME ( A1.RIGHT,I,J );\r
+END RENAME;\r
+\r
+(****************************************************************************)\r
+(* REMOVE ALL EMPTY SEQUENTS AFTER CALLING SQUEEZE PROCEDURE *)\r
+\r
+UNIT CUT_SEQ : PROCEDURE ( A : SEQUENT );\r
+BEGIN\r
+ IF A <> NONE THEN CALL CUT_SEQ ( A.NEXT ) ELSE RETURN FI; (* GO TO THE LAST \r
+ SEQUENT *)\r
+ IF A.PLEAF = NONE AND A.LLEAF = NONE THEN KILL ( A ) FI; (* WHEN EMPTY \r
+ REMOVE IT *)\r
+END CUT_SEQ;\r
+\r
+(****************************************************************************)\r
+(* FIND A CONNECTIVE NUMBER 'R' *)\r
+\r
+UNIT FINDCONN : FUNCTION ( A : SEQUENT , R , P : INTEGER ) : TNODE;\r
+VAR B : TNODE;\r
+BEGIN\r
+ IF A = NONE THEN RETURN FI;\r
+ CASE P\r
+ WHEN 1: IF A.PLEAF = NONE THEN RETURN FI;\r
+ B := A.PLEAF;\r
+ CALL FUNCTOR ( R , B );\r
+ RESULT := B;\r
+ WHEN 0: IF A.LLEAF = NONE THEN RETURN FI;\r
+ B := A.LLEAF;\r
+ CALL FUNCTOR ( R , B );\r
+ RESULT := B;\r
+ ESAC;\r
+END FINDCONN;\r
+\r
+(****************************************************************************)\r
+(* SEARCH FOR A FUNCTOR *)\r
+\r
+UNIT FUNCTOR : PROCEDURE ( R : INTEGER ; INOUT B : TNODE );\r
+ \r
+BEGIN\r
+ IF B.KIND = BEGKIND ANDIF B.LEFT <> NONE ANDIF B.LEFT.IDENT = 1 ANDIF\r
+ B.LEFT.KIND = SEMKIND THEN\r
+ B := B.RIGHT;\r
+ FI;\r
+ WHILE B.KIND = VARPROG OR B.KIND = BVARPRO\r
+ DO\r
+ B := B.RIGHT;\r
+ OD;\r
+ IF B.KIND <> R THEN B := NONE FI;\r
+END FUNCTOR;\r
+\r
+(****************************************************************************)\r
+(* LOOK FOR MORE THAN ONE EQUALITIES IN A SEQUENT OF TYPE U=TERM *)\r
+\r
+UNIT SEARCH_U : FUNCTION ( A : SEQUENT ) : BOOLEAN;\r
+VAR I : INTEGER;\r
+BEGIN\r
+ WHILE A <> NONE \r
+ DO\r
+ IF A.PLEAF <> NONE THEN\r
+ IF A.PLEAF.KIND = EQUKIND ANDIF\r
+ ( A.PLEAF.LEFT.KIND = VRUKIND OR A.PLEAF.LEFT.RIGHT.KIND = VRUKIND ) THEN\r
+ I := I + 1 ;\r
+ FI;\r
+ IF I = 2 THEN \r
+ RESULT := TRUE; \r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+END SEARCH_U;\r
+\r
+(****************************************************************************)\r
+(* CHECK WHETHER THERE IS IN A SEQUENT THE DEFINITION SYMBOL LIKE: FUNCTION, \r
+ LITERAL ; OR PROGRAM *)\r
+\r
+UNIT CHECK_L_F_P : FUNCTION ( A : SEQUENT ) : BOOLEAN;\r
+BEGIN\r
+ IF A <> NONE AND NOT ALFA THEN \r
+ ALFA := CHECK_L_F_P_TN ( A.PLEAF ) OR CHECK_L_F_P_TN ( A.LLEAF );\r
+ RESULT := ALFA OR CHECK_L_F_P ( A.NEXT );\r
+ FI;\r
+END CHECK_L_F_P;\r
+\r
+(*****************************************************************************)\r
+(* CHECK WHETHER THERE IS IN A TNODE THE DEFINITION SYMBOL LIKE: FUNCTION, \r
+ LITERAL ; OR PROGRAM *)\r
+\r
+UNIT CHECK_L_F_P_TN : FUNCTION ( C : TNODE ) : BOOLEAN;\r
+VAR BETA : BOOLEAN ;\r
+BEGIN\r
+ IF C <> NONE THEN\r
+ BETA := ( C.KIND > 2 AND C.KIND < 23 ) OR C.KIND = LT1KIND OR\r
+ C.KIND = FN1KIND OR C.KIND = 4;\r
+ RESULT := BETA OR CHECK_L_F_P_TN ( C.LEFT ) OR CHECK_L_F_P_TN ( C.RIGHT );\r
+ FI;\r
+END;\r
+\r
+(****************************************************************************)\r
+(* WRITES A CHARACTER TO FILE *)\r
+\r
+UNIT PUTCH : PROCEDURE ( A : CHARACTER );\r
+BEGIN\r
+ IF CHARSH >= LINLNG THEN \r
+ WRITELN ;\r
+ CHARSH := 0 \r
+ FI;\r
+ WRITE ( A );\r
+ CHARSH := CHARSH + 1 \r
+END PUTCH;\r
+\r
+(****************************************************************************)\r
+\r
+\r
+(****************************************************************************)\r
+(* PRIMARY RULES AND FIRSTLY PROCEDURES AND FUNCTIONS APPLIED IN THE TREE *) \r
+(****************************************************************************)\r
+\r
+(****************************************************************************)\r
+(* REPLACE IN SEQUENT A ALL FUNKIND WITH NUMBER N TO FN1KIND WITH NUMBER N *)\r
+\r
+UNIT REP_F_SEQ : PROCEDURE ( A : SEQUENT , N : INTEGER );\r
+BEGIN\r
+ IF A = NONE THEN RETURN FI;\r
+ CALL REP_FUN_N ( A.LLEAF , N );\r
+ CALL REP_FUN_N ( A.PLEAF , N );\r
+ CALL REP_F_SEQ ( A.NEXT , N );\r
+END REP_F_SEQ;\r
+\r
+(****************************************************************************)\r
+(* REPLACE IN TNODE C ALL FUNKIND WITH NUMBER N TO FN1KIND WITH NUMBER N *)\r
+\r
+UNIT REP_FUN_N : PROCEDURE ( C : TNODE , N : INTEGER );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ IF C.KIND=FUNKIND AND C.IDENT = N THEN C.KIND := FN1KIND FI;\r
+ CALL REP_FUN_N ( C.LEFT , N );\r
+ CALL REP_FUN_N ( C.RIGHT , N );\r
+END REP_FUN_N;\r
+\r
+(****************************************************************************)\r
+(* REPLACE IN TNODE C ALL FUNKIND TO FN1KIND *)\r
+\r
+UNIT REP_FUN : PROCEDURE ( C : TNODE );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ IF C.KIND = FUNKIND THEN C.KIND := FN1KIND FI;\r
+ CALL REP_FUN ( C.LEFT );\r
+ CALL REP_FUN ( C.RIGHT );\r
+END REP_FUN;\r
+\r
+(****************************************************************************)\r
+(* REPLACE ALL LITKIND WITH NUMBER N IN SEQUENT A TO LT1KIND *)\r
+\r
+UNIT REP_L_SEQ : PROCEDURE ( A :SEQUENT , N :INTEGER );\r
+BEGIN\r
+ IF A = NONE THEN RETURN FI;\r
+ CALL REP_LIT_N ( A.PLEAF , N );\r
+ CALL REP_LIT_N ( A.LLEAF , N );\r
+ CALL REP_L_SEQ ( A.NEXT , N );\r
+END REP_L_SEQ;\r
+\r
+(****************************************************************************)\r
+(* REPLACE ALL LITKIND IN TNODE C TO LT1KIND *)\r
+\r
+UNIT REP_LIT : PROCEDURE ( C : TNODE );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ IF C.KIND = LITKIND THEN C.KIND := LT1KIND FI;\r
+ CALL REP_LIT ( C.LEFT );\r
+ CALL REP_LIT ( C.RIGHT );\r
+END REP_LIT;\r
+\r
+(****************************************************************************)\r
+(* REPLACE ALL LITKIND WITH NUMBER N IN TNODE C TO LT1KIND *)\r
+\r
+UNIT REP_LIT_N : PROCEDURE ( C : TNODE , N : INTEGER );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ IF C.KIND = LITKIND AND C.IDENT = N THEN C.KIND := LT1KIND FI;\r
+ CALL REP_LIT_N ( C.LEFT , N );\r
+ CALL REP_LIT_N ( C.RIGHT , N );\r
+END REP_LIT_N;\r
+\r
+(*****************************************************************************)\r
+(* REPLACE DEFINITION SYMBOL LIKE : FUNKIND AND LITKIND INTO FN1KIND AND \r
+ LT1KIND RESPECTIVELY *)\r
+\r
+UNIT REP_F_L : PROCEDURE ( M3 : DEF );\r
+VAR M2 : DEF ;\r
+BEGIN\r
+ M2 := M3;\r
+ DO \r
+ CASE M3.FUN_REL.KIND \r
+ WHEN EQUKIND : CALL REP_FUN_N ( M2.FUN_REL , M2.FUN_REL.LEFT.IDENT ); \r
+ (* REPLACE FUNKIND WITH PROPER NUMBERS *)\r
+ (* INTO FN1KIND IN A DEFINITION TREE *)\r
+ CALL REP_F_SEQ ( M.NEXT , M2.FUN_REL.LEFT.IDENT );\r
+ (* DO THE SAME BUT IN DATA TREE *)\r
+ WHEN EQVKIND : CALL REP_LIT_N ( M2.FUN_REL , M2.FUN_REL.LEFT.IDENT );\r
+ (* REPLACE LITKIND WITH PROPER NUMBERS *)\r
+ (* INTO LT1KIND IN A DEFINITION TREE *) \r
+ CALL REP_L_SEQ ( M.NEXT , M2.FUN_REL.LEFT.IDENT );\r
+ (* DO THE SAME BUT IN DATA TREE *)\r
+ ESAC;\r
+ IF M2 = M3 THEN EXIT FI;\r
+ M2 := M2.NEXT;\r
+ OD;\r
+END REP_F_L;\r
+\r
+(*****************************************************************************)\r
+(* USE THE DEFINITION OF FUNCTION *)\r
+\r
+UNIT RULEDF_F : PROCEDURE ( M : POINTER, P : INTEGER, F_NUMBER : INTEGER );\r
+VAR A , A1 , ALR , C , B1 : TNODE,\r
+ ALFA : BOOLEAN,\r
+ B : SEQUENT;\r
+BEGIN\r
+ B:=M.NEXT;\r
+ CASE P\r
+ WHEN 1:\r
+ IF B=NONE ORIF B.PLEAF=NONE THEN RETURN FI;\r
+ A := B.PLEAF;\r
+ DO\r
+ WHILE A.KIND <> EQUKIND\r
+ DO\r
+ IF B.NEXT=NONE ORIF B.NEXT.PLEAF=NONE THEN RETURN FI;\r
+ B := B.NEXT;\r
+ A := B.PLEAF;\r
+ OD;\r
+ IF FOUND_F ( B.PLEAF , B.PLEAF , A , ALR , ALFA , F_NUMBER ) THEN \r
+ EXIT FI;\r
+ IF B.NEXT=NONE ORIF B.NEXT.PLEAF=NONE THEN RETURN FI;\r
+ B := B.NEXT;\r
+ A := B.PLEAF; OD;\r
+ WHEN 0:\r
+ IF B=NONE ORIF B.LLEAF=NONE THEN RETURN FI;\r
+ A := B.LLEAF;\r
+ DO\r
+ WHILE A.KIND <> EQUKIND\r
+ DO\r
+ IF B.NEXT=NONE ORIF B.NEXT.LLEAF=NONE THEN RETURN FI;\r
+ B := B.NEXT;\r
+ A := B.LLEAF;\r
+ OD;\r
+ IF FOUND_F ( B.LLEAF , B.LLEAF , A , ALR , ALFA , F_NUMBER ) THEN \r
+ EXIT \r
+ FI;\r
+ IF B.NEXT=NONE ORIF B.NEXT.LLEAF=NONE THEN RETURN FI;\r
+ B := B.NEXT;\r
+ A := B.LLEAF;\r
+ OD;\r
+ ESAC;\r
+ C := ALR.RIGHT; (* C STORES RIGHT SIDE OF *)\r
+ (* OPERATION CONTAINING FUNCTION *)\r
+ A1 := COPYTNODE ( M1.FUN_REL.LEFT.RIGHT ); (* REMEMBER K -TAU *)\r
+ IF ALR.LEFT = NONE THEN (* IF THERE IS NO ARGUMENT *)\r
+ B1 := A1\r
+ ELSE\r
+ B1 := NEW TNODE;\r
+ CALL MAKE_SUB ( ALR.LEFT , A1 , B1 ); (* ALR.LEFT REFERS TO FIRST ARG *)\r
+ CALL LIFT ( B1 , 1 , 0 );\r
+ FI;\r
+ CALL END_OF_P ( A1 ); (* A1 REFERS TO THE END OF PROGRAM *)\r
+ (* BEFORE TAU *)\r
+ IF A.LEFT = ALR THEN (* FUNCTION IS ON LEFT *)\r
+ KILL ( A.LEFT );\r
+ A.LEFT := A1.RIGHT (* JOIN TAU *)\r
+ ELSE (* FUNCTION IS ON RIGHT *) \r
+ KILL ( A.RIGHT );\r
+ A.RIGHT := A1.RIGHT; (* JOIN TAU *)\r
+ FI;\r
+ A1.RIGHT.RIGHT := C; (* JOIN U OR SOMETHING ELSE *)\r
+ A1.RIGHT := NONE;\r
+ CASE P\r
+ WHEN 1 : A1 := B.PLEAF; (* MOVE '=' BEYOND PROGRAM *)\r
+ B.PLEAF := B1; (* ON RIGHT *)\r
+ CALL END_OF_PRG ( B1 );\r
+ B1.RIGHT := A1;\r
+ WHEN 0 : A1 := B.LLEAF; (* OR ON LEFT SIDE *)\r
+ B.LLEAF := B1;\r
+ CALL END_OF_PRG ( B1 );\r
+ B1.RIGHT := A1;\r
+ ESAC\r
+END RULEDF_F;\r
+\r
+(*****************************************************************************)\r
+(* SEARCH FUNCTION FN1KIND IN A TREE TO BE SUBSTITUTED ON *)\r
+\r
+UNIT FOUND_F : FUNCTION ( B , B1 : TNODE ; INOUT C , D : TNODE , ALFA : BOOLEAN ;\r
+ F_NUMBER : INTEGER ) : BOOLEAN;\r
+BEGIN\r
+ IF B <> NONE THEN\r
+ IF B.KIND = FN1KIND AND B.IDENT = F_NUMBER THEN \r
+ RESULT := TRUE ; \r
+ IF NOT ALFA THEN \r
+ ALFA := TRUE;\r
+ D := B;\r
+ C := B1;\r
+ FI;\r
+ RETURN \r
+ ELSE\r
+ RESULT := FOUND_F ( B.LEFT , B , C , D , ALFA , F_NUMBER ) \r
+ OR FOUND_F ( B.RIGHT , B , C , D , ALFA , F_NUMBER )\r
+ FI;\r
+ FI;\r
+END FOUND_F; \r
+ \r
+(****************************************************************************)\r
+(* MAKE THE SUBSTITUTION *)\r
+\r
+UNIT MAKE_SUB:PROCEDURE ( D , A1 , A : TNODE );\r
+VAR F,G,E:TNODE,\r
+ I : INTEGER;\r
+BEGIN \r
+ IF D.RIGHT = NONE THEN (* ONLY ONE ARGUMENT *)\r
+ E := NEW TNODE;\r
+ A.LEFT:=E;\r
+ E.KIND := VARPROG;\r
+ E.LEFT := D;\r
+ E.IDENT :=LAST2_S ( A1 , 1 );\r
+ E.RIGHT := A1;\r
+ RETURN;\r
+ FI;\r
+ F := NEW TNODE; (* MORE THAN ONE ARGUMENTS *)\r
+ F.KIND := BEGKIND;\r
+ F.IDENT := ENDKIND; \r
+ WHILE D <> NONE\r
+ DO (* VIEW ALL ARGUMENTS AND *)\r
+ (* MAKE RELEVANT SUBSTITUTION *)\r
+ (* CREATE SUBSTITUTION CELLS *)\r
+ (* FILL THEM *) \r
+ (* AND JOIN THEM- XI:=TI *)\r
+ G := NEW TNODE;\r
+ G.KIND := SEMKIND;\r
+ G.IDENT := 1; (* SIGN THAT SUBSTITUTION *)\r
+ (* SHOULD BE DONE SIMULTANEOUSLY *)\r
+ E:=NEW TNODE;\r
+ G.LEFT := E;\r
+ E.KIND := VARPROG; \r
+ E.LEFT := D; (* ASSOCIATE VARIABLE WITH ITS term XI:=TI *) \r
+ E.RIGHT := D.RIGHT; \r
+ D.RIGHT := NONE;\r
+ IF I=0 THEN \r
+ A.LEFT := F; \r
+ I := 1; \r
+ F.LEFT := G;\r
+ ELSE \r
+ A.RIGHT := G;\r
+ I := I+1;\r
+ FI;\r
+ E.IDENT := LAST2_S ( A1 , I ); (* ASSIGN VARPROG NEW NUMBER \r
+ AND UPDATE LIST OF VARPROG'S *)\r
+ A := G;\r
+ D := E.RIGHT;\r
+ E.RIGHT := NONE;\r
+ OD;\r
+ CALL LIFT ( G , 1 , 0 );\r
+ F.RIGHT := A1;\r
+END MAKE_SUB; \r
+\r
+(****************************************************************************)\r
+(* USE A DEFINITION OF RELATION *)\r
+\r
+UNIT RULEDF_L : PROCEDURE ( M : POINTER , P : INTEGER , N : INTEGER );\r
+VAR A,A1,D : TNODE,\r
+ B : SEQUENT;\r
+BEGIN\r
+ B := M.NEXT;\r
+ CASE P\r
+ WHEN 1:\r
+ IF B=NONE ORIF B.PLEAF=NONE THEN RETURN FI;\r
+ A := B.PLEAF;\r
+ WHILE ( A.KIND <> LT1KIND OR A.IDENT <> N ) AND A.KIND <> EQVKIND\r
+ DO\r
+ IF B.NEXT=NONE ORIF B.NEXT.PLEAF=NONE THEN RETURN FI;\r
+ B := B.NEXT;\r
+ A := B.PLEAF;\r
+ OD;\r
+ WHEN 0:\r
+ IF B=NONE ORIF B.LLEAF=NONE THEN RETURN FI;\r
+ A := B.LLEAF;\r
+ WHILE ( A.KIND <> LT1KIND OR A.IDENT <> N ) AND A.KIND <> EQVKIND\r
+ DO\r
+ IF B.NEXT=NONE ORIF B.NEXT.LLEAF=NONE THEN RETURN FI;\r
+ B := B.NEXT;\r
+ A := B.LLEAF;\r
+ OD;\r
+ ESAC;\r
+ IF A.KIND = EQVKIND THEN A := A.LEFT FI;\r
+ D := A.LEFT; (* FIRST ARGUMENT *)\r
+ A1 := COPY ( M1.FUN_REL.RIGHT ); (* REMEMBER K-ALFA *)\r
+ IF D=NONE THEN\r
+ A.RIGHT := A1;\r
+ CALL LIFT ( A , 1 , 1 );\r
+ CALL SWEEP ( A );\r
+ RETURN;\r
+ FI;\r
+ CALL MAKE_SUB ( D , A1 , A );\r
+ CASE P\r
+ WHEN 0 : CALL LIFT ( B.LLEAF.LEFT, 1, 0 );\r
+ CALL SWEEP ( B.LLEAF );\r
+ WHEN 1 : CALL LIFT ( B.PLEAF.LEFT, 1, 0 );\r
+ CALL SWEEP ( B.PLEAF );\r
+ ESAC; \r
+ CASE P \r
+ WHEN 0 : A := B.LLEAF;\r
+ WHEN 1 : A := B.PLEAF;\r
+ ESAC;\r
+ IF A.LEFT.KIND = BEGKIND ANDIF A.LEFT.LEFT <> NONE ANDIF \r
+ A.LEFT.LEFT.KIND = SEMKIND ANDIF A.LEFT.LEFT.IDENT = 1 THEN\r
+ D := A.LEFT; (* MOVE OUT PARALLEL *)\r
+ A.LEFT := D.RIGHT; (* SUBSTITUTION BEYOND *)\r
+ D.RIGHT := A; (* EQUIVALENCE *)\r
+ CASE P \r
+ WHEN 0 : B.LLEAF := D;\r
+ WHEN 1 : B.PLEAF := D;\r
+ ESAC;\r
+ FI;\r
+\r
+END RULEDF_L;\r
+\r
+(*****************************************************************************)\r
+\r
+\r
+(*****************************************************************************)\r
+(* AID RULES *)\r
+(*****************************************************************************)\r
+\r
+(****************************************************************************)\r
+(* THROWING AWAY THE SEQUENCE OF SEQUENTS INCLUDING 0 ON LEFT SIDE\r
+ OR 1 ON RIGHT SIDE *)\r
+\r
+UNIT THROW_RUBBISH : PROCEDURE ( M : POINTER );\r
+VAR A : SEQUENT;\r
+BEGIN\r
+ IF M=NONE ORIF M.NEXT=NONE THEN RETURN FI;\r
+ A := M.NEXT;\r
+ WHILE A<>NONE\r
+ DO\r
+ IF A.PLEAF<>NONE THEN\r
+ IF A.PLEAF.IDENT=1 ANDIF A.PLEAF.KIND=LOGKIND THEN\r
+ CALL ERASE_SEQ ( M.NEXT ); (* IF THERE IS TRUE ON RIGHT *)\r
+ EXIT; (* SIDE, THEN REMOVE ALL SEQUENTS *)\r
+ FI;\r
+ IF DEF_LIT = 1 ANDIF A.PLEAF.KIND = LOGKIND ANDIF A.PLEAF.IDENT = 0 THEN\r
+ KILL ( A.PLEAF );\r
+ FI;\r
+ FI;\r
+ IF A.LLEAF<>NONE THEN\r
+ IF A.LLEAF.IDENT=0 ANDIF A.LLEAF.KIND=LOGKIND THEN \r
+ CALL ERASE_SEQ ( M.NEXT ); (* IF THERE IS FALSE ON LEFT *) \r
+ EXIT; (* SIDE, THEN REMOVE ALL SEQUENTS *)\r
+ FI;\r
+ IF DEF_LIT = 1 ANDIF A.LLEAF.KIND = LOGKIND ANDIF A.LLEAF.IDENT = 1 THEN\r
+ KILL ( A.LLEAF );\r
+ FI; \r
+ FI;\r
+ A := A.NEXT; (* OTHERWISE GO ON FURTHER *)\r
+ OD;\r
+END THROW_RUBBISH;\r
+\r
+(****************************************************************************)\r
+(* CALCULATE STANDARD FUNCTIONS *,+,-,^,/ *)\r
+\r
+UNIT RULEVAL : PROCEDURE ( A:TNODE; INOUT ALFA:BOOLEAN );\r
+VAR BETA : BOOLEAN,\r
+ B,C : TNODE;\r
+BEGIN\r
+ BETA := TRUE; \r
+ IF A=NONE THEN RETURN FI; \r
+ IF A.KIND=ARIKIND THEN (* MUST BEGIN WITH FUNCTOR *)\r
+ CALL CHECKCHAR ( A.LEFT , BETA ); (* CHECK WHETHER IN THE FOLLOWING\r
+ TREE THERE ARE ONLY STANDARD\r
+ FUNCTORS AND DIGITS *)\r
+ IF BETA THEN (* IF YES *)\r
+ BETA := FALSE;\r
+ CALL FUNCHECK ( A , BETA );\r
+ A.IDENT := COUNT ( A ) ; (* COUNT THIS EXPRESSION *)\r
+ IF BETA THEN \r
+ A.KIND := CN1KIND\r
+ ELSE \r
+ A.KIND := CNTKIND;\r
+ FI;\r
+ CALL ERASE ( A.LEFT ); (* WHEN DONE REMOVE IT *)\r
+ ALFA := TRUE;\r
+ RETURN\r
+ ELSE (* MAKE SPECIAL ARITHMETIC *)\r
+ BETA := TRUE; (* OPERATIONS LIKE : X+X A.S.O. *)\r
+ B := COPYTNODE ( A.LEFT );\r
+ C := B.RIGHT;\r
+ B.RIGHT := NONE;\r
+ CALL COMPARE ( B , C , BETA ); (* COMPARE TWO TREES *)\r
+ IF BETA THEN (* THEY ARE EQUAL *)\r
+ B.RIGHT := C;\r
+ CALL ERASE ( B );\r
+ CASE A.IDENT \r
+ WHEN 42 : A.IDENT := 94; (* TERM*TERM -> TERM^2 *)\r
+ A.LEFT.RIGHT.KIND := CNTKIND;\r
+ A.LEFT.RIGHT.IDENT := 2;\r
+ CALL ERASE ( A.LEFT.RIGHT.LEFT );\r
+ WHEN 43 : A.IDENT := 42; (* TERM+TERM -> 2*TERM *)\r
+ A.LEFT.KIND := CNTKIND;\r
+ A.LEFT.IDENT := 2;\r
+ CALL ERASE ( A.LEFT.LEFT );\r
+ ESAC; \r
+ FI;\r
+ FI;\r
+ FI;\r
+ CALL RULEVAL ( A.LEFT,ALFA );\r
+ CALL RULEVAL ( A.RIGHT,ALFA );\r
+END RULEVAL;\r
+\r
+(****************************************************************************)\r
+(* CALLS COUNT_0_1 UNTIL IT IS NOT USELESS *)\r
+\r
+UNIT ZEROS_AND_ONES : PROCEDURE ( A : TNODE ; ALFA : BOOLEAN );\r
+VAR BETA : BOOLEAN; (* BETA MEANS THAT COUNT_0_1 IS STILL WORKING *)\r
+BEGIN\r
+ BETA := TRUE;\r
+ WHILE BETA\r
+ DO\r
+ BETA := FALSE;\r
+ CALL COUNT_0_1 ( A , BETA );\r
+ ALFA := ALFA OR BETA;\r
+ OD;\r
+END ZEROS_AND_ONES;\r
+\r
+(****************************************************************************)\r
+(* DOES ALL ARITHMETIC OPERATIONS *)\r
+\r
+UNIT COUNT_0_1 : PROCEDURE ( B : TNODE ; INOUT ALEF : BOOLEAN );\r
+VAR BETA : BOOLEAN;\r
+BEGIN\r
+ IF B=NONE THEN RETURN FI;\r
+ IF B.KIND=ARIKIND THEN\r
+ BETA := FALSE;\r
+ IF B.LEFT.KIND = CNTKIND OR B.LEFT.KIND = CN1KIND THEN\r
+ CASE B.LEFT.IDENT\r
+ WHEN 0: CASE B.IDENT\r
+ WHEN 42,94:CALL FUNCHECK ( B.LEFT.RIGHT , BETA );\r
+ IF B.IDENT = 94 AND B.LEFT.RIGHT.IDENT = 0 \r
+ AND B.LEFT.RIGHT.KIND = CNTKIND THEN\r
+ CALL EXCEPTIONS ( 4 )\r
+ ELSE\r
+ IF BETA THEN\r
+ B.KIND := CN1KIND\r
+ ELSE\r
+ B.KIND := CNTKIND;\r
+ FI;\r
+ B.IDENT := 0;\r
+ CALL ERASE ( B.LEFT );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ FI;\r
+ WHEN 43:B.LEFT.RIGHT.RIGHT := B.RIGHT;\r
+ CALL LIFT ( B,1,0 );\r
+ CALL LIFT ( B,1,1 );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ WHEN 47:IF B.LEFT.RIGHT.KIND=CNTKIND AND\r
+ B.LEFT.RIGHT.IDENT = 0 THEN\r
+ CALL EXCEPTIONS ( 2 )\r
+ ELSE\r
+ CALL FUNCHECK ( B.LEFT.RIGHT,BETA );\r
+ IF BETA THEN\r
+ B.KIND := CN1KIND;\r
+ ELSE\r
+ B.KIND := CNTKIND;\r
+ FI;\r
+ B.IDENT := 0;\r
+ CALL ERASE ( B.LEFT );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ FI;\r
+ WHEN 45:CALL LIFT ( B.LEFT,1,1 );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ ESAC;\r
+ WHEN 1: CASE B.IDENT\r
+ WHEN 42:B.LEFT.RIGHT.RIGHT := B.RIGHT;\r
+ CALL LIFT ( B,1,0 );\r
+ CALL LIFT ( B,1,1 );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ WHEN 94:CALL FUNCHECK ( B.LEFT.RIGHT,BETA );\r
+ IF BETA THEN\r
+ B.KIND := CN1KIND;\r
+ ELSE\r
+ B.KIND := CNTKIND;\r
+ FI;\r
+ B.IDENT := 1;\r
+ CALL ERASE ( B.LEFT );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ WHEN 47:IF B.LEFT.RIGHT.IDENT=1 THEN\r
+ B.KIND := CNTKIND;\r
+ B.IDENT := 1;\r
+ CALL ERASE ( B.LEFT );\r
+ ALEF := TRUE;\r
+ FI;\r
+ RETURN;\r
+ ESAC;\r
+ ESAC\r
+ ELSE\r
+ IF B.LEFT.RIGHT.KIND = CNTKIND OR B.LEFT.RIGHT.KIND = CN1KIND THEN\r
+ CASE B.LEFT.RIGHT.IDENT\r
+ WHEN 0: CASE B.IDENT\r
+ WHEN 42:CALL FUNCHECK ( B.LEFT , BETA );\r
+ IF BETA THEN\r
+ B.KIND := CN1KIND;\r
+ ELSE\r
+ B.KIND := CNTKIND;\r
+ FI;\r
+ B.IDENT := 0;\r
+ CALL ERASE ( B.LEFT );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ WHEN 43:CALL ERASE ( B.LEFT.RIGHT );\r
+ B.LEFT.RIGHT := B.RIGHT;\r
+ CALL LIFT ( B,1,0 );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ WHEN 94:CALL FUNCHECK ( B.LEFT,BETA );\r
+ IF BETA THEN\r
+ B.KIND := CN1KIND;\r
+ ELSE\r
+ B.KIND := CNTKIND;\r
+ FI;\r
+ B.IDENT := 1;\r
+ CALL ERASE ( B.LEFT );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ WHEN 47:CALL EXCEPTIONS ( 3 );\r
+ WHEN 45:KILL ( B.LEFT.RIGHT );\r
+ B.LEFT.RIGHT := B.RIGHT;\r
+ CALL LIFT ( B,1,0 );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ ESAC;\r
+ WHEN 1: CASE B.IDENT\r
+ WHEN 42,47,94:B.LEFT.RIGHT.RIGHT := B.RIGHT;\r
+ CALL LIFT ( B,1,0 );\r
+ CALL LIFT ( B.RIGHT,1,1 );\r
+ ALEF := TRUE;\r
+ RETURN;\r
+ ESAC;\r
+ ESAC;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ CALL COUNT_0_1 ( B.LEFT,ALEF );\r
+ CALL COUNT_0_1 ( B.RIGHT,ALEF );\r
+END COUNT_0_1;\r
+\r
+(****************************************************************************)\r
+(* CHECK WHETHER THERE IS A FN1KIND OR CN1KIND IN A TREE *)\r
+(* FN1KIND MEANS THE NAME OF FUNCTION DEFINED BY A PROCEDURE OF THE\r
+ FORM F(X)=KT *)\r
+\r
+UNIT FUNCHECK : PROCEDURE ( C : TNODE ; INOUT BETA : BOOLEAN );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ IF C.KIND = FN1KIND OR C.KIND = CN1KIND THEN \r
+ BETA := TRUE;\r
+ RETURN; \r
+ FI;\r
+ CALL FUNCHECK ( C.LEFT , BETA );\r
+ CALL FUNCHECK ( C.RIGHT , BETA );\r
+END FUNCHECK; \r
+\r
+(****************************************************************************)\r
+(* TERM=TERM CONVERTS TO LOGICAL 1 *)\r
+\r
+UNIT RULEIDE : PROCEDURE ( C : TNODE ; INOUT ALFA : BOOLEAN );\r
+VAR A,B : TNODE,\r
+ BETA : BOOLEAN;\r
+BEGIN\r
+ IF C=NONE THEN RETURN FI;\r
+ BETA := TRUE;\r
+ IF C.KIND=EQUKIND THEN \r
+ CASE C.LEFT.KIND \r
+ WHEN VARPROG , \r
+ BVARPRO : A := C.LEFT;\r
+ CALL END_OF_S ( A,B );\r
+ B := A.RIGHT;\r
+ A.RIGHT := NONE;\r
+ CALL COMPARE ( C.LEFT,B,BETA );\r
+ A.RIGHT := B;\r
+ WHEN IFFKIND : A := C.LEFT.RIGHT.RIGHT.RIGHT.RIGHT ;\r
+ C.LEFT.RIGHT.RIGHT.RIGHT.RIGHT := NONE;\r
+ CALL COMPARE ( C.LEFT , A , BETA );\r
+ C.LEFT.RIGHT.RIGHT.RIGHT.RIGHT := A; \r
+ WHEN BEGKIND : A := C.LEFT.RIGHT.RIGHT;\r
+ C.LEFT.RIGHT.RIGHT := NONE;\r
+ CALL COMPARE ( C.LEFT, A ,BETA );\r
+ C.LEFT.RIGHT.RIGHT := A;\r
+ WHEN WHIKIND : A := C.LEFT.RIGHT.RIGHT.RIGHT;\r
+ C.LEFT.RIGHT.RIGHT.RIGHT := NONE;\r
+ CALL COMPARE ( C.LEFT , A , BETA );\r
+ C.LEFT.RIGHT.RIGHT.RIGHT := A;\r
+ OTHERWISE A := C.LEFT.RIGHT; (* STORE RIGHT ARGUMENT *)\r
+ C.LEFT.RIGHT := NONE;\r
+ CALL COMPARE ( C.LEFT , A , BETA );\r
+ C.LEFT.RIGHT := A;\r
+ ESAC;\r
+ IF BETA THEN \r
+ C.KIND := LOGKIND;\r
+ C.IDENT := 1;\r
+ CALL ERASE ( C.LEFT );\r
+ ALFA := TRUE;\r
+ FI;\r
+ FI;\r
+END RULEIDE;\r
+\r
+(*****************************************************************************)\r
+(* COMPARE THOROUGHLY TWO TREES *)\r
+\r
+UNIT COMPARE : PROCEDURE ( A,B : TNODE ; INOUT BETA : BOOLEAN );\r
+BEGIN\r
+ IF A <> NONE AND B <> NONE THEN\r
+ IF A.KIND=B.KIND AND A.IDENT=B.IDENT THEN \r
+ CALL COMPARE ( A.LEFT,B.LEFT,BETA );\r
+ CALL COMPARE ( A.RIGHT,B.RIGHT,BETA )\r
+ ELSE\r
+ BETA := FALSE;\r
+ RETURN\r
+ FI\r
+ ELSE\r
+ IF A <> NONE OR B <> NONE THEN BETA := FALSE FI; \r
+ FI\r
+END COMPARE; \r
+\r
+(****************************************************************************)\r
+(* TERM1 <> TERM2 IN THE STANDARD INTERPRETATION CONVERTS TO 0 *)\r
+\r
+UNIT RULEIDT : PROCEDURE ( C : TNODE ; INOUT ALFA : BOOLEAN );\r
+VAR BETA : BOOLEAN;\r
+BEGIN\r
+ BETA := TRUE;\r
+ IF C = NONE THEN RETURN FI;\r
+ IF C.KIND = EQUKIND THEN \r
+ CALL CHECKCHAR ( C.LEFT,BETA );\r
+ IF BETA THEN \r
+ IF COUNT( C.LEFT ) <> COUNT( C.LEFT.RIGHT ) THEN\r
+ C.KIND := LOGKIND;\r
+ C.IDENT := 0;\r
+ CALL ERASE ( C.LEFT );\r
+ ALFA := TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+END RULEIDT;\r
+\r
+(****************************************************************************)\r
+(* CALCULATOR *)\r
+\r
+UNIT COUNT : FUNCTION ( A : TNODE ) : INTEGER;\r
+VAR BASIS,I,POWER,LIMIT : INTEGER;\r
+BEGIN\r
+ IF A.KIND <> ARIKIND THEN\r
+ RESULT := A.IDENT\r
+ ELSE\r
+ CASE A.IDENT\r
+ WHEN 42 : RESULT := COUNT( A.LEFT ) * COUNT( A.LEFT.RIGHT );\r
+ WHEN 43 : RESULT := COUNT( A.LEFT ) + COUNT( A.LEFT.RIGHT );\r
+ WHEN 47 : RESULT := COUNT( A.LEFT ) DIV COUNT( A.LEFT.RIGHT );\r
+ WHEN 45 : RESULT := COUNT( A.LEFT ) - COUNT( A.LEFT.RIGHT );\r
+ WHEN 94 : IF A.LEFT.RIGHT.IDENT=0 THEN \r
+ RESULT := 1\r
+ ELSE\r
+ POWER := 1;\r
+ BASIS := COUNT ( A.LEFT );\r
+ LIMIT := COUNT ( A.LEFT.RIGHT );\r
+ FOR I:=1 TO LIMIT\r
+ DO\r
+ POWER := POWER * BASIS;\r
+ OD;\r
+ RESULT := POWER;\r
+ FI;\r
+ ESAC\r
+ FI; \r
+END COUNT;\r
+\r
+(****************************************************************************)\r
+(* CHECK WHETHER TERM IS BUILT ONLY BY STANDARD FUNCTORS *)\r
+\r
+UNIT CHECKCHAR : PROCEDURE ( A : TNODE ; INOUT BETA : BOOLEAN );\r
+BEGIN\r
+ IF A<>NONE THEN\r
+ IF A.KIND=ARIKIND OR A.KIND=CNTKIND OR A.KIND=CN1KIND THEN\r
+ CALL CHECKCHAR ( A.LEFT , BETA );\r
+ CALL CHECKCHAR ( A.RIGHT , BETA )\r
+ ELSE\r
+ BETA := FALSE;\r
+ RETURN\r
+ FI; \r
+ FI;\r
+END CHECKCHAR;\r
+\r
+(****************************************************************************)\r
+(* A HELP FOR DUST_BIN PROCEDURE , MANAGE THE VERY SIMPLE BOOLEAN OPERATIONS *)\r
+\r
+UNIT DUST : PROCEDURE ( C : TNODE ; INOUT ALFA : BOOLEAN );\r
+BEGIN\r
+ CASE C.KIND\r
+ WHEN CONKIND: IF C.LEFT.KIND=LOGKIND THEN\r
+ CASE C.LEFT.IDENT\r
+ WHEN 1: CALL ERASE ( C.LEFT );\r
+ CALL LIFT ( C,1,1 );\r
+ ALFA := TRUE;\r
+ WHEN 0: CALL ERASE ( C.RIGHT );\r
+ CALL LIFT ( C,1,0 );\r
+ ALFA := TRUE;\r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ IF C.RIGHT.KIND=LOGKIND THEN\r
+ CASE C.RIGHT.IDENT\r
+ WHEN 1: CALL ERASE ( C.RIGHT );\r
+ CALL LIFT ( C,1,0 );\r
+ ALFA := TRUE;\r
+ WHEN 0: CALL ERASE ( C.LEFT );\r
+ CALL LIFT ( C,1,1 );\r
+ ALFA := TRUE;\r
+ ESAC;\r
+ RETURN;\r
+ FI; \r
+ WHEN DISKIND: IF C.LEFT.KIND=LOGKIND THEN\r
+ CASE C.LEFT.IDENT\r
+ WHEN 1: CALL ERASE ( C.RIGHT );\r
+ CALL LIFT ( C,1,0 );\r
+ ALFA := TRUE;\r
+ WHEN 0: CALL ERASE ( C.LEFT );\r
+ CALL LIFT ( C,1,1 );\r
+ ALFA := TRUE;\r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ IF C.RIGHT.KIND=LOGKIND THEN\r
+ CASE C.RIGHT.IDENT\r
+ WHEN 1: CALL ERASE ( C.LEFT );\r
+ CALL LIFT ( C,1,1 );\r
+ ALFA := TRUE;\r
+ WHEN 0: CALL ERASE ( C.RIGHT );\r
+ CALL LIFT ( C,1,0 );\r
+ ALFA := TRUE; \r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ WHEN NEGKIND: IF C.LEFT.KIND=LOGKIND THEN\r
+ CASE C.LEFT.IDENT\r
+ WHEN NEGKIND: CALL LIFT ( C,2,0 );\r
+ ALFA := TRUE;\r
+ WHEN 1: CALL LIFT ( C,1,0 );\r
+ C.IDENT:=0;\r
+ ALFA := TRUE;\r
+ WHEN 0: CALL LIFT ( C,1,0 );\r
+ C.IDENT:=1;\r
+ ALFA := TRUE;\r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ WHEN IMPKIND : IF C.LEFT.KIND=LOGKIND THEN \r
+ CASE C.LEFT.IDENT\r
+ WHEN 1: CALL ERASE ( C.LEFT );\r
+ CALL LIFT ( C,1,1 );\r
+ ALFA := TRUE;\r
+ WHEN 0: C.KIND := LOGKIND;\r
+ C.IDENT:=1;\r
+ CALL ERASE ( C.LEFT );\r
+ CALL ERASE ( C.RIGHT );\r
+ ALFA := TRUE;\r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ IF C.RIGHT.KIND=LOGKIND THEN\r
+ CASE C.RIGHT.IDENT\r
+ WHEN 1: C.KIND := LOGKIND;\r
+ C.IDENT := 1;\r
+ CALL ERASE ( C.LEFT );\r
+ CALL ERASE ( C.RIGHT );\r
+ ALFA := TRUE;\r
+ WHEN 0: C.KIND:=NEGKIND;\r
+ CALL ERASE ( C.RIGHT );\r
+ ALFA := TRUE;\r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ ESAC;\r
+END DUST;\r
+\r
+(****************************************************************************)\r
+(* CALLED BY SWEEP PROCEDURE *)\r
+\r
+UNIT DUST_BIN : PROCEDURE ( C : TNODE ; INOUT ALFA : BOOLEAN );\r
+BEGIN\r
+ IF C = NONE THEN RETURN FI;\r
+ CALL RULEVAL ( C,ALFA ); (* COUNT ARITHMETIC EXPRESSIONS : '1+2 -> 3' *)\r
+ CALL ZEROS_AND_ONES ( C,ALFA ); (* COUNT EXPRESSIONS E.G. 0*X *)\r
+ CALL RULEIDT ( C,ALFA ); (* TERM1 <> TERM2 -> FALSE *)\r
+ CALL RULEIDE ( C,ALFA ); (* TERM1 IDENTICAL WITH TERM2 -> TRUE *)\r
+ CALL DUST ( C,ALFA ); (* SIMPLIFY BOOLEAN EXPRESSIONS *)\r
+ CALL DUST_BIN ( C.LEFT,ALFA );\r
+ CALL DUST_BIN ( C.RIGHT,ALFA );\r
+ END DUST_BIN;\r
+\r
+(****************************************************************************)\r
+(* MANAGE THE SWEEPING SYSTEM IN A TREE , CALL DUST_BIN PROCEDURE *)\r
+\r
+UNIT SWEEP : PROCEDURE ( C : TNODE );\r
+VAR ALFA : BOOLEAN;\r
+BEGIN\r
+ ALFA := TRUE;\r
+ WHILE ALFA \r
+ DO (* SWEEP IF IT IS POSSIBLE *)\r
+ ALFA := FALSE;\r
+ CALL DUST_BIN ( C , ALFA ); (* MAKE IT AND UPDATE ALFA *)\r
+ OD;\r
+END SWEEP;\r
+\r
+(****************************************************************************)\r
+(* SQUEEZE A LIST OF SEQUENTS BY GETTING RID OF ALL THE HOLES *)\r
+\r
+UNIT SQUEEZE : PROCEDURE ( M : POINTER , P : INTEGER );\r
+VAR A,B : SEQUENT;\r
+BEGIN\r
+ IF M=NONE ORIF M.NEXT=NONE ORIF LAST (M,P)=NONE THEN RETURN FI;\r
+ A := FIRSTHOLE ( M , P );\r
+ B := NEXTNODE ( A , P );\r
+ WHILE LAST(M,P).NEXT <> A\r
+ DO\r
+ CASE P\r
+ WHEN 1: A.PLEAF := B.PLEAF;\r
+ B.PLEAF := NONE;\r
+ WHEN 0: A.LLEAF := B.LLEAF;\r
+ B.LLEAF := NONE;\r
+ ESAC;\r
+ B := NEXTNODE ( A.NEXT , P );\r
+ A := FIRSTHOLE ( M , P );\r
+ OD;\r
+END SQUEEZE;\r
+\r
+(****************************************************************************)\r
+(* SEARCH FOR THE FIRST NON-EMPTY TNODE AFTER THE FIRST HOLE *)\r
+\r
+UNIT NEXTNODE : FUNCTION ( U : SEQUENT , P : INTEGER ) : SEQUENT;\r
+VAR ALFA : BOOLEAN;\r
+BEGIN\r
+ IF U=NONE THEN RETURN FI;\r
+ WHILE U <> NONE AND NOT ALFA\r
+ DO\r
+ CASE P\r
+ WHEN 1:IF U.PLEAF <> NONE THEN\r
+ RESULT := U;\r
+ ALFA := TRUE\r
+ ELSE\r
+ U := U.NEXT;\r
+ FI;\r
+ WHEN 0:IF U.LLEAF <> NONE THEN\r
+ RESULT := U;\r
+ ALFA := TRUE\r
+ ELSE\r
+ U := U.NEXT\r
+ FI;\r
+ ESAC;\r
+ OD;\r
+END NEXTNODE;\r
+\r
+(****************************************************************************)\r
+(* SEARCH FOR THE FIRST HOLE *)\r
+\r
+UNIT FIRSTHOLE : FUNCTION ( M : POINTER , P : INTEGER ) : SEQUENT;\r
+VAR ALFA : BOOLEAN,\r
+ A : SEQUENT;\r
+BEGIN\r
+ IF M=NONE ORIF M.NEXT=NONE THEN RETURN FI;\r
+ A := M.NEXT;\r
+ WHILE A <> NONE AND NOT ALFA\r
+ DO\r
+ CASE P\r
+ WHEN 1: IF A.PLEAF=NONE THEN\r
+ RESULT := A;\r
+ ALFA := TRUE\r
+ ELSE\r
+ A := A.NEXT;\r
+ FI;\r
+ WHEN 0: IF A.LLEAF=NONE THEN\r
+ RESULT := A;\r
+ ALFA := TRUE\r
+ ELSE\r
+ A := A.NEXT;\r
+ FI;\r
+ ESAC;\r
+ OD;\r
+END FIRSTHOLE;\r
+\r
+(****************************************************************************)\r
+\r
+(****************************************************************************)\r
+(* ESSENTIAL RULES *)\r
+(****************************************************************************)\r
+\r
+(****************************************************************************)\r
+(* SENDS TO PROPER RULES *)\r
+\r
+UNIT RULES : PROCEDURE ( INOUT M : POINTER; P , R : INTEGER );\r
+VAR C : TNODE;\r
+BEGIN\r
+ C := FINDCONN ( LAST ( M , P ) , R , P );\r
+ IF C=NONE THEN RETURN FI;\r
+ CASE R\r
+ WHEN 03: CALL RULEEQU ( M,C,P );\r
+ WHEN 04: CALL RULECON ( M,C,P );\r
+ WHEN 05: CALL RULEDIS ( M,C,P );\r
+ WHEN 06: CALL RULEIMP ( M,C,P );\r
+ WHEN 07: CALL RULENEG ( M,C,P );\r
+ WHEN 09: IF P=1 THEN CALL RULEEXIST ( M,C,P )\r
+ ELSE CALL RULE_EX_GEN ( M,P,K_MN_K,C,LOGIC );\r
+ FI;\r
+ WHEN 08: IF P=1 THEN CALL RULE_EX_GEN ( M,P,K_MN_K,C,LOGIC )\r
+ ELSE CALL RULEEXIST ( M,C,P )\r
+ FI;\r
+ WHEN 10: CALL RULEIF ( M,C,P ); \r
+ WHEN 11: CALL RULEBEG ( M, C, P );\r
+ WHEN 12: CALL RULEWHL ( M,C,P );\r
+ WHEN 13: CALL RULEQUAN ( M,P ); \r
+ ESAC;\r
+END RULES;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR THE PROGRAM BEGIN-END *)\r
+\r
+UNIT RULEBEG : PROCEDURE ( INOUT M : POINTER, C : TNODE, P : INTEGER );\r
+VAR A,B,D,E,F : TNODE;\r
+BEGIN\r
+ A := C.RIGHT; (* HOLD BETA *)\r
+ IF C.LEFT.IDENT = 1 THEN (* SIMULTANEOUSLY SUBSTITUTION *)\r
+ CALL BEG_SUB ( C ) ;\r
+ CALL MOVE ( M, P, P );\r
+ RETURN;\r
+ FI;\r
+ IF C.LEFT<>NONE THEN\r
+ CALL LIFT ( C, 1, 0 ); (* THROW 'BEGIN' AND 'END' *)\r
+ IF C.KIND=0 THEN (* ONLY ONE PROGRAM *)\r
+ CALL LIFT ( C, 1, 0 );\r
+ CALL END_OF_PRG ( C ); (* GO TO THE END OF IT *)\r
+ C.RIGHT := A (* REFERS TO 'BETA' *)\r
+ ELSE (* MORE THAN ONE PROGRAM *)\r
+ WHILE C.KIND=SEMKIND (* LOOP FOR NEXT PROGRAMS *)\r
+ DO\r
+ B := C.RIGHT; (* HOLD NEXT PROGRAM *)\r
+ CALL LIFT ( C, 1, 0 ); (* THROW SEMICOLON *)\r
+ CALL END_OF_PRG ( C ); (* GO TO THE END OF PROGRAM *)\r
+ C.RIGHT := B; C:=B;\r
+ OD;\r
+ CALL END_OF_PRG ( C ); (* END OF LAST PROGRAM *)\r
+ C.RIGHT := A; (* REFERS TO 'BETA' *)\r
+ FI\r
+ ELSE (* NO PROGRAM *)\r
+ CALL LIFT ( C, 1, 1 ) \r
+ FI;\r
+ CALL MOVE ( M, P, P );\r
+END RULEBEG;\r
+\r
+(****************************************************************************)\r
+(* DO SIMULTANEOUS SUBSTITUTIONS, MADE BY RULEDF_F AND RULEDF_L \r
+ PROCEDURES, WHEN ONLY ATOMS LEFT *)\r
+\r
+UNIT BEG_SUB : PROCEDURE ( C : TNODE );\r
+BEGIN\r
+ IF C.RIGHT.KIND = LITKIND OR C.RIGHT.KIND = EQUKIND \r
+ OR C.RIGHT.KIND = LOGKIND OR C.RIGHT.KIND = BVAKIND THEN \r
+ (* MAKE ONLY IN ATOMS AND *)\r
+ (* LOGICAL CONTANTS *)\r
+ CALL SUB ( C, C.RIGHT );\r
+ CALL ERASE ( C.LEFT ); (* WHEN DONE ERASE SUBSTITUTIONS *)\r
+ CALL LIFT ( C, 1, 1 );\r
+ FI;\r
+END BEG_SUB;\r
+ \r
+(*****************************************************************************)\r
+(* CALLED BY BEG_SUB PROCEDURES *)\r
+\r
+UNIT SUB : PROCEDURE ( A, A1 : TNODE );\r
+VAR B,C,D : TNODE;\r
+BEGIN\r
+ IF A1 = NONE THEN RETURN FI;\r
+ IF A1.KIND = SUBKIND THEN (* MIGHT BE CHANGED *)\r
+ B := A.LEFT; (* REFERS TO SEMICOLON *)\r
+ WHILE B <> NONE (* VIEW THE WHOLE LIST *)\r
+ DO\r
+ IF B.KIND <> SEMKIND THEN\r
+ C := B\r
+ ELSE\r
+ C := B.LEFT; (* C REFERS TO NEXT ARG *)\r
+ FI;\r
+ IF C.IDENT = A1.IDENT THEN (* WILL BE CHANGED *)\r
+ A1.LEFT := COPYTNODE ( C.LEFT ); (* S/TAU *)\r
+ D := A1.RIGHT; (* STORES TEMPORARILY NEXT ARG *)\r
+ CALL LIFT ( A1, 1, 0 ); (* REMOVE S *)\r
+ A1.RIGHT := D; (* LINK STORED ARG *)\r
+ CALL SUB ( A, A1.RIGHT ); (* REALIZE SIMULTANEOUS *)\r
+ (* SUBSTITUTION *)\r
+ RETURN; \r
+ FI;\r
+ B := B.RIGHT;\r
+ OD;\r
+ FI;\r
+ CALL SUB ( A, A1.LEFT );\r
+ CALL SUB ( A, A1.RIGHT );\r
+END SUB;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR A PROGRAM WHILE-DO-OD *)\r
+\r
+UNIT RULEWHL : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+VAR B,D,E,F,G,S,T,U,V : TNODE;\r
+BEGIN\r
+ B := C.LEFT; (* HOLD 'ALFA' *)\r
+ D := C.RIGHT.LEFT; (* HOLD PROGRAM 'K' *)\r
+ E := C.RIGHT.RIGHT; (* HOLD 'BETA' *)\r
+ C.KIND := BVARPRO; (* Q:=... *)\r
+ C.IDENT := -LAST_Q-1;\r
+ G := NEW TNODE;\r
+ C.LEFT := G;\r
+ G.KIND := LOGKIND; (* ...1 *)\r
+ G.IDENT := 1;\r
+ C.RIGHT.KIND := ITEKIND; (* ITER. GREAT QUANT. *)\r
+ C.RIGHT.IDENT := 0;\r
+ G := NEW TNODE; (* 'BEGIN' - 'END' *)\r
+ C := C.RIGHT;\r
+ C.LEFT := NONE;\r
+ C.RIGHT := G;\r
+ G.KIND := BEGKIND;\r
+ G.IDENT := ENDKIND;\r
+ U := NEW TNODE; \r
+ G.LEFT := U;\r
+ U.KIND := SEMKIND; (* SEMICOLON *)\r
+ V := NEW TNODE;\r
+ U.LEFT := V;\r
+ V.KIND := BVARPRO; (* Q:=... *)\r
+ V.IDENT := -LAST_Q-1;\r
+ T := NEW TNODE;\r
+ V.LEFT := T;\r
+ T.KIND := CONKIND; (* CONJUNCTION *)\r
+ S := NEW TNODE;\r
+ T.LEFT := S;\r
+ S.KIND := BVAKIND; (* Q *)\r
+ S.IDENT := -LAST_Q-1;\r
+ T.RIGHT := B; (* REFERS TO 'ALFA' *)\r
+ U.RIGHT := D; (* REFERS TO PROGRAM 'K' *)\r
+ T := NEW TNODE;\r
+ G.RIGHT := T;\r
+ T.KIND := CONKIND; (* CONJUNCTION *)\r
+ U := NEW TNODE;\r
+ T.LEFT := U;\r
+ U.KIND := BVAKIND; (* Q *)\r
+ U.IDENT := -LAST_Q-1;\r
+ G := NEW TNODE; (* CONJUNCTION *)\r
+ T.RIGHT := G;\r
+ G.KIND := CONKIND;\r
+ G.RIGHT := E; (* REFERS TO 'BETA' *)\r
+ T := NEW TNODE;\r
+ G.LEFT := T;\r
+ T.KIND := NEGKIND; (* NEGATION *)\r
+ T.LEFT := COPYTNODE ( B ); (* OF 'ALFA' *)\r
+ LAST_Q := LAST_Q+1;\r
+ CALL MOVE ( M,P,P );\r
+END RULEWHL;\r
+\r
+(****************************************************************************)\r
+(* SEARCH FOR A VARIABLE NUMBER I IN FORMULA AND CHANGE IT INTO SUBKIND *)\r
+\r
+UNIT SEARCH_X : PROCEDURE ( A : TNODE , I : INTEGER );\r
+BEGIN\r
+ IF A <> NONE THEN\r
+ IF A.IDENT = I AND A.KIND = VARKIND THEN \r
+ A.KIND := SUBKIND;\r
+ A.IDENT := LAST_S;\r
+ FI;\r
+ CALL SEARCH_X ( A.LEFT , I );\r
+ CALL SEARCH_X ( A.RIGHT , I );\r
+ FI;\r
+END SEARCH_X;\r
+\r
+(*****************************************************************************)\r
+(* BOTH RULES FOR QUANTIFIERS AX-ALFA *)\r
+\r
+UNIT RULEQUAN : PROCEDURE ( M : POINTER , P : INTEGER );\r
+VAR A,C,C1,D,E,F : TNODE;\r
+BEGIN\r
+ IF P=0 THEN (* QUAN ON LEFT SIDE *)\r
+ IF LAST (M,0).NEXT = NONE THEN (* BOTTOM LONGER THAN TOP *)\r
+ LAST (M,0).NEXT := COPYSEQUENT( LAST(M,0) ); (* COPY A QUANTIFIER *)\r
+ CALL ERASE ( LAST(M,0).PLEAF ) (* ERASE UPPER SIDE OF SEQUENT *)\r
+ ELSE (* OTHERWISE *)\r
+ LAST(M,1).NEXT := COPYSEQUENT( LAST(M,0) ); (* COPY A QUANTIFIER *)\r
+ CALL ERASE ( LAST(M,0).PLEAF ); (* ERASE UPPER SIDE OF SEQUENT *)\r
+ FI;\r
+ FI;\r
+ CASE P\r
+ WHEN 1: A := LAST (M,1).PLEAF;\r
+ WHEN 0: A := LAST (M,0).LLEAF;\r
+ ESAC;\r
+ C := A;\r
+ WHILE C.KIND=VARPROG OR C.KIND=BVARPRO\r
+ DO\r
+ C1 := C; (* C1 POINTS TO LAST S *)\r
+ C := C.RIGHT; (* C POINTS TO QUAN *)\r
+ OD;\r
+ D := NEW TNODE; (* NEW SUBSTITUTION *)\r
+ D.KIND := VARPROG; (* S:=... *)\r
+ LAST_S := LAST_S+1; \r
+ D.IDENT := LAST_S;\r
+ F := NEW TNODE; \r
+ D.LEFT := F;\r
+ F.KIND := SUBKIND; (* ...:=Y *)\r
+ IF LAST_X <= LAST_S THEN \r
+ LAST_X := LAST_S + 1\r
+ ELSE \r
+ LAST_X := LAST_X + 1\r
+ FI;\r
+ F.IDENT := LAST_X;\r
+ IF C1 = NONE THEN \r
+ A.RIGHT := D\r
+ ELSE\r
+ C1.RIGHT := D;\r
+ FI;\r
+ D.RIGHT := C.LEFT; (* REFERS TO FORMULA 'ALFA' *)\r
+ CALL SEARCH_X ( C.LEFT , C.IDENT ); (* UPDATE NUMBERS OF BOUND *)\r
+ (* VARIABLE *)\r
+ IF A.KIND = QUAKIND THEN \r
+ A.LEFT := NONE;\r
+ CALL LIFT ( A , 1 , 1 );\r
+ D := A\r
+ ELSE \r
+ KILL ( C )\r
+ FI; (* ERASE QUANTIFIER TNODE *)\r
+ \r
+(* NEXT LINES ARE ONLY CONNECTED WITH THE LEFT SIDE QUANTIFIER *)\r
+\r
+ IF P=0 THEN\r
+ E := NEW TNODE; (* NEW SUBSTITUTION *)\r
+ E.KIND := VARPROG; (* Y:=... *)\r
+ E.IDENT := LAST_X; \r
+ LAST_S := LAST_X; (* UPDATE NUMBER OF LAST *)\r
+ (* SUBSTITUTION *)\r
+ F := NEW TNODE; (* ...:=TERM *)\r
+ E.LEFT := F;\r
+ F.KIND := SIGNTRM; (* JOKER TERM *)\r
+ LAST_D := LAST_D+1;\r
+ F.IDENT := LAST_D;\r
+ E.RIGHT := A; (* REFERS TO SUBSTITUTIONS *)\r
+ LAST ( M , 0 ).LLEAF := E;\r
+ CALL MOVE ( M , P , P ); (* MOVES THE LAST SEQUENT *)\r
+ (* WITHOUT QUANTIFIER *) \r
+ CALL SWEEP ( M.NEXT.LLEAF );\r
+ FI;\r
+ CALL MOVE ( M , P , P ); (* MOVES SEQUENT *)\r
+ (* WITH QUANTIFIER *)\r
+END RULEQUAN;\r
+\r
+(***************************************************************************)\r
+(* HELP FOR RULEITE - MAKE COPY AND INSERT IT DOWN TO CURRENT POINTER M *)\r
+\r
+UNIT K_MN_K_DOWN : PROCEDURE ( M : POINTER, E : TNODE );\r
+VAR M2 : POINTER, \r
+ A1 : SEQUENT;\r
+BEGIN\r
+ M2 := NEW POINTER;\r
+ M2.NEXT := COPYSEQUENT ( M.NEXT );\r
+ M2.DOWN := M.DOWN;\r
+ M.DOWN := M2;\r
+ A1 := LAST ( M2 , 0 );\r
+ CALL ERASE ( A1.LLEAF );\r
+ A1.LLEAF := COPYTNODE ( E ); \r
+ CALL SWEEP ( A1.LLEAF );\r
+ CALL SQUEEZE ( M2 , 0 );\r
+ CALL MOVE ( M2 , 0 , 0 )\r
+END K_MN_K_DOWN;\r
+ \r
+(***************************************************************************)\r
+(* ITERATIONAL QUANTIFIER CONNECTED WITH WHILE *)\r
+\r
+UNIT RULEITE : PROCEDURE ( INOUT M : POINTER , LOGIC : BOOLEAN );\r
+(* K_MN_K MEANS k IN Mn(k) *)\r
+\r
+VAR A,B,C,D,E:TNODE,\r
+ M2,M3:POINTER,\r
+ A1,B2,F:SEQUENT,\r
+ I:INTEGER;\r
+\r
+BEGIN\r
+ C := COPYTNODE ( LAST ( M , 0 ).LLEAF );\r
+ E := C; (* E HOLDS BEGINNING OF Mn(0) *)\r
+ WHILE C.KIND <> ITEKIND\r
+ DO (* MAKE THE SAME IN FAKE TREE *)\r
+ D := C;\r
+ C := C.RIGHT;\r
+ OD; (* C POINTS TO ITERATION *)\r
+ A := COPYTNODE ( E ); \r
+ CALL LIFT ( C , 1 , 1); (* EXPELL ITERATION QUANTIFIER *)\r
+ IF NOT LOGIC THEN\r
+ B := A;\r
+ WHILE B .KIND <> ITEKIND \r
+ DO \r
+ B := B.RIGHT;\r
+ OD;\r
+ CALL LIFT ( B, 1, 1 ); (* EXPELL ITERATION QUANTIFIER *)\r
+ CALL ERASE ( B.LEFT );\r
+ CALL LIFT ( B, 1, 1 ); \r
+ WHILE B.KIND <> CONKIND\r
+ DO (* GO DOWN UNTIL C CONTAINS CONJUNCTION *) \r
+ B := B.RIGHT;\r
+ OD;\r
+ M2 := NEW POINTER; (* CREATES NEW BRANCH *)\r
+ M2.NEXT := COPYSEQUENT ( M.NEXT );\r
+ M2.DOWN := M.DOWN;\r
+ M.DOWN := M2;\r
+ F := LAST ( M2 , 0 );\r
+ CALL ERASE ( F.LLEAF );\r
+ F.LLEAF := A;\r
+ CALL SWEEP ( F.LLEAF );\r
+ CALL SQUEEZE ( M2 , 0 );\r
+ FI;\r
+ IF NOT LOGIC OR K_MN_K=1 THEN (* CONSTRUCT Mn(1) *)\r
+ M2 := NEW POINTER; (* AND INSERT IT INTO *)\r
+ M2.NEXT := COPYSEQUENT ( M.NEXT ); (* THE SEQUENT *)\r
+ F := LAST ( M2 , 0 );\r
+ CALL ERASE ( F.LLEAF );\r
+ F.LLEAF := COPYTNODE ( E );\r
+ M2.DOWN := M.DOWN;\r
+ M.DOWN := M2;\r
+ CALL SWEEP ( F.LLEAF );\r
+ CALL SQUEEZE ( M2 , 0 );\r
+ FI;\r
+ FOR I := 0 TO K_MN_K-2\r
+ DO \r
+ (* CREATE kMn(K_MN_K)ALFA *)\r
+ B := C; (* B POINTS TO BEGIN-END PROGRAM AFTER 'U' *) \r
+ WHILE B.KIND <> CONKIND\r
+ DO (* GOES DOWN UNTIL B CONTAINS CONJUNCTION *) \r
+ A := B;\r
+ B := B.RIGHT;\r
+ OD; (* B POINTS TO CONJUNCTION, A PRECEED B *) \r
+ D := COPYTNODE ( C ); (* D CONTAINS ONLY ONE PROGRAM K *)\r
+ (* AND CONJUCTION AS WELL *) \r
+ CALL ERASE ( A.RIGHT );\r
+ A.RIGHT := D;\r
+ C := D;\r
+ IF NOT LOGIC THEN (* LOGIC=TRUE MEANS THAT WHILE HAS *)\r
+ CALL K_MN_K_DOWN ( M, E ); (* ALREADY BEEN USED *)\r
+ FI;\r
+ \r
+ OD;\r
+ IF LOGIC AND K_MN_K > 1 THEN (* INSERT Mn(K) INTO *)\r
+ CALL K_MN_K_DOWN ( M, E );\r
+ FI;\r
+ K_MN_K:=K_MN_K+1;\r
+ (* PREPARE THREE NEW FORMULAS TO PROVE FOR 'WHILE' *)\r
+ FOR I := 1 TO 3\r
+ DO\r
+ M3 := NEW POINTER;\r
+ SQNT := COPYSEQUENT ( LAST ( M.DOWN , 0 ) );\r
+ CALL ERASE_SEQ ( SQNT.NEXT );\r
+ CALL ERASE ( SQNT.PLEAF );\r
+ A := SQNT.LLEAF;\r
+ WHILE A.KIND <> CONKIND\r
+ DO\r
+ A := A.RIGHT;\r
+ OD;\r
+ CASE I\r
+ WHEN 1 : CALL ERASE ( A.RIGHT );\r
+ CALL LIFT ( A , 1 , 0 ); (* M(l) p *)\r
+ WHEN 2 : CALL ERASE ( A.LEFT ); (* M(l) NOT ALFA *)\r
+ CALL LIFT ( A , 1 , 1 );\r
+ CALL ERASE ( A.RIGHT );\r
+ CALL LIFT ( A , 1 , 0 );\r
+ WHEN 3 : CALL ERASE ( A.LEFT ); (* M(l) BETA *)\r
+ CALL LIFT ( A , 1 , 1 );\r
+ CALL ERASE ( A.LEFT );\r
+ CALL LIFT ( A , 1 , 1 );\r
+ ESAC; \r
+ M3.NEXT := SQNT;\r
+ CHI := TRUE; \r
+ DIF := 1; (* VARIABLE DIF MEANS THAT *)\r
+ (* PROVE PROCEDURE WAS CALLED *)\r
+ (* FROM WHILE *) \r
+ CALL PROVE ( M3 , DIF ); (* PROOF FOR M(l)p, *)\r
+ (* M(l)NOT ALFA, *)\r
+ (* AND M(l)BETA *)\r
+ CALL ERASE_PNTR ( M3 ); \r
+ (* IF ONE CAN PROVE CURRENT *)\r
+ (* SEQUENT E.G. Mn(l)p |- GENERATED *)\r
+ (* BY 'WHILE ' CHI IS NOT CHANGED *)\r
+ (* OTHERWISE CHI := FALSE IN PROVE *)\r
+ IF CHI THEN EXIT FI; (* FINISHED PROOF BY M(l)p *)\r
+ (* OR M(l)NOT ALFA *)\r
+ (* OR BY M(l)BETA *) \r
+ OD;\r
+ IF CHI THEN\r
+ CALL ERASE_SEQ ( M.NEXT );\r
+ CALL LIFT_PNTR ( M );\r
+ CALL ERASE_SEQ ( M.NEXT );\r
+ CALL LIFT_PNTR ( M );\r
+ FI;\r
+END RULEITE;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR ITERATION QUANTIFIERS *)\r
+\r
+UNIT RULE_EX_GEN:PROCEDURE(INOUT M:POINTER;P,K_MN_K:INTEGER,C:TNODE,LOGIC:BOOLEAN);\r
+VAR I : INTEGER,\r
+ A,B,C2,D : TNODE,\r
+ A2 : SEQUENT,\r
+ M3,M2 : POINTER;\r
+BEGIN\r
+ IF C.RIGHT.KIND = BEGKIND ANDIF C.RIGHT.LEFT <> NONE ANDIF\r
+ C.RIGHT.LEFT.LEFT <> NONE ANDIF C.RIGHT.LEFT.LEFT.IDENT < 0 THEN\r
+ CALL RULEITE ( M , LOGIC ); (* WHILE - ITERATION *)\r
+ LOGIC := TRUE;\r
+ RETURN;\r
+ FI;\r
+ A2 := COPYSEQUENT ( M.NEXT ); \r
+ M2 := NEW POINTER; (* CREATE NEW BRANCH *)\r
+ M2.NEXT := A2;\r
+ CASE P\r
+ WHEN 0: A := LAST (M2,0).LLEAF;\r
+ WHEN 1: A := LAST (M2,1).PLEAF;\r
+ ESAC; \r
+ IF C.IDENT = 0 THEN (* THE FIRST STEP OF ITERATION *)\r
+ CALL END_OF_S ( A,B );\r
+ CALL LIFT ( A, 1, 1 ); (* REMOVE ITERATION SIGN *)\r
+ I := A.KIND;\r
+ CALL ERASE ( A.LEFT );\r
+ CALL LIFT ( A, 1, 1 ); (* REMOVE SUBSTITUTION OR *)\r
+ (* BEGINNING OF ANOTHER PROGRAM *)\r
+ IF I <> VARPROG AND I <> BVARPRO THEN\r
+ CASE A.KIND\r
+ WHEN WHIKIND : CALL ERASE ( A.LEFT );\r
+ CALL LIFT ( A,1,1 );\r
+ WHEN IFFKIND : CALL ERASE ( A.LEFT );\r
+ CALL LIFT ( A,1,1 );\r
+ CALL ERASE ( A.LEFT );\r
+ CALL LIFT ( A,1,1 );\r
+ ESAC;\r
+ FI;\r
+ C.IDENT := 1;\r
+ ELSE (* NEXT STEPS OF ITERATION *)\r
+ WHILE A.KIND=VARPROG OR A.KIND=BVARPRO (* OMITS SUBSTITUTION *)\r
+ DO\r
+ D := A; \r
+ A := A.RIGHT;\r
+ OD;\r
+ A := A.RIGHT; (* A REFERS TO PROGRAM 'K' *)\r
+ IF A.KIND=VARPROG OR A.KIND=BVARPRO THEN (* CONSISTING OF SUBSTITUTION *)\r
+ C2 := COPYTNODE ( A );\r
+ CALL ERASE ( A.RIGHT );\r
+ A.RIGHT := C2\r
+ ELSE (* OR ANOTHER PROGRAM *)\r
+ D := A;\r
+ WHILE A.IDENT<>ENDKIND AND A.IDENT<>ODFKIND AND A.IDENT<>FIFKIND\r
+ DO\r
+ A := A.RIGHT;\r
+ OD; (* A OMITS PROGRAM 'K' *)\r
+ C2 := COPYTNODE ( D );\r
+ CALL ERASE ( A.RIGHT );\r
+ A.RIGHT := C2;\r
+ FI;\r
+ FI; \r
+ M3 := M2; (* ITERATION PUSHED TO *)\r
+ M2 := M; (* THE END OF A TREE *)\r
+ M := M3;\r
+ M.DOWN := M2;\r
+ CALL MOVE ( M , P , P );\r
+END RULE_EX_GEN;\r
+\r
+(****************************************************************************)\r
+(* EXISTENTIAL ITERATION QUANTIFIER *)\r
+\r
+UNIT RULEEXIST : PROCEDURE ( M : POINTER, C : TNODE, P : INTEGER );\r
+VAR B,D,E : TNODE,\r
+ A : SEQUENT;\r
+BEGIN\r
+ B := C;\r
+ E := COPYTNODE ( C.RIGHT );\r
+ IF B.RIGHT.KIND=VARPROG OR B.RIGHT.KIND=BVARPRO THEN\r
+ D := B.RIGHT.RIGHT;\r
+ B.RIGHT.RIGHT := E\r
+ ELSE\r
+ WHILE B.IDENT<>FIFKIND AND B.IDENT<>ODFKIND AND B.IDENT<>ENDKIND\r
+ DO\r
+ B := B.RIGHT;\r
+ OD;\r
+ D := B.RIGHT;\r
+ B.RIGHT := E;\r
+ FI;\r
+ CASE P\r
+ WHEN 0 : IF LAST (M,0).NEXT = NONE THEN\r
+ LAST (M,0).NEXT := COPYSEQUENT ( LAST(M,P) )\r
+ ELSE \r
+ LAST (M,1).NEXT := COPYSEQUENT ( LAST(M,P) )\r
+ FI;\r
+ E := FINDCONN ( LAST(M,0) , IGQKIND , 0 );\r
+ CALL ERASE ( LAST(M,0).PLEAF );\r
+ WHEN 1 : IF LAST (M,1).NEXT = NONE THEN\r
+ LAST (M,1).NEXT := COPYSEQUENT ( LAST(M,P) )\r
+ ELSE \r
+ LAST (M,0).NEXT := COPYSEQUENT ( LAST(M,P) )\r
+ FI;\r
+ E := FINDCONN ( LAST(M,1) , ITEKIND , 1 );\r
+ CALL ERASE ( LAST(M,1).LLEAF );\r
+ ESAC;\r
+ CALL ERASE ( E.RIGHT );\r
+ E.RIGHT := D;\r
+ CALL LIFT ( E , 1 , 1 );\r
+ CASE P\r
+ WHEN 0: CALL MOVE ( M , 0 , 0 );\r
+ CALL SWEEP ( M.NEXT.LLEAF );\r
+ CALL MOVE ( M , 0 , 0 );\r
+ WHEN 1: CALL MOVE ( M , 1 , 1 );\r
+ CALL SWEEP ( M.NEXT.PLEAF ); \r
+ CALL MOVE ( M , 1 , 1 );\r
+ ESAC;\r
+END RULEEXIST;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR IF-ALFA-THEN-K-ELSE-M-FI-BETA OR WITHOUT 'ELSE' PROGRAM *)\r
+\r
+UNIT RULEIF : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+VAR B,D,E,G,H,K : TNODE;\r
+BEGIN\r
+ B := C.LEFT; (* HOLD 'ALFA' *)\r
+ C.LEFT := NONE;\r
+ D := C.RIGHT.RIGHT.RIGHT; (* HOLD BETA *)\r
+ C.RIGHT.RIGHT.RIGHT := NONE;\r
+ IF C.RIGHT.RIGHT.KIND <> ELSKIND THEN (* WITHOUT 'ELSE' *)\r
+ C.LEFT := B; (* REFERS TO 'ALFA' *)\r
+ C.KIND := CONKIND;\r
+ C := C.RIGHT;\r
+ CALL LIFT ( C , 1 , 0 ); (* THROW 'THNKIND' *)\r
+ CALL END_OF_PRG ( C ); (* GO TO THE END OF 'K' *)\r
+ C.RIGHT := D (* REFERS TO 'BETA' *)\r
+ ELSE (* WITH 'ELSE' *)\r
+ C.KIND := DISKIND; \r
+ G := NEW TNODE;\r
+ G.KIND := CONKIND;\r
+ C.LEFT := G;\r
+ G.LEFT := B; (* REFERS TO 'ALFA' *)\r
+ K := C.RIGHT.RIGHT.LEFT; (* HOLD PROGRAM 'M' *)\r
+ E := C.RIGHT;\r
+ KILL ( E.RIGHT );\r
+ CALL LIFT ( E , 1 , 0 ); (* THROW 'THNKIND' *)\r
+ G.RIGHT := E;\r
+ CALL END_OF_PRG ( G ); (* GO TO THE END OF 'K' *)\r
+ G.RIGHT := D; (* REFERS TO 'BETA' *)\r
+ H := NEW TNODE; (* 2ND ARG OF DISJUNCTION *)\r
+ C.RIGHT := H;\r
+ H.KIND := CONKIND;\r
+ G := NEW TNODE;\r
+ G.KIND := NEGKIND;\r
+ H.LEFT := G;\r
+ G.LEFT := COPYTNODE ( B ); (* REFERS TO 'ALFA' *)\r
+ H.RIGHT := K;\r
+ CALL END_OF_PRG ( H );\r
+ H.RIGHT := COPYTNODE ( D ); (* REFERS TO 'BETA' *)\r
+ H := C.LEFT; (* CHANGE FORMULA *)\r
+ C.LEFT := C.RIGHT;\r
+ C.RIGHT := H;\r
+ FI;\r
+ CALL MOVE ( M , P , P );\r
+END RULEIF;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR IMPLICATION *)\r
+\r
+UNIT RULEIMP : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+VAR U,V : TNODE,\r
+ D : SEQUENT;\r
+BEGIN\r
+ CASE P\r
+ WHEN 1: D:= NEW SEQUENT; (* |- P => Q CONVERT TO *)\r
+ D.NEXT := M.NEXT; (* P |- Q *)\r
+ M.NEXT := D;\r
+ U := COPYTNODE ( LAST ( M,1 ).PLEAF );\r
+ D.LLEAF := U;\r
+ CALL ERASE ( C.LEFT );\r
+ CALL LIFT ( C , 1 , 1 );\r
+ V := FINDCONN ( D, IMPKIND, 0 );\r
+ CALL ERASE ( V.RIGHT );\r
+ CALL LIFT ( V, 1, 0 );\r
+ CALL MOVE ( M, 1, 1 );\r
+ WHEN 0: C.KIND := DISKIND; (* IMPLICATION CHANGE TO *)\r
+ U := NEW TNODE; (* DISJUNCTION *)\r
+ U.KIND := NEGKIND;\r
+ U.LEFT := C.LEFT;\r
+ C.LEFT := U;\r
+ CALL RULEDIS ( M , C , P );\r
+ ESAC;\r
+END RULEIMP;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR EQUIVALENCE *)\r
+\r
+UNIT RULEEQU : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+VAR T,U,V,W : TNODE;\r
+\r
+BEGIN\r
+ C.KIND := CONKIND;\r
+ U := COPYTNODE ( C.LEFT );\r
+ V := COPYTNODE ( C.RIGHT );\r
+ W := NEW TNODE;\r
+ T := NEW TNODE;\r
+ W.KIND := IMPKIND;\r
+ T.KIND := IMPKIND;\r
+ W.LEFT := V;\r
+ W.RIGHT := U;\r
+ T.LEFT := C.LEFT;\r
+ T.RIGHT := C.RIGHT;\r
+ C.LEFT := W;\r
+ C.RIGHT := T;\r
+ CALL MOVE ( M , P , P );\r
+END RULEEQU;\r
+\r
+(*****************************************************************************)\r
+(* MAKE SERIAL OR PARALLEL SUBSTITUTION ON ATOMS *)\r
+\r
+UNIT SUBAT : PROCEDURE ( M : POINTER , P : INTEGER );\r
+VAR A : SEQUENT,\r
+ B : TNODE;\r
+BEGIN\r
+ A := LAST(M,P);\r
+ IF A=NONE THEN RETURN FI;\r
+ CASE P\r
+ WHEN 1: B := A.PLEAF;\r
+ WHEN 0: B := A.LLEAF;\r
+ ESAC;\r
+ IF B = NONE THEN RETURN FI;\r
+ IF B.KIND = BEGKIND AND B.LEFT.IDENT <> 1 THEN RETURN FI;\r
+ IF B.KIND = BEGKIND AND B.LEFT.IDENT = 1 AND (B.RIGHT.KIND = LITKIND \r
+ OR B.RIGHT.KIND = EQUKIND ) THEN CALL BEG_SUB ( B ); RETURN FI;\r
+ IF B.KIND = BEGKIND AND B.LEFT.IDENT = 1 AND (B.RIGHT.KIND = BVARPRO\r
+ OR B.RIGHT.KIND = VARPROG ) THEN CALL SER_INSERT ( B.RIGHT );RETURN \r
+ FI;\r
+ CALL SER_INSERT ( B );\r
+END SUBAT;\r
+\r
+(*****************************************************************************)\r
+(* DO SERIAL SUBSTITUTITON *)\r
+\r
+UNIT SER_INSERT : PROCEDURE ( A : TNODE );\r
+VAR B : TNODE;\r
+BEGIN\r
+ CALL END_OF_S ( A, B ); (* GO TO LAST SUBSTITUTION *)\r
+ IF B.RIGHT.KIND = BVAKIND THEN \r
+ CALL SERIAL_Q ( B, B.RIGHT ) (* MAKE SERIAL SUBSTITUION *)\r
+ (* FOR LOGICAL VARIABLES *)\r
+ ELSE \r
+ CALL SERIAL_SUB ( B, B.RIGHT ); (* MAKE SERIAL SUBSTITUTION *)\r
+ FI; (* FOR LITERALS OR EQUALITIES *)\r
+ CALL ERASE ( B.LEFT ); (* REMOVE TAU *)\r
+ CALL LIFT ( B, 1, 1 ); (* REMOVE SUBSTITUTION *)\r
+END SER_INSERT;\r
+ \r
+(*****************************************************************************)\r
+(* DO SERIAL SUBSTITUTION FOR ON LOGICAL VARIABLES - BVAKINS'S *)\r
+\r
+UNIT SERIAL_Q : PROCEDURE ( C, D : TNODE );\r
+BEGIN\r
+ IF D = NONE THEN RETURN FI;\r
+ IF D.IDENT = C.IDENT THEN\r
+ D.LEFT := COPYTNODE ( C.LEFT ); (* COPY TAU *)\r
+ CALL LIFT ( D , 1 , 0 ); (* REMOVE S *)\r
+ FI;\r
+END SERIAL_Q;\r
+\r
+(*****************************************************************************)\r
+(* CALLED BY SER_INSERT *)\r
+\r
+UNIT SERIAL_SUB : PROCEDURE ( C,D : TNODE );\r
+VAR E : TNODE;\r
+BEGIN\r
+ IF D = NONE THEN RETURN FI;\r
+ IF ( D.KIND = SUBKIND OR D.KIND = BVAKIND ) AND D.IDENT = C.IDENT THEN\r
+ E := D.RIGHT; (* STORE TEMPORARILY NEXT ARG *)\r
+ D.LEFT := COPYTNODE ( C.LEFT ); (* COPY TAU *)\r
+ CALL LIFT ( D , 1 , 0 ); (* REMOVE S *)\r
+ D.RIGHT := E; (* LINK NEXT ARG *)\r
+ CALL SERIAL_SUB ( C , D.RIGHT ); (* SEARCH FOR NEXT SUBKIND *)\r
+ RETURN;\r
+ FI;\r
+ CALL SERIAL_SUB ( C , D.LEFT ); \r
+ CALL SERIAL_SUB ( C , D.RIGHT );\r
+END SERIAL_SUB;\r
+\r
+(****************************************************************************)\r
+(* MOVES ALL ATOMS FROM THE END TO THE BEGINNING *)\r
+\r
+UNIT RULEAT : PROCEDURE ( M : POINTER , P : INTEGER ; INOUT BET : BOOLEAN );\r
+VAR A , B : SEQUENT;\r
+BEGIN\r
+ IF M=NONE ORIF M.NEXT=NONE THEN RETURN FI;\r
+ A := M.NEXT;\r
+ CASE P\r
+ WHEN 0 : WHILE A <> NONE\r
+ DO\r
+ IF A.LLEAF <> NONE THEN \r
+ IF A.LLEAF.KIND <> LITKIND AND A.LLEAF.KIND <> EQUKIND \r
+ AND A.LLEAF.KIND <> LOGKIND AND\r
+ A.LLEAF.KIND <> BVAKIND THEN \r
+ B := A \r
+ FI;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+ WHEN 1 : WHILE A <> NONE \r
+ DO\r
+ IF A.PLEAF <> NONE THEN\r
+ IF A.PLEAF.KIND <> LITKIND AND A.PLEAF.KIND <> EQUKIND \r
+ AND A.PLEAF.KIND <> LOGKIND AND \r
+ A.PLEAF.KIND <> BVAKIND THEN \r
+ B := A \r
+ FI;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+ ESAC;\r
+ IF B = NONE THEN RETURN FI;\r
+ WHILE B <> LAST ( M , P )\r
+ DO\r
+ CALL MOVE ( M , P , P );\r
+ OD;\r
+ BET := TRUE;\r
+END RULEAT;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR NEGATION *)\r
+\r
+UNIT RULENEG : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+BEGIN\r
+ CALL LIFT ( C , 1 , 0 );\r
+ CALL MOVE ( M , P , 1 - P );\r
+END RULENEG;\r
+\r
+(****************************************************************************)\r
+(* DIVIDE A SEQUENT INTO TWO PIECES AND DEPENDING ON 'S' RE-CONSTRUCT A LIST:\r
+S=1-ONE LIST; S=0-TWO LISTS *)\r
+\r
+UNIT BRANCH : PROCEDURE ( M : POINTER , P , R , S : INTEGER , C : TNODE );\r
+VAR M2 : POINTER,\r
+ A,B,D : SEQUENT,\r
+ E,F,E1,F1 : TNODE;\r
+BEGIN\r
+ D := NEW SEQUENT;\r
+ B := NEW SEQUENT;\r
+ E := COPYTNODE( C.LEFT );\r
+ F := COPYTNODE( C.RIGHT );\r
+ A := LAST ( M , P );\r
+ CALL ERASE ( C );\r
+ CASE P\r
+ WHEN 0 : D.LLEAF := COPYTNODE ( A.LLEAF );\r
+ B.LLEAF := COPYTNODE ( A.LLEAF );\r
+ E1 := B.LLEAF;\r
+ CALL END_OF_PRG ( E1 );\r
+ IF E1 <> NONE THEN\r
+ E1.RIGHT := E\r
+ ELSE\r
+ B.LLEAF := E;\r
+ FI;\r
+ E1 := D.LLEAF;\r
+ CALL END_OF_PRG ( E1 );\r
+ IF E1 <> NONE THEN \r
+ E1.RIGHT := F\r
+ ELSE \r
+ D.LLEAF := F;\r
+ FI;\r
+ CALL ERASE ( A.LLEAF );\r
+ WHEN 1 : D.PLEAF := COPYTNODE ( A.PLEAF );\r
+ B.PLEAF := COPYTNODE ( A.PLEAF );\r
+ E1 := B.PLEAF;\r
+ CALL END_OF_PRG ( E1 );\r
+ IF E1 <> NONE THEN\r
+ E1.RIGHT := E\r
+ ELSE\r
+ B.PLEAF := E;\r
+ FI;\r
+ E1 := D.PLEAF;\r
+ CALL END_OF_PRG ( E1 );\r
+ IF E1 <> NONE THEN \r
+ E1.RIGHT := F\r
+ ELSE \r
+ D.PLEAF := F;\r
+ FI;\r
+ CALL ERASE ( A.PLEAF );\r
+ ESAC;\r
+ CASE S\r
+ WHEN 0: D.NEXT := M.NEXT;\r
+ M2 := NEW POINTER;\r
+ M2.DOWN := M.DOWN;\r
+ M.DOWN := M2;\r
+ M2.NEXT := B;\r
+ M.NEXT := D;\r
+ B.NEXT := COPYSEQUENT ( D.NEXT );\r
+ WHEN 1: B.NEXT := M.NEXT;\r
+ D.NEXT := B;\r
+ M.NEXT := D;\r
+ ESAC;\r
+END BRANCH;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR CONJUNCTION *)\r
+\r
+UNIT RULECON : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+BEGIN\r
+ CALL BRANCH ( M,P,4,1-P,C );\r
+ CASE P\r
+ WHEN 1 : CALL SWEEP ( M.DOWN.NEXT.PLEAF );\r
+ WHEN 0 : CALL SWEEP ( M.NEXT.NEXT.PLEAF );\r
+ ESAC;\r
+END RULECON;\r
+\r
+(****************************************************************************)\r
+(* RULE FOR DISJUNCTION *)\r
+\r
+UNIT RULEDIS : PROCEDURE ( M : POINTER , C : TNODE , P : INTEGER );\r
+BEGIN\r
+ CALL BRANCH ( M , P , 5 , P , C );\r
+ CASE P\r
+ WHEN 0 : CALL SWEEP ( M.DOWN.NEXT.PLEAF );\r
+ WHEN 1 : CALL SWEEP ( M.NEXT.NEXT.PLEAF );\r
+ ESAC;\r
+END RULEDIS;\r
+\r
+(*****************************************************************************)\r
+\r
+\r
+(*****************************************************************************)\r
+(* MAIN BODY OF THIS PROVER *)\r
+(*****************************************************************************)\r
+\r
+(*****************************************************************************)\r
+(* PROVE AND RETRIEVE AXIOMS OF ALL INPUT FORMULAS *)\r
+\r
+UNIT PROVE : PROCEDURE ( INOUT M : POINTER; DIF : INTEGER );\r
+VAR BETA : BOOLEAN;\r
+BEGIN\r
+ CALL SWEEP ( M.NEXT.PLEAF );\r
+ CALL THROW_RUBBISH ( M );\r
+ WHILE M <> NONE\r
+ DO\r
+ ALFA := FALSE;\r
+ BETA := FALSE;\r
+ WHILE CHECK_L_F_P ( M.NEXT )\r
+ DO\r
+ WRITELN("DR");\r
+ CALL SHOW_SEQ ( M.NEXT );\r
+ CALL PROVE_P ( M , 1 );\r
+ CALL MAKE_ORDER ( M );\r
+ CALL PROVE_P ( M , 0 );\r
+ CALL MAKE_ORDER ( M );\r
+ IF AX <> NONE THEN\r
+ IF SEARCH_AXIOMS ( M ) THEN \r
+ CALL ERASE_SEQ ( M.NEXT );\r
+ BETA := TRUE; (* FOUND AXIOM *)\r
+ EXIT \r
+ FI;\r
+ FI;\r
+ ALFA := FALSE;\r
+ OD; \r
+ write("*");\r
+ WRITELN("SEQ");\r
+ CALL SHOW_SEQ ( M.NEXT );\r
+ IF AX = NONE THEN\r
+ IF SEARCH_AXIOMS ( M ) THEN\r
+ CALL ERASE_SEQ ( M.NEXT );\r
+ BETA := TRUE;\r
+ FI;\r
+ FI;\r
+ IF AX <> NONE THEN \r
+ WRITELN( "AX");\r
+ CALL SHOW_TREE ( AX.AXIOM );\r
+ WRITELN("KONIEC");\r
+ FI;\r
+ IF BETA ORIF M.NEXT=NONE ORIF SEARCH_AXIOMS ( M ) THEN\r
+ CALL LIFT_PNTR ( M );\r
+ BETA := FALSE\r
+ ELSE\r
+ IF DIF<>1 THEN \r
+ WRITE("THERE IS NO MODEL TO PROVE THIS EQUIVALENCE");\r
+ RAISE ENDRUN\r
+ ELSE \r
+ CHI:=FALSE;\r
+ RETURN \r
+ FI; \r
+ FI;\r
+ OD;\r
+ IF AX = NONE THEN WRITELN ( " THE FORMULA IS A THEOREM "); FI;\r
+END PROVE;\r
+\r
+(*****************************************************************************)\r
+(* DO THE RULES FOR P - SIDE UNTIL IT HAS NO USE *)\r
+ \r
+UNIT PROVE_P : PROCEDURE ( INOUT M : POINTER; P : INTEGER );\r
+VAR R,I : INTEGER,\r
+ A : TNODE,\r
+ BET : BOOLEAN;\r
+BEGIN\r
+ R := 0;\r
+ IF LAST ( M , P ) <> NONE THEN\r
+ FOR I := 3 TO 13 \r
+ DO\r
+ IF FINDCONN ( LAST ( M , P ) , I , P ) <> NONE THEN\r
+ R := I;\r
+ EXIT\r
+ FI;\r
+ OD;\r
+ IF R <> 0 THEN\r
+ CALL RULES ( M, P, R )\r
+ ELSE \r
+ CASE P\r
+ WHEN 0 : A := LAST ( M, P ).LLEAF;\r
+ WHEN 1 : A := LAST ( M, P ).PLEAF;\r
+ ESAC;\r
+ IF A.KIND = BEGKIND ANDIF A.LEFT.KIND = SEMKIND ANDIF\r
+ A.LEFT.IDENT = 1 THEN\r
+ IF A.RIGHT.KIND <> VARPROG AND A.RIGHT.KIND <> BVARPRO THEN\r
+ CASE P\r
+ WHEN 1 : CALL RULEBEG ( M, A , P );\r
+ WHEN 0 : CALL RULEBEG ( M, A , P );\r
+ ESAC;\r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ IF A.RIGHT <> NONE THEN\r
+ IF A.KIND = VARPROG ORIF A.KIND = BVARPRO ORIF A.RIGHT.KIND = VARPROG\r
+ ORIF A.RIGHT.KIND = BVARPRO THEN\r
+ CALL SUBAT ( M, P );\r
+ CASE P \r
+ WHEN 0 : CALL SWEEP ( LAST ( M, P ).LLEAF );\r
+ WHEN 1 : CALL SWEEP ( LAST ( M, P ).PLEAF );\r
+ ESAC;\r
+ CALL MOVE ( M, P, P );\r
+ FI;\r
+ FI;\r
+ BET := FALSE;\r
+ CALL RULEAT ( M, P, BET );\r
+ IF NOT BET AND DEF_LIT = 1 THEN\r
+ M1 := M1.NEXT;\r
+ CASE M1.FUN_REL.KIND\r
+ WHEN LITKIND : CALL RULEDF_L ( M, P, M1.FUN_REL.IDENT );\r
+ WHEN EQUKIND : CALL RULEDF_F ( M, P, M1.FUN_REL.LEFT.IDENT );\r
+ ESAC;\r
+ FI;\r
+ FI;\r
+ FI;\r
+END PROVE_P;\r
+\r
+(*****************************************************************************)\r
+(* DO ORDER PROCEDURES IN WHOLE SEQUENT *)\r
+\r
+UNIT MAKE_ORDER : PROCEDURE ( M : POINTER );\r
+BEGIN\r
+ IF M = NONE ORIF M.NEXT = NONE THEN RETURN FI;\r
+ CALL SQUEEZE ( M, 0 ); (* REMOVE HOLES *)\r
+ CALL SQUEEZE ( M, 1 ); \r
+ CALL SWEEP ( M.NEXT.PLEAF ); (* MAKE SIMPLE OPERATION *)\r
+ CALL SWEEP ( M.NEXT.LLEAF );\r
+ CALL CLAS_AX ( M ); (* SEARCH CLASSICAL AXIOMS *)\r
+ CALL THROW_RUBBISH ( M ); (* REMOVE SEQUENT CONTAINING *)\r
+ (* LOGICAL CONSTANTS *)\r
+ IF M.NEXT <> NONE THEN CALL CUT_SEQ ( M.NEXT ) FI;\r
+ (* REMOVE EMPTY FORMULAS *)\r
+END MAKE_ORDER;\r
+\r
+(*****************************************************************************)\r
+(* SEARCH EXTRA AXIOMS *)\r
+\r
+UNIT SEARCH_AXIOMS : FUNCTION ( INOUT M : POINTER ) : BOOLEAN;\r
+BEGIN\r
+ IF SEARCH_CN1 ( M.NEXT ) THEN \r
+ CALL END_OF_M ( M, M.NEXT );\r
+ RETURN;\r
+ FI;\r
+ IF LOOK_NQ ( M, 0 ) OR LOOK_NQ ( M, 1 ) OR LOOK_IDE ( M.NEXT ) THEN\r
+ RESULT := TRUE;\r
+ CALL ERASE_SEQ ( M.NEXT );\r
+ FI;\r
+END SEARCH_AXIOMS;\r
+\r
+(****************************************************************************)\r
+(* SEARCH FOR FALSE CONSTANTS IN WHOLE SEQUENT *)\r
+\r
+UNIT SEARCH_CN1 : FUNCTION ( A : SEQUENT ) : BOOLEAN;\r
+VAR ALFA : BOOLEAN;\r
+BEGIN\r
+ WHILE A <> NONE \r
+ DO\r
+ CALL FUNCHECK ( A.PLEAF, ALFA );\r
+ CALL FUNCHECK ( A.LLEAF, ALFA );\r
+ IF ALFA THEN \r
+ RESULT := TRUE;\r
+ RETURN;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+END SEARCH_CN1;\r
+ \r
+(****************************************************************************)\r
+(* SEARCH CLASSICAL AXIOMS *)\r
+\r
+UNIT CLAS_AX : PROCEDURE ( M : POINTER );\r
+VAR A, A1 : SEQUENT,\r
+ AX1 : LIST_AXIOMS,\r
+ ALFA : BOOLEAN;\r
+BEGIN\r
+ IF M.NEXT=NONE THEN RETURN FI;\r
+ A := M.NEXT;\r
+ WHILE A <> NONE\r
+ DO (* SEARCH FOR THE IDENTICAL *)\r
+ A1 := M.NEXT;\r
+ IF A.PLEAF <> NONE THEN (* FORMULAS IN A SEQUENT *)\r
+ WHILE A1 <> NONE \r
+ DO (* ON BOTH SIDES *)\r
+ IF A1.LLEAF <> NONE THEN (* I.E. ...beta...|-...beta... *)\r
+ ALFA := TRUE;\r
+ CALL COMPARE ( A.PLEAF, A1.LLEAF, ALFA);\r
+ IF ALFA THEN\r
+ CALL ERASE_SEQ ( M.NEXT ); (* WHEN FOUND - ERASE SEQUENT *)\r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ A1 := A1.NEXT;\r
+ OD;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+ A := M.NEXT;\r
+ WHILE A <> NONE\r
+ DO\r
+ A1 := M.NEXT;\r
+ IF A.PLEAF <> NONE THEN\r
+ WHILE A1 <> NONE\r
+ DO\r
+ IF A1.LLEAF <> NONE THEN\r
+ IF A.PLEAF.KIND = LITKIND OR A.PLEAF.KIND = EQUKIND THEN\r
+ IF A.PLEAF.KIND=A1.LLEAF.KIND AND A.PLEAF.IDENT=A1.LLEAF.IDENT\r
+ THEN\r
+ IF SYL_AXIOMS ( M , A1.LLEAF.LEFT , A.PLEAF.LEFT ) THEN\r
+ CALL ERASE_SEQ ( M.NEXT );\r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ A1 := A1.NEXT;\r
+ OD;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+END CLAS_AX;\r
+\r
+(****************************************************************************)\r
+(* LOOK FOR AXIOM OF THE FORM Xi=Yi and P(X1,...,Xn) |- P(Y1,...,Yn) *)\r
+\r
+UNIT SYL_AXIOMS : FUNCTION ( M : POINTER, E, F : TNODE ) : BOOLEAN;\r
+VAR A : SEQUENT,\r
+ B, C, D : TNODE,\r
+ BETA, ALFA : BOOLEAN;\r
+BEGIN\r
+ WHILE E<>NONE AND F<>NONE\r
+ DO\r
+ B := COPYTNODE ( E );\r
+ C := COPYTNODE ( F );\r
+ CALL ERASE ( C.RIGHT );\r
+ CALL ERASE ( B.RIGHT );\r
+ B.RIGHT := C; (* CREATE PAIR Xi->Yi *)\r
+ A := M.NEXT;\r
+ WHILE A<>NONE \r
+ DO \r
+ IF A.LLEAF<>NONE ANDIF A.LLEAF.KIND=EQUKIND THEN\r
+ D := A.LLEAF.LEFT;\r
+ ALFA := TRUE;\r
+ CALL COMPARE ( D, B, ALFA ); (* SEARCH FOR RESPECTIVE PAIR *)\r
+ IF ALFA THEN\r
+ BETA := TRUE;\r
+ EXIT;\r
+ FI;\r
+ FI;\r
+ A := A.NEXT;\r
+ OD;\r
+ CALL ERASE ( B );\r
+ IF NOT BETA THEN RETURN FI; (* IF NOT FOUND THEN RESULT := FALSE *)\r
+ E := E.RIGHT; (* SEARCH FURTHER *)\r
+ F := F.RIGHT; (* FOR NEXT PAIR *)\r
+ OD;\r
+ RESULT := TRUE;\r
+END SYL_AXIOMS;\r
+\r
+(****************************************************************************)\r
+(* LOOKING FOR NQ OR Q AXIOM *)\r
+\r
+UNIT LOOK_NQ : FUNCTION ( M : POINTER, P : INTEGER ) : BOOLEAN;\r
+VAR A : SEQUENT,\r
+ AX2 : LIST_AXIOMS,\r
+ C : TNODE ;\r
+BEGIN\r
+ A := M.NEXT;\r
+ WHILE A <> NONE\r
+ DO (* VIEW WHOLE SEQUENT *)\r
+ (* LOOKING FOR Q *)\r
+ CASE P \r
+ WHEN 0 : IF A.LLEAF <> NONE THEN\r
+ IF A.LLEAF.KIND = BVAKIND THEN (* FOUND Q ON LEFT SIDE *)\r
+ IF SRCH_Q_AX ( A.LLEAF.IDENT, AX2 ) THEN \r
+ IF AX2.AXIOM.KIND = NEGKIND THEN\r
+ RESULT := TRUE;\r
+ RETURN\r
+ ELSE\r
+ RESULT := FALSE (* FOUND NEGATION OF EXISTED *)\r
+ (* AXIOM Q *)\r
+ FI\r
+ ELSE (* AXIOM NOT FOUND *)\r
+ AX2 := MAKE_AXIOM ( AX );\r
+ IF AX = NONE THEN AX := AX2 FI;\r
+ C := NEW TNODE; (* AXIOM := NOT Q *)\r
+ C.KIND := NEGKIND;\r
+ C.LEFT := COPYTNODE ( A.LLEAF );\r
+ AX2.AXIOM := C; \r
+ RESULT := TRUE;\r
+ RETURN; \r
+ FI;\r
+ FI;\r
+ FI;\r
+ WHEN 1 : IF A.PLEAF <> NONE THEN\r
+ IF A.PLEAF.KIND = BVAKIND THEN (* FOUND Q ON RIGHT SIDE *)\r
+ IF SRCH_Q_AX ( A.PLEAF.IDENT, AX2 ) THEN \r
+ IF AX2.AXIOM.KIND = NEGKIND THEN\r
+ RESULT := FALSE; (* FOUND NEGATION OF EXISTED *)\r
+ (* AXIOM Q *)\r
+ ELSE\r
+ RESULT := TRUE; (* FOUND CORRECT AXIOM *)\r
+ FI\r
+ ELSE (* AXIOM NOT FOUND *)\r
+ AX2 := MAKE_AXIOM ( AX );\r
+ IF AX = NONE THEN AX := AX2 FI;\r
+ AX2.AXIOM := COPYTNODE ( A.PLEAF ); \r
+ RESULT := TRUE;\r
+ FI;\r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ ESAC;\r
+ A := A.NEXT;\r
+ OD;\r
+END LOOK_NQ;\r
+\r
+(*****************************************************************************)\r
+(* SEARCH FOR A BVAKIND IN THE SET OF AXIOMS *)\r
+\r
+UNIT SRCH_Q_AX : FUNCTION ( N : INTEGER; INOUT AX2 : LIST_AXIOMS ) : BOOLEAN;\r
+BEGIN\r
+ AX2 := AX;\r
+ WHILE AX2 <> NONE \r
+ DO\r
+ IF AX2.AXIOM.KIND = BVAKIND AND AX2.AXIOM.IDENT = N THEN\r
+ RESULT := TRUE;\r
+ RETURN\r
+ ELSE\r
+ IF AX2.AXIOM.KIND = NEGKIND ANDIF AX2.AXIOM.LEFT.KIND = BVAKIND\r
+ AND AX2.AXIOM.LEFT.IDENT = N THEN\r
+ RESULT := TRUE;\r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ AX2 := AX2.NEXT;\r
+ OD;\r
+ RESULT := FALSE;\r
+END SRCH_Q_AX;\r
+\r
+(*****************************************************************************)\r
+(* CREATE A NEW AXIOM *)\r
+\r
+UNIT MAKE_AXIOM : FUNCTION ( AX1 : LIST_AXIOMS ) : LIST_AXIOMS ;\r
+BEGIN\r
+ IF AX1 = NONE THEN\r
+ RESULT := NEW LIST_AXIOMS;\r
+ ELSE\r
+ CALL END_OF_AX ( AX1 );\r
+ AX1.NEXT := NEW LIST_AXIOMS;\r
+ RESULT := AX1.NEXT;\r
+ FI;\r
+END MAKE_AXIOM;\r
+\r
+(*****************************************************************************)\r
+(* LOOKING FOR IDENTITY AXIOM U=TAU *)\r
+\r
+UNIT LOOK_IDE:FUNCTION ( A : SEQUENT ) : BOOLEAN;\r
+VAR AX1 : LIST_AXIOMS,\r
+ ALFA : BOOLEAN;\r
+BEGIN\r
+ WHILE A <> NONE \r
+ DO\r
+ IF A.PLEAF <> NONE ANDIF A.PLEAF.KIND = EQUKIND ANDIF \r
+ ( A.PLEAF.LEFT.KIND = VRUKIND OR A.PLEAF.LEFT.RIGHT.KIND = VRUKIND )\r
+ THEN (* FOUND U=TAU *)\r
+ CALL FUNCHECK ( A.PLEAF, ALFA );\r
+ IF NOT ALFA THEN \r
+ AX1 := AX;\r
+ RESULT := TRUE;\r
+ WHILE AX1 <> NONE\r
+ DO\r
+ ALFA := TRUE;\r
+ CALL COMPARE ( A.PLEAF, AX1.AXIOM, ALFA );\r
+ IF ALFA THEN RETURN FI; (* THIS AXIOM HAS ALREADY *)\r
+ AX1 := AX1.NEXT; (* BEEN WRITTEN TO THE LIST *)\r
+ OD;\r
+ IF SEARCH_U ( A ) THEN \r
+ CALL END_OF_M ( M, A );\r
+ RETURN;\r
+ FI;\r
+ CALL END_OF_AX ( AX1 ); (* AXIOM NOT FOUND *)\r
+ IF AX = NONE THEN \r
+ AX1 := NEW LIST_AXIOMS;\r
+ AX := AX1\r
+ ELSE\r
+ AX1.NEXT := NEW LIST_AXIOMS; (* SO, THE LIST MUST BE *)\r
+ AX1 :=AX1.NEXT;\r
+ FI;\r
+ AX1.AXIOM := COPYTNODE ( A.PLEAF ); (* UPDATED *)\r
+ RETURN\r
+ ELSE\r
+ ALFA := FALSE\r
+ FI;\r
+ FI;\r
+ A := A.NEXT; \r
+ OD;\r
+END LOOK_IDE;\r
+\r
+(*****************************************************************************)\r
+\r
+\r
+(*****************************************************************************)\r
+(* OUTPUT OF AXIOMS *)\r
+(*****************************************************************************)\r
+\r
+(*****************************************************************************)\r
+(* PRINTS ALL LIST OF AXIOMS *)\r
+\r
+UNIT SHOW_AX : PROCEDURE ( AX1 : LIST_AXIOMS );\r
+BEGIN\r
+ IF AX1 <> NONE THEN\r
+ CALL SHOW_TREE ( AX1.AXIOM );\r
+ CALL SHOW_AX ( AX1.NEXT );\r
+ FI;\r
+END SHOW_AX;\r
+ \r
+(****************************************************************************)\r
+(* WRITES AXIOMS *)\r
+\r
+UNIT WRITE_AXIOMS : PROCEDURE;\r
+VAR AX1 : LIST_AXIOMS;\r
+BEGIN\r
+ AX1 := AX;\r
+ IF AX = NONE THEN \r
+ WRITE ( "IT IS TRUE WITHOUT ADDITIONAL AXIOMS" ); \r
+ RETURN \r
+ FI;\r
+ WHILE AX1 <> NONE \r
+ DO \r
+ IF AX1.AXIOM.KIND = EQUKIND THEN\r
+ WRITE (" U = ");\r
+ IF AX1.AXIOM.LEFT.KIND = VRUKIND THEN\r
+ CALL WRITE_EXPR ( AX1.AXIOM.LEFT.RIGHT )\r
+ ELSE\r
+ CALL WRITE_EXPR ( AX1.AXIOM.LEFT );\r
+ FI\r
+ ELSE\r
+ CASE AX1.AXIOM.KIND\r
+ WHEN 7 : CALL PUTCH ( 'Q' );\r
+ CALL PNUM ( AX1.AXIOM.LEFT.IDENT );\r
+ WRITE ( " <=> FALSE" );\r
+ WHEN 33 : CALL PUTCH ( 'Q');\r
+ CALL PNUM ( AX1.AXIOM.IDENT );\r
+ WRITE ( " <=> TRUE" );\r
+ ESAC\r
+ FI;\r
+ AX1 := AX1.NEXT;\r
+ WRITELN;\r
+ OD;\r
+ CALL ERASE_AX ( AX );\r
+END WRITE_AXIOMS; \r
+ \r
+(****************************************************************************)\r
+(* PRINT BRACKETS *)\r
+ \r
+UNIT PUT_BRACKET : PROCEDURE ( C : TNODE );\r
+VAR K : INTEGER;\r
+BEGIN\r
+ K := C.KIND;\r
+ IF K=LITKIND ORIF K=FUNKIND ORIF K=42 ORIF K=43\r
+ ORIF K=47 ORIF K=45 ORIF K=94 THEN\r
+ CALL PUTCH ( '(' );\r
+ CALL WRITE_EXPR ( C );\r
+ CALL PUTCH ( ')' )\r
+ ELSE\r
+ CALL WRITE_EXPR ( C );\r
+ FI;\r
+END PUT_BRACKET;\r
+\r
+(****************************************************************************)\r
+(* PRINT TERM *)\r
+\r
+UNIT WRITE_EXPR : PROCEDURE ( C : TNODE );\r
+BEGIN\r
+ IF C=NONE THEN RETURN FI;\r
+ CASE C.KIND\r
+ WHEN CN2KIND:CALL PUTCH ( 'C' );\r
+ CALL PNUM ( C.IDENT );\r
+ RETURN;\r
+ WHEN CNTKIND:CALL PNUM ( C.IDENT + 1 );\r
+ RETURN;\r
+ WHEN LITKIND:CALL PUTCH ( 'P' );\r
+ CALL PNUM ( C.IDENT );\r
+ C := C.LEFT;\r
+ IF C <> NONE THEN \r
+ CALL PUTCH ( '(' );\r
+ FI;\r
+ RETURN;\r
+ WHEN FUNKIND:CALL PUTCH ( 'F' );\r
+ CALL PNUM ( C.IDENT );\r
+ IF C.LEFT <> NONE THEN \r
+ CALL PUTCH ( '(' );\r
+ CALL WRITE_EXPR ( C.LEFT ); \r
+ FI;\r
+ C := C.RIGHT;\r
+ IF C = NONE THEN \r
+ CALL PUTCH ( ')' )\r
+ ELSE \r
+ CALL PUTCH ( ',' );\r
+ FI;\r
+ RETURN;\r
+ WHEN ARIKIND:\r
+ CASE C.IDENT\r
+ WHEN 42 :CALL PUT_BRACKET ( C.LEFT );\r
+ CALL PUTCH ( '*' );\r
+ CALL PUT_BRACKET ( C.LEFT.RIGHT );\r
+ RETURN;\r
+ WHEN 43 :CALL PUT_BRACKET ( C.LEFT );\r
+ CALL PUTCH ( '+' );\r
+ CALL PUT_BRACKET ( C.LEFT.RIGHT );\r
+ RETURN; \r
+ WHEN 45 :CALL PUT_BRACKET ( C.LEFT );\r
+ CALL PUTCH ( '-' );\r
+ CALL PUT_BRACKET ( C.LEFT.RIGHT );\r
+ RETURN; \r
+ WHEN 47 :CALL PUT_BRACKET ( C.LEFT );\r
+ CALL PUTCH ( '/' );\r
+ CALL PUT_BRACKET ( C.LEFT.RIGHT );\r
+ RETURN; \r
+ WHEN 94 :CALL PUT_BRACKET ( C.LEFT );\r
+ CALL PUTCH ( '^' );\r
+ CALL PUT_BRACKET ( C.LEFT.RIGHT );\r
+ RETURN;\r
+ ESAC;\r
+ ESAC;\r
+END WRITE_EXPR;\r
+\r
+(****************************************************************************)\r
+(* PRINT NUMBER WITHOUT SPACES OR ZEROS CONTROLLING END OF LINE *)\r
+ \r
+UNIT PNUM : PROCEDURE ( N : INTEGER );\r
+VAR I:INTEGER;\r
+BEGIN\r
+ N := N-1;\r
+ IF N > -1 THEN\r
+ I := 1;\r
+ IF N>9 THEN I := I+1 FI;\r
+ IF N>99 THEN I := I+1 FI;\r
+ IF N>999 THEN I := I+1 FI;\r
+ IF N>9999 THEN I := I+1 FI;\r
+ IF CHARSH+1>LINLNG THEN WRITELN; CHARSH := 0 FI;\r
+ IF CHARSH=0 THEN WRITE(' '); FI;\r
+ WRITE ( N:I );\r
+ CHARSH := CHARSH+1;\r
+ FI;\r
+END PNUM;\r
+\r
+(****************************************************************************)\r
+(* SERVES SPECIAL EXCEPTIONS - HARD EXIT FROM PROGRAM *)\r
+\r
+SIGNAL ENDRUN;\r
+HANDLERS\r
+ WHEN ENDRUN: TERMINATE;\r
+END HANDLERS;\r
+\r
+(****************************************************************************)\r
+\r
+BEGIN\r
+ L := 0;\r
+ OPEN ( G , TEXT , UNPACK ( "RETRPROV.DAT" ) );\r
+ M := NEW POINTER;\r
+ SQNT := NEW SEQUENT;\r
+ M.NEXT := SQNT;\r
+ CALL RESET ( G );\r
+ SQNT.PLEAF := GEN_TREE;\r
+ CALL LAST1_S ( SQNT.PLEAF );\r
+ CALL LAST1_X ( SQNT.PLEAF );\r
+ (* M contains f(t1,...,tn)=u or relation *)\r
+ WRITELN ( "PROVE WITH DEFINITION ------- 1 " );\r
+ WRITELN ( "PROVE WITHOUT DEFINITION ------- 2 " );\r
+ READ ( DEF_LIT );\r
+ IF DEF_LIT = 1 THEN \r
+ (* M1 contains f(x1,...,xn)=Ktau or relation *)\r
+ OPEN ( G , TEXT , UNPACK ( "RETRPROV.DEF" ) );\r
+ M1 := NEW DEF;\r
+ M1.NEXT := M1;\r
+ CALL RESET ( G );\r
+ L := 0;\r
+ M1.FUN_REL := GEN_TREE;\r
+ CALL LAST1_S ( M1.FUN_REL );\r
+ CALL LAST1_X ( M1.FUN_REL );\r
+ CALL REP_F_L ( M1 ); (* FUNKIND -> FN1KIND *)\r
+ (* LITKIND -> LT1KIND *)\r
+ CALL RULEDF_L ( M , 1 , M1.FUN_REL.LEFT.IDENT );\r
+ CALL RULEDF_F ( M , 1 , M1.FUN_REL.LEFT.IDENT ); \r
+ FI;\r
+ K_MN_K := 2;\r
+ LOGIC := FALSE;\r
+ CALL PROVE ( M , 0 );\r
+ CALL WRITE_AXIOMS;\r
+END RETRPROV; \r
+\r
+(****************************************************************************)\1a
\ No newline at end of file
--- /dev/null
+P<=>((p3=>p1)=>((p3=>p2)=>(p3=>(p1&p2))))?
\ No newline at end of file
--- /dev/null
+P<=>(TvF)?
\ No newline at end of file
--- /dev/null
+p(1,2)<=>q?
\ No newline at end of file
--- /dev/null
+P<=>((=(x1,x2)&=(x3,x4)&P1(x1,x3))=>P1(x2,x4))?
\ No newline at end of file
--- /dev/null
+P<=>Ax(P1(x)=>P1(x))?
\ No newline at end of file
--- /dev/null
+P<=>n((p1=>(p2=>p3))=>((p1=>p2)=>(p1=>p3)))?
\ No newline at end of file
--- /dev/null
+AxP(x)=>P(x)?
\ No newline at end of file
--- /dev/null
+AxP(x)=>P(x)?
\ No newline at end of file
--- /dev/null
+BEGINs1:=1$s2:=2endif=(s1,s2)thenq1:=Felsebegins3:=0;whilen(=(s3,s2)v=(s3,s1))dos3:=+(s3,1)od;if=(s3,s1)thenq1:=Telseq1:=Ffiendfi(q1)?
\ No newline at end of file
--- /dev/null
+P<=>((p3=>p1)=>((p3=>p2)=>(p3=>(p1&p2))))?
\ No newline at end of file
--- /dev/null
+=(g(x1,x2),BEGINs1:=0;s2:=0;WHILEn=(s2,x2)DOBEGINs3:=0;WHILEn=(s3,x1)DOBEGINs1:=+(s1,1);s3:=+(s3,1)ENDOD;s2:=+(s1,1)ENDODENDs1)?
\ No newline at end of file
--- /dev/null
+P<=>((p1&(p1=>p2))=>p2)?
\ No newline at end of file
--- /dev/null
+P<=>((p1&(p1vp2))=>p2)?
\ No newline at end of file
--- /dev/null
+P<=>((p1&(p1&p2))=>p2)?
\ No newline at end of file
--- /dev/null
+P<=>((p1=>p2)=>((p2=>p3)=>(p1=>p3)))?
\ No newline at end of file
--- /dev/null
+P<=>(p1=>(p2vp1))?
\ No newline at end of file
--- /dev/null
+P<=>((p1=>p3)=>((p2=>p3)=>((p1vp2)=>p3)))?
\ No newline at end of file
--- /dev/null
+P<=>((p1&p3)=>p3)?
\ No newline at end of file
--- /dev/null
+P<=>((p1=>(p3&np3))=>np1)?
\ No newline at end of file
--- /dev/null
+P<=>(((p1&p2)=>p3)=>(p1=>(p2=>p3)))?
\ No newline at end of file
--- /dev/null
+P<=>Q?
\ No newline at end of file
--- /dev/null
+program chinczyk;\r
+ \r
+ var ii,ij,kostka, ilugraczy: integer;\r
+ var tab: arrayof arrayof integer;\r
+ var gracz: arrayof coroutine;\r
+\r
+unit gracz1:coroutine;\r
+var i:integer;\r
+ \r
+begin\r
+ return;\r
+ do\r
+ call A.gdziepiony; \r
+ i:=0;\r
+ call A.przesunpion(0);\r
+ detach;\r
+od;\r
+end gracz1;\r
+\r
+\r
+\r
+\r
+ \r
+unit gracz2:coroutine;\r
+var witch:integer; \r
+begin\r
+ return;\r
+ do\r
+ call A.gdziepiony; \r
+ witch:=0;\r
+ call A.przesunpion(witch);\r
+ detach;\r
+od;\r
+end gracz2;\r
+ \r
+unit gracz3:coroutine;\r
+const g=3; (* number of player *)\r
+const eh=20; (* finish *)\r
+const spp=21; (* start *)\r
+\r
+var stran :arrayof integer;\r
+var pp,i,leader,nrkil,nrhun,witch :integer;\r
+var home :arrayof boolean;\r
+\r
+unit man:class; (* pawn *)\r
+ var ple,saf,rsa :integer;\r
+ var kil,hun,fin,mov :boolean;\r
+end man;\r
+\r
+var pawn :arrayof man;\r
+unit poleposition:function:boolean;\r
+ var h,i:integer;\r
+ begin\r
+ pp:=0;\r
+ result:=true;\r
+ for i:=1 to 4 do\r
+ home(i):=false;\r
+ od;\r
+ for i:=1 to 4 do\r
+ h:=tab(g,i); \r
+ if h=0 then pp:=pp+1 fi;\r
+ if h=spp then result:=false fi;\r
+ if h>100 then home(h-100):=true fi;\r
+ od;\r
+ if pp=0 then result:=false fi;\r
+end poleposition; \r
+\r
+unit pawns:procedure;\r
+var i:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ pawn(i).ple:=tab(g,i);\r
+ od;\r
+end pawns; \r
+ \r
+unit finish:function:integer;\r
+ var i:integer;\r
+ unit inhome:function(a:integer):boolean;\r
+ begin\r
+ result:=false;\r
+ if a>1 andif a<=eh andif a+kostka>eh then\r
+ if a+kostka-eh<5 andif not home(a+kostka-eh) then\r
+ result:=true;\r
+ pawn(i).mov:=true;\r
+ else\r
+ pawn(i).mov:=false; \r
+ fi;\r
+ else\r
+ pawn(i).mov:=true; \r
+ fi;\r
+ end inhome; \r
+ begin\r
+ result:=0;\r
+ for i:=1 to 4 do\r
+ pawn(i).fin:=false;\r
+ if pawn(i).ple>0 andif pawn(i).ple<99 then\r
+ if inhome(pawn(i).ple) then\r
+ result:=result+1;\r
+ pawn(i).fin:=true;\r
+ fi\r
+ else\r
+ pawn(i).mov:=false;\r
+ fi;\r
+ od;\r
+end finish;\r
+\r
+unit killer:function:integer;\r
+ var i,j,k:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ pawn(i).kil:=false;\r
+ for j:=1 to 3 do\r
+ k:=(i+j) mod 4;\r
+ if k=0 then k:=4 fi;\r
+ if pawn(i).ple+kostka=pawn(k).ple andif pawn(i).ple=/=0 then\r
+ pawn(i).kil:=true;\r
+ fi\r
+ od\r
+ od\r
+end killer;\r
+\r
+unit hunter:function:integer;\r
+ var i,j:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ if pawn(i).ple=/=0 then\r
+ j:=member(pawn(i).ple+kostka,stran);\r
+ if pawn(i).ple+kostka=stran(j) then\r
+ pawn(i).hun:=true;\r
+ result:=result+1;\r
+ else\r
+ pawn(i).hun:=false;\r
+ fi\r
+ fi\r
+ od\r
+end hunter;\r
+\r
+unit strangers:procedure;\r
+var i,j,k:integer;\r
+ begin\r
+ k:=1; \r
+ for i:=1 to 4 do\r
+ if i=/=g then\r
+ for j:=1 to 4 do\r
+ if i>ilugraczy then stran(k):=0;\r
+ else stran(k):=tab(i,j);\r
+ fi;\r
+ k:=k+1;\r
+ od;\r
+ fi\r
+ od;\r
+ stran(13):=200;\r
+ j:=12;\r
+ while j>1 do\r
+ i:=1;\r
+ while i<j do\r
+ if stran(i)>stran(i+1) then\r
+ k:=stran(i);\r
+ stran(i):=stran(i+1);\r
+ stran(i+1):=k;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ j:=j-1;\r
+ od;\r
+end strangers; \r
+\r
+unit member:function(a:integer,arra:arrayof integer):integer;\r
+var i:integer;\r
+ begin\r
+ if a<99 then a:=(a+40)mod 40 fi;\r
+ if a=0 then a:=40 fi;\r
+ if a>arra(1) andif a<arra(13) then\r
+ i:=1;\r
+ while a>arra(i) do\r
+ i:=i+1;\r
+ od;\r
+ result:=i;\r
+ else if a<arra(1) then result:=1;\r
+ else result:=12 fi\r
+ fi; \r
+end member;\r
+\r
+\r
+unit safety:procedure;\r
+ var i:integer;\r
+ unit rafset:function(k:integer):integer;\r
+ var p,q:integer;\r
+ begin\r
+ p:=member(k,stran);\r
+ q:=member(k-6,stran);\r
+ result:=0;\r
+ if p>q then result:=p-q\r
+ else\r
+ if p=q then result:=0\r
+ else\r
+ while stran(q)<99 do\r
+ q:=q+1;\r
+ result:=result+1;\r
+ if q=13 then exit fi;\r
+ od;\r
+ q:=1;\r
+ while stran(q)=0 do\r
+ q:=q+1;\r
+ od;\r
+ result:=result+p-q;\r
+ fi; \r
+ fi;\r
+ end rafset;\r
+ begin\r
+ for i:=1 to 4 do\r
+ if pawn(i).ple>0 andif pawn(i).ple<99 then\r
+ pawn(i).saf:=rafset(pawn(i).ple);\r
+ pawn(i).rsa:=pawn(i).saf-rafset(pawn(i).ple+kostka);\r
+ else\r
+ pawn(i).saf:=6;\r
+ pawn(i).rsa:=-12; \r
+ fi;\r
+ od;\r
+end safety; \r
+ \r
+unit move:procedure;\r
+ var i,j:integer;\r
+ var speed:boolean;\r
+ var moves:arrayof boolean;\r
+ begin\r
+ j:=-12;\r
+ if leader>0 then\r
+ for i:=1 to 4 do\r
+ if pawn(i).fin then\r
+ if pawn(i).rsa>j then \r
+ witch:=i;\r
+ j:=pawn(i).rsa\r
+ fi\r
+ fi\r
+ od;\r
+ else \r
+ speed:=true;\r
+ array moves dim(1:4);\r
+ for i:=1 to 4 do\r
+ moves(i):=false;\r
+ if not pawn(i).kil andif pawn(i).hun then\r
+ moves(i):=true;\r
+ speed:=false;\r
+ fi\r
+ od;\r
+ for i:=1 to 4 do\r
+ if not pawn(i).kil andif pawn(i).ple>0 andif pawn(i).mov then\r
+ if speed orif moves(i) then\r
+ if pawn(i).rsa>j then \r
+ witch:=i;\r
+ j:=pawn(i).rsa\r
+ fi\r
+ fi\r
+ fi\r
+ od;\r
+ kill (moves);\r
+ fi; \r
+end move;\r
+ \r
+begin\r
+ array pawn dim(1:4);\r
+ array home dim(1:4);\r
+ array stran dim(1:13);\r
+ for i:=1 to 4 do\r
+ pawn(i):=new man;\r
+ od;\r
+ return;\r
+ do\r
+ call A.gdziepiony; \r
+ call pawns;\r
+ call strangers;\r
+ if poleposition and kostka=6 then\r
+ i:=1;\r
+ while tab(g,i)=/=0 do\r
+ i:=i+1;\r
+ od;\r
+ witch:=i;\r
+ else\r
+ leader:=finish;\r
+ nrkil:=killer;\r
+ if nrkil=4-pp then\r
+ witch:=0;\r
+ else\r
+ nrhun:=hunter;\r
+ call safety;\r
+ call move;\r
+ fi;\r
+ fi;\r
+ call A.przesunpion(witch);\r
+ detach;\r
+od;\r
+end gracz3;\r
+(*44444**************** gracz 4 **********)\r
+\r
+\r
+unit gracz4: coroutine;\r
+const g=4;\r
+const start=31;\r
+const endpos=30;\r
+\r
+var players : arrayof boy; \r
+\r
+unit boy:class;\r
+ var pos,back : integer;\r
+ var suicide,stab,finish,moveout : boolean;\r
+end boy;\r
+\r
+unit playerinit:procedure;\r
+var i:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ players(i).pos:=tab(g,i);\r
+ od;\r
+end playerinit;\r
+\r
+unit finishing:function(nr:integer):boolean;\r
+ var i,j:integer;\r
+ begin\r
+ result:=false;\r
+ i:=players(nr).pos;\r
+ if i<>0 \r
+ then \r
+ if i+kostka>endpos and i+kostka<endpos+5 and i<=endpos\r
+ then \r
+ result:=true;\r
+ for j:=1 to 4\r
+ do \r
+ if j <> nr \r
+ then\r
+ if (players(j).pos-100+1)=i+kostka-endpos\r
+ then result:=false;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ fi;\r
+end finishing;\r
+ \r
+unit suiciding:function(nr:integer):boolean;\r
+ var i:integer;\r
+ begin\r
+ result:=false;\r
+ if players(nr).pos<>0\r
+ then \r
+ for i:=1 to 4 \r
+ do\r
+ if nr<>i \r
+ then\r
+ if (players(nr).pos+kostka-1) mod 40 + 1 = players(i).pos \r
+ andif players(i).pos<100\r
+ then \r
+ result:=true;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od\r
+ else\r
+ for i:= 1 to 4\r
+ do\r
+ if i<>nr andif players(i).pos=start\r
+ then result:=true;\r
+ exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+end suiciding;\r
+ \r
+unit stabing:function(nr:integer):boolean;\r
+ var i,j:integer;\r
+ var b1,b2:boolean;\r
+ begin\r
+ result:=false;\r
+ for i:=1 to 4\r
+ do\r
+ if i<>g \r
+ then\r
+ for j:= 1 to 4\r
+ do\r
+ if players(nr).pos > 0 and players(nr).pos <100\r
+ then\r
+ b1:=(players(nr).pos+kostka-1) mod 40 +1 =tab(i,j) ;\r
+ b2:=players(nr).pos>=start and b1;\r
+ if b1 and (players(nr).pos+kostka-1) mod 40 + 1<=endpos orif b2 \r
+ then\r
+ result:=true;\r
+ exit exit;\r
+ fi\r
+ else\r
+ result:=(kostka=6 and players(nr).pos=0 and tab(i,j)=start);\r
+ exit exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+end stabing; \r
+\r
+unit atback:function(nr:integer):integer;\r
+ var i,j,np:integer;\r
+ begin\r
+ np:=players(nr).pos;\r
+ result:=0;\r
+ if np<>0\r
+ then \r
+ if np < 7 \r
+ then\r
+ for i:=1 to 4 \r
+ do \r
+ if i<>g \r
+ then \r
+ for j:=1 to 4\r
+ do\r
+ if (tab(i,j) < np)\r
+ then\r
+ if tab(i,j)>0\r
+ then result:=result+1;\r
+ fi\r
+ else \r
+ if tab(i,j) > 40-(6-np)\r
+ then result:=result+1;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ else\r
+ for i:=1 to 4\r
+ do\r
+ if i<>g\r
+ then\r
+ for j:=1 to 4\r
+ do\r
+ if tab(i,j) < np\r
+ andif tab(i,j) > np-7\r
+ then result:=result +1;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od; \r
+ fi;\r
+ fi;\r
+ end atback;\r
+ \r
+ unit begining : function(nr:integer):boolean;\r
+ begin\r
+ result:=players(nr).pos=0 and kostka=6;\r
+ end begining;\r
+ \r
+ unit move:function:integer;\r
+ var i,j,k : integer;\r
+ var ok:boolean;\r
+ begin\r
+ for i:= 1 to 4\r
+ do\r
+ players(i).back:=atback(i);\r
+ players(i).suicide:=suiciding(i);\r
+ players(i).stab:=stabing(i);\r
+ players(i).finish:=finishing(i);\r
+ players(i).moveout:=begining(i);\r
+ od;\r
+ ok:=false;\r
+ (********************* bije i wychodzi ************)\r
+ for i:=1 to 4\r
+ do \r
+ if players(i).moveout \r
+ then\r
+ for j:=1 to 4\r
+ do\r
+ if g<>j \r
+ then\r
+ for k:=1 to 4 \r
+ do\r
+ if tab(j,k)=start\r
+ then \r
+ result:=i;\r
+ ok:=true; exit exit exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ (******************** gonia go i konczy **************)\r
+ if not ok \r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos>0\r
+ andif players(i).pos<100\r
+ andif players(i).finish \r
+ andif players(i).back > 0\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************** gonia go i bije ******************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).back>0\r
+ andif players(i).stab\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* bije ********************************)\r
+ if not ok \r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ if players(i).stab\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************** goni go conajmniej dwoch **********)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).back>=2\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* wychodzi ****************************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).moveout\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ (******************* konczy *******************************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).finish\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+\r
+ (******************** gonia go **********)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).pos>0\r
+ andif players(i).back>0\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi; \r
+ (******************* nie bije swojego *********************)\r
+ if not ok \r
+ then\r
+ for i:=4 downto 1\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).pos>0\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* bije swojego *********************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).suicide\r
+ then\r
+ result := 0 ;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ \r
+ if not ok then result:=0 fi; \r
+\r
+\r
+ end move;\r
+ \r
+\r
+ \r
+ \r
+ \r
+ \r
+ (****** MAIN *****)\r
+ (*****************)\r
+var aa:char;\r
+\r
+ unit inchar : IIuwgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ var i,m:integer;\r
+ begin\r
+ array players dim(1:4);\r
+ for i:=1 to 4 \r
+ do\r
+ players(i):=new boy;\r
+ od;\r
+ return;\r
+ do\r
+ call playerinit;\r
+ m:=move;\r
+ call A.przesunpion(m);\r
+ \r
+ writeln("back,suic,stab,fin,out:");\r
+ for i:= 1 to 4\r
+ do\r
+\r
+ write(players(i).back," ");\r
+ if players(i).suicide then write("1") else write("0") fi;\r
+ write(" ");\r
+ if players(i).stab then write("1") else write("0") fi;\r
+ write(" ");\r
+ if players(i).finish then write("1") else write("0") fi;\r
+ write(" ");\r
+ if players(i).moveout then write("1") else write("0") fi;\r
+ write(",");\r
+ od;\r
+ writeln(" ->",m);\r
+ pref iiuwgraph block \r
+\r
+ var i:integer;\r
+ begin\r
+ i:=inchar;\r
+ end;\r
+ \r
+ detach;\r
+ od;\r
+end gracz4;\r
+\r
+ \r
+ unit arbiter: coroutine;\r
+\r
+ hidden plansza, ilegr, i, j, oczka, ktory, sk, polozenie, dom, gracze;\r
+ hidden wejscie, polestartu, skonczyli, sem, zakonczenie;\r
+ var plansza: arrayof pion;\r
+ var ilegr, i, j, oczka, ktory, sk: integer;\r
+ var polozenie, dom: arrayof arrayof integer;\r
+ var gracze: arrayof coroutine;\r
+ var wejscie: arrayof integer;\r
+ var polestartu, skonczyli: arrayof integer;\r
+ var sem: boolean;\r
+ var zakonczenie: char;\r
+ \r
+ \r
+ unit rzut: function: integer;\r
+ \r
+ var pom: real;\r
+ \r
+ begin\r
+ pom:=random;\r
+ pom:=6*pom;\r
+ result:= entier(pom)+1\r
+ end rzut;\r
+ \r
+ \r
+ unit pion: class (czyj, jaki: integer);\r
+ end pion;\r
+ unit gdziepiony: procedure;\r
+ var i, j: integer;\r
+ begin\r
+ for i:=1 to ilegr\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ tab(i,j):=polozenie(i,j)\r
+ od\r
+ od \r
+ end gdziepiony;\r
+ \r
+ \r
+ unit przesunpion: procedure (co: integer);\r
+ \r
+ var s, g, t: integer;\r
+ \r
+ unit start: procedure;\r
+ begin\r
+ if oczka=/=6 then return fi;\r
+ g:=polestartu (ktory);\r
+ polozenie (ktory, co):=g;\r
+ if plansza (g) =/= none\r
+ then call bicie\r
+ fi;\r
+ plansza (g):=new pion (ktory, co)\r
+ end start;\r
+ \r
+ unit bicie: procedure;\r
+ begin\r
+ polozenie (plansza(g).czyj, plansza(g).jaki):=0;\r
+ kill (plansza(g))\r
+ end bicie;\r
+ \r
+ begin (* przesunpion *)\r
+ if not sem \r
+ then\r
+ return\r
+ else\r
+ sem:=false\r
+ fi;\r
+ if co=0 then return fi;\r
+ s:=polozenie (ktory, co);\r
+ if s > 100\r
+ then (* pion w domu *)\r
+ return\r
+ fi;\r
+ if s=0 \r
+ then\r
+ call start;\r
+ return\r
+ fi;\r
+ g:=s+oczka;\r
+ if ( s <= wejscie(ktory) and g > wejscie(ktory) )\r
+ then (* wejscie do domu *)\r
+ t:= oczka-(wejscie(ktory)-s);\r
+ if t>4 then return fi;\r
+ if dom (ktory,t) = 0\r
+ then\r
+ dom (ktory,t) := co;\r
+ polozenie (ktory,co) :=100+t;\r
+ kill (plansza(s))\r
+ else\r
+ return\r
+ fi\r
+ else\r
+ if g>40 then g:=g-40 fi;\r
+ if plansza(g)=/=none\r
+ then call bicie\r
+ fi;\r
+ plansza(g):=plansza(s);\r
+ plansza(s):=none;\r
+ polozenie (ktory,co):=g\r
+ fi\r
+ end przesunpion;\r
+ \r
+ unit skonczyl: function: boolean;\r
+ var i: integer;\r
+ begin \r
+ for i:=1 to sk\r
+ do\r
+ if skonczyli(i)=ktory\r
+ then\r
+ result:=true;\r
+ exit\r
+ fi\r
+ od\r
+ end skonczyl;\r
+ \r
+ \r
+ unit koniec: function: boolean;\r
+ var i: integer;\r
+ var doszedl: boolean;\r
+ begin\r
+ doszedl:=true;\r
+ for i:=1 to 4\r
+ do\r
+ if dom(ktory,i)=0\r
+ then\r
+ doszedl:=false;\r
+ exit\r
+ fi\r
+ od;\r
+ if doszedl\r
+ then\r
+ sk:=sk+1;\r
+ skonczyli(sk):=ktory\r
+ fi;\r
+ result:= sk=ilegr\r
+ end koniec; \r
+ \r
+ unit komunikat: procedure;\r
+ var i: integer;\r
+ begin\r
+ writeln;\r
+ for i:=1 to ilegr\r
+ do\r
+ writeln (i:1," miejsce zajal gracz ",skonczyli(i):1)\r
+ od\r
+ end komunikat;\r
+\r
+ \r
+begin (* arbiter *)\r
+ ilegr:=ilugraczy;\r
+ if ilegr=0 then call endrun fi;\r
+ array polozenie dim (1:ilegr);\r
+ array tab dim (1:ilegr);\r
+ array dom dim (1:ilegr);\r
+ array plansza dim (1:40);\r
+ array skonczyli dim (1:ilegr);\r
+ array gracze dim (1:ilegr);\r
+ gracze:=copy(gracz); \r
+ for i:=1 to ilegr\r
+ do\r
+ array dom(i) dim (1:4); \r
+ array polozenie(i) dim (1:4);\r
+ array tab(i) dim (1:4)\r
+ od;\r
+ array wejscie dim (1:ilegr);\r
+ array polestartu dim (1:ilegr);\r
+ for i:=1 to ilegr\r
+ do\r
+ polestartu(i):=10*(i-1)+1;\r
+ wejscie(i):=polestartu(i)-1\r
+ od;\r
+ wejscie(1):=40;\r
+ \r
+ return;\r
+for ii:=1 to 4 do\r
+ for ij:=1 to 4 do \r
+ write(tab(ii,ij):4) \r
+ od;\r
+ writeln;\r
+od;\r
+ ktory:=4;\r
+ do\r
+ if ktory=3 then ktory:=4\r
+ else ktory:=3;\r
+ fi;\r
+ if skonczyl\r
+ then repeat\r
+ fi;\r
+ do\r
+ kostka, oczka:=rzut;\r
+ sem:=true;\r
+\r
+writeln (" kostka :" ,oczka," ktory :",ktory); \r
+for ii:=3 to 4 do\r
+ for ij:=1 to 4 do \r
+ write(tab(ii,ij):4) \r
+ od;\r
+ writeln;\r
+od;\r
+ attach (gracze(ktory));\r
+ if koniec then exit exit fi;\r
+ if oczka=/=6 or skonczyl then exit fi;\r
+ od;\r
+ od;\r
+ call komunikat;\r
+ read (zakonczenie);\r
+ call endrun\r
+end arbiter;\r
+\r
+ var A: arbiter; \r
+ \r
+ \r
+(* * * * * *) \r
+ \r
+ \r
+ \r
+ \r
+begin (* program glowny *)\r
+ilugraczy :=4; \r
+array gracz dim (1:ilugraczy);\r
+gracz(1) := new gracz1;\r
+gracz(2) := new gracz2;\r
+gracz(3) := new gracz3;\r
+gracz(4) := new gracz4;\r
+A := new arbiter;\r
+attach (A)\r
+\r
+end chinczyk \r
+ \1a
\ No newline at end of file
--- /dev/null
+\r
+unit gracz4: coroutine;\r
+const g=4;\r
+const start=31;\r
+const endpos=30;\r
+\r
+var players : arrayof boy; \r
+\r
+unit boy:class;\r
+ var pos,back : integer;\r
+ var suicide,stab,finish,moveout : boolean;\r
+end boy;\r
+\r
+unit playerinit:procedure;\r
+var i:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ players(i).pos:=tab(g,i);\r
+ od;\r
+end playerinit;\r
+\r
+unit finishing:function(nr:integer):boolean;\r
+ var i,j:integer;\r
+ begin\r
+ result:=false;\r
+ i:=players(nr).pos;\r
+ if i<>0 \r
+ then \r
+ if i+kostka>endpos and i+kostka<endpos+5 and i<=endpos\r
+ then \r
+ result:=true;\r
+ for j:=1 to 4\r
+ do \r
+ if j <> nr \r
+ then\r
+ if (players(j).pos-100+1)=i+kostka-endpos\r
+ then result:=false;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ fi;\r
+end finishing;\r
+ \r
+unit suiciding:function(nr:integer):boolean;\r
+ var i:integer;\r
+ begin\r
+ result:=false;\r
+ if players(nr).pos<>0\r
+ then \r
+ for i:=1 to 4 \r
+ do\r
+ if nr<>i \r
+ then\r
+ if (players(nr).pos+kostka-1) mod 40 + 1 = players(i).pos \r
+ andif players(i).pos<100\r
+ then \r
+ result:=true;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od\r
+ else\r
+ for i:= 1 to 4\r
+ do\r
+ if i<>nr andif players(i).pos=start\r
+ then result:=true;\r
+ exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+end suiciding;\r
+ \r
+unit stabing:function(nr:integer):boolean;\r
+ var i,j:integer;\r
+ var b1,b2:boolean;\r
+ begin\r
+ result:=false;\r
+ for i:=1 to 4\r
+ do\r
+ if i<>g \r
+ then\r
+ for j:= 1 to 4\r
+ do\r
+ if players(nr).pos > 0 and players(nr).pos <100\r
+ then\r
+ b1:=(players(nr).pos+kostka-1) mod 40 +1 =tab(i,j) ;\r
+ b2:=players(nr).pos>=start and b1;\r
+ if b1 and (players(nr).pos+kostka-1) mod 40 + 1<=endpos orif b2 \r
+ then\r
+ result:=true;\r
+ exit exit;\r
+ fi\r
+ else\r
+ result:=(kostka=6 and players(nr).pos=0 and tab(i,j)=start);\r
+ exit exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+end stabing; \r
+\r
+unit atback:function(nr:integer):integer;\r
+ var i,j,np:integer;\r
+ begin\r
+ np:=players(nr).pos;\r
+ result:=0;\r
+ if np<>0\r
+ then \r
+ if np < 7 \r
+ then\r
+ for i:=1 to 4 \r
+ do \r
+ if i<>g \r
+ then \r
+ for j:=1 to 4\r
+ do\r
+ if (tab(i,j) < np)\r
+ then\r
+ if tab(i,j)>0\r
+ then result:=result+1;\r
+ fi\r
+ else \r
+ if tab(i,j) > 40-(6-np)\r
+ then result:=result+1;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ else\r
+ for i:=1 to 4\r
+ do\r
+ if i<>g\r
+ then\r
+ for j:=1 to 4\r
+ do\r
+ if tab(i,j) < np\r
+ andif tab(i,j) > np-7\r
+ then result:=result +1;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od; \r
+ fi;\r
+ fi;\r
+ end atback;\r
+ \r
+ unit begining : function(nr:integer):boolean;\r
+ begin\r
+ result:=players(nr).pos=0 and kostka=6;\r
+ end begining;\r
+ \r
+ unit move:function:integer;\r
+ var i,j,k : integer;\r
+ var ok:boolean;\r
+ begin\r
+ for i:= 1 to 4\r
+ do\r
+ players(i).back:=atback(i);\r
+ players(i).suicide:=suiciding(i);\r
+ players(i).stab:=stabing(i);\r
+ players(i).finish:=finishing(i);\r
+ players(i).moveout:=begining(i);\r
+ od;\r
+ ok:=false;\r
+ (********************* bije i wychodzi ************)\r
+ for i:=1 to 4\r
+ do \r
+ if players(i).moveout \r
+ then\r
+ for j:=1 to 4\r
+ do\r
+ if g<>j \r
+ then\r
+ for k:=1 to 4 \r
+ do\r
+ if tab(j,k)=start\r
+ then \r
+ result:=i;\r
+ ok:=true; exit exit exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ (******************** gonia go i konczy **************)\r
+ if not ok \r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos>0\r
+ andif players(i).pos<100\r
+ andif players(i).finish \r
+ andif players(i).back > 0\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************** gonia go i bije ******************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).back>0\r
+ andif players(i).stab\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* bije ********************************)\r
+ if not ok \r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ if players(i).stab\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************** goni go conajmniej dwoch **********)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).back>=2\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* wychodzi ****************************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).moveout\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ (******************* konczy *******************************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).finish\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+\r
+ (******************** gonia go **********)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).pos>0\r
+ andif players(i).back>0\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi; \r
+ (******************* nie bije swojego *********************)\r
+ if not ok \r
+ then\r
+ for i:=4 downto 1\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).pos>0\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* bije swojego *********************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).suicide\r
+ then\r
+ result := 0 ;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ \r
+ if not ok then result:=0 fi; \r
+\r
+\r
+ end move;\r
+ \r
+\r
+ \r
+ \r
+ \r
+ \r
+ (****** MAIN *****)\r
+ (*****************)\r
+var aa:char;\r
+\r
+ var i,m:integer;\r
+ begin\r
+ array players dim(1:4);\r
+ for i:=1 to 4 \r
+ do\r
+ players(i):=new boy;\r
+ od;\r
+ return;\r
+ do\r
+ call playerinit;\r
+ m:=move;\r
+ call A.przesunpion(m);\r
+ \r
+ detach;\r
+ od;\r
+end gracz4;\r
+\1a
\ No newline at end of file
--- /dev/null
+program chinczyk;\r
+(*****************************************************************************)\r
+(* *)\r
+(* Program autorstwa Tomasza Michalaka i Piotra Miekusa. *)\r
+(* Coroutiny biorace udzial w grze sa sparametryzowana coroutina jednego *)\r
+(* typu.Dokonano rowniez wielu zmian i poprawek w wspolprogramie arbitra *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+ var kostka,i,ia:integer;\r
+ var tab: arrayof arrayof integer;\r
+ var gracz: arrayof coroutine;\r
+ var f:file;\r
+(* * * * * *)\r
+\r
+ unit player:iiuwgraph coroutine(g:integer);\r
+ var x,y,i,j,k,l:integer;\r
+ var b:boolean;\r
+ begin\r
+ return;\r
+ do;\r
+ b:=false;\r
+ call move(280,240);\r
+ call A.outhline("use curcors to point pawn");\r
+ call move(300,250);\r
+ call A.outhline(" and press END"); \r
+ call move(360,230);\r
+ call move(360,230);\r
+ call track(360,230);\r
+ x:=inxpos;\r
+ y:=inypos;\r
+ call move(280,240);\r
+ call A.outhline(" ");\r
+ call move(300,250);\r
+ call A.outhline(" "); \r
+ for i:=1 to 4 do\r
+ j:=tab(g,i);\r
+ if j=0 then\r
+ k:=x-A.pl(0,g,i).x;\r
+ l:=y-A.pl(0,g,i).y;\r
+ else\r
+ if j<41 then\r
+ k:=x-A.pl(j,1,1).x;\r
+ l:=y-A.pl(j,1,1).y;\r
+ else\r
+ k,l:=0;\r
+ fi;\r
+ fi;\r
+ if k>0 andif l>0 andif k<47 andif l<36 then b:=true; exit fi;\r
+ od;\r
+ if b then call A.przesunpion(i);\r
+ else call A.przesunpion(0);\r
+ fi;\r
+ detach;\r
+ od;\r
+ end player;\r
+ \r
+ \r
+unit gracz1:coroutine(g,eh,spp:integer);\r
+\r
+var stran :arrayof integer;\r
+var pp,j,i,nrkil,witch :integer;\r
+var home :arrayof boolean;\r
+var polepos :boolean; \r
+ \r
+unit man:class; (* pawn *)\r
+ var ple,saf,rsa :integer;\r
+ var kil,hun,fin,mov :boolean;\r
+end man;\r
+\r
+var pawn :arrayof man;\r
+\r
+unit pawns:procedure;\r
+ var h:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ pawn(i).ple:=tab(g,i);\r
+ od;\r
+ pp:=0;\r
+ polepos:=true;\r
+ for i:=1 to 4 do home(i):=false; od;\r
+ for i:=1 to 4 do\r
+ h:=tab(g,i); \r
+ if h=0 then pp:=pp+1 fi;\r
+ if h=spp then polepos:=false fi;\r
+ if h>100 then home(h-100):=true fi;\r
+ od;\r
+ if pp=0 then polepos:=false fi;\r
+end pawns; \r
+ \r
+unit finish:function:boolean;\r
+ unit inhome:function(a:integer):boolean;\r
+ begin\r
+ result:=false;\r
+ if a>1 andif a<=eh andif a+kostka>eh then\r
+ if a+kostka-eh<5 andif not home(a+kostka-eh) then\r
+ result:=true;\r
+ pawn(i).mov:=true;\r
+ else\r
+ pawn(i).mov:=false; \r
+ fi;\r
+ else\r
+ pawn(i).mov:=true; \r
+ fi;\r
+ end inhome; \r
+ begin\r
+ result:=false;\r
+ for i:=1 to 4 do\r
+ pawn(i).fin:=false;\r
+ if pawn(i).ple>0 andif pawn(i).ple<99 then\r
+ if inhome(pawn(i).ple) then\r
+ result:=true;\r
+ pawn(i).fin:=true;\r
+ fi\r
+ else\r
+ pawn(i).mov:=false;\r
+ fi;\r
+ od;\r
+end finish;\r
+\r
+unit killer:function:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ pawn(i).kil:=false;\r
+ pawn(i).hun:=false;\r
+ j:=pawn(i).ple;\r
+ if j>0 andif j<50 then\r
+ j:=j+kostka;\r
+ if j>40 then j:=j-40 fi;\r
+ if stran(j)=/=0 then\r
+ if stran(j)=/=g then\r
+ pawn(i).hun:=true\r
+ else\r
+ pawn(i).kil:=true;\r
+ pawn(i).mov:=false;\r
+ result:=result+1;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ od; \r
+end killer;\r
+\r
+unit strangers:procedure;\r
+ begin\r
+ for i:=1 to 40 do stran(i):=0;od;\r
+ for i:=1 to 4 do \r
+ for j:=1 to 4 do\r
+ if tab(i,j)>0 andif tab(i,j)<50 then\r
+ stran(tab(i,j)):=i;\r
+ fi;\r
+ od;\r
+ od; \r
+end strangers;\r
+\r
+unit safety:procedure;\r
+ unit rafset:function(a:integer):integer;\r
+ var b,c,p:integer;\r
+ var finplo :boolean;\r
+ begin\r
+ if a>40 then a:=a mod 40 fi; \r
+ result:=0;\r
+ finplo:=false;\r
+ if a mod 10=1 then\r
+ if (a+9) div 10 =/=g then result:=1 fi;\r
+ fi;\r
+ for p:=1 to 6 do \r
+ if a = 1 then a:=40;\r
+ else a:=a-1;\r
+ fi;\r
+ b:=stran(a);\r
+ if a mod 10 =0 then finplo:=true fi;\r
+ if b=/=0 andif b=/=g then\r
+ if finplo then\r
+ c:=(((a-1) div 10)+2) mod 4;\r
+ if c=0 then c:=4 fi;\r
+ if c=/=g then result:=result+1 fi;\r
+ else \r
+ result:=result+1;\r
+ fi;\r
+ fi;\r
+ od; \r
+ end rafset;\r
+ begin\r
+ for i:=1 to 4 do\r
+ if pawn(i).ple>0 andif pawn(i).ple<99 then\r
+ pawn(i).saf:=rafset(pawn(i).ple);\r
+ pawn(i).rsa:=pawn(i).saf-rafset(pawn(i).ple+kostka);\r
+ else\r
+ pawn(i).saf:=6;\r
+ pawn(i).rsa:=-12; \r
+ fi;\r
+ od;\r
+end safety; \r
+ \r
+unit move:procedure;\r
+ var speed:boolean;\r
+ var moves:arrayof boolean;\r
+ begin\r
+ j:=-12;\r
+ \r
+ speed:=true;\r
+ array moves dim(1:4);\r
+ for i:=1 to 4 do\r
+ moves(i):=false;\r
+ if not pawn(i).kil andif pawn(i).hun then\r
+ moves(i):=true;\r
+ speed:=false;\r
+ fi\r
+ od;\r
+ for i:=1 to 4 do\r
+ if not pawn(i).kil andif pawn(i).ple>0 andif pawn(i).mov then\r
+ if speed orif moves(i) then\r
+ if pawn(i).rsa>j then \r
+ witch:=i;\r
+ j:=pawn(i).rsa\r
+ fi\r
+ fi\r
+ fi\r
+ od;\r
+ kill (moves);\r
+ if witch>4 then witch:=0 fi;\r
+end move;\r
+ \r
+begin\r
+ array pawn dim(1:4);\r
+ array home dim(1:4);\r
+ array stran dim(1:40);\r
+ for i:=1 to 4 do\r
+ pawn(i):=new man;\r
+ od;\r
+ return;\r
+ do\r
+ call pawns;\r
+ call strangers;\r
+ if finish then\r
+ for i:=1 to 4 do\r
+ if pawn(i).fin then witch:=i fi;\r
+ od;\r
+ else\r
+ if polepos and kostka=6 then\r
+ i:=1;\r
+ while tab(g,i)=/=0 do i:=i+1; od;\r
+ if i>4 then i:=4 fi;\r
+ witch:=i;\r
+ else\r
+ nrkil:=killer;\r
+ witch:=0;\r
+ if nrkil=/=4-pp then\r
+ call safety;\r
+ call move;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ call A.przesunpion(witch);\r
+ detach;\r
+od;\r
+end gracz1;\r
+(* * * * * *)\r
+\r
+ \r
+ unit gracz3:coroutine;\r
+\r
+ unit possible_pool:function(gracz,pion,kostka:integer):integer;\r
+ var beg,dom,i:integer,b:boolean;\r
+ begin\r
+ beg:=(gracz-1)*10+1;\r
+ if tab(gracz)(pion)=0 then \r
+ if kostka=6 then result:=beg;\r
+ else result:=0;\r
+ fi;\r
+ else \r
+ if tab(gracz)(pion)>=100 then result:=0;\r
+ else\r
+ if tab(gracz)(pion)<beg and tab(gracz)(pion)+kostka>=beg then\r
+ dom:=kostka+tab(gracz)(pion)+100;\r
+ for i:=1 to 4 do\r
+ b:=false;\r
+ if tab(gracz)(i)=dom then b:=true; fi;\r
+ if b then result:=0; else result:=100; fi;\r
+ od;\r
+ else\r
+ b:=false;\r
+ for i:=1 to 4 do\r
+ if i<>pion andif tab(gracz)(pion)+kostka=tab(gracz)(i) then \r
+ b:=true; \r
+ fi;\r
+ od;\r
+ if b then result:=0;\r
+ else result:=tab(gracz)(pion)+kostka;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end possible_pool;\r
+\r
+ unit inni_w_domu:function(gracz:integer):integer;\r
+ var i:integer;\r
+ begin\r
+ result:=0;\r
+ for i:=1 to 4 do \r
+ if tab(gracz)(i)>=100 then result:=result+1; \r
+ fi;\r
+ od;\r
+ end inni_w_domu;\r
+\r
+ unit inni_jeszcze_w_domu:function(gracz:integer):integer;\r
+ var i:integer;\r
+ begin\r
+ result:=0;\r
+ for i:=1 to 4 do \r
+ if tab(gracz)(i)=0 then result:=result+1;\r
+ fi;\r
+ od;\r
+ end inni_jeszcze_w_domu;\r
+\r
+ unit wyjscie_z_domu:function(pion:integer):integer;\r
+ begin\r
+ if tab(3)(pion)=0 and kostka=6 then result:=1; \r
+ else result:=0;\r
+ fi;\r
+ end wyjscie_z_domu;\r
+\r
+ unit state_of_player:function(player:integer):integer;\r
+ var i:integer;\r
+ begin\r
+ result:=0;\r
+ for i:=1 to 4 do\r
+ if tab(player,i)=0 then result:=result-1;\r
+ else \r
+ if tab(player,i)>=100 then result:=result+2;\r
+ fi;\r
+ fi;\r
+ od;\r
+ if result<0 then result:=0;\r
+ fi;\r
+ end state_of_player;\r
+ \r
+ unit pod_biciem:function(pool:integer):integer;\r
+ var i,j,k:integer;\r
+ begin\r
+ if pool=0 or pool>=100 then result:=0;\r
+ else\r
+ for i:=1 to 4 do\r
+ if i<>3 then\r
+ for j:=1 to 4 do\r
+ for k:=1 to 6 do\r
+ if possible_pool(i,j,k)=pool then result:=result+1;\r
+ fi;\r
+ od;\r
+ od;\r
+ fi;\r
+ od; \r
+ fi;\r
+ end pod_biciem;\r
+ \r
+ unit wyjscie_spod_bicia:function(pion:integer):integer;\r
+ var p,k:integer;\r
+ begin\r
+ p:=pod_biciem(tab(3)(pion));\r
+ if p>0 then\r
+ k:=pod_biciem(possible_pool(3,pion,kostka));\r
+ if p-k>0 then result:=p-k;\r
+ else\r
+ if p=k then result:=spodmn*p;\r
+ else result:=0;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end wyjscie_spod_bicia;\r
+\r
+ unit wejscie_pod_bicie:function(pion:integer):integer;\r
+ begin\r
+ result:=pod_biciem(possible_pool(3,pion,kostka));\r
+ end wejscie_pod_bicie;\r
+\r
+ unit bicie:function(pion:integer):integer;\r
+ var i,j,p:integer;\r
+ begin\r
+ result:=0;\r
+ p:=possible_pool(3,pion,kostka);\r
+ if p<100 then\r
+ for i:=1 to 4 do\r
+ if i<>3 then\r
+ for j:=1 to 4 do\r
+ if tab(i,j)=p then result:=state_of_player(i)*3;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ fi;\r
+ end bicie;\r
+\r
+ unit stoi_moj:function(pole:integer):boolean;\r
+ var pion:integer;\r
+ begin\r
+ result:=false;\r
+ for pion:=1 to 4 do \r
+ if tab(3,pion)=pole then result:=true; fi;\r
+ od;\r
+ end stoi_moj;\r
+\r
+ unit dom:function(pion:integer):integer;\r
+ begin\r
+ if tab(3)(pion)<100 and possible_pool(3,pion,kostka)>=100 then \r
+ result:=1;\r
+ else result:=0;\r
+ fi;\r
+ end dom;\r
+\r
+ var turniej:arrayof integer;\r
+ var ii,j:integer;\r
+ var spodmn,inni,innij:integer;\r
+\r
+ begin\r
+ array turniej dim(1:4);\r
+ spodmn:=2;\r
+ return;\r
+ do\r
+(* call A.gdziepiony; *)\r
+ for ii:=1 to 4 do turniej(ii):=0; od;\r
+ inni:=inni_w_domu(1);\r
+ inni:=inni+inni_w_domu(2);\r
+ inni:=inni+inni_w_domu(4);\r
+ innij:=inni_jeszcze_w_domu(1);\r
+ innij:=innij+inni_jeszcze_w_domu(2);\r
+ innij:=innij+inni_jeszcze_w_domu(4);\r
+ for ii:=1 to 4 do\r
+ turniej(ii):=turniej(ii)+dom(ii)*inni*3;\r
+ turniej(ii):=turniej(ii)+wyjscie_z_domu(ii)*(inni+innij);\r
+ turniej(ii):=turniej(ii)+bicie(ii);\r
+ turniej(ii):=turniej(ii)-wejscie_pod_bicie(ii);\r
+ turniej(ii):=turniej(ii)+wyjscie_spod_bicia(ii);\r
+ od;\r
+ for ii:=1 to 4 do\r
+ if possible_pool(3,ii,kostka)=0 \r
+ orif stoi_moj(possible_pool(3,ii,kostka)) \r
+ then turniej(ii):=-1; fi;\r
+ od;\r
+ j:=1;\r
+ for ii:=2 to 4 do\r
+ if turniej(ii)>turniej(j) then j:=ii;\r
+ fi;\r
+ if turniej(ii)=turniej(j) then \r
+ if tab(3)(ii)>tab(3)(j) then j:=ii;\r
+ fi;\r
+ fi;\r
+ od;\r
+ if turniej(j)>=0 then\r
+ call A.przesunpion(j);\r
+ fi;\r
+ detach;\r
+ od;\r
+ end gracz3;\r
+\r
+(***************************************************************)\r
+\r
+\r
+unit gracz4: coroutine;\r
+const g=4;\r
+const start=31;\r
+const endpos=30;\r
+\r
+var players : arrayof boy; \r
+\r
+unit boy:class;\r
+ var pos,back : integer;\r
+ var suicide,stab,finish,moveout : boolean;\r
+end boy;\r
+\r
+unit playerinit:procedure;\r
+var i:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ players(i).pos:=tab(g,i);\r
+ od;\r
+end playerinit;\r
+\r
+unit finishing:function(nr:integer):boolean;\r
+ var i,j:integer;\r
+ begin\r
+ result:=false;\r
+ i:=players(nr).pos;\r
+ if i<>0 \r
+ then \r
+ if i+kostka>endpos and i+kostka<endpos+5 and i<=endpos\r
+ then \r
+ result:=true;\r
+ for j:=1 to 4\r
+ do \r
+ if j <> nr \r
+ then\r
+ if (players(j).pos-100+1)=i+kostka-endpos\r
+ then result:=false;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ fi;\r
+end finishing;\r
+ \r
+unit suiciding:function(nr:integer):boolean;\r
+ var i:integer;\r
+ begin\r
+ result:=false;\r
+ if players(nr).pos<>0\r
+ then \r
+ for i:=1 to 4 \r
+ do\r
+ if nr<>i \r
+ then\r
+ if (players(nr).pos+kostka-1) mod 40 + 1 = players(i).pos \r
+ andif players(i).pos<100\r
+ then \r
+ result:=true;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od\r
+ else\r
+ for i:= 1 to 4\r
+ do\r
+ if i<>nr andif players(i).pos=start\r
+ then result:=true;\r
+ exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+end suiciding;\r
+ \r
+unit stabing:function(nr:integer):boolean;\r
+ var i,j:integer;\r
+ var b1,b2:boolean;\r
+ begin\r
+ result:=false;\r
+ for i:=1 to 4\r
+ do\r
+ if i<>g \r
+ then\r
+ for j:= 1 to 4\r
+ do\r
+ if players(nr).pos > 0 and players(nr).pos <100\r
+ then\r
+ b1:=(players(nr).pos+kostka-1) mod 40 +1 =tab(i,j) ;\r
+ b2:=players(nr).pos>=start and b1;\r
+ if b1 and (players(nr).pos+kostka-1) mod 40 + 1<=endpos orif b2 \r
+ then\r
+ result:=true;\r
+ exit exit;\r
+ fi\r
+ else\r
+ result:=(kostka=6 and players(nr).pos=0 and tab(i,j)=start);\r
+ exit exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+end stabing; \r
+\r
+unit atback:function(nr:integer):integer;\r
+ var i,j,np:integer;\r
+ begin\r
+ np:=players(nr).pos;\r
+ result:=0;\r
+ if np<>0\r
+ then \r
+ if np < 7 \r
+ then\r
+ for i:=1 to 4 \r
+ do \r
+ if i<>g \r
+ then \r
+ for j:=1 to 4\r
+ do\r
+ if (tab(i,j) < np)\r
+ then\r
+ if tab(i,j)>0\r
+ then result:=result+1;\r
+ fi\r
+ else \r
+ if tab(i,j) > 40-(6-np)\r
+ then result:=result+1;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ else\r
+ for i:=1 to 4\r
+ do\r
+ if i<>g\r
+ then\r
+ for j:=1 to 4\r
+ do\r
+ if tab(i,j) < np\r
+ andif tab(i,j) > np-7\r
+ then result:=result +1;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od; \r
+ fi;\r
+ fi;\r
+ end atback;\r
+ \r
+ unit begining : function(nr:integer):boolean;\r
+ begin\r
+ result:=players(nr).pos=0 and kostka=6;\r
+ end begining;\r
+ \r
+ unit move:function:integer;\r
+ var i,j,k : integer;\r
+ var ok:boolean;\r
+ begin\r
+ for i:= 1 to 4\r
+ do\r
+ players(i).back:=atback(i);\r
+ players(i).suicide:=suiciding(i);\r
+ players(i).stab:=stabing(i);\r
+ players(i).finish:=finishing(i);\r
+ players(i).moveout:=begining(i);\r
+ od;\r
+ ok:=false;\r
+ (********************* bije i wychodzi ************)\r
+ for i:=1 to 4\r
+ do \r
+ if players(i).moveout \r
+ then\r
+ for j:=1 to 4\r
+ do\r
+ if g<>j \r
+ then\r
+ for k:=1 to 4 \r
+ do\r
+ if tab(j,k)=start\r
+ then \r
+ result:=i;\r
+ ok:=true; exit exit exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ (******************** gonia go i konczy **************)\r
+ if not ok \r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos>0\r
+ andif players(i).pos<100\r
+ andif players(i).finish \r
+ andif players(i).back > 0\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************** gonia go i bije ******************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).back>0\r
+ andif players(i).stab\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* bije ********************************)\r
+ if not ok \r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ if players(i).stab\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************** goni go conajmniej dwoch **********)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).back>=2\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* wychodzi ****************************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).moveout\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ (******************* konczy *******************************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).finish\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+\r
+ (******************** gonia go **********)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).pos>0\r
+ andif players(i).back>0\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi; \r
+ (******************* nie bije swojego *********************)\r
+ if not ok \r
+ then\r
+ for i:=4 downto 1\r
+ do\r
+ if players(i).pos<100\r
+ andif players(i).pos>0\r
+ andif not players(i).suicide\r
+ then\r
+ result:=i;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ (******************* bije swojego *********************)\r
+ if not ok \r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if players(i).suicide\r
+ then\r
+ result := 0 ;\r
+ ok:=true; exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ \r
+ if not ok then result:=0 fi; \r
+\r
+\r
+ end move;\r
+ \r
+\r
+ \r
+ \r
+ \r
+ \r
+ (****** MAIN *****)\r
+ (*****************)\r
+var aa:char;\r
+\r
+ var i,m:integer;\r
+ begin\r
+ array players dim(1:4);\r
+ for i:=1 to 4 \r
+ do\r
+ players(i):=new boy;\r
+ od;\r
+ return;\r
+ do\r
+ call playerinit;\r
+ m:=move;\r
+ call A.przesunpion(m);\r
+ \r
+ detach;\r
+ od;\r
+end gracz4;\r
+ \r
+ \r
+ (********* * * * * * * * * * * * *************)\r
+ \r
+\r
+ unit arbiter:iiuwgraph coroutine;\r
+ \r
+ var x,y,zawod,i,j,ktory,sk : integer;\r
+ var polestartu,skon,zero,wejscie,plansza: arrayof integer;\r
+ var dom,old,tabcub : arrayof arrayof integer;\r
+ var tabpi : arrayof arrayof arrayof integer; \r
+ var dtab : arrayof arrayof string; \r
+ var ctabs : arrayof string;\r
+ \r
+ const c=1.3;\r
+(********** plan **************)\r
+ \r
+ unit line:class(x1,y1,x2,y2:integer);\r
+ end line;\r
+ \r
+ unit inchar : function: integer;\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit OUTHLINE: procedure(b:string);\r
+ var i,j:integer;\r
+ var a :arrayof char;\r
+ \r
+ begin\r
+ a:=unpack(b);\r
+ i:=upper(a);\r
+ for j:=1 to i do\r
+ call hascii(0);\r
+ call hascii(ord(a(j)));\r
+ od;\r
+ kill (a); \r
+ end outhline; \r
+ unit sdrp:procedure(a,b,c,d:integer);\r
+ begin\r
+ call move(a,c);\r
+ call draw(b,c);\r
+ call draw(b,d);\r
+ call draw(a,d);\r
+ call draw(a,c);\r
+ end sdrp \r
+\r
+ unit sdrp1:procedure;\r
+ begin\r
+ call sdrp(45,76,23,49);\r
+ call move(76,23);\r
+ call draw(80,26);\r
+ call draw(80,52);\r
+ call draw(49,52);\r
+ call draw(45,49);\r
+ end sdrp1; \r
+\r
+ unit sdrp2:procedure;\r
+ begin\r
+ call sdrp(48,82,23,49); \r
+ call move(82,49);\r
+ call draw(78,52);\r
+ call draw(44,52);\r
+ call draw(44,26);\r
+ call draw(48,23);\r
+ end sdrp2;\r
+ \r
+ unit sdrp3:procedure;\r
+ begin\r
+ call sdrp(48,82,26,52); \r
+ call move(48,52);\r
+ call draw(44,49);\r
+ call draw(44,23);\r
+ call draw(78,23);\r
+ call draw(82,26);\r
+ end sdrp3;\r
+ \r
+ unit sdrp4:procedure;\r
+ begin\r
+ call sdrp(45,76,26,52); \r
+ call move(45,26);\r
+ call draw(49,23);\r
+ call draw(80,23);\r
+ call draw(80,49);\r
+ call draw(76,52);\r
+ end sdrp4; \r
+ \r
+ \r
+ unit drp1:procedure(a,b:integer,t:arrayof string);\r
+ begin \r
+ call move(a,b);\r
+ call outhline(t(1)); \r
+ call move(a,b+8);\r
+ call outhline(t(2));\r
+ call move(a,b+16);\r
+ call outhline(t(3));\r
+ end drp1 \r
+ \r
+ unit drp11:procedure(d:integer);\r
+ begin\r
+ call sdrp1;\r
+ call drp1(51,25,dtab(d));\r
+ end;\r
+ \r
+ unit drp21:procedure(d:integer);\r
+ begin\r
+ call sdrp2;\r
+ call drp1(53,25,dtab(d));\r
+ end;\r
+\r
+ unit drp31:procedure(d:integer);\r
+ begin\r
+ call sdrp3;\r
+ call drp1(53,28,dtab(d));\r
+ end;\r
+\r
+ unit drp41:procedure(d:integer);\r
+ begin\r
+ call sdrp4;\r
+ call drp1(51,28,dtab(d));\r
+ end;\r
+ \r
+ unit mktab:procedure;\r
+ var i,j:integer;\r
+ begin\r
+ array tabpi dim(1:4);\r
+ for i:=1 to 4 do\r
+ array tabpi(i) dim(1:4);\r
+ for j:=1 to 4 do\r
+ array tabpi(i,j) dim(1:200);\r
+ od;\r
+ od;\r
+ for i:=1 to 4 do \r
+ call cls;\r
+ call drp11(i);\r
+ call move(43,22);\r
+ tabpi(i,1):=getmap(84,54);\r
+ od;\r
+ \r
+ for i:=1 to 4 do \r
+ call cls;\r
+ call drp21(i);\r
+ call move(43,22);\r
+ tabpi(i,2):=getmap(84,54);\r
+ od;\r
+ \r
+ for i:=1 to 4 do \r
+ call cls;\r
+ call drp31(i);\r
+ call move(43,22);\r
+ tabpi(i,3):=getmap(84,54);\r
+ od;\r
+ \r
+ for i:=1 to 4 do \r
+ call cls;\r
+ call drp41(i);\r
+ call move(43,22);\r
+ tabpi(i,4):=getmap(84,54);\r
+ od;\r
+ end mktab; \r
+\r
+ unit piszpion:coroutine(x,y,k:integer);\r
+ var i,j:integer;\r
+ begin\r
+ return;\r
+ do\r
+ call move(x,y);\r
+ for i:=1 to 2 do\r
+ call putmap(tabpi(ktory,k));\r
+ for j:=1 to 30 do od;\r
+ call putmap(zero);\r
+ for j:=1 to 30 do od;\r
+ od;\r
+ call putmap(tabpi(ktory,k));\r
+ detach;\r
+ od;\r
+ end piszpion; \r
+var pl:arrayof arrayof arrayof piszpion;\r
+\r
+ \r
+ unit mkpl:procedure;\r
+ var a,b,c,i,j:integer; \r
+ \r
+ begin\r
+ array pl dim(0:104);\r
+ array pl(0) dim(1:4);\r
+ for i:=1 to 4 do\r
+ array pl(0,i) dim (1:4);\r
+ array pl(100+i) dim (1:4);\r
+ for j:=1 to 4 do\r
+ array pl(100+i,j) dim (1:1);\r
+ od;\r
+ od;\r
+ for i:=1 to 40 do\r
+ array pl(i) dim(1:1);\r
+ array pl(i,1) dim(1:1);\r
+ od;\r
+\r
+open(f,integer,unpack("pola"));\r
+call reset(f);\r
+\r
+for i:=1 to 40 do\r
+get(f,a);\r
+get(f,b);\r
+get(f,c);\r
+pl(i,1,1):=new piszpion(a,b,c);\r
+od;\r
+\r
+for i:=1 to 4 do\r
+for j:=1 to 4 do\r
+get(f,a);\r
+get(f,b);\r
+get(f,c);\r
+pl(0,i,j):=new piszpion(a,b,c);\r
+od;\r
+od;\r
+\r
+for i:=1 to 4 do\r
+for j:=101 to 104 do\r
+get(f,a);\r
+get(f,b);\r
+get(f,c);\r
+pl(j,i,1):=new piszpion(a,b,c);\r
+od;\r
+od;\r
+\r
+end mkpl; \r
+ unit sq:procedure(x,y:integer);\r
+ begin\r
+ call move(c*(x+1)+40,20+y+1);\r
+ call draw(c*(x+35)+40,20+y+1);\r
+ call draw(c*(x+35)+40,20+y+35);\r
+ call draw(c*(x+1)+40,20+y+35);\r
+ call draw(c*(x+1)+40,20+y+1);\r
+ end sq;\r
+ \r
+ unit cube:procedure;\r
+ begin\r
+ call move(0,8);\r
+ call draw(32,8);\r
+ call draw(32,34);\r
+ call draw(0,34);\r
+ call draw(0,8);\r
+ call draw(10,0);\r
+ call draw(41,0);\r
+ call draw(32,8);\r
+ call move(41,0);\r
+ call draw(41,26);\r
+ call draw(32,34);\r
+ end;\r
+ \r
+ unit cubes:procedure(i,a,b,c:integer);\r
+ begin\r
+ call cube;\r
+ call move(4,9);\r
+ call outhline(ctabs(a));\r
+ call move(4,17);\r
+ call outhline(ctabs(b));\r
+ call move(4,25);\r
+ call outhline(ctabs(c));\r
+ call move(0,0);\r
+ tabcub(i):=getmap(41,34);\r
+ call cls;\r
+ end cubes; \r
+ \r
+ unit cu:procedure(i,j:integer);\r
+ begin\r
+ call move(310,70);\r
+ call outhline("PLAYER : ");\r
+ case j \r
+ when 1: call outhline("1");\r
+ when 2: call outhline("2");\r
+ when 3: call outhline("3");\r
+ when 4: call outhline("4");\r
+ esac; \r
+ call move(360,80); \r
+ call putmap(tabcub(i));\r
+ end cu;\r
+ \r
+ unit hjm:procedure(nw:arrayof arrayof integer);\r
+ var i,j,x:integer;\r
+ var z:string;\r
+ unit drp:procedure(i,j:integer);\r
+ var b1,b2:boolean;\r
+ begin\r
+ b1:=old(i,j)=0;\r
+ if not b1 then b2:=plansza(old(i,j))=0 fi;\r
+ if b2 or b1 then\r
+ if b1 then\r
+ attach(pl(0,i,j));\r
+ else \r
+ attach(pl(old(i,j),1,1));\r
+ fi; \r
+ call putmap(zero); fi;\r
+ if nw(i,j)=0 then x:=ktory;\r
+ ktory:=i;\r
+ attach(pl(0,i,j));\r
+ ktory:=x;\r
+ else\r
+ if nw(i,j)>100 then attach(pl(nw(i,j),i,1));\r
+ else attach(pl(nw(i,j),1,1));\r
+ fi;\r
+ fi;\r
+ end drp; \r
+ begin\r
+ i:=ktory;\r
+ do\r
+ for j:=1 to 4 do\r
+ if old(i,j)<>nw(i,j) then call drp(i,j); fi;\r
+ old(i,j):=nw(i,j);\r
+ od;\r
+ i:=i mod 4 +1;\r
+ if i=ktory then exit fi;\r
+ od;\r
+ end;\r
+ \r
+ unit drpl:procedure;\r
+ var i,x,y,x1,x2,y1,y2:integer;\r
+ begin\r
+ call gron(1); \r
+ open(f,integer,unpack("plan"));\r
+ call reset(f);\r
+ for i:=1 to 47 do\r
+\r
+ get(f,x1);\r
+ get(f,y1);\r
+ call move(x1,y1);\r
+ get(f,x2);\r
+ get(f,y2);\r
+ call draw(x2,y2);\r
+\r
+ \r
+ x:=735-x1;\r
+ y:=y1;\r
+ call move(x,y);\r
+ x:=735-x2;\r
+ y:=y2;\r
+ call draw(x,y);\r
+ \r
+ x:=735-x1;\r
+ y:=328-y1;\r
+ call move(x,y);\r
+ x:=735-x2;\r
+ y:=328-y2;\r
+ call draw(x,y);\r
+ \r
+ x:=x1;\r
+ y:=328-y1;\r
+ call move(x,y);\r
+ x:=x2;\r
+ y:=328-y2;\r
+ call draw(x,y);\r
+ \r
+ od;\r
+ \r
+ end drpl;\r
+ \r
+ unit starter:procedure;\r
+ var i,j:integer;\r
+ begin\r
+ array zero dim(1:1300);\r
+ call gron(1);\r
+ call move(0,0);\r
+ zero:=getmap(42,32);\r
+ call cubes(1,1,2,1);\r
+ call cubes(2,3,1,4);\r
+ call cubes(3,3,2,4);\r
+ call cubes(4,5,1,5);\r
+ call cubes(5,5,2,5);\r
+ call cubes(6,5,5,5);\r
+ call mktab;\r
+ call mkpl;\r
+ call drpl;\r
+ call sq(72,0);\r
+ call sq(395,36);\r
+ call sq(395,252);\r
+ call sq(72,216);\r
+ for i:=1 to 4 do\r
+ for j:=1 to 4 do\r
+ ktory:=i;\r
+ attach(pl(0,i,j));\r
+ od;\r
+ od;\r
+ i:=inchar;\r
+ \r
+ end starter;\r
+ \r
+(************** end plan ***********)\r
+\r
+ \r
+ unit przesunpion:procedure(co:integer);\r
+ var g,s,t:integer;\r
+ \r
+ unit start:procedure;\r
+ begin\r
+ g:=polestartu(ktory);\r
+ tab(ktory,co):=g;\r
+ if plansza(g)=/=0 then\r
+ tab((plansza(g)/10),(plansza(g) mod 10)):=0;\r
+ fi;\r
+ plansza(g):=ktory*10+co;\r
+ end start;\r
+ begin\r
+ if co<1 orif co>4 then return fi;\r
+ if ktory<1 orif ktory>4 then return fi;\r
+ s:=tab(ktory,co);\r
+ g:=s+kostka;\r
+ if s>100 then return fi;\r
+ if s=0 then \r
+ if kostka=6 then call start fi;\r
+ return; \r
+ fi;\r
+ t:=wejscie(ktory);\r
+ if s<=t andif g>t then\r
+ t:=g-t;\r
+ if t<5 andif dom(ktory,t)=0 then\r
+ dom(ktory,t):=co;\r
+ tab(ktory,co):=100+t;\r
+ plansza(s):=0;\r
+ fi;\r
+ return;\r
+ else\r
+ if g>40 then g:=g-40 fi;\r
+ if plansza(g)=/=0 then\r
+ tab((plansza(g)/10),(plansza(g) mod 10)):=0;\r
+ fi;\r
+ tab(ktory,co):=g;\r
+ plansza(g):=plansza(s);\r
+ plansza(s):=0;\r
+ fi;\r
+ end przesunpion;\r
+ \r
+ unit koniec: function: boolean;\r
+ var doszedl: boolean;\r
+ begin\r
+ doszedl:=true;\r
+ for i:=1 to 4\r
+ do\r
+ if dom(ktory,i)=0 then\r
+ doszedl:=false;exit\r
+ fi\r
+ od;\r
+ if doszedl then\r
+ sk:=sk+1;\r
+ skon(ktory):=sk;\r
+ fi;\r
+ result:= sk=4\r
+ end koniec; \r
+ \r
+ unit komunikat: procedure;\r
+ var m: arrayof integer;\r
+ begin\r
+ array m dim (1:4);\r
+ for i:=1 to 4 do\r
+ m(skon(i)):=i;\r
+ od; \r
+ call groff;\r
+ writeln;\r
+ for i:=1 to 4 do\r
+ writeln (i:1," miejsce zajal gracz ",m(i):1)\r
+ od\r
+ end komunikat;\r
+\r
+begin (* arbiter *)\r
+ array tab dim (1:4);\r
+ array old dim (1:4);\r
+ array dom dim (1:4);\r
+ array ctabs dim (1:5);\r
+ array tabcub dim (1:6);\r
+ array plansza dim (1:40);\r
+ array skon dim (1:4);\r
+ array wejscie dim (1:4);\r
+ array polestartu dim (1:4);\r
+ array dtab dim(1:4);\r
+ for i:=1 to 4\r
+ do\r
+ skon(i):=0;\r
+ array tabcub(i) dim(1:200);\r
+ array dtab(i) dim (1:3);\r
+ array tab(i) dim (1:4);\r
+ array old(i) dim (1:4);\r
+ array dom(i) dim (1:4);\r
+ polestartu(i):=10*(i-1)+1;\r
+ wejscie(i):=polestartu(i)-1;\r
+ od;\r
+ wejscie(1):=40;\r
+ for i:=5 to 6 do\r
+ array tabcub(i) dim(1:200);\r
+ od;\r
+ ctabs(1):=" "; \r
+ ctabs(2):=" * ";\r
+ ctabs(3):="* ";\r
+ ctabs(4):=" *";\r
+ ctabs(5):="* *";\r
+ dtab(1,1):=" 1 "; \r
+ dtab(1,2):=" 1 ";\r
+ dtab(1,3):=" 1 ";\r
+ dtab(2,1):="2 "; \r
+ dtab(2,2):=" 2 ";\r
+ dtab(2,3):=" 2";\r
+ dtab(3,1):=" 3";\r
+ dtab(3,2):=" 3 ";\r
+ dtab(3,3):="3 ";\r
+ dtab(4,1):=" "; \r
+ dtab(4,2):="444";\r
+ dtab(4,3):=" ";\r
+\r
+ return;\r
+ call starter;\r
+ ktory:=0;\r
+ do\r
+ ktory:= (ktory mod 4) + 1;\r
+ if skon(ktory)=/=0 then repeat fi;\r
+ do\r
+ kostka:=entier(random*6)+1;\r
+ call cu(kostka,ktory);\r
+ attach (gracz(ktory));\r
+ call hjm(tab);\r
+ if koniec then exit exit fi;\r
+ if kostka=/=6 or skon(ktory)=/=0 then exit fi\r
+ od\r
+ od;\r
+ call komunikat;\r
+ read (i);\r
+ call endrun\r
+end arbiter;\r
+\r
+ var A: arbiter; \r
+(* * * * * *) \r
+begin (* program glowny *)\r
+array gracz dim (1:4);\r
+writeln ("Type how many PLAYERS want to enjoy game");\r
+read(ia);\r
+for i:=1 to ia do\r
+gracz(i) := new player(i);\r
+od;\r
+if ia=0 then ia:=1;gracz(1):=new gracz1(1,40,1); fi;\r
+for i:=ia+1 to 2 do\r
+gracz(i) := new gracz1(i,(i-1)*10,i*10-9);\r
+od;\r
+gracz(3):=new gracz3;\r
+gracz(4):=new gracz4;\r
+A := new arbiter;\r
+attach (A)\r
+end chinczyk \r
+\1a
\ No newline at end of file
--- /dev/null
+program bank22;\r
+\r
+ UNIT PRIORITYQUEUE: CLASS;\r
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+\r
+\r
+\r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+\r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+\r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+\r
+ UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+\r
+ UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+\r
+ END QUEUEHEAD;\r
+\r
+\r
+ UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+\r
+ \r
+ UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+\r
+\r
+ END PRIORITYQUEUE;\r
+\r
+\r
+ \r
+ UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+ (* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+\r
+\r
+ UNIT SIMPROCESS: COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+\r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+\r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+\r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+\r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ BEGIN\r
+\r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+\r
+\r
+ UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+\r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+\r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+\r
+ UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+ UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+\r
+ UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+ UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)\r
+ (* WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+ END SCHEDULE;\r
+\r
+ UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+ UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+\r
+ UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+ END RUN;\r
+\r
+ UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+\r
+ UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN\r
+ WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+ END CHOICEPROCESS;\r
+\r
+ BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+ END SIMULATION;\r
+\r
+\r
+ \r
+ UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+\r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE FI;\r
+ END;\r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+\r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT:PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+\r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI FI;\r
+ END INTO;\r
+ END LINK;\r
+\r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+\r
+ END LISTS;\r
+\r
+\r
+ unit numero : class(val : real;choix:integer);\r
+ var next : numero;\r
+ end numero;\r
+ \r
+ unit liste : class;\r
+ var tete, queue : numero;\r
+ \r
+ \r
+ unit listevide : function : boolean;\r
+ begin\r
+ if tete = NONE then result := true fi\r
+ end listevide;\r
+ \r
+ unit supprime : procedure(inout valeur:real;inout choix:integer);\r
+ var aux : numero;\r
+ begin\r
+ if listevide then \r
+ valeur:=-1;\r
+ choix:=0;\r
+ else \r
+ valeur:=tete.val;\r
+ choix:=tete.choix;\r
+ aux := tete;\r
+ tete := tete.next;\r
+ kill(aux);\r
+ fi\r
+ end supprime;\r
+\r
+\r
+ unit ajout : procedure(e : real;choix:integer);\r
+ var aux : numero;\r
+ begin\r
+ if listevide then tete, queue := new numero(e,choix)\r
+ else aux := new numero(e,choix);\r
+ queue.next := aux;\r
+ queue := aux\r
+ fi\r
+ end ajout;\r
+ \r
+ unit member : function(e : integer) : boolean;\r
+ var aux : numero;\r
+ begin\r
+ if listevide then exit fi;\r
+ aux := tete;\r
+ do if aux = NONE then exit fi;\r
+ if aux.val = e then result := true;\r
+ exit\r
+ else aux := aux.next\r
+ fi\r
+ od\r
+ end member;\r
+ \r
+ unit delliste : procedure;\r
+ var aux : numero;\r
+ begin\r
+ do if listevide then exit fi;\r
+ aux := tete.next;\r
+ kill(tete);\r
+ tete := aux\r
+ od\r
+ end delliste;\r
+ end liste;\r
+\r
+\r
+\r
+ unit station : LISTS class;\r
+ unit prioritaire:procedure;\r
+ var\r
+ i,min:integer;\r
+ begin\r
+ min:=contenu(1);\r
+ numero_prioritaire:=1;\r
+ for i:=2 to nombre_machine\r
+ do\r
+ if( contenu(i)<min )\r
+ then\r
+ min:=contenu(i);\r
+ numero_prioritaire:=i\r
+ fi;\r
+ od;\r
+ end prioritaire;\r
+ unit arrivee_client:simprocess class(nombre_machine,nombre_client:integer);\r
+ var i:integer,\r
+ r:real;\r
+ begin\r
+ for i:=1 to nombre_client\r
+ do\r
+ if( random*10 < 10 )\r
+ then\r
+ (* choix machine *)\r
+ call prioritaire;\r
+ writeln("ARRIVEE : nouveau client sur machine ",\r
+ numero_prioritaire);\r
+ r:=random;\r
+ if( r*10 < 3 )\r
+ then\r
+ call l(numero_prioritaire).ajout(time,1);\r
+ fi;\r
+ if( r*10 >= 3 ) AND (r*10 < 6 )\r
+ then\r
+ call l(numero_prioritaire).ajout(time,2);\r
+ fi;\r
+ if( r*10 >= 6 )\r
+ then\r
+ call l(numero_prioritaire).ajout(time,3);\r
+ fi;\r
+\r
+ contenu(numero_prioritaire):=contenu(numero_prioritaire)+1;\r
+ call hold((nombre_machine+1)*base_temps);\r
+ else\r
+ i:=i-1;\r
+ fi;\r
+ od;\r
+ termine:=1;\r
+ writeln("ARRIVEE : FIN DES ARRIVEES");\r
+ do\r
+ call hold((nombre_machine+1)*base_temps);\r
+ od;\r
+ end arrivee_client;\r
+\r
+ unit machine:simprocess class(base_temps,numero:integer);\r
+ var\r
+ total,nombre,heure,valeur:real,\r
+ choix:integer;\r
+ begin\r
+ total:=0;\r
+ nombre:=0;\r
+ while( ( termine = 0 ) OR ( not l(numero).listevide) )\r
+ do\r
+ if( not l(numero).listevide )\r
+ then\r
+ writeln("MACHINE nø",numero," : mise en marche. ");\r
+ heure:=time;\r
+ call l(numero).supprime(valeur,choix);\r
+ writeln("MACHINE nø",numero," : client arrive a ",valeur);\r
+ writeln("MACHINE nø",numero," : client servit a ",heure);\r
+ total:=total+(heure-valeur);\r
+ nombre:=nombre+1;\r
+ nbre_client(numero):=nbre_client(numero)+1;\r
+ writeln(" MMMMMMMMMMMMMMMMMMMMMMMMM choix :",choix);\r
+ if( choix > 1 )\r
+ then\r
+ (* prelavage *)\r
+ writeln(" MACHINE nø",numero," : prelavage de la voiture ",\r
+ nombre);\r
+ call hold(5*(nombre_machine+1)*base_temps);\r
+ fi;\r
+\r
+ (* lavage *)\r
+ writeln(" MACHINE nø",numero," : lavage de la voiture ",nombre);\r
+ call hold(10*(nombre_machine+1)*base_temps);\r
+ if( choix > 2 )\r
+ then\r
+ (* lustrage *)\r
+ writeln(" MACHINE nø",numero," : lustrage de la voiture ",\r
+ nombre);\r
+ call hold(10*(nombre_machine+1)*base_temps);\r
+ fi;\r
+\r
+ (* rincage *)\r
+ writeln(" MACHINE nø",numero," : rincage de la voiture ",nombre);\r
+ contenu(numero):=contenu(numero)-1;\r
+ call prioritaire;\r
+\r
+ fi;\r
+ call hold(5*(nombre_machine+1)*base_temps);\r
+ od;\r
+ if( nombre <> 0 )\r
+ then\r
+ writeln("MACHINE nø",numero," : mise a jour resultat -->",total/nombre);\r
+ resultat(numero):=total/nombre;\r
+ fi;\r
+ fini:=fini+1;\r
+ writeln("MACHINE nø",numero," ARRET DE LA MACHINE");\r
+ do\r
+ call hold((nombre_machine+1)*base_temps);\r
+ od;\r
+ end machine;\r
+\r
+ end station;\r
+\r
+ var\r
+ l:arrayof liste,\r
+ k,termine,numero_prioritaire:integer,\r
+ contenu:arrayof integer,\r
+ fini,nombre_machine,nombre_client,numero_machine:integer,\r
+ resultat:arrayof real,\r
+ moyenne,base_temps,base_temps2:real,\r
+ nbre_client:arrayof integer;\r
+ begin \r
+ PREF station BLOCK\r
+\r
+ UNIT GENERATOR:SIMPROCESS CLASS;\r
+\r
+ BEGIN\r
+ for k:=1 to nombre_machine\r
+ DO\r
+ CALL SCHEDULE(NEW machine(base_temps,k),TIME+k*base_temps);\r
+ OD;\r
+ CALL SCHEDULE(NEW arrivee_client(nombre_machine,nombre_client),\r
+ TIME+k*base_temps);\r
+\r
+ END GENERATOR;\r
+ BEGIN\r
+ write("MAIN : donner le nombre de machines:");\r
+ readln(nombre_machine);\r
+ write("MAIN : donner le nombre de clients:");\r
+ readln(nombre_client);\r
+ write("MAIN : donner la base de temps:");\r
+ readln(base_temps);\r
+ write("MAIN : donner la tempo du main:");\r
+ readln(base_temps2);\r
+\r
+ fini:=0;\r
+ numero_prioritaire:=1;\r
+ array nbre_client dim(1:nombre_machine);\r
+ array contenu dim(1:nombre_machine);\r
+ array l dim (1:nombre_machine);\r
+ array resultat dim (1:nombre_machine);\r
+ for k:=1 to nombre_machine\r
+ do\r
+ l(k):=new liste;\r
+ od;\r
+\r
+ for k:=1 to nombre_machine\r
+ do\r
+ resultat(k):=0.0;\r
+ contenu(k):=0;\r
+ nbre_client(k):=0;\r
+ od;\r
+\r
+ CALL SCHEDULE(NEW GENERATOR,TIME);\r
+\r
+ while (fini<nombre_machine) \r
+ do\r
+ call hold(base_temps2);\r
+ od;\r
+ moyenne:=0;\r
+ for k:=1 to nombre_machine\r
+ do\r
+ writeln("MAIN: resultat machine numero ",k," = ",resultat(k));\r
+ writeln("MAIN : nombre de client machine numero ",k," = ",\r
+ nbre_client(k));\r
+ moyenne:=moyenne+resultat(k);\r
+ od;\r
+ writeln("MAIN : le temps d'attente moyen pour laver sa voiture est ",\r
+ moyenne/nombre_machine);\r
+ end;\r
+ END;\r
+end bank22;\r
+\r
--- /dev/null
+program projet;\r
+var i,j:integer,\r
+ h,v:char;\r
+ (* Les variables h et v sont utilis\82es pour comparer le sens des segments*)\r
+begin\r
+\r
+(************************************************************)\r
+h:='h';(* Initialisation des variables h et v *)\r
+v:='v';\r
+pref iiuwgraph block\r
+var t,tab:arrayof segment;(* Le tableau tab contient les segments saisis soit \r
+au clavier, soit \85 l'aide de la souris ou soit cr\82er al\82atoirement, et le \r
+tableau t est le r\82sultat du tri de tab suivant les ordonn\82es (et les abscisses\r
+si les ordonn\82es sont \82gales *)\r
+\r
+(************************************************************)\r
+(* Les fonctions de convertion des abscisses et des ordonn\82es\r
+en entier(pixel) (xconv_en_entier,yconx_en_entier) ou en r\82el\r
+(yconv_en_reel,xconv_en_reel) *)\r
+\r
+unit xconv_en_entier:function(x:real):integer;\r
+begin\r
+ result:=entier(40+20*x);\r
+end xconv_en_entier;\r
+\r
+unit yconv_en_entier:function(y:real):integer;\r
+begin\r
+ result:=entier(210-20*y);\r
+end yconv_en_entier;\r
+\r
+unit xconv_en_reel:function(x:integer):real;\r
+begin\r
+ result:=(x-40)/20;\r
+end xconv_en_reel;\r
+\r
+unit yconv_en_reel:function(y:integer):real;\r
+begin\r
+ result:=(210-y)/20;\r
+end yconv_en_reel;\r
+\r
+(************************************************************)\r
+(* La structure de la classe segment, la procedure saisie utile pour\r
+la procedure clavier *)\r
+\r
+unit segment:class;\r
+ var sens:char,\r
+ x1,x2,y1,y2:real;\r
+ (* La procedure saisie n'est utilis\82e que si les segments sont saisis\r
+ au clavier *)\r
+ unit saisie:procedure(input sens:char;inout x1,y1,x2,y2:real);\r
+ var i,k:integer,j:real,\r
+ b:boolean;\r
+ begin\r
+ if sens=h then\r
+ call move(40,290);\r
+ call outstring("entrer la valeur de l'ordonn\82e : Y= ");\r
+ i:=inkey;j:=1.0;k:=0;y1:=0.0;b:=false;\r
+ while i<>13\r
+ do\r
+ call hascii(i);\r
+ call move(350+7*k,290);\r
+ if i<>46 then\r
+ y1:=10*y1+i-48;\r
+ fi;\r
+ k:=k+1;\r
+ if b then j:=j/10.0 fi;\r
+ if i=46 then b:=true fi;\r
+ i:=inkey;\r
+ od;\r
+ y1:=y1*j;if y1>10.0 then y1:=10.0 fi;\r
+ call move(40,310);\r
+ call outstring("entrer la valeur de l'abscisse1 : X1= ");\r
+ i:=inkey;j:=1.0;k:=0;x1:=0.0;b:=false;\r
+ while i<>13\r
+ do\r
+ call hascii(i);\r
+ call move(350+7*k,310);\r
+ if i<>46 then\r
+ x1:=10*x1+i-48;\r
+ fi;\r
+ k:=k+1;\r
+ if b then j:=j/10.0 fi;\r
+ if i=46 then b:=true fi;\r
+ i:=inkey;\r
+ od;\r
+ x1:=x1*j;\r
+ call move(40,330);\r
+ call outstring("entrer la valeur de l'abscisse2 : X2= ");\r
+ i:=inkey;j:=1.0;k:=0;x2:=0.0;b:=false;\r
+ while i<>13\r
+ do\r
+ call hascii(i);\r
+ call move(350+7*k,330);\r
+ if i<>46 then\r
+ x2:=10*x2+i-48;\r
+ fi;\r
+ k:=k+1;\r
+ if b then j:=j/10.0 fi;\r
+ if i=46 then b:=true fi;\r
+ i:=inkey;\r
+ od;\r
+ x2:=x2*j;\r
+ if x1>x2 then\r
+ y2:=x1;x1:=x2;x2:=y2;\r
+ fi;\r
+ y2:=y1;if x2>28.0 then x2:=28.0 fi;if x1>28.0 then x1:=28 fi;\r
+ call move(xconv_en_entier(x1),yconv_en_entier(y1));\r
+ call draw(xconv_en_entier(x2),yconv_en_entier(y2));\r
+ else\r
+ if sens=v then\r
+ call move(40,290);\r
+ call outstring("entrer la valeur de l'abscisse : X= ");\r
+ i:=inkey;j:=1.0;k:=0;x1:=0.0;b:=false;\r
+ while i<>13\r
+ do\r
+ call hascii(i);\r
+ call move(350+7*k,290);\r
+ if i<>46 then\r
+ x1:=10*x1+i-48;\r
+ fi;\r
+ k:=k+1;\r
+ if b then j:=j/10.0 fi;\r
+ if i=46 then b:=true fi;\r
+ i:=inkey;\r
+ od;\r
+ x1:=x1*j;if x1>28 then x1:=28 fi;\r
+ call move(40,310);\r
+ call outstring("entrer la valeur de l'ordonn\82e1 : Y1= ");\r
+ i:=inkey;j:=1.0;k:=0;y1:=0.0;b:=false;\r
+ while i<>13\r
+ do\r
+ call hascii(i);\r
+ call move(350+7*k,310);\r
+ if i<>46 then\r
+ y1:=10*y1+i-48;\r
+ fi;\r
+ k:=k+1;\r
+ if b then j:=j/10.0 fi;\r
+ if i=46 then b:=true fi;\r
+ i:=inkey;\r
+ od;\r
+ y1:=y1*j;\r
+ call move(40,330);\r
+ call outstring("entrer la valeur de l'ordonn\82e2 : Y2= ");\r
+ i:=inkey;j:=1.0;k:=0;y2:=0.0;b:=false;\r
+ while i<>13\r
+ do\r
+ call hascii(i);\r
+ call move(350+7*k,330);\r
+ if i<>46 then\r
+ y2:=10*y2+i-48;\r
+ fi;\r
+ k:=k+1;\r
+ if b then j:=j/10.0 fi;\r
+ if i=46 then b:=true fi;\r
+ i:=inkey;\r
+ od;\r
+ y2:=y2*j;\r
+ if y1>y2 then\r
+ x2:=y1;y1:=y2;y2:=x2;\r
+ fi;\r
+ x2:=x1;if y2>10 then y2:=10 fi;if y1>10 then y1:=10 fi;\r
+ call move(xconv_en_entier(x1),yconv_en_entier(y1));\r
+ call draw(xconv_en_entier(x2),yconv_en_entier(y2));\r
+ fi;\r
+ fi;\r
+ call move(40,275);\r
+ call outstring(" ");\r
+ call move(40,290);\r
+ call outstring(" ");\r
+ call move(40,310);\r
+ call outstring(" ");\r
+ call move(40,330);\r
+ call outstring(" ");\r
+ end saisie;\r
+end segment;\r
+\r
+(*************************************************************)\r
+(* La procedure tri, comme son nom l'indique, trie le tableau contenant\r
+tous les segments(tab) et met le r\82sultat dans un autre tableau(t) *)\r
+\r
+unit tri:procedure(tb:arrayof segment;output ta:arrayof segment);\r
+ var i,j,k,n:integer,t:arrayof integer;\r
+ begin\r
+ n:=upper(tb);\r
+ array t dim(1:n);\r
+ array ta dim(1:n);\r
+ for i:=1 to n do t(i):=i od;\r
+ for i:=1 to n-1 \r
+ do \r
+ for j:=i+1 to n\r
+ do \r
+ if tb(i).y1>tb(j).y1 then\r
+ k:=t(i); \r
+ t(i):=t(j);\r
+ t(j):=k;\r
+ fi;\r
+ if tb(i).y1=tb(j).y1 then\r
+ if tb(i).x1>tb(j).x1 then\r
+ k:=t(i);\r
+ t(i):=t(j);\r
+ t(j):=k;\r
+ fi; fi;\r
+ od;\r
+ od;\r
+ for i:=1 to n\r
+ do\r
+ ta(i):=new segment;\r
+ ta(i):=tb(t(i));\r
+ od;\r
+ call move(60,295);call color(9);\r
+ call outstring("Fin du tri.");\r
+ call move(60,310);call color(5);\r
+ call outstring("Appuyer sur une touche pour voir ");call color(14);\r
+ call outstring("les intersections \82ventuelles. ");\r
+ call move(60,325);call color(15);\r
+ call outstring("Pour revenir au menu pr\82c\82dent, taper sur une nouvelle touche");\r
+ j:=inkey;\r
+end tri;\r
+(*************************************************************)\r
+(* Cette procedure est appel\82\82e par la procedure intersection, si les conditions\r
+pour une intersection sont r\82alis\82es, pour tracer l'intersection *)\r
+\r
+unit trace:procedure(c:char,x,y,z:real);\r
+begin\r
+ if c='p' then\r
+ call point(xconv_en_entier(x),yconv_en_entier(y));\r
+ fi;\r
+ if c=h then\r
+ call move(xconv_en_entier(x),yconv_en_entier(y));\r
+ call draw(xconv_en_entier(z),yconv_en_entier(y));\r
+ fi;\r
+ if c=v then\r
+ call move(xconv_en_entier(x),yconv_en_entier(y));\r
+ call draw(xconv_en_entier(x),yconv_en_entier(z));\r
+ fi;\r
+end trace;\r
+\r
+(*************************************************************)\r
+(* La procedure parcours a pour but de traiter le tableau tri\82 et si n\82cessaire\r
+faire appel \85 une de ses procedures(traitement, intersection) ou classe(arb) pour \r
+trouver toutes les intersections existantes *)\r
+\r
+unit parcours:procedure(tab:arrayof segment);\r
+ (* La classe arb va servir \85 traiter uniquement les segments verticaux *)\r
+ unit arb:class;\r
+ var nb:integer,tv:arrayof segment;\r
+\r
+ unit insertion:procedure(tab:arrayof segment,nb:integer;inout tv:arrayof segment);\r
+ var i,j:integer;\r
+ begin\r
+ array tv dim(1:nb);j:=0;\r
+ for i:=1 to upper(tab)\r
+ do;\r
+ if tab(i).sens=v then\r
+ j:=j+1;\r
+ tv(j):=new segment;tv(j).sens:=v;\r
+ tv(j).x1:=tab(i).x1;tv(j).y1:=tab(i).y1;\r
+ tv(j).x2:=tab(i).x2;tv(j).y2:=tab(i).y2;\r
+ fi;\r
+ od;\r
+ end insertion;\r
+\r
+ unit Arb_parcours:procedure(vertical:arrayof segment);\r
+ begin\r
+ for i:=1 to upper(vertical)\r
+ do\r
+ for j:=i+1 to upper(vertical)\r
+ do\r
+ call intersection(vertical(i),vertical(j));\r
+ od;od;\r
+ end Arb_parcours;\r
+\r
+ end arb;\r
+\r
+(* La procedure intersection permet de v\82rifier si les conditions d'intersection\r
+entre deux segments sont r\82alis\82es *)\r
+\r
+ unit intersection:procedure(s1,s2:segment);\r
+ begin\r
+ call color(14);\r
+ if s1.sens=s2.sens then\r
+ if s1.sens=h then\r
+ if s1.y1=s2.y1 then\r
+ if s2.x2<=s1.x2 then\r
+ call trace(h,s2.x1,s1.y1,s2.x2);\r
+ else\r
+ call trace(h,s2.x1,s1.y1,s1.x2);\r
+ fi; fi; \r
+ else\r
+ if s1.x1=s2.x1 then \r
+ if s2.y1<=s1.y2 then\r
+ if s2.y2<=s1.y2 then\r
+ call trace(v,s2.x1,s2.y1,s2.y2);\r
+ else\r
+ call trace(v,s2.x1,s2.y1,s1.y2);\r
+ fi; fi; fi; fi;\r
+ else\r
+ if s1.y1>=s2.y1 and s1.y2<=s2.y2 then\r
+ call trace('p',s2.x1,s1.y1,0);\r
+ fi; \r
+ fi;\r
+ end intersection;\r
+\r
+(* La procedure traitement parcours le tableau tri\82 et r\82alise un traitement \r
+diff\82rent selon s'il s'agit d'un segment horizontal ou d'un segment vertical *)\r
+ unit traitement: procedure(tab:arrayof segment);\r
+ var i,j:integer,b:boolean;\r
+ var bst:arb;\r
+ begin\r
+ bst:=new arb;b:=false;bst.nb:=0;\r
+ for i:=1 to upper(tab)\r
+ do\r
+ if tab(i).sens=h then\r
+ for j:=1 to upper(tab)\r
+ do \r
+ if j<>i then \r
+ if tab(i).x1<=tab(j).x1 then\r
+ if tab(i).x2>=tab(j).x2 or tab(i).x2>=tab(j).x1 then\r
+ call intersection(tab(i),tab(j));\r
+ fi;\r
+ fi;fi;\r
+ od;\r
+ else\r
+ bst.nb:=bst.nb+1;b:=true;\r
+ fi;\r
+ od;\r
+ call bst.insertion(tab,bst.nb,bst.tv);\r
+ if b then call bst.Arb_parcours(bst.tv) fi;\r
+ end traitement;\r
+begin\r
+ call traitement(tab);\r
+ i:=inkey;\r
+end;\r
+(*************************************************************)\r
+(* Cette procedure r\82alise le cadre dans lequel les segments,les intersections \r
+de segments et le dialogue avec l'utilisateur sont \82cris *)\r
+unit graphisme:procedure;\r
+ begin\r
+ call cls;\r
+ call color(10);call move(0,0);\r
+ call hfill(640);call draw(0,250);\r
+ call hfill(640);call move(639,0);\r
+ call draw(639,349);call draw(0,349);\r
+ call draw(0,250);call color(15);\r
+ call move(40,10);call draw(40,210);\r
+ call hfill(599);\r
+ for i:=1 to 10\r
+ do \r
+ call move(38,210-20*i);\r
+ call draw(42,210-20*i);\r
+ call move(28,210-i*20);\r
+ if (i/10)<1 then\r
+ call hascii(48+i);\r
+ else\r
+ call move(20,210-i*20);\r
+ call hascii(48+i/10);\r
+ call move(28,210-i*20);\r
+ call hascii(i-entier(i/10)*10+48);\r
+ fi;\r
+ od;\r
+ call move(10,8);call outstring("Y");\r
+ call move(26,215);call outstring("0");\r
+ for i:= 1 to 28\r
+ do \r
+ call move(40+i*20,212);\r
+ call draw(40+i*20,208);\r
+ call move(33+i*20,218);\r
+ if (i/10)<1 then\r
+ call hascii(48+i);\r
+ else\r
+ call hascii(48+i/10);\r
+ call move(40+i*20,218);\r
+ call hascii(i-entier(i/10)*10+48);\r
+ fi;\r
+ od;\r
+ call move(620,210);call outstring("X");\r
+end;\r
+\r
+(*************************************************************)\r
+(* La procedure souris permet la saisie des segments \85 l'aide de la souris *)\r
+unit souris:procedure(output tab:arrayof segment);\r
+var i,j,n,h1,h2,v1,v2:integer,\r
+ b:boolean;\r
+begin\r
+ call graphisme;\r
+ call move(40,260);call color(15);\r
+ call outstring("Appuyer sur le bouton de gauche pour la premi\8are coordonn\82es");\r
+ call move(40,280);\r
+ call outstring("puis sur le bouton de droite pour la seconde coordonn\82es.");\r
+ call move (40,300);\r
+ call outstring("Appuyer sur entr\82e pour continuer.");\r
+ i:=inkey;\r
+ call move(40,260);call color(15);\r
+ call outstring(" ");\r
+ call move(40,280);\r
+ call outstring(" ");\r
+ call move (40,300);\r
+ call outstring(" ");\r
+ pref MOUSE BLOCK\r
+ unit click:procedure (output x,y,z,t:integer);\r
+ var p:integer,l,r,c:boolean;\r
+ begin\r
+ call status(x,y,l,r,c);\r
+ do\r
+ call getpress(0,x,y,p,l,r,c);\r
+ if l then\r
+ call move(x,y);x:=inxpos;y:=inypos;call point(x,y);\r
+ fi;\r
+ if r then exit fi;\r
+ od;\r
+ call status(z,t,l,r,c);\r
+ do\r
+ call getpress(1,z,t,p,l,r,c);\r
+ if r then\r
+ call move(z,t);z:=inxpos;t:=inypos;call point(z,t);\r
+ exit;\r
+ fi;\r
+ if l then exit fi;\r
+ od;\r
+ end click;\r
+ begin\r
+ b:=init(i);\r
+ if b then \r
+ call showcursor;call setwindow(40,600,10,210);\r
+ call defcursor(1,12,13);call move(40,260);\r
+ call outstring("Entrer le nombre de segments(12 au maximum) : ");\r
+ i:=inkey;call hascii(i);n:=i-48;\r
+ if i<>13 then \r
+ i:=inkey;\r
+ if i<>13 then\r
+ call hascii(i);\r
+ n:=10*n+i-48;\r
+ fi; fi;\r
+ array tab dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ tab(i):=new segment;\r
+ call move(40,280);call color(i);\r
+ call outstring("Entrer le sens du segment (h/v) : ");\r
+ j:=inkey;tab(i).sens:=chr(j);call hascii(0);\r
+ if tab(i).sens=h then\r
+ call hascii(72);\r
+ call click(tab(i).x1,tab(i).y1,tab(i).x2,tab(i).y2);\r
+ tab(i).x1:=xconv_en_reel(tab(i).x1);\r
+ tab(i).x2:=xconv_en_reel(tab(i).x2);\r
+ tab(i).y1:=yconv_en_reel(tab(i).y1);\r
+ tab(i).y2:=yconv_en_reel(tab(i).y2);\r
+ tab(i).y2:=tab(i).y1;\r
+ if tab(i).x1>tab(i).x2 then\r
+ j:=tab(i).x1;\r
+ tab(i).x1:=tab(i).x2;\r
+ tab(i).x2:=j;\r
+ fi;\r
+ call move(xconv_en_entier(tab(i).x1),yconv_en_entier(tab(i).y1));\r
+ call draw(xconv_en_entier(tab(i).x2),yconv_en_entier(tab(i).y2));\r
+ else \r
+ call hascii(86);\r
+ call click(tab(i).x1,tab(i).y1,tab(i).x2,tab(i).y2);\r
+ tab(i).x1:=xconv_en_reel(tab(i).x1);\r
+ tab(i).x2:=xconv_en_reel(tab(i).x2);\r
+ tab(i).y1:=yconv_en_reel(tab(i).y1);\r
+ tab(i).y2:=yconv_en_reel(tab(i).y2);\r
+ tab(i).x2:=tab(i).x1;\r
+ if tab(i).y1>tab(i).y2 then\r
+ j:=tab(i).y1;\r
+ tab(i).y1:=tab(i).y2;\r
+ tab(i).y2:=j;\r
+ fi;\r
+ call move(xconv_en_entier(tab(i).x1),yconv_en_entier(tab(i).y1));\r
+ call draw(xconv_en_entier(tab(i).x2),yconv_en_entier(tab(i).y2));\r
+ fi;\r
+ od;\r
+ else\r
+ call move(100,200);call outstring(" NO M O U S E "); \r
+ fi;\r
+ end;\r
+end souris;\r
+\r
+(*************************************************************)\r
+(* La procedure clavier est appel\82e si le choix "saisie au clavier" est s\82lectionner". *) \r
+\r
+unit clavier:procedure(output tab:arrayof segment);\r
+var i,j,n:integer;\r
+begin\r
+ call graphisme;call move(40,260);\r
+ call outstring("Entrer le nombre de segments(12 au maximum) : ");\r
+ n:=inkey;call hascii(n);n:=n-48;\r
+ j:=inkey;if j<>13 then \r
+ n:=10*n+j-48;\r
+ call hascii(j);\r
+ fi;\r
+ array tab dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ tab(i):=new segment;\r
+ call move(40,275);call color(i);\r
+ call outstring("Entrer le sens du segment (h/v) : ");\r
+ j:=inkey;tab(i).sens:=chr(j);call hascii(0);\r
+ if tab(i).sens=h then\r
+ call hascii(72);\r
+ call tab(i).saisie(tab(i).sens,tab(i).x1,tab(i).y1,tab(i).x2,tab(i).y2);\r
+ else \r
+ call hascii(86);\r
+ call tab(i).saisie(tab(i).sens,tab(i).x1,tab(i).y1,tab(i).x2,tab(i).y2);\r
+ fi;\r
+ od;\r
+end clavier;\r
+\r
+(*************************************************************)\r
+(* Menu principal *)\r
+unit menu:procedure;\r
+ var choix:integer;\r
+ (* Sous-menu du choix num\82ro 2 du menu principal *)\r
+ unit menu2:procedure;\r
+ var choix:integer;\r
+ begin\r
+ call graphisme;\r
+ call move(40,260);call outstring(" Choix du mode de saisie :");\r
+ call move(80,275);call outstring("1- au clavier.");\r
+ call move(80,290);call outstring("2- avec la souris.");\r
+ call move(80,305);call outstring("3- retour au menu principal");\r
+ call move(40,325);call outstring("Votre choix : ");\r
+ choix:=inkey;call hascii(choix);choix:=choix-48;\r
+ case choix\r
+ when 1 :do\r
+ call clavier(tab);\r
+ call tri(tab,t);\r
+ call parcours(t);\r
+ call menu2;\r
+ exit;\r
+ od;\r
+ when 2 : do\r
+ call souris(tab);\r
+ call tri(tab,t);\r
+ call parcours(t);\r
+ call menu2;\r
+ exit;\r
+ od;\r
+ when 3 : do\r
+ call move(150,325);\r
+ call outstring("retour au menu principal");\r
+ i:=inkey;\r
+ exit;\r
+ od;\r
+ otherwise call menu2;\r
+ esac;\r
+ end menu2;\r
+ \r
+ unit choix_alea : procedure(output tab:arrayof segment);\r
+ var nb_seg,nb_segh,nb_segv,i,j,k:integer,x1,x2,y1,y2:real;\r
+ begin\r
+ j:=0;\r
+ call ranset(1);\r
+ nb_seg:=2+entier(10*random);\r
+ array tab dim (1:nb_seg);\r
+ k:=0;\r
+ nb_segh:=entier(nb_seg*random);\r
+ (* nombre de segments horizontaux *)\r
+ for i:=1 to nb_segh\r
+ do\r
+ y1:=10*random;y2:=y1;j:=j+1;call color(j);\r
+ x1:=28*random;x2:=28*random;\r
+ tab(j):=new segment;tab(j).sens:=h;\r
+ tab(j).x1:=x1;tab(j).x2:=x2;\r
+ tab(j).y1:=y1;tab(j).y2:=y2;\r
+ if tab(i).x1>tab(i).x2 then \r
+ k:=tab(i).x1;tab(i).x1:=tab(i).x2;tab(i).x2:=k;\r
+ fi;\r
+ if tab(i).y1>tab(i).y2 then \r
+ k:=tab(i).y1;tab(i).y1:=tab(i).y2;tab(i).y2:=k;\r
+ fi;\r
+ call point(xconv_en_entier(tab(i).x1),yconv_en_entier(tab(i).y1));\r
+ call draw(xconv_en_entier(tab(i).x2),yconv_en_entier(tab(i).y1));\r
+ od;\r
+ nb_segv:=nb_seg-nb_segh;\r
+ for i:=1 to nb_segv\r
+ do\r
+ x1:=28*random;x2:=x1;j:=j+1;call color(j);\r
+ y1:=10*random;y2:=10*random;\r
+ tab(j):=new segment;tab(j).sens:=v;\r
+ tab(j).x1:=x1;tab(j).x2:=x2;\r
+ tab(j).y1:=y1;tab(j).y2:=y2;\r
+ if tab(j).x1>tab(j).x2 then \r
+ k:=tab(j).x1;tab(j).x1:=tab(j).x2;tab(j).x2:=k;\r
+ fi;\r
+ if tab(j).y1>tab(j).y2 then \r
+ k:=tab(j).y1;tab(j).y1:=tab(j).y2;tab(j).y2:=k;\r
+ fi;\r
+ call point(xconv_en_entier(tab(j).x1),yconv_en_entier(tab(j).y1));\r
+ call draw(xconv_en_entier(tab(j).x1),yconv_en_entier(tab(j).y2));\r
+ od;\r
+ end choix_alea;\r
+begin\r
+ call cls;\r
+ call move(300,0);call color(10);call outstring("MENU");\r
+ call move(60,60);call color(15);\r
+ call outstring("1- choix al\82atoire de segments.");\r
+ call move(60,100);\r
+ call outstring("2- choix des segments par l'utilisateur.");\r
+ call move(60,140);call outstring("3- fin du programme.");\r
+ call move(60,220);call outstring("Votre choix :");\r
+ choix:=inkey;call hascii(choix);choix:=choix-48;\r
+ case choix\r
+ when 1:do \r
+ call graphisme;\r
+ call choix_alea(tab);\r
+ call tri(tab,t);\r
+ call parcours(t);\r
+ call menu;\r
+ exit;\r
+ od;\r
+ when 2:do\r
+ call menu2;\r
+ call menu;exit;\r
+ od;\r
+ when 3:do\r
+ call cls;\r
+ call move(250,50);\r
+ call outstring("FIN DU PROGRAMME");\r
+ exit;\r
+ od;\r
+ otherwise call menu;\r
+ esac;\r
+end menu;\r
+\r
+(*************************************************************)\r
+(* Programme principal *)\r
+begin\r
+call gron(nocard);\r
+call menu;\r
+i:=inkey;\r
+call groff;\r
+end;\r
+end projet;\r
+\r
+\r
--- /dev/null
+PRogram Projet2;\r
+\r
+\r
+(**** GESTION DES CARACTERES SAISIES POUR L'AFFICHAGE EN MODE GRAPHIQUE ***)\r
+\r
+UNIT inchar : IIUWgraph function(a:integer): integer;\r
+ \r
+ var i : integer;\r
+ begin\r
+ call move(100,315);\r
+ call color(grisfonce);\r
+ case a\r
+ when 1:\r
+ call outstring(" <ESC>: menu principal");\r
+ when 2:\r
+ call outstring("<RC>: nouvelle saisie <ESC>: menu principal");\r
+ esac;\r
+ do\r
+\r
+ i := inkey;\r
+ if a=1 then\r
+ if i=27 then exit;\r
+ fi;\r
+ else\r
+ if i=27 or i=13 then exit fi;\r
+ fi;\r
+ od;\r
+ call move(100,315);\r
+ call outstring(" ");\r
+ result := i;\r
+end inchar;\r
+\r
+UNIT SAISIE:IIUWGRAPH function(e,x,y:integer):arrayof char;\r
+var i,n:integer,\r
+ c: integer,\r
+ t :arrayof char;\r
+begin\r
+ \r
+ array t dim(1:e);\r
+ for i:=1 to e do\r
+ t(i):='a';\r
+ od;\r
+ call color(grisclair);\r
+ do\r
+ i:=1;\r
+ c:=inkey;\r
+ while c<>13 and c<>27 and i<=e do\r
+ if c-48>=0 and c-48<=9 then\r
+ t(i):=chr(c);\r
+ call move(x+i*9,y);\r
+ call hascii(c);\r
+ \r
+ i:=i+1;\r
+ fi;\r
+ c:=inkey;\r
+ od;\r
+ if t(1)<>'a' then exit; fi;\r
+ od;\r
+ result:=t;\r
+end SAISIE;\r
+\r
+UNIT ConvEnt:function(t:arrayof char):integer;\r
+var n,i:integer;\r
+begin\r
+ n:=0;\r
+ for i:=1 to upper(t) do\r
+ if t(i)<>'a' then\r
+ n:=n*10+(ord(t(i))-48);\r
+ fi;\r
+ od;\r
+ write(n);\r
+ result:=n;\r
+end ConvEnt;\r
+\r
+UNIT ConvASC:function(i:integer):arrayof char;\r
+ var t: arrayof char,\r
+ n,r:integer;\r
+begin\r
+ array t dim(1:10);\r
+ n:=1;\r
+ if i=0 then \r
+ t(1):=chr(48);\r
+ n:=n+1;\r
+ else\r
+ \r
+ while I<>0 do\r
+ t(n):=chr((i mod 10) +48);\r
+ i:=i div 10;\r
+ n:=n+1;\r
+ \r
+ od;\r
+\r
+ fi;\r
+ array result dim(1:(n-1));\r
+ for r:=1 to (n-1) do\r
+ result(r):=t(((n-1)-r)+1);\r
+ od;\r
+ kill(t);\r
+END convasc;\r
+\r
+UNIT drawmenu: IIUWGRAPH procedure;\r
+begin\r
+call color(grisclair);\r
+call move(0,200);\r
+call draw(620,200);\r
+call move(620,202);\r
+call draw(0,202);\r
+call move(240,208);\r
+call color(bleu);\r
+call outstring("GESTION DES ARBRES 23");\r
+call color(grisclair);\r
+call move(0,220);\r
+call draw(620,220);\r
+call move(5,230);\r
+call outstring(" 1-inserer des elements 3-element minimum 5-detruire un arbre");\r
+call move(5,240);\r
+call outstring(" 2-supprimer un element 4-element de l'arbre 6-afficher une fouffe");\r
+call move(5,250);\r
+call outstring(" 0-quitter le programme");\r
+\r
+call move(0,260);\r
+call draw(620,260);\r
+call move(0,277);\r
+call draw(620,277);\r
+call move(620,200);\r
+call draw(620,330);\r
+call draw(0,330);\r
+call draw(0,200);\r
+END drawmenu;\r
+\r
+ UNIT SelectMenu: IIUWGRAPH function:integer;\r
+ var choix:integer;\r
+ begin\r
+ call color(rouge);\r
+ call move(1,265);\r
+ call outstring(" ");\r
+ call move(5,265);\r
+ call outstring("Votre choix :");\r
+ \r
+ do\r
+ choix:=convent(saisie(1,110,265));\r
+ if choix>=0 and choix<=6 then exit;fi;\r
+ od;\r
+ call move(1,265);\r
+ call outstring(" ");\r
+ call move(1,290);\r
+ call outstring(" ");\r
+ call move(1,310);\r
+ call outstring(" ");\r
+ result:=choix;\r
+ end;\r
+(*** FIN DE LA GESTION DE L'AFFICHAGE... ***)\r
+\r
+\r
+ \r
+(**** DECLARATION DU TYPE: OBJET... *****)\r
+UNIT CObjet: CLASS;\r
+ UNIT objet:IIUWGRAPH class;\r
+ unit virtual show: procedure(x,y:integer);\r
+ end show;\r
+ unit virtual getvalue:function:integer;\r
+ end getvalue;\r
+ unit virtual length:function:integer;\r
+ end length;\r
+ end objet;\r
+\r
+ UNIT elem:objet class(val:integer);\r
+ unit virtual getvalue: function:integer;\r
+ begin\r
+ \r
+ result:=val;\r
+ end;\r
+ unit virtual length:function:integer;\r
+ var t:arrayof char;\r
+ begin\r
+ t:=convASC(val);\r
+ result:=upper(t);\r
+ end;\r
+\r
+ unit virtual show: procedure(x,y:integer);\r
+ var a,f,i:integer,\r
+ c:char,\r
+ tab:arrayof char;\r
+ begin\r
+ tab:=convasc(val);\r
+ f:=(longueur*8-(upper(tab)*8+(upper(tab)-1)*2))div 2;\r
+ f:=f+x;\r
+ for i:=1 to upper(tab) do\r
+ call move(f,y);\r
+ c:=tab(i);\r
+ call hascii(ord(c));\r
+ f:=f+10;\r
+ od;\r
+ kill(tab);\r
+ end show;\r
+ \r
+ end elem;\r
+\r
+END Cobjet;\r
+(**** fin de la declaration de OBJET ****) \r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+UNIT arbre23: CObjet class;\r
+\r
+VAR racine:arbre,aux:arbre,eq:boolean; \r
+ \r
+(**** STRUCTURE DE L'ARBRE 23 ****)\r
+\r
+(**** hierarchie: arbre -|-- noeud *******)\r
+(** |-- feuille *)\r
+\r
+\r
+\r
+ UNIT Arbre: IIUWGRAPH class; (** ABSTRACT CLASS **)\r
+ unit virtual display: procedure(inout h,l:integer);\r
+ end display;\r
+ unit virtual getinfo:function(quoi:integer):objet;\r
+ end getinfo;\r
+ END arbre;\r
+ \r
+ UNIT Noeud: Arbre CLASS (inf,sup:objet);\r
+\r
+ VAR arbG,arbM,arbD:arbre;\r
+ \r
+ unit virtual getinfo:function(quoi:integer):objet;\r
+ begin\r
+ case quoi\r
+ when 1:result:=inf;\r
+ when 2:result:=sup;\r
+ esac;\r
+ end getinfo;\r
+\r
+ unit enfants:function:integer;\r
+ var i:integer;\r
+ begin\r
+ i:=0;\r
+ if arbG<>none then i:=i+1; fi;\r
+ if arbM<>none then i:=i+1; fi;\r
+ if arbD<>none then i:=i+1; fi;\r
+ result:=i;\r
+ end;\r
+ UNIT integre:function:boolean;\r
+ begin\r
+ result:= (arbD=none);\r
+ end integre;\r
+ \r
+ UNIT virtual display: procedure(inout h,l:integer);\r
+ var x1,x2:integer;\r
+ begin \r
+ x1:=h - (((8*longueur+(longueur-1)*2)*2+4) div 2);\r
+ x2:=h - (((8*longueur+(longueur-1)*2)*2+4)div 2);;\r
+\r
+ call color(grisclair);\r
+ call inf.show(x2,l);\r
+ x2:=x1+(8*longueur+(longueur-1)*2);\r
+ call color(grisfonce);\r
+ call move(x2,l-5);\r
+ call draw(x2,l+10);\r
+ call move(x2,l);\r
+ \r
+ x2:=x2+2;\r
+ call color(grisclair);\r
+ call sup.show(x2,l);\r
+ call color(grisfonce);\r
+ call move(x2,l);\r
+\r
+ x2:=x2+(8*longueur+(longueur-1)*2);\r
+ call move(x1-2,l-5);\r
+ call draw(x2+2,l-5);\r
+ call draw(x2+2,l+10);\r
+ call draw(x1-2,l+10);\r
+ call draw(x1-2,l-5); \r
+ end display;\r
+\r
+ END noeud;\r
+\r
+\r
+ UNIT Feuille: arbre CLASS(e:objet);\r
+ \r
+ unit virtual display: procedure(inout h,l:integer);\r
+ VAR X1,X2:integer;\r
+ begin\r
+ x1:=h - ((8*longueur+(longueur-1)*2+4) div 2);\r
+ call color(rouge);\r
+ call e.show(x1,l);\r
+ call color(grisfonce);\r
+ x2:=x1+(8*longueur+(longueur-1)*2);\r
+ call move(x1-2,l-5);\r
+ call draw(x2+2,l-5);\r
+ call draw(x2+2,l+10);\r
+ call draw(x1-2,l+10);\r
+ call draw(x1-2,l-5);\r
+ end DISPLAY;\r
+ unit virtual getinfo:function(quoi:integer):objet;\r
+ begin\r
+ result:=e;\r
+ end getinfo;\r
+ END feuille;\r
+\r
+\r
+\r
+ UNIT SousArbre: function(a:arbre;element:objet):arbre; \r
+ var linf,lesup:objet;\r
+ begin\r
+ linf:=a.getinfo(inf);\r
+ lesup:=a.getinfo(sup);\r
+ if element.getvalue<=linf.getvalue then \r
+ result:=a qua noeud.arbG;\r
+ else \r
+ if lesup.getvalue=-1 then\r
+ result:=a qua noeud.arbG;\r
+\r
+ else\r
+ if element.getvalue<=lesup.getvalue then \r
+ result:=a qua noeud.arbM;\r
+ \r
+ else \r
+ if a qua noeud.arbD=none then \r
+ result:=a qua noeud.arbM;\r
+ else \r
+ result:=a qua noeud.arbD;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ \r
+ END sousarbre;\r
+ \r
+\r
+UNIT affichage:IIUWGRAPH procedure(r:arbre);\r
+var x,y,t,i:integer;\r
+begin\r
+ call drawmenu;\r
+ x:=5;\r
+\r
+ y:=25;\r
+ i:=0;\r
+ call afficheArbre23(r,y,x,i);\r
+ call move(70,290);\r
+ call color(rouge);\r
+ call outstring("les elements de l'arbre sont des nombres inferieurs a 100");\r
+ call move(110,310);\r
+ call outstring(" !!! JUSQU'A 24 ELEMENTS PEUVENT ETRE AFFICHES !!!");\r
+end;\r
+Unit affichearbre23: IIUWGRAPH procedure\r
+ (r:arbre;inout y:integer;x:integer;inout i:integer);\r
+ const esp=5;\r
+ var yD,yG,a,\r
+ t1,t2,t3:integer;\r
+\r
+ begin\r
+ if r<> none then\r
+ if r is feuille then call r.display(y,x);\r
+ else\r
+ \r
+ if r qua noeud.arbG is feuille then\r
+ if r qua noeud.enfants=2 then \r
+ yD:=y;\r
+ \r
+ t1:=y;\r
+ call affichearbre23(r qua noeud.arbG,y,x+40,i);\r
+ \r
+ y:=y+22+esp; \r
+ t2:=y;\r
+ t3:=0;\r
+ call affichearbre23(r qua noeud.arbM,y,x+40,i);\r
+ y:=y+22+esp;\r
+ yD:=yD+(51 div 2);\r
+ i:=yD;\r
+ call r.display(yD,x); \r
+ call color(grisfonce);\r
+ call move(t1,(x+40)-5);\r
+ call draw(yD,x+10);\r
+ call move(t2,(x+40)-5);\r
+ call draw(yD,x+10);\r
+ \r
+ else \r
+ yd:=y;\r
+ \r
+ t1:=y;\r
+ call affichearbre23(r qua noeud.arbG,y,x+40,i);\r
+ y:=y+22+esp;\r
+ t2:=y;\r
+ call affichearbre23(r qua noeud.arbM,y,x+40,i);\r
+ y:=y+22+esp;\r
+ t3:=y;\r
+ call affichearbre23(r qua noeud.arbD,y,x+40,i);\r
+ y:=y+22+esp;\r
+ yD:=yD+(60 div 2);\r
+ i:=yd;\r
+ call color(grisfonce);\r
+ call move(t1,(x+40)-5);\r
+ call draw(yD,x+8);\r
+ call move(t2,(x+40)-5);\r
+ call draw(yD,x+8);\r
+ call move(t3,(x+40)-5);\r
+ call draw(yD,x+8);\r
+\r
+ \r
+ call r.display(yd,x); \r
+ fi; \r
+ \r
+ else\r
+ \r
+ call affichearbre23(r qua noeud.arbG,y,x+40,i);\r
+ t1:=i;\r
+ call affichearbre23(r qua noeud.arbM,y,x+40,i);\r
+ t2:=i;\r
+ call affichearbre23(r qua noeud.arbD,y,x+40,i); \r
+ t3:=i;\r
+ call color(grisfonce);\r
+ if r qua noeud.enfants=2 then \r
+ yd:=t1+((t2-t1)/2);\r
+ call move(t1,x+35); \r
+ call draw(yd,x+8);\r
+ call move(t2,x+35);\r
+ call draw(yd,x+8);\r
+ else \r
+ yd:=t1+((t3-t1)/2);\r
+ call move(t1,x+35); \r
+\r
+ call draw(yd,x+8);\r
+ call move(t2,x+35);\r
+ call draw(yd,x+8);\r
+ call move(t3,x+35);\r
+ call draw(yd,x+8);\r
+ fi;\r
+ \r
+ \r
+ call r.display(yd,x); \r
+ i:=yd;\r
+\r
+ fi;\r
+ fi;\r
+fi;\r
+ \r
+ \r
+end affichearbre23;\r
+\r
+\r
+\r
+unit suppression:function(d:arbre,num:objet):boolean;\r
+var delete:boolean,cousin:arbre;\r
+ \r
+begin\r
+ (**** INITIALISATION ****)\r
+ if d<>none then\r
+ delete:=false;\r
+ cousin:=none;\r
+ if member(d,num) then\r
+ call supprime(d,num,delete,cousin);\r
+ result:=true;\r
+ else result:=false;\r
+ fi;\r
+ else result:=false;\r
+ fi;\r
+end;\r
+UNIT supprime: procedure(p:arbre,n:objet;inout deleted:boolean,aux:arbre);\r
+var linf,lesup:objet,\r
+ fils:arbre;\r
+begin\r
+ linf:=p.getinfo(1);\r
+ lesup:=p.getinfo(2);\r
+ \r
+ if p is feuille then (** le pere est une feuille **)\r
+ kill(p);\r
+ racine:=none;\r
+ deleted:=true;\r
+ else\r
+ fils:=sousarbre(p,n);\r
+ \r
+ if fils is feuille then (* fils est une feuille **)\r
+ deleted:=true; (* on le supprime*)\r
+ if p qua noeud.enfants=2 then (* l'arbre n'est plus un arbre 23 *)\r
+ if n.getvalue=linf.getvalue then\r
+ aux:=p qua noeud.arbM;\r
+ else aux:=p qua noeud.arbG;\r
+ fi;\r
+ kill(fils); \r
+ if p=racine then\r
+ racine:=aux;\r
+ fi;\r
+ kill(p); \r
+ (* on supprime le noeud car il a qu'un fils...*)\r
+ else\r
+ kill(fils);\r
+ call decale(p);\r
+ aux:=none;\r
+ fi;\r
+ ELSE (* fils est un noeud..*)\r
+ \r
+ call supprime(fils,n,deleted,aux);\r
+ if deleted then\r
+ if aux<>none then\r
+ if p qua noeud.enfants=1 then\r
+ if p qua noeud.arbg=none then\r
+ p qua noeud.arbG:=p qua noeud.arbM;\r
+ p qua noeud.arbM:=none;\r
+ p qua noeud.inf:=supI(p qua noeud.arbG);\r
+ p qua noeud.sup:=new elem(-1);\r
+ else p qua noeud.sup:=new elem(-1);\r
+ fi;\r
+ else call decale(p);\r
+ fi;\r
+ fils:=sousarbre(p,aux.getinfo(inf));\r
+ if fils qua noeud.enfants=3 then\r
+ aux:=ordre(aux.getinfo(inf),fils,aux);\r
+ call ordonne(aux.getinfo(inf),p,aux);\r
+ aux:=none;\r
+ else \r
+ call ordonne(aux.getinfo(inf),fils,aux);\r
+ p qua noeud.inf:=supI(p qua noeud.arbG);\r
+ p qua noeud.sup:=supI(p qua noeud.arbM);\r
+ \r
+ aux:=none;\r
+ fi;\r
+ \r
+ if p qua noeud.enfants=1 then \r
+ if p=racine then\r
+ racine:=fils;\r
+ else\r
+ aux:=fils;\r
+ fi;\r
+ kill(p); \r
+ fi;\r
+ else\r
+ p qua noeud.inf:=supI(p qua noeud.arbG);\r
+ p qua noeud.sup:=supI(p qua noeud.arbM);\r
+ fi;\r
+ fi;\r
+ \r
+ FI;\r
+ fi;\r
+END SUPPRIME;\r
+\r
+Unit root:function:arbre;\r
+begin\r
+ result:=racine;\r
+end;\r
+\r
+UNIT reset:procedure(r:arbre);\r
+begin\r
+ if r<>none then\r
+ if r is feuille then \r
+ kill(r qua feuille.e);\r
+ kill(r);\r
+ else\r
+ call reset(r qua noeud.arbG);\r
+\r
+ call reset(r qua noeud.arbM);\r
+ call reset(r qua noeud.arbD);\r
+ kill(r qua noeud.inf);\r
+ kill(r qua noeud.sup);\r
+ kill(r);\r
+ fi;\r
+ fi;\r
+end reset;\r
+UNIT minimum:function(r:arbre):elem;\r
+begin\r
+ if r<>none then\r
+ if r is feuille then \r
+ result:=r.getinfo(1);\r
+ else\r
+ result:=minimum(r qua noeud.arbG);\r
+ fi;\r
+ else result:=none;\r
+ fi;\r
+end minimum;\r
+\r
+UNIT member: function(per:arbre,value:objet):boolean;\r
+ var fil:arbre,\r
+ cettevaleur:objet;\r
+ Begin\r
+ if per<>none then\r
+ if per is noeud then \r
+ fil:=SousArbre(per,value);\r
+ else (* l'arbre est constitu\82 d'une seule feuille *)\r
+ fil:=per;\r
+ per:=none;\r
+ fi;\r
+ fi;\r
+ \r
+ \r
+ if fil<>none then \r
+ \r
+ if fil is noeud then \r
+ result:=member(fil,value); \r
+ else \r
+ cettevaleur:=fil.getinfo(leave);\r
+ result:=(cettevaleur.getvalue=value.getvalue);\r
+ fi;\r
+ else\r
+ result:=false;\r
+ fi;\r
+END member;\r
+\r
+(**** procedures utilis\82es dans les procedures INSERTION,SUPPRESSION,MEMBER... *******) \r
+\r
+ Unit ordonne:procedure(valeur:objet,nd,obj:arbre);\r
+ (* ordonne le noeud "ND" apr\82s insertion du nouvel objet *)\r
+ (* le noeud comporte alors 3 fils...*)\r
+ var Lesup,Linf:objet;\r
+ begin\r
+ Linf:=nd.getinfo(inf);\r
+ lesup:=nd.getinfo(sup);\r
+ if valeur.getvalue<Linf.getvalue then\r
+ nd qua noeud.arbD:=nd qua noeud.arbM;\r
+ nd qua noeud.arbM:=nd qua noeud.arbG;\r
+ nd qua noeud.arbG:=obj;\r
+ else if lesup.getvalue=-1 then\r
+ nd qua noeud.arbM:=obj;\r
+ else\r
+ if valeur.getvalue<Lesup.getvalue then \r
+ nd qua noeud.arbD:=nd qua noeud.arbM;\r
+ nd qua noeud.arbM:=obj;\r
+ else \r
+ nd qua noeud.arbD:=obj;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ nd qua noeud.sup:=supI(nd qua noeud.arbM);\r
+ nd qua noeud.inf:=supI(nd qua noeud.arbG);\r
+\r
+ end ordonne;\r
+ \r
+ \r
+ UNIT decalle:procedure(n:arbre);\r
+ begin \r
+ n qua noeud.arbG:=n qua noeud.arbM;\r
+ n qua noeud.arbM:=n qua noeud.arbD;\r
+ n qua noeud.arbD:=none;\r
+ n qua noeud.inf:=supI(n qua noeud.arbG);\r
+ n qua noeud.sup:=supI(n qua noeud.arbM);\r
+ end;\r
+\r
+ UNIT decale:procedure(n:arbre);\r
+ begin\r
+ if n qua noeud.arbG=none then\r
+ n qua noeud.arbG:=n qua noeud.arbM;\r
+ n qua noeud.arbM:=n qua noeud.arbD;\r
+ n qua noeud.arbD:=none;\r
+ else if n qua noeud.arbM=none then\r
+ n qua noeud.arbM:=n qua noeud.arbD;\r
+ n qua noeud.arbD:=none;\r
+ \r
+ fi;\r
+ fi;\r
+ n qua noeud.inf:=supI(n qua noeud.arbG);\r
+ n qua noeud.sup:=supI(n qua noeud.arbM);\r
+ end decale;\r
+ \r
+ \r
+ Unit ordre:function(valeur:objet,nd,obj:arbre):arbre;\r
+ var aux1:arbre,\r
+ linf,lesup:objet;\r
+ begin\r
+ linf:=nd.getinfo(inf);\r
+ lesup:=nd.getinfo(sup);\r
+ if valeur.getvalue<linf.getvalue then\r
+ aux1:=new noeud(supI(obj),supI(nd qua noeud.arbG)); \r
+ aux1 qua noeud.arbG:=obj;\r
+ aux1 qua noeud.arbM:=nd qua noeud.arbG;\r
+ \r
+ call decalle(nd);\r
+ else \r
+ if valeur.getvalue<lesup.getvalue then\r
+ aux1:=new noeud(supI(nd qua noeud.arbG),supI(obj)); \r
+ aux1 qua noeud.arbM:=obj;\r
+ aux1 qua noeud.arbG:=nd qua noeud.arbG;\r
+ call decalle(nd);\r
+ else \r
+ if nd qua noeud.arbD.getinfo(2).getvalue<valeur.getvalue then\r
+ aux1:=new noeud(supI(nd qua noeud.arbD),valeur); \r
+ aux1 qua noeud.arbM:=obj;\r
+ aux1 qua noeud.arbG:=nd qua noeud.arbD;\r
+ nd qua noeud.arbD:=none;\r
+ else \r
+ aux1:=new noeud(valeur,supI(nd qua noeud.arbD)); \r
+ aux1 qua noeud.arbM:=nd qua noeud.arbD;\r
+ aux1 qua noeud.arbG:=obj;\r
+ nd qua noeud.arbD:=none;\r
+ fi;\r
+ fi; \r
+ fi; \r
+ result:=aux1;\r
+ end ordre;\r
+\r
+ Unit supI:function(r:arbre):objet;\r
+ var theleave:objet;\r
+ begin\r
+ if r<>none then\r
+ \r
+ if r is feuille then \r
+ theleave:=r.getinfo(leave);\r
+ result:=theleave;\r
+ else\r
+ if r qua noeud.arbD=none then\r
+ result:=supI(r qua noeud.arbM);\r
+ else\r
+ result:=supI(r qua noeud.arbD);\r
+ fi;\r
+ fi;\r
+ else\r
+ result:=none;\r
+ fi;\r
+ end supI;\r
+\r
+(************************************************************************************)\r
+\r
+Unit inserer: IIUWGRAPH procedure; \r
+var num:file,\r
+ a:integer;\r
+var exist:boolean,\r
+ d:arbre,\r
+ rt:elem,\r
+ components,i:integer;\r
+begin \r
+ i:=100;\r
+ do \r
+ call move(5,290);\r
+ call color(grisfonce);\r
+ call outstring("Element a inserer :");\r
+ \r
+ rt:= new elem (ConvEnt(SAISIE(longueur,160,290)));\r
+ \r
+ d:=racine;\r
+ exist:=member(d,rt);\r
+ if not exist then\r
+ call insertion(d,rt);\r
+\r
+ else \r
+ call color(rouge);\r
+ call move(200,290);\r
+ call outstring(" ... element existe deja! ...");\r
+ fi;\r
+ \r
+ a:=inchar(2);\r
+ if a=27 then exit;\r
+ else \r
+ if not exist then\r
+ call move(50,300);\r
+ call color(bleu);\r
+ call outstring("===>");\r
+ \r
+ call rt.show(i,300); i:=i+22; fi;\r
+ fi;\r
+ call move(1,290);\r
+ call outstring(" ");\r
+ od;\r
+ call move(1,290);\r
+ call outstring(" ");\r
+ call move(1,300);\r
+ call outstring(" ");\r
+end inserer;\r
+\r
+UNIT insertion:procedure(pere:arbre,v:objet);\r
+\r
+ var p,fils:arbre,\r
+ linf,lesupdupere,lesupduaux:objet; \r
+Begin\r
+\r
+\r
+ if pere<>none then\r
+ \r
+ \r
+ if pere is noeud then \r
+ fils:=SousArbre(pere,v);\r
+ else (* l'arbre est constitu\82 d'une seule feuille *)\r
+ fils:=pere;\r
+ \r
+ fi;\r
+ \r
+ linf:=fils.getinfo(inf);\r
+ if fils is feuille then\r
+ \r
+ if pere=fils then\r
+ racine:=new noeud(v,v);\r
+ \r
+ if linf.getvalue<v.getvalue then\r
+ racine qua noeud.arbG:=fils;\r
+ racine qua noeud.arbM:=new feuille(v);\r
+ else\r
+ racine qua noeud.arbM:=fils;\r
+ racine qua noeud.arbG:=new feuille(v);\r
+ fi; \r
+ \r
+ racine qua noeud.inf:=supI(racine qua noeud.arbG);\r
+ racine qua noeud.sup:=supI(racine qua noeud.arbM);\r
+ else \r
+ \r
+ if pere qua noeud.integre then \r
+ p:=new feuille(v);\r
+ call ordonne(v,pere,p);\r
+ eq:=true;\r
+ else (* le noeud comportera plus de trois elements ...*)\r
+ eq:=true; (* il faut donc le rendre "23"*)\r
+ aux:=ordre(v,pere,new feuille(v)); \r
+ if pere=racine then\r
+ racine:=new noeud(v,v);\r
+ lesupdupere:=pere.getinfo(sup); \r
+ lesupduaux:=aux.getinfo(sup);\r
+ if lesupduPERE.getvalue<lesupduAUX.getvalue then\r
+ racine qua noeud.arbG:=pere;\r
+ racine qua noeud.arbM:=aux;\r
+ else\r
+ racine qua noeud.arbM:=pere;\r
+ racine qua noeud.arbG:=aux;\r
+ fi; \r
+ \r
+ racine qua noeud.inf:=supI(racine qua noeud.arbG);\r
+ racine qua noeud.sup:=supI(racine qua noeud.arbM);\r
+ eq:=false;\r
+ aux:=none;\r
+ fi;\r
+ fi; \r
+ \r
+ fi;\r
+ else \r
+ call insertion(fils,v);\r
+ \r
+ if eq then\r
+ if aux<>none then\r
+ if pere=racine then\r
+ if pere qua noeud.integre then\r
+ call ordonne(aux qua noeud.sup,pere,aux);\r
+ else\r
+ p:=ordre(aux qua noeud.sup,pere,aux);\r
+ lesupduPERE:=pere.getinfo(sup); \r
+ lesupduAUX:=p.getinfo(sup);\r
+ if LesupduAUX.getvalue>LesupduPERE.getvalue then\r
+ racine:=new noeud(pere qua noeud.sup,p qua noeud.sup);\r
+ racine qua noeud.arbG:=pere;\r
+ racine qua noeud.arbM:=p;\r
+ \r
+ else\r
+ racine:=new noeud(p qua noeud.sup,pere qua noeud.sup);\r
+ racine qua noeud.arbM:=pere;\r
+ racine qua noeud.arbG:=p;\r
+ fi; \r
+ \r
+ fi;\r
+ eq:=false;\r
+ aux:=none;\r
+ \r
+ else\r
+ if pere qua noeud.integre then\r
+ call ordonne(aux qua noeud.sup,pere,aux);\r
+ aux:=none;\r
+ else\r
+ aux:=ordre(aux qua noeud.sup,pere,aux);\r
+ fi;\r
+ fi;\r
+ else (* mise a jour des noeud uniquement*)\r
+ pere qua noeud.inf:= supI(pere qua noeud.arbG);\r
+ pere qua noeud.sup:= supI(pere qua noeud.arbM);\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+ else\r
+ racine:=new feuille(v); \r
+ fi;\r
+\r
+END insertion;\r
+ \r
+\r
+\r
+BEGIN \r
+\r
+racine:=none;\r
+aux:=none; \r
+eq:=false;\r
+\r
+END arbre23;\r
+\r
+\r
+\r
+\r
+\r
+(************************* PROGRAMME PRINCIPAL ******************************)\r
+\r
+CONST longueur=2,\r
+ rouge=4,\r
+ vert=2,\r
+ marron=6,\r
+ grisclair=7,\r
+ grisfonce=8,\r
+ violet=5, \r
+ vertclair=10,\r
+ bleu=9,\r
+ sup=2,\r
+ couleur=3,\r
+ inf=1,leave=1;\r
+\r
+VAR i:integer;\r
+ \r
+\r
+\r
+BEGIN\r
+ \r
+ \r
+ \r
+ pref iiuwgraph block\r
+ begin \r
+ pref arbre23 block\r
+ var rt:elem;\r
+ begin \r
+ call gron(2);\r
+ do\r
+ call cls;\r
+ racine:=root;\r
+ call affichage(racine);\r
+ call drawmenu;\r
+ \r
+ i:=selectmenu;\r
+ call move(1,265);\r
+ call color(rouge);\r
+ case i\r
+ when 1: \r
+ call outstring(" Insertion d'un ou plusieurs elements dans l'arbre");\r
+ call inserer;\r
+ \r
+ when 2:\r
+ call outstring(" Suppression d'un element dans l'arbre");\r
+ call move(10,280);\r
+ call color(rouge);\r
+ call outstring("element a supprimer:");\r
+ rt:=new elem(convent(saisie(2,200,280)));\r
+ call color(grisclair);\r
+ call move(130,300);\r
+ if suppression(racine,rt) then \r
+ call outstring("L'ELEMENT A ETE SUPPRIME !");\r
+ else\r
+ call outstring("L'ELEMENT A SUPPRIMER N'APPARTIENT PAS A L'ARBRE !");\r
+ fi;\r
+ i:=inchar(1);\r
+ kill(rt);\r
+ when 3:\r
+ call outstring(" Recherche de l'element minimum appartenant a l'arbre");\r
+ call move(10,300);\r
+ call color(grisclair);\r
+ call outstring("l'element minimum est -->");\r
+ rt:=minimum(racine);\r
+ call color(rouge);\r
+ if rt<>none then\r
+ call rt.show(250,300);\r
+ i:=inchar(1);\r
+ fi;\r
+ when 4:\r
+ call outstring(" Interrogation sur l'appartenance d'un element..."); \r
+ call move(10,280);\r
+ call color(grisfonce);\r
+ call outstring("element :");\r
+ rt:=new elem(convent(saisie(2,200,280)));\r
+ call move(100,300);\r
+ call color(grisclair);\r
+ if member(racine,rt) then \r
+ call outstring("L'ELEMENT APPARTIENT A L'ARBRE !");\r
+ else call outstring("L'ELEMENT N'APPARTIENT PAS A L'ARBRE !");\r
+ fi;\r
+ kill(rt);\r
+ i:=inchar(1);\r
+ when 5: call reset(racine);\r
+ when 0: exit;\r
+ esac;\r
+ od;\r
+ call reset(racine);\r
+ kill(rt);\r
+ call groff; \r
+ \r
+ end; (* block arbre23 *) \r
+ end; (* block IIUWGRAPH *)\r
+\r
+\r
+END projet2;\r
+\r
--- /dev/null
+program drzewo;\r
+(*-----------------------------------------------------------------------*)\r
+(* 2-3 tree J.Kujawski 1989-90 *)\r
+(*-----------------------------------------------------------------------*)\r
+ \r
+CONST min = 0 ,\r
+ max = 99 ,\r
+ lewy = ".lsyn" ,\r
+ prawy = ".psyn" ,\r
+ srodkowy = ".ssyn" ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+VAR\r
+ node :drzewo ,\r
+ i,j : integer ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+SIGNAL emptytree ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT drzewo:class;\r
+ \r
+ Var klucz:integer,\r
+ lsyn,psyn:drzewo,\r
+ logl,logp:boolean;\r
+ \r
+ Unit lisc : function :boolean ;\r
+ begin\r
+ result := lsyn = none\r
+ end lisc\r
+end drzewo;\r
+ \r
+ \r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT licznosc :function (d:drzewo , p:integer , log:boolean):integer ;\r
+ \r
+(* Liczy ile miejsca potrzeba do wydruku linii *)\r
+ \r
+Var licznik : integer ;\r
+ \r
+Signal alarm ;\r
+ \r
+ \r
+Unit licz :procedure (d:drzewo) ;\r
+ begin\r
+ i := i+1 ;\r
+ if d = none then raise alarm fi;\r
+ if i = p then\r
+ if log then licznik := licznik + 1\r
+ else\r
+ if d.logp then\r
+ licznik := licznik + 6\r
+ else\r
+ licznik := licznik + 3 ;\r
+ fi\r
+ fi\r
+ else\r
+ call licz (d.lsyn) ;\r
+ if d.logp then\r
+ call licz(d.psyn.lsyn) ;\r
+ call licz(d.psyn.psyn) ;\r
+ else\r
+ call licz(d.psyn)\r
+ fi\r
+ fi ;\r
+ i := i-1\r
+end licz ;\r
+ \r
+Handlers\r
+ when alarm : licznik := 0 ;\r
+ wind\r
+end handlers ;\r
+ \r
+Begin\r
+ licznik :=0 ;\r
+ i := 0 ;\r
+ call licz (d) ;\r
+ result := licznik\r
+end licznosc ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT infix :procedure(d : drzewo) ;\r
+ \r
+Begin\r
+ if d.lisc then\r
+ write(d.klucz:3)\r
+ else\r
+ call infix (d.lsyn );\r
+ call infix (d.psyn )\r
+ fi\r
+end infix ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT empty : function (d : drzewo) : boolean ;\r
+ Begin\r
+ result := d = none\r
+End empty ;\r
+ \r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT minimum : function (d : drzewo) : integer ;\r
+ \r
+Begin\r
+ if d = none then\r
+ raise emptytree\r
+ else\r
+ if d.lisc then\r
+ result := d.klucz\r
+ else\r
+ result := minimum (d.lsyn)\r
+ fi\r
+ fi\r
+end minimum ;\r
+ \r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT member : function ( k:integer , d:drzewo ) : boolean ;\r
+ \r
+ Begin\r
+ if d <> none then\r
+ if d.klucz <> k then\r
+ if d.klucz < k then\r
+ result := member(k,d.psyn);\r
+ else\r
+ result := member(k,d.lsyn);\r
+ fi\r
+ else\r
+ result := true\r
+ fi\r
+ else\r
+ result := false\r
+ fi\r
+ end member ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT insert : procedure ( k : integer ; inout d : drzewo ) ;\r
+ \r
+Var pom1,pom2 : drzewo ,\r
+ max1,max2 : integer ;\r
+ \r
+Signal jest ;\r
+ \r
+Unit ins : procedure ( a:drzewo ) ;\r
+Begin\r
+ if a.klucz = k then raise jest\r
+ fi ;\r
+ if a.lisc then\r
+ pom1 := new drzewo ;\r
+ if a.klucz < k then\r
+ pom1.klucz := k ;\r
+ max1 := a.klucz\r
+ else\r
+ pom1.klucz := a.klucz ;\r
+ max1 := k ;\r
+ a.klucz := k\r
+ fi\r
+ else\r
+ if k <= a.klucz then\r
+ call ins (a.lsyn ) ;\r
+ if pom1 <> none then\r
+ if a.logl then\r
+ pom2 := a.psyn ;\r
+ a.psyn := pom1 ;\r
+ max2 := a.klucz ;\r
+ a.klucz := max1 ;\r
+ max1 := max2 ;\r
+ pom1 := pom2\r
+ else\r
+ if a.logp then\r
+ pom2 := a.psyn ;\r
+ a.psyn := pom1 ;\r
+ max2 := a.klucz ;\r
+ a.klucz := max1 ;\r
+ max1 := max2 ;\r
+ pom1 := pom2 ;\r
+ a.logp,pom1.logl := false\r
+ else\r
+ pom2 := new drzewo ;\r
+ pom2.lsyn := pom1 ;\r
+ pom2.psyn := a.psyn ;\r
+ pom2.klucz := a.klucz ;\r
+ a.klucz := max1 ;\r
+ pom2.logl,a.logp := true ;\r
+ a.psyn := pom2 ;\r
+ pom1 := none\r
+ fi\r
+ fi\r
+ fi\r
+ else\r
+ call ins (a.psyn) ;\r
+ if pom1 <> none then\r
+ if a.logp then\r
+ pom2 := a.psyn ;\r
+ a.psyn := a.psyn.lsyn ;\r
+ pom2.lsyn := pom2.psyn ;\r
+ pom2.psyn := pom1 ;\r
+ max2 := max1 ;\r
+ max1 := pom2.klucz ;\r
+ pom2.klucz := max2 ;\r
+ pom1 := pom2 ;\r
+ pom1.logl,a.logp := false\r
+ else\r
+ if not a.logl then\r
+ pom2 := new drzewo ;\r
+ pom2.psyn := pom1 ;\r
+ pom2.lsyn := a.psyn ;\r
+ a.psyn := pom2 ;\r
+ pom2.klucz := max1 ;\r
+ a.logp,pom2.logl := true ;\r
+ pom1 := none\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+end ins ;\r
+ \r
+Handlers\r
+ when jest : call setcursor(20,1) ;\r
+ call eraseline ;\r
+ writeln("element ",k:2," already in this tree") ;\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("press any key") ;\r
+ call cursorleft (1) ;\r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor (20,1) ;\r
+ call eraseline ;\r
+ terminate\r
+end handlers ;\r
+ \r
+Begin\r
+ if d=none then\r
+ d := new drzewo ;\r
+ d.klucz := k\r
+ else\r
+ call ins (d) ;\r
+ if pom1 <> none then\r
+ pom2 := new drzewo ;\r
+ pom2.klucz := max1 ;\r
+ pom2.lsyn := d ;\r
+ pom2.psyn := pom1 ;\r
+ d := pom2\r
+ fi\r
+ fi\r
+end insert ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT delete:procedure(k:integer;inout d:drzewo);\r
+ \r
+ Var pom,pom1 : drzewo ,\r
+ nowymax : integer ,\r
+ kon : boolean ;\r
+ \r
+ Signal koniec ,niema ;\r
+ \r
+ Unit del : procedure (inout d : drzewo ) ;\r
+ \r
+ Begin\r
+ if d.lisc then\r
+ if d.klucz = k then\r
+ kill (d)\r
+ else\r
+ raise niema\r
+ fi\r
+ else\r
+ if d.klucz >= k then\r
+ call del (d.lsyn) ;\r
+ if kon then\r
+ raise koniec\r
+ fi ;\r
+ if d.lsyn = none then\r
+ if pom = none then\r
+ if d.logp then\r
+ pom1 := d ;\r
+ d := d.psyn ;\r
+ d.logl := false ;\r
+ kill (pom1) ;\r
+ kon := true\r
+ else\r
+ pom := d.psyn ;\r
+ kill (d)\r
+ fi\r
+ else\r
+ if k = d.klucz then\r
+ d.klucz := nowymax\r
+ fi ;\r
+ if d.logp then\r
+ if d.psyn.lsyn.logp then\r
+ pom1 := d.psyn.lsyn ;\r
+ d.psyn.lsyn := d.psyn.lsyn.psyn ;\r
+ d.lsyn :=pom ;\r
+ pom1.psyn := d.psyn ;\r
+ d.psyn := pom1.lsyn ;\r
+ pom1.lsyn := d ;\r
+ d := pom1 ;\r
+ d.logp,d.psyn.logl := false ;\r
+ d.lsyn.logp , d.psyn.lsyn.logl := false ;\r
+ kon := true\r
+ else\r
+ pom1 := d.psyn ;\r
+ d.lsyn := pom ;\r
+ d.psyn := d.psyn.lsyn ;\r
+ pom1.lsyn := d ;\r
+ d := pom1 ;\r
+ d.logl := false ;\r
+ d.lsyn.psyn.logl := true ;\r
+ pom := none ;\r
+ kon := true\r
+ fi\r
+ else\r
+ if d.psyn.logp then\r
+ pom1 := d.psyn ;\r
+ d.lsyn := pom ;\r
+ d.psyn := d.psyn.lsyn ;\r
+ pom1.lsyn := d ;\r
+ d := pom1 ;\r
+ d.logp , d.psyn.logl := false ;\r
+ if d.lsyn.logl then\r
+ d.lsyn.logl := false ;\r
+ d.logl := true\r
+ fi ;\r
+ pom := none ;\r
+ kon := true\r
+ else\r
+ d.lsyn := pom ;\r
+ d.psyn.logl , d.logp := true ;\r
+ pom := d ;\r
+ d := none ;\r
+ fi\r
+ fi\r
+ fi\r
+ else\r
+ \r
+ if k = d.klucz then d.klucz := nowymax fi;\r
+ pom := none ;\r
+ kon := true\r
+ fi\r
+ else\r
+ call del (d.psyn) ;\r
+ if kon then\r
+ raise koniec\r
+ fi ;\r
+ if d.psyn = none then\r
+ if pom = none then\r
+ nowymax := d.lsyn.klucz ;\r
+ pom := d.lsyn ;\r
+ kill (d)\r
+ else\r
+ if d.logp then\r
+ d.psyn := pom ;\r
+ d.logp := false ;\r
+ d.psyn.logl := false ;\r
+ pom := none\r
+ else\r
+ if d.lsyn.logp then\r
+ pom1 := d.lsyn ;\r
+ d.psyn := pom ;\r
+ d.lsyn := pom1.psyn.psyn ;\r
+ pom1.psyn.psyn := d ;\r
+ d := pom1.psyn ;\r
+ pom1.psyn := d.lsyn ;\r
+ d.lsyn := pom1 ;\r
+ d.logl , d.lsyn.logp := false ;\r
+ pom := none\r
+ else\r
+ pom1 := d.lsyn ;\r
+ d.psyn := pom ;\r
+ d.lsyn := d.lsyn.psyn ;\r
+ pom1.psyn :=d ;\r
+ pom :=pom1 ;\r
+ pom1.logp , pom1.psyn.logl := true ;\r
+ d := none ;\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ end del ;\r
+ \r
+Handlers\r
+ when niema : call setcursor(20,1) ;\r
+ writeln("There is no ",k:2," in the tree") ;\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("press any key") ;\r
+ call cursorleft (1) ;\r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor(20,1) ;\r
+ call eraseline ;\r
+ terminate ;\r
+ when koniec : terminate\r
+end handlers ;\r
+ \r
+ Begin\r
+ if d = none then\r
+ raise niema\r
+ else\r
+ call del (d) ;\r
+ if pom <> none then\r
+ d := pom\r
+ fi\r
+ fi\r
+end delete ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+Unit delmin : procedure (inout d : drzewo) ;\r
+ \r
+ Var a : integer ;\r
+ \r
+ Begin\r
+ if empty (d) then\r
+ raise emptytree\r
+ else\r
+ a := minimum (d) ;\r
+ call delete (a,d)\r
+ fi\r
+End delmin\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+(* PROCEDURY prawie GRAFICZNE *)\r
+(* ----------------------------------------------------------------------*)\r
+ \r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+ \r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ \r
+ unit EraseLine : procedure;\r
+ begin\r
+ write( chr(27), "[K")\r
+ end EraseLine;\r
+ \r
+ unit inchar : IIUWgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
+ unit CursorLeft : procedure (columns : integer);\r
+ var e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := columns div 10;\r
+ j := columns mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", e, f, "D")\r
+ end CursorLeft;\r
+ \r
+ unit CursorRight : procedure (columns : integer);\r
+ var e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := columns div 10;\r
+ j := columns mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", e, f, "C")\r
+ end CursorRight;\r
+ \r
+ unit CursorUp : procedure (rows : integer);\r
+ var c,d : char,\r
+ i,j : integer;\r
+ begin\r
+ i := rows div 10;\r
+ j := rows mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ write( chr(27), "[", c, d, "A")\r
+ end CursorUp;\r
+ \r
+ unit CursorDown : procedure (rows : integer);\r
+ var c,d : char,\r
+ i,j : integer;\r
+ begin\r
+ i := rows div 10;\r
+ j := rows mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ write( chr(27), "[", c, d, "B")\r
+ end CursorDown;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT czekaj :procedure ;\r
+ Var i :integer ;\r
+ Begin\r
+ i := inchar\r
+End czekaj ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+unit PrAnyKey : procedure;\r
+begin\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("press any key") ;\r
+ call cursorleft (1) ;\r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor(20,1) ;\r
+ call eraseline;\r
+end PrAnyKey;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+UNIT tytul : procedure ;\r
+Begin\r
+ call newpage ;\r
+ call setcursor (10,30) ;\r
+ write ("PRIORITY QUEUE in 2-3 TREE ") ;\r
+ call setcursor (15,32) ;\r
+ write ("Author : Adam Kujawski") ;\r
+ call PrAnyKey;\r
+ \r
+end tytul ;\r
+ \r
+ \r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT menu : procedure ;\r
+ \r
+Unit insdelmenu : procedure(formal : boolean) ;\r
+ Var c1,c2,c3 : integer ;\r
+ \r
+ Begin\r
+ call newpage ;\r
+ call setcursor (5,25) ;\r
+ write ("Give a number x to insert ") ;\r
+ call setcursor (7,25) ;\r
+ write ( " 0 < x < 100 .") ;\r
+ call setcursor (9,25) ;\r
+ writeln (" 0 --- to terminate the operation") ;\r
+ \r
+ Do\r
+ call setcursor(15,39);\r
+ call eraseline ;\r
+ c1 := 0 ;\r
+ c2 := 0 ;\r
+ do\r
+ c1 := inchar ;\r
+ if c1 >= 48 andif c1 <= 57 then\r
+ write (chr(c1)) ;\r
+ do\r
+ c2 := inchar ;\r
+ if c2 >= 48 andif c2 <= 57 then\r
+ write (chr (c2)) ;\r
+ do\r
+ c3 := inchar ;\r
+ if c3 = 13 then\r
+ j := (c1-48) * 10 + (c2-48) ;\r
+ exit exit exit\r
+ else\r
+ if c3 = 8 then\r
+ c2 := 0 ;\r
+ call cursorleft(1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi\r
+ od\r
+ else\r
+ if c2 = 13 then\r
+ j := c1-48 ;\r
+ exit exit\r
+ else\r
+ if c2 = 8 then\r
+ c1 := 0 ;\r
+ call cursorleft (1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi\r
+ fi\r
+ od\r
+ fi\r
+ od ;\r
+ \r
+ if j < 100 andif j > 0 then\r
+ if formal then\r
+ call insert (j,node) ;\r
+ else\r
+ call delete (j,node) ;\r
+ fi ;\r
+ call setcursor(20,1) ;\r
+ call eraseline ;\r
+ write (" O.K.")\r
+ else\r
+ if j = 0 then\r
+ exit\r
+ fi\r
+ fi\r
+ Od\r
+ end insdelmenu ;\r
+ \r
+(*----------------------------------------------------------------------*)\r
+ \r
+Unit membermenu : procedure ;\r
+ \r
+ Var c1,c2,c3 : integer ,\r
+ bool1 : boolean ;\r
+ \r
+ Begin\r
+ call newpage ;\r
+ call setcursor (5,25) ;\r
+ write ("Give a number x ") ;\r
+ call setcursor (7,25) ;\r
+ write ( " 0 < x < 100 .") ;\r
+ call setcursor (9,25) ;\r
+ writeln (" 0 --- to terminate the operation") ;\r
+ \r
+ Do\r
+ call setcursor(15,39);\r
+ call eraseline ;\r
+ c1 := 0 ;\r
+ c2 := 0 ;\r
+ do\r
+ c1 := inchar ;\r
+ if c1 >= 48 andif c1 <= 57 then\r
+ write (chr(c1)) ;\r
+ do\r
+ c2 := inchar ;\r
+ if c2 >= 48 andif c2 <= 57 then\r
+ write (chr (c2)) ;\r
+ do\r
+ c3 := inchar ;\r
+ if c3 = 13 then\r
+ j := (c1-48) * 10 + (c2-48) ;\r
+ exit exit exit\r
+ else\r
+ if c3 = 8 then\r
+ c2 := 0 ;\r
+ call cursorleft(1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi\r
+ od\r
+ else\r
+ if c2 = 13 then\r
+ j := c1-48 ;\r
+ exit exit\r
+ else\r
+ if c2 = 8 then\r
+ c1 := 0 ;\r
+ call cursorleft (1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi\r
+ fi\r
+ od\r
+ fi\r
+ od ;\r
+ \r
+ if j < 100 andif j > 0 then\r
+ bool1 := member (j,node) ;\r
+ call setcursor (20,20) ;\r
+ if bool1 then\r
+ write(" Element ",j:2," exists already in the tree.")\r
+ else\r
+ write (" There is no ",j:2," in the tree.")\r
+ fi ;\r
+ call PrAnyKey;\r
+ fi ;\r
+ \r
+ if j = 0 then\r
+ exit\r
+ fi\r
+ Od\r
+end membermenu ;\r
+(*-----------------------------------------------------------------------*)\r
+ \r
+Unit help : procedure ;\r
+ \r
+Begin\r
+ call newpage ;\r
+ call setcursor (7,1) ;\r
+ write (" If you do not know : ") ;\r
+ write (" ^d = 'Ctrl' + 'd' .") ;\r
+ call PrAnyKey;\r
+end help ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+Unit emptymenu : procedure ;\r
+Var bo : boolean ;\r
+Begin\r
+ call newpage ;\r
+ bo := empty (node) ;\r
+ call setcursor (12,25) ;\r
+ if bo then\r
+ write ( "The tree is empty.") ;\r
+ else\r
+ write ("This is not empty tree.") ;\r
+ fi ;\r
+ call PrAnyKey;\r
+end emptymenu ;\r
+(*------------------------------------------------------------------------*)\r
+ \r
+Unit minimummenu:procedure ;\r
+Var x : integer ;\r
+Begin\r
+ if empty (node) then\r
+ raise emptytree\r
+ else\r
+ x := minimum(node) ;\r
+ call newpage ;\r
+ call setcursor(12,20) ;\r
+ write ("A minimal element of the tree : ",x:2," .") ;\r
+ call PrAnyKey;\r
+ fi\r
+end minimummenu;\r
+(*---------------------------------------------------------------------*)\r
+ \r
+Unit rysmenu :procedure ;\r
+ \r
+Unit listawezlow : class ;\r
+ var dr : drzewo ,\r
+ kier : integer ,\r
+ next,pop : listawezlow ;\r
+end listawezlow ;\r
+ \r
+Var aktualny : listawezlow ,\r
+ pom : listawezlow ;\r
+ \r
+Begin\r
+ aktualny := new listawezlow ;\r
+ aktualny.dr := node ;\r
+DO\r
+ call newpage ;\r
+ call setcursor (10,30);\r
+ call reverse ;\r
+ write (" S U B M E N U ") ;\r
+ call normal ;\r
+ call setcursor (13,27);\r
+ write ("-> , <- - to change the actual tree") ;\r
+ call setcursor (14,27);\r
+ write ("enter - draw the actual tree") ;\r
+ call setcursor (15,27);\r
+ write ("Esc - return to M E N U") ;\r
+ call setcursor (25,1);\r
+ write ("actual = root") ;\r
+ pom := aktualny ;\r
+ while pom.pop <> none\r
+ do\r
+ pom := pom.pop\r
+ od;\r
+ while pom.next <> none\r
+ do\r
+ case pom.kier\r
+ when 1 : write (lewy) ;\r
+ when 2 : write (srodkowy) ;\r
+ when 3 : write (prawy)\r
+ esac ;\r
+ pom := pom.next\r
+ od;\r
+ DO\r
+ i := inchar ;\r
+ if i > 0 then\r
+ case i\r
+ when 13 : exit ;\r
+ when 27 : exit exit\r
+ esac\r
+ else\r
+ case i + 80\r
+ when 8 : if aktualny.dr <> node then\r
+ aktualny := aktualny.pop ;\r
+ call cursorleft(5) ;\r
+ call eraseline ;\r
+ kill (aktualny.next) ;\r
+ aktualny.kier := 0\r
+ fi ;\r
+ when 5 :if aktualny.dr <> none then\r
+ pom := new listawezlow ;\r
+ pom.pop := aktualny ;\r
+ pom.dr := aktualny.dr.lsyn ;\r
+ aktualny.next := pom ;\r
+ aktualny.kier := 1 ;\r
+ aktualny := pom ;\r
+ write (lewy)\r
+ fi ;\r
+ when 3 :if aktualny.dr <> none then\r
+ pom := new listawezlow ;\r
+ pom.pop := aktualny ;\r
+ if aktualny.dr.logp then\r
+ pom.dr := aktualny.dr.psyn.psyn\r
+ else\r
+ pom.dr := aktualny.dr.psyn\r
+ fi ;\r
+ aktualny.next := pom ;\r
+ aktualny.kier := 3 ;\r
+ aktualny := pom ;\r
+ write (prawy) ;\r
+ fi ;\r
+ when 0 :if aktualny.dr <> none then\r
+ if aktualny.dr.logp then\r
+ pom := new listawezlow ;\r
+ pom.pop := aktualny ;\r
+ aktualny.next := pom ;\r
+ pom.dr := aktualny.dr.psyn.lsyn ;\r
+ aktualny.kier := 2 ;\r
+ aktualny := pom ;\r
+ write (srodkowy)\r
+ fi ;\r
+ fi\r
+ esac\r
+ fi\r
+ \r
+ OD ;\r
+ call rys (aktualny.dr)\r
+ OD\r
+ \r
+end rysmenu ;\r
+(*--------------------------------------------------------------------*)\r
+ \r
+Begin\r
+DO\r
+ call newpage ;\r
+ call setcursor (13,31);\r
+ call reverse ;\r
+ write (" M E N U ") ;\r
+ call normal ;\r
+ call setcursor (13,30);\r
+ write ("i - insert") ;\r
+ call setcursor (14,30);\r
+ write ("d - delete");\r
+ call setcursor (15,30);\r
+ write ("m - member" );\r
+ call setcursor (16,30);\r
+ write ("e - empty?") ;\r
+ call setcursor (17,30);\r
+ write ("w - draw tree");\r
+ call setcursor (18,30);\r
+ write ("^m - minimum");\r
+ call setcursor (19,30);\r
+ write ("^d - delmin");\r
+ call reverse ;\r
+ call setcursor (25,1);\r
+ write (" F1 - HELP , Esc - end of the execution ");\r
+ call normal ;\r
+ \r
+ DO\r
+ i := inchar ;\r
+ if i = 27 then\r
+ exit exit\r
+ else\r
+ if i > 80 then\r
+ case i\r
+ when 105 : call insdelmenu(true) ;\r
+ when 100 : call insdelmenu(false) ;\r
+ when 109 : call membermenu ;\r
+ when 101 : call emptymenu ;\r
+ when 119 : call rysmenu ;\r
+ esac;\r
+ exit\r
+ else\r
+ case i + 60\r
+ when 64 : call delmin (node) ;\r
+ when 73 : call minimummenu ;\r
+ when 1 : call help ;\r
+ esac;\r
+ exit;\r
+ fi\r
+ fi\r
+ OD\r
+OD;\r
+call NewPage;\r
+ \r
+end menu ;\r
+(*-----------------------------------------------------------------------*)\r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT rys:IIUWGraph procedure(d:drzewo) ;\r
+ \r
+Const skok = 6 ;\r
+ \r
+Var licznik,poziom,licznik2 : integer ,\r
+ krok,krok2,staryx,staryy : integer ;\r
+ \r
+ \r
+ Unit ramka :procedure (wr,kol,dl:integer) ;\r
+ Var x1,y1,l,h :integer ;\r
+ Begin\r
+ x1 := (wr) * 8 - 2 ;\r
+ y1 := (kol) * 8 -2 ;\r
+ l := 8 * dl + 4 ;\r
+ h := 12 ;\r
+ call move (x1,y1) ;\r
+ call draw (x1+l,y1) ;\r
+ call draw (x1+l,y1+h) ;\r
+ call draw (x1,y1+h) ;\r
+ call draw (x1,y1) ;\r
+ call move (x1 + l div 2,y1) ;\r
+ call draw (staryx ,staryy ) ;\r
+ call move (x1+2,y1+2)\r
+ end ramka ;\r
+ \r
+ Unit print : procedure (a : integer) ;\r
+ Begin\r
+ if a > 9 then\r
+ call hascii (48 + a div 10)\r
+ fi;\r
+ call hascii (48 + a mod 10)\r
+ end print ;\r
+ \r
+ Unit odstep : function(d :drzewo,poziom :integer) : integer ;\r
+ var i,j : integer ;\r
+ \r
+ begin\r
+ j := licznosc (d,poziom,true) ;\r
+ i := licznosc (d,poziom,false) ;\r
+ result :=( 85 - i ) div (j+1)\r
+end odstep ;\r
+ \r
+Unit linia :procedure (d:drzewo);\r
+ \r
+ (* poziom = drukowany poziom *)\r
+ (* i - numer poziomu *)\r
+ \r
+ begin\r
+ i := i+1 ;\r
+ if poziom - 1 = i then\r
+ if d.logp then\r
+ staryx := licznik2 * 8 + 20;\r
+ staryy := i * skok * 8 + 10 ;\r
+ licznik2 := licznik2 + 6 + krok2\r
+ else\r
+ staryx := licznik2 * 8 + 8;\r
+ staryy := i * skok * 8 + 10 ;\r
+ licznik2 := licznik2 + 3 +krok2\r
+ fi\r
+ fi ;\r
+ if i = poziom then\r
+ if d.logp then\r
+ call ramka (licznik, poziom*skok ,5) ;\r
+ call print (d.klucz) ;\r
+ call hascii (44) ;\r
+ call print (d.psyn.klucz) ;\r
+ licznik := licznik + 6 + krok\r
+ else\r
+ call ramka (licznik, poziom*skok ,2) ;\r
+ call print (d.klucz) ;\r
+ licznik := licznik + 3 + krok\r
+ fi\r
+ else\r
+ call linia (d.lsyn) ;\r
+ if d.logp then\r
+ call linia(d.psyn.lsyn) ;\r
+ call linia(d.psyn.psyn) ;\r
+ else\r
+ call linia(d.psyn)\r
+ fi\r
+ fi;\r
+ i := i-1\r
+end linia ;\r
+ \r
+Unit napis1 : procedure ;\r
+begin\r
+ call move ( 275 ,335) ;\r
+ call hascii (78) ;\r
+ call hascii (97) ;\r
+ call hascii (99) ;\r
+ call hascii (105) ;\r
+ call hascii (115) ;\r
+ call hascii (110) ;\r
+ call hascii (105) ;\r
+ call hascii (106) ;\r
+ call hascii (32) ;\r
+ call hascii (99) ;\r
+ call hascii (111) ;\r
+ call hascii (107) ;\r
+ call hascii (111) ;\r
+ call hascii (108) ;\r
+ call hascii (119) ;\r
+ call hascii (105) ;\r
+ call hascii (101) ;\r
+ call hascii (107)\r
+ \r
+end napis1 ;\r
+ \r
+Unit napis2 : procedure ;\r
+begin\r
+ call move ( 275 ,300) ;\r
+ call hascii (66) ;\r
+ call hascii (114) ;\r
+ call hascii (97) ;\r
+ call hascii (107) ;\r
+ call hascii (32) ;\r
+ call hascii (109) ;\r
+ call hascii (105) ;\r
+ call hascii (101) ;\r
+ call hascii (106) ;\r
+ call hascii (115) ;\r
+ call hascii (99) ;\r
+ call hascii (97)\r
+ \r
+end napis2 ;\r
+ \r
+Unit napis3 : procedure ;\r
+ \r
+begin\r
+ call move ( 285 ,300) ;\r
+ call hascii (79) ;\r
+ call hascii (46) ;\r
+ call hascii (75) ;\r
+ call hascii (46) ;\r
+ \r
+end napis3 ;\r
+ \r
+Begin\r
+ call gron(0) ;\r
+ poziom:=1 ;\r
+ Do\r
+ j := licznosc(d,poziom,false) ;\r
+ if j>0 andif j<82 then\r
+ i := 0 ;\r
+ krok2 := odstep (d,poziom-1) ;\r
+ krok := odstep (d,poziom) ;\r
+ licznik := krok + 1 ;\r
+ licznik2 :=krok2 + 1 ;\r
+ staryx := 350 ;\r
+ staryy := skok * 8 -2 ;\r
+ call linia(d) ;\r
+ poziom := poziom+1\r
+ else\r
+ exit\r
+ fi\r
+ Od ;\r
+ call napis1 ;\r
+ if j >= 82 then\r
+ call napis2\r
+ else\r
+ call napis3\r
+ fi ;\r
+ call czekaj ;\r
+ call groff\r
+end rys;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+ \r
+HANDLERS\r
+ when emptytree : call newpage ;\r
+ call setcursor(12,30) ;\r
+ write ("EMPTY TREE !") ;\r
+ call PrAnyKey;\r
+ (*\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ;\r
+ call normal ;\r
+ call czekaj ;*)\r
+ return\r
+End handlers;\r
+(*-----------------------------------------------------------------------*)\r
+ (* program glowny *)\r
+(*-----------------------------------------------------------------------*)\r
+ \r
+BEGIN\r
+ \r
+ call tytul ;\r
+ call menu\r
+ \r
+END kolejka ;\r
--- /dev/null
+program grzybobranie;\r
+(* to mialo byc drzewo bst z wywazaniem -- AVL *)\r
+(* niestety nie zawsz dziala dobrze *)\r
+ \r
+unit drzewo:class;\r
+ \r
+ unit elem:class;\r
+ \r
+ unit virtual comp:function(e2:elem):integer;\r
+ end comp;\r
+ \r
+ end elem;\r
+ \r
+ unit slowo:class(el:elem);\r
+ var waga:integer,ls,rs:slowo;\r
+ begin\r
+ waga:=0;\r
+ ls,rs:=none;\r
+ inner;\r
+ end slowo;\r
+ \r
+ var korzen:slowo;\r
+ \r
+ unit virtual rysuj_drzewo:procedure;\r
+ end rysuj_drzewo;\r
+ \r
+ unit findc:coroutine(e:elem);\r
+ \r
+ var new_slowo:slowo,waga:integer;\r
+ \r
+ unit lrot:procedure(inout p:slowo);\r
+ var c1,c2:integer;\r
+ var pp,ppp:slowo;\r
+ begin\r
+ pp:=p;\r
+ p:=p.ls;\r
+ ppp:=p.rs;\r
+ p.rs:=pp;\r
+ pp.ls:=ppp;\r
+ c1:=pp.waga-p.waga+1;\r
+ if p.waga>0 then c1:=c1+p.waga; fi;\r
+ c2:=pp.waga;\r
+ if p.waga>0 then c2:=c2+p.waga; fi;\r
+ if p.waga>c2 then c2:=p.waga; fi;\r
+ pp.waga:=c2+1;\r
+ p.waga:=c1;\r
+ waga:=0;\r
+ end lrot;\r
+ \r
+ unit rrot:procedure(inout p:slowo);\r
+ var c1,c2:integer;\r
+ var pp,ppp:slowo;\r
+ begin\r
+ pp:=p;\r
+ p:=p.rs;\r
+ ppp:=p.ls;\r
+ p.ls:=pp;\r
+ pp.rs:=ppp;\r
+ c1:=-1+pp.waga;\r
+ if p.waga>0 then c1:=c1-p.waga; fi;\r
+ c2:=1-pp.waga;\r
+ if p.waga>0 then c2:=c2+p.waga; fi;\r
+ if c2<0 then c2:=0; fi;\r
+ c2:=p.waga-c2-1;\r
+ pp.waga:=c1;\r
+ p.waga:=c2;\r
+ waga:=0;\r
+ end rrot;\r
+ \r
+ \r
+ unit f:procedure(inout s:slowo);\r
+ begin\r
+ if s=none then\r
+ detach;\r
+ s:=new_slowo;\r
+ else\r
+ if e.comp(s.el)<=0 then\r
+ call f(s.ls);\r
+ s.waga:=s.waga-waga;\r
+ else\r
+ call f(s.rs);\r
+ s.waga:=s.waga+waga;\r
+ fi;\r
+ if s.waga<-1 then\r
+ if s.ls.waga>0 then call rrot(s.ls) fi;\r
+ call lrot(s);\r
+ fi;\r
+ if s.waga>1 then\r
+ if s.rs.waga<0 then call lrot(s.rs) fi;\r
+ call rrot(s);\r
+ fi;\r
+ fi;\r
+ end f;\r
+ \r
+ begin\r
+ new_slowo:=none;\r
+ waga:=0;\r
+ return;\r
+ call f(korzen);\r
+ end findc;\r
+ \r
+ \r
+ \r
+ unit wstaw:procedure(e:elem);\r
+ \r
+ var f:findc;\r
+ \r
+ begin\r
+ f:=new findc(e);\r
+ attach(f);\r
+ f.new_slowo:=new slowo(e);\r
+ f.waga:=1;\r
+ attach(f);\r
+ kill(f);\r
+ end wstaw;\r
+ \r
+ \r
+ unit find:function(e:elem):slowo;\r
+ \r
+ unit f:function(s:slowo):slowo;\r
+ begin\r
+ if s=none then result:=none\r
+ else\r
+ if e.comp(s.el)=0 then result:=s\r
+ else\r
+ if e.comp(s.el)<0 then result:=f(s.ls)\r
+ else result:=f(s.rs)\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end f;\r
+ \r
+ begin\r
+ result:=f(korzen)\r
+ end find;\r
+ \r
+ \r
+ \r
+ unit delete:procedure(e:elem);\r
+ \r
+ unit find_last:function(s:slowo):slowo;\r
+ begin\r
+ result:=s;\r
+ if result.rs<>none then\r
+ while result.rs.rs<>none do result:=result.rs; od;\r
+ fi;\r
+ end find_last;\r
+ \r
+ var s,ss:slowo;\r
+ \r
+ begin\r
+ s:=find(e);\r
+ if s<>none then\r
+ if s.ls<>none then\r
+ ss:=find_last(s.ls);\r
+ kill(s.el);\r
+ if ss.rs<>none then\r
+ s.el:=ss.rs.el;\r
+ if ss.rs.ls<>none then\r
+ ss.rs.el:=ss.rs.ls.el;\r
+ kill(ss.rs.ls);\r
+ else\r
+ kill(ss.rs);\r
+ fi;\r
+ else\r
+ s.el:=ss.el;\r
+ if ss.ls<>none then\r
+ ss.el:=ss.ls.el;\r
+ kill(ss.ls);\r
+ else\r
+ kill(ss);\r
+ fi;\r
+ fi;\r
+ else\r
+ if s.rs<>none then\r
+ kill(s.el);\r
+ s.el:=s.rs.el;\r
+ s.ls:=s.rs.ls;\r
+ ss:=s.rs;\r
+ s.rs:=s.rs.rs;\r
+ kill(ss);\r
+ else\r
+ kill(s);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ kill(e);\r
+ end delete;\r
+ \r
+ \r
+ unit porzadek:class;\r
+ var e:elem,x,y,d,nawias:integer,\r
+ czy_korzen,czy_lewy,koniec:boolean,\r
+ w:integer;\r
+ unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
+ end next;\r
+ \r
+ begin\r
+ y:=0;\r
+ koniec:=false;\r
+ return;\r
+ do\r
+ call next(korzen,1,16,40,false);\r
+ koniec:=true;\r
+ detach;\r
+ od;\r
+ end porzadek;\r
+ \r
+ \r
+ unit lex:porzadek coroutine;\r
+ \r
+ unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
+ begin\r
+ if s<> none then\r
+ nawias:=1;\r
+ detach;\r
+ call next(s.ls,i+1,dx div 2,ix-dx,true);\r
+ e:=s.el;\r
+ y:=i;x:=ix;\r
+ nawias:=0;\r
+ czy_korzen:=(s=korzen);\r
+ czy_lewy:=lewy;\r
+ d:=dx;\r
+ detach;\r
+ call next(s.rs,i+1,dx div 2,ix+dx,false);\r
+ nawias:=2;\r
+ detach;\r
+ fi;\r
+ end next;\r
+ \r
+ end lex;\r
+ \r
+ unit pre:porzadek coroutine;\r
+ \r
+ unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
+ begin\r
+ if s<> none then\r
+ nawias:=1;\r
+ detach;\r
+ e:=s.el;\r
+ y:=i;x:=ix;\r
+ nawias:=0;\r
+ czy_korzen:=(s=korzen);\r
+ czy_lewy:=lewy;\r
+ d:=dx;\r
+ w:=s.waga;\r
+ detach;\r
+ call next(s.ls,i+1,dx div 2,ix-dx,true);\r
+ call next(s.rs,i+1,dx div 2,ix+dx,false);\r
+ nawias:=2;\r
+ detach;\r
+ fi;\r
+ end next;\r
+ \r
+ end pre;\r
+ \r
+ unit post:porzadek coroutine;\r
+ \r
+ unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
+ begin\r
+ if s<> none then\r
+ nawias:=1;\r
+ detach;\r
+ call next(s.ls,i+1,dx div 2,ix-dx,true);\r
+ call next(s.rs,i+1,dx div 2,ix+dx,false);\r
+ e:=s.el;\r
+ y:=i;x:=ix;\r
+ nawias:=0;\r
+ czy_korzen:=(s=korzen);\r
+ czy_lewy:=lewy;\r
+ d:=dx;\r
+ detach;\r
+ nawias:=2;\r
+ detach;\r
+ fi;\r
+ end next;\r
+ \r
+ end post;\r
+ \r
+end drzewo;\r
+ \r
+unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+end SetCursor;\r
+ \r
+ \r
+unit drzewo_liczb:drzewo class;\r
+ \r
+ unit liczba:elem class(i:integer);\r
+ \r
+ unit virtual comp:function(e2:liczba):integer;\r
+ begin\r
+ if i < e2.i then result:=-1\r
+ else if i > e2.i then result:=1\r
+ else result:=0\r
+ fi;\r
+ fi;\r
+ end comp;\r
+ \r
+ end liczba;\r
+ \r
+ unit wstaw_liczbe:procedure(i:integer);\r
+ begin\r
+ call wstaw(new liczba(i));\r
+ end wstaw_liczbe;\r
+ \r
+ unit del_liczba:procedure(i:integer);\r
+ begin\r
+ call delete(new liczba(i));\r
+ end del_liczba;\r
+ \r
+ unit virtual rysuj_drzewo:procedure;\r
+ var l:pre,i:integer;\r
+ begin\r
+ write(chr(27),"[2J");\r
+ l:=new pre;\r
+ attach(l);\r
+ while( ( l.nawias<>0 ) and ( not l.koniec ) )do attach(l); od;\r
+ while not l.koniec do\r
+ call SetCursor(4*l.y,l.x);\r
+ write(l.e qua liczba.i:3);\r
+ call SetCursor(4*l.y-1,l.x-1);\r
+ if l.czy_korzen then write("ÚÄÄÄ¿ "); else write("ÚÄÁÄ¿ "); fi;\r
+ call SetCursor(4*l.y+1,l.x-1);\r
+ write("ÀÄÄÄÙ ");\r
+ call SetCursor(4*l.y,l.x-1);\r
+ write("³");\r
+ call SetCursor(4*l.y,l.x+3);\r
+ write("³");\r
+ if not l.czy_korzen then\r
+ if l.czy_lewy then\r
+ call SetCursor(4*l.y-2,l.x+1);\r
+ write("Ú");\r
+ for i:=1 to 2*l.d-2 do write("Ä"); od;\r
+ write("Ù");\r
+ call SetCursor(4*l.y-3,l.x+2*l.d);\r
+ write("Â");\r
+ else\r
+ call SetCursor(4*l.y-2,l.x+1);\r
+ write("¿");\r
+ call SetCursor(4*l.y-3,l.x-2*l.d+2);\r
+ write("Â");\r
+ call SetCursor(4*l.y-2,l.x-2*l.d+2);\r
+ write("À");\r
+ for i:=1 to 2*l.d-2 do write("Ä"); od;\r
+ fi;\r
+ fi;\r
+ attach(l);\r
+ while( ( l.nawias<>0 ) and ( not l.koniec ) )do attach(l); od;\r
+ od;\r
+ kill(l);\r
+ end rysuj_drzewo;\r
+ \r
+ unit rysuj_porz:procedure(i:integer);\r
+ var l:porzadek;\r
+ begin\r
+ write(chr(27),"[2J");\r
+ case i\r
+ when 2:l:=new lex;\r
+ when 3:l:=new pre;\r
+ when 4:l:=new post;\r
+ esac;\r
+ attach(l);\r
+ while not l.koniec do\r
+ case l.nawias\r
+ when 0:write(l.e qua liczba.i);\r
+ when 1:write("(");\r
+ when 2:write(")");\r
+ esac;\r
+ attach(l);\r
+ od;\r
+ kill(l);\r
+ end rysuj_porz;\r
+ \r
+end drzewo_liczb;\r
+ \r
+var d:drzewo_liczb;\r
+var i:integer;\r
+var screen:integer;\r
+ \r
+begin\r
+screen:=1;\r
+d:=new drzewo_liczb;\r
+while screen<>0 do\r
+ write(chr(27),"[2J");\r
+ writeln("aby wstawic wpisz liczbe, aby skasowac minus liczbe, zero konczy!");\r
+ writeln;\r
+ writeln("0-KONIEC");\r
+ writeln("1-postac drzewa");\r
+ writeln("2-porzadek infiksowy");\r
+ writeln("3-porzadek prosty");\r
+ writeln("4-porzadek odwrotny");\r
+ call SetCursor(23,1);\r
+ write(">");\r
+ read(screen);\r
+ write(chr(27),"[2J");\r
+ if screen<0 or screen>4 then screen:=0; fi;\r
+ i:=1;\r
+ while screen*i<>0 do\r
+ if screen=1 then call d.rysuj_drzewo;\r
+ else call d.rysuj_porz(screen);\r
+ fi;\r
+ call SetCursor(23,1);\r
+ write(">");\r
+ read(i);\r
+ if i<>0 then\r
+ if i>0 then call d.wstaw_liczbe(i);\r
+ else call d.del_liczba(-i);\r
+ fi;\r
+ fi;\r
+ od;\r
+od;\r
+end.\r
+ \r
--- /dev/null
+Program BArbres;\r
+(*****************************************************************************)\r
+(* *)\r
+(* PROJET LI1 Nø1 pour le 15/01/94 *)\r
+(* *)\r
+(* PATAUD Frederic *)\r
+(* PEYRAT Francois *)\r
+(* *)\r
+(* Structure des Barbres *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+\r
+(*****************************************************************************)\r
+(* Structure d'une donnees *)\r
+(*****************************************************************************)\r
+Unit STData : class;\r
+var data : integer;\r
+End STData;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* Structure d'une page d'un B_Arbre *)\r
+(*****************************************************************************)\r
+Unit STPage : class (N : integer);\r
+Var pere : STPage;\r
+var nbdata : integer;\r
+var data : arrayof STData;\r
+var fils : arrayof STPage;\r
+Begin\r
+ nbdata:=0; (* A l'initialisation il n'y a pas de data *)\r
+ array data dim (1:2*N); (* Il y a au plus 2n donnees dans une page *)\r
+ array fils dim (1:2*N+1);(* et au plus 2n+1 fils. *)\r
+ pere:=none; (* Aucun pere n'est definit \85 la creation. *)\r
+End STPage;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 > elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Superieur : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data>elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Superieur;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 < elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Inferieur : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data<elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Inferieur;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 = elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Egalite : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data=elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Egalite;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(*****************************************************************************)\r
+Unit Barbre : class (N : integer);\r
+Var root : STPage;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne un booleen indiquant si l'arbre est vide *)\r
+ (****************************************************************************)\r
+ Unit Vide : function : boolean;\r
+ Begin\r
+ result:=root.nbdata=0; (* Si la racine n'a pas d'element alors arbre vide *)\r
+ End Vide;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne la valeur du minimun de l'arbre *)\r
+ (****************************************************************************)\r
+ Unit Minimum : function (output data : STData) : boolean;\r
+ var page : STPage\r
+ Begin\r
+ call outgtext("Recherche minimum... ");\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ if page.fils(1)=none (* le minimum se trouve le plus en bas *)\r
+ then data:=page.data(1); (* \85 gauche de l'arbre *)\r
+ exit\r
+ fi;\r
+ page:=page.fils(1)\r
+ od;\r
+ result:=true;\r
+ else call outgtext("L'arbre est vide !!!"); (* il y a une erreur *)\r
+ result:=false\r
+ fi\r
+ End Minimum;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne la valeur du maximum de l'arbre *)\r
+ (****************************************************************************)\r
+ Unit Maximum : function (output data : STData) : boolean;\r
+ Var page : STPage;\r
+ Begin\r
+ call outgtext("Recherche maximum... ");\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ if page.fils(page.nbdata)=none (* le maximum est l'element le *)\r
+ then data:=page.data(page.nbdata); (* plus \85 droite de l'arbre *)\r
+ exit\r
+ fi;\r
+ page:=page.fils(page.nbdata+1);\r
+ od;\r
+ result:=true;\r
+ else call outgtext("L'arbre est vide !!!");\r
+ result:=false;\r
+ fi;\r
+ End Maximum;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne vraie si l'element elmt est dans l'arbre ainsi que la page *)\r
+ (* la recherche va se faire par dichotomie, ameliorant le nombre de *)\r
+ (* comparaisons necessaire pour trouver : *)\r
+ (* -soit l'element dans la page courante *)\r
+ (* -soit la page suivante a examiner *)\r
+ (****************************************************************************)\r
+ Unit Membre : function (input elmt : STData; output page : STPage) : boolean;\r
+ Var a,milieu,b : integer;\r
+ Begin\r
+ call outgtext("Recherche donn\82e...");\r
+ result:=false;\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ a:=0; (* a=debut de l'intervalle *)\r
+ b:=page.nbdata+1; (* b=fin de l'intervalle *)\r
+ do\r
+ milieu:=(a+b) div 2; (* milieu = milieu de l'intervalle *)\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if Egalite(page.data(milieu),elmt)\r
+ then result:=true; (* on a trouve l'element *)\r
+ exit\r
+ else if (b-a)=1 (* on sort sans avoir touver *)\r
+ then exit\r
+ fi;\r
+ fi\r
+ od;\r
+ if result\r
+ then exit\r
+ fi;\r
+ if page.fils(1)=none (* si plus de page alors on sort *)\r
+ then exit\r
+ fi;\r
+ if Superieur(page.data(milieu),elmt) (* sinon on change de page *)\r
+ then page:=page.fils(milieu)\r
+ else page:=page.fils(milieu+1)\r
+ fi\r
+ od\r
+ else call outgtext("L'arbre est vide!!!")\r
+ fi\r
+ End Membre;\r
+\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Insertion d'un element *)\r
+ (****************************************************************************)\r
+ Unit Insertion : procedure (elmt : STData);\r
+ Var a,milieu,b,i : integer;\r
+ var aux_fils : arrayof STPage;\r
+ var aux_data : arrayof STData;\r
+ var pagenew,page : STPage;\r
+ var sauv1,sauv2 : STPage;\r
+ Begin\r
+ page:=root;\r
+ if vide (* on insert la premiere donnee dans l'arbre *)\r
+ then page.data(1):=elmt;\r
+ page.nbdata:=1;\r
+ call outgtext("L'\82l\82ment a \82t\82 ajout\82.")\r
+ else if not membre(elmt,page) (* l'element elmt n'existe pas deja *)\r
+ then do\r
+ if page <> none (* s'il ne faut pas creer une nouvelle page *)\r
+ then a:=0;\r
+ b:=page.nbdata+1;\r
+ do (* recherche dichotomique de la position dans la page *)\r
+ milieu:=(a+b) div 2;\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if (b-a)=1\r
+ then exit\r
+ fi;\r
+ od;\r
+ if Inferieur(page.data(milieu),elmt)\r
+ then milieu:=milieu+1\r
+ fi;\r
+ if page.nbdata < 2*N (* si on n'a pas le maximum d'elments*)\r
+ then for i:=page.nbdata downto milieu\r
+ do (* on decale pour inserer l'element *)\r
+ page.data(i+1):=page.data(i);\r
+ page.fils(i+2):=page.fils(i+1)\r
+ od;\r
+ page.data(milieu):=elmt; (* on insert l'element *)\r
+ page.fils(milieu+1):=pagenew;\r
+ page.nbdata:=page.nbdata+1;\r
+ exit\r
+ else a:=1;\r
+ b:=page.nbdata+1;\r
+ array aux_data dim (a:b);\r
+ array aux_fils dim (a:b+1);\r
+ for i:=1 to milieu-1 (* on sauve les donnees *)\r
+ do\r
+ aux_data(i):=page.data(i);\r
+ aux_fils(i):=page.fils(i);\r
+ od;\r
+ aux_fils(i):=page.fils(i);\r
+ aux_data(milieu):=elmt;\r
+ aux_fils(milieu+1):=pagenew;\r
+ for i:=milieu to 2*N\r
+ do\r
+ aux_data(i+1):=page.data(i);\r
+ aux_fils(i+2):=page.fils(i);\r
+ od;\r
+ pagenew:= new STPage(N);\r
+ page.nbdata:=n;\r
+ pagenew.nbdata:=n;\r
+ for i:=1 to n (* on coupe en deux *)\r
+ do\r
+ pagenew.data(i):=aux_data(n+1+i);\r
+ page.data(i):=aux_data(i);\r
+ pagenew.fils(i):=aux_fils(n+1+i);\r
+ page.fils(i):=aux_fils(i);\r
+ od;\r
+ pagenew.fils(i):=aux_fils(n+1+i);\r
+ page.fils(i):=aux_fils(i);\r
+ elmt:=aux_data(n+1);\r
+ sauv1:=page;\r
+ if page.fils(1) <> none (* on rechaine les parents *)\r
+ then for i:=1 to n+1\r
+ do\r
+ pagenew.fils(i).pere:=pagenew;\r
+ od\r
+ fi;\r
+ pagenew.pere:=page.pere;\r
+ page:=page.pere;\r
+ kill(aux_data); (* on efface les *)\r
+ kill(aux_fils); (* variables intermediaires *)\r
+ fi\r
+ else sauv2:=pagenew;\r
+ pagenew:= new STPage(N); (* creation d'une nouvelle page *)\r
+ pagenew.nbdata:=1;\r
+ pagenew.data(1):=elmt;\r
+ pagenew.fils(1):=sauv1;\r
+ pagenew.fils(2):=sauv2;\r
+ sauv1.pere:=pagenew;\r
+ sauv2.pere:=pagenew;\r
+ root:=pagenew; (* il y a changement de racine *)\r
+ exit\r
+ fi\r
+ od;\r
+ call outgtext("L'\82l\82ment a \82t\82 ajout\82.");\r
+ else call outgtext("L'\82l\82ment existe deja!") (* l'element existe deja *)\r
+ fi\r
+ fi\r
+ End Insertion;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Suppression d'un element *)\r
+ (****************************************************************************)\r
+ Unit Supprimer : procedure (elmt : STData);\r
+ var a,milieu,b,i : integer;\r
+ var aux_data : arrayof STData;\r
+ var aux_fils : arrayof STPage;\r
+ var page,avant : STPage;\r
+ var courant,pere : STPage;\r
+ var pred,aux : integer;\r
+\r
+ Begin\r
+ if vide (* l'arbre est vide ?! *)\r
+ then call outgtext("L'arbre est vide!!!")\r
+ else page:=root;\r
+ if not membre(elmt,page) (* l'element n'est pas dans l'arbre ?! *)\r
+ then call outgtext("Donn\82e pas ds l'arbre.")\r
+ else courant:=page;\r
+ a:=0; (* on recherche par dichotomie la place de l'element *)\r
+ b:=courant.nbdata+1;\r
+ do\r
+ milieu:=(a+b) div 2;\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if Egalite(page.data(milieu),elmt)\r
+ then exit\r
+ fi\r
+ od; (* on a sa place *)\r
+ if courant.fils(milieu) <> none\r
+ then courant:=courant.fils(milieu)\r
+ fi;\r
+ while courant.fils(courant.nbdata+1) <> none\r
+ do\r
+ courant:=courant.fils(courant.nbdata+1)\r
+ od;\r
+ if page.fils(1) <> none\r
+ then page.data(milieu):=courant.data(courant.nbdata)\r
+ else for i:=milieu to courant.nbdata-1\r
+ do\r
+ page.data(i):=page.data(i+1)\r
+ od\r
+ fi;\r
+ courant.nbdata:=courant.nbdata-1;\r
+ if courant.nbdata < N\r
+ then if courant=root\r
+ then exit\r
+ fi;\r
+ do\r
+ pere:=courant.pere;\r
+ i:=1;\r
+ do\r
+ if pere.fils(i)=courant\r
+ then exit\r
+ fi;\r
+ i:=i+1\r
+ od;\r
+ pred:=i-1;\r
+ if pred <> 0\r
+ then avant:=pere.fils(pred)\r
+ else avant:=courant;\r
+ pred:=1;\r
+ courant:=pere.fils(2)\r
+ fi;\r
+ if avant.nbdata <= N\r
+ then if courant.nbdata > N\r
+ then array aux_data dim (1:3*N);\r
+ array aux_fils dim (1:3*N+1);\r
+ for i:=1 to avant.nbdata\r
+ do\r
+ aux_data(i):=avant.data(i);\r
+ aux_fils(i):=avant.fils(i)\r
+ od;\r
+ aux_fils(i):=avant.fils(i);\r
+ aux_data(i):=pere.data(pred);\r
+ for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
+ od;\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
+ aux:=avant.nbdata+1+courant.nbdata;\r
+ milieu:=aux div 2 +1;\r
+ for i:=1 to milieu-1\r
+ do\r
+ avant.data(i):=aux_data(i);\r
+ avant.fils(i):=aux_fils(i)\r
+ od;\r
+ avant.fils(i):=aux_fils(i);\r
+ avant.nbdata:=milieu-1;\r
+ pere.data(pred):=aux_data(milieu);\r
+ for i:=milieu+1 to aux\r
+ do\r
+ courant.data(i-milieu):=aux_data(i);\r
+ courant.fils(i-milieu):=aux_fils(i)\r
+ od;\r
+ courant.fils(i-milieu):=aux_fils(i);\r
+ courant.nbdata:=aux-avant.nbdata-1\r
+ else for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ avant.data(i):=courant.data(i-avant.nbdata-1);\r
+ avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
+ if courant.fils(i-avant.nbdata-1) <> none\r
+ then courant.fils(i-avant.nbdata-1).pere:=avant\r
+ fi\r
+ od;\r
+ avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
+ if courant.fils(i-avant.nbdata-1) <> none\r
+ then courant.fils(i-avant.nbdata-1).pere:=avant\r
+ fi;\r
+ avant.data(avant.nbdata+1):=pere.data(pred);\r
+ avant.nbdata:=avant.nbdata+1+courant.nbdata;\r
+ for i:=pred+1 to pere.nbdata\r
+ do\r
+ pere.data(i-1):=pere.data(i);\r
+ pere.fils(i):=pere.fils(i+1)\r
+ od;\r
+ pere.fils(pere.nbdata+1):=none;\r
+ pere.nbdata:=pere.nbdata-1;\r
+ if pere.nbdata=0\r
+ then root:=avant;\r
+ root.pere:=none\r
+ fi\r
+ fi\r
+ else array aux_data dim (1:3*N);\r
+ array aux_fils dim (1:3*N+1);\r
+ for i:=1 to avant.nbdata\r
+ do\r
+ aux_data(i):=avant.data(i);\r
+ aux_fils(i):=avant.fils(i)\r
+ od;\r
+ aux_fils(i):=avant.fils(i);\r
+ aux_data(i):=pere.data(pred);\r
+ for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
+ od;\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
+ aux:=avant.nbdata+1+courant.nbdata;\r
+ milieu:=aux div 2 +1;\r
+ for i:=1 to milieu-1\r
+ do\r
+ avant.data(i):=aux_data(i);\r
+ avant.fils(i):=aux_fils(i)\r
+ od;\r
+ avant.fils(i):=aux_fils(i);\r
+ avant.nbdata:=milieu-1;\r
+ pere.data(pred):=aux_data(milieu);\r
+ for i:=milieu+1 to aux\r
+ do\r
+ courant.data(i-milieu):=aux_data(i);\r
+ courant.fils(i-milieu):=aux_fils(i)\r
+ od;\r
+ courant.fils(i-milieu):=aux_fils(i);\r
+ courant.nbdata:=aux-avant.nbdata-1\r
+ fi;\r
+ if avant <> root\r
+ then avant:=pere;\r
+ if avant <> root\r
+ then if avant.nbdata < N\r
+ then pere:=pere.pere;\r
+ i:=1;\r
+ do\r
+ if pere.fils(i)=avant\r
+ then exit\r
+ fi;\r
+ i:=i+1\r
+ od;\r
+ courant:=pere.fils(i+1);\r
+ if courant=none\r
+ then courant:=avant;\r
+ avant:=pere.fils(i-1)\r
+ fi\r
+ else exit\r
+ fi\r
+ else exit\r
+ fi\r
+ else exit\r
+ fi\r
+ od\r
+ fi;\r
+ call outgtext("El\82ment supprim\82.")\r
+ fi\r
+ fi\r
+ End Supprimer;\r
+\r
+Begin\r
+ root:=new STPage(N);\r
+End Barbre;\r
+\r
+(****************************************************************************)\r
+(* dessine une ligne entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit line : procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ call color(colore)\r
+ end\r
+end line;\r
+\r
+(****************************************************************************)\r
+(* dessine une boite entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit rectanglef : procedure(x1,y1,x2,y2,c:integer);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ for i:=y1 to y2\r
+ do\r
+ call line(x1,i,x2,i,c)\r
+ od;\r
+ call color(colore)\r
+ end\r
+end rectanglef;\r
+\r
+(****************************************************************************)\r
+(* dessine un rectangle entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit rectangle : procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(x1,y1,x2,y1,c);\r
+ call line(x2,y1,x2,y2,c);\r
+ call line(x2,y2,x1,y2,c);\r
+ call line(x1,y2,x1,y1,c);\r
+ call color(colore)\r
+ end\r
+end rectangle;\r
+\r
+(****************************************************************************)\r
+(* dessine un rectangle en pointilles entre (x1,y1) et (x2,y2) *)\r
+(****************************************************************************)\r
+unit rectpoint : procedure(x1,y1,x2,y2,c:integer);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ for i:=x1 step 4 to x2-2\r
+ do\r
+ call line(i,y1,i+2,y1,c);\r
+ call line(i,y2,i+2,y2,c)\r
+ od;\r
+ for i:=y1 step 4 to y2-2\r
+ do\r
+ call line(x1,i,x1,i+2,c);\r
+ call line(x2,i,x2,i+2,c)\r
+ od\r
+ end\r
+end rectpoint;\r
+\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche le bandeau de commande en premiere ligne de l'ecran *)\r
+(****************************************************************************)\r
+unit affiche : procedure;\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call rectanglef(0,0,640,9,colorf);\r
+ call color(colore);\r
+ call move(1,1);\r
+ for i:=1 to nbitem\r
+ do\r
+ call move(10+espace*(i-1),1);\r
+ call outstring(item(i))\r
+ od;\r
+ call rectangle(1,15,196,340,colorf);\r
+ call rectangle(200,15,639,320,colorf);\r
+ call rectangle(200,325,639,340,colorf);\r
+ call move(202,330);\r
+ call outstring(" BArbre d'ordre 3 Li1 : PATAUD F. - PEYRAT F.")\r
+ end\r
+end affiche;\r
+\r
+(****************************************************************************)\r
+(* gere le menu, retourne le code action soit clavier soit souris *)\r
+(****************************************************************************)\r
+unit mousegest : function : integer;\r
+var l,r,c : boolean;\r
+var x,y : integer;\r
+var rep : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then if (y<=10 and y>=1)\r
+ then result:=(x-10)/espace+1; exit\r
+ fi\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep>=-65 and rep<=-59)\r
+ then result:=-rep-58;\r
+ exit\r
+ fi\r
+ od\r
+ end\r
+ end\r
+end mousegest;\r
+\r
+(****************************************************************************)\r
+(* initialise le menu et effectue l'action demand\82e *)\r
+(****************************************************************************)\r
+unit maine : procedure;\r
+var i : integer;\r
+var action : integer;\r
+begin\r
+ pref mouse block\r
+ begin\r
+ colorf:=9;\r
+ colore:=10;\r
+ espace:=90;\r
+ nbitem:=7;\r
+ array item dim (1:nbitem);\r
+ item(1):=" Inserer ";\r
+ item(2):=" Effacer ";\r
+ item(3):=" Affiche ";\r
+ item(4):=" Membre? ";\r
+ item(5):=" Minimum ";\r
+ item(6):=" Maximum ";\r
+ item(7):=" Quitter ";\r
+ call affiche;\r
+ call showcursor;\r
+ colore:=2;\r
+ do\r
+ action:=mousegest;\r
+ case action\r
+ when 1: call menu_ins;\r
+ when 2: call menu_del;\r
+ when 3: call menu_aff(arbr.root);\r
+ when 4: call menu_mem;\r
+ when 5: call menu_min;\r
+ when 6: call menu_max;\r
+ when 7: if menu_qui then exit fi\r
+ esac\r
+ od\r
+ end\r
+end maine;\r
+\r
+(****************************************************************************)\r
+(* procedure d'affichage dans l'ecran de commandes, fait un scroll si besoin*)\r
+(****************************************************************************)\r
+unit outgtext : procedure(id : string);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ call hidecursor;\r
+ call color(colore);\r
+ call move(10,posy);\r
+ call outstring(id);\r
+ posy:=posy+10;\r
+ if (posy>=320) (* on est en fin de page, on fait un scroll d'une ligne *)\r
+ then call rectanglef(2,16,195,337,0);\r
+ posy:=20\r
+ fi;\r
+ call showcursor\r
+ end\r
+ end\r
+end outgtext;\r
+\r
+(****************************************************************************)\r
+(* lecture d'un entier en mode graphique, esc revient au debut de saisie *)\r
+(****************************************************************************)\r
+unit gscanf : function : integer;\r
+var valeur : integer;\r
+var sauvx,sauvy : integer;\r
+var flag : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ valeur:=0;\r
+ sauvx:=inxpos;\r
+ sauvy:=inypos;\r
+ do\r
+ do\r
+ flag:=inkey;\r
+ if (flag>=48 and flag<=57) orif (flag=13) orif (flag=27) then exit fi\r
+ od;\r
+ if (flag>=48 and flag<=57)\r
+ then valeur:=valeur*10+flag-48;\r
+ call move(inxpos,inypos);\r
+ call hascii(flag)\r
+ fi;\r
+ if (flag=13) then exit fi;\r
+ if (flag=27) (* on a demand\82 annulation *)\r
+ then valeur:=0;\r
+ call rectanglef(sauvx-1,sauvy-3,inxpos,sauvy+7,0);\r
+ call color(colore);\r
+ call move(sauvx,sauvy)\r
+ fi\r
+ od\r
+ end;\r
+ result:=valeur\r
+end gscanf;\r
+\r
+(****************************************************************************)\r
+(* affiche un entier en mode graphique, maximum 6 chiffres *)\r
+(****************************************************************************)\r
+unit writint : procedure( valeur : integer);\r
+var flag,i : integer;\r
+var tbl : arrayof integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ array tbl dim (1:6);\r
+ flag:=1; (* on 'empile' en ordre reverse *)\r
+ while valeur<>0\r
+ do\r
+ tbl(flag):=valeur mod 10;\r
+ valeur:=valeur div 10;\r
+ flag:=flag+1\r
+ od;\r
+ for i:=flag-1 downto 1 (* on affiche dans le bon ordre *)\r
+ do\r
+ call hascii(48+tbl(i))\r
+ od\r
+ end\r
+end writint;\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche ds l'ecran de droite la page courante *)\r
+(****************************************************************************)\r
+unit affiche_page : procedure (page : STPage);\r
+var i :integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ if page<>arbr.root\r
+ then call line(420,82,420,97,colorf);\r
+ call cirb(420,77,5,0,0,colorf,0,1,1);\r
+ fi;\r
+ for i:=1 to 6\r
+ do\r
+ call rectpoint(339+(i-1)*27,97,339+i*27,117,colorf);\r
+ if i<=page.nbdata\r
+ then call move(339+(i-1)*27+3,105);\r
+ call writint(page.data(i).data)\r
+ fi\r
+ od\r
+ end\r
+end affiche_page;\r
+\r
+(****************************************************************************)\r
+(* affiche ds l'ecran de droite la page fille de gauche *)\r
+(****************************************************************************)\r
+unit affiche_gche : procedure (page : STPage);\r
+var i : integer;\r
+var savi : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(312,220,312,240,colorf);\r
+ for i:=1 to 6\r
+ do\r
+ call rectangle(204+i*27,240,204+(i+1)*27,260,colorf);\r
+ if i<=page.nbdata\r
+ then call move(204+i*27+3,248);\r
+ call writint(page.data(i).data);\r
+ savi:=i;\r
+ if page.fils(i) <> none\r
+ then if i=4\r
+ then call line(204+i*27,260,204+i*27,275,colorf);\r
+ else if i<4\r
+ then call line(204+i*27,260,204+i*27-5,275,colorf);\r
+ else call line(204+i*27,260,204+i*27+5,275,colorf);\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ od;\r
+ if page.fils(i) <> none\r
+ then if savi<>3 (* comme on part gche->dte on a soit | soit \ *)\r
+ then call line(204+(savi+1)*27,260,204+(savi+1)*27+5,275,colorf);\r
+ else call line(204+(savi+1)*27,260,204+(savi+1)*27,275,colorf);\r
+ fi\r
+ fi\r
+ end\r
+end affiche_gche;\r
+\r
+(****************************************************************************)\r
+(* affiche ds ecran de droite la page fille droite *)\r
+(****************************************************************************)\r
+unit affiche_drte : procedure (page :STPage);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(527,220,527,240,colorf);\r
+ for i:=1 to 6\r
+ do\r
+ call rectangle(635-(i+1)*27,240,635-i*27,260,colorf);\r
+ if (6-i+1)<=page.nbdata\r
+ then call move(635-(i+1)*27+3,248);\r
+ call writint(page.data(6-i+1).data);\r
+ if page.fils(6-i+1) <> none\r
+ then if (6-i+1)=4\r
+ then call line(635-i*27,260,635-i*27,275,colorf);\r
+ else if (6-i+1)>4\r
+ then call line(635-i*27,260,635-i*27+5,275,colorf);\r
+ else call line(635-i*27,260,635-i*27-5,275,colorf);\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ od;\r
+ if page.fils(1) <> none\r
+ then call line(635-i*27,260,635-i*27-5,275,colorf);\r
+ fi\r
+ end\r
+end affiche_drte;\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* Lecture de la donn\82e de STData *)\r
+(****************************************************************************)\r
+unit lect_data : function : STData;\r
+var d : STData;\r
+begin\r
+ d:=new STData;\r
+ call outgtext("Entrez la donn\82e : ");\r
+ d.data:=gscanf;\r
+ result:=d\r
+end lect_data;\r
+\r
+(****************************************************************************)\r
+(* menu insertion *)\r
+(****************************************************************************)\r
+unit menu_ins : procedure;\r
+var d : STData;\r
+begin\r
+ d:=lect_data;\r
+ call arbr.insertion(d);\r
+ call outgtext("")\r
+end menu_ins;\r
+\r
+\r
+(****************************************************************************)\r
+(* menu effacement *)\r
+(****************************************************************************)\r
+unit menu_del : procedure;\r
+var d : STData;\r
+begin\r
+ d:=lect_data;\r
+ call arbr.supprimer(d);\r
+ call outgtext("")\r
+end menu_del;\r
+\r
+(****************************************************************************)\r
+(* affiche l'aide clavier dans le mode affichage *)\r
+(****************************************************************************)\r
+unit help : procedure;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ call hidecursor;\r
+ call rectangle(260,25,625,65,colorf);\r
+ call move(270,30);\r
+ call outstring("G: gauche devient pere");\r
+ call move(270,40);\r
+ call outstring("D: droite devient pere");\r
+ call move(270,50);\r
+ call outstring("P: remonte d'un niveau");\r
+ call line(450,28,450,62,colorf);\r
+ call move(460,30);\r
+ call outstring("1..6: changement de");\r
+ call move(460,40);\r
+ call outstring(" cellule active");\r
+ call move(460,50);\r
+ call outstring(" dans le pere.");\r
+ call showcursor\r
+ end\r
+ end\r
+end help;\r
+\r
+(****************************************************************************)\r
+(* menu de parcours de l'arbre dans la fenetre droite *)\r
+(****************************************************************************)\r
+unit menu_aff : procedure(depart : STPage);\r
+var pos,spos: integer;\r
+var rep,x,y : integer;\r
+var l,r,c : boolean;\r
+var page : STPage;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ pos:=1;\r
+ page:=depart;\r
+ call rectangle(210,40,245,51,colorf);\r
+ call move(212,42);\r
+ call outstring("Exit");\r
+ call outgtext("Mode affichage");\r
+ call help;\r
+ do\r
+ call hidecursor;\r
+ call rectanglef(201,66,638,319,0);\r
+ call affiche_page(page);\r
+ if page.fils(pos) <> none\r
+ then call affiche_gche(page.fils(pos))\r
+ fi;\r
+ if page.fils(pos+1) <> none\r
+ then call affiche_drte(page.fils(pos+1))\r
+ fi;\r
+ call rectangle(339+(pos-1)*27,97,339+pos*27,117,colorf);\r
+ if page.fils(pos) <> none\r
+ then call line(339+(pos-1)*27,117,339+(pos-1)*27-5,132,colorf)\r
+ fi;\r
+ if page.fils(pos+1) <> none\r
+ then call line(339+pos*27,117,339+pos*27+5,132,colorf)\r
+ fi;\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then if (y<51 and y>40 and x>211 and x<245) (* button exit *)\r
+ then exit exit\r
+ fi;\r
+ if (x<501 and x>339 and y<117 and y>97) (* ds pere chgt gch dte *)\r
+ then spos:=((x-339) div 27)+1;\r
+ if spos<=page.nbdata\r
+ then pos:=spos\r
+ fi;\r
+ exit\r
+ fi;\r
+ if (x>231 and x<393 and y>240 and y<260) (* fils gche devient pere*)\r
+ then page:=page.fils(pos);\r
+ pos:=1;\r
+ exit\r
+ fi;\r
+ if (x>446 and x<608 and y>240 and y<260) (* fils dte devient pere *)\r
+ then page:=page.fils(pos+1);\r
+ pos:=1;\r
+ exit\r
+ fi;\r
+ if (page<>arbr.root) and (x>415 and x<425 and y>72 and y<82)\r
+ then page:=page.pere; (* on remonte d'un niveau *)\r
+ pos:=1;\r
+ exit\r
+ fi\r
+ fi;\r
+ rep:=inkey;\r
+ if rep=27\r
+ then exit exit\r
+ else if (rep>=49 and rep<=54)\r
+ then spos:=rep-48;\r
+ if spos<=page.nbdata\r
+ then pos:=spos;\r
+ fi;\r
+ exit\r
+ fi;\r
+ if (rep=71 or rep=103) (* g or G : fils gauche=pere *)\r
+ then if page.fils(pos)<>none\r
+ then page:=page.fils(pos);\r
+ pos:=1;\r
+ exit\r
+ fi\r
+ fi;\r
+ if (rep=68 or rep=100) (* d or D : fils droite=pere *)\r
+ then if page.fils(pos+1)<>none\r
+ then page:=page.fils(pos+1);\r
+ pos:=1;\r
+ exit\r
+ fi\r
+ fi;\r
+ if (rep=80 or rep=112) (* p or P : remonte d'un niveau *)\r
+ then if page.pere<>none\r
+ then page:=page.pere;\r
+ pos:=1;\r
+ exit\r
+ fi\r
+ fi\r
+ fi\r
+ od\r
+ od;\r
+ call hidecursor;\r
+ call rectanglef(210,40,245,51,0);\r
+ call showcursor;\r
+ call outgtext("Mode standard");\r
+ call outgtext("")\r
+ end\r
+ end\r
+end menu_aff;\r
+\r
+(****************************************************************************)\r
+(* menu membre *)\r
+(****************************************************************************)\r
+unit menu_mem : procedure;\r
+var d : STData;\r
+var page : STPage;\r
+begin\r
+ d:=lect_data;\r
+ if arbr.Membre(d,page)\r
+ then call outgtext("La donn\82e est ds arbre");\r
+ call menu_aff(page)\r
+ else call outgtext("Donn\82e absente ds arbre");\r
+ call outgtext("")\r
+ fi;\r
+end menu_mem;\r
+\r
+(****************************************************************************)\r
+(* menu minimum *)\r
+(****************************************************************************)\r
+unit menu_min : procedure;\r
+var d : STData;\r
+begin\r
+ if arbr.Minimum(d)\r
+ then call writint(d.data)\r
+ fi;\r
+ call outgtext("")\r
+end menu_min;\r
+\r
+(****************************************************************************)\r
+(* menu maximum *)\r
+(****************************************************************************)\r
+unit menu_max : procedure;\r
+var d : STData;\r
+begin\r
+ if arbr.Maximum(d)\r
+ then call writint(d.data)\r
+ fi;\r
+ call outgtext("")\r
+end menu_max;\r
+\r
+(****************************************************************************)\r
+(* menu quitte *)\r
+(****************************************************************************)\r
+unit menu_qui : function : boolean;\r
+var rep : boolean;\r
+var a : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call outgtext("Voulez-vous quitter");\r
+ call outgtext(" (o/n) ?");\r
+ call move(inxpos+8,inypos);\r
+ do\r
+ a:=inkey;\r
+ if (a=111 or a=79)\r
+ then result:=true;\r
+ call outstring("o");\r
+ exit\r
+ fi;\r
+ if (a=110 or a=78)\r
+ then result:=false;\r
+ call outstring("n");\r
+ exit\r
+ fi\r
+ od;\r
+ call outgtext("")\r
+ end\r
+end menu_qui;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(*****************************************************************************)\r
+(* *)\r
+(* P R O G R A M M E P R I N C I P A L *)\r
+(* *)\r
+(*****************************************************************************)\r
+(*****************************************************************************)\r
+var colorf,colore : integer;\r
+var nbitem : integer;\r
+var espace : integer;\r
+var item : arrayof string;\r
+var nbbot : integer;\r
+var flag : boolean;\r
+var posy : integer;\r
+var arbr : Barbre;\r
+\r
+Begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ arbr:=new Barbre(3);\r
+ call gron(1);\r
+ flag:=init(nbbot);\r
+ call hpage(0,1,1);\r
+ posy:=20;\r
+ call maine;\r
+ call hidecursor;\r
+ call groff\r
+ end\r
+ end\r
+End BArbres.\r
--- /dev/null
+\r
+program bicolore;\r
+\r
+\r
+(* ANNEE UNIVERSITAIRE 1993/1994 : Universit\82 de Pau *)\r
+\r
+(* DATE DE REMISE : 15 JANVIER 1994 *)\r
+(* *)\r
+(* SUJET : ARBRES BICOLORES *)\r
+(* *)\r
+(* GROUPE 2 , LICENCE INFORMATIQUE , LI1 *)\r
+(* *)\r
+(* *)\r
+(* MARIE HEGUY *)\r
+(* JACQUES LATAPIE *)\r
+\r
+(* SUJET PROPOSE PAR MME MIRKOWSKA *)\r
+\r
+\r
+unit noeud:class;\r
+var elem:integer,gauche,droite,pere:noeud,couleur:integer;\r
+end noeud;\r
+\r
+\r
+(* RECHERCHE DU MINIMUN *)\r
+unit recmin:function(t:noeud):noeud;\r
+begin\r
+if t.gauche=z then result:=t;\r
+ else result:=recmin(t.gauche);\r
+fi;\r
+end recmin;\r
+\r
+\r
+(* RECHERCHE DU MAXIMUM *)\r
+unit recmax:function(t:noeud):noeud;\r
+begin\r
+if t.droite=z then result:=t;\r
+ else result:=recmax(t.droite);\r
+fi;\r
+end recmax;\r
+\r
+\r
+(* SUPPRESSION D'UN ELEMENT COMME DANS UN ARBRE BST *)\r
+unit suppression:iiuwgraph procedure(inout t:noeud,supp:noeud,remplacant:noeud);\r
+var locale:noeud;\r
+begin\r
+if supp.gauche=z or supp.droite=z\r
+ then remplacant:=supp;\r
+ else remplacant:=recmin(supp.droite);\r
+fi;\r
+if remplacant.gauche<>z\r
+ then locale:=remplacant.gauche;\r
+ else locale:=remplacant.droite;\r
+fi;\r
+locale.pere:=remplacant.pere;\r
+if remplacant.pere=remplacant\r
+ then t:=locale;\r
+ t.pere:=t;\r
+ else if remplacant=remplacant.pere.gauche\r
+ then remplacant.pere.gauche:=locale;\r
+ else remplacant.pere.droite:=locale;\r
+ fi;\r
+fi;\r
+if remplacant<>supp then supp.elem:=remplacant.elem;fi;\r
+if remplacant.couleur=0 then call suppresmaj(t,locale);fi;\r
+end suppression;\r
+\r
+\r
+(* ROTATION ET INVERSION DES COULEURS APRES SUPPRESSION *)\r
+unit suppresmaj:iiuwgraph procedure(inout t:noeud,rond:noeud);\r
+var local:noeud,rep:integer;\r
+begin\r
+while rond<>t and rond.couleur=0\r
+do\r
+ if rond=rond.pere.gauche\r
+ then \r
+ local:=rond.pere.droite;\r
+ if local.couleur=1\r
+ then\r
+ local.couleur:=0;\r
+ rond.pere.couleur:=1;\r
+ call gauch(t,rond.pere);\r
+ call cls;\r
+ call visua(t,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Visua. apr\8as rot. Gauche sur ");\r
+ call writeinteger(rond.pere.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ local:=rond.pere.droite;\r
+ fi;\r
+ if local.gauche.couleur=0 and local.droite.couleur=0\r
+ then\r
+ local.couleur:=1;\r
+ rond:=rond.pere;\r
+ else\r
+ if local.droite.couleur=0 \r
+ then local.gauche.couleur:=0;\r
+ local.couleur:=1;\r
+ call droit(t,local);\r
+ call cls;\r
+ call visua(t,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Rotation Droite sur ");\r
+ call writeinteger(local.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ local:=rond.pere.droite;\r
+ fi;\r
+ local.couleur:=rond.pere.couleur;\r
+ rond.pere.couleur:=0;\r
+ local.droite.couleur:=0;\r
+ call gauch(t,rond.pere);\r
+ call cls;\r
+ call visua(t,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Rotation Gauche sur ");\r
+ call writeinteger(rond.pere.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ rond:=t;\r
+ fi;\r
+ else\r
+ local:=rond.pere.gauche;\r
+ if local.couleur=1\r
+ then\r
+ local.couleur:=0;\r
+ rond.pere.couleur:=1;\r
+ call droit(t,rond.pere);\r
+ call cls;\r
+ call visua(t,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Rotation Droite sur ");\r
+ call writeinteger(rond.pere.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ local:=rond.pere.gauche;\r
+ fi;\r
+ if local.droite.couleur=0 and local.gauche.couleur=0\r
+ then\r
+ local.couleur:=1; \r
+ rond:=rond.pere;\r
+ else\r
+ if local.gauche.couleur=0\r
+ then\r
+ local.droite.couleur:=0;\r
+ local.couleur:=1;\r
+ call gauch(t,local);\r
+ call cls;\r
+ call visua(t,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Rotation Gauche sur ");\r
+ call writeinteger(local.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ local:=rond.pere.gauche;\r
+ fi;\r
+ local.couleur:=rond.pere.couleur;\r
+ rond.pere.couleur:=0;\r
+ local.gauche.couleur:=0;\r
+ call droit(t,rond.pere);\r
+ call cls;\r
+ call visua(t,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Rotation Droite sur ");\r
+ call writeinteger(rond.pere.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ rond:=t;\r
+ fi;\r
+ fi;\r
+od;\r
+rond.couleur:=0;\r
+end suppresmaj;\r
+\r
+\r
+(* INSERSION COMME DANS UN ARBRE BST *)\r
+unit insert_bst: procedure(nb:integer;inout r:noeud,x:noeud,p:noeud,trouve:integer);\r
+begin\r
+if r.elem=nb then\r
+ if r=z then\r
+ r:=new noeud;\r
+ r.elem:=nb;\r
+ if p=z then r.pere:=r;\r
+ else r.pere:=p;\r
+ fi;\r
+ r.droite:=z;\r
+ r.gauche:=z;\r
+ x:=r;\r
+ else\r
+ (*("CET ELEMENT EST DEJA INSERE !!! ");*)\r
+ trouve:=1;\r
+ fi;\r
+else\r
+ if nb<r.elem then call insert_bst(nb,r.gauche,x,r,trouve);\r
+ else call insert_bst(nb,r.droite,x,r,trouve);\r
+ fi;\r
+fi;\r
+end insert_bst;\r
+\r
+\r
+(* ROTATIONS ET CHANGEMENTS DE COULEURS APRES INSERSION *)\r
+unit insert:iiuwgraph procedure(inout x:noeud;inout racine:noeud);\r
+var y,valeur:noeud,rep:integer;\r
+begin\r
+call cls;\r
+call color(14);\r
+x.couleur:=1;\r
+while ((x<>racine) and (x.pere.couleur=1))\r
+do\r
+call cls;\r
+call visua(racine,0.5,1,0,0);\r
+call color(14);\r
+call move(2,340);\r
+call outstring("On a deux noeuds rouges cons\82cutifs ");\r
+call writeinteger(x.elem);\r
+call outstring(" et ");\r
+call writeinteger(x.pere.elem);\r
+call outstring(" <RETURN> ");\r
+rep:=inchar;\r
+call cls;\r
+if x.pere=x.pere.pere.gauche \r
+then \r
+ y:=x.pere.pere.droite;\r
+ if y.couleur=1\r
+ then\r
+ (* L'oncle de x.elem est rouge donc inversion des couleurs*)\r
+ x.pere.couleur:=0;\r
+ y.couleur:=0;\r
+ x.pere.pere.couleur:=1;\r
+ call visua(racine,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Visualisation apr\8as inversion des couleur <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ x:=x.pere.pere;\r
+ else\r
+ if x=x.pere.droite \r
+ then\r
+ x:=x.pere;\r
+ call gauch(racine,x);\r
+ call cls;\r
+ call visua(racine,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Visualisation apr\8as rot. gauche au niveau de ");\r
+ call writeinteger(x.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ fi;\r
+ x.pere.couleur:=0;\r
+ x.pere.pere.couleur:=1;\r
+ if x.pere.pere=racine \r
+ then valeur:=x.pere;\r
+ else valeur:=x.pere.pere.pere;\r
+ fi;\r
+ call droit(racine,x.pere.pere);\r
+ x.pere.pere:=valeur;\r
+ call cls;\r
+ call visua(racine,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Visu.ap\8as r\82tab. des couleurs et rot. D sur ");\r
+ call writeinteger(x.pere.pere.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ fi;\r
+else\r
+ y:=x.pere.pere.gauche;\r
+ if y.couleur=1\r
+ then\r
+ (* L'oncle de x.elem est rouge donc inversion des couleurs*)\r
+ x.pere.couleur:=0;\r
+ y.couleur:=0;\r
+ x.pere.pere.couleur:=1;\r
+ call cls;\r
+ call visua(racine,0.5,1,0,0);\r
+ call color(14);\r
+ call move(2,340);\r
+ call outstring("Visua. apr\8as inversion des couleurs <RETURN>");\r
+ rep:=inchar;\r
+ call cls;\r
+ x:=x.pere.pere;\r
+ else\r
+ if x=x.pere.gauche\r
+ then\r
+ x:=x.pere;\r
+ call droit(racine,x);\r
+ call cls;\r
+ call visua(racine,0.5,1,0,0);\r
+ call move(2,340);\r
+ call color(14);\r
+ call outstring("Visualisation apr\8as rotation droite au niveau de ");\r
+ call writeinteger(x.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ fi;\r
+ x.pere.couleur:=0;\r
+ x.pere.pere.couleur:=1;\r
+ if x.pere.pere=racine \r
+ then valeur:=x.pere;\r
+ else valeur:=x.pere.pere.pere;\r
+ fi;\r
+ call gauch(racine,x.pere.pere);\r
+ x.pere.pere:=valeur;\r
+ call cls;\r
+ call visua(racine,0.5,1,0,0);\r
+ call move(2,340);\r
+ call color(14);\r
+ call outstring("Visu.apr\8as r\82tab. des couleurs et rot. gauche sur ");\r
+ call writeinteger(x.pere.pere.elem);\r
+ call outstring(" <RETURN> ");\r
+ rep:=inchar;\r
+ call cls;\r
+ fi;\r
+fi;\r
+od;\r
+racine.couleur:=0;\r
+end insert;\r
+\r
+\r
+(* ROTATION GAUCHE *)\r
+unit gauch:procedure(inout t:noeud;inout aux1:noeud);\r
+var fils:noeud;\r
+begin\r
+fils:=aux1.droite;\r
+aux1.droite:=fils.gauche;\r
+if aux1<>t then fils.pere:=aux1.pere;\r
+ else fils.pere:=fils;\r
+fi;\r
+if fils.gauche<>z then fils.gauche.pere:=aux1;fi;\r
+if aux1.pere=aux1 then t:=fils;\r
+else\r
+ if aux1=aux1.pere.gauche\r
+ then\r
+ aux1.pere.gauche:=fils;\r
+ else\r
+ aux1.pere.droite:=fils; \r
+ fi; \r
+fi;\r
+fils.gauche:=aux1;\r
+aux1.pere:=fils;\r
+end gauch;\r
+\r
+\r
+(* ROTATION DROITE *)\r
+\r
+unit droit:procedure(inout t:noeud;inout aux2:noeud);\r
+var child:noeud;\r
+begin\r
+child:=aux2.gauche;\r
+aux2.gauche:=child.droite;\r
+if child.droite<>z then child.droite.pere:=aux2;fi;\r
+if aux2<>t then child.pere:=aux2.pere;\r
+ else child.pere:=child;\r
+fi;\r
+if aux2.pere=aux2 then t:=child;\r
+else\r
+ if aux2=aux2.pere.droite\r
+ then aux2.pere.droite:=child;\r
+ else aux2.pere.gauche:=child;\r
+ fi;\r
+fi;\r
+child.droite:=aux2;\r
+aux2.pere:=child;\r
+end droit;\r
+\r
+\r
+(* RECHERCHE D'UN ELEMENT QUELCONQUE *)\r
+unit recherche: iiuwgraph procedure(r:noeud;nb:integer;inout pointeur:noeud);\r
+var rep:integer;\r
+begin\r
+while r<>z \r
+do\r
+ call cls;\r
+ call move(200,100);\r
+ if r.elem=nb then call outstring("Element ");\r
+ call writeinteger(nb);\r
+ call outstring(" est trouv\82 dans l'arbre");\r
+ call move(200,120);\r
+ call outstring(" COULEUR = ");\r
+ if r.couleur=1 then\r
+ call outstring(" ROUGE ");\r
+ else call outstring(" NOIR ");\r
+ fi;\r
+ call move(200,140);\r
+ call outstring(" PERE = ");\r
+ call writeinteger(r.pere.elem);\r
+ call move(200,160);\r
+ if r.gauche<>z then call outstring("FILS GAUCHE = ");\r
+ call writeinteger(r.gauche.elem);fi;\r
+ call move(200,180);\r
+ if r.droite<>z then call outstring("FILS DROIT = ");\r
+ call writeinteger(r.droite.elem);fi;\r
+ call move(0,340);\r
+ call outstring("APPUYEZ SUR <RETURN> POUR CONTINUER .. ");\r
+ rep:=inchar;\r
+ pointeur:=r;\r
+ return;\r
+ else\r
+ if nb>r.elem then r:=r.droite;\r
+ else r:=r.gauche;\r
+ fi;\r
+ fi;\r
+od;\r
+if r=z then \r
+ call move(200,160);\r
+ call writeinteger(nb);\r
+ call outstring(" N'APPARTIENT PAS A L'ARBRE ");\r
+ call move(0,340);\r
+ call outstring("APPUYEZ SUR <RETURN> POUR CONTINUER ...");\r
+ rep:=inchar;\r
+ pointeur:=z;\r
+fi;\r
+end recherche;\r
+\r
+\r
+\r
+(* PROCEDURES ET FONCTIONS UTILISANT LE MODE GRAPHIQUE *)\r
+\r
+unit inchar: iiuwgraph function:integer;\r
+var i:integer;\r
+begin\r
+ do\r
+ i:=inkey;\r
+ if i=/=0 then exit fi;\r
+ od;\r
+ result:=i;\r
+end inchar;\r
+\r
+\r
+unit ReadInteger : iiuwgraph function : integer;\r
+ var X,Y,i, OrdN, j : integer,\r
+ Number : arrayof integer;\r
+(* i - liczba wprowadzonych znakow *)\r
+ begin\r
+ array Number dim( 1 : 4 );\r
+ i:= 0 ;\r
+ X := InXPos;\r
+ Y := InYPos;\r
+ do\r
+ OrdN:=inchar;\r
+ if i = 4 or (OrdN < 48 and OrdN > 57) then exit fi;\r
+ \r
+ case OrdN\r
+ when 48 :i:=i+1;\r
+ Number(i):=0;\r
+ when 49 :i:=i+1;\r
+ Number(i):=1;\r
+ when 50 :i:=i+1;\r
+ Number(i):=2;\r
+ when 51 :i:=i+1;\r
+ Number(i):=3;\r
+ when 52 :i:=i+1;\r
+ Number(i):=4;\r
+ when 53 :i:=i+1;\r
+ Number(i):=5;\r
+ when 54 :i:=i+1;\r
+ Number(i):=6;\r
+ when 55 :i:=i+1;\r
+ Number(i):=7;\r
+ when 56 :i:=i+1;\r
+ Number(i):=8;\r
+ when 57 :i:=i+1;\r
+ Number(i):=9;\r
+ when 8 :if i>0 then\r
+ Number( i ) := 0;\r
+ i := i - 1;\r
+ fi;\r
+ when 13 :if i > 0 then exit fi ;\r
+ \r
+ esac;\r
+ \r
+ if Number( 1 ) <> 0 then\r
+ call Move( X,Y );\r
+ call hascii( 0 );\r
+ call hascii(48+Number( 1 ));\r
+ call hascii( 0 );\r
+ \r
+ fi;\r
+ \r
+ if i = 2 then\r
+ call Move( X + 8, Y );\r
+ call hascii( 0 );\r
+ call hascii( 48 + Number( 2 ));\r
+ call hascii( 0 );\r
+ fi;\r
+ od;\r
+ \r
+ if Number( 1 ) = 0 and Number( 2 ) = 0 then\r
+ call Move( X,Y );\r
+ call hascii( 0 );\r
+ call hascii( 48 );\r
+ call hascii( 0 );\r
+ fi;\r
+ \r
+ if i = 1 then result := Number( 1 );\r
+ else\r
+ result := 10 * Number( 1 ) + Number ( 2 );\r
+ fi;\r
+ kill( Number );\r
+ end ReadInteger;\r
+ \r
+\r
+\r
+unit WriteInteger:iiuwgraph procedure(Number:integer);\r
+var i,j:integer;\r
+begin\r
+ if Number < 10 then\r
+ call HASCII( 0 );\r
+ call HASCII( Number + 48 );\r
+ call HASCII( 0 );\r
+ else\r
+ i:=Number div 10;\r
+ j:=(Number - (i * 10));\r
+ call HASCII(0);\r
+ call HASCII( i + 48 );\r
+ call HASCII(0);\r
+ call HASCII( j + 48 );\r
+ fi;\r
+end WriteInteger;\r
+\r
+(* FIN DES UNITES DE LECTURE ET ECRITURE EN MODE GRAPHIQUE *)\r
+\r
+\r
+(* SAISIE D'UN ELEMENT *)\r
+unit saisie : iiuwgraph procedure(output nombre:integer);\r
+begin\r
+ call cls;\r
+ call move(200,100);\r
+ call outstring("ENTREZ UN ENTIER : ");\r
+ nombre:=readinteger;\r
+end;\r
+\r
+\r
+(* AFFICHAGE DU MENU PRINCIPAL *)\r
+unit menu:iiuwgraph procedure(output chx:integer);\r
+begin\r
+ call cls;\r
+ call color(14);\r
+ call move(180,50);\r
+ call outstring("IMPLEMENTATION DES ARBRES BICOLORES");\r
+ call move(280,100);\r
+ call outstring("MENU PRINCIPAL");\r
+ call move(200,140);\r
+ call outstring("INSERTION : 1");\r
+ call move(200,160);\r
+ call outstring("SUPPRESSION : 2");\r
+ call move(200,180);\r
+ call outstring("VISUALITION DE L'ARBRE : 3");\r
+ call move(200,200);\r
+ call outstring("RECHERCHE D'UN ELEMENT : 4");\r
+ call move(200,220);\r
+ call outstring("RECHERCHE DU MININUM : 5");\r
+ call move(200,240);\r
+ call outstring("RECHERCHE DU MAXIMUM : 6");\r
+ call move(200,260);\r
+ call outstring("FIN DU TRAITEMENT : 9");\r
+ call move(200,300);\r
+ call outstring(" VOTRE CHOIX : ");\r
+ chx:=readinteger;\r
+end;\r
+\r
+\r
+(* AFFICHAGE DE L'ARBRE *)\r
+unit visua: procedure(t:noeud;input coeff:real,sup:real,inf:real,niveau:integer);\r
+var posx:real,posy,i,j:integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ if t=/= z then\r
+ niveau:=niveau+1;\r
+ posx:=(coeff*(sup-inf))+inf;\r
+ posy:=(niveau*35);\r
+ if niveau=/=1 then\r
+ (*call move(inxpos+8,inypos+8);*)\r
+ call draw(posx*640,posy);\r
+ (*call move(inxpos-8,inypos-8);*)\r
+ fi;\r
+ call move(round(posx*640),posy);\r
+ call HASCII(0);\r
+ (*call writeinteger(t.elem);*)\r
+ (*call HASCII(t.elem+48);*)\r
+ call move(inxpos+4,inypos);\r
+ if t.couleur=1 then call color(12);\r
+ else call color(7);\r
+ fi;\r
+ if t.elem<10 then\r
+ call HASCII(0);\r
+ call HASCII(t.elem+48);\r
+ call HASCII(0);\r
+ else\r
+ i:=t.elem div 10;\r
+ j:=t.elem-i*10;\r
+ call HASCII(0);\r
+ call HASCII(i+48);\r
+ call HASCII(0);\r
+ call HASCII(j+48);\r
+ fi;\r
+ call color(1);\r
+ call move(inxpos-20,inypos);\r
+ call visua(t.gauche,0.5,posx,inf,niveau);\r
+ call move(round(posx*640)+8,posy+8);\r
+ call visua(t.droite,0.5,sup,posx,niveau);\r
+ call move(round(posx*640)+8,posy+8);\r
+ fi;\r
+ end;\r
+end visua;\r
+\r
+\r
+\r
+\r
+(* PROGRAMME PRINCIPAL *)\r
+\r
+\r
+var choix,a,trouve,i,ligne:integer,\r
+ x,z,racine,min,max,pnteur,remp:noeud,\r
+ rp:char;\r
+\r
+\r
+BEGIN\r
+pref iiuwgraph block (* UTILISATION DU MODE GRAPHIQUE SUR ECRAN EGA/VGA *)\r
+begin\r
+\r
+z:=new noeud;\r
+choix:=0;\r
+z.couleur:=0;\r
+racine:=z;\r
+call gron(5);\r
+\r
+while (choix<>9)\r
+do\r
+call menu(choix);\r
+ case choix\r
+ when 1 : call cls;\r
+ call move(200,100);\r
+ call saisie(a);\r
+ z.elem:=a;\r
+ trouve:=0;\r
+ call insert_bst(a,racine,x,racine,trouve);\r
+ if trouve=0\r
+ then call insert(x,racine);\r
+ fi\r
+ when 2 : call cls;\r
+ call move(200,100);\r
+ call saisie(a);\r
+ call recherche(racine,a,pnteur);\r
+ if pnteur<>z \r
+ then\r
+ call suppression(racine,pnteur,remp);\r
+ fi;\r
+ when 3 : if racine<>z then\r
+ call cls;\r
+ call visua(racine,0.5,1,0,0);\r
+ else\r
+ call cls;\r
+ call move(200,100);\r
+ call outstring(" ARBRE VIDE ");\r
+ fi;\r
+ call color(14);\r
+ call move(0,340);\r
+ call outstring("APPUYEZ SUR <RETURN> POUR CONTINUER ... ");\r
+ rp:=chr(inchar)\r
+ when 4 : call cls;\r
+ call move(200,100);\r
+ call saisie(a);\r
+ call recherche(racine,a,pnteur)\r
+ when 5 : call cls;\r
+ if racine<>z then\r
+ if racine.gauche<>z \r
+ then min:=recmin(racine.gauche);\r
+ else min:=racine;\r
+ fi;\r
+ call move(200,100); \r
+ call outstring("LE MININUM DE L'ARBRE EST: ");\r
+ call WriteInteger(min.elem);\r
+ else\r
+ call move(200,100);\r
+ call outstring("OPERATION IMPOSSIBLE : ARBRE VIDE ");\r
+ call move(0,340);\r
+ call outstring("APPUYEZ SUR <RETURN> POUR CONTINUER ...");\r
+ fi;\r
+ rp:=chr(inchar)\r
+ when 6 : call cls;\r
+ if racine<>z then\r
+ if racine.droite<>z\r
+ then max:=recmax(racine.droite);\r
+ else max:=racine;\r
+ fi;\r
+ call move(200,100);\r
+ call outstring("LE MAXIMUM DE L'ARBRE EST: ");\r
+ call WriteInteger(max.elem);\r
+ else\r
+ call move(200,100);\r
+ call outstring("OPERATION IMPOSSIBLE : ARBRE VIDE ");\r
+ fi;\r
+ call move(0,340);\r
+ call outstring("APPUYEZ SUR <RETURN> POUR CONTINUER ... ");\r
+ rp:=chr(inchar);\r
+ esac;\r
+od;\r
+\r
+call groff;\r
+call endrun;\r
+end;\r
+\r
+END bicolore;\r
+\r
--- /dev/null
+BLOCK\r
+ const\r
+ rouge=0,\r
+ blanc=1;\r
+\r
+ (* D\82finition classe Caract\8are *)\r
+ unit caractere:class(x:char);\r
+ end caractere;\r
+\r
+ (* Function attendant qu'un caract\8are soit tap\82 au clavier *)\r
+ (* et le renvoie *)\r
+ unit saisie_car:function:integer;\r
+ var a:integer;\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ a:=0;\r
+ while a=0 do\r
+ a:=inkey;\r
+ od;\r
+ result:=a;\r
+ end;\r
+ end saisie_car;\r
+\r
+ (* D\82finition de la classe arbre_bicolore *)\r
+ (* Param\88tres : le type elem des \82l\82ments utilis\82s *)\r
+ (* fonction inf renvoyant vrai si e1<e2 *)\r
+ (* fonction sup renvoyant vrai si e1>e2 *)\r
+ (* fonction eg renvoyant vrai si e1=e2 *)\r
+ (* proc\82dure aff affichant e *)\r
+ unit arbre_bicolore:class(type elem;\r
+ function inf(e1,e2:elem):boolean;\r
+ function sup(e1,e2:elem):boolean;\r
+ function eg(e1,e2:elem):boolean;\r
+ procedure aff(e:elem));\r
+\r
+ (* D\82finition d'une cellule ou noeud *)\r
+ unit cellule:class;\r
+ var e:elem;\r
+ var p,left,right:cellule;\r
+ var color:integer;\r
+ end cellule;\r
+\r
+ (* D\82claration de la racine *)\r
+ Var T:cellule;\r
+\r
+ (* Procedure affichant les information contenues dans *)\r
+ (* s, x et s2 en faisant une pause *)\r
+ unit info:procedure(s:string;x:elem;s2:string);\r
+ var i:integer;\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ call color(15);\r
+ call move(10,200);\r
+ call outstring(" ");\r
+ call move(10,200);\r
+ call outstring(s);\r
+ call aff(x);\r
+ call outstring(s2);\r
+ call move(10,220);\r
+ call outstring("<Enter>");\r
+ i:=0;\r
+ while (i<>13) do\r
+ i:=inkey;\r
+ od;\r
+ call move(10,220);\r
+ call outstring(" ");\r
+ end;\r
+ end info;\r
+\r
+ (* Fonction ajoutant un nouvel \82l\82ment dans l'arbre \85 la fa\87on *)\r
+ (* d'un bst, elle renvoie la cellule qui a \82t\82 cr\82e et rajout\82e*)\r
+ unit recursive_ajout:function(e:elem;inout r,p:cellule):cellule;\r
+ var a:cellule;\r
+ begin\r
+ if r=none then\r
+ a:=new cellule;\r
+ a.e:=e;\r
+ a.p:=p;\r
+ r:=a;\r
+ result:=r;\r
+ else\r
+ if inf(e,r.e) then\r
+ result:=recursive_ajout(e,r.left,r);\r
+ else if sup(e,r.e) then\r
+ result:=recursive_ajout(e,r.right,r);\r
+ fi\r
+ fi;\r
+ fi;\r
+ end recursive_ajout;\r
+\r
+ (* Cette fonction apelle la proc\82dure r\82cursive "recursive_ajout"*)\r
+ unit insere_bst:function(x:elem):cellule;\r
+ var none_p:cellule;\r
+ begin\r
+ none_p:=none;\r
+ result:=recursive_ajout(x,T,none_p);\r
+ end insere_bst;\r
+\r
+ (* Procedure effectuant une rotation \85 gauche sur la cellule c *)\r
+ unit left_rotate:procedure(c:cellule);\r
+ var y:cellule;\r
+ begin\r
+ y:=c.right;\r
+ c.right:=y.left;\r
+ if y.left<>none then\r
+ y.left.p:=c;\r
+ fi;\r
+ y.p:=c.p;\r
+ if c.p=none then\r
+ T:=y;\r
+ else\r
+ if c=c.p.left then\r
+ c.p.left:=y;\r
+ else\r
+ c.p.right:=y;\r
+ fi;\r
+ fi;\r
+ y.left:=c;\r
+ c.p:=y;\r
+ end left_rotate;\r
+\r
+ (* Procedure effectuant une rotation \85 droite sur la cellule c *)\r
+ unit right_rotate:procedure(c:cellule);\r
+ var y:cellule;\r
+ begin\r
+ y:=c.left;\r
+ c.left:=y.right;\r
+ if y.right<>none then\r
+ y.right.p:=c;\r
+ fi;\r
+ y.p:=c.p;\r
+ if c.p=none then\r
+ T:=y;\r
+ else\r
+ if c=c.p.right then\r
+ c.p.right:=y;\r
+ else\r
+ c.p.left:=y;\r
+ fi;\r
+ fi;\r
+ y.right:=c;\r
+ c.p:=y;\r
+ end right_rotate;\r
+\r
+ (* Proc\82dure ins\82rant un nouvel \82l\82ment x dans l'arbre bicolore *)\r
+ unit insert:procedure(x:elem);\r
+ var y,c:cellule,ok:boolean;\r
+ var i:integer;\r
+ var E:cellule;\r
+ begin\r
+ e:=new cellule;\r
+ pref IIUWGRAPH block\r
+ begin\r
+ (* insersion dans l'arbre et affichage *)\r
+ c:=insere_bst(x);\r
+ if c<>none then c.color:=rouge;fi;\r
+ call parcours;\r
+ if c<>none then\r
+ call info("Ajout en rouge de l'\82l\82ment ",c.e," dans le BST-arbre ");\r
+ fi;\r
+\r
+ (* Retraitement de l'arbre si un nouvel \82l\82ment a \82t\82 cr\82\82 *)\r
+ if c<>none then\r
+ if c=t then ok:=false\r
+ else ok:=c.p.color=rouge;\r
+ fi;\r
+\r
+ (* on teste les \82l\82ments de la feuille ajout\82e *)\r
+ (* Jusqu'\85 la racine *)\r
+ while (c<>T) and (ok)\r
+ do\r
+ if (c.p=c.p.p.left) then\r
+ y:=c.p.p.right;\r
+ (* Echange des couleurs si un noeud a deux fils rouges *)\r
+ if (y<>none) andif (y.color=rouge) then\r
+ c.p.color:=blanc;\r
+ y.color:=blanc;\r
+ c.p.p.color:=rouge;\r
+ c:=c.p.p;\r
+ call parcours;\r
+ if c<>none then\r
+ call info("Echanges de couleurs entre ",c.e," et ses fils");\r
+ fi;\r
+ else\r
+ (* Rotation si un noeud rouge a un fils rouge *)\r
+ if (c=c.p.right) then\r
+ c:=c.p;\r
+ E.e:=c.e;\r
+ call info("Rotation gauche sur ",e.e,". ");\r
+ call left_rotate(c);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation gauche sur ",e.e,"effectu\82e. ");\r
+ fi;\r
+ c.p.color:=blanc;\r
+ c.p.p.color:=rouge;\r
+ e.e:=c.p.p.e;\r
+ call info("Rotation droite sur ",e.e,".");\r
+ call right_rotate(c.p.p);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation droite sur ",e.e," effectu\82e.");\r
+ fi;\r
+ else\r
+ y:=c.p.p.left;\r
+ (* Echange des couleurs si un noeud a deux fils rouges *)\r
+ if (y<>none) andif (y.color=rouge) then\r
+ c.p.color:=blanc;\r
+ y.color:=blanc;\r
+ c.p.p.color:=rouge;\r
+ c:=c.p.p;\r
+ if c<>none then\r
+ call info("Echange de couleurs entre ",c.e," et ses fils ");\r
+ fi;\r
+ call parcours;\r
+ else\r
+ (* Rotation si un noeud rouge a un fils rouge *)\r
+ if (c=c.p.left) then\r
+ c:=c.p;\r
+ e.e:=c.e;\r
+ call info("Rotation droite sur ",e.e," .");\r
+ call right_rotate(c);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation droite sur ",e.e," effectu\82e.");\r
+ fi;\r
+ c.p.color:=blanc;\r
+ c.p.p.color:=rouge;\r
+ e.e:=c.p.p.e;\r
+ call info("Rotation gauche sur ",e.e,".");\r
+ call left_rotate(c.p.p);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation gauche sur ",e.e," effectu\82e.");\r
+ fi;\r
+ fi;\r
+ if c=t then ok:=false;\r
+ else ok:=c.p.color=rouge;\r
+ fi;\r
+ od;\r
+ fi;\r
+\r
+ (* La racine est toujours blanche *)\r
+ T.color:=blanc;\r
+ end;\r
+ kill(e);\r
+ end insert;\r
+\r
+\r
+ (* Proc\82dure r\82cursive de parcours et d'affichage *)\r
+ (* de l'arbre \85 l'\82cran *)\r
+ (* param\8atres r:cellule en cours de traitement *)\r
+ (* x2,y2 : coordonn\82es du pr\82c\82dent noeud *)\r
+ (* x,y : coordonn\82es du nouveau noeud *)\r
+ (* dx : \82cartement actuel des branches *)\r
+ unit rec_par:procedure(r:cellule;x2,y2,x,y,dx:integer);\r
+ var coul:integer;\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ if r.left<>none then\r
+ call rec_par(r.left,x-5,y,x-dx,y+30,dx div 2);\r
+ fi;\r
+\r
+ (* affichage de la branche *)\r
+ call color(8);\r
+ call move(x2,y2);\r
+ call draw(x,y);\r
+ if r.color=rouge then coul:=4;\r
+ else coul:=15;\r
+ fi;\r
+\r
+ (* affichage du noeud *)\r
+ call style(0);\r
+ call cirb(x+3,y+3,10,0,0,coul,1,1,1);\r
+ call style(1);\r
+ call color(coul);\r
+ call move(x,y);\r
+ call aff(r.e);\r
+ if r.right <>none then\r
+ call rec_par(r.right,x+11,y,x+dx,y+30,dx div 2);\r
+ fi;\r
+ end;\r
+ end rec_par;\r
+\r
+ (* Proc\82dure amor\87ant le parcours *)\r
+ unit parcours:procedure;\r
+ begin\r
+ if T<>none then call rec_par(T,320,10,320,10,160);fi;\r
+ end parcours;\r
+\r
+ (* Function recherchant dans l'arbre l'\82l\82ment x *)\r
+ (* a partir du noeud noeud et renvoyant la cellule correspondante *)\r
+ unit recherche:procedure(x:elem;noeud:cellule;output c:cellule);\r
+ begin\r
+ if inf(x,noeud.e) andif (noeud.left<>none) then\r
+ call recherche(x,noeud.left,c)\r
+ else\r
+ if sup(x,noeud.e) andif (noeud.right<>none) then\r
+ call recherche(x,noeud.right,c)\r
+ else\r
+ if eg(x,noeud.e) then c:=noeud;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end recherche;\r
+\r
+ (* Proc\82dure mettant \85 jour l'arbre de fa\87on \85 ce que toutes les *)\r
+ (* propri\82t\82s des arbres bicolores soient respect\82es apr\8as une *)\r
+ (* suppression d'un \82l\82ment *)\r
+ unit delete_fixup:procedure (x:cellule);\r
+ var e,w:cellule;\r
+ var ok,test1,test2,cree:boolean;\r
+ var i:integer;\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ e:=new cellule;\r
+ if x=none then ok:=false;\r
+ else ok:=x.color=blanc;\r
+ fi;\r
+\r
+ (* on part de la cellule supprim\82e jusqu'\85 la racine *)\r
+ (* on teste s'il n'y a pas deux noeuds rouges \85 la suite *)\r
+ (* sinon on fait des rotations ... *)\r
+ while (x<>T) and (ok)\r
+ do\r
+ if (x=x.p.left) then\r
+ w:=x.p.right;\r
+ if w=none then\r
+ cree:=true;\r
+ w:=new cellule;\r
+ w.color:=blanc;\r
+ w.p:=x.p;\r
+ x.p.right:=w;\r
+ else cree:=false;\r
+ fi;\r
+ \r
+ if (w<>none) andif (w.color=rouge) then\r
+ w.color:=blanc;\r
+ x.p.color:=rouge;\r
+ e.e:=x.p.e;\r
+ call info("Rotation gauche sur ",e.e,".");\r
+ call left_rotate(x.p);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation gauche sur ",e.e," effectu\82e.");\r
+ w:=x.p.right;\r
+ fi;\r
+ if (w.left=none) orif (w.left.color=blanc)\r
+ then test1:=true;\r
+ else test1:=false;\r
+ fi;\r
+ if (w.right=none) orif (w.right.color=blanc)\r
+ then test2:=true;\r
+ else test2:=false;\r
+ fi;\r
+ if (test1) and (test2) then\r
+ w.color:=rouge;\r
+ x:=x.p;\r
+ else\r
+ if (w.right=none) orif (w.right.color=blanc) then\r
+ w.left.color:=blanc;\r
+ w.color:=rouge;\r
+ e.e:=w.e;\r
+ call info("Rotation droite sur ",e.e,".");\r
+ call right_rotate(w);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation droite sur ",e.e," effectu\82e.");\r
+ w:=x.p.right;\r
+ fi;\r
+ w.color:=x.p.color;\r
+ x.p.color:=blanc;\r
+ w.right.color:=blanc;\r
+ e.e:=x.p.e;\r
+ call info("Rotation gauche sur ",e.e,".");\r
+ call left_rotate(x.p);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation gauche sur ",e.e," effectu\82e.");\r
+ x:=T;\r
+ fi;\r
+ if cree then\r
+ kill(w);\r
+ fi;\r
+ else\r
+ w:=x.p.left;\r
+ if w=none then\r
+ w:=new cellule;\r
+ w.color:=blanc;\r
+ w.p:=x.p;\r
+ x.p.left:=w;\r
+ cree:=true;\r
+ else cree:=false;\r
+ fi;\r
+ call parcours;\r
+ if (w<>none) andif (w.color=rouge) then\r
+ w.color:=blanc;\r
+ x.p.color:=rouge;\r
+ e.e:=x.p.e;\r
+ call info("Rotation droite sur ",e.e,".");\r
+ call right_rotate(x.p);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation droite sur ",e.e," effectu\82e.");\r
+ w:=x.p.left;\r
+ fi;\r
+ if (w.right=none) orif (w.right.color=blanc) then\r
+ test1:=true;\r
+ else test1:=false;\r
+ fi;\r
+ if (w.left=none) orif (w.left.color=blanc) then\r
+ test2:=true;\r
+ else test2:=false;\r
+ fi;\r
+ if (test1) and (test2) then\r
+ w.color:=rouge;\r
+ x:=x.p;\r
+ else\r
+ if (w.left=none) orif (w.left.color=blanc) then\r
+ w.right.color:=blanc;\r
+ w.color:=rouge;\r
+ e.e:=w.e;\r
+ call info("Rotation gauche sur ",e.e,".");\r
+ call left_rotate(w);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation gauche sur ",e.e," effectu\82e.");\r
+ w:=x.p.left;\r
+ fi;\r
+ w.color:=x.p.color;\r
+ x.p.color:=blanc;\r
+ w.left.color:=blanc;\r
+ e.e:=x.p.e;\r
+ call info("Rotation droite sur ",e.e,".");\r
+ call right_rotate(x.p);\r
+ call cls;\r
+ call parcours;\r
+ call info("Rotation droite sur ",e.e," effectu\82e.");\r
+ x:=T;\r
+ fi;\r
+ if (cree) then\r
+ kill(w);\r
+ fi;\r
+ fi;\r
+ if x=none then ok:=false;\r
+ else ok:=x.color=blanc;\r
+ fi;\r
+ od;\r
+ if x<>none then\r
+ (* racine blanche *)\r
+ x.color:=blanc;\r
+ fi;\r
+ call parcours;\r
+ call move(10,200);\r
+ call color(15);\r
+ call outstring("Mise \85 jour de l'arbre effectu\82e. ");\r
+ for i:=1 to 4000 do;od;\r
+ kill(e);\r
+ end;\r
+ end delete_fixup;\r
+\r
+ (* Fonction renvoyant le succ\82sseur d'une cellule \85 supprimer *)\r
+ (* c'est \85 dire, le plus grand \82l\82ment du sous-arbre gauche, *)\r
+ (* ou le plus petit \82l\82ment du sous-arbre droit *)\r
+ unit tree_suc:function(c:cellule):cellule;\r
+ var r:cellule;\r
+ begin\r
+ if (c.left<>none) then\r
+ r:=c.left;\r
+ while r.right<>none\r
+ do\r
+ r:=r.right;\r
+ od;\r
+ else\r
+ if (c.right<>none) then\r
+ r:=c.right;\r
+ while r.left<>none\r
+ do\r
+ r:=r.left\r
+ od;\r
+ fi;\r
+ fi;\r
+ result:=r;\r
+ end tree_suc;\r
+\r
+ (* Proc\82dure supprimant un \82l\82ment dans l'arbre *)\r
+ unit delete:procedure(e:elem);\r
+ var c,x,y,k:cellule;\r
+ var cree:integer;\r
+ begin\r
+ k:=new cellule;\r
+ pref IIUWGRAPH block\r
+ begin\r
+ (* Recherche de l'\82l\82ment *)\r
+ if T<>none then call recherche(e,T,c);fi;\r
+ (* Recherche de l'\82l\82ment le rempla\87ant *)\r
+ if c<>none then\r
+ if c.left=none or c.right=none then\r
+ y:=c;\r
+ kill(k);\r
+ else\r
+ y:=tree_suc(c);\r
+ k.e:=y.e;\r
+ fi;\r
+\r
+ (* Remplacement *)\r
+ call info("Suppression et remplacement de ",c.e,".");\r
+ if y.left<>none then\r
+ x:=y.left;\r
+ else\r
+ x:=y.right;\r
+ if x=none then\r
+ x:=new cellule;\r
+ y.right:=x;\r
+ x.color:=blanc;\r
+ cree:=1;\r
+ else\r
+ cree:=0;\r
+ fi;\r
+ fi;\r
+ x.p:=y.p;\r
+\r
+ if y.p=none then\r
+ T:=x;\r
+ else\r
+ if y=y.p.left then\r
+ y.p.left:=x;\r
+ else\r
+ y.p.right:=x;\r
+ fi;\r
+ fi;\r
+ if y<>c then\r
+ c.e:=y.e;\r
+ fi;\r
+ call cls;\r
+ call parcours;\r
+ if k<>none then\r
+ call info("Suppression et remplacement par ",k.e," effectu\82e.");\r
+ kill(k);\r
+ else\r
+ call info("Suppression de ",y.e," effectu\82e .");\r
+ fi;\r
+ (* mise \85 jour de l'arbre *)\r
+ if y.color=blanc then\r
+ call delete_fixup(x);\r
+ fi;\r
+ if (cree=1) then\r
+ if (x.p<>none) andif (x=x.p.left) then\r
+ x.p.left:=none;\r
+ else\r
+ if (x.p<>none) andif (x=x.p.right) then\r
+ x.p.right:=none;\r
+ else\r
+ if (x.p=none) then\r
+ T:=none;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end;\r
+ end delete;\r
+\r
+ end arbre_bicolore;\r
+\r
+ (* Indique si x=y *)\r
+ unit eg:function(x,y:caractere):boolean;\r
+ begin\r
+ result:=ord(x.x)=ord(y.x);\r
+ end eg;\r
+\r
+ (* Indique si x<y *)\r
+ unit inf:function(x,y:caractere):boolean;\r
+ begin\r
+ result:=ord(x.x)<ord(y.x);\r
+ end inf;\r
+\r
+ (* Indique si x>y *)\r
+ unit sup:function(x,y:caractere):boolean;\r
+ begin\r
+ result:=ord(x.x)>ord(y.x);\r
+ end sup;\r
+\r
+ (* affiche le caract\8are a *)\r
+ unit aff:procedure(a:caractere);\r
+ begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ if a<>none then\r
+ Call HASCII(ord(a.x));\r
+ fi;\r
+ end;\r
+ end aff;\r
+\r
+ (* d\82claration des variables *)\r
+ var a_b:arbre_bicolore;\r
+ var a:caractere;\r
+ var e:char;\r
+ var op:integer;\r
+begin\r
+ pref IIUWGRAPH block\r
+ begin\r
+ (* initialisation graphique *)\r
+ call gron(5);\r
+\r
+ (* Cr\82ation d'un arbre *)\r
+ a_b:=new arbre_bicolore(caractere,inf,sup,eg,aff);\r
+\r
+ (* menu principal *)\r
+ op:=0;\r
+ while (op<>ord('q')) do\r
+ call color(15);\r
+ call move(10,270);\r
+ call outstring("Ajouter un noeud .... A");\r
+ call move(10,280);\r
+ call outstring("Supprimer un noeud .. S");\r
+ call move(10,290);\r
+ call outstring("Quitter ............. Q");\r
+ call move(10,300);\r
+ call outstring(" ");\r
+\r
+ (* Saisie de l'op\82ration *)\r
+ op:=0;\r
+ while (op<>ord('q')) and (op<>ord('s')) and (op<>ord('a')) do\r
+ op:=inkey;\r
+ if (op<=ord('Z')) then op:=op+ord('a')-ord('A');fi;\r
+ od;\r
+\r
+ (* Saisie et ajout d'un \82l\82ment *)\r
+ if (op=ord('a')) then\r
+ call color(15);\r
+ call move(10,300);\r
+ call outstring("Tapez l'\82l\82ment \85 ajouter (Escape pour finir) :");\r
+ e:=chr(saisie_car);\r
+ while e<>chr(27) do\r
+ call move(400,300);\r
+ a:=new caractere(e);\r
+ call aff(a);\r
+ call a_b.insert(a);\r
+ call cls;\r
+ call a_b.parcours;\r
+ call color(15);\r
+ call move(10,300);\r
+ call outstring("Tapez l'\82l\82ment \85 ajouter (Escape pour finir) :");\r
+ e:=chr(saisie_car);\r
+ od;\r
+ else\r
+ (* Saisie et Suppression d'un \82l\82ment *)\r
+ if (op=ord('s')) then\r
+ call color(15);\r
+ call move(10,300);\r
+ call outstring("Tapez l'\82l\82ment \85 supprimer (Escape pour finir) :");\r
+ e:=chr(saisie_car);\r
+ while e<>chr(27) do\r
+ a:=new caractere(e);\r
+ call a_b.delete(a);\r
+ call cls;\r
+ call a_b.parcours;\r
+ call color(15);\r
+ call move(10,300);\r
+ call outstring("Tapez l'\82l\82ment \85 supprimer (Escape pour finir) :");\r
+ e:=chr(saisie_car);\r
+ od;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call groff;\r
+ end;\r
+end;\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+program bst;(* T.Michalak *);\r
+var tree :tnode;\r
+var son,father :node;\r
+var fet :arrayof string;\r
+var horn :arrayof arrayof char;\r
+var rozm,actree,treer,menu,menu2,key,key2,i,x:integer;\r
+var hornod,forest :arnode;\r
+var bigi,arsmal :arint;\r
+var short,first,bigtree,wyjscie,usa,change :boolean;\r
+var horbol :arrayof boolean;\r
+var trenam :arrayof char;\r
+ \r
+ unit bold : procedure;\r
+ begin\r
+ write( chr(27), "[1m")\r
+ end bold;\r
+ \r
+ unit reverse : procedure; (* PROCEDURY PRAWIE GRAFICZNE *)\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end reverse;\r
+ \r
+ unit normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end normal;\r
+ \r
+ unit newpage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end newpage;\r
+ \r
+ unit setcursor : procedure(x,y : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := x div 10;\r
+ j := x mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := y div 10;\r
+ j := y mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end setcursor; (* KONIEC TYCH PROCEDUR ^ *)\r
+ \r
+ \r
+ \r
+ \r
+unit node:class; (* KLUCZ DRZEWA *)\r
+ var e :integer;\r
+ var left,right:node;\r
+end node;\r
+ \r
+unit arnode:class; (* TABLICA DRZEW *)\r
+ var a:arrayof node;\r
+ var p:arrayof boolean\r
+end arnode;\r
+ \r
+unit tnode:class;\r
+ var n:node;\r
+ var p:boolean;\r
+end;\r
+ \r
+unit arint:class;\r
+ var a:arrayof integer\r
+end arint;\r
+ \r
+unit search :class(where:node;what:integer);\r
+ (* ALGORYTM DRZEWA BST *)\r
+ var isit,leftone:boolean;\r
+ begin\r
+ son:=where;\r
+ father:=where;\r
+ do if son = none orif son.e=what then exit fi;\r
+ father:=son;\r
+ if son.e>what then son:=son.left;\r
+ leftone:=true\r
+ else son:=son.right;\r
+ leftone:=false fi\r
+ od;\r
+ if son =/=none then isit:=true fi;\r
+ end search;\r
+ \r
+ unit member:search function:boolean;\r
+ begin (* CZY ELEMENT NA DRZEWIE *)\r
+ result:=isit;\r
+ end member;\r
+ \r
+ unit insert:search procedure;\r
+ var help:node; (* WSTAWIANIE ELEMENTU *)\r
+ begin\r
+ if member(where,what) then\r
+ if not short then\r
+ writeln("This number is in this tree");\r
+ for i:=1 to 400 do od\r
+ fi;\r
+ else\r
+ if not tree.p then\r
+ where.e:=what;\r
+ tree.p:=true;\r
+ else\r
+ help:=new node;\r
+ help.e:=what;\r
+ if what>father.e then\r
+ father.right:=help\r
+ else\r
+ father.left:=help\r
+ fi\r
+ fi\r
+ fi\r
+ end insert;\r
+ \r
+ unit delete:search procedure; (* KASOWANIE ELEMENTU *)\r
+ var help,fathelp:node;\r
+ begin\r
+ if member(where,what) then\r
+ if son.right=none then\r
+ if son.left=none then\r
+ if father=/=none then\r
+ if leftone then\r
+ father.left:=none;\r
+ kill(son);\r
+ else father.right:=none;\r
+ kill(son)\r
+ fi\r
+ else\r
+ write("This tree is empty now");\r
+ fi\r
+ else if leftone then father.left:=son.left;\r
+ kill(son)\r
+ else father.right:=son.left;\r
+ kill(son)\r
+ fi\r
+ fi\r
+ else if son.left=none then\r
+ if leftone then father.left:=son.right;\r
+ kill(son)\r
+ else father.right:=son.right;\r
+ kill(son)\r
+ fi\r
+ else if son.right.left=none then\r
+ son.e:=son.right.e;\r
+ help:=new node;\r
+ help:=son.right;\r
+ son.right:=son.right.right;\r
+ kill(help)\r
+ else help:=new node;\r
+ fathelp:=new node;\r
+ help:=son.right.left;\r
+ while help.left=/= none do\r
+ fathelp:=help;\r
+ help:=help.left;\r
+ od;\r
+ if help.right=none then son.e:=help.e;\r
+ fathelp.left:=none;\r
+ kill(help)\r
+ else fathelp.left:=help.right;\r
+ son.e:=help.e;\r
+ kill(help)\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ else writeln("This number is absent");\r
+ for i:=1 to 1000 do od\r
+ fi\r
+ end delete;\r
+ \r
+ \r
+ \r
+unit howbig:function(klop:node):integer;\r
+ var licz:integer;\r
+ unit intx:procedure(klop:node);\r
+ begin\r
+ if klop<>none then\r
+ call intx(klop.left);\r
+ licz:=licz+1;\r
+ call intx(klop.right);\r
+ fi;\r
+ end intx;\r
+begin\r
+ licz:=0;\r
+ call intx(klop);\r
+ result:=licz;\r
+end howbig;\r
+ \r
+ \r
+unit wektor:function (where:node;inout k:integer):arint;\r
+var d,i:integer;\r
+ unit infiks:procedure(where:node;tab:arint);\r
+ begin\r
+ if where<>none then\r
+ call infiks(where.left,tab);\r
+ tab.a(k):=where.e;\r
+ k:=k+1;\r
+ call infiks(where.right,tab);\r
+ fi\r
+ end infiks\r
+begin\r
+ d:=howbig(where);\r
+ k:=1;\r
+ result:=new arint;\r
+ array result.a dim(1:d);\r
+ i:=1;\r
+ call infiks(where,result);\r
+ k:=k-1;\r
+end wektor;\r
+ \r
+unit union:procedure(forest:arnode);\r
+var nrt,no,min,roz,lic,small,maks:integer;\r
+ \r
+ \r
+ unit makser:function(k:integer;where:node):integer;\r
+ begin\r
+ while where.right=/=none do\r
+ where:=where.right\r
+ od;\r
+ if k>where.e then result:=k else result:=where.e fi;\r
+ end makser;\r
+ \r
+ unit minimal:function(tbl:arint;output kl:integer):integer;\r
+ var lep:integer;\r
+ begin\r
+ result:=tbl.a(1);\r
+ kl:=1;\r
+ for lep:=2 to lic do\r
+ if result>tbl.a(lep) then result:=tbl.a(lep);kl:=lep fi;\r
+ od;\r
+ end minimal;\r
+ \r
+ unit trawers:coroutine(where:node);\r
+ unit cwalk:procedure(nod:node);\r
+ begin\r
+ if nod=/=none then\r
+ call cwalk(nod.left);\r
+ small:=nod.e;\r
+ detach;\r
+ call cwalk(nod.right);\r
+ fi\r
+ end cwalk;\r
+ var small:integer;\r
+ begin\r
+ return;\r
+ call cwalk(where);\r
+ small:=maks\r
+ end trawers;\r
+ \r
+ var artraw:arrayof trawers;\r
+ \r
+ begin\r
+ lic:=0;\r
+ for i:=1 to upper(horbol) do if horbol(i) then lic:=lic+1 fi od;\r
+ array forest.a dim(1:lic);\r
+ roz:=1;\r
+ for i:=1 to upper(horbol) do\r
+ if horbol(i) then forest.a(roz):=hornod.a(i);fi;\r
+ roz:=roz+1;\r
+ od;\r
+ roz:=0;\r
+ for i:=1 to lic do\r
+ roz:=roz+howbig(forest.a(i))\r
+ od;\r
+ rozm:=roz;\r
+ bigi:=new arint;\r
+ array bigi.a dim(1:roz);\r
+ array artraw dim(1:lic);\r
+ arsmal:=new arint;\r
+ array arsmal.a dim (1:lic);\r
+ maks:=0;\r
+ for i:=1 to lic do\r
+ artraw(i):=new trawers(forest.a(i));\r
+ maks:=makser(maks,forest.a(i))\r
+ od;\r
+ for i:=1 to lic do attach(artraw(i));arsmal.a(i):=artraw(i).small od;\r
+ min:=arsmal.a(1);\r
+ maks:=maks+1;\r
+ no:=1;\r
+ while min<maks do\r
+ min:=minimal(arsmal,nrt);\r
+ if min<maks then\r
+ bigi.a(no):=min;\r
+ no:=no+1;\r
+ attach(artraw(nrt));\r
+ arsmal.a(nrt):=artraw(nrt).small;\r
+ fi\r
+ od;\r
+end union;\r
+ \r
+unit balance:procedure (inout where:node);\r
+var tab:arint;\r
+var roz:integer;\r
+ unit rozwies:procedure(tabel:arint;a,b:integer);\r
+ begin\r
+ if b-a>0 andif not member(where,tabel.a((a+b) div 2)) then\r
+ call insert(where,tabel.a((a+b) div 2));\r
+ call rozwies(tabel,a,(a+b) div 2);\r
+ call rozwies(tabel,(a+b) div 2,b);\r
+ fi;\r
+ end rozwies;\r
+begin\r
+ if not short then\r
+ tab:=wektor(where,roz);\r
+ else\r
+ tab:=bigi;\r
+ roz:=rozm;\r
+ fi;\r
+ where:=new node;\r
+ tree.p:=false;\r
+ call rozwies(tab,1,roz);\r
+ call insert(where,tab.a(roz));\r
+end balance;\r
+ \r
+unit pisz:procedure(where:node);\r
+var tab:arint;\r
+var i,roz:integer;\r
+begin\r
+tab:=wektor(where,roz);\r
+call setcursor(16,5);\r
+for i:=1 to roz do\r
+ write(tab.a(i):4);\r
+od;\r
+for i:=1 to 500 do od;\r
+end pisz;\r
+ \r
+unit rysuj:procedure(where:node,x:integer,y:integer);\r
+ var i,z,k:integer;\r
+ begin\r
+ call setcursor(x,y-1);\r
+ write("³",where.e:3);\r
+ call setcursor(x,y+3);\r
+ write("³");\r
+ call setcursor(x-1,y-1);\r
+ write("Ú");\r
+ if x=2 then write("ÄÄÄ¿ ") else write("ÄÁÄ¿ ") fi;\r
+ call setcursor(x+1,y-1);\r
+ if where.left=/=none orif where.right=/=none then\r
+ write("ÀÄÂÄÙ")\r
+ else write("ÀÄÄÄÙ")\r
+ fi;\r
+ z:=(x+2) div 4;\r
+ k:=1;\r
+ for i:=1 to z do k:=2*k od;\r
+ k:=40 div k;\r
+ if x>20 then bigtree:=true fi;\r
+ \r
+ if where.left=/=none andif x<21 then\r
+ for i:=y-k+2 to y do\r
+ call setcursor(x+2,i);\r
+ write("Ä");\r
+ od;\r
+ call setcursor(x+2,y+1);\r
+ if where.right=/=none then write("Á")\r
+ else write("Ù")\r
+ fi;\r
+ call setcursor (x+2,y-k+1);\r
+ write("Ú");\r
+ call rysuj(where.left,x+4,y-k)\r
+ fi;\r
+ if where.right=/=none andif x<17 then\r
+ for i:=y+2 to y+k do\r
+ call setcursor(x+2,i);\r
+ write("Ä");\r
+ od;\r
+ write("¿");\r
+ if where.left=none then\r
+ call setcursor(x+2,y+1);\r
+ write("À")\r
+ fi;\r
+ call rysuj(where.right,x+4,y+k)\r
+ fi;\r
+ \r
+end rysuj;\r
+ \r
+ \r
+unit newtree:procedure;\r
+ var name :arrayof char;\r
+ var art :arrayof arrayof char;\r
+ \r
+ unit readstring:function:arrayof char;\r
+ var i,c :integer;\r
+ var klap :boolean;\r
+ var pod :arrayof char;\r
+ begin\r
+ call setcursor(17,10);\r
+ array pod dim (1:8);\r
+ klap:=true;\r
+ result:=pod;\r
+ for i:=1 to 8 do\r
+ while c=0 and klap do\r
+ c:=inkeys\r
+ od;\r
+ if c=13 then klap:=false fi;\r
+ if klap then result(i):=chr(c);\r
+ c:=0;write(result(i)) else result(i):=' ' fi;\r
+ od;\r
+ end readstring;\r
+ \r
+ begin\r
+ call setcursor(15,4);\r
+ writeln("Give name of a new tree");\r
+ call setcursor(16,6);\r
+ name:=readstring;\r
+ if treer>1 then\r
+ hornod.a(actree):=tree.n;\r
+ hornod.p(actree):=tree.p;\r
+ forest.a:=copy (hornod.a);\r
+ forest.p:=copy (hornod.p);\r
+ array hornod.a dim(1:treer);\r
+ array hornod.p dim(1:treer);\r
+ for i:=1 to treer-1 do\r
+ hornod.a(i):=copy (forest.a(i));\r
+ hornod.p(i):=forest.p(i);\r
+ od\r
+ else\r
+ array hornod.a dim(1:1);\r
+ array hornod.p dim(1:1);\r
+ fi;\r
+ hornod.a(treer):=new node;\r
+ art:=copy (horn);\r
+ actree:=treer;\r
+ array horn dim(1:treer+1);\r
+ for i:=1 to treer-1 do\r
+ horn(i):=copy (art(i))\r
+ od;\r
+ horn(treer):=name;\r
+ treer:=treer+1;\r
+ horn(treer):=art(treer-1);\r
+ tree.n:=hornod.a(treer-1);\r
+ tree.p:=false;\r
+ trenam:=name;\r
+ first:=true;\r
+end newtree;\r
+ \r
+ \r
+unit actual:procedure;\r
+ begin\r
+ call setcursor(1,62);\r
+ writeln("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ call setcursor(2,62);\r
+ write ("³ ACTUAL TREE ³Û ");\r
+ call setcursor(3,62);\r
+ write ("³ ");\r
+ call bold;\r
+ if treer=/=1 then\r
+ for i:=1 to 8 do\r
+ write (trenam(i))\r
+ od\r
+ else write(" ") fi;\r
+ call normal;\r
+ write(" ³Û ");\r
+ call setcursor(4,62);\r
+ writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙÛ ");\r
+ call setcursor(5,62);\r
+ writeln(" ßßßßßßßßßßßßßßßßß ");\r
+end actual;\r
+ \r
+unit border:procedure;\r
+ begin\r
+ call normal;\r
+ call newpage;\r
+ call setcursor(1,1);\r
+ writeln("ÚÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ write("³ ");\r
+ call reverse;\r
+ write(fet(1):8);\r
+ call normal;\r
+ writeln(" ³Û ");\r
+ for i:=2 to 10 do\r
+ writeln("³ ",fet(i):8," ³Û ")\r
+ od;\r
+ writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÙÛ ");\r
+ writeln(" ßßßßßßßßßßßßß ");\r
+ call actual;\r
+end border;\r
+ \r
+ \r
+unit border2:procedure;\r
+ var z:integer;\r
+begin\r
+ call normal;\r
+ call setcursor(5,7);\r
+ writeln("ÚÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ call setcursor(6,7);\r
+ write("³ ");\r
+ call reverse;\r
+ for i:=1 to 8 do\r
+ write (horn(1,i))\r
+ od;\r
+ call normal;\r
+ writeln(" ³Û ");\r
+ for z:=2 to treer do\r
+ call setcursor(5+z,7);\r
+ write("³ ");\r
+ for i:=1 to 8 do\r
+ write (horn(z,i))\r
+ od;\r
+ write(" ³Û ")\r
+ od;\r
+ call setcursor(6+treer,7);\r
+ writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÙÛ ");\r
+ call setcursor(7+treer,7);\r
+ writeln(" ßßßßßßßßßßßßß ");\r
+end border2;\r
+ \r
+unit number:procedure;\r
+ begin\r
+ call setcursor(18,2);\r
+ writeln("Give the number ");\r
+ call setcursor(19,6);\r
+ read(x);\r
+end;\r
+ \r
+unit clear:procedure;\r
+ begin\r
+ call setcursor(18,2);\r
+ writeln(" ");\r
+ writeln(" ");\r
+end clear;\r
+ \r
+unit inkeys:IIuwgraph function:integer;\r
+ begin\r
+ result:=inkey;\r
+end inkeys;\r
+ \r
+unit fmenu: procedure;\r
+ unit move:procedure(s1,s2,f1,f2:integer);\r
+ begin\r
+ call setcursor(s1,3);\r
+ write(fet(f1):8);\r
+ call reverse;\r
+ call setcursor(s2,3);\r
+ write(fet(f2):8);\r
+ call normal\r
+ end move;\r
+ begin\r
+ call normal;\r
+ while key=/=13 do\r
+ do key:=inkeys;\r
+ if key=13 orif key=-72 orif key=-80 then exit fi;\r
+ od;\r
+ if key=-72 then\r
+ if menu>1 then menu:=menu-1;\r
+ call move(menu+2,menu+1,menu+1,menu)\r
+ else menu:=10;\r
+ call move(2,11,1,10)\r
+ fi\r
+ fi;\r
+ \r
+ if key=-80 then\r
+ if menu<10 then menu:=menu+1;\r
+ call move(menu,menu+1,menu-1,menu)\r
+ else menu:=1;\r
+ call move(11,2,10,1)\r
+ fi\r
+ fi\r
+ od\r
+end fmenu;\r
+ \r
+ \r
+unit fmenu2: procedure;\r
+ unit move2:procedure(x1,x2,y:integer);\r
+ begin\r
+ call setcursor(x1,y);\r
+ for i:=1 to 8 do\r
+ write (horn(x2,i))\r
+ od;\r
+ call normal;\r
+ end move2;\r
+ begin\r
+ array horbol dim (1:treer-1);\r
+ for i:=1 to treer-1 do\r
+ horbol(i):=false\r
+ od;\r
+ call normal;\r
+ if treer=1 then\r
+ call setcursor(10,15);\r
+ writeln("You haven't tree");\r
+ for i:=1 to 1000 do od else\r
+ while menu2=/=treer do\r
+ while key2=/=13 do\r
+ do key2:=inkeys;\r
+ if key2=13 orif key2=-72 orif key2=-80 then exit fi;\r
+ od;\r
+ if key2=-72 then\r
+ if menu2>1 then menu2:=menu2-1;\r
+ if horbol(menu2+1) then call bold fi;\r
+ call move2(menu2+6,menu2+1,9);\r
+ call reverse;\r
+ call move2(menu2+5,menu2,9)\r
+ else menu2:=treer;\r
+ if horbol(1) then call bold fi;\r
+ call move2(6,1,9);\r
+ call reverse;\r
+ call move2(treer+5,treer,9)\r
+ fi\r
+ fi;\r
+ \r
+ if key2=-80 then\r
+ if menu2<treer then menu2:=menu2+1;\r
+ if horbol(menu2-1) then call bold fi;\r
+ call move2(menu2+4,menu2-1,9);\r
+ call reverse;\r
+ call move2(menu2+5,menu2,9)\r
+ else menu2:=1;\r
+ if horbol(treer) then call bold fi;\r
+ call move2(treer+5,treer,9);\r
+ call reverse;\r
+ call move2(6,1,9)\r
+ fi\r
+ fi\r
+ od;\r
+ if menu2=treer orif not usa then\r
+ if change and menu2=/=treer then\r
+ hornod.a(actree):=tree.n;\r
+ hornod.p(actree):=tree.p;\r
+ actree:=menu2;\r
+ tree.p:=hornod.p(menu2);\r
+ tree.n:=hornod.a(menu2);\r
+ trenam:=horn(menu2);\r
+ change:=false\r
+ fi;\r
+ call setcursor(3,64);\r
+ call bold;\r
+ for i:=1 to 8 do\r
+ write (trenam(i))\r
+ od;\r
+ exit\r
+ else\r
+ if horbol(menu2) then horbol(menu2):=false;\r
+ call reverse\r
+ else call normal;\r
+ call bold;\r
+ horbol(menu2):=true\r
+ fi;\r
+ call move2(menu2+5,menu2,9);\r
+ call normal;\r
+ fi;\r
+ call normal;\r
+ key2:=1\r
+ od\r
+fi;\r
+end fmenu2;\r
+ \r
+ unit WAITforKEY: procedure;\r
+ begin\r
+ while inkeys=0 do od;\r
+ end WAITforKEY\r
+ \r
+ \r
+begin\r
+ hornod:=new arnode;\r
+ forest:=new arnode;\r
+ tree:=new tnode;\r
+ first:=true;\r
+ array fet dim(1:10);\r
+ array horn dim(1:1);\r
+ array horn(1) dim(1:8);\r
+ fet(1):="INSERT ";\r
+ fet(2):="DELETE ";\r
+ fet(3):="MEMBER ";\r
+ fet(4):="DRAW ";\r
+ fet(5):="BALANCE ";\r
+ fet(6):="UNION ";\r
+ fet(7):="WRITE ";\r
+ fet(8):="NEW TREE";\r
+ fet(9):="CHANGE ";\r
+ fet(10):="QUIT ";\r
+ \r
+ horn(1,1):='E';\r
+ horn(1,2):='X';\r
+ horn(1,3):='I';\r
+ horn(1,4):='T';\r
+ for x:=5 to 8 do horn(1,x):=' ' od;\r
+ treer:=1;\r
+ array horbol dim(1:1);\r
+ menu:=1;\r
+ usa:=false;\r
+ call SetCursor(5,10);\r
+ \r
+ do\r
+ call border;\r
+ call fmenu;\r
+ \r
+ case menu\r
+ when 1: if treer=/=1 then\r
+ call number;\r
+ call insert(tree.n,x);\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ key:=1;\r
+ \r
+ when 2:if treer=/=1 then\r
+ if not tree.p then\r
+ call setcursor(17,1);\r
+ write("This tree is empty");\r
+ else\r
+ call number;\r
+ call delete(tree.n,x);\r
+ fi\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ \r
+ \r
+ when 3:if treer=/=1 then\r
+ if not tree.p then\r
+ call setcursor(17,1);\r
+ write("This tree is empty");\r
+ else\r
+ call number;\r
+ wyjscie:=member(tree.n,x);\r
+ if wyjscie\r
+ then\r
+ write( " This number is present ")\r
+ else\r
+ write(" This number is absent")\r
+ fi;\r
+ \r
+ fi\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ \r
+ \r
+ when 4:if treer=/=1 then\r
+ \r
+ if not tree.p then\r
+ call setcursor(17,1);\r
+ write("This tree is empty")\r
+ else\r
+ call newpage;\r
+ call actual;\r
+ bigtree:=false;\r
+ call rysuj(tree.n,2,40);\r
+ call setcursor(22,40);\r
+ if bigtree then\r
+ writeln("Tree to big")\r
+ fi;\r
+ writeln("press any key");\r
+ menu:=1;\r
+ fi\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ \r
+ key:=1;\r
+ \r
+ \r
+ when 5:if treer=/=1 then\r
+ if not tree.p then\r
+ call setcursor(17,1);\r
+ write("This tree is empty");\r
+ else\r
+ call balance(tree.n);\r
+ fi;\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ \r
+ \r
+ when 6:if treer=/=1 then\r
+ usa:=true;\r
+ menu2:=1;key2:=1;\r
+ call border2;\r
+ call fmenu2;\r
+ short:=true;\r
+ call union(forest);\r
+ call newtree;\r
+ call balance(tree.n);\r
+ short:=false;\r
+ usa:=false;\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ \r
+ fi;\r
+ \r
+ \r
+ when 7:if treer<>1 then\r
+ if not tree.p then\r
+ call setcursor(17,1);\r
+ write("This tree is empty");\r
+ else\r
+ call pisz(tree.n);\r
+ fi\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ \r
+ \r
+ when 8: call newtree;\r
+ \r
+ \r
+ when 9: if treer<>1\r
+ then\r
+ change:=true;\r
+ menu2:=1;key2:=1;\r
+ call border2;\r
+ call fmenu2;\r
+ call border;\r
+ else\r
+ call setcursor(17,1);\r
+ writeln("You haven't tree");\r
+ fi;\r
+ \r
+ \r
+ when 10: call endrun;\r
+ \r
+ esac ;\r
+ call SetCursor(22,40);\r
+ write("press any key");\r
+ call WaitForKey;\r
+ call SetCursor(22,40);\r
+ write(" ");\r
+ call SetCursor(17,1);\r
+ write(" ");\r
+ menu:=1;\r
+ key:=1;\r
+ od;\r
+ \r
+end bst.\r
--- /dev/null
+program tree;\r
+(*****************************************************************************\r
+ B O G D A N W I E R C Z Y N S K I\r
+ 1 0 . 0 1 . 1 9 8 9\r
+ Przedstawiony program umozliwia tworzenie drzewa BST oraz jego modyfikacje\r
+ w celach dydaktycznych. Udostepnia cztery podstawowe operacje na tej\r
+ strukturze danych:insert,delete,minimum i maximum. Struktora drzewa jest\r
+ wyswietlana na ekranie i kazda akcja powodujaca jej zmiane wiaze sie ze\r
+ zmiana drzewa na ekranie.\r
+******************************************************************************)\r
+ \r
+ \r
+ unit BST:class;\r
+ (* Klasa implementujaca BST jako abstrakcyjny typ danych z podstawowymi\r
+ operacjami zwiazanymi z ta struktora. *)\r
+ \r
+ unit vertex:class;\r
+ var key:integer,\r
+ left,right:vertex;\r
+ end vertex;\r
+ \r
+ unit find:class(x:real;inout v:vertex);\r
+ (* Wyszukanie w drzewie o korzeniu v wierzcholka z kluczem o wartosci x *)\r
+ var father,(* Wskazanie na ojca szukanegoelementu *)\r
+ znaleziony,(* Wskazanie na wierzcholek ktorego klucz ma wartosc x *)\r
+ vpom:vertex,(* Zmienna pomocnicza *)\r
+ lson:boolean;(* Zmienna informujaca ze znaleziony element jest\r
+ lewym synem *)\r
+ begin\r
+ vpom:=v;\r
+ father,znaleziony:=none;\r
+ while vpom=/=none do\r
+ if x<vpom.key then father:=vpom;vpom:=vpom.left;lson:=true\r
+ else\r
+ if x>vpom.key then father:=vpom;vpom:=vpom.right;lson:=false\r
+ else znaleziony:=vpom;exit\r
+ fi\r
+ fi\r
+ od;\r
+ end find;\r
+ \r
+ unit delete:find procedure;\r
+ (* Kasowanie wierzcholka ktorego wartosc klucza jest parametrem x w\r
+ find *)\r
+ begin\r
+ if znaleziony=/=none then\r
+ if znaleziony.left=znaleziony.right then\r
+ (* Usuwany element jest lisciem *) kill(znaleziony)\r
+ else\r
+ if znaleziony.right=none then\r
+ if father=none then v:=v.left\r
+ (* Usuwany element jest korzeniem drzewa *)\r
+ else\r
+ if lson then father.left:=znaleziony.left\r
+ else father.right:=znaleziony.left\r
+ fi\r
+ fi;\r
+ kill(znaleziony)\r
+ else\r
+ vpom:=znaleziony.right;\r
+ while vpom.left=/=none do\r
+ vpom:=vpom.left\r
+ od;\r
+ znaleziony.key:=vpom.key;\r
+ if vpom.right=none then kill(vpom)\r
+ else\r
+ znaleziony:=vpom.right; (* Wykorzystanie zmiennej znaleziony\r
+ jako zmiennej pomocniczej *)\r
+ vpom.key:=znaleziony.key;\r
+ vpom.left:=znaleziony.left;\r
+ vpom.right:=znaleziony.right;\r
+ kill(znaleziony)\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ end delete;\r
+ \r
+ unit insert:procedure(x:integer;inout v:vertex);\r
+ (* Wstawienie do drzewa BST o korzeniu v elementu ktorego wartosc klucza\r
+ bedzie rowna x *)\r
+ var vpom:vertex;\r
+ begin\r
+ if v=none then v:=new vertex; v.key:=x (* Puste drzewo *)\r
+ else\r
+ vpom:=v;\r
+ do\r
+ if x<=vpom.key then\r
+ if vpom.left=/=none then vpom:=vpom.left\r
+ else vpom.left:=new vertex;\r
+ vpom.left.key:=x;\r
+ exit\r
+ fi\r
+ else\r
+ if vpom.right=/=none then vpom:=vpom.right\r
+ else vpom.right:=new vertex;\r
+ vpom.right.key:=x;\r
+ exit\r
+ fi\r
+ fi\r
+ od\r
+ fi\r
+ end insert;\r
+ \r
+ unit minimum:function(v:vertex):integer;\r
+ (* Znalezienie elementu o najmniejszym kluczu *)\r
+ begin\r
+ while v.left =/= none do\r
+ v:=v.left;\r
+ od;\r
+ result:=v.key;\r
+ end minimum;\r
+ \r
+ unit maximum:function(v:vertex):integer;\r
+ (* Znalezienie elementu o najwiekszym kluczu *)\r
+ begin\r
+ while v.right=/= none do\r
+ v:=v.right;\r
+ od;\r
+ result:=v.key;\r
+ end maximum;\r
+ \r
+ end BST;\r
+ \r
+ \r
+ unit SetCursor: procedure(x,y:integer);\r
+ var i,j:integer,\r
+ c,d,e,f:char;\r
+ begin\r
+ i:= x div 10;\r
+ j:= x mod 10;\r
+ c:=chr(48+i);\r
+ d:=chr(48+j);\r
+ i:=y div 10;\r
+ j:=y mod 10;\r
+ e:=chr(48+i);\r
+ f:=chr(48+j);\r
+ write(chr(27),"[",c,d,";",e,f,"H")\r
+ end SetCursor;\r
+ \r
+ unit inchar : IIUWgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit ClearScreen: procedure;\r
+ begin\r
+ write(chr(27),"[2J")\r
+ end ClearScreen;\r
+ \r
+ \r
+begin\r
+pref BST block\r
+ \r
+ \r
+ unit OpenWindow:procedure(x,y,height,width:integer);\r
+ (* Otwarcie okienka ktorege lewy gorny rog ma wspolrzedne (x,y) i o wymiarach\r
+ height x width (wysokosc x szerokosc) *)\r
+ var i,j:integer;\r
+ begin\r
+ call SetCursor(x,y);\r
+ write(chr(218));\r
+ for j:=2 to width-1 do write(chr(196)) od;\r
+ write(chr(191));\r
+ for i:=2 to height-1 do\r
+ call SetCursor(x+i-1,y);\r
+ write(chr(179));\r
+ for j:=2 to width-1 do write(" ") od;\r
+ write(chr(179));\r
+ od;\r
+ call SetCursor(x+height-1,y);\r
+ write(chr(192));\r
+ for j:=2 to width-1 do write(chr(196)) od;\r
+ write(chr(217));\r
+ call SetCursor(x+1,y+1);\r
+ end OpenWindow;\r
+ \r
+ unit CloseWindow:procedure(x,y,height,width:integer);\r
+ (* Zamkniecie okienka ktorege lewy gorny rog ma wspolrzedne (x,y) i o wymiarach\r
+ height x width (wysokosc x szerokosc) *)\r
+ var i,j:integer;\r
+ begin\r
+ \r
+ for i:=0 to height-1 do\r
+ call SetCursor(x+i,y);\r
+ for j:=1 to width do write(" ") od;\r
+ od;\r
+ end CloseWindow;\r
+ \r
+ unit negative:procedure;\r
+ begin\r
+ write(chr(27),"[7m");\r
+ end negative;\r
+ \r
+ unit positive:procedure;\r
+ begin\r
+ write(chr(27),"[0m");\r
+ end positive;\r
+ \r
+ unit MenuType:class;\r
+ var beginingX,beginingY:integer,\r
+ Name:string;\r
+ end MenuType;\r
+ \r
+ unit Inic:procedure;\r
+ (* Zainicjowanie systemu,utorzenie odpowiednich danych, ich zainicjowanie,\r
+ wyswietlenie menu . *)\r
+ var i:integer;\r
+ begin\r
+ AktPoz:=0;\r
+ array Menu dim(0:4);\r
+ for i:=0 to 4 do (* Wypelnienie tablicy menu *)\r
+ Menu(i):=new MenuType;\r
+ Menu(i).beginingX:=2; (* Wspolrzedne peczatku napisu opcji w menu *)\r
+ Menu(i).beginingY:=8+i*16;\r
+ case i (* Wstawienie odpowiedniego tekstu *)\r
+ when 0: Menu(i).Name:="INSERT";\r
+ when 1: Menu(i).Name:="DELETE";\r
+ when 2: Menu(i).Name:="MINIMUM";\r
+ when 3: Menu(i).Name:="MAXIMUM";\r
+ when 4: Menu(i).Name:="EXIT";\r
+ esac;\r
+ od;\r
+ call ClearScreen;\r
+ call SetCursor(1,1);\r
+ for i:=1 to 80 do\r
+ write(chr(196))\r
+ od;\r
+ call negative;\r
+ call SetCursor(Menu(0).beginingX,Menu(0).beginingY);\r
+ write(Menu(0).Name);\r
+ call positive;\r
+ for i:=1 to 4 do\r
+ call SetCursor(Menu(i).beginingX,Menu(i).beginingY);\r
+ write(Menu(i).Name);\r
+ od;\r
+ call SetCursor(3,1);\r
+ for i:=1 to 80 do\r
+ write(chr(196))\r
+ od;\r
+ call SetCursor(Menu(0).beginingX,Menu(0).beginingY);\r
+ end Inic;\r
+ \r
+ unit printclass:class;\r
+ (* Klasa ktora zajmuje sie wyswietlaniem drzewa na ekranie .\r
+ (Mozna ja traktowac w pewnym sensie jak pprocedure) *)\r
+ const X=1,\r
+ Y=2;\r
+ var i,j,last,przes,NumberOfVert:integer,\r
+ VertCoord:array_of array_of integer,(*Tablica zawierajaca wspolrzedne\r
+ wyswietlanych elementow *)\r
+ queueForPrint:array_of vertex;(*kolejka elementow do wyswietlenia*)\r
+ \r
+ unit printTree:procedure(v:vertex);\r
+ (* Procedura wyswietlajaca drzewo o podanym korzeniu *)\r
+ var first:integer,\r
+ isleft,isright:boolean;\r
+ begin\r
+ if v=/=none then\r
+ first,last:=1;\r
+ queueForPrint(last):=v;\r
+ while first<=31 do (* Wstawianie 31 kolejnych wierzcholkow do kolejki\r
+ i drukowanie ich.(Tylko tyle miesci sie na\r
+ monitorze *)\r
+ if first<=15 then\r
+ if queueForPrint(first)=none then\r
+ queueForPrint(last+1),queueForPrint(last+2):=none;\r
+ (*Niema synow wiec wstawiamy none *)\r
+ else\r
+ queueForPrint(last+1):=queueForPrint(first).left;\r
+ queueForPrint(last+2):=queueForPrint(first).right;\r
+ isleft:=queueForPrint(first).left=/=none;\r
+ isright:=queueForPrint(first).right=/=none;\r
+ call Setcursor(VertCoord(X,first),VertCoord(Y,first)-1);\r
+ (* Wypisanie elementu drzewa w odpowiednim formacie *)\r
+ call format(queueForPrint(first).key);\r
+ if isleft or_if isright then\r
+ call Setcursor(VertCoord(X,first)+1,VertCoord(Y,first));\r
+ write(chr(179));\r
+ if isleft then\r
+ call Setcursor(VertCoord(X,first*2)-1,VertCoord(Y,2*first));\r
+ write(chr(179));\r
+ call Setcursor(VertCoord(X,first*2)-2,VertCoord(Y,2*first));\r
+ write(chr(218));\r
+ for i:=1 to ( VertCoord(Y,first)-VertCoord(Y,2*first)-1) do\r
+ write(chr(196));\r
+ od;\r
+ fi;\r
+ if isleft and isright then write(chr(193))\r
+ else\r
+ if isleft then write(chr(217))\r
+ else\r
+ call Setcursor(VertCoord(X,first)+2,VertCoord(Y,first));\r
+ write(chr(192));\r
+ fi;\r
+ fi;\r
+ if isright then\r
+ for i:=1 to ( VertCoord(Y,2*first+1)-VertCoord(Y,first)-1) do\r
+ write(chr(196));\r
+ od;\r
+ write(chr(191));\r
+ call Setcursor(VertCoord(X,first*2+1)-1,\r
+ VertCoord(Y,2*first+1));\r
+ write(chr(179));\r
+ fi;\r
+ fi;\r
+ fi;\r
+ last:=last+2\r
+ else\r
+ if queueForPrint(first)=/=none then\r
+ call SetCursor(VertCoord(X,first),VertCoord(Y,first)-1);\r
+ (* Wypisanie elementu drzewa w odpowiednim formacie *)\r
+ call format(queueForPrint(first).key);\r
+ if queueForPrint(first).left=/=none or_if\r
+ queueForPrint(first).right=/=none then\r
+ call Setcursor(VertCoord(X,first)+1,VertCoord(Y,first));\r
+ write(chr(25));\r
+ fi;\r
+ fi;\r
+ fi;\r
+ first:=first+1\r
+ od;\r
+ fi;\r
+ end printTree;\r
+ \r
+ unit format:procedure(x:integer);\r
+ (* Procedura wybiera odpowiedni format wydruku w zaleznosci od liczby\r
+ cyfr w liczbie x i wypisuje ja na ekran *)\r
+ begin\r
+ if x>=0 then\r
+ if x>999 then write(x:4)\r
+ else\r
+ if x>99 then write(x:3)\r
+ else write(x:2)\r
+ fi\r
+ fi\r
+ else\r
+ if x<-99 then write(x:4)\r
+ else\r
+ if x<-9 then write(x:3)\r
+ else write(x:2)\r
+ fi\r
+ fi\r
+ fi\r
+ end format;\r
+ \r
+ begin\r
+ array VertCoord dim(1:2);\r
+ for i:=1 to 2 do array VertCoord(i) dim(1:31);od;\r
+ array queueForPrint dim(1:31);\r
+ przes:=40;\r
+ last,NumberOfVert:=1;\r
+ (* Wypelnienie tablicy VertCoord wspolrzednymi wszystkich elementow\r
+ ktore moga byc wyswietlone na ekranie *)\r
+ for i:=0 to 4 do\r
+ for j:=1 to NumberOfVert do\r
+ if i=/=4 then\r
+ VertCoord(Y,last):=przes+(j-1)*2*przes;\r
+ fi;\r
+ VertCoord(X,last):=i*4+7;\r
+ last:=last+1\r
+ od;\r
+ NumberOfVert:=NumberOfVert*2;\r
+ przes:=przes div 2\r
+ od;\r
+ przes:=0;\r
+ for last:=16 to 31 do\r
+ VertCoord(Y,last):=2+przes;\r
+ przes:=przes+5\r
+ od;\r
+ end printclass;\r
+ \r
+ \r
+const IndicatorLeft=-75,(* Kody znakow wykorzystywanych przy poslugiwaniu *)\r
+ IndicatorRight=-77,(* sie menu. *)\r
+ Enter=13,\r
+ Esc=27,\r
+ ConstInsert=0,(* Indeksy tablicy Menu odpowiadajace opcjom *)\r
+ ConstDelete=1,\r
+ ConstMinimum=2,\r
+ ConstMaximum=3,\r
+ ConstExit=4;\r
+ \r
+var i,znak,AktPoz,key:integer,\r
+ root:vertex,(* Korzen drzewa BST *)\r
+ print:printclass,\r
+ Menu :array_of MenuType;\r
+ \r
+(********** POCZATEK PROGRAMU GLOWNEGO **********)\r
+begin\r
+ print:=new printclass;\r
+ call Inic;\r
+ do\r
+ znak:=inchar;\r
+ case znak\r
+ when IndicatorRight:call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ write(Menu(AktPoz).Name);\r
+ AktPoz:=(AktPoz+1) mod 5;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ call negative;\r
+ write(Menu(AktPoz).Name);\r
+ call positive;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ when IndicatorLeft: call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ write(Menu(AktPoz).Name);\r
+ AktPoz:=(AktPoz+4) mod 5;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ call negative;\r
+ write(Menu(AktPoz).Name);\r
+ call positive;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ when Enter: if Aktpoz=ConstExit then call endrun\r
+ else\r
+ call OpenWindow(3,Menu(AktPoz).beginingY,3,22);\r
+ case Aktpoz\r
+ when ConstInsert:write("VALUE: ");\r
+ readln(key);\r
+ call insert(key,root);\r
+ call print.printtree(root);\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ when ConstDelete:write("VALUE: ");\r
+ readln(key);\r
+ call delete(key,root);\r
+ call CloseWindow(7,1,18,80);\r
+ call print.printtree(root);\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ when ConstMinimum:if root =/= none then\r
+ write(minimum(root):4," ")\r
+ else write("Empty Tree ");\r
+ fi;\r
+ write("press Esc");\r
+ do\r
+ if inchar=Esc then exit fi;\r
+ od;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ when ConstMaximum:if root =/= none then\r
+ write(maximum(root):4," ")\r
+ else write("Empty Tree ");\r
+ fi;\r
+ write("press Esc");\r
+ do\r
+ if inchar=Esc then exit fi;\r
+ od;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ esac;\r
+ call CloseWindow(3,Menu(AktPoz).beginingY,3,22);\r
+ call SetCursor(Menu(AktPoz).beginingX+1,\r
+ Menu(AktPoz).beginingY);\r
+ for i:=1 to 22 do write(chr(196)) od;\r
+ call SetCursor(Menu(AktPoz).beginingX,\r
+ Menu(AktPoz).beginingY);\r
+ fi;\r
+ \r
+ esac;\r
+ od;\r
+end ;\r
+end tree\r
--- /dev/null
+program drzewo;\r
+ \r
+ \r
+ var num: integer;\r
+ var op: boolean;\r
+ var korzen: node;\r
+ \r
+ \r
+ unit sc : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end sc;\r
+\r
+ unit inchar : IIUWgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+\r
+ unit node: class (e: integer);\r
+ var left, right: node\r
+ end node;\r
+ \r
+ unit search: class (inout gdzie: node, co: integer);\r
+ var pom: node, pom2: node;\r
+ var czyjest: boolean\r
+ begin\r
+ pom:=gdzie;\r
+ while pom=/=none \r
+ do\r
+ if pom.e=co\r
+ then exit\r
+ fi;\r
+ pom2:=pom;\r
+ if pom.e>co\r
+ then pom:=pom.left\r
+ else pom:=pom.right\r
+ fi\r
+ od;\r
+ if pom=/=none\r
+ then czyjest:=true\r
+ fi\r
+ end search;\r
+ \r
+ unit np : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end np;\r
+ \r
+ unit cll: procedure (k: integer);\r
+ unit EraseLine : procedure;\r
+ begin\r
+ write( chr(27), "[K")\r
+ end EraseLine;\r
+ begin\r
+ call sc(k,1);\r
+ call EraseLine\r
+ end cll;\r
+ \r
+ unit ramka: procedure (w1, w2, w3, k1, k2: integer);\r
+ var i: integer;\r
+ begin\r
+ call sc(w1,k1);\r
+ write ("Ú");\r
+ for i:=k1+1 to k2-1\r
+ do\r
+ write ("Ä")\r
+ od;\r
+ write ("¿");\r
+ for i:=w1+1 to w3-1\r
+ do\r
+ call sc(i,k1);\r
+ write ("³");\r
+ call sc(i,k2);\r
+ write ("³")\r
+ od;\r
+ if w2 > 0\r
+ then\r
+ call sc(w2,k1);\r
+ write ("Ã");\r
+ for i:=k1+1 to k2-1\r
+ do\r
+ write ("Ä")\r
+ od;\r
+ write ("´")\r
+ fi;\r
+ call sc (w3,k1);\r
+ write ("À");\r
+ for i:=k1+1 to k2-1\r
+ do write ("Ä") od;\r
+ write ("Ù")\r
+ end ramka;\r
+ \r
+ unit menu: procedure;\r
+ begin\r
+ call np;\r
+ call ramka (1,5,21,10,70);\r
+ call sc(3,33);\r
+ write ("M E N U");\r
+ call sc(7,15);\r
+ write ("1. Wstawienie elementu do drzewa");\r
+ call sc(9,15);\r
+ write ("2. Usuniecie elementu z drzewa");\r
+ call sc(11,15);\r
+ write ("3. Sprawdzenie, czy element jest w drzewie");\r
+ call sc(13,15);\r
+ write ("4. Sprawdzenie, czy drzewo jest puste");\r
+ call sc(15,15);\r
+ write ("5. Drukowanie drzewa w postaci grafu");\r
+ call sc(17,15);\r
+ write ("6. Drukowanie drzewa w postaci listy elementow");\r
+ call sc(19,15);\r
+ write ("7. Wyjscie")\r
+ end menu;\r
+ \r
+ unit wprowliczbe: procedure (output liczba: integer, jest: boolean);\r
+ var znak: char;\r
+ var minus,l: boolean;\r
+ var t, k: integer;\r
+ var m,z: char;\r
+ \r
+ unit cyfra: function (z: char): boolean;\r
+ begin\r
+ if ord(z) >= ord('0') and ord(z) <= ord('9')\r
+ then result:=true\r
+ fi\r
+ end cyfra;\r
+ \r
+ unit alarm: procedure;\r
+ begin\r
+ writeln;\r
+ write ("To nie jest liczba calkowita");\r
+ call beep\r
+ end alarm;\r
+ \r
+ begin\r
+ t:=0;\r
+ z:='0';\r
+ k:=inchar;\r
+ znak:=chr(k);\r
+ m:='-';\r
+ if znak=m\r
+ then\r
+ minus:=true;\r
+ write ("-")\r
+ else\r
+ if not cyfra(znak) \r
+ then \r
+ call alarm;\r
+ return\r
+ else\r
+ write (znak); \r
+ t:=t+ord(znak)-ord(z);\r
+ l:=true\r
+ fi\r
+ fi;\r
+ do\r
+ k:=inchar;\r
+ if k=013 (* enter *)\r
+ then \r
+ jest:=l;\r
+ if minus\r
+ then\r
+ liczba:=-t\r
+ else\r
+ liczba:=t;\r
+ fi;\r
+ exit\r
+ else\r
+ if not cyfra (chr(k))\r
+ then \r
+ call alarm;\r
+ return\r
+ else\r
+ write (chr(k));\r
+ l:=true;\r
+ t:=10*t+k-ord('0');\r
+ fi\r
+ fi\r
+ od\r
+ end wprowliczbe;\r
+ \r
+ unit podkresl: procedure (k1, k2, opcja: integer, czym: char);\r
+ var i, j, co: integer;\r
+ begin\r
+ co:=5+2*opcja;\r
+ for i:=co-1 step 2 to co+1 \r
+ do\r
+ call sc(i,k1+1);\r
+ for j:=k1+1 to k2-1\r
+ do\r
+ write (czym)\r
+ od\r
+ od\r
+ end podkresl;\r
+ \r
+ unit robzsearch: procedure (r: integer);\r
+ var elem: integer;\r
+ var licz: boolean;\r
+ \r
+ unit insert: search procedure;\r
+ var nowy: node;\r
+ begin\r
+ if not czyjest\r
+ then\r
+ nowy:=new node(co);\r
+ if gdzie=none\r
+ then\r
+ gdzie:=nowy\r
+ else\r
+ if pom2.e>co\r
+ then pom2.left:=nowy\r
+ else pom2.right:=nowy\r
+ fi\r
+ fi\r
+ fi\r
+ end insert;\r
+ \r
+ unit delete: search procedure;\r
+ var p1, p2: node;\r
+ \r
+ unit przestaw: procedure (naco: node);\r
+ begin\r
+ if pom=gdzie\r
+ then (* usuwamy korzen *)\r
+ gdzie:=naco\r
+ else\r
+ if pom2.left=pom\r
+ then pom2.left:=naco\r
+ else pom2.right:=naco\r
+ fi\r
+ fi\r
+ end przestaw;\r
+ \r
+ begin\r
+ if czyjest \r
+ then\r
+ if pom.left=none\r
+ then \r
+ call przestaw (pom.right)\r
+ else\r
+ if pom.right=none\r
+ then\r
+ call przestaw (pom.left)\r
+ else (* usuwany wezel ma dwoch synow *)\r
+ if pom.right.left=none\r
+ then\r
+ call przestaw(pom.right);\r
+ pom.right.left:=pom.left\r
+ else\r
+ p1:=pom.right;\r
+ p2:=p1.left;\r
+ while p2.left=/=none\r
+ do\r
+ p1:=p1.left;\r
+ p2:=p2.left\r
+ od;\r
+ p1.left:=p2.right;\r
+ p2.left:=pom.left;\r
+ p2.right:=pom.right;\r
+ call przestaw (p2)\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ end delete;\r
+ \r
+ unit member: search procedure;\r
+ var kon: integer;\r
+ begin\r
+ call cll(24);\r
+ if czyjest\r
+ then\r
+ write ("Ten element jest w drzewie ")\r
+ else\r
+ write ("Tego elementu nie ma w drzewie ") \r
+ fi;\r
+ kon:=inchar\r
+ end member;\r
+ \r
+ begin (* robzsearch *)\r
+ call cll(24);\r
+ write ("Podaj element ");\r
+ call wprowliczbe (elem,licz);\r
+ if not licz\r
+ then\r
+ return\r
+ else\r
+ case r\r
+ when 1 : call insert (korzen,elem);\r
+ when 2 : call delete (korzen,elem);\r
+ when 3 : call member (korzen,elem)\r
+ esac\r
+ fi\r
+ end robzsearch;\r
+ \r
+ unit empty: procedure (k: node);\r
+ var kon: integer;\r
+ begin\r
+ call cll(24);\r
+ if k=none\r
+ then\r
+ write ("Drzewo jest puste ")\r
+ else\r
+ write ("Drzewo nie jest puste ")\r
+ fi;\r
+ kon:=inchar\r
+ end empty;\r
+ \r
+ unit drukuj: procedure;\r
+ var s: char;\r
+ var g, ko: integer;\r
+ var h: boolean;\r
+ var x: search;\r
+ \r
+ unit druk: procedure (kor: node);\r
+ var kondruk: boolean;\r
+ \r
+ unit dlugi: function (k: node): boolean;\r
+ begin\r
+ if k=/=none\r
+ then\r
+ result:=k.e>99 or k.e<-9 or dlugi(k.left) or dlugi(k.right)\r
+ fi\r
+ end dlugi;\r
+ \r
+ unit krotkidruk: procedure (wiersz, pocz, kon: integer; drzewo: node);\r
+ var y, i, z: integer;\r
+ begin\r
+ z:= (kon+pocz-1) div 2;\r
+ call ramka (wiersz, 0, wiersz+2, z-1, z+2);\r
+ if wiersz=/=1\r
+ then\r
+ call sc(wiersz,z);\r
+ write ("Á")\r
+ fi;\r
+ call sc(wiersz+1,z);\r
+ write (drzewo.e:2);\r
+ if drzewo.left=/=none\r
+ then \r
+ if wiersz=21\r
+ then kondruk:=true\r
+ else (* drukowanie lewego poddrzewa *)\r
+ y:= (z+pocz-1) div 2;\r
+ call sc (wiersz+4,y);\r
+ write ("Ú");\r
+ for i:=y+1 to z-1\r
+ do\r
+ write ("Ä")\r
+ od;\r
+ write ("Ù");\r
+ call sc(wiersz+3,z);\r
+ write ("³");\r
+ call sc(wiersz+2,z);\r
+ write ("Â");\r
+ call krotkidruk (wiersz+5,pocz,z,drzewo.left)\r
+ fi\r
+ fi;\r
+ if drzewo.right=/=none\r
+ then\r
+ if wiersz=21\r
+ then kondruk:=true\r
+ else (* drukowanie prawego poddrzewa *)\r
+ y:= (kon+z) div 2;\r
+ call sc(wiersz+2,z+1);\r
+ write ("Â");\r
+ call sc(wiersz+3,z+1);\r
+ write ("³");\r
+ call sc(wiersz+4,z+1);\r
+ write ("À");\r
+ for i:=z+2 to y-1\r
+ do\r
+ write ("Ä")\r
+ od;\r
+ write ("¿");\r
+ call krotkidruk (wiersz+5,z+1,kon,drzewo.right)\r
+ fi\r
+ fi\r
+ end krotkidruk;\r
+ \r
+ unit dlugidruk: procedure (wiersz, pocz, kon: integer, drzewo: node);\r
+ var y, i, z: integer;\r
+ begin\r
+ z:= (kon+pocz-1) div 2;\r
+ call ramka (wiersz, 0, wiersz+2, z-4, z+4);\r
+ if wiersz=/=1\r
+ then\r
+ call sc(wiersz,z);\r
+ write ("Á")\r
+ fi;\r
+ call sc(wiersz+1,z-3);\r
+ write (drzewo.e:7);\r
+ if drzewo.left=/=none\r
+ then\r
+ if wiersz=19\r
+ then \r
+ kondruk:=true\r
+ else (* drukowanie lewego poddrzewa *)\r
+ y:= (z+pocz-1) div 2;\r
+ call sc(wiersz+5,y);\r
+ write ("³");\r
+ call sc(wiersz+4,y);\r
+ write ("Ú");\r
+ for i:=y+1 to z-3\r
+ do\r
+ write ("Ä")\r
+ od;\r
+ write ("Ù");\r
+ call sc(wiersz+3,z-2);\r
+ write ("³");\r
+ call sc(wiersz+2,z-2);\r
+ write ("Â");\r
+ call dlugidruk (wiersz+6, pocz, z, drzewo.left)\r
+ fi\r
+ fi;\r
+ if drzewo.right=/=none\r
+ then\r
+ if wiersz=19\r
+ then\r
+ kondruk:=true\r
+ else (* drukowanie prawego poddrzewa *)\r
+ y:= (kon+z) div 2;\r
+ call sc (wiersz+2,z+2);\r
+ write ("Â");\r call sc(wiersz+3,z+2);\r
+ write ("³");\r
+ call sc(wiersz+4,z+2);\r
+ write ("À");\r
+ for i:=z+3 to y-1\r
+ do\r
+ write ("Ä")\r
+ od;\r
+ write ("¿");\r
+ call sc(wiersz+5,y);\r
+ write ("³");\r
+ call dlugidruk (wiersz+6, z+1, kon, drzewo.right)\r
+ fi\r
+ fi\r
+ end dlugidruk;\r
+ \r
+ begin (* druk *)\r
+ call np;\r
+ if dlugi (kor)\r
+ then\r
+ call dlugidruk(1,1,80,kor)\r
+ else\r
+ call krotkidruk(1,1,80,kor)\r
+ fi;\r
+ if kondruk\r
+ then\r
+ call sc(25,1);\r
+ write ("Dalsza czesc drzewa nie miesci sie na ekranie ");\r
+ fi\r
+ end druk;\r
+ \r
+ begin (* drukuj *)\r
+ call cll(24);\r
+ if korzen=none\r
+ then\r
+ write ("Drzewo jest puste")\r
+ else\r
+ write ("Czy chcesz obejrzec drzewo od korzenia ?");\r
+ ko:=inchar;\r
+ s:=chr(ko);\r
+ if s=/='n'\r
+ then\r
+ call druk (korzen)\r
+ else\r
+ call cll(24);\r
+ write ("Podaj korzen poddrzewa, ktore chcesz obejrzec ");\r
+ call wprowliczbe (g,h);\r
+ if not h \r
+ then\r
+ return\r
+ else\r
+ x:=new search (korzen,g);\r
+ if not x.czyjest\r
+ then\r
+ call cll(24);\r
+ write ("Tego elementu nie ma w drzewie ");\r
+ kill (x)\r
+ else\r
+ call druk (x.pom);\r
+ kill (x)\r
+ fi\r
+ fi\r
+ fi\r
+ fi;\r
+ ko:=inchar\r
+ end drukuj;\r
+ \r
+ unit fix: procedure (k: node);\r
+ var n, kon: integer;\r
+ var f: boolean;\r
+ \r
+ unit prefix: procedure (d: node);\r
+ begin\r
+ if d=/=none\r
+ then\r
+ write (d.e);\r
+ write (" , ");\r
+ call prefix (d.left);\r
+ call prefix (d.right)\r
+ fi\r
+ end prefix;\r
+ \r
+ unit infix: procedure (d: node);\r
+ begin\r
+ if d=/=none\r
+ then\r
+ call infix (d.left);\r
+ write (d.e);\r
+ write (" , ");\r
+ call infix (d.right)\r
+ fi\r
+ end infix;\r
+ \r
+ unit postfix: procedure (d: node);\r
+ begin\r
+ if d=/=none\r
+ then\r
+ call postfix (d.left);\r
+ call postfix (d.right);\r
+ write (d.e);\r
+ write (" , ")\r
+ fi\r
+ end postfix;\r
+ \r
+ begin (* fix *)\r
+ if k=none\r
+ then\r
+ writeln;\r
+ write ("Drzewo jest puste")\r
+ else\r
+ call np;\r
+ call ramka (1,5,13,30,49);\r
+ call sc(3,35);\r
+ write ("M E N U");\r
+ call sc(7,33);\r
+ write ("1. prefix");\r
+ call sc(9,33);\r
+ write ("2. infix");\r
+ call sc(11,33);\r
+ write ("3. postfix");\r
+ call sc(24,1);\r
+ write ("Podaj numer opcji ");\r
+ call wprowliczbe (n,f);\r
+ if f andif (n >= 1 and n <= 3)\r
+ then\r
+ call podkresl (30,49,n,'.');\r
+ call cll(24);\r
+ call sc(17,1);\r
+ case n\r
+ when 1 : call prefix (korzen);\r
+ when 2 : call infix (korzen);\r
+ when 3 : call postfix (korzen)\r
+ esac\r
+ fi;\r
+ fi;\r
+ write(" ");\r
+ kon:=inchar\r
+ end fix;\r
+ \r
+ unit czekaj: procedure;\r
+ var t, k: integer;\r
+ begin\r
+ t:=time;\r
+ k:=time;\r
+ while k-t<2\r
+ do\r
+ k:=time\r
+ od\r
+ end czekaj;\r
+ \r
+ unit beep: procedure;\r
+ begin\r
+ write ("\a\a\a\a")\r
+ end beep;\r
+ \r
+ unit zakonczenie: procedure;\r
+ var i, j, t, k: integer;\r
+ begin\r
+ for i:=9 to 15 \r
+ do\r
+ call cll(i)\r
+ od;\r
+ for i:=10 step 4 to 14 \r
+ do\r
+ call sc(i,10);\r
+ for j:=10 to 70\r
+ do\r
+ write ('*')\r
+ od\r
+ od;\r
+ for i:=10 step 60 to 70 \r
+ do\r
+ for j:=11 to 13\r
+ do\r
+ call sc(j,i);\r
+ write ('*')\r
+ od\r
+ od;\r
+ call sc(12,33);\r
+ write ("DO ZOBACZENIA ");\r
+ call czekaj;\r
+ call endrun\r
+ end zakonczenie;\r
+ \r
+ \r
+begin (* program glowny *)\r
+ call menu;\r
+ do\r
+ call cll(25);\r
+ call cll(24);\r
+ write ("Podaj numer opcji ");\r
+ call wprowliczbe (num,op);\r
+ if not op\r
+ then \r
+ repeat\r
+ fi;\r
+ if num < 1 or num > 7\r
+ then \r
+ call beep;\r
+ repeat\r
+ fi;\r
+ call podkresl (10,70,num,'.');\r
+ case num\r
+ when 1 : call robzsearch (1); (* insert *)\r
+ when 2 : call robzsearch (2); (* delete *)\r
+ when 3 : call robzsearch (3); (* member *)\r
+ when 4 : call empty (korzen);\r
+ when 5 : call drukuj;\r
+ when 6 : call fix (korzen)\r
+ esac;\r
+ if num=5 or num=6\r
+ then\r
+ call menu\r
+ else\r
+ call podkresl (10,70,num,' ')\r
+ fi;\r
+ if num=7\r
+ then\r
+ call zakonczenie\r
+ fi\r
+ od\r
+end drzewo\r
+\r
+ \r
+\1a
\ No newline at end of file
--- /dev/null
+program BSTscanner;\r
+ \r
+begin\r
+ \r
+ pref iiuwgraph block\r
+ \r
+ \r
+ unit inchar :function: integer;\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit node:class;\r
+ var left:node;\r
+ var right:node;\r
+ var e:arrayof char;\r
+ end node;\r
+ \r
+ unit head:class;\r
+ var tre:node;\r
+ var size:integer;\r
+ var name:arrayof char;\r
+ var next:head;\r
+ end;\r
+ \r
+ unit MENU:class;\r
+ \r
+ var y:integer;\r
+ var name:arrayof char;\r
+ var sub:menu;\r
+ var next:menu;\r
+ var prev:menu;\r
+ \r
+ end menu;\r
+ \r
+ unit directory:procedure;\r
+ var hel1,hel2,hel3,hel4:menu;\r
+ var tru:boolean;\r
+ begin\r
+ tru:=true;\r
+ hel1:=new menu;\r
+ pointer:=hel1;\r
+ hel1.name:=sa("DISC ");\r
+ hel1.y:=135;\r
+ \r
+ hel2:=new menu;\r
+ hel2.name:=sa("TREE ");\r
+ hel2.y:=155;\r
+ hel1.next:=hel2;\r
+ hel2.prev:=hel1;\r
+ \r
+ hel3:=new menu;\r
+ hel3.name:=sa("EXIT ");\r
+ hel3.y:=175;\r
+ hel2.next:=hel3;\r
+ hel3.prev:=hel2;\r
+ hel3.next:=hel1;\r
+ hel1.prev:=hel3;\r
+ \r
+ hel3:=new menu;\r
+ hel3.name:=sa("UPDIR ");\r
+ hel3.y:=135;\r
+ hel3.sub:=hel1;\r
+ hel1.sub:=hel3;\r
+ \r
+ hel1:=new menu;\r
+ hel1.name:=sa("SAVEnot");\r
+ hel1.y:=155;\r
+ hel3.next:=hel1;\r
+ hel1.prev:=hel3;\r
+ \r
+ hel4:=new menu;\r
+ hel4.name:=sa("LOADnot");\r
+ hel4.y:=175;\r
+ hel3.prev:=hel4;\r
+ hel4.next:=hel3;\r
+ hel1.next:=hel4;\r
+ hel4.prev:=hel1;\r
+ hel1:=hel3.sub;\r
+ \r
+ hel3:=new menu;\r
+ hel3.name:=sa("UPDIR ");\r
+ hel3.y:=95;\r
+ hel2.sub:=hel3;\r
+ hel3.sub:=hel1;\r
+ \r
+ hel2:=new menu;\r
+ hel2.name:=sa("CREATE ");\r
+ hel2.y:=115;\r
+ hel2.prev:=hel3;\r
+ hel3.next:=hel2;\r
+ \r
+ hel4:=new menu;\r
+ hel4.name:=sa("INSERT ");\r
+ hel4.y:=135;\r
+ hel4.prev:=hel2;\r
+ hel2.next:=hel4;\r
+ \r
+ hel2:=new menu;\r
+ hel2.name:=sa("DELETE ");\r
+ hel2.y:=155;\r
+ hel2.prev:=hel4;\r
+ hel4.next:=hel2;\r
+ \r
+ hel4:=new menu;\r
+ hel4.name:=sa("MEMBER ");\r
+ hel4.y:=175;\r
+ hel4.prev:=hel2;\r
+ hel2.next:=hel4;\r
+ \r
+ hel2:=new menu;\r
+ hel2.name:=sa("CHANGE ");\r
+ hel2.y:=195;\r
+ hel2.prev:=hel4;\r
+ hel4.next:=hel2;\r
+ \r
+ hel4:=new menu;\r
+ hel4.name:=sa("WRITE ");\r
+ hel4.y:=215;\r
+ hel4.prev:=hel2;\r
+ hel2.next:=hel4;\r
+ hel4.next:=hel3;\r
+ hel3.prev:=hel4;\r
+ \r
+ hel2:=new menu;\r
+ hel2.name:=sa("UPDIR ");\r
+ hel2.y:=115;\r
+ hel4.sub:=hel2;\r
+ hel2.sub:=hel3;\r
+ \r
+ hel4:=new menu;\r
+ hel4.name:=sa("DRAW ");\r
+ hel4.y:=135;\r
+ hel4.prev:=hel2;\r
+ hel2.next:=hel4;\r
+ \r
+ hel3:=new menu;\r
+ hel3.name:=sa("PREFIX ");\r
+ hel3.y:=155;\r
+ hel3.prev:=hel4;\r
+ hel4.next:=hel3;\r
+ \r
+ hel4:=new menu;\r
+ hel4.name:=sa("INFIX ");\r
+ hel4.y:=175;\r
+ hel4.prev:=hel3;\r
+ hel3.next:=hel4;\r
+ \r
+ hel3:=new menu;\r
+ hel3.name:=sa("POSTFIX");\r
+ hel3.y:=195;\r
+ hel3.prev:=hel4;\r
+ hel4.next:=hel3;\r
+ hel3.next:=hel2;\r
+ hel2.prev:=hel3;\r
+ \r
+ pointer:=hel1;\r
+ \r
+ end directory;\r
+ \r
+ \r
+ unit RANGE:procedure(x:integer,y:integer,i:integer);\r
+ begin\r
+ call color(i);\r
+ call move(x,y);\r
+ call draw(x+120,y);\r
+ call draw(x+120,y+20);\r
+ call draw(x,y+20);\r
+ call draw(x,y);\r
+ call color(2);\r
+ end range;\r
+ \r
+ unit BOX:procedure(xc,yc:integer;lenght,szer:integer);\r
+ begin\r
+ call move(xc,yc);\r
+ call color(14);\r
+ call draw(xc+lenght,yc);\r
+ call draw(xc+lenght,yc+szer);\r
+ call draw(xc,yc+szer);\r
+ call draw(xc,yc);\r
+ end box;\r
+ \r
+ unit CLR:procedure;\r
+ begin\r
+ call cls;\r
+ call color(14);\r
+ call move(0,0);\r
+ call draw(618,0);\r
+ call draw(618,319);\r
+ call draw(0,319);\r
+ call draw(0,0);\r
+ end clr;\r
+ \r
+ unit drawmenu:procedure(pointer:menu);\r
+ var phelp:menu;\r
+ var yhelp:integer;\r
+ var n,i,j:integer;\r
+ var sub,run:arrayof char;\r
+ \r
+ \r
+ begin\r
+ call clr;\r
+ call color(2);\r
+ call box(400,20,200,30);\r
+ call box(398,18,204,34);\r
+ if actual=/=none then\r
+ call move(420,30);\r
+ call outhline(actual.name);\r
+ fi;\r
+ \r
+ sub:=sa(" sub");\r
+ run:=sa(" run");\r
+ phelp:=pointer;\r
+ yhelp:=phelp.y;\r
+ n:=1;\r
+ phelp:=phelp.next;\r
+ while yhelp=/= phelp.y do\r
+ phelp:=phelp.next;\r
+ n:=n+1;\r
+ od;\r
+ call color(14);\r
+ x:=270;\r
+ y:=(320-n*20-20)/2;\r
+ call move(x,y);\r
+ call draw(x+140,y);\r
+ call draw(x+140,y+n*20+20);\r
+ call draw(x,y+n*20+20);\r
+ call draw(x,y);\r
+ \r
+ \r
+ x:=268;\r
+ y:=y-2;\r
+ call move(x,y);\r
+ call draw(x+144,y);\r
+ call draw(x+144,y+n*20+24);\r
+ call draw(x,y+n*20+24);\r
+ call draw(x,y);\r
+ \r
+ for i:=1 to 8 do\r
+ call move(x+144+i,y+5);\r
+ call draw(x+144+i,y+n*20+24+i);\r
+ call draw(x+5,y+n*20+24+i);\r
+ od;\r
+ \r
+ \r
+ x:=x+20;\r
+ for j:=1 to n do\r
+ y:=phelp.y;\r
+ call move(x,y);\r
+ call OUTHLINE(phelp.name);\r
+ \r
+ if phelp.sub =/=none then;\r
+ call OUTHLINE(sub);\r
+ else\r
+ call OUTHLINE(run);\r
+ fi;\r
+ phelp:=phelp.next;\r
+ od;\r
+ \r
+ x:=x-10;\r
+ y:=phelp.y-5;\r
+ call RANGE(x,y,1);\r
+ \r
+ end drawmenu;\r
+ \r
+ unit OUTHLINE:procedure(a:arrayof char);\r
+ \r
+ var i:integer;\r
+ var j:integer;\r
+ \r
+ begin\r
+ call color(11); (* czerwony *)\r
+ i:=upper(a);\r
+ for j:=1 to i do\r
+ call hascii(0);\r
+ call hascii(ord(a(j)));\r
+ od;\r
+ end outhline;\r
+ \r
+ \r
+ unit INHLINE:function(xc:integer;yc:integer):arrayof char;\r
+ \r
+ var i:integer;\r
+ var count:integer;\r
+ var ik:integer;\r
+ var ar:arrayof char;\r
+ \r
+ begin\r
+ call move(xc,yc);\r
+ count:=0;\r
+ array ar dim(1:13);\r
+ \r
+ while ik=/=13 and count<13 do\r
+ ik:=inchar;\r
+ if ik=8 and count>0 then\r
+ ar(count):=' ';\r
+ count:=count-1;\r
+ call move(xc+(count)*8,yc);\r
+ call hascii(0);\r
+ else\r
+ if ik=/=13 then\r
+ count:=count+1;\r
+ ar(count):=chr(ik);\r
+ call hascii(0);\r
+ call hascii(ik);\r
+ fi;\r
+ fi;\r
+ od;\r
+ if count=/=0 then\r
+ array result dim(1:count);\r
+ for i:=1 to count do\r
+ result(i):=ar(i);\r
+ od;\r
+ fi;\r
+ end inhline;\r
+ \r
+ \r
+ unit SEARCH:class(where:node;what:arrayof char);\r
+ \r
+ var hel1:node,hel2:node;\r
+ var isit:boolean;\r
+ \r
+ begin\r
+ hel1:=where;\r
+ hel2:=none;\r
+ do\r
+ if hel1=none then exit\r
+ else\r
+ if equal(hel1.e,what) then exit\r
+ else\r
+ hel2:=hel1;\r
+ if not less(hel1.e,what) then\r
+ hel1:=hel1.left;\r
+ else\r
+ hel1:=hel1.right;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ if hel1=/=none then isit:=true;\r
+ else isit:= false;\r
+ fi\r
+ end search;\r
+ \r
+ unit membe:SEARCH procedure;\r
+ begin\r
+ \r
+ if isit\r
+ then\r
+ call outhline(sa(" EXISTS "));\r
+ else\r
+ call outhline(sa(" DOESN'T EXIST"));\r
+ fi;\r
+ end membe;\r
+ \r
+ unit INSER:SEARCH procedure;\r
+ var help:node;\r
+ begin\r
+ if where=none then\r
+ help:=new node;\r
+ call OUTHLINE(sa(" O.K."));\r
+ help.e:=what;\r
+ actual.tre:=help;\r
+ else\r
+ if isit then\r
+ call OUTHLINE(sa(" ALREADY EXIXTS"));\r
+ else\r
+ help:=new node;\r
+ call OUTHLINE(sa(" O.K."));\r
+ help.e:=what;\r
+ if not less(hel2.e,what) then\r
+ hel2.left:=help;\r
+ else\r
+ hel2.right:=help;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end inser;\r
+ \r
+ unit delet:SEARCH procedure;\r
+ var i:integer;\r
+ var pom:node;\r
+ begin\r
+ if where=none then\r
+ \r
+ call OUTHLINE(sa(" TREE IS EMPTY "));\r
+ else\r
+ if not isit then\r
+ call OUTHLINE(sa("DOESN'T EXIST"));\r
+ else\r
+ call outhline(sa(" O.K. "));\r
+ if hel2=none then\r
+ \r
+ if hel1.right<>none then\r
+ where:=hel1.right;\r
+ pom:=where;\r
+ do\r
+ if pom.left=none then exit;\r
+ else pom:=pom.left;\r
+ fi;\r
+ od;\r
+ pom.left:=hel1.left;\r
+ kill(hel1);\r
+ actual.tre:=where;\r
+ \r
+ else\r
+ if hel1.left<>none then\r
+ where:=hel1.left;\r
+ pom:=where;\r
+ do;\r
+ if pom.right=none then exit;\r
+ else pom:=pom.right;\r
+ fi;\r
+ od;\r
+ pom.right:=hel1.right;\r
+ kill(hel1);\r
+ actual.tre:=where;\r
+ else\r
+ where:=none;\r
+ kill (hel1);\r
+ fi; fi; (****** 1 to 2 *****)\r
+ else\r
+ if not less(hel1.e,hel2.e) then\r
+ if hel1.left=none then\r
+ hel2.right:=hel1.right;\r
+ kill (hel1);\r
+ else\r
+ if hel1.right=none then\r
+ hel2.right:=hel1.left;\r
+ kill (hel1);\r
+ else\r
+ hel2.right:=hel1.right;\r
+ pom:=hel2.right;\r
+ while pom.left=/=none do\r
+ pom:=pom.left;\r
+ od;\r
+ pom.left:=hel1.left;\r
+ kill (hel1);\r
+ fi;\r
+ fi;\r
+ else\r
+ if hel1.left=none then\r
+ hel2.left:=hel1.right;\r
+ kill (hel1);\r
+ else\r
+ if hel1.right=none then\r
+ hel2.left:=hel1.left;\r
+ kill (hel1);\r
+ else\r
+ hel2.left:=hel1.left;\r
+ pom:=hel1.left;\r
+ while pom.right=/=none do\r
+ pom:=pom.right;\r
+ od;\r
+ pom.right:=hel1.right;\r
+ kill (hel1);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end delet;\r
+ \r
+ unit GIVEME:function:arrayof arrayof char;\r
+ var i,j:integer;\r
+ var a:arrayof arrayof char;\r
+ var ac:arrayof char;\r
+ var x,y:integer;\r
+ var count:integer;\r
+ \r
+ begin\r
+ call clr;\r
+ call box(100,20,200,30);\r
+ call box(98,18,204,34);\r
+ CALL move(110,30);\r
+ call outhline(sa(" GIVE ME ELEMENTS"));\r
+ call box(100,60,200,200);\r
+ x:=180;\r
+ y:=70;\r
+ j:=0;\r
+ array a dim(1:16);\r
+ \r
+ do\r
+ call move(x-10,y);\r
+ call outhline(sa(">"));\r
+ ac:=inhline(x,y);\r
+ if ac=none or j> 15 then exit\r
+ else\r
+ j:=j+1;\r
+ a(j):=ac;\r
+ fi;\r
+ y:=y+10;\r
+ od;\r
+ if j=/=0 then\r
+ array result dim(1:j);\r
+ for i:=1 to j do\r
+ result(i):=a(i);\r
+ od;\r
+ fi;\r
+ \r
+ \r
+ end giveme;\r
+ \r
+ unit SA:function(s:string):arrayof char;\r
+ begin\r
+ result:=unpack(s);\r
+ end sa;\r
+ \r
+ unit CHOOSE:procedure;\r
+ var i:integer;\r
+ begin\r
+ do\r
+ i:=inkey;\r
+ \r
+ if i=-80 then\r
+ call range(x,pointer.y-5,0);\r
+ pointer:=pointer.next;\r
+ call range(x,pointer.y-5,14);\r
+ else\r
+ if i=-72 then\r
+ call range(x,pointer.y-5,0);\r
+ pointer:=pointer.prev;\r
+ call range(x,pointer.y-5,14);\r
+ else\r
+ if i=13 then\r
+ call runner;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ \r
+ od;\r
+ end choose;\r
+ \r
+ unit ESCAPE:procedure;\r
+ begin\r
+ call groff;\r
+ call endrun;\r
+ end escape;\r
+ \r
+ unit RUNNER:procedure;\r
+ begin\r
+ if pointer.sub=/=none then\r
+ pointer:=pointer.sub;\r
+ call drawmenu(pointer);\r
+ else\r
+ if equal(pointer.name,sa("EXIT ")) then\r
+ call ESCAPE;\r
+ else\r
+ if equal(pointer.name,sa("CREATE ")) then\r
+ call CREATE;\r
+ else\r
+ if equal(pointer.name,sa("INSERT ")) then\r
+ call INSERT;\r
+ else\r
+ if equal(pointer.name,sa("DELETE ")) then\r
+ call DELETE;\r
+ else\r
+ if equal(pointer.name,sa("MEMBER ")) then\r
+ call MEMBER;\r
+ else\r
+ if equal(pointer.name,sa("CHANGE ")) then\r
+ call CHANGE;\r
+ else\r
+ if equal(pointer.name,sa("UNION ")) then\r
+ else\r
+ if equal(pointer.name,sa("BALANCE")) then\r
+ else\r
+ if equal(pointer.name,sa("DRAW ")) then\r
+ call PAINT;\r
+ else\r
+ if equal(pointer.name,sa("PREFIX ")) then\r
+ call PREFIX;\r
+ else\r
+ if equal(pointer.name,sa("INFIX ")) then\r
+ call INFIX;\r
+ else\r
+ if equal(pointer.name,sa("POSTFIX")) then\r
+ call POSTFIX;\r
+ else\r
+ if equal(pointer.name,sa("SAVE ")) then\r
+ else\r
+ if equal(pointer.name,sa("LOAD ")) then\r
+ fi;fi;fi;fi;fi;fi;fi;fi;fi;fi;fi;fi;fi;fi;fi;\r
+ end;\r
+ \r
+ \r
+ unit CREATE:procedure;\r
+ \r
+ var h:head;\r
+ var ac:arrayof char;\r
+ var i:integer;\r
+ \r
+ begin\r
+ call range(x,pointer.y-5,0);\r
+ for i:=0 to 7 do\r
+ call box(401+i,21+i,178-2*i,28-2*i);\r
+ od;\r
+ call move (410,30);\r
+ call outhline(sa(" "));\r
+ call move(420,31);\r
+ call outhline(sa(">"));\r
+ ac:=inhline(430,30);\r
+ call color(0);\r
+ for i:=0 to 7 do\r
+ call box(401+i,21+i,178-2*i,28-2*i);\r
+ od;\r
+ call color(2);\r
+ call range(x,pointer.y-5,1);\r
+ if ac=/=none then\r
+ h:=new head;\r
+ h.name:=ac;\r
+ actual:=tree;\r
+ if actual=/=none then\r
+ while actual.next=/=none do\r
+ actual:=actual.next;\r
+ od;\r
+ actual.next:=h;\r
+ else\r
+ tree:=h;\r
+ fi;\r
+ actual:=h;\r
+ fi;\r
+ end create;\r
+ \r
+ unit INSERT:procedure;\r
+ \r
+ var i,j,y:integer;\r
+ var ai:arrayof arrayof char;\r
+ \r
+ begin\r
+ call clr;\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE INSERT NOW !"));\r
+ else\r
+ ai:=giveme;\r
+ if ai<>none then\r
+ call box(400,20,200,30);\r
+ call box(398,18,204,34);\r
+ call move(470,30);\r
+ call OUTHLINE(sa("INSERT"));\r
+ call box(400,60,200,200);\r
+ i:=upper(ai);\r
+ actual.size:=actual.size+i;\r
+ y:=70;\r
+ for j:=1 to i do\r
+ call move(430,y);\r
+ call inser(actual.tre,ai(j));\r
+ y:=y+10;\r
+ od;\r
+ fi;\r
+ fi;\r
+ i:=inchar;\r
+ call CLR;\r
+ call DRAWMENU(pointer);\r
+ end insert;\r
+ \r
+ unit MEMBER:procedure;\r
+ \r
+ var i,j,y:integer;\r
+ var ai:arrayof arrayof char;\r
+ \r
+ begin\r
+ call clr;\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE MEMBER NOW !"));\r
+ else\r
+ ai:=giveme;\r
+ if ai<>none then\r
+ call box(400,20,200,30);\r
+ call box(398,18,204,34);\r
+ call move(470,30);\r
+ call OUTHLINE(sa("MEMBER"));\r
+ call box(400,60,200,200);\r
+ i:=upper(ai);\r
+ y:=70;\r
+ for j:=1 to i do\r
+ call move(430,y);\r
+ call membe(actual.tre,ai(j));\r
+ y:=y+10;\r
+ od;\r
+ fi;\r
+ fi;\r
+ i:=inchar;\r
+ call CLR;\r
+ call DRAWMENU(pointer);\r
+ \r
+ end;\r
+ \r
+unit delete:procedure;\r
+ \r
+ var i,j,y:integer;\r
+ var ai:arrayof arrayof char;\r
+ \r
+ begin\r
+ call clr;\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE DELETE NOW !"));\r
+ else\r
+ ai:=giveme;\r
+ if ai<> none then\r
+ call box(400,20,200,30);\r
+ call box(398,18,204,34);\r
+ call move(470,30);\r
+ call OUTHLINE(sa("DELETE"));\r
+ call box(400,60,200,200);\r
+ i:=upper(ai);\r
+ actual.size:=actual.size-i;\r
+ y:=70;\r
+ for j:=1 to i do\r
+ call move(430,y);\r
+ call delet(actual.tre,ai(j));\r
+ y:=y+10;\r
+ od;\r
+ fi;\r
+ fi;\r
+ \r
+ i:=inchar;\r
+ call DRAWMENU(pointer);\r
+ end delete;\r
+ \r
+ unit CHANGE:procedure;\r
+ var i:integer;\r
+ begin\r
+ if actual=none then\r
+ call clr;\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE CHANGE NOW !"));\r
+ i:=inchar;\r
+ call drawmenu(pointer);\r
+ else\r
+ call range(x,pointer.y-5,0);\r
+ for i:=0 to 7 do\r
+ call box(401+i,21+i,178-2*i,28-2*i);\r
+ od;\r
+ call move (410,30);\r
+ call outhline(sa(" "));\r
+ actual:=tree;\r
+ \r
+ do\r
+ call move(420,30);\r
+ call outhline(sa(" "));\r
+ call move(420,30);\r
+ call outhline(actual.name);\r
+ i:=inchar;\r
+ if i=13 then exit\r
+ else\r
+ if actual.next=/=none then\r
+ actual:=actual.next;\r
+ else\r
+ actual:=tree;\r
+ fi;\r
+ fi;\r
+ od;\r
+ \r
+ call color(0);\r
+ for i:=0 to 7 do\r
+ call box(401+i,21+i,178-2*i,28-2*i);\r
+ od;\r
+ call color(2);\r
+ call range(x,pointer.y-5,1);\r
+ fi;\r
+ end change;\r
+ \r
+ \r
+ \r
+ unit PAINT:procedure;\r
+ \r
+ var i:integer;\r
+ var toobig:boolean;\r
+ \r
+ unit dr:procedure(elem:node,xo:integer,delta:integer,level:integer);\r
+ begin\r
+ call move(xo-upper(elem.e)*4,level*40+10);\r
+ call outhline(elem.e);\r
+ if elem.left=/=none then\r
+ call move(xo,level*40+20);\r
+ call draw(xo-delta,(level+1)*40);\r
+ call dr(elem.left,xo-delta,delta/2,level+1);\r
+ fi;\r
+ if elem.right=/=none then\r
+ call move(xo,level*40+20);\r
+ call draw(xo+delta,(level+1)*40);\r
+ call dr(elem.right,xo+delta,delta/2,level+1);\r
+ fi;\r
+ end dr;\r
+ \r
+ begin\r
+ call clr;\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE DRAW NOW !"));\r
+ else \r
+ elem:=actual.tre;\r
+ if elem=none then\r
+ call clr;\r
+ call outhline(sa(" TREE IS EMPTY "));\r
+ else\r
+ toobig:=false;\r
+ call dr(elem,320,160,0);\r
+ if toobig then ;\r
+ call outhline(sa(" TREE IS TOO BIG "));\r
+ fi;\r
+ fi;\r
+ FI;\r
+ i:=inchar;\r
+ call drawmenu(pointer);\r
+ end paint;\r
+ \r
+ unit PREFIX:procedure;\r
+ var h:node;\r
+ var i:integer;\r
+ var x,y:integer;\r
+ unit go4:procedure(elem:node);\r
+ begin\r
+ if elem=/=none then\r
+ call move(x,y);\r
+ call outhline(elem.e);\r
+ y:=y+10;\r
+ if y>290 then\r
+ y:=60;\r
+ x:=x+240;\r
+ fi;\r
+ \r
+ call go4(elem.left);\r
+ call go4(elem.right);\r
+ fi;\r
+ end go4;\r
+ begin\r
+ call CLR;\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE PREFIX NOW !"));\r
+ else\r
+ call box (260,10,200,30);\r
+ call box (258,8,204,34);\r
+ call move (300,20);\r
+ call outhline(sa("PREFIX"));\r
+ call box(20,50,200,250);\r
+ call box(260,50,200,250);\r
+ \r
+ x:=50;\r
+ y:=60;\r
+ if actual.tre=none then\r
+ call outhline(sa(" TREE IS EMPTY "));\r
+ else\r
+ call go4(actual.tre);\r
+ fi;\r
+ fi;\r
+ i:=inchar;\r
+ call DRAWMENU(pointer);\r
+ end prefix;\r
+ \r
+ unit INFIX:procedure;\r
+ \r
+ var h:node;\r
+ var i:integer;\r
+ var x,y:integer;\r
+ unit go4:procedure(elem:node);\r
+ begin\r
+ if elem=/=none then\r
+ \r
+ call go4(elem.left);\r
+ call move(x,y);\r
+ call outhline(elem.e);\r
+ y:=y+10;\r
+ if y>290 then\r
+ y:=60;\r
+ x:=x+240;\r
+ fi;\r
+ call go4(elem.right);\r
+ fi;\r
+ end go4;\r
+ begin\r
+ call CLR;\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE INFIX NOW !"));\r
+ else\r
+ call box (260,10,200,30);\r
+ call box (258,8,204,34);\r
+ call move (300,20);\r
+ call outhline(sa("INFIX"));\r
+ call box(20,50,200,250);\r
+ call box(260,50,200,250);\r
+ \r
+ x:=50;\r
+ y:=60;\r
+ if actual.tre=none then ;\r
+ call outhline(sa(" TREE IS EMPTY "));\r
+ else\r
+ call go4(actual.tre);\r
+ fi;\r
+ fi;\r
+ i:=inchar;\r
+ call DRAWMENU(pointer);\r
+ end infix;\r
+ \r
+ unit POSTFIX:procedure;\r
+ var h:node;\r
+ var i:integer;\r
+ var x,y:integer;\r
+ unit go4:procedure(elem:node);\r
+ begin\r
+ if elem=/=none then\r
+ \r
+ call go4(elem.left);\r
+ call go4(elem.right);\r
+ \r
+ call move(x,y);\r
+ call outhline(elem.e);\r
+ y:=y+10;\r
+ if y>290 then\r
+ y:=60;\r
+ x:=x+240;\r
+ fi;\r
+ fi;\r
+ end go4;\r
+ begin\r
+ call CLR;\r
+ call color(12);\r
+ if actual=none then\r
+ call BOX(250,150,250,30);\r
+ call BOX(248,148,254,34);\r
+ call move(270,160);\r
+ call OUTHLINE(unpack("YOU CAN'T USE POSTFIX NOW !"));\r
+ else\r
+ call box (260,10,200,30);\r
+ call box (258,8,204,34);\r
+ call move (300,20);\r
+ call outhline(sa("POSTFIX"));\r
+ call box(20,50,200,250);\r
+ call box(260,50,200,250);\r
+ \r
+ x:=50;\r
+ y:=60;\r
+ if actual.tre=none then\r
+ call outhline(sa(" TREE IS EMPTY "));\r
+ else\r
+ call go4(actual.tre);\r
+ fi;\r
+ fi;\r
+ i:=inchar;\r
+ call DRAWMENU(pointer);\r
+ end postfix;\r
+ \r
+ unit equal:function(a1:arrayof char, a2:arrayof char):boolean;\r
+ \r
+ var len1,len2:integer;\r
+ var i:integer;\r
+ \r
+ begin\r
+ len1:=upper(a1);\r
+ len2:=upper(a2);\r
+ if len1=/=len2 then\r
+ result:=false\r
+ else\r
+ result:=true;\r
+ for i:=1 to len1 do\r
+ if ord(a1(i))=/=ord(a2(i)) then\r
+ result:=false;\r
+ fi;\r
+ od;\r
+ fi;\r
+ \r
+ end equal;\r
+ \r
+ unit less:function(a1:arrayof char,a2:arrayof char):boolean;\r
+ var len1,len2:integer;\r
+ var i:integer;\r
+ \r
+ begin\r
+ len1:=upper(a1);\r
+ len2:=upper(a2);\r
+ if len1>len2 then\r
+ result:=false;\r
+ else\r
+ result:=true;\r
+ if len1=len2 then\r
+ i:=1;\r
+ if not equal(a1,a2) then\r
+ while ord(a1(i))=ord(a2(i)) do\r
+ i:=i+1;\r
+ od;\r
+ if ord(a1(i))>ord(a2(i)) then result:=false; fi;\r
+ \r
+ fi;\r
+ fi;\r
+ fi;\r
+ end less;\r
+ \r
+ var v:arrayof char;\r
+ var elem:node;\r
+ var pointer:menu;\r
+ var x,y:integer;\r
+ var ii:integer;\r
+ var actual:head;\r
+ var tree:head;\r
+ \r
+ begin\r
+ \r
+ call gron(0);\r
+ call color(14);\r
+ call BOX(210,110,260,80);\r
+ call BOX(208,108,264,84);\r
+ \r
+ v:=sa("Binary Search Tree Scanner");\r
+ call move(240,125);\r
+ call outhline(v);\r
+ v:=sa("written by Peter Miekus");\r
+ call move(250,145);\r
+ call outhline(v);\r
+ v:=sa("January 6,1989 Ver. 1.0");\r
+ call move(250,165);\r
+ call outhline(v);\r
+ v:=sa("Hit any key to start");\r
+ call move(50,300);\r
+ call outhline(v);\r
+ ii:=inchar;\r
+ \r
+ call cls;\r
+ call color(2);\r
+ call directory;\r
+ call drawmenu(pointer);\r
+ call choose;\r
+ call groff;\r
+ \r
+end;\r
+ \r
+ \r
+end\r
--- /dev/null
+Program BArbres;\r
+(*****************************************************************************)\r
+(* *)\r
+(* PROJET LI1 Nø1 pour le 15/01/94 *)\r
+(* *)\r
+(* PATAUD Frederic *)\r
+(* PEYRAT Francois *)\r
+(* *)\r
+(* Structure des Barbres *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+\r
+(*****************************************************************************)\r
+(* Structure d'une donnees *)\r
+(*****************************************************************************)\r
+Unit STData : class;\r
+var data : integer;\r
+End STData;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* Structure d'une page d'un B_Arbre *)\r
+(*****************************************************************************)\r
+Unit STPage : class (N : integer);\r
+Var pere : STPage;\r
+var nbdata : integer;\r
+var data : arrayof STData;\r
+var fils : arrayof STPage;\r
+Begin\r
+ nbdata:=0; (* A l'initialisation il n'y a pas de data *)\r
+ array data dim (1:2*N); (* Il y a au plus 2n donnees dans une page *)\r
+ array fils dim (1:2*N+1);(* et au plus 2n+1 fils. *)\r
+ pere:=none; (* Aucun pere n'est definit \85 la creation. *)\r
+End STPage;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 > elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Superieur : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data>elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Superieur;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 < elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Inferieur : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data<elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Inferieur;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 = elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Egalite : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data=elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Egalite;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(*****************************************************************************)\r
+Unit Barbre : class (N : integer);\r
+Var root : STPage;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne un booleen indiquant si l'arbre est vide *)\r
+ (****************************************************************************)\r
+ Unit Vide : function : boolean;\r
+ Begin\r
+ result:=root.nbdata=0; (* Si la racine n'a pas d'element alors arbre vide *)\r
+ End Vide;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne la valeur du minimun de l'arbre *)\r
+ (****************************************************************************)\r
+ Unit Minimum : function (output data : STData) : boolean;\r
+ var page : STPage\r
+ Begin\r
+ call outgtext("Recherche minimum...");\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ if page.fils(1)=none (* le minimum se trouve le plus en bas *)\r
+ then data:=page.data(1); (* \85 gauche de l'arbre *)\r
+ exit\r
+ fi;\r
+ page:=page.fils(1);\r
+ od;\r
+ result:=true;\r
+ else call outgtext("L'arbre est vide !!!"); (* il y a une erreur *)\r
+ result:=false;\r
+ fi\r
+ End Minimum;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne la valeur du maximum de l'arbre *)\r
+ (****************************************************************************)\r
+ Unit Maximum : function (output data : STData) : boolean;\r
+ Var page : STPage;\r
+ Begin\r
+ call outgtext("Recherche maximum...");\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ if page.fils(page.nbdata)=none (* le maximum est l'element le *)\r
+ then data:=page.data(page.nbdata); (* plus \85 droite de l'arbre *)\r
+ exit\r
+ fi;\r
+ page:=page.fils(page.nbdata+1);\r
+ od;\r
+ result:=true;\r
+ else call outgtext("L'arbre est vide !!!");\r
+ result:=false;\r
+ fi;\r
+ End Maximum;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne vraie si l'element elmt est dans l'arbre ainsi que la page *)\r
+ (* la recherche va se faire par dichotomie, ameliorant le nombre de *)\r
+ (* comparaisons necessaire pour trouver : *)\r
+ (* -soit l'element dans la page courante *)\r
+ (* -soit la page suivante a examiner *)\r
+ (****************************************************************************)\r
+ Unit Membre : function (input elmt : STData; output page : STPage) : boolean;\r
+ Var a,milieu,b : integer;\r
+ Begin\r
+ call outgtext("Recherche donn\82e...");\r
+ result:=false;\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ a:=0; (* a=debut de l'intervalle *)\r
+ b:=page.nbdata+1; (* b=fin de l'intervalle *)\r
+ do\r
+ milieu:=(a+b) div 2; (* milieu = milieu de l'intervalle *)\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if Egalite(page.data(milieu),elmt)\r
+ then result:=true; (* on a trouve l'element *)\r
+ exit\r
+ else if (b-a)=1 (* on sort sans avoir touver *)\r
+ then exit\r
+ fi;\r
+ fi\r
+ od;\r
+ if result\r
+ then exit\r
+ fi;\r
+ if page.fils(1)=none (* si plus de page alors on sort *)\r
+ then exit\r
+ fi;\r
+ if Superieur(page.data(milieu),elmt) (* sinon on change de page *)\r
+ then page:=page.fils(milieu)\r
+ else page:=page.fils(milieu+1)\r
+ fi\r
+ od\r
+ else call outgtext("L'arbre est vide!!!");\r
+ fi;\r
+ End Membre;\r
+\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Insertion d'un element *)\r
+ (****************************************************************************)\r
+ Unit Insertion : procedure (elmt : STData);\r
+ Var a,milieu,b,i : integer;\r
+ var aux_fils : arrayof STPage;\r
+ var aux_data : arrayof STData;\r
+ var pagenew,page : STPage;\r
+ var sauv1,sauv2 : STPage;\r
+ Begin\r
+ page:=root;\r
+ if vide (* on insert la premiere donnee dans l'arbre *)\r
+ then page.data(1):=elmt;\r
+ page.nbdata:=1;\r
+ call outgtext("L'element a ete ajoute.")\r
+ else if not membre(elmt,page) (* l'element elmt n'existe pas deja *)\r
+ then do\r
+ if page <> none (* s'il ne faut pas creer une nouvelle page *)\r
+ then a:=0;\r
+ b:=page.nbdata+1;\r
+ do (* recherche dichotomique de la position dans la page *)\r
+ milieu:=(a+b) div 2;\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if (b-a)=1\r
+ then exit\r
+ fi;\r
+ od;\r
+ if Inferieur(page.data(milieu),elmt)\r
+ then milieu:=milieu+1\r
+ fi;\r
+ if page.nbdata < 2*N (* si on n'a pas le maximum d'elments*)\r
+ then for i:=page.nbdata downto milieu\r
+ do (* on decale pour inserer l'element *)\r
+ page.data(i+1):=page.data(i);\r
+ page.fils(i+2):=page.fils(i+1)\r
+ od;\r
+ page.data(milieu):=elmt; (* on insert l'element *)\r
+ page.fils(milieu+1):=pagenew;\r
+ page.nbdata:=page.nbdata+1;\r
+ exit\r
+ else a:=1;\r
+ b:=page.nbdata+1;\r
+ array aux_data dim (a:b);\r
+ array aux_fils dim (a:b+1);\r
+ for i:=1 to milieu-1 (* on sauve les donnees *)\r
+ do\r
+ aux_data(i):=page.data(i);\r
+ aux_fils(i):=page.fils(i);\r
+ od;\r
+ aux_fils(i):=page.fils(i);\r
+ aux_data(milieu):=elmt;\r
+ aux_fils(milieu+1):=pagenew;\r
+ for i:=milieu to 2*N\r
+ do\r
+ aux_data(i+1):=page.data(i);\r
+ aux_fils(i+2):=page.fils(i);\r
+ od;\r
+ pagenew:= new STPage(N);\r
+ page.nbdata:=n;\r
+ pagenew.nbdata:=n;\r
+ for i:=1 to n (* on coupe en deux *)\r
+ do\r
+ pagenew.data(i):=aux_data(n+1+i);\r
+ page.data(i):=aux_data(i);\r
+ pagenew.fils(i):=aux_fils(n+1+i);\r
+ page.fils(i):=aux_fils(i);\r
+ od;\r
+ pagenew.fils(i):=aux_fils(n+1+i);\r
+ page.fils(i):=aux_fils(i);\r
+ elmt:=aux_data(n+1);\r
+ sauv1:=page;\r
+ if page.fils(1) <> none (* on rechaine les parents *)\r
+ then for i:=1 to n+1\r
+ do\r
+ pagenew.fils(i).pere:=pagenew;\r
+ od\r
+ fi;\r
+ pagenew.pere:=page.pere;\r
+ page:=page.pere;\r
+ kill(aux_data); (* on efface les *)\r
+ kill(aux_fils); (* variables intermediaires *)\r
+ fi\r
+ else sauv2:=pagenew;\r
+ pagenew:= new STPage(N); (* creation d'une nouvelle page *)\r
+ pagenew.nbdata:=1;\r
+ pagenew.data(1):=elmt;\r
+ pagenew.fils(1):=sauv1;\r
+ pagenew.fils(2):=sauv2;\r
+ sauv1.pere:=pagenew;\r
+ sauv2.pere:=pagenew;\r
+ root:=pagenew; (* il y a changement de racine *)\r
+ exit\r
+ fi\r
+ od;\r
+ call outgtext("L'\82l\82ment a ete ajoute.");\r
+ else call outgtext("L'\82l\82ment existe deja!");(* l'element existe deja *)\r
+ fi\r
+ fi\r
+ End Insertion;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Suppression d'un element *)\r
+ (****************************************************************************)\r
+ Unit Supprimer : procedure (elmt : STData);\r
+ var a,milieu,b,i : integer;\r
+ var aux_data : arrayof STData;\r
+ var aux_fils : arrayof STPage;\r
+ var page,avant : STPage;\r
+ var courant,pere : STPage;\r
+ var pred,aux : integer;\r
+\r
+ Begin\r
+ if vide (* l'arbre est vide ?! *)\r
+ then call outgtext("L'arbre est vide!!!")\r
+ else page:=root;\r
+ if not membre(elmt,page) (* l'element n'est pas dans l'arbre ?! *)\r
+ then call outgtext("Donn\82e pas ds l'arbre.");\r
+ else courant:=page;\r
+ a:=0; (* on recherche par dichotomie la place de l'element *)\r
+ b:=courant.nbdata+1;\r
+ do\r
+ milieu:=(a+b) div 2;\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if Egalite(page.data(milieu),elmt)\r
+ then exit\r
+ fi\r
+ od; (* on a sa place *)\r
+ if courant.fils(milieu) <> none\r
+ then courant:=courant.fils(milieu)\r
+ fi;\r
+ while courant.fils(courant.nbdata+1) <> none\r
+ do\r
+ courant:=courant.fils(courant.nbdata+1)\r
+ od;\r
+ if page.fils(1) <> none\r
+ then page.data(milieu):=courant.data(courant.nbdata)\r
+ else for i:=milieu to courant.nbdata-1\r
+ do\r
+ page.data(i):=page.data(i+1)\r
+ od\r
+ fi;\r
+ courant.nbdata:=courant.nbdata-1;\r
+ if courant.nbdata < N\r
+ then if courant=root\r
+ then exit\r
+ fi;\r
+ do\r
+ pere:=courant.pere;\r
+ i:=1;\r
+ do\r
+ if pere.fils(i)=courant\r
+ then exit\r
+ fi;\r
+ i:=i+1\r
+ od;\r
+ pred:=i-1;\r
+ if pred <> 0\r
+ then avant:=pere.fils(pred)\r
+ else avant:=courant;\r
+ pred:=1;\r
+ courant:=pere.fils(2)\r
+ fi;\r
+ if avant.nbdata <= N\r
+ then if courant.nbdata > N\r
+ then array aux_data dim (1:3*N);\r
+ array aux_fils dim (1:3*N+1);\r
+ for i:=1 to avant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=avant.fils(i)\r
+ od;\r
+ aux_fils(i):=avant.fils(i);\r
+ aux_data(i):=pere.data(pred);\r
+ for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
+ od;\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
+ aux:=avant.nbdata+1+courant.nbdata;\r
+ milieu:=aux div 2 +1;\r
+ for i:=1 to milieu-1\r
+ do\r
+ avant.data(i):=aux_data(i);\r
+ avant.fils(i):=aux_fils(i)\r
+ od;\r
+ avant.fils(i):=aux_fils(i);\r
+ avant.nbdata:=milieu-1;\r
+ pere.data(pred):=aux_data(milieu);\r
+ for i:=milieu+1 to aux\r
+ do\r
+ courant.data(i-milieu):=aux_data(i);\r
+ courant.fils(i-milieu):=aux_fils(i)\r
+ od;\r
+ courant.fils(i-milieu):=aux_fils(i);\r
+ courant.nbdata:=aux-avant.nbdata-1\r
+ else for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ avant.data(i):=courant.data(i-avant.nbdata-1);\r
+ avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
+ if courant.fils(i-avant.nbdata-1) <> none\r
+ then courant.fils(i-avant.nbdata-1).pere:=avant\r
+ fi\r
+ od;\r
+ avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
+ if courant.fils(i-avant.nbdata-1) <> none\r
+ then courant.fils(i-avant.nbdata-1).pere:=avant\r
+ fi;\r
+ avant.data(avant.nbdata+1):=pere.data(pred);\r
+ avant.nbdata:=avant.nbdata+1+courant.nbdata;\r
+ for i:=pred+1 to pere.nbdata\r
+ do\r
+ pere.data(i-1):=pere.data(i);\r
+ pere.fils(i):=pere.fils(i+1)\r
+ od;\r
+ pere.fils(pere.nbdata+1):=none;\r
+ pere.nbdata:=pere.nbdata-1;\r
+ if pere.nbdata=0\r
+ then root:=avant;\r
+ root.pere:=none\r
+ fi\r
+ fi\r
+ else array aux_data dim (1:3*N);\r
+ array aux_fils dim (1:3*N+1);\r
+ for i:=1 to avant.nbdata\r
+ do\r
+ aux_data(i):=avant.data(i);\r
+ aux_fils(i):=avant.fils(i)\r
+ od;\r
+ aux_fils(i):=avant.fils(i);\r
+ aux_data(i):=pere.data(pred);\r
+ for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
+ od;\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
+ aux:=avant.nbdata+1+courant.nbdata;\r
+ milieu:=aux div 2 +1;\r
+ for i:=1 to milieu-1\r
+ do\r
+ avant.data(i):=aux_data(i);\r
+ avant.fils(i):=aux_fils(i)\r
+ od;\r
+ avant.fils(i):=aux_fils(i);\r
+ avant.nbdata:=milieu-1;\r
+ pere.data(pred):=aux_data(milieu);\r
+ for i:=milieu+1 to aux\r
+ do\r
+ courant.data(i-milieu):=aux_data(i);\r
+ courant.fils(i-milieu):=aux_fils(i)\r
+ od;\r
+ courant.fils(i-milieu):=aux_fils(i);\r
+ courant.nbdata:=aux-avant.nbdata-1\r
+ fi;\r
+ if avant <> root\r
+ then avant:=pere;\r
+ if avant <> root\r
+ then if avant.nbdata < N\r
+ then pere:=pere.pere;\r
+ i:=1;\r
+ do\r
+ if pere.fils(i)=avant\r
+ then exit\r
+ fi;\r
+ i:=i+1\r
+ od;\r
+ courant:=pere.fils(i+1);\r
+ if courant=none\r
+ then courant:=avant;\r
+ avant:=pere.fils(i-1)\r
+ fi\r
+ else exit\r
+ fi\r
+ else exit\r
+ fi\r
+ else exit\r
+ fi\r
+ od\r
+ fi;\r
+ call outgtext("El\82ment supprim\82.")\r
+ fi\r
+ fi\r
+ End Supprimer;\r
+\r
+Begin\r
+ root:=new STPage(N);\r
+End Barbre;\r
+\r
+(****************************************************************************)\r
+(* dessine une ligne entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit line : procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ call color(colore);\r
+ end\r
+end line;\r
+\r
+(****************************************************************************)\r
+(* dessine une boite entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit rectanglef : procedure(x1,y1,x2,y2,c:integer);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ for i:=y1 to y2\r
+ do\r
+ call line(x1,i,x2,i,c);\r
+ od;\r
+ call color(colore);\r
+ end\r
+end rectanglef;\r
+\r
+(****************************************************************************)\r
+(* dessine un rectangle entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit rectangle : procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(x1,y1,x2,y1,c);\r
+ call line(x2,y1,x2,y2,c);\r
+ call line(x2,y2,x1,y2,c);\r
+ call line(x1,y2,x1,y1,c);\r
+ call color(colore);\r
+ end\r
+end rectangle;\r
+\r
+(****************************************************************************)\r
+(* dessine un rectangle en pointilles entre (x1,y1) et (x2,y2) *)\r
+(****************************************************************************)\r
+unit rectpoint : procedure(x1,y1,x2,y2,c:integer);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ for i:=x1 step 4 to x2-2\r
+ do\r
+ call line(i,y1,i+2,y1,c);\r
+ call line(i,y2,i+2,y2,c);\r
+ od;\r
+ for i:=y1 step 4 to y2-2\r
+ do\r
+ call line(x1,i,x1,i+2,c);\r
+ call line(x2,i,x2,i+2,c);\r
+ od\r
+ end\r
+end rectpoint;\r
+\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche le bandeau de commande en premiere ligne de l'ecran *)\r
+(****************************************************************************)\r
+unit affiche : procedure;\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call rectanglef(0,0,640,9,colorf);\r
+ call color(colore);\r
+ call move(1,1);\r
+ for i:=1 to nbitem\r
+ do\r
+ call move(10+espace*(i-1),1);\r
+ call outstring(item(i));\r
+ od;\r
+ call rectangle(1,15,196,340,colorf);\r
+ call rectangle(200,15,639,320,colorf);\r
+ call rectangle(200,325,639,340,colorf);\r
+ call move(202,330);\r
+ call outstring(" BArbre d'ordre 3 Li1 : PATAUD F. - PEYRAT F.");\r
+ end\r
+end affiche;\r
+\r
+(****************************************************************************)\r
+(* gere le menu, retourne le code action soit clavier soit souris *)\r
+(****************************************************************************)\r
+unit mousegest : function : integer;\r
+var l,r,c : boolean;\r
+var x,y : integer;\r
+var rep : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then if (y<=10 and y>=1)\r
+ then result:=(x-10)/espace+1; exit;\r
+ fi\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep>=-65 and rep<=-59)\r
+ then result:=-rep-58;\r
+ exit\r
+ fi;\r
+ od\r
+ end\r
+ end\r
+end mousegest;\r
+\r
+(****************************************************************************)\r
+(* initialise le menu et effectue l'action demand\82e *)\r
+(****************************************************************************)\r
+unit maine : procedure;\r
+var i : integer;\r
+var action : integer;\r
+begin\r
+ pref mouse block\r
+ begin\r
+ colorf:=9;\r
+ colore:=10;\r
+ espace:=90;\r
+ nbitem:=7;\r
+ array item dim (1:nbitem);\r
+ item(1):=" Inserer ";\r
+ item(2):=" Effacer ";\r
+ item(3):=" Affiche ";\r
+ item(4):=" Membre? ";\r
+ item(5):=" Minimum ";\r
+ item(6):=" Maximum ";\r
+ item(7):=" Quitter ";\r
+ call affiche;\r
+ call showcursor;\r
+ colore:=2;\r
+ do\r
+ action:=mousegest;\r
+ case action\r
+ when 1: call menu_ins;\r
+ when 2: call menu_del;\r
+ when 3: call menu_aff;\r
+ when 4: call menu_mem;\r
+ when 5: call menu_min;\r
+ when 6: call menu_max;\r
+ when 7: if menu_qui then exit fi;\r
+ esac;\r
+ od;\r
+ end\r
+end maine;\r
+\r
+(****************************************************************************)\r
+(* procedure d'affichage dans l'ecran de commandes, fait un scroll si besoin*)\r
+(****************************************************************************)\r
+unit outgtext : procedure(id : string);\r
+var i,savx : integer;\r
+var tmap1 : arrayof integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call color(colore);\r
+ call move(10,posy);\r
+ call outstring(id);\r
+ posy:=posy+10;\r
+ if (posy>=320) (* on est en fin de page, on fait un scroll d'une ligne *)\r
+ then savx:=inxpos;\r
+(* array tmap1 dim (1:300); *)\r
+(* for i:=1 step 10 to 281 *)\r
+(* do*)\r
+(* call move(1,36+i);*)\r
+(* tmap1:=getmap(196,46+i);*)\r
+(* call move(1,16+i);*)\r
+(* call putmap(tmap1);*)\r
+(* od;*)\r
+(* call rectanglef(2,317,195,337,0);*)\r
+(* posy:=310; *)\r
+(* call move(savx,posy); *)\r
+ call rectanglef(2,16,195,337,0);\r
+ posy:=20;\r
+ fi;\r
+ end\r
+end outgtext;\r
+\r
+(****************************************************************************)\r
+(* lecture d'un entier en mode graphique, esc revient au debut de saisie *)\r
+(****************************************************************************)\r
+unit gscanf : function : integer;\r
+var valeur : integer;\r
+var sauvx,sauvy : integer;\r
+var flag : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ valeur:=0;\r
+ sauvx:=inxpos;\r
+ sauvy:=inypos;\r
+ do\r
+ do\r
+ flag:=inkey;\r
+ if (flag>=48 and flag<=57) orif (flag=13) orif (flag=27) then exit fi\r
+ od;\r
+ if (flag>=48 and flag<=57)\r
+ then valeur:=valeur*10+flag-48;\r
+ call move(inxpos,inypos);\r
+ call hascii(flag);\r
+ fi;\r
+ if (flag=13) then exit fi;\r
+ if (flag=27) (* on a demand\82 annulation *)\r
+ then valeur:=0;\r
+ call rectanglef(sauvx-1,sauvy-3,inxpos,sauvy+7,0);\r
+ call color(colore);\r
+ call move(sauvx,sauvy);\r
+ fi;\r
+ od;\r
+ end;\r
+ result:=valeur;\r
+end gscanf;\r
+\r
+(****************************************************************************)\r
+(* affiche un entier en mode graphique, maximum 6 chiffres *)\r
+(****************************************************************************)\r
+unit writint : procedure( valeur : integer);\r
+var flag,i : integer;\r
+var tbl : arrayof integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ array tbl dim (1:6);\r
+ flag:=1; (* on 'empile' en ordre reverse *)\r
+ while valeur<>0\r
+ do\r
+ tbl(flag):=valeur mod 10;\r
+ valeur:=valeur div 10;\r
+ flag:=flag+1;\r
+ od;\r
+ for i:=flag-1 downto 1 (* on affiche dans le bon ordre *)\r
+ do\r
+ call hascii(48+tbl(i));\r
+ od;\r
+ end\r
+end writint;\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche ds l'ecran de droite la page courante *)\r
+(****************************************************************************)\r
+unit affiche_page : procedure (page : STPage);\r
+var i :integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ if page<>arbr.root\r
+ then call line(420,82,420,97,colorf);\r
+ call cirb(420,77,5,0,0,colorf,0,1,1);\r
+ fi;\r
+ for i:=1 to 6\r
+ do\r
+ call rectpoint(339+(i-1)*27,97,339+i*27,117,colorf);\r
+ if i<=page.nbdata\r
+ then call move(339+(i-1)*27+3,105);\r
+ call writint(page.data(i).data);\r
+ fi;\r
+ od;\r
+ end\r
+end affiche_page;\r
+\r
+(****************************************************************************)\r
+(* affiche ds l'ecran de droite la page fille de gauche *)\r
+(****************************************************************************)\r
+unit affiche_gche : procedure (page : STPage);\r
+var i : integer;\r
+var savi : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(312,220,312,240,colorf);\r
+ for i:=1 to 6\r
+ do\r
+ call rectangle(204+i*27,240,204+(i+1)*27,260,colorf);\r
+ if i<=page.nbdata\r
+ then call move(204+i*27+3,248);\r
+ call writint(page.data(i).data);\r
+ savi:=i;\r
+ if page.fils(i) <> none\r
+ then if i=4\r
+ then call line(204+i*27,260,204+i*27,275,colorf);\r
+ else if i<4\r
+ then call line(204+i*27,260,204+i*27-5,275,colorf);\r
+ else call line(204+i*27,260,204+i*27+5,275,colorf);\r
+ fi\r
+ fi\r
+ fi\r
+ fi;\r
+ od;\r
+ if page.fils(i) <> none\r
+ then if savi<>3 (* comme on part gche->dte on a soit | soit \ *)\r
+ then call line(204+(savi+1)*27,260,204+(savi+1)*27+5,275,colorf);\r
+ else call line(204+(savi+1)*27,260,204+(savi+1)*27,275,colorf);\r
+ fi;\r
+ fi;\r
+ end\r
+end affiche_gche;\r
+\r
+(****************************************************************************)\r
+(* affiche ds ecran de droite la page fille droite *)\r
+(****************************************************************************)\r
+unit affiche_drte : procedure (page :STPage);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(527,220,527,240,colorf);\r
+ for i:=1 to 6\r
+ do\r
+ call rectangle(635-(i+1)*27,240,635-i*27,260,colorf);\r
+ if (6-i+1)<=page.nbdata\r
+ then call move(635-(i+1)*27+3,248);\r
+ call writint(page.data(6-i+1).data);\r
+ if page.fils(6-i+1) <> none\r
+ then if (6-i+1)=4\r
+ then call line(635-i*27,260,635-i*27,275,colorf);\r
+ else if (6-i+1)>4\r
+ then call line(635-i*27,260,635-i*27+5,275,colorf);\r
+ else call line(635-i*27,260,635-i*27-5,275,colorf);\r
+ fi\r
+ fi\r
+ fi\r
+ fi;\r
+ od;\r
+ if page.fils(1) <> none\r
+ then call line(635-i*27,260,635-i*27-5,275,colorf);\r
+ fi;\r
+ end\r
+end affiche_drte;\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* Lecture de la donn\82e de STData *)\r
+(****************************************************************************)\r
+unit lect_data : function : STData;\r
+var d : STData;\r
+begin\r
+ d:=new STData;\r
+ call outgtext("Entrez la donn\82e :");\r
+ d.data:=gscanf;\r
+ result:=d;\r
+end lect_data;\r
+\r
+(****************************************************************************)\r
+(* menu insertion *)\r
+(****************************************************************************)\r
+unit menu_ins : procedure;\r
+var d : STData;\r
+begin\r
+ d:=lect_data;\r
+ call arbr.insertion(d);\r
+ call outgtext("");\r
+end menu_ins;\r
+\r
+\r
+(****************************************************************************)\r
+(* menu effacement *)\r
+(****************************************************************************)\r
+unit menu_del : procedure;\r
+var d : STData;\r
+begin\r
+ d:=lect_data;\r
+ call arbr.supprimer(d);\r
+ call outgtext("");\r
+end menu_del;\r
+\r
+(****************************************************************************)\r
+(* menu de parcours de l'arbre dans la fenetre droite *)\r
+(****************************************************************************)\r
+unit menu_aff : procedure;\r
+var pos,spos: integer;\r
+var rep,x,y : integer;\r
+var l,r,c : boolean;\r
+var page : STPage;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ pos:=1;\r
+ page:=arbr.root;\r
+ call rectangle(210,25,245,36,colorf);\r
+ call move(212,27);\r
+ call outstring("Exit");\r
+ do\r
+ call hidecursor;\r
+ call outgtext("MENU AFF");\r
+ call rectanglef(201,37,638,319,0);\r
+ call affiche_page(page);\r
+ if page.fils(pos) <> none\r
+ then call affiche_gche(page.fils(pos));\r
+ fi;\r
+ if page.fils(pos+1) <> none\r
+ then call affiche_drte(page.fils(pos+1));\r
+ fi;\r
+ call rectangle(339+(pos-1)*27,97,339+pos*27,117,colorf);\r
+ if page.fils(pos) <> none\r
+ then call line(339+(pos-1)*27,117,339+(pos-1)*27-5,132,colorf);\r
+ fi;\r
+ if page.fils(pos+1) <> none\r
+ then call line(339+pos*27,117,339+pos*27+5,132,colorf);\r
+ fi;\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then if (y<36 and y>25 and x>211 and x<245) (* button exit *)\r
+ then exit exit\r
+ fi;\r
+ if (x<501 and x>339 and y<117 and y>97) (* ds pere chgt gch dte *)\r
+ then spos:=((x-339) div 27)+1;\r
+ if spos<=page.nbdata\r
+ then pos:=spos\r
+ fi;\r
+ exit\r
+ fi;\r
+ if (x>231 and x<393 and y>240 and y<260) (* fils gche devient pere*)\r
+ then page:=page.fils(pos);\r
+ pos:=1;\r
+ exit;\r
+ fi;\r
+ if (x>446 and x<608 and y>240 and y<260) (* fils dte devient pere *)\r
+ then page:=page.fils(pos+1);\r
+ pos:=1;\r
+ exit;\r
+ fi;\r
+ if (page<>arbr.root) and (x>415 and x<425 and y>72 and y<82)\r
+ then page:=page.pere; (* on remonte d'un niveau *)\r
+ pos:=1;\r
+ exit\r
+ fi;\r
+ fi;\r
+ rep:=inkey;\r
+ if rep=27\r
+ then exit exit\r
+ else if (rep>=49 and rep<=54)\r
+ then pos:=rep-48;\r
+ exit\r
+ fi;\r
+ fi;\r
+ od;\r
+ od;\r
+ call hidecursor;\r
+ call rectanglef(201,24,638,319,0);\r
+ call showcursor;\r
+ end\r
+ end\r
+end menu_aff;\r
+\r
+(****************************************************************************)\r
+(* menu membre *)\r
+(****************************************************************************)\r
+unit menu_mem : procedure;\r
+var d : STData;\r
+var page : STPage;\r
+begin\r
+ d:=lect_data;\r
+ if arbr.Membre(d,page)\r
+ then call outgtext("Donn\82e pr\82sente ds arbre");\r
+ else call outgtext("Donn\82e absente ds arbre");\r
+ fi;\r
+ call outgtext("");\r
+end menu_mem;\r
+\r
+(****************************************************************************)\r
+(* menu minimum *)\r
+(****************************************************************************)\r
+unit menu_min : procedure;\r
+var d : STData;\r
+begin\r
+ if arbr.Minimum(d)\r
+ then call writint(d.data);\r
+ fi;\r
+ call outgtext("");\r
+end menu_min;\r
+\r
+(****************************************************************************)\r
+(* menu maximum *)\r
+(****************************************************************************)\r
+unit menu_max : procedure;\r
+var d : STData;\r
+begin\r
+ if arbr.Maximum(d)\r
+ then call writint(d.data);\r
+ fi;\r
+ call outgtext("");\r
+end menu_max;\r
+\r
+(****************************************************************************)\r
+(* menu quitte *)\r
+(****************************************************************************)\r
+unit menu_qui : function : boolean;\r
+var rep : boolean;\r
+var a : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call outgtext("Voulez-vous quitter");\r
+ call outgtext(" (o/n) ?");\r
+ call move(inxpos+8,inypos);\r
+ do\r
+ a:=inkey;\r
+ if (a=111 or a=79)\r
+ then result:=true;\r
+ call outgtext("o");\r
+ exit\r
+ fi;\r
+ if (a=110 or a=78)\r
+ then result:=false;\r
+ call outgtext("n");\r
+ exit\r
+ fi;\r
+ od;\r
+ call outgtext("");\r
+ end\r
+end menu_qui;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(*****************************************************************************)\r
+(* *)\r
+(* P R O G R A M M E P R I N C I P A L *)\r
+(* *)\r
+(*****************************************************************************)\r
+(*****************************************************************************)\r
+var colorf,colore : integer;\r
+var nbitem : integer;\r
+var espace : integer;\r
+var item : arrayof string;\r
+var nbbot : integer;\r
+var flag : boolean;\r
+var posy : integer;\r
+var arbr : Barbre;\r
+\r
+Begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ arbr:=new Barbre(3);\r
+ call gron(1);\r
+ flag:=init(nbbot);\r
+ call hpage(0,1,1);\r
+ posy:=20;\r
+ call maine;\r
+ call hidecursor;\r
+ call groff;\r
+ end\r
+ end\r
+End BArbres.\r
--- /dev/null
+program BARBRES;\r
+\r
+\r
+unit barbre:class;\r
+ var NB:integer,\r
+ inf:barbre,\r
+ page:arrayof couple;\r
+\r
+ unit couple:class;\r
+ var cle:integer,\r
+ sup:barbre;\r
+ end couple;\r
+\r
+end barbre;\r
+\r
+\r
+\r
+begin\r
+\r
+ pref barbre block\r
+\r
+ var n,cherche,choix : integer,\r
+ rep,h : boolean,\r
+ racine,q : barbre,\r
+ u : couple;\r
+\r
+\r
+\r
+ (**** RECHERCHE DU MINIMUM ****)\r
+\r
+unit minimum:function(racine:barbre):integer;\r
+\r
+ begin\r
+ if (racine.inf = none)\r
+ then result:=racine.page(1).cle\r
+ else result:=minimum(racine.inf)\r
+ fi;\r
+ end minimum;\r
+\r
+ (**** RECHERCHE DU MAXIMUM ****)\r
+\r
+ unit maximum:function(racine:barbre):integer;\r
+\r
+ begin\r
+ if (racine.inf = none)\r
+ then result := racine.page(racine.nb).cle;\r
+ else result := maximum(racine.page(racine.nb).sup);\r
+ fi;\r
+ end maximum;\r
+\r
+\r
+ (**** RECHERCHE D'UN ELEMENT ****)\r
+\r
+ unit rechercher:function(cherche:integer;tree:barbre):boolean;\r
+ var left,right,milieu:integer;\r
+\r
+ begin\r
+ if (tree=none) then result:=false else\r
+ left:=1;right:=tree.NB;\r
+ while (left<=right) and (right>=1)\r
+\r
+ (* RECHERCHE DICHOTOMIQUE *)\r
+ do\r
+ milieu:=(left+right) div 2;\r
+ if (cherche<tree.page(milieu).cle) then right:=milieu-1;fi;\r
+ if (cherche>tree.page(milieu).cle) then left:=milieu+1;fi;\r
+ if (cherche=tree.page(milieu).cle) then result:=true;exit;fi;\r
+ od;\r
+ if (not result) then\r
+\r
+ (* RECHERCHE DE L'ELEMENT AU NIVEAU SUIVANT *)\r
+ if (right=0)\r
+ then result:=rechercher(cherche,tree.inf);\r
+ else result:=rechercher(cherche,tree.page(right).sup);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end rechercher;\r
+\r
+\r
+ (**** INSERTION D'UN ELEMENT ****)\r
+\r
+ unit recherche_place:procedure(tree:barbre;cherche:integer;\r
+ output h:boolean,v:couple);\r
+ var left,right,milieu:integer,\r
+ q:barbre,\r
+ u:couple;\r
+\r
+\r
+ unit insere_deborde:procedure;\r
+\r
+(* INSERTION DE L'ELEMENT ET TRAITEMENT DES EVENTUELS DEBORDEMENTS *)\r
+\r
+ var i:integer,\r
+ t:arrayof couple,\r
+ b:barbre;\r
+ begin\r
+ if (tree.nb < 2*n )\r
+ then\r
+ (* INSERTION DANS LE CAS OU IL N'Y A PAS DE DEBORDEMENT *)\r
+\r
+ tree.nb := tree.nb + 1;\r
+ h:=false; (* IL N'Y A PAS DEBORDEMENT DONC ON MET H A FALSE *)\r
+ for i:= tree.nb downto (right+2) do tree.page(i):=tree.page(i-1) od;\r
+ tree.page(right+1):=u;\r
+ else\r
+\r
+ (* INSERTION DANS LE CAS OU IL Y A DEBORDEMENT *)\r
+\r
+ b:=new barbre;\r
+ array b.page dim (1:2*n);\r
+ if (right <= n) then\r
+ if (right=n) then v:=u;\r
+ else v:=tree.page(n);\r
+ for i:= n downto (right +2) do tree.page(i):=tree.page(i-1) od;\r
+ tree.page(right+1):=u;\r
+ fi;\r
+ for i:= 1 to n do b.page(i):=tree.page(i+n) od;\r
+ else\r
+ right:= right - n;\r
+ v:= tree.page(n+1);\r
+ for i := 1 to (right-1) do b.page(i) := tree.page(i+n+1) od;\r
+ b.page(right):=u;\r
+ for i := right+1 to n do b.page(i) := tree.page(i+n) od;\r
+ fi;\r
+ tree.nb:=n;\r
+ b.nb:=n;\r
+ b.inf:=v.sup;\r
+ v.sup:=b;\r
+ fi;\r
+\r
+ end insere_deborde;\r
+\r
+ begin\r
+ if(tree=none) then\r
+\r
+ (* CAS ON A DEPASSE LES FEUILLES, OU BIEN L'ARBRE EST VIDE *)\r
+\r
+ h:=true;\r
+ v:= new couple;\r
+ v.cle:=cherche;\r
+ else\r
+\r
+ (* RECHERCHE DE LA PLACE OU INSERER AU NIVEAU SUIVANT *)\r
+\r
+ left:=1;right:=tree.NB;\r
+ while (left<=right) and (right>=1)\r
+ do\r
+ milieu:=(left+right) div 2;\r
+ if (cherche<tree.page(milieu).cle) then right:=milieu-1;fi;\r
+ if (cherche>tree.page(milieu).cle) then left:=milieu+1;fi;\r
+ if (cherche=tree.page(milieu).cle) then\r
+ writeln(" L'element ",cherche," est deja dans l'arbre");\r
+ exit;\r
+ fi;\r
+ od;\r
+ if (left=right) then h:=false;\r
+ else\r
+ (* APPELS RECURSIFS DE LA PROCEDURE RECHERCHE *)\r
+ if (right=0)\r
+ then call recherche_place(tree.inf,cherche,h,u);\r
+ else call recherche_place(tree.page(right).sup,cherche,h,u);;\r
+ fi;\r
+\r
+ (* L'INSTRUCTION QUI SUIT N'EST EFFECTUEE QUE LORS DU DEPILAGE\r
+ DE L'APPEL PRECEDENT DE LA PROCEDURE RECHERCHE_PLACE. SI IL Y A\r
+ DEBORDEMENT APRES L'APPEL DE INSERE_DEBORDE, ALORS H GARDE LA VALEUR\r
+ TRUE ET ON FAIT UN APPEL DE INSERE_DEBORDE SUR LE NIVEAU PRECEDENT\r
+ GRACE AU DEPILLAGE DES APPELS DE RECHERCHE_PLACE *)\r
+\r
+ if (h) then call insere_deborde fi;\r
+ fi;\r
+ fi;\r
+ end recherche_place;\r
+\r
+\r
+ unit inserer:procedure(x:integer;inout racine:barbre);\r
+\r
+ begin\r
+ call recherche_place(racine,x,h,u);\r
+\r
+ (* CAS OU L'ARBRE EST VIDE, OU CAS OU IL FAUT CREER UNE NOUVELLE RACINE,\r
+ LE DEBORDEMENT AYANT ATTEINT LA RACINE *)\r
+\r
+ if (h) then q:=racine;\r
+ racine:=new barbre;\r
+ array racine.page dim (1:2*n);\r
+ racine.nb:=1;\r
+ racine.inf:=q;\r
+ racine.page(1):=u;\r
+ fi;\r
+ end inserer;\r
+\r
+\r
+ (**** VISUALISATION ****)\r
+\r
+ unit visualise:procedure( b_arb:barbre;separe:integer);\r
+\r
+(* VISUALISATION DES ELEMENTS PAR APPELS RECURSIFS SUR L'ARBRE *)\r
+ var i:integer;\r
+\r
+ begin\r
+ if (b_arb <> none)\r
+ then\r
+ for i:= 1 to separe do write(" ") od;\r
+ for i:= 1 to b_arb.nb do write(b_arb.page(i).cle:5) od;\r
+ writeln;\r
+ call visualise(b_arb.inf,separe+1);\r
+ for i:= 1 to b_arb.nb do call visualise(b_arb.page(i).sup,separe+1) od;\r
+ fi;\r
+ end visualise;\r
+\r
+\r
+ (**** SAUTER n LIGNES A L ECRAN ****)\r
+\r
+ unit ligne:procedure(n:integer);\r
+ var i : integer;\r
+ begin\r
+ for i := 1 to n do writeln od;\r
+ end ligne;\r
+\r
+\r
+ (**** MENU ****)\r
+\r
+ unit menu: procedure(output choix:integer);\r
+ begin\r
+ call ligne(30);\r
+ write(" MANIPULATION DE B-ARBRE ");\r
+ writeln;\r
+ write(" 1 : recherche de l'element minimum ");\r
+ writeln;\r
+ write(" 2 : recherche de l'element maximun ");\r
+ writeln;\r
+ write(" 3 : recherche d'un element quelconque");\r
+ writeln;\r
+ write(" 4 : Insertion d'un element dans l'arbre ");\r
+ writeln;\r
+ write(" 5 : Visualisation de l'arbre");\r
+ writeln;\r
+ write(" 6 : Quitter le programme ");\r
+ call ligne(9);\r
+ write(" Entrer votre choix : ");\r
+ readln(choix);\r
+ writeln;\r
+ end menu;\r
+\r
+ (**** PASSAGE AU MENU SUIVANT ****)\r
+\r
+unit continuer : procedure;\r
+\r
+(* PERMET DE "FIGER" L'ECRAN POUR LIRE LE RESULTAT *)\r
+\r
+ var c : char;\r
+ begin\r
+ writeln;\r
+ writeln;\r
+ write(" Pour continuer appuyez deux fois sur 'entree' :");\r
+ readln(c);\r
+ end continuer;\r
+\r
+\r
+ (* ----------------- PROGRAMME PRINCIPAL ------------------- *)\r
+\r
+\r
+ begin\r
+ rep := true;\r
+ call ligne(30);\r
+ write(" ENTRER L'ORDRE DE L'ARBRE :");\r
+ readln(n);\r
+\r
+ while rep do\r
+ call menu(choix);\r
+\r
+ case choix\r
+\r
+ (* APPEL DE LA PROCEDURE CHERCHANT LE MINIMUM *)\r
+ when 1 : call ligne(30);\r
+ if (racine = none)\r
+ then writeln(" L' ARBRE EST VIDE !!!");\r
+ else\r
+ write(" LE MINIMUM EST ", minimum(racine):2);\r
+ fi;\r
+ call ligne(11);\r
+ call continuer;\r
+\r
+ (* APPEL DE LA PROCEDURE CHERCHANT LE MAXIMUM *)\r
+ when 2 : call ligne(11);\r
+ if (racine = none )\r
+ then\r
+ writeln(" L' ARBRE EST VIDE !!!");\r
+ else\r
+ write(" LE MAXIMUM EST ", maximum(racine):2);\r
+ fi;\r
+ call ligne(11);\r
+ call continuer;\r
+\r
+ (* APPEL DE LA PROCEDURE CHERCHANT UN ELEMENT QUELCONQUE *)\r
+ when 3 : write(" ENTRER L'ELEMENT A CHERCHER :");\r
+ readln(cherche);\r
+ writeln;\r
+ call ligne(30);\r
+ if (rechercher(cherche,racine))\r
+ then\r
+ writeln(" L'ELEMENT ",cherche :2," SE TROUVE DANS L'ARBRE");\r
+ else\r
+ writeln(" L'ELEMENT ",cherche:2," N'EST PAS DANS L'ARBRE");\r
+ fi;\r
+ call ligne(11);\r
+ call continuer;\r
+\r
+ (* APPEL DE LA PROCEDURE INSERANT UN ELEMENT *)\r
+ when 4 : write(" ENTRER L'ELEMENT A INSERER :");\r
+ readln(cherche);\r
+ call inserer (cherche,racine);\r
+\r
+ (* APPEL DE LA PROCEDURE VISUALISANT UN ARBRE *)\r
+ when 5:\r
+ if (racine = none)\r
+ then call ligne(30);\r
+ writeln(" L'ARBRE EST VIDE .");\r
+ call ligne(11);\r
+ else writeln(" L'arbre est : ");\r
+ call visualise(racine,1);\r
+ fi;\r
+ call continuer;\r
+\r
+ (* SORTIE DU PROGRAMME *)\r
+ when 6: rep:= false;\r
+ esac;\r
+ od;\r
+\r
+end;\r
+end BARBRES.\r
+\1a
\ No newline at end of file
--- /dev/null
+program drzewo;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+CONST min = 0 ,\r
+ max = 99 ,\r
+ lewy = ".lsyn" ,\r
+ prawy = ".psyn" ,\r
+ srodkowy = ".ssyn" ;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+VAR\r
+ node :drzewo ,\r
+ i,j : integer ;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+SIGNAL emptytree ;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT drzewo:class;\r
+ \r
+ Var klucz:integer,\r
+ lsyn,psyn:drzewo,\r
+ logl,logp:boolean;\r
+ \r
+ Unit lisc : function :boolean ;\r
+ begin\r
+ result := lsyn = none\r
+ end lisc \r
+end drzewo;\r
+\r
+\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT licznosc :function (d:drzewo , p:integer , log:boolean):integer ;\r
+\r
+(* Liczy ile miejsca potrzeba do wydruku linii *)\r
+\r
+Var licznik : integer ;\r
+\r
+Signal alarm ;\r
+\r
+\r
+Unit licz :procedure (d:drzewo) ;\r
+ begin\r
+ i := i+1 ; \r
+ if d = none then raise alarm fi;\r
+ if i = p then\r
+ if log then licznik := licznik + 1\r
+ else\r
+ if d.logp then\r
+ licznik := licznik + 6\r
+ else\r
+ licznik := licznik + 3 ; \r
+ fi\r
+ fi \r
+ else\r
+ call licz (d.lsyn) ;\r
+ if d.logp then \r
+ call licz(d.psyn.lsyn) ;\r
+ call licz(d.psyn.psyn) ;\r
+ else\r
+ call licz(d.psyn) \r
+ fi\r
+ fi ;\r
+ i := i-1\r
+end licz ;\r
+\r
+Handlers \r
+ when alarm : licznik := 0 ;\r
+ wind\r
+end handlers ; \r
+ \r
+Begin\r
+ licznik :=0 ;\r
+ i := 0 ;\r
+ call licz (d) ;\r
+ result := licznik\r
+end licznosc ;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT infix :procedure(d : drzewo) ;\r
+\r
+Begin \r
+ if d.lisc then\r
+ write(d.klucz:3)\r
+ else \r
+ call infix (d.lsyn );\r
+ call infix (d.psyn )\r
+ fi\r
+end infix ; \r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT empty : function (d : drzewo) : boolean ;\r
+ Begin\r
+ result := d = none \r
+End empty ; \r
+\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT minimum : function (d : drzewo) : integer ;\r
+\r
+Begin\r
+ if d = none then \r
+ raise emptytree\r
+ else\r
+ if d.lisc then \r
+ result := d.klucz \r
+ else \r
+ result := minimum (d.lsyn)\r
+ fi\r
+ fi \r
+end minimum ; \r
+\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT member : function ( k:integer , d:drzewo ) : boolean ;\r
+ \r
+ Begin\r
+ if d <> none then\r
+ if d.klucz <> k then \r
+ if d.klucz < k then\r
+ result := member(k,d.psyn);\r
+ else \r
+ result := member(k,d.lsyn);\r
+ fi \r
+ else\r
+ result := true\r
+ fi \r
+ else\r
+ result := false\r
+ fi\r
+ end member ; \r
+ \r
+(*-----------------------------------------------------------------------*) \r
+ \r
+UNIT insert : procedure ( k : integer ; inout d : drzewo ) ;\r
+\r
+Var pom1,pom2 : drzewo ,\r
+ max1,max2 : integer ; \r
+\r
+Signal jest ;\r
+ \r
+Unit ins : procedure ( a:drzewo ) ;\r
+Begin\r
+ if a.klucz = k then raise jest \r
+ fi ;\r
+ if a.lisc then\r
+ pom1 := new drzewo ;\r
+ if a.klucz < k then\r
+ pom1.klucz := k ;\r
+ max1 := a.klucz\r
+ else\r
+ pom1.klucz := a.klucz ;\r
+ max1 := k ;\r
+ a.klucz := k\r
+ fi\r
+ else\r
+ if k <= a.klucz then\r
+ call ins (a.lsyn ) ;\r
+ if pom1 <> none then\r
+ if a.logl then \r
+ pom2 := a.psyn ;\r
+ a.psyn := pom1 ;\r
+ max2 := a.klucz ;\r
+ a.klucz := max1 ;\r
+ max1 := max2 ;\r
+ pom1 := pom2\r
+ else\r
+ if a.logp then\r
+ pom2 := a.psyn ;\r
+ a.psyn := pom1 ;\r
+ max2 := a.klucz ;\r
+ a.klucz := max1 ;\r
+ max1 := max2 ;\r
+ pom1 := pom2 ;\r
+ a.logp,pom1.logl := false\r
+ else\r
+ pom2 := new drzewo ;\r
+ pom2.lsyn := pom1 ;\r
+ pom2.psyn := a.psyn ;\r
+ pom2.klucz := a.klucz ;\r
+ a.klucz := max1 ;\r
+ pom2.logl,a.logp := true ;\r
+ a.psyn := pom2 ;\r
+ pom1 := none \r
+ fi\r
+ fi \r
+ fi\r
+ else\r
+ call ins (a.psyn) ;\r
+ if pom1 <> none then\r
+ if a.logp then\r
+ pom2 := a.psyn ;\r
+ a.psyn := a.psyn.lsyn ;\r
+ pom2.lsyn := pom2.psyn ;\r
+ pom2.psyn := pom1 ;\r
+ max2 := max1 ;\r
+ max1 := pom2.klucz ;\r
+ pom2.klucz := max2 ;\r
+ pom1 := pom2 ;\r
+ pom1.logl,a.logp := false \r
+ else\r
+ if not a.logl then\r
+ pom2 := new drzewo ;\r
+ pom2.psyn := pom1 ;\r
+ pom2.lsyn := a.psyn ;\r
+ a.psyn := pom2 ;\r
+ pom2.klucz := max1 ;\r
+ a.logp,pom2.logl := true ;\r
+ pom1 := none \r
+ fi \r
+ fi\r
+ fi \r
+ fi\r
+ fi\r
+end ins ;\r
+\r
+Handlers \r
+ when jest : call setcursor(20,1) ;\r
+ call eraseline ; \r
+ writeln("element ",k:2," znajduje sie w drzewie") ;\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor (20,1) ;\r
+ call eraseline ;\r
+ terminate \r
+end handlers ; \r
+\r
+Begin \r
+ if d=none then\r
+ d := new drzewo ;\r
+ d.klucz := k\r
+ else\r
+ call ins (d) ;\r
+ if pom1 <> none then\r
+ pom2 := new drzewo ;\r
+ pom2.klucz := max1 ;\r
+ pom2.lsyn := d ;\r
+ pom2.psyn := pom1 ;\r
+ d := pom2 \r
+ fi\r
+ fi \r
+end insert ; \r
+ \r
+(*-----------------------------------------------------------------------*) \r
+ \r
+UNIT delete:procedure(k:integer;inout d:drzewo);\r
+\r
+ Var pom,pom1 : drzewo ,\r
+ nowymax : integer ,\r
+ kon : boolean ;\r
+\r
+ Signal koniec ,niema ;\r
+ \r
+ Unit del : procedure (inout d : drzewo ) ;\r
+ \r
+ Begin\r
+ if d.lisc then \r
+ if d.klucz = k then \r
+ kill (d)\r
+ else\r
+ raise niema \r
+ fi\r
+ else\r
+ if d.klucz >= k then \r
+ call del (d.lsyn) ;\r
+ if kon then \r
+ raise koniec\r
+ fi ; \r
+ if d.lsyn = none then \r
+ if pom = none then \r
+ if d.logp then \r
+ pom1 := d ;\r
+ d := d.psyn ;\r
+ d.logl := false ;\r
+ kill (pom1) ;\r
+ kon := true\r
+ else\r
+ pom := d.psyn ;\r
+ kill (d)\r
+ fi \r
+ else\r
+ if k = d.klucz then \r
+ d.klucz := nowymax \r
+ fi ;\r
+ if d.logp then\r
+ if d.psyn.lsyn.logp then\r
+ pom1 := d.psyn.lsyn ;\r
+ d.psyn.lsyn := d.psyn.lsyn.psyn ;\r
+ d.lsyn :=pom ;\r
+ pom1.psyn := d.psyn ;\r
+ d.psyn := pom1.lsyn ;\r
+ pom1.lsyn := d ;\r
+ d := pom1 ;\r
+ d.logp,d.psyn.logl := false ; \r
+ d.lsyn.logp , d.psyn.lsyn.logl := false ;\r
+ kon := true\r
+ else\r
+ pom1 := d.psyn ;\r
+ d.lsyn := pom ;\r
+ d.psyn := d.psyn.lsyn ;\r
+ pom1.lsyn := d ;\r
+ d := pom1 ;\r
+ d.logl := false ;\r
+ d.lsyn.psyn.logl := true ;\r
+ pom := none ;\r
+ kon := true \r
+ fi\r
+ else\r
+ if d.psyn.logp then \r
+ pom1 := d.psyn ;\r
+ d.lsyn := pom ;\r
+ d.psyn := d.psyn.lsyn ;\r
+ pom1.lsyn := d ;\r
+ d := pom1 ;\r
+ d.logp , d.psyn.logl := false ;\r
+ if d.lsyn.logl then\r
+ d.lsyn.logl := false ;\r
+ d.logl := true \r
+ fi ; \r
+ pom := none ;\r
+ kon := true\r
+ else\r
+ d.lsyn := pom ;\r
+ d.psyn.logl , d.logp := true ;\r
+ pom := d ;\r
+ d := none ;\r
+ fi\r
+ fi\r
+ fi \r
+ else\r
+ \r
+ if k = d.klucz then d.klucz := nowymax fi;\r
+ pom := none ;\r
+ kon := true\r
+ fi \r
+ else\r
+ call del (d.psyn) ;\r
+ if kon then \r
+ raise koniec\r
+ fi ; \r
+ if d.psyn = none then \r
+ if pom = none then \r
+ nowymax := d.lsyn.klucz ;\r
+ pom := d.lsyn ;\r
+ kill (d) \r
+ else\r
+ if d.logp then \r
+ d.psyn := pom ;\r
+ d.logp := false ;\r
+ d.psyn.logl := false ;\r
+ pom := none \r
+ else\r
+ if d.lsyn.logp then \r
+ pom1 := d.lsyn ;\r
+ d.psyn := pom ;\r
+ d.lsyn := pom1.psyn.psyn ;\r
+ pom1.psyn.psyn := d ;\r
+ d := pom1.psyn ;\r
+ pom1.psyn := d.lsyn ;\r
+ d.lsyn := pom1 ;\r
+ d.logl , d.lsyn.logp := false ;\r
+ pom := none\r
+ else\r
+ pom1 := d.lsyn ;\r
+ d.psyn := pom ;\r
+ d.lsyn := d.lsyn.psyn ;\r
+ pom1.psyn :=d ;\r
+ pom :=pom1 ;\r
+ pom1.logp , pom1.psyn.logl := true ;\r
+ d := none ;\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ fi\r
+ fi \r
+ end del ; \r
+ \r
+Handlers\r
+ when niema : call setcursor(20,1) ;\r
+ writeln("elementu ",k:2," nie ma w drzewie") ;\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor(20,1) ;\r
+ call eraseline ;\r
+ terminate ;\r
+ when koniec : terminate \r
+end handlers ; \r
+ \r
+ Begin\r
+ if d = none then\r
+ raise niema\r
+ else \r
+ call del (d) ;\r
+ if pom <> none then \r
+ d := pom\r
+ fi\r
+ fi\r
+end delete ; \r
+\r
+(*-----------------------------------------------------------------------*) \r
+\r
+Unit delmin : procedure (inout d : drzewo) ;\r
+ \r
+ Var a : integer ;\r
+ \r
+ Begin\r
+ if empty (d) then\r
+ raise emptytree\r
+ else \r
+ a := minimum (d) ;\r
+ call delete (a,d) \r
+ fi \r
+End delmin \r
+\r
+(*-----------------------------------------------------------------------*) \r
+ \r
+(* *)\r
+(* PROCEDURY GRAFICZNE *)\r
+(* *) \r
+\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+\r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ \r
+ unit EraseLine : procedure;\r
+ begin\r
+ write( chr(27), "[K")\r
+ end EraseLine;\r
+\r
+ unit inchar : IIUWgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
+ unit CursorLeft : procedure (columns : integer);\r
+ var e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := columns div 10;\r
+ j := columns mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", e, f, "D")\r
+ end CursorLeft;\r
+ \r
+ unit CursorRight : procedure (columns : integer);\r
+ var e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := columns div 10;\r
+ j := columns mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", e, f, "C")\r
+ end CursorRight;\r
+ \r
+ unit CursorUp : procedure (rows : integer);\r
+ var c,d : char,\r
+ i,j : integer;\r
+ begin\r
+ i := rows div 10;\r
+ j := rows mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ write( chr(27), "[", c, d, "A")\r
+ end CursorUp;\r
+ \r
+ unit CursorDown : procedure (rows : integer);\r
+ var c,d : char,\r
+ i,j : integer;\r
+ begin\r
+ i := rows div 10;\r
+ j := rows mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ write( chr(27), "[", c, d, "B")\r
+ end CursorDown;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT czekaj :procedure ;\r
+ Var i :integer ;\r
+ Begin\r
+ i := inchar\r
+End czekaj ;\r
+ \r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT tytul : procedure ;\r
+Begin\r
+ call newpage ;\r
+ call setcursor (10,30) ;\r
+ write ("PROGRAM KOLEJKA") ;\r
+ call setcursor (15,27) ;\r
+ write (" autor : Adam Kujawski") ;\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj \r
+end tytul ; \r
+ \r
+\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+UNIT menu : procedure ;\r
+\r
+Unit insdelmenu : procedure(formal : boolean) ;\r
+ \r
+ Var c1,c2,c3 : integer ; \r
+ \r
+ Begin\r
+ call newpage ;\r
+ call setcursor (5,25) ;\r
+ write ("Podaj liczbe z przedzialu") ;\r
+ call setcursor (7,25) ; \r
+ write ( " 0 < liczba < 100 .") ;\r
+ call setcursor (9,25) ; \r
+ writeln ("Wprowadz 0 jesli chcesz zakonczyc") ; \r
+ \r
+ Do\r
+ call setcursor(15,39);\r
+ call eraseline ; \r
+ c1 := 0 ;\r
+ c2 := 0 ;\r
+ do\r
+ c1 := inchar ;\r
+ if c1 >= 48 andif c1 <= 57 then\r
+ write (chr(c1)) ;\r
+ do\r
+ c2 := inchar ;\r
+ if c2 >= 48 andif c2 <= 57 then\r
+ write (chr (c2)) ;\r
+ do\r
+ c3 := inchar ;\r
+ if c3 = 13 then\r
+ j := (c1-48) * 10 + (c2-48) ;\r
+ exit exit exit\r
+ else\r
+ if c3 = 8 then\r
+ c2 := 0 ;\r
+ call cursorleft(1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi \r
+ od \r
+ else \r
+ if c2 = 13 then\r
+ j := c1-48 ;\r
+ exit exit\r
+ else\r
+ if c2 = 8 then \r
+ c1 := 0 ;\r
+ call cursorleft (1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi\r
+ fi \r
+ od \r
+ fi\r
+ od ; \r
+\r
+ if j < 100 andif j > 0 then\r
+ if formal then\r
+ call insert (j,node) ;\r
+ else\r
+ call delete (j,node) ;\r
+ fi ; \r
+ call setcursor(20,1) ;\r
+ call eraseline ;\r
+ write (" O.K.") \r
+ else\r
+ if j = 0 then \r
+ exit\r
+ fi\r
+ fi \r
+ Od\r
+ end insdelmenu ; \r
+ \r
+Unit membermenu : procedure ;\r
+\r
+ Var c1,c2,c3 : integer ,\r
+ bool1 : boolean ; \r
+ \r
+ Begin\r
+ call newpage ;\r
+ call setcursor (5,25) ;\r
+ write ("Podaj liczbe z przedzialu") ;\r
+ call setcursor (7,25) ; \r
+ write ( " 0 < liczba < 100 .") ;\r
+ call setcursor (9,25) ; \r
+ writeln ("Wprowadz 0 jesli chcesz zakonczyc") ; \r
+ \r
+ Do\r
+ call setcursor(15,39);\r
+ call eraseline ; \r
+ c1 := 0 ;\r
+ c2 := 0 ;\r
+ do\r
+ c1 := inchar ;\r
+ if c1 >= 48 andif c1 <= 57 then\r
+ write (chr(c1)) ;\r
+ do\r
+ c2 := inchar ;\r
+ if c2 >= 48 andif c2 <= 57 then\r
+ write (chr (c2)) ;\r
+ do\r
+ c3 := inchar ;\r
+ if c3 = 13 then\r
+ j := (c1-48) * 10 + (c2-48) ;\r
+ exit exit exit\r
+ else\r
+ if c3 = 8 then\r
+ c2 := 0 ;\r
+ call cursorleft(1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi \r
+ od \r
+ else \r
+ if c2 = 13 then\r
+ j := c1-48 ;\r
+ exit exit\r
+ else\r
+ if c2 = 8 then \r
+ c1 := 0 ;\r
+ call cursorleft (1) ;\r
+ call eraseline ;\r
+ exit\r
+ fi\r
+ fi\r
+ fi \r
+ od \r
+ fi\r
+ od ; \r
+\r
+ if j < 100 andif j > 0 then\r
+ bool1 := member (j,node) ;\r
+ call setcursor (20,20) ;\r
+ if bool1 then \r
+ write(" Element ",j:2," znajduje sie w drzewie .")\r
+ else\r
+ write (" Elementu ",j:2," nie ma w drzewie .")\r
+ fi ; \r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor(20,1) ;\r
+ call eraseline ;\r
+ write (" O.K.") \r
+ fi ;\r
+ if j = 0 then \r
+ exit\r
+ fi \r
+ Od \r
+end membermenu ;\r
+\r
+Unit help : procedure ;\r
+\r
+Begin\r
+ call newpage ;\r
+ call setcursor (7,1) ;\r
+ write (" Dla tych ktorzy nie wiedza : ") ;\r
+ write (" ^d oznacza rownoczesne nacisniecie klawiszy 'Ctrl' i 'd' .") ;\r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj \r
+ \r
+end help ;\r
+\r
+Unit emptymenu : procedure ;\r
+\r
+Var bo : boolean ;\r
+\r
+Begin\r
+ call newpage ;\r
+ bo := empty (node) ;\r
+ call setcursor (12,25) ;\r
+ if bo then\r
+ write ( "Drzewo jest puste .") ;\r
+ else\r
+ write ("Drzewo nie jest puste .") ;\r
+ fi ; \r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj \r
+\r
+end emptymenu ;\r
+ \r
+Unit minimummenu:procedure ;\r
+\r
+Var x : integer ;\r
+\r
+Begin\r
+ if empty (node) then\r
+ raise emptytree\r
+ else\r
+ x := minimum(node) ;\r
+ call newpage ;\r
+ call setcursor(12,20) ;\r
+ write ("Najmniejszy element w drzewie : ",x:2," .") ; \r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj ;\r
+ call setcursor (25,30) ;\r
+ call eraseline ;\r
+ call setcursor(20,1) ;\r
+ call eraseline \r
+ fi \r
+ \r
+end minimummenu;\r
+\r
+Unit rysmenu :procedure ;\r
+\r
+Unit listawezlow : class ;\r
+ var dr : drzewo ,\r
+ kier :integer ,\r
+ next,pop : listawezlow ; \r
+end listawezlow ; \r
+\r
+Var aktualny : listawezlow ,\r
+ pom : listawezlow ;\r
+\r
+Begin\r
+aktualny := new listawezlow ;\r
+aktualny.dr := node ;\r
+DO\r
+ call newpage ;\r
+ call setcursor (10,30);\r
+ call reverse ;\r
+ write (" P O D M E N U ") ; \r
+ call normal ;\r
+ call setcursor (13,27);\r
+ write ("strzalki - zmiana aktualnego drzewa") ;\r
+ call setcursor (14,27);\r
+ write ("enter - wydruk aktualnego drzewa") ;\r
+ call setcursor (15,27);\r
+ write ("Esc - powrot do M E N U") ;\r
+ call setcursor (25,1);\r
+ write ("aktualne = korzen") ;\r
+ pom := aktualny ;\r
+ while pom.pop <> none \r
+ do\r
+ pom := pom.pop\r
+ od;\r
+ while pom.next <> none \r
+ do\r
+ case pom.kier\r
+ when 1 : write (lewy) ;\r
+ when 2 : write (srodkowy) ;\r
+ when 3 : write (prawy) \r
+ esac ;\r
+ pom := pom.next\r
+ od; \r
+ DO\r
+ i := inchar ;\r
+ if i > 0 then \r
+ case i\r
+ when 13 : exit ;\r
+ when 27 : exit exit\r
+ esac\r
+ else\r
+ case i + 80 \r
+ when 8 : if aktualny.dr <> node then \r
+ aktualny := aktualny.pop ;\r
+ call cursorleft(5) ;\r
+ call eraseline ;\r
+ kill (aktualny.next) ;\r
+ aktualny.kier := 0\r
+ fi ;\r
+ when 5 :if aktualny.dr <> none then\r
+ pom := new listawezlow ;\r
+ pom.pop := aktualny ;\r
+ pom.dr := aktualny.dr.lsyn ;\r
+ aktualny.next := pom ;\r
+ aktualny.kier := 1 ;\r
+ aktualny := pom ;\r
+ write (lewy) \r
+ fi ; \r
+ when 3 :if aktualny.dr <> none then\r
+ pom := new listawezlow ;\r
+ pom.pop := aktualny ;\r
+ if aktualny.dr.logp then\r
+ pom.dr := aktualny.dr.psyn.psyn\r
+ else \r
+ pom.dr := aktualny.dr.psyn \r
+ fi ; \r
+ aktualny.next := pom ;\r
+ aktualny.kier := 3 ;\r
+ aktualny := pom ;\r
+ write (prawy) ; \r
+ fi ;\r
+ when 0 :if aktualny.dr <> none then\r
+ if aktualny.dr.logp then \r
+ pom := new listawezlow ;\r
+ pom.pop := aktualny ;\r
+ aktualny.next := pom ;\r
+ pom.dr := aktualny.dr.psyn.lsyn ;\r
+ aktualny.kier := 2 ;\r
+ aktualny := pom ;\r
+ write (srodkowy)\r
+ fi ; \r
+ fi \r
+ esac\r
+ fi \r
+ \r
+ OD ;\r
+call rys (aktualny.dr) \r
+OD \r
+ \r
+end rysmenu ;\r
+ \r
+Begin\r
+DO\r
+ call newpage ;\r
+ call setcursor (13,31);\r
+ call reverse ;\r
+ write (" M E N U ") ; \r
+ call normal ;\r
+ call setcursor (13,30);\r
+ write ("i - insert") ;\r
+ call setcursor (14,30);\r
+ write ("d - delete");\r
+ call setcursor (15,30);\r
+ write ("m - member" );\r
+ call setcursor (16,30); \r
+ write ("e - empty?") ;\r
+ call setcursor (17,30);\r
+ write ("w - wydruk drzewa");\r
+ call setcursor (18,30);\r
+ write ("^m - minimum");\r
+ call setcursor (19,30);\r
+ write ("^d - delmin");\r
+ call reverse ;\r
+ call setcursor (25,1);\r
+ write (" F1 - HELP , Esc - wyjscie z programu ");\r
+ call normal ;\r
+ \r
+ DO\r
+ i := inchar ;\r
+ if i = 27 then \r
+ exit exit\r
+ else \r
+ if i > 80 then\r
+ case i\r
+ when 105 : call insdelmenu(true) ;\r
+ exit ;\r
+ when 100 : call insdelmenu(false) ;\r
+ exit ;\r
+ when 109 : call membermenu ;\r
+ exit ;\r
+ when 101 : call emptymenu ; \r
+ exit ;\r
+ when 119 : call rysmenu ;\r
+ exit \r
+ esac\r
+ else\r
+ case i + 60 \r
+ when 64 : call delmin (node) ;\r
+ exit ; \r
+ when 73 : call minimummenu ;\r
+ exit ;\r
+ when 1 : call help ;\r
+ exit \r
+ esac \r
+ fi\r
+ fi\r
+ OD\r
+OD \r
+end menu ;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+ \r
+UNIT rys:IIUWGraph procedure(d:drzewo) ;\r
+\r
+Const skok = 6 ;\r
+\r
+Var licznik,poziom,licznik2 : integer , \r
+ krok,krok2,staryx,staryy : integer ; \r
+\r
+\r
+Unit ramka :procedure (wr,kol,dl:integer) ;\r
+\r
+ Var x1,y1,l,h :integer ;\r
+\r
+ Begin\r
+ x1 := (wr) * 8 - 2 ;\r
+ y1 := (kol) * 8 -2 ;\r
+ l := 8 * dl + 4 ;\r
+ h := 12 ;\r
+ call move (x1,y1) ;\r
+ call draw (x1+l,y1) ;\r
+ call draw (x1+l,y1+h) ;\r
+ call draw (x1,y1+h) ;\r
+ call draw (x1,y1) ;\r
+ call move (x1 + l div 2,y1) ;\r
+ call draw (staryx ,staryy ) ; \r
+ call move (x1+2,y1+2)\r
+end ramka ;\r
+\r
+Unit print : procedure (a : integer) ;\r
+\r
+ Begin\r
+ if a > 9 then \r
+ call hascii (48 + a div 10) \r
+ fi;\r
+ call hascii (48 + a mod 10) \r
+end print ; \r
+\r
+Unit odstep : function(d :drzewo,poziom :integer) : integer ;\r
+ \r
+ var i,j : integer ;\r
+ \r
+ begin\r
+ j := licznosc (d,poziom,true) ;\r
+ i := licznosc (d,poziom,false) ;\r
+ result :=( 85 - i ) div (j+1)\r
+end odstep ;\r
+\r
+Unit linia :procedure (d:drzewo);\r
+ \r
+ (* poziom = drukowany poziom *)\r
+ (* i - numer poziomu *) \r
+ \r
+ begin\r
+ i := i+1 ;\r
+ if poziom - 1 = i then\r
+ if d.logp then \r
+ staryx := licznik2 * 8 + 20;\r
+ staryy := i * skok * 8 + 10 ;\r
+ licznik2 := licznik2 + 6 + krok2 \r
+ else \r
+ staryx := licznik2 * 8 + 8;\r
+ staryy := i * skok * 8 + 10 ;\r
+ licznik2 := licznik2 + 3 +krok2\r
+ fi\r
+ fi ; \r
+ if i = poziom then\r
+ if d.logp then \r
+ call ramka (licznik, poziom*skok ,5) ;\r
+ call print (d.klucz) ;\r
+ call hascii (44) ;\r
+ call print (d.psyn.klucz) ;\r
+ licznik := licznik + 6 + krok\r
+ else\r
+ call ramka (licznik, poziom*skok ,2) ;\r
+ call print (d.klucz) ;\r
+ licznik := licznik + 3 + krok\r
+ fi\r
+ else\r
+ call linia (d.lsyn) ;\r
+ if d.logp then \r
+ call linia(d.psyn.lsyn) ;\r
+ call linia(d.psyn.psyn) ;\r
+ else\r
+ call linia(d.psyn) \r
+ fi\r
+ fi;\r
+ i := i-1 \r
+end linia ;\r
+\r
+Unit napis1 : procedure ;\r
+\r
+begin\r
+ call move ( 275 ,335) ;\r
+ call hascii (78) ;\r
+ call hascii (97) ;\r
+ call hascii (99) ;\r
+ call hascii (105) ;\r
+ call hascii (115) ;\r
+ call hascii (110) ;\r
+ call hascii (105) ;\r
+ call hascii (106) ;\r
+ call hascii (32) ;\r
+ call hascii (99) ;\r
+ call hascii (111) ;\r
+ call hascii (107) ;\r
+ call hascii (111) ;\r
+ call hascii (108) ;\r
+ call hascii (119) ;\r
+ call hascii (105) ;\r
+ call hascii (101) ;\r
+ call hascii (107) \r
+\r
+end napis1 ;\r
+\r
+Unit napis2 : procedure ;\r
+\r
+begin\r
+ call move ( 275 ,300) ;\r
+ call hascii (66) ;\r
+ call hascii (114) ;\r
+ call hascii (97) ;\r
+ call hascii (107) ;\r
+ call hascii (32) ;\r
+ call hascii (109) ;\r
+ call hascii (105) ;\r
+ call hascii (101) ;\r
+ call hascii (106) ;\r
+ call hascii (115) ;\r
+ call hascii (99) ;\r
+ call hascii (97) \r
+\r
+end napis2 ;\r
+\r
+Unit napis3 : procedure ;\r
+\r
+begin\r
+ call move ( 285 ,300) ;\r
+ call hascii (79) ;\r
+ call hascii (46) ;\r
+ call hascii (75) ;\r
+ call hascii (46) ;\r
+ \r
+end napis3 ;\r
+\r
+Begin \r
+call gron(0) ;\r
+poziom:=1 ;\r
+Do\r
+ j := licznosc(d,poziom,false) ; \r
+ if j>0 andif j<82 then\r
+ i := 0 ;\r
+ krok2 := odstep (d,poziom-1) ;\r
+ krok := odstep (d,poziom) ; \r
+ licznik := krok + 1 ;\r
+ licznik2 :=krok2 + 1 ;\r
+ staryx := 350 ;\r
+ staryy := skok * 8 -2 ;\r
+ call linia(d) ;\r
+ poziom := poziom+1\r
+ else \r
+ exit\r
+ fi\r
+Od ;\r
+call napis1 ;\r
+if j >= 82 then \r
+ call napis2 \r
+else\r
+ call napis3\r
+fi ; \r
+call czekaj ;\r
+call groff \r
+end rys;\r
+\r
+(*-----------------------------------------------------------------------*)\r
+\r
+HANDLERS \r
+ when emptytree : call newpage ;\r
+ call setcursor(12,30) ;\r
+ write ("PUSTE DRZEWO !") ; \r
+ call setcursor (25,30) ;\r
+ call reverse ;\r
+ write ("nacisnij cokolwiek") ;\r
+ call cursorleft (1) ; \r
+ call normal ;\r
+ call czekaj ;\r
+ return\r
+End handlers\r
+(*-----------------------------------------------------------------------*)\r
+ (* program glowny *)\r
+(*-----------------------------------------------------------------------*)\r
+\r
+BEGIN\r
+\r
+call tytul ;\r
+call menu \r
+\r
+END kolejka \1a
\ No newline at end of file
--- /dev/null
+program projet;\r
+\r
+(****************************************************)\r
+(* LI1 - Projet : Structure de Polynome *)\r
+(* Thierry D\82l\82ris *)\r
+(* Licence d'Informatique - Groupe 1 *)\r
+(****************************************************)\r
+\r
+var t:table,\r
+ g:gestion,\r
+ fini:boolean,\r
+ choix:integer;\r
+\r
+(****************************************************)\r
+(** D\82clarations des Objets de Base *****************)\r
+(****************************************************)\r
+\r
+ (*================================================*)\r
+ (*= D\82claration de l'Objet ELEMENT ===============*)\r
+ (*================================================*)\r
+ unit element:class;\r
+ var a:real,\r
+ k:integer;\r
+\r
+ (*- D\82claration de l'Unit\82 SAISIE --------------*)\r
+ unit saisie:procedure;\r
+ begin\r
+ write("Entrez la Valeur du Coefficient de x : ");\r
+ readln(a);\r
+ write("Entrez la Valeur de la Puissance de x : ");\r
+ readln(k);\r
+ end saisie;\r
+\r
+ (*- D\82claration de l'Unit\82 VALEUR --------------*)\r
+ unit valeur:function(x:integer):real;\r
+\r
+ (*+ D\82claration de l'Unit\82 PUISS +++++++++++++*)\r
+ unit puiss:function(x,k:integer):real;\r
+ var i:integer;\r
+ begin\r
+ result:=1;\r
+ if k > 0 then\r
+ for i:=1 to k\r
+ do\r
+ result:=result*x;\r
+ od;\r
+ else\r
+ if k < 0 then\r
+ for i:=1 to (-1*k)\r
+ do\r
+ result:=result*x;\r
+ od;\r
+ result:=1/result;\r
+ fi;\r
+ fi;\r
+ end puiss;\r
+\r
+ begin\r
+ result:=a*puiss(x,k);\r
+ end valeur;\r
+\r
+ (*- D\82claration de l'Unit\82 MULT ----------------*)\r
+ unit mult:function(i:real;j:integer):element;\r
+ begin\r
+ result:=new element;\r
+ result.a:=a*i;\r
+ result.k:=k+j;\r
+ end mult;\r
+\r
+ (*- D\82claration de l'Unit\82 DERIVE --------------*)\r
+ unit derive:function:element;\r
+ begin\r
+ result:=new element;\r
+ result.a:=a*k;\r
+ result.k:=k-1;\r
+ end derive;\r
+\r
+ end element;\r
+\r
+ (*================================================*)\r
+ (*= D\82claration de l'Objet POLYNOME ==============*)\r
+ (*================================================*)\r
+ unit polynome:class;\r
+ var nom:char,\r
+ nbr:integer,\r
+ exp:arrayof element;\r
+\r
+ (*- D\82claration de l'Unit\82 TRIE ----------------*)\r
+ unit trie:procedure;\r
+ var i,j,h:integer,\r
+ trouve:boolean;\r
+\r
+ (*+ D\82claration de l'Unit\82 ECHANGER ++++++++++*)\r
+ unit echanger:procedure(inout a,b:element);\r
+ var buffer:element;\r
+ begin\r
+ buffer:=a;\r
+ a:=b;\r
+ b:=buffer;\r
+ end echanger;\r
+\r
+ begin\r
+ if nbr > 1 then\r
+ for i:=2 to nbr\r
+ do\r
+ trouve:=false;\r
+ j:=1;\r
+ while j < i and not trouve\r
+ do\r
+ if exp(i).k > exp(j).k then\r
+ for h:=j to i-1\r
+ do\r
+ call echanger(exp(h),exp(i));\r
+ od;\r
+ trouve:=true;\r
+ else\r
+ j:=j+1;\r
+ fi;\r
+ od;\r
+ od;\r
+ fi;\r
+ end trie;\r
+\r
+ (*- D\82claration de l'Unit\82 SAISIE --------------*)\r
+ unit saisie:procedure;\r
+ var i:integer;\r
+ begin\r
+ write("Nombre d'El\82ments ... : ");\r
+ readln(nbr);\r
+ array exp dim (1:nbr);\r
+ for i:=1 to nbr\r
+ do\r
+ writeln("El\82ment Nø ",i:2," : ");\r
+ writeln("-------------");\r
+ exp(i):=new element;\r
+ call exp(i).saisie;\r
+ od;\r
+ call factorise;\r
+ end saisie;\r
+\r
+ (*- D\82claration de l'Unit\82 AFFICHE -------------*)\r
+ unit affiche:procedure;\r
+ var j:integer;\r
+ begin\r
+ if nbr > 0 then\r
+ write(" ");\r
+ for j:=1 to nbr\r
+ do\r
+ if exp(j).k=0 or exp(j).k=1 then\r
+ write(" ");\r
+ else\r
+ write(" ",exp(j).k:2);\r
+ fi;\r
+ od;\r
+ writeln;\r
+ write("Polynome de Nom ",nom," : ");\r
+ for j:=1 to nbr\r
+ do\r
+ if exp(j).a > 0 then\r
+ if exp(j).k=0 then\r
+ write("+",exp(j).a:5:2," ");\r
+ else\r
+ write("+",exp(j).a:5:2," x ");\r
+ fi;\r
+ else\r
+ if exp(j).k=0 then\r
+ write("-",-1*exp(j).a:5:2," ");\r
+ else\r
+ write("-",-1*exp(j).a:5:2," x ");\r
+ fi;\r
+ fi;\r
+ od;\r
+ else\r
+ writeln;\r
+ writeln("Polynome de Nom ",nom," : 0 ");\r
+ fi;\r
+ writeln;\r
+ end affiche;\r
+\r
+ (*- D\82claration de l'Unit\82 EVALUATION ----------*)\r
+ unit evaluation:function(x:integer):real;\r
+ var j:integer;\r
+ begin\r
+ result:=0;\r
+ for j:=1 to nbr\r
+ do\r
+ result:=result+exp(j).valeur(x);\r
+ od;\r
+ end evaluation;\r
+\r
+ (*- D\82claration de l'Unit\82 FACTORISE -----------*)\r
+ unit factorise:procedure;\r
+ var i,j:integer;\r
+\r
+ (*+ D\82claration de l'Unit\82 COMPACTE ++++++++++*)\r
+ unit compacte:procedure;\r
+ var b:arrayof element,\r
+ i,j:integer;\r
+ begin\r
+ j:=1;\r
+ for i:=1 to nbr\r
+ do\r
+ if exp(i) =/= none then\r
+ exp(j):=exp(i);\r
+ j:=j+1;\r
+ fi;\r
+ od;\r
+ nbr:=j-1;\r
+ if nbr > 0 then\r
+ array b dim (1:nbr);\r
+ for i:=1 to nbr\r
+ do\r
+ b(i):=exp(i);\r
+ od;\r
+ exp:=b;\r
+ fi;\r
+ end compacte;\r
+\r
+ begin\r
+ for i:=1 to nbr\r
+ do\r
+ for j:=i+1 to nbr\r
+ do\r
+ if exp(j) =/= none and exp(i) =/= none then\r
+ if exp(j).k=exp(i).k then\r
+ exp(i).a:=exp(i).a+exp(j).a;\r
+ kill(exp(j));\r
+ fi;\r
+ fi;\r
+ od;\r
+ if exp(i) =/= none then\r
+ if exp(i).a = 0 then\r
+ kill(exp(i));\r
+ fi;\r
+ fi;\r
+ od;\r
+ call compacte;\r
+ if exp =/= none then\r
+ call trie;\r
+ fi;\r
+ end factorise;\r
+\r
+ (*- D\82claration de l'Unit\82 DERIVE ------------*)\r
+ unit derive:function:polynome;\r
+ var i:integer;\r
+ begin\r
+ result:=new polynome;\r
+ result.nom:='R';\r
+ result.nbr:=nbr;\r
+ array result.exp dim (1:nbr);\r
+ for i:=1 to nbr\r
+ do\r
+ result.exp(i):=exp(i).derive;\r
+ od;\r
+ call result.factorise;\r
+ end derive;\r
+\r
+ end polynome;\r
+\r
+ (*==============================================*)\r
+ (*= D\82claration de l'Objet TABLE ===============*)\r
+ (*==============================================*)\r
+ unit table:class;\r
+ var pol:arrayof polynome;\r
+\r
+ (*- D\82claration de l'Unit\82 VIDE --------------*)\r
+ unit vide:function:boolean;\r
+ begin\r
+ result:= pol=none;\r
+ end vide;\r
+\r
+ (*- D\82claration de l'Unit\82 AFFMEM ------------*)\r
+ unit affmem:procedure;\r
+ var i:integer;\r
+ begin\r
+ if vide then\r
+ writeln("Aucun Polynome en M\82moire");\r
+ else\r
+ write("Les Polynomes en M\82moire sont : ");\r
+ for i:=1 to upper(pol)\r
+ do\r
+ write(pol(i).nom,", ");\r
+ od;\r
+ fi;\r
+ writeln;\r
+ end affmem;\r
+\r
+ (*- D\82claration de l'Unit\82 AFFICHE -----------*)\r
+ unit affiche:procedure;\r
+ var i:integer;\r
+ begin\r
+ if not vide then\r
+ for i:=1 to upper(pol)\r
+ do\r
+ call pol(i).affiche;\r
+ od;\r
+ else\r
+ writeln("Aucun Polynome en M\82moire");\r
+ fi;\r
+ writeln;\r
+ end affiche;\r
+\r
+ (*- D\82claration de l'Unit\82 NOMEXISTE ---------*)\r
+ unit nomexiste:function(input nom:char):boolean;\r
+ var i:integer;\r
+ begin\r
+ i:=0;\r
+ result:=false;\r
+ if not vide then\r
+ while i < upper(pol) and not result\r
+ do\r
+ i:=i+1;\r
+ if pol(i).nom=nom then\r
+ result:=true;\r
+ fi;\r
+ od;\r
+ fi;\r
+ end nomexiste;\r
+\r
+ (*- D\82claration de l'Unit\82 AJOUTE ------------*)\r
+ unit ajoute:procedure(input r:polynome);\r
+ var b:arrayof polynome,\r
+ i:integer;\r
+ begin\r
+ if vide then\r
+ array pol dim (1:1);\r
+ else\r
+ array b dim (1:upper(pol)+1);\r
+ for i:=1 to upper(pol)\r
+ do\r
+ b(i):=pol(i);\r
+ od;\r
+ pol:=b;\r
+ fi;\r
+ pol(upper(pol)):=r;\r
+ end ajoute;\r
+\r
+ (*- D\82claration de l'Unit\82 SAISIEPOL ---------*)\r
+ unit saisiepol:procedure;\r
+ var trouve:boolean,\r
+ r:polynome,\r
+ i:integer;\r
+ begin\r
+ call affmem;\r
+ r:=new polynome;\r
+ trouve:=true;\r
+ while trouve\r
+ do\r
+ write("Nom du Polynome ..... : ");\r
+ readln(r.nom);\r
+ trouve:=nomexiste(r.nom);\r
+ if trouve then\r
+ writeln("Le Nom ",r.nom," a d\82j\85 \82t\82 utilis\82...");\r
+ fi;\r
+ od;\r
+ call r.saisie;\r
+ writeln;\r
+ call r.affiche;\r
+ call ajoute(r);\r
+ end saisiepol;\r
+\r
+ (*- D\82claration de l'Unit\82 REMPLACERPAR ------*)\r
+ unit remplacerpar:procedure(input cible:polynome);\r
+ var i:integer,\r
+ trouve:boolean;\r
+ begin\r
+ i:=0;\r
+ while (i < upper(pol)) and not trouve\r
+ do\r
+ i:=i+1;\r
+ trouve:= pol(i).nom=cible.nom;\r
+ od;\r
+ if trouve then\r
+ kill(pol(i));\r
+ pol(i):=cible;\r
+ fi;\r
+ end remplacerpar;\r
+\r
+ (*- D\82claration de l'Unit\82 QUESTION ----------*)\r
+ unit question:procedure(inout r:polynome);\r
+ var choix:char,\r
+ trouve:boolean;\r
+ begin\r
+ if r.nbr > 0 then\r
+ choix:=' ';\r
+ while not (choix='o' or choix='O' or choix='n' or choix='N')\r
+ do\r
+ write("Desirez-vous sauvegarder ",r.nom," dans la Table (O ou N) : ");\r
+ readln(choix);\r
+ od;\r
+ if choix='o' or choix='O' then\r
+ trouve:=false;\r
+ while not trouve\r
+ do\r
+ write("Sous quel Nom : ");\r
+ readln(r.nom);\r
+ if nomexiste(r.nom) then\r
+ write(r.nom," D\82j\85 Utilis\82... Confirmation (O ou N) : ");\r
+ readln(choix);\r
+ if choix='o' or choix='O' then\r
+ trouve:=true;\r
+ call remplacerpar(r);\r
+ fi;\r
+ else\r
+ call ajoute(r);\r
+ trouve:=true;\r
+ fi;\r
+ od;\r
+ fi;\r
+ writeln;\r
+ fi;\r
+ end question;\r
+\r
+ (*- D\82claration de l'Unit\82 SELECTION ---------*)\r
+ unit selection:procedure(output p1:polynome);\r
+ var i:integer,\r
+ choix:char,\r
+ trouve,choisi:boolean;\r
+ begin\r
+ choisi:=false;\r
+ while not choisi\r
+ do\r
+ write("Votre choix : ");\r
+ readln(choix);\r
+ i:=0;\r
+ trouve:=false;\r
+ while i < upper(pol) and not trouve\r
+ do\r
+ i:=i+1;\r
+ trouve:= choix=pol(i).nom;\r
+ od;\r
+ if trouve then\r
+ p1:=pol(i);\r
+ choisi:=true;\r
+ fi;\r
+ od;\r
+ end selection;\r
+\r
+ (*- D\82claration de l'Unit\82 SELECTION2 --------*)\r
+ unit selection2:procedure(output p1,p2:polynome);\r
+ begin\r
+ writeln;\r
+ writeln("Polynome Nø 1 : ");\r
+ call selection(p1);\r
+ writeln;\r
+ writeln("Polynome Nø 2 : ");\r
+ call selection(p2);\r
+ call p1.affiche;\r
+ call p2.affiche;\r
+ end selection2;\r
+\r
+ (*- D\82claration de l'Unit\82 TRAITEMENT --------*)\r
+ unit traitement:procedure(function operation(p1,p2:polynome):polynome);\r
+ var r,p1,p2:polynome;\r
+ begin\r
+ call affmem;\r
+ if not vide then\r
+ call selection2(p1,p2);\r
+ r:=operation(p1,p2);\r
+ call r.affiche;\r
+ call question(r);\r
+ fi;\r
+ end traitement;\r
+\r
+ (*- D\82claration de l'Unit\82 DIVISION ----------*)\r
+ unit division:procedure;\r
+ var p1,p2,q,r:polynome;\r
+ begin\r
+ call affmem;\r
+ if not vide then\r
+ call selection2(p1,p2);\r
+ call divise(p1,p2,q,r);\r
+ call question(q);\r
+ call question(r);\r
+ fi;\r
+ end division;\r
+\r
+ end table;\r
+\r
+(**************************************************)\r
+(** D\82claration des Op\82rations : + - * / **********)\r
+(**************************************************)\r
+\r
+ (*==============================================*)\r
+ (*= D\82claration de l'Unit\82 PLUS ================*)\r
+ (*==============================================*)\r
+ unit plus:function(input a,b:polynome):polynome;\r
+ var i:integer;\r
+ begin\r
+ result:=new polynome;\r
+ result.nom:='R';\r
+ result.nbr:=a.nbr+b.nbr;\r
+ array result.exp dim (1:result.nbr);\r
+ for i:=1 to a.nbr\r
+ do\r
+ result.exp(i):=new element;\r
+ result.exp(i):=copy(a.exp(i));\r
+ od;\r
+ for i:=1 to b.nbr\r
+ do\r
+ result.exp(a.nbr+i):=new element;\r
+ result.exp(a.nbr+i):=copy(b.exp(i));\r
+ od;\r
+ call result.factorise;\r
+ end plus;\r
+\r
+ (*================================================*)\r
+ (*= D\82claration de l'Unit\82 MOINS =================*)\r
+ (*================================================*)\r
+ unit moins:function(input a,b:polynome):polynome;\r
+ var i:integer;\r
+ begin\r
+ result:=new polynome;\r
+ result.nom:='R';\r
+ result.nbr:=a.nbr+b.nbr;\r
+ array result.exp dim (1:result.nbr);\r
+ for i:=1 to a.nbr\r
+ do\r
+ result.exp(i):=new element;\r
+ result.exp(i):=copy(a.exp(i));\r
+ od;\r
+ for i:=1 to b.nbr\r
+ do\r
+ result.exp(a.nbr+i):=b.exp(i).mult(-1,0);\r
+ od;\r
+ call result.factorise;\r
+ end moins;\r
+\r
+ (*=================================================*)\r
+ (*= D\82claration de l'Unit\82 MULTIPL ================*)\r
+ (*=================================================*)\r
+ unit multipl:function(input a,b:polynome):polynome;\r
+ var i,j,ind:integer;\r
+ begin\r
+ result:=new polynome;\r
+ result.nom:='R';\r
+ result.nbr:=a.nbr*b.nbr;\r
+ array result.exp dim (1:result.nbr);\r
+ ind:=1;\r
+ for i:=1 to a.nbr\r
+ do\r
+ for j:=1 to b.nbr\r
+ do\r
+ result.exp(ind):=a.exp(i).mult(b.exp(j).a,b.exp(j).k);\r
+ ind:=ind+1;\r
+ od;\r
+ od;\r
+ call result.factorise;\r
+ end multipl;\r
+\r
+ (*================================================*)\r
+ (*= D\82claration de l'Unit\82 DIVISE ================*)\r
+ (*================================================*)\r
+ unit divise:procedure(input p1,p2:polynome;output quotient,r:polynome);\r
+ var q:polynome,\r
+ fin:boolean;\r
+ begin\r
+ quotient:=new polynome;\r
+ quotient.nbr:=0;\r
+ q:=new polynome;\r
+ array q.exp dim (1:1);\r
+ q.nbr:=1;\r
+ r:=new polynome;\r
+ r:=copy(p1);\r
+ fin:=false;\r
+ while not fin\r
+ do\r
+ if r.exp(1).k >= p2.exp(1).k then\r
+ q.exp(1):=r.exp(1).mult(1/p2.exp(1).a,-1*p2.exp(1).k);\r
+ r:=moins(r,multipl(p2,q));\r
+ quotient:=plus(quotient,q);\r
+ fin:= r.nbr=0;\r
+ else\r
+ fin:=true;\r
+ fi;\r
+ od;\r
+ quotient.nom:='Q';\r
+ writeln;\r
+ writeln(" Q : Quotient de la Division, R : Reste de la Division.");\r
+ call quotient.affiche;\r
+ call r.affiche;\r
+ end divise;\r
+\r
+(****************************************************)\r
+(** D\82claration de l'Unit\82 de Gestion de l'Ecran ****)\r
+(****************************************************)\r
+\r
+ (*================================================*)\r
+ (*= D\82claration de l'Unit\82 GESTION ===============*)\r
+ (*================================================*)\r
+ unit gestion:class;\r
+\r
+ (*- D\82claration de l'Unit\82 CLS -----------------*)\r
+ unit cls:procedure;\r
+ begin\r
+ write(chr(27),"[2J");\r
+ end cls;\r
+\r
+ (*- D\82claration de l'Unit\82 ATTEND ---------------*)\r
+ unit attend:procedure;\r
+ var c:integer;\r
+ begin\r
+ writeln;\r
+ write(" Appuyez sur < ENTER > pour Continuer ");\r
+ readln;\r
+ end attend;\r
+\r
+ end gestion;\r
+\r
+(****************************************************)\r
+(* D\82claration des Unit\82es correspondant ************)\r
+(* aux diverses Options du Menu Principal. **********)\r
+(****************************************************)\r
+\r
+ (*= OPTION 1 =====================================*)\r
+ (*= Saisie d'un Nouveau Polynome =================*)\r
+ (*================================================*)\r
+ unit option1:procedure(g:gestion;inout a:table);\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Saisie de Polynomes =========");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.saisiepol;\r
+ call g.attend;\r
+ end option1;\r
+\r
+ (*= OPTION 2 =====================================*)\r
+ (*= Affichage de la Table des Polynomes ==========*)\r
+ (*================================================*)\r
+ unit option2:procedure(g:gestion;input a:table);\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Affichage des Polynomes =====");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.affiche;\r
+ call g.attend;\r
+ end option2;\r
+\r
+ (*= OPTION 3 =====================================*)\r
+ (*= Evaluation d'un Polynome pour un x Donn\82 =====*)\r
+ (*================================================*)\r
+ unit option3:procedure(g:gestion;input a:table);\r
+ var x:real,\r
+ r:polynome;\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Evaluation de Polynome ======");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.affmem;\r
+ if not a.vide then\r
+ call a.selection(r);\r
+ writeln;\r
+ call r.affiche;\r
+ write("Entrez la valeur de x : ");\r
+ readln(x);\r
+ writeln;\r
+ writeln("Resultat : ",r.evaluation(x):9:2);\r
+ fi;\r
+ call g.attend;\r
+ end option3;\r
+\r
+ (*= OPTION 4 =====================================*)\r
+ (*= Addition de Deux Polynomes de la Table =======*)\r
+ (*================================================*)\r
+ unit option4:procedure(g:gestion;inout a:table);\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Addition de Polynome ========");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.traitement(plus);\r
+ call g.attend;\r
+ end option4;\r
+\r
+ (*= OPTION 5 =====================================*)\r
+ (*= Soustraction de Deux Polynomes de la Table ===*)\r
+ (*================================================*)\r
+ unit option5:procedure(g:gestion;inout a:table);\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Soustraction de Polynome ====");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.traitement(moins);\r
+ call g.attend;\r
+ end option5;\r
+\r
+ (*= OPTION 6 =====================================*)\r
+ (*= Multiplication de Deux Polynomes de la Table =*)\r
+ (*================================================*)\r
+ unit option6:procedure(g:gestion;inout a:table);\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Multiplication de Polynomes =");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.traitement(multipl);\r
+ call g.attend;\r
+ end option6;\r
+\r
+ (*= OPTION 7 ===================================*)\r
+ (*= Division de Deux Polynomes de la Table =====*)\r
+ (*==============================================*)\r
+ unit option7:procedure(g:gestion;inout a:table);\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Division de Polynomes =========");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.division;\r
+ call g.attend;\r
+ end option7;\r
+\r
+ (*= OPTION 8 ===================================*)\r
+ (*= D\82rivation d'un Polynome de la Table =======*)\r
+ (*==============================================*)\r
+ unit option8:procedure(g:gestion;inout a:table);\r
+ var p1,r:polynome;\r
+ begin\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Derivation d'un Polynome ====");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ call a.affmem;\r
+ if not a.vide then\r
+ call a.selection(p1);\r
+ writeln;\r
+ call p1.affiche;\r
+ r:=p1.derive;\r
+ call r.affiche;\r
+ call a.question(r);\r
+ fi;\r
+ call g.attend;\r
+ end option8;\r
+\r
+(****************************************************)\r
+(** Instructions du Programme Principal *************)\r
+(****************************************************)\r
+\r
+begin\r
+ g:=new gestion;\r
+ t:=new table;\r
+ fini:=false;\r
+ while not fini\r
+ do\r
+ call g.cls;\r
+ writeln("==========================================================");\r
+ writeln("= STRUCTURE DE POLYNOMES : Menu Principal ==============");\r
+ writeln("==========================================================");\r
+ writeln;\r
+ writeln;\r
+ writeln(" Options Disponibles : ");\r
+ writeln(" ------------------- ");\r
+ writeln;\r
+ writeln(" Saisie d'un Polynome ...................... : 1 ");\r
+ writeln(" Visualisation de la Table des Polynomes ... : 2 ");\r
+ writeln(" Evaluation d'un Polynome pour un x donn\82 .. : 3 ");\r
+ writeln(" Additionner des Polynomes ................. : 4 ");\r
+ writeln(" Soustraire des Polynomes .................. : 5 ");\r
+ writeln(" Multiplier des Polynomes .................. : 6 ");\r
+ writeln(" Diviser des Polynomes ..................... : 7 ");\r
+ writeln(" D\82river un Polynome ....................... : 8 ");\r
+ writeln(" Retour au Syst\8ame d'Exploitation .......... : 9 ");\r
+ writeln;\r
+ write(" Votre Choix : ");\r
+ readln(choix);\r
+ case choix\r
+ when 1 : call option1(g,t);\r
+ when 2 : call option2(g,t);\r
+ when 3 : call option3(g,t);\r
+ when 4 : call option4(g,t);\r
+ when 5 : call option5(g,t);\r
+ when 6 : call option6(g,t);\r
+ when 7 : call option7(g,t);\r
+ when 8 : call option8(g,t);\r
+ when 9 : fini:=true;\r
+ esac\r
+ od;\r
+ call g.cls;\r
+end projet;\r
+(****************************************************)\r
+\1a
\ No newline at end of file
--- /dev/null
+K\82
\ No newline at end of file
--- /dev/null
+K\82
\ No newline at end of file
--- /dev/null
+PROGRAM BIBLIOTHEQUE;\r
+\r
+SIGNAL Del_Rec_Inexistant, Key_AlReady_In_Index,\r
+ TreeHeight_Overflow, Signal11, Signal12, Signal14;\r
+ \r
+(*-------------------------------------------------*)\r
+(* MODULE de GESTION des FICHIERS de l'application *)\r
+(*-------------------------------------------------*)\r
+UNIT FileSystem: CLASS;\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* CLASSE representant la FILE des FICHIERS de l'application *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT RFile: CLASS;\r
+ VAR Name: ARRAYOF CHAR,\r
+ Opened: BOOLEAN,\r
+ RecLen, Position,\r
+ Length: INTEGER,\r
+ Fichier: file,\r
+ Next, Prev: RFile\r
+ END RFile;\r
+ \r
+ VAR System: RFile; (* FICHIER manipule lors des differentes operations *)\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* RECHERCHE d'un FICHIER dans les FICHIERS de l'APPLICATION *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT FindInSystem : FUNCTION(Name:ARRAYOF CHAR): RFile;\r
+ \r
+ (*-------------------------------------------*)\r
+ (* COMPARAISON de deux CHAINES de caracteres *)\r
+ (*-------------------------------------------*)\r
+ UNIT EqualString: FUNCTION(chaine1, chaine2: ARRAYOF CHAR):BOOLEAN;\r
+ VAR i1, i2, len, i: INTEGER;\r
+ BEGIN\r
+ IF (chaine1 = NONE) OR (chaine2 = NONE)\r
+ THEN writeln("Un parametre est egal a NONE dans EqualString");\r
+ CALL ENDRUN (* ARRET du programme *)\r
+ FI;\r
+ i1 := LOWER(chaine1); i2 := LOWER(chaine2);\r
+ len := UPPER(chaine1) - i1 + 1;\r
+ IF len =/= UPPER(chaine2) - i2 + 1\r
+ THEN RETURN (* Chaines de longueurs differentes *)\r
+ FI;\r
+ FOR i := 1 TO len\r
+ DO\r
+ IF chaine1(i1) =/= chaine2(i2)\r
+ THEN RETURN (* Chaines differentes *)\r
+ FI;\r
+ i1 := i1 + 1; i2 := i2 + 1\r
+ OD;\r
+ (* Si on arrive la les chaines sont egales *)\r
+ RESULT := TRUE\r
+ END EqualString;\r
+ \r
+ VAR df :RFile;\r
+ \r
+ BEGIN\r
+ System.Name := Name;\r
+ df := System.Next;\r
+ WHILE NOT EqualString(Name,df.Name)\r
+ DO\r
+ df := df.Next\r
+ OD;\r
+ IF (df = System)\r
+ THEN RESULT := NONE\r
+ ELSE RESULT := df\r
+ FI;\r
+ END FindInSystem;\r
+ \r
+ (*-------------------------------------------*)\r
+ (* AJOUT d'un Fichier a la FILE des FICHIERS *)\r
+ (*-------------------------------------------*)\r
+ UNIT AddToSystem: FUNCTION(Name: ARRAYOF CHAR): RFile;\r
+ BEGIN\r
+ RESULT := NEW RFile;\r
+ RESULT.Name := Name;\r
+ RESULT.Next := System.Next;\r
+ RESULT.Prev := System;\r
+ System.Next.Prev := RESULT;\r
+ System.Next := RESULT;\r
+ END AddToSystem;\r
+ \r
+ (*----------------------------------------------*)\r
+ (* SUPPRIMER un FICHIER de la FILE des FICHIERS *)\r
+ (*----------------------------------------------*)\r
+ UNIT DeleteFromSystem: PROCEDURE(df:RFile);\r
+ BEGIN\r
+ IF df = System\r
+ THEN RETURN\r
+ FI;\r
+ df.Next.Prev := df.Prev;\r
+ df.Prev.Next := df.Next\r
+ END DeleteFromSystem;\r
+ \r
+ (*-------------------------------------------------------------------------*)\r
+ (* CALCUL de la LONGUEUR d'un Fichier exprime en nombres d'enregistrements *)\r
+ (*-------------------------------------------------------------------------*)\r
+ UNIT FindFileLength: FUNCTION(df :file, RecLen :INTEGER) :INTEGER;\r
+ VAR record: ARRAYOF INTEGER, i:INTEGER;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR FindFileLength : Fichier inexistant");\r
+ RETURN;\r
+ FI;\r
+ RESULT := 1;\r
+ CALL RESET(df);\r
+ ARRAY record DIM (1:RecLen);\r
+ i := RecLen*INTSIZE;\r
+ DO\r
+ GETREC(df,record,i);\r
+ IF i =/= RecLen*INTSIZE\r
+ THEN EXIT\r
+ FI;\r
+ RESULT := RESULT + 1;\r
+ OD;\r
+ END FindFileLength;\r
+ \r
+ \r
+ (*-----------------------------------------------------------------------*)\r
+ (* CREATION d'un nouveau FICHIER et insertion de ce Fichier dans la FILE *)\r
+ (* le Fichier est ouvert est sa longueur est egal a 1 *)\r
+ (*-----------------------------------------------------------------------*)\r
+ UNIT MakeFile: FUNCTION(Name: ARRAYOF CHAR, RecLen: INTEGER): RFile;\r
+ BEGIN\r
+ IF FindInSystem(Name) =/= NONE\r
+ THEN writeln("ERREUR MakeFile : Fichier existant");\r
+ FI;\r
+ IF RecLen <= 0\r
+ THEN writeln("ERREUR MakeFile : Longueur de Fichier doit etre positive");\r
+ FI;\r
+ RESULT := AddToSystem(Name);\r
+ RESULT.Opened := TRUE;\r
+ RESULT.RecLen := RecLen;\r
+ RESULT.Position := 1;\r
+ RESULT.Length := 1;\r
+ OPEN(RESULT.Fichier, direct, Name);\r
+ CALL REWRITE(RESULT.Fichier);\r
+ END MakeFile;\r
+ \r
+ (*------------------------------------------------------------------*)\r
+ (* OUVRIR un Fichier deja present dans la FILE des FICHIERS *)\r
+ (* ou AJOUT de ce FICHIER a la FILE si il n'y est pas. *)\r
+ (*------------------------------------------------------------------*)\r
+ UNIT OpenFile: FUNCTION(Name: ARRAYOF CHAR, RecLen: INTEGER): RFile;\r
+ BEGIN\r
+ IF RecLen <= 0\r
+ THEN writeln("ERREUR OpenFile : La longueur d'enregistrement doit etre\r
+ positive");\r
+ FI;\r
+ RESULT := FindInSystem(Name);\r
+ IF RESULT = NONE\r
+ THEN RESULT := AddToSystem(Name)\r
+ FI;\r
+ RESULT.Opened := TRUE;\r
+ RESULT.RecLen := RecLen;\r
+ RESULT.Position := 1;\r
+ OPEN(RESULT.Fichier,direct,Name);\r
+ RESULT.Length := FindFileLength(RESULT.Fichier,RecLen);\r
+ IF RESULT.Length = 1\r
+ THEN CALL REWRITE(RESULT.Fichier) (* Le FICHIER est VIDE *)\r
+ ELSE CALL RESET(RESULT.Fichier) FI; (* Le FICHIER n'est pas VIDE *)\r
+ END OpenFile;\r
+ \r
+ (*--------------------------------------------*)\r
+ (* FERMETURE d'un fichier ouvert par OpenFile *)\r
+ (*--------------------------------------------*)\r
+ UNIT CloseFile: PROCEDURE (df :RFile);\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR CloseFile : Fichier inexistant");\r
+ FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("ERREUR CloseFile : Fermeture d'un fichier pas ouvert");\r
+ FI;\r
+ df. Opened := FALSE;\r
+ KILL(df.fichier)\r
+ END CloseFile;\r
+ \r
+ (*-------------------------------*)\r
+ (* TEST si un FICHIER est OUVERT *)\r
+ (*-------------------------------*)\r
+ UNIT IsOpen: FUNCTION(df :RFile) :BOOLEAN;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR IsOpen : Fichier inexistant");\r
+ FI;\r
+ RESULT := df.Opened\r
+ END IsOpen;\r
+ \r
+ (*----------------------------------------------------*)\r
+ (* MISE a 1 de la POSITION de LECTURE dans le FICHIER *)\r
+ (*----------------------------------------------------*)\r
+ UNIT Frewind: PROCEDURE(df :RFile);\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("Frewind : Fichier inexistant");\r
+ FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("Frewind : Fichier pas ouvert");\r
+ FI;\r
+ df.Position := 1;\r
+ CALL RESET(df.Fichier)\r
+ END Frewind;\r
+ \r
+ (*----------------------------------*)\r
+ (* TEST si on est en fin de FICHIER *)\r
+ (*----------------------------------*)\r
+ UNIT Feof: FUNCTION(df: RFile): BOOLEAN;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("Feof : Fichier inexistant");\r
+ FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("Feof : Fichier pas ouvert");\r
+ FI;\r
+ RESULT := ( df.Position >= df.Length )\r
+ END Feof;\r
+ \r
+ (*----------------------------------------------*)\r
+ (* ECRITURE d'un enregistrement dans le fichier *)\r
+ (*----------------------------------------------*)\r
+ UNIT Fput: PROCEDURE(df :RFile, Record :ARRAYOF INTEGER);\r
+ VAR nbint, i : INTEGER;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR Fput : Fichier inexistant");\r
+ CALL ENDRUN; (* FIN du PROGRAMME *)\r
+ FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("ERREUR Fput : Fichier pas ouvert"); FI;\r
+ IF df.Position > df.Length\r
+ THEN writeln("ERREUR Fput : Tentative d'acces apres la fin de fichier");\r
+ FI;\r
+ IF Record = NONE\r
+ THEN writeln("ERREUR Fput : Enregistrement inexistant");\r
+ FI;\r
+ nbint := UPPER(Record) - LOWER(Record) + 1;\r
+ IF nbint =/= df.RecLen\r
+ THEN writeln("ERREUR Fput : Taille enregistrement incorrect") FI;\r
+ i := nbint * intsize;\r
+ PUTREC(df.Fichier, Record, i);\r
+ IF i =/= nbint * intsize\r
+ THEN writeln("ERREUR Fput : ERREUR durant l'ecriture") FI;\r
+ (* MODIFICATION de la POSITION de LECTURE du FICHIER et de la LONGUEUR\r
+ eventuellement du FICHIER *)\r
+ df.Position := df.Position + 1;\r
+ IF df.Position > df.Length\r
+ THEN df.Length := df.Position\r
+ FI;\r
+ END Fput;\r
+ \r
+ (*---------------------------------------------*)\r
+ (* LECTURE d'un ENREGISTREMENT dans le FICHIER *)\r
+ (*---------------------------------------------*)\r
+ UNIT Fget: FUNCTION(df :RFile): ARRAYOF INTEGER;\r
+ VAR Record: ARRAYOF INTEGER,\r
+ nbint, i : INTEGER;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR Fget : Fichier inexistant"); FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("ERREUR Fget : Fichier pas ouvert"); FI;\r
+ IF df.Position >= df.Length\r
+ THEN writeln("ERREUR Fget : Tentative lecture apres la fin de fichier");\r
+ FI;\r
+ nbint := df.RecLen;\r
+ ARRAY Record dim (1:nbint);\r
+ i := nbint * intsize;\r
+ GETREC(df.Fichier, Record, i);\r
+ IF i =/= nbint * intsize\r
+ THEN writeln("ERREUR Fget : Erreur durant la lecture");\r
+ FI;\r
+ df.Position := df.Position + 1;\r
+ RESULT := Record;\r
+ END Fget;\r
+ \r
+ (*------------------------------------------------------------------------*)\r
+ (* DEPLACEMENT dans le fichier a la Position du NUMRECieme ENREGISTREMENT *)\r
+ (*------------------------------------------------------------------------*)\r
+ UNIT Fseek: PROCEDURE(df :RFile, numrec :INTEGER);\r
+ VAR offset: INTEGER;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR Fseek : Fichier inexistant");\r
+ FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("ERREUR Fseek : Fichier non ouvert");\r
+ FI;\r
+ IF numrec <= 0\r
+ THEN writeln("ERREUR Fseek : Numero de record doit etre positif");\r
+ FI;\r
+ IF numrec > df.Length\r
+ THEN writeln("ERREUR Fseek : Tentative d'acces apres la fin de fichier");\r
+ FI;\r
+ df.Position := numrec;\r
+ offset := (numrec - 1) * df.RecLen * intsize;\r
+ CALL seek(df.Fichier, offset, 0)\r
+ END Fseek;\r
+ \r
+ (*-------------------------------------------------------*)\r
+ (* INDIQUE la POSITION COURANTE dans le FICHIER specifie *)\r
+ (*-------------------------------------------------------*)\r
+ UNIT Position: FUNCTION(df :RFile) :INTEGER;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR Position : Fichier inexistant") FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("ERREUR Position : Fichier pas ouvert") FI;\r
+ RESULT := df.Position\r
+ END Position;\r
+ \r
+ (*-----------------------------------------*)\r
+ (* INDIQUE la LONGUEUR du FICHIER specifie *)\r
+ (*-----------------------------------------*)\r
+ UNIT FileLen: FUNCTION(df :RFile) :INTEGER;\r
+ BEGIN\r
+ IF df = NONE\r
+ THEN writeln("ERREUR FileLen : Fichier inexistant") FI;\r
+ IF NOT df.Opened\r
+ THEN writeln("ERREUR FileLen : Fichier pas ouvert") FI;\r
+ RESULT := df.Length\r
+ END FileLen;\r
+ \r
+BEGIN (* FileSystem *)\r
+ System := NEW RFile;\r
+ System.Next, System.Prev := System;\r
+END FileSystem;\r
+ \r
+\r
+\r
+\r
+(*------------------------------------------------------*)\r
+(* MODULE contenant la declaration d'une BASE de DONNEE *)\r
+(* c.a.d. : RELATION, FICHIER DONNEES, FICHIER INDEX *)\r
+(*------------------------------------------------------*)\r
+UNIT HandlerOfRelations:FileSystem CLASS(PageSize, TreeHeight,\r
+ HalfPageSize : INTEGER);\r
+ \r
+ (*-----------------------------------------------------*)\r
+ (* MODULE GENERIQUE d'un FICHIER de DONNEES de la BASE *)\r
+ (*-----------------------------------------------------*)\r
+ UNIT DataFile :CLASS;\r
+ VAR df :RFile; (* DESCRIPTEUR du FICHIER *)\r
+ VAR FreePlace:INTEGER; (* POSITION du dernier EMPLACEMENT LIBRE *)\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* DEPLACEMENT de la POSITION de LECTURE du fichier au DEBUT *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT Reset:PROCEDURE;\r
+ BEGIN CALL Fseek(df,1) END Reset;\r
+ \r
+ (*-------------------------------------------------*)\r
+ (* AJOUT au fichier de DONNEES d'un enregistrement *)\r
+ (*-------------------------------------------------*)\r
+ UNIT AddRec : PROCEDURE(Rec :ARRAYOF INTEGER;OUTPUT DataRef :INTEGER);\r
+ VAR AuxRec: ARRAYOF INTEGER; (* Tableau auxiliaire pour lire la Position\r
+ du nouvel emplacement libre *)\r
+ BEGIN\r
+ IF FreePlace=0\r
+ THEN (* AJOUT en FIN de fFICHIER *)\r
+ DataRef:=FileLen(df);\r
+ ELSE (* AJOUT a l'EMPLACEMENT LIBRE *)\r
+ DataRef:=FreePlace;\r
+ CALL Fseek(df,DataRef);\r
+ ARRAY AuxRec dim(LOWER(Rec):UPPER(Rec));\r
+ AuxRec:=Fget(df);\r
+ FreePlace:=AuxRec(1); (* NOUVEL EMPLACEMENT LIBRE *)\r
+ FI;\r
+ (* ECRITURE de l'enregistrement *)\r
+ CALL Fseek(df,DataRef);\r
+ CALL Fput(df,Rec)\r
+ END AddRec;\r
+ \r
+ (*-------------------------------------------------------*)\r
+ (* SUPPRESSION du fichier de DONNEES d'un enregistrement *)\r
+ (*-------------------------------------------------------*)\r
+ UNIT DelRec: PROCEDURE(DataRef :INTEGER);\r
+ VAR AuxRec: ARRAYOF INTEGER;\r
+ BEGIN\r
+ CALL Fseek(df,DataRef);\r
+ ARRAY AuxRec dim (1:df.RecLen);\r
+ AuxRec(1):=FreePlace;\r
+ CALL Fput(df,AuxRec);\r
+ FreePlace:=DataRef (* NOUVEL EMPLACEMENT LIBRE *)\r
+ END DelRec;\r
+ \r
+ (*--------------------------------------------------------------*)\r
+ (* RECHERCHE d'un ENREGISTREMENT dans le FICHIER de DONNEES *)\r
+ (* renvoie sa Position dans le fichier ou -1 si il n'y est pas. *)\r
+ (*--------------------------------------------------------------*)\r
+ UNIT FindRec:PROCEDURE(Rec :ARRAYOF INTEGER;OUTPUT DataRef :INTEGER);\r
+ VAR AuxRec: ARRAYOF INTEGER,\r
+ i, Place: INTEGER,\r
+ trouve : BOOLEAN;\r
+ BEGIN\r
+ ARRAY AuxRec DIM(LOWER(Rec):UPPER(Rec));\r
+ CALL Reset;\r
+ WHILE (NOT Feof(df) AND NOT trouve)\r
+ DO\r
+ DataRef := Position(df);\r
+ AuxRec:= Fget(df);\r
+ FOR i:=LOWER(AuxRec) TO UPPER(AuxRec)\r
+ DO\r
+ trouve := (AuxRec(i)=Rec(i));\r
+ IF NOT trouve\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ IF (trouve AND FreePlace <> 0)\r
+ THEN (* RECHERCHE SI ce n'est pas un enregistrement EFFACE\r
+ qui correspond au tuple *)\r
+ Place:=FreePlace;\r
+ WHILE NOT Place=0 (* POUR CHAQUE emplacement LIBRE *)\r
+ DO\r
+ IF DataRef = Place\r
+ THEN trouve := FALSE;\r
+ EXIT\r
+ ELSE CALL Fseek(df,Place);\r
+ AuxRec:=Fget(df);\r
+ Place:=AuxRec(1)\r
+ FI\r
+ OD;\r
+ (* REPOSITIONNEMENT TETE de LECTURE *)\r
+ CALL Fseek(df,DataRef+df.RecLen)\r
+ FI\r
+ OD;\r
+ IF NOT trouve\r
+ THEN (* L'ENREGISTREMENT n'est pas dans le FICHIER *)\r
+ DataRef:=-1\r
+ FI;\r
+ END FindRec;\r
+ \r
+ BEGIN\r
+ FreePlace:=0 (* AUCUN EMPLACEMENT LIBRE a la creation *)\r
+ END DataFile;\r
+ \r
+ (*-------------------------------------------------------*)\r
+ (* MODULE GENERIQUE d'une relation de la BASE DE DONNEES *)\r
+ (*-------------------------------------------------------*)\r
+ UNIT Relation : DataFile CLASS ;\r
+ VAR Indexs :ARRAYOF IndexFile; (* Tableau des INDEXs lies au fichier de\r
+ donnees *)\r
+ (*---------------------------------*)\r
+ (* CLASSE generique d'une RELATION *)\r
+ (*---------------------------------*)\r
+ UNIT Tuple : CLASS;\r
+ END Tuple;\r
+ \r
+ (*-------------------------------------------------------*)\r
+ (* FONCTION GENERIQUE de conversion d'une relation en *)\r
+ (* TABLEAU d'ENTIERS pour la sauvegarde dans un fichier. *)\r
+ (*-------------------------------------------------------*)\r
+ UNIT VIRTUAL TupleToArray:FUNCTION(T: Tuple):ARRAYOF INTEGER;\r
+ BEGIN\r
+ END TupleToArray;\r
+ \r
+ (*---------------------------------------------------------*)\r
+ (* FONCTION GENERIQUE de conversion d'un tableau d'entiers *)\r
+ (* en objet de type TUPLE. *)\r
+ (*---------------------------------------------------------*)\r
+ UNIT VIRTUAL ArrayToTuple : FUNCTION(A :ARRAYOF INTEGER):Tuple;\r
+ END ArrayToTuple;\r
+ \r
+ (*--------------------------------------------*)\r
+ (* INSERTION d'un TUPLE au FICHIER de DONNEES *)\r
+ (*--------------------------------------------*)\r
+ UNIT InsertTuple :PROCEDURE(T: Tuple);\r
+ VAR AuxRec : ARRAYOF INTEGER,\r
+ i,DataRef:INTEGER;\r
+ BEGIN\r
+ AuxRec := TupleToArray(T);\r
+ (* AJOUT au FICHIER de DONNEES *)\r
+ CALL AddRec(AuxRec,DataRef);\r
+ IF Indexs <> NONE\r
+ THEN (* Pour chaque INDEX lie a la RELATION *)\r
+ (* MISE a JOUR *)\r
+ FOR i:=1 TO UPPER(Indexs)\r
+ DO\r
+ IF Indexs(i)<>NONE\r
+ THEN (* AJOUT d'une NOUVELLE CLE *)\r
+ CALL Indexs(i).AddKey(Indexs(i).KeyOf(T),DataRef)\r
+ FI\r
+ OD\r
+ FI;\r
+ END InsertTuple;\r
+ \r
+ (*----------------------------------------------*)\r
+ (* SUPPRESSION d'un TUPLE du FICHIER de DONNEES *)\r
+ (*----------------------------------------------*)\r
+ UNIT DeleteTuple :PROCEDURE(T: Tuple);\r
+ VAR AuxRec :ARRAYOF INTEGER,\r
+ i,DataRef :INTEGER;\r
+ BEGIN\r
+ (* RECHERCHE de la POSITION du tuple dans la BASE a partir *)\r
+ (* de l'INDEX PRIMAIRE Indexs(1). *)\r
+ DataRef := Indexs(1).FindKey(Indexs(1).KeyOf(T));\r
+ CALL Indexs(1).DelKey(Indexs(1).KeyOf(T),DataRef);\r
+ (* LECTURE du TUPLE dans la BASE *)\r
+ CALL Fseek(df,DataRef);\r
+ AuxRec := Fget(df);\r
+ (* SUPRESSION du tuple de la BASE *)\r
+ CALL DelRec(DataRef);\r
+ (* SUPPRESSION des differentes CLES dans les autres indexs *)\r
+ FOR i:=UPPER(Indexs) DOWNTO 2\r
+ DO\r
+ CALL Indexs(i).DelKey(Indexs(i).KeyOf(T),DataRef)\r
+ OD\r
+ END DeleteTuple;\r
+ \r
+ (*---------------------------------*)\r
+ (* RECHERCHE d'un TUPLE de la BASE *)\r
+ (*---------------------------------*)\r
+ UNIT FindTuple :PROCEDURE(T: Tuple;OUTPUT Position : INTEGER);\r
+ VAR AuxRec :ARRAYOF INTEGER,\r
+ i,DataRef :INTEGER;\r
+ BEGIN\r
+ AuxRec := TupleToArray(T);\r
+ CALL FindRec(AuxRec,DataRef);\r
+ Position := DataRef;\r
+ END FindTuple;\r
+ \r
+ (*-------------------------------------------------------------*)\r
+ (* MODULE GENERIQUE d'un FICHIER d'INDEX de la BASE de DONNEES *)\r
+ (* implemente sous forme de B ARBRE. *)\r
+ (*-------------------------------------------------------------*)\r
+ UNIT IndexFile:DataFile COROUTINE;\r
+ \r
+ (*---------------------------------------------------------------*)\r
+ (* PAGE contenu dans le B ARBRE est qui est le type des ELEMENTS *)\r
+ (* SAUVEGARDES sur le FICHIER. *)\r
+ (*---------------------------------------------------------------*)\r
+ UNIT Page:CLASS;\r
+ VAR ItemsOnPage, (* NOMBRES de PAGES FILLES *)\r
+ LessPageRef :INTEGER, (* POSITION dans le FICHIER de la PAGE des\r
+ cles INFERIEURES a la PREMIERE cle de\r
+ celui-ci. *)\r
+ ItemsArray :ARRAYOF Item; (* TABLEAU des cles contenues dans cette\r
+ PAGE *)\r
+ BEGIN\r
+ ARRAY ItemsArray dim (1:PageSize)\r
+ END Page;\r
+ \r
+ \r
+ (*-------------------------------------------------------------*)\r
+ (* FONCTION de CONVERSION d'un enregistrement du FICHIER INDEX *)\r
+ (* en page du B-arbre correspondant. *)\r
+ (*-------------------------------------------------------------*)\r
+ UNIT RecToPage:FUNCTION(A :ARRAYOF INTEGER) :Page;\r
+ VAR P :Page,\r
+ It :Item,\r
+ i, j :INTEGER;\r
+ BEGIN\r
+ P:=NEW Page;\r
+ P.ItemsOnPage,j := A(1);\r
+ P.LessPageRef := A(2);\r
+ ARRAY P.ItemsArray dim (1:PageSize);\r
+ FOR i := 1 TO j\r
+ DO\r
+ It := NEW Item;\r
+ It.ky := RecToKey(A, 3+(i-1)*(KeySize+2) ) ;\r
+ It.PageRef := A(i*(KeySize+2)+1);\r
+ It.DataRef := A(i*(KeySize+2)+2);\r
+ P.ItemsArray(i) := It;\r
+ OD;\r
+ RESULT :=P\r
+ END RecToPage;\r
+ \r
+ (*----------------------------------------------------------------*)\r
+ (* FONCTION de CONVERSION d'une PAGE du B-ARBRE en enregistrement *)\r
+ (* du FICHIER INDEX correspondant. *)\r
+ (*----------------------------------------------------------------*)\r
+ UNIT PageToRec : FUNCTION (P: Page): ARRAYOF INTEGER;\r
+ VAR AuxRec : ARRAYOF INTEGER,\r
+ It: Item,\r
+ i : INTEGER;\r
+ BEGIN\r
+ ARRAY AuxRec dim(1:(PageSize*(KeySize+2)+2));\r
+ AuxRec(1) := P.ItemsOnPage;\r
+ AuxRec(2) := P.LessPageRef;\r
+ FOR i := 1 TO P.ItemsOnPage\r
+ DO\r
+ It:=P.ItemsArray(i);\r
+ CALL KeyToRec(It.ky,AuxRec, 3+(i-1)*(KeySize+2) );\r
+ AuxRec(i*(KeySize+2)+1) := It.PageRef;\r
+ AuxRec(i*(KeySize+2)+2) := It.DataRef;\r
+ OD;\r
+ RESULT := AuxRec\r
+ END PageToRec;\r
+ \r
+ UNIT Item : CLASS ;\r
+ VAR ky: key, (* CLE du tuple concerne *)\r
+ PageRef, (* POSITION dans le FICHIER INDEX de la PAGE RACINE\r
+ contenant les CLES SUPERIEURES a ce tuple ci *)\r
+ DataRef :INTEGER; (* POSITION dans le FICHIER de DONNEES du tuple\r
+ concerne *)\r
+ END Item;\r
+ \r
+ (*------------------------------------------------------------------*)\r
+ (* MODULE GENERIQUE de CLE de TUPLE defini ulterieurement dans les *)\r
+ (* classes heritantes. *)\r
+ (*------------------------------------------------------------------*)\r
+ UNIT Key : CLASS;\r
+ END Key;\r
+ \r
+ VAR KeySize : INTEGER; (* Taille de la cle de Items *)\r
+ \r
+ (*--------------------------------------*)\r
+ (* FONCTION GENERIQUE renvoyant pour un *)\r
+ (* tuple donne la cle correspondante. *)\r
+ (*--------------------------------------*)\r
+ UNIT VIRTUAL KeyOf:FUNCTION(t :Tuple) :key; END KeyOf;\r
+ \r
+ (*------------------------------------------------------*)\r
+ (* TEST de COMPARAISON GENERIQUE de deux cles de tuples *)\r
+ (*------------------------------------------------------*)\r
+ UNIT VIRTUAL Leq:FUNCTION(key1, key2 :key) :Boolean; END Leq;\r
+ \r
+ (*------------------------------------------------------------*)\r
+ (* FONCTION GENERIQUE de TRANSFORMATION d'une serie d'entiers *)\r
+ (* en la CLE correspondante. *)\r
+ (*------------------------------------------------------------*)\r
+ UNIT VIRTUAL RecToKey : FUNCTION(A :ARRAYOF INTEGER, j :INTEGER) :Key;\r
+ BEGIN END RecToKey;\r
+ \r
+ (*---------------------------------------------------------*)\r
+ (* FONCTION GENERIQUE de TRANSFORMATION d'une CLE de tuple *)\r
+ (* en une serie d'entiers. *)\r
+ (*---------------------------------------------------------*)\r
+ UNIT VIRTUAL KeyToRec:PROCEDURE(ky :Key, A :ARRAYOF INTEGER, j :INTEGER);\r
+ BEGIN END KeyToRec;\r
+ \r
+ UNIT SearchStep: CLASS;\r
+ VAR PageRef,RefOnPage : INTEGER,\r
+ updated : BOOLEAN;\r
+ END SearchStep;\r
+ \r
+ VAR StackOfPages: ARRAYOF Page, (* Pile de Pages *)\r
+ Finger: INTEGER, (* Indice *)\r
+ Path: ARRAYOF SearchStep,\r
+ AuxRec : ARRAYOF INTEGER,\r
+ Ak : Key,\r
+ PageRef : INTEGER;\r
+ \r
+ (*------------------------------------------------------------------*)\r
+ (* INSERTION de la cle ky au FICHIER d'INDEX, DataRef correspondant *)\r
+ (* a la Position du tuple dans le fichier de donnees. *)\r
+ (*------------------------------------------------------------------*)\r
+ UNIT AddKey:PROCEDURE(INPUT ky:key,DataRef:INTEGER);\r
+ VAR depth,\r
+ PageRef,\r
+ i : INTEGER,\r
+ AddItem, AuxItem, itm2 : Item,\r
+ IncreaseHeight : BOOLEAN,\r
+ NewRoot : Page,\r
+ AuxRec : ARRAYOF INTEGER;\r
+ \r
+ UNIT Search : PROCEDURE (INPUT itm1 : Item, PageRef:INTEGER;\r
+ OUTPUT include : BOOLEAN, itm2 :Item);\r
+ VAR NextPageRef,\r
+ ItemRef : INTEGER,\r
+ inclde : BOOLEAN,\r
+ item2 : Item,\r
+ AuxPage : Page;\r
+ \r
+ UNIT Insert : PROCEDURE;\r
+ VAR OldPage, RightPage : Page,\r
+ AuxRec : ARRAYOF INTEGER,\r
+ AuxItmArr, AuxItmArr2 : ARRAYOF Item,\r
+ RightPageRef, i : INTEGER;\r
+ BEGIN\r
+ OldPage := StackOfPages(Finger);\r
+ IF OldPage.ItemsOnPage < PageSize\r
+ THEN CALL UpdatePage (item2, ItemRef, OldPage);\r
+ Path(Finger).RefOnPage := ItemRef + 1;\r
+ include := FALSE;\r
+ ELSE include := TRUE;\r
+ OldPage.ItemsOnPage := HalfPageSize;\r
+ Path(Finger).updated := TRUE;\r
+ RightPage := NEW Page;\r
+ RightPage.ItemsOnPage := HalfPageSize;\r
+ ARRAY RightPage.ItemsArray dim (1:PageSize);\r
+ AuxItmArr := OldPage.ItemsArray;\r
+ AuxItmArr2 := RightPage.ItemsArray;\r
+ IF ItemRef = HalfPageSize\r
+ THEN FOR i := 1 to HalfPageSize\r
+ DO\r
+ AuxItmArr2(i):=AuxItmArr(i+HalfPageSize)\r
+ OD;\r
+ itm2:= item2;\r
+ ELSE IF ItemRef < HalfPageSize\r
+ THEN FOR i := 1 TO HalfPageSize\r
+ DO\r
+ AuxItmArr2(i) := AuxItmArr(i+HalfPageSize)\r
+ OD;\r
+ itm2 := AuxItmArr(HalfPageSize);\r
+ FOR i := HalfPageSize-1 DOWNTO ItemRef+1\r
+ DO\r
+ AuxItmArr(i+1) := AuxItmArr(i)\r
+ OD;\r
+ AuxItmArr(ItemRef+1) := item2;\r
+ ELSE itm2 := AuxItmArr(HalfPageSize+1);\r
+ FOR i := HalfPageSize+2 TO ItemRef\r
+ DO\r
+ AuxItmArr2(i-HalfPageSize-1) :=\r
+ AuxItmArr(i)\r
+ OD;\r
+ AuxItmArr2(ItemRef-HalfPageSize) := item2;\r
+ FOR i := ItemRef+1 TO PageSize\r
+ DO\r
+ AuxItmArr2(i-HalfPageSize) := AuxItmArr(i)\r
+ OD;\r
+ FI;\r
+ FI;\r
+ (* StackOfPages(finger) := OldPage; *)\r
+ CALL Fseek(df,Path(Finger).PageRef);\r
+ CALL Fput(df,PageToRec(StackOfPages(Finger)));\r
+ RightPage.LessPageRef := itm2.PageRef;\r
+ AuxRec :=PageToRec(RightPage);\r
+ CALL AddRec(AuxRec,RightPageRef);\r
+ itm2.PageRef :=RightPageRef;\r
+ FI\r
+ END Insert;\r
+ \r
+ BEGIN (* Search*)\r
+ IF PageRef = -1\r
+ THEN include := TRUE;\r
+ itm2 := itm1;\r
+ itm2.PageRef := -1;\r
+ ELSE Finger, depth := Finger+1;\r
+ CALL GetPage (PageRef);\r
+ AuxPage := StackOfPages (Finger);\r
+ CALL SearchPage (AuxPage, itm1, NextPageRef, ItemRef);\r
+ CALL Search(itm1, NextPageRef, include, item2);\r
+ IF include\r
+ THEN CALL Insert;\r
+ FI;\r
+ Finger := Finger -1;\r
+ FI;\r
+ END Search;\r
+ \r
+ BEGIN (*AddKey*)\r
+ Path(1).updated := TRUE;\r
+ AuxItem := NEW Item;\r
+ AuxItem.ky := ky;\r
+ AuxItem.DataRef := DataRef;\r
+ AuxItem.PageRef := -1;\r
+ Finger := 0;\r
+ CALL Search(AuxItem, Path(1).PageRef,\r
+ IncreaseHeight, AddItem);\r
+ IF IncreaseHeight\r
+ THEN NewRoot := NEW Page;\r
+ NewRoot.ItemsOnPage := 1;\r
+ NewRoot.LessPageRef := Path(1).PageRef;\r
+ ARRAY NewRoot.ItemsArray dim (1:PageSize);\r
+ NewRoot.ItemsArray(1) := AddItem;\r
+ IF depth+1 > TreeHeight\r
+ THEN RAISE TreeHeight_Overflow\r
+ FI;\r
+ FOR i := 1 TO depth\r
+ DO\r
+ StackOfPages(i+1) := StackOfPages(i);\r
+ Path(i+1) := Path(i);\r
+ OD;\r
+ StackOfPages(1) := NewRoot;\r
+ Path(1) := NEW SearchStep;\r
+ Path(1).RefOnPage := 1;\r
+ Path(1).updated := TRUE;\r
+ AuxRec :=PageToRec(NewRoot);\r
+ CALL AddRec(AuxRec, PageRef);\r
+ Path(1).PageRef := PageRef;\r
+ Finger := depth+1\r
+ ELSE Finger := depth\r
+ FI (* IncreaseHeight *);\r
+ END AddKey;\r
+ \r
+ (*-------------------------------------------------------------------*)\r
+ (* RECHERCHE de la cle Ky IMMEDIATEMENT INFERIEURE a la CLE indique *)\r
+ (* par Path, DataRef correspond a la POSITION du TUPLE associe a la *)\r
+ (* CLE dans le fichier de donnees. *)\r
+ (*-------------------------------------------------------------------*)\r
+ UNIT PrevKey : PROCEDURE (OUTPUT ky:key, DataRef:INTEGER);\r
+ VAR AuxPage : Page, AuxRec : ARRAYOF INTEGER,\r
+ PageRef, NextPageRef, RefOnPage : INTEGER;\r
+ BEGIN\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ PageRef:=Path(Finger).PageRef;\r
+ AuxPage:=StackOfPages(Finger);\r
+ IF AuxPage.LessPageRef = -1\r
+ THEN IF RefOnPage <> 1\r
+ THEN RefOnPage := RefOnPage -1;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ ELSE IF Finger = 1\r
+ THEN ky:=AuxPage.ItemsArray(RefOnPage).ky;\r
+ DataRef:=AuxPage.ItemsArray(RefOnPage).DataRef;\r
+ RAISE signal11;\r
+ RETURN;\r
+ ELSE RefOnPage := 0;\r
+ WHILE Finger <> 1 AND RefOnPage = 0\r
+ DO\r
+ Finger := Finger-1;\r
+ Auxpage := StackOfPages(Finger);\r
+ RefOnPage := Path(Finger).RefOnPage\r
+ OD;\r
+ IF Finger = 1 AND RefOnPage = 0\r
+ THEN ky:=AuxPage.ItemsArray(1).ky;\r
+ DataRef:=AuxPage.ItemsArray(1).DataRef;\r
+ RAISE signal11;\r
+ RETURN;\r
+ FI;\r
+ FI;\r
+ FI (* RefOnPage <> 1 *);\r
+ ELSE IF RefOnPage = 1\r
+ THEN NextPageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0\r
+ ELSE RefOnPage := RefOnPage -1;\r
+ NextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ FI;\r
+ WHILE NextPageRef <> -1\r
+ DO\r
+ Finger := Finger +1;\r
+ PageRef := NextPageRef;\r
+ CALL GetPage(PageRef);\r
+ AuxPage := StackOfPages(Finger);\r
+ RefOnPage, Path(Finger).RefOnPage := Auxpage.ItemsOnPage;\r
+ NextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef\r
+ OD;\r
+ FI;\r
+ ky:=AuxPage.ItemsArray(RefOnPage).ky;\r
+ DataRef:=AuxPage.ItemsArray(RefOnPage).DataRef\r
+ END PrevKey;\r
+ (*-----------------------------------------------------*)\r
+ (* RECHERCHE de la CLE la plus petite du fichier INDEX *)\r
+ (*-----------------------------------------------------*)\r
+ UNIT MinKey : PROCEDURE (OUTPUT k:Key, DataRef : INTEGER);\r
+ VAR PageRef : INTEGER, AuxPage : Page, AuxItem : Item;\r
+ BEGIN\r
+ Finger :=1;\r
+ DO\r
+ AuxPage := StackOfPages(Finger);\r
+ PageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0;\r
+ IF PageRef = -1 THEN EXIT FI;\r
+ Finger := Finger +1;\r
+ CALL GetPage(PageRef);\r
+ OD;\r
+ AuxItem := AuxPage.ItemsArray(1);\r
+ k := AuxItem.ky;\r
+ DataRef := AuxItem.DataRef;\r
+ Path(Finger).RefOnPage := 1\r
+ END MinKey;\r
+ \r
+ UNIT MaxKey : PROCEDURE( OUTPUT k:Key, DataRef: INTEGER);\r
+ VAR PageRef, n : INTEGER,\r
+ AuxPage : Page;\r
+ BEGIN\r
+ Finger :=1;\r
+ DO\r
+ AuxPage := StackOfPages(Finger);\r
+ Path(Finger).RefOnPage, n := AuxPage.ItemsOnPage;\r
+ PageRef := AuxPage.ItemsArray(n).PageRef;\r
+ IF PageRef = -1 THEN EXIT FI;\r
+ Finger := Finger+1;\r
+ CALL GetPage(PageRef)\r
+ OD;\r
+ k := AuxPage.ItemsArray(n).Ky;\r
+ DataRef := AuxPage.ItemsArray(n).DataRef\r
+ END MaxKey;\r
+ \r
+ (*-------------------------------------------------------------------*)\r
+ (* RECHERCHE de la cle Ky IMMEDIATEMENT SUPERIEURE a la cle indique *)\r
+ (* par Path, DataRef correspond a la Position du tuple associe a la *)\r
+ (* cle dans le fichier de donnees. *)\r
+ (*-------------------------------------------------------------------*)\r
+ UNIT NextKey: PROCEDURE (OUTPUT ky:key,DataRef:INTEGER);\r
+ VAR AuxPage : Page,\r
+ AuxItem : Item,\r
+ PageRef,NextPageRef,\r
+ RefOnPage : INTEGER;\r
+ BEGIN\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ PageRef := Path(Finger).PageRef;\r
+ AuxPage:=StackOfPages(Finger);\r
+ IF AuxPage.LessPageRef = -1\r
+ THEN WHILE Finger <> 1 AND RefOnPage = AuxPage.ItemsOnPage\r
+ DO\r
+ Finger := Finger - 1;\r
+ AuxPage := StackOfPages(Finger);\r
+ RefOnPage := Path(Finger).refOnPage\r
+ OD;\r
+ IF RefOnPage = AuxPage.ItemsOnPage\r
+ THEN AuxItem := AuxPage.ItemsArray(RefOnPage);\r
+ DataRef := AuxItem.DataRef;\r
+ ky := AuxItem.ky;\r
+ RAISE signal12;\r
+ RETURN;\r
+ ELSE RefOnPage := RefOnPage+1;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ FI;\r
+ ELSE NextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ WHILE NextPageRef <> -1\r
+ DO\r
+ Finger := Finger+1;\r
+ PageRef := NextPageRef;\r
+ CALL GetPage(PageRef);\r
+ AuxPage := StackOfPages(Finger);\r
+ Path(Finger).refOnPage := 0;\r
+ NextPageRef := AuxPage.LesspageRef\r
+ OD;\r
+ RefOnPage := 1;\r
+ Path(Finger).RefOnPage := 1\r
+ FI;\r
+ AuxItem := AuxPage.ItemsArray(RefOnPage);\r
+ DataRef := AuxItem.DataRef;\r
+ ky := AuxItem.ky\r
+ END NextKey;\r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* SUPPRESSION de la cle ky au FICHIER d'INDEX, DataRef correspondant *)\r
+ (* a la Position du tuple dans le fichier de donnees. *)\r
+ (*--------------------------------------------------------------------*)\r
+ UNIT DelKey : PROCEDURE (INPUT ky:key,DataRef:INTEGER);\r
+ VAR DataRef1: INTEGER,\r
+ k: key,\r
+ underflw:BOOLEAN;\r
+ \r
+ UNIT remove : PROCEDURE(OUTPUT underflw:BOOLEAN);\r
+ VAR AuxPage,AuxPage1 :Page,\r
+ i,ItemsOnPage,RefOnPage,NextPageRef :INTEGER;\r
+ BEGIN\r
+ AuxPage:=StackOfPages(Finger);\r
+ i:=Finger;\r
+ Path(Finger).updated:=TRUE;\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ \r
+ IF AuxPage.LessPageRef <> -1\r
+ THEN NextPageRef :=\r
+ AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ WHILE NextPageRef <> -1\r
+ DO\r
+ Finger := Finger+1;\r
+ CALL GetPage(NextPageRef);\r
+ AuxPage1 := StackOfPages(Finger);\r
+ Path(Finger).RefOnPage := 0;\r
+ NextPageRef := AuxPage1.LessPageRef\r
+ OD;\r
+ Path(Finger).updated:=TRUE;\r
+ Path(Finger).RefOnPage := 1;\r
+ AuxPage.ItemsArray(RefOnPage).ky := AuxPage1.ItemsArray(1).ky;\r
+ AuxPage.ItemsArray(RefOnPage).DataRef:=\r
+ AuxPage1.ItemsArray(1).DataRef;\r
+ StackOfPages(i):=AuxPage;\r
+ AuxPage:= AuxPage1;\r
+ RefOnPage:=1;\r
+ FI;\r
+ ItemsOnPage:= AuxPage.ItemsOnPage -1;\r
+ FOR i:=RefOnPage TO ItemsOnPage\r
+ DO\r
+ AuxPage.ItemsArray(i):=AuxPage.ItemsArray(i+1)\r
+ OD;\r
+ AuxPage.ItemsOnPage:= ItemsOnPage;\r
+ StackOfPages(Finger):=AuxPage;\r
+ IF ItemsOnPage<HalfPageSize\r
+ THEN underflw:=TRUE\r
+ FI\r
+ END remove;\r
+ \r
+ UNIT underflow: PROCEDURE(inout underflw:BOOLEAN);\r
+ VAR Itm:Item,\r
+ AuxPage,AuxPage1, AuxPage2:Page,\r
+ i,k,n,pb,lb,PageRef,RefOnPage: INTEGER,\r
+ AuxRec: ARRAYOF INTEGER;\r
+ BEGIN\r
+ writeln("underflow",Finger);\r
+ underflw:=FALSE;\r
+ IF Finger<>1\r
+ THEN AuxPage:=StackOfPages(Finger);\r
+ Path(Finger).updated:=TRUE ;\r
+ Path(Finger-1).updated:=TRUE ;\r
+ AuxPage1:=StackOfPages(Finger-1);\r
+ RefOnPage:=Path(Finger-1).RefOnPage;\r
+ IF RefOnPage< AuxPage1.ItemsOnPage\r
+ THEN k:=RefOnPage+1;\r
+ Itm:=AuxPage1.ItemsArray(k);\r
+ PageRef:=Itm.PageRef;\r
+ CALL Fseek(df,PageRef);\r
+ AuxRec:=Fget(df);\r
+ AuxPage2:=RecToPage(AuxRec);\r
+ Itm.PageRef:=AuxPage2.LessPageRef;\r
+ AuxPage.ItemsArray(AuxPage.ItemsOnPage+1):=Itm;\r
+ n:=AuxPage2.ItemsOnPage-HalfPageSize;\r
+ IF n>0\r
+ THEN n:=entier((n-1)/2);\r
+ Itm:=AuxPage2.ItemsArray(n+1);\r
+ Itm.PageRef:=PageRef;\r
+ AuxPage1.ItemsArray(k):=Itm;\r
+ FOR i:=1 TO n\r
+ DO\r
+ AuxPage.ItemsArray(HalfPageSize+i):=\r
+ AuxPage2.ItemsArray(i)\r
+ OD;\r
+ AuxPage.ItemsOnPage:=HalfPageSize+n;\r
+ StackOfPages(Finger):=AuxPage;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ k:=AuxPage2.ItemsOnPage-(n+1);\r
+ FOR i:=1 TO k\r
+ DO\r
+ AuxPage2.ItemsArray(i):=\r
+ AuxPage2.ItemsArray(n+1+i)\r
+ OD;\r
+ AuxPage2.ItemsOnPage:=k;\r
+ AuxRec:=PageToRec(AuxPage2);\r
+ CALL Fseek(df,PageRef);\r
+ CALL Fput(df,AuxRec);\r
+ ELSE (*AuxPage2.ItemsOnPage=HalfPageSize tzn. n=0*)\r
+ FOR i:=1 TO HalfPageSize\r
+ DO\r
+ AuxPage.ItemsArray(HalfPageSize+i):=\r
+ AuxPage2.ItemsArray(i)\r
+ OD;\r
+ AuxPage.ItemsOnPage:=PageSize;\r
+ FOR i:=RefOnPage+2 TO AuxPage1.ItemsOnPage\r
+ DO\r
+ AuxPage1.ItemsArray(i-1):=\r
+ AuxPage1.ItemsArray(i)\r
+ OD;\r
+ AuxPage1.ItemsOnPage:=AuxPage1.ItemsOnPage-1;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage;\r
+ CALL DelRec(PageRef);\r
+ IF AuxPage1.ItemsOnPage<HalfPageSize\r
+ THEN Finger:=Finger-1;\r
+ underflw:=TRUE;\r
+ FI;\r
+ FI (*n>0*)\r
+ ELSE IF RefOnPage>1\r
+ THEN Itm:=AuxPage1.ItemsArray(RefOnPage-1);\r
+ PageRef:=Itm.PageRef;\r
+ ELSE PageRef:=AuxPage1.LessPageRef;\r
+ FI;\r
+ CALL Fseek(df,PageRef);\r
+ AuxRec:=Fget(df);\r
+ AuxPage2:=RecToPage(AuxRec);\r
+ Itm:=AuxPage1.ItemsArray(RefOnPage);\r
+ Itm.PageRef:=AuxPage.LessPageRef;\r
+ n:=AuxPage2.ItemsOnPage-HalfPageSize;\r
+ IF n>0\r
+ THEN n:=entier((n-1)/2);\r
+ k:=AuxPage.ItemsOnPage;\r
+ FOR i:=1 TO n+1\r
+ DO\r
+ AuxPage.ItemsArray(k+n+2-i):=\r
+ AuxPage.ItemsArray(k+1-i)\r
+ OD;\r
+ AuxPage.ItemsArray(n+1):=Itm;\r
+ AuxPage.ItemsOnPage:=k+n+1;\r
+ Itm:=AuxPage2.ItemsArray(HalfPageSize+n+1);\r
+ Itm.PageRef:=PageRef;\r
+ AuxPage1.ItemsArray(RefOnPage):=Itm;\r
+ FOR i:=1 TO n\r
+ DO\r
+ AuxPage.ItemsArray(i):=\r
+ AuxPage2.ItemsArray(HalfPageSize+1+i+n)\r
+ OD;\r
+ AuxPage.ItemsOnPage:=HalfPageSize+n;\r
+ AuxPage2.ItemsOnPage:= HalfPageSize+n;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage;\r
+ AuxRec:=PageToRec(AuxPage2);\r
+ CALL Fseek(df,PageRef);\r
+ CALL Fput(df,AuxRec);\r
+ ELSE AuxPage2.ItemsArray(HalfPageSize+1):=Itm;\r
+ FOR i:=1 TO HalfPageSize-1\r
+ DO AuxPage2.ItemsArray(HalfPageSize+1+i):=\r
+ AuxPage.ItemsArray(i)\r
+ OD;\r
+ AuxPage1.ItemsOnPage:=AuxPage1.ItemsOnPage-1;\r
+ AuxPage2.ItemsOnPage:=PageSize;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage2;\r
+ Path(Finger-1).RefOnPage:=RefOnPage-1;\r
+ CALL DelRec(Path(Finger).PageRef);\r
+ Path(Finger).PageRef:=PageRef;\r
+ IF AuxPage1.ItemsOnPage<HalfPageSize\r
+ THEN Finger:=Finger-1;\r
+ underflw:=TRUE\r
+ FI;\r
+ FI (*n>0*)\r
+ FI\r
+ ELSE AuxPage:=StackOfPages(1);\r
+ IF AuxPage.ItemsOnPage=0\r
+ THEN CALL DelRec(Path(1).PageRef);\r
+ IF AuxPage.LessPageRef<>-1\r
+ THEN i:=2;\r
+ WHILE Path(i)<>NONE\r
+ DO\r
+ Path(i-1):=Path(i);\r
+ StackOfPages(i-1):=StackOfPages(i);\r
+ i:=i+1\r
+ OD\r
+ ELSE writeln("erreur1");\r
+ FI;\r
+ FI\r
+ FI;\r
+ END underflow;\r
+ \r
+ BEGIN (*DelKey*)\r
+ k:=ky;\r
+ DataRef1:=FindKey(k);\r
+ DO\r
+ IF k=ky AND DataRef=DataRef1\r
+ THEN CALL remove(underflw);\r
+ WHILE underflw\r
+ DO\r
+ CALL underflow(underflw)\r
+ OD;\r
+ RETURN\r
+ ELSE IF k<>ky or DataRef1= -1\r
+ THEN writeln("erreur2")\r
+ ELSE CALL NextKey(k,DataRef1)\r
+ FI\r
+ FI\r
+ OD\r
+ END DelKey;\r
+ \r
+ \r
+ UNIT FindKey:FUNCTION (k : key): INTEGER;\r
+ VAR PageRef,\r
+ i : INTEGER,\r
+ AuxPage : Page,\r
+ Itms : ARRAYOF Item,\r
+ k1 : Key;\r
+ BEGIN\r
+ Finger := 1;\r
+ PageRef := Path(Finger).PageRef;\r
+ DO\r
+ CALL GetPage( PageRef );\r
+ AuxPage := StackOfPages(Finger);\r
+ Itms := AuxPage.ItemsArray;\r
+ FOR i := AuxPage.ItemsOnPage DOWNTO 1\r
+ DO\r
+ k1 := Itms(i).ky;\r
+ IF leq(k1, k)\r
+ THEN Path(Finger).RefOnPage := i;\r
+ IF leq(k, k1)\r
+ THEN RESULT := Itms(i).DataRef;\r
+ RETURN\r
+ FI;\r
+ PageRef := Itms(i).PageRef;\r
+ EXIT;\r
+ ELSE IF i =1\r
+ THEN PageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ IF PageRef = -1\r
+ THEN IF Path(Finger).RefOnPage = 0\r
+ THEN Path(Finger).RefOnPage :=1\r
+ FI;\r
+ RESULT := -1;\r
+ EXIT (*FindKey*)\r
+ ELSE Finger := Finger+1\r
+ FI;\r
+ OD;\r
+ END FindKey;\r
+ \r
+ UNIT SearchKey: PROCEDURE(INPUT k:key;OUTPUT DataRef : INTEGER);\r
+ BEGIN\r
+ DataRef := FindKey(k);\r
+ IF DataRef = -1\r
+ THEN CALL NextKey(k,DataRef)\r
+ FI\r
+ END SearchKey;\r
+ \r
+ UNIT GetPage : PROCEDURE(PageRef : INTEGER);\r
+ VAR AuxRec : ARRAYOF INTEGER;\r
+ BEGIN\r
+ IF Path(Finger) = NONE\r
+ THEN Path(Finger) := NEW SearchStep;\r
+ Path(Finger).Updated := FALSE;\r
+ Path(Finger).PageRef := PageRef-1;\r
+ FI;\r
+ IF Path(Finger).Updated\r
+ THEN AuxRec := PageToRec(StackOfPages(Finger));\r
+ CALL Fseek(df, Path(Finger).PageRef);\r
+ CALL Fput(df,AuxRec);\r
+ FI;\r
+ CALL Fseek(df, PageRef);\r
+ AuxRec := Fget(df);\r
+ StackOfPages(Finger) := RecToPage(AuxRec);\r
+ Path(Finger) := NEW SearchStep;\r
+ Path(Finger).PageRef := PageRef;\r
+ Path(Finger).updated := FALSE;\r
+ END GetPage ;\r
+ \r
+ UNIT UpdatePage : PROCEDURE (INPUT AuxItem : Item, ItemRef : INTEGER,\r
+ AuxPage : Page);\r
+ VAR AuxItmArr : ARRAYOF Item,\r
+ n,i: INTEGER;\r
+ BEGIN\r
+ AuxPage.ItemsOnPage, n := AuxPage.ItemsOnPage +1;\r
+ FOR i := n DOWNTO ItemRef +2\r
+ DO\r
+ AuxItmArr := AuxPage.ItemsArray;\r
+ AuxItmArr(i) := AuxItmArr(i-1)\r
+ OD;\r
+ AuxPage.ItemsArray(ItemRef+1) := AuxItem;\r
+ Path(Finger).Updated := TRUE;\r
+ END UpdatePage ;\r
+ \r
+ UNIT order : FUNCTION (i1, i2 : Item) : BOOLEAN;\r
+ VAR k1,k2 :key,\r
+ n : INTEGER;\r
+ BEGIN\r
+ k1 := i1.ky;\r
+ k2 := i2.ky;\r
+ IF Leq(k2,k1)\r
+ THEN IF Leq(k1, k2)\r
+ THEN n := i1.DataRef - i2.DataRef;\r
+ IF n=0\r
+ THEN RAISE Signal14\r
+ FI;\r
+ RESULT := n<0;\r
+ ELSE RESULT := FALSE\r
+ FI\r
+ ELSE IF NOT Leq(k1, k2)\r
+ THEN\r
+ ELSE RESULT := TRUE\r
+ FI\r
+ FI\r
+ END order;\r
+ \r
+ UNIT SearchPage : PROCEDURE (INPUT P :Page, it :Item;\r
+ OUTPUT NextPageRef, ItemRef :INTEGER);\r
+ VAR Itms : ARRAYOF Item,\r
+ it1 : Item;\r
+ BEGIN\r
+ Itms :=P.ItemsArray;\r
+ FOR ItemRef := P.ItemsOnPage DOWNTO 1\r
+ DO\r
+ it1 := Itms(ItemRef);\r
+ IF order(it1, it)\r
+ THEN NextPageRef := it1.PageRef;\r
+ RETURN\r
+ FI\r
+ OD;\r
+ ItemRef := 0;\r
+ NextPageRef := P.LessPageRef;\r
+ END SearchPage ;\r
+ \r
+ BEGIN (*IndexFile*)\r
+ Finger :=1;\r
+ ARRAY StackOfPages dim(1:TreeHeight);\r
+ ARRAY Path dim (1:TreeHeight);\r
+ StackOfPages(1) := NEW Page;\r
+ StackOfPages(1).ItemsOnPage := 0;\r
+ StackOfPages(1).LessPageRef := -1;\r
+ ARRAY StackOfPages(1).ItemsArray dim (1: PageSize);\r
+ Path(1):= NEW SearchStep;\r
+ Path(1).PageRef := 1;\r
+ Path(1).RefOnPage := 0;\r
+ END IndexFile;\r
+ END Relation;\r
+END HandlerOfRelations;\r
+ \r
+BEGIN (* MAIN *)\r
+ \r
+PREF HandlerOfRelations(4,8,2) BLOCK\r
+ \r
+CONST (* couleur: la definition de ces couleurs varie avec le mode \82cran *)\r
+ (* il est possible celles ci ne corespondent pas \85 leurs d\82finition *)\r
+ Noir = 0, Rouge = 1, Vert = 2, Jaune = 3, Bleu = 4, Magenta = 5,\r
+ Cyan = 6, Blanc = 7, \r
+ (* attribut carateres *)\r
+ Normal = 0, Gras = 1, Clignotant = 5, Inverse = 7, Cache = 8,\r
+ (* code retour clavier *)\r
+ Fgauche = -75, Fdroite = -77,Fhaut = -72, Fbas = -80,\r
+ ESC = 27, RETOUR = 13, BKSPACE = 8;\r
+ \r
+(* definition des procedures \82cran et clavier *)\r
+\r
+(*detection d'une touche *)\r
+UNIT inchar : IIuwgraph FUNCTION : INTEGER;\r
+VAR i : INTEGER;\r
+BEGIN\r
+ DO RESULT := inkey; IF RESULT =/= 0 THEN EXIT FI OD;\r
+END inchar;\r
+ \r
+(*efface l'\82cran et place le curseur en position (1,1) *)\r
+UNIT cls : PROCEDURE;\r
+BEGIN\r
+ write( CHR(27),"[2J");\r
+ CALL GotoXY(1,1)\r
+END Cls;\r
+ \r
+(* positionne le curseur en colonne x et ligne y *)\r
+UNIT GotoXY : PROCEDURE(x, y: INTEGER);\r
+VAR a,b,c,d : CHAR, i,j : INTEGER;\r
+BEGIN\r
+ i := y DIV 10; j := y MOD 10; a := CHR(48+i); b := CHR(48+j);\r
+ i := x DIV 10; j := x mod 10; c := CHR(48+i); d := CHR(48+j);\r
+ write(CHR(27),"[",a,b,";",c,d,"H")\r
+END GotoXY;\r
+ \r
+(* definition des couleurs du caracteres et du fon *)\r
+UNIT SetColor : PROCEDURE(font,back : INTEGER);\r
+BEGIN \r
+ write(CHR(27),"[","3",CHR(48+font),";4",CHR(48+back),"m");\r
+END SetColor;\r
+ \r
+UNIT Text_attr : PROCEDURE(Plus, Attr : INTEGER);\r
+BEGIN\r
+ IF (Plus = 0) THEN write(CHR(27),"[0m") FI;\r
+ write(CHR(27),"[",CHR(48+Attr),"m");\r
+END Text_Attr;\r
+\r
+(***) \r
+\r
+\r
+(* classe de base d'affichage d'une fiche \85 l'\82cran *)\r
+\r
+UNIT Base_Fiche : CLASS;\r
+VAR Titre :STRING;\r
+ \r
+ UNIT VIRTUAL Touche_Aff : PROCEDURE;\r
+ BEGIN\r
+ END Touche_Aff;\r
+ \r
+ UNIT Affiche : PROCEDURE; (* procedure d'affichage de la base graphique *)\r
+ (* permetant la saisie comme la consultation *)\r
+ BEGIN\r
+ CALL setcolor(cyan,bleu);\r
+ CALL GotoXY(10,5);\r
+ (* taille du titre: 20 caracteres *)\r
+ write(" ",titre," ");\r
+ CALL GotoXY(10,6);\r
+ write(" ");\r
+ CALL setcolor(vert,bleu);\r
+ CALL GotoXY(10,7);\r
+ write(" Auteur : ");\r
+ CALL GotoXY(10,8);\r
+ write(" Titre : ");\r
+ CALL GotoXY(10,9);\r
+ write(" Editeur: ");\r
+ CALL GotoXY(10,10);\r
+ write(" Annee : ");\r
+ CALL GotoXY(10,11);\r
+ write(" Sujet : ");\r
+ CALL GotoXY(10,12);\r
+ write(" NøInv : ");\r
+ CALL GotoXY(10,13);\r
+ write(" ");\r
+ CALL GotoXY(10,14);\r
+ CALL setcolor(rouge,bleu);\r
+ CALL touche_aff;\r
+ CALL GotoXY(10,15);\r
+ write(" ");\r
+ END affiche;\r
+\r
+END Base_Fiche;\r
+ \r
+\r
+\r
+UNIT Fiche_Cons : Base_Fiche CLASS;\r
+ \r
+ UNIT VIRTUAL Touche_Aff : PROCEDURE;\r
+ BEGIN END Touche_Aff;\r
+ \r
+ UNIT Put_Champs :PROCEDURE;\r
+ BEGIN\r
+ IF (L.INV.Ak = NONE)\r
+ THEN RETURN;\r
+ FI;\r
+ CALL Put_Chaine(20,7,L.INV.AutLeng,L.INV.Ak.Author);\r
+ CALL Put_Chaine(20,8,L.INV.TitLeng,L.INV.Ak.Title);\r
+ CALL Put_Chaine(20,9,L.INV.PubLeng,L.INV.Ak.Publisher);\r
+ CALL Put_Entier(20,10,4,L.INV.Ak.Year);\r
+ CALL Put_Chaine(20,11,L.INV.SubjLeng,L.INV.Ak.Subject);\r
+ CALL Put_Entier(20,12,5,L.INV.Ak.NoInv);\r
+ END Put_Champs;\r
+ \r
+BEGIN \r
+ Titre := " CONSULTATION LIVRE ";\r
+ CALL Affiche;\r
+ CALL Put_Champs;\r
+END Fiche_Cons;\r
+ \r
+UNIT Fiche_Saisie : Base_Fiche CLASS;\r
+ \r
+ UNIT VIRTUAL Touche_Aff : PROCEDURE;\r
+ BEGIN\r
+ write(" [\11ÄÙ]: Validation. [Esc]: Abandon de la saisie. ");\r
+ END touche_aff;\r
+ \r
+ UNIT Read_Champs :FUNCTION : BOOLEAN;\r
+ VAR Code_Saisie : INTEGER;\r
+ BEGIN\r
+ DO\r
+ CALL say("Entrer le Nom de l'Auteur");\r
+ DO\r
+ Code_Saisie := Read_Chaine(20,7,L.INV.AutLeng,L.INV.Ak.Author);\r
+ IF Code_Saisie = 1\r
+ THEN EXIT EXIT;\r
+ ELSE IF Code_Saisie = 2\r
+ THEN CALL say(\r
+ "Saisie Obligatoire du nom de l'auteur");\r
+ write(CHR(7),CHR(7));\r
+ ELSE EXIT;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ CALL say("Entrer le Titre du livre");\r
+ DO\r
+ Code_Saisie := Read_Chaine(20,8,L.INV.TitLeng,L.INV.Ak.Title);\r
+ IF Code_Saisie = 1\r
+ THEN EXIT EXIT;\r
+ ELSE IF Code_Saisie = 2\r
+ THEN CALL say(\r
+ "Saisie Obligatoire du titre de l'oeuvre");\r
+ write(CHR(7),CHR(7));\r
+ ELSE EXIT;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ CALL say("Entrer le Nom de l'Editeur");\r
+ DO\r
+ Code_Saisie := Read_Chaine(20,9,L.INV.PubLeng,L.INV.Ak.Publisher);\r
+ IF Code_Saisie = 1\r
+ THEN EXIT EXIT;\r
+ ELSE IF Code_Saisie = 2\r
+ THEN CALL say(\r
+ "Saisie Obligatoire du Nom de l'Editeur !");\r
+ write(CHR(7),CHR(7));\r
+ ELSE EXIT;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ CALL say("Entrer l'Annee de Parution de l'Oeuvre");\r
+ DO\r
+ Code_Saisie := Read_Entier(20,10,4);\r
+ IF Code_saisie = -1\r
+ THEN EXIT EXIT;\r
+ ELSE IF Code_Saisie = -2\r
+ THEN CALL say(\r
+ "Saisie Obligatoire de l'annee de parution !");\r
+ write(CHR(7),CHR(7));\r
+ ELSE L.INV.Ak.Year := Code_Saisie;\r
+ EXIT; \r
+ FI;\r
+ FI;\r
+ OD;\r
+ CALL say("Entrer le Theme de l'Oeuvre");\r
+ DO\r
+ Code_Saisie := Read_Chaine(20,11,L.INV.SubjLeng,L.INV.Ak.Subject);\r
+ IF Code_saisie = 1\r
+ THEN EXIT EXIT;\r
+ ELSE IF Code_Saisie = 2\r
+ THEN CALL say(\r
+ "Saisie Obligatoire du Theme de l'oeuvre !");\r
+ write(CHR(7),CHR(7));\r
+ ELSE EXIT;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ CALL say("Entrer le Numero d'inventaire du livre");\r
+ DO\r
+ Code_Saisie := Read_Entier(20,12,5);\r
+ IF Code_saisie = -1\r
+ THEN EXIT EXIT;\r
+ ELSE IF Code_Saisie = -2\r
+ THEN CALL say(\r
+ "Saisie Obligatoire du Nø Inventaire !");\r
+ write(CHR(7),CHR(7));\r
+ ELSE L.INV.Ak.NoInv := Code_Saisie;\r
+ Code_Saisie := 0;\r
+ EXIT EXIT;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ OD;\r
+ IF Code_Saisie = 0 THEN RESULT := TRUE FI;\r
+ END Read_Champs;\r
+ \r
+BEGIN\r
+ Titre := " FICHE SAISIE LIVRE ";\r
+ CALL Affiche;\r
+ ok := Read_Champs;\r
+END Fiche_Saisie;\r
+ \r
+UNIT Read_Entier : FUNCTION(x,y,longueur : INTEGER) : INTEGER;\r
+VAR val : INTEGER;\r
+BEGIN\r
+ CALL Text_Attr(0,Gras);\r
+ CALL GotoXY(x,y);\r
+ FOR i := 1 TO longueur \r
+ DO\r
+ write("Û");\r
+ OD;\r
+ i := 0;\r
+ CALL Text_Attr(0,Inverse);\r
+ CALL GotoXY(x,y);\r
+ DO\r
+ val := inchar;\r
+ CALL GotoXY(x+i,y);\r
+ CASE val\r
+ WHEN ESC : RESULT := -1;\r
+ RETURN;\r
+ WHEN RETOUR : IF i = 0\r
+ THEN RESULT := -2;\r
+ FI;\r
+ RETURN;\r
+ WHEN BKSPACE,\r
+ FGauche : IF (i = 0)\r
+ THEN write(CHR(7))\r
+ ELSE i := i-1;\r
+ CALL Text_Attr(0,Gras);\r
+ CALL GotoXY(x+i,y);\r
+ write("Û");\r
+ CALL Text_Attr(0,Inverse);\r
+ RESULT := ENTIER(RESULT / 10)\r
+ FI;\r
+ OTHERWISE IF (i = longueur)\r
+ THEN write(CHR(7))\r
+ ELSE IF (val > 47 AND val < 58)\r
+ THEN write(CHR(val));\r
+ i := i + 1;\r
+ RESULT := RESULT* 10 + (val - 48);\r
+ ELSE write(CHR(7));\r
+ FI;\r
+ FI;\r
+ ESAC;\r
+ OD;\r
+END Read_Entier;\r
+ \r
+UNIT Put_Entier : PROCEDURE(x,y,longueur : INTEGER;val : INTEGER);\r
+VAR c: CHAR;\r
+BEGIN\r
+ CALL Text_Attr(0,Gras); CALL GotoXY(x,y);\r
+ FOR i := 1 TO longueur DO write("Û") OD;\r
+ longueur := longueur - 1;\r
+ CALL GotoXY(x+longueur,y);\r
+ CALL Text_Attr(0,Inverse);\r
+ DO\r
+ c := CHR(48+(val MOD 10));\r
+ write(c);\r
+ longueur := longueur - 1;\r
+ CALL GotoXY(x+longueur,y);\r
+ val := val DIV 10;\r
+ IF val = 0 THEN EXIT FI;\r
+ OD;\r
+END Put_Entier;\r
+ \r
+UNIT Read_Chaine : FUNCTION(x,y,longueur :INTEGER;\r
+ OUTPUT ch : ARRAYOF CHAR) : INTEGER;\r
+VAR val: INTEGER;\r
+BEGIN\r
+ ARRAY ch DIM (1:longueur);\r
+ CALL Text_Attr(0,Gras);\r
+ CALL GotoXY(x,y);\r
+ FOR i := 1 TO longueur DO\r
+ write("Û");\r
+ OD; \r
+ i := 0;\r
+ CALL Text_Attr(0,Inverse);\r
+ CALL GotoXY(x,y);\r
+ DO\r
+ val := INCHAR;\r
+ CALL GotoXY(x+i,y);\r
+ CASE val\r
+ WHEN ESC : RESULT := 1;\r
+ RETURN;\r
+ WHEN RETOUR : IF i = 0\r
+ THEN RESULT := 2\r
+ FI;\r
+ RETURN;\r
+ WHEN BKSPACE,\r
+ FGauche : IF (i = 0)\r
+ THEN write(CHR(7))\r
+ ELSE i := i-1;\r
+ CALL Text_Attr(0,Gras);\r
+ CALL GotoXY(x+i,y);\r
+ write("Û");\r
+ CALL Text_Attr(0,Inverse)\r
+ FI;\r
+ WHEN Fdroite : IF (i = longueur - 1)\r
+ THEN write(CHR(7))\r
+ ELSE write(CHR(32));\r
+ i := i + 1;\r
+ ch(i) := CHR(32)\r
+ FI;\r
+ OTHERWISE IF (i = longueur)\r
+ THEN write(CHR(7));\r
+ ELSE IF (val >=32 AND val <=125)\r
+ THEN write(CHR(val));\r
+ i := i + 1;\r
+ ch(i) := CHR(val)\r
+ ELSE write(CHR(7))\r
+ FI;\r
+ FI;\r
+ ESAC;\r
+ OD;\r
+END Read_chaine;\r
+ \r
+UNIT Put_chaine : PROCEDURE(x,y,Longueur : INTEGER;ch : ARRAYOF CHAR);\r
+BEGIN\r
+ CALL Text_Attr(0,Gras); CALL GotoXY(x,y);\r
+ FOR i := 1 TO longueur - 1 DO write("Û") OD;\r
+ CALL GotoXY(x,y);\r
+ CALL Text_Attr(0,Inverse);\r
+ i := 1;\r
+ DO\r
+ IF (i > UPPER(ch)) ORIF (ORD(ch(i)) = RETOUR) ORIF (i > Longueur - 1)\r
+ THEN EXIT fi;\r
+ write(ch(i));\r
+ i := i+1;\r
+ OD;\r
+END Put_chaine;\r
+ \r
+\r
+UNIT say : PROCEDURE(phrase : string);\r
+BEGIN\r
+ CALL SetColor(noir,cyan);\r
+ CALL GotoXY(1,25);\r
+ write(\r
+" ");\r
+ CALL GotoXY(2,25);\r
+ write(phrase);\r
+ CALL Text_Attr(0,normal);\r
+END say;\r
+ \r
+\r
+VAR ok : BOOLEAN,\r
+ L : Library,\r
+ INFO : ARRAYOF INTEGER,\r
+ infofile : RFile,\r
+ extrem : BOOLEAN,\r
+ i : INTEGER,\r
+ f : Base_Fiche,\r
+ menu : CoMenu,\r
+ DataRef : INTEGER;\r
+ \r
+UNIT Library: CLASS;\r
+ \r
+ VAR New_Base : BOOLEAN,\r
+ INV : Inventory;\r
+ \r
+ UNIT Inventory : Relation CLASS;\r
+ VAR AutLeng, TitLeng, Publeng, SubjLeng : INTEGER;\r
+ \r
+ VAR i : INTEGER;\r
+ \r
+ UNIT Fiche : Tuple CLASS;\r
+ VAR Author,\r
+ Title,\r
+ Publisher,\r
+ Subject : ARRAYOF CHAR,\r
+ Year,\r
+ NoInv : INTEGER;\r
+ BEGIN\r
+ ARRAY Author dim(1:AutLeng);\r
+ Author(1) := CHR(13);\r
+ ARRAY Title dim (1:TitLeng);\r
+ Title(1) := CHR(13);\r
+ ARRAY Publisher dim (1:Publeng);\r
+ Publisher(1) := CHR(13);\r
+ ARRAY Subject dim (1:SubjLeng);\r
+ Subject(1) := CHR(13);\r
+ END Fiche;\r
+ \r
+ UNIT VIRTUAL TupleToArray : FUNCTION(F : Fiche):ARRAYOF INTEGER;\r
+ VAR AuxRec :ARRAYOF INTEGER,\r
+ i,cpt :INTEGER;\r
+ BEGIN\r
+ ARRAY AuxRec DIM (1:137);\r
+ FOR i := 1 TO AutLeng\r
+ DO\r
+ AuxRec(i) :=\r
+ ORD(F.Author(i));\r
+ IF ORD(F.Author(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := AutLeng;\r
+ FOR i := 1 TO TitLeng\r
+ DO\r
+ AuxRec(cpt+i) := ORD(F.Title(i));\r
+ IF ORD(F.Title(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := cpt + TitLeng;\r
+ FOR i := 1 TO Publeng\r
+ DO\r
+ AuxRec(cpt+i) := ORD(F.Publisher(i));\r
+ IF ORD(F.Publisher(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := cpt + Publeng;\r
+ FOR i := 1 TO SubjLeng\r
+ DO\r
+ AuxRec(cpt+i) := ORD(F.Subject(i));\r
+ IF ORD(F.Subject(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := cpt + SubjLeng;\r
+ AuxRec(cpt+1) := F.Year;\r
+ AuxRec(cpt+2) := F.NoInv;\r
+ RESULT := AuxRec;\r
+ END TupleToArray;\r
+ \r
+ UNIT VIRTUAL ArrayToTuple : FUNCTION (A :ARRAYOF INTEGER) :Fiche;\r
+ VAR f: Fiche,\r
+ i, cpt :INTEGER;\r
+ BEGIN\r
+ f := NEW Fiche;\r
+ FOR i := 1 TO AutLeng\r
+ DO\r
+ f.Author(i) := CHR(A(i));\r
+ IF A(i) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := AutLeng;\r
+ FOR i := 1 TO TitLeng\r
+ DO\r
+ f.Title(i) := CHR(A(cpt+i));\r
+ IF ORD(f.Title(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := cpt + TitLeng;\r
+ FOR i := 1 TO Publeng\r
+ DO\r
+ f.Publisher(i) := CHR(A(cpt+i));\r
+ IF ORD(f.Publisher(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := cpt + Publeng;\r
+ FOR i := 1 TO SubjLeng\r
+ DO\r
+ f.Subject(i) := CHR(A(cpt+i));\r
+ IF ORD(f.Subject(i)) = 13\r
+ THEN EXIT\r
+ FI\r
+ OD;\r
+ cpt := cpt + SubjLeng;\r
+ f.Year := A(cpt+1);\r
+ f.NoInv := A(cpt+2);\r
+ RESULT := f\r
+ END ArrayToTuple;\r
+ \r
+ UNIT NoInvCatalogue : IndexFile COROUTINE;\r
+ \r
+ UNIT cleNo :Key CLASS;\r
+ VAR NoInv : INTEGER;\r
+ BEGIN END cleNo;\r
+ \r
+ UNIT VIRTUAL KeyOf:FUNCTION (f :Fiche) :cleNo;\r
+ BEGIN\r
+ RESULT := NEW cleNo;\r
+ RESULT.NoInv := f.NoInv;\r
+ END KeyOf;\r
+ \r
+ UNIT VIRTUAL Leq : FUNCTION (k1,k2 : cleNo) : BOOLEAN;\r
+ BEGIN\r
+ RESULT := TRUE;\r
+ IF (k1.NoInv > k2.NoInv)\r
+ THEN RESULT := FALSE\r
+ FI\r
+ END Leq;\r
+ \r
+ UNIT VIRTUAL KeyToRec :PROCEDURE(ky:cleNo, A :ARRAYOF INTEGER;\r
+ j :INTEGER);\r
+ BEGIN\r
+ A(j) := ky.NoInv\r
+ END KeyToRec;\r
+ \r
+ UNIT VIRTUAL RecToKey : FUNCTION(A: ARRAYOF INTEGER,j:INTEGER): cleNo;\r
+ BEGIN\r
+ RESULT := NEW cleNo;\r
+ RESULT.NoInv := A(j);\r
+ END RecToKey;\r
+ \r
+ VAR Akey_NoInv : cleNo;\r
+ \r
+ BEGIN (* NoInvCatalogue *)\r
+ (* OUVERTURE du FICHIER INDEX *)\r
+ KeySize := 1;\r
+ Akey_NoInv := NEW cleNo;\r
+ IF New_Base\r
+ THEN df := MakeFile(UNPACK("NoInv.idx"),2+(PageSize*(KeySize+2)));\r
+ ELSE df := OpenFile(UNPACK("NoInv.idx"),2+(PageSize*(KeySize+2)));\r
+ Path(1).PageRef := INFO(1);\r
+ Path(1).RefOnPage := 1;\r
+ CALL Fseek(df,Path(1).PageRef);\r
+ AuxRec := Fget(df);\r
+ StackOfPages(1) := RecToPage(AuxRec);\r
+ KILL(AuxRec);\r
+ FI;\r
+ RETURN;\r
+ (* FERMETURE DU FICHIER INDEX *)\r
+ FOR i := 1 TO TreeHeight\r
+ DO\r
+ IF Path(i) = NONE THEN EXIT FI;\r
+ IF Path(i).updated\r
+ THEN CALL Fseek(df,Path(i).PageRef);\r
+ CALL Fput(df,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := FALSE\r
+ FI\r
+ OD;\r
+ INFO(1) := Path(1).PageRef;\r
+ CALL CloseFile(df)\r
+ END NoInvCatalogue;\r
+ \r
+ UNIT AuthorsCatalogue : IndexFile COROUTINE;\r
+ \r
+ UNIT cleA :Key CLASS;\r
+ VAR Author :ARRAYOF CHAR,\r
+ NoInv : INTEGER;\r
+ BEGIN\r
+ ARRAY Author dim (1:AutLeng);\r
+ END cleA;\r
+ \r
+ UNIT VIRTUAL KeyOf:FUNCTION (f :Fiche) :cleA;\r
+ BEGIN\r
+ RESULT := NEW cleA;\r
+ RESULT.Author := COPY(f.Author);\r
+ RESULT.NoInv := f.NoInv;\r
+ END KeyOf;\r
+ \r
+ UNIT VIRTUAL Leq : FUNCTION (k1,k2 : cleA) : BOOLEAN;\r
+ VAR i: INTEGER;\r
+ BEGIN\r
+ RESULT := TRUE;\r
+ FOR i := 1 to AutLeng\r
+ DO\r
+ IF ORD(k1.Author(i)) =13\r
+ THEN RETURN\r
+ ELSE IF ORD(k2.Author(i)) = 13\r
+ THEN RESULT := FALSE;\r
+ RETURN\r
+ FI\r
+ FI;\r
+ IF ORD(k1.Author(i)) =/= ORD(k2.Author(i))\r
+ THEN IF ORD(k1.Author(i)) > ORD(k2.Author(i))\r
+ THEN RESULT := FALSE\r
+ FI;\r
+ RETURN\r
+ FI;\r
+ OD;\r
+ IF (k1.NoInv > k2.NoInv)\r
+ THEN RESULT := FALSE\r
+ FI\r
+ END Leq;\r
+ \r
+ UNIT VIRTUAL KeyToRec :PROCEDURE(ky:cleA, A :ARRAYOF INTEGER;\r
+ j :INTEGER);\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ FOR i := 1 TO AutLeng\r
+ DO\r
+ A(j+i-1) := ORD(ky.Author(i))\r
+ OD;\r
+ A(j+AutLeng) := ky.NoInv\r
+ END KeyToRec;\r
+ \r
+ UNIT VIRTUAL RecToKey : FUNCTION(A: ARRAYOF INTEGER,j:INTEGER): cleA;\r
+ BEGIN\r
+ RESULT := NEW cleA;\r
+ FOR i := 1 TO AutLeng\r
+ DO\r
+ RESULT.Author(i) := CHR(A(j+i-1))\r
+ OD;\r
+ RESULT.NoInv := A(j+AutLeng);\r
+ END RecToKey;\r
+ \r
+ VAR Akey_Author : cleA;\r
+ \r
+ BEGIN (* AuthorsCatalogue *)\r
+ (* OUVERTURE du FICHIER INDEX *)\r
+ KeySize := AutLeng + 1;\r
+ Akey_Author := NEW cleA;\r
+ IF New_Base\r
+ THEN df := MakeFile(unpack("Authors.idx"),2+(PageSize*(KeySize+2)));\r
+ ELSE df := OpenFile(unpack("Authors.idx"),2+(PageSize*(KeySize+2)));\r
+ Path(1).PageRef := INFO(2);\r
+ Path(1).RefOnPage := 1;\r
+ CALL Fseek(df,Path(1).PageRef);\r
+ AuxRec := Fget(df);\r
+ StackOfPages(1) := RecToPage(AuxRec);\r
+ KILL(AuxRec);\r
+ FI;\r
+ RETURN;\r
+ (* FERMETURE DU FICHIER INDEX *)\r
+ FOR i := 1 TO TreeHeight\r
+ DO\r
+ IF Path(i) = NONE THEN EXIT FI;\r
+ IF Path(i).updated\r
+ THEN CALL Fseek(df,Path(i).PageRef);\r
+ CALL Fput(df,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := FALSE\r
+ FI\r
+ OD;\r
+ INFO(2) := Path(1).PageRef;\r
+ CALL CloseFile(df)\r
+ END AuthorsCatalogue;\r
+ \r
+ VAR CA :AuthorsCatalogue,\r
+ CInv : NoInvCatalogue,\r
+ NBindexs : INTEGER,\r
+ Ak : Fiche;\r
+ \r
+ BEGIN (* Inventory *)\r
+ IF New_Base\r
+ THEN df := MakeFile(UNPACK("LIBRARY.DAT"),137)\r
+ ELSE df := OpenFile(UNPACK("LIBRARY.DAT"),137)\r
+ FI;\r
+ NBindexs := 2;\r
+ ARRAY Indexs DIM (1:NBindexs);\r
+ AutLeng := 25; TitLeng := 50; Publeng := 40; SubjLeng := 20;\r
+ Ak := NEW Fiche;\r
+ Indexs(1),CInv := NEW NoInvCatalogue;\r
+ Indexs(2),CA := NEW AuthorsCatalogue;\r
+ END Inventory;\r
+ \r
+ UNIT OpenLIB : PROCEDURE;\r
+ BEGIN\r
+ infofile := OpenFile(UNPACK("library.bas"),3);\r
+ INFO := Fget(InfoFile);\r
+ INV := NEW Inventory;\r
+ INV.FreePlace := INFO(3);\r
+ END OpenLIB;\r
+ \r
+ UNIT MakeLIB : PROCEDURE;\r
+ BEGIN\r
+ infofile := MakeFile(UNPACK("library.bas"),3);\r
+ INV := NEW Inventory;\r
+ END MakeLIB;\r
+ \r
+ UNIT CloseLIB : PROCEDURE;\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ CALL cls;\r
+ CALL Text_Attr(0,Gras);\r
+ writeln("> FIN DU PROGRAMME BIBLIOTHEQUE.");\r
+ CALL CloseFile(INV.df);\r
+ FOR i := 1 TO INV.NBindexs DO\r
+ ATTACH(INV.Indexs(i))\r
+ OD;\r
+ INFO(3) := INV.FreePlace;\r
+ CALL Frewind(InfoFile);\r
+ CALL Fput(InfoFile,INFO);\r
+ CALL CloseFile(InfoFile);\r
+ CALL ENDRUN;\r
+ END CloseLIB;\r
+ \r
+BEGIN (* Library *)\r
+ ARRAY INFO dim (1:3);\r
+ CALL cls;\r
+ CALL setcolor(noir,vert);\r
+ CALL GotoXY(2,1);\r
+ write("ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ");\r
+ CALL GotoXY(2,2);\r
+ write("º ABDILLAHI Ibrahim º ");\r
+ CALL GotoXY(2,3);\r
+ write("º AMBAUD Richard º ");\r
+ CALL GotoXY(2,4);\r
+ write("º AMIGO Patrick º ");\r
+ CALL GotoXY(2,5);\r
+ write("º BRIGIDO Angel º ");\r
+ CALL GotoXY(2,6);\r
+ write("º COSTES Francois º ");\r
+ CALL GotoXY(2,7);\r
+ write("º COUDERC Christophe º ");\r
+ CALL GotoXY(2,8);\r
+ write("º CUESTA Mireille º ");\r
+ CALL GotoXY(2,9);\r
+ write("º IBARBIDE Sandrine º ");\r
+ CALL GotoXY(2,10);\r
+ write("ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ");\r
+ CALL setcolor(blanc,rouge);\r
+ CALL GotoXY(35,12);\r
+ write(" GESTION ");\r
+ CALL GotoXY(36,13);\r
+ write(" D'UNE ");\r
+ CALL GotoXY(33,14);\r
+ write(" BIBLIOTHEQUE ");\r
+ CALL setcolor(magenta,bleu);\r
+ CALL GotoXY(8,23);\r
+ write("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿");\r
+ CALL GotoXY(8,24);\r
+ write("³ Voulez-vous utilisez une nouvelle base de donn\82es (O/N) ? : ³");\r
+ CALL GotoXY(8,25);\r
+ write("ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ");\r
+ CALL GotoXY(70,24);\r
+ CALL setcolor(blanc,noir);\r
+ DO\r
+ i := INCHAR;\r
+ CASE i\r
+ WHEN ESC : CALL cls;\r
+ CALL GotoXY(1,1);\r
+ writeln("Sortie [ESCAPE], retour au systeme.");\r
+ CALL ENDRUN;\r
+ WHEN 79,89,\r
+ 111,121 : (* OUI *)\r
+ write("O");\r
+ New_Base := TRUE;\r
+ CALL MakeLIB;\r
+ EXIT;\r
+ WHEN 78,110 : (* NON *)\r
+ write("N");\r
+ New_Base := FALSE;\r
+ CALL OpenLIB;\r
+ EXIT;\r
+ OTHERWISE write(CHR(7));\r
+ ESAC;\r
+ OD;\r
+ CALL GotoXY(1,25);\r
+ FOR i:=1 to 25 \r
+ DO\r
+ writeln;\r
+ OD;\r
+ CALL CLS;\r
+END Library;\r
+ \r
+UNIT CoMenu : COROUTINE;\r
+CONST nbchoix = 4;\r
+VAR tchoix : ARRAYOF string,\r
+ choix,i : INTEGER;\r
+ \r
+ UNIT mov_choix: PROCEDURE(No: INTEGER);\r
+ BEGIN\r
+ CALL setcolor(blanc,noir);\r
+ CALL affchoix(34,choix+5,tchoix(choix));\r
+ choix := choix+No;\r
+ IF (choix > nbchoix)\r
+ THEN choix := 1;\r
+ ELSE IF (choix = 0)\r
+ THEN choix := nbchoix;\r
+ FI;\r
+ FI;\r
+ CALL text_attr(1,inverse);\r
+ CALL affchoix(34,choix+5,tchoix(choix));\r
+ CASE (choix)\r
+ WHEN 1: CALL say(\r
+ "Ajouter des livres \85 la librairie.");\r
+ WHEN 2: CALL say(\r
+ "Suprimer des livres de la librairie.");\r
+ WHEN 3: CALL say(\r
+ "Rechercher un livre \85 partir des catalogues (auteurs/sujets).");\r
+ WHEN 4: CALL say(\r
+ "Quitter ");\r
+ ESAC;\r
+ END mov_choix;\r
+ \r
+ UNIT affchoix : PROCEDURE(x,y : INTEGER;ch : string);\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ CALL GotoXY(x,y);\r
+ write(ch);\r
+ END affchoix;\r
+ \r
+\r
+BEGIN (* CoMenu *)\r
+ ARRAY tchoix DIM (1:nbchoix);\r
+ tchoix(1) := "AJOUTER ";\r
+ tchoix(2) := "SUPPRIMER ";\r
+ tchoix(3) := "RECHERCHER";\r
+ tchoix(4) := "QUITTER ";\r
+ choix := 1;\r
+ RETURN;\r
+ DO\r
+ CALL cls;\r
+ CALL setcolor(jaune,noir);\r
+ CALL GotoXY(1,5);\r
+ writeln(" ÚÄÄÄÄMenuÄÄÄÄ¿");\r
+ writeln(" ³ ³");\r
+ writeln(" ³ ³");\r
+ writeln(" ³ ³");\r
+ writeln(" ³ ³");\r
+ writeln(" ÀÄÄÄÄÄÄÄÄÄÄÄÄÙ");\r
+ CALL GotoXY(1,5);\r
+ CALL setcolor(blanc,noir);\r
+ FOR i := 1 TO nbchoix \r
+ DO\r
+ CALL affchoix(34,i+5,tchoix(i));\r
+ OD;\r
+ CALL mov_choix(0);\r
+ DO\r
+ i := INCHAR;\r
+ CASE i\r
+ WHEN Fhaut : CALL mov_choix(-1);\r
+ WHEN Fbas : CALL mov_choix(1);\r
+ WHEN ESC : CALL mov_choix(4-choix);\r
+ DETACH;\r
+ EXIT;\r
+ WHEN RETOUR : DETACH;\r
+ EXIT;\r
+ OTHERWISE REPEAT;\r
+ ESAC;\r
+ OD;\r
+ OD;\r
+END CoMenu;\r
+ \r
+HANDLERS\r
+ WHEN Del_Rec_Inexistant:\r
+ RETURN;\r
+ WHEN Signal11 :\r
+ extrem := TRUE;\r
+ RETURN;\r
+ WHEN Signal12 :\r
+ extrem := TRUE;\r
+ RETURN;\r
+END HANDLERS;\r
+ \r
+(*******************************************************************)\r
+(******************** programme principal **************************)\r
+(*******************************************************************)\r
+\r
+BEGIN\r
+ CALL Text_Attr(0,Normal);\r
+ CALL cls;\r
+ L := NEW Library;\r
+ Menu := NEW CoMenu;\r
+ DO\r
+ ATTACH(menu);\r
+ CASE Menu.choix\r
+ WHEN 1: (* INSERTION de TUPLES dans la BASE *)\r
+ CALL cls;\r
+ DO\r
+ f := NEW Fiche_Saisie;\r
+ IF ok\r
+ THEN CALL L.INV.InsertTuple(L.INV.Ak);\r
+ CALL say(\r
+ "INSERTION REALISEE, Taper une touche pour continuer");\r
+ i := INCHAR;\r
+ KILL(f);\r
+ ELSE EXIT\r
+ FI;\r
+ OD;\r
+ KILL(f);\r
+ WHEN 2: (* DESTRUCTION de TUPLES de la BASE *)\r
+ DO\r
+ CALL say(\r
+ "No inventaire du livre a supprimer ?: [ESC] = Abandon");\r
+ L.INV.Ak.NoInv := Read_Entier(40,25,5);\r
+ IF (L.INV.Ak.NoInv =/= -1) AND (L.INV.Ak.NoInv =/= -2)\r
+ THEN L.INV.CInv.AKey_NoInv := L.INV.CInv.KeyOf(L.INV.Ak);\r
+ DataRef := L.INV.CInv.FindKey(L.INV.CInv.AKey_NoInv);\r
+ IF (DataRef = -1)\r
+ THEN write(chr(7));\r
+ CALL say(\r
+ "SUPPRESSION DE LIVRE INEXISTANT !!!. taper une touche");\r
+ i := INCHAR;\r
+ ELSE writeln("DATAREF = ",dataref);\r
+ CALL L.INV.DeleteTuple(L.INV.Ak);\r
+ CALL say(\r
+ "SUPPRESSION REALISEE !!!. taper une touche");\r
+ i := INCHAR;\r
+ \r
+ FI;\r
+ ELSE EXIT;\r
+ FI\r
+ OD;\r
+ WHEN 3: (* RECHERCHE de TUPLES dans la BASE *)\r
+ \r
+ WHEN 4: (* CONFIRMATION DE LA SORTIE *)\r
+ CALL setcolor(blanc,noir);\r
+ CALL cls;\r
+ write(chr(7));\r
+ CALL setcolor(blanc,rouge);\r
+ CALL Gotoxy(13,10);\r
+ write(" CONFIRMER LA SORTIE DU PROGRAMME ");\r
+ CALL Gotoxy(13,11);\r
+ write(" ");\r
+ CALL Gotoxy(13,12);\r
+ write(" SORTIR ( O / N ) ? ");\r
+ CALL setcolor(blanc,noir);\r
+ DO\r
+ i := INCHAR;\r
+ CASE i\r
+ WHEN 79,111 : (* OUI = "O" ou "o" *)\r
+ CALL L.CloseLIB; \r
+ WHEN 78,110 : (* NON = "N" ou "n" *)\r
+ CALL GotoXY(59,12); \r
+ CALL cls;\r
+ EXIT;\r
+ OTHERWISE write(CHR(7));\r
+ (*REPEAT*)\r
+ ESAC;\r
+ OD;\r
+ ESAC;\r
+ CALL Menu.mov_choix(0);\r
+ OD;\r
+END;\r
+\r
+\r
+END BIBLIOTHEQUE\r
+(****************************************************************************)\r
--- /dev/null
+program test19;\r
+(* 19 lipiec 1988\r
+ \r
+ ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»\r
+ º m o d u l o b s l u g i º\r
+ º r e l a c j i º\r
+ º º\r
+ ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ\r
+ \r
+ zadaniem modulu jest zrealizowanie systemu wspolpracy z\r
+ relacjami i krotkami: modul opisuje te pojecia i definiuje\r
+ operacje na nich: insert, delete, make etc.*)\r
+ \r
+ \r
+ (***************************************************)\r
+ (* *)\r
+ (* Assumptions on file system *)\r
+ (* *)\r
+ (* The module handling relations assumes a file *)\r
+ (* system of random access files. The signature *)\r
+ (* of file system consists of four sorts: *)\r
+ (* P - files, *)\r
+ (* R - records, *)\r
+ (* S - file's names, *)\r
+ (* N - nonnegative integers *)\r
+ (* and several operations and predicates, *)\r
+ (* makefile : S x N -> P *)\r
+ (* openfile : S x N -> P *)\r
+ (* closefile : P -> P *)\r
+ (* isopen? : P -> B0 *)\r
+ (* frewind : P -> P *)\r
+ (* feof : P -> B0 *)\r
+ (* fput : P x R -> P *)\r
+ (* fget : P -> R *)\r
+ (* fseek : P x N -> P *)\r
+ (* position : P -> N *)\r
+ (* filelen : P -> N *)\r
+ (* *)\r
+ (* which satisfy the following properties *)\r
+ (* *)\r
+ (* isopen?(makefile(s,n)) *)\r
+ (* position(makefile(s,n)) = 1 *)\r
+ (* feof(p) <=> (position(p) = filelen(p)) *)\r
+ (* ªisopen?(closefile(p)) *)\r
+ (* position(frewind(p)) = 1 *)\r
+ (* k<filelen(p) => position(fseek(p,k)) = k *)\r
+ (* *)\r
+ (* isopen?(p) => (p':=fput(p,r))(k:=position(p')) *)\r
+ (* (p":=fseek(p',k-1)) (r':=fget(p")) (r =r') *)\r
+ (* *)\r
+ (* isopen?(p) => (p':=frewind(p)) *)\r
+ (* (while ªfeof(p') do r:= fget(p') od) true *)\r
+ (* *)\r
+ (* position(p) ó filelen(p) *)\r
+ (* *)\r
+ (*** * * * * * * * * * * * * * * * * * * * * * * ***)\r
+ \r
+unit FileSystem: class;\r
+ (* system plikow bezposredniego dostepu *)\r
+ \r
+ \r
+ (************************************************************)\r
+ (* T Y P Y D A N Y C H *)\r
+ (************************************************************)\r
+ \r
+ unit Rfile: class;\r
+ (* plik jest ciagiem ponumerowanych rekordow\r
+ jednakowej dlugosci *)\r
+ \r
+ var name: arrayof char (* nazwa zewnetrzna *),\r
+ opened: boolean (* czy otwarty *),\r
+ reclen (* dlugosc rekordu - w slowach *),\r
+ (* rozmiar slowa odpowiada rozmiarowi\r
+ liczby typu integer *)\r
+ position (* numer biezacego rekordu *),\r
+ length: integer (* dlugosc pliku -\r
+ numer pozycji nastepnej po\r
+ ostatniej zajetej *),\r
+ plik: file (* plik bezposredniego dostepu *),\r
+ next, prev: Rfile (* wszystkie pliki w systemie\r
+ sa powiazane w liste\r
+ dwukierunkowa *)\r
+ end Rfile;\r
+ \r
+ \r
+ var system: Rfile; (* dowiazanie do straznika listy plikow *)\r
+ \r
+ \r
+ \r
+ \r
+ \r
+(******************************************************************)\r
+(******************************************************************)\r
+ \r
+ \r
+ \r
+ (*****************************************************************)\r
+ (* P R O C E D U R Y I F U N K C J E *)\r
+ (* S Y S T E M U P L I K O W *)\r
+ (*****************************************************************)\r
+ \r
+ \r
+ \r
+ (******************************)\r
+ (* A U X I L I A R Y *)\r
+ (******************************)\r
+ \r
+ \r
+ \r
+ unit FindInSystem: function\r
+ ( name:arrayof char): Rfile ;\r
+ \r
+ unit equalstring: function\r
+ (s1, s2: arrayof char): boolean;\r
+ var i1, i2, len, i: integer;\r
+ begin\r
+ if s1 = none then\r
+ writeln(" 1st parameter in equalstring=none");\r
+ call endrun fi;\r
+ if s2 = none then\r
+ writeln(" 2nd parameter in equalstring=none");\r
+ call endrun fi;\r
+ i1 := lower(s1); i2 := lower(s2);\r
+ len := upper(s1) - i1 + 1;\r
+ if len =/= upper(s2) - i2 + 1\r
+ then return fi;\r
+ for i := 1 to len\r
+ do if s1(i1) =/= s2(i2)\r
+ then return fi;\r
+ i1 := i1 + 1;\r
+ i2 := i2 + 1;\r
+ od;\r
+ result := true\r
+ end equalstring;\r
+ \r
+ var p: Rfile;\r
+ begin system.name := name;\r
+ p := system.next;\r
+ while not equalstring( name, p.name )\r
+ do p := p.next od;\r
+ if (p = system) then result := none\r
+ else result := p fi;\r
+ end FindInSystem;\r
+ \r
+ (*********************************)\r
+ \r
+ unit AddToSystem: function\r
+ (name: arrayof char): Rfile;\r
+ begin\r
+ result := new Rfile;\r
+ result.name := name;\r
+ result.next := system.next;\r
+ result.prev := system;\r
+ system.next.prev := result;\r
+ system.next := result;\r
+ end AddToSystem;\r
+ \r
+ (*********************************)\r
+ \r
+ unit DeleteFromSystem: procedure\r
+ (p:Rfile);\r
+ begin\r
+ if p = system then return fi;\r
+ p.next.prev := p.prev;\r
+ p.prev.next := p.next\r
+ end DeleteFromSystem;\r
+ \r
+ (********************************)\r
+ \r
+ unit FindFileLength: function\r
+ (p: file, recl:integer): integer;\r
+ \r
+ (* odtwarza dlugosc istniejacego pliku,\r
+ recl - dlugosc rekord w slowach *)\r
+ \r
+ var record: arrayof integer, i:integer;\r
+ begin\r
+ if p = none then\r
+ write(" FS - FindFileLength - ");\r
+ writeln("file object does not exist");\r
+ return;\r
+ fi; \r
+ result := 1;\r
+ call reset(p);\r
+ array record dim (1:recl);\r
+ i := recl*intsize;\r
+ do\r
+ getrec(p,record,i);\r
+ if i =/= recl*intsize then exit fi;\r
+ result := result + 1;\r
+ od;\r
+ end FindFileLength; \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+(*****************************************************************)\r
+ \r
+(* M A K E F I L E *)\r
+ \r
+ (* utworzenie i dolaczenie do systemu nowego pliku\r
+ o zadanej nazwie i dlugosci rekordu *)\r
+ \r
+ \r
+ \r
+ unit makefile: function\r
+ ( name: arrayof char (* nazwa zewnetrzna pliku *),\r
+ reclen: integer (* dlugosc rekordu pliku *) ): Rfile;\r
+ \r
+ begin\r
+ if FindInSystem(name) =/= none\r
+ (* istnieje w systemie plik o tej nazwie *)\r
+ then\r
+ writeln(" FS - makefile - file name duplicated");\r
+ fi;\r
+ if reclen <= 0\r
+ then\r
+ writeln(" FS - makefile - record length should be possitive");\r
+ fi;\r
+ result := AddToSystem(name); \r
+ result.opened := true;\r
+ result .reclen := reclen;\r
+ result.position := 1;\r
+ result.length := 1;\r
+ open (result.plik, direct, name);\r
+ call rewrite(result.plik);\r
+ end makefile; \r
+ \r
+ \r
+(***************************************************************)\r
+ \r
+(* O P E N F I L E *)\r
+ \r
+ (* otwarcie i ewentualne dolaczenie do systemu\r
+ pliku o zadanej nazwie zewnetrznej i rozmiarze\r
+ rekordu *)\r
+ \r
+ \r
+ \r
+ unit openfile: function\r
+ (name: arrayof char (* nazwa zewnetrzna pliku *),\r
+ reclen: integer (* dlugosc rekordu pliku *) ): Rfile;\r
+ \r
+ begin\r
+ if reclen <= 0\r
+ then\r
+ writeln(" FS - openfile - record length should be possitive");\r
+ fi;\r
+ result := FindInSystem(name);\r
+ if result = none then result := AddToSystem(name) fi;\r
+ result.opened := true;\r
+ result.reclen := reclen;\r
+ result.position := 1;\r
+ open(result.plik, direct, name);\r
+ result.length := FindFileLength(result.plik,reclen);\r
+ if result.length = 1 then call rewrite(result.plik)\r
+ else call reset(result.plik) fi;\r
+ end openfile;\r
+ \r
+ \r
+(***************************************************************)\r
+ \r
+(* C L O S E F I L E *)\r
+ \r
+ (* zamkniecie pliku z usunieciem obiektu pliku ;\r
+ obiekt typu Rfile pozostaje w systemie z odpowiednia\r
+ adnotacja *)\r
+ \r
+ \r
+ unit closefile: procedure (p:Rfile);\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - closefile - closing nonexisting file");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - closefile - closing not opened file");\r
+ fi;\r
+ p. opened := false;\r
+ kill(p.plik)\r
+ end closefile;\r
+ \r
+ \r
+ \r
+(****************************************************************)\r
+ \r
+(* I S O P E N *)\r
+ \r
+ (* sprawdzenie, czy plik jest otwarty *)\r
+ \r
+ \r
+ unit isopen: function( p:Rfile): boolean;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - isopen - testing nonexisting file");\r
+ fi;\r
+ result := p.opened\r
+ end isopen;\r
+ \r
+ \r
+(****************************************************************)\r
+ \r
+(* F R E W I N D *)\r
+ \r
+ (* przewiniecie pliku do poczatku *)\r
+ \r
+ \r
+ unit frewind: procedure( p:Rfile);\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - frewind - rewinding nonexisting file");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - frewind - rewinding net opened file");\r
+ fi;\r
+ p.position := 1;\r
+ call reset(p.plik)\r
+ end frewind;\r
+ \r
+ \r
+(**************************************************************)\r
+ \r
+(* F E O F *)\r
+ \r
+ (* test, czy koniec pliku *)\r
+ \r
+ \r
+ unit feof: function(p: Rfile): boolean;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - feof - testing nonexisting file");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - feof - testing not opened file");\r
+ fi;\r
+ result := ( p.position >= p.length )\r
+ end feof;\r
+ \r
+ \r
+(**************************************************************)\r
+ \r
+(* F P U T *)\r
+ \r
+ (* wlozenie rekordu na plik w miejsce wskazane przez\r
+ atrybut position *)\r
+ \r
+ \r
+ \r
+ unit fput: procedure( p: Rfile, Record: arrayof integer);\r
+ \r
+ var ile, i : integer;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - fput - file does not exist"); i:= inchar;\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - fput - file not opened");\r
+ fi;\r
+ if p.position > p.length\r
+ then\r
+ writeln(" FS - fput - try to access after file length");\r
+ fi;\r
+ if Record = none\r
+ then\r
+ writeln(" FS - fput - record does not exist");\r
+ fi;\r
+ ile := upper(Record) - lower(Record) + 1;\r
+ if ile =/= p.reclen\r
+ then\r
+ writeln(" FS - fput - wrong record length");\r
+ fi;\r
+ i := ile * intsize;\r
+ putrec(p.plik, Record, i);\r
+ if i =/= ile * intsize\r
+ then\r
+ writeln(" FS - fput - error during writing ");\r
+ fi;\r
+ p.position := p.position + 1;\r
+ if p.position > p.length then p.length := p.position fi;\r
+ end fput;\r
+ \r
+ \r
+(**************************************************************)\r
+ \r
+(* F G E T *)\r
+ \r
+ (* odczytanie rekordu z pliku z miejsca wskazywanego\r
+ przez atrybut position *)\r
+ \r
+ \r
+ unit fget: function( p: Rfile): arrayof integer;\r
+ var Record: arrayof integer,\r
+ ile, i : integer;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - fget - file does not exist ");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - fget - file not opened");\r
+ fi;\r
+ if p.position >= p.length\r
+ then\r
+ writeln(" FS - fget - try to read past eof");\r
+ fi;\r
+ ile := p.reclen;\r
+ array Record dim (1:ile);\r
+ i := ile * intsize;\r
+ getrec(p.plik, Record, i);\r
+ if i =/= ile * intsize\r
+ then\r
+ writeln(" FS - fget - error during reading");\r
+ fi;\r
+ p.position := p.position + 1;\r
+ result := Record;\r
+ end fget;\r
+ \r
+ \r
+ \r
+(*************************************************************)\r
+ \r
+(* F S E E K *)\r
+ \r
+ (* wyszukanie w pliku rekordu o zadanym numerze -\r
+ ustawienie atrybutu position *)\r
+ \r
+ \r
+ \r
+ unit fseek: procedure( p: Rfile, nrrec: integer);\r
+ \r
+ var offset: integer;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - fseek - file does not exist");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - fseek - file not opened");\r
+ fi;\r
+ if nrrec <= 0\r
+ then\r
+ writeln(" FS - fseek - record number should be positive");\r
+ fi;\r
+ if nrrec > p.length\r
+ then\r
+ writeln(" FS - fseek - try to access after file length");\r
+ fi;\r
+ p.position := nrrec;\r
+ offset := (nrrec - 1) * p.reclen * intsize;\r
+ call seek(p.plik, offset, 0)\r
+ end fseek;\r
+ \r
+ \r
+ \r
+(************************************************************)\r
+ \r
+(* P O S I T I O N *)\r
+ \r
+ (* answeres the current position of file pointer *)\r
+ \r
+ \r
+ unit position: function( p: Rfile): integer;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - position - checking nonexisting file");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - position - checking not opened file");\r
+ fi;\r
+ result := p.position\r
+ end position;\r
+ \r
+ \r
+(************************************************************)\r
+ \r
+(* F I L E L E N *)\r
+ \r
+ (* gives the file length - the number of position\r
+ immediately after the last one *)\r
+ \r
+ \r
+ unit filelen: function( p: Rfile): integer;\r
+ begin\r
+ if p = none\r
+ then\r
+ writeln(" FS - filelen - checking nonexisting file");\r
+ fi;\r
+ if not p.opened\r
+ then\r
+ writeln(" FS - filelen - checking not opened file");\r
+ fi;\r
+ result := p.length\r
+ end filelen;\r
+ \r
+ \r
+(**************************************************************)\r
+(**************************************************************)\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ begin (* of FileSystem *)\r
+ system := new Rfile;\r
+ system.next, system.prev := system;\r
+ end FileSystem;\r
+ \r
+(***************************************************************)\r
+(* Pakiet Grafiki Blokowej *)\r
+(* *)\r
+(* *)\r
+(* *)\r
+(* *)\r
+(***************************************************************)\r
+ unit Bold : procedure;\r
+ begin\r
+ write( chr(27), "[1m")\r
+ end Bold;\r
+ \r
+ unit Blink : procedure;\r
+ begin\r
+ write( chr(27), "[5m")\r
+ end Blink;\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+ \r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ unit Underscore : procedure;\r
+ begin\r
+ write( chr(27), "[4m")\r
+ end Underscore;\r
+ \r
+ \r
+ \r
+ unit inchar : IIuwgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+h(***************************************************************)\r
+(* koniec Grafiki *)\r
+(***************************************************************)\r
+ \r
+unit HandlerOfRelations : FileSystem class(PageSize: integer,\r
+ TreeHeight: integer,\r
+ HalfPageSize : integer) ;\r
+ signal signal8, (*przekroczono wysokosc TreeHeight *)\r
+ signal14, (*dwa identyczne klucze o jednakowych ref*)\r
+ Signal13; (*sygnal usuwania nieobecnego rekordu*)\r
+ signal Signal11, (*nie ma poprzednika w PrevKey*)\r
+ Signal12; (*nie ma nastepnika w NextKey*)\r
+ \r
+ \r
+ unit Node : class;\r
+ (*klasa prefiksujaca wszystkie klasy wykorzystywane w\r
+ interpreterze*)\r
+ var Gender:integer\r
+ begin\r
+ end Node;\r
+ \r
+(* unit ObjectToRec : function (n : Node) : arrayof integer;\r
+ end ObjectToRec;\r
+ \r
+ unit RecToObject : function(a: arrayof integer) : Node;\r
+ end RecToObject;*)\r
+ \r
+(*struktura logiczna\r
+ \r
+ DataFile\r
+ / | \\r
+ Atrybut \ .\r
+ | Relation \ |\r
+ | \ |\r
+ | |\r
+ | |IndexFile | |\r
+ | | | |\r
+ | _______________________ | *)\r
+ \r
+ \r
+ \r
+ (********************************************\r
+ * *\r
+ * DataFile *\r
+ * *\r
+ * Reset *\r
+ * AddRec *\r
+ * DelRec *\r
+ * FindRec *\r
+ * FreePlace *\r
+ * *\r
+ * *\r
+ ********************************************)\r
+ \r
+ unit DataFile : Node class;\r
+ (*typ DataFile jest wspolnym prefiksem dla Atrybut i\r
+Relation i IndexFile. Ten typ umo*liwia operacje\r
+ Wstaw Rekord, UsunRekord etc. *)\r
+ var plik : Rfile;\r
+ var FreePlace : integer; (* pozycja wolnego miejsca\r
+ w pliku*)\r
+ \r
+ \r
+ unit Reset : procedure ;\r
+ begin\r
+ call fseek(plik,1);\r
+ end Reset;\r
+ \r
+ unit AddRec : procedure (input Record:arrayof integer;\r
+ output RefRec:integer);\r
+ (*Procedura wstawia rekord Record do DataFile i zwraca\r
+jego pozycje w pliku wykorzystujac przy tym informacje o\r
+wolnych miejscach zapamietana na stosie FreePlace*)\r
+ \r
+ var AuxRec: arrayof integer;\r
+ begin\r
+ array AuxRec dim(lower(Record):upper(Record));\r
+ if FreePlace=0\r
+ then\r
+ RefRec:=FileLen(plik);\r
+ (*jesli nie bylo usunietych rekordow, to Record\r
+ zapiszemy na koncu pliku*)\r
+ else\r
+ RefRec:=FreePlace;\r
+ call fseek(plik,RefRec);\r
+ AuxRec:=fget(plik);(*odczytanie pozycji poprzed\r
+ niego wolnego miejsca, ktore\r
+ bedzie teraz aktualnym wolnym miejscem*)\r
+ FreePlace:=AuxRec(1);\r
+ fi;\r
+ call fseek(plik,RefRec);\r
+ call fput(plik,Record)\r
+ end AddRec;\r
+ \r
+ unit DelRec: procedure(input DataRef: integer);\r
+ (*Procedura usuwa rekord wskazany przez DataRef i wpisuje\r
+na jego miejsce referencje do ostatniego wolnego miejsca.\r
+Pozycja usunietego rekordu jest zapamietana na stosie\r
+FreePlace *)\r
+ \r
+ var AuxRec: arrayof integer;\r
+ begin\r
+ call fseek(plik,DataRef);\r
+ array AuxRec dim (1 : plik.reclen);\r
+ AuxRec(1):=FreePlace;\r
+ call fput(plik,AuxRec);\r
+ FreePlace:=DataRef;\r
+ end DelRec;\r
+ \r
+ unit FindRec:procedure(input Record:arrayof integer;\r
+ output RefRec : integer);\r
+(*Procedura FindRec odszukuje rekord wskazany przez Record\r
+i zwraca jego pozycje w pliku*)\r
+ var equal :boolean,\r
+ i, Place: integer,\r
+ AuxRec: arrayof integer;\r
+ begin\r
+ array AuxRec dim(lower(Record): upper(Record));\r
+ call Reset;\r
+ equal:=false;\r
+ while (not feof(plik) and not equal)\r
+ do\r
+ RefRec := position(plik);\r
+ AuxRec:= fget(plik);\r
+ for i:=lower(AuxRec) to upper(AuxRec)\r
+ do\r
+ equal:= AuxRec(i)=Record(i);\r
+ if not equal then exit fi\r
+ od (*koniec porownywania rekordow*);\r
+ (* czy znaleziony jest usunietym wczesniej rekordem? *)\r
+ if (equal and FreePlace <> 0)\r
+ then\r
+ Place:=FreePlace;\r
+ while not Place=0\r
+ do\r
+ if RefRec = Place\r
+ then\r
+ equal:=false;\r
+ exit (*if equal*)\r
+ else\r
+ call fseek(plik,Place);\r
+ AuxRec:=fget(plik);\r
+ Place:=AuxRec(1)\r
+ fi;\r
+ od;\r
+ call fseek(plik,RefRec+plik.reclen);\r
+ fi (*if equal*);\r
+ od (*eof plik*);\r
+ if not equal\r
+ then\r
+ RefRec:=-1(*nie znalezlismy rekordu*)\r
+ fi;\r
+ end FindRec;\r
+ \r
+ begin (*DataFile*)\r
+ \r
+ FreePlace:=0\r
+ end DataFile;\r
+ \r
+(*\r
+ ********************************************\r
+ * Relation *\r
+ * *\r
+ * insert *\r
+ * delete *\r
+ * retrieve *\r
+ * member *\r
+ * close *\r
+ * open *\r
+ * allocate *\r
+ * deallocate *\r
+ * *\r
+ ********************************************\r
+*)\r
+unit Relation : DataFile class ;\r
+ var Index :arrayof IndexFile;\r
+ \r
+ unit Tuple : Node class;\r
+ (*element relacji*)\r
+ end Tuple;\r
+ \r
+ unit virtual TupleToRec : function (t : Tuple): arrayof\r
+ integer;\r
+ end TupleToRec ;\r
+ \r
+ unit virtual RecToTuple : function(a : arrayof integer):\r
+ Tuple;\r
+ end RecToTuple;\r
+ \r
+ \r
+ \r
+ unit Insert: procedure (t: Tuple);\r
+ var i,PageRef,DataRef:integer;\r
+ var AuxRec : arrayof integer;\r
+ begin\r
+ AuxRec:=TupleToRec(t);\r
+ call AddRec(AuxRec, DataRef);\r
+ if Index <> none\r
+ then\r
+ for i:=1 to upper(Index)\r
+ do\r
+ if Index(i)<>none\r
+ then\r
+ call Index(i).AddKey(Index(i).KeyOf(t),DataRef)\r
+ fi\r
+ od;\r
+ fi;\r
+ end Insert;\r
+ \r
+ unit Delete : procedure (t: Tuple);\r
+ var i,DataRef :integer,\r
+ AuxRec : arrayof integer;\r
+ begin\r
+ if Index =/= none\r
+ then (*najpierw szukamy w indeksach i usuwamy tam*)\r
+ for i:=1 to upper(Index)\r
+ do\r
+ if none <> Index(i)\r
+ then\r
+ DataRef := Index(i).FindKey(Index(i).KeyOf(t));\r
+ call Index(i).DelKey(Index(i).KeyOf(t),DataRef);\r
+ (*\r
+DelKey dziala? *)\r
+ fi;\r
+ od\r
+ else (*brak indeksu*)\r
+ AuxRec := TupleToRec(t);\r
+ call FindRec(AuxRec, DataRef);\r
+ fi;\r
+ if DataRef = -1\r
+ then\r
+ raise Signal13 (*proba usuniecia rekordu ktorego nie ma*)\r
+ else\r
+ call DelRec(DataRef) ; (*wstawic na liste usuniec*)\r
+ fi\r
+ end Delete;\r
+ \r
+ \r
+ (* ********************************************\r
+ * IndexFile *\r
+ * *\r
+ * Key *\r
+ * Order *\r
+ * Item *\r
+ * Page *\r
+ * Addkey *\r
+ * DelKey *\r
+ * NextKey *\r
+ * FindKey *\r
+ * SearchKey *\r
+ * PrevKey *\r
+ * MinKey *\r
+ * MaxKey *\r
+ * Path *\r
+ * CloseIndex *\r
+ ********************************************\r
+*)\r
+ \r
+unit IndexFile : DataFile coroutine;\r
+ \r
+ \r
+ unit SearchStep: class;\r
+ var PageRef,RefOnPage : integer,\r
+ updated : boolean;\r
+ end SearchStep;\r
+ \r
+ unit Item : class ;\r
+ var ky: key, PageRef: integer, DataRef: integer;\r
+ (* item jest jednostka ( rekordem) przechowywana w\r
+ indeksie na stronie tzn.Page\r
+ zawiera:\r
+ ky - klucz,\r
+ PageRef - informacje o stronie na ktorej znajduje sie\r
+ korzen poddrzewa z kluczami wiekszymi od klucza kl,\r
+ a mniejszymi od kluczy podporzadkowanych sasiadowi z\r
+ lewej,\r
+ DataRef - informacja w ktorym rekordzie zapisano\r
+ krotke odpowiadajaca naszemu kluczowi ky*)\r
+ end Item;\r
+ \r
+ unit Page: class;\r
+ var ItemsOnPage, (*ilu synow ma ta strona +1*)\r
+ LessPageRef: integer; (*wskaznik do poddrzewa elementow\r
+mniejszych od pierwszego klucza na tej stronie*)\r
+ var ItemsArray: arrayof Item;\r
+ begin\r
+ array ItemsArray dim (1:PageSize)\r
+ end Page;\r
+ \r
+ var KeySize: integer;\r
+ \r
+ unit key : Node class ;\r
+ (*definicja klucza zgodnie z zyczeniem uzytkownika*)\r
+ end key;\r
+ \r
+ \r
+ var StackOfPages: arrayof Page;\r
+ var Finger: integer; (*zmienne StackOfPages i Finger\r
+ implementuja stos stron*)\r
+ var Path: arrayof SearchStep; (*zmienne Path i Finger\r
+ implementuja sciezke*)\r
+ \r
+(* axiom: nr strony wskazanej przez Finger w StackOfPages jest\r
+ identyczny z numerem strony wskazanym przez Finger w Path*)\r
+ \r
+ unit virtual KeyOf : function (t : Tuple) : key;\r
+ (*KeyOf tworzy z dowolnej krotki klucz zaleznie od\r
+ rozwazanego indeksu*)\r
+ end KeyOf;\r
+ \r
+ unit virtual Leq: function (k1,k2 : key):Boolean;\r
+ (* Leq sprawdza czy krotki k1,k2 sa w relacji\r
+ obowiazujacej w rozwazanym indeksie\r
+ zakladamy, ze jest to relacja antysymetryczna*)\r
+ end Leq;\r
+ \r
+ \r
+ unit AddKey : procedure (input ky:key,DataRef:integer);\r
+ (*wstawienie klucza ky i referencji DataRef do indexu w odpowiednie\r
+ miejsce w B-drzewie\r
+ DataRef jest adresem rekordu ktory odpowiada kluczowi\r
+ w pliku relacji*)\r
+ var depth, (*aktualna glebokosc stosu stron*)\r
+ PageRef,\r
+ i : integer,\r
+ AddItem, AuxItem, itm2 : Item,\r
+ IncreaseHeight : boolean,\r
+ NewRoot : Page,\r
+ AuxRec : arrayof integer;\r
+ \r
+ unit Search : procedure (input itm1 : Item, PageRef :\r
+ integer;\r
+ output include : boolean, itm2 :\r
+ Item);\r
+ (*szukaj poczawszy od strony PageRef, miejsca dla itm1;\r
+ jezeli nie znajdzie miejsca na tej stronie to\r
+rekurencyjnie szuka na nastepnej odpowiedniej az do\r
+liscia;\r
+ jezeli include to WSTAWIA obiekt itm2*)\r
+ \r
+ var NextPageRef,\r
+ ItemRef : integer,\r
+ inclde : boolean,\r
+ item2 : Item,\r
+ AuxPage : Page;\r
+ \r
+ unit Insert : procedure;\r
+ (*wstawia obiekt itm2 na strone PageRef w miejscu ItemRef*)\r
+ var OldPage, RightPage : Page,\r
+ AuxRec : arrayof integer,\r
+ AuxItmArr ,\r
+ AuxItmArr2 : arrayof Item,\r
+ RightPageRef,\r
+ i : integer;\r
+ begin (*Insert*)\r
+ OldPage := StackOfPages(Finger);\r
+ if OldPage.ItemsOnPage < PageSize\r
+ then (*jest miejsce na tej stronie *)\r
+ call UpdatePage (item2, ItemRef, OldPage);\r
+ Path(Finger).RefOnPage := ItemRef + 1;\r
+ include := false;\r
+ else (*strona jest pelna dokonujemy podzialu *)\r
+ include := true;\r
+ OldPage.ItemsOnPage := HalfPageSize;\r
+ Path(Finger).updated := true;\r
+ RightPage := new Page;\r
+ RightPage.ItemsOnPage := HalfPageSize;\r
+ array RightPage.ItemsArray dim (1:PageSize);\r
+ AuxItmArr := OldPage.ItemsArray;\r
+ AuxItmArr2 := RightPage.ItemsArray;\r
+ if ItemRef = HalfPageSize\r
+ then (*obiekt itm2=item2 idzie do gory*)\r
+ for i := 1 to HalfPageSize\r
+ do\r
+ AuxItmArr2(i):=AuxItmArr(i+HalfPageSize)\r
+ od;\r
+ itm2:= item2;\r
+ else (*to nie item2 idzie do gory *)\r
+ if ItemRef < HalfPageSize\r
+ then (*wstawiamy do lewej strony*)\r
+ for i := 1 to HalfPageSize\r
+ do\r
+ AuxItmArr2(i) :=\r
+ AuxItmArr(i+HalfPageSize)\r
+ od;\r
+ itm2 := AuxItmArr(HalfPageSize);\r
+ for i := HalfPageSize-1 downto ItemRef+1\r
+ do\r
+ AuxItmArr(i+1) :=\r
+ AuxItmArr(i)\r
+ od;\r
+ AuxItmArr(ItemRef+1) := item2;\r
+ else (*ItemRef>HalfPageSize *)\r
+ itm2 := AuxItmArr(HalfPageSize+1);\r
+ for i := HalfPageSize+2 to ItemRef\r
+ do\r
+ AuxItmArr2(i-HalfPageSize-1) :=\r
+ AuxItmArr(i)\r
+ od;\r
+ AuxItmArr2(ItemRef-HalfPageSize)\r
+ := item2;\r
+ \r
+ for i := ItemRef+1 to PageSize\r
+ do\r
+ AuxItmArr2(i-HalfPageSize) :=\r
+ AuxItmArr(i)\r
+ od;\r
+ fi (*ItemRef < HalfPageSize *)\r
+ fi (*ItemRef = HalfPagSize *);\r
+(*****) (* StackOfPages(finger) := OldPage; *)\r
+ call fseek(plik,Path(Finger).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(Finger)));\r
+ RightPage.LessPageRef := itm2.PageRef;\r
+ AuxRec :=PageToRec(RightPage);\r
+ call AddRec(AuxRec,RightPageRef);\r
+ itm2.PageRef :=RightPageRef;\r
+ fi (* *)\r
+ end Insert;\r
+ \r
+ \r
+ begin (*Search*)\r
+ \r
+ if PageRef = -1\r
+ then (*poprzednia strona jest lisciem, nalezy do niej\r
+ wstawic itm1 ale z PageRef = -1*)\r
+ include := true;\r
+ itm2 := itm1;\r
+ itm2.PageRef := -1;\r
+ else (*przeszukaj te strone*)\r
+ Finger, depth := Finger+1;\r
+ call GetPage (PageRef);\r
+ AuxPage := StackOfPages (Finger);\r
+ call SearchPage (AuxPage, itm1, NextPageRef, ItemRef);\r
+ call Search(itm1, NextPageRef, include, item2);\r
+ if include\r
+ then (*wstawic obiekt item2 na strone PageRef w miejsce\r
+ ItemRef; jezeli na tej stronie wystarczy miejsca\r
+ na nowy obiekt to wstawic go i zgasic include;\r
+ jezeli brakuje miejsca to strone dzielimy i\r
+ include pozostawiamy zapalone, nowy item itm2 ma\r
+ byc wstawiony na wyzszej stronie *)\r
+ call Insert;\r
+ fi (*include*);\r
+ Finger := Finger -1;\r
+ fi (*PageRef=-1*);\r
+ end Search;\r
+ \r
+ \r
+ begin (*AddKey*)\r
+ (*szukaj w korzeniu i powtarzaj rekurencyjnie w odp.\r
+ poddrzewach, gdy znajdziesz to sygnal blad\r
+ w przeciwnym przypadku*)\r
+ Path(1).updated := true;\r
+ AuxItem := new Item;\r
+ AuxItem.ky := ky;\r
+ AuxItem.DataRef := DataRef;\r
+ AuxItem.PageRef := -1;\r
+ Finger := 0;\r
+ call Search(AuxItem, Path(1).PageRef,\r
+ IncreaseHeight, AddItem);\r
+ if IncreaseHeight\r
+ then (*korzen podzielony, dodajemy nowy korzen*)\r
+ NewRoot := new Page;\r
+ NewRoot.ItemsOnPage := 1;\r
+ NewRoot.LessPageRef := Path(1).PageRef;\r
+ (*adres prawej czesci starego korzenia*)\r
+ array NewRoot.ItemsArray dim (1:PageSize);\r
+ NewRoot.ItemsArray(1) := AddItem;\r
+ if depth+1 > TreeHeight\r
+ then (*przekroczono dopuszczalna wysokosc drzewa*)\r
+ raise Signal8\r
+ fi;\r
+ for i := 1 to depth\r
+ do\r
+ StackOfPages(i+1) := StackOfPages(i);\r
+ Path(i+1) := Path(i);\r
+ od;\r
+ StackOfPages(1) := NewRoot;\r
+ Path(1) := new SearchStep;\r
+ Path(1).RefOnPage := 1;\r
+ Path(1).updated := true;\r
+ AuxRec :=PageToRec(NewRoot);\r
+ call AddRec(AuxRec, PageRef);\r
+ Path(1).PageRef := PageRef (*adres nowego korzenia*) ;\r
+ Finger := depth+1;\r
+ else\r
+ Finger := depth;\r
+ fi (*IncreaseHeight*);\r
+ \r
+ end AddKey;\r
+ \r
+ \r
+ \r
+ \r
+(*AXIOM po wykonaniu dowolnej operacji zmieniajacej Finger\r
+ Finger i Path pokazuja na sciezce jakis item w ktorym jest\r
+ klucz tzn. item dla ktorego RefOnPage =/= 0*)\r
+ \r
+ unit PrevKey : procedure (output ky:key, DataRef:integer);\r
+ (*ky jest bezposrednim poprzednikiem klucza biezacego\r
+wskazanego przez Path. DataRef wskazuje referencje do\r
+krotki odpowiadajacej ky w pliku danych*)\r
+ var AuxPage : Page,\r
+ AuxRec : arrayof integer,\r
+ PageRef, nextPageRef,\r
+ RefOnPage : integer;\r
+ begin (*Zakladamy, ze biezacy klucz jest wskazany przez\r
+ Path(Finger)*)\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ PageRef:=Path(Finger).PageRef;\r
+ AuxPage:=StackOfPages(Finger);\r
+ if AuxPage.LessPageRef = -1\r
+ then (*jestesmy w lisciu*)\r
+ if RefOnPage <> 1\r
+ then (*poprzednikiem jest sasiad z lewej*)\r
+ RefOnPage := RefOnPage -1;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ else (*RefOnPage = 1*)\r
+ if Finger =1\r
+ then (*to jest korzen*)\r
+ ky:=AuxPage.ItemsArray(RefOnPage).ky;\r
+ DataRef:=AuxPage.ItemsArray(RefOnPage).DataRef;\r
+ raise signal11; (*nie ma poprzednika*)\r
+ return;\r
+ else\r
+ RefOnPage := 0;\r
+ while Finger <> 1 and RefOnPage = 0\r
+ do\r
+ Finger := Finger-1;\r
+ Auxpage := StackOfPages(Finger);\r
+ RefOnPage := Path(Finger).RefOnPage\r
+ od;\r
+ if Finger = 1 and RefOnPage = 0\r
+ then\r
+ ky:=AuxPage.ItemsArray(1).ky;\r
+ DataRef:=AuxPage.ItemsArray(1).DataRef;\r
+ raise signal11; (*nie ma poprzednika*)\r
+ return;\r
+ fi;\r
+ fi (* Finger = 1 *);\r
+ fi (* RefOnPage <> 1 *);\r
+ else (*to nie jest lisc*)\r
+ if RefOnPage = 1\r
+ then\r
+ nextPageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0\r
+ else\r
+ RefOnPage := RefOnPage -1;\r
+ nextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ fi;\r
+ while nextPageRef <> -1 (*szukamy najwiekszego syna*)\r
+ do\r
+ Finger := Finger +1;\r
+ PageRef := nextPageRef;\r
+ call GetPage(PageRef);\r
+ AuxPage := StackOfPages(Finger);\r
+ RefOnPage, Path(Finger).RefOnPage :=\r
+ Auxpage.ItemsOnPage;\r
+ nextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef\r
+ od;\r
+ fi;\r
+ ky:=AuxPage.ItemsArray(RefOnPage).ky;\r
+ DataRef:=AuxPage.ItemsArray(RefOnPage).DataRef\r
+ end PrevKey;\r
+ \r
+ \r
+ unit MinKey : procedure (output k:Key, DataRef : integer);\r
+ (*ustawia Pointer do indexu i Path tak by pokazywaly\r
+najmniejszy klucz. k - jest najmniejszym kluczem w\r
+rozwazanym indeksie, DataRef jest odpowiadajaca mu\r
+referencja do rekordu w pliku glownym relacji*)\r
+ \r
+ var PageRef : integer,\r
+ AuxPage : Page,\r
+ AuxItem : Item;\r
+ \r
+ begin\r
+ Finger :=1;\r
+ do\r
+ AuxPage := StackOfPages(Finger);\r
+ PageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0;\r
+ if PageRef = -1 then exit fi;\r
+ Finger := Finger +1;\r
+ call GetPage(PageRef);\r
+ od;\r
+ AuxItem := AuxPage.ItemsArray(1);\r
+ k := AuxItem.ky;\r
+ DataRef := AuxItem.DataRef;\r
+ Path(Finger).RefOnPage := 1;\r
+ \r
+ end MinKey;\r
+ \r
+ unit MaxKey : procedure( output k:Key, DataRef: integer);\r
+(*ustawia Pointer do indexu i Path tak by pokazywaly\r
+najwiekszy klucz*)\r
+ var PageRef, n : integer,\r
+ AuxPage : Page;\r
+ \r
+ begin\r
+ Finger :=1;\r
+ do\r
+ AuxPage := StackOfPages(Finger);\r
+ Path(Finger).RefOnPage, n :=\r
+ AuxPage.ItemsOnPage ;\r
+ PageRef := AuxPage.ItemsArray(n).PageRef;\r
+ if PageRef = -1 then exit fi;\r
+ Finger := Finger+1;\r
+ call GetPage(PageRef);\r
+ od;\r
+ k := AuxPage.ItemsArray(n).Ky;\r
+ DataRef := AuxPage.ItemsArray(n).DataRef;\r
+ \r
+ end MaxKey;\r
+ \r
+ \r
+ \r
+(*************************************************************************)\r
+ \r
+ \r
+ unit NextKey: procedure (output ky:key,DataRef:integer);\r
+(*referencja DataRef do bezposredniego nastepnika biezacej\r
+ pozycji\r
+ ky jest bezposrednim nastepnikiem klucza biezacego\r
+ wskazanego przez Path. DataRef wskazuje referencje do\r
+ krotki odpowiadajacej ky w pliku danych*)\r
+ var AuxPage : Page,\r
+ AuxItem : Item,\r
+ PageRef,nextPageRef,\r
+ RefOnPage : integer;\r
+ begin (*Zakladamy, ze biezacy klucz jest wskazany przez\r
+ Path(Finger) *)\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ PageRef := Path(Finger).PageRef;\r
+ AuxPage:=StackOfPages(Finger);\r
+ \r
+ if AuxPage.LessPageRef = -1\r
+ then (*jestesmy w lisciu*)\r
+ while Finger <> 1 and RefOnPage = AuxPage.ItemsOnPage\r
+ do\r
+ Finger := Finger - 1;\r
+ AuxPage := StackOfPages(Finger);\r
+ RefOnPage := Path(Finger).refOnPage\r
+ od;\r
+ if RefOnPage = AuxPage.ItemsOnPage\r
+ then\r
+ AuxItem := AuxPage.ItemsArray(RefOnPage);\r
+ DataRef := AuxItem.DataRef;\r
+ ky := AuxItem.ky;\r
+ raise signal12; (*nie ma nastepnika*)\r
+ return;\r
+ else\r
+ RefOnPage := RefOnPage+1;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ fi;\r
+ else (*to nie jest lisc*)\r
+ nextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ while nextPageRef <> -1\r
+ do\r
+ Finger := Finger+1;\r
+ PageRef := NextPageRef;\r
+ call GetPage(PageRef);\r
+ AuxPage := StackOfPages(Finger);\r
+ Path(Finger).refOnPage := 0;\r
+ NextPageRef := AuxPage.LesspageRef\r
+ od;\r
+ RefOnPage := 1;\r
+ Path(Finger).RefOnPage := 1\r
+ fi;\r
+ AuxItem := AuxPage.ItemsArray(RefOnPage);\r
+ DataRef := AuxItem.DataRef;\r
+ ky := AuxItem.ky\r
+ end NextKey;\r
+ \r
+ \r
+ unit DelKey : procedure (input ky:key,DataRef:integer);\r
+ (*usuwanie klucza ky, o referencji do pliku glownego\r
+ dataref, z indeksu, jezeli takiego klucza nie ma to\r
+ sygnal*)\r
+ var DataRef1: integer,\r
+ k: key,\r
+ underflw:boolean; (*true if underflow occurred*)\r
+ \r
+ unit remove : procedure(output underflw:boolean);\r
+ var AuxPage,AuxPage1 :Page,\r
+ i,ItemsOnPage,RefOnPage,nextPageRef :integer;\r
+ begin\r
+ AuxPage:=StackOfPages(Finger);\r
+ i:=Finger;\r
+ Path(Finger).updated:=true;\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ \r
+ if AuxPage.LessPageRef <> -1\r
+ then (*to nie jest lisc*)\r
+ NextPageRef :=\r
+ AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ while NextPageRef <> -1\r
+ do\r
+ Finger := Finger+1;\r
+ call GetPage(NextPageRef);\r
+ AuxPage1 := StackOfPages(Finger);\r
+ Path(Finger).RefOnPage := 0;\r
+ NextPageRef := AuxPage1.LessPageRef\r
+ od;\r
+ Path(Finger).updated:=true;\r
+ Path(Finger).RefOnPage := 1;\r
+ AuxPage.ItemsArray(RefOnPage).ky:=\r
+ AuxPage1.ItemsArray(1).ky;\r
+ AuxPage.ItemsArray(RefOnPage).DataRef:=\r
+ AuxPage1.ItemsArray(1).DataRef;\r
+ StackOfPages(i):=AuxPage;(*wymienilam usuniety element*)\r
+ AuxPage:= AuxPage1;\r
+ RefOnPage:=1;\r
+ fi;(*jestesmy w lisciu*)\r
+ \r
+ ItemsOnPage:= AuxPage.ItemsOnPage -1;\r
+ \r
+ for i:=RefOnPage to ItemsOnPage\r
+ do\r
+ AuxPage.ItemsArray(i):=AuxPage.ItemsArray(i+1)\r
+ od;\r
+ AuxPage.ItemsOnPage:= ItemsOnPage;\r
+ StackOfPages(Finger):=AuxPage;\r
+ if ItemsOnPage<HalfPageSize\r
+ then (*trzeba wywolac underflow*)\r
+ underflw:=true\r
+ fi\r
+ end remove;\r
+ \r
+unit underflow: procedure(inout underflw:boolean);\r
+ (* Finger wskazuje strone A na ktorej jest niedomiar *)\r
+ var Itm:Item,\r
+ AuxPage,AuxPage1, AuxPage2:Page,\r
+ i,k,n,pb,lb,PageRef,RefOnPage: integer,\r
+ AuxRec: arrayof integer;\r
+ begin\r
+ call SetCursor(7,1); (*****************************)\r
+ writeln("underflow",Finger);\r
+ underflw:=false;\r
+ if Finger<>1 then\r
+ AuxPage:=StackOfPages(Finger);(*strona z niedomiarem*)\r
+ \r
+ Path(Finger).updated:=true ;\r
+ Path(Finger-1).updated:=true ;\r
+ AuxPage1:=StackOfPages(Finger-1); (*strona ojca*)\r
+ RefOnPage:=Path(Finger-1).RefOnPage;\r
+ if RefOnPage< AuxPage1.ItemsOnPage\r
+ then (*istnieje prawy stryj*)\r
+ k:=RefOnPage+1;\r
+ Itm:=AuxPage1.ItemsArray(k);\r
+ PageRef:=Itm.PageRef;\r
+ (*wczytanie strony-brata prawego na AuxPage2*)\r
+ call fseek(plik,PageRef);\r
+ AuxRec:=fget(plik);\r
+ AuxPage2:=RecToPage(AuxRec);\r
+ \r
+ Itm.PageRef:=AuxPage2.LessPageRef;\r
+ AuxPage.ItemsArray(AuxPage.ItemsOnPage+1):=Itm;\r
+ (*stryj schodzi do AuxPage*)\r
+ n:=AuxPage2.ItemsOnPage-HalfPageSize;\r
+ \r
+ if n>0\r
+ then\r
+ n:=entier((n-1)/2);(* przelewamy n elementow *)\r
+ Itm:=AuxPage2.ItemsArray(n+1);\r
+ Itm.PageRef:=PageRef;\r
+ AuxPage1.ItemsArray(k):=Itm;\r
+ for i:=1 to n\r
+ do\r
+ AuxPage.ItemsArray(HalfPageSize+i):=\r
+ AuxPage2.ItemsArray(i)\r
+ od;\r
+ AuxPage.ItemsOnPage:=HalfPageSize+n;\r
+ StackOfPages(Finger):=AuxPage;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ k:=AuxPage2.ItemsOnPage-(n+1);\r
+ \r
+ for i:=1 to k\r
+ do\r
+ AuxPage2.ItemsArray(i):=\r
+ AuxPage2.ItemsArray(n+1+i)\r
+ od;\r
+ AuxPage2.ItemsOnPage:=k;\r
+ AuxRec:=PageToRec(AuxPage2);(*zapamiet. AuxPage2*)\r
+ call fseek(plik,PageRef);\r
+ call fput(plik,AuxRec);\r
+ else\r
+ (*AuxPage2.ItemsOnPage=HalfPageSize tzn. n=0*)\r
+ for i:=1 to HalfPageSize\r
+ do\r
+ AuxPage.ItemsArray(HalfPageSize+i):=\r
+ AuxPage2.ItemsArray(i)\r
+ od;\r
+ AuxPage.ItemsOnPage:=PageSize;\r
+ for i:=RefOnPage+2 to AuxPage1.ItemsOnPage\r
+ do\r
+ AuxPage1.ItemsArray(i-1):=\r
+ AuxPage1.ItemsArray(i)\r
+ od;\r
+ \r
+ AuxPage1.ItemsOnPage:=AuxPage1.ItemsOnPage-1;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage;\r
+ call DelRec(PageRef);\r
+ if AuxPage1.ItemsOnPage<HalfPageSize\r
+ then\r
+ Finger:=Finger-1;\r
+ underflw:=true;\r
+ (*niedomiar na stronie ojca*)\r
+ fi ;\r
+ fi (*n>0*)\r
+ \r
+ else (*nie ma prawego stryja, wez z lewej*)\r
+ if RefOnPage>1\r
+ then\r
+ Itm:=AuxPage1.ItemsArray(RefOnPage-1);\r
+ PageRef:=Itm.PageRef;\r
+ else\r
+ PageRef:=AuxPage1.LessPageRef;\r
+ fi;\r
+ (*wczytanie strony-brata lewego na AuxPage2*)\r
+ call fseek(plik,PageRef);\r
+ AuxRec:=fget(plik);\r
+ AuxPage2:=RecToPage(AuxRec); (*str-brat lewy*)\r
+ \r
+ Itm:=AuxPage1.ItemsArray(RefOnPage);\r
+ Itm.PageRef:=AuxPage.LessPageRef;\r
+ n:=AuxPage2.ItemsOnPage-HalfPageSize;\r
+ if n>0\r
+ then\r
+ n:=entier((n-1)/2);\r
+ (*przesun o n+1 w prawo elem na str.AuxPage*)\r
+ k:=AuxPage.ItemsOnPage;\r
+ for i:=1 to n+1\r
+ do\r
+ AuxPage.ItemsArray(k+n+2-i):=\r
+ AuxPage.ItemsArray(k+1-i)\r
+ od;\r
+ \r
+ AuxPage.ItemsArray(n+1):=Itm;\r
+ (*ojciec do AuxPage*)\r
+ AuxPage.ItemsOnPage:=k+n+1;\r
+ Itm:=AuxPage2.ItemsArray(HalfPageSize+n+1);\r
+ Itm.PageRef:=PageRef; (*referencja do AuxPage*)\r
+ AuxPage1.ItemsArray(RefOnPage):=Itm;\r
+ for i:=1 to n\r
+ do\r
+ AuxPage.ItemsArray(i):=\r
+ AuxPage2.ItemsArray(HalfPageSize+1+i+n)\r
+ od;\r
+ AuxPage.ItemsOnPage:=HalfPageSize+n;\r
+ AuxPage2.ItemsOnPage:= HalfPageSize+n;\r
+ \r
+ (*wyslac strony i zapisac sciezke i stos*)\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage;\r
+ (*zapamietanie strony AuxPage2*)\r
+ AuxRec:=PageToRec(AuxPage2);\r
+ call fseek(plik,PageRef);\r
+ call fput(plik,AuxRec);\r
+ \r
+ else\r
+ (*n=o tzn.AuxPage2.ItemsOnPage=HalfPageSize*)\r
+ \r
+ AuxPage2.ItemsArray(HalfPageSize+1):=Itm;\r
+ for i:=1 to HalfPageSize-1\r
+ do\r
+ AuxPage2.ItemsArray(HalfPageSize+1+i):=\r
+ AuxPage.ItemsArray(i)\r
+ od;\r
+ AuxPage1.ItemsOnPage:=AuxPage1.ItemsOnPage-1;\r
+ AuxPage2.ItemsOnPage:=PageSize;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage2;\r
+ Path(Finger-1).RefOnPage:=RefOnPage-1;\r
+ call DelRec(Path(Finger).PageRef);\r
+ (*wyrzucono str AuxPage*)\r
+ Path(Finger).PageRef:=PageRef;\r
+ \r
+ if AuxPage1.ItemsOnPage<HalfPageSize\r
+ then\r
+ Finger:=Finger-1;\r
+ underflw:=true (*niedomiar na stronie ojca*)\r
+ fi;\r
+ fi (*n>0*)\r
+ \r
+ fi(*lewy istnieje*)\r
+ \r
+ \r
+ else (*niedomiar jest w korzeniu*)\r
+ AuxPage:=StackOfPages(1);\r
+ if AuxPage.ItemsOnPage=0\r
+ then\r
+ call DelRec(Path(1).PageRef);\r
+ if AuxPage.LessPageRef<>-1\r
+ then\r
+ i:=2;\r
+ while Path(i)<>none\r
+ do\r
+ Path(i-1):=Path(i);\r
+ StackOfPages(i-1):=StackOfPages(i);\r
+ i:=i+1\r
+ od\r
+ else\r
+ writeln("drzewo znika ");\r
+ fi;\r
+ fi\r
+ fi (*Finger<>1*);\r
+ end underflow;\r
+ \r
+ begin (*DelKey*)\r
+ k:=ky;\r
+ DataRef1:=FindKey(k);\r
+ do\r
+ if k=ky and DataRef=DataRef1\r
+ then\r
+ (*znalezlismy wlasciwy klucz *)\r
+ call remove(underflw);\r
+ while underflw\r
+ do\r
+ call underflow(underflw)\r
+ od;\r
+ return\r
+ else\r
+ if k<>ky or DataRef1= -1\r
+ then\r
+ writeln("* nie ma takiego klucza *")\r
+ else\r
+ call NextKey(k,DataRef1)\r
+ fi\r
+ fi\r
+ od\r
+ end DelKey;\r
+ \r
+ \r
+ unit FindKey:function (k : key): integer;\r
+ (*wynikiem poszukiwania klucza k jest referencja do\r
+ datafile wskazujaca na krotke o danym kluczu. Gdy\r
+ nie znaleziono, wartoscia funkcji jest -1 *)\r
+ var PageRef,\r
+ i : integer,\r
+ AuxPage : Page,\r
+ Itms : arrayof Item,\r
+ k1 : Key;\r
+ begin\r
+ Finger := 1;\r
+ PageRef := Path(Finger).PageRef;\r
+ do\r
+ call GetPage( PageRef );\r
+ (*przeszukujemy strone o adresie Pageref*)\r
+ AuxPage := StackOfPages(Finger);\r
+ Itms := AuxPage.ItemsArray;\r
+ for i := AuxPage.ItemsOnPage downto 1\r
+ do\r
+ k1 := Itms(i).ky;\r
+ if leq(k1, k)\r
+ then\r
+ Path(Finger).RefOnPage := i;\r
+ if leq(k, k1)\r
+ then (*znaleziony*)\r
+ result := Itms(i).DataRef;\r
+ return\r
+ fi;\r
+ PageRef := Itms(i).PageRef;\r
+ exit;\r
+ else\r
+ if i =1\r
+ then (*klucz k jest mniejszy od wszystkich kluczy\r
+ na rozwazanej stronie*)\r
+ PageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0;\r
+ fi;\r
+ fi;\r
+ od;\r
+ \r
+ if PageRef = -1\r
+ then (*jestesmy w lisciu, nie ma poszukiwanego klucza*)\r
+ if Path(Finger).RefOnPage = 0\r
+ then\r
+ Path(Finger).RefOnPage :=1\r
+ fi;\r
+ result := -1;\r
+ exit (*FindKey*)\r
+ else\r
+ Finger := Finger+1\r
+ fi;\r
+ od;\r
+ end FindKey;\r
+ \r
+unit SearchKey: procedure(input k:key;\r
+ output DataRef : integer);\r
+(*referencja do klucza, ktory jest >=k *)\r
+begin\r
+ DataRef:=FindKey(k);\r
+ if DataRef=-1\r
+ then\r
+ call NextKey(k,DataRef)\r
+ fi\r
+end SearchKey;\r
+ \r
+ \r
+ \r
+ unit GetPage : procedure(PageRef : integer);\r
+ (* wczytanie do stosu stron strony o adresie PageRef,\r
+ chyba, ze strona o tej referencji jest juz w stosie.\r
+ Poprawienie sciezki i ew. przeslanie do pliku strony\r
+ wskazanej przez Path(Finger).PageRef o ile byla zmieniana jej tresc *)\r
+ \r
+ var AuxRec : arrayof integer;\r
+ begin\r
+ \r
+ if Path(Finger) = none\r
+ then\r
+ Path(Finger) := new SearchStep;\r
+ Path(Finger).Updated := false;\r
+ Path(Finger).PageRef := PageRef-1; (*chce by byla roznica ponizej *)\r
+ fi;\r
+(*! if Path(Finger).PageRef <> PageRef\r
+ then *) (*zmiana strony *)\r
+ if Path(Finger).Updated\r
+ then (*wyslanie strony na plik, poniewaz byla zmieniana *)\r
+ AuxRec := PageToRec(StackOfPages(Finger));\r
+ call fseek(plik, Path(Finger).PageRef);\r
+ call fput(plik,AuxRec);\r
+ fi (*updated*);\r
+ (*wczytanie potrzebnej strony*)\r
+ call fseek(plik, PageRef);\r
+ AuxRec := fget(plik);\r
+ StackOfPages(Finger) := RecToPage(AuxRec);\r
+ Path(Finger) := new SearchStep;\r
+ Path(Finger).PageRef := PageRef;\r
+ Path(Finger).updated := false;\r
+(*! fi *)\r
+ \r
+ end GetPage ;\r
+ \r
+ unit UpdatePage : procedure (input AuxItem : Item,\r
+ ItemRef : integer,\r
+ AuxPage : Page);\r
+ (* wstaw AuxItem na wskazanej stronie, w miejscu ItemRef +1 *)\r
+ var AuxItmArr : arrayof Item,\r
+ n,i: integer;\r
+ begin\r
+ AuxPage.ItemsOnPage, n := AuxPage.ItemsOnPage +1;\r
+ for i := n downto ItemRef +2\r
+ do\r
+ AuxItmArr := AuxPage.ItemsArray;\r
+ AuxItmArr(i) := AuxItmArr(i-1)\r
+ od;\r
+ AuxPage.ItemsArray(ItemRef+1) := AuxItem;\r
+ Path(Finger).Updated := true;\r
+ end UpdatePage ;\r
+ \r
+ unit order : function (i1, i2 : Item) : boolean;\r
+ (*ropzszerzenie porzadku LessOrEqual Leq o badanie DataRef w\r
+przypadku gdy klucze sa rowne *)\r
+ \r
+ var k1,k2 :key,\r
+ n : integer;\r
+ \r
+ begin\r
+ k1 := i1.ky;\r
+ k2 := i2.ky;\r
+ if Leq(k2,k1)\r
+ then (* k2ók1 *)\r
+ if Leq(k1, k2)\r
+ then (* k1=k2 *)\r
+ \r
+ (* DORADZAMY zbadaj czy k1 = k2? *************************)\r
+ (* potrzebna inna funkcja EQ? booleowska *****************)\r
+ (* o odp. wlasnosciach: zwrotnsc,przechodniosc, symetria *)\r
+ \r
+ n := i1.DataRef - i2.DataRef;\r
+ if n=0\r
+ then (*dwa identyczne klucze o jednakowych referencjach*)\r
+ raise Signal14\r
+ fi;\r
+ result := n<0;\r
+ else (* k1>k2 *)\r
+ result := false\r
+ fi\r
+ else (*k1<k2 ?*)\r
+ if not Leq(k1, k2)\r
+ then\r
+(* 16.08.87 ********************************************)\r
+ (* raise RelacjaNieSpojna *)\r
+ else \r
+ result := true\r
+ fi \r
+ fi\r
+ end order;\r
+ \r
+ unit SearchPage : procedure (input P : Page, it : Item;\r
+ output NextPageRef, ItemRef : integer);\r
+ (* szukamy miejsca dla obiektu it na stronie P, NextPageRef\r
+jest adresem strony na ktorej mozemy kontynuowac\r
+poszukiwania; ItemRef jest numerem obiektu mniejszego od it\r
+lub jest rowne 0 gdy nasz obiekt it jest mniejszy\r
+od wszystkich obiektow na stronie*)\r
+ \r
+ var Itms : arrayof Item,\r
+ it1 : Item;\r
+ \r
+ begin\r
+ Itms :=P.ItemsArray;\r
+ for ItemRef := P.ItemsOnPage downto 1\r
+ do\r
+ it1 := Itms(ItemRef);\r
+ if order (it1, it)\r
+ then (*it1<it *)\r
+ NextPageRef := it1.PageRef;\r
+ return\r
+ fi\r
+ od;\r
+ (*obiekt it jest mniejszy od wszystkich obiektow na tej\r
+stronie*)\r
+ ItemRef := 0;\r
+ NextPageRef := P.LessPageRef;\r
+ end SearchPage ;\r
+ \r
+ \r
+ \r
+ unit RecToPage : function(A: arrayof integer): Page;\r
+ (*Ta funkcja odczytuje tablice liczb calkowitych i zmienia\r
+ja w strone Page. Wykorzystuje sie virtualna funkcje\r
+RecToKey. *)\r
+ var P: Page,\r
+ i,j : integer,\r
+ It : Item;\r
+ begin\r
+ P:=new Page;\r
+ P.ItemsOnPage,j := A(1);\r
+ P.LessPageRef := A(2);\r
+ array P.ItemsArray dim (1:PageSize);\r
+ for i := 1 to j (*P.ItemsOnPage*)\r
+ do\r
+ It := new Item;\r
+ It.ky := RecToKey(A, 3+(i-1)*(KeySize+2) ) ;\r
+ It.PageRef := A(i*(KeySize+2)+1);\r
+ It.DataRef := A(i*(KeySize+2)+2);\r
+ P.ItemsArray(i) := It;\r
+ od(*itemsOnPage*);\r
+ result :=P\r
+ end RecToPage ;\r
+ \r
+ unit PageToRec : function (P: Page): arrayof integer;\r
+ (*Funkcja odwrotna do poprzedniej*)\r
+ var A : arrayof integer,\r
+ It: Item,\r
+ i : integer;\r
+ begin\r
+ array A dim(1:(2+PageSize*(KeySize+2)));\r
+ A(1) :=P.ItemsOnPage;\r
+ A(2) := P.LessPageRef;\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ It:=P.ItemsArray(i);\r
+ (* if It = none then writeln(" It w PageToRec jest none");\r
+ writeln("ItemsOnPage= ",P.ItemsOnPage,"i= ",i)\r
+ fi; *)\r
+ call KeyToRec(It.ky, A, 3+(i-1)*(KeySize+2) );\r
+ (*O KeyToRec zakladam, ze jest to procedura virtualna,\r
+ktora przepisuje klucz ky do tablicy A poczynajac od\r
+danego miejsca A(j) do kolejnych KeySize komorek tej\r
+tablicy. *)\r
+ A(i*(KeySize+2)+1) := It.PageRef;\r
+ A(i*(KeySize+2)+2) := It.DataRef;\r
+ od;\r
+ result := A\r
+ end PageToRec ;\r
+ \r
+ unit virtual KeyToRec : procedure(ky:Key, A: arrayof integer, j: integer);\r
+ (*procedura virtualna, ktora przepisuje klucz ky do tablicy\r
+A poczynajac od danego miejsca A(j) do kolejnych KeySize\r
+komorek tej tablicy. *)\r
+ \r
+ begin\r
+ \r
+ end KeyToRec ;\r
+ \r
+ unit virtual RecToKey : function(A: arrayof integer, \r
+ j:integer): Key;\r
+ (*Funkcja odczytuje KeySize kolejnych komorek z tablicy A\r
+poczynajac od A(j) i tworzy z nich klucz *)\r
+ \r
+ begin\r
+ \r
+ end RecToKey ;\r
+ \r
+ var AuxRec : arrayof integer,\r
+ akey : Key,\r
+ PageRef : integer;\r
+ \r
+begin (*IndexFile*)\r
+ (*ustawic wskazowke do IndexFile *)\r
+ (*zainicjowac Path i StackOfPages*)\r
+ Finger :=1;\r
+ array StackOfPages dim(1:TreeHeight);\r
+ array Path dim (1:TreeHeight);\r
+ StackOfPages(1) := new Page;\r
+ StackOfPages(1).ItemsOnPage := 0;\r
+ StackOfPages(1).LessPageRef := -1;\r
+ array StackOfPages(1).ItemsArray dim (1: PageSize);\r
+ Path(1):= new SearchStep;\r
+ Path(1).PageRef := 1;\r
+ Path(1).RefOnPage := 0;\r
+ \r
+ \r
+end IndexFile;\r
+ \r
+ \r
+ \r
+ \r
+begin (*Relation*)\r
+ \r
+ end Relation;\r
+ \r
+ \r
+ \r
+ \r
+begin (*obsluga relacji*)\r
+ \r
+end HandlerOfRelations;\r
+ \r
+ \r
+begin (*to begin odpowiada zewnetrznym : program i end*)\r
+ \r
+pref HandlerOfRelations(4,8,2) block\r
+ \r
+unit Bibliografia : Relation class;\r
+ (*nasza przykladowa relacja *)\r
+ const autleng=25, tytleng=50, wydleng=15;\r
+ \r
+ unit Krotka : Tuple class ;\r
+ var autor,\r
+ tytul,\r
+ wydawca : arrayof char,\r
+ rok,\r
+ pozycja : integer;\r
+ begin\r
+ array autor dim(1 : autleng);\r
+ array tytul dim (1 : tytleng);\r
+ array wydawca dim (1 :wydleng);\r
+ end Krotka;\r
+ \r
+ var ak : Krotka; (*aktualna krotka*)\r
+ \r
+ unit virtual TupleToRec : function (k : Krotka): arrayof\r
+ integer;\r
+ var Aux : arrayof integer,\r
+ AIC : arrayof char,\r
+ i : integer;\r
+ \r
+ begin\r
+ array Aux dim (1:95);\r
+ AIC := k.autor;\r
+ for i := 1 to autleng\r
+ do\r
+ Aux(i) := ord(AIC(i));\r
+ if ord(AIC(i)) = 13\r
+ then (*Enter *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i := 1 to tytleng\r
+ do\r
+ Aux(autleng+i) := ord(k.tytul(i));\r
+ if ord(k.tytul(i)) = 13\r
+ then (*Enter *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i := 1 to wydleng\r
+ do\r
+ Aux(75+i) := ord(k.wydawca(i));\r
+ if ord(k.wydawca(i)) = 13\r
+ then (*Enter *)\r
+ exit\r
+ fi;\r
+ od;\r
+ Aux(91) := k.rok;\r
+ Aux(92) := k.pozycja;\r
+ result := Aux;\r
+ end TupleToRec;\r
+ \r
+unit virtual RecToTuple : function (a: arrayof integer)\r
+ :Krotka;\r
+ (* *)\r
+ var k:krotka,\r
+ i:integer;\r
+begin\r
+ k:=new krotka;\r
+ for i:=1 to autleng\r
+ do\r
+ k.autor(i):=chr(a(i));\r
+ if a(i) = 13\r
+ then (*koniec tekstu *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i:=1 to tytleng\r
+ do\r
+ k.tytul(i):=chr(a(autleng+i));\r
+ if a(autleng+i) = 13\r
+ then (*koniec tekstu *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i := 1 to wydleng\r
+ do\r
+ k.wydawca(i):=chr(a(75+i));\r
+ if a(75+i) = 13\r
+ then (*koniec tekstu *)\r
+ exit\r
+ fi;\r
+ od;\r
+ k.rok:=a(91);\r
+ k.pozycja:=a(92);\r
+ result := k\r
+end RecToTuple ;\r
+ \r
+unit DrukujKrotke : procedure;\r
+ (*drukuj aktualna krotke *)\r
+begin\r
+ call SetCursor(4,1);\r
+ writeln(" ");\r
+ writeln(" ");\r
+ writeln(" ");\r
+ writeln(" ");\r
+ call SetCursor(10,1);\r
+ write(" autor: ");\r
+ call SetCursor(10,14);\r
+ call Drukuj(ak.autor); writeln;\r
+ write(" tytul: ");\r
+ call SetCursor(11,14);\r
+ call Drukuj(ak.tytul); writeln;\r
+ write(" wydawca: ");\r
+ call SetCursor(12,14);\r
+ call Drukuj(ak.wydawca); writeln;\r
+ writeln("rok wydania: ",ak.rok);\r
+ writeln(" pozycja nr: ",ak.pozycja);\r
+end DrukujKrotke ;\r
+ \r
+unit WczytajKrotke : procedure;\r
+ (*Czytaj aktualna krotke *)\r
+begin\r
+ call SetCursor(25,1);\r
+ write("edit tuple, pressing PgDn finishes ");\r
+ \r
+ do\r
+ call SetCursor(4,1);\r
+ writeln; call Reverse;\r
+ write(" autor: "); call Normal;\r
+ call Czytaj(ak.autor); call Reverse;\r
+ write(" tytul: "); call Normal;\r
+ call Czytaj(ak.tytul); call Reverse;\r
+ write(" wydawca: "); call Normal;\r
+ call Czytaj(ak.wydawca); call Reverse;\r
+ write("rok wydania: "); call Normal;\r
+ read(ak.rok); call Reverse;\r
+ write(" pozycja nr: "); call Normal;\r
+ readln(ak.pozycja);\r
+ if inchar = -81 then exit fi;\r
+ od;\r
+end WczytajKrotke ;\r
+ \r
+unit IndeksAutorow : IndexFile class ;\r
+ (* *)\r
+ unit klucz : Key class ;\r
+ var autor : arrayof char;\r
+ begin\r
+ array autor dim (1: autleng );\r
+ \r
+ end klucz;\r
+ \r
+ unit virtual KeyOf : function (k :Krotka) : klucz;\r
+ (*tworzenie klucza z krotki *)\r
+ begin\r
+ result := new klucz;\r
+ result.autor := copy (k.autor)\r
+ end KeyOf ;\r
+ \r
+ unit virtual Leq : function (k1,k2 : klucz) : boolean;\r
+ (*porownanie dwu kluczy *)\r
+ var i: integer;\r
+ begin\r
+ result := true;\r
+ \r
+ \r
+ \r
+ for i := 1 to autleng\r
+ do\r
+ if ord(k1.autor(i)) =13\r
+ then\r
+ exit\r
+ else\r
+ if ord(k2.autor(i)) = 13 \r
+ then\r
+ result := false;\r
+ exit\r
+ else\r
+ \r
+ fi;\r
+ fi;\r
+ if ord(k1.autor(i)) = ord(k2.autor(i))\r
+ then (*rowne*)\r
+ else\r
+ if ord(k1.autor(i)) < ord(k2.autor(i))\r
+ then\r
+ result := true ;\r
+ else\r
+ result := false;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ end Leq ;\r
+ \r
+ unit virtual KeyToRec : procedure(ky:klucz, A: arrayof integer,\r
+ j: integer);\r
+ (*procedura virtualna, ktora przepisuje klucz ky do tablicy\r
+ A poczynajac od danego miejsca A(j) do kolejnych KeySize\r
+ komorek tej tablicy. *)\r
+ \r
+ var i : integer;\r
+ begin\r
+ for i := 1 to autleng\r
+ do\r
+ A(j+i-1) := ord(ky.autor(i))\r
+ od;\r
+ end KeyToRec ;\r
+ \r
+ unit virtual RecToKey : function(A: arrayof integer, \r
+ j:integer): klucz;\r
+ (*Funkcja odczytuje KeySize kolejnych komorek z tablicy A\r
+ poczynajac od A(j) i tworzy z nich klucz *)\r
+ \r
+ var k : klucz;\r
+ begin\r
+ k := new klucz;\r
+ for i := 1 to autleng\r
+ do\r
+ k.autor(i) := chr(A(j+i-1))\r
+ od;\r
+ result := k\r
+ end RecToKey ;\r
+ \r
+ unit DrukujStrone : procedure (PageRef: integer);\r
+ var P : Page,\r
+ j,\r
+ i : integer,\r
+ l : klucz,\r
+ c : char,\r
+ AuxRec : arrayof integer;\r
+ begin\r
+ if PageRef = -1 then return fi;\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od;\r
+ (*wczytaj strone*)\r
+ call fseek(plik, PageRef);\r
+ AuxRec := fget(plik);\r
+ P := RecToPage(AuxRec);\r
+ (*drukuj*)\r
+ \r
+ writeln("stronaRefNr=",PageRef:4," itemow =", P.ItemsOnPage:3);\r
+ write(" klucze ");\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ l := P.ItemsArray(i).ky;\r
+ for j := 1 to 12\r
+ do\r
+ c := l.autor(j);\r
+ if ord(c) = 13\r
+ then\r
+ write(' ')\r
+ else\r
+ write(c)\r
+ fi;\r
+ od;\r
+ od;\r
+ writeln;\r
+ write(" PgRfs",P.LessPageRef:5);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ write(P.ItemsArray(i).PageRef:12);\r
+ od;\r
+ writeln;\r
+ call DrukujStrone(P.LessPageRef);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ call DrukujStrone(P.ItemsArray(i).PageRef);\r
+ od;\r
+ kill(AuxRec);\r
+ end DrukujStrone;\r
+ \r
+ var akl : klucz;\r
+ \r
+ begin (*indeksAutorow*)\r
+ KeySize := autleng;\r
+ akl, akey := new klucz;\r
+ (* dlugosc rekordu-klucza = 2+(PageSize * (KeySize + 2)); *)\r
+ if otworz\r
+ then\r
+ plik := openfile(unpack("autor.idx"),2+(PageSize * (KeySize + 2)) );\r
+ (* odczytac strony do StackOfPages *)\r
+ Path(1).PageRef := INFO(1);\r
+ Path(1).RefOnPage := 1;\r
+ call fseek(plik,Path(1).PageRef);\r
+ AuxRec := fget(plik);\r
+ StackOfPages(1) := RecToPage(AuxRec);\r
+ kill(AuxRec);\r
+ else\r
+ plik := makefile(unpack("autor.idx"),2+(PageSize * (KeySize + 2)) );\r
+ fi;\r
+ return;\r
+ (* ZAMYKANIE indeksu *)\r
+ (* strony zmienione ze sciezki sa zapisywane na pliku *)\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od;\r
+ (* ZAPISAC nr rekordu - korzenia *)\r
+ INFO(1) := Path(1).PageRef;\r
+ call closefile(plik);\r
+ end IndeksAutorow ;\r
+ \r
+ var IA :IndeksAutorow ;\r
+ \r
+ unit IndeksPoz : IndexFile class ;\r
+ (* *)\r
+ unit klucz : Key class ;\r
+ var poz : integer;\r
+ begin\r
+ \r
+ end klucz;\r
+ \r
+ unit virtual KeyOf : function (k :Krotka) : klucz;\r
+ (*tworzenie klucza z krotki *)\r
+ begin\r
+ result := new klucz;\r
+ result.poz := k.pozycja\r
+ end KeyOf ;\r
+ \r
+ unit virtual Leq : function (k1,k2 : klucz) : boolean;\r
+ (*porownanie dwu kluczy *)\r
+ begin\r
+ result := not (k1.poz > k2.poz)\r
+ end Leq ;\r
+ \r
+ unit virtual KeyToRec : procedure(ky:klucz, A: arrayof integer,\r
+ j: integer);\r
+ (*procedura virtualna, ktora przepisuje klucz ky do tablicy\r
+ A poczynajac od danego miejsca A(j) do kolejnych KeySize\r
+ komorek tej tablicy. *)\r
+ \r
+ (* *)\r
+ var i : integer;\r
+ begin\r
+ A(j) := ky.poz;\r
+ end KeyToRec ;\r
+ \r
+ unit virtual RecToKey : function(A: arrayof integer, \r
+ j:integer): klucz;\r
+ (*Funkcja odczytuje KeySize kolejnych komorek z tablicy A\r
+ poczynajac od A(j) i tworzy z nich klucz *)\r
+ (* *)\r
+ var k : klucz;\r
+ begin\r
+ k := new klucz;\r
+ k.poz := A(j);\r
+ result := k\r
+ end RecToKey ;\r
+ \r
+ unit DrukujStrone : procedure (PageRef: integer);\r
+ var P : Page,\r
+ i : integer,\r
+ AuxRec : arrayof integer;\r
+ begin\r
+ if PageRef = -1 then return fi;\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od;\r
+ (*wczytaj strone*)\r
+ call fseek(plik, PageRef);\r
+ AuxRec := fget(plik);\r
+ P := RecToPage(AuxRec);\r
+ (*drukuj*)\r
+ \r
+ writeln("stronaRefNr=",PageRef:4," itemow =", P.ItemsOnPage:3);\r
+ write(" klucze ");\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ write(P.ItemsArray(i).ky qua klucz.poz:12);\r
+ od;\r
+(* 16.08.87 *******************************************************)\r
+ writeln;\r
+ write(" PgRfs",P.LessPageRef:5);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ write(P.ItemsArray(i).PageRef:12);\r
+ od;\r
+ writeln;\r
+ call DrukujStrone(P.LessPageRef);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ call DrukujStrone(P.ItemsArray(i).PageRef);\r
+ od;\r
+ kill(AuxRec);\r
+ end DrukujStrone;\r
+ \r
+ \r
+ var akl : klucz;\r
+ \r
+ begin (*indeksPozycji*)\r
+ KeySize := 1;\r
+ akl, akey := new klucz;\r
+ (* plik.reclength := 2+(PageSize * (KeySize + 2)); *)\r
+ if otworz\r
+ then\r
+ plik := openfile(unpack("nrpzycji.idx"),2+(PageSize * (KeySize + 2)));\r
+ (* odczytac strone-korzen do StackOfPages *)\r
+ \r
+ Path(1).PageRef := INFO(2);\r
+ Path(1).RefOnPage := 1;\r
+ call fseek(plik,Path(1).PageRef);\r
+ AuxRec := fget(plik);\r
+ StackOfPages(1) := RecToPage(AuxRec);\r
+ kill(AuxRec);\r
+ else\r
+ plik := makefile(unpack("nrpzycji.idx"),2+(PageSize * (KeySize + 2)) );\r
+ fi;\r
+ return;\r
+ (* ZAMYKANIE indexu *)\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od;\r
+ (* ZAPISAC nr rekordu - korzenia *)\r
+ INFO(2) := Path(1).PageRef;\r
+ call closefile(plik);\r
+end IndeksPoz ;\r
+ \r
+var IB :IndeksPoz ;\r
+ \r
+begin (*bibliografia*)\r
+ \r
+if otworz\r
+then\r
+ plik:= openfile(unpack("bibliog.dta"), 95);\r
+else\r
+ plik:= makefile(unpack("bibliog.dta"), 95);\r
+fi;\r
+ ak := new Krotka;\r
+ (* call IncreaseIndex( new IndeksAutorow); *)\r
+ array Index dim(1 : 2);\r
+ Index(1), IA := new IndeksAutorow;\r
+ Index(2), IB := new IndeksPoz;\r
+end Bibliografia ;\r
+ \r
+ \r
+ (*deklaracje pomocnicze programu glownego*)\r
+ var cha : char,\r
+ otworz, (* otwieramy *)\r
+ otwarta : boolean, (*czy baza bibliograficzna juz jest otwarta?*)\r
+ R : Bibliografia,\r
+ i,j : integer,\r
+ Rec : arrayof integer;\r
+ \r
+ unit Czytaj : procedure(a: arrayof char);\r
+ (*czytaj tablice znakow *)\r
+ var i,j : integer,\r
+ cha1: char;\r
+ begin\r
+ for i := 1 to upper(a)\r
+ do\r
+ j := inchar;\r
+ a(i) := chr(j);\r
+ write(a(i));\r
+ if j = 13\r
+ then (*wczytano Enter *)\r
+ writeln;\r
+ exit\r
+ fi;\r
+ od;\r
+ if i < upper(a)\r
+ then\r
+ a(i+1) := chr(13)\r
+ else\r
+ a(upper(a)) := chr(13)\r
+ fi\r
+ end Czytaj ;\r
+ \r
+ unit Drukuj : procedure (a : arrayof char);\r
+ (*drukuj tablice znakow jako linijke tekstu *)\r
+ var i : integer;\r
+ begin\r
+ for i := 1 to upper(a)\r
+ do\r
+ write(a(i));\r
+ if ord(a(i)) =13\r
+ then (*wydrukowano Enter *)\r
+ exit\r
+ fi\r
+ od;\r
+ end Drukuj ;\r
+ \r
+var INFO : arrayof integer,\r
+ j1,j2: integer,\r
+ extrem : boolean,\r
+ infoplik : Rfile;\r
+ \r
+ handlers\r
+ \r
+ when Signal13 :\r
+ call SetCursor(5,1);\r
+ writeln("Trying to delete an already absent record");\r
+ return;\r
+ \r
+ when Signal11 :\r
+ call SetCursor(5,1);\r
+ writeln("osiagnieto element minimalny");\r
+ extrem := true;\r
+ return;\r
+ \r
+ when Signal12 :\r
+ call SetCursor(5,1);\r
+ writeln("osiagnieto element maksymalny");\r
+ extrem := true;\r
+ return; \r
+ end handlers;\r
+ \r
+ \r
+begin (*program glowny prefiksowany przez HandlerOfRelations*)\r
+ (*dane bibliograficzne*)\r
+ (*wyswietl powitanie*)\r
+ \r
+ array INFO dim (1:3);\r
+ call Reverse;\r
+ call NewPage;\r
+ call SetCursor(13,10);\r
+ (*call Normal;*)\r
+ (*call Bold;*)\r
+ write("TOOLBOX dla baz danych");\r
+ call SetCursor(15,10);\r
+ write("test 19v.4");\r
+ call SetCursor(21,10);\r
+ (*call Normal;*)\r
+ write("G.Mirkowska, A.Salwicki - Lipiec 1988");\r
+ call SetCursor(22,10);\r
+ write("klase FileSystem napisala J.Warpechowska");\r
+ call SetCursor(23,68);\r
+ write("press a key");\r
+ i := inchar;\r
+ call Normal;\r
+ call NewPage;\r
+ writeln; writeln; writeln;\r
+ write(\r
+ "Do you wish to use the previously prepared bibliography files?(y/n)?");\r
+ i := inchar;\r
+ call Bold;\r
+ write(chr(i));\r
+ if i =121\r
+ then\r
+ otworz := true;\r
+ infoplik := openfile(unpack("bibliog.bas"),3);\r
+ INFO := fget(infoplik);\r
+ else\r
+ otworz := false;\r
+ infoplik := makefile(unpack("bibliog.bas"),3);\r
+ fi;\r
+ \r
+ R :=new Bibliografia;\r
+ R.FreePlace := Info(3);\r
+ call NewPage;\r
+ call Reverse;\r
+ writeln(\r
+ "i-INSERT d-DELETE s-SEARCH m-MINMAX t-TYPE n-NEXT p-PREVIOUS q-QUIT");\r
+ \r
+ writeln(\r
+ "ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ");\r
+ writeln;\r
+ call SetCursor(23,1);\r
+ call Normal;\r
+ writeln(\r
+ "ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ");\r
+ writeln(\r
+ " ");\r
+ call Blink;\r
+ write(\r
+ " make a choice ");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(1,76);\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call SetCursor(25,1);\r
+ write(\r
+ " ");\r
+ call SetCursor(5,1);\r
+ do\r
+ case cha\r
+ \r
+ when 'q' : (* quit*)\r
+ call Blink;\r
+ call SetCursor(24,7);\r
+ writeln("end of program test19-4, CLOSING FILES");\r
+ call Normal;\r
+ call SetCursor(5,1);\r
+ call closefile(R.plik);\r
+ attach(R.IA);\r
+ attach(R.IB);\r
+ INFO(3) := R.FreePlace;\r
+ call frewind(infoplik);\r
+ call fput(infoplik,INFO);\r
+ call closefile(infoplik);\r
+ call NewPage;\r
+ call endrun;\r
+ (* end quit *)\r
+ \r
+ when 'i': (*read a tuple and INSERT*)\r
+ call R.WczytajKrotke;\r
+ call SetCursor(24,7);\r
+ call Blink;\r
+ call Reverse;\r
+ write("inserting the tuple");\r
+ call R.Insert(R.ak);\r
+ j1,j2 := 1;\r
+ call Normal;\r
+ call SetCursor(24,7);\r
+ write(" ");\r
+ \r
+ when 't' : (*type*)\r
+ call Normal;\r
+ call Reverse;\r
+ call SetCursor(3,38);\r
+ write("print: r-RELATION or b-BTREE ");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ if cha = 'r'\r
+ then (*printing relation*)\r
+ call SetCursor(24,4);\r
+ write(" press SPACEBAR for next record");\r
+ call SetCursor(5,1);\r
+ call fseek(R.plik,1);\r
+ while not feof(R.plik)\r
+ do\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call R.DrukujKrotke;\r
+ call SetCursor(24,19);\r
+ i:=inchar;\r
+ od;\r
+ else (*printing Btree*)\r
+ call SetCursor(4,30);\r
+ call Reverse;\r
+ write("select index: a-AUTHORS or p-POSITIONS ");\r
+ call Normal;\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call SetCursor(5,1);\r
+ if cha = 'p'\r
+ then\r
+ call R.IB.DrukujStrone(R.IB.Path(1).PageRef);\r
+ else\r
+ call R.IA.DrukujStrone(R.IA.Path(1).PageRef);\r
+ fi;\r
+ \r
+ fi (*koniec drukuj*);\r
+ \r
+ when 's': (*search for a tuple*)\r
+ call SetCursor(3,19);\r
+ call Reverse;\r
+ write(" searching tuple (t)? or key (k)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal;\r
+ if cha = 't'\r
+ then (*give a tuple *)\r
+ call SetCursor(5,1);\r
+ call R.WczytajKrotke;\r
+ Rec := R.TupleToRec(R.ak);\r
+ call SetCursor(24,7);\r
+ call Blink;\r
+ call Reverse;\r
+ write("searching the tuple");\r
+ \r
+ call R.FindRec(Rec, i);\r
+ \r
+ call Normal;\r
+ call SetCursor(24,7);\r
+ write(" ");\r
+ if i = -1\r
+ then (* *)\r
+ writeln(" the tuple not found");\r
+ else (* *)\r
+ writeln(" position of the tuple in the datafile = ",i);\r
+ (* call fseek(R.plik, i);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(rec);\r
+ call R.DrukujKrotke; *)\r
+ fi;\r
+ else (*'k' *)\r
+ if cha ='k'\r
+ then (*searching in the authors or position index*)\r
+ call SetCursor(4,19);\r
+ call Reverse;\r
+ write("which index: authors(a)? or positions(p)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal; \r
+ if cha = 'a'\r
+ then\r
+ i := 1;\r
+ call SetCursor(5,1);\r
+ write(" autor: ");\r
+ call Czytaj(R.IA.akl.autor);\r
+ \r
+ j1 := R.IA.Findkey(R.IA.akl);\r
+ if j1<> -1\r
+ then (*znaleziono *)\r
+ call SetCursor(24,7);\r
+ writeln("tuple found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call R.DrukujKrotke;\r
+ else (*nie znaleziono *)\r
+ call SetCursor(24,7);\r
+ writeln(" tuple not found");\r
+ fi\r
+ else (*zakladamy cha ='p'*)\r
+ i := 2;\r
+ call SetCursor(5,1);\r
+ write(" position nr: ");\r
+ read(R.IB.akl.poz);\r
+ j2 := R.Index(i).Findkey(R.IB.akl);\r
+ if j2<> -1\r
+ then (*znaleziono *)\r
+ call SetCursor(24,7);\r
+ write("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ else (*nie znaleziono *)\r
+ call SetCursor(24,7);\r
+ writeln(" tuple not found");\r
+ fi ;\r
+ fi (*wyboru klucza*);\r
+ fi (*cha ='c'*)\r
+ fi (*when 's'*);\r
+ \r
+ \r
+ \r
+ when 'p': (*show the previous tuple*)\r
+ \r
+ call SetCursor(4,19);\r
+ call Reverse;\r
+ write("which index: authors(a)? or positions(p)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal; \r
+ if cha = 'a'\r
+ then\r
+ if j1>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(1).PrevKey(R.IA.akl,j1);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ j1 :=0;\r
+ R.IA.akl := R.IA.new klucz;\r
+ else\r
+ call SetCursor(24,7);\r
+ write("tuple found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ call SetCursor(24,7);\r
+ write("no key has been located yet");\r
+ fi;\r
+ else\r
+ if j2>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(2).PrevKey(R.IB.akl,j2);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ else\r
+ call SetCursor(24,7);\r
+ write("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ call SetCursor(24,7);\r
+ writeln("no key has been located yet");\r
+ fi;\r
+ fi (* prev *);\r
+ \r
+ \r
+ when 'm': (*min or max*)\r
+ call Reverse;\r
+ call SetCursor(3,25);\r
+ write("searching index of: authors(a)? or positions(p)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ if cha ='a'\r
+ then\r
+ call Reverse;\r
+ call SetCursor(4,25);\r
+ write("searching index of authors: min(i)? or max(x)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ call SetCursor(5,1);\r
+ if cha = 'i'\r
+ then\r
+ call R.IA.MinKey(R.IA.akl, j1);\r
+ call SetCursor(24,7);\r
+ writeln(" min key found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ else\r
+ call R.IA.MaxKey(R.IA.akl, j1);\r
+ call SetCursor(24,7);\r
+ writeln("max key found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (*wg pozycji*)\r
+ call Reverse;\r
+ call SetCursor(4,25);\r
+ write("searching index of positions: min(i)? or max(x)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ call SetCursor(24,7);\r
+ if cha = 'i'\r
+ then\r
+ call R.IB.MinKey(R.IB.akl, j2);\r
+ writeln("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ else\r
+ call R.IB.MaxKey(R.IB.akl, j2);\r
+ writeln("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ fi; (* end of minmax utility *)\r
+ \r
+ \r
+ when 'n': (*show the next tuple*)\r
+ call SetCursor(4,19);\r
+ call Reverse;\r
+ write("which index: authors(a)? or positions(p)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal; \r
+ call SetCursor(24,7);\r
+ if cha = 'a'\r
+ then\r
+ if j1>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(1).NextKey(R.IA.akl,j1);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ else\r
+ writeln("tuple found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ writeln("no key has been located yet");\r
+ fi;\r
+ else\r
+ if j2>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(2).NextKey(R.IB.akl,j2);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ else\r
+ writeln("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ writeln("no key has been located yet");\r
+ fi;\r
+ fi (*Next*);\r
+ \r
+ when 'd': (*delete the actual tuple*)\r
+ call Reverse;\r
+ call SetCursor(3,25);\r
+ write("from index of: authors(a)? or positions(p)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ \r
+ if cha ='a'\r
+ then (* ustawic aktualna krotke*)\r
+ \r
+ else\r
+ \r
+ fi;\r
+ \r
+ call SetCursor(25,4);\r
+ call Blink;\r
+ call Reverse;\r
+ write("DELETING the actual tuple");\r
+ call R.Delete(R.ak);\r
+ \r
+ \r
+ otherwise\r
+ call SetCursor(25,4);\r
+ write("REPEAT")\r
+ esac;\r
+ \r
+ call Normal;\r
+ call SetCursor(25,1);\r
+ write(" ");\r
+ call Blink;\r
+ call Reverse;\r
+ call SetCursor(25,60);\r
+ write("press a key");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(1,76);\r
+ write(chr(32));\r
+ i:=inchar;\r
+ call Normal; \r
+ call SetCursor(3,1);\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ call SetCursor(24,1);\r
+ writeln(\r
+ " ");\r
+ write(\r
+ " ");\r
+ \r
+ call Normal;\r
+ call Blink;\r
+ call Reverse;\r
+ call SetCursor(25,60);\r
+ write("make your choice");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(1,76);\r
+ write(chr(32));\r
+ i := inchar;\r
+ cha := chr(i);\r
+ call SetCursor(1,76);\r
+ writeln(chr(i));\r
+ call SetCursor(25,60);\r
+ write(" ");\r
+ call SetCursor(5,1);\r
+ od\r
+ end\r
+end Test19;\r
+ \r
--- /dev/null
+program TRI;\r
+begin\r
+ pref iiuwgraph block\r
+begin\r
+ pref mouse block\r
+\r
+(*************************************************************************)\r
+(* PROGRAMME DE COMPARAISON *)\r
+(* DE DEUX METHODES DE TRIS SUR DES ELEMENTS DIFFERENTS *)\r
+(*************************************************************************)\r
+(**************************************************************************)\r
+(* PROCEDURES DE GRAPHISMES *)\r
+(**************************************************************************)\r
+UNIT RECTANGLE_PLEIN : procedure(x_h,y_h,x_b,y_b,\r
+ coul,contour:integer);\r
+var \r
+ i : integer ;\r
+\r
+BEGIN\r
+ call color (coul);\r
+ for i:= y_h to y_b \r
+ do\r
+ call move (x_h,i);\r
+ call hfill (x_b);\r
+ od;\r
+ call color (contour);\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+ END RECTANGLE_PLEIN;\r
+\r
+UNIT RECTANGLE_HISTO : procedure(x_h,y_h,x_b,y_b,\r
+ coul:integer);\r
+var \r
+ i : integer ;\r
+\r
+BEGIN\r
+ call color (coul);\r
+ for i:= x_h to x_b \r
+ do\r
+ call move (i,y_h);\r
+ call vfill (y_b);\r
+ od;\r
+ END RECTANGLE_HISTO;\r
+\r
+UNIT RECTANGLE: procedure(x_h,y_h,x_b,y_b:integer);\r
+BEGIN\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+END RECTANGLE;\r
+\r
+(************************************************************************)\r
+(* IMPLEMENTATION DE LA STRUCTURE DE DONNEES *)\r
+(* m\82thode utilis\82e : h\82ritage *)\r
+(************************************************************************)\r
+\r
+(********************************************************)\r
+(* CLASSE SUPERIEURE *)\r
+(********************************************************)\r
+unit STR_ELEMENTS : class;\r
+ unit virtual randomize : procedure;\r
+ end randomize;\r
+\r
+ unit virtual trace : procedure (e,y : integer);\r
+ end trace;\r
+\r
+ unit virtual echange : procedure (e1,e2,y : integer);\r
+ end echange;\r
+\r
+ unit virtual compare : function (e1,e2 : integer) : integer;\r
+ end compare;\r
+\r
+ unit virtual copie : procedure (T : STR_ELEMENTS);\r
+ end copie;\r
+\r
+ unit virtual killtab : procedure;\r
+ end killtab;\r
+end STR_ELEMENTS;\r
+\r
+(********************************************************)\r
+(* CLASSE INFERIEURE *)\r
+(********************************************************)\r
+\r
+(********************************************************)\r
+(* CLASSE HISTOGRAMME *)\r
+(********************************************************)\r
+ unit HISTOGRAMMES : STR_ELEMENTS class (nb_elements : integer);\r
+ unit ENR_ELEMENTS : class;\r
+ var\r
+ couleur : integer,\r
+ valeur : integer;\r
+ end ENR_ELEMENTS;\r
+ var\r
+ TAB : arrayof ENR_ELEMENTS,\r
+ i : integer ;\r
+\r
+ unit virtual randomize : procedure;\r
+ var i : integer;\r
+ begin\r
+ for i := 0 to nb_elements-1 do\r
+ TAB(i).valeur := (random*100)+1;\r
+ TAB(i).couleur := tab(i).valeur div 10+1;\r
+ if(TAB(i).couleur>=6)then \r
+ TAB(i).couleur:= TAB(i).couleur +3;\r
+ fi;\r
+ od;\r
+ end randomize;\r
+ \r
+ unit virtual trace : procedure (e,y : integer);\r
+ var\r
+ larg : integer;\r
+ begin\r
+ larg := 600 div nb_elements;\r
+ call RECTANGLE_HISTO (15+e*larg,y-TAB(e).valeur,15+(e+1)*larg-2,y,\r
+ TAB(e).couleur); \r
+ end trace;\r
+\r
+ unit virtual echange : procedure (e1,e2,y : integer);\r
+ var\r
+ tmp1,tmp2,coul1,h2,larg : integer;\r
+ begin\r
+ larg := 600 div nb_elements;\r
+ call RECTANGLE_HISTO (15+e1*larg,y-100,15+(e1+1)*larg-2,y,7); \r
+ call RECTANGLE_HISTO (15+e2*larg,y-100,15+(e2+1)*larg-2,y,7); \r
+ h2 := TAB(e2).valeur;\r
+ tmp1 := TAB(e1).valeur;\r
+ tmp2 := TAB(e1).couleur;\r
+ TAB(e1).valeur := TAB(e2).valeur;\r
+ TAB(e1).couleur := TAB(e2).couleur;\r
+ TAB(e2).valeur := tmp1;\r
+ TAB(e2).couleur := tmp2;\r
+ coul1 := TAB(e1).couleur;\r
+ call RECTANGLE_HISTO (15+e1*larg,y-h2,15+(e1+1)*larg-2,y,\r
+ coul1); \r
+ call RECTANGLE_HISTO (15+e2*larg,y-tmp1,15+(e2+1)*larg-2,y,\r
+ tmp2); \r
+ end echange;\r
+ \r
+ unit virtual compare : function (e1,e2 : integer) : integer;\r
+ begin\r
+ if TAB(e1).valeur < TAB(e2).valeur then result := -1;\r
+ else if TAB(e1).valeur = TAB(e2).valeur then result := 0;\r
+ else result := 1;\r
+ fi;\r
+ fi;\r
+ end compare;\r
+\r
+ unit virtual copie : procedure ( T : HISTOGRAMMES);\r
+ var\r
+ i : integer;\r
+ begin\r
+ for i := 0 to nb_elements-1 do\r
+ TAB(i).valeur := T.tab(i).valeur;\r
+ TAB(i).couleur := T.tab(i).couleur;\r
+\r
+ od;\r
+ end copie;\r
+\r
+ unit virtual killtab : procedure;\r
+ var\r
+ i : integer;\r
+ begin\r
+ for i:=0 to nb_elements-1 do\r
+ kill (TAB(i));\r
+ od;\r
+ end killtab;\r
+ begin\r
+ array TAB dim (0:nb_elements-1);\r
+ for i:=0 to nb_elements-1 do\r
+ TAB(i) := new ENR_ELEMENTS;\r
+ od;\r
+ end HISTOGRAMMES;\r
+\r
+(********************************************************)\r
+(* CLASSE SURFACES *)\r
+(********************************************************)\r
+ unit SURFACES : STR_ELEMENTS class (nb_elements : integer);\r
+ unit ENR_ELEMENTS : class;\r
+ var\r
+ couleur : integer,\r
+ longueur: integer,\r
+ largeur : integer;\r
+\r
+ end ENR_ELEMENTS;\r
+\r
+ var\r
+ TAB : arrayof ENR_ELEMENTS,\r
+ i : integer ;\r
+\r
+\r
+ unit virtual randomize : procedure;\r
+ var i,largeur_max,surf_interne : integer;\r
+ begin\r
+ for i := 0 to nb_elements-1 \r
+ do\r
+ largeur_max := 25;\r
+ TAB(i).longueur := (random*largeur_max)+1;\r
+ TAB(i).largeur := (random * largeur_max)+1;\r
+ surf_interne := TAB(i).longueur * TAB(i).largeur;\r
+ TAB(i).couleur := (surf_interne * 12) \r
+ div (largeur_max*largeur_max)+1;\r
+ if(TAB(i).couleur>=6)then \r
+ TAB(i).couleur:= TAB(i).couleur +3;\r
+ fi;\r
+ od;\r
+ end randomize;\r
+ \r
+ unit virtual trace : procedure (e,y : integer);\r
+ var\r
+ larg,xx,yy : integer;\r
+ begin\r
+ larg := 25;\r
+ xx := (e mod 20)*30+30;\r
+ yy := y - 90 + (e div 20 )*30;\r
+ call RECTANGLE_HISTO (xx-(tab(e).largeur div 2),\r
+ yy-(tab(e).longueur div 2),\r
+ xx+((TAB(e).largeur+1) div 2),\r
+ yy+((TAB(e).longueur+1) div 2),TAB(e).couleur); \r
+ end trace;\r
+\r
+\r
+ unit virtual echange : procedure (e1,e2,y : integer);\r
+ var\r
+ xx1,yy1,xx2,yy2,tmp1,tmp2,tmp3,coul1,h2long,\r
+ h2larg,larg : integer;\r
+ begin\r
+\r
+ larg := 25;\r
+ xx1 := (e1 mod 20)*30+30;\r
+ yy1 := y - 90 + (e1 div 20 )*30;\r
+ xx2 := (e2 mod 20)*30+30;\r
+ yy2 := y - 90 + (e2 div 20 )*30;\r
+\r
+ call RECTANGLE_HISTO (xx1-(tab(e1).largeur div 2),\r
+ yy1-(tab(e1).longueur div 2),\r
+ xx1+((TAB(e1).largeur+1) div 2),\r
+ yy1+((TAB(e1).longueur+1) div 2),7); \r
+ call RECTANGLE_HISTO (xx2-(tab(e2).largeur div 2),\r
+ yy2-(tab(e2).longueur div 2),\r
+ xx2+((TAB(e2).largeur+1) div 2),\r
+ yy2+((TAB(e2).longueur+1) div 2),7); \r
+ h2larg := TAB(e2).largeur;\r
+ h2long := TAB(e2).longueur;\r
+ tmp1 := TAB(e1).largeur;\r
+ tmp2 := TAB(e1).longueur;\r
+ tmp3 := TAB(e1).couleur;\r
+ TAB(e1).largeur := TAB(e2).largeur;\r
+ TAB(e1).longueur := TAB(e2).longueur;\r
+ TAB(e1).couleur := TAB(e2).couleur;\r
+ TAB(e2).largeur := tmp1; \r
+ TAB(e2).longueur := tmp2;\r
+ TAB(e2).couleur := tmp3;\r
+ coul1 := TAB(e1).couleur;\r
+ call RECTANGLE_HISTO (xx1-(h2larg div 2),\r
+ yy1-(h2long div 2),\r
+ xx1+((h2larg+1) div 2),\r
+ yy1+((h2long+1) div 2),coul1);\r
+ call RECTANGLE_HISTO (xx2-(tmp1 div 2),\r
+ yy2-(tmp2 div 2),\r
+ xx2+((tmp1+1) div 2),\r
+ yy2+((tmp2+1) div 2),tmp3);\r
+ end echange;\r
+ \r
+ unit virtual compare : function (e1,e2 : integer) : integer;\r
+ var\r
+ surf1,surf2 : integer;\r
+ begin\r
+ \r
+ surf1 := TAB(e1).largeur * TAB(e1).longueur;\r
+ surf2 := TAB(e2).largeur * TAB(e2).longueur;\r
+ if surf1 < surf2 then result := -1;\r
+ else if surf1 = surf2 then result := 0;\r
+ else result := 1;\r
+ fi;\r
+ fi;\r
+ end compare;\r
+\r
+ unit virtual copie : procedure ( T : SURFACES);\r
+ var\r
+ i : integer;\r
+ begin\r
+ for i := 0 to nb_elements-1 do\r
+ TAB(i).largeur := T.tab(i).largeur;\r
+ TAB(i).longueur := T.tab(i).longueur;\r
+ TAB(i).couleur := T.tab(i).couleur;\r
+ od;\r
+ end copie;\r
+\r
+ unit virtual killtab : procedure;\r
+ var\r
+ i : integer;\r
+ begin\r
+ for i:=0 to nb_elements-1 do\r
+ kill (TAB(i));\r
+ od;\r
+ end killtab;\r
+ begin\r
+ array TAB dim (0:nb_elements-1);\r
+ for i:=0 to nb_elements-1 do\r
+ TAB(i) := new ENR_ELEMENTS;\r
+ od;\r
+ end SURFACES;\r
+\r
+(********************************************************)\r
+(* CLASSE POLYNOME *)\r
+(********************************************************)\r
+ unit POLY : STR_ELEMENTS class (nb_elements : integer);\r
+ unit ENR_ELEMENTS : class;\r
+ var\r
+ coeff : arrayof integer,\r
+ degre : integer;\r
+ end ENR_ELEMENTS;\r
+ var\r
+ TAB : arrayof ENR_ELEMENTS,\r
+ i : integer ,\r
+ x : integer ;\r
+\r
+unit CAL_POLYNOME : function (indice : integer): integer;\r
+ var\r
+ somme,i : integer;\r
+ begin\r
+ somme := TAB(indice).coeff(TAB(indice).degre);\r
+ i := TAB(indice).degre - 1;\r
+ while (i>=0) \r
+ do\r
+ somme := somme * x +TAB(indice).coeff(i);\r
+ i := i -1;\r
+ od;\r
+ result := somme;\r
+ end CAL_POLYNOME;\r
+\r
+ unit virtual randomize : procedure;\r
+ var \r
+ i,j,deg,valeur,test : integer;\r
+ begin\r
+ for i := 0 to nb_elements-1 \r
+ do\r
+ deg := (random * 5) + 1;\r
+ x := (random * 7) + 1;\r
+ TAB(i).degre := deg;\r
+ test := 0;\r
+ while (test = 0)\r
+ do\r
+ for j := 0 to deg\r
+ do\r
+ TAB(i).coeff(j) := random*9 - 4;\r
+ test := TAB(i).coeff(j) + test;\r
+ od;\r
+ od;\r
+ od;\r
+ call AFFICHE_INFO;\r
+ end randomize;\r
+ \r
+ unit affchar : procedure (n : integer);\r
+ begin\r
+ case n\r
+ when 0 : call outstring ("0");\r
+ when 1 : call outstring ("1");\r
+ when 2 : call outstring ("2");\r
+ when 3 : call outstring ("3");\r
+ when 4 : call outstring ("4");\r
+ when 5 : call outstring ("5");\r
+ when 6 : call outstring ("6");\r
+ when 7 : call outstring ("7");\r
+ when 8 : call outstring ("8");\r
+ when 9 : call outstring ("9");\r
+ esac;\r
+ end;\r
+\r
+ unit AFFICHE_INFO : procedure ;\r
+ begin\r
+\r
+ call color (15);\r
+ call move (520,160);\r
+ call outstring ("VALEUR X : ");\r
+ call affchar(x);\r
+ call move (520,335);\r
+ call outstring ("VALEUR X : ");\r
+ call affchar(x);\r
+ call color (8);\r
+ call move (521,161);\r
+ call outstring ("VALEUR X : ");\r
+ call affchar(x);\r
+ call move (521,336);\r
+ call outstring ("VALEUR X : ");\r
+ call affchar(x);\r
+\r
+ call color (4);\r
+ call RECTANGLE (8,5,12,85);\r
+ call move (8,85);\r
+ call draw (4,85);\r
+ call draw (10,90);\r
+ call draw (16,85);\r
+ call draw (12,85);\r
+ call RECTANGLE (8,180,12,259);\r
+ call move (8,259);\r
+ call draw (4,259);\r
+ call draw (10,264);\r
+ call draw (16,259);\r
+ call draw (12,259);\r
+ end ;\r
+\r
+ unit virtual trace : procedure (e,y : integer);\r
+ var\r
+ xx,yy,i,nbchar : integer,\r
+ debut : boolean;\r
+ begin\r
+ xx := (e div 10)*320+20;\r
+ yy := y-100+(e mod 10)*8;\r
+ call move (xx,yy);\r
+ nbchar := 0;\r
+ debut := true;\r
+ for i:=TAB(e).degre downto 0 do\r
+ if tab(e).coeff(i)<>0 then \r
+\r
+ if TAB(e).coeff(i)<0 then\r
+ call outstring ("-");\r
+ nbchar := nbchar + 1;\r
+ else\r
+ if not debut then\r
+ call outstring ("+");\r
+ nbchar := nbchar + 1;\r
+ fi;\r
+ fi;\r
+ debut := false;\r
+ if ((tab(e).coeff(i)<>1) and \r
+ (tab(e).coeff(i)<>-1)) or (i=0) then\r
+ if tab(e).coeff(i)>=0 then\r
+ call affchar (TAB(e).coeff(i));\r
+ else\r
+ call affchar (-TAB(e).coeff(i));\r
+ fi;\r
+ nbchar := nbchar + 1;\r
+ fi;\r
+ if i<>0 then\r
+ call outstring ("X");\r
+ if i<>1 then\r
+ call outstring ("^");\r
+ call affchar (i);\r
+ nbchar := nbchar + 2;\r
+ fi;\r
+ nbchar := nbchar + 1;\r
+ fi;\r
+ fi;\r
+ od;\r
+ for i:=nbchar to 25 do\r
+ call outstring (" ");\r
+ od;\r
+ end trace;\r
+\r
+ unit virtual echange : procedure (e1,e2,y : integer);\r
+ var\r
+ i ,sauve_degre,sauve_coef : integer;\r
+\r
+ begin\r
+\r
+ sauve_degre := TAB(e2).degre;\r
+ TAB(e2).degre := TAB(e1).degre;\r
+ TAB(e1).degre := sauve_degre;\r
+\r
+ for i := 5 downto 0\r
+ do\r
+ sauve_coef := TAB(e2).coeff(i);\r
+ TAB(e2).coeff(i) := TAB(e1).coeff(i);\r
+ TAB(e1).coeff(i) := sauve_coef;\r
+ od;\r
+\r
+ call trace (e1,y);\r
+ call trace (e2,y);\r
+\r
+ end echange;\r
+ \r
+ unit virtual compare : function (e1,e2 : integer) : integer;\r
+ var\r
+ val1,val2 : integer;\r
+ begin\r
+ val1 := CAL_POLYNOME(e1);\r
+ val2 := CAL_POLYNOME(e2);\r
+ if val1<val2 then result := -1;\r
+ else if val1 = val2 then result := 0;\r
+ else result := 1;\r
+ fi;\r
+ fi;\r
+ end compare;\r
+\r
+ unit virtual copie : procedure ( T : POLY);\r
+ var\r
+ i,j : integer;\r
+ begin\r
+ x := T.x;\r
+ for i := 0 to nb_elements-1 do\r
+ TAB(i).degre := T.tab(i).degre;\r
+ for j := 0 to 5 do\r
+ TAB(i).coeff(j) := T.tab(i).coeff(j);\r
+ od;\r
+ od;\r
+ end copie;\r
+\r
+ unit virtual killtab : procedure;\r
+ var\r
+ i : integer;\r
+ begin\r
+ for i:=0 to nb_elements-1 do\r
+ kill (TAB(i));\r
+ od;\r
+ end killtab;\r
+ begin\r
+ array TAB dim (0:nb_elements-1);\r
+ for i:=0 to nb_elements-1 do\r
+ TAB(i) := new ENR_ELEMENTS;\r
+ array tab(i).coeff dim (0:5);\r
+ od;\r
+ end POLY;\r
+\r
+\r
+begin\r
+pref STR_ELEMENTS block\r
+\r
+unit EFFACE : procedure (x1,y1,x2,y2,c1,c2,c3 : integer);\r
+var\r
+ i,j,k : integer;\r
+begin\r
+ i := x2-x1;\r
+ j := y2-y1;\r
+ k := 0;\r
+ call color (c1);\r
+ while (k<=j) and (k<=i) do\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ i := i-1;\r
+ j := j-1;\r
+ k := k+1;\r
+ od;\r
+ call color (c2);\r
+ while (k>=0) do\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ i := i+1;\r
+ j := j+1;\r
+ k := k-1;\r
+ od;\r
+ call color (c3);\r
+ call RECTANGLE (x1,y1,x2,y2);\r
+end EFFACE;\r
+\r
+\r
+UNIT BOX_MESSAGE : function (chaine:string;x1,y1,x2,y2:integer): boolean ;\r
+\r
+ VAR \r
+ succes,gauche,droit,centre : boolean,\r
+ x,y,p,i:integer;\r
+ BEGIN\r
+ succes := false;\r
+ call BOUTON (x1,y1,x2,y2,7,9,1); \r
+ call move (x1+20,y1+30);\r
+ call outstring (chaine);\r
+ call BOUTON (x1+80,y2-50,x1+150,y2-15,7,15,8);\r
+ call BOUTON (x1+200,y2-50,x1+270,y2-15,7,15,8);\r
+ call move (x1+94,y2-35);\r
+ call color (4);\r
+ call outstring ("O U I");\r
+ call move (x1+214,y2-35);\r
+ call outstring ("N O N ");\r
+ do\r
+ call showcursor;\r
+ call getpress (0,x,y,p,gauche,droit,centre);\r
+ if (gauche) then\r
+ call hidecursor;\r
+ if (x > (x1+80) and x < (x1 + 150) and y>(y2-50) and y<(y2-15)) then\r
+ call BOUTON (x1+80,y2-50,x1+150,y2-15,7,8,15);\r
+ call move (x1+90,y2-35);\r
+ call color (8);\r
+ call outstring ("O U I");\r
+ call delai (2000);\r
+ call move (x1+90,y2-35);\r
+ call color (8);\r
+ call outstring ("O U I");\r
+ call BOUTON (x1+80,y2-50,x1+150,y2-15,7,15,8);\r
+ call move (x1+90,y2-35);\r
+ call color (8);\r
+ call outstring ("O U I");\r
+ succes := true;\r
+ exit ;\r
+ fi;\r
+ if (x>(x1+200) and x<(x1+270) and y>(y2-50) and y<(y2-15)) then\r
+ call BOUTON (x1+200,y2-50,x1+270,y2-15,7,8,15);\r
+ call color (8);\r
+ call move (x1+210,y2-35);\r
+ call outstring ("N O N ");\r
+ call delai (2000);\r
+ call move (x1+210,y2-35);\r
+ call outstring ("N O N ");\r
+ call BOUTON (x1+200,y2-50,x1+270,y2-15,7,15,8);\r
+ call color (8);\r
+ call move (x1+210,y2-35);\r
+ call outstring ("N O N ");\r
+ exit;\r
+ fi;\r
+ call showcursor;\r
+ fi;\r
+ od;\r
+ result := succes;\r
+END BOX_MESSAGE;\r
+\r
+unit carre : procedure (x,y : integer);\r
+ begin\r
+ call RECTANGLE_PLEIN (x,y,x+39,y+31,7,15);\r
+ call color (15);\r
+ call move (x,y+29);\r
+ call draw (x,y);\r
+ call draw (x+37,y);\r
+ call color (8);\r
+ call draw (x+37,y+29);\r
+ call draw (x+1,y+29);\r
+ call color (8);\r
+ call move (x+38,y+3);\r
+ call draw (x+38,y+30);\r
+ call draw (x+3,y+30);\r
+ end;\r
+\r
+ unit eff_titre : procedure;\r
+ var\r
+ f : file,\r
+ i,j : integer,\r
+ n : integer,\r
+ col : integer,\r
+ A : arrayof char,\r
+ map : arrayof integer,\r
+ c : char;\r
+ begin\r
+ for i:=5 to 10 do\r
+ for j:=0 to 1 do\r
+ call carre (i*40,j*32);\r
+ od;\r
+ od;\r
+ \r
+ end eff_titre;\r
+\r
+ unit tracev : procedure (x,y2,y1 : integer);\r
+ begin\r
+ call move (x,y1);\r
+ call vfill (y2);\r
+ end tracev;\r
+\r
+ unit dessinstat : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (3+x,16+y,13+y); call tracev (3+x,33+y,32+y);\r
+ call tracev (4+x,18+y,8+y); call tracev (4+x,34+y,32+y);\r
+ call tracev (5+x,20+y,7+y); call tracev (5+x,35+y,32+y);\r
+ call tracev (6+x,21+y,6+y); call tracev (6+x,36+y,33+y);\r
+ call tracev (7+x,22+y,5+y); call tracev (7+x,36+y,34+y);\r
+ call tracev (8+x,23+y,4+y); call tracev (8+x,37+y,34+y);\r
+ call tracev (9+x,24+y,3+y); call tracev (9+x,37+y,35+y);\r
+ call tracev (10+x,24+y,3+y); call tracev (10+x,38+y,35+y);\r
+ call tracev (11+x,25+y,2+y); call tracev (11+x,38+y,36+y);\r
+ call tracev (12+x,26+y,2+y); call tracev (12+x,38+y,36+y);\r
+ call tracev (13+x,26+y,2+y); call tracev (13+x,38+y,36+y);\r
+ call tracev (14+x,27+y,2+y); call tracev (14+x,39+y,36+y);\r
+ call tracev (15+x,28+y,2+y); call tracev (15+x,39+y,36+y);\r
+ call tracev (16+x,29+y,2+y); call tracev (16+x,39+y,35+y);\r
+ call tracev (17+x,29+y,2+y); call tracev (17+x,39+y,35+y);\r
+ call tracev (18+x,39+y,2+y); call tracev (19+x,8+y,2+y);\r
+ call tracev (19+x,39+y,10+y); call tracev (20+x,6+y,2+y);\r
+ call tracev (20+x,38+y,11+y); call tracev (21+x,5+y,2+y);\r
+ call tracev (21+x,38+y,12+y); call tracev (22+x,4+y,2+y);\r
+ call tracev (22+x,38+y,13+y); call tracev (23+x,4+y,2+y);\r
+ call tracev (23+x,38+y,14+y); call tracev (24+x,4+y,2+y);\r
+ call tracev (24+x,38+y,14+y); call tracev (25+x,4+y,2+y);\r
+ call tracev (25+x,38+y,15+y); call tracev (26+x,4+y,2+y);\r
+ call tracev (26+x,37+y,15+y); call tracev (27+x,5+y,2+y);\r
+ call tracev (27+x,37+y,16+y); call tracev (28+x,5+y,3+y);\r
+ call tracev (28+x,36+y,17+y); call tracev (29+x,6+y,3+y);\r
+ call tracev (29+x,36+y,18+y); call tracev (30+x,8+y,4+y);\r
+ call tracev (30+x,35+y,19+y); call tracev (31+x,4+y,2+y);\r
+ call tracev (31+x,9+y,5+y); call tracev (31+x,34+y,20+y);\r
+ call tracev (32+x,4+y,2+y); call tracev (32+x,9+y,6+y);\r
+ call tracev (32+x,33+y,22+y); call tracev (33+x,4+y,2+y);\r
+ call tracev (33+x,9+y,8+y); call tracev (33+x,30+y,25+y);\r
+ call tracev (34+x,4+y,2+y); call tracev (35+x,4+y,2+y);\r
+ call tracev (36+x,4+y,2+y); call tracev (37+x,4+y,2+y);\r
+ call tracev (38+x,4+y,2+y); call tracev (39+x,4+y,2+y);\r
+ call tracev (40+x,4+y,2+y); call tracev (41+x,4+y,2+y);\r
+ call tracev (42+x,38+y,2+y); call tracev (43+x,38+y,2+y);\r
+ call tracev (44+x,38+y,2+y); call tracev (45+x,38+y,2+y);\r
+ call tracev (46+x,38+y,2+y); call tracev (47+x,38+y,2+y);\r
+ call tracev (48+x,38+y,2+y); call tracev (49+x,38+y,2+y);\r
+ call tracev (50+x,38+y,2+y); call tracev (51+x,38+y,2+y);\r
+ call tracev (52+x,38+y,2+y); call tracev (53+x,38+y,2+y);\r
+ call tracev (54+x,38+y,2+y); call tracev (55+x,38+y,2+y);\r
+ call tracev (56+x,38+y,2+y); call tracev (57+x,38+y,2+y);\r
+ call tracev (58+x,38+y,2+y); call tracev (59+x,38+y,2+y);\r
+ call tracev (60+x,38+y,2+y); call tracev (61+x,4+y,2+y);\r
+ call tracev (61+x,38+y,37+y); call tracev (62+x,4+y,2+y);\r
+ call tracev (62+x,38+y,35+y); call tracev (63+x,4+y,2+y);\r
+ call tracev (63+x,38+y,33+y); call tracev (64+x,4+y,2+y);\r
+ call tracev (64+x,37+y,31+y); call tracev (65+x,4+y,2+y);\r
+ call tracev (65+x,35+y,29+y); call tracev (66+x,4+y,2+y);\r
+ call tracev (66+x,34+y,27+y); call tracev (67+x,4+y,2+y);\r
+ call tracev (67+x,34+y,25+y); call tracev (68+x,4+y,2+y);\r
+ call tracev (68+x,29+y,23+y); call tracev (68+x,34+y,31+y);\r
+ call tracev (69+x,4+y,2+y); call tracev (69+x,27+y,21+y);\r
+ call tracev (69+x,34+y,31+y); call tracev (70+x,4+y,2+y);\r
+ call tracev (70+x,25+y,19+y); call tracev (70+x,34+y,31+y);\r
+ call tracev (71+x,23+y,17+y); call tracev (71+x,34+y,31+y);\r
+ call tracev (72+x,25+y,15+y); call tracev (72+x,34+y,31+y);\r
+ call tracev (73+x,27+y,13+y); call tracev (73+x,34+y,31+y);\r
+ call tracev (74+x,29+y,11+y); call tracev (74+x,34+y,31+y);\r
+ call tracev (75+x,34+y,9+y); call tracev (76+x,34+y,7+y);\r
+ call tracev (77+x,35+y,5+y); call tracev (78+x,37+y,3+y);\r
+ call tracev (79+x,38+y,2+y); call tracev (80+x,38+y,3+y);\r
+ call tracev (81+x,38+y,5+y); call tracev (82+x,38+y,7+y);\r
+ call tracev (83+x,38+y,9+y); call tracev (84+x,38+y,11+y);\r
+ call tracev (85+x,38+y,13+y); call tracev (86+x,38+y,15+y);\r
+ call tracev (87+x,38+y,17+y); call tracev (88+x,38+y,19+y);\r
+ call tracev (89+x,4+y,2+y); call tracev (89+x,38+y,21+y);\r
+ call tracev (90+x,4+y,2+y); call tracev (90+x,38+y,23+y);\r
+ call tracev (91+x,4+y,2+y); call tracev (91+x,38+y,25+y);\r
+ call tracev (92+x,4+y,2+y); call tracev (92+x,38+y,27+y);\r
+ call tracev (93+x,4+y,2+y); call tracev (93+x,38+y,29+y);\r
+ call tracev (94+x,4+y,2+y); call tracev (94+x,38+y,31+y);\r
+ call tracev (95+x,4+y,2+y); call tracev (95+x,38+y,33+y);\r
+ call tracev (96+x,4+y,2+y); call tracev (96+x,38+y,35+y);\r
+ call tracev (97+x,4+y,2+y); call tracev (97+x,38+y,37+y);\r
+ call tracev (98+x,4+y,2+y); call tracev (99+x,38+y,2+y);\r
+ call tracev (100+x,38+y,2+y); call tracev (101+x,38+y,2+y);\r
+ call tracev (102+x,38+y,2+y); call tracev (103+x,38+y,2+y);\r
+ call tracev (104+x,38+y,2+y); call tracev (105+x,38+y,2+y);\r
+ call tracev (106+x,38+y,2+y); call tracev (107+x,38+y,2+y);\r
+ call tracev (108+x,38+y,2+y); call tracev (109+x,38+y,2+y);\r
+ call tracev (110+x,38+y,2+y); call tracev (111+x,38+y,2+y);\r
+ call tracev (112+x,38+y,2+y); call tracev (113+x,38+y,2+y);\r
+ call tracev (114+x,38+y,2+y); call tracev (115+x,38+y,2+y);\r
+ call tracev (116+x,38+y,2+y); call tracev (117+x,38+y,2+y);\r
+ call tracev (118+x,4+y,2+y); call tracev (119+x,4+y,2+y);\r
+ call tracev (120+x,4+y,2+y); call tracev (121+x,4+y,2+y);\r
+ call tracev (122+x,4+y,2+y); call tracev (123+x,4+y,2+y);\r
+ call tracev (124+x,4+y,2+y); call tracev (124+x,16+y,10+y);\r
+ call tracev (124+x,34+y,32+y); call tracev (125+x,4+y,2+y);\r
+ call tracev (125+x,19+y,8+y); call tracev (125+x,35+y,32+y);\r
+ call tracev (126+x,4+y,2+y); call tracev (126+x,21+y,6+y);\r
+ call tracev (126+x,35+y,32+y); call tracev (127+x,4+y,2+y);\r
+ call tracev (127+x,22+y,5+y); call tracev (127+x,36+y,33+y);\r
+ call tracev (128+x,22+y,5+y); call tracev (128+x,36+y,34+y);\r
+ call tracev (129+x,23+y,4+y); call tracev (129+x,37+y,34+y);\r
+ call tracev (130+x,24+y,3+y); call tracev (130+x,38+y,35+y);\r
+ call tracev (131+x,25+y,2+y); call tracev (131+x,38+y,36+y);\r
+ call tracev (132+x,26+y,2+y); call tracev (132+x,38+y,36+y);\r
+ call tracev (133+x,26+y,2+y); call tracev (133+x,38+y,36+y);\r
+ call tracev (134+x,27+y,2+y); call tracev (134+x,39+y,36+y);\r
+ call tracev (135+x,28+y,2+y); call tracev (135+x,39+y,36+y);\r
+ call tracev (136+x,29+y,2+y); call tracev (136+x,39+y,36+y);\r
+ call tracev (137+x,29+y,2+y); call tracev (137+x,39+y,35+y);\r
+ call tracev (138+x,31+y,2+y); call tracev (138+x,39+y,33+y);\r
+ call tracev (139+x,39+y,2+y); call tracev (140+x,6+y,2+y);\r
+ call tracev (140+x,39+y,11+y); call tracev (141+x,5+y,2+y);\r
+ call tracev (141+x,38+y,12+y); call tracev (142+x,5+y,2+y);\r
+ call tracev (142+x,38+y,13+y); call tracev (143+x,4+y,2+y);\r
+ call tracev (143+x,38+y,14+y); call tracev (144+x,4+y,2+y);\r
+ call tracev (144+x,38+y,14+y); call tracev (145+x,4+y,2+y);\r
+ call tracev (145+x,38+y,15+y); call tracev (146+x,4+y,2+y);\r
+ call tracev (146+x,38+y,15+y); call tracev (147+x,4+y,2+y);\r
+ call tracev (147+x,37+y,16+y); call tracev (148+x,5+y,2+y);\r
+ call tracev (148+x,37+y,16+y); call tracev (149+x,5+y,3+y);\r
+ call tracev (149+x,36+y,17+y); call tracev (150+x,6+y,3+y);\r
+ call tracev (150+x,36+y,18+y); call tracev (151+x,8+y,4+y);\r
+ call tracev (151+x,35+y,20+y); call tracev (152+x,9+y,6+y);\r
+ call tracev (152+x,33+y,21+y); call tracev (153+x,9+y,7+y);\r
+ call tracev (153+x,32+y,22+y);\r
+ call tracev (154+x,9+y,8+y);\r
+ call tracev (154+x,28+y,25+y);\r
+end dessinstat;\r
+\r
+ unit dessinmenu : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (8+x,47+y,45+y); call tracev (9+x,47+y,43+y);\r
+ call tracev (10+x,45+y,40+y); call tracev (11+x,43+y,38+y);\r
+ call tracev (12+x,41+y,35+y); call tracev (13+x,38+y,32+y);\r
+ call tracev (14+x,36+y,30+y); call tracev (15+x,37+y,27+y);\r
+ call tracev (16+x,38+y,25+y); call tracev (17+x,40+y,22+y);\r
+ call tracev (18+x,41+y,20+y); call tracev (19+x,43+y,17+y);\r
+ call tracev (20+x,44+y,14+y); call tracev (21+x,46+y,12+y);\r
+ call tracev (22+x,47+y,10+y); call tracev (23+x,46+y,11+y);\r
+ call tracev (24+x,44+y,13+y); call tracev (25+x,43+y,14+y);\r
+ call tracev (26+x,41+y,16+y); call tracev (27+x,40+y,17+y);\r
+ call tracev (28+x,38+y,19+y); call tracev (29+x,37+y,20+y);\r
+ call tracev (30+x,36+y,22+y); call tracev (31+x,38+y,20+y);\r
+ call tracev (32+x,41+y,19+y); call tracev (33+x,43+y,17+y);\r
+ call tracev (34+x,45+y,16+y); call tracev (35+x,47+y,14+y);\r
+ call tracev (36+x,47+y,13+y); call tracev (37+x,47+y,11+y);\r
+ call tracev (38+x,47+y,10+y); call tracev (39+x,47+y,12+y);\r
+ call tracev (40+x,47+y,14+y); call tracev (41+x,47+y,17+y);\r
+ call tracev (42+x,47+y,19+y); call tracev (43+x,47+y,21+y);\r
+ call tracev (44+x,47+y,24+y); call tracev (45+x,47+y,26+y);\r
+ call tracev (46+x,47+y,29+y); call tracev (47+x,47+y,31+y);\r
+ call tracev (48+x,47+y,33+y); call tracev (49+x,47+y,36+y);\r
+ call tracev (50+x,47+y,38+y); call tracev (51+x,47+y,41+y);\r
+ call tracev (52+x,47+y,43+y); call tracev (53+x,47+y,45+y);\r
+ call tracev (55+x,47+y,10+y); call tracev (56+x,47+y,10+y);\r
+ call tracev (57+x,47+y,10+y); call tracev (58+x,47+y,10+y);\r
+ call tracev (59+x,47+y,10+y); call tracev (60+x,47+y,10+y);\r
+ call tracev (61+x,47+y,10+y); call tracev (62+x,47+y,10+y);\r
+ call tracev (63+x,47+y,10+y); call tracev (64+x,47+y,10+y);\r
+ call tracev (65+x,47+y,10+y); call tracev (66+x,47+y,10+y);\r
+ call tracev (67+x,47+y,10+y); call tracev (68+x,47+y,10+y);\r
+ call tracev (69+x,47+y,10+y); call tracev (70+x,47+y,10+y);\r
+ call tracev (71+x,47+y,10+y); call tracev (72+x,47+y,10+y);\r
+ call tracev (73+x,13+y,10+y); call tracev (73+x,23+y,21+y);\r
+ call tracev (73+x,47+y,44+y); call tracev (74+x,13+y,10+y);\r
+ call tracev (74+x,23+y,21+y); call tracev (74+x,47+y,44+y);\r
+ call tracev (75+x,13+y,10+y); call tracev (75+x,23+y,21+y);\r
+ call tracev (75+x,47+y,44+y); call tracev (76+x,13+y,10+y);\r
+ call tracev (76+x,23+y,21+y); call tracev (76+x,47+y,44+y);\r
+ call tracev (77+x,13+y,10+y); call tracev (77+x,23+y,21+y);\r
+ call tracev (77+x,47+y,44+y); call tracev (78+x,13+y,10+y);\r
+ call tracev (78+x,23+y,21+y); call tracev (78+x,47+y,44+y);\r
+ call tracev (79+x,13+y,10+y); call tracev (79+x,23+y,21+y);\r
+ call tracev (79+x,47+y,44+y); call tracev (80+x,13+y,10+y);\r
+ call tracev (80+x,23+y,21+y); call tracev (80+x,47+y,44+y);\r
+ call tracev (81+x,13+y,10+y); call tracev (81+x,23+y,21+y);\r
+ call tracev (81+x,47+y,44+y); call tracev (82+x,13+y,10+y);\r
+ call tracev (82+x,23+y,21+y); call tracev (82+x,47+y,44+y);\r
+ call tracev (83+x,13+y,10+y); call tracev (83+x,23+y,21+y);\r
+ call tracev (83+x,47+y,44+y); call tracev (84+x,13+y,10+y);\r
+ call tracev (84+x,23+y,21+y); call tracev (84+x,47+y,44+y);\r
+ call tracev (85+x,13+y,10+y); call tracev (85+x,23+y,21+y);\r
+ call tracev (85+x,47+y,44+y); call tracev (86+x,13+y,10+y);\r
+ call tracev (86+x,23+y,21+y); call tracev (86+x,47+y,44+y);\r
+ call tracev (87+x,13+y,10+y); call tracev (87+x,23+y,21+y);\r
+ call tracev (87+x,47+y,44+y); call tracev (88+x,23+y,21+y);\r
+ call tracev (88+x,47+y,44+y); call tracev (89+x,23+y,21+y);\r
+ call tracev (89+x,47+y,44+y); call tracev (90+x,47+y,44+y);\r
+ call tracev (92+x,47+y,10+y); call tracev (93+x,47+y,11+y);\r
+ call tracev (94+x,30+y,11+y); call tracev (95+x,30+y,12+y);\r
+ call tracev (96+x,31+y,12+y); call tracev (97+x,31+y,13+y);\r
+ call tracev (98+x,32+y,14+y); call tracev (99+x,32+y,14+y);\r
+ call tracev (100+x,33+y,15+y); call tracev (101+x,33+y,16+y);\r
+ call tracev (102+x,34+y,16+y); call tracev (103+x,35+y,17+y);\r
+ call tracev (104+x,35+y,17+y); call tracev (105+x,36+y,18+y);\r
+ call tracev (106+x,36+y,19+y); call tracev (107+x,37+y,19+y);\r
+ call tracev (108+x,37+y,20+y); call tracev (109+x,38+y,20+y);\r
+ call tracev (110+x,39+y,21+y); call tracev (111+x,39+y,22+y);\r
+ call tracev (112+x,40+y,22+y); call tracev (113+x,40+y,23+y);\r
+ call tracev (114+x,41+y,23+y); call tracev (115+x,41+y,24+y);\r
+ call tracev (116+x,42+y,25+y); call tracev (117+x,42+y,25+y);\r
+ call tracev (118+x,43+y,26+y); call tracev (119+x,44+y,27+y);\r
+ call tracev (120+x,44+y,27+y); call tracev (121+x,45+y,28+y);\r
+ call tracev (122+x,45+y,28+y); call tracev (123+x,46+y,10+y);\r
+ call tracev (124+x,46+y,10+y); call tracev (125+x,47+y,10+y);\r
+ call tracev (127+x,37+y,10+y); call tracev (128+x,39+y,10+y);\r
+ call tracev (129+x,41+y,10+y); call tracev (130+x,42+y,10+y);\r
+ call tracev (131+x,43+y,10+y); call tracev (132+x,44+y,10+y);\r
+ call tracev (133+x,45+y,10+y); call tracev (134+x,46+y,10+y);\r
+ call tracev (135+x,46+y,10+y); call tracev (136+x,47+y,10+y);\r
+ call tracev (137+x,47+y,10+y); call tracev (138+x,47+y,10+y);\r
+ call tracev (139+x,47+y,10+y); call tracev (140+x,48+y,10+y);\r
+ call tracev (141+x,48+y,10+y); call tracev (142+x,48+y,10+y);\r
+ call tracev (143+x,48+y,10+y); call tracev (144+x,48+y,10+y);\r
+ call tracev (145+x,48+y,45+y); call tracev (146+x,48+y,45+y);\r
+ call tracev (147+x,48+y,45+y); call tracev (148+x,47+y,45+y);\r
+ call tracev (149+x,47+y,45+y); call tracev (150+x,47+y,45+y);\r
+ call tracev (151+x,47+y,44+y); call tracev (152+x,47+y,44+y);\r
+ call tracev (153+x,47+y,43+y); call tracev (154+x,46+y,43+y);\r
+ call tracev (155+x,46+y,42+y); call tracev (156+x,45+y,42+y);\r
+ call tracev (157+x,44+y,41+y); call tracev (158+x,43+y,41+y);\r
+ call tracev (159+x,43+y,39+y); call tracev (160+x,42+y,37+y);\r
+ call tracev (161+x,41+y,10+y); call tracev (162+x,39+y,10+y);\r
+ end dessinmenu;\r
+\r
+ unit dessinelem : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (41+x,3+y,1+y); call tracev (42+x,3+y,1+y);\r
+ call tracev (43+x,3+y,1+y); call tracev (44+x,3+y,1+y);\r
+ call tracev (45+x,3+y,1+y); call tracev (46+x,3+y,1+y);\r
+ call tracev (47+x,3+y,1+y); call tracev (48+x,3+y,1+y);\r
+ call tracev (49+x,3+y,1+y); call tracev (50+x,3+y,1+y);\r
+ call tracev (51+x,3+y,1+y); call tracev (52+x,37+y,1+y);\r
+ call tracev (53+x,37+y,1+y); call tracev (54+x,37+y,1+y);\r
+ call tracev (55+x,37+y,1+y); call tracev (56+x,37+y,1+y);\r
+ call tracev (57+x,37+y,1+y); call tracev (58+x,37+y,1+y);\r
+ call tracev (59+x,37+y,1+y); call tracev (60+x,37+y,1+y);\r
+ call tracev (61+x,37+y,1+y); call tracev (62+x,37+y,1+y);\r
+ call tracev (63+x,37+y,1+y); call tracev (64+x,37+y,1+y);\r
+ call tracev (65+x,37+y,1+y); call tracev (66+x,37+y,1+y);\r
+ call tracev (67+x,37+y,1+y); call tracev (68+x,37+y,1+y);\r
+ call tracev (69+x,37+y,1+y); call tracev (70+x,37+y,1+y);\r
+ call tracev (71+x,3+y,1+y); call tracev (72+x,3+y,1+y);\r
+ call tracev (73+x,3+y,1+y); call tracev (74+x,3+y,1+y);\r
+ call tracev (75+x,3+y,1+y); call tracev (76+x,3+y,1+y);\r
+ call tracev (77+x,3+y,1+y); call tracev (78+x,3+y,1+y);\r
+ call tracev (79+x,3+y,1+y); call tracev (80+x,3+y,1+y);\r
+ call tracev (82+x,2+y,1+y); call tracev (83+x,4+y,1+y);\r
+ call tracev (84+x,6+y,1+y); call tracev (85+x,8+y,1+y);\r
+ call tracev (86+x,10+y,1+y); call tracev (87+x,12+y,1+y);\r
+ call tracev (88+x,14+y,1+y); call tracev (89+x,16+y,1+y);\r
+ call tracev (90+x,18+y,1+y); call tracev (91+x,20+y,1+y);\r
+ call tracev (92+x,22+y,1+y); call tracev (93+x,24+y,1+y);\r
+ call tracev (94+x,26+y,1+y); call tracev (94+x,37+y,36+y);\r
+ call tracev (95+x,28+y,1+y); call tracev (95+x,37+y,34+y);\r
+ call tracev (96+x,30+y,1+y); call tracev (96+x,36+y,32+y);\r
+ call tracev (97+x,34+y,1+y); call tracev (98+x,32+y,1+y);\r
+ call tracev (99+x,30+y,1+y); call tracev (100+x,28+y,2+y);\r
+ call tracev (101+x,26+y,4+y); call tracev (102+x,24+y,6+y);\r
+ call tracev (103+x,22+y,8+y); call tracev (104+x,20+y,10+y);\r
+ call tracev (105+x,18+y,12+y); call tracev (106+x,16+y,10+y);\r
+ call tracev (107+x,14+y,8+y); call tracev (108+x,12+y,6+y);\r
+ call tracev (109+x,10+y,4+y); call tracev (110+x,8+y,2+y);\r
+ call tracev (111+x,6+y,1+y); call tracev (112+x,4+y,1+y);\r
+ call tracev (113+x,2+y,1+y); call tracev (115+x,37+y,1+y);\r
+ call tracev (116+x,37+y,1+y); call tracev (117+x,37+y,1+y);\r
+ call tracev (118+x,37+y,1+y); call tracev (119+x,37+y,1+y);\r
+ call tracev (120+x,37+y,1+y); call tracev (121+x,37+y,1+y);\r
+ call tracev (122+x,37+y,1+y); call tracev (123+x,37+y,1+y);\r
+ call tracev (124+x,37+y,1+y); call tracev (125+x,37+y,1+y);\r
+ call tracev (126+x,37+y,1+y); call tracev (127+x,37+y,1+y);\r
+ call tracev (128+x,37+y,1+y); call tracev (129+x,37+y,1+y);\r
+ call tracev (130+x,37+y,1+y); call tracev (131+x,37+y,1+y);\r
+ call tracev (132+x,37+y,1+y); call tracev (133+x,3+y,1+y);\r
+ call tracev (133+x,27+y,25+y); call tracev (134+x,3+y,1+y);\r
+ call tracev (134+x,27+y,25+y); call tracev (135+x,3+y,1+y);\r
+ call tracev (135+x,28+y,26+y); call tracev (136+x,3+y,1+y);\r
+ call tracev (136+x,28+y,26+y); call tracev (137+x,3+y,1+y);\r
+ call tracev (137+x,28+y,26+y); call tracev (138+x,4+y,1+y);\r
+ call tracev (138+x,28+y,25+y); call tracev (139+x,4+y,1+y);\r
+ call tracev (139+x,28+y,25+y); call tracev (140+x,4+y,1+y);\r
+ call tracev (140+x,28+y,25+y); call tracev (141+x,4+y,1+y);\r
+ call tracev (141+x,28+y,25+y); call tracev (142+x,4+y,2+y);\r
+ call tracev (142+x,27+y,25+y); call tracev (143+x,5+y,2+y);\r
+ call tracev (143+x,27+y,24+y); call tracev (144+x,6+y,3+y);\r
+ call tracev (144+x,26+y,23+y); call tracev (145+x,6+y,4+y);\r
+ call tracev (145+x,25+y,22+y); call tracev (146+x,8+y,5+y);\r
+ call tracev (146+x,24+y,22+y); call tracev (147+x,10+y,5+y);\r
+ call tracev (147+x,23+y,19+y); call tracev (148+x,14+y,6+y);\r
+ call tracev (148+x,22+y,17+y); call tracev (149+x,21+y,8+y);\r
+ call tracev (150+x,20+y,10+y); call tracev (152+x,37+y,1+y);\r
+ call tracev (153+x,37+y,1+y); call tracev (154+x,37+y,1+y);\r
+ call tracev (155+x,37+y,1+y); call tracev (156+x,37+y,1+y);\r
+ call tracev (157+x,37+y,1+y); call tracev (158+x,37+y,1+y);\r
+ call tracev (159+x,37+y,1+y); call tracev (160+x,37+y,1+y);\r
+ call tracev (161+x,37+y,1+y); call tracev (162+x,37+y,1+y);\r
+ call tracev (163+x,37+y,1+y); call tracev (164+x,37+y,1+y);\r
+ call tracev (165+x,37+y,1+y); call tracev (166+x,37+y,1+y);\r
+ call tracev (167+x,37+y,1+y); call tracev (168+x,37+y,1+y);\r
+ call tracev (169+x,37+y,1+y); call tracev (170+x,37+y,1+y);\r
+ call tracev (171+x,3+y,1+y); call tracev (171+x,13+y,11+y);\r
+ call tracev (171+x,37+y,35+y); call tracev (172+x,3+y,1+y);\r
+ call tracev (172+x,13+y,11+y); call tracev (172+x,37+y,35+y);\r
+ call tracev (173+x,3+y,1+y); call tracev (173+x,13+y,11+y);\r
+ call tracev (173+x,37+y,35+y); call tracev (174+x,3+y,1+y);\r
+ call tracev (174+x,13+y,11+y); call tracev (174+x,37+y,35+y);\r
+ call tracev (175+x,3+y,1+y); call tracev (175+x,13+y,11+y);\r
+ call tracev (175+x,37+y,35+y); call tracev (176+x,3+y,1+y);\r
+ call tracev (176+x,13+y,11+y); call tracev (176+x,37+y,35+y);\r
+ call tracev (177+x,3+y,1+y); call tracev (177+x,13+y,11+y);\r
+ call tracev (177+x,37+y,35+y); call tracev (178+x,3+y,1+y);\r
+ call tracev (178+x,13+y,11+y); call tracev (178+x,37+y,35+y);\r
+ call tracev (179+x,3+y,1+y); call tracev (179+x,13+y,11+y);\r
+ call tracev (179+x,37+y,35+y); call tracev (180+x,3+y,1+y);\r
+ call tracev (180+x,13+y,11+y); call tracev (180+x,37+y,35+y);\r
+ call tracev (181+x,3+y,1+y); call tracev (181+x,13+y,11+y);\r
+ call tracev (181+x,37+y,35+y); call tracev (182+x,3+y,1+y);\r
+ call tracev (182+x,13+y,11+y); call tracev (182+x,37+y,35+y);\r
+ call tracev (183+x,3+y,1+y); call tracev (183+x,13+y,11+y);\r
+ call tracev (183+x,37+y,35+y); call tracev (184+x,3+y,1+y);\r
+ call tracev (184+x,13+y,11+y); call tracev (184+x,37+y,35+y);\r
+ call tracev (185+x,3+y,1+y); call tracev (185+x,13+y,11+y);\r
+ call tracev (185+x,37+y,35+y); call tracev (186+x,13+y,11+y);\r
+ call tracev (186+x,37+y,35+y); call tracev (187+x,37+y,35+y);\r
+ call tracev (188+x,37+y,35+y);\r
+ end dessinelem;\r
+\r
+ unit dessinrand : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (0+x,39+y,2+y); call tracev (1+x,39+y,2+y);\r
+ call tracev (2+x,39+y,2+y); call tracev (3+x,39+y,2+y);\r
+ call tracev (4+x,39+y,2+y); call tracev (5+x,39+y,2+y);\r
+ call tracev (6+x,39+y,2+y); call tracev (7+x,39+y,2+y);\r
+ call tracev (8+x,39+y,2+y); call tracev (9+x,39+y,2+y);\r
+ call tracev (10+x,39+y,2+y); call tracev (11+x,39+y,2+y);\r
+ call tracev (12+x,39+y,2+y); call tracev (13+x,39+y,2+y);\r
+ call tracev (14+x,39+y,2+y); call tracev (15+x,39+y,2+y);\r
+ call tracev (16+x,39+y,2+y); call tracev (17+x,39+y,2+y);\r
+ call tracev (18+x,39+y,2+y); call tracev (19+x,5+y,2+y);\r
+ call tracev (19+x,31+y,27+y); call tracev (20+x,5+y,2+y);\r
+ call tracev (20+x,32+y,27+y); call tracev (21+x,5+y,2+y);\r
+ call tracev (21+x,29+y,27+y); call tracev (21+x,33+y,30+y);\r
+ call tracev (22+x,5+y,2+y); call tracev (22+x,29+y,27+y);\r
+ call tracev (22+x,34+y,31+y); call tracev (23+x,5+y,2+y);\r
+ call tracev (23+x,29+y,27+y); call tracev (23+x,34+y,32+y);\r
+ call tracev (24+x,5+y,3+y); call tracev (24+x,29+y,27+y);\r
+ call tracev (24+x,35+y,32+y); call tracev (25+x,5+y,3+y);\r
+ call tracev (25+x,29+y,27+y); call tracev (25+x,35+y,33+y);\r
+ call tracev (26+x,5+y,3+y); call tracev (26+x,29+y,27+y);\r
+ call tracev (26+x,36+y,33+y); call tracev (27+x,6+y,3+y);\r
+ call tracev (27+x,29+y,26+y); call tracev (27+x,36+y,34+y);\r
+ call tracev (28+x,6+y,4+y); call tracev (28+x,28+y,26+y);\r
+ call tracev (28+x,36+y,34+y); call tracev (29+x,7+y,4+y);\r
+ call tracev (29+x,28+y,25+y); call tracev (29+x,37+y,35+y);\r
+ call tracev (30+x,7+y,4+y); call tracev (30+x,27+y,25+y);\r
+ call tracev (30+x,37+y,35+y); call tracev (31+x,8+y,5+y);\r
+ call tracev (31+x,27+y,24+y); call tracev (31+x,38+y,36+y);\r
+ call tracev (32+x,10+y,6+y); call tracev (32+x,26+y,23+y);\r
+ call tracev (32+x,38+y,36+y); call tracev (33+x,12+y,7+y);\r
+ call tracev (33+x,25+y,21+y); call tracev (33+x,39+y,36+y);\r
+ call tracev (34+x,24+y,8+y); call tracev (34+x,39+y,36+y);\r
+ call tracev (35+x,23+y,10+y); call tracev (35+x,39+y,36+y);\r
+ call tracev (36+x,21+y,12+y); call tracev (36+x,39+y,36+y);\r
+ call tracev (38+x,39+y,37+y); call tracev (39+x,39+y,35+y);\r
+ call tracev (40+x,38+y,33+y); call tracev (41+x,36+y,31+y);\r
+ call tracev (42+x,35+y,29+y); call tracev (43+x,35+y,27+y);\r
+ call tracev (44+x,30+y,25+y); call tracev (44+x,35+y,32+y);\r
+ call tracev (45+x,28+y,23+y); call tracev (45+x,35+y,32+y);\r
+ call tracev (46+x,26+y,21+y); call tracev (46+x,35+y,32+y);\r
+ call tracev (47+x,24+y,18+y); call tracev (47+x,35+y,32+y);\r
+ call tracev (48+x,25+y,16+y); call tracev (48+x,35+y,32+y);\r
+ call tracev (49+x,27+y,14+y); call tracev (49+x,35+y,32+y);\r
+ call tracev (50+x,28+y,12+y); call tracev (50+x,35+y,32+y);\r
+ call tracev (51+x,30+y,10+y); call tracev (51+x,35+y,32+y);\r
+ call tracev (52+x,35+y,8+y); call tracev (53+x,36+y,6+y);\r
+ call tracev (54+x,38+y,4+y); call tracev (55+x,39+y,2+y);\r
+ call tracev (56+x,39+y,4+y); call tracev (57+x,39+y,6+y);\r
+ call tracev (58+x,39+y,8+y); call tracev (59+x,39+y,10+y);\r
+ call tracev (60+x,39+y,12+y); call tracev (61+x,39+y,14+y);\r
+ call tracev (62+x,39+y,16+y); call tracev (63+x,39+y,18+y);\r
+ call tracev (64+x,39+y,20+y); call tracev (65+x,39+y,22+y);\r
+ call tracev (66+x,39+y,24+y); call tracev (67+x,39+y,26+y);\r
+ call tracev (68+x,39+y,28+y); call tracev (69+x,39+y,30+y);\r
+ call tracev (70+x,39+y,32+y); call tracev (71+x,39+y,34+y);\r
+ call tracev (72+x,39+y,36+y); call tracev (73+x,39+y,38+y);\r
+ call tracev (75+x,39+y,2+y); call tracev (76+x,39+y,3+y);\r
+ call tracev (77+x,22+y,3+y); call tracev (78+x,22+y,4+y);\r
+ call tracev (79+x,23+y,4+y); call tracev (80+x,23+y,5+y);\r
+ call tracev (81+x,24+y,6+y); call tracev (82+x,24+y,6+y);\r
+ call tracev (83+x,25+y,7+y); call tracev (84+x,25+y,8+y);\r
+ call tracev (85+x,26+y,8+y); call tracev (86+x,27+y,9+y);\r
+ call tracev (87+x,27+y,9+y); call tracev (88+x,28+y,10+y);\r
+ call tracev (89+x,28+y,11+y); call tracev (90+x,29+y,11+y);\r
+ call tracev (91+x,29+y,12+y); call tracev (92+x,30+y,12+y);\r
+ call tracev (93+x,31+y,13+y); call tracev (94+x,31+y,14+y);\r
+ call tracev (95+x,32+y,14+y); call tracev (96+x,32+y,15+y);\r
+ call tracev (97+x,33+y,15+y); call tracev (98+x,33+y,16+y);\r
+ call tracev (99+x,34+y,17+y); call tracev (100+x,34+y,17+y);\r
+ call tracev (101+x,35+y,18+y); call tracev (102+x,36+y,19+y);\r
+ call tracev (103+x,36+y,19+y); call tracev (104+x,37+y,20+y);\r
+ call tracev (105+x,37+y,20+y); call tracev (106+x,38+y,2+y);\r
+ call tracev (107+x,38+y,2+y); call tracev (108+x,39+y,2+y);\r
+ call tracev (111+x,39+y,2+y); call tracev (112+x,39+y,2+y);\r
+ call tracev (113+x,39+y,2+y); call tracev (114+x,39+y,2+y);\r
+ call tracev (115+x,39+y,2+y); call tracev (116+x,39+y,2+y);\r
+ call tracev (117+x,39+y,2+y); call tracev (118+x,39+y,2+y);\r
+ call tracev (119+x,39+y,2+y); call tracev (120+x,39+y,2+y);\r
+ call tracev (121+x,39+y,2+y); call tracev (122+x,39+y,2+y);\r
+ call tracev (123+x,39+y,2+y); call tracev (124+x,39+y,2+y);\r
+ call tracev (125+x,39+y,2+y); call tracev (126+x,39+y,2+y);\r
+ call tracev (127+x,39+y,2+y); call tracev (128+x,39+y,2+y);\r
+ call tracev (129+x,39+y,2+y); call tracev (130+x,5+y,2+y);\r
+ call tracev (130+x,39+y,36+y); call tracev (131+x,5+y,2+y);\r
+ call tracev (131+x,39+y,36+y); call tracev (132+x,5+y,2+y);\r
+ call tracev (132+x,38+y,36+y); call tracev (133+x,5+y,2+y);\r
+ call tracev (133+x,38+y,36+y); call tracev (134+x,5+y,2+y);\r
+ call tracev (134+x,38+y,36+y); call tracev (135+x,5+y,2+y);\r
+ call tracev (135+x,38+y,36+y); call tracev (136+x,6+y,2+y);\r
+ call tracev (136+x,37+y,35+y); call tracev (137+x,6+y,3+y);\r
+ call tracev (137+x,37+y,35+y); call tracev (138+x,6+y,3+y);\r
+ call tracev (138+x,37+y,35+y); call tracev (139+x,7+y,4+y);\r
+ call tracev (139+x,36+y,34+y); call tracev (140+x,7+y,4+y);\r
+ call tracev (140+x,36+y,34+y); call tracev (141+x,8+y,5+y);\r
+ call tracev (141+x,35+y,33+y); call tracev (142+x,9+y,6+y);\r
+ call tracev (142+x,35+y,32+y); call tracev (143+x,11+y,7+y);\r
+ call tracev (143+x,34+y,30+y); call tracev (144+x,13+y,8+y);\r
+ call tracev (144+x,33+y,28+y); call tracev (145+x,16+y,10+y);\r
+ call tracev (145+x,31+y,25+y); call tracev (146+x,19+y,11+y);\r
+ call tracev (146+x,30+y,22+y); call tracev (147+x,28+y,13+y);\r
+ call tracev (148+x,26+y,15+y); call tracev (150+x,27+y,15+y);\r
+ call tracev (151+x,29+y,13+y); call tracev (152+x,31+y,11+y);\r
+ call tracev (153+x,32+y,10+y); call tracev (154+x,34+y,8+y);\r
+ call tracev (155+x,35+y,7+y); call tracev (156+x,36+y,6+y);\r
+ call tracev (157+x,36+y,6+y); call tracev (158+x,37+y,5+y);\r
+ call tracev (159+x,37+y,4+y); call tracev (160+x,38+y,4+y);\r
+ call tracev (161+x,38+y,3+y); call tracev (162+x,38+y,3+y);\r
+ call tracev (163+x,39+y,2+y); call tracev (164+x,39+y,2+y);\r
+ call tracev (165+x,39+y,2+y); call tracev (166+x,39+y,2+y);\r
+ call tracev (167+x,40+y,2+y); call tracev (168+x,40+y,2+y);\r
+ call tracev (169+x,5+y,2+y); call tracev (169+x,40+y,37+y);\r
+ call tracev (170+x,5+y,2+y); call tracev (170+x,40+y,37+y);\r
+ call tracev (171+x,5+y,2+y); call tracev (171+x,39+y,37+y);\r
+ call tracev (172+x,5+y,2+y); call tracev (172+x,39+y,37+y);\r
+ call tracev (173+x,5+y,2+y); call tracev (173+x,39+y,37+y);\r
+ call tracev (174+x,5+y,2+y); call tracev (174+x,39+y,37+y);\r
+ call tracev (175+x,6+y,2+y); call tracev (175+x,38+y,36+y);\r
+ call tracev (176+x,6+y,3+y); call tracev (176+x,38+y,36+y);\r
+ call tracev (177+x,6+y,3+y); call tracev (177+x,38+y,35+y);\r
+ call tracev (178+x,7+y,4+y); call tracev (178+x,37+y,35+y);\r
+ call tracev (179+x,7+y,4+y); call tracev (179+x,37+y,34+y);\r
+ call tracev (180+x,8+y,5+y); call tracev (180+x,36+y,33+y);\r
+ call tracev (181+x,9+y,6+y); call tracev (181+x,36+y,32+y);\r
+ call tracev (182+x,11+y,7+y); call tracev (182+x,35+y,31+y);\r
+ call tracev (183+x,13+y,8+y); call tracev (183+x,34+y,29+y);\r
+ call tracev (184+x,16+y,10+y); call tracev (184+x,32+y,26+y);\r
+ call tracev (184+x,39+y,37+y); call tracev (185+x,19+y,11+y);\r
+ call tracev (185+x,31+y,23+y); call tracev (185+x,39+y,35+y);\r
+ call tracev (186+x,29+y,13+y); call tracev (186+x,37+y,32+y);\r
+ call tracev (187+x,27+y,15+y); call tracev (187+x,35+y,30+y);\r
+ call tracev (188+x,33+y,27+y); call tracev (189+x,30+y,24+y);\r
+ call tracev (190+x,28+y,22+y); call tracev (191+x,29+y,19+y);\r
+ call tracev (192+x,30+y,17+y); call tracev (193+x,32+y,14+y);\r
+ call tracev (194+x,33+y,12+y); call tracev (195+x,35+y,9+y);\r
+ call tracev (196+x,36+y,6+y); call tracev (197+x,38+y,4+y);\r
+ call tracev (198+x,39+y,2+y); call tracev (199+x,38+y,3+y);\r
+ call tracev (200+x,36+y,5+y); call tracev (201+x,35+y,6+y);\r
+ call tracev (202+x,33+y,8+y); call tracev (203+x,32+y,9+y);\r
+ call tracev (204+x,30+y,11+y); call tracev (205+x,29+y,12+y);\r
+ call tracev (206+x,28+y,14+y); call tracev (207+x,30+y,12+y);\r
+ call tracev (208+x,33+y,11+y); call tracev (209+x,35+y,9+y);\r
+ call tracev (210+x,37+y,8+y); call tracev (211+x,39+y,6+y);\r
+ call tracev (212+x,39+y,5+y); call tracev (213+x,39+y,3+y);\r
+ call tracev (214+x,39+y,2+y); call tracev (215+x,39+y,4+y);\r
+ call tracev (216+x,39+y,6+y); call tracev (217+x,39+y,9+y);\r
+ call tracev (218+x,39+y,11+y); call tracev (219+x,39+y,13+y);\r
+ call tracev (220+x,39+y,16+y); call tracev (221+x,39+y,18+y);\r
+ call tracev (222+x,39+y,21+y); call tracev (223+x,39+y,23+y);\r
+ call tracev (224+x,39+y,25+y); call tracev (225+x,39+y,28+y);\r
+ call tracev (226+x,39+y,30+y); call tracev (227+x,39+y,33+y);\r
+ call tracev (228+x,39+y,35+y); call tracev (229+x,39+y,37+y);\r
+ end dessinrand;\r
+ \r
+ \r
+ unit dessinquick : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (30+x,26+y,14+y); call tracev (31+x,28+y,12+y);\r
+ call tracev (32+x,30+y,10+y); call tracev (33+x,31+y,9+y);\r
+ call tracev (34+x,33+y,7+y); call tracev (35+x,34+y,6+y);\r
+ call tracev (36+x,35+y,5+y); call tracev (37+x,36+y,4+y);\r
+ call tracev (38+x,36+y,3+y); call tracev (39+x,37+y,3+y);\r
+ call tracev (40+x,37+y,2+y); call tracev (41+x,37+y,2+y);\r
+ call tracev (42+x,37+y,1+y); call tracev (43+x,38+y,1+y);\r
+ call tracev (44+x,38+y,1+y); call tracev (45+x,38+y,1+y);\r
+ call tracev (46+x,39+y,1+y); call tracev (47+x,39+y,1+y);\r
+ call tracev (48+x,4+y,1+y); call tracev (48+x,39+y,36+y);\r
+ call tracev (49+x,4+y,1+y); call tracev (49+x,39+y,36+y);\r
+ call tracev (50+x,4+y,1+y); call tracev (50+x,38+y,36+y);\r
+ call tracev (51+x,4+y,1+y); call tracev (51+x,38+y,36+y);\r
+ call tracev (52+x,4+y,1+y); call tracev (52+x,38+y,36+y);\r
+ call tracev (53+x,4+y,1+y); call tracev (53+x,38+y,35+y);\r
+ call tracev (54+x,4+y,1+y); call tracev (54+x,31+y,30+y);\r
+ call tracev (54+x,38+y,35+y); call tracev (55+x,5+y,2+y);\r
+ call tracev (55+x,31+y,28+y); call tracev (55+x,37+y,34+y);\r
+ call tracev (56+x,5+y,2+y); call tracev (56+x,32+y,29+y);\r
+ call tracev (56+x,37+y,34+y); call tracev (57+x,5+y,3+y);\r
+ call tracev (57+x,36+y,30+y); call tracev (58+x,6+y,3+y);\r
+ call tracev (58+x,36+y,31+y); call tracev (59+x,7+y,4+y);\r
+ call tracev (59+x,36+y,32+y); call tracev (60+x,7+y,5+y);\r
+ call tracev (60+x,36+y,33+y); call tracev (61+x,8+y,5+y);\r
+ call tracev (61+x,36+y,31+y); call tracev (62+x,10+y,6+y);\r
+ call tracev (62+x,33+y,29+y); call tracev (62+x,37+y,34+y);\r
+ call tracev (63+x,12+y,7+y); call tracev (63+x,32+y,28+y);\r
+ call tracev (63+x,38+y,35+y); call tracev (64+x,15+y,9+y);\r
+ call tracev (64+x,31+y,27+y); call tracev (64+x,38+y,35+y);\r
+ call tracev (65+x,29+y,11+y); call tracev (65+x,38+y,36+y);\r
+ call tracev (66+x,27+y,14+y); call tracev (66+x,38+y,36+y);\r
+ call tracev (67+x,21+y,18+y); call tracev (67+x,39+y,36+y);\r
+ call tracev (69+x,28+y,1+y); call tracev (70+x,30+y,1+y);\r
+ call tracev (71+x,32+y,1+y); call tracev (72+x,33+y,1+y);\r
+ call tracev (73+x,34+y,1+y); call tracev (74+x,35+y,1+y);\r
+ call tracev (75+x,36+y,1+y); call tracev (76+x,37+y,1+y);\r
+ call tracev (77+x,37+y,1+y); call tracev (78+x,38+y,1+y);\r
+ call tracev (79+x,38+y,1+y); call tracev (80+x,38+y,1+y);\r
+ call tracev (81+x,38+y,1+y); call tracev (82+x,39+y,1+y);\r
+ call tracev (83+x,39+y,1+y); call tracev (84+x,39+y,1+y);\r
+ call tracev (85+x,39+y,1+y); call tracev (86+x,39+y,1+y);\r
+ call tracev (87+x,39+y,36+y); call tracev (88+x,39+y,36+y);\r
+ call tracev (89+x,39+y,36+y); call tracev (90+x,38+y,36+y);\r
+ call tracev (91+x,38+y,36+y); call tracev (92+x,38+y,36+y);\r
+ call tracev (93+x,38+y,35+y); call tracev (94+x,38+y,35+y);\r
+ call tracev (95+x,38+y,34+y); call tracev (96+x,37+y,34+y);\r
+ call tracev (97+x,37+y,33+y); call tracev (98+x,36+y,33+y);\r
+ call tracev (99+x,35+y,32+y); call tracev (100+x,34+y,32+y);\r
+ call tracev (101+x,34+y,30+y); call tracev (102+x,33+y,28+y);\r
+ call tracev (103+x,32+y,1+y); call tracev (104+x,30+y,1+y);\r
+ call tracev (107+x,38+y,1+y); call tracev (108+x,38+y,1+y);\r
+ call tracev (109+x,38+y,1+y); call tracev (110+x,38+y,1+y);\r
+ call tracev (111+x,38+y,1+y); call tracev (112+x,38+y,1+y);\r
+ call tracev (113+x,38+y,1+y); call tracev (114+x,38+y,1+y);\r
+ call tracev (115+x,38+y,1+y); call tracev (116+x,38+y,1+y);\r
+ call tracev (117+x,38+y,1+y); call tracev (118+x,38+y,1+y);\r
+ call tracev (119+x,38+y,1+y); call tracev (120+x,38+y,1+y);\r
+ call tracev (121+x,38+y,1+y); call tracev (122+x,38+y,1+y);\r
+ call tracev (123+x,38+y,1+y); call tracev (124+x,38+y,1+y);\r
+ call tracev (126+x,22+y,18+y); call tracev (127+x,26+y,14+y);\r
+ call tracev (128+x,29+y,11+y); call tracev (129+x,31+y,9+y);\r
+ call tracev (130+x,33+y,7+y); call tracev (131+x,34+y,6+y);\r
+ call tracev (132+x,35+y,5+y); call tracev (133+x,35+y,5+y);\r
+ call tracev (134+x,36+y,4+y); call tracev (135+x,36+y,3+y);\r
+ call tracev (136+x,37+y,3+y); call tracev (137+x,37+y,2+y);\r
+ call tracev (138+x,37+y,2+y); call tracev (139+x,38+y,1+y);\r
+ call tracev (140+x,38+y,1+y); call tracev (141+x,38+y,1+y);\r
+ call tracev (142+x,38+y,1+y); call tracev (143+x,39+y,1+y);\r
+ call tracev (144+x,39+y,1+y); call tracev (145+x,4+y,1+y);\r
+ call tracev (145+x,39+y,36+y); call tracev (146+x,4+y,1+y);\r
+ call tracev (146+x,39+y,36+y); call tracev (147+x,4+y,1+y);\r
+ call tracev (147+x,39+y,36+y); call tracev (148+x,4+y,1+y);\r
+ call tracev (148+x,38+y,36+y); call tracev (149+x,4+y,1+y);\r
+ call tracev (149+x,38+y,36+y); call tracev (150+x,4+y,1+y);\r
+ call tracev (150+x,38+y,36+y); call tracev (151+x,4+y,2+y);\r
+ call tracev (151+x,38+y,36+y); call tracev (152+x,4+y,2+y);\r
+ call tracev (152+x,38+y,35+y); call tracev (153+x,5+y,2+y);\r
+ call tracev (153+x,37+y,35+y); call tracev (154+x,5+y,2+y);\r
+ call tracev (154+x,37+y,34+y); call tracev (155+x,6+y,3+y);\r
+ call tracev (155+x,36+y,34+y); call tracev (156+x,6+y,4+y);\r
+ call tracev (156+x,36+y,33+y); call tracev (157+x,7+y,4+y);\r
+ call tracev (157+x,35+y,33+y); call tracev (158+x,8+y,5+y);\r
+ call tracev (158+x,35+y,32+y); call tracev (159+x,10+y,5+y);\r
+ call tracev (159+x,34+y,30+y); call tracev (160+x,11+y,6+y);\r
+ call tracev (160+x,33+y,29+y); call tracev (161+x,11+y,8+y);\r
+ call tracev (161+x,32+y,29+y); call tracev (162+x,11+y,10+y);\r
+ call tracev (162+x,31+y,29+y); call tracev (164+x,38+y,1+y);\r
+ call tracev (165+x,38+y,1+y); call tracev (166+x,38+y,1+y);\r
+ call tracev (167+x,38+y,1+y); call tracev (168+x,38+y,1+y);\r
+ call tracev (169+x,38+y,1+y); call tracev (170+x,38+y,1+y);\r
+ call tracev (171+x,38+y,1+y); call tracev (172+x,38+y,1+y);\r
+ call tracev (173+x,38+y,1+y); call tracev (174+x,38+y,1+y);\r
+ call tracev (175+x,38+y,1+y); call tracev (176+x,38+y,1+y);\r
+ call tracev (177+x,38+y,1+y); call tracev (178+x,38+y,1+y);\r
+ call tracev (179+x,38+y,1+y); call tracev (180+x,38+y,1+y);\r
+ call tracev (181+x,38+y,1+y); call tracev (182+x,38+y,1+y);\r
+ call tracev (183+x,13+y,11+y); call tracev (184+x,13+y,11+y);\r
+ call tracev (185+x,13+y,10+y); call tracev (186+x,15+y,9+y);\r
+ call tracev (187+x,11+y,9+y); call tracev (187+x,17+y,12+y);\r
+ call tracev (188+x,11+y,8+y); call tracev (188+x,19+y,14+y);\r
+ call tracev (189+x,10+y,7+y); call tracev (189+x,21+y,16+y);\r
+ call tracev (190+x,9+y,6+y); call tracev (190+x,23+y,18+y);\r
+ call tracev (191+x,9+y,6+y); call tracev (191+x,25+y,20+y);\r
+ call tracev (192+x,8+y,5+y); call tracev (192+x,27+y,22+y);\r
+ call tracev (193+x,7+y,4+y); call tracev (193+x,29+y,24+y);\r
+ call tracev (194+x,7+y,4+y); call tracev (194+x,31+y,25+y);\r
+ call tracev (195+x,6+y,3+y); call tracev (195+x,33+y,27+y);\r
+ call tracev (196+x,5+y,2+y); call tracev (196+x,35+y,29+y);\r
+ call tracev (197+x,5+y,2+y); call tracev (197+x,37+y,31+y);\r
+ call tracev (198+x,4+y,1+y); call tracev (198+x,38+y,33+y);\r
+ call tracev (199+x,38+y,35+y); call tracev (200+x,38+y,37+y);\r
+ end dessinquick;\r
+\r
+ unit dessinbubble : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (4+x,39+y,3+y); call tracev (5+x,39+y,3+y);\r
+ call tracev (6+x,39+y,3+y); call tracev (7+x,39+y,3+y);\r
+ call tracev (8+x,39+y,3+y); call tracev (9+x,39+y,3+y);\r
+ call tracev (10+x,39+y,3+y); call tracev (11+x,39+y,3+y);\r
+ call tracev (12+x,39+y,3+y); call tracev (13+x,39+y,3+y);\r
+ call tracev (14+x,39+y,3+y); call tracev (15+x,39+y,3+y);\r
+ call tracev (16+x,39+y,3+y); call tracev (17+x,39+y,3+y);\r
+ call tracev (18+x,39+y,3+y); call tracev (19+x,39+y,3+y);\r
+ call tracev (20+x,39+y,3+y); call tracev (21+x,39+y,3+y);\r
+ call tracev (22+x,5+y,3+y); call tracev (22+x,39+y,37+y);\r
+ call tracev (23+x,5+y,3+y); call tracev (23+x,22+y,21+y);\r
+ call tracev (23+x,39+y,37+y); call tracev (24+x,5+y,3+y);\r
+ call tracev (24+x,23+y,19+y); call tracev (24+x,39+y,37+y);\r
+ call tracev (25+x,5+y,3+y); call tracev (25+x,23+y,19+y);\r
+ call tracev (25+x,39+y,37+y); call tracev (26+x,5+y,3+y);\r
+ call tracev (26+x,23+y,19+y); call tracev (26+x,39+y,37+y);\r
+ call tracev (27+x,6+y,3+y); call tracev (27+x,23+y,19+y);\r
+ call tracev (27+x,39+y,37+y); call tracev (28+x,6+y,3+y);\r
+ call tracev (28+x,23+y,20+y); call tracev (28+x,39+y,37+y);\r
+ call tracev (29+x,6+y,3+y); call tracev (29+x,23+y,20+y);\r
+ call tracev (29+x,39+y,37+y); call tracev (30+x,6+y,3+y);\r
+ call tracev (30+x,23+y,20+y); call tracev (30+x,39+y,36+y);\r
+ call tracev (31+x,6+y,4+y); call tracev (31+x,23+y,20+y);\r
+ call tracev (31+x,39+y,36+y); call tracev (32+x,6+y,4+y);\r
+ call tracev (32+x,23+y,20+y); call tracev (32+x,39+y,36+y);\r
+ call tracev (33+x,7+y,4+y); call tracev (33+x,23+y,19+y);\r
+ call tracev (33+x,38+y,36+y); call tracev (34+x,7+y,5+y);\r
+ call tracev (34+x,24+y,19+y); call tracev (34+x,38+y,35+y);\r
+ call tracev (35+x,8+y,5+y); call tracev (35+x,21+y,18+y);\r
+ call tracev (35+x,26+y,22+y); call tracev (35+x,38+y,35+y);\r
+ call tracev (36+x,10+y,6+y); call tracev (36+x,21+y,18+y);\r
+ call tracev (36+x,28+y,23+y); call tracev (36+x,37+y,34+y);\r
+ call tracev (37+x,12+y,6+y); call tracev (37+x,20+y,14+y);\r
+ call tracev (37+x,30+y,24+y); call tracev (37+x,37+y,32+y);\r
+ call tracev (38+x,20+y,7+y); call tracev (38+x,36+y,26+y);\r
+ call tracev (39+x,19+y,9+y); call tracev (39+x,34+y,28+y);\r
+ call tracev (42+x,29+y,3+y); call tracev (43+x,32+y,3+y);\r
+ call tracev (44+x,34+y,3+y); call tracev (45+x,35+y,3+y);\r
+ call tracev (46+x,36+y,3+y); call tracev (47+x,37+y,3+y);\r
+ call tracev (48+x,38+y,3+y); call tracev (49+x,39+y,3+y);\r
+ call tracev (50+x,39+y,3+y); call tracev (51+x,40+y,3+y);\r
+ call tracev (52+x,40+y,3+y); call tracev (53+x,40+y,3+y);\r
+ call tracev (54+x,40+y,3+y); call tracev (55+x,40+y,3+y);\r
+ call tracev (56+x,40+y,3+y); call tracev (57+x,40+y,3+y);\r
+ call tracev (58+x,40+y,3+y); call tracev (59+x,40+y,3+y);\r
+ call tracev (60+x,40+y,38+y); call tracev (61+x,40+y,38+y);\r
+ call tracev (62+x,40+y,38+y); call tracev (63+x,40+y,37+y);\r
+ call tracev (64+x,40+y,37+y); call tracev (65+x,40+y,37+y);\r
+ call tracev (66+x,39+y,37+y); call tracev (67+x,39+y,37+y);\r
+ call tracev (68+x,39+y,36+y); call tracev (69+x,38+y,36+y);\r
+ call tracev (70+x,38+y,35+y); call tracev (71+x,37+y,35+y);\r
+ call tracev (72+x,37+y,34+y); call tracev (73+x,36+y,33+y);\r
+ call tracev (74+x,35+y,32+y); call tracev (75+x,34+y,29+y);\r
+ call tracev (76+x,33+y,3+y); call tracev (77+x,32+y,3+y);\r
+ call tracev (79+x,39+y,3+y); call tracev (80+x,39+y,3+y);\r
+ call tracev (81+x,39+y,3+y); call tracev (82+x,39+y,3+y);\r
+ call tracev (83+x,39+y,3+y); call tracev (84+x,39+y,3+y);\r
+ call tracev (85+x,39+y,3+y); call tracev (86+x,39+y,3+y);\r
+ call tracev (87+x,39+y,3+y); call tracev (88+x,39+y,3+y);\r
+ call tracev (89+x,39+y,3+y); call tracev (90+x,39+y,3+y);\r
+ call tracev (91+x,39+y,3+y); call tracev (92+x,39+y,3+y);\r
+ call tracev (93+x,39+y,3+y); call tracev (94+x,39+y,3+y);\r
+ call tracev (95+x,39+y,3+y); call tracev (96+x,39+y,3+y);\r
+ call tracev (97+x,39+y,3+y); call tracev (98+x,5+y,3+y);\r
+ call tracev (98+x,39+y,37+y); call tracev (99+x,5+y,3+y);\r
+ call tracev (99+x,22+y,20+y); call tracev (99+x,39+y,37+y);\r
+ call tracev (100+x,5+y,3+y); call tracev (100+x,23+y,19+y);\r
+ call tracev (100+x,39+y,37+y); call tracev (101+x,5+y,3+y);\r
+ call tracev (101+x,23+y,19+y); call tracev (101+x,39+y,37+y);\r
+ call tracev (102+x,5+y,3+y); call tracev (102+x,23+y,19+y);\r
+ call tracev (102+x,39+y,37+y); call tracev (103+x,6+y,3+y);\r
+ call tracev (103+x,23+y,19+y); call tracev (103+x,39+y,37+y);\r
+ call tracev (104+x,6+y,3+y); call tracev (104+x,23+y,20+y);\r
+ call tracev (104+x,39+y,37+y); call tracev (105+x,6+y,3+y);\r
+ call tracev (105+x,23+y,20+y); call tracev (105+x,39+y,37+y);\r
+ call tracev (106+x,6+y,4+y); call tracev (106+x,23+y,20+y);\r
+ call tracev (106+x,39+y,36+y); call tracev (107+x,6+y,4+y);\r
+ call tracev (107+x,23+y,20+y); call tracev (107+x,39+y,36+y);\r
+ call tracev (108+x,7+y,4+y); call tracev (108+x,23+y,19+y);\r
+ call tracev (108+x,39+y,36+y); call tracev (109+x,7+y,5+y);\r
+ call tracev (109+x,24+y,19+y); call tracev (109+x,38+y,36+y);\r
+ call tracev (110+x,7+y,5+y); call tracev (110+x,24+y,18+y);\r
+ call tracev (110+x,38+y,35+y); call tracev (111+x,8+y,5+y);\r
+ call tracev (111+x,21+y,18+y); call tracev (111+x,26+y,23+y);\r
+ call tracev (111+x,37+y,35+y); call tracev (112+x,10+y,6+y);\r
+ call tracev (112+x,21+y,17+y); call tracev (112+x,28+y,23+y);\r
+ call tracev (112+x,37+y,33+y); call tracev (113+x,20+y,6+y);\r
+ call tracev (113+x,36+y,24+y); call tracev (114+x,19+y,7+y);\r
+ call tracev (114+x,35+y,26+y); call tracev (115+x,17+y,9+y);\r
+ call tracev (115+x,34+y,28+y); call tracev (117+x,39+y,3+y);\r
+ call tracev (118+x,39+y,3+y); call tracev (119+x,39+y,3+y);\r
+ call tracev (120+x,39+y,3+y); call tracev (121+x,39+y,3+y);\r
+ call tracev (122+x,39+y,3+y); call tracev (123+x,39+y,3+y);\r
+ call tracev (124+x,39+y,3+y); call tracev (125+x,39+y,3+y);\r
+ call tracev (126+x,39+y,3+y); call tracev (127+x,39+y,3+y);\r
+ call tracev (128+x,39+y,3+y); call tracev (129+x,39+y,3+y);\r
+ call tracev (130+x,39+y,3+y); call tracev (131+x,39+y,3+y);\r
+ call tracev (132+x,39+y,3+y); call tracev (133+x,39+y,3+y);\r
+ call tracev (134+x,39+y,3+y); call tracev (135+x,39+y,3+y);\r
+ call tracev (136+x,5+y,3+y); call tracev (136+x,39+y,37+y);\r
+ call tracev (137+x,5+y,3+y); call tracev (137+x,22+y,20+y);\r
+ call tracev (137+x,39+y,37+y); call tracev (138+x,5+y,3+y);\r
+ call tracev (138+x,23+y,19+y); call tracev (138+x,39+y,37+y);\r
+ call tracev (139+x,5+y,3+y); call tracev (139+x,23+y,19+y);\r
+ call tracev (139+x,39+y,37+y); call tracev (140+x,5+y,3+y);\r
+ call tracev (140+x,23+y,19+y); call tracev (140+x,39+y,37+y);\r
+ call tracev (141+x,6+y,3+y); call tracev (141+x,23+y,19+y);\r
+ call tracev (141+x,39+y,37+y); call tracev (142+x,6+y,3+y);\r
+ call tracev (142+x,23+y,20+y); call tracev (142+x,39+y,37+y);\r
+ call tracev (143+x,6+y,3+y); call tracev (143+x,23+y,20+y);\r
+ call tracev (143+x,39+y,37+y); call tracev (144+x,6+y,4+y);\r
+ call tracev (144+x,23+y,20+y); call tracev (144+x,39+y,36+y);\r
+ call tracev (145+x,6+y,4+y); call tracev (145+x,23+y,20+y);\r
+ call tracev (145+x,39+y,36+y); call tracev (146+x,7+y,4+y);\r
+ call tracev (146+x,23+y,19+y); call tracev (146+x,39+y,36+y);\r
+ call tracev (147+x,7+y,5+y); call tracev (147+x,24+y,19+y);\r
+ call tracev (147+x,38+y,36+y); call tracev (148+x,7+y,5+y);\r
+ call tracev (148+x,24+y,18+y); call tracev (148+x,38+y,35+y);\r
+ call tracev (149+x,8+y,5+y); call tracev (149+x,21+y,18+y);\r
+ call tracev (149+x,26+y,23+y); call tracev (149+x,37+y,35+y);\r
+ call tracev (150+x,10+y,6+y); call tracev (150+x,21+y,17+y);\r
+ call tracev (150+x,28+y,23+y); call tracev (150+x,37+y,33+y);\r
+ call tracev (151+x,20+y,6+y); call tracev (151+x,36+y,24+y);\r
+ call tracev (152+x,19+y,7+y); call tracev (152+x,35+y,26+y);\r
+ call tracev (153+x,17+y,9+y); call tracev (153+x,34+y,28+y);\r
+ call tracev (155+x,39+y,3+y); call tracev (156+x,39+y,3+y);\r
+ call tracev (157+x,39+y,3+y); call tracev (158+x,39+y,3+y);\r
+ call tracev (159+x,39+y,3+y); call tracev (160+x,39+y,3+y);\r
+ call tracev (161+x,39+y,3+y); call tracev (162+x,39+y,3+y);\r
+ call tracev (163+x,39+y,3+y); call tracev (164+x,39+y,3+y);\r
+ call tracev (165+x,39+y,3+y); call tracev (166+x,39+y,3+y);\r
+ call tracev (167+x,39+y,3+y); call tracev (168+x,39+y,3+y);\r
+ call tracev (169+x,39+y,3+y); call tracev (170+x,39+y,3+y);\r
+ call tracev (171+x,39+y,3+y); call tracev (172+x,39+y,3+y);\r
+ call tracev (173+x,39+y,3+y); call tracev (174+x,39+y,37+y);\r
+ call tracev (175+x,39+y,37+y); call tracev (176+x,39+y,37+y);\r
+ call tracev (177+x,39+y,37+y); call tracev (178+x,39+y,37+y);\r
+ call tracev (179+x,39+y,37+y); call tracev (180+x,39+y,37+y);\r
+ call tracev (181+x,39+y,37+y); call tracev (182+x,39+y,37+y);\r
+ call tracev (183+x,39+y,37+y); call tracev (184+x,39+y,37+y);\r
+ call tracev (185+x,39+y,37+y); call tracev (186+x,39+y,37+y);\r
+ call tracev (187+x,39+y,37+y); call tracev (188+x,39+y,37+y);\r
+ call tracev (190+x,39+y,3+y); call tracev (191+x,39+y,3+y);\r
+ call tracev (192+x,39+y,3+y); call tracev (193+x,39+y,3+y);\r
+ call tracev (194+x,39+y,3+y); call tracev (195+x,39+y,3+y);\r
+ call tracev (196+x,39+y,3+y); call tracev (197+x,39+y,3+y);\r
+ call tracev (198+x,39+y,3+y); call tracev (199+x,39+y,3+y);\r
+ call tracev (200+x,39+y,3+y); call tracev (201+x,39+y,3+y);\r
+ call tracev (202+x,39+y,3+y); call tracev (203+x,39+y,3+y);\r
+ call tracev (204+x,39+y,3+y); call tracev (205+x,39+y,3+y);\r
+ call tracev (206+x,39+y,3+y); call tracev (207+x,39+y,3+y);\r
+ call tracev (208+x,39+y,3+y); call tracev (209+x,5+y,3+y);\r
+ call tracev (209+x,16+y,13+y); call tracev (209+x,39+y,37+y);\r
+ call tracev (210+x,5+y,3+y); call tracev (210+x,16+y,13+y);\r
+ call tracev (210+x,39+y,37+y); call tracev (211+x,5+y,3+y);\r
+ call tracev (211+x,16+y,13+y); call tracev (211+x,39+y,37+y);\r
+ call tracev (212+x,5+y,3+y); call tracev (212+x,16+y,13+y);\r
+ call tracev (212+x,39+y,37+y); call tracev (213+x,5+y,3+y);\r
+ call tracev (213+x,16+y,13+y); call tracev (213+x,39+y,37+y);\r
+ call tracev (214+x,5+y,3+y); call tracev (214+x,16+y,13+y);\r
+ call tracev (214+x,39+y,37+y); call tracev (215+x,5+y,3+y);\r
+ call tracev (215+x,16+y,13+y); call tracev (215+x,39+y,37+y);\r
+ call tracev (216+x,5+y,3+y); call tracev (216+x,16+y,13+y);\r
+ call tracev (216+x,39+y,37+y); call tracev (217+x,5+y,3+y);\r
+ call tracev (217+x,16+y,13+y); call tracev (217+x,39+y,37+y);\r
+ call tracev (218+x,5+y,3+y); call tracev (218+x,16+y,13+y);\r
+ call tracev (218+x,39+y,37+y); call tracev (219+x,5+y,3+y);\r
+ call tracev (219+x,16+y,13+y); call tracev (219+x,39+y,37+y);\r
+ call tracev (220+x,5+y,3+y); call tracev (220+x,16+y,13+y);\r
+ call tracev (220+x,39+y,37+y); call tracev (221+x,5+y,3+y);\r
+ call tracev (221+x,16+y,13+y); call tracev (221+x,39+y,37+y);\r
+ call tracev (222+x,5+y,3+y); call tracev (222+x,16+y,13+y);\r
+ call tracev (222+x,39+y,37+y); call tracev (223+x,16+y,13+y);\r
+ call tracev (223+x,39+y,37+y); call tracev (224+x,16+y,13+y);\r
+ call tracev (224+x,39+y,37+y); call tracev (225+x,39+y,37+y);\r
+ end dessinbubble;\r
+\r
+ unit dessinsort : procedure (x,y,c : integer);\r
+ begin\r
+ call color (c);\r
+ call tracev (45+x,19+y,11+y); call tracev (45+x,35+y,33+y);\r
+ call tracev (46+x,21+y,9+y); call tracev (46+x,36+y,33+y);\r
+ call tracev (47+x,22+y,7+y); call tracev (47+x,37+y,33+y);\r
+ call tracev (48+x,23+y,6+y); call tracev (48+x,37+y,34+y);\r
+ call tracev (49+x,24+y,6+y); call tracev (49+x,38+y,35+y);\r
+ call tracev (50+x,25+y,5+y); call tracev (50+x,38+y,36+y);\r
+ call tracev (51+x,25+y,4+y); call tracev (51+x,39+y,36+y);\r
+ call tracev (52+x,26+y,3+y); call tracev (52+x,39+y,37+y);\r
+ call tracev (53+x,27+y,3+y); call tracev (53+x,39+y,37+y);\r
+ call tracev (54+x,27+y,3+y); call tracev (54+x,39+y,37+y);\r
+ call tracev (55+x,28+y,3+y); call tracev (55+x,40+y,37+y);\r
+ call tracev (56+x,29+y,3+y); call tracev (56+x,40+y,37+y);\r
+ call tracev (57+x,30+y,3+y); call tracev (57+x,40+y,37+y);\r
+ call tracev (58+x,30+y,2+y); call tracev (58+x,40+y,36+y);\r
+ call tracev (59+x,32+y,2+y); call tracev (59+x,40+y,34+y);\r
+ call tracev (60+x,40+y,2+y); call tracev (61+x,6+y,2+y);\r
+ call tracev (61+x,40+y,12+y); call tracev (62+x,6+y,2+y);\r
+ call tracev (62+x,39+y,13+y); call tracev (63+x,5+y,2+y);\r
+ call tracev (63+x,39+y,13+y); call tracev (64+x,5+y,2+y);\r
+ call tracev (64+x,39+y,14+y); call tracev (65+x,5+y,2+y);\r
+ call tracev (65+x,39+y,15+y); call tracev (66+x,5+y,3+y);\r
+ call tracev (66+x,39+y,15+y); call tracev (67+x,5+y,3+y);\r
+ call tracev (67+x,38+y,16+y); call tracev (68+x,5+y,3+y);\r
+ call tracev (68+x,38+y,17+y); call tracev (69+x,6+y,3+y);\r
+ call tracev (69+x,38+y,17+y); call tracev (70+x,7+y,4+y);\r
+ call tracev (70+x,37+y,18+y); call tracev (71+x,8+y,4+y);\r
+ call tracev (71+x,37+y,19+y); call tracev (72+x,9+y,5+y);\r
+ call tracev (72+x,36+y,21+y); call tracev (73+x,9+y,6+y);\r
+ call tracev (73+x,34+y,22+y); call tracev (74+x,9+y,8+y);\r
+ call tracev (74+x,31+y,23+y); call tracev (75+x,24+y,20+y);\r
+ call tracev (76+x,27+y,16+y); call tracev (77+x,30+y,12+y);\r
+ call tracev (78+x,32+y,10+y); call tracev (79+x,34+y,8+y);\r
+ call tracev (80+x,35+y,7+y); call tracev (81+x,36+y,6+y);\r
+ call tracev (82+x,36+y,6+y); call tracev (83+x,37+y,5+y);\r
+ call tracev (84+x,37+y,5+y); call tracev (85+x,38+y,4+y);\r
+ call tracev (86+x,38+y,4+y); call tracev (87+x,38+y,4+y);\r
+ call tracev (88+x,39+y,3+y); call tracev (89+x,39+y,3+y);\r
+ call tracev (90+x,39+y,3+y); call tracev (91+x,39+y,2+y);\r
+ call tracev (92+x,40+y,2+y); call tracev (93+x,40+y,2+y);\r
+ call tracev (94+x,5+y,2+y); call tracev (94+x,40+y,37+y);\r
+ call tracev (95+x,5+y,2+y); call tracev (95+x,40+y,37+y);\r
+ call tracev (96+x,5+y,2+y); call tracev (96+x,40+y,37+y);\r
+ call tracev (97+x,5+y,3+y); call tracev (97+x,39+y,37+y);\r
+ call tracev (98+x,5+y,3+y); call tracev (98+x,39+y,37+y);\r
+ call tracev (99+x,5+y,3+y); call tracev (99+x,39+y,37+y);\r
+ call tracev (100+x,6+y,3+y); call tracev (100+x,38+y,36+y);\r
+ call tracev (101+x,6+y,4+y); call tracev (101+x,38+y,36+y);\r
+ call tracev (102+x,7+y,4+y); call tracev (102+x,38+y,36+y);\r
+ call tracev (103+x,7+y,4+y); call tracev (103+x,38+y,35+y);\r
+ call tracev (104+x,8+y,5+y); call tracev (104+x,37+y,35+y);\r
+ call tracev (105+x,9+y,5+y); call tracev (105+x,37+y,34+y);\r
+ call tracev (106+x,10+y,6+y); call tracev (106+x,36+y,33+y);\r
+ call tracev (107+x,11+y,6+y); call tracev (107+x,35+y,31+y);\r
+ call tracev (108+x,12+y,7+y); call tracev (108+x,34+y,30+y);\r
+ call tracev (109+x,14+y,8+y); call tracev (109+x,32+y,28+y);\r
+ call tracev (110+x,16+y,10+y); call tracev (110+x,31+y,26+y);\r
+ call tracev (111+x,29+y,12+y); call tracev (112+x,27+y,16+y);\r
+ call tracev (114+x,39+y,2+y); call tracev (115+x,39+y,2+y);\r
+ call tracev (116+x,39+y,2+y); call tracev (117+x,39+y,2+y);\r
+ call tracev (118+x,39+y,2+y); call tracev (119+x,39+y,2+y);\r
+ call tracev (120+x,39+y,2+y); call tracev (121+x,39+y,2+y);\r
+ call tracev (122+x,39+y,2+y); call tracev (123+x,39+y,2+y);\r
+ call tracev (124+x,39+y,2+y); call tracev (125+x,39+y,2+y);\r
+ call tracev (126+x,39+y,2+y); call tracev (127+x,39+y,2+y);\r
+ call tracev (128+x,39+y,2+y); call tracev (129+x,39+y,2+y);\r
+ call tracev (130+x,39+y,2+y); call tracev (131+x,39+y,2+y);\r
+ call tracev (132+x,39+y,2+y); call tracev (133+x,5+y,2+y);\r
+ call tracev (133+x,31+y,27+y); call tracev (134+x,5+y,2+y);\r
+ call tracev (134+x,32+y,27+y); call tracev (135+x,5+y,3+y);\r
+ call tracev (135+x,29+y,27+y); call tracev (135+x,33+y,30+y);\r
+ call tracev (136+x,5+y,3+y); call tracev (136+x,30+y,27+y);\r
+ call tracev (136+x,34+y,31+y); call tracev (137+x,5+y,3+y);\r
+ call tracev (137+x,30+y,27+y); call tracev (137+x,34+y,32+y);\r
+ call tracev (138+x,6+y,3+y); call tracev (138+x,30+y,27+y);\r
+ call tracev (138+x,35+y,32+y); call tracev (139+x,6+y,3+y);\r
+ call tracev (139+x,29+y,27+y); call tracev (139+x,36+y,33+y);\r
+ call tracev (140+x,6+y,3+y); call tracev (140+x,29+y,27+y);\r
+ call tracev (140+x,36+y,34+y); call tracev (141+x,6+y,3+y);\r
+ call tracev (141+x,29+y,27+y); call tracev (141+x,37+y,35+y);\r
+ call tracev (142+x,6+y,4+y); call tracev (142+x,29+y,27+y);\r
+ call tracev (142+x,37+y,35+y); call tracev (143+x,7+y,4+y);\r
+ call tracev (143+x,29+y,26+y); call tracev (143+x,38+y,35+y);\r
+ call tracev (144+x,7+y,4+y); call tracev (144+x,28+y,25+y);\r
+ call tracev (144+x,38+y,35+y); call tracev (145+x,8+y,5+y);\r
+ call tracev (145+x,27+y,24+y); call tracev (145+x,38+y,36+y);\r
+ call tracev (146+x,5+y,2+y); call tracev (146+x,10+y,6+y);\r
+ call tracev (146+x,26+y,24+y); call tracev (146+x,38+y,36+y);\r
+ call tracev (147+x,5+y,2+y); call tracev (147+x,12+y,7+y);\r
+ call tracev (147+x,25+y,21+y); call tracev (147+x,39+y,37+y);\r
+ call tracev (148+x,5+y,2+y); call tracev (148+x,24+y,8+y);\r
+ call tracev (148+x,39+y,37+y); call tracev (149+x,5+y,2+y);\r
+ call tracev (149+x,23+y,10+y); call tracev (149+x,39+y,37+y);\r
+ call tracev (150+x,5+y,2+y); call tracev (150+x,21+y,12+y);\r
+ call tracev (150+x,39+y,37+y); call tracev (151+x,5+y,2+y);\r
+ call tracev (152+x,5+y,2+y); call tracev (153+x,5+y,2+y);\r
+ call tracev (154+x,5+y,2+y); call tracev (155+x,5+y,2+y);\r
+ call tracev (156+x,39+y,2+y); call tracev (157+x,39+y,2+y);\r
+ call tracev (158+x,39+y,2+y); call tracev (159+x,39+y,2+y);\r
+ call tracev (160+x,39+y,2+y); call tracev (161+x,39+y,2+y);\r
+ call tracev (162+x,39+y,2+y); call tracev (163+x,39+y,2+y);\r
+ call tracev (164+x,39+y,2+y); call tracev (165+x,39+y,2+y);\r
+ call tracev (166+x,39+y,2+y); call tracev (167+x,39+y,2+y);\r
+ call tracev (168+x,39+y,2+y); call tracev (169+x,39+y,2+y);\r
+ call tracev (170+x,39+y,2+y); call tracev (171+x,39+y,2+y);\r
+ call tracev (172+x,39+y,2+y); call tracev (173+x,39+y,2+y);\r
+ call tracev (174+x,39+y,2+y); call tracev (175+x,5+y,2+y);\r
+ call tracev (176+x,5+y,2+y); call tracev (177+x,5+y,2+y);\r
+ call tracev (178+x,5+y,2+y); call tracev (179+x,5+y,2+y);\r
+ call tracev (180+x,5+y,2+y); call tracev (181+x,5+y,2+y);\r
+ call tracev (182+x,5+y,2+y); call tracev (183+x,5+y,2+y);\r
+ call tracev (184+x,5+y,2+y);\r
+ end dessinsort;\r
+\r
+unit BOUTON : procedure(x,y,x2,y2,col_font,col1,col2:integer);\r
+var\r
+ i : integer;\r
+begin\r
+ call RECTANGLE_PLEIN (x+2,y+2,x2-2,y2-2,col_font,col_font);\r
+ for i:= 0 to 2 \r
+ do\r
+ call color (col1);\r
+ call move (x+i,y);\r
+ call draw (x+i,y2-i);\r
+ call move (x,y+i);\r
+ call draw (x2-i,y+i);\r
+ call color (col2);\r
+ call move (x2,y2-i);\r
+ call draw (x+i,y2-i);\r
+ call move (x2-i,y2);\r
+ call draw (x2-i,y+i);\r
+ od;\r
+ call color (7);\r
+ call RECTANGLE (x-1,y-1,x2+1,y2+1);\r
+ call color (7);\r
+ call move (x2,y2);\r
+ call draw (x2-2,y2-2);\r
+ call color (col2);\r
+ call move (x+3,y+3);\r
+ call draw (x2-3,y+3);\r
+ call move (x+3,y+3);\r
+ call draw (x+3,y2-3);\r
+ call color (col1);\r
+ call move (x2-3,y2-3);\r
+ call draw (x+4,y2-3);\r
+ call move (x2-3,y2-3);\r
+ call draw (x2-3,y+4);\r
+end BOUTON;\r
+\r
+UNIT RECTANGLE_PLEINV : procedure(x_h,y_h,x_b,y_b,\r
+ coul,contour:integer);\r
+var \r
+ i : integer ;\r
+\r
+BEGIN\r
+ call color (coul);\r
+ for i:= y_h to y_b \r
+ do\r
+ call move (x_h,i);\r
+ call hfill (x_b);\r
+ od;\r
+ call color (contour);\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+ END RECTANGLE_PLEINV;\r
+\r
+\r
+ unit aff_nb : procedure (x,y,nb,dec,c : integer);\r
+ var\r
+ i,k : integer\r
+ begin\r
+ k := 1;\r
+ call rectangle_plein (x-2,y-2,x+dec*8+9,y+8,0,15);\r
+ call color (c);\r
+ for i := 0 to dec do\r
+ call move (x+(dec-i)*8,y); \r
+ call hascii (48+ (nb div k) mod 10);\r
+ k := k*10;\r
+ od;\r
+ end aff_nb;\r
+ \r
+ unit CHARGE_FOND : procedure;\r
+ var\r
+ i,j,n : integer,\r
+ col : integer,\r
+ c : char;\r
+ begin\r
+ call color (15);\r
+ for i:=0 to 10 do\r
+ call move (0,i*32);\r
+ call hfill (639);\r
+ od;\r
+ for i:=0 to 15 do\r
+ call move (i*40,0);\r
+ call vfill (349);\r
+ od;\r
+\r
+ call color (8);\r
+ for i:=0 to 10 do\r
+ call move (0,i*32+29);\r
+ call hfill (639);\r
+ call move (0,i*32+30);\r
+ call hfill (639);\r
+ od;\r
+ for i:=0 to 15 do\r
+ call move (i*40+37,0);\r
+ call vfill (349);\r
+ call move (i*40+38,0);\r
+ call vfill (349);\r
+ od;\r
+ call color (7);\r
+ for i:=0 to 10 do\r
+ call move (0,i*32+31);\r
+ call hfill (639);\r
+ od;\r
+ for i:=0 to 15 do\r
+ call move (i*40+39,0);\r
+ call vfill (349);\r
+ od;\r
+ call color (15);\r
+ for i:=0 to 10 do\r
+ call move (0,i*32);\r
+ call hfill (639);\r
+ od;\r
+ for i:=0 to 15 do\r
+ call move (i*40,0);\r
+ call vfill (349);\r
+ od;\r
+ call RECTANGLE_PLEIN (70,80,570,300,1,1);\r
+ call RECTANGLE_PLEIN (105,301,581,309,8,8);\r
+ call RECTANGLE_PLEIN (570,105,581,301,8,8);\r
+ end CHARGE_FOND;\r
+\r
+unit AFF_OPTIONS : procedure;\r
+begin\r
+\r
+ (* definition des boutons *)\r
+ call BOUTON (150,100,190,125,7,15,8);\r
+ call BOUTON (150,155,190,180,7,15,8);\r
+ call BOUTON (150,210,190,235,7,15,8);\r
+ call BOUTON (150,265,190,290,7,15,8);\r
+ (* definition des barres de textes*)\r
+ call RECTANGLE_PLEIN (230,100,500,125,7,15);\r
+ call RECTANGLE_PLEIN (230,155,500,180,7,15);\r
+ call RECTANGLE_PLEIN (230,210,500,235,7,15);\r
+ call RECTANGLE_PLEIN (230,265,500,290,7,15);\r
+ (* texte *)\r
+ call pallet (7);\r
+ call color (15);\r
+ call move (249,110);\r
+ call outstring ("CHOIX DES ELEMENTS A TRIER");\r
+ call move (249,165);\r
+ call outstring ("GENERER DES NOUVELLES VALEURS");\r
+ call move (249,220);\r
+ call outstring ("TRI DES ELEMENTS ");\r
+ call move (249,275);\r
+ call outstring ("QUITTER LE PROGRAMME");\r
+ call color (8);\r
+ call move (251,111);\r
+ call outstring ("CHOIX DES ELEMENTS A TRIER");\r
+ call move (251,166);\r
+ call outstring ("GENERER DES NOUVELLES VALEURS");\r
+ call move (251,221);\r
+ call outstring ("TRI DES ELEMENTS ");\r
+ call move (251,276);\r
+ call outstring ("QUITTER LE PROGRAMME");\r
+end AFF_OPTIONS;\r
+\r
+unit DELAI : procedure ( n : integer);\r
+var\r
+ i : integer;\r
+begin\r
+ for i := 1 to n do od;\r
+end DELAI;\r
+\r
+unit CHOIX_UTIL : procedure ;\r
+begin\r
+\r
+ pref STR_ELEMENTS block\r
+var\r
+ x,y,p,choix_courant,nbelems : integer,\r
+ gauche,droit,centre : boolean;\r
+ BEGIN\r
+ call dessinmenu (250,10,8);\r
+ call dessinmenu (247,7,4);\r
+\r
+ call AFF_OPTIONS;\r
+ choix_courant := 1;\r
+ nbelems := 100;\r
+ do\r
+\r
+ call showcursor;\r
+ call setwindow (70,570,80,300);\r
+\r
+ call getpress (0,x,y,p,gauche,droit,centre);\r
+ if (gauche) then\r
+ call hidecursor;\r
+ if (x>150 and x<190) then\r
+ if (y>100 and y<125) then\r
+ call BOUTON (150,100,190,125,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,100,190,125,7,15,8);\r
+ call CHOIX_ELEM(choix_courant,nbelems);\r
+ call AFF_OPTIONS;\r
+ call eff_titre;\r
+ call dessinmenu (250,10,8);\r
+ call dessinmenu (247,7,4);\r
+ fi;\r
+ if (y>155 and y<180) then\r
+ call BOUTON (150,155,190,180,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,155,190,180,7,15,8);\r
+ call CHOIX_NB_ELEM(nbelems,choix_courant);\r
+ call AFF_OPTIONS;\r
+ call eff_titre;\r
+ call dessinmenu (250,10,8);\r
+ call dessinmenu (247,7,4);\r
+ fi;\r
+ if (y>210 and y<235) then\r
+ call BOUTON (150,210,190,235,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,210,190,235,7,15,8);\r
+ call AFF_TRI(choix_courant,nbelems);\r
+ call CHARGE_FOND;\r
+ call AFF_OPTIONS;\r
+ call eff_titre;\r
+ call dessinmenu (250,10,8);\r
+ call dessinmenu (247,7,4);\r
+ fi;\r
+ if (y>265 and y<290) then\r
+ call BOUTON (150,265,190,290,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,265,190,290,7,15,8);\r
+ exit ;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ end;\r
+end CHOIX_UTIL;\r
+\r
+unit AFF_CONTOUR_CHOIX : procedure (choix_courant,coul : integer);\r
+begin\r
+ call color (coul);\r
+ case choix_courant \r
+ when 1: call RECTANGLE (229,89,501,146);\r
+ call RECTANGLE (228,88,502,147);\r
+ call RECTANGLE (227,87,503,148);\r
+ when 2: call RECTANGLE (229,159,501,216);\r
+ call RECTANGLE (228,158,502,217);\r
+ call RECTANGLE (227,157,503,218);\r
+ when 3: call RECTANGLE (229,229,501,286);\r
+ call RECTANGLE (228,228,502,287);\r
+ call RECTANGLE (227,227,503,288);\r
+ esac;\r
+end AFF_CONTOUR_CHOIX;\r
+\r
+unit GRAPH_ELEM : procedure ;\r
+begin\r
+ (* histogrammes *)\r
+ call BOUTON (150,105,190,130,7,15,8);\r
+ call RECTANGLE_PLEIN (230,90,500,132,7,8);\r
+ call RECTANGLE_PLEIN (250,100,270,130,4,4);\r
+ call RECTANGLE_PLEIN (280,120,300,130,2,2);\r
+ call RECTANGLE_PLEIN (310,110,330,130,13,13);\r
+ call RECTANGLE_PLEIN (340,95,360,130,9,9);\r
+ call RECTANGLE_PLEIN (370,105,390,130,1,1);\r
+ call RECTANGLE_PLEIN (400,108,420,130,12,12);\r
+ call RECTANGLE_PLEIN (430,115,450,130,10,10);\r
+ call RECTANGLE_PLEIN (460,100,480,130,11,11);\r
+ call RECTANGLE_PLEIN (230,132,500,145,7,8);\r
+ call color (15);\r
+ call move (270,136);\r
+ call outstring ("H I S T O G R A M M E S");\r
+ call color (8);\r
+ call move (271,137);\r
+ call outstring ("H I S T O G R A M M E S");\r
+ (* polynomes *)\r
+ call BOUTON (150,175,190,200,7,15,8);\r
+ call RECTANGLE_PLEIN (230,160,500,202,7,8);\r
+ call RECTANGLE_PLEIN (230,202,500,215,7,8);\r
+ call color (1);\r
+ call move (240,170);\r
+ call outstring ("X^2+3");\r
+ call color (4);\r
+ call move (270,185);\r
+ call outstring ("-4X^5+5X^4-2X^3+6");\r
+ call color (2);\r
+ call move (300,165);\r
+ call outstring ("6X+5");\r
+ call color (11);\r
+ call move (405,175);\r
+ call outstring ("-X^2+2X-3");\r
+ call color (15);\r
+ call move (295,206);\r
+ call outstring ("P O L Y N O M E S");\r
+ call color (8);\r
+ call move (296,207);\r
+ call outstring ("P O L Y N O M E S");\r
+ (* rectangles *)\r
+ call RECTANGLE_PLEIN (230,230,500,272,7,8);\r
+ call BOUTON (150,245,190,270,7,15,8);\r
+ call RECTANGLE_PLEIN (250,235,290,267,13,13);\r
+ call RECTANGLE_PLEIN (300,255,330,270,12,12);\r
+ call RECTANGLE_PLEIN (340,240,400,272,10,10);\r
+ call RECTANGLE_PLEIN (410,232,430,265,9,9);\r
+ call RECTANGLE_PLEIN (440,243,480,260,4,4);\r
+ call RECTANGLE_PLEIN (230,272,500,285,7,8);\r
+ call color (15);\r
+ call move (305,276);\r
+ call outstring ("S U R F A C E S");\r
+ call color (8);\r
+ call move (306,277);\r
+ call outstring ("S U R F A C E S");\r
+end GRAPH_ELEM;\r
+\r
+unit CHOIX_ELEM : procedure(inout choix_courant,nbelems : integer);\r
+var\r
+x,y,p : integer,\r
+choix : char,\r
+gauche,droit,centre : boolean;\r
+begin \r
+ call EFFACE (70,80,570,300,9,1,15);\r
+ call eff_titre;\r
+ call dessinelem (206,20,8);\r
+ call dessinelem (203,17,4);\r
+ call GRAPH_ELEM;\r
+ call AFF_CONTOUR_CHOIX(choix_courant,15);\r
+ call BOUTON (80,175,130,200,7,15,8);\r
+ call move (92,185);\r
+ call color (4);\r
+ call outstring ("O K");\r
+ call showcursor;\r
+ do\r
+ call getpress (0,x,y,p,gauche,droit,centre);\r
+ if (gauche) then\r
+ call hidecursor;\r
+ if ( x >150 and x <190 and y>105 and y<130) then\r
+ call BOUTON (150,105,190,130,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,105,190,130,7,15,8);\r
+ call AFF_CONTOUR_CHOIX(1,15);\r
+ call AFF_CONTOUR_CHOIX(2,1);\r
+ call AFF_CONTOUR_CHOIX(3,1);\r
+ choix_courant := 1;\r
+ nbelems := 100;\r
+ \r
+ fi;\r
+ if ( x >150 and x <190 and y>175 and y<200) then\r
+ call BOUTON (150,175,190,200,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,175,190,200,7,15,8);\r
+ call AFF_CONTOUR_CHOIX(2,15);\r
+ call AFF_CONTOUR_CHOIX(1,1);\r
+ call AFF_CONTOUR_CHOIX(3,1);\r
+ choix_courant := 2;\r
+ nbelems := 10;\r
+ fi;\r
+ if ( x >150 and x <190 and y>245 and y<270) then\r
+ call BOUTON (150,245,190,270,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (150,245,190,270,7,15,8);\r
+ call AFF_CONTOUR_CHOIX(1,1);\r
+ call AFF_CONTOUR_CHOIX(2,1);\r
+ call AFF_CONTOUR_CHOIX(3,15);\r
+ choix_courant := 3;\r
+ nbelems := 25;\r
+ fi;\r
+ if (x>80 and x<130 and y>130 and y<200) then\r
+ call BOUTON (80,175,130,200,7,8,15);\r
+ call move (92,185);\r
+ call color (8);\r
+ call outstring ("O K");\r
+ call DELAI (2000); \r
+ call BOUTON (80,175,130,200,7,15,8);\r
+ call EFFACE(70,80,570,300,9,1,15);\r
+ exit;\r
+ fi;\r
+ call showcursor ; \r
+ fi;\r
+ od;\r
+end CHOIX_ELEM;\r
+\r
+unit AFF_C : procedure (coul,nb_bouton : integer);\r
+\r
+begin\r
+call color (coul);\r
+ case nb_bouton\r
+ when 1 : \r
+ call RECTANGLE (199,159,241,186);\r
+ call RECTANGLE (198,158,242,187);\r
+ call RECTANGLE (197,157,243,188);\r
+ when 2 : \r
+ call RECTANGLE (299,159,341,186);\r
+ call RECTANGLE (298,158,342,187);\r
+ call RECTANGLE (297,157,343,188);\r
+ when 3 :\r
+ call RECTANGLE (399,159,441,186);\r
+ call RECTANGLE (398,158,442,187);\r
+ call RECTANGLE (397,157,443,188);\r
+ esac;\r
+end AFF_C;\r
+\r
+unit GERE_CHOIX_NB : procedure (choix_courant :integer\r
+ ;inout nbelems : integer);\r
+var\r
+ x,y,p : integer,\r
+ gauche,droit,centre : boolean;\r
+begin\r
+ call showcursor;\r
+ call setwindow (70,570,80,300);\r
+ do\r
+ call getpress (0,x,y,p,gauche,droit,centre);\r
+ if (gauche) then\r
+ call hidecursor;\r
+ if ( x >200 and x <240 and y>200 and y<225) then\r
+ call BOUTON (200,200,240,225,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (200,200,240,225,7,15,8);\r
+ case choix_courant\r
+ when 1 : nbelems := 30;\r
+ when 2 : nbelems := 5;\r
+ when 3 : nbelems := 15;\r
+ esac;\r
+ call AFF_C(15,1);\r
+ call AFF_C(1,2);\r
+ call AFF_C(1,3);\r
+ fi;\r
+ if ( x >300 and x <340 and y>200 and y<225) then\r
+ call BOUTON (300,200,340,225,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (300,200,340,225,7,15,8);\r
+ case choix_courant \r
+ when 1 : nbelems := 100;\r
+ when 2 : nbelems := 10;\r
+ when 3 : nbelems := 25;\r
+ esac;\r
+ call AFF_C(1,1);\r
+ call AFF_C(15,2);\r
+ call AFF_C(1,3);\r
+ fi;\r
+ if ( x >400 and x <440 and y>200 and y<225) then\r
+ call BOUTON (400,200,440,225,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (400,200,440,225,7,15,8);\r
+ case choix_courant\r
+ when 1 : nbelems := 150 ;\r
+ when 2 : nbelems := 20;\r
+ when 3 : nbelems := 50;\r
+ esac;\r
+ call AFF_C(1,1);\r
+ call AFF_C(1,2);\r
+ call AFF_C(15,3);\r
+ fi;\r
+ if ( x >265 and x <365 and y>250 and y<280) then\r
+ call BOUTON (265,250,365,280,7,8,15);\r
+ call DELAI (2000);\r
+ call BOUTON (265,250,365,280,7,15,8);\r
+ exit ;\r
+ fi;\r
+ call showcursor;\r
+ call setwindow (70,570,80,300);\r
+ fi;\r
+ od;\r
+end GERE_CHOIX_NB;\r
+\r
+unit CHOIX_NB_ELEM : procedure (inout nbelems :integer;\r
+ choix_courant : integer);\r
+var\r
+coul,nbbouton : integer,\r
+choix : char ;\r
+begin\r
+ call EFFACE (70,80,570,300,9,1,15);\r
+ call eff_titre;\r
+ call dessinrand (206,20,8);\r
+ call dessinrand (203,17,4); \r
+ call RECTANGLE_PLEIN(150,100,490,150,7,15);\r
+ call RECTANGLE_PLEIN (200,160,240,185,7,15);\r
+ call BOUTON (200,200,240,225,7,15,8);\r
+ call RECTANGLE_PLEIN (300,160,340,185,7,15);\r
+ call BOUTON (300,200,340,225,7,15,8);\r
+ call RECTANGLE_PLEIN (400,160,440,185,7,15);\r
+ call BOUTON (400,200,440,225,7,15,8);\r
+ call BOUTON (265,250,365,280,7,15,8);\r
+ call color (4);\r
+ case choix_courant \r
+ when 1 : \r
+ call move (250,120);\r
+ call outstring ("H I S T O G R A M M E S");\r
+ call move (209,167);\r
+ call outstring ("30");\r
+ call move (309,167);\r
+ call outstring ("100");\r
+ call move (405,167);\r
+ call outstring ("150");\r
+ when 2 : \r
+ call move (250,120);\r
+ call outstring (" P O L Y N O M E S");\r
+ call move (209,167);\r
+ call outstring ("5");\r
+ call move (309,167);\r
+ call outstring ("10");\r
+ call move (405,167);\r
+ call outstring ("20");\r
+ when 3 : \r
+ call move (255,120);\r
+ call outstring ("S U R F A C E S");\r
+ call move (209,167);\r
+ call outstring ("15");\r
+ call move (309,167);\r
+ call outstring ("25");\r
+ call move (405,167);\r
+ call outstring ("50");\r
+ esac;\r
+ coul := 15;\r
+ if (nbelems=30 or nbelems =5 or nbelems =15) then\r
+ call AFF_C(15,1);\r
+ else\r
+ if (nbelems = 100 or nbelems = 10 or nbelems = 25) then\r
+ call AFF_C(15,2);\r
+ else\r
+ call AFF_C(15,3);\r
+ fi;\r
+ fi;\r
+ call GERE_CHOIX_NB (choix_courant,nbelems);\r
+ call EFFACE (70,80,570,300,9,1,15);\r
+end CHOIX_NB_ELEM;\r
+\r
+unit AFF_RENS : procedure ;\r
+begin\r
+ call color (15);\r
+ call move (0,174);\r
+ call draw (639,174);\r
+ call move (0,110);\r
+ call draw (639,110);\r
+ call move (0,285);\r
+ call draw (639,285);\r
+ call move (0,284);\r
+ call draw (639,284);\r
+ call dessinquick (-23+3,123+3,8);\r
+ call dessinsort (220+3,123+3,8);\r
+ call dessinquick (-23,123,9);\r
+ call dessinsort (220,123,9);\r
+ call dessinbubble (0+3,300+3,8);\r
+ call dessinsort (220+3,300+3,8);\r
+ call dessinbubble (0,300,14);\r
+ call dessinsort (220,300,14);\r
+ call RECTANGLE_PLEIN (415,115,520,130,7,15);\r
+ call RECTANGLE_PLEIN (415,135,520,150,7,15);\r
+ call color (4);\r
+ call move (420,120);\r
+ call outstring ("PERMUTATIONS");\r
+ call move (420,140);\r
+ call outstring ("COMPARAISONS");\r
+ call move (420,160);\r
+ call color (4);\r
+ call outstring ("en cours ...");\r
+ call RECTANGLE_PLEIN (415,290,520,305,7,15);\r
+ call RECTANGLE_PLEIN (415,310,520,325,7,15);\r
+ call color (4);\r
+ call move (420,295);\r
+ call outstring ("PERMUTATIONS");\r
+ call move (420,315);\r
+ call outstring ("COMPARAISONS");\r
+ call move (420,335);\r
+ call color (4);\r
+ call outstring ("en attente ");\r
+end AFF_RENS;\r
+\r
+unit AFF_RENS_FIN : procedure;\r
+begin\r
+ call RECTANGLE_PLEIN (415,155,520,170,7,7);\r
+ call RECTANGLE_PLEIN (415,330,520,345,7,7);\r
+ call color (4);\r
+ call move (420,160);\r
+ call outstring ("tri fini.");\r
+ call move (420,335);\r
+ call outstring ("en cours ...");\r
+end AFF_RENS_FIN;\r
+\r
+unit AFF_RENS_FIN2 : procedure;\r
+begin\r
+ call RECTANGLE_PLEIN (415,330,520,345,7,7);\r
+ call color (4);\r
+ call move (420,335);\r
+ call outstring ("tri fini.");\r
+end AFF_RENS_FIN2;\r
+\r
+unit STATS: procedure(nb_iterationsq,nb_iterationsb,nbelems:integer);\r
+var\r
+ trouve : boolean,\r
+ chaine1,chaine2 : string,\r
+ choix : char,\r
+ i,x1,x2,x3,x4,itermax,ind_perfb,\r
+ calcule_cmq,calcule_cmb,cout_maxb,cout_maxq,\r
+ ind_perfq,marque : integer,\r
+ sauve_valq,sauve_valb ,\r
+ pas_q,pas_b,facteur : real;\r
+begin\r
+ trouve := true;\r
+ call pallet(0);\r
+ call RECTANGLE_PLEIN(0,0,639,349,0,15);\r
+ call dessinstat(235+3,10+3,8);\r
+ call dessinstat(235,10,9);\r
+ call move (115,90); \r
+ call color (8);\r
+ call outstring ("INDICE DE RAPIDITE (calcul\82 sur la base des comparaisons)");\r
+ call move (114,89);\r
+ call color (15);\r
+ call outstring ("INDICE DE RAPIDITE (calcul\82 sur la base des comparaisons)");\r
+ call move (5,107);\r
+ call color (9);\r
+ call outstring ("QUICK SORT");\r
+ call move (5,157);\r
+ call outstring ("BUBBLE SORT");\r
+ call RECTANGLE_PLEIN(99,100,551,130,8,15);\r
+ call RECTANGLE_PLEIN(99,150,551,180,8,15);\r
+ call aff_nb (570,115,nb_iterationsq,4,15); \r
+ call aff_nb (570,165,nb_iterationsb,4,15); \r
+ facteur := nb_iterationsq / 100;\r
+ pas_q := facteur * 450 / nb_iterationsq ;\r
+ pas_b := facteur * 450 / nb_iterationsb ;\r
+ call color (4);\r
+ if nb_iterationsq>nb_iterationsb then itermax := nb_iterationsq;\r
+ else itermax := nb_iterationsb;\r
+ fi;\r
+ itermax := entier (itermax / facteur);\r
+ for i := 0 to itermax\r
+ do\r
+ x1 := entier(i*pas_q);\r
+ x2 := entier(i*pas_b);\r
+ x3 := entier ((i+1)*pas_q);\r
+ x4 := entier ((i+1)*pas_b);\r
+ sauve_valq := 100 + x1 ;\r
+ sauve_valb := 100 + x2 ;\r
+ if (x3 <= 450) then\r
+ call RECTANGLE_PLEIN(sauve_valq,101,100+x3,129,4,4);\r
+ else\r
+ if trouve then\r
+ call color (15);\r
+ trouve := false;\r
+ call move (sauve_valb,140);\r
+ call outstring ("³");\r
+ fi;\r
+ fi;\r
+ if (x4 <= 450) then\r
+ call RECTANGLE_PLEIN(sauve_valb,151,100+x4,179,4,4);\r
+ fi;\r
+ od;\r
+ cout_maxb := entier((nbelems*(nbelems-1)) / 2);\r
+ cout_maxq := entier((((nbelems+1)*(nbelems+2)/2)-3));\r
+ ind_perfb := 100 - ((nb_iterationsb*100)/cout_maxb);\r
+ ind_perfq := 100 -((nb_iterationsq*100)/cout_maxq);\r
+ chaine1 := "QUICK SORT";\r
+ chaine2 := "BUBBLE SORT";\r
+ call move (180,190);\r
+ call color (8);\r
+ call outstring ("W I N N E R :");\r
+ call move (178,188);\r
+ call color (14);\r
+ call outstring ("W I N N E R :");\r
+\r
+ call color (9);\r
+ if (nb_iterationsq < nb_iterationsb) then\r
+ call move (290,190);\r
+ call outstring(chaine1);\r
+ else\r
+ call move (290,190);\r
+ call outstring (chaine2);\r
+ fi;\r
+ call RECTANGLE_PLEIN (20,210,620,330,0,15);\r
+ call color (15);\r
+ call move (20,250);\r
+ call draw (620,250);\r
+ call move (20,290);\r
+ call draw (620,290);\r
+ call move (140,210);\r
+ call draw (140,330);\r
+ call move (260,210);\r
+ call draw (260,330);\r
+ call move (380,210);\r
+ call draw (380,330);\r
+ call move (500,210);\r
+ call draw (500,330);\r
+ call move (40,220);\r
+ call color (2);\r
+ call outstring ("METHODES");\r
+ call move (152,220);\r
+ call outstring ("NB ELEMENTS");\r
+ call move (280,220);\r
+ call outstring ("COUT MOYEN");\r
+ call move (390,220);\r
+ call outstring ("COUT MAXIMUM");\r
+ call move (510,220);\r
+ call outstring ("PERFORMANCE");\r
+ call move (522,230);\r
+ call outstring ("en %");\r
+ call aff_nb(160,260,nbelems,3,15);\r
+ call aff_nb(160,300,nbelems,3,15);\r
+ calcule_cmb := entier((nbelems*(nbelems-1)) / 2);\r
+ calcule_cmq := entier(2*(ln (nbelems) / ln (10))*nbelems);\r
+ call aff_nb(550,300,ind_perfb,2,15);\r
+ call aff_nb(550,260,ind_perfq,2,15);\r
+ call aff_nb(290,300,calcule_cmb,4,15);\r
+ call aff_nb(290,260,calcule_cmq,3,15);\r
+ call aff_nb(410,260,cout_maxq,3,15);\r
+ call aff_nb(410,300,calcule_cmb,4,15);\r
+ call color (2);\r
+ call move (35,260);\r
+ call outstring ("QUICK SORT");\r
+ call move (35,300);\r
+ call outstring ("BUBBLE SORT");\r
+ read (choix);\r
+ call EFFACE (0,0,639,349,9,7,15);\r
+end;\r
+\r
+unit AFF_TRI : procedure(choix_courant,nbelems: integer);\r
+begin\r
+pref STR_ELEMENTS block\r
+var \r
+ CONTINUE : boolean,\r
+ choix : char,\r
+ TAB1,TAB2 : STR_ELEMENTS,\r
+ i,rand,det_coul,essai,\r
+ nb_perm,nb_iterationsq,nb_iterationsb : integer;\r
+begin\r
+ nb_perm := 0;\r
+ nb_iterationsq := 0;\r
+ nb_iterationsb := 0;\r
+ CONTINUE := false;\r
+ call EFFACE (0,0,639,349,9,7,15);\r
+ case choix_courant\r
+ when 1:\r
+ TAB1 := new HISTOGRAMMES (nbelems);\r
+ TAB2 := new HISTOGRAMMES (nbelems);\r
+ when 2:\r
+ TAB1 := new POLY (nbelems);\r
+ TAB2 := new POLY (nbelems);\r
+ when 3 :\r
+ TAB1 := new SURFACES (nbelems);\r
+ TAB2 := new SURFACES (nbelems);\r
+ esac;\r
+ call AFF_RENS;\r
+ call TAB1.randomize;\r
+ call TAB2.copie(TAB1);\r
+ for i := 0 to nbelems-1\r
+ do\r
+ call TAB1.trace (i,105);\r
+ call TAB2.trace (i,280);\r
+ od;\r
+ \r
+ call QUICK_SORT (0,nbelems-1,TAB1,nb_perm,nb_iterationsq);\r
+ call AFF_RENS_FIN;\r
+ nb_perm := 0;\r
+ call TAB1.killtab;\r
+ kill (TAB1);\r
+ call bubble_sort(nbelems-1,TAB2,nb_perm,nb_iterationsb);\r
+ call AFF_RENS_FIN2;\r
+ call TAB2.killtab;\r
+ kill (TAB2);\r
+ read (choix);\r
+ CONTINUE:=BOX_MESSAGE("Voulez-vous les statistiques des tris ?",\r
+ 150,75,500,200);\r
+ if ( CONTINUE) then \r
+ call EFFACE (0,0,639,349,9,7,15);\r
+ call STATS(nb_iterationsq,nb_iterationsb,nbelems);\r
+ else\r
+ call EFFACE (0,0,639,349,9,7,15);\r
+ exit;\r
+ fi;\r
+ end;\r
+end AFF_TRI;\r
+unit SWAP : procedure (indice1 , indice2 : integer ; \r
+ inout T2 : STR_ELEMENTS;inout nb_perm : integer);\r
+begin\r
+\r
+pref STR_ELEMENTS block\r
+var\r
+temp1,temp2,coul1,coul2,hauteur1,hauteur2 : integer;\r
+\r
+ begin\r
+ nb_perm := nb_perm + 1;\r
+ call aff_nb (560,120,nb_perm,4,1);\r
+ call T2.echange (indice1,indice2,105);\r
+end;\r
+end SWAP;\r
+\r
+\r
+unit QUICK_SORT : procedure (gauche,droite : integer ; inout T : STR_ELEMENTS;\r
+ inout nb_perm,nb_iterations :integer);\r
+\r
+begin\r
+pref STR_ELEMENTS block\r
+var\r
+ moy,ibas,ihaut : integer ;\r
+begin\r
+ (* initialisation des indices bas et haut *)\r
+ ibas := gauche; \r
+ ihaut := droite;\r
+ (* choix d'une valeur mediane *) \r
+ moy := (gauche + droite) div 2;\r
+ (* echange pour que valeurs gauches <= pivot <= valeurs droites *)\r
+ do\r
+ (* recherche de la premiere valeur de gauche mal placee *)\r
+ while (T.compare (ibas,moy)=-1)\r
+ do\r
+ ibas := ibas + 1;\r
+ nb_iterations := nb_iterations + 1;\r
+ od;\r
+ (* recherche de la premiere valeur de droite mal placee *)\r
+ while (T.compare (moy,ihaut)=-1)\r
+ do\r
+ ihaut := ihaut - 1;\r
+ nb_iterations := nb_iterations + 1;\r
+ od;\r
+ call aff_nb(560,140,nb_iterations,4,1);\r
+ (* echange eventuel de 2 valeurs mal classees *)\r
+ if ibas <= ihaut then\r
+ call SWAP (ibas,ihaut,T,nb_perm);\r
+ if ibas = moy then\r
+ moy := ihaut;\r
+ else if ihaut = moy then\r
+ moy := ibas;\r
+ fi;\r
+ fi;\r
+ ibas := ibas + 1;\r
+ ihaut := ihaut - 1;\r
+ fi;\r
+ if ibas > ihaut then exit;\r
+ fi;\r
+ od;\r
+ (* recursion si les sous-intervalles ne sont pas d\82j\85 tri\82s *)\r
+ if ihaut > gauche then\r
+ call QUICK_SORT (gauche,ihaut,T,nb_perm,nb_iterations);\r
+ fi;\r
+ if ibas < droite then\r
+ call QUICK_SORT (ibas,droite,T,nb_perm,nb_iterations);\r
+ fi;\r
+\r
+end;\r
+end QUICK_SORT;\r
+\r
+unit bubble_sort : procedure (n : integer;inout T : STR_ELEMENTS;\r
+ inout nb_perm,nb_iterations : integer);\r
+var\r
+ i,j : integer,\r
+ triok : boolean;\r
+ begin\r
+ i:=n;\r
+ (* tant que le tableau n'est pas enti\8arement tri\82 *)\r
+ while (i>=0) and not triok\r
+ do\r
+ triok := true;\r
+ (* tri du sous-tableau *)\r
+ for j := 0 to i-1 \r
+ do\r
+ nb_iterations := nb_iterations + 1;\r
+ call aff_nb (560,315,nb_iterations,4,1);\r
+ (* ordonner 2 \82l\82ments *)\r
+ if T.compare(j,j+1) = 1 then\r
+ nb_perm := nb_perm + 1;\r
+ call aff_nb (560,295,nb_perm,4,1);\r
+ call T.echange(j,j+1,280);\r
+ triok := false;\r
+ fi;\r
+ od;\r
+ i := i-1;\r
+ od;\r
+ end bubble_sort;\r
+\r
+begin\r
+ pref STR_ELEMENTS block\r
+(********************************************************************)\r
+(* PROGRAMME PRINCIPAL *)\r
+(********************************************************************)\r
+\r
+begin\r
+ call gron(NOCARD); (* installation du pilote graphique *)\r
+ call rectangle_plein (0,0,639,349,7,7);\r
+ call pallet (7);\r
+ call CHARGE_FOND;\r
+ call CHOIX_UTIL ;\r
+ call EFFACE (0,0,639,349,9,7,15);\r
+ call groff;\r
+end;\r
+end;\r
+end;\r
+end;\r
+end TRI;\r
--- /dev/null
+egahint /m 95000 sort\r
+rem dopilnuj by mem /c pokazal > 600 kB wolnych\r
+ \r
+rem TRZEBA ten program przerobic na 486 Loglan!!
\ No newline at end of file
--- /dev/null
+Program AVL;\r
+(*******************************************************************)\r
+(*******************************************************************)\r
+(** **)\r
+(** IMPLEMENTATION DE QUEUE DE PRIORITE **)\r
+(** REALISATION AVEC ARBRES A.V.L. **)\r
+(** **)\r
+(*******************************************************************)\r
+(************** PROJET 1 DE LI1 **********************)\r
+(*******************************************************************)\r
+(** Annee 1993-1994 REALISE PAR UPPA **)\r
+(** GOUGEON Jean-Yves et RICHARD Jerome **)\r
+(*******************************************************************)\r
+(*******************************************************************)\r
+ \r
+ \r
+(*************** DEBUT DU PROGRAMME **********************)\r
+ \r
+(****************** UNIT ************************)\r
+ \r
+(****************************************************************************************************)\r
+(********** LISTE DES UNITs ***********)\r
+(****************************************************************************************************)\r
+(********** presentation : page d'acuei ***********)\r
+(********** init_graph : contient menu et gestion souris ***********)\r
+(********** aide : page d'aide du programme ***********)\r
+(********** mousepos : recherche position de souris ***********)\r
+(********** message : regroupement des messages ***********)\r
+(********** erreur : regroupement des messages d'erreurs ***********)\r
+(********** efface : efface une partie de l'\82cran concernant les messages ***********)\r
+(********** ecrit : ecrit le nombre lu au clavier ***********)\r
+(********** AVL : d\82claration de la classe AVL pour initialisation des arbres ***********)\r
+(********** PAUSE : pour cr\82er une pause \82cran ***********)\r
+(********** RG : rotation gauche ***********)\r
+(********** RGD : rotation gauche droite ***********)\r
+(********** INSERT : insertion dans un arbre ***********)\r
+(********** EQUILIBRE : pour \82quilibrer l'arbre ***********)\r
+(********** MEMBER : pour d\82tecter si l'element est membre de l'arbre ***********)\r
+(********** VIDE : teste si l'arbre est vide ou non ***********)\r
+(********** AFFICHE : affiche l'arbre (racine gauche droit) ***********)\r
+(********** MAX : determine l'element maximum de l'arbre ***********)\r
+(********** MIN : determine l'element minimum de l'arbre ***********)\r
+(********** DELETE : supprime l'element de l'arbre ***********)\r
+(****************************************************************************************************)\r
+ \r
+unit presentation:iiuwgraph procedure;\r
+begin\r
+ \r
+ (* creation d'une bordure*)\r
+ \r
+ call border(13);\r
+ \r
+ (*creation d'un cadre pour la fenetre*)\r
+ \r
+ call move(10,10);\r
+ call draw(10,340);\r
+ call draw( 628,340);\r
+ call draw(628,10);\r
+ call draw(10,10);\r
+ call color(2);\r
+ \r
+ (*contenu du titre*)\r
+ call move(160,80);\r
+ call outstring("IMPLEMENTATION D'UNE QUEUE DE PRIORITE");\r
+ call move(210,100);\r
+ call outstring("METHODE DES ARBRES A.V.L.");\r
+ call color(12);\r
+ call move(250,180);\r
+ call outstring("PROJET NUMERO 1");\r
+ call color(14);\r
+ call move(130,300);\r
+ call outstring("PAR : Mr GOUGEON Jean-Yves et Mr RICHARD Jerome");\r
+ \r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ call PAUSE;\r
+ \r
+ (*appel de l'effacage de l'ecran*)\r
+ call cls;\r
+end presentation;\r
+ \r
+unit init_graph : iiuwgraph procedure(output chx : integer);\r
+var i,b,h,v:integer;\r
+ \r
+begin\r
+pref mouse block\r
+begin\r
+ (*teste si le driver de la souris est charge*)\r
+ if(driver) then\r
+ \r
+ call color(10);\r
+ \r
+ call move(0,0);\r
+ (*creation d'un cadre pour le menu*)\r
+ call draw(0,26);\r
+ call draw(639,26);\r
+ call draw(639,0);\r
+ call draw(0,0);\r
+ call move(5,10);\r
+ \r
+ (*contenu du menu*)\r
+ call outstring(" INSERT SUPPRE RECHRCH VIDE MIN MAX QUIT ? ");\r
+ \r
+ call move(400,330);\r
+ call showcursor;\r
+ (*montre le curseur de la souris*)\r
+\r
+ do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ (*attend un click et detecte le bouton*)\r
+\r
+ if gauche then call mousepos(h,v,chx);\r
+ (*demande la position de la souris*)\r
+\r
+ call hidecursor;\r
+ (*enleve le curseur et sauve garde l'envirronnement*)\r
+\r
+ gauche:=false;\r
+ (*remet le bouton gauche a false*)\r
+\r
+ exit;\r
+ fi;\r
+ od;\r
+ else\r
+ call move(150,200);\r
+ call outstring("VOUS AVEZ BESOIN DE LA SOURIS");\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ chx:=7;\r
+ (*met chx a 7 pour sortir directement*)\r
+ exit;\r
+ fi;\r
+ call color(9);\r
+ end;\r
+end init_graph;\r
+ \r
+unit aide:iiuwgraph procedure;\r
+begin\r
+call cls;\r
+call color(1);\r
+call move(180,65);\r
+(*creation d'un cadre pour le titre*)\r
+call draw(500,65);\r
+call draw(500,100);\r
+call draw(180,100);\r
+call draw(180,65);\r
+call color(3);\r
+call move(200,80);\r
+(*contenu du titre*)\r
+call outstring("AIDE SUR L'UTILISATION DU PROGRAMME");\r
+call color(4);\r
+call move(80,120);\r
+(*contenu de l'aide*)\r
+call outstring(" INSERT : Pour construire et inserer des valeurs dans l'arbre.");\r
+call move(80,140);\r
+call outstring(" SUPPRE : Pour supprimer un element de l'arbre. ");\r
+call move(80,160);\r
+call outstring(" RECHRCH : Pour rechercher un element dans l'arbre. ");\r
+call move(80,180);\r
+call outstring(" VIDE : Pour indiquer si l'arbre est vide ou non vide.");\r
+call move(80,200);\r
+call outstring(" MIN : Pour indiquer le minimum present dans l'arbre.");\r
+call move(80,220);\r
+call outstring(" MAX : Pour indiquer le maximum present dans l'arbre.");\r
+call move(80,240);\r
+call outstring(" QUIT : Pour sortir de ce programme.");\r
+call move(80,260);\r
+call outstring(" ? : Cette page d'aide !");\r
+call color(14);\r
+call move(80,280);\r
+call outstring("Pour selectionner une de ces option il faut placer le cuseur de la");\r
+call move(80,300);\r
+call outstring("souris sur le choix et cliquer sur le bouton gauche.");\r
+ \r
+ \r
+ \r
+end aide;\r
+ \r
+unit mousepos : iiuwgraph procedure (x,y:integer;output chx : integer);\r
+var touche:integer;\r
+begin\r
+(*declaration des emplacements du titre pour retourner le choix correspondant*)\r
+if((y>0)and(y<25))then\r
+ if((x<80)and(x>0)) then chx:=1;\r
+ else\r
+ if((x<160)and(x>88)) then chx:=2;\r
+ else\r
+ if((x<220)and(x>168)) then chx:=3;\r
+ else\r
+ if((x<300)and(x>228)) then chx:=4;\r
+ else\r
+ if((x<350)and(x>308)) then chx:=5;\r
+ else\r
+ if((x<400)and(x>358)) then chx:=6;\r
+ else\r
+ if((x<500)and(x>432)) then chx:=7;\r
+ else\r
+ if((x<639)and(x>580)) then chx:=8;\r
+ fi; fi; fi; fi; fi; fi; fi; fi;\r
+fi;\r
+ \r
+end mousepos;\r
+ \r
+(****** UNIT DE MESSAGE ***********)\r
+unit message:iiuwgraph procedure(x:integer);\r
+begin\r
+case x\r
+ when 0 :\r
+\r
+ call move(120,330);\r
+ call outstring("Valider votre choix en cliquant sur le menu ");\r
+ \r
+ \r
+ \r
+ when 1 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(90,330);\r
+ call outstring("Entrez la valeur \85 ins\82rer (taper 100 pour stopper la saisie):");\r
+\r
+ \r
+ when 2 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(150,330);\r
+ call outstring("Entrer la valeur \85 supprimer:");\r
+\r
+ \r
+ when 3 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(150,330);\r
+ call outstring("Entrer la valeur \85 rechercher : ");\r
+\r
+ \r
+ when 4 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(250,290);\r
+ call outstring("L'arbre est vide");\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ \r
+ when 5 :\r
+\r
+ call efface;\r
+\r
+ call move(150,290);\r
+ call outstring("L'arbre n'est pas vide");\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ \r
+ \r
+ when 6 :\r
+\r
+ call cls;\r
+\r
+ call move(80,150);\r
+ call outstring("Au revoir \85 bient\93t pour une future utilisation !!!");\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ \r
+ \r
+ when 7 :\r
+ call move(200,40);\r
+ call outstring("Voi\87i l'arbre avant r\82\82quilibrage");\r
+ \r
+ when 8 :\r
+ call move(200,40);\r
+ call outstring("Voi\87i l'arbre APRES r\82\82quilibrage");\r
+ \r
+ when 9 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(150,290);\r
+ call outstring("Voi\87i l'\82l\82ment maximun de l'arbre :");\r
+ call ecrit(tampon,550,290);\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ \r
+ when 10 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(150,290);\r
+ call outstring("Voi\87i l'\82l\82ment minimun de l'arbre :");\r
+ call ecrit(tampon,500,290);\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ \r
+ when 11 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(250,290);\r
+ call outstring(" n'est pas membre de l'arbre");\r
+ call ecrit(val,200,290);\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ \r
+ when 12 :\r
+\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(150,290);\r
+ call outstring(" est membre de l'arbre");\r
+ call ecrit(val,100,290);\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ \r
+ when 13 :\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(250,290);\r
+ call outstring("L'arbre est vide.");\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ \r
+ when 14 :\r
+ call move(230,40);\r
+ call outstring(" L'ARBRE A.V.L. ACTUEL");\r
+ call move(358,60);\r
+ call outstring("NOEUD");\r
+ call move(358,80);\r
+ call outstring("BALANCE");\r
+ \r
+esac;\r
+call move(400,330);\r
+end message;\r
+ \r
+(********* UNIT ERREUR ********)\r
+unit erreur:iiuwgraph procedure(x:integer);\r
+begin\r
+case x\r
+ \r
+ when 1 :\r
+ call color(10);\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(100,290);\r
+ call outstring("L'arbre est vide : IMPOSSIBLE D'EFFECTUER UNE SUPPRESSION");\r
+ call move(400,330);\r
+ \r
+ when 2 :\r
+ call color(10);\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(100,290);\r
+ call outstring("L'arbre est vide : IMPOSSIBLE D'EFFECTUER UNE RECHERCHE");\r
+ call move(400,330);\r
+ \r
+esac;\r
+end erreur;\r
+ \r
+unit efface:iiuwgraph procedure;\r
+var i : integer;\r
+begin\r
+\r
+(*efface l'ecran de y=280 a y=330*)\r
+for i:=280 step 5 to 330 do\r
+ call move(80,i);\r
+ call outstring(" ");\r
+od;\r
+end efface;\r
+ \r
+unit ecrit :iiuwgraph procedure(element : integer, x, y : integer);\r
+ var length, i : integer;\r
+ begin\r
+ call color(5);\r
+\r
+ (*convertion du code ascii en chiffre <1000*)\r
+ if(element<0) then\r
+ call move(x-10,y);\r
+ call outstring("-");\r
+ element:=(element*(-1));\r
+ fi;\r
+ call move(x,y);\r
+ call Hascii(48 + element div 100);\r
+ element := element mod 100;\r
+ call Hascii(48 + element div 10);\r
+ call Hascii(48 + element mod 10);\r
+ call move(x-5,y-4);\r
+ (*creation d'un cadre pour l'element*)\r
+ call draw(x+28,y-4);\r
+ call draw(x+28,y+10);\r
+ call draw(x-5,y+10);\r
+ call draw(x-5,y-4);\r
+end ecrit;\r
+ \r
+unit AVL:class;\r
+ var balance,info:real,\r
+ fd,fg:AVL;\r
+end AVL;\r
+ \r
+unit PAUSE:iiuwgraph procedure;\r
+var touche:char;\r
+ \r
+begin\r
+pref mouse block\r
+var h,b,v,p:integer,\r
+touche:char;\r
+begin\r
+droit:=false;\r
+\r
+driver:=init(b);\r
+(*teste le driver de souris*)\r
+\r
+if(driver) then\r
+ call color(13);\r
+ call move(150,330);\r
+ call outstring("Appuyez sur une le bouton droit de la souris...");\r
+ call move(400,330);\r
+\r
+ (*tantque le bouton droit n'est pas selectionner*)\r
+ while ( NOT droit) do\r
+ call getpress(1,h,v,p,gauche,droit,centre);\r
+ od;\r
+\r
+ (*efface les messages*)\r
+ call efface;\r
+\r
+ (*restitue la couleur*)\r
+ call color(9);\r
+else\r
+ call efface;\r
+ (*efface les messages*)\r
+\r
+ call move(150,330);\r
+ call outstring("APPUYER SUR UNE TOUCHE....");\r
+\r
+ read(touche);\r
+fi;\r
+end;\r
+end PAUSE;\r
+ \r
+unit RG:procedure(inout sous_arbre:AVL);\r
+ var aux:AVL;\r
+begin\r
+ aux:=sous_arbre.fd;\r
+ sous_arbre.fd:=aux.fg;\r
+ aux.fg:=sous_arbre;\r
+ sous_arbre:=aux;\r
+end RG;\r
+ \r
+unit RD:procedure(inout sous_arbre:AVL);\r
+ var aux:AVL;\r
+begin\r
+ aux:=sous_arbre.fg;\r
+ sous_arbre.fg:=aux.fd;\r
+ aux.fd:=sous_arbre;\r
+ sous_arbre:=aux;\r
+end RD;\r
+ \r
+unit RGD:procedure(inout sous_arbre:AVL);\r
+begin\r
+ call RG(sous_arbre.fg);\r
+ call RD(sous_arbre);\r
+end RGD;\r
+ \r
+unit RDG:procedure(inout sous_arbre:AVL);\r
+begin\r
+ call RD(sous_arbre.fd);\r
+ call RG(sous_arbre);\r
+end RDG;\r
+ \r
+unit INSERT:iiuwgraph procedure(x:integer;inout arbre:AVL);\r
+ var sous_arbre,\r
+ ps_arbre,\r
+ noeud_courant,\r
+ pn_courant,\r
+ noeud_cree:AVL;\r
+begin\r
+ (* cr\82ation de l'objet \85 ins\82rer *)\r
+ \r
+ noeud_cree:=new AVL;\r
+ noeud_cree.info:=x;\r
+ noeud_cree.balance:=0;\r
+ noeud_cree.fd:=none;\r
+ noeud_cree.fg:=none;\r
+ \r
+ (* si l'arbre est vide *)\r
+ \r
+ if arbre=none\r
+ then\r
+ arbre:=noeud_cree;\r
+ else\r
+ \r
+ (* recherche de l'emplacement o\97 doit s'effectuer l'insertion *)\r
+ \r
+ \r
+ sous_arbre:=new AVL;\r
+ ps_arbre:=new AVL;\r
+ noeud_courant:=new AVL;\r
+ pn_courant:=new AVL;\r
+ sous_arbre:=arbre;\r
+ ps_arbre:=none;\r
+ noeud_courant:=arbre;\r
+ pn_courant:=none;\r
+ while noeud_courant=/=none\r
+ do\r
+ \r
+ (* recherche de l'emplacement et m\82morisation du\r
+ dernier sous arbre pour lequel il y aura\r
+ eventuellement desequilibre apr\8as insertion\r
+ (valeur actuelle de la balance:+1 ou -1) *)\r
+ \r
+ if noeud_courant.balance=/=0\r
+ then\r
+ sous_arbre:=noeud_courant;\r
+ ps_arbre:=pn_courant;\r
+ fi;\r
+ pn_courant:=noeud_courant;\r
+ if x<=noeud_courant.info\r
+ then\r
+ noeud_courant:=noeud_courant.fg;\r
+ else\r
+ noeud_courant:=noeud_courant.fd;\r
+ fi;\r
+ od;\r
+ \r
+ (* ajout du noeud cr\82\82 *)\r
+ \r
+ if x<=pn_courant.info\r
+ then\r
+ pn_courant.fg:=noeud_cree;\r
+ else\r
+ pn_courant.fd:=noeud_cree;\r
+ fi;\r
+ \r
+ (* mise \85 jour des d\82s\82quilibres du sous_arbre au\r
+ noeud cr\82\82 *);\r
+ \r
+ noeud_courant:=sous_arbre;\r
+ while noeud_courant=/=noeud_cree\r
+ do\r
+ if x<=noeud_courant.info\r
+ then\r
+ noeud_courant.balance:=noeud_courant.balance+1;\r
+ noeud_courant:=noeud_courant.fg;\r
+ else\r
+ noeud_courant.balance:=noeud_courant.balance-1;\r
+ noeud_courant:=noeud_courant.fd;\r
+ fi;\r
+ od;\r
+ \r
+ (* r\82\82quilibrage *)\r
+ \r
+ call cls;\r
+\r
+ call message(7);\r
+ (*Voi\87i l'arbre avant r\82\82quilibrage*)\r
+\r
+ call AFFICHE(arbre,0,649,60);\r
+ (*appel procedure affichage arbre*) \r
+\r
+ call EQUILIBRE(sous_arbre);\r
+ \r
+ if ps_arbre=none\r
+ then\r
+ arbre:=sous_arbre;\r
+ else\r
+ if sous_arbre.info<=ps_arbre.info\r
+ then\r
+ ps_arbre.fg:=sous_arbre;\r
+ else\r
+ ps_arbre.fd:=sous_arbre;\r
+ fi;\r
+ fi;\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ call cls;\r
+ (*appel de l'effacage de l'ecran*)\r
+\r
+ call color(9);\r
+\r
+ call message(8);\r
+ (*Voi\87i l'arbre APRES r\82\82quilibrage*)\r
+\r
+ call AFFICHE(arbre,0,649,60);\r
+ (*appel procedure affichage arbre*) \r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ call color(9);\r
+ fi;\r
+end INSERT;\r
+ \r
+unit EQUILIBRE:procedure(inout sous_arbre:AVL);\r
+ var\r
+ aux1,aux2:AVL,\r
+ balance,\r
+ balance_fd,\r
+ balance_fg:real;\r
+begin\r
+if (NOT VIDE(sous_arbre)) then\r
+ if sous_arbre.balance=-1\r
+ then\r
+ \r
+ balance:=3;\r
+ else\r
+ if sous_arbre.balance=-2\r
+ then\r
+ balance:=4;\r
+ else\r
+ balance:=sous_arbre.balance;\r
+ fi;\r
+ fi;\r
+ case balance\r
+ when 0:\r
+ exit;\r
+ when 1:\r
+ exit;\r
+ when 3:\r
+ exit;\r
+ when 2:\r
+ if sous_arbre.fg.balance=-1\r
+ then\r
+ balance_fg:=2;\r
+ else\r
+ balance_fg:=sous_arbre.fg.balance;\r
+ fi;\r
+ case balance_fg\r
+ when 0:\r
+ aux1:=sous_arbre.fg;\r
+ aux2:=aux1.fd;\r
+ sous_arbre.balance:=1;\r
+ aux1.balance:=-1;\r
+ sous_arbre.fg:=aux2;\r
+ aux1.fd:=sous_arbre;\r
+ sous_arbre:=aux1;\r
+ when 1:\r
+ call RD(sous_arbre);\r
+ sous_arbre.balance:=0;\r
+ sous_arbre.fd.balance:=0;\r
+ when 2:\r
+ call RGD(sous_arbre);\r
+ if sous_arbre.balance=-1\r
+ then\r
+ balance:=2;\r
+ else\r
+ if sous_arbre.balance=1\r
+ then\r
+ balance:=1;\r
+ else\r
+ balance:=0;\r
+ fi;\r
+ fi;\r
+ case balance\r
+ when 1:\r
+ sous_arbre.fg.balance:=0;\r
+ sous_arbre.fd.balance:=-1;\r
+ when 2:\r
+ sous_arbre.fg.balance:=1;\r
+ sous_arbre.fd.balance:=0;\r
+ when 0:\r
+ sous_arbre.fg.balance:=0;\r
+ sous_arbre.fd.balance:=0;\r
+ esac;\r
+ sous_arbre.balance:=0;\r
+ esac;\r
+ when 4:\r
+ if sous_arbre.fd.balance=-1\r
+ then\r
+ balance_fd:=2;\r
+ else\r
+ balance_fd:=sous_arbre.fd.balance;\r
+ fi;\r
+ case balance_fd\r
+ when 1:\r
+ call RDG(sous_arbre);\r
+ if sous_arbre.balance=-1\r
+ then\r
+ balance:=2;\r
+ else\r
+ if sous_arbre.balance = 1\r
+ then\r
+ balance := 1;\r
+ else\r
+ balance := 0;\r
+ fi;\r
+ fi;\r
+ case balance\r
+ when 1:\r
+ sous_arbre.fd.balance:=-1;\r
+ sous_arbre.fg.balance:=0;\r
+ when 2:\r
+ sous_arbre.fd.balance:=0;\r
+ sous_arbre.fg.balance:=1;\r
+ when 0:\r
+ sous_arbre.fd.balance:=0;\r
+ sous_arbre.fg.balance:=0;\r
+ esac;\r
+ sous_arbre.balance:=0;\r
+ when 0:\r
+ aux1:=sous_arbre.fd;\r
+ aux1.balance:=1;\r
+ sous_arbre.balance:=-1;\r
+ aux2:=aux1.fg;\r
+ aux1.fg:=sous_arbre;\r
+ sous_arbre.fd:=aux2;\r
+ sous_arbre:=aux1;\r
+ when 2:\r
+ call RG(sous_arbre);\r
+ sous_arbre.balance:=0;\r
+ sous_arbre.fg.balance:=0;\r
+ esac;\r
+ esac;\r
+fi;\r
+ \r
+end EQUILIBRE;\r
+ \r
+unit MEMBER:function(val:real;\r
+ arbre:AVL;\r
+ output pos_element:AVL):boolean;\r
+begin\r
+ do\r
+ if arbre=/=none\r
+ then\r
+ pos_element:=arbre;\r
+ if val>arbre.info\r
+ then\r
+ arbre:=arbre.fd;\r
+ else\r
+ if arbre.info=val\r
+ then\r
+ result:=TRUE;\r
+ exit;\r
+ else\r
+ arbre:=arbre.fg;\r
+ fi;\r
+ fi;\r
+ else\r
+ result:=FALSE;\r
+ exit;\r
+ fi;\r
+ od;\r
+end MEMBER;\r
+ \r
+unit VIDE:function(arbre:AVL):boolean;\r
+begin\r
+ if arbre=none\r
+ then\r
+ result:=TRUE;\r
+ else\r
+ result:=FALSE;\r
+ fi;\r
+end VIDE;\r
+ \r
+unit AFFICHE:iiuwgraph procedure(t:AVL;xmin,xmax,y:integer);\r
+var w:integer;\r
+begin\r
+ if t=/=none\r
+ then\r
+ w:=((xmin-xmax)/2)+xmax;\r
+ (*divise la longeur de l'ecran par 2 pour la position*)\r
+\r
+ call color(10);\r
+ call ecrit(t.info,w,y);\r
+\r
+ call ecrit(t.balance,w,y+20);\r
+\r
+ call AFFICHE(t.fg,xmin,w,y+60);\r
+ (*appel procedure affichage arbre avec fils gauche*) \r
+\r
+ call AFFICHE(t.fd,w,xmax,y+60);\r
+ (*appel procedure affichage arbre avec fils droit*) \r
+ fi;\r
+ call color(9);\r
+end AFFICHE;\r
+ \r
+unit MAX:procedure(input sous_arbre:AVL;output element:AVL);\r
+begin\r
+ element:=sous_arbre;\r
+ while element.fd=/=none\r
+ do\r
+ element:=element.fd;\r
+ od;\r
+end MAX;\r
+ \r
+unit MIN:procedure(input sous_arbre:AVL;output element:AVL);\r
+begin\r
+ element:=sous_arbre;\r
+ while element.fg=/=none\r
+ do\r
+ element:=element.fg;\r
+ od;\r
+end MIN;\r
+ \r
+unit DELETE:procedure(x:real;input arbre:AVL;input pere:AVL);\r
+var\r
+ balance_pere:integer,\r
+ pere_element,pos_element,element:AVL;\r
+begin\r
+ if x>arbre.info\r
+ then\r
+ (*si x>info de l'arbre aller fils droit*)\r
+ call DELETE(x,arbre.fd,arbre);\r
+ else\r
+ if x<arbre.info\r
+ then\r
+ (*si x<info aller fils gauche*)\r
+ call DELETE(x,arbre.fg,arbre);\r
+ else\r
+ \r
+ (* on a trouv\82 x *)\r
+ (* si la balance de l'objet \85 supprimer=0 et si il n'a*)\r
+ (* pas de fils droit par exemple cela veut dire qu'il n'a*)\r
+ (*pas de sous_arbre*)\r
+ \r
+ if (arbre.balance=0 AND arbre.fd=none)\r
+ then\r
+ balance_pere:=pere.balance;\r
+ if pere.info>x\r
+ then\r
+ pere.fg:=none;\r
+ pere.balance:=pere.balance-1;\r
+ else\r
+ pere.fd:=none;\r
+ pere.balance:=pere.balance+1;\r
+ fi;\r
+ else\r
+ if (arbre.fg=none AND arbre.fd=/=none) OR\r
+ (arbre.fg=/=none AND arbre.fd=none)\r
+ then\r
+ balance_pere:=pere.balance;\r
+ if arbre.fd=none\r
+ then\r
+ if x<pere.info\r
+ then\r
+ pere.fg:=arbre.fg;\r
+ y:=arbre.fg.info;\r
+ pere.balance:=pere.balance-1;\r
+ else\r
+ pere.fd:=arbre.fg;\r
+ pere.balance:=pere.balance+1;\r
+ fi;\r
+ else\r
+ (*le fils gauche est \85 none *)\r
+ if x<pere.info\r
+ then\r
+ pere.fg:=arbre.fd;\r
+ pere.balance:=pere.balance-1;\r
+ else\r
+ pere.fd:=arbre.fd;\r
+ pere.balance:=pere.balance+1;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ kill(arbre);\r
+ (*destruction de la feuille*)\r
+ call EQUILIBRE(pere);\r
+ (* r\82\82quilibrage selon la balance *)\r
+ (* du p\8are *)\r
+ fi;\r
+ fi;\r
+ if low\r
+ then\r
+ if x<pere.info\r
+ then\r
+ balance_pere:=pere.balance;\r
+ pere.balance:=pere.balance-1;\r
+ else\r
+ balance_pere:=pere.balance;\r
+ pere.balance:=pere.balance+1;\r
+ fi;\r
+ low:=FALSE;\r
+ fi;\r
+ if pere.balance=0 AND balance_pere=/=0\r
+ then\r
+ low:=TRUE;\r
+ else\r
+ low:=FALSE;\r
+ fi;\r
+end DELETE;\r
+ \r
+(**********************FIN UNIT ****************************)\r
+ \r
+ \r
+(**************************** DEBUT PRINCIPAL *******************)\r
+var\r
+ val,choix,cas,y,valeur,tampon:real,\r
+ tree,pere_max,elem_max,pere_noeud_supprime,pos_noeud_supprime,pere\r
+ ,position,recherche:AVL,\r
+ low,driver,droit,gauche,centre:boolean,\r
+ nombre_noeud : integer,\r
+ touche:char;\r
+ \r
+ \r
+BEGIN\r
+ pref iiuwgraph block\r
+ begin\r
+ driver:=false;\r
+ call HPAGE(0,0,0);\r
+ call HPAGE(0,639,349);\r
+ call gron(0);\r
+ call presentation;\r
+ gauche:=false;\r
+ droit:=false;\r
+ centre:=false;\r
+ \r
+ call border(5);\r
+ call color(9);\r
+ \r
+ (*** demande choix ***)\r
+ call message(0);\r
+ (*Valider votre choix en cliquant sur le menu*)\r
+ \r
+ call init_graph(choix);\r
+ \r
+ nombre_noeud:=0;\r
+do\r
+ case choix\r
+ \r
+ when 1:\r
+\r
+ call message(1);\r
+ (*Entrez la valeur \85 ins\82rer (taper 100 pour stopper la saisie):*)\r
+\r
+ call move(400,330);\r
+ read(val);\r
+\r
+ while(MEMBER(val,tree,position))do\r
+\r
+ call message(12);\r
+ (*est membre de l'arbre*)\r
+\r
+ call move(400,330);\r
+\r
+ call message(1);\r
+ (*Entrez la valeur \85 ins\82rer (taper 100 pour stopper la saisie):*)\r
+\r
+ read(val);\r
+ od;\r
+ nombre_noeud:=nombre_noeud+1;\r
+ \r
+ while val=/=100\r
+ do\r
+ if nombre_noeud<16\r
+ then\r
+ call INSERT(val,tree);\r
+\r
+ call message(7);\r
+ (*Voi\87i l'arbre avant r\82\82quilibrage*)\r
+\r
+ call message(1);\r
+ (*Entrez la valeur \85 ins\82rer (taper 100 pour stopper la saisie):*)\r
+\r
+ call move(400,330);\r
+\r
+ read(val);\r
+\r
+ while(MEMBER(val,tree,position))do\r
+\r
+ call message(12);\r
+ (*est membre de l'arbre*)\r
+\r
+ call move(400,330);\r
+\r
+ call message(1);\r
+ (*Entrez la valeur \85 ins\82rer (taper 100 pour stopper la saisie):*)\r
+\r
+ read(val);\r
+ od;\r
+ nombre_noeud:=nombre_noeud+1;\r
+ else\r
+ call color(10);\r
+ call move(150,290);\r
+ call outstring(" VOUS AVEZ ATTEINT LE MAXIMUM ");\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ val:=100;\r
+ (*affecte 100 pour sortir de la boucle*)\r
+\r
+ call color(9);\r
+ fi;\r
+ od;\r
+ call efface;\r
+ \r
+ when 2:\r
+ \r
+ if VIDE(tree)\r
+ then\r
+\r
+ call erreur(1);\r
+ (*L'arbre est vide : IMPOSSIBLE D'EFFECTUER UNE SUPPRESSION*)\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ else\r
+ \r
+ call message(2);\r
+ (*Entrer la valeur \85 supprimer:*)\r
+\r
+ call move(400,330);\r
+ read(val);\r
+ (*lit nouvelle valeur*)\r
+ \r
+ if member(val,tree,position)\r
+ then\r
+\r
+ call message(7);\r
+ (*Voi\87i l'arbre avant r\82\82quilibrage*)\r
+ pere:=new AVL;\r
+\r
+ if position.fg=/=none AND position.fd=/=none\r
+ then\r
+\r
+ call MAX(position.fg,elem_max);\r
+ valeur:=elem_max.info;\r
+ call DELETE(elem_max.info,tree,pere);\r
+ if MEMBER(val,tree,position)\r
+ then\r
+ position.info:=valeur;\r
+ fi;\r
+\r
+ if VIDE(tree)\r
+ then\r
+\r
+ call message(13);\r
+ (*L'arbre est vide.*)\r
+\r
+ else\r
+\r
+ call cls;\r
+ (*appel de l'effacage de l'ecran*)\r
+\r
+ call message(7);\r
+ (*Voi\87i l'arbre avant r\82\82quilibrage*)\r
+\r
+ call AFFICHE(tree,0,649,60);\r
+ (*appel procedure affichage arbre*)\r
+\r
+ call EQUILIBRE(tree);\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ call cls;\r
+ (*appel de l'effacage de l'ecran*)\r
+\r
+ call message(8);\r
+ (*Voi\87i l'arbre APRES r\82\82quilibrage*)\r
+\r
+ call AFFICHE(tree,0,649,60);\r
+ (*appel procedure affichage arbre*)\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ call color(9);\r
+ fi;\r
+ else\r
+ call DELETE(val,tree,pere);\r
+\r
+ call cls;\r
+ (*appel de l'effacage de l'ecran*)\r
+\r
+ call message(7);\r
+ (*Voi\87i l'arbre avant r\82\82quilibrage*)\r
+\r
+ call AFFICHE(tree,0,649,60);\r
+ (*appel procedure affichage arbre*)\r
+ call EQUILIBRE(tree);\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ call cls;\r
+ (*appel de l'effacage de l'ecran*)\r
+\r
+ call message(8);\r
+ (*Voi\87i l'arbre APRES r\82\82quilibrage*)\r
+\r
+ call AFFICHE(tree,0,649,60);\r
+ (*appel procedure affichage arbre*)\r
+\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+\r
+ call color(9);\r
+ fi;\r
+ if(VIDE(tree)) then\r
+ nombre_noeud:=0;\r
+ else\r
+ nombre_noeud:=nombre_noeud-1;\r
+ fi;\r
+ else\r
+ \r
+ call message(11);\r
+ \r
+ fi;\r
+ fi;\r
+ \r
+ when 3:\r
+ if VIDE(tree)\r
+ then\r
+ call erreur(2);\r
+ (*L'arbre est vide : IMPOSSIBLE D'EFFECTUER UNE RECHERCHE*)\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ else\r
+ call message(3);\r
+ (*Entrer la valeur \85 rechercher :*)\r
+ call move(400,330);\r
+ read(val);\r
+ if (MEMBER(val,tree,position))\r
+ then\r
+ call message(12);\r
+ (*est membre de l'arbre*)\r
+ else\r
+ call message(11);\r
+ (*n'est pas membre de l'arbre*)\r
+ fi;\r
+ fi;\r
+ \r
+ when 4:\r
+ \r
+ if VIDE(tree)\r
+ then\r
+ call message(4);\r
+ (*L'arbre est vide*)\r
+ else\r
+ call message(5);\r
+ (*L'arbre n'est pas vide*)\r
+ fi;\r
+ \r
+ when 5:\r
+ \r
+ if VIDE(tree)\r
+ then\r
+ call erreur(2);\r
+ (*L'arbre est vide : IMPOSSIBLE D'EFFECTUER UNE RECHERCHE*)\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ else\r
+ recherche:=tree;\r
+ while(recherche=/=none)\r
+ do\r
+ tampon:=recherche.info;\r
+ recherche:=recherche.fg;\r
+ od;\r
+ call message(10);\r
+ (*Voi\87i l'\82l\82ment minimun de l'arbre :*)\r
+ fi;\r
+ \r
+ when 6:\r
+ \r
+ if VIDE(tree)\r
+ then\r
+ call erreur(2);\r
+ (*L'arbre est vide : IMPOSSIBLE D'EFFECTUER UNE RECHERCHE*)\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ else\r
+ recherche:=tree;\r
+ while(recherche=/=none)\r
+ do\r
+ tampon:=recherche.info;\r
+ recherche:=recherche.fd;\r
+ od;\r
+ call message(9);\r
+ (*Voi\87i l'\82l\82ment maximun de l'arbre :*)\r
+ fi;\r
+ \r
+ when 7:\r
+ call message(6);\r
+ (*Au revoir \85 bient\93t pour une future utilisation !!*)\r
+ exit;\r
+ when 8 : (* AIDE *)\r
+ call efface;\r
+ (*efface les messages*)\r
+ call aide;\r
+ (*appel procedure aide*)\r
+ call PAUSE;\r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ esac;\r
+ call cls;\r
+ (*appel de l'effacage de l'ecran*)\r
+ call message(14);\r
+ (*L'ARBRE A.V.L. ACTUEL*)\r
+ call AFFICHE(tree,0,649,60);\r
+ (*appel procedure affichage arbre*)\r
+ call color(9);\r
+ call message(0);\r
+ (*Valider votre choix en cliquant sur le menu*)\r
+ call init_graph(choix);\r
+ od;\r
+ call groff;\r
+ end;\r
+END AVL;\r
+(*************************FIN PRINCIPAL ********************)\r
--- /dev/null
+program myBarbres;\r
+(* Mlles Beau et Delburg *)\r
+ (* representation d'un noeud *)\r
+ Unit noeud : class;\r
+ Var pere : noeud,\r
+ nb : integer,\r
+ IG, IM : integer,\r
+ FG, FM, FD : noeud;\r
+ (* \r
+ pere est le pere\r
+ nb est le nombre de fils\r
+ IG est l'information de gauche\r
+ IM est l'information de droite\r
+ FG est le fils de gauche\r
+ FM est le fils du milieu\r
+ FD est le fils de droite\r
+ *)\r
+ begin\r
+ (* initialisation des variables *)\r
+ pere := none;\r
+ nb := 0;\r
+ IG := -1;\r
+ IM := -1;\r
+ FG := none;\r
+ FM := none;\r
+ FD := none;\r
+ end noeud;\r
+\r
+\r
+\r
+ Unit barbre : class;\r
+ Var racine : noeud;\r
+\r
+ unit afficher : procedure(inout courant : noeud);\r
+ begin\r
+ if courant.IM = -1\r
+ then\r
+ (* courant pointe sur une feuille *)\r
+ writeln(courant.IG:1);\r
+ else\r
+ (* courant pointe sur un noeud *)\r
+ writeln(courant.IG:1, ":", courant.IM:1);\r
+ fi;\r
+ \r
+ if courant.FG =/= none\r
+ then\r
+ (* courant a 1, 2 ou 3 fils *) \r
+ if courant.FG.FG =/= none\r
+ then\r
+ (* courant a 2 ou 3 petits fils *)\r
+ (* appel de la procedure afficher avec le fils gauche de courant *)\r
+ call afficher(courant.FG);\r
+ if courant.FM =/= none\r
+ then\r
+ (* courant a 2 ou 3 fils *)\r
+ (* appel de la procedure afficher avec le fils milieu de courant *)\r
+ call afficher(courant.FM);\r
+ if courant.FD =/= none\r
+ then\r
+ (* courant a 3 fils *)\r
+ (* appel de la procedure afficher avec le fils droit de courant *)\r
+ call afficher(courant.FD);\r
+ fi;\r
+ fi;\r
+ else\r
+ (* courant n'a pas de petits fils \r
+ i.e. les fils de courant sont des feuilles *)\r
+ (* affichage de la feuille de gauche *)\r
+ write(courant.FG.IG:1);\r
+ if courant.FM =/= none\r
+ then\r
+ (* courant a 2 ou 3 fils *)\r
+ (* affichage de la feuille du milieu *)\r
+ write(" ", courant.FM.IG:1);\r
+ if courant.FD =/= none\r
+ then\r
+ (* courant a 3 fils *)\r
+ (* affichage de la feuille de droite *)\r
+ writeln(" ", courant.FD.IG:1);\r
+ else\r
+ (* il n'y a pas de fils droit *)\r
+ writeln;\r
+ fi;\r
+ else\r
+ (* il n'y a pas de fils milieu *)\r
+ writeln;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end;\r
+\r
+ unit reorganiser : procedure(inout courant,bidon : noeud);\r
+ begin\r
+ if courant.FG =/= none\r
+ then\r
+ (* courant a 1, 2 ou 3 fils *)\r
+ if courant.FG.FG =/= none\r
+ then\r
+ (* courant a 2 ou 3 petits fils *)\r
+ (* appel de la procedure reorganiser avec le fils gauche *)\r
+ call reorganiser(courant.FG, bidon);\r
+ (* appel de la procedure reorganiser avec le fils milieu *)\r
+ call reorganiser(courant.FM, bidon);\r
+ if courant.FD =/= none\r
+ then\r
+ (* courant a 3 fils *)\r
+ (* appel de la procedure reorganiser avec le fils droit *)\r
+ call reorganiser(courant.FD, bidon);\r
+ fi;\r
+\r
+ (* recherche du plus grand element dans le sous arbre \r
+ gauche de courant pour recuperer le IG de courant *)\r
+ bidon := courant.FG;\r
+ do\r
+ case bidon.nb\r
+ when 0 : courant.IG := bidon.IG;\r
+ exit;\r
+ when 1 : bidon := bidon.FG;\r
+\r
+ when 2 : bidon := bidon.FM;\r
+\r
+ when 3 : bidon := bidon.FD;\r
+ esac;\r
+ od;\r
+ \r
+ (* recherche du plus grand element dans le sous arbre \r
+ du milieu de courant pour recuperer le IM de courant *)\r
+ bidon := courant.FM;\r
+ do\r
+ case bidon.nb\r
+ when 0 : courant.IM := bidon.IG;\r
+ exit;\r
+ when 1 : bidon := bidon.FG;\r
+\r
+ when 2 : bidon := bidon.FM;\r
+\r
+ when 3 : bidon := bidon.FD;\r
+ esac;\r
+ od;\r
+ else\r
+ (* courant n'a pas de petis fils *)\r
+ (* recuperation de IG pour courant *)\r
+ courant.IG := courant.FG.IG;\r
+ if courant.nb =/= 1\r
+ then\r
+ (* recuperation de IM pour courant *)\r
+ (* courant a 2 ou 3 fils *)\r
+ courant.IM := courant.FM.IG;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end reorganiser;\r
+\r
+ Unit vide : function : boolean;\r
+ begin\r
+ result := (racine.nb = 0);\r
+ end vide;\r
+\r
+ Unit minimum : function : integer;\r
+ var courant : noeud;\r
+ begin\r
+ courant := racine;\r
+ do\r
+ if courant.FG = none\r
+ then\r
+ (* result contient le plus petit element de l'arbre *)\r
+ result := courant.IG;\r
+ exit;\r
+ else\r
+ (* descendre a gauche *)\r
+ courant := courant.FG;\r
+ fi;\r
+ od;\r
+ end minimum;\r
+\r
+ Unit maximum : function : integer;\r
+ var courant : noeud;\r
+ begin\r
+ courant := racine;\r
+ do\r
+ (* suivant le nombre de fils de courant *)\r
+ case courant.nb\r
+ when 0 : (* result contient le plus grand element de l'arbre *)\r
+ result := courant.IG;\r
+ exit;\r
+ when 1 : (* le plus grand element se trouve \r
+ dans le sous arbre de gauche *)\r
+ courant := courant.FG;\r
+\r
+ when 2 : (* le plus grand element se trouve\r
+ dans le sous arbre du milieu *)\r
+ courant := courant.FM;\r
+\r
+ when 3 : (* le plus grand element se trouve\r
+ dans le sous arbre de droite *)\r
+ courant := courant.FD;\r
+ esac;\r
+ od;\r
+ end maximum;\r
+ \r
+ unit present : function(v : integer; inout courant : noeud) : boolean;\r
+ begin\r
+ do\r
+ (* suivant le nombre de fils de courant *)\r
+ case courant.nb\r
+ when 0 : (* 0 fils donc c'est une feuille *)\r
+ if courant.IG = v\r
+ then result := true;\r
+ else result := false;\r
+ fi;\r
+ exit;\r
+ when 1 : (* 1 fils donc le pere est la racine *)\r
+ courant := courant.FG;\r
+ if courant.IG = v\r
+ then result := true;\r
+ else result := false;\r
+ fi;\r
+ exit;\r
+ when 2 : (* 2 fils *)\r
+ if courant.IG > v\r
+ then\r
+ (* v se trouve a gauche, si il existe *) \r
+ courant := courant.FG;\r
+ else\r
+ if courant.IG = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FG;\r
+ fi;\r
+ else\r
+ (* v ne se trouve pas a gauche, si il existe *)\r
+ if courant.IM > v\r
+ then\r
+ (* v se trouve au milieu, si il existe *)\r
+ courant := courant.FM;\r
+ else\r
+ if courant.IM = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FM;\r
+ fi;\r
+ else\r
+ courant := courant.FM;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ when 3 : (* 3 fils *)\r
+ if courant.IG > v\r
+ then\r
+ (* v se trouve a gauche, si il existe *)\r
+ courant := courant.FG;\r
+ else\r
+ if courant.IG = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FG;\r
+ fi;\r
+ else \r
+ (* v ne se trouve pas a gauche, si il existe *)\r
+ if courant.IM > v\r
+ then\r
+ (* v se trouve au milieu, si il existe *)\r
+ courant := courant.FM;\r
+ else\r
+ if courant.IM = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FM;\r
+ fi;\r
+ else\r
+ (* v ne se trouve pas a gauche, si il existe *)\r
+ if courant.IM < v\r
+ then \r
+ (* v se trouve a droite, si il existe *)\r
+ courant := courant.FD;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ esac;\r
+ od;\r
+ end present;\r
+\r
+\r
+\r
+\r
+\r
+ unit supprimer : function(v: integer) : barbre;\r
+ var courant, p : noeud,\r
+ b : barbre;\r
+ begin\r
+ b := new barbre;\r
+ courant := racine;\r
+ if present(v, courant)\r
+ then\r
+ (* l'element est present dans l'arbre donc on peut le supprimer *)\r
+ p := courant.pere;\r
+ if p.pere = none\r
+ then\r
+ (* p pointe sur la racine *)\r
+ case p.nb\r
+ when 1 : (* p a 1 fils *)\r
+ courant := p;\r
+ courant.FG := none;\r
+ courant.nb := 0;\r
+ courant.IG := -1;\r
+\r
+ when 2 : (* p a 2 fils *)\r
+ if p.FG.IG = courant.IG\r
+ then\r
+ p.FG := p.FM;\r
+ p.IG := p.FG.IG;\r
+ fi;\r
+ p.FM := none;\r
+ p.nb := p.nb - 1;\r
+ p.IM := -1;\r
+ when 3 : (* p a 3 fils *)\r
+ if p.IG = courant.IG\r
+ then\r
+ p.FG := p.FM;\r
+ p.FM := p.FD;\r
+ p.IG := p.FG.IG;\r
+ p.IM := p.FM.IG;\r
+ else\r
+ if p.FM.IG = courant.IG\r
+ then\r
+ p.FM := p.FD;\r
+ p.IM := p.FM.IG;\r
+ fi;\r
+ fi;\r
+ p.FD := none;\r
+ p.nb := p.nb - 1;\r
+ esac;\r
+ else\r
+ (* p ne pointe pas sur le racine *)\r
+ case p.nb\r
+ when 2 : (* p a 2 fils *)\r
+ writeln("Le cas ou l'on veut supprimer une feuille");\r
+ writeln("dont le pere a 2 fils n'a pas ete gere.");\r
+ \r
+ when 3 : (* p a 3 fils *)\r
+ if p.FG.IG = courant.IG\r
+ then\r
+ p.FG := p.FM;\r
+ p.FM := p.FD;\r
+ p.IG := p.FG.IG;\r
+ p.IM := p.FM.IG;\r
+ else\r
+ if p.FM.IG = courant.IG\r
+ then\r
+ p.FM := p.FD;\r
+ p.IM := p.FM.IG;\r
+ fi;\r
+ fi;\r
+ \r
+ p.FD := none;\r
+ p.nb := p.nb - 1 ;\r
+ esac;\r
+ fi;\r
+ else\r
+ writeln("On ne peut pas supprimer cet element"); \r
+ writeln("car il n'est pas dans l'arbre");\r
+ fi;\r
+ b.racine := racine;\r
+ result := b;\r
+ end supprimer;\r
+\r
+ unit inserer : function(v : integer) : barbre;\r
+\r
+ unit refaire : procedure(inout p, f1, f2, j, r : noeud);\r
+ begin\r
+ (* suivant le nombre de fils de p *)\r
+ case p.nb\r
+ when 3 : (* p a 3 fils *)\r
+ if p.FG = f1\r
+ then\r
+ p.FD := p.FM;\r
+ p.FM := j;\r
+ else\r
+ p.FD := j;\r
+ fi;\r
+\r
+ when 4 : (* p a 4 fils *)\r
+ (* et creer un nouveau noeud *)\r
+ j := new noeud;\r
+ if p.FG = f1\r
+ then\r
+ j.FG := p.FM;\r
+ j.FM := p.FD;\r
+ p.FM := f2;\r
+ else\r
+ if p.FM = f1\r
+ then\r
+ j.FG := f2;\r
+ j.FM := p.FD;\r
+ else\r
+ j.FG := f1;\r
+ j.FM := f2;\r
+ fi;\r
+ fi;\r
+ \r
+ j.FG.pere := j;\r
+ j.FM.pere := j;\r
+ j.nb := 2;\r
+ p.FD := none;\r
+ p.nb := 2;\r
+ \r
+ if p.pere =/= none\r
+ then\r
+ (* le pere de p n'est pas la racine *)\r
+ (* il faut repeter la procedure refaire *)\r
+ j.pere := p.pere;\r
+ p.pere.nb := p.pere.nb + 1;\r
+ call refaire(p.pere, p, j, j, r);\r
+ else\r
+ (* le pere de p est la racine *)\r
+ (* donc il faut creer une nouvelle racine *)\r
+ r := new noeud;\r
+ r.nb := 2;\r
+ r.FG := p;\r
+ r.FM := j;\r
+ p.pere := r;\r
+ j.pere := r;\r
+ racine := r;\r
+ fi;\r
+ esac;\r
+ end refaire;\r
+\r
+\r
+ var bidon, courant, i, f1, f2, j, p, r : noeud,\r
+ b : barbre,\r
+ pos : integer;\r
+ begin\r
+ b := new barbre;\r
+\r
+ bidon := new noeud;\r
+ courant := new noeud;\r
+ r := new noeud;\r
+ i:= new noeud;\r
+ f1 := new noeud;\r
+ f2 := new noeud;\r
+ j := new noeud;\r
+ p:= new noeud;\r
+\r
+ if vide\r
+ then\r
+ (* l'arbre est vide *)\r
+ (* creer la feuille qui contiendra l'element a inserer *)\r
+ courant := new noeud;\r
+ courant.pere := racine;\r
+ courant.IG := v;\r
+ racine.IG := v;\r
+ racine.nb := 1;\r
+ racine.FG := courant;\r
+\r
+ b.racine := racine;\r
+ result := b;\r
+\r
+ else\r
+ (* l'arbre n'est pas vide *)\r
+ courant := racine;\r
+ if present(v,courant)\r
+ then\r
+ writeln("L'element ne peut etre inserer puisqu'il appartient deja a l'arbre.");\r
+ else\r
+ (* l'element n'existe pas dans l'arbre *)\r
+ \r
+ pos := 0;\r
+\r
+ i := new noeud;\r
+ p := new noeud;\r
+ i := courant;\r
+ i.pere := courant.pere;\r
+ p := courant.pere;\r
+\r
+ (* creer le noeud qui contiendra l'element a inserer *)\r
+ courant := new noeud;\r
+ courant.IG := v;\r
+ courant.pere := p;\r
+ p.nb := p.nb + 1;\r
+\r
+ (* determination de la position ou inserer l'element *)\r
+ if i.IG = p.FG.IG\r
+ then\r
+ pos := 1;\r
+ else\r
+ if p.FM =/= none\r
+ then\r
+ if i.IG = p.FM.IG\r
+ then\r
+ pos := 2;\r
+ else\r
+ if p.FD =/= none\r
+ then\r
+ if i.IG = p.FD.IG\r
+ then\r
+ pos := 3;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+ (* suivant le nombre de fils de p *)\r
+ case p.nb\r
+ when 2 : (* p a 2 fils *)\r
+ if courant.IG > i.IG\r
+ then pos := pos + 1;\r
+ fi;\r
+ \r
+ (* suivant la position de l'element *)\r
+ case pos\r
+ when 1 : p.FM := p.FG;\r
+ p.FG := courant;\r
+ when 2 : p.FM := courant;\r
+ esac;\r
+ when 3 : (* p a 3 fils *)\r
+ if courant.IG > i.IG\r
+ then pos := pos + 1;\r
+ fi;\r
+ \r
+ (* suivant la position de l'element *)\r
+ case pos\r
+ when 1 : p.FD := p.FM;\r
+ p.FM := p.FG;\r
+ p.FG := courant;\r
+ when 2 : p.FD := p.FM;\r
+ p.FM := courant;\r
+ when 3 : p.FD := courant;\r
+ esac;\r
+ when 4 : (* p a 4 fils *)\r
+ if courant.IG > i.IG\r
+ then pos := pos + 1;\r
+ fi;\r
+\r
+ f1 := new noeud;\r
+ f2 := new noeud;\r
+ \r
+ (* suivant la position de l'element *)\r
+ case pos\r
+ when 1 : f1 := p.FM;\r
+ f2 := P.FD;\r
+ p.FD := none;\r
+ p.FM := p.FG;\r
+ p.FG := courant;\r
+ (**)\r
+ when 2 : f1 := p.FM;\r
+ f2 := p.FD;\r
+ p.FD := none;\r
+ p.FM := courant;\r
+ (**)\r
+ when 3 : f1 := courant;\r
+ f2 := p.FD;\r
+ p.FD := none;\r
+ (**)\r
+ when 4 : f1 := p.FD;\r
+ f2 := courant;\r
+ p.FD := none;\r
+ (**)\r
+ esac;\r
+\r
+ j := new noeud;\r
+\r
+ j.FG := f1;\r
+ j.FM := f2;\r
+ j.FG.pere := j;\r
+ j.FM.pere := j;\r
+ j.nb := 2;\r
+ p.nb := 2;\r
+\r
+ if p.pere =/= none\r
+ then\r
+ (* p a un pere *)\r
+ (* il faut repeter la procedure refaire *)\r
+ j.pere := p.pere;\r
+ p.pere.nb := p.pere.nb + 1;\r
+ call refaire(p.pere, p, j, j, r);\r
+ else\r
+ (* p est la racine *)\r
+ (* donc il faut creer une nouvelle racine *)\r
+ r := new noeud;\r
+ r.nb := 2;\r
+ r.FG := p;\r
+ r.FM := j;\r
+ p.pere := r;\r
+ j.pere := r;\r
+ racine := r;\r
+ fi;\r
+ esac;\r
+ fi;\r
+\r
+ courant := racine;\r
+ b.racine := courant;\r
+ result := b;\r
+ fi;\r
+ end inserer;\r
+\r
+ begin\r
+ racine := new noeud;\r
+ end barbre;\r
+\r
+\r
+var ba : barbre,\r
+ e : integer,\r
+ bidon, courant, a, b : noeud,\r
+ choix : integer;\r
+\r
+begin\r
+ ba := new barbre;\r
+ courant := new noeud;\r
+ courant := ba.racine;\r
+\r
+ do\r
+ (* affichage du menu *)\r
+ writeln;\r
+ writeln;\r
+ writeln;\r
+ writeln;\r
+ writeln("1 -> ajouter un element :");\r
+ writeln("2 -> supprimer un element :");\r
+ writeln("3 -> existence d'un element ? :");\r
+ writeln("4 -> minimum de l'arbre :");\r
+ writeln("5 -> maximum de l'arbre :");\r
+ writeln("6 -> arbre vide ? :");\r
+ writeln("7 -> afficher l'arbre :");\r
+ writeln("8 -> fin.");\r
+\r
+ write("choix =");\r
+ read(choix);\r
+ writeln;\r
+ writeln("-------------------------------------------");\r
+ writeln;\r
+ \r
+ (* selon le choix *)\r
+ case choix\r
+ when 1 : (* inserer un element *)\r
+ write(" element = ");\r
+ read(e);\r
+\r
+ courant := ba.racine;\r
+ ba := ba.inserer(e);\r
+ courant := ba.racine;\r
+ call ba.reorganiser(courant, bidon);\r
+ writeln;\r
+\r
+ when 2 : (* supprimer un element *)\r
+ if ba.vide\r
+ then\r
+ writeln("L'arbre est vide. Impossible de faire supprimer.");\r
+ else\r
+ write(" element = ");\r
+ read(e);\r
+ \r
+ courant := ba.racine;\r
+ ba := ba.supprimer(e);\r
+ courant := ba.racine;\r
+ call ba.reorganiser(courant, bidon);\r
+ writeln;\r
+ fi;\r
+\r
+ when 3 : (* determiner si l'element est present dans l'arbre *)\r
+ if ba.vide\r
+ then\r
+ writeln("L'arbre est vide. Impossible de faire present.");\r
+ else\r
+ write(" element = ");\r
+ read(e);\r
+ writeln;\r
+ courant := ba.racine;\r
+ if ba.present(e,courant)\r
+ then\r
+ writeln(" -> present");\r
+ else\r
+ writeln(" -> absent");\r
+ fi;\r
+ fi;\r
+\r
+ when 4 : (* determiner l'element minimum *)\r
+ if ba.vide\r
+ then\r
+ writeln("L'arbre est vide. Impossible de faire minimum.");\r
+ else\r
+ writeln(" minimum = ", ba.minimum);\r
+ fi;\r
+\r
+ when 5 : (* determiner l'element maximum *)\r
+ if ba.vide\r
+ then\r
+ writeln("L'arbre est vide. Impossible de faire maximum.");\r
+ else\r
+ writeln(" maximum = ", ba.maximum);\r
+ fi;\r
+\r
+ when 6 : (* determiner si l'arbre est vide *)\r
+ if ba.vide then writeln(" -> vide");\r
+ else writeln(" -> pas vide");\r
+ fi;\r
+ \r
+ when 7 : (* affichage de l'arbre *)\r
+ if ba.vide\r
+ then\r
+ writeln("L'arbre est vide.");\r
+ else\r
+ courant := ba.racine;\r
+ call ba.afficher(courant);\r
+ fi;\r
+\r
+ when 8 : (* fin du programme *)\r
+ exit;\r
+ esac;\r
+ od;\r
+end mybarbre.\r
+\r
+\r
--- /dev/null
+program myBarbres;\r
+\r
+ unit presentation : procedure;\r
+ begin\r
+ pref IIUWgraph block\r
+ begin\r
+ call gron(1);\r
+ call hpage(1,1,1);\r
+ call border(5);\r
+ call move(270,50);\r
+ call color(5);\r
+ call outstring("LES ARBRES 2-3");\r
+ call move(80,100);\r
+ call color(3);\r
+ call outstring("MENU :");\r
+ call move(100,125);\r
+ call color(3);\r
+ call outstring("1 -> inserer un element");\r
+ call move(100,150);\r
+ call outstring("2 -> supprimer un element");\r
+ call move(100,175);\r
+ call outstring("3 -> existence d'un element");\r
+ call move(100,200);\r
+ call outstring("4 -> minimum de l'arbre");\r
+ call move(100,225);\r
+ call outstring("5 -> maximum de l'arbre");\r
+ call move(100,250);\r
+ call outstring("6 -> vide");\r
+ call move(100,275);\r
+ call outstring("7 -> afficher l'arbre");\r
+ call move(100,300);\r
+ call outstring("8 -> fin");\r
+ call move(100,325);\r
+ call outstring("choix =");\r
+ end;\r
+ end presentation;\r
+\r
+ unit inchar: iiuwgraph function:integer;\r
+ var i:integer;\r
+ begin\r
+ do\r
+ i:=inkey;\r
+ if i=/=0 then exit fi;\r
+ od;\r
+ result:=i;\r
+ end inchar;\r
+\r
+ unit reponse : IIUWgraph procedure(output r : char);\r
+ begin\r
+ call move(250,325);\r
+ call outstring("Tapez o/n pour continuer");\r
+ r := chr(inchar);\r
+ call hascii(0);\r
+ call hascii(ord(r));\r
+ end reponse; \r
+\r
+\r
+ unit WriteInteger : IIUWgraph procedure( Number : integer );\r
+ var i, j : integer;\r
+ begin\r
+ if Number < 10 then\r
+ call HASCII( 0 );\r
+ call HASCII( Number + 48 );\r
+ call Hascii( 0 );\r
+ else\r
+ i := Number div 10;\r
+ j := Number - i * 10;\r
+ call HASCII( 0 );\r
+ call Hascii( i + 48 );\r
+ call Hascii( 0 );\r
+ call Hascii( j + 48 );\r
+ fi;\r
+ end WriteInteger;\r
+\r
+\r
+ (* representation d'un noeud *)\r
+ unit noeud : class;\r
+ var pere : noeud,\r
+ nb : integer,\r
+ IG, IM : integer,\r
+ FG, FM, FD : noeud;\r
+ (* \r
+ pere est le pere\r
+ nb est le nombre de fils\r
+ IG est l'information de gauche\r
+ IM est l'information de droite\r
+ FG est le fils de gauche\r
+ FM est le fils du milieu\r
+ FD est le fils de droite\r
+ *)\r
+ begin\r
+ (* initialisation des variables *)\r
+ pere := none;\r
+ nb := 0;\r
+ IG := -1;\r
+ IM := -1;\r
+ FG := none;\r
+ FM := none;\r
+ FD := none;\r
+ end noeud;\r
+\r
+\r
+\r
+ unit barbre : class;\r
+ var racine : noeud;\r
+\r
+ unit afficher : procedure(inout courant : noeud);\r
+ begin\r
+ if courant.IM = -1\r
+ then\r
+ (* courant pointe sur une feuille *)\r
+ writeln(courant.IG:1);\r
+ else\r
+ (* courant pointe sur un noeud *)\r
+ writeln(courant.IG:1, ":", courant.IM:1);\r
+ fi;\r
+ \r
+ if courant.FG =/= none\r
+ then\r
+ (* courant a 1, 2 ou 3 fils *) \r
+ if courant.FG.FG =/= none\r
+ then\r
+ (* courant a 2 ou 3 petits fils *)\r
+ (* appel de la procedure afficher avec le fils gauche de courant *)\r
+ call afficher(courant.FG);\r
+ if courant.FM =/= none\r
+ then\r
+ (* courant a 2 ou 3 fils *)\r
+ (* appel de la procedure afficher avec le fils milieu de courant *)\r
+ call afficher(courant.FM);\r
+ if courant.FD =/= none\r
+ then\r
+ (* courant a 3 fils *)\r
+ (* appel de la procedure afficher avec le fils droit de courant *)\r
+ call afficher(courant.FD);\r
+ fi;\r
+ fi;\r
+ else\r
+ (* courant n'a pas de petits fils \r
+ i.e. les fils de courant sont des feuilles *)\r
+ (* affichage de la feuille de gauche *)\r
+ write(courant.FG.IG:1);\r
+ if courant.FM =/= none\r
+ then\r
+ (* courant a 2 ou 3 fils *)\r
+ (* affichage de la feuille du milieu *)\r
+ write(" ", courant.FM.IG:1);\r
+ if courant.FD =/= none\r
+ then\r
+ (* courant a 3 fils *)\r
+ (* affichage de la feuille de droite *)\r
+ writeln(" ", courant.FD.IG:1);\r
+ else\r
+ writeln;\r
+ fi;\r
+ else\r
+ writeln;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end;\r
+\r
+ unit reorganiser : procedure(inout courant,bidon : noeud);\r
+ begin\r
+ if courant.FG =/= none\r
+ then\r
+ (* courant a 1, 2 ou 3 fils *)\r
+ if courant.FG.FG =/= none\r
+ then\r
+ (* courant a 2 ou 3 petits fils *)\r
+ (* appel de la procedure reorganiser avec le fils gauche *)\r
+ call reorganiser(courant.FG, bidon);\r
+ (* appel de la procedure reorganiser avec le fils milieu *)\r
+ call reorganiser(courant.FM, bidon);\r
+ if courant.FD =/= none\r
+ then\r
+ (* courant a 3 fils *)\r
+ (* appel de la procedure reorganiser avec le fils droit *)\r
+ call reorganiser(courant.FD, bidon);\r
+ fi;\r
+\r
+ (* recherche du plus grand element dans le sous arbre \r
+ gauche de courant pour recuperer le IG de courant *)\r
+ bidon := courant.FG;\r
+ do\r
+ case bidon.nb\r
+ when 0 : courant.IG := bidon.IG;\r
+ exit;\r
+ when 1 : bidon := bidon.FG;\r
+\r
+ when 2 : bidon := bidon.FM;\r
+\r
+ when 3 : bidon := bidon.FD;\r
+ esac;\r
+ od;\r
+ \r
+ (* recherche du plus grand element dans le sous arbre \r
+ du milieu de courant pour recuperer le IM de courant *)\r
+ bidon := courant.FM;\r
+ do\r
+ case bidon.nb\r
+ when 0 : courant.IM := bidon.IG;\r
+ exit;\r
+ when 1 : bidon := bidon.FG;\r
+\r
+ when 2 : bidon := bidon.FM;\r
+\r
+ when 3 : bidon := bidon.FD;\r
+ esac;\r
+ od;\r
+ else\r
+ (* courant n'a pas de petis fils *)\r
+ (* recuperation de IG pour courant *)\r
+ courant.IG := courant.FG.IG;\r
+ if courant.nb =/= 1\r
+ then\r
+ (* recuperation de IM pour courant *)\r
+ (* courant a 2 ou 3 fils *)\r
+ courant.IM := courant.FM.IG;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end reorganiser;\r
+\r
+ unit vide : function : boolean;\r
+ begin\r
+ result := (racine.nb = 0);\r
+ end vide;\r
+\r
+ unit minimum : function : integer;\r
+ var courant : noeud;\r
+ begin\r
+ courant := racine;\r
+ do\r
+ if courant.FG = none\r
+ then\r
+ (* result contient le plus petit element de l'arbre *)\r
+ result := courant.IG;\r
+ exit;\r
+ else\r
+ (* descendre a gauche *)\r
+ courant := courant.FG;\r
+ fi;\r
+ od;\r
+ end minimum;\r
+\r
+ unit maximum : function : integer;\r
+ var courant : noeud;\r
+ begin\r
+ courant := racine;\r
+ do\r
+ (* suivant le nombre de fils de courant *)\r
+ case courant.nb\r
+ when 0 : (* result contient le plus grand element de l'arbre *)\r
+ result := courant.IG;\r
+ exit;\r
+ when 1 : (* le plus grand element se trouve \r
+ dans le sous arbre de gauche *)\r
+ courant := courant.FG;\r
+\r
+ when 2 : (* le plus grand element se trouve\r
+ dans le sous arbre du milieu *)\r
+ courant := courant.FM;\r
+\r
+ when 3 : (* le plus grand element se trouve\r
+ dans le sous arbre de droite *)\r
+ courant := courant.FD;\r
+ esac;\r
+ od;\r
+ end maximum;\r
+ \r
+ unit present : function(v : integer; inout courant : noeud) : boolean;\r
+ begin\r
+ do\r
+ (* suivant le nombre de fils de courant *)\r
+ case courant.nb\r
+ when 0 : (* 0 fils donc c'est une feuille *)\r
+ if courant.IG = v\r
+ then result := true;\r
+ else result := false;\r
+ fi;\r
+ exit;\r
+ when 1 : (* 1 fils donc le pere est la racine *)\r
+ courant := courant.FG;\r
+ if courant.IG = v\r
+ then result := true;\r
+ else result := false;\r
+ fi;\r
+ exit;\r
+ when 2 : (* 2 fils *)\r
+ if courant.IG > v\r
+ then\r
+ (* v se trouve a gauche, si il existe *) \r
+ courant := courant.FG;\r
+ else\r
+ if courant.IG = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FG;\r
+ fi;\r
+ else\r
+ (* v ne se trouve pas a gauche, si il existe *)\r
+ if courant.IM > v\r
+ then\r
+ (* v se trouve au milieu, si il existe *)\r
+ courant := courant.FM;\r
+ else\r
+ if courant.IM = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FM;\r
+ fi;\r
+ else\r
+ courant := courant.FM;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ when 3 : (* 3 fils *)\r
+ if courant.IG > v\r
+ then\r
+ (* v se trouve a gauche, si il existe *)\r
+ courant := courant.FG;\r
+ else\r
+ if courant.IG = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FG;\r
+ fi;\r
+ else \r
+ (* v ne se trouve pas a gauche, si il existe *)\r
+ if courant.IM > v\r
+ then\r
+ (* v se trouve au milieu, si il existe *)\r
+ courant := courant.FM;\r
+ else\r
+ if courant.IM = v\r
+ then\r
+ if courant.nb =/= 0\r
+ then\r
+ courant := courant.FM;\r
+ fi;\r
+ else\r
+ (* v ne se trouve pas a gauche, si il existe *)\r
+ if courant.IM < v\r
+ then \r
+ (* v se trouve a droite, si il existe *)\r
+ courant := courant.FD;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ esac;\r
+ od;\r
+ end present;\r
+\r
+\r
+\r
+\r
+\r
+ unit supprimer : IIUWgraph function(v: integer) : barbre;\r
+ var courant, p : noeud,\r
+ b : barbre;\r
+ begin\r
+ b := new barbre;\r
+ courant := racine;\r
+ if present(v, courant)\r
+ then\r
+ (* l'element est present dans l'arbre donc on peut le supprimer *)\r
+ p := courant.pere;\r
+ if p.pere = none\r
+ then\r
+ (* p pointe sur la racine *)\r
+ case p.nb\r
+ when 1 : (* p a 1 fils *)\r
+ courant := p;\r
+ courant.FG := none;\r
+ courant.nb := 0;\r
+ courant.IG := -1;\r
+\r
+ when 2 : (* p a 2 fils *)\r
+ if p.FG.IG = courant.IG\r
+ then\r
+ p.FG := p.FM;\r
+ p.IG := p.FG.IG;\r
+ fi;\r
+ p.FM := none;\r
+ p.nb := p.nb - 1;\r
+ p.IM := -1;\r
+ when 3 : (* p a 3 fils *)\r
+ if p.IG = courant.IG\r
+ then\r
+ p.FG := p.FM;\r
+ p.FM := p.FD;\r
+ p.IG := p.FG.IG;\r
+ p.IM := p.FM.IG;\r
+ else\r
+ if p.FM.IG = courant.IG\r
+ then\r
+ p.FM := p.FD;\r
+ p.IM := p.FM.IG;\r
+ fi;\r
+ fi;\r
+ p.FD := none;\r
+ p.nb := p.nb - 1;\r
+ esac;\r
+ else\r
+ (* p ne pointe pas sur le racine *)\r
+ case p.nb\r
+ when 2 : (* p a 2 fils *)\r
+ pref IIUWgraph block\r
+ begin\r
+ call cls;\r
+ call move(10,10);\r
+ call outstring("-> Le cas ou l'on veut supprimer une feuille");\r
+ call move(10,20);\r
+ call outstring("dont le pere a 2 fils n'a pas ete gere.");\r
+ end;\r
+ \r
+ when 3 : (* p a 3 fils *)\r
+ if p.FG.IG = courant.IG\r
+ then\r
+ p.FG := p.FM;\r
+ p.FM := p.FD;\r
+ p.IG := p.FG.IG;\r
+ p.IM := p.FM.IG;\r
+ else\r
+ if p.FM.IG = courant.IG\r
+ then\r
+ p.FM := p.FD;\r
+ p.IM := p.FM.IG;\r
+ fi;\r
+ fi;\r
+ \r
+ p.FD := none;\r
+ p.nb := p.nb - 1 ;\r
+ esac;\r
+ fi;\r
+ else\r
+ pref IIUWgraph block\r
+ begin\r
+ call move(10,20);\r
+ call outstring("-> On ne peut pas supprimer cet element");\r
+ call move(10,30);\r
+ call outstring("car il n'est pas dans l'arbre");\r
+ end;\r
+ fi;\r
+ b.racine := racine;\r
+ result := b;\r
+ end supprimer;\r
+\r
+ unit inserer : function(v : integer) : barbre;\r
+\r
+ unit refaire : procedure(inout p, f1, f2, j, r : noeud);\r
+ begin\r
+ (* suivant le nombre de fils de p *)\r
+ case p.nb\r
+ when 3 : (* p a 3 fils *)\r
+ if p.FG = f1\r
+ then\r
+ p.FD := p.FM;\r
+ p.FM := j;\r
+ else\r
+ p.FD := j;\r
+ fi;\r
+\r
+ when 4 : (* p a 4 fils *)\r
+ (* et creer un nouveau noeud *)\r
+ j := new noeud;\r
+ if p.FG = f1\r
+ then\r
+ j.FG := p.FM;\r
+ j.FM := p.FD;\r
+ p.FM := f2;\r
+ else\r
+ if p.FM = f1\r
+ then\r
+ j.FG := f2;\r
+ j.FM := p.FD;\r
+ else\r
+ j.FG := f1;\r
+ j.FM := f2;\r
+ fi;\r
+ fi;\r
+ \r
+ j.FG.pere := j;\r
+ j.FM.pere := j;\r
+ j.nb := 2;\r
+ p.FD := none;\r
+ p.nb := 2;\r
+ \r
+ if p.pere =/= none\r
+ then\r
+ (* le pere de p n'est pas la racine *)\r
+ (* il faut repeter la procedure refaire *)\r
+ j.pere := p.pere;\r
+ p.pere.nb := p.pere.nb + 1;\r
+ call refaire(p.pere, p, j, j, r);\r
+ else\r
+ (* le pere de p est la racine *)\r
+ (* donc il faut creer une nouvelle racine *)\r
+ r := new noeud;\r
+ r.nb := 2;\r
+ r.FG := p;\r
+ r.FM := j;\r
+ p.pere := r;\r
+ j.pere := r;\r
+ racine := r;\r
+ fi;\r
+ esac;\r
+ end refaire;\r
+\r
+\r
+ var bidon, courant, i, f1, f2, j, p, r : noeud,\r
+ b : barbre,\r
+ pos : integer;\r
+ begin\r
+ b := new barbre;\r
+\r
+ bidon := new noeud;\r
+ courant := new noeud;\r
+ r := new noeud;\r
+ i:= new noeud;\r
+ f1 := new noeud;\r
+ f2 := new noeud;\r
+ j := new noeud;\r
+ p:= new noeud;\r
+\r
+ if vide\r
+ then\r
+ (* l'arbre est vide *)\r
+ (* creer la feuille qui contiendra l'element a inserer *)\r
+ courant := new noeud;\r
+ courant.pere := racine;\r
+ courant.IG := v;\r
+ racine.IG := v;\r
+ racine.nb := 1;\r
+ racine.FG := courant;\r
+\r
+ b.racine := racine;\r
+ result := b;\r
+\r
+ else\r
+ (* l'arbre n'est pas vide *)\r
+ courant := racine;\r
+ if present(v,courant)\r
+ then\r
+ pref IIUWgraph block\r
+ begin\r
+ call move(10,20);\r
+ call outstring("-> L'element ne peut etre inserer");\r
+ call move(10,30);\r
+ call outstring("puisqu'il appartient deja a l'arbre.");\r
+ end; \r
+ else\r
+ (* l'element n'existe pas dans l'arbre *)\r
+ \r
+ pos := 0;\r
+\r
+ i := new noeud;\r
+ p := new noeud;\r
+ i := courant;\r
+ i.pere := courant.pere;\r
+ p := courant.pere;\r
+\r
+ (* creer le noeud qui contiendra l'element a inserer *)\r
+ courant := new noeud;\r
+ courant.IG := v;\r
+ courant.pere := p;\r
+ p.nb := p.nb + 1;\r
+\r
+ (* determination de la position ou inserer l'element *)\r
+ if i.IG = p.FG.IG\r
+ then\r
+ pos := 1;\r
+ else\r
+ if p.FM =/= none\r
+ then\r
+ if i.IG = p.FM.IG\r
+ then\r
+ pos := 2;\r
+ else\r
+ if p.FD =/= none\r
+ then\r
+ if i.IG = p.FD.IG\r
+ then\r
+ pos := 3;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+ (* suivant le nombre de fils de p *)\r
+ case p.nb\r
+ when 2 : (* p a 2 fils *)\r
+ if courant.IG > i.IG\r
+ then pos := pos + 1;\r
+ fi;\r
+ \r
+ (* suivant la position de l'element *)\r
+ case pos\r
+ when 1 : p.FM := p.FG;\r
+ p.FG := courant;\r
+ when 2 : p.FM := courant;\r
+ esac;\r
+ when 3 : (* p a 3 fils *)\r
+ if courant.IG > i.IG\r
+ then pos := pos + 1;\r
+ fi;\r
+ \r
+ (* suivant la position de l'element *)\r
+ case pos\r
+ when 1 : p.FD := p.FM;\r
+ p.FM := p.FG;\r
+ p.FG := courant;\r
+ when 2 : p.FD := p.FM;\r
+ p.FM := courant;\r
+ when 3 : p.FD := courant;\r
+ esac;\r
+ when 4 : (* p a 4 fils *)\r
+ if courant.IG > i.IG\r
+ then pos := pos + 1;\r
+ fi;\r
+\r
+ f1 := new noeud;\r
+ f2 := new noeud;\r
+ \r
+ (* suivant la position de l'element *)\r
+ case pos\r
+ when 1 : f1 := p.FM;\r
+ f2 := P.FD;\r
+ p.FD := none;\r
+ p.FM := p.FG;\r
+ p.FG := courant;\r
+ (**)\r
+ when 2 : f1 := p.FM;\r
+ f2 := p.FD;\r
+ p.FD := none;\r
+ p.FM := courant;\r
+ (**)\r
+ when 3 : f1 := courant;\r
+ f2 := p.FD;\r
+ p.FD := none;\r
+ (**)\r
+ when 4 : f1 := p.FD;\r
+ f2 := courant;\r
+ p.FD := none;\r
+ (**)\r
+ esac;\r
+\r
+ j := new noeud;\r
+\r
+ j.FG := f1;\r
+ j.FM := f2;\r
+ j.FG.pere := j;\r
+ j.FM.pere := j;\r
+ j.nb := 2;\r
+ p.nb := 2;\r
+\r
+ if p.pere =/= none\r
+ then\r
+ (* p a un pere *)\r
+ (* il faut repeter la procedure refaire *)\r
+ j.pere := p.pere;\r
+ p.pere.nb := p.pere.nb + 1;\r
+ call refaire(p.pere, p, j, j, r);\r
+ else\r
+ (* p est la racine *)\r
+ (* donc il faut creer une nouvelle racine *)\r
+ r := new noeud;\r
+ r.nb := 2;\r
+ r.FG := p;\r
+ r.FM := j;\r
+ p.pere := r;\r
+ j.pere := r;\r
+ racine := r;\r
+ fi;\r
+ esac;\r
+ fi;\r
+\r
+ courant := racine;\r
+ b.racine := courant;\r
+ result := b;\r
+ fi;\r
+ end inserer;\r
+\r
+ begin\r
+ racine := new noeud;\r
+ end barbre;\r
+\r
+\r
+var ba : barbre,\r
+ touche, e : integer,\r
+ bidon, courant, a, b : noeud,\r
+ rep : char,\r
+ choix : integer;\r
+\r
+begin\r
+ ba := new barbre;\r
+ courant := new noeud;\r
+ courant := ba.racine;\r
+ \r
+ pref IIUWgraph block\r
+ begin\r
+ do\r
+ call presentation;\r
+ read(choix);\r
+ call WriteInteger(choix);\r
+ (* selon le choix *)\r
+ case choix\r
+ when 1 : (* inserer un element *)\r
+ rep := 'o';\r
+ do \r
+ if rep = 'o'\r
+ then\r
+ call cls;\r
+ call hpage(0,1,1);\r
+ call move(10,10);\r
+ call outstring("-> Entrez l'element a inserer = ");\r
+ read(e);\r
+ call WriteInteger(e);\r
+ courant := ba.racine;\r
+ ba := ba.inserer(e);\r
+ courant := ba.racine;\r
+ call ba.reorganiser(courant, bidon);\r
+ call reponse(rep);\r
+ else if rep ='n'\r
+ then\r
+ exit;\r
+ else\r
+ call reponse(rep);\r
+ fi;\r
+ fi;\r
+ od;\r
+\r
+\r
+ when 2 : (* supprimer un element *)\r
+ rep := 'o';\r
+ do \r
+ if rep = 'o'\r
+ then\r
+ call cls;\r
+ call hpage(0,1,1);\r
+ if ba.vide\r
+ then\r
+ call move(10,10);\r
+ call outstring("-> Il est impossible de supprimer un element");\r
+ call move(10,20);\r
+ call outstring("dans un arbre vide");\r
+ else\r
+ call move(10,10);\r
+ call outstring("-> Entrez l'element a supprimer = ");\r
+ read(e);\r
+ call WriteInteger(e);\r
+ courant := ba.racine;\r
+ ba := ba.supprimer(e);\r
+ courant := ba.racine;\r
+ call ba.reorganiser(courant,bidon);\r
+ call reponse(rep);\r
+ fi;\r
+ else if rep ='n'\r
+ then\r
+ exit;\r
+ else\r
+ call reponse(rep);\r
+ fi;\r
+ fi;\r
+ od;\r
+\r
+ when 3 : (* determiner si l'element est present dans l'arbre *)\r
+ rep := 'o';\r
+ do \r
+ if rep = 'o'\r
+ then\r
+ call cls;\r
+ call hpage(0,1,1);\r
+ if ba.vide\r
+ then\r
+ call move(10,10);\r
+ call outstring("-> Il est impossible de rechercher un element");\r
+ call move(10,20);\r
+ call outstring("dans un arbre vide");\r
+ else\r
+ call move(10,10);\r
+ call outstring("Entrez l'element = ");\r
+ read(e);\r
+ call WriteInteger(e);\r
+ courant := ba.racine;\r
+ if ba.present(e,courant)\r
+ then\r
+ call move(10,20);\r
+ call outstring("-> L'element est present");\r
+ else\r
+ call move(10,20);\r
+ call outstring("-> L'element est absent");\r
+ fi;\r
+ fi;\r
+ call reponse(rep);\r
+ else if rep ='n'\r
+ then\r
+ exit;\r
+ else\r
+ call reponse(rep);\r
+ fi;\r
+ fi;\r
+ od;\r
+\r
+\r
+ when 4 : (* determiner l'element minimum *)\r
+ call cls;\r
+ call hpage(0,1,1);\r
+ if ba.vide\r
+ then\r
+ call move(10,10);\r
+ call outstring("-> Il est impossible de rechercher le minimum");\r
+ call move(10,20);\r
+ call outstring("dans un arbre vide");\r
+ else\r
+ e := ba.minimum;\r
+ call move(10,10);\r
+ call outstring("-> Le minimum est ");\r
+ call WriteInteger(e);\r
+ fi;\r
+ call move(250,325);\r
+ call outstring("Tapez une touche pour continuer");\r
+ touche := inchar;\r
+\r
+ when 5 : (* determiner l'element maximum *)\r
+ call cls;\r
+ call hpage(0,1,1);\r
+ if ba.vide\r
+ then\r
+ call move(10,10);\r
+ call outstring("-> Il est impossible de rechercher le maximum");\r
+ call move(10,20);\r
+ call outstring("dans un arbre vide");\r
+ else\r
+ e := ba.maximum;\r
+ call move(10,10);\r
+ call outstring("-> Le maximum est ");\r
+ call WriteInteger(e);\r
+ fi;\r
+ call move(250,325);\r
+ call outstring("Tapez une touche pour continuer");\r
+ touche := inchar;\r
+\r
+ when 6 : (* determiner si l'arbre est vide *)\r
+ call cls;\r
+ call hpage(0,1,1);\r
+ call move(10,10);\r
+ if ba.vide then call outstring("-> L'arbre est vide");\r
+ else call outstring("-> L'arbre n'est pas vide");\r
+ fi;\r
+ call move(250,325);\r
+ call outstring("Tapez une touche pour continuer");\r
+ touche := inchar;\r
+\r
+ when 7 : (* affichage de l'arbre *)\r
+ call cls;\r
+ if ba.vide\r
+ then\r
+ call hpage(0,1,1);\r
+ call move(10,10);\r
+ call outstring("L'arbre est vide.");\r
+ else\r
+ courant := ba.racine;\r
+ call ba.afficher(courant);\r
+ fi;\r
+ call move(250,325);\r
+ call outstring("Tapez une touche pour continuer");\r
+ touche := inchar;\r
+\r
+ when 8 : (* fin du programme *)\r
+ call groff;\r
+ exit;\r
+ esac;\r
+ od;\r
+ end;\r
+end mybarbre.\r
+ \r
--- /dev/null
+PROGRAM BICOLORE;\r
+\r
+(* Projet LI1 : Operations sur les arbres bicolores . *)\r
+(* Realise par CHICHER Corinne et DOME Nadege - UPPA 1993/1994 - *)\r
+\r
+\r
+ (* NewPage vide l'ecran en mode texte *)\r
+ UNIT NewPage : PROCEDURE;\r
+ BEGIN\r
+ write( chr(27), "[2J")\r
+ END NewPage;\r
+\r
+ (* SetCursor positionne le curseur aux ligne et colonne indiquees *)\r
+ UNIT SetCursor : PROCEDURE(ligne,colonne:integer);\r
+ VAR c,d,e,f :char,\r
+ i,j :integer;\r
+ BEGIN\r
+ i:=ligne div 10;\r
+ j:=ligne mod 10;\r
+ c:=chr(48+i);\r
+ d:=chr(48+j);\r
+ i:=colonne div 10;\r
+ j:=colonne mod 10;\r
+ e:=chr(48+i);\r
+ f:=chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H");\r
+ END SetCursor;\r
+\r
+\r
+ (* la classe bic definit la structure d'un noeud d'arbre bicolore *)\r
+ UNIT bic : CLASS;\r
+ VAR val:integer, (* val:Valeur de l'element d'un noeud *)\r
+ rouge : boolean, (* rouge:couleur d'un noeud:si vrai alors rouge sinon blanc *) \r
+ fg,fd : bic; (* fg,fd:fils gauche et droit d'un noeud *)\r
+ END bic;\r
+\r
+\r
+ (* inchar saisit un caractere en mode graphique *)\r
+ UNIT inchar : iiuwgraph FUNCTION : integer;\r
+ VAR i:integer;\r
+ BEGIN\r
+ DO \r
+ i:=INKEY;\r
+ if i <> 0 then\r
+ exit\r
+ fi;\r
+ OD;\r
+ result:=i;\r
+ END inchar;\r
+\r
+ (* ReadInteger lit un entier positif a 3 chiffres avec echo a l'ecran *)\r
+ UNIT ReadInteger : iiuwgraph FUNCTION : integer;\r
+ VAR X,Y,i,OrdN : integer,\r
+ Number : arrayof integer;\r
+ BEGIN\r
+ array Number dim( 1 : 4 );\r
+ i:=0;\r
+ X:=InXPos;\r
+ Y:=InYPos;\r
+ DO\r
+ OrdN:=inchar;\r
+ if i=8 or (OrdN < 48 and OrdN > 57) then\r
+ exit\r
+ fi;\r
+ CASE OrdN\r
+ when 48 : i:=i+1;\r
+ Number(i):=0;\r
+ when 49 : i:=i+1;\r
+ Number(i):=1;\r
+ when 50 : i:=i+1;\r
+ Number(i):=2;\r
+ when 51 : i:=i+1;\r
+ Number(i):=3;\r
+ when 52 : i:=i+1;\r
+ Number(i):=4;\r
+ when 53 : i:=i+1;\r
+ Number(i):=5;\r
+ when 54 : i:=i+1;\r
+ Number(i):=6;\r
+ when 55 : i:=i+1;\r
+ Number(i):=7;\r
+ when 56 : i:=i+1;\r
+ Number(i):=8;\r
+ when 57 : i:=i+1;\r
+ Number(i):=9;\r
+ when 8 : if i > 0 then\r
+ Number(i):=0;\r
+ i:=i-1;\r
+ call hascii(0);\r
+ fi;\r
+ when 13 : if i > 0 then\r
+ exit\r
+ fi;\r
+ ESAC;\r
+ if i=1 then\r
+ call Move(X,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(1));\r
+ fi;\r
+ if i=2 then\r
+ call Move(X+8,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(2));\r
+ fi; \r
+ if i=3 then\r
+ call Move(X+16,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(3));\r
+ fi; \r
+ OD;\r
+ if (Number(1) = 0) or (Number(1) = 0 and Number(2) = 0) \r
+ or (Number(1) = 0 and Number(2) = 0 and Number(3) = 0) then\r
+ call Move(X,Y);\r
+ call hascii(0);\r
+ call hascii(48);\r
+ call hascii(0);\r
+ fi;\r
+ if i=1 then\r
+ result:=Number(1);\r
+ else\r
+ if i=2 then\r
+ result:=10 * Number(1) + Number(2);\r
+ else\r
+ result:=100 * Number(1) + 10 * Number(2) + Number(3);\r
+ fi;\r
+ fi;\r
+ kill(Number);\r
+ END ReadInteger;\r
+ \r
+ (* WriteInteger permet d'afficher un entier positif a 3 chiffres a l'ecran *)\r
+ UNIT WriteInteger : iiuwgraph PROCEDURE(Number:integer);\r
+ VAR i,j,k:integer;\r
+ BEGIN\r
+ if Number < 10 then\r
+ call HASCII(0);\r
+ call HASCII(Number+48);\r
+ call HASCII(0);\r
+ else\r
+ if Number < 100 then\r
+ i:=Number div 10;\r
+ j:=Number - i * 10;\r
+ call HASCII(0);\r
+ call HASCII(i+48);\r
+ call HASCII(0);\r
+ call HASCII(j+48);\r
+ else\r
+ i:=Number div 100;\r
+ j:=(Number - i * 100) div 10;\r
+ k:=Number - i * 100 - j * 10;\r
+ call HASCII(0);\r
+ call HASCII(i+48);\r
+ call HASCII(0);\r
+ call HASCII(j+48);\r
+ call HASCII(0);\r
+ call HASCII(k+48);\r
+ fi;\r
+ fi;\r
+ END WriteInteger;\r
+\r
+ (* Mousepos gere la position de la souris a l'endroit ou le bouton gauche *)\r
+ (* a ete presse *)\r
+ UNIT MOUSEPOS : iiuwgraph PROCEDURE(x,y:integer;inout bonclic:boolean;output choix:integer);\r
+ BEGIN\r
+ if (x >= 24) and (x <= 544) then\r
+ if (y >= 80) and (y <= 88) then\r
+ choix:=1;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 96) and (y <= 104) then\r
+ choix:=2;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 112) and (y <= 120) then\r
+ choix:=3;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 128) and (y <= 136) then\r
+ choix:=4;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 144) and (y <=152) then\r
+ choix:=5;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 160) and (y <= 168) then\r
+ choix:=6;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 176) and (y <= 184) then\r
+ choix:=7;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 192) and (y <= 200) then\r
+ choix:=8;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 208) and (y <= 216) then\r
+ choix:=9;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 224) and (y <= 232) then\r
+ call CLS;\r
+ (*call GROFF;*)\r
+ choix:=0;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+ END MOUSEPOS;\r
+\r
+ (* cadre trace un rectangle autour des operations *)\r
+ UNIT cadre : iiuwgraph PROCEDURE(xg,yg,xd,yd:integer);\r
+ BEGIN\r
+ call COLOR(7);\r
+ call MOVE(xg,yg);\r
+ call DRAW(xd,yg);\r
+ call MOVE(xd,yg);\r
+ call DRAW(xd,yd);\r
+ call MOVE(xd,yd);\r
+ call DRAW(xg,yd);\r
+ call MOVE(xg,yd);\r
+ call DRAW(xg,yg);\r
+ END cadre;\r
+\r
+ (* menu propose les traitements pouvant etre realises sur les arbres bicolores *)\r
+ UNIT menu : iiuwgraph FUNCTION : integer;\r
+ VAR i,b,h,v,numop:integer,\r
+ g,d,c,driver,selection:boolean;\r
+ BEGIN\r
+\r
+ pref mouse block\r
+ BEGIN\r
+ call CLS;\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ call COLOR(7);\r
+ call MOVE(184,24);\r
+ call OUTSTRING("OPERATIONS SUR LES ARBRES BICOLORES");\r
+ call COLOR(15);\r
+ call cadre(24,56,544,240);\r
+ call MOVE(64,80);\r
+ call OUTSTRING("Creation d'un arbre bicolore");\r
+ call MOVE(64,96);\r
+ call OUTSTRING("Ajout d'un element");\r
+ call MOVE(64,112);\r
+ call OUTSTRING("Recherche d'un element dans un arbre");\r
+ call MOVE(64,128);\r
+ call OUTSTRING("Recherche du minimum dans un arbre");\r
+ call MOVE(64,144);\r
+ call OUTSTRING("Recherche du maximum dans un arbre");\r
+ call MOVE(64,160);\r
+ call OUTSTRING("Recherche de(s) successeur(s) d'un element de l'arbre");\r
+ call MOVE(64,176);\r
+ call OUTSTRING("Recherche du predecesseur d'un element de l'arbre");\r
+ call MOVE(64,192);\r
+ call OUTSTRING("Suppression de certains noeuds de l'arbre");\r
+ call MOVE(64,208);\r
+ call OUTSTRING("Affichage d'un arbre");\r
+ call MOVE(64,224);\r
+ call OUTSTRING("Quitter l'application");\r
+ call MOVE(24,256);\r
+ call OUTSTRING("Selectionnez l'operation avec le bouton gauche de la souris...");\r
+ \r
+ (* Gestion de la souris *)\r
+ driver:=INIT(b);\r
+ call SETPOSITION(0,0);\r
+ call SHOWCURSOR;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call MOUSEPOS(h,v,selection,numop);\r
+ if not selection then\r
+ g:=false;\r
+ repeat;\r
+ else\r
+ call HIDECURSOR;\r
+ exit\r
+ fi;\r
+ fi;\r
+ OD;\r
+ result:=numop;\r
+ END;\r
+ END menu;\r
+\r
+ (* ajout sert : *)\r
+ (* a creer un bicolore : inserer un element dans un arbre vide *)\r
+ (* a ajouter un element dans un arbre deja cree *)\r
+\r
+ (* ses parametres sont : *)\r
+ (* en entree, l'element a inserer *)\r
+ (* en entree/sortie, la racine de l'arbre et 2 sentinelles *)\r
+ (* un booleen indiquant si au moins un ajout a ete realise *)\r
+\r
+ UNIT ajout : PROCEDURE(x:integer;inout A,T,Z,Q:bic,adj:boolean);\r
+ VAR P,GP,AGP : bic, \r
+ touche:integer;\r
+ (* Pere,grand-pere et arriere grand-pere du pteur courant A *)\r
+ (* Ces pointeurs servent au reequilibrage de l'arbre *)\r
+\r
+ BEGIN\r
+ pref IIUWGRAPH block\r
+ BEGIN\r
+ adj:=false;\r
+ A:=new bic; \r
+ A:=T; (* T:Tete de l'arbre ayant pour valeur 0, pour couleur blanc, *)\r
+ (* pour fils gauche Z et pour fils droit initial Z *) \r
+ Z.val:=x; (* On affecte l'element a inserer au champ val de Z *)\r
+ P:=new bic;\r
+ P:=T;\r
+ GP:=new bic;\r
+ GP:=T;\r
+ AGP:=new bic;\r
+\r
+ DO\r
+ AGP:=GP;\r
+ GP:=P;\r
+ P:=A;\r
+ \r
+ if x < A.val then (* Descente dans l'arbre *)\r
+ A:=A.fg;\r
+ else\r
+ A:=A.fd;\r
+ fi;\r
+ \r
+ if (A.fg.rouge and A.fd.rouge) then\r
+ \r
+ if A = Z then (* Ajout de l'element dand une feuille *)\r
+ adj:=true;\r
+ A:=new bic;\r
+ A.val:=x;\r
+ A.fg:=Z;\r
+ A.fd:=Z; \r
+ A.rouge:=true; (* L'ajout d'un element s'effectue dans une feuille *)\r
+ (* qui devient un noeud rouge *) \r
+ if x < P.val then\r
+ P.fg:=A;\r
+ else\r
+ P.fd:=A;\r
+ fi;\r
+ else\r
+ A.rouge:=true; (* Inversion des couleurs *)\r
+ A.fg.rouge:=false;\r
+ A.fd.rouge:=false;\r
+ fi;\r
+ \r
+ call CLS;\r
+ \r
+ if P.rouge then (* Reequilibrage car 2 noeuds rouges consecutifs*)\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("RESULTAT INTERMEDIAIRE : "); \r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour continuer ...");\r
+ touche:=INCHAR;\r
+ \r
+ (* 8 types de rotation-raccrochage *)\r
+ if P.val > GP.val then (* Rotation gauche ou droite-gauche *)\r
+ if A.val > P.val then\r
+ call rg(GP);\r
+ else\r
+ call rdg(GP);\r
+ fi;\r
+ if GP.val < AGP.val then\r
+ AGP.fg:=GP;\r
+ else\r
+ AGP.fd:=GP;\r
+ fi;\r
+ else\r
+ if A.val < P.val then (* Rotation droite ou gauche-droite *)\r
+ call rd(GP);\r
+ else\r
+ call rgd(GP);\r
+ fi;\r
+ if GP.val < AGP.val then\r
+ AGP.fg:=GP;\r
+ else\r
+ AGP.fd:=GP;\r
+ fi;\r
+ fi;\r
+ (* Retablissement des couleurs apres rotation *)\r
+ GP.rouge:=false;\r
+ GP.fg.rouge:=true;\r
+ GP.fd.rouge:=true;\r
+ (* Retablissement de la hierarchie des ascendants *)\r
+ P:=GP;\r
+ GP:=AGP;\r
+ if x = P.val then\r
+ A:=P; (* A renvoie l'adresse de l'element a inserer dans l'arbre *)\r
+ else\r
+ if x < P.val then\r
+ A:=P.fg;\r
+ else\r
+ A:=P.fd;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ \r
+ if x <> A.val then (* Poursuite de la descente car place *)\r
+ (* nouvel element non trouvee *)\r
+ repeat;\r
+ else\r
+ exit; (* L'ajout de l'element est termine *)\r
+ fi;\r
+ \r
+ OD;\r
+ T.fd.rouge:=false; (* La racine de l'arbre est toujours blanche *)\r
+ END;\r
+ END ajout;\r
+\r
+ (* recherche parcourt l'arbre et indique si l'element a rechercher *)\r
+ (* est present ou absent de l'arbre *)\r
+ (* ses parametres d'entree sont l'element a rechercher , la sentinelle Z1 *)\r
+ (* Tr: noeud contenant l'element recherche et Pr:pere de Tr *)\r
+ \r
+ UNIT recherche : FUNCTION (x:integer,Z1:bic;inout Tr,Pr:bic):boolean;\r
+ BEGIN\r
+ (* Parcours de l'arbre *)\r
+ Tr:=Tr.fd;\r
+ while Tr <> Z1 and not result\r
+ do\r
+ if x = Tr.val then (* On a trouve l'element :recherche terminee positivement *)\r
+ result:=true\r
+ else (* On continue la recherche *)\r
+ if x < Tr.val then (* a gauche *)\r
+ Pr:=Tr;\r
+ Tr:=Tr.fg;\r
+ else\r
+ if x > Tr.val then (* a droite *)\r
+ Pr:=Tr;\r
+ Tr:=Tr.fd;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ END recherche;\r
+ \r
+ (* Suppression supprime un certain type de noeud de l'arbre *)\r
+ (* Ses parametres d'entree sont l'element a supprimer, la sentinelle Z1 *)\r
+ (* Tr: noeud contenant l'element a supprimer et Pr:pere de Tr *)\r
+\r
+ UNIT suppression :PROCEDURE(x:integer,Z1:bic;inout T,Tr,Pr:bic,adj:boolean);\r
+ BEGIN\r
+ pref IIUWGRAPH block\r
+ BEGIN\r
+ if Tr.fg = Z1 and Tr.fd = Z1 then (*Si c'est un noeud sans fils *)\r
+ if Tr = T.fd then (* Si le noeud a supprimer est la racine *)\r
+ kill(Tr);\r
+ kill(T);\r
+ adj:=false; (* L'arbre devient donc vide *)\r
+ else\r
+ if Tr.val < Pr.val then\r
+ Pr.fg:=Z1;\r
+ else\r
+ Pr.fd:=Z1;\r
+ fi;\r
+ fi;\r
+ else\r
+ if Tr.fg <> Z1 and Tr.fd=Z1 then (* Si c'est un noeud qui a un fils gauche *)\r
+ (* Alors on remplace ce noeud par son fils*)\r
+ if Tr=Pr.fd then \r
+ Pr.fd:=Tr.fg;\r
+ Pr.fd.rouge:=false;\r
+ kill(Tr);\r
+ else\r
+ if Tr.val < Pr.val then\r
+ Pr.fg:=Tr.fg;\r
+ Pr.fg.rouge:=false;\r
+ kill(Tr);\r
+ else\r
+ Pr.fd:=Tr.fg;\r
+ Pr.fd.rouge:=false;\r
+ kill(Tr);\r
+ fi;\r
+ fi;\r
+ else (* Si c'est un noeud qui a un fils droit *)\r
+ (* Alors on remplace ce noeud par son fils*) \r
+ if Tr.fg = Z1 and Tr.fd <> Z1 then\r
+ if Tr=Pr.fd then\r
+ Pr.fd:=Tr.fd;\r
+ Pr.fd.rouge:=false;\r
+ kill(Tr);\r
+ else\r
+ if Tr.val < Pr.val then\r
+ Pr.fg:=Tr.fd;\r
+ Pr.fg.rouge:=false;\r
+ kill(Tr);\r
+ else\r
+ Pr.fd:=Tr.fd;\r
+ Pr.fd.rouge:=false;\r
+ kill(Tr);\r
+ fi;\r
+ fi;\r
+ else (* Si c'est un noeud qui a deux fils *)\r
+ (* Alors on remplace ce noeud par celui*)\r
+ (* qui lui est inferieur *)\r
+ if (Tr.fg.fg=Z1 and Tr.fg.fd=Z1) and (Tr.fd.fg=Z1 and Tr.fd.fd=Z1) then\r
+ if Tr.val > Pr.val then\r
+ Pr.fd:=Tr.fg;\r
+ else\r
+ Pr.fg:=Tr.fg;\r
+ fi;\r
+ Pr.fd.rouge:=false;\r
+ Pr.fd.fd:=Tr.fd;\r
+ kill(Tr);\r
+ else (*Cas non traite: Le noeud a supprimer a des petits fils *)\r
+ call MOVE (40,160);\r
+ call OUTSTRING("Il est impossible de supprimer ce genre de noeuds...");\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour verification ...");\r
+ touche:=INCHAR; \r
+ \r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ END; \r
+ END suppression;\r
+\r
+ (* rd effectue une rotation a droite de l'arbre *)\r
+ UNIT rd : PROCEDURE(inout GP:bic);\r
+ VAR aux:bic;\r
+ BEGIN\r
+ aux:=new bic;\r
+ aux:=GP.fg;\r
+ GP.fg:=aux.fd;\r
+ aux.fd:=GP;\r
+ GP:=aux;\r
+ END rd;\r
+\r
+ (* rg effectue une rotation a gauche de l'arbre *)\r
+ UNIT rg : PROCEDURE(inout GP:bic);\r
+ VAR aux:bic;\r
+ BEGIN\r
+ aux:=new bic;\r
+ aux:=GP.fd;\r
+ GP.fd:=aux.fg;\r
+ aux.fg:=GP;\r
+ GP:=aux;\r
+ END rg;\r
+\r
+ (* rdg effectue une rotation droite-gauche de l'arbre *)\r
+ UNIT rdg : PROCEDURE(inout GP:bic);\r
+ BEGIN\r
+ call rd(GP.fd);\r
+ call rg(GP);\r
+ END rdg;\r
+ \r
+ (* rgd effectue une rotation gauche-droite de l'arbre *)\r
+ UNIT rgd : PROCEDURE(inout GP:bic);\r
+ BEGIN\r
+ call rg(GP.fg);\r
+ call rd(GP);\r
+ END rgd;\r
+\r
+ (* minmax renvoie le minimum ou le maximum de l'arbre *)\r
+ (* ses parametres d'entree sont l'arbre, la sentinelle, et le type de recherche *)\r
+ UNIT minmax : FUNCTION(N,Z1:bic,choix:integer) : integer;\r
+ VAR S:bic; (* Noeud contenant la valeur a renvoyer *)\r
+ BEGIN\r
+ (* Si on recherche le minimum (choix=0) on descend le plus a gauche possible *)\r
+ (* Si on recherche le maximum (choix=1) on descend le plus a droite possible *)\r
+ S:=new bic;\r
+ N:=N.fd;\r
+ if choix=0 then\r
+ while N <> Z1\r
+ do \r
+ S:=N;\r
+ N:=N.fg;\r
+ od;\r
+ fi;\r
+ if choix=1 then\r
+ while N <> Z1\r
+ do\r
+ S:=N;\r
+ N:=N.fd;\r
+ od;\r
+ fi;\r
+ result:=S.val;\r
+ END minmax;\r
+ \r
+ (* affpreordre affiche l'arbre dans un ordre prefixe *)\r
+ UNIT affpreordre : PROCEDURE(N,Z1:bic,coefm,sup,inf:real,niveau:integer);\r
+ VAR posx:real,posy,i,j:integer;\r
+ BEGIN\r
+ pref iiuwgraph BLOCK\r
+ BEGIN\r
+ if N <> Z1 then\r
+ niveau:=niveau+1;\r
+ posx:=(coefm * (sup - inf)) + inf;\r
+ posy:= niveau * 35;\r
+ if niveau <> 1 then\r
+ call DRAW(posx*640 , posy);\r
+ fi;\r
+ if N.rouge then\r
+ call COLOR(12);\r
+ else\r
+ call COLOR(15);\r
+ fi;\r
+ call MOVE(round(posx * 640),posy);\r
+ call HASCII(0);\r
+ call WriteInteger(N.val);\r
+ call MOVE(INXPOS + 4,INYPOS);\r
+ call COLOR(3);\r
+ call MOVE(INXPOS-20,INYPOS);\r
+ call affpreordre(N.fg,Z1,0.5,posx,inf,niveau);\r
+ call MOVE(ROUND(posx * 640) + 8 , posy + 8);\r
+ call affpreordre(N.fd,Z1,0.5,sup,posx,niveau);\r
+ call MOVE(ROUND(posx * 640) + 8,posy + 8);\r
+ fi;\r
+ END;\r
+ END affpreordre;\r
+\r
+ (* menage:permet la destruction de l'objet passe en parametre *)\r
+ UNIT menage : PROCEDURE(inout Z,N:bic);\r
+ BEGIN\r
+ if N.fg <> Z then\r
+ call menage(Z,N.fg);\r
+ kill(N.fg);\r
+ fi;\r
+ if N.fd <> Z then\r
+ call menage(Z,N.fd);\r
+ kill(N.fd);\r
+ fi;\r
+ END menage;\r
+ \r
+ (* PROGRAMME PRINCIPAL *)\r
+\r
+ VAR rep,elt,interm:integer, (* rep:choix de l'operation a realiser *)\r
+ (* elt:Element entre par l'utilisateur *)\r
+ (* interm:reponse aux questions posees *)\r
+ AA,ZZ,QQ,TT,Taff,Trech,Prech:bic,\r
+ (* AA:pointeur sur le noeud courant *)\r
+ (* ZZ:sentinelle sur laquelle on fait pointer tous *)\r
+ (* les liens qui sont a NONE *)\r
+ (* QQ:sentinelle pointee par ZZ et dont les liens *)\r
+ (* sont a NONE *)\r
+ (* TT:Tete de l'arbre dont le fils droit va pointer*)\r
+ (* sur le premier noeud de l'arbre *)\r
+ touche:integer,\r
+ adjonc:boolean;\r
+ \r
+ BEGIN\r
+ pref IIUWGRAPH block\r
+ BEGIN\r
+\r
+ call GRON(5);\r
+ adjonc:=false;\r
+ \r
+ DO\r
+ call COLOR(3);\r
+ call BORDER(1);\r
+ call CLS;\r
+ rep:=menu; (* Recuperation du choix de l'utilisateur *)\r
+ call BORDER(3);\r
+ CASE rep\r
+ \r
+ when 0: (* Pour quitter l'application *)\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call GROFF;\r
+ call NewPage;\r
+ call Setcursor(5,20);\r
+ writeln("**********TERMINE**********");\r
+ call ENDRUN; (*Sortie de l'application*)\r
+\r
+ when 1: call CLS; (* pour creer un arbre *)\r
+ if adjonc then\r
+ call COLOR(3);\r
+ call MOVE(40,40);\r
+ call OUTSTRING("ATTENTION ! : L'arbre precedemment cree va etre efface");\r
+ call COLOR(3);\r
+ call MOVE(40,56);\r
+ call OUTSTRING("Voulez-vous toujours creer un arbre ? Si oui, tapez 1 : "); \r
+ interm:=ReadInteger;\r
+ if interm <> 1 then\r
+ repeat;\r
+ else\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ fi; \r
+ (* creation et initialisation du pointeur courant et des 2 sentinnelles *)\r
+\r
+ AA:=new bic;\r
+ ZZ:=new bic;\r
+ ZZ.rouge:=false;\r
+ ZZ.fg:=new bic;\r
+ ZZ.fd:=new bic;\r
+\r
+ QQ:=new bic;\r
+ QQ.rouge:=true;\r
+ QQ.fg:=new bic;\r
+ QQ.fd:=new bic;\r
+ QQ.fg:=NONE;\r
+ QQ.fd:=NONE;\r
+\r
+ ZZ.fg:=QQ;\r
+ ZZ.fd:=QQ;\r
+\r
+ (* creation et initialisation de la tete de l'arbre *)\r
+ TT:=new bic;\r
+ TT.rouge:=false;\r
+ TT.fg:=new bic;\r
+ TT.fd:=new bic;\r
+ TT.fg:=ZZ;\r
+ TT.fd:=ZZ;\r
+ \r
+ Trech:=new bic;\r
+ Prech:=new bic;\r
+ Taff:=new bic;\r
+ adjonc:=false;\r
+\r
+ call COLOR(3);\r
+ call MOVE(192,16);\r
+ call OUTSTRING("CREATION D'UN ARBRE BICOLORE");\r
+ call MOVE(40,88);\r
+ call OUTSTRING("Entrez le premier element de l'arbre :");\r
+ call MOVE(360,88);\r
+ elt:=ReadInteger;\r
+\r
+ (* On va inserer elt dans l'arbre *) \r
+ call ajout(elt,AA,TT,ZZ,QQ,adjonc);\r
+ repeat;\r
+\r
+ when 2 : call CLS; (* pour ajouter un element dans l'arbre *)\r
+ if adjonc then\r
+ call COLOR(3);\r
+ call MOVE(152,16);\r
+ call OUTSTRING("AJOUT D'UN ELEMENT DANS UN ARBRE BICOLORE");\r
+ call MOVE(40,88);\r
+ call OUTSTRING("Entrez l'element a inserer dans l'arbre :");\r
+ call MOVE(376,88);\r
+ elt:=ReadInteger;\r
+\r
+ (* Test de presence de l'element dans l'arbre *)\r
+ Trech:=TT;\r
+ if recherche(elt,ZZ,Trech,Prech) then \r
+ call COLOR(3);\r
+ call MOVE(160,120);\r
+ call OUTSTRING("ATTENTION ! AJOUT IMPOSSIBLE !!!");\r
+ call MOVE(40,136);\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est deja present dans l'arbre ! ");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION");\r
+ \r
+ (* Affichage de l'arbre *)\r
+ Taff:=TT.fd;\r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ else\r
+ call ajout(elt,AA,TT,ZZ,QQ,adjonc);\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("RESULTAT : "); \r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR; \r
+ fi;\r
+ repeat;\r
+ else\r
+ call MOVE(350,40);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,64);\r
+ call OUTSTRING("Ajout impossible car arbre inexistant !");\r
+ call MOVE(40,80);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(488,80);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ CALL GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+\r
+ when 3 : call CLS; (* pour chercher un element dans l'arbre *)\r
+ if adjonc then\r
+ call COLOR(3);\r
+ call MOVE(128,16);\r
+ call OUTSTRING("RECHERCHE D'UN ELEMENT DANS UN ARBRE BICOLORE");\r
+ call MOVE(40,88);\r
+ call OUTSTRING("Entrez l'element a rechercher dans l'arbre :");\r
+ call MOVE(400,88);\r
+ elt:=ReadInteger;\r
+ Trech:=TT;\r
+ if not recherche(elt,ZZ,Trech,Prech) then\r
+ call CLS;\r
+ call MOVE(40,136);\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est absent de l'arbre !!");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION");\r
+ Taff:=TT.fd;\r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ else\r
+ call MOVE(40,136);\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est present dans l'arbre");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION : "); \r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR; \r
+ fi;\r
+ repeat;\r
+ else\r
+ call MOVE(160,120);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,136);\r
+ call OUTSTRING("Recherche impossible car arbre inexistant !");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(496,152);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+ \r
+ when 4 : call CLS; (* pour trouver le minimum de l'arbre *)\r
+ if adjonc then\r
+ call MOVE(128,16);\r
+ call OUTSTRING("RECHERCHE DU MINIMUM DANS UN ARBRE BICOLORE");\r
+ call MOVE(40,136);\r
+ call OUTSTRING("Voici le minimum de l'arbre bicolore :");\r
+ call MOVE(360,136);\r
+ call WriteInteger(minmax(TT,ZZ,0));\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ repeat;\r
+ else\r
+ call MOVE(160,120);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,144);\r
+ call OUTSTRING("Recherche du minimum impossible car arbre inexistant !");\r
+ call MOVE(40,160);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(488,160);\r
+ interm:=ReadInteger; \r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+\r
+ when 5 : call CLS; (* pour trouver le maximum de l'arbre *)\r
+ if adjonc then\r
+ call MOVE(128,16);\r
+ call OUTSTRING("RECHERCHE DU MAXIMUM DANS UN ARBRE BICOLORE");\r
+ call MOVE(40,136);\r
+ call OUTSTRING("Voici le maximum de l'arbre bicolore :");\r
+ call MOVE(360,136);\r
+ call WriteInteger(minmax(TT,ZZ,1));\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ repeat;\r
+ else\r
+ call MOVE(24,40);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,40);\r
+ call OUTSTRING("Recherche du maximum impossible car arbre inexistant !");\r
+ call MOVE(56,40);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(56,488);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+\r
+ when 6 : call CLS; (* pour chercher le(s) successeur(s) d'un element*)\r
+ if adjonc then \r
+ call COLOR(3);\r
+ call MOVE(136,16);\r
+ call OUTSTRING("RECHERCHE DE(S) SUCCESSEUR(S) D'UN ELEMENT");\r
+ call MOVE(40,88);\r
+ call OUTSTRING("Entrez l'element dont vous voulez le(s) successeur(s) :");\r
+ call MOVE(496,88);\r
+ elt:=ReadInteger;\r
+ Trech:=TT;\r
+ if not recherche(elt,ZZ,Trech,Prech) then\r
+ call CLS;\r
+ call MOVE(40,136);\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est absent de l'arbre !!");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION : ");\r
+ Taff:=TT.fd;\r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ else\r
+ call CLS;\r
+ call MOVE(40,40);\r
+ if Trech.fg <> ZZ and Trech.fd <> ZZ then\r
+ call OUTSTRING("Le(s) successeurs de ");\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" sont : ");\r
+ call WriteInteger(Trech.fg.val);\r
+ call OUTSTRING(" et ");\r
+ call WriteInteger(Trech.fd.val);\r
+ else\r
+ if Trech.fg <> ZZ then\r
+ call OUTSTRING("Le successeur gauche de ");\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est : ");\r
+ call WriteInteger(Trech.fg.val);\r
+ else\r
+ if Trech.fd <> ZZ then\r
+ call OUTSTRING("Le successeur droit de ");\r
+ call WriteInteger(elt);\r
+ call OUTSTRING("est : ");\r
+ call WriteInteger(Trech.fd.val);\r
+ else\r
+ call OUTSTRING("L'element ");\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" n'a aucun successeur !");\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call BORDER(1);\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(112,16);\r
+ call OUTSTRING("VERIFICATION : "); \r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR; \r
+ fi;\r
+ repeat;\r
+ else\r
+ call COLOR(3);\r
+ call MOVE(350,40);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,64); \r
+ call OUTSTRING("Recherche impossible car arbre inexistant !");\r
+ call MOVE(40,80);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(488,80);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+ \r
+ \r
+ when 7 : call CLS; (* pour chercher le predecesseur d'un element*)\r
+ if adjonc then\r
+ call COLOR(3);\r
+ call MOVE(136,16);\r
+ call OUTSTRING("RECHERCHE DU PREDECESSEUR D'UN ELEMENT");\r
+ call MOVE(40,88);\r
+ call OUTSTRING("Entrez l'element dont vous voulez le predecesseur :");\r
+ call MOVE(456,88);\r
+ elt:=ReadInteger;\r
+ Trech:=TT;\r
+ if not recherche(elt,ZZ,Trech,Prech) then\r
+ call CLS;\r
+ call MOVE(40,136);\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est absent de l'arbre !!");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION : ");\r
+ Taff:=TT.fd;\r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ repeat;\r
+ else\r
+ call CLS;\r
+ call MOVE(40,40);\r
+ if Trech = TT.fd then\r
+ call OUTSTRING("L'element ");\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" n'a pas de predecesseur ! ");\r
+ else\r
+ call OUTSTRING("Le predecesseur de ");\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est : ");\r
+ call WriteInteger(Prech.val);\r
+ fi;\r
+ fi;\r
+ call BORDER(1);\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ call CLS;\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION : "); \r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR; \r
+ repeat;\r
+ \r
+ else\r
+ call COLOR(3);\r
+ call MOVE(350,40);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,64);\r
+ call OUTSTRING("Recherche impossible car arbre inexistant !");\r
+ call MOVE(40,80);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(488,80);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+ \r
+ when 8 : call CLS; (* pour supprimer un element*)\r
+ if adjonc then\r
+ call MOVE(152,16);\r
+ call OUTSTRING("SUPPRESSION D'UN ELEMENT");\r
+ call MOVE(40,88);\r
+ call OUTSTRING("Entrez l'element a supprimer :");\r
+ call MOVE(280,88);\r
+ elt:=ReadInteger;\r
+ Trech:=TT;\r
+ Prech:=TT;\r
+ if not recherche(elt,ZZ,Trech,Prech) then\r
+ call CLS;\r
+ call MOVE(40,136);\r
+ call WriteInteger(elt);\r
+ call OUTSTRING(" est absent de l'arbre donc suppression impossible !!");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Tapez sur une touche pour verification...");\r
+ touche:=INCHAR;\r
+ else\r
+ call suppression(elt,ZZ,TT,Trech,Prech,adjonc);\r
+ if not adjonc then\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ call CLS;\r
+ call MOVE(350,40);\r
+ call OUTSTRING("Arbre detruit !!!");\r
+ call MOVE(40,200);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR;\r
+ repeat;\r
+ fi;\r
+ fi;\r
+ call CLS;\r
+ call BORDER(1);\r
+ call MOVE(88,16);\r
+ call OUTSTRING("VERIFICATION "); \r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ call MOVE(40,300);\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR; \r
+ repeat;\r
+ else\r
+ call MOVE(350,40);\r
+ call OUTSTRING("ATTENTION !");\r
+ call MOVE(40,64);\r
+ call OUTSTRING("Suppression impossible car arbre inexistant !");\r
+ call MOVE(40,80);\r
+ call OUTSTRING("Retour au menu pour creer un arbre ? Si oui, tapez 1 : ");\r
+ call MOVE(488,80);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,160);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ fi;\r
+ \r
+ when 9 : call CLS; (* pour afficher le contenu de l'arbre *)\r
+ call BORDER(1);\r
+ call COLOR(3);\r
+ call MOVE(192,16);\r
+ if adjonc then\r
+ call OUTSTRING("AFFICHAGE DE L'ARBRE BICOLORE");\r
+ call MOVE(180,32);\r
+ Taff:=TT.fd; \r
+ call affpreordre(Taff,ZZ,0.5,1,0,0);\r
+ else\r
+ call OUTSTRING("ARBRE VIDE !!!!");\r
+ fi;\r
+ call MOVE(40,300);\r
+ (*call COLOR(7);*)\r
+ call OUTSTRING("Tapez sur une touche pour retourner au menu ...");\r
+ touche:=INCHAR; \r
+ repeat;\r
+\r
+ otherwise\r
+ call CLS; (* gestion des operations inexistantes *)\r
+ call MOVE(350,40);\r
+ call OUTSTRING("Option inexistante !!");\r
+ call MOVE(40,152);\r
+ call OUTSTRING("Voulez-vous retourner au menu ? Si oui, tapez 1 : ");\r
+ call MOVE(440,152);\r
+ interm:=ReadInteger;\r
+ if interm=1 then\r
+ repeat;\r
+ else\r
+ if adjonc then\r
+ call menage(ZZ,TT); (*Destruction de l'arbre*)\r
+ kill(TT);\r
+ kill(ZZ);\r
+ kill(QQ);\r
+ fi;\r
+ call MOVE(160,1600);\r
+ call OUTSTRING("**********TERMINE**********");\r
+ call GROFF;\r
+ call ENDRUN;\r
+ fi;\r
+ ESAC; \r
+ OD;\r
+ END;\r
+END BICOLORE. \r
+ \r
+\r
+\r
+\r
+ \r
--- /dev/null
+program projet1;\r
+\r
+begin\r
+pref iiuwgraph block\r
+\r
+unit bst2 : class;\r
+ var racine : noeud;\r
+\r
+ unit noeud : class(x,y : integer);\r
+ var gauche,droite : noeud;\r
+ end noeud;\r
+\r
+ unit liste : class(x,y: integer);\r
+ var suiv,pred : liste;\r
+ end liste;\r
+\r
+ unit insert : procedure(x,y : integer);\r
+ var d,td : boolean;\r
+ var t,tt : noeud;\r
+ begin\r
+ d:=false;\r
+ tt,t:=racine;\r
+ while (t<>none)\r
+ do\r
+ if d then td:=x<t.x;\r
+ else td:=y<t.y; fi;\r
+ tt:=t;\r
+ if td then t:=t.gauche; else t:=t.droite; fi;\r
+ d:=not d;\r
+ od;\r
+ if racine<>none then\r
+ t:=new noeud(x,y);\r
+ if td then tt.gauche:=t; else tt.droite:=t; fi;\r
+ else racine:=new noeud(x,y);\r
+ fi;\r
+ end insert;\r
+\r
+ unit mb : function (x,y : integer) : boolean;\r
+ var d,td : boolean;\r
+ var t : noeud;\r
+ begin\r
+ d:=false;\r
+ t:=racine;\r
+ while (t<>none)\r
+ do\r
+ if ((t.x=x) and (t.y=y)) then exit; fi;\r
+ if d then td:=x<t.x;\r
+ else td:=y<t.y; fi;\r
+ if td then t:=t.gauche; else t:=t.droite; fi;\r
+ d:=not d;\r
+ od; if (t<>none) then result:=true; else result:=false; fi;\r
+ end mb;\r
+\r
+ unit twodrange : procedure (t : noeud; x1,y1,x2,y2 : integer;\r
+ d : boolean; inout l:liste);\r
+ var t1,t2,tx1,tx2,ty1,ty2 : boolean;\r
+ begin\r
+ if t<>none then\r
+ tx1:=x1<t.x; tx2:=t.x<x2;\r
+ ty1:=y1<t.y; ty2:=t.y<y2;\r
+ if d then\r
+ t1:=tx1; t2:=tx2;\r
+ else\r
+ t1:=ty1; t2:=ty2;\r
+ fi;\r
+ if t1 then call twodrange(t.gauche,x1,y1,x2,y2,(not d),l);fi;\r
+ if (x1<t.x) and (t.x<x2) and (y1<t.y) and (t.y<y2) then\r
+ if l<>none then\r
+ l.suiv:=new liste(t.x,t.y);\r
+ l.suiv.pred:=l;\r
+ l:=l.suiv;\r
+ else\r
+ l:=new liste(t.x,t.y);\r
+ fi;\r
+ else ;\r
+ fi;\r
+ if t2 then call twodrange (t.droite,x1,y1,x2,y2,(not d),l);fi;\r
+ fi;\r
+ end twodrange;\r
+\r
+ unit delete : procedure (x,y : integer);\r
+ var d,td : boolean;\r
+ var t,tt,pb : noeud;\r
+ var test : boolean;\r
+\r
+ unit sousmaxi : procedure(t : noeud;surx,click : boolean;\r
+ inout dsort : boolean; inout n : noeud);\r
+ begin\r
+ if t<>none then\r
+ if surx then\r
+ if t.x>=n.x then n:=t;\r
+ dsort:=click;\r
+ fi;\r
+ else\r
+ if t.y>=n.y then n:=t;\r
+ dsort:=click;\r
+ fi;\r
+ fi;\r
+ call sousmaxi(t.gauche,surx,not(click),dsort,n);\r
+ call sousmaxi(t.droite,surx,not(click),dsort,n);\r
+ fi;\r
+ end sousmaxi;\r
+\r
+ unit sousmini : procedure(t : noeud;surx,click : boolean;\r
+ inout dsort : boolean;inout n : noeud);\r
+ begin\r
+ if t<>none then\r
+ if surx then\r
+ if t.x<=n.x then n:=t;\r
+ dsort:=click;\r
+ fi;\r
+ else\r
+ if t.y<=n.y then n:=t;\r
+ dsort:=click;\r
+ fi;\r
+ fi;\r
+ call sousmini(t.gauche,surx,not(click),dsort,n);\r
+ call sousmini(t.droite,surx,not(click),dsort,n);\r
+ fi;\r
+ end sousmini;\r
+\r
+ unit delpartiel : procedure(t : noeud;surx : boolean);\r
+ var n : noeud;\r
+ var dn : boolean;\r
+ begin\r
+ if (t.gauche=none) and (t.droite=none) then\r
+ kill(t);\r
+ else\r
+ if t.gauche<>none then\r
+ n:=t.gauche;\r
+ call sousmaxi(t.gauche,surx,not(surx),dn,n);\r
+ t.x:=n.x; t.y:=n.y;\r
+ call delpartiel(n,dn);\r
+ else\r
+ n:=t.droite;\r
+ call sousmini(t.droite,surx,not(surx),dn,n);\r
+ t.x:=n.x; t.y:=n.y;\r
+ call delpartiel(n,dn);\r
+ fi;\r
+ fi;\r
+ end delpartiel;\r
+\r
+\r
+ begin\r
+ d:=false;\r
+ t:=racine;\r
+ while (t<>none)\r
+ do\r
+ if ((t.x=x) and (t.y=y)) then exit; fi;\r
+ if d then td:=x<t.x;\r
+ else td:=y<t.y; fi;\r
+ if td then t:=t.gauche; else t:=t.droite; fi;\r
+ d:=not d;\r
+ od;\r
+ if t=none then\r
+ exit;\r
+ fi;\r
+ call delpartiel(t,d);\r
+ end delete;\r
+\r
+ unit killall : procedure(inout t : noeud);\r
+ begin\r
+ if t<>none then\r
+ call killall(t.gauche);\r
+ call killall(t.droite);\r
+ kill(t);\r
+ fi;\r
+ end killall;\r
+\r
+\r
+ unit cadre : procedure( t : noeud;\r
+ inout minx,maxx,miny,maxy : integer);\r
+ begin\r
+ if t<>none then\r
+ if t<>racine then\r
+ if t.x<minx then minx:=t.x; fi;\r
+ if t.x>maxx then maxx:=t.x; fi;\r
+ if t.y>maxy then maxy:=t.y; fi;\r
+ if t.y<miny then miny:=t.y; fi;\r
+ else\r
+ minx,maxx:=t.x;\r
+ miny,maxy:=t.y;\r
+ fi;\r
+ call cadre(t.gauche,minx,maxx,miny,maxy);\r
+ call cadre(t.droite,minx,maxx,miny,maxy);\r
+ fi;\r
+ end cadre;\r
+\r
+ \r
+\r
+end bst2;\r
+\r
+(****************************************************************************)\r
+(********* PROGRAMME PRINCIPAL ***********)\r
+begin\r
+pref bst2 block\r
+\r
+\r
+var arbre : bst2;\r
+var x,y,x1,y1,x2,y2,z,n,p : integer;\r
+var choix : char;\r
+var test : boolean;\r
+var ax,b,cx,d : real;\r
+var lespoints,ll : liste;\r
+\r
+const maxx=639;\r
+const maxy=349;\r
+const bordure=10;\r
+\r
+\r
+unit SetCursor : procedure(column, row : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+\r
+unit writexy : procedure(x,y : integer; chaine : string);\r
+begin\r
+ call setcursor(x,y);\r
+ writeln(chaine);\r
+end;\r
+\r
+\r
+unit outtextxy : procedure (val,x,y : integer);\r
+ var c : integer;\r
+ var compt : integer;\r
+ var aux : integer;\r
+ var test : boolean;\r
+ var negatif : boolean;\r
+begin\r
+ \r
+ c:=1000;\r
+ compt:=4;\r
+ if (val<0) then\r
+ negatif:=true;\r
+ val:=-val;\r
+ else\r
+ negatif:=false;\r
+ fi;\r
+\r
+ do\r
+ aux:=entier(val/c);\r
+ if aux=0 then\r
+ compt:=compt-1;\r
+ c:=c/10;\r
+ else\r
+ exit;\r
+ fi;\r
+ if aux<>0 or c<=1 then exit; fi;\r
+ od;\r
+ if negatif then compt:=compt+1; fi;\r
+ call move(x+(4-compt)*8,y);\r
+ if negatif then call hascii(45); fi;\r
+ do\r
+ aux:=entier(val/c);\r
+ call hascii(48+aux);\r
+ val:=val-aux*c;\r
+ c:=c/10;\r
+ if c<1 then exit; fi;\r
+ od;\r
+end outtextxy;\r
+\r
+unit imprimegraphe : procedure (t : noeud);\r
+ unit chaine : class(x,y: integer);\r
+ var last,next : chaine;\r
+ end chaine;\r
+var r : noeud;\r
+var et,c : integer;\r
+var d,td,dd : boolean;\r
+var suite : boolean;\r
+var tt : noeud;\r
+var p : chaine;\r
+const cleft =-75;\r
+const cright =-77;\r
+const cup =-72;\r
+\r
+ unit boite : procedure(cx,cy:integer);\r
+ begin\r
+ call move(cx-34,cy-10);\r
+ call draw(cx+42,cy-10);\r
+ call draw(cx+42,cy+10);\r
+ call draw(cx-34,cy+10);\r
+ call draw(cx-34,cy-10);\r
+ call move(cx+4,cy);\r
+ call draw(cx+4,cy+10);\r
+ end boite;\r
+\r
+ unit imprimepartiel : procedure (t : noeud; cx,cy,px,py,c: integer;\r
+ inout suite : boolean;d : boolean);\r
+ var a : integer;\r
+ begin\r
+ if t<>none then\r
+ if (c=3 and (t.gauche<>none or t.droite<>none))\r
+ then suite:=true;\r
+ fi;\r
+ call boite(cx,cy);\r
+ if c<>0 then call move(px+4,py+10);call draw(cx+4,cy-10);fi;\r
+ call outtextxy(t.x,cx-32,cy);\r
+ if d then call move(cx,cy-8);call hascii(72);\r
+ else call move(cx,cy-8);call hascii(86); fi;\r
+ call outtextxy(t.y,cx+8,cy);\r
+ if c<3 then\r
+ a:=entier(40*8/exp(ln(2)*(c+1)));\r
+ call imprimepartiel(t.gauche,cx-a,cy+80,cx,cy,c+1,suite,not d);\r
+ call imprimepartiel(t.droite,cx+a,cy+80,cx,cy,c+1,suite,not d);\r
+ if suite then call move(200,300);\r
+ call outstring("Appuyer sur une fleche pour la suite");\r
+ fi;\r
+ fi;\r
+\r
+ fi;\r
+ end imprimepartiel;\r
+\r
+ Begin\r
+ if t<>none then\r
+ r:=t;\r
+ p:=new chaine(t.x,t.y);\r
+ kill(p.last);\r
+ call gron(nocard);\r
+ dd:=false;\r
+ do\r
+ et:=0;\r
+ suite:=false;\r
+ call imprimepartiel(r,314,10,-1,-1,et,suite,dd);\r
+ call move(60,320);\r
+ call outstring\r
+ ("<- ou 4:Branche gauche; -> ou 6:Branche droite;");\r
+ call outstring("³ ou 8:Pere; <Ù:Menu;");\r
+ call move(435,318);\r
+ call hascii(94);\r
+ c:=readkey;\r
+ call cls;\r
+ case c\r
+ when 52 : c:=cleft;\r
+ when 54 : c:=cright;\r
+ when 56 : c:=cup;\r
+ esac;\r
+ case c\r
+ when cleft : if r.gauche<>none then\r
+ r:=r.gauche;\r
+ p.next:=new chaine(r.x,r.y);\r
+ p.next.last:=p;\r
+ p:=p.next;\r
+ dd:=not dd;\r
+ fi;\r
+ when cright : if r.droite<>none then\r
+ r:=r.droite;\r
+ p.next:=new chaine(r.x,r.y);\r
+ p.next.last:=p;\r
+ p:=p.next;\r
+ dd:=not dd;\r
+ fi;\r
+ when cup : if p.last<>none then\r
+ dd:=not dd;\r
+ x:=p.last.x;\r
+ y:=p.last.y;\r
+ p:=p.last;\r
+ d:=false;\r
+ tt:=t;\r
+ while (tt<>none)\r
+ do\r
+ if ((tt.x=x) and (tt.y=y)) then exit; fi;\r
+ if d then td:=x<tt.x;\r
+ else td:=y<tt.y; fi;\r
+ if td then tt:=tt.gauche; else tt:=tt.droite; fi;\r
+ d:=not d;\r
+ od;\r
+ r:=tt;\r
+ fi;\r
+ when 13 : exit;\r
+ esac;\r
+ od;\r
+ call groff;\r
+ else\r
+ writeln(" Arbre Vide ");\r
+ z:=readkey;\r
+ fi;\r
+end imprimegraphe;\r
+\r
+unit dessine : procedure (t : noeud; inout lx,hx,ly,hy:integer;d:boolean);\r
+begin\r
+ if t<>none then\r
+ if not(d) then\r
+ call line(lx,t.y,hx,t.y);\r
+ call croix(t);\r
+ call dessine(t.gauche,lx,hx,ly,t.y,not(d));\r
+ call dessine(t.droite,lx,hx,t.y,hy,not(d));\r
+ else\r
+ call line(t.x,ly,t.x,hy);\r
+ call croix(t);\r
+ call dessine(t.gauche,lx,t.x,ly,hy,not(d));\r
+ call dessine(t.droite,t.x,hx,ly,hy,not(d));\r
+ fi;\r
+ fi;\r
+end dessine;\r
+\r
+unit croix: procedure (t:noeud);\r
+begin\r
+ call move((t.x*ax+b)-2,(t.y*cx+d)-2);\r
+ call draw((t.x*ax+b)+2,(t.y*cx+d)+2);\r
+ call move((t.x*ax+b)-2,(t.y*cx+d)+2);\r
+ call draw((t.x*ax+b)+2,(t.y*cx+d)-2);\r
+end croix;\r
+\r
+unit line : procedure (x1,y1,x2,y2 : integer);\r
+begin\r
+ call move(entier(x1*ax+b),entier(y1*cx+d));\r
+ call draw(entier(x2*ax+b),entier(y2*cx+d));\r
+end line;\r
+\r
+\r
+unit readkey : function : integer;\r
+ var c : integer;\r
+begin\r
+ do\r
+ c:=inkey;\r
+ if c<>0 then exit; fi;\r
+ od;\r
+ result:=c;\r
+end readkey;\r
+\r
+unit clrscr : procedure;\r
+begin\r
+ write( chr(27), "[2J")\r
+end clrscr;\r
+\r
+unit normal:procedure;\r
+begin\r
+ write(chr(27),"[0m");\r
+end normal;\r
+\r
+unit inverse:procedure;\r
+begin\r
+ write(chr(27),"[7m");\r
+end inverse;\r
+\r
+unit writeliste : procedure(l :liste);\r
+var i,c : integer;\r
+begin\r
+ i:=0;\r
+ while lespoints<>none\r
+ do\r
+ writeln(lespoints.x,",",lespoints.y);\r
+ if lespoints.pred<>none then lespoints:=lespoints.pred;\r
+ else exit;\r
+ fi;\r
+ i:=i+1;\r
+ if (i mod 22)=0 then\r
+ call writexy(30,24,"Appuyez sur une touche");\r
+ c:=readkey;\r
+ fi;\r
+ od;\r
+end writeliste;\r
+\r
+unit lecture : procedure (inout x : integer);\r
+begin\r
+ do\r
+ readln(x);\r
+ if x<=9999 and x>=-999 then exit; fi;\r
+ writeln(" Mauvaise coordonn\82e");\r
+ od;\r
+end lecture;\r
+\r
+unit afficheMenu:procedure(n : integer,inv : boolean);\r
+begin\r
+ if inv then call inverse;fi;\r
+ case n\r
+ when 1 : call writexy(20,5,"Inserer un element ");\r
+ when 2 : call writexy(20,6,"Inserer plusieurs elements");\r
+ when 3 : call writexy(20,7,"Recherche d' un element ");\r
+ when 4 : call writexy(20,8,"Range searching ");\r
+ when 5 : call writexy(20,9,"Affiche tous les elements ");\r
+ when 6 : call writexy(20,10,"Delete ");\r
+ when 7 : call writexy(20,11,"Efface arbre ");\r
+ when 8 : call writexy(20,12,"Affiche arbre ");\r
+ when 9 : call writexy(20,13,"Dessine Plan ");\r
+ when 10: call writexy(20,14,"Bye Bye ");\r
+ esac;\r
+ if inv then call normal;fi;\r
+end afficheMenu;\r
+\r
+begin\r
+ arbre:= new bst2;\r
+ call arbre.insert(2,9);\r
+ call arbre.insert(11,1);\r
+ call arbre.insert(6,8);\r
+ call arbre.insert(3,3);\r
+ call arbre.insert(5,15);\r
+ call arbre.insert(8,11);\r
+ call arbre.insert(0,6);\r
+ call arbre.insert(7,4);\r
+ call arbre.insert(9,7);\r
+ call arbre.insert(14,5);\r
+ call arbre.insert(10,13);\r
+ call arbre.insert(16,14);\r
+ call arbre.insert(15,2);\r
+ call arbre.insert(13,16);\r
+ call arbre.insert(1,12);\r
+ call arbre.insert(12,10);\r
+\r
+\r
+ do\r
+ call clrscr;\r
+ call writexy(19,1,"ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»");\r
+ for n:=2 to 14 do call writexy(19,n,"º º");\r
+ od;\r
+ call writexy(19,15,"ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ");\r
+ call writexy(31,2,"MENU");\r
+ for n:=2 to 10 do call afficheMenu(n,false);\r
+ od;\r
+ n:=1;\r
+ call afficheMenu(n,true);\r
+ do\r
+ z:=readkey;\r
+ if z=-80 or z=50 then p:=n;\r
+ if n=10 then n:=1 else n:=n+1; fi;\r
+ call afficheMenu(n,true);\r
+ call afficheMenu(p,false);\r
+ fi;\r
+ if z=-72 or z=56 then p:=n;\r
+ if n=1 then n:=10 else n:=n-1; fi;\r
+ call afficheMenu(n,true);\r
+ call afficheMenu(p,false);\r
+ fi;\r
+ if z=13 then exit;\r
+ fi;\r
+ od;\r
+ case n\r
+ when 1 : call clrscr;\r
+ call writexy(10,2,"Inserer un element");\r
+ write("x : "); call lecture(x);\r
+ write("y : "); call lecture(y);\r
+ call arbre.insert(x,y);\r
+ when 2 : call clrscr;\r
+ call writexy(10,2,"Inserer plusieurs elements");\r
+ do\r
+ writeln("x : "); call lecture(x);\r
+ writeln("y : "); call lecture(y);\r
+ call arbre.insert(x,y);\r
+ write("Encore ? (ENTER/n)");\r
+ writeln;\r
+ z:=readkey;\r
+ if z<>13 then exit;fi;\r
+ od;\r
+ when 3 : call clrscr;\r
+ call writexy(10,2,"Recherche d'un element");\r
+ write("x : "); call lecture(x);\r
+ write("y : "); call lecture(y);\r
+ if (arbre.mb(x,y)) then\r
+ writeln("Cet element fait partie de l'arbre.");\r
+ else\r
+ writeln("Cet element ne fait pas partie de l'arbre.");\r
+ fi;\r
+ z:=readkey;\r
+ when 4 : call clrscr;\r
+ call writexy(10,2,"Range searching");\r
+ writeln("x1,y1");\r
+ writeln(" ÚÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ writeln(" ³ ³ ");\r
+ writeln(" ³ ³ ");\r
+ writeln(" ³ ³ ");\r
+ writeln(" ³ ³ ");\r
+ writeln(" ³ ³ ");\r
+ writeln(" ÀÄÄÄÄÄÄÄÄÄÄÙ ");\r
+ writeln(" x2,y2");\r
+ write("x1 : "); call lecture(x1);\r
+ write("y1 : "); call lecture(y1);\r
+ write("x2 : "); call lecture(x2);\r
+ write("y2 : "); call lecture(y2);\r
+ if (x2<x1) then p:=x1;x1:=x2;x2:=p;fi;\r
+ if (y2<y1) then p:=y1;y1:=y2;y2:=p;fi;\r
+ kill(lespoints);\r
+ call arbre.twodrange(arbre.racine,x1,y1,x2,y2,false,\r
+ lespoints);\r
+ call clrscr;\r
+ if lespoints<>none then\r
+ call writeliste(lespoints);\r
+ else\r
+ writeln(" Aucun points dans ce rectangle.");\r
+ fi;\r
+ z:=readkey;\r
+ when 5 : call clrscr;\r
+ call writexy(10,2,"Affiche tous les elements");\r
+ call arbre.cadre(arbre.racine,x1,x2,y1,y2);\r
+ x1:=x1-1; x2:=x2+1; y1:=y1-1; y2:=y2+1;\r
+ kill(lespoints);\r
+ call arbre.twodrange(arbre.racine,x1,y1,x2,y2,false,\r
+ lespoints);\r
+ call writeliste(lespoints);\r
+ z:=readkey;\r
+ when 6 : call clrscr;\r
+ call writexy(10,2,"Suppression d'un element");\r
+ write("x : "); call lecture(x);\r
+ write("y : "); call lecture(y);\r
+ if arbre.mb(x,y) then\r
+ call arbre.delete(x,y);\r
+ else\r
+ writeln("Element non trouve...");\r
+ z:=readkey;\r
+ fi;\r
+ when 7 : call clrscr;\r
+ call writexy(10,2,"Destruction de l'arbre");\r
+ writeln("Etes vous sur de vouloir detruire l'arbre ? (o/n)");\r
+ readln(choix);\r
+ if choix='o' or choix='O' then\r
+ call arbre.killall(arbre.racine);\r
+ arbre:=new bst2;\r
+ fi;\r
+ when 8 : call clrscr;\r
+ call imprimegraphe(arbre.racine);\r
+ when 9 : call gron(nocard);\r
+ call cls;\r
+ call arbre.cadre(arbre.racine,x1,x2,y1,y2);\r
+ x1:=x1-1; x2:=x2+1; y1:=y1-1; y2:=y2+1;\r
+ ax:=maxx/(x2-x1); b:=-x1*ax;\r
+ cx:=maxy/(y2-y1); d:=-y1*cx;\r
+ call dessine(arbre.racine,x1,x2,y1,y2,false);\r
+ z:=readkey;\r
+ call groff;\r
+ when 10 : call clrscr;\r
+ exit;exit;\r
+\r
+ esac;\r
+ od;\r
+end;\r
+end; (* end bst2 *)\r
+end; (* end iiuwgraph *)\r
+\r
--- /dev/null
+s'elever\r
+to arise\r
+etre\r
+to be\r
+battre\r
+to beat\r
+devenir\r
+to become\r
+commencer\r
+to begin\r
+plier\r
+to bend\r
+parier\r
+to bet\r
+lier\r
+to bind\r
+mordre\r
+to bite\r
+saigner\r
+to bleed\r
+souffler\r
+to blow\r
+casser\r
+to break\r
+apporter\r
+to bring\r
+construire\r
+to build\r
+bruler\r
+to burn\r
+eclater\r
+to burst\r
+acheter\r
+to buy\r
+jeter\r
+to cast\r
+attraper\r
+to catch\r
+choisir\r
+to choose\r
+s'accrocher\r
+to cling\r
+venir\r
+to come\r
+couter\r
+to cost\r
+ramper\r
+to creep\r
+couper\r
+to cut\r
+s'occuper de\r
+to deal\r
+creuser\r
+to dig\r
+faire\r
+to do\r
+dessiner\r
+to draw\r
+rever\r
+to dream\r
+boire\r
+to drink\r
+conduire\r
+to drive\r
+manger\r
+to eat\r
+tomber\r
+to fall\r
+se nourrir\r
+to feed\r
+ressentir\r
+to feel\r
+se battre\r
+to fight\r
+trouver\r
+to find\r
+lancer violemment\r
+to fling\r
+voler\r
+to fly\r
+interdire\r
+to forbid\r
+oublier\r
+to forget\r
+pardonner\r
+to forgive\r
+geler\r
+to freeze\r
+obtenir\r
+to get\r
+donner\r
+to give\r
+aller\r
+to go\r
+moudre\r
+to grind\r
+grandir\r
+to grow\r
+suspendre\r
+to hang\r
+avoir\r
+to have\r
+entendre\r
+to hear\r
+se cacher\r
+to hide\r
+frapper\r
+to hit\r
+tenir\r
+to hold\r
+faire mal\r
+to hurt\r
+garder\r
+to keep\r
+s'agenouiller\r
+to kneel\r
+savoir\r
+to know\r
+mettre\r
+to lay\r
+mener\r
+to lead\r
+apprendre\r
+to learn\r
+quitter\r
+to leave\r
+preter\r
+to lend\r
+permettre\r
+to let\r
+etre etendu\r
+to lie\r
+allumer\r
+to light\r
+perdre\r
+to loose\r
+fabriquer\r
+to make\r
+vouloir dire\r
+to mean\r
+rencontrer\r
+to meet\r
+payer\r
+to pay\r
+poser\r
+to put\r
+lire\r
+to read\r
+faire du velo\r
+to ride\r
+sonner\r
+to ring\r
+s'elever\r
+to rise\r
+courrir\r
+to run\r
+dire\r
+to say\r
+voir\r
+to see\r
+chercher\r
+to seek\r
+vendre\r
+to sell\r
+envoyer\r
+to send\r
+fixer\r
+to set\r
+coudre\r
+to sew\r
+secouer\r
+to shake\r
+briller\r
+to shine\r
+tirer\r
+to shoot\r
+montrer\r
+to show\r
+se retrecir\r
+to shrink\r
+fermer\r
+to shut\r
+chanter\r
+to sing\r
+sombrer\r
+to sink\r
+etre assis\r
+to sit\r
+tuer\r
+to slay\r
+dormir\r
+to sleep\r
+glisser\r
+to slide\r
+sentir\r
+to smell\r
+parler\r
+to speak\r
+epeler\r
+to spell\r
+depenser\r
+to spend\r
+repandre\r
+to spill\r
+touner\r
+to spin\r
+cracher\r
+to spit\r
+se fendre\r
+to split\r
+etaler\r
+to spread\r
+bondir\r
+to spring\r
+etre debout\r
+to stand\r
+derober\r
+to steal\r
+coller\r
+to stick\r
+piquer\r
+to sting\r
+puer\r
+to stink\r
+frapper\r
+to strike\r
+jurer\r
+to swear\r
+balayer\r
+to sweep\r
+nager\r
+to swim\r
+se balancer\r
+to swing\r
+prendre\r
+to take\r
+enseigner\r
+to teach\r
+dechirer\r
+to tear\r
+raconter\r
+to tell\r
+croire\r
+to think\r
+jeter\r
+to throw\r
+fouler\r
+to tread\r
+subir\r
+to undergo\r
+comprendre\r
+to understand\r
+se reveiller\r
+to wake\r
+porter\r
+to wear\r
+tisser\r
+to weave\r
+pleurer\r
+to weep\r
+gagner\r
+to win\r
+serpenter\r
+to wind\r
+se retirer\r
+to withdraw\r
+tordre\r
+to wring\r
+ecrire\r
+to write\r
+\r
+\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+etre\r
+to be\r
+devenir\r
+to become\r
+commencer\r
+to begin\r
+casser\r
+to break\r
+apporter\r
+to bring\r
+construire\r
+to build\r
+acheter\r
+to buy\r
+choisir\r
+to choose\r
+venir\r
+to come\r
+couter\r
+to cost\r
+faire\r
+to do\r
+boire\r
+to drink\r
+conduire\r
+to drive\r
+manger\r
+to eat\r
+trouver\r
+to find\r
+voler\r
+to fly\r
+interdire\r
+to forbid\r
+oublier\r
+to forget\r
+obtenir\r
+to get\r
+donner\r
+to give\r
+aller\r
+to go\r
+avoir\r
+to have\r
+apprendre\r
+to learn\r
+quitter\r
+to leave\r
+perdre\r
+to loose\r
+fabriquer\r
+to make\r
+rencontrer\r
+to meet\r
+payer\r
+to pay\r
+poser\r
+to put\r
+lire\r
+to read\r
+courrir\r
+to run\r
+dire\r
+to say\r
+voir\r
+to see\r
+dormir\r
+to sleep\r
+parler\r
+to speak\r
+depenser\r
+to spend\r
+etre debout\r
+to stand\r
+derober\r
+to steal\r
+prendre\r
+to take\r
+enseigner\r
+to teach\r
+raconter\r
+to tell\r
+jeter\r
+to throw\r
+comprendre\r
+to understand\r
+gagner\r
+to win\r
+ecrire\r
+to write\r
+\1a
\ No newline at end of file
--- /dev/null
+Les fichiers\r
+\r
+bbarbre1 et bbarbre2 sont a Mlles Beau et Delburg\r
+\r
+projli1 data.bas data.dem sont a MM Fernandez et Paul\r
+projet.log est a M. Vautor\r
+\r
+go.bat et texte.log sont a M. Bianconi\r
+\r
+bidim.log est a MM. Debiard et Berthou\r
+ egaint bidim\r
+\r
+bicolore.log est a Mlles Chicher et Dome\r
+ egaint bicolore\r
+avl.log est a MM Gougeon et J.Richard\r
+ egaint avl\r
+\r
+hull.log est a M. Jouanny\r
+proj_li1.log est MM. Bourgeat et Mandonnaud\r
+\r
+\r
+envoyees par mail\r
+barb.log de la part de MM Ait Abdelhalim et Baradat ou?\r
+li07 par F.A'ch
\ No newline at end of file
--- /dev/null
+ \r
+program geometrie;\r
+ \r
+ \r
+(***************************************************************************)\r
+(* DULON Benjamin *)\r
+(* CORITON Willy *)\r
+(* Licence Informatique *)\r
+(* Groupe 1 *)\r
+(* *)\r
+(* P R O J E T L I 1 *)\r
+(* *)\r
+(* **** **** **** * * **** ***** **** * **** *)\r
+(* * * * * * * * * * * * * * *)\r
+(* * ** ** * * * * ** * **** * ** *)\r
+(* * * * * * * * * * * * * * *)\r
+(* **** **** **** * * **** * * * * **** *)\r
+(* *)\r
+(***************************************************************************)\r
+ \r
+BEGIN\r
+ \r
+(************************************************************)\r
+(* CLASSE DEFINISSANT LES PROCEDURES DE GRAPHISME UTILISEES *)\r
+(************************************************************)\r
+pref IIUWGRAPH block\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant d'utiliser le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ unit initgraph : procedure;\r
+ begin\r
+ CALL GRON(1);\r
+ end initgraph;\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant de fermer le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ unit closegraph : procedure;\r
+ begin\r
+ CALL GROFF;\r
+ end closegraph;\r
+ \r
+ (*-----------------------------------------------------------------*)\r
+ (* AFFICHAGE en (x,y) d'un RECTANGLE de longueur l et de hauteur h *)\r
+ (*-----------------------------------------------------------------*)\r
+ unit rectangle : procedure(x,y,l,h : integer);\r
+ begin\r
+ call move(x,y);\r
+ call draw (x+l,y);\r
+ call draw(x+l,y+h);\r
+ call draw(x,y+h);\r
+ CALL DRAW(x,y);\r
+ end rectangle;\r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* Definition du repere orthonorme *)\r
+ (*--------------------------------------------------------------------*)\r
+ Unit reportho:procedure;\r
+ begin\r
+ call move(425,10);\r
+ call draw(425,294);\r
+ call move(225,154);\r
+ call draw(625,154);\r
+ end reportho;\r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* ECRITURE d'une CHAINE de caracteres sur l'ecran graphique en (x,y) *)\r
+ (*--------------------------------------------------------------------*)\r
+ unit ecrit_text : procedure(x,y : integer;str : string);\r
+ var ch : arrayof character,\r
+ lg,i : integer;\r
+ begin\r
+ call move (x,y);\r
+ ch := unpack(str);\r
+ lg := upper(ch) - lower(ch) + 1;\r
+ for i := 1 to lg do\r
+ call hascii(0);\r
+ call hascii(ord(ch(i)));\r
+ od;\r
+ end ecrit_text;\r
+ \r
+ (*---------------------------------*)\r
+ (* LECTURE d'une touche au clavier *)\r
+ (*---------------------------------*)\r
+ unit inchar : function : integer;\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i =/= 0 then exit;\r
+ fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ (*-------------------------------------------------------------------*)\r
+ (* LECTURE d'un ENTIER au clavier et AFFICHAGE sur l'ecran graphique *)\r
+ (*-------------------------------------------------------------------*)\r
+ unit lire_entier: function(x,y:real):real;\r
+ var nbchiffre,key,i : integer, valeur : real, negatif : boolean;\r
+ begin\r
+ negatif := false;\r
+ valeur:=0;\r
+ call move(x,y);\r
+ for i:=1 to 4\r
+ do\r
+ call hascii(0);\r
+ od;\r
+ call move(x,y);\r
+ DO\r
+ (* Lecture de la touche *)\r
+ key := inchar;\r
+ if key = 45 then negatif := true ;\r
+ call hascii(key);\r
+ fi;\r
+ if (key >= 48 and key <= 57)\r
+ then\r
+ call hascii(key);\r
+ (* Saisie de chiffres *)\r
+ if (nbchiffre < 3 )\r
+ then\r
+ valeur := valeur*10 + key - 48;\r
+ fi;\r
+ fi;\r
+ \r
+ if (key = 27) or (key = 13) (* touche ESC ou RETOUR chariot *)\r
+ then exit;\r
+ fi;\r
+ od;\r
+ if negatif then result := -valeur\r
+ else\r
+ result:=valeur;\r
+ fi;\r
+ end lire_entier;\r
+ \r
+ (*---------------------------------------------------------------------*)\r
+ (* ECRITURE d'un ENTIER sur l'\82cran graphique au coordonn\82es courantes *)\r
+ (*---------------------------------------------------------------------*)\r
+ unit ecrit_entier : procedure (posx,posy:integer, x : real);\r
+ var val,i,j,val2 : integer,\r
+ ch,ch2 : arrayof character,\r
+ dec:boolean;\r
+ begin\r
+ array ch dim(1:4);\r
+ array ch2 dim(1:4);\r
+ for i:=1 to 4\r
+ do\r
+ ch(i):=chr(48);\r
+ ch2(i):=chr(48);\r
+ od;\r
+ i := 4;\r
+ j:=4;\r
+ \r
+ val:=entier(x);\r
+ val2:=x-val;\r
+ \r
+ do\r
+ ch(i) := chr(48+(val mod 10));\r
+ val := val div 10;\r
+ if (val = 0) then exit; fi;\r
+ i := i - 1;\r
+ od;\r
+ if val2 = 0 then\r
+ dec:=true;\r
+ else\r
+ do\r
+ ch2(i):= chr(48+(val2 mod 10));\r
+ val2:= val2 div 10;\r
+ if (val2 = 0) then exit; fi;\r
+ j := j - 1;\r
+ od;\r
+ fi;\r
+ if x < 0\r
+ then\r
+ call hascii(0);\r
+ call hascii(45);\r
+ posx:=posx+4;\r
+ fi;\r
+ \r
+ while i <= 4\r
+ do\r
+ posx:=posx+i;\r
+ call move(posx,posy);\r
+ call hascii(0);\r
+ call hascii(ord(ch(i)));\r
+ i := i + 1;\r
+ od;\r
+ if not dec then\r
+ call move(posx+8,posy);\r
+ call hascii(0);\r
+ call hascii(46);\r
+ while j <= 4\r
+ do\r
+ call move(posx+8*(j+1),posy);\r
+ call hascii(0);\r
+ call hascii(ord(ch2(j)));\r
+ j := j + 1;\r
+ od;\r
+ fi;\r
+ end ecrit_entier;\r
+ \r
+ (*\r
+ unit ecrit_entier : procedure (x:real);\r
+ \r
+ var i,j,n,tail : integer,\r
+ ch : arrayof character,\r
+ ok:boolean;\r
+ begin\r
+ tail:=0;\r
+ array ch dim(1:7);\r
+ for i:=1 to 7 do ch(i):=chr(48); od;\r
+ i := 7;\r
+ j:=1;\r
+ n:=x*100;\r
+ do;\r
+ ch(i):=chr(48+(n mod 10));\r
+ n:=n div 10;\r
+ tail:=tail+1;\r
+ i:=i-1;\r
+ if (n=0) then exit; fi;\r
+ od;\r
+ if tail<3 then\r
+ ch(j):=chr(48);\r
+ i:=1;\r
+ else\r
+ for i:=1 to tail-2\r
+ do\r
+ ch(i+j-1):=ch(i+8-j-tail);\r
+ od;\r
+ fi;\r
+ ch(i+j):='.';\r
+ ch(i+j+1):=ch(6);\r
+ ch(i+j+2):=ch(7);\r
+ if ok then tail:=tail+1; fi;\r
+ for i:=1 to tail+j\r
+ do\r
+ call hascii(0);\r
+ call hascii(ord(ch(i)));\r
+ od;\r
+ end ecrit_entier;*)\r
+ \r
+ (*----------------------------------------------------------------*)\r
+ (* PROCEDURE EQUATION QUI RENVOIE LES COORDONNEES DE DEUX DROITES *)\r
+ (*----------------------------------------------------------------*)\r
+ unit equation:procedure(output x1,y1,x2,y2:real);\r
+ begin\r
+ call ecrit_text(430,320,"abscisse premier point: ");\r
+ x1:=lire_entier(622,320);\r
+ call ecrit_text(430,330,"ordonnee premier point: ");\r
+ y1:=lire_entier(622,330);\r
+ call ecrit_text(430,320," ");\r
+ call ecrit_text(430,330," ");\r
+ call ecrit_text(430,320,"abscisse deuxieme point: ");\r
+ x1:=lire_entier(622,320);\r
+ call ecrit_text(430,330,"ordonnee deuxieme point: ");\r
+ y1:=lire_entier(622,330);\r
+ call ecrit_text(430,320," ");\r
+ call ecrit_text(430,330," ");\r
+ end equation;\r
+ \r
+ (*---------------------------------------------------------------*)\r
+ (* PROCEDURE EQUAT QUI SAISIE LES COORDONNEES A B C DE LA DROITE *)\r
+ (*---------------------------------------------------------------*)\r
+ unit equat:procedure(output a,b,c:real);\r
+ begin\r
+ call ecrit_text(470,317,"valeur de a: ");\r
+ a:=lire_entier(574,317);\r
+ call ecrit_text(470,327,"valeur de b: ");\r
+ b:=lire_entier(574,327);\r
+ call ecrit_text(470,337,"valeur de c: ");\r
+ c:=lire_entier(574,337);\r
+ call ecrit_text(470,317," ");\r
+ call ecrit_text(470,327," ");\r
+ call ecrit_text(470,337," ");\r
+ end equat;\r
+ \r
+ (*--------------------------------*)\r
+ (* PROCEDURE DE SAISIE D'UN POINT *)\r
+ (*--------------------------------*)\r
+ unit def_point:procedure(output x1,y1:real);\r
+ \r
+ begin\r
+ call ecrit_text(500,320,"Abscisse: ");\r
+ x1:=lire_entier(580,320);\r
+ call ecrit_text(500,330,"Ordonnee: ");\r
+ y1:=lire_entier(580,330);\r
+ call ecrit_text(500,320," ");\r
+ call ecrit_text(500,330," ");\r
+ end def_point;\r
+ \r
+ (*--------------------------------------------------------*)\r
+ (* PROCEDURE SOMMAIRE DES DIFFERENTES FONCTIONS PROPOSEES *)\r
+ (*--------------------------------------------------------*)\r
+ unit sommaire:procedure;\r
+ begin\r
+ call rectangle(1,0,210,306);\r
+ call ecrit_text (2,10," SOMMAIRE");\r
+ call ecrit_text (2,40," 1: Forme geometrique");\r
+ call ecrit_text (2,60," 2: Dessiner cercle");\r
+ call ecrit_text (2,80," 3: Intersection droites");\r
+ call ecrit_text (2,100," 4: Parallelisme ");\r
+ call ecrit_text (2,120," 5: Perpendicularite");\r
+ call ecrit_text (2,140," 6: Point appart. droite");\r
+ call ecrit_text (2,160," 7: Point appart. cercle");\r
+ call ecrit_text (2,180," 8: Intersection cercles");\r
+ call ecrit_text (2,200," 9: Points/droite");\r
+ call ecrit_text (2,220," 10: Quitter");\r
+ call ecrit_text (2,250," Votre choix : ");\r
+ end sommaire;\r
+ \r
+ unit ecran:procedure;\r
+ begin\r
+ call cls;\r
+ call sommaire;\r
+ call texte;\r
+ call graphique;\r
+ end ecran;\r
+ \r
+ unit graphique:procedure;\r
+ begin\r
+ call reportho;\r
+ call rectangle(215,0,420,306);\r
+ end graphique;\r
+ \r
+ unit texte:procedure;\r
+ begin\r
+ call rectangle(1,307,635,42);\r
+ end texte;\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE POUR SAISIR LES COORDONNEES D'UN CERCLE *)\r
+ (*---------------------------------------------------*)\r
+ unit def_cercle:procedure(output x1,y1,r:real);\r
+ begin\r
+ call ecrit_text(350,325,"Rayon: ");\r
+ r:=lire_entier(406,325);\r
+ call ecrit_text(450,320,"Abscisse du centre: ");\r
+ x1:=lire_entier(610,320);\r
+ call ecrit_text(450,330,"Ordonnee du centre: ");\r
+ y1:=lire_entier(610,330);\r
+ call ecrit_text(350,325," ");\r
+ call ecrit_text(450,320," ");\r
+ call ecrit_text(450,330," ");\r
+ end def_cercle;\r
+ \r
+ (*----------------------------------*)\r
+ (* PROCEDURE DE DESSIN D'UNE DROITE *)\r
+ (*----------------------------------*)\r
+ unit des_droite:procedure(a,b,c:real;output pb:boolean);\r
+ begin\r
+ pb:=false;\r
+ if b=0 then\r
+ if a=0 then\r
+ pb:=true;\r
+ else\r
+ call move(425-10*c/a,5);\r
+ call draw(425-10*c/a,295);\r
+ fi;\r
+ else\r
+ call move(625,154+10*((c+20*a)/b));\r
+ call draw(225,154+10*((c-20*a)/b));\r
+ fi;\r
+ end des_droite;\r
+ \r
+ (*------------------------------------------*)\r
+ (* PROCEDURE MISE EN ATTENTE MODE GRAPHIQUE *)\r
+ (*------------------------------------------*)\r
+ unit attente:procedure;\r
+ var reponse,rep:integer;\r
+ begin\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ reponse := inkey; (*:=lire_entier(180,295);*)\r
+ (*reponse := rep + 48 -rep*10;*)\r
+ while reponse<>13\r
+ do\r
+ (*rep:=lire_entier(180,295);*)\r
+ reponse := inkey ; (*rep + 48 -rep*10;*)\r
+ od;\r
+ end attente;\r
+ \r
+ \r
+(********************************************************)\r
+(* CLASSE DEFINISSANT LES FORMES GEOMETRIQUES UTILISEES *)\r
+(********************************************************)\r
+ \r
+unit geoplan :CLASS;\r
+ \r
+(*---------------------*)\r
+(* DEFINITION DU POINT *)\r
+(*---------------------*)\r
+unit pt:class(x,y:real);\r
+ \r
+ unit equal:function(q:pt):boolean;\r
+ (* renvoie une valeur booleenne sur l'egalite de deux points *)\r
+ \r
+ begin\r
+ result:=((q.x=x) and (q.y=y));\r
+ end equal;\r
+ \r
+ unit dist:function(p:pt):real;\r
+ (* renvoie la distance entre deux points *)\r
+ begin\r
+ if p=none\r
+ then\r
+ call erreur;\r
+ else\r
+ result:=sqrt((x-p.x)*(x-p.x)+(y-p.y)*(y-p.y));\r
+ fi;\r
+ end dist;\r
+ \r
+ unit memecote:function(l:line,p1:pt):boolean;\r
+ (* vrai si les deux points sont du meme cote de la droite *)\r
+ \r
+ var dx1,dx2:real;\r
+ begin\r
+ dx1:=l.a*p1.x+l.b*p1.y+l.c;\r
+ dx2:=l.a*x+l.b*y+l.c;\r
+ if (dx1>0 and dx2>0) or (dx1<0 and dx2<0)\r
+ then\r
+ result:= true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ end memecote;\r
+ \r
+ unit calculeq:procedure(p1:pt;output a,b,c:real);\r
+ (* calcul l'equation de la droite en fonction des deux points *)\r
+ \r
+ begin\r
+ a:=y-p1.y;\r
+ b:=p1.x-x;\r
+ c:=x*p1.y - p1.x*y;\r
+ end calculeq;\r
+ \r
+ unit virtual erreur:procedure;\r
+ begin\r
+ call ecrit_text(200,325,"Il n'y a pas de point");\r
+ end erreur;\r
+ \r
+end pt;\r
+ \r
+(*----------------------*)\r
+(* DEFINITION DU CERCLE *)\r
+(*----------------------*)\r
+unit cercle :class(q:pt,r:real);\r
+ \r
+ unit intersec:function(c:cercle):line;\r
+ (* renvoie la ligne d'intersection entre deux cercles *)\r
+ \r
+ var r1,r2:real;\r
+ begin\r
+ if c<> none\r
+ then\r
+ r1:=-r*r-q.x*q.x-q.y*q.y;\r
+ r2:=c.r*c.r-c.q.x*c.q.x-c.q.y*c.q.y;\r
+ result:=new line(q.x-c.q.x,q.y-c.q.y,(r1-r2)/2);\r
+ else\r
+ call erreur;\r
+ fi;\r
+ end intersec;\r
+ \r
+ unit ptappartcercle:function(p:pt,epsilon:real):boolean;\r
+ (* renvoie une valeur booleenne sur l'appartenance de p au cercle *)\r
+ \r
+ begin\r
+ if (p.x-q.x)*(p.x-q.x) + (p.y-q.y)*(p.y-q.y) >= (r-epsilon)*(r-epsilon)\r
+ and (p.x-q.x)*(p.x-q.x) + (p.y-q.y)*(p.y-q.y) <= (r+epsilon)*(r+epsilon)\r
+ then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ end ptappartcercle;\r
+ \r
+ unit virtual erreur:procedure;\r
+ begin\r
+ call ecrit_text(200,325,"Il n'y a pas de cercles");\r
+ writeln("Il n'y a pas de cercle");\r
+ end erreur;\r
+ \r
+end cercle;\r
+ \r
+(*-------------------------*)\r
+(* DEFINITION DE LA DROITE *)\r
+(*-------------------------*)\r
+unit line:class(a,b,c:real);\r
+ \r
+ unit meet:function(l:line):pt;\r
+ (* renvoie le point d'intersection de deux droites *)\r
+ \r
+ var t:real;\r
+ begin\r
+ if parallele(l) then\r
+ call ecrit_text(200,325,"Les deux droites sont paralleles");\r
+ else\r
+ if l<> none\r
+ then\r
+ t:=1/(l.a*b-l.b*a);\r
+ result:=new pt((c*l.b-b*l.c)/t,(a*l.c-c*l.a)/t);\r
+ else call erreur;\r
+ fi;\r
+ fi;\r
+ end meet;\r
+ \r
+ unit parallele:function(l:line):boolean;\r
+ (* renvoie une valeur booleenne sur le parallelisme de deux droites *)\r
+ \r
+ begin\r
+ if l <> none\r
+ then\r
+ if a*l.b -b*l.a=0\r
+ then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ else call erreur;\r
+ fi;\r
+ end parallele;\r
+ \r
+ unit perpendiculaire:function(l:line):boolean;\r
+ (* renvoie une valeur booleenne sur la perpendicularite de deux droites *)\r
+ \r
+ begin\r
+ if l <> none\r
+ then\r
+ if a*l.a + b*l.b=0\r
+ then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ else call erreur;\r
+ fi;\r
+ end perpendiculaire;\r
+ \r
+ unit ptappartligne:function(p:pt):boolean;\r
+ (* renvoie une valeur booleenne sur l'appartenance de p a la droite *)\r
+ \r
+ begin\r
+ if a*p.x + b*p.y +c=0\r
+ then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ end ptappartligne;\r
+ \r
+ unit virtual erreur:procedure;\r
+ begin\r
+ call ecrit_text(200,325,"Pas de droite");\r
+ end erreur;\r
+ \r
+var d:real;\r
+begin\r
+ d:=sqrt(a*a+b*b);\r
+ if d<>0\r
+ then\r
+ a:=a/d;\r
+ b:=b/d;\r
+ c:=c/d;\r
+ fi;\r
+end line;\r
+ \r
+END geoplan;\r
+ \r
+ \r
+(*---------------------------------------------------------*)\r
+(* PROCEDURE GOTOXY POUR DEPLACER LE CURSEUR EN MODE TEXTE *)\r
+(*---------------------------------------------------------*)\r
+unit gotoxy:procedure(ligne,colonne:integer);\r
+var i,j:integer,\r
+ c,d,e,f:char;\r
+ \r
+begin\r
+ \r
+ i:=ligne div 10;\r
+ j:=ligne mod 10;\r
+ c:=chr(48+i);\r
+ d:=chr(48+j);\r
+ i:=colonne div 10;\r
+ j:=colonne mod 10;\r
+ e:=chr(48+i);\r
+ f:=chr(48+j);\r
+ \r
+ write(chr(27), "[",c,d,";",e,f,"H");\r
+end gotoxy;\r
+ \r
+(*----------------------------------------------*)\r
+(* PROCEDURE POUR EFFACER L'ECRAN EN MODE TEXTE *)\r
+(*----------------------------------------------*)\r
+unit effacecran:procedure;\r
+begin\r
+ write(chr(27),"[2J");\r
+end effacecran;\r
+ \r
+(*--------------------------------------------------------*)\r
+(* PROCEDURE POUR METTRE L'ECRAN EN ATTENTE EN MODE TEXTE *)\r
+(*--------------------------------------------------------*)\r
+unit attent:procedure;\r
+var reponse:char;\r
+begin\r
+ call gotoxy(25,45);\r
+ writeln("taper sur entree");\r
+ reponse:='r';\r
+ while reponse='r'\r
+ do\r
+ read(reponse);\r
+ od;\r
+end attent;\r
+ \r
+ \r
+(*****************************************************************************)\r
+(* PROGRAMME PRINCIPAL *)\r
+(*****************************************************************************)\r
+ \r
+begin\r
+pref geoplan block\r
+ \r
+const epsilon=0.1;\r
+var p,q,centre,p1,p2:pt,\r
+ l2,l1:line,\r
+ c2,c3:cercle,\r
+ x1,y1,x2,y2,r,a,b,c,a1,b1,c1:real,\r
+ ch,n,rep,rep2,i:integer,\r
+ fin,pb,pb1:boolean,\r
+ t:arrayof arrayof real,\r
+ tab1,tab2: arrayof integer;\r
+ \r
+begin\r
+ call effacecran;\r
+ call gotoxy(3,10);\r
+ writeln("CORITON willy");\r
+ call gotoxy(5,10);\r
+ writeln("DULON Benjamin");\r
+ call gotoxy(7,10);\r
+ writeln("Licence informatique");\r
+ call gotoxy(9,10);\r
+ writeln("Groupe 1");\r
+ call gotoxy(12,10);\r
+ writeln("PROJET LI1");\r
+ call gotoxy(13,10);\r
+ writeln("----------");\r
+ call gotoxy(16,10);\r
+ writeln("***** ***** ***** ** ** ***** ***** ***** * *****");\r
+ call gotoxy(17,10);\r
+ writeln("* * * * * ** * * * * * * * ");\r
+ call gotoxy(18,10);\r
+ writeln("* *** ** * * * * ** * ***** * ** ");\r
+ call gotoxy(19,10);\r
+ writeln("* * * * * * * * * * * * * ");\r
+ call gotoxy(20,10);\r
+ writeln("***** ***** ***** * * ***** * * * * *****");\r
+ call attent;\r
+ \r
+ (* OUVERTURE DU MODE GRAPHIQUE *)\r
+ call initgraph;\r
+ rep:=0;\r
+ fin:=false;\r
+ while not fin\r
+ do\r
+ rep:=0;\r
+ while rep<=0 or rep>10\r
+ do\r
+ call ecran;\r
+ rep:=lire_entier(160,250);\r
+ case rep\r
+ (* dessiner une forme *)\r
+ when 1: call ecrit_text(10,325,"Combien de sommets : ");\r
+ n := lire_entier(178,325);\r
+ array t dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ array t(i) dim (1:2);\r
+ od;\r
+ for i:=1 to n\r
+ do\r
+ call ecrit_text(250,315,"Pour le point numero ");\r
+ call hascii(0);\r
+ call hascii(i);\r
+ call ecrit_text(250,325,"Abscisse: ");\r
+ t(i,1):= lire_entier(338,325);\r
+ call ecrit_text(250,335,"Ordonn\82e: ");\r
+ call ecrit_text(250,325," ");\r
+ call ecrit_text(250,335," ");\r
+ t(i,2):= lire_entier(338,335);\r
+ od;\r
+ call move(10*t(1,1)+425,154-10*t(1,2));\r
+ for i:=2 to n\r
+ do\r
+ call draw(10*t(i,1)+425,154-10*t(i,2));\r
+ od;\r
+ call draw(10*t(1,1)+425,154-10*t(1,2));\r
+ rep:=0;\r
+ CALL ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* dessiner un cercle *)\r
+ when 2: call def_cercle(x1,y1,r);\r
+ call point(x1*10+425,154-y1*10);\r
+ call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
+ p1:=new pt(x1,y1);\r
+ c2:= new cercle(p1,r);\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ rep:=0;\r
+ \r
+ (* intersection de deux droites *)\r
+ when 3: call ecrit_text(10,325,"Equation/P (1/2): ");\r
+ rep2:=lire_entier(154,325);\r
+ if rep2 = 2\r
+ then\r
+ call ecrit_text(280,325,"Premiere droite");\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a,b,c);\r
+ call ecrit_text(280,325,"Deuxieme droite");\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a1,b1,c1);\r
+ else\r
+ call ecrit_text(200,325,"Coordonnes premiere droite");\r
+ call equat(a,b,c);\r
+ call ecrit_text(200,325,"Coordonnes deuxieme droite");\r
+ call equat(a1,b1,c1);\r
+ fi;\r
+ \r
+ l1:= new line(a,b,c);\r
+ l2:= new line(a1,b1,c1);\r
+ centre:=l1.meet(l2);\r
+ \r
+ array tab1 dim(1:5000);\r
+ call move(1,307);\r
+ tab1:=getmap(636,349);\r
+ call des_droite(a,b,c,pb);\r
+ call des_droite(a1,b1,c1,pb1);\r
+ call move(1,307);\r
+ call putmap(tab1);\r
+ \r
+ if pb or pb1 then\r
+ call ecrit_text(250,325,"Probleme de saisie de droite ");\r
+ else\r
+ if centre=/=none\r
+ then\r
+ call ecrit_text(200,325,"Le point d'intersection a pour coordonnee : ");\r
+ call ecrit_entier(560,325,centre.x);\r
+ (* call ecrit_entier(560,335,centre.y); *)\r
+ else\r
+ call ecrit_text(200,325,"Il n'y a pas de point d'intersection");\r
+ fi;\r
+ fi;\r
+ rep:=0;\r
+ CALL ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* parallelisme de deux droites *)\r
+ when 4: call ecrit_text(10,325,"Equation/P (1/2): ");\r
+ rep2:=lire_entier(154,325);\r
+ if rep2 = 2\r
+ then\r
+ call ecrit_text(280,325,"Premiere droite");\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a,b,c);\r
+ call ecrit_text(280,325,"Deuxieme droite");\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a1,b1,c1);\r
+ else\r
+ call ecrit_text(280,325,"Premiere droite");\r
+ call equat(a,b,c);\r
+ call ecrit_text(280,325,"Deuxieme droite");\r
+ call equat(a1,b1,c1);\r
+ fi;\r
+ \r
+ l1:= new line(a,b,c);\r
+ l2:= new line(a1,b1,c1);\r
+ \r
+ array tab1 dim(1:5000);\r
+ call move(1,307);\r
+ tab1:=getmap(636,349);\r
+ call des_droite(a,b,c,pb);\r
+ call des_droite(a,b,c,pb1);\r
+ call move(1,307);\r
+ call putmap(tab1);\r
+ \r
+ if pb or pb1 then\r
+ call ecrit_text(250,325,"Probleme de saisie de droite ");\r
+ else\r
+ if l1.parallele(l2)\r
+ then\r
+ call ecrit_text(280,325,"Les droites sont paralleles");\r
+ else\r
+ call ecrit_text(280,325,"Les droites ne sont pas paralleles");\r
+ fi;\r
+ fi;\r
+ rep:=0;\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* perpendicularite de deux droites *)\r
+ when 5: call ecrit_text(10,325,"Equation/P (1/2): ");\r
+ rep2:=lire_entier(154,325);\r
+ if rep2 = 2\r
+ then\r
+ call ecrit_text(280,325,"Premiere droite");\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a,b,c);\r
+ call ecrit_text(280,325,"Deuxieme droite");\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a1,b1,c1);\r
+ else\r
+ call ecrit_text(280,325,"Premiere droite");\r
+ call equat(a,b,c);\r
+ call ecrit_text(280,325,"Deuxieme droite");\r
+ call equat(a1,b1,c1);\r
+ fi;\r
+ \r
+ array tab1 dim(1:5000);\r
+ call move(1,307);\r
+ tab1:=getmap(636,349);\r
+ call des_droite(a,b,c,pb);\r
+ call des_droite(a,b,c,pb);\r
+ call move(1,307);\r
+ call putmap(tab1);\r
+ l1:= new line(a,b,c);\r
+ l2:= new line(a1,b1,c1);\r
+ \r
+ if pb or pb1 then\r
+ call ecrit_text(250,325,"Probleme de saisie de droite ");\r
+ else\r
+ if l1.perpendiculaire(l2)\r
+ then\r
+ call ecrit_text(280,325,"Les droites sont perpendiculaires");\r
+ else\r
+ call ecrit_text(280,325,"Les droites ne sont pas perpendiculaires");\r
+ fi;\r
+ fi;\r
+ rep:=0;\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* appartenance d'un point a une droite *)\r
+ when 6: call ecrit_text(10,320,"Determination de la droite");\r
+ call ecrit_text(10,330,"Equation/P (1/2): ");\r
+ rep2:=lire_entier(154,330);\r
+ if rep2 = 2\r
+ then\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a,b,c);\r
+ else\r
+ call ecrit_text(300,325,"Coordonnees droite");\r
+ call equat(a,b,c);\r
+ fi;\r
+ call ecrit_text(300,325,"Coordonnees point ");\r
+ call def_point(x1,y1);\r
+ p1:= new pt(x1,y1);\r
+ l1:= new line(a,b,c);\r
+ call point(x1,y1);\r
+ \r
+ array tab1 dim(1:5000);\r
+ call move(1,307);\r
+ tab1:=getmap(636,349);\r
+ call des_droite(a,b,c,pb);\r
+ call move(1,307);\r
+ call putmap(tab1);\r
+ \r
+ if pb\r
+ then\r
+ call ecrit_text(250,325,"Probleme de saisie de la droite ");\r
+ else\r
+ if l1.ptappartligne(p1)\r
+ then\r
+ call ecrit_text(250,325,"Le point appartient a la droite");\r
+ else\r
+ call ecrit_text(250,325,"Le point n'appartient pas a la droite");\r
+ fi;\r
+ fi;\r
+ rep:=0;\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* appartenance d'un point a un cercle *)\r
+ when 7: call ecrit_text(200,325,"Determination du point");\r
+ call def_point(x1,y1);\r
+ p1:=new pt(x1,y1);\r
+ call point(454+10*x1,154-10*y1);\r
+ call ecrit_text(200,325," ");\r
+ call ecrit_text(100,325,"Determination du cercle");\r
+ call def_cercle(x1,y1,r);\r
+ call point(x1*10+425,154-y1*10);\r
+ call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
+ p2:=new pt(x1,y1);\r
+ c2:= new cercle(p2,r);\r
+ call ecrit_text(100,325," ");\r
+ \r
+ if c2.ptappartcercle(p1,epsilon)\r
+ then\r
+ call ecrit_text(250,325,"Le point appartient au cercle");\r
+ else\r
+ call ecrit_text(250,325,"Le point n'appartient pas au cercle");\r
+ fi;\r
+ rep:=0;\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* intersection entre deux cercles *)\r
+ when 8: call ecrit_text(10,325,"Pour le premier cercle");\r
+ call def_cercle(x1,y1,r);\r
+ call point(x1*10+425,154-y1*10);\r
+ call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
+ p1:=new pt(x1,y1);\r
+ c2:= new cercle(p1,r);\r
+ call ecrit_text(10,325,"Pour le second cercle ");\r
+ call def_cercle(x1,y1,r);\r
+ call point(x1*10+425,154-y1*10);\r
+ call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
+ p2:=new pt(x1,y1);\r
+ c3:= new cercle(p2,r);\r
+ \r
+ l1:=c2.intersec(c3);\r
+ call ecrit_text(10,325," ");\r
+ call ecrit_text(200,325,"La droite a pour equation");\r
+ rep:=0;\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* deux points d'un meme cote d'une droite *)\r
+ when 9: call ecrit_text(10,320,"Determination de la droite");\r
+ call ecrit_text(10,330,"Equation/P (1/2): ");\r
+ rep2:=lire_entier(154,330);\r
+ if rep2 = 2\r
+ then\r
+ call equation(x1,y1,x2,y2);\r
+ p1:= new pt(x1,y1);\r
+ p2:= new pt(x2,y2);\r
+ call p1.calculeq(p2,a,b,c);\r
+ else\r
+ call ecrit_text(280,325,"Coordonnees droite");\r
+ call equat(a,b,c);\r
+ fi;\r
+ call ecrit_text(280,325,"Coordonnees premier point ");\r
+ call def_point(x1,y1);\r
+ call point(425+10*x1,154-10*y1);\r
+ p1:= new pt(x1,y1);\r
+ call ecrit_text(280,325,"Coordonnees second point ");\r
+ call def_point(x1,y1);\r
+ call point(425+10*x1,154-10*y1);\r
+ p2:= new pt(x1,y1);\r
+ \r
+ array tab1 dim(1:5000);\r
+ call move(1,307);\r
+ tab1:=getmap(636,349);\r
+ call des_droite(a,b,c,pb);\r
+ call move(1,307);\r
+ call putmap(tab1);\r
+ \r
+ l1:= new line(a,b,c);\r
+ if pb\r
+ then\r
+ call ecrit_text(250,325,"Probleme de saisie de la droite ");\r
+ else\r
+ if p1.memecote(l1,p2)\r
+ then\r
+ call ecrit_text(280,325,"Les deux points sont du meme cote");\r
+ else\r
+ call ecrit_text(280,325,"Les deux points ne sont pas du meme cote");\r
+ fi;\r
+ fi;\r
+ rep:=0;\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ call attente;\r
+ \r
+ (* quitter *)\r
+ when 10: ch:=0;\r
+ while ch<1 or ch>2\r
+ do\r
+ call ecrit_text(10,325,"Voulez-vous vraiment : ");\r
+ call ecrit_text(220,320,"1: Quitter le programme ");\r
+ call ecrit_text(220,335,"2: Continuer ");\r
+ call ecrit_text(450,325,"Votre choix : ");\r
+ ch:=lire_entier(562,325);\r
+ call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
+ case ch\r
+ when 1: fin:=true;\r
+ when 2: exit;exit;rep:=0;\r
+ esac;\r
+ od;\r
+ esac;\r
+ od;\r
+ od;\r
+ \r
+ (* FERMETURE DU MODE GRAPHIQUE *)\r
+ call closegraph;\r
+end;\r
+end;\r
+end;\r
+end geometrie;\r
--- /dev/null
+ program hull;
+ (*******************************************************************)
+ (* OUTILS CONCERNANT L'AFFICHAGE DU TEXTE A L'ECRAN *)
+ (*******************************************************************)
+
+ (* Efface l'ecran et positionne le curseur en haut a gauche *)
+ UNIT CLS : PROCEDURE;
+ BEGIN
+ WRITE( chr(27), "[2J");
+ END CLS;
+
+
+ (* Affiche du texte en video inverse *)
+ UNIT Reverse : PROCEDURE;
+ BEGIN
+ WRITE( chr(27), "[7m"); END Reverse;
+
+
+ (* Affiche du texte en clignotant *)
+ UNIT Blink : PROCEDURE;
+ BEGIN
+ WRITE( chr(27), "[5m");
+ END Blink;
+
+
+ (* Affiche le texte de maniere normale *)
+ UNIT Normal : PROCEDURE;
+ BEGIN
+ WRITE( chr(27), "[0m")
+ END Normal;
+
+
+ (* Positionne le curseur sur un emplacement de l'ecran *)
+
+ UNIT Setcursor : PROCEDURE (row,column : INTEGER);
+ VAR c,d,e,f : CHAR,
+ i,j : INTEGER;
+ BEGIN
+ i:=row div 10;
+ j:=row mod 10;
+ c:=chr(48+i);
+ d:=chr(48+j);
+ i:=column div 10;
+ j:=column mod 10;
+ e:=chr(48+i);
+ f:=chr(48+j);
+
+ Write(chr(27), "[",c,d, ";",e,f, "H");
+ END Setcursor;
+
+ (* Unite qui sert a tracer un cadre *)
+
+ unit cadre: procedure (x1,y1,x2,y2 : integer);
+ var i , j : integer;
+ Begin
+ for i := x1 to x2 do
+ call setcursor(i,y1);
+ write("*");
+ od;
+ for i := x1 to x2 do
+ call setcursor(i,y2);
+ write ("*");
+ od;
+ for i := y1 to y2 do
+ call setcursor(x1,i);
+ write ("*");
+ od;
+ for i := y1 to y2 do
+ call setcursor(x2,i);
+ write ("*");
+ od;
+ End cadre;
+
+ (**************************** CADRE_T **********************************************)
+ unit cadre_t : procedure;
+ begin
+ call cls;
+ call cadre (1,1,30,85);
+ call cadre (2,20,4,70);
+ call setcursor (3,40);
+ CALL reverse;
+ write ("ENVELOPPE CONVEXE ");
+ CALL normal;
+ end cadre_t;
+
+ (************************** FIN CADRE_T *********************************************)
+
+ (*************************** PRESENTS_1*********************************************)
+ unit presents_1 : procedure;
+ begin
+ call cadre_t;
+ call setcursor (10,40);
+ write (" projet realise par : ");
+ call setcursor (10,60);
+ Write (" JOUANNY jean-pierre ");
+ call setcursor(14,40);
+ Write (" LICENCE INFORMATIQUE ");
+
+ end presents_1;
+ (************************** FIN PRESENTS_1 *****************************************)
+
+
+
+ (***************************** MENU *************************************************)
+ unit menu : procedure;
+ begin
+ call cls;
+ call setcursor(10,30);
+ write("1 : PACKED WRAPPING");
+ CALL SETCURSOR(12,30);
+ WRITE("2 : GRAHAM_SCAN");
+ CALL SETCURSOR(14,30);
+ WRITE("3 : SORTIR");
+ CALL CADRE(30,1,32,80);
+ CALL SETCURSOR(34,30);
+ WRITE("ACTION : ")
+ END MENU;
+
+(************************** FIN MENU **********************************************)
+
+(* unit exprimant un point en coordonnees cartesiennes*)
+unit pixl:class(ab,ordo:real);end pixl;
+
+(* unit exprimant un point en coordonnees polaires *)
+unit point:class(p:pixl,teta:real); end point;
+
+(***********************************************************)
+(* unit qui permettra a l utilisateur de saisir des points *)
+(***********************************************************)
+unit lecture:function(i:integer):pixl;
+ begin
+ result:=new pixl(0,0);
+ call cls;
+ call setcursor(10,30);
+ write("entrez l'abcisse n:",i,":" );
+ read (result.ab);
+ call setcursor(15,30);
+ write("entrez l'ordonnee n:",i,":" );
+ read(result.ordo);
+ end lecture;
+(***********************************************************)
+(*unit graphe est une classe qui contiendra les procedures *)
+(* et les fonctions destinees dans le cadre de la methode *)
+(* de "package wrapping" ou enveloppe a calculer les points*)
+(* de l'enveloppe convexe *)
+(***********************************************************)
+unit graphe:class(function readelem(i:integer):pixl);
+(***********************************************************)
+(* unit lire est destinee a initialiser le tableau qui *)
+(* contiendra les points du nuage. *)
+(***********************************************************)
+ unit lire:procedure(output g:arrayof pixl;input n:integer);
+ var
+ i:integer;
+ begin
+ array g dim(1:100); (* initialisation du tableau de sortie *)
+ for i:=1 to n do
+ g(i):=readelem(i); (* utilisation de la fonction readelem passee
+ comme parametre d'entree dans la classe
+ graphe. *)
+ od;
+ end lire;
+
+(******************************************************************)
+(* cette fonction est destinee a convertir les gradients en degre *)
+(******************************************************************)
+unit degre:function(x:real):real;
+ begin
+ result:=(x/3.14)*180;
+ end degre;
+(******************************************************************)
+(* cette fonction appelee "angle_montant" calcule a partir des *)
+(* coordonnees d'un point l'angle que ce dernier formera avec *)
+(* l'horizontale. *)
+(******************************************************************)
+unit angle_montant:function(variable:pixl):real;
+ var
+ distance:integer,pi,teta:real;
+ begin
+ pi:=3.14;
+ if variable.ab=0 then
+ result:=degre(pi/2);
+ else
+ teta:=atan((variable.ordo)/(variable.ab));
+ (*la fonction arc tangente permet a partir du rapport cote oppose
+ sur cote adjacent de donner l'angle en radient. *)
+ if variable.ordo>0 then
+ if (variable.ab <0) then
+ result:=degre(pi+teta); (*transformation de l'angle negatif
+ en sa valeur positive d'angle
+ obtus. *)
+ else
+ result:=degre(teta);
+ fi;
+ else
+ if variable.ab<0 then
+ result:=degre(pi+teta);
+ else
+ result:=degre(2*pi+teta);
+ fi;
+ fi
+ fi;
+ end angle_montant;
+
+(********************************************************************)
+(* cette fonction determine de bas en haut les points appartenant a *)
+(* l'enveloppe convexe. *)
+(********************************************************************)
+unit calcul_montant:procedure(output gt:arrayof pixl;inout cpt:integer,
+ fini:boolean,h:integer;input n:integer;inout g:arrayof pixl);
+ var
+ max,lowest,pi:real,min,i,value,p,maxi:integer,variable,pas:pixl;
+ begin
+array gt dim(1:100); (* initialisation des tableaux de sortie *)
+ h:=1;
+ min:=1;
+ max:=1;
+ fini:=false;
+ for i:=2 to n do (*recherche du point d'ordonnee minimal
+ a partir duquel s'effectuera la recherche
+ des autres points de la partie montante de
+ l'enveloppe convexe. *)
+ if g(i).ordo<g(min).ordo then
+ min:=i;
+ fi;
+ od;
+ for i:=2 to n do
+ if g(i).ordo>g(max).ordo then
+ max:=i;
+ fi;
+ od;
+ pas:=g(max);
+ gt(h):=g(min);
+ while not fini do
+ maxi:=360;
+ if n<=1 then exit; fi;
+ for i:=1 to n do
+ variable:=new pixl (g(i).ab-gt(h).ab,g(i).ordo-gt(h).ordo);
+ lowest:=angle_montant(variable);
+ if maxi>lowest then
+ maxi:=lowest;
+ value:=i;
+ fi;
+ od;
+ h:=h+1;
+ (* on enregistre dans gt les points qui formeront
+ l'enveloppe convexe.*)
+ min:=value;
+ gt(h):=g(min);
+ g(min):=g(n);
+ n:=n-1;
+ if gt(h)=pas then
+ cpt:=n;
+ fini:=true;
+ exit;
+ fi;
+ od;
+ end calcul_montant;
+ (***********************************************************************)
+ (*cette fonction permet de calculer a partir des coordonnees d'un point*)
+ (* l'angle que ce dernier formera avec l'horizontale. *)
+ (***********************************************************************)
+ unit angle_descendant:function(variable:pixl):real;
+ var
+ pi,teta:real;
+ begin
+ pi:=3.14;
+ if variable.ab=0 then
+ if variable.ordo>0 then
+ result:=400;
+ else
+ result:=degre(3*pi/2);
+ fi;
+ else
+ teta:=atan((variable.ordo)/(variable.ab));
+ if variable.ordo>0 then
+ result:=400; (* afin de ne pas selectionner un point qui serait
+ responsable d'une concavite. *)
+ else
+ if variable.ab<0 then
+ result:=degre(teta+pi);
+ else
+ result:=degre(2*pi+teta);
+ fi;
+ fi;
+ fi;
+ end angle_descendant;
+
+(*********************************************************************)
+(* cette fonction determine de haut en bas les points appartenant a *)
+(* l'enveloppe convexe. *)
+(*********************************************************************)
+
+ unit calcul_descendant:procedure(inout gt:arrayof pixl;input g:arrayof pixl,
+ n:integer;inout h:integer);
+ var
+ p,i,max,value:integer,lowest:real,termine:boolean,variable:pixl;
+ begin
+ termine:=false;
+ if n<1 then exit fi;
+ while not termine do
+ max:=720;
+ for i:=1 to n do (*les points qui seront sur l'enveloppe convexe de
+ la partie descendante devront avoir l'angle
+ compris entre le segment joignant la base a eux memes
+ et l'horizontale passant par la base ,le plus petit qui
+ soit dans l'intervalle [180,360]. *)
+
+ variable:=new pixl(g(i).ab-gt(h).ab,g(i).ordo-gt(h).ordo);
+ lowest:=angle_descendant(variable);
+ if max>lowest then
+ max:=lowest;
+ value:=i;
+ fi;
+ od;
+ h:=h+1; (* on enregistre dans gt les nouveaux points de l'enveloppe *)
+ gt(h):=g(value);
+ g(value):=g(n);
+ n:=n-1;
+ if n<1 then (* si nous n'avons plus qu'un point dans le tableau d'entree
+ nous avons termine*)
+ termine:=true;
+ else
+ if gt(h)=gt(1) then (* si nous retombons sur le premier point cela est
+ fini. *)
+ exit;
+ fi;
+ fi;
+ od;
+ end calcul_descendant;
+
+
+ unit dessin:procedure(input gt:arrayof pixl,h:integer,
+ gu:arrayof pixl,nb:integer,vrai:boolean);
+ var
+ i:integer;
+ begin
+ pref iiuwgraph block
+ begin
+ call hpage(0,0,0);
+ call hpage(0,1000,500);
+ call gron(0);
+ call move(0,250);
+ call draw(1000,250);
+ call move(500,0);
+ call draw(500,500);
+ for i:=1 to nb do
+ call point(gu(i).ab,gu(i).ordo);
+ od;
+ call move(10*gt(1).ab+500,10*(-gt(1).ordo)+250);
+ for i:=2 to h do
+ call draw(10*(gt(i).ab)+500,10*(-gt(i).ordo)+250);
+ od;
+ if vrai then
+ call draw(10*(gt(1).ab)+500,10*(-gt(1).ordo)+250);
+ fi;
+ readln;
+end;
+ end dessin;
+end graphe;
+
+(******************************************************************************)
+(* unit graphe2 est une classe qui herite de la classe graphe ,elle contiendra*)
+(* les procedures et les fonctions destinees dans le cadre de la methode dite *)
+(* de Graham_scan a calculer les points constituant l'enveloppe convexe d'un *)
+(* nuage de points donnes en entree. *)
+(******************************************************************************)
+ unit graphe2: graphe class;
+(* classe qui permet de definir une droite c'est a dire deux points *)
+ unit line:class(p1:pixl,p2:pixl);
+ end line;
+
+(*******************************************************************************)
+(* procedure qui en entree recoit des points en coordonnees cartesiennes et qui*)
+(* leur associe un angle en plus en sortie,nous avons donc des coordonnees *)
+(* polaires. *)
+(*******************************************************************************)
+ unit recuperer:procedure(input ge:arrayof pixl;inout gtr:arrayof point;n:integer);
+ var
+ variable,t:pixl,min,i:integer,elem:real;
+ begin
+ min:=1;
+ for i:=2 to n do (* recherche du point d'ordonnee minimal,qui desormais sera
+ la base du nouveau repere. *)
+ if ge(i).ordo<ge(min).ordo then
+ min:=i;
+ fi;
+ od;
+ t:=ge(1);ge(1):=ge(min);ge(min):=t;
+ gtr(1):=new point(ge(1),0);
+ for i:=2 to n do (* calcul de l'angle associe a chaque point *)
+ variable:=new pixl (ge(i).ab-ge(1).ab,ge(i).ordo-ge(1).ordo);
+ elem:=angle_montant(variable);
+ gtr(i):=new point (ge(i),elem); (* tous les points sont maintenant dans
+ un tableau pour chacun nous possedons
+ un angle avec l'horizontale. *)
+ od;
+ end recuperer;
+
+ (*******************************************************************)
+ (* function associe au tri par insertion dichotomique elle renvoie *)
+ (* l'indice ou l'on inserera les valeurs a leur juste place. *)
+ (*******************************************************************)
+ unit rang:function(input gtr:arrayof point,p,q:integer,x:point):integer;
+ var
+ mil:integer;
+ begin
+ if p=q then
+ result:=p;
+ else
+ mil:=(p+q) div 2;
+ if x.teta<gtr(mil).teta then
+ result:=rang(gtr,p,mil,x);
+ else
+ result:=rang(gtr,mil+1,q,x);
+ fi;
+ fi;
+ end rang;
+ (*********************************************************************)
+ (* fonction effectuant un tri par insertion dichotomique nous *)
+ (* obtiendrons ainsi un tableau trie sur la valeur de l'angle associe*)
+ (* a chaque point et cela dans le sens croissant. *)
+ (*********************************************************************)
+ unit tri_insert_dicho:procedure(inout gtr:arrayof point;input i:integer);
+ var j,k:integer,x:point;
+ begin
+ if i>1 then
+ call tri_insert_dicho(gtr,i-1);
+ if gtr(i-1).teta>gtr(i).teta then
+ k:=rang(gtr,1,i-1,gtr(i));
+ x:=gtr(i);
+ for j:=i-1 downto k do
+ gtr(j+1):=gtr(j);
+ od;
+ gtr(k):=x;
+ fi;
+ fi;
+ end tri_insert_dicho;
+ (**********************************************************************)
+ (* fonction qui calcule un double determinant cela afin de savoir si *)
+ (* deux droites se trouvent ou non de part et d'autre d'une premiere *)
+ (* droite. *)
+ (**********************************************************************)
+ unit same:function (l:line;p1,p2:pixl):real;
+ var
+ dx,dy,dx1,dx2,dy1,dy2:integer;
+ begin
+ dx:=l.p2.ab-l.p1.ab;
+ dy:=l.p2.ordo-l.p1.ordo;
+ dx1:=p1.ab-l.p1.ab;
+ dy1:=p1.ordo-l.p1.ordo;
+ dx2:=p2.ab-l.p2.ab;
+ dy2:=p2.ordo-l.p2.ordo;
+ result:=(dx*dy1-dy*dx1)*(dx*dy2-dy*dx2);
+ end same;
+ (***********************************************************************)
+ (* Graham scan determine ou non si un point appartient a l'enveloppe *)
+ (* convexe cela a l'aide du resultat de same.Si same est positif p[k] *)
+ (* appartient a l'enveloppe car la droite (p[k],p[k-1]) ne coupe pas *)
+ (* la droite (p[1],p[i]) ou p[i] est le point nouveau de l'enveloppe *)
+ (* et p[1] la base du repere ici,le point d'ordonnee le plus bas. *)
+ (***********************************************************************)
+ unit graham_scan:procedure(ge:arrayof pixl,n:integer;output gtr:arrayof point;
+ output m:integer);
+ var
+ cpt,i,j:integer,l:line,t:point;
+ begin
+ array gtr dim(1:n);
+ call recuperer(ge,gtr,n);
+ call tri_insert_dicho(gtr,n);
+ m:=2;
+ for i:=4 to n do
+ m:=m+2;
+ do
+ m:=m-1;
+ l:=new line(gtr(m).p,gtr(m-1).p);
+ cpt:=same(l,gtr(1).p,gtr(i).p);
+ if cpt>=0 then exit; fi;
+ od;
+ t:=gtr(m+1);
+ gtr(m+1):=gtr(i);
+ gtr(i):=t;
+ od;
+ end graham_scan;
+ end graphe2;
+ (* fin de la classe graphe2 et de la partie programmation *)
+
+ (**** PROGRAMME PRINCIPAL ****)
+ var
+ gt,g,genv,ge,gen,gu:arrayof pixl,nuage:graphe,nuage1:graphe2,n,cpt,h,
+ m:integer,
+ fini,vrai:boolean,toucher,ch:char,
+ gtr:arrayof point,rep,rep_1,rep_3,i,j,nb:integer,rep_2:char;
+ begin
+ array gu dim(1:100);
+ array genv dim(1:100);
+ call presents_1;
+ read(toucher);
+ call cls;
+ h:=0;
+ nb:=0;
+ cpt:=0;
+ do
+ call menu;
+ read(rep);
+ case rep
+ when 1:
+ call cls;
+ vrai:=false;
+ call setcursor(6,40);
+ write(" PACKAGE WRAPPED ");
+ call setcursor(34,20);
+ write ("indiquez le nombre de points a saisir:");
+ read(n);
+ nb:=n;
+ nuage:=new graphe(lecture);
+ call nuage.lire(g,n);
+ for i:=1 to nb do
+ gu(i):=g(i);
+ gu(i):=new pixl(10*(gu(i).ab)+500,10*(-gu(i).ordo)+250);
+ od;
+ call nuage.calcul_montant(gt,cpt,fini,h,n,g);
+ if fini then
+ call nuage.calcul_descendant(gt,g,cpt,h);
+ fi;
+ writeln("POINTS QUI COMPOSENT L'ENVELOPPE");
+ for i:=1 to h do
+ writeln(gt(i).ab,gt(i).ordo);
+ od;
+ writeln("tapez entree pour en voir la representation graphique");
+ readln;
+ call nuage.dessin(gt,h,gu,nb,vrai);
+ readln;
+ call setcursor(34,20);
+ write("tapez entree pour la suite");
+ read(rep_1);
+ exit;
+
+ when 2:
+ call cls;
+ vrai:=true;
+ call setcursor(6,40);
+ write (" GRAHAM_SCAN ");
+ call cadre (33,1,35,99);
+ call setcursor (34,20);
+ write ("Nombre de points du nuage ");
+ read(n);
+ nb:=n;
+ nuage1:=new graphe2(lecture);
+ call nuage1.lire(ge,n);
+ for i:=1 to nb do
+ gu(i):=ge(i);
+ gu(i):=new pixl(10*(gu(i).ab)+500,10*(-gu(i).ordo)+250);
+ od;
+ call nuage1.graham_scan(ge,n,gtr,m);
+ writeln("POINTS QUI COMPOSENT L'ENVELOPPE");
+ for i:=1 to m do
+ writeln(gtr(i).p.ab,gtr(i).p.ordo);
+ genv(i):=new pixl(gtr(i).p.ab,gtr(i).p.ordo);
+ od;
+ writeln("tapez entree pour en voir la representation graphique");
+ call nuage1.dessin(genv,m,gu,nb,vrai);
+ call setcursor(34,20);
+ write ("tapez entree pour revenir au sommaire");
+ read(rep_3);
+ while rep_3 =/=13
+ do
+ read(rep_3);
+ od;
+ exit;
+
+ when 3:
+ call cadre_t;
+ call setcursor(6,40);
+ write("Adieu a l'enveloppe convexe");
+ call cadre (33,1,35,99);
+ call setcursor(13,25);
+ write ("Etes vous decides");
+ read (rep_2);
+ while (rep_2=/='o') and (rep_2=/='O') do
+ call setcursor(13,50);
+ read(rep_2);
+ od;
+ call cls;
+ exit;
+ esac;
+ od;
+end.
+
+
+
+
+
--- /dev/null
+PROGRAM BD;\r
+ (*******************************************************************)\r
+ (* OUTILS CONCERNANT L'AFFICHAGE DU TEXTE A L'ECRAN *)\r
+ (*******************************************************************)\r
+ UNIT gest_ecran:CLASS;\r
+\r
+ (* Efface l'ecran et positionne le curseur en haut a gauche *)\r
+ UNIT cls : PROCEDURE;\r
+ BEGIN\r
+ WRITE( chr(27), "[2J");\r
+ END CLS;\r
+\r
+\r
+ (* Affiche du texte en video inverse *)\r
+ UNIT Reverse : PROCEDURE;\r
+ BEGIN\r
+ WRITE( chr(27), "[7m");\r
+ END Reverse;\r
+\r
+\r
+ (* Affiche le texte de maniere normale *)\r
+ UNIT Normal : PROCEDURE;\r
+ BEGIN\r
+ WRITE( chr(27), "[0m")\r
+ END Normal;\r
+\r
+\r
+ UNIT Setcursor : PROCEDURE (row,column : INTEGER);\r
+ VAR c,d,e,f : CHAR,\r
+ i,j : INTEGER;\r
+ BEGIN\r
+ i:=row div 10;\r
+ j:=row mod 10;\r
+ c:=chr(48+i);\r
+ d:=chr(48+j);\r
+ i:=column div 10;\r
+ j:=column mod 10;\r
+ e:=chr(48+i);\r
+ f:=chr(48+j);\r
+\r
+ Write(chr(27), "[",c,d, ";",e,f, "H");\r
+ END Setcursor;\r
+\r
+ (* unite qui sert a tracer un cadre *)\r
+\r
+ UNIT cadre: PROCEDURE (x1,y1,x2,y2 : integer);\r
+ var i , j : integer;\r
+ BEGIN\r
+ for i := x1 to x2 do\r
+ CALL setcursor(i,y1);\r
+ write("*");\r
+ od;\r
+ for i := x1 to x2 do\r
+ CALL setcursor(i,y2);\r
+ write ("*");\r
+ od;\r
+ for i := y1 to y2 do\r
+ CALL setcursor(x1,i);\r
+ write ("*");\r
+ od;\r
+ for i := y1 to y2 do\r
+ CALL setcursor(x2,i);\r
+ write ("*");\r
+ od;\r
+ END cadre;\r
+\r
+ END gest_ecran;\r
+\r
+ (**************************** CADRE_T **********************************************)\r
+ UNIT cadre_t:gest_ecran PROCEDURE;\r
+ BEGIN\r
+ CALL cls;\r
+ CALL cadre (1,1,22,80);\r
+ CALL cadre (1,1,3,80);\r
+ CALL setcursor (2,32);\r
+ CALL reverse;\r
+ write (" GESTION DE BIBLIOTHEQUE ");\r
+ CALL normal;\r
+ END cadre_t;\r
+\r
+\r
+ (*************************** PRESENTS_1*********************************************)\r
+ UNIT presents_1:gest_ecran PROCEDURE;\r
+ BEGIN\r
+ CALL cadre_t;\r
+ CALL setcursor (10,32);\r
+ CALL reverse;\r
+ write (" PROJET REALISE PAR : ");\r
+ CALL setcursor (12,32);\r
+ Write (" BOURGEAT - MANDONNAUD ");\r
+ CALL setcursor(14,32);\r
+ Write (" LICENCE INFORMATIQUE ");\r
+ CALL normal;\r
+ END presents_1;\r
+ \r
+ (****************************** chaine *****************)\r
+\r
+ UNIT chaine:CLASS;\r
+ VAR long:integer;\r
+ VAR ch : arrayof char;\r
+\r
+ UNIT lit : PROCEDURE;\r
+ VAR i:integer,\r
+ car:char;\r
+ BEGIN\r
+ i:=1;\r
+ read(car);\r
+ WHILE i<=long AND car=/=chr(10)\r
+ DO\r
+ ch(i):=car;\r
+ read(car);\r
+ i:=i+1;\r
+ OD;\r
+ END lit;\r
+\r
+ UNIT afi:PROCEDURE;\r
+ VAR i:integer;\r
+ BEGIN\r
+ i:=1;\r
+ FOR i:=1 TO long\r
+ DO\r
+ write(ch(i));\r
+ OD;\r
+ writeln;\r
+ END afi;\r
+\r
+ UNIT inff:FUNCTION(c2:chaine):boolean;\r
+ VAR i:integer;\r
+ BEGIN\r
+ i:=1;\r
+ IF long<=c2.long\r
+ THEN\r
+ WHILE ch(i)=c2.ch(i)\r
+ DO\r
+ i:=i+1;\r
+ IF i=long THEN exit; FI;\r
+ OD;\r
+ result:=ord(ch(i))<ord(c2.ch(i));\r
+ ELSE\r
+ WHILE ch(i)=c2.ch(i)\r
+ DO \r
+ i:=i+1;\r
+ IF i=c2.long THEN exit FI;\r
+ OD;\r
+ IF ord(ch(i))<ord(c2.ch(i)) \r
+ THEN result:=i<c2.long \r
+ ELSE result:=false \r
+ FI;\r
+ FI;\r
+ END inff;\r
+\r
+ UNIT eqq:FUNCTION(c2:chaine):boolean;\r
+ VAR i:integer;\r
+ BEGIN\r
+ i := 1;\r
+ IF long=c2.long\r
+ THEN\r
+ WHILE ord(ch(i)) = ord(c2.ch(i))\r
+ DO\r
+ i := i + 1;\r
+ IF i=long THEN exit FI;\r
+ OD;\r
+ result:=ch(i)=c2.ch(i);\r
+ ELSE\r
+ result:=FALSE;\r
+ FI;\r
+ END eqq;\r
+\r
+ UNIT copyy : PROCEDURE(xx : chaine);\r
+ VAR i:integer;\r
+ BEGIN\r
+ i:=1;\r
+ WHILE i<long\r
+ DO\r
+ ch(i):= xx.ch(i);\r
+ i:=i+1;\r
+ OD;\r
+ END copyy;\r
+\r
+ BEGIN\r
+ long:=30;\r
+ ARRAY ch DIM (1:long);\r
+ END chaine;\r
+\r
+\r
+\r
+\r
+\r
+\r
+(********************************** ELEMENT *****************************************)\r
+ UNIT element:CLASS;\r
+ VAR e:chaine;\r
+\r
+ UNIT sup:FUNCTION(e2:element):boolean;\r
+ BEGIN\r
+ result:=NOT (e.inff(e2.e)) AND NOT (e.eqq(e2.e));\r
+ END sup;\r
+\r
+ UNIT inf:FUNCTION(e2:element):boolean;\r
+ BEGIN\r
+ result:=e.inff(e2.e);\r
+ END inf;\r
+\r
+ UNIT eq:FUNCTION(e2:element):boolean;\r
+ BEGIN\r
+ result:=e.eqq(e2.e);\r
+ END eq;\r
+\r
+ UNIT lire : PROCEDURE;\r
+ BEGIN\r
+ CALL e.lit;\r
+ END lire;\r
+\r
+ UNIT VIRTUAL affich : PROCEDURE;\r
+ END affich;\r
+\r
+ BEGIN\r
+ e:=new chaine;\r
+ END element;\r
+\r
+ (************************ article ***************************)\r
+\r
+ UNIT article:element CLASS;\r
+ VAR i:integer,\r
+ c:arrayof chaine;\r
+\r
+ UNIT VIRTUAL affich:PROCEDURE;\r
+ BEGIN\r
+ CALL e.afi;\r
+ END affich;\r
+\r
+ BEGIN\r
+ ARRAY c DIM (1:2);\r
+ for i := 1 to 2\r
+ do\r
+ c(i) := new chaine;\r
+ od;\r
+ END article;\r
+\r
+ (******************* LISTE ***********************)\r
+\r
+ UNIT liste : CLASS;\r
+ VAR debut: noeud;\r
+\r
+ UNIT noeud : CLASS;\r
+ VAR clen : chaine,\r
+ suivant: noeud;\r
+ BEGIN\r
+ clen := new chaine;\r
+ END noeud;\r
+\r
+ UNIT insert : PROCEDURE(cle : chaine);\r
+ VAR nd,ndaux : noeud;\r
+ BEGIN\r
+ nd:=new noeud;\r
+ call nd.clen.copyy(cle);\r
+ IF debut=none\r
+ THEN\r
+ debut:=nd;\r
+ ELSE\r
+ ndaux:=debut;\r
+ debut:=nd;\r
+ debut.suivant:=ndaux;\r
+ FI;\r
+ END insert;\r
+\r
+ UNIT suppr : PROCEDURE(cle : chaine);\r
+ VAR nd,ndaux:noeud;\r
+ BEGIN\r
+ IF debut.clen.eqq(cle)\r
+ THEN\r
+ debut:=debut.suivant;\r
+ ELSE\r
+ ndaux:=debut;\r
+ nd:=ndaux.suivant;\r
+ WHILE NOT(nd.clen.eqq(cle))\r
+ DO\r
+ ndaux:=nd;\r
+ nd:=nd.suivant;\r
+ IF nd=none THEN EXIT FI;\r
+ OD;\r
+ IF nd<>none THEN ndaux:=nd.suivant FI;\r
+ FI; \r
+ END suppr;\r
+\r
+ UNIT affi:PROCEDURE;\r
+ VAR i:integer,\r
+ nd:noeud;\r
+ BEGIN\r
+ nd:=debut;\r
+ i:=1;\r
+ WHILE nd =/= none\r
+ DO\r
+ write("reference :");write(i); write(" ");\r
+ CALL nd.clen.afi;\r
+ i := i + 1;\r
+ nd:=nd.suivant;\r
+ OD;\r
+ END affi;\r
+ END liste;\r
+\r
+ (********************************** index_elem **********************************)\r
+ UNIT index_elem : element CLASS;\r
+ VAR lis : liste;\r
+ UNIT sup:FUNCTION(e2:element):boolean;\r
+ BEGIN\r
+ result:=NOT (e.inff(e2.e)) AND NOT (e.eqq(e2.e));\r
+ END sup;\r
+\r
+ UNIT inf:FUNCTION(e2:element):boolean;\r
+ BEGIN\r
+ result:=e.inff(e2.e);\r
+ END inf;\r
+\r
+ UNIT eq:FUNCTION(e2:element):boolean;\r
+ BEGIN\r
+ result:=e.eqq(e2.e);\r
+ END eq;\r
+\r
+ UNIT VIRTUAL affich : PROCEDURE ;\r
+ BEGIN\r
+ CALL e.afi;\r
+ END affich;\r
+\r
+ BEGIN\r
+ lis := new liste;\r
+ END index_elem;\r
+\r
+ (*********************** item ***************************************)\r
+\r
+ UNIT item : CLASS;\r
+ VAR key:element,\r
+ ptr:page;\r
+ BEGIN\r
+ key:=new element;\r
+ END item;\r
+\r
+\r
+(************************************** PAGE *****************************************)\r
+\r
+ UNIT page : CLASS(n:integer);\r
+ VAR m : integer,\r
+ p0: page,\r
+ e : arrayof item;\r
+\r
+ BEGIN (* creation de la page *)\r
+ array e dim(1:n*2);\r
+ for m:=1 to n*2 do e(m):=new item; od;\r
+ END page;\r
+\r
+\r
+\r
+(************************************** B_ARB ******************************************)\r
+UNIT Barb :gest_ecran CLASS(n : integer);\r
+\r
+VAR ROOT:page;\r
+\r
+ UNIT Search : PROCEDURE(input x:element,a:page; inout h:boolean,v:item);\r
+ VAR k,l,r:integer,\r
+ q:page,\r
+ u:item;\r
+\r
+ UNIT insert : PROCEDURE;\r
+ VAR i:integer, b:page;\r
+ BEGIN\r
+ IF a.m<(n*2) THEN\r
+ a.m:=a.m+1; h:=FALSE;\r
+ for i:=a.m downto (r+2)\r
+ do\r
+ a.e(i):=a.e(i-1);\r
+ od;\r
+ a.e(r+1):=u;\r
+ ELSE\r
+ b:=new page(n);\r
+ IF r<=n THEN\r
+ IF r=n THEN v:=u;\r
+ ELSE\r
+ v:=a.e(n);\r
+ for i:=n downto (r+2)\r
+ do\r
+ a.e(i):=a.e(i-1);\r
+ od;\r
+ a.e(r+1):=u;\r
+ FI;\r
+ for i:=1 to n\r
+ do\r
+ b.e(i):=a.e(i+n);\r
+ od;\r
+ ELSE\r
+ r:=r-n;\r
+ v:=a.e(n+1);\r
+ for i:=1 to (r-1)\r
+ do\r
+ b.e(i):=a.e(i+n+1);\r
+ od;\r
+ b.e(r):=u;\r
+ for i:=r+1 to n\r
+ do\r
+ b.e(i):=a.e(i+n);\r
+ od;\r
+ FI;\r
+ a.m:=n;\r
+ b.m:=n;\r
+ b.p0:=v.ptr;\r
+ v.ptr:=b;\r
+ FI;\r
+ END insert;\r
+\r
+ BEGIN (* Search *)\r
+ u:=new item;\r
+ IF a=none THEN\r
+ h:=TRUE;\r
+ v.key:=x;\r
+ v.ptr:=none;\r
+ ELSE\r
+ l:=1; r:=a.m;\r
+ DO\r
+ k:=(l+r) div 2;\r
+ (* writeln(" "); *)\r
+ IF NOT x.sup(a.e(k).key) THEN r:=k-1; FI;\r
+ IF NOT x.inf(a.e(k).key) THEN l:=k+1; FI;\r
+ IF r<l THEN exit; FI;\r
+ OD;\r
+ IF l-r>1 THEN h:=FALSE;\r
+ CALL setcursor(33,20);\r
+ WRITE ("Element deja dans l'arbre!");\r
+ ELSE\r
+ IF r=0 THEN q:=a.p0 ELSE q:=a.e(r).ptr; FI;\r
+ CALL Search(x,q,h,u);\r
+ IF h THEN CALL insert; FI;\r
+ FI;\r
+ FI;\r
+ END Search;\r
+\r
+\r
+ UNIT Inserer : PROCEDURE (newe : element);\r
+ VAR h:boolean,\r
+ pgaux:page,\r
+ u:item;\r
+ BEGIN\r
+ u:=new item;\r
+ CALL Search(newe,ROOT,h,u);\r
+ IF h THEN\r
+ pgaux:=ROOT;\r
+ ROOT:=new page(n);\r
+ ROOT.m:=1; ROOT.p0:=pgaux; ROOT.e(1):=u;\r
+ FI;\r
+ END Inserer;\r
+\r
+\r
+\r
+\r
+\r
+ UNIT delete :PROCEDURE(INPUT x:element, a:page; INOUT h:boolean);\r
+ VAR i,k,l,r : INTEGER,\r
+ q:page;\r
+\r
+ UNIT underflow : PROCEDURE(INPUT c,a: page, s:integer; INOUT h:boolean);\r
+ VAR b: page,\r
+ i,k,mb,mc: integer;\r
+ BEGIN\r
+ mc:=c.m;\r
+ IF s<mc THEN (* b <-- page qui se trouve a droite de a *)\r
+ s:=s+1;\r
+ b:=c.e(s).ptr;\r
+ mb:=b.m; k:=(mb-n+1) DIV 2;\r
+ (* k= Nombre d'elements disponibles sur la page b *)\r
+ a.e(n):=c.e(s);\r
+ a.e(n).ptr:=b.p0;\r
+\r
+ IF k>0 THEN (* Deplacer k elements de b vers a *)\r
+ FOR i:=1 TO k-1 DO a.e(i+n):=b.e(i) OD; i:=i-1;\r
+ c.e(s):=b.e(k);\r
+ b.p0:=b.e(k).ptr;\r
+ c.e(s).ptr:=b;\r
+ mb:=mb-k;\r
+ FOR i:=1 TO mb DO b.e(i):=b.e(i+k) OD; i:=i-1;\r
+ b.m:=mb;\r
+ a.m:=n-1+k;\r
+ h:=FALSE;\r
+ ELSE (* Il faut fusionner a et b *)\r
+ FOR i:=1 TO n DO a.e(i+n):=b.e(i) OD; i:=i-1;\r
+ FOR i:=s TO mc-1 DO c.e(i):=c.e(i+1) OD; i:=i-1;\r
+ a.m:=2*n; c.m:=mc-1;\r
+ h:=c.m<n; (*kill(b);*)\r
+ FI;\r
+ ELSE (* b <-- page qui se trouve a gauche de a *)\r
+ IF s=1 THEN b:=c.p0 ELSE b:=c.e(s-1).ptr FI;\r
+ mb:=b.m+1;\r
+ k:=(mb-n) DIV 2;\r
+ IF k>0 THEN (* Deplacer k elements de b vers a *)\r
+ FOR i:=n-1 DOWNTO 1 DO a.e(i+k):=a.e(i) OD; i:=i+1;\r
+ a.e(k):=c.e(s);\r
+ a.e(k).ptr:=a.p0;\r
+ mb:=mb-k;\r
+ FOR i:=k-1 DOWNTO 1 DO a.e(i):=b.e(i+mb) OD; i:=i+1;\r
+ a.p0:=b.e(mb).ptr;\r
+ c.e(s):=b.e(mb);\r
+ c.e(s).ptr:=a;\r
+ b.m:=mb-1; a.m:=n-1+k; h:=FALSE;\r
+ ELSE (* Il faut fusionner a et b *)\r
+ b.e(mb):=c.e(s);\r
+ b.e(mb).ptr:=a.p0;\r
+ FOR i:=1 TO n-1 DO b.e(i+mb):=a.e(i) OD; i:=i-1;\r
+ b.m:=2*n; c.m:=mc-1; h:=(c.m<n);\r
+ FI;\r
+ FI;\r
+ END underflow;\r
+\r
+ UNIT del : PROCEDURE(p:page; INOUT h:boolean);\r
+ VAR q:page;\r
+ BEGIN\r
+ q:=p.e(p.m).ptr;\r
+ IF q<>none THEN\r
+ CALL del(q,h);\r
+\r
+ IF h THEN CALL underflow(p,q,p.m,h);FI;\r
+ ELSE\r
+ p.e(p.m).ptr:=a.e(k).ptr;\r
+ a.e(k):=p.e(p.m);\r
+ p.m:=p.m-1;\r
+ h:=(p.m<n);\r
+ FI;\r
+ END del;\r
+\r
+ BEGIN\r
+ IF a=none THEN\r
+ WRITELN("L'element n'est pas dans l'arbre");\r
+ h:=FALSE;\r
+ ELSE\r
+ l:=1; r:=a.m;\r
+ DO (* recherche binaire dans la page a *)\r
+ k:=(l+r) div 2;\r
+ IF NOT x.sup(a.e(k).key) THEN r:=k-1; FI;\r
+ IF NOT x.inf(a.e(k).key) THEN l:=k+1; FI;\r
+ IF (l>r) THEN exit; FI;\r
+ OD;\r
+ IF r=0 THEN q:=a.p0 ELSE q:=a.e(r).ptr FI;\r
+ IF l-r >1 THEN\r
+ IF q=none THEN (* a est une feuille *)\r
+ a.m:=a.m-1;\r
+ h:=(a.m<n);\r
+ FOR i:=k TO a.m DO a.e(i):=a.e(i+1); OD; i:=i-1;\r
+ ELSE\r
+ CALL del (q,h);\r
+ IF h THEN CALL underflow(a,q,r,h); FI;\r
+ FI;\r
+ ELSE\r
+ CALL delete(x,q,h);\r
+ IF h THEN CALL underflow(a,q,r,h); FI;\r
+ FI;\r
+ FI;\r
+ END delete;\r
+\r
+\r
+ UNIT supprimer : PROCEDURE(newe:element);\r
+ VAR h:boolean,\r
+ pgaux:page;\r
+ BEGIN\r
+ CALL delete(newe,ROOT,h);\r
+ IF h THEN\r
+ IF root.m=0 THEN\r
+ pgaux:=root; root:=pgaux.p0; (* kill(pgaux); *)\r
+ FI;\r
+ FI;\r
+ END supprimer;\r
+\r
+(*************************************** MEMBER ****************************************************)\r
+\r
+ UNIT Member : FUNCTION(inout ele:element):boolean;\r
+ VAR existe:boolean,\r
+ k:integer,\r
+ paux:page;\r
+\r
+ UNIT Rech_page:FUNCTION(p:page) : integer;\r
+ VAR i:integer;\r
+ BEGIN\r
+ FOR i:=1 TO p.m\r
+ DO\r
+ IF ele.eq(p.e(i).key) THEN exit; FI;\r
+ IF ele.inf(p.e(i).key) THEN\r
+ i:=i-1;\r
+ exit;\r
+ FI;\r
+ OD;\r
+ if i>p.m then i:=i-1; fi;\r
+ result:=i;\r
+ END Rech_page;\r
+\r
+ BEGIN\r
+ existe:=FALSE;\r
+ paux:=root;\r
+ DO\r
+ IF (paux=none OR existe) THEN exit; FI;\r
+ k:= Rech_page(paux);\r
+ IF k=0 THEN paux:=paux.p0;\r
+ ELSE\r
+ IF paux.e(k).key.eq(ele) THEN\r
+ existe:=TRUE;\r
+ ele:= paux.e(k).key;\r
+ ELSE\r
+ paux:=paux.e(k).ptr;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ result:=existe;\r
+ END Member;\r
+\r
+\r
+(********************************************* MIN ****************************************************)\r
+\r
+ UNIT Min : FUNCTION(p:page): element;\r
+ BEGIN\r
+ IF p<>none THEN\r
+ DO\r
+ IF p.p0=none THEN\r
+ result:=p.e(1).key; exit;\r
+ ELSE\r
+ p:=p.p0;\r
+ FI;\r
+ OD;\r
+ FI;\r
+ END Min;\r
+\r
+(********************************************* MAX ****************************************************)\r
+ UNIT Max : FUNCTION(p:page): element;\r
+ BEGIN\r
+ IF p<>none THEN\r
+ DO\r
+ IF p.e(p.m).ptr=none THEN\r
+ result:=p.e(p.m).key; exit;\r
+ ELSE\r
+ p:=p.e(p.m).ptr;\r
+ FI;\r
+ OD;\r
+ FI;\r
+ END Max;\r
+\r
+(********************************************* LIST ****************************************************)\r
+ UNIT List : PROCEDURE(p:page;inout ligne,colonne : integer);\r
+ var\r
+ i : integer;\r
+\r
+ BEGIN\r
+\r
+ IF ligne = 24 THEN\r
+ ligne := 8;\r
+ colonne := colonne + 10;\r
+ FI;\r
+\r
+ IF P<>none THEN\r
+ IF (p.p0=none) THEN\r
+ IF (p.m>0) THEN\r
+ CALL setcursor(ligne,colonne);\r
+ CALL p.e(1).key.Affich;\r
+ ligne := ligne + 1;\r
+ fi;\r
+ ELSE\r
+ ligne := ligne + 1;\r
+ CALL list(p.p0,ligne,colonne);\r
+ CALL setcursor(ligne,colonne);\r
+ CALL p.e(1).key.Affich;\r
+\r
+ FI;\r
+ FOR i:=1 TO p.m\r
+ DO\r
+ IF p.e(i).ptr=none THEN\r
+ IF i<p.m THEN\r
+ CALL setcursor(ligne,colonne);\r
+ CALL p.e(i+1).key.Affich;\r
+ ligne := ligne +1;\r
+ FI;\r
+ ELSE\r
+ ligne := ligne + 1;\r
+ CALL List(p.e(i).ptr,ligne,colonne);\r
+ IF i<p.m THEN\r
+ CALL setcursor(ligne,colonne);\r
+ CALL p.e(i+1).key.Affich;\r
+ (* ligne := ligne + 1; *)\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FI;\r
+ END List;\r
+\r
+(****************************************** ERASE ******************************************************)\r
+\r
+UNIT Erase : PROCEDURE(p:page);\r
+ var i:integer;\r
+ BEGIN\r
+ IF P<>none THEN\r
+ IF (p.p0=none) THEN\r
+ IF (p.m>0) THEN Kill(p.e(1).key); fi;\r
+ ELSE\r
+ CALL Erase(p.p0);\r
+ Kill(p.p0);\r
+ Kill(p.e(1).key);\r
+ FI;\r
+ FOR i:=1 TO p.m\r
+ DO\r
+ IF p.e(i).ptr=none THEN\r
+ IF i<p.m THEN\r
+ Kill(p.e(i+1).key);\r
+ FI;\r
+ ELSE\r
+ CALL Erase(p.e(i).ptr);\r
+ Kill(p.e(i).ptr);\r
+ IF i<p.m THEN\r
+ Kill(p.e(i+1).key);\r
+ FI;\r
+ FI;\r
+ Kill(p.e(i));\r
+ OD;\r
+ FI;\r
+ END Erase;\r
+\r
+\r
+BEGIN (* DEBUT BARB *)\r
+ ROOT:=none;\r
+END Barb;\r
+\r
+\r
+(**************************************************)\r
+(**************************************************)\r
+(**************************************************)\r
+\r
+\r
+\r
+\r
+ UNIT finn :gest_ecran PROCEDURE;\r
+ BEGIN\r
+ CALL setcursor(18,50);\r
+ write("menu pr\82c\82dent taper RC : ");\r
+ readln;\r
+ END finn;\r
+\r
+ UNIT menu :gest_ecran PROCEDURE;\r
+\r
+ var\r
+ ii : integer;\r
+ BEGIN\r
+ CALL presents_1;\r
+ CALL finn;\r
+ do\r
+ CALL cls;\r
+ CALL cadre(1,1,24,80);\r
+ CALL setcursor(1,30);\r
+ CALL reverse;\r
+ write("menu principal");\r
+ CALL setcursor(10,30);\r
+ write("1 : Inserer un livre");\r
+ CALL SETCURSOR(12,30);\r
+ WRITE("2 : supprimer un livre");\r
+ CALL SETCURSOR(14,30);\r
+ WRITE("3 : recherche");\r
+ CALL SETCURSOR(16,30);\r
+ WRITE("4 : liste");\r
+\r
+ CALL SETCURSOR(18,30);\r
+ WRITE("10 : fin");\r
+\r
+ CALL normal;\r
+ CALL setcursor(18,50);\r
+ readln(ii);\r
+ case ii\r
+ when 1 : CALL insertlivre;\r
+ when 2 : CALL supprilivre;\r
+ when 3 : CALL recherche;\r
+ when 4 : CALL llist;\r
+ when 10 : exit;\r
+ esac;\r
+ od;\r
+ END menu;\r
+\r
+ UNIT insertlivre :gest_ecran PROCEDURE;\r
+ VAR x,xret : article,\r
+ xmatiere,xm,xauteur,xa : index_elem;\r
+ BEGIN\r
+ CALL cls;\r
+ CALL cadre(1,1,22,80);\r
+ CALL setcursor(1,30);\r
+ CALL reverse;\r
+ write("inserer un livre");\r
+ CALL normal;\r
+\r
+ x := new article;\r
+ xmatiere := new index_elem;\r
+ xauteur := new index_elem;\r
+\r
+ CALL setcursor(10,15);\r
+ write("titre : ..............................");\r
+ CALL setcursor(10,27);\r
+ CALL x.e.lit;\r
+ CALL SETCURSOR(12,15);\r
+ WRITE("auteur : ..............................");\r
+ CALL setcursor(12,27);\r
+ CALL xauteur.e.lit;\r
+ CALL SETCURSOR(14,15);\r
+ WRITE("matiere : ..............................");\r
+ CALL setcursor(14,27);\r
+ CALL xmatiere.e.lit;\r
+\r
+ CALL x.c(1).copyy(xauteur.e);\r
+ CALL x.c(2).copyy(xmatiere.e);\r
+\r
+ IF bfiche.member(x)\r
+ THEN\r
+ write("existe deja");\r
+ ELSE\r
+ IF bmatiere.member(xmatiere)\r
+ THEN\r
+ CALL xmatiere.lis.insert(x.e);\r
+ ELSE\r
+ CALL bmatiere.inserer(xmatiere);\r
+ CALL xmatiere.lis.insert(x.e);\r
+ FI;\r
+ \r
+ IF bauteur.member(xauteur) \r
+ THEN\r
+ CALL xauteur.lis.insert(x.e);\r
+ ELSE\r
+ CALL xauteur.lis.insert(x.e);\r
+ CALL bauteur.inserer(xauteur);\r
+ FI;\r
+ CALL bfiche.inserer(x);\r
+ \r
+ FI;\r
+ CALL finn;\r
+\r
+ END insertlivre;\r
+\r
+\r
+ UNIT supprilivre :gest_ecran PROCEDURE;\r
+ VAR x : article,\r
+ xauteur,xa,xmatiere,xm:index_elem;\r
+ BEGIN\r
+ CALL cls;\r
+ CALL cadre(1,1,22,80);\r
+ CALL setcursor(1,30);\r
+ CALL reverse;\r
+ write("supprimer un livre");\r
+ CALL normal;\r
+ x:=new article;\r
+ xmatiere:=new index_elem;\r
+ xauteur:=new index_elem;\r
+\r
+ CALL setcursor(10,15);\r
+ write("titre : ..............................");\r
+ CALL setcursor(10,27);\r
+ CALL x.e.lit;\r
+ CALL SETCURSOR(12,15);\r
+ WRITE("auteur : ..............................");\r
+ CALL setcursor(12,27);\r
+ CALL xauteur.e.lit;\r
+ CALL SETCURSOR(14,15);\r
+ WRITE("matiere : ..............................");\r
+ CALL setcursor(14,27);\r
+ CALL xmatiere.e.lit;\r
+\r
+ CALL bfiche.supprimer(x);\r
+\r
+ IF bmatiere.member(xmatiere)\r
+ THEN\r
+ CALL xmatiere.lis.suppr(x.e);\r
+ IF xmatiere.lis.debut=none THEN CALL bmatiere.supprimer(xmatiere) FI;\r
+ FI;\r
+\r
+ IF bauteur.member(xauteur)\r
+ THEN\r
+ CALL xauteur.lis.suppr(x.e);\r
+ IF xauteur.lis.debut=none THEN CALL bauteur.supprimer(xauteur) FI;\r
+ FI;\r
+\r
+ CALL setcursor(18,50);\r
+ CALL finn;\r
+ END supprilivre;\r
+\r
+ UNIT recherche :gest_ecran PROCEDURE;\r
+ var\r
+ i : integer,\r
+ x : article,\r
+ xx : index_elem,\r
+ reponse : boolean,\r
+ c : chaine;\r
+ BEGIN\r
+ c := new chaine;\r
+ x := new article;\r
+ xx := new index_elem;\r
+ CALL cadre_t;\r
+ CALL reverse;\r
+ CALL setcursor(2,30);\r
+ write("recherche");\r
+ CALL normal;\r
+\r
+ CALL setcursor(10,15);\r
+ write("titre : 1");\r
+ CALL SETCURSOR(12,15);\r
+ WRITE("auteur : 2");\r
+ CALL SETCURSOR(14,15);\r
+ WRITE("matiere : 3");\r
+ CALL SETCURSOR(16,15);\r
+ WRITE("quel champ de recherche ");readln(i);\r
+ CALL SETCURSOR(18,15);\r
+ write("..............................");\r
+ CALL SETCURSOR(18,15);\r
+ CALL c.lit;\r
+ case i\r
+ when 1 :\r
+ CALL x.e.copyy(c);\r
+ reponse := bfiche.member(x);\r
+ CALL cadre_t;\r
+ CALL setcursor(4,30);\r
+ CALL reverse;\r
+ write(" RECHERCHE OUVRAGE ");\r
+ IF reponse \r
+ THEN\r
+ CALL normal;\r
+ CALL setcursor(10,15);\r
+ write("titre : ");\r
+ CALL setcursor(10,30);\r
+ CALL x.e.afi;\r
+ CALL SETCURSOR(12,15);\r
+ WRITE("auteur : ");\r
+ CALL setcursor(12,30);\r
+ CALL x.c(1).afi;\r
+ CALL SETCURSOR(14,15);\r
+ WRITE("matiere : ");\r
+ CALL SETCURSOR(14,30);\r
+ CALL x.c(2).afi;\r
+ ELSE\r
+ CALL normal;\r
+ CALL setcursor(10,15);\r
+ write("element inexistant");\r
+ FI;\r
+ when 2 :\r
+ CALL cadre_t;\r
+ CALL setcursor(4,30);\r
+ CALL reverse;\r
+ write(" RECHERCHE AUTEUR ");\r
+ CALL normal;\r
+ CALL xx.e.copyy(c);\r
+ reponse := bauteur.member(xx);\r
+ if reponse then\r
+ CALL reverse;\r
+ CALL setcursor(5,10);\r
+ CALL xx.e.afi;\r
+ CALL normal;\r
+ CALL xx.lis.affi;\r
+ else\r
+ CALL setcursor(10,15);\r
+ write("introuvable");\r
+ fi;\r
+ when 3 :\r
+ CALL cadre_t;\r
+ CALL setcursor(4,30);\r
+ CALL reverse;\r
+ write(" RECHERCHE MATIERE ");\r
+ CALL normal;\r
+ CALL xx.e.copyy(c);\r
+ reponse := bmatiere.member(xx);\r
+ CALL cls;\r
+ CALL cadre(1,1,22,80);\r
+ if reponse then\r
+ CALL reverse;\r
+ CALL setcursor(5,10);\r
+ CALL xx.e.afi;\r
+ CALL normal;\r
+ (* CALL setcursor(1,2); *)\r
+ CALL xx.lis.affi;\r
+ else\r
+ CALL setcursor(10,15);\r
+ write("introuvable");\r
+ fi;\r
+ esac;\r
+ CALL finn;\r
+\r
+ END recherche;\r
+\r
+\r
+ UNIT llist :gest_ecran PROCEDURE;\r
+ var\r
+ i,fin : integer,\r
+ lig,col : integer;\r
+ BEGIN\r
+\r
+ CALL cadre_t;\r
+ CALL reverse;\r
+ CALL setcursor(2,30);\r
+ write("recherche");\r
+ CALL normal;\r
+\r
+ CALL setcursor(10,15);\r
+ write("titre : 1");\r
+ CALL SETCURSOR(12,15);\r
+ WRITE("auteur : 2");\r
+ CALL SETCURSOR(14,15);\r
+ WRITE("matiere : 3");\r
+ CALL SETCURSOR(16,15);\r
+ WRITE("quel champ de liste ");readln(i);\r
+ case i\r
+ when 1 :\r
+ CALL cadre_t;\r
+ CALL setcursor(2,30);\r
+ CALL reverse;\r
+ write(" liste des ouvrages ");\r
+ CALL normal;\r
+ lig := 4;\r
+ col := 2;\r
+ CALL bfiche.list(bfiche.root,lig,col);\r
+ CALL setcursor(18,50);\r
+ CALL finn;\r
+ when 2:\r
+ CALL cadre_t;\r
+ CALL setcursor(2,30);\r
+ CALL reverse;\r
+ write(" liste des auteurs ");\r
+ CALL normal;\r
+ lig := 4;\r
+ col := 2;\r
+ CALL bauteur.list(bauteur.root,lig,col);\r
+ CALL finn;\r
+ when 3 :\r
+ CALL cadre_t;\r
+ CALL setcursor(4,30);\r
+ CALL reverse;\r
+ write(" liste des matiere ");\r
+ CALL normal;\r
+ lig := 4;\r
+ col := 2;\r
+ CALL bmatiere.list(bmatiere.root,lig,col);\r
+ CALL finn;\r
+ esac;\r
+ END llist;\r
+\r
+\r
+var\r
+\r
+ bfiche,bmatiere,bauteur : barb;\r
+\r
+\r
+\r
+BEGIN\r
+ bmatiere := new barb(2);\r
+ bauteur := new barb(2);\r
+ bfiche := new barb(2);\r
+ CALL menu;\r
+\r
+END;\r
--- /dev/null
+PROGRAM projet; \r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT Entier_long : CLASS;\r
+\r
+ UNIT elem : CLASS (valeur:INTEGER, suivant:elem);\r
+ END elem;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ VAR sommet : elem;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT depiler : FUNCTION : INTEGER;\r
+ (* Cette fonction permet d'extraire d'une pile un \82l\8ament. *)\r
+\r
+ BEGIN\r
+ IF sommet =/= NONE \r
+ \r
+ THEN\r
+ RESULT := sommet.valeur; \r
+ sommet := sommet.suivant\r
+ \r
+ FI;\r
+ \r
+ END depiler;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT pile_vide : FUNCTION : BOOLEAN;\r
+ (* Cette fonction bool\82en confirme si une pile est vide ou non. \r
+ Si le sommet est faux null alors RESULT prend la valeur vraie\r
+ sinon faux. *)\r
+ \r
+ BEGIN\r
+ IF sommet = NONE \r
+ \r
+ THEN\r
+ RESULT := TRUE\r
+ \r
+ ELSE\r
+ RESULT := FALSE;\r
+ \r
+ FI;\r
+ \r
+ END pile_vide;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT empiler : PROCEDURE (x : INTEGER);\r
+ (* Cette proc\82dure permet d'empiler un \82l\8ament au sommet d'une pile. *)\r
+ \r
+ BEGIN\r
+ sommet := NEW elem (x,sommet);\r
+ \r
+ END empiler;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT addition : FUNCTION (p2 : Entier_long) : Entier_long; \r
+ (* Cette fonction permet d'effectuer l'addition, elle retourne une \r
+ Entier_long. \r
+ On effectue l'addition au fur et \85 mesure que l'on d\82pile. *)\r
+ \r
+ VAR retenu, so : INTEGER;\r
+ \r
+ BEGIN\r
+ retenu := 0;\r
+ RESULT := NEW Entier_long;\r
+\r
+ WHILE (NOT pile_vide) OR (NOT p2.pile_vide) \r
+ DO\r
+\r
+ IF pile_vide \r
+ \r
+ THEN\r
+ (* Si p1 est vide alors le calcul se fait avec la d\82pile \r
+ de p2 et la gestion de la retenu. *)\r
+ so := p2.depiler + retenu\r
+ \r
+ ELSE\r
+ \r
+ IF p2.pile_vide \r
+ (* Si p2 est vide alors le calcul se fait avec la d\82pile \r
+ de p1 et la gestion de la retenu. *)\r
+ \r
+ THEN\r
+ so := depiler + retenu\r
+ \r
+ ELSE\r
+ so := depiler + p2.depiler + retenu\r
+ (* Dans les autres cas, on d\82pile les deux piles et on g\82re\r
+ la retenu. *)\r
+ FI;\r
+ \r
+ FI;\r
+\r
+ IF so > 9 \r
+ \r
+ THEN\r
+ (* On fait en quelque sorte un modulo 10. On enl\8ave 10 pour em-\r
+ piler le chiffre qui en est d\82duit et la retenue vaut\r
+ alors 1. *) \r
+ retenu := 1;\r
+ so := so - 10\r
+ \r
+ ELSE\r
+ (* Ici le calcul donne un chiffre alors la retenu est nulle. *)\r
+ retenu := 0;\r
+ \r
+ FI;\r
+\r
+ CALL RESULT.empiler (so); \r
+ \r
+ OD;\r
+ (* Gestion de la retenu. *)\r
+ IF retenu =/= 0 \r
+ \r
+ THEN \r
+ \r
+ CALL RESULT.empiler (retenu)\r
+ \r
+ FI;\r
+\r
+ END addition;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT soustraction : FUNCTION (p2 : Entier_long) : Entier_long;\r
+ (* Cette fonction permet d'effectuer la soustraction, elle retourne une \r
+ entier long. \r
+ On effectue la soustraction au fur et \85 mesure que l'on d\82pile. \r
+ A la fin de la fonction on va tester la valeur de la retenu, si elle \r
+ est \82gale \85 1 cela signifie que le r\82sultat est n\82gatif. *) \r
+ \r
+ VAR retenu, di : INTEGER;\r
+\r
+ BEGIN\r
+\r
+ retenu := 0; \r
+ RESULT := NEW Entier_long;\r
+\r
+ WHILE (not pile_vide) OR (not p2.pile_vide) \r
+ \r
+ DO\r
+ \r
+ IF pile_vide THEN\r
+ (* Si p1 est vide alors le calcul se fait avec la d\82pile \r
+ de p2 et la gestion de la retenu. *)\r
+ \r
+ di := - p2.depiler - retenu\r
+ \r
+ ELSE\r
+ \r
+ IF p2.pile_vide THEN\r
+ (* Si p2 est vide alors le calcul se fait avec la d\82pile \r
+ de p1 et la gestion de la retenu. *)\r
+ \r
+ di := depiler - retenu\r
+ \r
+ ELSE\r
+ (* Dans les autres cas, on d\82pile les deux piles et on g\82re\r
+ la retenu. *)\r
+ \r
+ di := depiler - p2.depiler - retenu\r
+ \r
+ FI;\r
+ \r
+ FI;\r
+ \r
+ IF di < 0 THEN\r
+ (* Pour \82viter d'avoir une valeur n\82gative on ajoute 10 \r
+ \85 di pour empiler un chiffre positif et la retenu prend \r
+ la valeur vaut alors 1. *) \r
+ \r
+ retenu := 1;\r
+ di := di + 10\r
+ ELSE\r
+ (* Ici le calcul donne un chiffre positif alors la retenu est nulle. *)\r
+ \r
+ retenu := 0;\r
+ \r
+ FI;\r
+\r
+ CALL RESULT.empiler(di);\r
+ \r
+ OD;\r
+\r
+ \r
+ IF retenu =/= 0 (* Cette deuxi\8ame partie ne concerne que la \r
+ division. Quand les piles sont vides \r
+ si la retenu est diff\82rente de 0 c'est que \r
+ la valeur de p1 est < \85 celle de p2. *)\r
+ THEN\r
+\r
+ b1 := FALSE;\r
+\r
+ FI;\r
+\r
+ END soustraction;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT multiplication : FUNCTION (p2 : Entier_long ; n : INTEGER) : Entier_long;\r
+ (* Cette fonction permet d'effectuer la multiplication elle retourne un\r
+ entier long. n repr\82sente le nombre d'\82l\8aments qu'il y a dans la plus \r
+ grande pile. On d\82coupe les piles jusqu'\85 obtenir un type \82l\8ament. *)\r
+ \r
+ VAR val : INTEGER , x1, x2, x3, x4 : INTEGER , pp1, p11, pp2, pt, \r
+ p22, pp3, p33, pp4, p44, mul1, mul2, mul3, mul4, \r
+ som1, som2 : Entier_long; \r
+ \r
+ \r
+ BEGIN\r
+ \r
+ pp1 := NEW Entier_long; p11 := NEW Entier_long; \r
+ pp2 := NEW Entier_long; pp3 := NEW Entier_long;\r
+ p33 := NEW Entier_long; pp4 := NEW Entier_long;\r
+ p44 := NEW Entier_long; pt := NEW Entier_long;\r
+ \r
+ mul1 := NEW Entier_long; mul2 := NEW Entier_long; \r
+ mul3 := NEW Entier_long; mul4 := NEW Entier_long; \r
+ som1 := NEW Entier_long; som2 := NEW Entier_long; \r
+ \r
+ RESULT := NEW Entier_long; \r
+ \r
+ n := n DIV 2;\r
+ \r
+ CALL position (17,60); \r
+ WRITE ("Calcul en cours...");\r
+ \r
+ WHILE NOT pile_vide \r
+ DO (* Transfert de la pile p1 vers la pile pt.*) \r
+ CALL pt.empiler (depiler);\r
+ OD; \r
+ \r
+ (* Le transfert vers 2 piles permet de sauvegarder les informations \r
+ vers dans une autre pile parce qu'une fois les \82l\8aments utilis\82s\r
+ la pile qui les contenaient est vide. Et pour les utiliser une \r
+ autre fois il faut les avoir sauvegarder dans une autre. *)\r
+\r
+ CALL transferer_2_piles (pt,p11,pp1);\r
+\r
+ CALL transferer_2_piles (transferer_pile (p2),p22,pp2);\r
+\r
+ IF n <= 2 \r
+ \r
+ THEN \r
+\r
+ x3 := pp1.depiler ; x4 := pp2.depiler ; x1 := pp1.depiler ; \r
+ x2 := pp2.depiler ;\r
+ \r
+ val := x1 * x2 * 100 + (x1 * x4 + x3 * x2) * 10 + (x3 * x4);\r
+ \r
+ RESULT := conversion (val,n1); (* Ici n1 ne sert \85 rien puisse que \r
+ son but dans la fuction est de compter \r
+ aussi le nombre d'\82l\8aments qui se trou-\r
+ ve dans la pile. dans laquelle est mise \r
+ les chiffres qui sont convertis.*) \r
+\r
+ ELSE\r
+\r
+ pp3 := transferer_pile (apparition(pp1,n));\r
+ \r
+ p33 := transferer_pile (apparition(p11,n));\r
+ \r
+ pp4 := transferer_pile (apparition(pp2,n));\r
+ \r
+ p44 := transferer_pile (apparition(p22,n));\r
+ \r
+ (* mul1, mul2, mul3, mul4 : sont 4 traitements r\82cursives au il \r
+ ajouter pour certain cas un certain nombre de 0. *)\r
+\r
+ mul1 := transferer_pile (pp1.multiplication (pp2,n));\r
+ CALL mul1.ajouter_zero (n); \r
+ \r
+ mul2 := transferer_pile (p11.multiplication (pp4,n));\r
+ CALL mul2.ajouter_zero (n DIV 2); \r
+ \r
+ mul3 := transferer_pile (p22.multiplication (pp3,n));\r
+ CALL mul3.ajouter_zero (n DIV 2); \r
+ \r
+ mul4 := transferer_pile (p33.multiplication (p44,n));\r
+ \r
+ (* Addition des 4 mul trouv\82s qui forment le r\82sultat. *)\r
+\r
+ som1 := transferer_pile (mul1.addition (mul2));\r
+ \r
+ som2 := transferer_pile (mul3.addition (mul4));\r
+ \r
+ RESULT := som1.addition (som2);\r
+\r
+ FI;\r
+\r
+ END multiplication;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT carre : FUNCTION (n : INTEGER) : Entier_long;\r
+ (* Cette fonction permet d'effectuer le carre d'une multiplication. *)\r
+ \r
+ VAR p3, p4, pt : Entier_long;\r
+\r
+ BEGIN\r
+ RESULT := NEW Entier_long;\r
+ p3 := NEW Entier_long;\r
+ p4 := NEW Entier_long;\r
+ pt := NEW Entier_long;\r
+ \r
+ WHILE NOT pile_vide \r
+ DO (* Transfert de la pile p1 vers la pile pt.*) \r
+ CALL pt.empiler (depiler);\r
+ OD; \r
+ \r
+ CALL transferer_2_piles (pt,p3,p4);\r
+ RESULT := p4.multiplication (p3,n*2);\r
+ \r
+ CALL effacer_partie (1,19,16,58);\r
+ \r
+ END carre;\r
+ \r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT division : FUNCTION (p2 : Entier_Long) : Entier_long;\r
+ (* Cette fonction permet d'effectuer la division (enti\8are) avec un \r
+ Entier_long. Elle retourne Entier_long. \r
+ Un division est une soustraction du dividande avec le diviseur. *)\r
+\r
+ VAR p3, p5, p6, pt : Entier_long;\r
+ \r
+ BEGIN\r
+ \r
+ b1 := TRUE;\r
+ \r
+ RESULT := NEW Entier_long;\r
+ p3 := NEW Entier_long;\r
+ p5 := NEW Entier_long;\r
+ p6 := NEW Entier_long; \r
+ pt := NEW Entier_long;\r
+ \r
+ WHILE NOT pile_vide \r
+ DO (* Transfert de la pile p1 vers la pile pt.*) \r
+ CALL pt.empiler (depiler);\r
+ OD; \r
+ \r
+ CALL RESULT.empiler(0); (* R\82sult est initialis\82 \85 0. *)\r
+ \r
+ pt := transferer_pile (pt);\r
+\r
+ WHILE b1 (* Correspond au bool\82en donn\82e par la soustraction. *) \r
+ \r
+ DO\r
+ \r
+ CALL position (17,60); \r
+ WRITE ("Calcul en cours...");\r
+\r
+ CALL transferer_2_piles (p2,p5,p6); \r
+ pt := transferer_pile (pt.soustraction(transferer_pile (p5)));\r
+ p2 := transferer_pile (p6); (* pour ne pas perdre l'information \r
+ de base de p2 alors p6 redevient p2\r
+ qui \85 son tour redevient p6.*)\r
+ \r
+ IF b1 (* Quand on sort de la fonction traiter_soustrac-\r
+ tion retenu n'est pas forc\82ment \82gale \85 0. *)\r
+ THEN\r
+\r
+ CALL p3.empiler (1); (* A chaque soustraction on incr\82mente RESULT \r
+ de 1. Ce 1 est alors empiler dans p3. *)\r
+ \r
+ RESULT := transferer_pile (RESULT.addition (p3));\r
+ \r
+ FI;\r
+ \r
+ OD;\r
+ \r
+ RESULT := transferer_pile (RESULT);\r
+ \r
+ CALL effacer_partie (1,19,16,58);\r
+\r
+ END division;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT modulo : FUNCTION (p2 : Entier_long) : Entier_long;\r
+ (* Cette fonction permet de calculer le reste d'une division avec un \r
+ entier long. Elle retourne un Entier_long. Quand le r\82sultat de la sous-\r
+ traction est vide est < \85 0 il faut avoir garder quelque part la valeur\r
+ du pr\82c\82dent dividande. En fait tant que le reste est positif, on r\82ini\r
+ tialise la RESULT. *)\r
+\r
+ VAR p5, p6, pt : Entier_long; \r
+ \r
+ BEGIN\r
+ \r
+ b1 := TRUE;\r
+ p5 := NEW Entier_long;\r
+ p6 := NEW Entier_long; \r
+ pt := NEW Entier_long;\r
+ \r
+ WHILE NOT pile_vide \r
+ DO (* Transfert de la pile p1 vers la pile pt.*) \r
+ CALL pt.empiler (depiler);\r
+ OD; \r
+ \r
+ WHILE b1\r
+ \r
+ DO\r
+ \r
+ CALL position (17,60); \r
+ WRITE ("Calcul en cours...");\r
+ \r
+ CALL transferer_2_piles (p2,p5,p6); (* p2 et p6 font faire former un \r
+ cycle pourque l'information ne \r
+ soit pas perdu. *)\r
+ \r
+ RESULT := NEW Entier_long;\r
+\r
+ (* pt et RESULT contient le dernier reste de la division. Si b1 est faux\r
+ ce qui signifie que la valeur que contient la pile pt est inf\82rieur \r
+ \85 celle qui est incluse dans p5.\r
+ Tant que la soustraction est positive (b1 est vrai) alors RESULT est \r
+ reinitialis\82e. *)\r
+\r
+ CALL transferer_2_piles (pt,pt,RESULT);\r
+ \r
+ RESULT := transferer_pile (RESULT);\r
+\r
+ pt := transferer_pile(transferer_pile (pt.soustraction(transferer_pile (p5))));\r
+ \r
+ p2 := transferer_pile (p6);\r
+ \r
+ OD;\r
+ \r
+ CALL effacer_partie (1,19,16,58); \r
+ \r
+ END modulo;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT pgcd : FUNCTION (p2 : Entier_Long) : Entier_long;\r
+ (* Cette fonction permet de calculer le pgcd entre deux entiers longs. \r
+ Elle retourne un Entier_long.\r
+ Tq r =/=0 fr \r
+ r <-- a MOD b ; a <-- b ; b <-- r\r
+ Ftq\r
+ Ici r repr\82sente p2 et b2 qui lui va prendre FAUX lors du transfert\r
+ de p2 vers p2 si dans cette derni\8are pile il y la valeur 0. *)\r
+\r
+ VAR p5, pt : Entier_long;\r
+ \r
+ BEGIN\r
+ \r
+ b2 := TRUE;\r
+ p5 := NEW Entier_long;\r
+ pt := NEW Entier_long;\r
+ \r
+ WHILE NOT pile_vide \r
+ DO (* Transfert de la pile p1 vers la pile pt.*) \r
+ CALL pt.empiler (depiler);\r
+ OD; \r
+ \r
+ pt := transferer_pile (pt); \r
+\r
+ WHILE b2 \r
+ \r
+ DO\r
+ \r
+ CALL transferer_2_piles (p2,p2,p5);\r
+ \r
+ p2 := (pt.modulo (transferer_pile (p2)));\r
+ \r
+ RESULT := NEW Entier_long;\r
+\r
+ RESULT := transferer_pile (transferer_pile (p5));\r
+ \r
+ p2 := transferer_pile (p2);\r
+\r
+ IF b2\r
+ \r
+ THEN\r
+ \r
+ pt := transferer_pile (RESULT);\r
+ FI;\r
+ \r
+ OD;\r
+ \r
+ END pgcd;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT ppcm : FUNCTION (p2 : Entier_Long) : Entier_long;\r
+ (* Cette fonction permet de calculer le ppcm entre deux entiers longs. \r
+ Elle retourne un Entier_long. ppcm (a,b) = (a * b) / pgcd (a,b). *)\r
+\r
+ VAR p3, p4, pt, pp : Entier_long;\r
+ \r
+ BEGIN\r
+ \r
+ p3 := NEW Entier_long;\r
+ p4 := NEW Entier_long;\r
+ pp := NEW Entier_long;\r
+ pt := NEW Entier_long;\r
+ \r
+ WHILE NOT pile_vide \r
+ DO (* Transfert de la pile p1 vers la pile pt.*) \r
+ CALL pt.empiler (depiler);\r
+ OD; \r
+ \r
+\r
+ CALL transferer_2_piles (transferer_pile (p2),p2,p4);\r
+ \r
+ CALL transferer_2_piles (pt,pt,p3);\r
+ \r
+ (* pp prend la valeur de la multiplication de p2 et de pt. *)\r
+ pp := transferer_pile (pt.multiplication (p2,partition (grand(n1,n2,n3)))); \r
+ \r
+ RESULT := pp.division (transferer_pile (p3.pgcd (p4))); \r
+ \r
+ END ppcm;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT conversion : FUNCTION (nbre : INTEGER ; \r
+ OUTPUT n : INTEGER) : Entier_long ;\r
+ (* Cette fonction d\82compose un entier en tout chiffre qui la compose.\r
+ Elle retourne un type Entier_long et comme param\88tre le nombre de\r
+ chiffres qui compose cette description ainsi ce dernier param\88tre \r
+ donne une id\82e de la taille de la premi\8are pile. Pareil que la \r
+ fonction saisie, on va \82viter d'empiler des 0 en d\82but de nombre\r
+ inutile. *)\r
+ \r
+ VAR x : INTEGER, trouve : BOOLEAN;\r
+\r
+ BEGIN\r
+ \r
+ RESULT := NEW Entier_long; \r
+ trouve := FALSE; \r
+ \r
+ n := 0;\r
+ \r
+ DO\r
+ \r
+ x := nbre MOD 10;\r
+ IF (x =/= 0)\r
+ \r
+ THEN\r
+ \r
+ CALL RESULT.empiler (x);\r
+ trouve := TRUE;\r
+ nbre := nbre DIV 10;\r
+ n := n + 1\r
+ ELSE\r
+ \r
+ IF trouve\r
+\r
+ THEN\r
+ \r
+ CALL RESULT.empiler (x);\r
+ nbre := nbre DIV 10;\r
+ n := n + 1;\r
+ FI;\r
+\r
+ FI;\r
+ \r
+ IF (nbre = 0) \r
+ \r
+ THEN \r
+ \r
+ EXIT;\r
+ \r
+ FI;\r
+\r
+ OD;\r
+ \r
+ END conversion;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT transferer_pile : FUNCTION (p2 : Entier_long) : Entier_long;\r
+ (* Cette fonction permet de d\82piler une pile pour empiler dans une \r
+ autre.*)\r
+ \r
+ VAR i : INTEGER;\r
+\r
+ BEGIN\r
+ \r
+ b2 := FALSE; (* b2 va tester si la valeur du\8a reste est \82gale \85 \r
+ z\82ro (ce qui est valable seulement pour \r
+ le PGCD) *)\r
+\r
+ RESULT := NEW Entier_long;\r
+\r
+ WHILE NOT p2.pile_vide \r
+ DO\r
+ i := p2.depiler; \r
+\r
+ IF i =/= 0\r
+\r
+ THEN\r
+\r
+ b2 := TRUE;\r
+ FI;\r
+ \r
+ CALL RESULT.empiler (i);\r
+ \r
+ OD;\r
+\r
+ END transferer_pile;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT transferer_2_piles : PROCEDURE (p2 : Entier_long ; \r
+ OUTPUT p3,p4 : Entier_long);\r
+ (* Cette proc\82dure permet de d\82piler une pile pour empiler dans deux \r
+ autres. *)\r
+\r
+ VAR x : INTEGER;\r
+\r
+ BEGIN\r
+ \r
+ p3 := NEW Entier_long; \r
+ p4 := NEW Entier_long; \r
+ \r
+ WHILE NOT p2.pile_vide \r
+ DO\r
+ x := p2.depiler;\r
+ CALL p3.empiler (x);\r
+ CALL p4.empiler (x);\r
+ OD;\r
+\r
+ END transferer_2_piles;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT apparition : FUNCTION (p2 : Entier_long ; n : INTEGER) : Entier_long;\r
+ (* Cette fonction permet de faire appara\8ctre une nouvelle pile en\r
+ divisant celle qui existe en deux. n : repr\82sente le nombre de \r
+ chiffres contenu dans la pile. Cette fonction n'est valable pour la \r
+ multiplication. *)\r
+\r
+ BEGIN\r
+\r
+ RESULT := NEW Entier_long;\r
+\r
+ n := n DIV 2;\r
+ \r
+ WHILE n =/= 0 DO\r
+ CALL RESULT.empiler (p2.depiler);\r
+ n := n - 1;\r
+ OD;\r
+\r
+ END apparition;\r
+ \r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT max_de_2_piles : PROCEDURE (v1,v2 : INTEGER ; \r
+ INOUT p2 : Entier_long ; OUTPUT max : INTEGER);\r
+ (* Cette proc\82dure d\82termine quel nombre des piles est plus grand.\r
+ Puisse qu'au d\82part il y a s\82lection dans la saisie (les z\82ros qui pr\82c\8a-\r
+ dent un chiffre autre qu'un z\82ro) ; on fait la comparaison avec v1, v2 (le \r
+ nombre de chiffres compris dans la pile).\r
+ Si v1 et v2 sont \82gaux (exemple 121 et 331) les valeurs sont ici 3 ; alors \r
+ on compare deux \85 deux les chiffres pour d\82terminer la pile qui contient\r
+ le nombre le plus grande.\r
+ max resort 1 pour la pile1 et 2 pour la pile2.*) \r
+ \r
+ VAR x1, x2 : INTEGER, b : BOOLEAN, p3,p4,p5,p6 : Entier_long;\r
+\r
+ BEGIN\r
+ \r
+ p3 := NEW Entier_long; p4 := NEW Entier_long;\r
+ p5 := NEW Entier_long; p6 := NEW Entier_long;\r
+\r
+ max := 0; b := TRUE;\r
+ (* 1ø partie : Comparaison des valeurs v1 et v2. *)\r
+ IF v1 > v2 \r
+ THEN\r
+ max := 1\r
+ ELSE\r
+ \r
+ IF v1 < v2 \r
+ THEN\r
+ max := 2\r
+ ELSE (* Si dans les deux piles le nombre\r
+ de chiffres est \82gale, on compare\r
+ les chiffres entre eux pour con-\r
+ na\8ctre enfin la plus grande. *)\r
+\r
+ CALL transferer_2_piles (p1,p3,p5);\r
+ CALL transferer_2_piles (p2,p4,p6);\r
+ (* Au cours de la comparaison d\8as que \r
+ l'on a trouv\82 une diff\82rence entre\r
+ les deux piles, on arr\88te la recher-\r
+ che. *)\r
+\r
+ WHILE NOT (p3.pile_vide) AND b\r
+ DO\r
+ \r
+ x1 := p3.depiler;\r
+ x2 := p4.depiler;\r
+\r
+ IF (x1 > x2)\r
+ THEN\r
+ \r
+ max := 1;\r
+ b := FALSE\r
+ ELSE\r
+ \r
+ IF (x1 < x2) \r
+ THEN\r
+ \r
+ max := 2;\r
+ b := FALSE;\r
+ FI;\r
+ \r
+ FI;\r
+ \r
+ OD;\r
+ \r
+ p1 := transferer_pile (p5);\r
+ p2 := transferer_pile (p6);\r
+ \r
+ FI;\r
+ \r
+ FI;\r
+\r
+ END max_de_2_piles;\r
+ \r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT ajouter_zero : PROCEDURE (n : INTEGER);\r
+ (* Cette fonction permet d'ajouter des z\82ros \85 la suite d'une pile \r
+ n : repr\82sente le nombre de 0 qui vont \88tre empiler. Cette proc\82dure \r
+ est valable seulement pour la multiplication. *)\r
+\r
+ VAR emp : INTEGER;\r
+\r
+ BEGIN\r
+ \r
+ FOR emp := 1 to n \r
+ \r
+ DO\r
+ \r
+ CALL empiler (0);\r
+ OD; \r
+ \r
+ END ajouter_zero;\r
+ \r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT saisir : FUNCTION (i, j : INTEGER ; OUTPUT n : INTEGER) : Entier_long;\r
+ (* Cette fonction permet de saisir les chiffres pour les empiler. \r
+ Par cette m\82thode de saisie, les z\82ros qui sont en d\82but de nom-\r
+ bre ne sont pas saisies (ce qui permet d'avoir une id\82e rapide \r
+ de la plus grande pile. \r
+ i et j : deux variables qui repr\82sentent la position du curseur \85 l'\82cran.\r
+ n : resort le nbre de chiffre empil\82s.*)\r
+ \r
+ VAR nnbre : CHAR, nbre : INTEGER, trouve : BOOLEAN;\r
+ \r
+ BEGIN\r
+ \r
+ RESULT := NEW Entier_long;\r
+\r
+ trouve := FALSE;\r
+ n := 0;\r
+ \r
+ DO\r
+ \r
+ CALL position (i,j); \r
+ IF j = 80 \r
+ \r
+ THEN (* Passage \85 la ligne pour des entiers tr\8as longs.*)\r
+ \r
+ i := i + 1;\r
+ j := 1;\r
+ FI;\r
+\r
+ nnbre := chr (inchar);\r
+ \r
+ IF (ord (nnbre) < 48) OR (ord (nnbre) > 57) \r
+ THEN\r
+ EXIT;\r
+ FI;\r
+ \r
+ nbre := entier (nnbre);\r
+ \r
+ CALL position (i,j);\r
+ \r
+ WRITELN (nnbre);\r
+ \r
+ IF (nbre =/= 0) \r
+ \r
+ THEN \r
+ \r
+ CALL RESULT.empiler (nbre);\r
+ trouve := TRUE; (* On fait un barage aux premiers\r
+ z\82ros saisie. *)\r
+ n := n + 1\r
+ ELSE\r
+ \r
+ IF trouve \r
+ (* Une fois un nbre diff\82rent de 0 est \r
+ saisie 0 peut \88tre bien-s\96r saisie \r
+ autant de fois que possible. *)\r
+ THEN\r
+ \r
+ CALL RESULT.empiler (nbre);\r
+ n := n + 1;\r
+ \r
+ FI;\r
+ \r
+ FI;\r
+ \r
+ j := j + 1; (* Mise \85 jour de la colonne de l'\82cran. *)\r
+\r
+ OD;\r
+\r
+ END saisir;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT afficher_resultat : PROCEDURE ;\r
+ (* Cette proc\82dure permet d'afficher le r\82sultat du calcul effectu\82. \r
+ Tant que la pile n'est pas vide, on d\82pile. On \82vite d'afficher les \r
+ premiers 0 (Ce qui tr\8as important pour une soustraction). *) \r
+\r
+ VAR b : BOOLEAN , i : INTEGER ;\r
+\r
+ BEGIN\r
+ b := FALSE;\r
+ i := depiler;\r
+\r
+ WHILE NOT pile_vide DO\r
+ \r
+ IF (i =/= 0) or (b) THEN\r
+ b := TRUE; (* Une fois que le premier\r
+ nombre est affich\82 et qu'il \r
+ est diff\82rent de 0, on peut afficher \r
+ autant de fois de 0. *)\r
+ WRITE (i);\r
+ FI; \r
+ \r
+ i := depiler; \r
+ OD;\r
+\r
+ WRITE (i);\r
+\r
+\r
+ END afficher_resultat;\r
+\r
+\r
+\r
+ END Entier_long;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT Inchar : IIUWgraph FUNCTION : INTEGER;\r
+ (* Cette function permet de saisir une suite de caract\8ares sans avoir \r
+ \85 valider chaque fois. *)\r
+ \r
+ VAR i:integer;\r
+ \r
+ BEGIN\r
+ \r
+ DO\r
+ \r
+ i := INKEY;\r
+ IF (i<>0) \r
+ \r
+ THEN \r
+ EXIT;\r
+ FI;\r
+ \r
+ OD;\r
+ \r
+ RESULT := i;\r
+ \r
+ END Inchar;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+ \r
+ UNIT entier : FUNCTION (c : CHAR) : INTEGER;\r
+ (* Cette proc\82dure convertie un caract\8are en entier parce que la \r
+ fonction inchar lit un entier qu'elle traduit en caract\8are. *)\r
+\r
+ BEGIN\r
+ CASE c\r
+ \r
+ WHEN '0' : RESULT := 0;\r
+ \r
+ WHEN '1' : RESULT := 1;\r
+ \r
+ WHEN '2' : RESULT := 2;\r
+ \r
+ WHEN '3' : RESULT := 3;\r
+ \r
+ WHEN '4' : RESULT := 4;\r
+ \r
+ WHEN '5' : RESULT := 5;\r
+\r
+ WHEN '6' : RESULT := 6;\r
+ \r
+ WHEN '7' : RESULT := 7;\r
+\r
+ WHEN '8' : RESULT := 8;\r
+\r
+ WHEN '9' : RESULT := 9;\r
+\r
+ ESAC;\r
+\r
+ END entier;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT partition : FUNCTION (n : INTEGER):INTEGER;\r
+ (* Cette fonction renvoit la valeur pour laquelle il faut partitionner \r
+ les deux piles. La plus grande de leur deux valeurs (multilplier par 2\r
+ par la fonction grand) doit \88tre un multiple de deux. (ce qui est \r
+ seulement utile pour la multiplication).*)\r
+ \r
+ VAR n1 : INTEGER;\r
+\r
+ BEGIN\r
+ \r
+ n1 := 2;\r
+\r
+ WHILE n1 < n \r
+ (* La partition de la multiplication se fait\r
+ pour des valeurs qui correspondent \85 une \r
+ suite g\82om\82trique de premier terme 2 et de \r
+ raison 2. *)\r
+ DO\r
+ n1 := n1 * 2;\r
+ \r
+ OD;\r
+ \r
+ RESULT := n1;\r
+\r
+ END partition;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT grand : FUNCTION (d1, d2, d3 : INTEGER) : INTEGER;\r
+ (* Cette fonction renvoit le nbre d'\82l\8ament qui a dans la plus grande \r
+ pile. Le param\88tre d3 accepte le max des deux piles. \r
+ on rappelle que s'il vaut 2 alors il s'agit de la deuxi\8ame pile qui a \r
+ la grande valeur sinon la premi\8are et cette valeur est multiplier par 2\r
+ pour mieux partionner la pile. *)\r
+ \r
+ BEGIN\r
+ \r
+ IF (d3 = 2)\r
+ THEN\r
+ \r
+ d2 := d2 * 2;\r
+ RESULT := d2\r
+ ELSE\r
+ \r
+ d1 := d1 * 2;\r
+ \r
+ RESULT := d1;\r
+\r
+ FI;\r
+\r
+ END grand;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT position : PROCEDURE (lig, col : INTEGER);\r
+ (* Cette proc\82dure permet de positionner sur l'\82cran qui devient une \r
+ matrice. Les param\88tres lig et col correspondent respectivement \85 l'\r
+ abcisse x (ligne) et \85 l'abcisse y (colonne). *) \r
+\r
+ VAR c, d, e, f : CHAR, i, j : INTEGER;\r
+\r
+ BEGIN\r
+\r
+ i := lig DIV 10; j := lig mod 10; c := chr (48+i);\r
+ d := chr (48+j); i := col div 10; j := col mod 10;\r
+ e := chr (48+i); f := chr (48+j); \r
+ WRITE (chr (27), "[", c, d, ";", e, f, "H");\r
+ \r
+ END position;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT tracer_ligne : PROCEDURE (lig1,col1,col : INTEGER);\r
+ (* Cette proc\82dure permet de tracer les lignes du cadre. x, y repr\82-\r
+ tentent les param\88tres de POSITION c'est \85 dire position ligne, colon\r
+ ne, et col est la limite de la ligne. *)\r
+\r
+ VAR i : INTEGER; \r
+ \r
+ BEGIN\r
+\r
+ CALL POSITION (col1,lig1); \r
+\r
+ FOR i := 1 to col \r
+ DO \r
+ WRITE ('Ä');\r
+ OD;\r
+\r
+ END tracer_ligne;\r
+\r
+(*------------------------------------------------------------------------- *)\r
+\r
+ UNIT tracer_colonne : PROCEDURE (lig,lig1, col : INTEGER);\r
+ (* Cette proc\82dure permet de tracer les colonnes du cadre. \r
+ lig repr\82sente : lig2 - lig1, et col : la colonne courante ou l'or-\r
+ donn\82e de POSITON. *)\r
+\r
+ VAR i : INTEGER; \r
+\r
+ BEGIN\r
+\r
+ FOR i := 1 to lig\r
+ \r
+ DO\r
+ \r
+ CALL POSITION (lig1+i,col);\r
+\r
+ WRITE ("³");\r
+\r
+ OD; \r
+ \r
+ END tracer_colonne;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT cadrer : PROCEDURE (lig1, lig2, col1,col2 : INTEGER);\r
+ (* Cette proc\82dure dessine un cadre valable pour un \82cran. D'abord \r
+ dessins : des lignes, ensuite des colonnes enfin des coins. Les para-\r
+ m\88tres sont respectivement ligne du haut et du bas et colonne de droi-\r
+ te et de gauche. *)\r
+\r
+ BEGIN\r
+\r
+ CALL tracer_ligne (col1,lig1,col2-col1);\r
+ CALL tracer_ligne (col1,lig2,col2-col1);\r
+ \r
+ CALL tracer_colonne (lig2-lig1,lig1,col1); \r
+ CALL tracer_colonne (lig2-lig1,lig1,col2);\r
+\r
+ CALL POSITION (lig1,col1);\r
+ WRITE ("Ú"); \r
+\r
+ CALL POSITION (lig2,col1);\r
+ WRITE ("À");\r
+\r
+ CALL POSITION (lig1,col2);\r
+ WRITE ("¿");\r
+\r
+ CALL POSITION (lig2,col2);\r
+ WRITE ("Ù");\r
+\r
+ END cadrer;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT effacer_partie : PROCEDURE (lig, col, lig1, col1 : INTEGER);\r
+ (* Cette proc\82dure permet d'effacer une partie de l'\82cran (o\97 on \r
+ \82crit un caract\8are blanc) les param\88tres lig, col, lig1, col1\r
+ l'intervale de ligne, colonne et la position de la ligne1 et \r
+ de la colonne1. *)\r
+\r
+ VAR k,w : INTEGER;\r
+ \r
+ BEGIN \r
+ FOR k := 1 to col \r
+ DO\r
+ FOR w := 1 to lig\r
+ DO\r
+ \r
+ CALL POSITION (lig1+w,col1+k);\r
+ WRITE (" ");\r
+ OD;\r
+ \r
+ OD; \r
+\r
+ END effacer_partie;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT prompt : PROCEDURE (i,j : INTEGER);\r
+ (* Cette proc\82dure affiche le programme principal. *)\r
+ VAR choix : CHAR ; \r
+ \r
+ BEGIN\r
+ \r
+ DO\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ \r
+ IF ecr (* Cette condition va permettre \85 cette fen\88tre de pas\r
+ ser du plein \82cran au petit menu du haut de l'\82cran. *)\r
+ \r
+ THEN\r
+\r
+ CALL cadrer (8,16,2,80);\r
+ ecr := FALSE\r
+ ELSE\r
+ i := 3 ; j := 6;\r
+ CALL cadrer (2,4,2,80);\r
+ FI;\r
+\r
+ CALL position (i,j);\r
+ \r
+ WRITE ("1 : Aide - 2 : Calcul - 3 : Quitter -> Le choix : ");\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+\r
+ choix := chr(inchar);\r
+ \r
+ CALL position (3,77);\r
+ WRITELN (choix); \r
+\r
+ WRITE (chr(27), "[2J");\r
+ \r
+ CASE choix\r
+ \r
+ WHEN '1' : CALL aide;\r
+ \r
+ WHEN '2' : CALL effacer_partie (3,80,1,1); \r
+ CALL presentation;\r
+ \r
+ CALL cadrer (3,7,8,74); \r
+ CALL fenetre_operation (4,14);\r
+ \r
+ WHEN '3' : EXIT;\r
+\r
+ ESAC\r
+ \r
+ OD;\r
+ \r
+ END prompt;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT fenetre_operation : PROCEDURE (i,j : INTEGER);\r
+ (* Cette proc\82dure affiche la liste des op\82rations possibles \85 \r
+ r\82aliser et g\82re les signes des op\82rations saisies.\r
+ Cf la documentation pour comprendre la gestion des signes. *)\r
+ \r
+ VAR choix : CHAR; \r
+ \r
+ BEGIN\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ \r
+ CALL position (i,j);\r
+\r
+ WRITE ("1 : + ; 2 : - ; 3 : * ; 4 : ^2 ; 5 : DIV");\r
+ \r
+ CALL position (i+2,j);\r
+ \r
+ WRITE ("6 : MOD ; 7 : PGCD ; 8 : PPCM -> Le choix : ");\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ \r
+ choix := chr(inchar);\r
+\r
+ CALL position (i+2,j+54);\r
+ WRITELN (choix);\r
+\r
+ CALL effacer_partie (5,78,2,1); \r
+\r
+ CALL position (i+4,50);\r
+(* Dans tous les cas signe1 et signe2 sont les valeurs des signes des piles \r
+1 et 2. *) \r
+ CASE choix\r
+ \r
+ WHEN '1' : WRITE ("La s\82lection est : ");\r
+ WRITE ("+");\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+ \r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ CALL p1.max_de_2_piles (n1,n2,p2,n3);\r
+ \r
+ CASE signe1 \r
+ \r
+ WHEN '-' : IF signe2 = '-' \r
+ \r
+ THEN\r
+ \r
+ p3 := p1.addition (p2);\r
+ CALL position (19,15);\r
+ WRITE ("-")\r
+ ELSE\r
+ \r
+ IF (n3 = 1) (* cas o\97 la 1ø pile est \r
+ > \85 la 2ø pile.*)\r
+ THEN \r
+ \r
+ p3 := p1.soustraction (p2);\r
+ CALL position (19,15);\r
+ WRITE ("-")\r
+ \r
+ ELSE (* cas o\97 la 1ø pile est <=\r
+ \85 la 2ø pile.*)\r
+ p3 := p2.soustraction (p1);\r
+ FI;\r
+\r
+ FI;\r
+\r
+ OTHERWISE IF signe2 =/= '-'\r
+ \r
+ THEN \r
+ p3 := p1.addition (p2);\r
+ \r
+ ELSE\r
+\r
+ IF (n3 = 1) (* cas o\97 la 1ø pile est \r
+ > \85 la 2ø pile.*)\r
+ THEN \r
+ \r
+ p3 := p1.soustraction (p2);\r
+ \r
+ ELSE (* cas o\97 la 1ø pile est <=\r
+ \85 la 2ø pile.*)\r
+ p3 := p2.soustraction (p1);\r
+ \r
+ IF (n3 =/= 0) \r
+ \r
+ THEN\r
+ \r
+ CALL position (19,15);\r
+ WRITE ("-")\r
+ FI;\r
+\r
+ FI;\r
+\r
+ FI;\r
+ ESAC;\r
+ \r
+ WHEN '2': WRITE ("La s\82lection est : ");\r
+ WRITE ("-");\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+\r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ CALL p1.max_de_2_piles (n1,n2,p2,n3);\r
+ \r
+ CASE signe1 \r
+ \r
+ WHEN '-' : IF signe2 =/= '-' \r
+ \r
+ THEN\r
+ \r
+ p3 := p1.addition (p2);\r
+ CALL position (19,15);\r
+ WRITE ("-")\r
+ ELSE\r
+ \r
+ IF (n3 = 1) (* cas o\97 la 1ø pile est \r
+ > \85 la 2ø pile. *)\r
+ THEN \r
+ \r
+ p3 := p1.soustraction (p2);\r
+ CALL position (19,15);\r
+ WRITE ("-")\r
+ \r
+ ELSE (* cas o\97 la 1ø pile est <=\r
+ \85 la 2ø pile. *)\r
+ p3 := p2.soustraction (p1);\r
+\r
+ FI;\r
+\r
+ FI;\r
+\r
+ OTHERWISE IF signe2 = '-'\r
+ \r
+ THEN \r
+ p3 := p1.addition (p2);\r
+ \r
+ ELSE\r
+\r
+ IF (n3 = 2) (* cas o\97 la 1ø pile est \r
+ > \85 la 2ø pile.*)\r
+ THEN \r
+ \r
+ p3 := p2.soustraction (p1);\r
+ CALL position (19,15);\r
+ WRITE ("-")\r
+ \r
+ ELSE (* cas o\97 la 1ø pile est <=\r
+ \85 la 2ø pile. *)\r
+ p3 := p1.soustraction (p2);\r
+ FI;\r
+\r
+ FI;\r
+ ESAC;\r
+\r
+ WHEN '3': WRITE ("La s\82lection est : ");\r
+ WRITE ("*");\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+ \r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ CALL p1.max_de_2_piles (n1,n2,p2,n3);\r
+\r
+ CASE signe1\r
+\r
+ WHEN '-' : IF signe2 =/= '-' \r
+ \r
+ THEN\r
+ CALL position (19,15);\r
+ WRITE ("-");\r
+ FI; \r
+ \r
+ OTHERWISE IF signe2 = '-'\r
+ \r
+ THEN\r
+ CALL position (19,15);\r
+ WRITE ("-");\r
+ FI; \r
+ \r
+ ESAC ;\r
+ \r
+ p3 := p1.multiplication (p2,partition (grand(n1,n2,n3)));\r
+ \r
+ CALL effacer_partie (1,19,16,58);\r
+ (* Permet d'effacer le message "Calcul en cours"*)\r
+ \r
+ WHEN '4': WRITE ("La s\82lection est : ");\r
+ WRITE ("^2");\r
+ \r
+ CALL effacer_partie (1,14,13,1);\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+ \r
+ p3 := p1.carre (partition (n1));\r
+\r
+ WHEN '5': WRITE ("La s\82lection est : ");\r
+ WRITE ("DIV");\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+\r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ IF p2.pile_vide \r
+ (* Traitement de la division par\r
+ z\82ro.*) \r
+ THEN\r
+ \r
+ CALL position (17,45); \r
+ WRITELN ("IMPOSSIBLE... Division par Z\82ro");\r
+ EXIT;\r
+ FI;\r
+\r
+ IF ( (signe2 = '-') AND (signe1 =/= '-') ) \r
+ OR ( (signe2 =/= '-') AND (signe1 = '-') )\r
+ \r
+ THEN\r
+ CALL position (19,15);\r
+ WRITE ("-");\r
+ FI; \r
+ \r
+ p3 := p1.division (p2);\r
+ \r
+ WHEN '6': WRITE ("La s\82lection est : ");\r
+ WRITE ("MOD");\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+\r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ IF p2.pile_vide \r
+ (* Traitement de la division par\r
+ z\82ro.*) \r
+ THEN\r
+ \r
+ CALL position (17,45); \r
+ WRITELN ("IMPOSSIBLE... Division par Z\82ro");\r
+ EXIT;\r
+ FI;\r
+ \r
+ IF ( (signe2 = '-') AND (signe1 =/= '-') ) \r
+ OR ( (signe2 =/= '-') AND (signe1 = '-') )\r
+ \r
+ THEN\r
+ CALL position (19,15);\r
+ WRITE ("-");\r
+ FI; \r
+\r
+ p3 := p1.modulo (p2);\r
+\r
+\r
+ WHEN '7': WRITE ("La s\82lection est : ");\r
+ WRITE ("PGCD");\r
+ \r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+ \r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ IF p2.pile_vide \r
+ (* Traitement de la division par\r
+ z\82ro.*) \r
+ THEN\r
+ \r
+ CALL position (17,45); \r
+ WRITELN ("IMPOSSIBLE... Division par Z\82ro");\r
+ EXIT;\r
+ FI;\r
+\r
+ IF ( (signe2 = '-') AND (signe1 =/= '-') ) \r
+ OR ( (signe2 =/= '-') AND (signe1 = '-') )\r
+ \r
+ THEN\r
+ CALL position (19,15);\r
+ WRITE ("-");\r
+ FI; \r
+ \r
+\r
+ p3 := p1.pgcd (p2)\r
+\r
+\r
+ WHEN '8': WRITE ("La s\82lection est : ");\r
+ WRITE ("PPCM");\r
+ CALL cadrer (10,14,22,50);\r
+ CALL fenetre_saisie (11,25);\r
+ \r
+ CALL cadrer (15,19,22,50);\r
+ CALL fenetre_saisie (16,25);\r
+ \r
+ IF p2.pile_vide \r
+ (* Traitement de la division par\r
+ z\82ro.*) \r
+ THEN\r
+ \r
+ CALL position (17,45); \r
+ WRITELN ("IMPOSSIBLE... Division par Z\82ro");\r
+ EXIT;\r
+ FI;\r
+\r
+ IF ( (signe2 = '-') AND (signe1 =/= '-') ) \r
+ OR ( (signe2 =/= '-') AND (signe1 = '-') )\r
+ \r
+ THEN\r
+ CALL position (19,15);\r
+ WRITE ("-");\r
+ FI; \r
+ \r
+ p3 := p1.ppcm (p2);\r
+ \r
+ OTHERWISE CALL effacer_partie (5,78,2,1);\r
+ CALL cadrer (3,7,2,79);\r
+ CALL fenetre_operation (i,j); \r
+ ESAC;\r
+ \r
+ CALL position (19,17);\r
+ \r
+ CALL p3.afficher_resultat;\r
+ \r
+ \r
+ END fenetre_operation;\r
+ \r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT fenetre_saisie : PROCEDURE (i,j : INTEGER);\r
+ (* Cette proc\82dure permet de r\82aliser le choix entre la saisie d'un \r
+ entier court et long. Et permet d'effectuer la saisie du signe qui \r
+ sera g\82rer dans la proc\82dure ci dessus. *)\r
+\r
+ VAR choix : CHAR, nbre : INTEGER;\r
+\r
+ BEGIN\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ \r
+ CALL position (i,j);\r
+ \r
+ WRITELN ("1 : Entier court");\r
+ CALL position (i+1,j);\r
+ WRITELN ("2 : Entier long");\r
+ CALL position (i+2,j+2);\r
+ WRITELN ("Entrer votre choix : ");\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ \r
+ choix := chr (inchar);\r
+ \r
+ CALL position (i+2,j+23);\r
+ WRITELN (choix);\r
+ \r
+ WRITELN; (* Cette commande permet de vider le buffer *) \r
+\r
+ (* La saisie d'un entier court n\82cessite une conversion et un empilement. \r
+ Alors que la saisie d'un entier long se fait par empilement. *)\r
+ \r
+ CASE choix\r
+ (* On g\8are le choix et le position de l'\82cran qui permet de savoir \r
+ si on manipule p1 (pour i = 11) ou p2 (pour i = 22). *)\r
+ \r
+ WHEN '1' : IF i = 11 \r
+ THEN\r
+ \r
+ CALL effacer_partie (5,29,9,21);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ CALL position (9,16);\r
+ WRITE ("' '");\r
+ CALL position (9,17);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ signe1 := chr (inchar);\r
+ CALL position (9,17);\r
+ WRITE (signe1);\r
+ CALL position (9,20);\r
+ READ (nbre);\r
+ p1 := p1.transferer_pile (p1.conversion (nbre,n1) ) \r
+ ELSE\r
+ \r
+ CALL effacer_partie (5,29,14,21);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ CALL position (14,16);\r
+ WRITE ("' '");\r
+ CALL position (14,17);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ signe2 := chr (inchar); \r
+ CALL position (14,17);\r
+ WRITE (signe2);\r
+ CALL position (14,20);\r
+ READ (nbre);\r
+ p2 := p2.transferer_pile (p2.conversion (nbre,n2) ) \r
+\r
+ FI;\r
+ \r
+ WHEN '2' : IF i = 11 \r
+ THEN\r
+ \r
+ CALL effacer_partie (5,29,9,21);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ CALL position (9,16);\r
+ WRITE ("' '");\r
+ CALL position (9,17);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ signe1 := chr (inchar);\r
+ CALL position (9,17);\r
+ WRITE (signe1);\r
+ CALL position (9,20);\r
+ WRITELN; (* Cette commande permet de vider le buffer *) \r
+ p1 := p1.saisir (9,20,n1) \r
+ ELSE\r
+ \r
+ CALL effacer_partie (5,29,14,21);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ CALL position (14,16);\r
+ WRITE ("' '");\r
+ CALL position (14,17);\r
+ WRITELN; (* Cette commande permet de vider le buffer *)\r
+ signe2 := chr (inchar);\r
+ CALL position (14,17);\r
+ WRITE (signe2);\r
+ CALL position (14,20);\r
+ WRITELN; (* Cette commande permet de vider le buffer *) \r
+ p2 := p2.saisir (14,20,n2);\r
+\r
+ FI;\r
+ \r
+ OTHERWISE CALL fenetre_saisie (i,j);\r
+ \r
+ ESAC;\r
+\r
+ END fenetre_saisie;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT presentation : PROCEDURE;\r
+ (* Cette proc\82dure permet apr\8as le prompt d'afficher la maquette de \r
+ saisie et de r\82sultat. *)\r
+ \r
+ BEGIN\r
+ \r
+ CALL position (10,3);\r
+ WRITE ("Valeur nø1 : ");\r
+ CALL position (15,3);\r
+ WRITE ("Valeur nø2 : ");\r
+ CALL position (20,3);\r
+ WRITE ("R\82sultat : ");\r
+ CALL position (25,76);\r
+ WRITE ("D. V.");\r
+\r
+ END presentation;\r
+\r
+(* ------------------------------------------------------------------------ *)\r
+\r
+ UNIT aide : PROCEDURE;\r
+ (* Cette proc\82dure permet d'afficher le texte de l'aide. *)\r
+ \r
+ BEGIN\r
+ \r
+ CALL position (5,3);\r
+ WRITELN ("Le calcul consiste \85 :");\r
+ WRITELN (" - S\82lectionner l'op\82ration d\82sir\82e.");\r
+ WRITELN (" - Choisir entre un entier court ou long.");\r
+ WRITELN (" - Mettre le signe de l'op\82ration dans le ' '.");\r
+ WRITELN (" - pour les valeur n\82gatives.");\r
+ WRITELN (" + pour ou rien pour les valeurs positives.");\r
+ WRITELN (" - Valider la saisie des valeurs ");\r
+ WRITELN ;\r
+ WRITELN (" Pour le carre, il n'a pas de deuxi\8ame saisie.");\r
+ WRITELN ;\r
+ WRITELN (" Si le r\82sultat obtenu n'est pas visible \85 l'\82cran \85 cause d'un");\r
+ WRITELN ("trop grand nombre de chiffres, il faut quitter ce logiciel et"); \r
+ WRITELN ("taper 'int projet > exemple' et reprendre l'application pr\82c\82dente.");\r
+ WRITELN ;\r
+ WRITELN (" Ceci est tap\82 n'est pas visible \85 l'\82cran. Pour visualiser la saisie");\r
+ WRITELN ("et le r\82sultat il faut taper 'type exemple | more' \85 partir du DOS.");\r
+ WRITELN ;\r
+ WRITELN ("Quitter : permet de revenir au Syt\8ame d'Exploitation");\r
+\r
+ END aide;\r
+\r
+\r
+VAR p1,p2,p3 : Entier_long, (* p1, p2 sont deux piles de saisie et p3 : une \r
+ pile r\82sultat. *)\r
+\r
+n1, n2, n3 : INTEGER, (* n1, n2 correspondent au nombres de chiffres \r
+ qui sont dans les piles n3 resort leur maximum ou \r
+ leur \82galit\82. *)\r
+\r
+b1, b2, ecr : BOOLEAN, (* Les deux premeirs repr\82sentent respectivement \r
+ la l'obtention d'un r\82sultat n\82gatif pour la \r
+ soustraction et le test comme quoi la valeur \r
+ du reste est nulle pour le pgcd. \r
+ ecr va permetre au sommaire de passer de la \r
+ position de plein \82cran \85 celle de petit \82cran\r
+ sur les trois premi\8ares lignes.*)\r
+\r
+signe1, signe2 : CHAR; (* Ils repr\82sentent respectivement les valeurs \r
+ des signe de la pile 1 et 2. *) \r
+\r
+\r
+BEGIN\r
+\r
+(* Intialisation des trois piles. *)\r
+p1 := new Entier_long; \r
+p2 := new Entier_long; \r
+p3 := new Entier_long; \r
+\r
+WRITE (chr(27), "[2J");\r
+\r
+CALL position (4,19);\r
+WRITELN ("LA CALCULATRICE DES ENTIERS COURTS ET LONGS");\r
+CALL position (19,76);\r
+WRITELN ("D. V.");\r
+ecr := TRUE;\r
+\r
+CALL prompt (12,6) ;\r
+\r
+END projet;\r
--- /dev/null
+Program Htable;\r
+\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* Projet 1 li1 par PAUL olivier et FERNANDEZ raphael *)\r
+(* GESTION D'UNE TABLE DE HACHAGE *)\r
+(* le 13-1-1994 *)\r
+(* *)\r
+(***************************************************************************)\r
+\r
+\r
+const enter=10,\r
+ extrnb=8,\r
+ theta=0.6180339885;\r
+\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* Definition d'une classe contenant les principaux *)\r
+(* Outils utilises par la suite ... *)\r
+(***************************************************************************)\r
+\r
+unit tools: class; (* les outils *)\r
+\r
+unit inchar:IIUWGraph function:integer;\r
+ var i:integer;\r
+begin\r
+ do\r
+ i:=inkey;\r
+ if i<>0 then exit fi; (* attend q'un caractere soit saisi et *)\r
+ od; (* renvoie son code *)\r
+ result:=i;\r
+end inchar;\r
+\r
+unit gotoxy:procedure(col,lig:integer);\r
+var c,d,e,f:char,\r
+ i,j :integer;\r
+begin\r
+ i:=lig div 10;\r
+ j:=lig mod 10;\r
+ c:= chr(48+i); (* positionne le curseur *)\r
+ d:= chr(48+j); (* en utilisant le driver ANSI *)\r
+ i:=col div 10;\r
+ j:=col mod 10;\r
+ e:= chr(48+i);\r
+ f:= chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+end gotoxy;\r
+\r
+unit cls : procedure;\r
+begin\r
+ write(chr(27),"[2J"); (* efface l'ecran *)\r
+end cls;\r
+\r
+unit reverse:procedure;\r
+begin\r
+ write( chr(27),"[5m"); (* passe en mode blink *)\r
+end reverse;\r
+\r
+unit normal:procedure;\r
+begin\r
+ write( chr(27),"[0m"); (* passe en mode normal *)\r
+end normal;\r
+\r
+unit box : procedure(x,y,z,w:integer);\r
+var i:integer;\r
+begin\r
+ call gotoxy(x,y);\r
+ write("É");\r
+ for i:=2 to (z-1) do write("Í") od;\r
+ write("»");\r
+ for i:=1 to (w-1) do\r
+ call gotoxy(x,y+i); (* affiche une boite au coord x,y *)\r
+ write("º"); (* de largeur z et de hauteur w *)\r
+ call gotoxy(x+z-1,y+i);\r
+ write("º");\r
+ od;\r
+ call gotoxy(x,y+w);\r
+ write("È");\r
+ for i:=2 to (z-1) do write("Í") od;\r
+ write("¼");\r
+end box;\r
+\r
+unit line:procedure;\r
+var t:integer;\r
+begin\r
+ call gotoxy(1,23);\r
+ for t:=1 to 79 do write("_") od;\r
+ call gotoxy(1,24); (* trace une ligne et positionne le curseur *)\r
+ for t:=1 to 79 do write(" ") od;\r
+ call gotoxy(1,24);\r
+end line;\r
+\r
+unit decbin:function(input e:integer):arrayof integer;\r
+var f,g:integer;\r
+begin\r
+ array result dim(0:7);\r
+ for f:=0 to 7 do result(f):=0 od;\r
+ f:=e;\r
+ g:=0; (* convertisseur decimal-binaire *)\r
+ while (f<>0) do\r
+ result(g):=f mod 2;\r
+ f:=f div 2; (* on utilise les restes de la division par 2 *)\r
+ g:=g+1;\r
+ od;\r
+end decbin;\r
+\r
+unit exp:function(x:integer):integer;\r
+var t:integer;\r
+begin\r
+ result:=1; (* calcule 2^x *)\r
+ for t:=1 to x do result:=result*2 od;\r
+end exp;\r
+\r
+unit bindec:function(input e:arrayof integer;l:integer):integer;\r
+var i,res:integer;\r
+begin\r
+ i:=0;\r
+ result:=0;\r
+ while (i<l) do\r
+ result:=result+exp(i)*e(i); (* conversion binaire-decimal *)\r
+ i:=i+1;\r
+ od;\r
+end bindec;\r
+\r
+unit delay:procedure;\r
+begin\r
+ call line; (* attend qu 'une touche soit pressee *)\r
+ write("Appuyez sur une touche pour la suite");\r
+ while inchar=0 do od;\r
+end delay;\r
+\r
+end tools;\r
+\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* Definition des elements et des operations s'y rapportant *)\r
+(* *)\r
+(***************************************************************************)\r
+\r
+unit dicob : class; (* le type d 'element saisi *)\r
+var mot :arrayof char, (* un mot de 25 lettres max *)\r
+ trad :arrayof char; (* sa traduction en anglais *)\r
+begin\r
+ array mot dim (1:25);\r
+ array trad dim (1:100);\r
+end dicob;\r
+\r
+unit newdicob : function : dicob; (* cree un nouvel element *)\r
+var t:integer;\r
+begin\r
+ result:=new dicob;\r
+ for t:=1 to 100 do result.trad(t):=' ' od; (* et l 'initialise *)\r
+ for t:=1 to 25 do result.mot(t):=' ' od;\r
+end newdicob;\r
+\r
+unit readel : tools function(f:file) : dicob;\r
+var t:integer, (* lit un element *)\r
+ c:char,\r
+ tamp:dicob;\r
+begin\r
+ if (f=NONE) then\r
+ call line;\r
+ write("saisissez votre mot puis <enter> pour valider");\r
+ call box(1,15,79,2); (* si l' element provient du clavier *)\r
+ call gotoxy(2,16); (* on agremente la presentation *)\r
+ write("mot : ");\r
+ fi;\r
+ t:=1;\r
+ if (f<>NONE) then read(f,c) else read(c) fi;\r
+ if (ord(c)=enter) then read(c) fi;\r
+ tamp:=newdicob;\r
+ if (f<>NONE) then (* saisie du nom *)\r
+ while ((t<24) and not(eoln(f)))\r
+ do\r
+ tamp.mot(t):=c; (* si l' element provient d'un fichier *)\r
+ read(f,c);\r
+ t:=t+1;\r
+ od;\r
+ else\r
+ while ((t<24) and (ord(c)<>enter))\r
+ do\r
+ tamp.mot(t):=c;\r
+ read(c); (* si l' element provient du clavier *)\r
+ t:=t+1;\r
+ od;\r
+ if (t=24) then readln fi;\r
+ fi;\r
+ tamp.mot(t):=c;\r
+ tamp.mot(t+1):=chr(enter); (* on en marque la fin par enter *)\r
+ if (f<>NONE) then readln(f) fi;\r
+ if (f=NONE) then\r
+ call cls;\r
+ call line;\r
+ write("saisissez votre mot puis <enter> pour valider");\r
+ call box(1,15,79,3); (* si l' element provient du clavier *)\r
+ call gotoxy(2,16);\r
+ write("traduction : ");\r
+ fi;\r
+ t:=1;\r
+ if (f<>NONE) then read(f,c) else read(c) fi;\r
+ if (f<>NONE) then (* saisie de la traduction *)\r
+ while ((t<100) and not(eoln(f)))\r
+ do\r
+ tamp.trad(t):=c;\r
+ read(f,c); (* si l' element provient d'un fichier *)\r
+ t:=t+1;\r
+ od;\r
+ else\r
+ while ((t<100) and (ord(c)<>enter))\r
+ do\r
+ tamp.trad(t):=c;\r
+ read(c); (* si l' element provient du clavier *)\r
+ t:=t+1;\r
+ od;\r
+ fi;\r
+ tamp.trad(t):=c;\r
+ tamp.trad(t+1):=chr(enter); (* on en marque la fin par enter *)\r
+ if (f<>NONE) then readln(f) fi;\r
+ result:=tamp;\r
+end readel;\r
+\r
+unit writel : tools procedure(e:dicob);(* ecriture de l 'element *)\r
+var t:integer;\r
+begin\r
+ t:=1;\r
+ call box(1,15,79,3);\r
+ call gotoxy(2,16);\r
+ while ((ord(e.mot(t))<>enter) and (t<=25))\r
+ do\r
+ write(e.mot(t)); (* ecriture du mot *)\r
+ t:=t+1;\r
+ od;\r
+ write(" se traduit par ");\r
+ t:=1;\r
+ while ((ord(e.trad(t))<>enter) and (t<=25))\r
+ do\r
+ write(e.trad(t)); (* et de la traduction *)\r
+ t:=t+1;\r
+ od;\r
+end writel;\r
+\r
+unit supel :function(e1:dicob,e2:dicob):boolean;\r
+var t:integer,\r
+ res:integer;\r
+begin (* cherche si e1>e2 *)\r
+ res:=0; (* res=0 si e1=e2 ,res=-1 si e2>e1,res=1 si e1>e2 *)\r
+ t:=1;\r
+ while ((t<25) and (res=0) and (ord(e1.mot(t))<>enter)\r
+ and (ord(e2.mot(t))<>enter))\r
+ do\r
+ if (ord(e1.mot(t))<ord(e2.mot(t))) then res:=-1 fi;\r
+ if (ord(e1.mot(t))>ord(e2.mot(t))) then res:=1 fi;\r
+ t:=t+1;\r
+ od;\r
+ if (ord(e1.mot(t))=enter) and (ord(e2.mot(t))<>enter) and (res=0)\r
+ then res:=-1 fi; (* le plus long est le plus grand *)\r
+ if (ord(e2.mot(t))=enter) and (ord(e1.mot(t))<>enter) and (res=0)\r
+ then res:=1 fi; (* idem *)\r
+ result:=(res=1);\r
+end supel;\r
+\r
+unit egalel :function(input e1,e2:dicob):boolean;\r
+var t:integer, (* cherche si deux elements sont egaux *)\r
+ res:integer;\r
+begin\r
+ res:=0;\r
+ t:=1;\r
+ while ((t<25) and (res=0) and (ord(e1.mot(t))<>enter)\r
+ and (ord(e2.mot(t))<>enter))\r
+ do\r
+ if (e1.mot(t)<>e2.mot(t)) then res:=1 fi;\r
+ t:=t+1;\r
+ od;\r
+ if (ord(e1.mot(t))<>ord(e2.mot(t))) then res:=1 fi;\r
+ result:=(res=0);\r
+end egalel;\r
+\r
+unit extraction : tools function(e1:dicob;long:integer):integer;\r
+var t:integer, (* function de hachage par extraction *)\r
+ tamp:arrayof integer,\r
+ rep:arrayof arrayof integer;\r
+begin\r
+ array tamp dim(0:31);\r
+ for t:=0 to 31 do tamp(t):=0 od;\r
+ array rep dim(1:extrnb);\r
+ for t:=1 to extrnb do rep(t):=decbin(ord(e1.mot(t))) od;(* conversion *)\r
+ for t:=1 to extrnb do tamp(t-1):=rep(t)(t-1) od;(*on prend les extrnb*)\r
+ result:=((bindec(tamp,32) mod long)+1);(* premiers bits *)\r
+ (* voir remarque fonction suivante pour mod *)\r
+ kill(tamp);\r
+ for t:=1 to extrnb do kill(rep(t)) od;\r
+end extraction;\r
+\r
+unit compression : tools function(e1:dicob;long:integer):integer;\r
+var t,l,nb0,nb1,u:integer, (* function de hachage par compression *)\r
+ tamp:arrayof integer,\r
+ rep:arrayof arrayof integer;\r
+begin\r
+ array tamp dim(0:7);\r
+ for t:=0 to 7 do tamp(t):=0 od;\r
+ l:=1;\r
+ while ((ord(e1.mot(l))<>enter) and (l<25)) do l:=l+1 od;\r
+ l:=l-1; (* longueur du mot *)\r
+ array rep dim(1:l+1);\r
+ for t:=1 to l do rep(t):=decbin(ord(e1.mot(t))) od;\r
+ for u:=0 to 7 do\r
+ nb0:=0;nb1:=0;\r
+ for t:=1 to l do\r
+ if (rep(t)(u)=0) then nb0:=nb0+1 fi; (* on calcule le nombre de 1 et *)\r
+ if (rep(t)(u)=1) then nb1:=nb1+1 fi; (* de 0 pour chaque bit *)\r
+ od;\r
+ if ((nb1 mod 2)=1) then tamp(u):=1 (* Xor *)\r
+ else tamp(u):=0 fi;\r
+ od;\r
+ result:=((bindec(tamp,8) mod long)+1);(* reconversion*)\r
+ kill(tamp);\r
+ for t:=1 to l do kill(rep(t)) od;\r
+end compression;(*le mod permet de prendre une longueur de tableau variable*)\r
+ (* au detriment de la "precision" de la fonction *)\r
+\r
+unit division : tools function(e1:dicob;long:integer):integer;\r
+var t,l,u,v:integer, (* function de hachage par division *)\r
+ tamp:arrayof integer,\r
+ rep:arrayof arrayof integer;\r
+begin\r
+ l:=1;\r
+ while ((ord(e1.mot(l))<>enter) and (l<25)) do l:=l+1 od;\r
+ l:=l-1;\r
+ array rep dim(1:l+1);\r
+ array tamp dim(0:8*(l));\r
+ for t:=0 to 8*l-1 do tamp(t):=0 od;\r
+ for t:=1 to l do rep(t):=decbin(ord(e1.mot(t))) od; (* conversion *)\r
+ u:=1;\r
+ v:=0;\r
+ for t:=0 to 8*l-1 do\r
+ tamp(t):=rep(u)(v);\r
+ v:=v+1;\r
+ if (v=8) then (* on recopie les conversions dans un seul tableau *)\r
+ v:=0;\r
+ u:=u+1;\r
+ fi;\r
+ od;\r
+ result:=(bindec(tamp,8*l) mod long)+1; (* que l 'on convertit *)\r
+ kill(tamp);\r
+ for t:=1 to l+1 do kill(rep(t)) od;\r
+end division;\r
+\r
+unit multiplication : tools function(e1:dicob;long:integer):integer;\r
+var pos:real, (* function de hachage par multiplication *)\r
+ t,l,u,v:integer,\r
+ tamp:arrayof integer,\r
+ rep:arrayof arrayof integer;\r
+begin\r
+ l:=1;\r
+ while ((ord(e1.mot(l))<>enter) and (l<25)) do l:=l+1 od;\r
+ l:=l-1;\r
+ array rep dim(1:l+1);\r
+ array tamp dim(0:8*(l));\r
+ for t:=0 to 8*l-1 do tamp(t):=0 od;\r
+ for t:=1 to l do rep(t):=decbin(ord(e1.mot(t))) od;\r
+ u:=1;\r
+ v:=0; (* idem division *)\r
+ for t:=0 to 8*l-1 do\r
+ tamp(t):=rep(u)(v);\r
+ v:=v+1;\r
+ if (v=8) then\r
+ v:=0;\r
+ u:=u+1;\r
+ fi;\r
+ od;\r
+ pos:=bindec(tamp,8*l)*theta; (* conversion *)\r
+ result:=(entier((pos-entier(pos))*long)+1);\r
+ kill(tamp);\r
+ for t:=1 to l+1 do kill(rep(t)) od;\r
+end multiplication;\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* Definition de la classe table ainsi que des operations *)\r
+(* utilisees par celle-ci ... *)\r
+(***************************************************************************)\r
+\r
+unit table : tools class (type elem;function newelem:elem;\r
+function egalelem(e1,e2:elem):boolean;function readelem(f:file):elem;\r
+function supelem(e1,e2:elem):boolean;\r
+function hachelem(e1:elem;l:integer):integer;procedure writelem(e:elem));\r
+\r
+unit tree: class (el: elem); (* definition d 'un arbre binaire de recherche *)\r
+ var left,right: tree;\r
+end tree;\r
+\r
+unit max:function (input t:tree):tree;\r
+var tamp:tree,\r
+ continue:boolean;\r
+begin\r
+ continue:=TRUE;\r
+ if (t=NONE) then\r
+ continue:=FALSE;\r
+ tamp:=NONE; (* calcule le plus grand element d 'un arbre *)\r
+ else\r
+ tamp:=t;\r
+ while continue\r
+ do\r
+ if (tamp.right<>NONE) then\r
+ tamp:=tamp.right; (* celui-ci se trouve en bas a droite *)\r
+ else continue:=FALSE;\r
+ fi;\r
+ od;\r
+ fi;\r
+ result:=tamp;\r
+ call line;\r
+ writeln("maximum trouve ... fait.");\r
+end max;\r
+\r
+unit find:function(input t:tree;e:elem):tree;\r
+var tamp: tree,\r
+ continue,ok :boolean; (* recherche d 'un elemnt *)\r
+begin\r
+ continue:=TRUE;\r
+ if (t=NONE) then\r
+ tamp:=NONE;\r
+ ok:=FALSE;\r
+ else\r
+ tamp:=t;\r
+ ok:=FALSE;\r
+ while continue\r
+ do\r
+ if supelem(e,tamp.el) then\r
+ if (tamp.right<>NONE) then\r
+ tamp:=tamp.right; (* si l'arbre courant est plus petit on va a droite *)\r
+ else continue:=FALSE;\r
+ fi;\r
+ else\r
+ if egalelem(e,tamp.el) then\r
+ continue:=FALSE; (* si l'arbre courant est celui recherche on arrete *)\r
+ ok:=TRUE;\r
+ else\r
+ if (tamp.left<>NONE) then\r
+ tamp:=tamp.left; (* sinon on va a gauche *)\r
+ else continue:=FALSE;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ call line;\r
+ writeln("element trouve ... fait.");\r
+ if ok then result:=tamp;\r
+ else result:=NONE fi;\r
+end find;\r
+\r
+unit add: function (input t: tree; e: elem):tree;\r
+ var tamp1,tamp2: tree,\r
+ continue :boolean; (* ajout d 'un element a un arbre *)\r
+begin\r
+ continue:=TRUE;\r
+ if (t=NONE) then\r
+ t:=new tree(e);\r
+ continue:=FALSE;\r
+ else\r
+ tamp1:=t;\r
+ while continue\r
+ do\r
+ if supelem(e,tamp1.el) then\r
+ if (tamp1.right<>NONE) then\r
+ tamp1:=tamp1.right; (* idem recherche *)\r
+ else continue:=FALSE fi;\r
+ else\r
+ if (tamp1.left<>NONE) then\r
+ tamp1:=tamp1.left;\r
+ else continue:=FALSE fi;\r
+ fi;\r
+ od;\r
+ tamp2:=new tree(e);(* on cree un nouvel arbre *)\r
+ tamp2.left:=NONE;\r
+ tamp2.right:=NONE;\r
+ if supelem(e,tamp1.el) then tamp1.right:=tamp2;\r
+ else tamp1.left:=tamp2 fi;(*on le place*)\r
+ call line;\r
+ writeln("ajout classique ... fait.");\r
+ fi;\r
+ result:=t;\r
+end add;\r
+\r
+unit last:function(input t:tree;input e:tree;output r:boolean):tree;\r
+var tamp: tree, (* recherche l'element precedent un autre *)\r
+ continue,ok :boolean;\r
+begin\r
+ continue:=TRUE;\r
+ ok:=FALSE;\r
+ if (t=NONE) then\r
+ ok:=FALSE;\r
+ else\r
+ tamp:=t;\r
+ while continue\r
+ do\r
+ if (tamp.right<>NONE) then\r
+ if egalelem(e.el,tamp.right.el) then\r
+ continue:=FALSE;\r
+ ok:=TRUE; (* idem recherche mais avec 2 possibilites *)\r
+ r:=TRUE;\r
+ fi;\r
+ fi;\r
+ if (tamp.left<>NONE) then\r
+ if egalelem(e.el,tamp.left.el) then\r
+ continue:=FALSE;\r
+ ok:=TRUE;\r
+ r:=FALSE;\r
+ fi;\r
+ fi;\r
+ if not(ok) then\r
+ if supelem(e.el,tamp.el) then\r
+ if (tamp.right<>NONE) then\r
+ tamp:=tamp.right;\r
+ else continue:=FALSE; (* deplacement *)\r
+ fi;\r
+ else\r
+ if (tamp.left<>NONE) then\r
+ tamp:=tamp.left;\r
+ else continue:=FALSE;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi;\r
+ call line;\r
+ writeln("element precedent trouve ... fait.");\r
+ if ok then result:=tamp;\r
+ else result:=NONE fi;\r
+end last;\r
+\r
+unit sub: function (input t: tree;e:elem):tree;\r
+var tamp2,tamp3,pred1,pred2: tree,\r
+ r1,r2:boolean; (* on enleve une element a un arbre *)\r
+begin\r
+ tamp2:=find(t,e); (* on recherche la place de l' element *)\r
+ pred1:=last(t,tamp2,r1);(* son pere *)\r
+ if (tamp2<>NONE) then\r
+ if (tamp2=t) and (tamp2.left=NONE) then\r
+ t:=tamp2.right;\r
+ else\r
+ if (tamp2.left=NONE) then\r
+ if r1 then\r
+ pred1.right:=tamp2.right;\r
+ else\r
+ pred1.left:=tamp2.right; (* on raccorde *)\r
+ fi;\r
+ kill(tamp2);\r
+ else\r
+ tamp3:=max(tamp2.left);(* on cherche le max du sous arbre gauche *)\r
+ pred2:=last(t,tamp3,r2);(* et son pere *)\r
+ if (tamp3<>NONE) then\r
+ if r1 then\r
+ if (pred1<>NONE) then pred1.right:=tamp3;\r
+ else t:=tamp3;\r
+ fi;\r
+ if (pred2<>tamp2) then pred2.right:=tamp3.left fi;\r
+ tamp3.right:=tamp2.right;\r
+ tamp3.left:=pred2; (* on connecte *)\r
+ else\r
+ if (pred1<>NONE) then pred1.left:=tamp3;\r
+ else t:=tamp3;\r
+ fi;\r
+ if (pred2<>tamp2) then pred2.right:=tamp3.left fi;\r
+ tamp3.right:=tamp2.right;\r
+ tamp3.left:=pred2;\r
+ fi;\r
+ fi;\r
+ kill(tamp2);\r
+ fi;\r
+ fi;\r
+ else\r
+ call line;\r
+ writeln("element non touve ...");\r
+ fi;\r
+ call line;\r
+ writeln("deletion terminee ... fait.");\r
+ result:=t;\r
+end sub;\r
+\r
+unit proof:function(input t:tree):integer;\r
+begin (* calcule la profondeur d 'un arbre recursivement*)\r
+ if t<>NONE then\r
+ result:=imax(proof(t.left),proof(t.right))+1;\r
+ else(* proof=max(proof(arbredroit),proof(arbregauche)) *)\r
+ result:=0;\r
+ fi;\r
+end;\r
+\r
+unit total:procedure(input t:tree;input x,y,z:integer;input current:tree);\r
+var i:integer;(* affiche un arbre recursivement *)\r
+begin\r
+ if (t<>NONE) then\r
+ if (t.right<>NONE) and (t.left=NONE) then\r
+ call gotoxy(x,y);\r
+ write("e");\r
+ y:=y+1; (* si le sous arbre droit existe on l' affiche *)\r
+ call gotoxy(x,y);\r
+ write("Ê");\r
+ for i:=2 to (exp(z-2)) do write("Í") od;\r
+ x:=x+exp(z-2);\r
+ call total(t.right,x,y,z-1,current);\r
+ fi;\r
+ if (t.left<>NONE) and (t.right=NONE) then\r
+ call gotoxy(x,y);\r
+ write("e");\r
+ y:=y+1; (* si le sous arbre gauche existe on l' affiche *)\r
+ call gotoxy(x-exp(z-2),y);\r
+ for i:=1 to (exp(z-2)) do write("Í") od;\r
+ write("Ê");\r
+ x:=x-exp(z-2);\r
+ call total(t.left,x,y,z-1,current);\r
+ fi;\r
+ if (t.left<>NONE) and (t.right<>NONE) then\r
+ call gotoxy(x,y);\r
+ write("e");\r
+ y:=y+1;\r
+ call gotoxy(x,y);(* si les deux existent on les affiche les deux *)\r
+ write("Ê");\r
+ for i:=2 to (exp(z-2)) do write("Í") od;\r
+ x:=x+exp(z-2);\r
+ call total(t.right,x,y,z-1,current);\r
+ y:=y-1;\r
+ x:=x-exp(z-2);\r
+ call gotoxy(x,y);\r
+ write("e");\r
+ y:=y+1;\r
+ call gotoxy(x-exp(z-2),y);\r
+ for i:=1 to (exp(z-2)) do write("Í") od;\r
+ write("Ê");\r
+ x:=x-exp(z-2);\r
+ call total(t.left,x,y,z-1,current);\r
+ fi;\r
+ call gotoxy(x,y);(* sinon on affiche l'element *)\r
+ write("e");\r
+ fi;\r
+end total;\r
+\r
+unit tableau : procedure (input e,f:integer);\r
+begin (* on affiche le tableau correspondant au code de hachage *)\r
+ if ((e<f) or (e=f)) and ((e>1) or (e=1)) then\r
+ call box(30,10,10,10);\r
+ call gotoxy(31,15); (* tableau recherche *)\r
+ call reverse;\r
+ write(e);\r
+ call normal;\r
+ fi;\r
+ if (e+1<f) or (e+1=f) then\r
+ call box(50,10,10,10); (* le suivant *)\r
+ call gotoxy(51,15);\r
+ write(e+1);\r
+ fi;\r
+ if (e-1>1) or (e-1=1) then\r
+ call box(10,10,10,10); (* le precedent *)\r
+ call gotoxy(11,15);\r
+ write(e-1);\r
+ fi;\r
+end tableau;\r
+\r
+unit newtable : function (input long : integer) :arrayof tree;\r
+var t : integer;(* cree une nouvelle table *)\r
+begin\r
+ array result dim (1:long);\r
+ for t:=1 to long do result(t):=NONE od;\r
+ call line;\r
+ writeln("table initialisee ... fait.");\r
+end newtable;\r
+\r
+unit ajoute :function(input T:arrayof tree;long:integer):arrayof tree;\r
+var lg,pos:integer, (* ajoute un element a la table *)\r
+ e:elem,\r
+ current:tree;\r
+begin\r
+ e:=readelem(none); (* lit l'element *)\r
+ call cls;\r
+ pos:=hachelem(e,long);(* calcule son hach code *)\r
+ call line;\r
+ writeln("hach code calcule ... fait. ",pos);\r
+ call tableau(pos,long);(* marque sa position *)\r
+ call line;\r
+ writeln("tableau designe ... fait.");\r
+ current:=find(T(pos),e);(* le cherche *)\r
+ if (current=NONE) then\r
+ T(pos):=add(T(pos),e);(* s'il n'existe pas l'ajoute *)\r
+ call line;\r
+ writeln("element ajoute ... fait.");\r
+ call cls;\r
+ lg:=proof(T(pos)); (* calcule la profondeur de l'arbre *)\r
+ if lg<6 then call total(T(pos),40,1,lg,current) else (* affiche l'arbre *)\r
+ call line;\r
+ write("l'arbre est trop grand pour etre imprime ...");\r
+ fi;\r
+ else\r
+ call cls;\r
+ writeln("element deja stocke ...");\r
+ fi;\r
+ result:=T;\r
+ call delay;(* attend que l'utilisateur ai vu l'arbre *)\r
+end ajoute;\r
+\r
+unit supp :function(input T:arrayof tree;long:integer):arrayof tree;\r
+var lg,pos:integer,(* supprime un element *)\r
+ e:elem,\r
+ current:tree;\r
+begin\r
+ e:=readelem(none); (* idem ajoute *)\r
+ call cls;\r
+ pos:=hachelem(e,long);\r
+ call line;\r
+ writeln("hach code calcule ... fait. ",pos);\r
+ call tableau(pos,long);\r
+ call line;\r
+ writeln("tableau designe ... fait.");\r
+ current:=find(T(pos),e);\r
+ if (current<>NONE) then\r
+ T(pos):=sub(T(pos),e);\r
+ call line;\r
+ writeln("element detruit ... fait.");\r
+ call cls;\r
+ lg:=proof(T(pos));\r
+ if lg<6 then call total(T(pos),40,1,lg,current) else\r
+ call line;\r
+ write("l'arbre est trop grand pour etre imprime ...");\r
+ fi;\r
+ else\r
+ call cls;\r
+ writeln("non trouve ...");\r
+ fi;\r
+ call delay;\r
+ result:=T;\r
+end supp;\r
+\r
+unit recherche :procedure(input T:arrayof tree;long:integer);\r
+var pos:integer,(* recherche un element dans la table *)\r
+ current:tree,\r
+ e:elem;\r
+begin\r
+ e:=readelem(none);(* idem ajoute *)\r
+ call cls;\r
+ pos:=hachelem(e,long);\r
+ call line;\r
+ writeln("hach code calcule ... fait. ",pos);\r
+ call tableau(pos,long);\r
+ call line;\r
+ writeln("tableau designe ... fait.");\r
+ current:=find(T(pos),e);\r
+ call cls;\r
+ if (current<>NONE) then call writelem(current.el);(* ecrit le resultat *)\r
+ else writeln("non trouve ...") fi;(* de la recherche *)\r
+ call line;\r
+ writeln("recherche terminee ... fait.");\r
+ call delay;\r
+end recherche;\r
+\r
+unit demo :function(input T:arrayof tree;long:integer):arrayof tree;\r
+var fich:file,(*stocke automatiquement des elements contenus dans un fichier*)\r
+ c:char,\r
+ pos,lg:integer,\r
+ e:elem,\r
+ current:tree;\r
+begin\r
+ open(fich,text,unpack("data.dem"));(* on ouvre le fichier *)\r
+ call line;\r
+ writeln("ouverture du fichier ... fait.");\r
+ call reset(fich); (* en lecture *)\r
+ while not(eof(fich))\r
+ do\r
+ e:=readelem(fich);(* idem ajoute *)\r
+ pos:=hachelem(e,long);\r
+ call line;\r
+ writeln("hach code calcule ... fait. ");\r
+ call tableau(pos,long);\r
+ call line;\r
+ writeln("tableau designe ... fait.");\r
+ current:=find(T(pos),e);\r
+ if (current=NONE) then\r
+ T(pos):=add(T(pos),e);\r
+ call line;\r
+ writeln("element ajoute ... fait.");\r
+ lg:=proof(T(pos));\r
+ call cls;\r
+ if lg<6 then call total(T(pos),40,1,lg,current) else\r
+ call line;\r
+ write("l'arbre est trop grand pour etre imprime ...");\r
+ fi;\r
+ call line;\r
+ writeln("arbre imprime ... fait.");\r
+ else\r
+ call cls;\r
+ writeln("element deja stocke ...");\r
+ fi;\r
+ od;\r
+ result:=T;\r
+end demo;\r
+\r
+unit numb:function(input T:tree):integer;\r
+begin (* calcule le nombre de sommets par arbre recursivement *)\r
+ if (T<>NONE) then\r
+ result:=numb(T.left)+numb(T.right);\r
+ else (* nbsom=nbsom(arbregauche)+nbsom(arbredroit) *)\r
+ result:=1;\r
+ fi;\r
+end numb;\r
+\r
+unit stats:procedure(input T:arrayof tree;long:integer);\r
+var u,s1,s2,s3,max1,max2:integer,\r
+ s,v:arrayof integer;(* calcule quelques satistiques sur les donnees *)\r
+ (* stockees dans la table *)\r
+begin\r
+ s1:=0;s2:=0;s3:=0;\r
+ array s dim(1:long);\r
+ array v dim(1:long);\r
+ for u:=1 to long do\r
+ if (T(u)<>NONE) then\r
+ s1:=s1+1;(* nombre d'arbre utilises *)\r
+ s(u):=numb(T(u))-1;\r
+ v(u):=proof(T(u));\r
+ s2:=s2+s(u);(* nombre total de sommets *)\r
+ s3:=s3+v(u);(* profondeur totale de la table *)\r
+ fi;\r
+ od;\r
+ max1:=1;max2:=1;\r
+ for u:=1 to long do\r
+ if (s(u)>s(max1)) then max1:=u fi;\r
+ if (v(u)>s(max2)) then max2:=u fi;\r
+ od;\r
+ call cls;\r
+ call gotoxy(10,5);\r
+ write("Nombre Total de sommets :",s2);\r
+ call gotoxy(10,7);\r
+ write("Nombre Total d 'arbres non vides :",s1);\r
+ if s1<>0 then\r
+ call gotoxy(10,9);\r
+ write("Nombre moyen de sommet par arbre :",s2/s1);\r
+ call gotoxy(10,15);\r
+ write("Profondeur moyenne :",s3/s1);\r
+ else\r
+ call gotoxy(10,9);\r
+ write("Tableau non rempli ...");\r
+ fi;\r
+ call gotoxy(10,11);\r
+ write("Nombre de sommets de l'Arbre le plus important :",s(max1));\r
+ call gotoxy(10,13);\r
+ write("Profondeur de l'Arbre le plus grand :",v(max2));\r
+ call box(7,3,70,15);\r
+ call line;\r
+ write("stats calculees ... fait.");\r
+ call delay;\r
+end stats;\r
+\r
+\r
+unit op:procedure(size:integer);\r
+var T:arrayof tree, (* menu *)\r
+ c,i:integer;\r
+begin\r
+ T:=newtable(size);\r
+ while (i<>6) do\r
+ call cls;\r
+ call line;\r
+ write("utilisez les fleches haut/bas pour vous deplacer, droite pour\r
+ valider");\r
+ call gotoxy(1,7);\r
+ i:=1;\r
+ c:=0;\r
+ writeln(" Inserer un element");writeln;\r
+ writeln(" Rechercher un element");writeln;\r
+ writeln(" Supprimer un element");writeln;\r
+ writeln(" Demo");writeln;\r
+ writeln(" Statistiques");writeln;\r
+ writeln(" Quitter");writeln;\r
+ call box(5,4,50,17);\r
+ call box(10,4+2*i,35,2);\r
+ while (c<>-77) do\r
+ c:=inchar;\r
+ if (c=-80) or (c=-72) then\r
+ call gotoxy(10,4+2*i);\r
+ write(" ");\r
+ call gotoxy(10,4+2*(i+1));\r
+ write(" ");\r
+ call gotoxy(10,4+2*i+1);\r
+ write(" ");\r
+ call gotoxy(44,4+2*i+1);\r
+ write(" ");\r
+ if (c=-80) then i:=i+1 fi;\r
+ if (c=-72) then i:=i-1 fi;\r
+ if (i=7) then i:=1 fi;\r
+ if (i=0) then i:=6 fi;\r
+ call box(10,4+2*i,35,2);\r
+ fi;\r
+ od;\r
+ call cls;\r
+ case i\r
+ when 1 :T:=ajoute(T,size);\r
+ when 2 :call recherche(T,size);\r
+ when 3 :T:=supp(T,size);\r
+ when 4 :T:=demo(T,size);\r
+ when 5 :call stats(T,size);\r
+ esac;\r
+ od;\r
+ writeln("operations terminees ... fait.");\r
+end op;\r
+\r
+end table;\r
+\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* PROGRAMME PRINCIPAL *)\r
+(* *)\r
+(***************************************************************************)\r
+\r
+var stTable:table,\r
+ size,algo,i:integer,\r
+ c:integer;\r
+begin (* prog principal *)\r
+ i:=1;\r
+ while (i<>5) do\r
+ pref tools block\r
+ begin\r
+ call cls;\r
+ call line;\r
+ write("utilisez les fleches haut/bas pour vous deplacer, droite pour\r
+ valider");\r
+ call gotoxy(1,7);\r
+ writeln(" EXTRACTION");writeln;\r
+ writeln(" COMPRESSION");writeln;\r
+ writeln(" DIVISION");writeln;\r
+ writeln(" MULTIPLICATION");writeln;\r
+ writeln(" QUITTER");writeln;\r
+ call box(5,4,50,15);\r
+ call box(10,4+2*i,35,2);\r
+ while (c<>-77) do\r
+ c:=inchar;\r
+ if (c=-80) or (c=-72) then\r
+ call gotoxy(10,4+2*i);\r
+ write(" ");\r
+ call gotoxy(10,4+2*(i+1));\r
+ write(" ");\r
+ call gotoxy(10,4+2*i+1);\r
+ write(" ");\r
+ call gotoxy(44,4+2*i+1);\r
+ write(" ");\r
+ if (c=-80) then i:=i+1 fi;\r
+ if (c=-72) then i:=i-1 fi;\r
+ if (i=6) then i:=1 fi;\r
+ if (i=0) then i:=5 fi;\r
+ call box(10,4+2*i,35,2);\r
+ fi;\r
+ od;\r
+ call cls;\r
+ if (i<>5) then\r
+ call cls;\r
+ call line;\r
+ write("!! (petites tailles)+(beaucoup d'elts)=(pbs de memoire)");\r
+ call box(20,15,35,2);\r
+ call gotoxy(21,16);\r
+ write("taille du tableau desire : ");\r
+ read(size);\r
+ fi;\r
+ call cls;\r
+ c:=0;\r
+ end;\r
+ if (i=1) then\r
+ pref table(dicob,newdicob,egalel,readel,supel,extraction,writel) block\r
+ begin\r
+ stTable:= new table(dicob,newdicob,egalel,readel,supel,\r
+ extraction,writel);(* on definit les operations \85 utiliser *)\r
+ call op(size); (* dans la table sur elem *)\r
+ end;\r
+ fi;\r
+ if (i=2) then\r
+ pref table(dicob,newdicob,egalel,readel,supel,compression,writel) block\r
+ begin\r
+ stTable:= new table(dicob,newdicob,egalel,readel,supel,\r
+ compression,writel);(* idem *)\r
+ call op(size);\r
+ end;\r
+ fi;\r
+ if (i=3) then\r
+ pref table(dicob,newdicob,egalel,readel,supel,division,writel) block\r
+ begin\r
+ stTable:= new table(dicob,newdicob,egalel,readel,supel,\r
+ division,writel);(* idem *)\r
+ call op(size);\r
+ end;\r
+ fi;\r
+ if (i=4) then\r
+ pref table(dicob,newdicob,egalel,readel,supel,multiplication,writel) block\r
+ begin\r
+ stTable:= new table(dicob,newdicob,egalel,readel,supel,\r
+ multiplication,writel);(* idem *)\r
+ call op(size);\r
+ end;\r
+ fi;\r
+ od;\r
+end Htable;\r
+\r
+\r
+ (* 1006 *)\1a
\ No newline at end of file
--- /dev/null
+PROGRAM BACKTRACKING;\r
+ UNIT BACKTRACK: CLASS;\r
+ HIDDEN SE,ELEM,TOP;\r
+ VAR ROOT:NODE,SEARCH:SE,FOUND,OPT:NODE,\r
+ NUMBER_OF_NODES,NUMBER_OF_LEAVES,NUMBER_OF_ANSWERS:INTEGER;\r
+\r
+ UNIT NODE: COROUTINE(FATHER:NODE);\r
+ VAR NSONS,LEVEL: INTEGER , DEADEND:BOOLEAN;\r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ END LEAF;\r
+ UNIT VIRTUAL ANSWER :FUNCTION :BOOLEAN;\r
+ END ANSWER;\r
+ UNIT VIRTUAL LASTSON: FUNCTION : BOOLEAN;\r
+ END LASTSON;\r
+ UNIT VIRTUAL NEXTSON: FUNCTION : NODE;\r
+ END NEXTSON;\r
+ UNIT VIRTUAL EQUAL : FUNCTION (W:NODE):BOOLEAN;\r
+ END EQUAL;\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ END COST;\r
+ BEGIN\r
+ IF FATHER =/= NONE\r
+ THEN\r
+ LEVEL:=FATHER.LEVEL+1\r
+ ELSE\r
+ LEVEL:=0\r
+ FI;\r
+ END NODE;\r
+\r
+ UNIT OK: FUNCTION (V:NODE):BOOLEAN;\r
+ VAR W:NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RESULT:=FALSE; RETURN FI;\r
+ RESULT:=TRUE; W:=V.FATHER;\r
+ WHILE W =/= NONE\r
+ DO\r
+ IF V.EQUAL(W) THEN RESULT:=FALSE; RETURN FI;\r
+ W:=W.FATHER\r
+ OD\r
+ END OK;\r
+\r
+ UNIT PURGE: PROCEDURE (V:NODE);\r
+ VAR W: NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RETURN FI;\r
+ DO\r
+ W:=V.FATHER; KILL(V);\r
+ IF W=NONE THEN RETURN FI;\r
+ W.NSONS:=W.NSONS-1;\r
+ IF W.NSONS =/= 0 THEN RETURN FI;\r
+ V:=W\r
+ OD;\r
+ END PURGE;\r
+\r
+ VAR TOP:ELEM;\r
+\r
+ UNIT ELEM: CLASS (NEXT:ELEM, V:NODE);\r
+ END ELEM;\r
+\r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ BEGIN\r
+ TOP:=NEW ELEM(TOP,V);\r
+ END INSERT;\r
+\r
+ UNIT VIRTUAL DELETE: FUNCTION :NODE;\r
+ VAR E:ELEM;\r
+ BEGIN\r
+ IF TOP =/= NONE\r
+ THEN\r
+ RESULT:=TOP.V;\r
+ E:=TOP; TOP:=TOP.NEXT; KILL(E);\r
+ FI;\r
+ END DELETE;\r
+\r
+ UNIT SE: COROUTINE ;\r
+ VAR I:INTEGER,V,W:NODE;\r
+ BEGIN\r
+ RETURN; CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN EXIT FI;\r
+ ATTACH(V);\r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ FOUND:=V;\r
+ IF OPT=NONE ORIF V.COST < OPT.COST\r
+ THEN\r
+ OPT:=V\r
+ FI;\r
+ DETACH;\r
+ (* HERE THE USER OF BACKTRACK MAY UNDERTAKE SOME ACTIONS\r
+ ON THE ANSWER NODES. IF NOT NECESSARY DO ATTACH *)\r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V);\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ NUMBER_OF_NODES:=NUMBER_OF_NODES+1;\r
+ IF OK(W)\r
+ THEN\r
+ W.DEADEND:=W.LEAF; CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI;\r
+ OD;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FOUND:=NONE;\r
+ END SE;\r
+\r
+\r
+ UNIT KILLALL :PROCEDURE;\r
+ VAR V:NODE;\r
+ BEGIN\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN RETURN FI;\r
+ CALL PURGE(V);\r
+ OD;\r
+ END KILLALL;\r
+\r
+ BEGIN\r
+ SEARCH:=NEW SE;\r
+ INNER;\r
+ KILL(SEARCH); CALL KILLALL;\r
+ END BACKTRACK;\r
+\r
+\r
+UNIT BESTSEARCH: BACKTRACK CLASS;\r
+ (* BESTSEARCH USES A PRIORITY QUEUE FOR NODES.\r
+ QUEUE IS ORGANIZED AS A HEAP IN THE ARRAY A.\r
+ THE FIRST ELEMENT A(1) IS THE LEAST ONE. *)\r
+ HIDDEN A,B,X,K,M,I,J;\r
+ VAR A,B:ARRAYOF EX_NODE, X : EX_NODE, K,M,I,J:INTEGER;\r
+ (*M- CURRENT ARRAY A LENTGTH\r
+ K- CURRENT HEAP LENGTH\r
+ B- SRATCH ARRAY *)\r
+\r
+ UNIT EX_NODE : NODE CLASS;\r
+ UNIT VIRTUAL LESS : FUNCTION (X: EX_NODE) : BOOLEAN;\r
+ END LESS;\r
+ END EX_NODE;\r
+\r
+ UNIT VIRTUAL DELETE: FUNCTION :EX_NODE;\r
+\r
+ BEGIN\r
+ IF K=0 THEN RETURN FI;\r
+ RESULT:=A(1); X:=A(K); K:=K-1;\r
+ IF K=0\r
+ THEN\r
+ KILL(A); RETURN\r
+ FI;\r
+ IF K*2<M\r
+ THEN\r
+ ARRAY B DIM (1: M DIV 2);\r
+ FOR I:=1 TO K DO B(I):=A(I) OD;\r
+ KILL(A); M:=M DIV 2; A:=B\r
+ FI;\r
+ I:=1; J:=2;\r
+ WHILE J <= K\r
+ DO\r
+ IF J+1 <= K ANDIF A(J+1).LESS( A(J))\r
+ THEN\r
+ J:=J+1\r
+ FI;\r
+ IF X.LESS( A(J)) THEN EXIT FI;\r
+ A(I):=A(J); I:=J; J:=2*I\r
+ OD;\r
+ A(I):=X\r
+ END DELETE;\r
+\r
+\r
+ UNIT VIRTUAL INSERT : PROCEDURE(X: EX_NODE);\r
+ BEGIN\r
+ IF K=0\r
+ THEN\r
+ ARRAY A DIM (1:2); M:=2;\r
+ FI;\r
+ IF K=M\r
+ THEN\r
+ ARRAY B DIM(1:2*M); FOR I:=1 TO M DO B(I):=A(I) OD;\r
+ KILL(A); M:=2*M; A:=B;\r
+ FI;\r
+ K,J:=K+1;\r
+ IF K=1 THEN A(1):=X; RETURN; FI;\r
+ I:= J DIV 2;\r
+ WHILE I>=1\r
+ DO\r
+ IF A(I).LESS( X ) THEN EXIT FI;\r
+ A(J):=A(I); J:=I; I:= J DIV 2\r
+ OD;\r
+ A(J):=X\r
+ END INSERT;\r
+\r
+ BEGIN\r
+ INNER;\r
+ CALL KILLALL;\r
+ END BESTSEARCH;\r
+\r
+\r
+\r
+ VAR N,Q:INTEGER,H1,H2,H3:CHAR;\r
+ (* Q - BOAT CAPACITY, N- NUMBER OF CANNIBALS, N- NUMBER OF MISSIONARIES *)\r
+\r
+BEGIN\r
+ DO\r
+ WRITE(" NUMBER OF PERSONS ");\r
+ WRITE(" (IF END OF SESSION WRITE 0) =");\r
+ READLN(N);\r
+ IF N=0 THEN EXIT FI;\r
+ WRITE(" BOAT CAPACITY=");\r
+ READLN(Q);\r
+\r
+ PREF BESTSEARCH BLOCK\r
+ VAR M,C:INTEGER;\r
+ (* M- NUMBER OF MISSIONARIES, C- NUMBER OF CANNIBALS ON THE BOAT *)\r
+\r
+ UNIT STATE: EX_NODE CLASS(ML,CL:INTEGER);\r
+ VAR MR,CR:INTEGER, LEFT:BOOLEAN;\r
+\r
+ (* ML- NUMBER OF MISSIONARIES ON THE LEFT BANK OF THE RIVER\r
+ MR- NUMBER OF MISSIONARIES ON THE RIGHT BANK OF THE RIVER\r
+ CL- NUMBER OF CANNIBALS ON THE LEFT BANK OF THE RIVER\r
+ CR- NUMBER OF CANNIBALS ON THE RIGHT BANK OF THE RIVER\r
+ LEFT- TRUE IFF THE BOAT IS ON THE LEFT BANK OF THE RIVER *)\r
+\r
+ UNIT VIRTUAL ANSWER: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:=ML=0 AND CL=0\r
+ END ANSWER;\r
+\r
+ UNIT VIRTUAL LEAF: FUNCTION : BOOLEAN;\r
+ BEGIN\r
+ IF ML<0 ORIF MR<0 ORIF CL<0 ORIF CR<0 ORIF\r
+ ML>N ORIF MR>N ORIF CL>N ORIF CR>N ORIF\r
+ ML<CL AND ML>0 ORIF MR<CR AND MR>0\r
+ THEN\r
+ RESULT:=TRUE\r
+ FI\r
+ END LEAF;\r
+\r
+\r
+ UNIT VIRTUAL LASTSON: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ IF C=0 AND M=Q\r
+ THEN\r
+ RESULT:=TRUE; M:=0; C:=0;\r
+ FI;\r
+ END;\r
+\r
+ UNIT VIRTUAL NEXTSON : FUNCTION :STATE;\r
+ BEGIN\r
+ C:=C+1;\r
+ IF M=0\r
+ THEN\r
+ IF C>Q\r
+ THEN\r
+ C:=0; M:=1\r
+ FI\r
+ ELSE\r
+ IF M<C ORIF M+C>Q\r
+ THEN\r
+ C:=0; M:=M+1;\r
+ FI\r
+ FI;\r
+ IF LEFT\r
+ THEN\r
+ IF C+M<Q\r
+ THEN\r
+ RESULT:=NONE\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,ML-M,CL-C)\r
+ FI\r
+ ELSE\r
+ RESULT:=NEW STATE(THIS STATE,ML+M,CL+C)\r
+ FI;\r
+ END NEXTSON;\r
+\r
+ UNIT VIRTUAL EQUAL: FUNCTION(S:STATE):BOOLEAN;\r
+ BEGIN\r
+ RESULT:=LEFT=S.LEFT AND ML=S.ML AND CL=S.CL;\r
+ END EQUAL;\r
+\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ BEGIN\r
+ RESULT:=LEVEL\r
+ END COST;\r
+\r
+ UNIT VIRTUAL LESS: FUNCTION (S:STATE): BOOLEAN;\r
+ BEGIN\r
+ RESULT:=ML+CL<S.ML+S.CL\r
+ END LESS;\r
+\r
+\r
+\r
+ BEGIN\r
+ LEFT:=LEVEL MOD 2 = 0;\r
+ MR:=N-ML; CR:=N-CL;\r
+ RETURN;\r
+ DO\r
+ IF BOOL1 THEN CALL DISPLAY(THIS STATE) FI;\r
+ DETACH;\r
+ OD;\r
+ END STATE;\r
+\r
+\r
+ UNIT DISPLAY: PROCEDURE(V:STATE);\r
+ VAR J,I:INTEGER, W:STATE,AT: ARRAYOF STATE;\r
+ BEGIN\r
+ IF V=NONE THEN WRITELN(" NO MORE SOLUTIONS"); RETURN FI;\r
+ I:=V.LEVEL;\r
+ ARRAY AT DIM (0:I);\r
+ W:=V;\r
+ FOR J:=I DOWNTO 0\r
+ DO\r
+ AT(J):=W; W:=W.FATHER\r
+ OD;\r
+ WRITELN("MOVE NUMBER LEFT SIDE DIRECTION RIGHT SIDE");\r
+ FOR J:=0 TO I\r
+ DO\r
+ WRITE(J); WRITE(" ");\r
+ W:=AT(J);\r
+ WRITE(W.ML,W.CL," ");\r
+ IF W.LEFT\r
+ THEN\r
+ WRITE("->");\r
+ ELSE\r
+ WRITE("<-");\r
+ FI;\r
+ WRITELN(" ",W.MR,W.CR);\r
+ OD;\r
+ KILL(AT);\r
+ END DISPLAY;\r
+\r
+ VAR BOOL1:BOOLEAN;\r
+\r
+ BEGIN\r
+ ROOT:=NEW STATE(NONE,N,N);\r
+ WRITE("DO YOU WANT TO OPTIMIZE ");\r
+ WRITELN("OR TO PRINT ALL THE SOLUTIONS ?");\r
+ WRITELN(" (ANSWER OPT OR ALL)");\r
+ READLN(H1,H2,H3);\r
+ IF H1='O' AND H2='P' AND H3='T'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ IF OPT =/= NONE ANDIF OPT.COST<FOUND.COST\r
+ THEN\r
+ EXIT\r
+ FI;\r
+ OD;\r
+ IF OPT =/= NONE\r
+ THEN\r
+ CALL DISPLAY(OPT);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ ELSE\r
+ WRITELN("NO SOLUTIONS");\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ FI;\r
+ ELSE\r
+ IF H1='A' AND H2='L' AND H3='L'\r
+ THEN\r
+ WRITELN("DO YOU WANT TO PRINT PARTIAL RESULTS?");\r
+ READLN(H1,H2,H3);\r
+ IF H1='Y' AND H2='E' AND H3='S'\r
+ THEN\r
+ BOOL1:=TRUE\r
+ FI;\r
+ DO\r
+ ATTACH(SEARCH);\r
+ CALL DISPLAY(FOUND);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ WRITELN("DO YOU WANT TO CONTINUE?");\r
+ READ(H1,H2);\r
+ IF H1=/='Y' ORIF H2=/='E' THEN EXIT FI;\r
+ READLN(H3);\r
+ IF H3=/='S' THEN EXIT FI;\r
+ OD;\r
+ ELSE\r
+ EXIT\r
+ FI\r
+ FI;\r
+ END;\r
+ OD;\r
+\r
+ END;\r
+\r
+END\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+program TYPETEXT;\r
+\r
+(****************************************************************************) \r
+(********************** D\82claration de l'UNIT TYPETEXT *********************) \r
+(****************************************************************************) \r
+ \r
+ \r
+ UNIT Typetext : class;\r
+\r
+ VAR contenu : arrayof char, (* tableau contenant la valeur de la cha\8cne \r
+ de caract\8ares *)\r
+ position : integer; (* entier indiquant la position courante dans\r
+ le tableau pr\82c\82dent (indice d'un champ) *)\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************** D\82claration de l'UNIT Ecrire ********************)\r
+ (**********************************************************************)\r
+ (******** On affiche la valeur du type contenu dans "contenu" ********)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Ecrire : procedure;\r
+ \r
+(* si la variable contenu vaut none, cela signifie qu'elle n'a pas \82t\82 encore\r
+ cr\82\82e, donc l'affichage est vierge : on sort de la proc\82dure.\r
+ sinon du premier indice du tableau (1) jusqu'\85 la taille du tableau, on lit\r
+ chaque caract\8are au fur et \85 mesure et on les affiche. *)\r
+\r
+ VAR i:integer;\r
+\r
+ BEGIN\r
+ if (contenu=none) then exit fi;\r
+ for i:=1 to upper(contenu) do write(contenu(i)) od;\r
+ writeln;\r
+ END ecrire;\r
+\r
+ \r
+ (**********************************************************************)\r
+ (******************* D\82claration de l'UNIT Lecture *******************) \r
+ (**********************************************************************)\r
+ (******* On saisie les caract\8ares d\82finissant la valeur du type *******)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Lecture : procedure(l:integer);\r
+\r
+(* On ignore la taille de la cha\8cne de caract\8ares que va saisir l'utilisateur.\r
+ Il est donc impossible de cr\82er le tableau contenu car on ne conna\8ct pas sa\r
+ taille. Le principe retenu est le suivant : On cr\82e un tableau temporaire\r
+ appel\82 temp ayant une taille al\82atoire mais d\82finie par le programmeur, c'-\r
+ est la variable taille initialis\82e ici \85 10. Au fur et \85 mesure que l'utili- \r
+ sateur saisi les caract\8ares composant sa cha\8cne, chacun de ces derniers est\r
+ mis dans le tableau temp. Si ce tableau est plein, alors par r\82cursivit\82,\r
+ on rapelle cette proc\82dure Lecture avec pour param\8atre le nombre de carac- \r
+ t\8ares d\82j\85 saisi et ainsi de suite. Une fois la saisie finie (rep\82r\82e par\r
+ 13, le code de la touche ENTER ou RETOUR-CHARIOT), on cr\82e notre tableau\r
+ contenu ayant pour taille la valeur de la variable l pass\82e en param\8atre.\r
+ Pour chaque proc\82dure appel\82e, on part de la fin de leur tableau temp o\97\r
+ on lit les caract\8ares que l'on va affecter dans le tableau contenu mais en\r
+ partant aussi de la fin. *)\r
+\r
+ CONST taille = 10;\r
+ VAR temp : arrayof char,\r
+ cpt,i : integer;\r
+ \r
+ BEGIN\r
+ array temp dim(1:taille); (* tableau interne *)\r
+ cpt := 1;\r
+\r
+ do\r
+ i:=inchar; (* lecture d'une touche *)\r
+ write(chr(i));\r
+ \r
+ if ( i = 13) (* si enter ou retour-chariot *)\r
+ then\r
+ l := l + cpt -1 ;\r
+ \r
+ if (l=0) (* la cha\8cne saisie est vide *)\r
+ then\r
+ position := 0; (* no elements have been read *) \r
+ exit;\r
+ fi;\r
+ \r
+ array contenu dim(1:l); (* cr\82ation du tableau contenu *)\r
+ for i:=(cpt-1) downto 1 do\r
+ contenu(l) := temp(i); (* remplissage du tableau contenu *)\r
+ l := l -1;\r
+ od;\r
+ exit; (* fin du remplissage donc on peut sortir *)\r
+ fi;\r
+ \r
+ temp(cpt) := chr(i); (* affectation du caract\8are lu dans le \r
+ tableau *)\r
+ if (cpt=taille) (* si le tableau est plein, alors on cr\82e *)\r
+ then (* un autre tableau temporaire par r\82cur- *)\r
+ l := l + cpt; (* ssivit\82 pour pouvoir sauvegarder les *)\r
+ call Lecture(l); (* autres caract\8ares composant la cha\8cne *)\r
+ \r
+ for i:=taille downto 1 do \r
+ contenu(l) := temp(i);\r
+ l := l - 1;\r
+ od;\r
+ \r
+ exit;\r
+ fi;\r
+ \r
+ cpt := cpt +1;\r
+ od;\r
+ \r
+ position := 1;\r
+\r
+ END Lecture;\r
+ \r
+ \r
+ (**********************************************************************)\r
+ (******************** D\82claration de l'UNIT Concat ********************) \r
+ (**********************************************************************)\r
+ (******* On retourne une variable r\82sultant de la concat\82nation *******)\r
+ (***************** de deux varibles de type Typetext ******************)\r
+ (**********************************************************************)\r
+\r
+ \r
+ UNIT Concat : procedure(t:typetext) ;\r
+ \r
+(* On concat\8ane la variable courante avec une variable t d\82finie par l'utili- \r
+ sateur. \r
+ - si t est vide, la concat\82nation est inutile.\r
+ - si la variable courante est vide, la concat\82nation repr\82sente alors la\r
+ variable \85 concat\82ner.\r
+ - sinon, on r\82cup\8are la valeur de la variable contenu du type courant \r
+ dans un tableau temporaire. On recr\82e cette variable contenu mais avec\r
+ une taille de longueur \82gale \85 la taille du tableau temporaire plus la\r
+ taille du tableau contenu de la variable \85 concat\82ner (t).\r
+ * On r\82\82crit le tableau temporaire dans le nouveau tableau contenu.\r
+ * On d\82truit le tableau temporaire\r
+ * On \82crit le tableau contenu de la variable t dans le nouveau tableau.\r
+*) \r
+\r
+ VAR i,j : integer,\r
+ temp : arrayof char;\r
+ \r
+ BEGIN\r
+\r
+ if (t=none) then exit fi; \r
+ (* la concat\82nation avec une cha\8cne vide ne donne rien; on sort \r
+ donc de la proc\82dure *)\r
+ \r
+ if (contenu=none) (* si la variable \85 laquelle se fait la *) \r
+ then (* concat\82nation est vide, alors son *)\r
+ contenu := t.contenu; (* contenu est celle de la variable \85 *)\r
+ exit; (* concat\82ner. *)\r
+ fi;\r
+ \r
+ temp := copy(contenu); \r
+ kill(contenu);\r
+ array contenu dim (1:upper(temp)+upper(t.contenu));\r
+ (* Cr\82ation de la variable contenu avec sa nouvelle taille *)\r
+\r
+ for i:=1 to upper(temp) do (* recopie du tableau temporaire *)\r
+ contenu(i) := temp(i) \r
+ od;\r
+\r
+ kill(temp);\r
+\r
+ for j:=1 to upper(t.contenu) do (* recopie de la cha\8cne de caract\8a- *)\r
+ contenu(j+i-1) := t.contenu(j); (* res caract\82risant la variable t *)\r
+ od;\r
+\r
+ END concat;\r
+\r
+ \r
+ (**********************************************************************)\r
+ (********************* D\82claration de l'UNIT Copie ********************) \r
+ (**********************************************************************)\r
+ (**** Cette fonction renvoie une sous-cha\8cne de la variable contenu ***)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Copie : Function(number:integer) : typetext;\r
+\r
+(* A partir de la position courante dans le tableau, on recopie la cha\8cne de \r
+ caract\8ares sur une longueur number.\r
+ - Si la cha\8cne de caract\8ares dans laquelle se fait la recherche est vide\r
+ ou si la longueur de recopie est nulle ou n\82gative, la proc\82dure ne\r
+ donne rien, donc on sort.\r
+ - Sinon, on cr\82e une nouvelle variable typetext dont sa variable contenu\r
+ a pour longueur la variable number; cependant si longueur de recopie, \85\r
+ partir de la position courante atteint la fin de la cha\8cne de caract\8ares,\r
+ alors la longueur de la variable contenu a une longueur \82gale \85 la taille\r
+ de la cha\8cne de carat\8ares moins la position courante plus 1.\r
+ Ensuite on recopie les differents caract\8ares \85 partir de la position cou-\r
+ rante dans le tableau contenu de la variable \85 retourner *) \r
+\r
+ VAR i : integer; \r
+ \r
+ BEGIN\r
+ \r
+ if ( (contenu=none) or (number<=0) )\r
+ then exit\r
+ fi;\r
+ \r
+ result := new typetext;\r
+ \r
+ if (position + number - 1 > upper(contenu))\r
+ then number := upper(contenu) - position + 1\r
+ fi;\r
+ array result.contenu dim(1:number);\r
+ for i:=1 to number do\r
+ result.contenu(i) := contenu(position+i-1);\r
+ od;\r
+\r
+ END Copie;\r
+\r
+ \r
+ (**********************************************************************)\r
+ (**********************************************************************)\r
+ (******************** D\82claration de l'UNIT Insert ********************) \r
+ (**********************************************************************)\r
+ (********** On insere des caract\8ares dans le tableau contenu **********)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Insert : procedure(t:typetext);\r
+ \r
+(* A partir de la position courante du type courant, on ins\8are la cha\8cne de\r
+ caract\8ares repr\82sent\82e par t.\r
+ Si la cha\8cne \85 ins\82rer est vide, on quitte la proc\82dure.\r
+ Si la cha\8cne courante, c'est-\85-dire qui va recevoir la cha\8cne t, est vide\r
+ alors le r\82sultat est cette cha\8cne t.\r
+ Sinon\r
+ -On cr\82e une tableau temporaire de longueur \82gale \85 la taille de la cha\8cne \r
+ de caract\8ares \85 ins\82rer plus la taille de la cha\8cne de caract\8ares dans la-\r
+ quelle va se faire l'insertion.\r
+ -On recopie dans le tableau temporaire la cha\8cne, qui \88tre modifi\82e, de son \r
+ d\82but jusqu'\85 sa position courante moins un.\r
+ -On y recopie ensuite la cha\8cne t.\r
+ -On y copie enfin le reste de la premi\8are cha\8cne, c'est-\85-dire de la posi-\r
+ tion courante plus un jusqu'\85 sa fin. *)\r
+\r
+ VAR temp:arrayof char,\r
+ l,i,j : integer;\r
+\r
+ BEGIN\r
+\r
+ if (t=none) then exit fi;\r
+ \r
+ if (contenu=none)\r
+ then \r
+ contenu := t.contenu;\r
+ exit;\r
+ fi;\r
+\r
+ l := upper(contenu)+upper(t.contenu);\r
+ \r
+ array temp dim (1:l);\r
+\r
+ for i:=1 to (position-1) do temp(i) := contenu(i) od;\r
+ \r
+ for j:=1 to upper(t.contenu) do\r
+ temp(i) := t.contenu(j);\r
+ i := i + 1 ;\r
+ od;\r
+ \r
+ for j:= position to upper(contenu) do\r
+ temp(i) := contenu(j);\r
+ i := i + 1 ;\r
+ od;\r
+ \r
+ kill(contenu);\r
+ contenu := copy(temp);\r
+ kill(temp);\r
+ \r
+ END Insert;\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************** D\82claration de l'UNIT Delete ********************) \r
+ (**********************************************************************)\r
+ (************* On efface des caract\8ares du tableau contenu ************)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Delete : procedure(number:integer);\r
+ \r
+ VAR i,j,l : integer;\r
+ VAR temp : arrayof char;\r
+\r
+ BEGIN\r
+ \r
+ if ( (contenu=none) or (number<=0) ) \r
+ (* Cha\8cne vide ou longueur incorrect *)\r
+ then exit;\r
+ fi;\r
+ \r
+ if ( position + number - 1 > upper(contenu) )\r
+ then l := position - 1\r
+ else l := upper(contenu) - number;\r
+ fi;\r
+\r
+ array temp dim (1:l);\r
+ \r
+ for i:=1 to (position-1) do \r
+ temp(i) := contenu(i);\r
+ od;\r
+ \r
+ for j:=(position + number) to upper(contenu) do\r
+ temp(i) := contenu(j);\r
+ i := i + 1;\r
+ od;\r
+\r
+ kill(contenu);\r
+ contenu := copy(temp);\r
+ kill(temp);\r
+\r
+\r
+ END Delete;\r
+\r
+\r
+ (**********************************************************************)\r
+ (************** D\82claration de l'UNIT Rechercher_Position *************) \r
+ (**********************************************************************)\r
+ (**** On recherche une suite de caract\8ares dans le tableau contenu ****)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Rechercher_Position : function (s:typetext) : integer;\r
+\r
+(* la recherche de la cha\8cne de caract\8ares s revient \85 comparer tous les\r
+ \82l\82ments du tableau s.contenu avec ceux du tableau contenu de la variable\r
+ courante mais \85 partir d'une position pr\82cise. \r
+ On recherche le caract\8are correspondant \85 l'indice 1 de s.contenu dans le\r
+ tableau contenu courant, c'est-\85-dire de 1 \85 un certain indice.\r
+ A partir de cet indice, on compare les caract\8ares des indices suivants avec\r
+ ceux du s.contenu variant donc de 2 jusqu'\85 trouver un caract\8are different\r
+ ou la fin du tableau ce qui signifierait que la cha\8cne a \82t\82 trouv\82e, au-\r
+ quel cas on retourne la valeur de l'entier correspondant \85 l'indice de \r
+ commencement de recherche dans contenu. Si la cha\8cne n'est pas trouv\82e,\r
+ on retourne 0. *)\r
+\r
+ VAR i,j,temp : integer, \r
+ fin,occurence : boolean;\r
+ \r
+ BEGIN\r
+ \r
+ if (contenu = none)\r
+ then \r
+ result := 0;\r
+ exit;\r
+ fi;\r
+ \r
+ i := 1;\r
+ j := 1;\r
+ temp := 0;\r
+ fin := false;\r
+ occurence := false;\r
+\r
+ while( ( i <= upper(contenu) ) and not(fin) ) do\r
+ if (contenu(i) = s.contenu(j))\r
+ then j := j+1\r
+ else j := 1\r
+ fi;\r
+\r
+ if (contenu(i) = s.contenu(1)) \r
+ then \r
+ if not(occurence)\r
+ then \r
+ temp := i;\r
+ occurence := true;\r
+ else \r
+ if (j=1) \r
+ then\r
+ i := temp;\r
+ occurence := false;\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+ if (j>upper(s.contenu))\r
+ then fin := true;\r
+ else i := i + 1;\r
+ fi;\r
+\r
+ od;\r
+\r
+ if fin\r
+ then result := i - upper(s.contenu) + 1\r
+ else result := 0\r
+ fi;\r
+\r
+ END Rechercher_Position;\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************** D\82claration de l'UNIT Suivant *******************) \r
+ (**********************************************************************)\r
+ (* On incr\82mente la variable position rep\82rant la position courante *)\r
+ (********************* du tableau contenu *********************)\r
+ (**********************************************************************)\r
+\r
+ \r
+ UNIT Suivant : procedure ;\r
+ \r
+(* On incr\82mente simplement la variable position, sauf si :\r
+ - on est \85 la fin de la cha\8cne de caract\8ares\r
+ - si cette cha\8cne est vide *)\r
+\r
+ BEGIN\r
+ if (contenu=none) then exit fi;\r
+\r
+ if ( position < upper(contenu) ) then position := position +1 fi;\r
+ END Suivant;\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************* D\82claration de l'UNIT Precedent ******************) \r
+ (**********************************************************************)\r
+ (** On d\82cr\82mente la variable position rep\82rant la position courante **) \r
+ (************************ du tableau contenu *************************)\r
+ (**********************************************************************)\r
+ \r
+ \r
+ UNIT Precedent : procedure ;\r
+\r
+(* On d\82cr\82mente simplement la variable position, sauf si :\r
+ - on est au d\82but de la cha\8cne de caract\8ares\r
+ - si cette cha\8cne est vide *)\r
+ \r
+ BEGIN\r
+ if (contenu=none)\r
+ then exit\r
+ fi;\r
+ if ( position <> 1 )\r
+ then position := position -1\r
+ fi;\r
+\r
+ END Precedent;\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************* D\82claration de l'UNIT Majuscule ******************) \r
+ (**********************************************************************)\r
+ (* On transforme les lettres minuscules du tableau contenu en lettres *)\r
+ (******** majuscules sur une longueur d\82finie par l'utilisateur *******)\r
+ (**********************************************************************)\r
+\r
+(*****************************************************************************\r
+ \r
+ Si la cha\8cne de caract\8ares est vide, le traitement est inutile. \r
+ Sur une longueur l, on va transformer les lettres minuscules en majuscules \r
+ pour la proc\82dure Majuscule, et les lettres majuscules en minuscules pour\r
+ la proc\82dure Minuscules.\r
+ Pour ces deux traitements l'algorithme est le m\88me sauf pour la conversion. \r
+ Il repose sur la constatation suivante :\r
+ \r
+ - la conversion ne marche que pour les lettres alphab\82tiques \85 savoir :\r
+ * de 'a'..'z' pour la proc\82dure Majuscule\r
+ * de 'A'..'Z' pour la proc\82dure Minuscule \r
+ \r
+ - les caract\8ares ascii ont une valeur d\82cimale\r
+ * de 65 --> 90 pour 'A' --> 'Z'\r
+ * de 97 --> 122 pour 'a' --> 'z'\r
+ \r
+ - le passage, pour la valeur d\82cimale du code ascii, :\r
+ * d'une lettre Majuscule \85 une lettre Minuscule est de +32 \r
+ * d'une lettre Minuscule \85 une lettre Majuscule est de -32 \r
+\r
+ - Deux fonctions sont disponibles en loglan, avec int un entier (INTEGER)\r
+ et chr un caract\8are (CHAR)\r
+ * chr(int) = car : retourne le caract\8are car du code ascii int.\r
+ * ord(car) = int : retourne le code ascii int du caract\8ate car.\r
+\r
+ Il suffit donc, suivant la proc\82dure appel\82, de v\82rifier si le caract\8are\r
+ correspond bien \85 l'intervalle \85 traiter, puis de faire la conversion, \85\r
+ savoir r\82cup\82rer le code ascii du caract\8are et de lui ajouter ou retancher\r
+ 32 et de reconvertir dans le caract\8are correspondant \85 cette nouvelle va-\r
+ leur calcul\82e. \r
+\r
+*****************************************************************************)\r
+\r
+\r
+ UNIT Majuscule : procedure(l:integer);\r
+ \r
+ VAR i,pos,value : integer;\r
+\r
+ BEGIN\r
+ \r
+ if (contenu=none) then exit fi;\r
+ \r
+ pos := position;\r
+ \r
+ for i:=1 to l do\r
+ if (pos>upper(contenu)) then exit fi;\r
+ \r
+ value := ord(contenu(pos));\r
+ if ((value>=97) and (value<=122)) then contenu(pos) := chr(value-32) fi;\r
+ pos := pos + 1;\r
+ \r
+ od;\r
+\r
+ END Majuscule;\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************* D\82claration de l'UNIT Minuscule ******************) \r
+ (**********************************************************************)\r
+ (* On transforme les lettres majuscules du tableau contenu en lettres *)\r
+ (******* minuscules sur une longueur d\82finie par l'utilisateur ******)\r
+ (**********************************************************************)\r
+ \r
+\r
+ UNIT Minuscule : procedure(l:integer);\r
+ \r
+ (* voir explication dans la unit Majuscule *)\r
+\r
+ VAR i,pos,value : integer;\r
+\r
+ BEGIN\r
+ if (contenu=none) then exit fi;\r
+\r
+ pos := position;\r
+ for i:=1 to l do\r
+ if (pos>upper(contenu)) then exit fi;\r
+\r
+ value := ord(contenu(pos));\r
+ if ((value>= 65) and (value<=90)) then contenu(pos) := chr(value+32) fi;\r
+\r
+ pos := pos + 1;\r
+ od;\r
+ END Minuscule;\r
+\r
+\r
+ (**********************************************************************)\r
+ (*************** D\82claration de l'UNIT Position_courante **************) \r
+ (**********************************************************************)\r
+ (****** On transmet la position courante dans le tableau contenu ******)\r
+ (**********************************************************************)\r
+ \r
+ \r
+ UNIT Position_courante : function : integer;\r
+ \r
+(* On retourne la valeur de la position courante du type concern\82. Il suffit \r
+ de donner la valeur de la variable position. Si la cha\8cne concern\82e est \r
+ vide, on retourne 0 *)\r
+\r
+ BEGIN\r
+ if (contenu<>none)\r
+ then result := position\r
+ else result := 0\r
+ fi;\r
+ END Position_Courante;\r
+\r
+\r
+ (**********************************************************************)\r
+ (*************** D\82claration de l'UNIT Nouvelle_Position **************) \r
+ (**********************************************************************)\r
+ (******* On change la position courante dans le tableau contenu *******)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Nouvelle_Position : procedure(pos:integer);\r
+ \r
+(* A partir d'une position, repr\82sent\82e par la variable pos donn\82e par l-utili\r
+ sateur, on repositionne la position courante dans le tableau contenu sur \r
+ un autre \82l\82ment de celui-\87i. Cela revient donc \85 affecter \85 la variable\r
+ position cette valeur pos. \r
+ Cependant, \r
+ - Si la cha\8cne est vide ou si la nouvelle position d\82sir\82e est inf\82rieure \r
+ ou \82gale \85 0, on ne fait rien.\r
+ - Si la nouvelle position est sup\82rieure \85 la taille de la cha\8cne de ca-\r
+ ract\8ares, on se positionne sur le dernier \82l\82ment de cette cha\8cne. *)\r
+\r
+ BEGIN\r
+ if ( (pos <= 0) or (contenu=none) ) then exit fi;\r
+\r
+ if (upper(contenu) < pos)\r
+ then position := upper(contenu)\r
+ else position := pos\r
+ fi;\r
+ END Nouvelle_Position;\r
+\r
+\r
+ (**********************************************************************)\r
+ (******************** D\82claration de l'UNIT Length ********************) \r
+ (**********************************************************************)\r
+ (********** On transmet la longueur dans le tableau contenu ***********)\r
+ (**********************************************************************)\r
+\r
+\r
+ UNIT Length : function : integer;\r
+ \r
+(* On retourne la longueur de la cha\8cne de caract\8ares caract\82risant le type\r
+ courant. Il suffit de donner la taille de la variable contenu le caract\82-\r
+ risant, sauf si la cha\8cne est vide, dans quel cas on retourne 0.\r
+*)\r
+\r
+ BEGIN\r
+ if (contenu=none)\r
+ then result := 0\r
+ else result := upper(contenu);\r
+ fi;\r
+ END Length;\r
+ \r
+ \r
+ END typetext;\r
+\r
+\r
+(****************************************************************************) \r
+(***************** Fin de la D\82claration de l'UNIT TYPETEXT ****************) \r
+(****************************************************************************) \r
+ \r
+\r
+\r
+(****************************************************************************) \r
+(************************ Proc\82dures et fonctions *************************) \r
+(****************************************************************************) \r
+ \r
+\r
+ \r
+(***************************************************************************** \r
+ Cette fonction retourne la valeur d\82cimale correspondant \85 la touche \r
+ s\82lectionn\82e \r
+*****************************************************************************) \r
+ \r
+\r
+ UNIT Inchar : IIUWgraph function : integer;\r
+ \r
+ VAR i:integer;\r
+ \r
+ BEGIN\r
+ do\r
+ i:=inkey;\r
+ if (i<>0) then exit fi;\r
+ od;\r
+ result := i;\r
+ \r
+ END Inchar;\r
+ \r
+\r
+(***************************************************************************** \r
+ Cette proc\82dure efface l'\82cran\r
+*****************************************************************************)\r
+ \r
+\r
+ UNIT clear : procedure ;\r
+ BEGIN\r
+ write(chr(27),"[2J"); \r
+ END clear;\r
+\r
+\r
+(***************************************************************************** \r
+ Cette proc\82dure positionne le curseur l'\82cran em mode texte (80 x 25)\r
+*****************************************************************************)\r
+\r
+\r
+ UNIT SetCursor : procedure(row,column : integer);\r
+ VAR c,d,e,f : char,\r
+ i,j : integer; \r
+ BEGIN \r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10; \r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write(chr(27),"[",c,d,";",e,f,"H");\r
+ END SetCursor;\r
+\r
+\r
+(***************************************************************************** \r
+\r
+ Cette proc\82dure initialise l'\82cran. Elle : \r
+ - affiche le menu\r
+ - pr\82pare l'\82cran pour y \82crire les diff\82rents r\82sultats\r
+\r
+*****************************************************************************) \r
+ \r
+\r
+ UNIT initialisation : procedure ; \r
+ \r
+ VAR i,j : integer; \r
+ \r
+ BEGIN \r
+ \r
+ call clear;\r
+ \r
+ write("É");\r
+ for i:=1 to 78 do write("Í") od;\r
+ write("»");\r
+ writeln(" 1. Saisie du TEXTE1 2. Saisie du TEXTE2");\r
+ writeln(" 3. Longueur du TEXTE1 4. Concat\8ane le TEXTE1 avec le TEXTE2");\r
+ writeln(" a. Position courante dans TEXTE1 n. Nouvelle position dans TEXTE1");\r
+ writeln(" s. Position suivante dans TEXTE1 p. Position pr\82c\82dente dans TEXTE1");\r
+ writeln(" c. Copie une cha\8cne du TEXTE1 d. Supression d'une cha\8cne dans TEXTE1");\r
+ writeln(" i. Insertion d'une cha\8cne dans TEXTE1");\r
+ writeln(" u. Conversion de majuscules en minuscules"); \r
+ writeln(" m. Conversion de minuscules en majuscules ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍ");\r
+ writeln(" r. Recherche la position d'une cha\8cne dans TEXTE1 º ESC. Quitter ");\r
+ write("È");\r
+ for i:=1 to 78 do write("Í") od; \r
+ write("¼");\r
+ for j:=0 to 1 do\r
+ for i:=0 to 8 do\r
+ call setcursor(2+i,1+79*j);\r
+ write("º");\r
+ od;\r
+ od;\r
+ \r
+ call setcursor(12,1);\r
+ write("Question : ");\r
+\r
+ call setcursor(15,1); \r
+ write("R\82sultat : "); \r
+ \r
+ call setcursor(17,1);\r
+ writeln("TEXTE1"); \r
+ for i := 1 to 80 do write("Ä") od; \r
+ call setcursor(23,1);\r
+ for i := 1 to 80 do write("Ä") od; \r
+ \r
+ call setcursor(24,32); \r
+ writeln("Votre choix : "); (* attente d'un choix du menu *)\r
+ call SetCursor(24,46); \r
+ \r
+ END initialisation;\r
+\r
+\r
+(***************************************************************************** \r
+\r
+ Cette proc\82dure affiche certains messages et r\82initialise l'\82cran \r
+ pour pouvoir y afficher les prochains r\82sultats\r
+\r
+*****************************************************************************) \r
+ \r
+ \r
+ UNIT reinitialisation : procedure(inout choix:integer);\r
+\r
+ VAR i : integer;\r
+ \r
+ BEGIN \r
+ \r
+ if ( (choix=49) or (choix=52) or (choix=100) or (choix=105) \r
+ or (choix=109) or (choix=117) )\r
+ then\r
+ call setcursor(19,1);\r
+ for i:=1 to 150 do write(" ") od;\r
+ call setcursor(19,1);\r
+ if (t1<>none) then call t1.ecrire fi;\r
+ call SetCursor(15,12);\r
+ write("Voir TEXTE1");\r
+ fi;\r
+ \r
+ call SetCursor(24,46); \r
+ writeln(" ");\r
+ call SetCursor(24,46);\r
+ choix := inchar;\r
+ writeln(chr(choix));\r
+ \r
+ call setcursor(12,11);\r
+ for i := 1 to 180 do write(" ") od;\r
+ call setcursor(15,12);\r
+ for i := 1 to 80 do write(" ") od;\r
+\r
+ END reinitialisation;\r
+\r
+ \r
+(**************************************************************************** \r
+ \r
+ Cette proc\82dure traite la demande de l'utilsateur et appelle donc\r
+ les proc\82dures ou fonctions correspondantes.\r
+ On travaille sur le code ascii des touches s\82lectionn\82es.\r
+\r
+ 27 ---> touche ESC\r
+ 49 ---> touche 1\r
+ 50 ---> touche 2\r
+ 51 ---> touche 3\r
+ 52 ---> touche 4\r
+ 97 ---> touche a\r
+ 99 ---> touche c\r
+ 100 ---> touche d\r
+ 105 ---> touche i\r
+ 109 ---> touche m\r
+ 110 ---> touche n\r
+ 112 ---> touche p\r
+ 114 ---> touche r\r
+ 115 ---> touche s\r
+ 117 ---> touche u\r
+\r
+*****************************************************************************) \r
+\r
+ \r
+ UNIT traiter_choix : procedure ; \r
+ \r
+ VAR posit,num,choix : integer,\r
+ s:string;\r
+ \r
+ BEGIN\r
+\r
+ choix := inchar;\r
+ write(chr(choix));\r
+ \r
+ do \r
+ \r
+ call setcursor(12,12); \r
+ \r
+ case choix \r
+ \r
+ when 27 : call clear;\r
+ return;\r
+\r
+ when 49 : writeln("Saisie de TEXTE1");\r
+ call setcursor(19,1);\r
+ t1 := new typetext;\r
+ call t1.Lecture(0); \r
+\r
+ when 50 : writeln("Saisie de TEXTE2");\r
+ call SetCursor(15,12);\r
+ t2 := new typetext;\r
+ call t2.Lecture(0);\r
+\r
+ when 51 : writeln("Longueur de TEXTE1");\r
+ call SetCursor(15,12);\r
+ if (t1=none) \r
+ then writeln('0')\r
+ else writeln(t1.length)\r
+ fi;\r
+\r
+ when 52 : writeln("Concat\8ane TEXTE1 avec TEXTE2");\r
+ call setcursor(19,1); \r
+ if (t1=none) then t1:=t2 \r
+ else call t1.concat(t2) fi;\r
+ \r
+ when 97 : writeln("Position courante dans TEXTE1");\r
+ call SetCursor(15,12);\r
+ if (t1=none)\r
+ then writeln("0")\r
+ else writeln(t1.Position_Courante)\r
+ fi;\r
+\r
+ when 99 : Writeln("Copie une cha\8cne de TEXTE1");\r
+ Writeln("Donnez la longueur de la cha\8cne \85 retourner : ");\r
+ call Setcursor(13,47);\r
+ readln(num);\r
+ call SetCursor(15,12);\r
+ if (t1<>none)\r
+ then\r
+ t3 := t1.Copie(num);\r
+ if (t3<>none) \r
+ then call t3.ecrire \r
+ else writeln("Cha\8cne vide")\r
+ fi;\r
+ else writeln("Cha\8cne vide");\r
+ fi;\r
+\r
+ when 100 : Writeln("Suppression d'une cha\8cne de TEXTE1");\r
+ Writeln("Donnez la longueur de la cha\8cne \85 supprimer : ");\r
+ call SetCursor(13,47);\r
+ readln(posit);\r
+ if (t1<>none) \r
+ then call t1.delete(posit); \r
+ fi;\r
+ \r
+ when 105 : Writeln("Ins\82rer une cha\8cne dans TEXTE1");\r
+ Writeln("Entrez la cha\8cne \85 ins\82rer : ");\r
+ call SetCursor(13,30);\r
+ t3 := new typetext;\r
+ call t3.Lecture(0);\r
+ call SetCursor(15,12);\r
+ if (t1<>none)\r
+ then call t1.Insert(t3)\r
+ else t1 := t3\r
+ fi;\r
+\r
+ when 109 : Writeln("Conversion de lettres minuscules en majuscules");\r
+ Writeln("Donnez la longueur de la cha\8cne \85 modifier : ");\r
+ call SetCursor(13,46);\r
+ readln(num);\r
+ if (t1<>none) \r
+ then call t1.majuscule(num);\r
+ fi;\r
+ \r
+ when 110 : writeln("Saisie de la nouvelle position dans TEXTE1"); \r
+ writeln("Donnez la nouvelle position : ");\r
+ call SetCursor(13,31);\r
+ if (t1<>none)\r
+ then\r
+ readln(posit);\r
+ call t1.Nouvelle_Position(posit); \r
+ call SetCursor(15,12); \r
+ writeln(t1.position);\r
+ else writeln("Texte1 non d\82fini");\r
+ fi;\r
+\r
+ when 112 : writeln("Position pr\82c\82dente \85 la position courante dans TEXTE1"); \r
+ call SetCursor(15,12);\r
+ if (t1<>none)\r
+ then\r
+ call t1.Precedent;\r
+ writeln(t1.position);\r
+ else\r
+ writeln("0");\r
+ fi;\r
+ \r
+ when 115 : writeln("Position suivante \85 la position courante dans TEXTE1");\r
+ call SetCursor(15,12); \r
+ if (t1<>none)\r
+ then\r
+ call t1.Suivant;\r
+ writeln(t1.position); \r
+ else\r
+ writeln("0");\r
+ fi;\r
+ \r
+ when 114 : writeln("Recherche de la position d'une sous-cha\8cne dans TEXTE1");\r
+ writeln("Donnez la valeur de la sous-cha\8cne : ");\r
+ call SetCursor(13,38);\r
+ if (t1<>none) \r
+ then \r
+ t3 := new typetext;\r
+ call t3.Lecture(0);\r
+ num := t1.Rechercher_Position(t3);\r
+ call SetCursor(15,12); \r
+ writeln(num);\r
+ else writeln("TEXTE1 non d\82fini");\r
+ fi;\r
+\r
+ when 117 : writeln("Conversion de lettres majuscules en minuscules");\r
+ writeln("Donnez la longueur de la cha\8cne \85 modifier : "); \r
+ call SetCursor(13,46);\r
+ readln(num);\r
+ if (t1<>none) \r
+ then call t1.minuscule(num);\r
+ fi;\r
+\r
+ otherwise writeln("Mauvaise touche");;\r
+\r
+ esac;\r
+ \r
+ call reinitialisation(choix);\r
+\r
+ od;\r
+ \r
+ END traiter_choix;\r
+\r
+\r
+(****************************************************************************) \r
+\r
+\r
+\r
+(****************************************************************************) \r
+(* PROGRAMME PRINCIPAL *)\r
+(****************************************************************************) \r
+\r
+ \r
+ VAR t1,t2,t3 : typetext; \r
+\r
+ BEGIN\r
+ \r
+ call initialisation; (* affichage du menu *)\r
+ call traiter_choix; (* traitement de la demande de l'utilisateur *)\r
+ \r
+ END TYPETEXT;\r
+\r
+\r
+(****************************************************************************) \r
+\r
+ \r
+ \r
+ \r
+\r
--- /dev/null
+PROGRAM COROUTINE;\r
+ signal fin;\r
+(* Projet LI1 : Didacticiel sur les coroutines. *)\r
+(* Realise par CHICHER Corinne et DOME Nadege - UPPA 1993/1994 - *)\r
+\r
+BEGIN\r
+ pref iiuwgraph block\r
+ BEGIN\r
+ pref mouse block\r
+\r
+ VAR nooper,typexec,touche:integer, \r
+ i,b,h,v,num,xpa,ypa:integer,\r
+ g,d,c,driver,selection,demarrage,ptarok,stopexec:boolean;\r
+\r
+ (* nooper:correspond soit a l'execution du programmes soit a l'affichage*)\r
+ (* d'informations sur les coroutines.*)\r
+ (* typexec:type de l'execution du programme ou types de renseignements sur*)\r
+ (* les coroutines.*)\r
+ (* demarrage a vrai si choix de l'icone Execution*)\r
+ (* ptarok a vrai l'utilisateur a choisi un point d'arret*)\r
+ (* stopexec a vrai si l'utilisateur a clique sur l'icone Quitter*)\r
+\r
+\r
+(******************************************************************************)\r
+(* Procedures permettant la gestion de l'ecran en mode texte et graphique *)\r
+(******************************************************************************)\r
+\r
+ (* NewPage vide l'ecran en mode texte *)\r
+ UNIT NewPage : PROCEDURE;\r
+ BEGIN\r
+ write( chr(27), "[2J");\r
+ END NewPage;\r
+\r
+ (* SetCursor positionne le curseur aux lignes et colonnes indiquees *)\r
+ UNIT SetCursor : PROCEDURE(ligne,colonne:integer);\r
+ VAR c,d,e,f :char,\r
+ i,j :integer;\r
+ BEGIN\r
+ i:=ligne div 10;\r
+ j:=ligne mod 10;\r
+ c:=chr(48+i);\r
+ d:=chr(48+j);\r
+ i:=colonne div 10;\r
+ j:=colonne mod 10;\r
+ e:=chr(48+i);\r
+ f:=chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H");\r
+ END SetCursor;\r
+\r
+\r
+ (* inchar saisit un caractere en mode graphique *)\r
+ UNIT inchar : FUNCTION : integer;\r
+ VAR i:integer;\r
+ BEGIN\r
+ DO \r
+ i:=INKEY;\r
+ if i <> 0 then\r
+ exit\r
+ fi;\r
+ OD;\r
+ result:=i;\r
+ END inchar;\r
+\r
+\r
+ (* ReadInteger lit un entier positif a 3 chiffres avec echo a l'ecran *)\r
+ UNIT ReadInteger : FUNCTION : integer;\r
+ VAR X,Y,i,OrdN : integer,\r
+ Number : arrayof integer;\r
+ BEGIN\r
+ array Number dim( 1 : 4 );\r
+ i:=0;\r
+ X:=InXPos;\r
+ Y:=InYPos;\r
+ DO\r
+ OrdN:=inchar;\r
+ if i=8 or (OrdN < 48 and OrdN > 57) then\r
+ exit\r
+ fi;\r
+ CASE OrdN\r
+ when 48 : i:=i+1;\r
+ Number(i):=0;\r
+ when 49 : i:=i+1;\r
+ Number(i):=1;\r
+ when 50 : i:=i+1;\r
+ Number(i):=2;\r
+ when 51 : i:=i+1;\r
+ Number(i):=3;\r
+ when 52 : i:=i+1;\r
+ Number(i):=4;\r
+ when 53 : i:=i+1;\r
+ Number(i):=5;\r
+ when 54 : i:=i+1;\r
+ Number(i):=6;\r
+ when 55 : i:=i+1;\r
+ Number(i):=7;\r
+ when 56 : i:=i+1;\r
+ Number(i):=8;\r
+ when 57 : i:=i+1;\r
+ Number(i):=9;\r
+ when 8 : if i > 0 then\r
+ Number(i):=0;\r
+ i:=i-1;\r
+ call hascii(0);\r
+ fi;\r
+ when 13 : if i > 0 then\r
+ exit\r
+ fi;\r
+ ESAC;\r
+ if i=1 then\r
+ call Move(X,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(1));\r
+ fi;\r
+ if i=2 then\r
+ call Move(X+8,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(2));\r
+ fi; \r
+ if i=3 then\r
+ call Move(X+16,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(3));\r
+ fi; \r
+ OD;\r
+ if (Number(1) = 0) or (Number(1) = 0 and Number(2) = 0) \r
+ or (Number(1) = 0 and Number(2) = 0 and Number(3) = 0) then\r
+ call Move(X,Y);\r
+ call hascii(0);\r
+ call hascii(48);\r
+ call hascii(0);\r
+ fi;\r
+ if i=1 then\r
+ result:=Number(1);\r
+ else\r
+ if i=2 then\r
+ result:=10 * Number(1) + Number(2);\r
+ else\r
+ result:=100 * Number(1) + 10 * Number(2) + Number(3);\r
+ fi;\r
+ fi;\r
+ kill(Number);\r
+ END ReadInteger;\r
+ \r
+ (* WriteInteger permet d'afficher un entier positif a 3 chiffres a l'ecran *)\r
+ UNIT WriteInteger : PROCEDURE(Number:integer);\r
+ VAR i,j,k:integer;\r
+ BEGIN\r
+ if Number < 10 then\r
+ call HASCII(0);\r
+ call HASCII(Number+48);\r
+ call HASCII(0);\r
+ else\r
+ if Number < 100 then\r
+ i:=Number div 10;\r
+ j:=Number - i * 10;\r
+ call HASCII(0);\r
+ call HASCII(i+48);\r
+ call HASCII(0);\r
+ call HASCII(j+48);\r
+ else\r
+ i:=Number div 100;\r
+ j:=(Number - i * 100) div 10;\r
+ k:=Number - i * 100 - j * 10;\r
+ call HASCII(0);\r
+ call HASCII(i+48);\r
+ call HASCII(0);\r
+ call HASCII(j+48);\r
+ call HASCII(0);\r
+ call HASCII(k+48);\r
+ fi;\r
+ fi;\r
+ END WriteInteger;\r
+\r
+\r
+(*******************************************************************************)\r
+(* Procedures gerant un click de la souris sur l'ecran *)\r
+(*******************************************************************************)\r
+\r
+ (* Si choix=0 l'utilisateur a clique sur l'icone Quitter*)\r
+ (* presentbout gere le click lors de la page de presentation*)\r
+ UNIT presentbout : PROCEDURE(x,y:integer;inout bonclic:boolean,choix:integer);\r
+ BEGIN\r
+ if (x >= 12) and (x <= 92) then\r
+ if (y >= 296) and (y <= 312) then\r
+ bonclic:=true;\r
+ choix:=0; \r
+ fi;\r
+ fi;\r
+ if (x >= 116) and (x<=284) then\r
+ if (y >= 296) and (y <= 312) then\r
+ bonclic:=true;\r
+ choix:=1; (* Click sur l'icone execution*)\r
+ fi;\r
+ fi;\r
+ END presentbout;\r
+\r
+\r
+ (* Mousepos gere la position de la souris a l'endroit ou le bouton gauche *)\r
+ (* a ete presse dans le premier ecran *)\r
+ UNIT MOUSEPOS : PROCEDURE(x,y:integer;inout bonclic:boolean;output choix:integer);\r
+ BEGIN\r
+ if (x >= 24) and (x <= 544) then\r
+ if (y >= 96) and (y <= 104) then\r
+ choix:=1; (* Click sur execution du programme*)\r
+ bonclic:=true;\r
+ fi;\r
+\r
+ if (y >= 112) and (y <= 120) then\r
+ choix:=2; (* Click sur A propos des coroutines*)\r
+ bonclic:=true;\r
+ fi;\r
+\r
+ if (y >= 160) and (y <= 168) then\r
+ choix:=3; (* Click sur execution normale du programme *)\r
+ (* ou sur definition et interet des coroutines*)\r
+ bonclic:=true;\r
+ fi;\r
+\r
+ if (y >= 176) and (y <= 184) then\r
+ choix:=4; (* Click sur execution pas a pas du programme*)\r
+ (* ou sur le schema de la semantique *)\r
+ bonclic:=true;\r
+ fi;\r
+\r
+ if (y >= 192) and (y <= 200) then\r
+ choix:=5; (* click sur l'execution avec point d'arret*)\r
+ bonclic:=true;\r
+ fi;\r
+\r
+ if (y >= 224) and (y <= 232) then\r
+ call CLS;\r
+ choix:=0;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+ END MOUSEPOS;\r
+\r
+\r
+ (* POSmouse gere la position de la souris a l'endroit ou le bouton gauche *)\r
+ (* a ete presse dans le deuxieme ecran*)\r
+ UNIT POSmouse : PROCEDURE(x,y:integer;inout bonclic:boolean;output choix:integer);\r
+ BEGIN\r
+ if (x >= 12) and (x <= 92) then\r
+ if (y >= 236) and (y <= 252) then\r
+ choix:=1;\r
+ bonclic:=true;\r
+ fi;\r
+ if (y >= 256) and (y <= 272) then\r
+ choix:=0;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+ END POSmouse;\r
+\r
+\r
+ (* ptarret gere la position de la souris a l'endroit ou le bouton gauche *)\r
+ (* a ete presse pour la selection du point d'arret*)\r
+ UNIT ptarret : PROCEDURE(x,y:integer;inout bonclic:boolean;output choix:integer);\r
+ BEGIN\r
+ choix:=0;\r
+ (* Click sur une ligne du main*)\r
+ if (x >= 12) and (x <= 200) then\r
+ if ((y > 24) and (y < 32))or((y > 48) and (y < 80))\r
+ or ((y > 88) and (y < 144)) then\r
+ choix:=1;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+\r
+ (* Click sur une ligne de producer*)\r
+ if (x >= 216) and (x <= 412) then\r
+ if ((y > 24) and (y < 32)) or ((y >40) and (y < 136)) then\r
+ choix:=2;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+\r
+ (* Click sur une ligne de consumer*)\r
+ if (x >= 428) and (x <= 628) then\r
+ if ((y > 24) and (y < 32)) or ((y > 48) and (y < 248)) then\r
+ choix:=3;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+\r
+ (* Click sur l'icone "Quitter"*)\r
+ if (x>=12) and (x<=92) then\r
+ if(y>=256) and (y<=272) then\r
+ choix:=0;\r
+ bonclic:=true; \r
+ fi;\r
+ fi; \r
+ END ptarret;\r
+\r
+ (* GoStop gere la position de la souris a l'endroit ou le bouton gauche *)\r
+ (* a ete presse dans le deuxieme ecran avec l'execution pas a pas*)\r
+ UNIT GoStop : PROCEDURE(x,y:integer;inout bonclic:boolean,choix:integer);\r
+ BEGIN\r
+ if (x >= 120) and (x <= 200) then\r
+ if (y >= 236) and (y <= 252) then\r
+ choix:=1;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+ if (x >= 12) and (x <= 92) then\r
+ if (y >= 256) and (y <= 272) then\r
+ choix:=0;\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+ END GoStop;\r
+\r
+\r
+ (* clicquit gere le click sur quitter quand le point d'arret a ete atteint*)\r
+ UNIT clicquit : PROCEDURE(x,y:integer;inout bonclic:boolean);\r
+ BEGIN\r
+ if (x >= 12) and (x <= 92) then\r
+ if (y >= 256) and (y <= 272) then\r
+ bonclic:=true;\r
+ fi;\r
+ fi;\r
+ END clicquit;\r
+\r
+ (*textquit gere le click sur quitter quand l'utilisateur a lu les informations*)\r
+ UNIT textquit : PROCEDURE(x,y:integer;inout bonclic:boolean,choix:integer);\r
+ BEGIN\r
+ if (x >= 8) and (x <= 88) then\r
+ if (y >= 320) and (y <= 336) then\r
+ bonclic:=true;\r
+ choix:=0;\r
+ fi;\r
+ fi;\r
+ if (x >= 428) and (x<=558) then\r
+ if (y >= 320) and (y <= 336) then\r
+ bonclic:=true;\r
+ choix:=1;\r
+ fi;\r
+ fi;\r
+ END textquit;\r
+\r
+\r
+(********************************************************************************)\r
+(* Procedures gerant les dessins geometriques a l'ecran *)\r
+(********************************************************************************)\r
+\r
+ (* cadre trace un rectangle *)\r
+ UNIT cadre : PROCEDURE(xg,yg,xd,yd,couleur:integer);\r
+ BEGIN\r
+ call COLOR(couleur);\r
+ call MOVE(xg,yg);\r
+ call DRAW(xd,yg);\r
+ call MOVE(xd,yg);\r
+ call DRAW(xd,yd);\r
+ call MOVE(xd,yd);\r
+ call DRAW(xg,yd);\r
+ call MOVE(xg,yd);\r
+ call DRAW(xg,yg);\r
+ END cadre;\r
+\r
+ (* encadrpt determine et encadre la ligne correspondant au point d'arret*)\r
+ UNIT encadrpt : PROCEDURE(input numcode:integer;inout y:integer);\r
+ VAR ycadre,bornesup,xdeb,xfin,couleur:integer,\r
+ trouve:boolean;\r
+ BEGIN \r
+ if numcode=1 then\r
+ bornesup:=140;\r
+ xdeb:=14;\r
+ xfin:=198;\r
+ fi;\r
+ if numcode=2 then\r
+ bornesup:=132;\r
+ xdeb:=218;\r
+ xfin:=410;\r
+ fi;\r
+ if numcode=3 then\r
+ bornesup:=244;\r
+ xdeb:=430;\r
+ xfin:=626;\r
+ fi; \r
+ ycadre:=24;\r
+ while not trouve and ycadre<=bornesup\r
+ do\r
+ if y >=ycadre and y<=ycadre+8 then\r
+ trouve:=true;\r
+ else \r
+ ycadre:=ycadre+8;\r
+ fi;\r
+ od;\r
+ couleur:=12;\r
+ call cadre(xdeb,ycadre,xfin,ycadre+8,couleur);\r
+ y:=ycadre+4; \r
+ END encadrpt;\r
+\r
+\r
+(********************************************************************************)\r
+(* Procedures mettant en place les differents ecrans *)\r
+(********************************************************************************)\r
+\r
+ (* Presentation de l'application*)\r
+ UNIT presentation : PROCEDURE;\r
+ VAR couleur,choix:integer;\r
+ BEGIN\r
+ call CLS;\r
+ call BORDER(7);\r
+ (* Mise en place des boutons*)\r
+ call cadre(12,296,92,312,12);\r
+ call MOVE(26,300);\r
+ call OUTSTRING("Quitter");\r
+\r
+ call cadre(116,296,284,312,12);\r
+ call MOVE(120,300);\r
+ call OUTSTRING("Lancer l'application");\r
+\r
+ call COLOR(12);\r
+ call MOVE(370,304);\r
+ call OUTSTRING("Licence informatique - UPPA 1994");\r
+\r
+ call COLOR(12);\r
+ call MOVE(184,64);\r
+ call OUTSTRING("Corinne CHICHER & Nadege DOME");\r
+ call MOVE(241,88);\r
+ call OUTSTRING("Vous presentent");\r
+ call MOVE(169,128);\r
+ call OUTSTRING("UN DIDACTICIEL SUR LES COROUTINES");\r
+ call MOVE(157,152);\r
+ call OUTSTRING("DANS LE LANGAGE ORIENTE OBJET LOGLAN");\r
+ \r
+\r
+ call STYLE(5);\r
+ call cadre(137,48,465,176,7);\r
+\r
+ (* Gestion de la souris *)\r
+ driver:=INIT(b);\r
+ call SETPOSITION(0,0);\r
+ call SHOWCURSOR;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call presentbout(h,v,selection,choix);\r
+ if not selection then\r
+ g:=false;\r
+ repeat;\r
+ else\r
+ if choix=0 then (* L'utilisateur a selectionne Quitter*)\r
+ call HIDECURSOR;\r
+ call quitter;\r
+ else\r
+ call HIDECURSOR;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END presentation;\r
+\r
+ (* menu propose les programmes a executer et le type d'execution *)\r
+ UNIT menu : PROCEDURE(inout numop1,numop2:integer);\r
+ VAR i,touche,couleur:integer,\r
+ selection:boolean;\r
+ BEGIN\r
+ call CLS;\r
+ call BORDER(20);\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ call COLOR(15);\r
+ call MOVE(184,24);\r
+ call OUTSTRING("DIDACTICIEL SUR LES COROUTINES");\r
+ couleur:=6;\r
+ call cadre(24,56,544,240,couleur);\r
+ call COLOR(7);\r
+ call MOVE(64,96);\r
+ call OUTSTRING("Execution du programme 'Producteur-Consommateur'");\r
+ call MOVE(64,112);\r
+ call OUTSTRING("A propos des 'Coroutines'...");\r
+\r
+ call MOVE(64,224);\r
+ call OUTSTRING("Quitter l'application");\r
+ call MOVE(24,256);\r
+ call COLOR(15);\r
+ call OUTSTRING("Selectionnez l'operation avec le bouton gauche de la souris...");\r
+ call COLOR(7); \r
+\r
+ (* Gestion de la souris *)\r
+ driver:=INIT(b);\r
+ call SETPOSITION(0,0);\r
+ call SHOWCURSOR;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call MOUSEPOS(h,v,selection,numop1);\r
+ if not selection then\r
+ g:=false;\r
+ repeat;\r
+ else\r
+ if numop1=0 then (* L'utilisateur a selectionne Quitter*)\r
+ call HIDECURSOR;\r
+ exit\r
+ else\r
+ selection:=false;\r
+ call HIDECURSOR;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ call MOVE(64,160);\r
+\r
+ if numop1=1 then (* L'utilisateur a selectionne l'exemple*)\r
+ call OUTSTRING("Execution normale du programme ");\r
+ call MOVE(64,176);\r
+ call OUTSTRING("Execution pas a pas du programme ");\r
+ call MOVE(64,192);\r
+ call OUTSTRING("Execution avec point d'arret du programme ");\r
+ driver:=INIT(b);\r
+ call SHOWCURSOR;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call MOUSEPOS(h,v,selection,numop2);\r
+ if not selection then\r
+ g:=false;\r
+ repeat;\r
+ else\r
+ call HIDECURSOR;\r
+ exit exit\r
+ fi;\r
+ fi;\r
+ OD;\r
+ else \r
+ (* L'utilisateur a selectionne le "dictionnaire" sur les coroutines*)\r
+ call OUTSTRING("Definition et interet des coroutines ");\r
+ call MOVE(64,176);\r
+ call OUTSTRING("Instructions associees aux coroutines "); \r
+ driver:=INIT(b);\r
+ call SHOWCURSOR;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call MOUSEPOS(h,v,selection,numop2);\r
+ if not selection then\r
+ g:=false;\r
+ repeat;\r
+ else\r
+ call HIDECURSOR;\r
+ exit exit\r
+ fi;\r
+ fi;\r
+ OD;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END menu;\r
+\r
+\r
+ (* Contexte met en place les differentes parties servant a l'execution *)\r
+ UNIT contexte : PROCEDURE(input typexec:integer,ptarok:boolean);\r
+ VAR touche,couleur:integer;\r
+\r
+ BEGIN\r
+ call CLS;\r
+ call COLOR(12);\r
+ call MOVE(216,4);\r
+ call OUTSTRING("EXECUTION DU PROGRAMME");\r
+ (* Cadre entourant le code du main et coroutines *)\r
+ couleur:=7; \r
+ call cadre(8,16,632,280,couleur);\r
+\r
+ (* Cadre simulant l'ecran *)\r
+ call cadre(8,288,632,336,couleur);\r
+ (* Boutons pour lancer l'execution et quitter *)\r
+ call cadre(12,236,92,252,couleur);\r
+ call MOVE(16,240);\r
+ if typexec=5 and not ptarok then\r
+ call COLOR(8);\r
+ else\r
+ call COLOR(12);\r
+ fi;\r
+ call OUTSTRING("Execution"); \r
+ call cadre(12,256,92,272,couleur);\r
+ call MOVE(16,260);\r
+ call COLOR(12); \r
+ call OUTSTRING("Quitter");\r
+ driver:=INIT(b);\r
+ call SETPOSITION(0,0);\r
+ call SHOWCURSOR;\r
+ END contexte; \r
+\r
+ (* mainvisu affiche dans le cadre le code du main *)\r
+ UNIT mainvisu : PROCEDURE;\r
+ VAR couleur:integer;\r
+ BEGIN\r
+ call COLOR(7);\r
+ (* cadre entourant le code du main *)\r
+ couleur:=7;\r
+ call cadre(12,20,200,228,couleur);\r
+ call MOVE(12,192);\r
+ call HFILL(200);\r
+ call MOVE(16,24);\r
+ call OUTSTRING("PROGRAM prodcons;");\r
+ call MOVE(16,40);\r
+ call OUTSTRING("VAR"); \r
+ call MOVE(16,48);\r
+ call OUTSTRING(" prod:producer,");\r
+ call MOVE(16,56);\r
+ call OUTSTRING(" cons:consumer,");\r
+ call MOVE(16,64);\r
+ call OUTSTRING(" n,mag:integer,");\r
+ call MOVE(16,72);\r
+ call OUTSTRING(" last:boolean;");\r
+ call MOVE(16,88);\r
+ call OUTSTRING("BEGIN");\r
+ call MOVE(16,96);\r
+ call OUTSTRING(" prod:=new producer;");\r
+ call MOVE(16,104);\r
+ call OUTSTRING(" read(n);");\r
+ call MOVE(16,112);\r
+ call OUTSTRING(" cons:=new consumer(n);");\r
+ call MOVE(16,120);\r
+ call OUTSTRING(" attach(prod);");\r
+ call MOVE(16,128);\r
+ call OUTSTRING(" writeln;");\r
+ call MOVE(16,136);\r
+ call OUTSTRING("END prodcons;");\r
+ END mainvisu;\r
+\r
+ (* prodvisu (coroutine 1) affiche dans le cadre le code de producer *)\r
+ UNIT prodvisu : PROCEDURE;\r
+ VAR couleur:integer;\r
+ BEGIN\r
+ (* Cadre de la 1ere coroutine *)\r
+ couleur:=7;\r
+ call cadre(216,20,412,272,couleur);\r
+ (* Ecriture du code de la 1ere coroutine *)\r
+ call MOVE(220,24);\r
+ call OUTSTRING("UNIT producer:COROUTINE;");\r
+ call MOVE(220,40);\r
+ call OUTSTRING("BEGIN");\r
+ call MOVE(220,48);\r
+ call OUTSTRING(" return;");\r
+ call MOVE(220,56);\r
+ call OUTSTRING(" DO");\r
+ call MOVE(220,64);\r
+ call OUTSTRING(" read(mag);");\r
+ call MOVE(220,72);\r
+ call OUTSTRING(" if mag=0 then");\r
+ call MOVE(220,80);\r
+ call OUTSTRING(" last:=true;");\r
+ call MOVE(220,88);\r
+ call OUTSTRING(" exit;");\r
+ call MOVE(220,96);\r
+ call OUTSTRING(" fi;");\r
+ call MOVE(220,104);\r
+ call OUTSTRING(" attach(cons);");\r
+ call MOVE(220,112);\r
+ call OUTSTRING(" OD;");\r
+ call MOVE(220,120);\r
+ call OUTSTRING(" attach(cons);");\r
+ call MOVE(220,128);\r
+ call OUTSTRING("END producer;");\r
+ END prodvisu;\r
+\r
+ (* consvisu (coroutine 2) affiche dans le cadre le code de consumer *)\r
+ UNIT consvisu : PROCEDURE;\r
+ VAR couleur:integer;\r
+ BEGIN\r
+ couleur:=7;\r
+ call cadre(428,20,628,272,couleur); (* Cadre de la coroutine 2 cad consumer*)\r
+ call MOVE(428,252);\r
+ call HFILL(628);\r
+ (* Ecriture du code de la 2eme coroutine *)\r
+ call MOVE(432,24);\r
+ call OUTSTRING("UNIT consumer:coroutine");\r
+ call MOVE(432,32);\r
+ call OUTSTRING(" (n:integer);");\r
+ call MOVE(432,48);\r
+ call OUTSTRING("VAR buf:arrayof integer,");\r
+ call MOVE(432,56);\r
+ call OUTSTRING(" i,j:integer;");\r
+ call MOVE(432,64);\r
+ call OUTSTRING("BEGIN");\r
+ call MOVE(432,72);\r
+ call OUTSTRING(" array buf dim(1:n);");\r
+ call MOVE(432,80);\r
+ call OUTSTRING(" return;");\r
+ call MOVE(432,88);\r
+ call OUTSTRING(" DO");\r
+ call MOVE(432,96);\r
+ call OUTSTRING(" for i:=1 to n");\r
+ call MOVE(432,104);\r
+ call OUTSTRING(" DO");\r
+ call MOVE(432,112);\r
+ call OUTSTRING(" buf(i):=mag;");\r
+ call MOVE(432,120);\r
+ call OUTSTRING(" attach(prod);");\r
+ call MOVE(432,128);\r
+ call OUTSTRING(" if last then");\r
+ call MOVE(432,136);\r
+ call OUTSTRING(" exit exit fi;");\r
+ call MOVE(432,144);\r
+ call OUTSTRING(" OD");\r
+ call MOVE(432,152);\r
+ call OUTSTRING(" for i:=1 to n");\r
+ call MOVE(432,160);\r
+ call OUTSTRING(" DO");\r
+ call MOVE(432,168);\r
+ call OUTSTRING(" write(' ',buf(i));");\r
+ call MOVE(432,176);\r
+ call OUTSTRING(" OD;");\r
+ call MOVE(432,184);\r
+ call OUTSTRING(" writeln;");\r
+ call MOVE(432,192);\r
+ call OUTSTRING(" OD");\r
+ call MOVE(432,200);\r
+ call OUTSTRING(" for j:=1 to i DO");\r
+ call MOVE(432,208);\r
+ call OUTSTRING(" write(' ',buf(i));");\r
+ call MOVE(432,216);\r
+ call OUTSTRING(" OD;");\r
+ call MOVE(432,224);\r
+ call OUTSTRING(" writeln;");\r
+ call MOVE(432,232);\r
+ call OUTSTRING(" attach(main);");\r
+ call MOVE(432,240);\r
+ call OUTSTRING("END consumer;");\r
+ END consvisu;\r
+\r
+\r
+ (* instalnorm affiche le code du main et attend click sur execution/quitter *)\r
+ UNIT instalnorm : PROCEDURE(typexec,xpa,ypa:integer;inout execok:boolean);\r
+ VAR i,touche,rep,couleur:integer,\r
+ selection:boolean;\r
+ HANDLERS\r
+ when fin:stopexec:=true;\r
+ terminate;\r
+ END HANDLERS;\r
+ BEGIN\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ (* Affichage du code du main*) \r
+ call mainvisu;\r
+ if typexec=5 and xpa=14 then\r
+ couleur:=12;\r
+ call cadre(xpa,ypa-4,198,ypa+4,couleur);\r
+ fi;\r
+ call COLOR(12);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Selectionnez 'execution' ou 'quitter' en cliquant sur l'icone correspondante");\r
+ (* Gestion de la souris *)\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call POSmouse(h,v,selection,rep);\r
+ call HIDECURSOR;\r
+ if not selection then\r
+ g:=false;\r
+ call SHOWCURSOR;\r
+ repeat;\r
+ else\r
+ if rep=0 then (* l'utilisateur a clique sur quitter *) \r
+ raise fin;\r
+ else (* l'utilisateur a clicke sur execution *) \r
+ call COLOR(0);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Selectionnez 'execution' ou 'quitter' en cliquant sur l'icone correspondante");\r
+ call COLOR(8);\r
+ call MOVE(16,240);\r
+ call OUTSTRING("Execution");\r
+ \r
+ if typexec=3 or typexec=5 then \r
+ call COLOR(8); \r
+ call MOVE(16,260);\r
+ call OUTSTRING("Quitter");\r
+ call SHOWCURSOR;\r
+\r
+ else (*typexec=4*)\r
+ call COLOR(7);\r
+ (* Bouton "continuer" pour avancer pas a pas dans l'execution*)\r
+ couleur:=7;\r
+ call cadre(120,236,200,252,couleur);\r
+ call MOVE(124,240);\r
+ call COLOR(12);\r
+ call OUTSTRING("Continuer");\r
+ call SHOWCURSOR;\r
+ fi; \r
+ execok:=true;\r
+\r
+ fi;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END instalnorm;\r
+\r
+\r
+(********************************************************************************)\r
+(* Procedure permettant la prise en compte d'une execution avec point d'arret *)\r
+(********************************************************************************)\r
+\r
+ (* selectpoint permet de prendre en compte le point d'arret choisi*)\r
+ (* par l'utilisateur*)\r
+ UNIT selectpoint : PROCEDURE(inout x,y:integer);\r
+ VAR i,touche,rep,numcode:integer,\r
+ selection:boolean;\r
+ HANDLERS\r
+ when fin:stopexec:=true;\r
+ terminate;\r
+ END HANDLERS;\r
+ BEGIN\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+\r
+ (* Affichage du message demandant la selection du point d'arret*)\r
+ call COLOR(12);\r
+ call MOVE(16,296);\r
+ call OUTSTRING("Cliquez sur la ligne qui sera le point d'arret de l'execution");\r
+\r
+ (* Gestion de la souris *)\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call ptarret(h,v,selection,numcode);\r
+ call HIDECURSOR;\r
+ if not selection then\r
+ g:=false;\r
+ call SHOWCURSOR;\r
+ repeat;\r
+ else\r
+ if numcode=0 then\r
+ raise fin;\r
+ fi; \r
+ call encadrpt(numcode,v); \r
+ call COLOR(0);\r
+ call MOVE(16,296);\r
+ call OUTSTRING("Cliquez sur la ligne qui sera le point d'arret de l'execution");\r
+ call COLOR(8);\r
+ call MOVE(16,260);\r
+ call OUTSTRING("Quitter");\r
+ call COLOR(12);\r
+ call MOVE(16,296);\r
+ call OUTSTRING("Tapez <RC> pour valider votre selection");\r
+ touche:=inchar;\r
+ call COLOR(0);\r
+ call MOVE(16,296);\r
+ call OUTSTRING("Tapez <RC> pour valider votre selection");\r
+ y:=v;\r
+ if numcode=1 then\r
+ x:=14;\r
+ else\r
+ if numcode=2 then \r
+ x:=218;\r
+ else\r
+ x:=430;\r
+ fi;\r
+ fi; \r
+ exit;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END selectpoint;\r
+\r
+\r
+(********************************************************************************)\r
+(* Procedures utilisees pour l'execution du programme *)\r
+(********************************************************************************)\r
+\r
+ (* fleche permet d'afficher une fleche devant l'instruction courante *)\r
+ UNIT fleche : PROCEDURE(input x,y,xpa,ypa,numcode,choixexe:integer);\r
+ VAR rempli,atteint:boolean;\r
+ BEGIN\r
+ call MOVE(x,y); \r
+ call COLOR(12);\r
+ call OUTSTRING("->");\r
+\r
+ (*Execution avec point d'arret*)\r
+ if numcode=1 then\r
+ if (xpa=x+14) and (ypa-4=y) then\r
+ atteint:=true;\r
+ call finexecut(choixexe,rempli,atteint);\r
+ fi;\r
+ fi;\r
+ if numcode=2 or numcode=3 then\r
+ if (xpa=x+18) and (ypa-4=y) then\r
+ atteint:=true;\r
+ call finexecut(choixexe,rempli,atteint);\r
+ fi;\r
+ fi;\r
+ END fleche; \r
+\r
+ (* Changecoul permet de modifier la couleur du cadre des record selon*)\r
+ (* qu'ils sont actifs ou non*)\r
+ UNIT changecoul : PROCEDURE(couleur,numcode:integer);\r
+ BEGIN\r
+ if numcode=1 then\r
+ call cadre(12,20,200,228,couleur);\r
+ fi;\r
+ if numcode=2 then\r
+ call cadre(216,20,412,272,couleur);\r
+ fi; \r
+ if numcode=3 then\r
+ call cadre(428,20,628,272,couleur);\r
+ fi;\r
+ call COLOR(12); \r
+ END changecoul;\r
+\r
+ (* restaure permet de supprimer la fleche courante et provoque un temps d'arret*)\r
+ (* apres chaque instruction. *)\r
+ UNIT restaure : PROCEDURE(debx,deby,choixexe,numcode:integer); \r
+ VAR i,touche,rep:integer,\r
+ selection:boolean;\r
+ BEGIN\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ CASE choixexe\r
+ when 3: (* Execution normale du programme choisi*)\r
+ for i:=1 to 10000 do od;\r
+\r
+ when 4: (* Execution pas a pas du programme choisi*)\r
+ (* Gestion de la souris *)\r
+ driver:=init(b);\r
+ call SETPOSITION(160,244);\r
+\r
+ call SHOWCURSOR;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call GoStop(h,v,selection,rep);\r
+ call HIDECURSOR;\r
+ if not selection then\r
+ g:=false;\r
+ call SHOWCURSOR;\r
+ repeat;\r
+ else\r
+ if rep=0 then (* l'utilisateur a clique sur quitter *) \r
+ raise fin;\r
+ fi;\r
+ (* l'utilisateur a clique sur continuer *) \r
+ exit;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ \r
+ when 5: (* Execution avec point d'arret du programme choisi*) \r
+ for i:=1 to 10000 do od;\r
+ \r
+ ESAC;\r
+ (* Effacement de la fleche se trouvant devant la ligne courante*)\r
+ call MOVE(debx,deby);\r
+ call COLOR(0);\r
+ call OUTSTRING("->");\r
+ call COLOR(7);\r
+ if numcode=1 then\r
+ call MOVE(8,deby);\r
+ call VFILL(deby+8);\r
+ call COLOR(10);\r
+ call MOVE(12,deby);\r
+ call VFILL(deby+8);\r
+ fi;\r
+ if numcode=2 then\r
+ call MOVE(200,deby);\r
+ call VFILL(deby+8);\r
+ fi;\r
+ if numcode=3 then\r
+ call MOVE(412,deby);\r
+ call VFILL(deby+8);\r
+ fi;\r
+ END restaure;\r
+\r
+ (* execut permet l'execution du programme *)\r
+ UNIT execut : PROCEDURE(input choixexe,xpa,ypa:integer);\r
+ VAR touche,k,x,y,i,j,n,mag,numcode,nbaffic,nbcases,rep,couleur:integer,\r
+ passe,last,encore,magzero,rempli,atteint:boolean,\r
+ buf:arrayof integer;\r
+ HANDLERS\r
+ when fin:stopexec:=true;\r
+ terminate;\r
+ END HANDLERS;\r
+\r
+ BEGIN \r
+ array buf dim(1:10);\r
+ rempli:=false;\r
+ (* 1ere ligne du main*)\r
+ numcode:=1;\r
+ call changecoul(10,numcode);\r
+ x:=0;\r
+ y:=24;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 3eme ligne du main*)\r
+ y:=48;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 4eme ligne du main*)\r
+ y:=56;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 5eme ligne du main*)\r
+ y:=64;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ (* Affichage de la valeur de n et mag *)\r
+ call MOVE(16,196);\r
+ call OUTSTRING("n = 0 et mag = 0");\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 6eme ligne du main*)\r
+ y:=72;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ (* Affichage de la valeur de last*)\r
+ call MOVE(16,212);\r
+ call OUTSTRING("last = false");\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 7eme ligne du main*)\r
+ y:=88;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 8eme ligne du main*)\r
+ y:=96;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call changecoul(7,numcode);\r
+\r
+ (* Affichage du code de la coroutine 1 cad producer*)\r
+ call prodvisu;\r
+ if typexec=5 and xpa=218 then\r
+ couleur:=12;\r
+ call cadre(xpa,ypa-4,410,ypa+4,couleur);\r
+ fi;\r
+ (* Debut de l'execution de la 1ere coroutine*)\r
+ (* 1ere ligne de la coroutine 1*)\r
+ x:=200;\r
+ numcode:=2;\r
+ call changecoul(10,numcode);\r
+ y:=24;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 2eme ligne de la coroutine 1*)\r
+ y:=40;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 3eme ligne de la coroutine 1*)\r
+ y:=48;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call changecoul(7,numcode);\r
+\r
+ (* On revient au programme appelant cad le main*)\r
+ x:=0;\r
+ numcode:=1;\r
+ call changecoul(10,numcode);\r
+ y:=96;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 9eme ligne du main*)\r
+ y:=104;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+\r
+ DO\r
+ call COLOR(12);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Entrez la taille du tableau buf (<=10) et tapez <RC>: ");\r
+ n:=ReadInteger;\r
+ call WriteInteger(n);\r
+ call HIDECURSOR;\r
+ call COLOR(0);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Entrez la taille du tableau buf (<=10) et tapez <RC>: ");\r
+ call WriteInteger(n);\r
+ call SHOWCURSOR;\r
+ (* Test sur la valeur de la taille du tableau*)\r
+ if n=0 or n>10 then\r
+ call COLOR(12);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Vous devez entrer une valeur comprise entre 1 et 10 (tapez <RC>) !");\r
+ touche:=inchar;\r
+ call COLOR(0);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Vous devez entrer une valeur comprise entre 1 et 10 (tapez <RC>) !");\r
+ else\r
+ exit\r
+ fi; \r
+ od;\r
+ \r
+ (* Mise a jour de la valeur de n*)\r
+ call COLOR(12);\r
+ call MOVE(48,196);\r
+ call WriteInteger(n);\r
+ call restaure(x,y,choixexe,numcode); \r
+ (* 10eme ligne du main*)\r
+ y:=112;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call changecoul(7,numcode);\r
+\r
+ (* Affichage du code de la coroutine 2 cad consumer*)\r
+ call consvisu;\r
+ if typexec=5 and xpa=430 then\r
+ couleur:=12;\r
+ call cadre(xpa,ypa-4,626,ypa+4,couleur);\r
+ fi;\r
+ (* Debut de l'execution de la coroutine 2*)\r
+ (* ligne 1 de la coroutine 2*)\r
+ x:=412;\r
+ numcode:=3;\r
+ call changecoul(10,numcode);\r
+ y:=24;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* ligne 3 de la coroutine 2*)\r
+ y:=48;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* ligne 4 de la coroutine 2*)\r
+ y:=56;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call MOVE(432,264);\r
+ call OUTSTRING("i = 0 et j = 0"); \r
+ call restaure(x,y,choixexe,numcode); \r
+ (* ligne 5 de la coroutine 2*)\r
+ y:=64;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* ligne 6 de la coroutine 2*)\r
+ y:=72;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call MOVE(432,256);\r
+ call OUTSTRING("buf :");\r
+ for i:=0 to n-1 \r
+ DO\r
+ call MOVE(472+i*16,256);\r
+ if i=n-1 then\r
+ call OUTSTRING("0");\r
+ else\r
+ call OUTSTRING("0,");\r
+ fi;\r
+ OD;\r
+ call restaure(x,y,choixexe,numcode); \r
+ (* ligne 7 de la coroutine 2*)\r
+ y:=80;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call changecoul(7,numcode);\r
+ \r
+ (* Retour a la procedure appelante cad le main*)\r
+ x:=0;\r
+ numcode:=1;\r
+ call changecoul(10,numcode);\r
+ y:=112;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 11eme ligne du main*)\r
+ y:=120;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call changecoul(7,numcode);\r
+ \r
+ (* Retour a la coroutine 1 cad producer*)\r
+ x:=200;\r
+ numcode:=2;\r
+ call changecoul(10,numcode);\r
+ y:=48;\r
+ call restaure(x,y,choixexe,numcode);\r
+\r
+ DO (* Gros DO*)\r
+ x:=200;\r
+ numcode:=2;\r
+ call changecoul(10,numcode);\r
+ (* 4eme ligne de la coroutine 1*)\r
+ y:=56;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode); \r
+ (* 5eme ligne de la coroutine 1*)\r
+ y:=64;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+\r
+ if nbaffic=4 then\r
+ rempli:=true;\r
+ call finexecut(choixexe,rempli,atteint);\r
+ exit\r
+ fi;\r
+ DO\r
+ call COLOR(12);\r
+ call MOVE(12,296);\r
+ if nbaffic=3 then\r
+ call OUTSTRING("Vous devez a present taper zero comme valeur du tableau et <RC>: ");\r
+ else\r
+ call OUTSTRING("Entrez la valeur (<10) a stocker dans le tableau et tapez <RC>: ");\r
+ fi;\r
+ mag:=ReadInteger;\r
+ (* Mise a jour de la valeur de mag*)\r
+ call MOVE(144,196);\r
+ call WriteInteger(mag);\r
+ call COLOR(0);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Entrez la valeur (<10) a stocker dans le tableau et tapez <RC>: ");\r
+ call WriteInteger(mag);\r
+ (* Test sur la valeur de mag qui doit etre < 10*)\r
+ if mag > 9 then\r
+ call COLOR(12);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Vous devez entrer une valeur comprise entre 0 et 9 (tapez <RC>) !");\r
+ touche:=inchar;\r
+ call COLOR(0);\r
+ call MOVE(12,296);\r
+ call OUTSTRING("Vous devez entrer une valeur comprise entre 0 et 9 (tapez <RC>) !");\r
+ else\r
+ exit;\r
+ fi;\r
+ OD;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 6eme ligne de la coroutine 1*)\r
+ y:=72;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ if mag=0 then\r
+ if not passe then\r
+ magzero:=true;\r
+ fi;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 7eme ligne de la coroutine 1*)\r
+ y:=80;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ (* MAJ de la variable last*)\r
+ last:=true;\r
+ call MOVE(72,212);\r
+ call COLOR(0);\r
+ call OUTSTRING("false");\r
+ call MOVE(72,212);\r
+ call COLOR(12);\r
+ call OUTSTRING("true");\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 8eme ligne de la coroutine 1 *)\r
+ y:=88;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 12eme ligne de la coroutine 1*)\r
+ y:=120;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe); (* on va au moyen DO*)\r
+ else\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 9eme ligne de la coroutine1*)\r
+ y:=96;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 10eme ligne de la coroutine1 *)\r
+ y:=104;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ fi;\r
+ call changecoul(7,numcode);\r
+\r
+ (* retour a la coroutine 2 cad consumer*)\r
+ DO (* Moyen DO*)\r
+ x:=412;\r
+ numcode:=3;\r
+ call changecoul(10,numcode);\r
+ if not passe or encore then\r
+ if not passe then\r
+ y:=80;\r
+ call restaure(x,y,choixexe,numcode);\r
+ fi;\r
+ (* 8eme ligne de la coroutine 2 *)\r
+ y:=88;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ passe:=true;\r
+ encore:=false;\r
+ else\r
+ y:=120;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 13eme ligne de la coroutine 2 *)\r
+ y:=128;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ if last then\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 14eme ligne de la coroutine 2*)\r
+ y:=136;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ exit exit\r
+ else\r
+ nbcases:=nbcases+1;\r
+ call restaure(x,y,choixexe,numcode); \r
+ (* 15eme ligne de la coroutine 2*)\r
+ y:=144;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ fi;\r
+ fi;\r
+ \r
+ DO (* Petit DO*)\r
+ (* 9eme ligne de la coroutine 2 *)\r
+ y:=96;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ (* Affichage de l'indice de buf*)\r
+ call MOVE(464,264); \r
+ call WriteInteger(nbcases+1); \r
+ call restaure(x,y,choixexe,numcode);\r
+ if nbcases=n then\r
+ exit\r
+ fi;\r
+ (* 10eme ligne de la coroutine 2 *)\r
+ y:=104;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 11eme ligne de la coroutine 2 *)\r
+ y:=112;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe); \r
+ (* MAJ du tableau buf avec la valeur de mag*)\r
+ buf(nbcases+1):=mag;\r
+ call MOVE(472+nbcases*16,256);\r
+ call WriteInteger(buf(nbcases+1));\r
+ if nbcases+1<>n then\r
+ call MOVE(480+nbcases*16,256);\r
+ call OUTSTRING(",");\r
+ fi;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 12eme ligne de la coroutine 2 *)\r
+ y:=120;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call changecoul(7,numcode); \r
+ \r
+ (* Retour a la coroutine 1 cad producer*)\r
+ x:=200;\r
+ numcode:=2;\r
+ call changecoul(10,numcode);\r
+ if magzero then\r
+ y:=120;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 13eme ligne de la coroutine 1*)\r
+ y:=128;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* Destruction du record d'activation de la coroutine 1 cad producer*)\r
+ call COLOR(10);\r
+ call MOVE(216,20);\r
+ call DRAW(412,272);\r
+ call MOVE(412,20);\r
+ call DRAW(216,272);\r
+ call COLOR(12);\r
+ call changecoul(7,numcode);\r
+ call MOVE(12,296);\r
+ call COLOR(10);\r
+ call OUTSTRING("ATTENTION : Le record d'activation de Producer vient d'etre detruit !");\r
+ for i:=1 to 20000 do od;\r
+ call MOVE(12,296);\r
+ call COLOR(0);\r
+ call OUTSTRING("ATTENTION : Le record d'activation de Producer vient d'etre detruit !");\r
+ exit\r
+ else\r
+ y:=104;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* ligne 11 de la coroutine 1*)\r
+ y:=112;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ exit exit\r
+ fi;\r
+ od;\r
+\r
+ if not magzero then\r
+ call COLOR(8);\r
+ (* Retour a la coroutine 2 cad consumer*)\r
+ (* Impression du tampon buf*)\r
+ nbcases:=0;\r
+ i:=0;\r
+ do\r
+ (* 16eme ligne de la coroutine 2*)\r
+ y:=152;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* Affichage de l'indice de buf*)\r
+ call COLOR(12);\r
+ call MOVE(464,264); \r
+ call WriteInteger(i+1); \r
+ if i<>n then\r
+ (* 17eme ligne de la coroutine 2*)\r
+ y:=160;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 18eme ligne de la coroutine 2*)\r
+ y:=168;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call MOVE(12+i*16,304+nbaffic*8);\r
+ call OUTSTRING(" ");\r
+ call WriteInteger(buf(i+1));\r
+ call restaure(x,y,choixexe,numcode);\r
+ fi;\r
+ (* 19eme ligne de la coroutine 2*)\r
+ y:=176;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ if i=n then\r
+ exit\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ (* ligne 20 de la coroutine 2*)\r
+ y:=184;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ nbaffic:=nbaffic+1;\r
+ encore:=true;\r
+ fi;\r
+ od;\r
+ od;\r
+ \r
+ (* Imprime le reste du tampon buf*)\r
+ (* 22eme ligne de la coroutine 2*)\r
+ k:=0;\r
+ for j:=1 to nbcases+1 \r
+ do\r
+ y:=200;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ (* Affichage de l'indice de buf*)\r
+ call MOVE(544,264); \r
+ call WriteInteger(j); \r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 23eme ligne de la coroutine 2*)\r
+ y:=208;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call MOVE(12+k*16,304+nbaffic*8);\r
+ call OUTSTRING(" ");\r
+ call WriteInteger(buf(j));\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 24eme ligne de la coroutine 2*) \r
+ y:=216;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ k:=k+1; \r
+ od;\r
+ (* 25eme ligne de la coroutine 2*)\r
+ y:=224;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 26eme ligne de la coroutine 2*) \r
+ y:=232;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe); \r
+ call changecoul(7,numcode);\r
+\r
+ (* Retour a la ligne 11 du main*)\r
+ x:=0;\r
+ numcode:=1;\r
+ call changecoul(10,numcode);\r
+ y:=120;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 12eme ligne du main*)\r
+ y:=128;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 13eme et derniere ligne du main*)\r
+ y:=136;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* Destruction du record d'activation du main*)\r
+ call COLOR(10);\r
+ call MOVE(12,20);\r
+ call DRAW(200,228);\r
+ call MOVE(200,20);\r
+ call DRAW(12,228);\r
+ call changecoul(7,numcode);\r
+ call MOVE(12,296);\r
+ call COLOR(10);\r
+ call OUTSTRING("ATTENTION : Le record d'activation du Main vient d'etre detruit !");\r
+ for i:=1 to 20000 do od;\r
+ call MOVE(12,296);\r
+ call COLOR(0);\r
+ call OUTSTRING("ATTENTION : Le record d'activation du Main vient d'etre detruit !");\r
+ \r
+ call COLOR(12);\r
+ (* Retour a la ligne 26 de la coroutine2*)\r
+ x:=412;\r
+ numcode:=3;\r
+ call changecoul(10,numcode);\r
+ y:=232;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 27eme ligne de la coroutine2*)\r
+ y:=240;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* Destruction du record d'activation de la coroutine 2 cad consumer*)\r
+ call COLOR(10);\r
+ call MOVE(428,20);\r
+ call DRAW(628,272);\r
+ call MOVE(628,20);\r
+ call DRAW(428,272);\r
+ call changecoul(7,numcode);\r
+ call MOVE(12,296);\r
+ call COLOR(10);\r
+ call OUTSTRING("ATTENTION : Le record d'activation de Consumer vient d'etre detruit !");\r
+ for i:=1 to 20000 do od;\r
+ call MOVE(12,296);\r
+ call COLOR(0);\r
+ call OUTSTRING("ATTENTION : Le record d'activation de Consumer vient d'etre detruit !");\r
+ call COLOR(12);\r
+ if not magzero then\r
+ (* Retour a la ligne 12 de la coroutine1*)\r
+ x:=200;\r
+ numcode:=2;\r
+ call changecoul(10,numcode);\r
+ y:=120;\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* 13eme ligne de la coroutine 1*)\r
+ y:=128;\r
+ call fleche(x,y,xpa,ypa,numcode,choixexe);\r
+ call restaure(x,y,choixexe,numcode);\r
+ (* Destruction du record d'activation de la coroutine 1 cad producer*)\r
+ call COLOR(10);\r
+ call MOVE(216,20);\r
+ call DRAW(412,272);\r
+ call MOVE(412,20);\r
+ call DRAW(216,272);\r
+ call changecoul(7,numcode);\r
+ call MOVE(12,296);\r
+ call COLOR(10);\r
+ call OUTSTRING("ATTENTION : Le record d'activation du Producer vient d'etre detruit !");\r
+ for i:=1 to 20000 do od;\r
+ call MOVE(12,296);\r
+ call COLOR(0);\r
+ call OUTSTRING("ATTENTION : Le record d'activation de Producer vient d'etre detruit !");\r
+ fi;\r
+ if choixexe=4 then\r
+ call COLOR(8); (* L'execution est terminee on ne peut donc plus cliquer*)\r
+ (* sur Continuer*)\r
+ call MOVE(124,240);\r
+ call OUTSTRING("Continuer");\r
+ call SHOWCURSOR;\r
+ fi;\r
+ call COLOR(12);\r
+ call finexecut(choixexe,rempli,atteint);\r
+ END execut;\r
+\r
+\r
+(********************************************************************************)\r
+(* Procedures gerant l'option A propos des coroutines *)\r
+(********************************************************************************)\r
+\r
+ (* boutontxt met en place et gere les boutons concernat l'option *)\r
+ (* A propos des coroutines*)\r
+ UNIT boutontxt : FUNCTION :integer;\r
+ VAR choix:integer;\r
+ BEGIN\r
+ (* Mise en place du bouton Page suivante*)\r
+ call cadre(428,320,558,336,12);\r
+\r
+ (* Mise en place du bouton Quitter*)\r
+ call cadre(8,320,88,336,12);\r
+ call MOVE(20,324);\r
+ call COLOR(12);\r
+ call OUTSTRING("Quitter");\r
+\r
+ (* Mise en place de la souris*)\r
+ driver:=init(b);\r
+ call SHOWCURSOR;\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call textquit(h,v,selection,choix);\r
+ call HIDECURSOR;\r
+ if not selection then\r
+ g:=false;\r
+ call SHOWCURSOR;\r
+ repeat;\r
+ else\r
+ if choix=0 then\r
+ result:=0;\r
+ else\r
+ result:=1;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END boutontxt;\r
+\r
+\r
+ (* afficdef affiche a l'ecran la definition et l'utilite des coroutines*)\r
+ UNIT afficdef : PROCEDURE;\r
+ VAR touche,choix:integer;\r
+ BEGIN\r
+ call CLS;\r
+ (* Mise en place du texte*)\r
+ call MOVE(170,16);\r
+ call COLOR(12);\r
+ call OUTSTRING("DEFINITION ET INTERET DES COROUTINES");\r
+ call MOVE(16,40);\r
+ call OUTSTRING("I> Definition d'une coroutine");\r
+ call COLOR(7);\r
+ call MOVE(56,56);\r
+ call OUTSTRING("Une coroutine est un objet tel que l'execution de sa sequence");\r
+ call MOVE(56,64);\r
+ call OUTSTRING("d'instructions peut etre suspendue et relancee de maniere pro-");\r
+ call MOVE(56,72);\r
+ call OUTSTRING("grammee."); \r
+ call MOVE(56,80);\r
+ call OUTSTRING("Il est important de preciser, qu'a un instant donne, une seule");\r
+ call MOVE(56,88);\r
+ call OUTSTRING("coroutine est active (en execution)."); \r
+ call MOVE(56,100);\r
+ call OUTSTRING("Par ailleurs, c'est une extension de la notion de classe, une");\r
+ call MOVE(56,108);\r
+ call OUTSTRING("classe etant une construction dans laquelle peuvent etre regrou-");\r
+ call MOVE(56,116);\r
+ call OUTSTRING("pes toutes sortes d'objets.");\r
+ call COLOR(12);\r
+ call MOVE(56,132);\r
+ call OUTSTRING("Syntaxe");\r
+ call COLOR(7);\r
+ call MOVE(80,144);\r
+ call OUTSTRING("UNIT <nom_coroutine> : <prefixe> COROUTINE(<parametres formels>);");\r
+ call MOVE(120,152);\r
+ call OUTSTRING("<declarations variables locales,fonctions,procedures,classes>");\r
+ call MOVE(80,160);\r
+ call OUTSTRING("BEGIN");\r
+ call MOVE(120,168);\r
+ call OUTSTRING("<instruction 1>");\r
+ call MOVE(120,176);\r
+ call OUTSTRING("return;");\r
+ call MOVE(120,184);\r
+ call OUTSTRING("<instruction 2...instruction n>");\r
+ call MOVE(80,192);\r
+ call OUTSTRING("END nom_coroutine;");\r
+ call COLOR(12);\r
+ call MOVE(16,216);\r
+ call OUTSTRING("II> Interet des coroutines");\r
+ call COLOR(7);\r
+ call MOVE(56,232);\r
+ call OUTSTRING("Les coroutines jouent un role essentiel dans les taches de simu-");\r
+ call MOVE(56,240);\r
+ call OUTSTRING("lation.");\r
+ call MOVE(56,248);\r
+ call OUTSTRING("Ainsi, divers problemes de simulation de grande complexite et de");\r
+ call MOVE(56,256);\r
+ call OUTSTRING("taille importante sont traitees avec succes par les coroutines.");\r
+\r
+ (* Mise en place du bouton Quitter*)\r
+ call cadre(8,320,88,336,10);\r
+ call MOVE(20,324);\r
+ call COLOR(10);\r
+ call OUTSTRING("Quitter");\r
+\r
+ (* Mise en place de la souris*)\r
+ call SHOWCURSOR;\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call textquit(h,v,selection,choix);\r
+ call HIDECURSOR;\r
+ if not selection then\r
+ g:=false;\r
+ call SHOWCURSOR;\r
+ repeat;\r
+ else\r
+ if choix=0 then\r
+ (* l'utilisateur a clique sur quitter *) \r
+ exit exit\r
+ else\r
+ repeat;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END afficdef;\r
+\r
+\r
+(* afficinstr affiche a l'ecran le schema de la semantique des coroutines*)\r
+ UNIT afficinstr : PROCEDURE;\r
+ VAR touche,choix:integer;\r
+ HANDLERS\r
+ when fin:stopexec:=true;\r
+ terminate;\r
+ END HANDLERS;\r
+ BEGIN\r
+ call CLS;\r
+ (* Mise en place du texte*)\r
+ call MOVE(154,16);\r
+ call COLOR(12);\r
+ call OUTSTRING("INSTRUCTIONS ASSOCIEES AUX COROUTINES");\r
+ call MOVE(258,32);\r
+ call OUTSTRING("SEMANTIQUE");\r
+\r
+ call MOVE(76,60);\r
+ call COLOR(7);\r
+ call OUTSTRING("Declaration : VAR C:nom_coroutine;"); \r
+\r
+ call COLOR(12);\r
+ call MOVE(206,76);\r
+ call VFILL(90);\r
+ call MOVE(202,90);\r
+ call OUTSTRING("V");\r
+ call cadre(146,100,266,116,10);\r
+ call COLOR(7);\r
+ call MOVE(174,104);\r
+ call OUTSTRING("CREATION");\r
+ call MOVE(222,83);\r
+ call OUTSTRING("C:=new nom_coroutine(<parametres formels>);");\r
+\r
+ call COLOR(12);\r
+ call MOVE(206,118);\r
+ call VFILL(130);\r
+ call MOVE(202,130);\r
+ call OUTSTRING("V");\r
+ call cadre(146,140,266,156,10);\r
+ call COLOR(7);\r
+ call MOVE(150,144);\r
+ call OUTSTRING("INITIALISATION");\r
+\r
+ call COLOR(12);\r
+ call MOVE(206,158);\r
+ call VFILL(170);\r
+ call MOVE(202,170);\r
+ call OUTSTRING("V");\r
+ call cadre(146,180,266,196,10);\r
+ call COLOR(7);\r
+ call MOVE(154,184);\r
+ call OUTSTRING("DESACTIVATION"); \r
+ call MOVE(222,164);\r
+ call OUTSTRING("return;");\r
+\r
+ call COLOR(12);\r
+ call MOVE(176,198);\r
+ call VFILL(210);\r
+ call MOVE(172,210);\r
+ call OUTSTRING("V");\r
+ call MOVE(236,198);\r
+ call VFILL(216);\r
+ call MOVE(232,198);\r
+ call OUTSTRING("^"); \r
+ call cadre(146,220,266,236,10);\r
+ call COLOR(7);\r
+ call MOVE(168,224);\r
+ call OUTSTRING("ACTIVATION");\r
+ call MOVE(80,204);\r
+ call OUTSTRING("attach(C);");\r
+ call MOVE(252,204);\r
+ call OUTSTRING("detach;");\r
+\r
+ call COLOR(12);\r
+ call MOVE(206,238);\r
+ call VFILL(250);\r
+ call MOVE(202,250);\r
+ call OUTSTRING("V");\r
+ call cadre(146,260,266,276,10);\r
+ call COLOR(7);\r
+ call MOVE(178,264);\r
+ call OUTSTRING("TERMINE");\r
+\r
+ call COLOR(12);\r
+ call MOVE(206,278);\r
+ call VFILL(290);\r
+ call MOVE(202,290);\r
+ call OUTSTRING("V");\r
+\r
+ call MOVE(116,298);\r
+ call COLOR(7);\r
+ call OUTSTRING("Destruction : kill(C);");\r
+\r
+ call MOVE(444,324);\r
+ call COLOR(12);\r
+ call OUTSTRING("Page suivante");\r
+ choix:=boutontxt;\r
+ if choix=0 then\r
+ (* l'utilisateur a clique sur quitter *) \r
+ raise fin;\r
+ else\r
+ (* L'utilisateur a clique sur page suivante*)\r
+ call pagesuiv;\r
+ fi;\r
+ END afficinstr;\r
+\r
+\r
+(* pagesuiv affiche a l'ecran les informations sur les instructions *)\r
+(* associees aux coroutines*)\r
+ UNIT pagesuiv : PROCEDURE;\r
+ VAR touche,choix:integer;\r
+ BEGIN\r
+ call CLS;\r
+ (* Mise en place du texte*)\r
+ call MOVE(154,16);\r
+ call COLOR(12);\r
+ call OUTSTRING("INSTRUCTIONS ASSOCIEES AUX COROUTINES");\r
+ call MOVE(258,32);\r
+ call OUTSTRING("Suite...");\r
+ call COLOR(12);\r
+ call MOVE(16,48);\r
+ call OUTSTRING("I> New");\r
+ call COLOR(7);\r
+ call MOVE(56,64);\r
+ call OUTSTRING("Instruction generatrice (allocateur) de creation d'un objet");\r
+ call MOVE(56,72);\r
+ call OUTSTRING("d'une classe donnee (dans le cas present coroutine).");\r
+ call MOVE(88,84);\r
+ call OUTSTRING("Exemple : C:=NEW nom_coroutine;");\r
+\r
+ call COLOR(12);\r
+ call MOVE(16,100);\r
+ call OUTSTRING("II> Return");\r
+ call COLOR(7);\r
+ call MOVE(56,116);\r
+ call OUTSTRING("Apres que le record d'activation de la coroutine ait ete cree,");\r
+ call MOVE(56,124);\r
+ call OUTSTRING("(instruction NEW), et que les initialisations aient ete effec-");\r
+ call MOVE(56,132);\r
+ call OUTSTRING("tuees, l'instruction de retour RETURN (obligatoire) a pour effet");\r
+ call MOVE(56,140);\r
+ call OUTSTRING("de rendre le controle au programme appelant."); \r
+\r
+ call COLOR(12);\r
+ call MOVE(16,156);\r
+ call OUTSTRING("III> Attach");\r
+ call COLOR(7);\r
+ call MOVE(56,172);\r
+ call OUTSTRING("Des qu'un objet de type coroutine a ete cree, il peut etre soit");\r
+ call MOVE(56,180);\r
+ call OUTSTRING("actif, soit suspendu. Toute reactivation d'une coroutine X ");\r
+ call MOVE(56,188);\r
+ call OUTSTRING("(ATTACH(X);) se traduit par la suspension de la coroutine active");\r
+ call MOVE(56,196);\r
+ call OUTSTRING("et par la poursuite de l'execution a l'instruction de x suivant"); \r
+ call MOVE(56,204);\r
+ call OUTSTRING("celle ayant ete executee lors de la precedente reactivation.");\r
+\r
+ call COLOR(12);\r
+ call MOVE(16,220);\r
+ call OUTSTRING("IV> Detach");\r
+ call COLOR(7);\r
+ call MOVE(56,236);\r
+ call OUTSTRING("L'instruction DETACH a pour effet de desactiver la coroutine");\r
+ call MOVE(56,244);\r
+ call OUTSTRING("active qui contient la dite instruction et de rendre la main a");\r
+ call MOVE(56,252);\r
+ call OUTSTRING("la coroutine appelante (i.e. celle contenant le dernier ATTACH).");\r
+\r
+ call COLOR(12);\r
+ call MOVE(16,268);\r
+ call OUTSTRING("V> Kill");\r
+ call COLOR(7);\r
+ call MOVE(56,284);\r
+ call OUTSTRING("L'instruction KILL(X) a pour consequence la destruction du ");\r
+ call MOVE(56,292);\r
+ call OUTSTRING("record d'activation de la coroutine designee par la variable");\r
+ call MOVE(56,300);\r
+ call OUTSTRING("de reference X.");\r
+\r
+ call MOVE(434,324);\r
+ call COLOR(12);\r
+ call OUTSTRING("Page precedente");\r
+ choix:=boutontxt;\r
+ if choix=0 then\r
+ (* l'utilisateur a clique sur quitter *) \r
+ raise fin;\r
+ else\r
+ (* L'utilisateur a clique sur page suivante*)\r
+ call afficinstr;\r
+ fi;\r
+ END pagesuiv;\r
+\r
+\r
+(********************************************************************************)\r
+(* Procedures permettant de quitter l'application ou de revenir au menu *)\r
+(********************************************************************************)\r
+\r
+ (* Gestion du click sur l'icone 'Quitter' car execution terminee ou point *)\r
+ (* d'arret atteint*)\r
+ UNIT finexecut: PROCEDURE(typexec:integer,rempli,atteint:boolean);\r
+ VAR i,touche:integer,\r
+ selection:boolean;\r
+ BEGIN\r
+ call MOVE(16,296);\r
+ call COLOR(10);\r
+ if rempli then\r
+ call OUTSTRING("LE NOMBRE MAXIMUM DE SAISIE DES VALEURS DU TABLEAU EST ATTEINT !");\r
+ call MOVE(150,304);\r
+ call OUTSTRING("Cliquez sur l'icone Quitter afin de retourner au menu");\r
+ else\r
+ if typexec=5 then\r
+ if atteint then\r
+ call OUTSTRING("POINT D'ARRET ATTEINT !.Pour retourner au menu, cliquez sur l'icone Quitter");\r
+ else\r
+ call OUTSTRING("LE PROGRAMME S'EST TERMINE SANS ETRE PASSE PAR LE POINT D'ARRET !");\r
+ call MOVE(150,304);\r
+ call OUTSTRING("Cliquez sur l'icone Quitter afin de retourner au menu");\r
+ fi;\r
+ fi;\r
+\r
+ if typexec=3 or typexec=4 then\r
+ call OUTSTRING("PROGRAMME TERMINE !.Pour retourner au menu, cliquez sur l'icone Quitter");\r
+ fi;\r
+ fi;\r
+ call SHOWCURSOR;\r
+ call COLOR(12); \r
+ call MOVE(16,260);\r
+ call OUTSTRING("Quitter");\r
+ selection:=false;\r
+ g:=false;\r
+ d:=false;\r
+ c:=false;\r
+ (* Gestion de la souris *)\r
+ DO\r
+ call GETPRESS(0,h,v,b,g,d,c);\r
+ if g then\r
+ call clicquit(h,v,selection);\r
+ call HIDECURSOR;\r
+ if not selection then\r
+ g:=false;\r
+ call SHOWCURSOR;\r
+ repeat;\r
+ else\r
+ (* l'utilisateur a clique sur quitter *) \r
+ raise fin;\r
+ fi;\r
+ fi;\r
+ OD;\r
+ END finexecut;\r
+\r
+ (* quitter permet de sortir de l'application convenablement *)\r
+ UNIT quitter : PROCEDURE;\r
+ BEGIN\r
+ call GROFF;\r
+ call NewPage;\r
+ call Setcursor(5,20);\r
+ writeln("**********TERMINE**********");\r
+ call ENDRUN;\r
+ END quitter;\r
+\r
+\r
+(********************************************************************************)\r
+(* PROGRAMME PRINCIPAL : main *)\r
+(********************************************************************************)\r
+\r
+ BEGIN\r
+ (* Utilisation du mode graphique *)\r
+ call GRON(0);\r
+ (* Mise en place de l'ecran de presentation de l'application *)\r
+ call presentation;\r
+ DO\r
+ call COLOR(9);\r
+ call style(1);\r
+ demarrage:=false;\r
+ ptarok:=false;\r
+ xpa:=0;\r
+ ypa:=0;\r
+ call menu(nooper,typexec); (* Recuperation des choix de l'utilisateur*)\r
+ call BORDER(16);\r
+ CASE nooper\r
+ when 0:\r
+ (*l'utilisateur veut quitter l'application*)\r
+ call quitter;\r
+\r
+ when 1:\r
+ (*l'utilisateur choisit d'executer le programme prod-cons*)\r
+ if typexec=0 then\r
+ (* L'utilisateur choisit de quitter l'application *)\r
+ call quitter;\r
+ else\r
+ call contexte(typexec,ptarok);\r
+ (* Si typexec=3 alors execution normale du programme *)\r
+ (* Si typexec=4 alors execution pas a pas du programme*)\r
+ (* Si typexec=5 alors execution avec point d'arret *)\r
+\r
+ if typexec=3 or typexec=4 then\r
+ call instalnorm(typexec,xpa,ypa,demarrage);\r
+ if demarrage then (* Choix de l'option execution*)\r
+ call execut(typexec,xpa,ypa);\r
+ if stopexec then \r
+ (* Choix a un moment donne de l'option Quitter*)\r
+ stopexec:=false;\r
+ repeat;\r
+ fi;\r
+ fi;\r
+ if stopexec then\r
+ stopexec:=false;\r
+ fi; \r
+ fi;\r
+\r
+ if typexec=5 then\r
+ call mainvisu;\r
+ call prodvisu;\r
+ call consvisu;\r
+ (* Selection du point d'arret par l'utilisateur*)\r
+ call selectpoint(xpa,ypa);\r
+ if stopexec then\r
+ stopexec:=false;\r
+ else\r
+ ptarok:=true;\r
+ call contexte(typexec,ptarok);\r
+ call instalnorm(typexec,xpa,ypa,demarrage);\r
+ if stopexec then \r
+ stopexec:=false;\r
+ else\r
+ call execut(typexec,xpa,ypa);\r
+ if stopexec then\r
+ stopexec:=false;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ fi;\r
+ when 2: (* L'utilisateur desire des renseignements sur les coroutines*)\r
+ if typexec=0 then\r
+ call quitter;\r
+ else\r
+ (* Si typexec=3 alors affichage de la definition et de l'interet*)\r
+ (* des coroutines*)\r
+ (* Si typexec=4 alors affichage du shema de la semantique des*)\r
+ (* coroutines*)\r
+\r
+ if typexec=3 then\r
+ call afficdef;\r
+ if stopexec then\r
+ stopexec:=false;\r
+ fi;\r
+ else\r
+ if typexec=4 then\r
+ call afficinstr;\r
+ if stopexec then\r
+ stopexec:=false;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ repeat;\r
+ ESAC;\r
+ OD;\r
+ END;\r
+ END;\r
+ END COROUTINE.\r
+\r
+(********************************************************************************)\r
--- /dev/null
+(* ********************************************************** *)\r
+(*\r
+SOURCE : P.LOG\r
+PROGRAMME : Visualisation de coroutines sur l'exemple du programme merge.log\r
+\r
+AUTEURS : BEAU Anne-Valerie\r
+ DELBURG Myriam\r
+*)\r
+(* ********************************************************** *)\r
+(*\r
+ Les units utilises :\r
+ ecrit\r
+ lit\r
+ affiche_abr\r
+ affiche_prg\r
+ affiche_cor\r
+ node\r
+ efface\r
+ pause\r
+ mousepos\r
+ rectangle\r
+ inchar\r
+ menu\r
+ presentation\r
+*)\r
+\r
+\r
+\r
+\r
+\r
+\r
+BLOCK\r
+ (* COROUTINE MERGE OF BINARY TREES*)\r
+\r
+(*************************************************************)\r
+unit ecrit : iiuwgraph procedure( Number : integer );\r
+ var n1, n2, n3 : integer;\r
+begin\r
+ if Number < 10\r
+ then\r
+ call HASCII(0);\r
+ call HASCII(Number + 48);\r
+ call Hascii(0);\r
+ else\r
+ if Number < 100\r
+ then\r
+ n1 := Number div 10;\r
+ n2 := Number - n1 * 10;\r
+ call HASCII(0);\r
+ call Hascii(n1 + 48);\r
+ call Hascii(0);\r
+ call Hascii(n2 + 48);\r
+ else\r
+ n1 := Number div 100;\r
+ n2 := (Number - n1 * 100) div 10;\r
+ n3 := Number - n1 * 100 - n2 * 10;\r
+ call HASCII(0);\r
+ call Hascii(n1 + 48);\r
+ call Hascii(0);\r
+ call Hascii(n2 + 48);\r
+ call HASCII(0);\r
+ call Hascii(n3 + 48);\r
+ fi;\r
+ fi;\r
+ call outstring(" ");\r
+end ecrit;\r
+\r
+(*************************************************************)\r
+unit lit : iiuwgraph function : integer;\r
+ var X,Y,i, OrdN : integer,\r
+ Number : arrayof integer;\r
+begin\r
+ array Number dim(1:4);\r
+ i:= 0 ;\r
+ X := InXPos;\r
+ Y := InYPos;\r
+ do\r
+ OrdN:=inchar;\r
+ if i = 8 or (OrdN < 48 and OrdN > 57) then exit fi;\r
+\r
+ case OrdN\r
+ when 48 : i:=i+1;\r
+ Number(i):=0;\r
+ when 49 : i:=i+1;\r
+ Number(i):=1;\r
+ when 50 : i:=i+1;\r
+ Number(i):=2;\r
+ when 51 : i:=i+1;\r
+ Number(i):=3;\r
+ when 52 : i:=i+1;\r
+ Number(i):=4;\r
+ when 53 : i:=i+1;\r
+ Number(i):=5;\r
+ when 54 : i:=i+1;\r
+ Number(i):=6;\r
+ when 55 : i:=i+1;\r
+ Number(i):=7;\r
+ when 56 : i:=i+1;\r
+ Number(i):=8;\r
+ when 57 : i:=i+1;\r
+ Number(i):=9;\r
+ when 8 : if i>0\r
+ then\r
+ Number(i) := 0;\r
+ i := i - 1;\r
+ call hascii(0);\r
+ fi;\r
+ when 13 : if i > 0 then exit fi ;\r
+ esac;\r
+\r
+ if i = 1\r
+ then\r
+ call Move(X,Y);\r
+ call hascii(0);\r
+ call hascii(48+Number(1));\r
+ fi;\r
+\r
+ if i = 2\r
+ then\r
+ call Move(X + 8,Y);\r
+ call hascii(0);\r
+ call hascii(48 + Number(2));\r
+ fi;\r
+ od;\r
+\r
+ if (Number(1) =0 ) or (Number(1) = 0 and Number(2) = 0)\r
+ or (Number(1) = 0 and Number(2) = 0 and Number(3) = 0)\r
+ then\r
+ call Move(X,Y);\r
+ call hascii(0);\r
+ call hascii(48);\r
+ call hascii(0);\r
+ fi;\r
+\r
+ if i = 1\r
+ then\r
+ result := Number(1);\r
+ else\r
+ if i = 2\r
+ then\r
+ result := 10 * Number(1) + Number (2);\r
+ else\r
+ result := 100 * Number(1) + 10 * Number(2) + Number(3);\r
+ fi;\r
+ fi;\r
+ kill(Number);\r
+end lit;\r
+\r
+(*************************************************************)\r
+unit inchar : iiuwgraph function : integer;\r
+var c : integer;\r
+begin\r
+ do\r
+ c := inkey;\r
+ if c =/= 0 then exit fi;\r
+ od;\r
+ result := c;\r
+end inchar;\r
+\r
+(*************************************************************)\r
+unit mousepos : iiuwgraph procedure(A,B : integer; output chx : integer);\r
+begin\r
+ if ((A>50) and (A<170))\r
+ then\r
+ if ((B>325) and (B<345))\r
+ then\r
+ chx := 1;\r
+ fi;\r
+ else\r
+ if ((A>260) and (A<380))\r
+ then\r
+ if ((B>290) and (B<310))\r
+ then\r
+ chx := 2;\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+end mousepos;\r
+\r
+(*************************************************************)\r
+unit rectangle : iiuwgraph procedure(X1,Y1,X2,Y2 : integer);\r
+begin\r
+ call move(X1,Y1);\r
+ call draw(X2,Y1);\r
+ call move(X2,Y1);\r
+ call draw(X2,Y2);\r
+ call move(X2,Y2);\r
+ call draw(X1,Y2);\r
+ call move(X1,Y2);\r
+ call draw(X1,Y1);\r
+end rectangle;\r
+\r
+(*************************************************************)\r
+unit affiche_prg : iiuwgraph procedure;\r
+begin\r
+ call color(13);\r
+ call move(5,5);\r
+ call draw(5,325);\r
+ call draw(400,325);\r
+ call draw(400,5);\r
+ call draw(5,5);\r
+ call move(5,15);\r
+ call draw(400,15);\r
+ call move(100,7);\r
+ call outstring("DL");\r
+ call move(260,7);\r
+ call outstring("SL");\r
+ call move(5,97);\r
+ call draw(400,97);\r
+ call move(370,330);\r
+ call outstring("main");\r
+ call color(3);\r
+ call move(10,17);\r
+ call outstring("program merge;");\r
+ call move(20,26);\r
+ call outstring("unit node:class;...;");\r
+ call move(30,35);\r
+ call outstring("unit ins:procedure(value:integer);...;end ins;");\r
+ call move(20,44);\r
+ call outstring("end node;");\r
+ call move(20,53);\r
+ call outstring("unit travers:coroutine(x:node);...;");\r
+ call move(30,62);\r
+ call outstring("unit t:procedure(y:node);...;end t;");\r
+ call move(20,71);\r
+ call outstring("end travers;");\r
+ call move(20,80);\r
+ call outstring("var n ,i ,j ,min ,m :integer,");\r
+ call color(12);\r
+ call move(63,80);\r
+ call outstring(" ");\r
+ call move(63,80);\r
+ call ecrit(n);\r
+ call move(108,80);\r
+ call outstring(" ");\r
+ call move(108,80);\r
+ call ecrit(i);\r
+ call move(158,80);\r
+ call outstring(" ");\r
+ call move(158,80);\r
+ call ecrit(j);\r
+ call move(228,80);\r
+ call outstring(" ");\r
+ call move(228,80);\r
+ call ecrit(min);\r
+ call move(285,80);\r
+ call outstring(" ");\r
+ call move(285,80);\r
+ call ecrit(m);\r
+ call color(3);\r
+ call move(30,89);\r
+ call outstring("d:arrayof node, tr:array of travers;");\r
+ call move(10,98);\r
+ call outstring("begin");\r
+ call move(20,107);\r
+ call outstring("writeln('Donnez le nombre d'arbres :');read(n);");\r
+ call move(20,116);\r
+ call outstring("array d dim(1:n);");\r
+ call move(20,125);\r
+ call outstring("for i:=1 to n do");\r
+ call move(30,134);\r
+ call outstring("writeln('Donnez la sequence de l'arbre no :');");\r
+ call move(30,143);\r
+ call outstring("read(j); if j>m then m:=j fi;");\r
+ call move(30,152);\r
+ call outstring("d(i):=new node; d(i).val:=j;");\r
+ call move(30,161);\r
+ call outstring("do");\r
+ call move(40,170);\r
+ call outstring("read(j); if j=0 then exit fi;");\r
+ call move(40,179);\r
+ call outstring("if j>m then m:=j fi; call d(i).ins(j);");\r
+ call move(30,188);\r
+ call outstring("od;");\r
+ call move(20,197);\r
+ call outstring("od;");\r
+ call move(20,206);\r
+ call outstring("m:=m+1; array tr dim(1:n); min:=0;");\r
+ call move(20,215);\r
+ call outstring("for i:=1 to n do");\r
+ call move(30,224);\r
+ call outstring("tr(i):=new travers(d(i)); attach(tr(i));");\r
+ call move(20,233);\r
+ call outstring("od;");\r
+ call move(20,242);\r
+ call outstring("writeln('La fusion de la sequence est :');");\r
+ call move(20,251);\r
+ call outstring("do");\r
+ call move(30,260);\r
+ call outstring("if min=m then exit fi; min:=tr(1).val; j:=1;");\r
+ call move(30,269);\r
+ call outstring("for i:=2 to n do");\r
+ call move(40,278);\r
+ call outstring("if min>tr(i).val then min:=tr(i).val;j:=i;fi;");\r
+ call move(30,287);\r
+ call outstring("od;");\r
+ call move(30,296);\r
+ call outstring("if min<m then write(min); attach(tr(j)); fi;");\r
+ call move(20,305);\r
+ call outstring("od;");\r
+ call move(10,314);\r
+ call outstring("end merge.");\r
+end affiche_prg;\r
+\r
+(*************************************************************)\r
+unit affiche_abr : iiuwgraph procedure(x1,y1,x2,y2:integer);\r
+ var number : integer;\r
+begin\r
+ call color(3);\r
+ call move(x1+5,y1+5);\r
+ number := 1;\r
+ call ecrit(number);\r
+ call color(9);\r
+ call rectangle(x1,y1,x2,y2);\r
+ call move(x1,y1+5);\r
+ call draw(400,y1+5);\r
+ y1:=y1+20;\r
+ y2:=y2+20;\r
+\r
+ if n=2\r
+ then\r
+ call color(3);\r
+ call move(x1+5,y1+5);\r
+ call ecrit(n);\r
+ call color(9);\r
+ call rectangle(x1,y1,x2,y2);\r
+ call move(x1,y1+5);\r
+ call draw(400,y1+5);\r
+ y1:=y1+20;\r
+ y2:=y2+20;\r
+ else\r
+ if n>2\r
+ then\r
+ call color(3);\r
+ call move(x1+5,y1+5);\r
+ call outstring("...");\r
+ call color(9);\r
+ call rectangle(x1,y1,x2,y2);\r
+ call move(x1,y1+5);\r
+ call draw(400,y1+5);\r
+ y1:=y1+20;\r
+ y2:=y2+20;\r
+ call color(3);\r
+ call move(x1+5,y1+5);\r
+ call ecrit(n);\r
+ call color(9);\r
+ call rectangle(x1,y1,x2,y2);\r
+ call move(x1,y1+5);\r
+ call draw(400,y1+5);\r
+ y1:=y1+20;\r
+ y2:=y2+20;\r
+ fi;\r
+ fi;\r
+end affiche_abr;\r
+\r
+(*************************************************************)\r
+unit affiche_cor : iiuwgraph procedure(x1,y1,x2,y2:integer);\r
+begin\r
+ call color(13);\r
+ call rectangle(x1,y1,x2,y2);\r
+ call move(x1,y1+10);\r
+ call draw(x2,y1+10);\r
+ call move(x1+50,y1+2);\r
+ call outstring("DL");\r
+ call move(x1+150,y1+2);\r
+ call outstring("SL");\r
+\r
+ call move(x1,y1+145);\r
+ call draw(x2,y1+145);\r
+ call move(x2-55,y2+5);\r
+ call outstring("travers");\r
+ call color(3);\r
+ call move(x1+5,y1+15);\r
+ call outstring("unit travers:coroutine");\r
+ call move(x1+30,y1+25);\r
+ call outstring("(x:node);");\r
+ call move(x1+10,y1+35);\r
+ call outstring("var val : interger;");\r
+ call move(x1+170,y1+35);\r
+ call color(12);\r
+ call outstring(" ");\r
+ call move(x1+170,y1+35);\r
+ call ecrit(valeur);\r
+ call color(3);\r
+ call move(x1+10,y1+45);\r
+ call outstring("unit t:procedure(y:node);");\r
+ call move(x1+10,y1+55);\r
+ call outstring("begin");\r
+ call move(x1+15,y1+65);\r
+ call outstring("if y=/=none");\r
+ call move(x1+15,y1+75);\r
+ call outstring("then");\r
+ call move(x1+20,y1+85);\r
+ call outstring("call t(y.left);");\r
+ call move(x1+20,y1+95);\r
+ call outstring("val:=y.val;");\r
+ call move(x1+20,y1+105);\r
+ call outstring("detach;");\r
+ call move(x1+20,y1+115);\r
+ call outstring("call t(y.right);");\r
+ call move(x1+15,y1+125);\r
+ call outstring("fi;");\r
+ call move(x1+10,y1+135);\r
+ call outstring("end t;");\r
+ call color(5);\r
+ call color(3);\r
+ call move(x1+5,y1+150);\r
+ call outstring("begin");\r
+ call move(x1+10,y1+160);\r
+ call outstring("return;");\r
+ call move(x1+10,y1+170);\r
+ call outstring("call t(x);");\r
+ call move(x1+10,y1+180);\r
+ call outstring("val:=m;");\r
+ call move(x1+5,y1+190);\r
+ call outstring("end travers;");\r
+end affiche_cor;\r
+\r
+(*************************************************************)\r
+unit presentation : iiuwgraph procedure;\r
+begin\r
+ call border(5);\r
+ call color(13);\r
+ call rectangle(115,90,515,120);\r
+ call color(3);\r
+ call move(125,100);\r
+ call outstring("VISUALISATION DES COROUTINES DU PROGRAMME MERGE");\r
+ call move(65,160);\r
+ call outstring("Ce programme utilise les coroutines et fusionne un nombre donn\82");\r
+ call move(65,185);\r
+ call outstring("d'arbres de recherche.");\r
+ call pause;\r
+ call cls;\r
+end presentation;\r
+\r
+(*************************************************************)\r
+unit menu : iiuwgraph procedure(output chx:integer);\r
+ var b,h,v : integer;\r
+begin\r
+ pref mouse block\r
+ begin\r
+ if (driver)\r
+ then\r
+ call color(1);\r
+ call rectangle(20,328,140,348);\r
+ call move(50,335);\r
+ call color(15);\r
+ call outstring("Quitter");\r
+ call move(170,340);\r
+ call outstring("Ou cliquer ailleurs pour continuer");\r
+ call move(400,330);\r
+ call showcursor;\r
+\r
+ do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ if gauche\r
+ then\r
+ call mousepos(h,v,chx);\r
+ call hidecursor;\r
+ gauche := false;\r
+ exit;\r
+ fi;\r
+ od;\r
+ else\r
+ call move(150,340);\r
+ call outstring("SERVEZ-VOUS DE LA SOURIS");\r
+ call pause;\r
+ chx := 5;\r
+ exit;\r
+ fi;\r
+ end;\r
+end menu;\r
+\r
+(*************************************************************)\r
+unit menu1 : iiuwgraph procedure(output chx:integer);\r
+ var b,h,v : integer;\r
+begin\r
+ pref mouse block\r
+ begin\r
+ if (driver)\r
+ then\r
+ call color(13);\r
+ call style(2);\r
+ call rectangle(200,160,430,180);\r
+ call color(3);\r
+ call move(210,165);\r
+ call outstring("L'application est termin\82e");\r
+ call color(1);\r
+ call rectangle(260,290,380,310);\r
+ call move(295,297);\r
+ call color(15);\r
+ call style(3);\r
+ call outstring("Quitter");\r
+ call move(400,330);\r
+ call showcursor;\r
+\r
+ do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ if gauche\r
+ then\r
+ call mousepos(h,v,chx);\r
+ call hidecursor;\r
+ gauche := false;\r
+ exit;\r
+ fi;\r
+ od;\r
+ else\r
+ call move(150,340);\r
+ call outstring("SERVEZ-VOUS DE LA SOURIS");\r
+ call pause;\r
+ chx := 5;\r
+ exit;\r
+ fi;\r
+ end;\r
+end menu1;\r
+\r
+(*************************************************************)\r
+unit efface : iiuwgraph procedure;\r
+begin\r
+ call move(150,340);\r
+ call outstring(" ");\r
+end efface;\r
+\r
+(*************************************************************)\r
+unit efface_zone : iiuwgraph procedure;\r
+ var cpt : integer;\r
+begin\r
+ for cpt:=1 to 9\r
+ do\r
+ call move(231,cpt);\r
+ call outstring(" ");\r
+ od;\r
+ for cpt:=5 to 25\r
+ do\r
+ call move(317,cpt);\r
+ call outstring(" ");\r
+ od;\r
+ for cpt:=30 to 160\r
+ do\r
+ call move(231,cpt);\r
+ call outstring(" ");\r
+ od;\r
+end efface_zone;\r
+\r
+(*************************************************************)\r
+unit pause : iiuwgraph procedure;\r
+ var touche : char;\r
+begin\r
+ pref mouse block;\r
+ var h,b,v,p : integer,\r
+ touche : char;\r
+ begin\r
+ droit := false;\r
+ driver := init(b);\r
+ if (driver)\r
+ then\r
+ call color(15);\r
+ call move(150,340);\r
+ call outstring("Appuyez sur le bouton droit de la souris");\r
+ call move(400,340);\r
+ while (not droit)\r
+ do\r
+ call getpress(1,h,v,p,gauche,droit,centre);\r
+ od;\r
+ call move(150,340);\r
+ call outstring(" ");\r
+ call color(5);\r
+ else\r
+ call move(150,340);\r
+ call outstring(" ");\r
+ call move(150,340);\r
+ call outstring("Appuyez sur une touche");\r
+ read (touche);\r
+ fi;\r
+ end;\r
+end pause;\r
+\r
+\r
+unit aff : iiuwgraph procedure(num : integer);\r
+begin\r
+ call color(13);\r
+ call move(260,18);\r
+ call outstring("tr(");\r
+ call ecrit(num);\r
+ call move(310,18);\r
+ call outstring(")");\r
+ call move(255,20);\r
+ call draw(235,20);\r
+ call move(230,17);\r
+ call outstring("<");\r
+end aff;\r
+\r
+\r
+(*************************************************************)\r
+UNIT NODE : CLASS;\r
+ (* NODE OF BINARY TREE *)\r
+ VAR LEFT,RIGHT : NODE, VAL,tuer : INTEGER; (*SEARCHING KEY *)\r
+\r
+ UNIT INS : PROCEDURE (VALUE : INTEGER);\r
+ BEGIN\r
+ IF VAL> VALUE\r
+ THEN\r
+ IF LEFT = NONE\r
+ THEN\r
+ LEFT := NEW NODE;\r
+ LEFT.VAL := VALUE;\r
+ ELSE\r
+ CALL LEFT.INS(VALUE);\r
+ FI;\r
+ ELSE\r
+ (* ELEMENTS NOT LESS THAN VAL ARE LOCATED IN THE RIGHT SUBTREE *)\r
+ IF RIGHT = NONE\r
+ THEN\r
+ RIGHT := NEW NODE;\r
+ RIGHT.VAL := VALUE;\r
+ ELSE\r
+ CALL RIGHT.INS(VALUE);\r
+ FI;\r
+ FI;\r
+ END INS;\r
+END NODE;\r
+\r
+unit reaffiche_boi : iiuwgraph procedure(courant,boite : node,\r
+ hmin, hmax, vmax, hauteur : integer);\r
+ var w : integer;\r
+begin\r
+ if sortir =/= 1\r
+ then\r
+ IF boite =/= NONE\r
+ THEN\r
+ if hauteur > 2\r
+ then\r
+ call efface_zone;\r
+ hauteur := 0;\r
+ hmin := 240;\r
+ hmax := 630;\r
+ vmax := 10;\r
+ fi;\r
+ w := ((hmin - hmax) / 2) + hmax;\r
+ call move(w-5,vmax+10);\r
+ call color(12);\r
+ call ecrit(boite.val);\r
+ call color(13);\r
+ call rectangle(w-10,vmax-4,w+38,vmax+20);\r
+ call move(w-10,vmax+6);\r
+ call draw(w+38,vmax+6);\r
+ call move(w-3,vmax-2);\r
+ call outstring("DL");\r
+ call move(w+20,vmax-2);\r
+ call outstring("SL");\r
+ call move(w+30,vmax+25);\r
+ call outstring("t");\r
+ if hauteur < 2\r
+ then\r
+ call trait(w,vmax);\r
+ fi;\r
+\r
+ if boite = courant\r
+ then\r
+ sortir := 1;\r
+ else\r
+ if boite.tuer = 0\r
+ then\r
+ CALL reaffiche_boi(courant,boite.left,hmin,w,vmax+60,hauteur+1);\r
+ fi;\r
+ CALL reaffiche_boi(courant,boite.RIGHT,w,hmax,vmax+60,hauteur+1);\r
+ fi;\r
+ fi;\r
+ fi;\r
+end reaffiche_boi;\r
+\r
+unit trait : iiuwgraph procedure(mil,bas : integer);\r
+begin\r
+ call color(9);\r
+ call move(mil-10,bas+14);\r
+ call draw(mil-60,bas+14);\r
+ call draw(mil-60,bas+50);\r
+ call move(mil-67,bas+45);\r
+ call outstring("\/");\r
+\r
+ call move(mil+38,bas+14);\r
+ call draw(mil+88,bas+14);\r
+ call draw(mil+88,bas+50);\r
+ call move(mil+81,bas+45);\r
+ call outstring("\/");\r
+end trait;\r
+\r
+unit aff_cor : iiuwgraph procedure(x1,y1,x2,y2 : integer);\r
+begin\r
+ call color(9);\r
+ call move(x1+220,y1+48);\r
+ call draw(x1+400,y1+5);\r
+ call move(x1+405,y1);\r
+ call outstring(">");\r
+ call color(2);\r
+ call move(x1+400,y1-3);\r
+ call draw(x1+220,y1+3);\r
+ call move(x1+220,y1);\r
+ call outstring("<");\r
+ call color(11);\r
+ call move(x1+450,y1-6);\r
+ call draw(x1+220,y1-6);\r
+ call move(x1+220,y1-9);\r
+ call outstring("<");\r
+ x1 := 10;\r
+ x2 := 230;\r
+ y1 := 10;\r
+ y2 := 210;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+end aff_cor;\r
+\r
+\r
+(*************************************************************)\r
+UNIT TRAVERS : iiuwgraph COROUTINE (X :NODE);\r
+ (* CONSECUTIVE ELEMENTS OF TREE NODE ARE LOCATED IN THE GROWING ORDER TO *)\r
+ (* THE "MAIL BOX" VAL AND SENT TO THE ATTACHING UNIT *)\r
+ VAR VAL : INTEGER;\r
+ (* ----------------------------------------------------------- *)\r
+ UNIT T : PROCEDURE (Y : NODE, xmin, xmax, ymax, haut : integer);\r
+ (* RECURSIVE PROCEDURE FOR INFIX TRAVERSION RESULTING TREE ELEMENTS *)\r
+ (* IN NOT DECREASING ORDER *)\r
+ var w : integer;\r
+ BEGIN\r
+ x1 := 10;\r
+ x2 := 230;\r
+ y1 := 10;\r
+ y2 := 210;\r
+ call color(10);\r
+ call move(x1+10,y1+55);\r
+ call outstring("begin");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+15,y1+65);\r
+ call outstring("if y=/=none");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+\r
+ IF Y =/= NONE\r
+ THEN\r
+ call color(10);\r
+ call move(x1+15,y1+75);\r
+ call outstring("then");\r
+ call pause;\r
+ if haut > 2\r
+ then\r
+ call efface_zone;\r
+ haut := 0;\r
+ xmin := 240;\r
+ xmax := 630;\r
+ ymax := 10;\r
+ fi;\r
+ w := ((xmin - xmax) / 2) + xmax;\r
+ call move(w-5,ymax+10);\r
+ call color(12);\r
+ call ecrit(y.val);\r
+ call color(13);\r
+ call rectangle(w-10,ymax-4,w+38,ymax+20);\r
+ call move(w-10,ymax+6);\r
+ call draw(w+38,ymax+6);\r
+ call move(w-3,ymax-2);\r
+ call outstring("DL");\r
+ call move(w+20,ymax-2);\r
+ call outstring("SL");\r
+ call move(w+30,ymax+25);\r
+ call outstring("t");\r
+ if haut < 2\r
+ then\r
+ call trait(w,ymax);\r
+ fi;\r
+\r
+ call aff_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+20,y1+85);\r
+ call outstring("call t(y.left);");\r
+ call pause;\r
+ call aff_cor(x1,y1,x2,y2);\r
+ CALL T(Y.LEFT,xmin,w,ymax+60,haut+1);\r
+ sortir := 0;\r
+ call efface_zone;\r
+ call reaffiche_boi(y,x,240,630,10,0);\r
+ call color(10);\r
+ call move(x1+20,y1+95);\r
+ call outstring("val:=y.val;");\r
+ call pause;\r
+ call aff_cor(x1,y1,x2,y2);\r
+ VAL := Y.VAL;\r
+ valeur := y.val;\r
+ call color(10);\r
+ call move(x1+20,y1+105);\r
+ call outstring("detach;");\r
+ call pause;\r
+ call cls;\r
+ DETACH;\r
+ call aff(j);\r
+ y.tuer := 1;\r
+ sortir := 0;\r
+ call reaffiche_boi(y,x,240,630,10,0);\r
+ call aff_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+20,y1+115);\r
+ call outstring("call t(y.right);");\r
+ call pause;\r
+ call aff_cor(x1,y1,x2,y2);\r
+ (* CONSECUTIVE ELEMENTS OF TREE Y ARE SENT FOR FURTHER *)\r
+ (* PROCESSING TO THE MASTER PROGRAM *)\r
+ CALL T(Y.RIGHT,w,xmax,ymax+60,haut+1);\r
+ FI;\r
+ call color(10);\r
+ call move(x1+15,y1+125);\r
+ call outstring("fi;");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+10,y1+135);\r
+ call outstring("end t;");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call efface_zone;\r
+ END T;\r
+\r
+BEGIN\r
+ x1 := 410;\r
+ x2 := 630;\r
+ y1 := 30;\r
+ y2 := 230;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+5,y1+150);\r
+ call outstring("begin");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+10,y1+160);\r
+ call outstring("return;");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ RETURN;\r
+ xmin := 240;\r
+ xmax := 630;\r
+ ymax := 10;\r
+ hmin := 240;\r
+ hmax := 630;\r
+ vmax := 10;\r
+ call aff(i);\r
+ x1 := 10;\r
+ x2 := 230;\r
+ y1 := 10;\r
+ y2 := 210;\r
+\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call color(10);\r
+ call move(x1+10,y1+170);\r
+ call outstring("call t(x);");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ CALL T(X,240,630,10,0);\r
+ call color(10);\r
+ call move(x1+10,y1+180);\r
+ call outstring("val:=m;");\r
+ call pause;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ VAL := M;\r
+ valeur := m;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ call pause;\r
+ call color(10);\r
+ call move(x1+5,y1+190);\r
+ call outstring("end travers;");\r
+ call pause;\r
+ call cls;\r
+ call affiche_prg;\r
+ (* VAL IS MAXIMAL VALUE TREATED AS A SENTINEL WHILE ENTIRE TREE IS *)\r
+ (* TRAVESED *)\r
+END TRAVERS;\r
+\r
+unit saisir : iiuwgraph procedure;\r
+ var cpt, w, z : integer;\r
+begin\r
+ w := 120;\r
+ z := 0;\r
+ call color(3);\r
+ call move(10,30);\r
+ call outstring(" Les elements de l'arbre sont des entiers");\r
+ call move(10,50);\r
+ call outstring(" Pour terminer l'insertion des elements de l'arbre, tapez 0");\r
+ call move(10,70);\r
+ call outstring(" Ce nombre n'est pas insere dans l'arbre");\r
+ call color(3);\r
+ call move(10,100);\r
+ call outstring(" Donnez la sequence des elements de l'arbre numero ");\r
+ call ecrit(i);\r
+ call move(10,w);\r
+ for cpt := 1 to borne\r
+ do\r
+ z := z + 1;\r
+ if z = 10\r
+ then\r
+ w := w + 10;\r
+ call move(10,w);\r
+ z := 0;\r
+ fi;\r
+ call ecrit(arbre(cpt));\r
+ od;\r
+end saisir;\r
+\r
+unit sequence : iiuwgraph procedure;\r
+ var cpt, w, z : integer;\r
+begin\r
+ w := 30;\r
+ z := 0;\r
+ call color(3);\r
+ call move(10,10);\r
+ call outstring("La fusion des sequences est : ");\r
+ call move(10,w);\r
+ for cpt := 1 to borne\r
+ do\r
+ z := z + 1;\r
+ if z = 10\r
+ then\r
+ w := w+10;\r
+ call move(10,w);\r
+ z := 0;\r
+ fi;\r
+ call ecrit(res(cpt));\r
+ od;\r
+end sequence;\r
+\r
+\r
+\r
+(*************************************************************)\r
+ VAR N,I,J,MIN,M,K, choix,x1,x2,y1,y2,valeur,u : INTEGER,\r
+ h,v,p,abscisse,ordonnee,xmin,xmax,ymax : integer,\r
+ hmin,hmax,vmax,hauteur,haut,sortir,borne,longueur : integer,\r
+ driver,droit,gauche,centre : boolean,\r
+ touche : char,\r
+ rep : char,\r
+ arbre,res : arrayof integer,\r
+\r
+ (* N - TNE NUMBER OF TREES\r
+ M - MAXIMAL KEY VALUE + 1\r
+ MIN- MINIMAL VALUE PRODUCED AT A GIVEN MOMENT BY SYSTEM OF COROUTINES*)\r
+ D : ARRAYOF NODE,\r
+ TR : ARRAYOF TRAVERS;\r
+\r
+BEGIN\r
+ pref iiuwgraph block\r
+ begin\r
+ abscisse := 0;\r
+ ordonnee := 30;\r
+ driver := false;\r
+ call hpage(0,0,0);\r
+ call hpage(0,639,349);\r
+ call gron(0);\r
+ call presentation;\r
+ gauche := false;\r
+ droit := false;\r
+ centre := false;\r
+ call border(5);\r
+ call color(3);\r
+\r
+ call cls;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(10,98);\r
+ call outstring("begin");\r
+ call pause;\r
+\r
+ DO\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,107);\r
+ call outstring("writeln('Donnez le nombre d'arbres :');");\r
+ call pause;\r
+ call cls;\r
+ call color(3);\r
+ call move(10,10);\r
+ call outstring(" Donnez le nombre d'arbres : ");\r
+ call pause;\r
+ call cls;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(332,107);\r
+ call outstring("read(n);");\r
+ call pause;\r
+ call cls;\r
+ call color(3);\r
+ call move(10,10);\r
+ call outstring(" Donnez le nombre d'arbres : ");\r
+ read(N);\r
+ IF N>0\r
+ THEN EXIT;\r
+ ELSE\r
+ call move(10,30);\r
+ call outstring(" Ce nombre doit etre superieur a 0");\r
+ call pause;\r
+ call cls;\r
+ FI;\r
+ OD;\r
+ call move(250,10);\r
+ call ecrit(N);\r
+ call pause;\r
+ call cls;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,116);\r
+ call outstring("array d dim(1:n);");\r
+ call pause;\r
+ ARRAY D DIM(1:N);\r
+ call affiche_prg;\r
+\r
+ x1:=450;\r
+ x2:=485;\r
+ y1:=30;\r
+ y2:=45;\r
+ call affiche_abr(x1,y1,x2,y2);\r
+ call pause;\r
+ call cls;\r
+\r
+ longueur := 0;\r
+ FOR I := 1 TO N\r
+ DO\r
+ borne := 0;\r
+ array arbre dim(1:50);\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,125);\r
+ call outstring("for i:=1 to n do");\r
+ call pause;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,134);\r
+ call outstring("writeln('Donnez la sequence de l'arbre no :');");\r
+ call pause;\r
+ call cls;\r
+ call saisir;\r
+ call pause;\r
+ call cls;\r
+\r
+ do\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,143);\r
+ call outstring("read(j);");\r
+ call pause;\r
+ call cls;\r
+ call saisir;\r
+ call move(10,200);\r
+ read(J);\r
+ if j > 0\r
+ then exit;\r
+ fi;\r
+ call cls;\r
+ od;\r
+ borne := borne + 1;\r
+ arbre(borne) := j;\r
+ longueur := longueur + 1;\r
+ call saisir;\r
+ call pause;\r
+ call cls;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(102,143);\r
+ call outstring("if j>m");\r
+ call pause;\r
+ IF J>M\r
+ THEN\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(158,143);\r
+ call outstring("then");\r
+ call pause;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(198,143);\r
+ call outstring("m:=j");\r
+ call pause;\r
+ M :=J;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(238,143);\r
+ call outstring("fi;");\r
+ call pause;\r
+ FI;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,152);\r
+ call outstring("d(i):=new node;");\r
+ call pause;\r
+ D(I) := NEW NODE;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(158,152);\r
+ call outstring("d(i).val:=j;");\r
+\r
+ call pause;\r
+ D(I).VAL := J;\r
+\r
+ DO\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,161);\r
+ call outstring("do");\r
+ call pause;\r
+ do\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(40,170);\r
+ call outstring("read(j);");\r
+ call pause;\r
+ call cls;\r
+\r
+ call saisir;\r
+ call move(10,200);\r
+ read(j);\r
+ if j =/= 0\r
+ then\r
+ borne := borne + 1;\r
+ arbre(borne) := j;\r
+ longueur := longueur + 1;\r
+ call saisir;\r
+ call pause;\r
+ fi;\r
+ call cls;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(112,170);\r
+ call outstring("if j=0");\r
+ call pause;\r
+ IF J = 0\r
+ THEN\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(168,170);\r
+ call outstring("then");\r
+ call pause;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(208,170);\r
+ call outstring("exit");\r
+ call pause;\r
+ EXIT exit;\r
+ FI;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(248,170);\r
+ call outstring("fi;");\r
+ call pause;\r
+\r
+ if j > 0 then exit fi;\r
+ od;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(40,179);\r
+ call outstring("if j>m");\r
+ call pause;\r
+ IF J > M\r
+ THEN\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(96,179);\r
+ call outstring("then");\r
+ call pause;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(136,179);\r
+ call outstring("m:=j");\r
+ call pause;\r
+ M := J;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(176,179);\r
+ call outstring("fi;");\r
+ call pause;\r
+ FI;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(208,179);\r
+ call outstring("call d(i).ins(j);");\r
+ call pause;\r
+ CALL D(I).INS(J);\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,188);\r
+ call outstring("od;");\r
+ call pause;\r
+ OD;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,197);\r
+ call outstring("od;");\r
+ call pause;\r
+ kill(arbre);\r
+ OD;\r
+\r
+\r
+ call affiche_prg;\r
+\r
+ call menu(choix);\r
+ if choix = 1\r
+ then\r
+ call groff;\r
+ call endrun;\r
+ else\r
+ call move(19,327);\r
+ for u:=328 to 348\r
+ do\r
+ call move(20,u);\r
+ call outstring(" ");\r
+ od;\r
+\r
+ call color(10);\r
+ call move(20,206);\r
+ call outstring("m:=m+1;");\r
+ call pause;\r
+ M := M+1;\r
+ fi;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(84,206);\r
+ call outstring("array tr dim(1:n);");\r
+ call pause;\r
+ ARRAY TR DIM(1:N);\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(236,206);\r
+ call outstring("min:=0;");\r
+ call pause;\r
+ MIN := 0;\r
+\r
+ FOR I:=1 TO N DO\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,215);\r
+ call outstring("for i:=1 to n do");\r
+ call pause;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,224);\r
+ call outstring("tr(i):=new travers(d(i));");\r
+ call pause;\r
+\r
+\r
+ call color(13);\r
+ call move(580,10);\r
+ call outstring("tr(");\r
+ call ecrit(i);\r
+ call move(630,10);\r
+ call outstring(")");\r
+ call move(595,22);\r
+ call outstring("\/");\r
+ call move(602,18);\r
+ call draw(602,26);\r
+\r
+ call color(9);\r
+ call move(310,55);\r
+ call draw(400,55);\r
+ call move(400,52);\r
+ call outstring(">");\r
+\r
+ call color(2);\r
+ call move(465,30);\r
+ call draw(465,20);\r
+ call draw(400,20);\r
+ call move(400,17);\r
+ call outstring("<");\r
+\r
+ call color(11);\r
+ call move(570,30);\r
+ call draw(570,10);\r
+ call draw(400,10);\r
+ call move(400,7);\r
+ call outstring("<");\r
+ TR(I) := NEW TRAVERS (D(I));\r
+ call affiche_prg;\r
+\r
+\r
+ x1 := 410;\r
+ x2 := 630;\r
+ y1 := 30;\r
+ y2 := 230;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(238,224);\r
+ call outstring("attach(tr(i));");\r
+ call pause;\r
+ call cls;\r
+ x1 := 10;\r
+ x2 := 230;\r
+ y1 := 10;\r
+ y2 := 210;\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ ATTACH(TR(I));\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,233);\r
+ call outstring("od;");\r
+ call pause;\r
+ OD;\r
+\r
+ call affiche_prg;\r
+\r
+ call menu(choix);\r
+ if choix = 1\r
+ then\r
+ call groff;\r
+ call endrun;\r
+ else\r
+ call move(19,327);\r
+ for u:=328 to 348\r
+ do\r
+ call move(20,u);\r
+ call outstring(" ");\r
+ od;\r
+\r
+ call color(10);\r
+ call move(20,242);\r
+ call outstring("writeln('La fusion de la sequence est :');");\r
+ call pause;\r
+ fi;\r
+ call cls;\r
+\r
+ borne := 0;\r
+ array res dim(1:longueur);\r
+ call sequence;\r
+ call pause;\r
+ call cls;\r
+\r
+ DO\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,251);\r
+ call outstring("do");\r
+ call pause;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,260);\r
+ call outstring("if min=m");\r
+ call pause;\r
+ IF MIN = M\r
+ THEN\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(102,260);\r
+ call outstring("then");\r
+ call pause;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(142,260);\r
+ call outstring("exit");\r
+ call pause;\r
+ EXIT;\r
+ FI;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(182,260);\r
+ call outstring("fi;");\r
+ call pause;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(214,260);\r
+ call outstring("min:=tr(1).val;");\r
+ call pause;\r
+ MIN := TR(1).VAL;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(342,260);\r
+ call outstring("j:=1;");\r
+ call pause;\r
+ J :=1;\r
+\r
+ FOR I:= 2 TO N\r
+ DO\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,269);\r
+ call outstring("for i:=2 to n do");\r
+ call pause;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(40,278);\r
+ call outstring("if min>tr(i).val");\r
+ call pause;\r
+ IF MIN>TR(I).VAL\r
+ THEN\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(176,278);\r
+ call outstring("then");\r
+ call pause;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(216,278);\r
+ call outstring("min:=tr(i).val;");\r
+ call pause;\r
+ MIN:= TR(I).VAL;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(336,278);\r
+ call outstring("j:=i;");\r
+ call pause;\r
+ J := I;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(376,278);\r
+ call outstring("fi;");\r
+ call pause;\r
+ FI;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,287);\r
+ call outstring("od;");\r
+ call pause;\r
+ OD;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(30,296);\r
+ call outstring("if min<m");\r
+ call pause;\r
+ IF MIN< M\r
+ THEN\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(102,296);\r
+ call outstring("then");\r
+ call pause;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(142,296);\r
+ call outstring("write(min);");\r
+ call pause;\r
+ call cls;\r
+\r
+ borne := borne + 1;\r
+ res(borne) := min;\r
+\r
+ call sequence;\r
+ call pause;\r
+ call cls;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(236,296);\r
+ call outstring("attach(tr(j));");\r
+ call pause;\r
+ call cls;\r
+\r
+ call affiche_cor(x1,y1,x2,y2);\r
+ ATTACH(TR(J));\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(358,296);\r
+ call outstring("fi;");\r
+ call pause;\r
+ FI;\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(20,305);\r
+ call outstring("od;");\r
+ call pause;\r
+ OD;\r
+\r
+ call affiche_prg;\r
+ call color(10);\r
+ call move(10,314);\r
+ call outstring("end merge.");\r
+ call pause;\r
+ call cls;\r
+\r
+ call menu1(choix);\r
+ do\r
+ case choix\r
+ when 2 :\r
+ call groff;\r
+ call endrun;\r
+ esac;\r
+ call menu1(choix);\r
+ od;\r
+ end;\r
+END\r
--- /dev/null
+program STRAS ;\r
+(*************************************************************************\r
+ Auteurs : AKPAMOLI Eudes\r
+ HANNOYER Philippe\r
+ ___________________________\r
+ \r
+ \r
+ Projet nø 1 Li1\r
+ \r
+ \r
+ Multiplication de deux matrices selon l'algorithme r\82cursif\r
+ de Strassen (ou diviser pour r\8agner)\r
+ \r
+ Programme r\82alis\82 en Loglan 82, sur un PC 486,\r
+ \82cran SVGA Couleur (640 x 480) avec h\82ritage des deux unit\82s\r
+ * unit\82 graphique : IIUWGRAPH\r
+ * unit\82 de gestion de la souris : MOUSE.\r
+ \r
+ Remarque : Ce programme n\82cessite obligatoirement un PC avec \82cran\r
+ graphique (640 x 480). Il est pr\82f\82rable d'uiliser une souris.\r
+ En effet certaines parties de l'interface graphique ne\r
+ r\82agissent qu'avec la souris (ascenseurs g\82rants les scrollings).\r
+ \r
+**************************************************************************)\r
+ \r
+ \r
+begin\r
+ Pref iiuwgraph block (* h\82ritage de l'unt\82 graphique *)\r
+ begin\r
+ Pref mouse block (* h\82ritage de l'unit\82 souris *)\r
+ \r
+ \r
+ \r
+ (* DEBUT PARTIE GRAPHIQUE *)\r
+ \r
+ (* Sauve une partie de l'\82cran d\82finie par X, Y, XX, YY *)\r
+ unit GET_MAP : function (X, Y, XX, YY : integer) : arrayof integer ;\r
+ begin\r
+ call move (XX,YY) ;\r
+ result:=getmap(X, Y) ;\r
+ end GET_MAP ;\r
+ \r
+ (* Restore la partie d'\82cran sauv\82e par GET_MAP *)\r
+ unit PUT_MAP : procedure (X, Y : integer; Map : arrayof integer) ;\r
+ begin\r
+ call move (X, Y) ;\r
+ call putmap (Map) ;\r
+ end PUT_MAP ;\r
+ \r
+ \r
+ \r
+ (********* BOUTON **********)\r
+ (* Class g\82rant les procedure sur les boutons\r
+ X,Y,XX,YY : Coordonn\82es du bouton,\r
+ Epais : Epaisseur du bord du bouton,\r
+ C1, C2, C3 : Trois couleurs (Fond, Bordure une, Bordure deux).\r
+ \r
+ map_bouton : Sauvegarde de la partie d'\82cran avant affichage,\r
+ Bouton_aff : Bool\82en indiquant si le bouton est affich\82.*)\r
+ unit BOUTON : class (X, Y, XX, YY, Epais, C1, C2, C3 : Integer) ;\r
+ var map_Bouton : arrayof integer,\r
+ Bouton_Aff : boolean ;\r
+ \r
+ (* Affichage de la bordure d'un bouton *)\r
+ unit BORDURE : procedure (couleur1,couleur2 : integer) ;\r
+ var i : integer ;\r
+ begin\r
+ for i:=0 to Epais-1\r
+ do\r
+ call color(couleur1) ;\r
+ call move (x+1+i,yy-1-i) ;\r
+ call draw (x+1+i,y+1+i) ;\r
+ call draw (xx-1-i,y+1+i) ;\r
+ call color(couleur2) ;\r
+ call draw (xx-1-i,yy-1-i) ;\r
+ call draw (x+1+i,yy-1-i) ;\r
+ od ;\r
+ end BORDURE ;\r
+ \r
+ \r
+ (* Modifie les coordonn\82es d'un bouton *)\r
+ unit CHG_BOUTON_XY : procedure (Nv_X,Nv_Y : integer) ;\r
+ begin\r
+ XX:=Nv_X+(XX-X) ;\r
+ YY:=Nv_Y+(YY-Y) ;\r
+ X:=Nv_X ;\r
+ Y:=Nv_Y ;\r
+ end CHG_BOUTON_XY ;\r
+ \r
+ (* Affichage d'un bouton *)\r
+ unit AFF_BOUTON : procedure ;\r
+ begin\r
+ Bouton_Aff:=True ;\r
+ map_Bouton:=GET_MAP(X,Y,XX,YY) ;\r
+ call patern(x,y,xx,yy,0,1) ;\r
+ call patern(x+1,y+1,xx-1,yy-1,C1,1) ;\r
+ call BORDURE (C2, C3) ;\r
+ end AFF_BOUTON ;\r
+ \r
+ (* Effa\87age d'un bouton *)\r
+ unit EFF_BOUTON : procedure ;\r
+ begin\r
+ Bouton_Aff:=False ;\r
+ call PUT_MAP (X, Y, map_Bouton) ;\r
+ end EFF_BOUTON ;\r
+ \r
+ (* Simulation du clique sur un bouton avec la souris *)\r
+ unit BOUTON_ENFONCE : function (Num,NumSouris,XSouris,YSouris : Integer)\r
+ : boolean ;\r
+ begin\r
+ result:=(Num=NumSouris) and (Bouton_Aff and (X<=XSouris) and (XX>=XSouris)\r
+ and (Y<=YSouris) and (YY>=YSouris)) ;\r
+ if result\r
+ then\r
+ (* simulation de l'onfoncement du bouton *)\r
+ call BORDURE (C3,C2) ;\r
+ call BORDURE (C2,C3) ;\r
+ fi\r
+ end BOUTON_ENFONCE;\r
+ \r
+(* Bouton_Aff := False ;*)\r
+ end BOUTON ;\r
+ (******** BOUTON *********)\r
+ \r
+ \r
+ (********** ASCENSEUR *********)\r
+ (* Class g\82rant les proc\82dures relatives aux Ascenseur\r
+ Hor : Bool\82en \85 vrai si l'ascenseur est horizontal,\r
+ Max : Valeur indiquant le maximum pour le d\82placement de l'ascenseur,\r
+ X, Y : Coordonn\82es haut gauche de l'ascenseur,\r
+ Lgr : Longueur (ou hauteur) de l'ascenseur,\r
+ C1, C2, C3 : Trois couleurs (Fond, Bordure une, Bordure deux).\r
+ \r
+ BPlus, BDep, BBar, BMoins : Boutons de l'ascenseur,\r
+ Map : Sauvegarde l'\82cran avant l'affichage du bouton,\r
+ Courant : Valeur de d\82placement de l'ascenseur. *)\r
+ unit ASCENSEUR : class (Hor:Boolean,Max,X,Y,Lgr,c1,c2,c3 : integer) ;\r
+ Var BPlus, BDep, BBar, BMoins : BOUTON,\r
+ Map : arrayof integer,\r
+ Courant : Integer ;\r
+ \r
+ \r
+ (* Bouge le bouton de d\82placement de l'ascenseur. *)\r
+ unit BOUGE_ASC : procedure (EffAvt : boolean) ;\r
+ begin\r
+ if EffAvt then\r
+ call BDep.EFF_BOUTON ;\r
+ fi ;\r
+ if Max > 0\r
+ then\r
+ if (Hor)\r
+ then\r
+ BDep.X:=X+20+(Lgr-60)*Courant/Max ;\r
+ BDep.XX:=BDep.X+20 ;\r
+ else\r
+ BDep.Y:=Y+20+(Lgr-60)*Courant/Max ;\r
+ BDep.YY:=BDep.Y+20 ;\r
+ fi ;\r
+ fi ;\r
+ call BDep.AFF_BOUTON ;\r
+ end BOUGE_ASC;\r
+ \r
+ (* Affiche l'ascenseur *)\r
+ unit AFF_ASC : procedure ;\r
+ Var i : Integer ;\r
+ begin\r
+ call BPlus.AFF_BOUTON ;\r
+ call BMoins.AFF_BOUTON ;\r
+ call BBar.AFF_BOUTON ;\r
+ call Color(0) ;\r
+ for i:=1 to 6\r
+ do\r
+ if (Hor) then\r
+ call move (X+5+i,y+11-i) ;\r
+ call draw (X+5+i,y+9+i) ;\r
+ call move (X+Lgr-14+i,y+4+i) ;\r
+ call draw (X+Lgr-14+i,y+16-i) ;\r
+ else\r
+ call move (X+11-i,y+5+i) ;\r
+ call draw (X+9+i,y+5+i) ;\r
+ call move (X+4+i,y+Lgr-14+i) ;\r
+ call draw (X+16-i,y+Lgr-14+i) ;\r
+ fi ;\r
+ od ;\r
+ call BOUGE_ASC (False) ;\r
+ end AFF_ASC ;\r
+ \r
+ begin\r
+ if (Lgr<70) then Lgr := 70 fi ;\r
+ BPlus := new BOUTON (X,Y,X+20,Y+20,2,c1,c3,c2) ;\r
+ if (Hor)\r
+ then\r
+ BDep := new BOUTON (X+20,Y,X+40,Y+20,2,c1,c3,c2) ;\r
+ BBar := new BOUTON (X+20,Y,X+Lgr-20,Y+20,2,c1,c1,c1) ;\r
+ BMoins := new BOUTON (X+Lgr-20,Y,X+Lgr,Y+20,2,c1,c3,c2) ;\r
+ else\r
+ BDep := new BOUTON ( X,Y+20,X+20,Y+40,2,c1,c3,c2) ;\r
+ BBar := new BOUTON ( X,Y+20,X+20,Y+Lgr-20,2,c1,c1,c1) ;\r
+ BMoins := new BOUTON ( X,Y+Lgr-20,X+20,Y+Lgr,2,c1,c3,c2) ;\r
+ fi ;\r
+ Courant := 0 ;\r
+ end ASCENSEUR ;\r
+ (********** ASCENSEUR *********)\r
+ \r
+ \r
+ (********** WINDOWS *********)\r
+ (* Class g\82rant les proc\82dures relatives aux Fen\88tres (ces fen\88tres sont\r
+ celles qui permettent d'afficher les trois matrices (A, B, Res ou Tmp)\r
+ Titre : Nom de la fen\88tre ("A", "B", "Tmp" ou "Res"),\r
+ Maxi : Valeur indiquant la taille de la matrice,\r
+ X, Y : Coordonn\82es haut gauche de la fen\88tre,\r
+ \r
+ A1, A2 : Deux ascenseur (horizontal, vertical),\r
+ Map : Sauvegarde l'\82cran avant l'affichage du bouton,\r
+ Courant : Valeur de d\82placement de l'ascenseur.\r
+ Taille, Fond_win : Deux bouton (les 1er pour afficher la taille de la\r
+ matrice, le second qui sert de fond \85 la fen\88tre *)\r
+ unit WINDOWS : class (Titre : string ; Maxi, X, Y : Integer);\r
+ var A1, A2 : ASCENSEUR,\r
+ i : integer,\r
+ Taille, Fond_Win : BOUTON ;\r
+ \r
+ (* Affiche la matrice : au maximum 4 x 4 *)\r
+ unit AFF_MATRICE : procedure (M : arrayof arrayof integer) ;\r
+ var max, i, j : integer ;\r
+ begin\r
+ (* max ne peut \88tre plus grand que 4 *)\r
+ max:=imin(4,upper(M)) ;\r
+ for i:=1 to 4\r
+ do\r
+ (* On efface les \82ventuelles anciennes valeures *)\r
+ call outstring (X+10+(i*58),Y+7," ",4,12) ;\r
+ call outstring (X+10,Y+(i*38)," ",4,12) ;\r
+ for j:=1 to 4\r
+ do\r
+ call outstring (X-21+(i*58),Y+(j*38)," ",4,12) ;\r
+ od ;\r
+ od ;\r
+ for i:=1 to max\r
+ do\r
+ (* On \82crit les nouvelles valeures *)\r
+ call track (X+10+(i*58),Y+7,A1.Courant+i,12,4) ;\r
+ call track (X+10,Y+(i*38),A2.Courant+i,12,4) ;\r
+ for j:=1 to max\r
+ do\r
+ if Aff_Num_Grd or M(j+A1.Courant,i+A2.Courant)<=9999999 and\r
+ M(j+A1.Courant,i+A2.Courant)>=-100000\r
+ then\r
+ call track (X-21+(i*58),Y+(j*38),M(j+A1.Courant,i+A2.Courant),12,4) ;\r
+ else\r
+ call outstring (X-21+(i*58),Y+(j*38)," #####",4,12) ;\r
+ fi ;\r
+ od ;\r
+ od ;\r
+ end AFF_MATRICE ;\r
+ \r
+ (* Test si un clique a eu lieu sur un des bouton (+ ou -) de l'ascenseur,\r
+ enventuellement modifie la valeur de courant de l'ascenseur et\r
+ bouge l'ascenseur *)\r
+ unit MOUVE_ASC : procedure (M : arrayof arrayof integer;\r
+ A : ASCENSEUR;NumSouris, X_S, Y_S : integer) ;\r
+ begin\r
+ if (A.BMoins.BOUTON_ENFONCE (1,NumSouris,X_S, Y_S))\r
+ then\r
+ if (A.Courant<A.Max)\r
+ then\r
+ (* si le bouton - de l'ascenseur est cliquer et que la valeure courant\r
+ est plus petite que la valeur maximale, alors on bouge l'ascenseur,\r
+ on d\82cr\82ment la valeure courant et on r\82affiche la matrice *)\r
+ A.Courant:=A.Courant+1 ;\r
+ call A.BOUGE_ASC (True) ;\r
+ call AFF_MATRICE (M) ;\r
+ fi ;\r
+ fi ;\r
+ if (A.BPlus.BOUTON_ENFONCE(1,NumSouris,X_S, Y_S))\r
+ then\r
+ if (A.Courant>0)\r
+ then\r
+ (* si le bouton + de l'ascenseur est cliquer et que la valeure courant\r
+ est sup\82rieure \85 0, alors on bouge l'ascenseur, on d\82cr\82ment la\r
+ valeure courant et on r\82affiche la matrice *)\r
+ A.Courant:=A.Courant-1 ;\r
+ call A.BOUGE_ASC (True) ;\r
+ call AFF_MATRICE (M) ;\r
+ fi ;\r
+ fi ;\r
+ end MOUVE_ASC ;\r
+ \r
+ (* Efface une fen\88tre *)\r
+ unit EFF_WINDOWS : procedure ;\r
+ begin\r
+ call A1.BPlus.EFF_BOUTON ;\r
+ call A2.BPlus.EFF_BOUTON ;\r
+ call A1.BMoins.EFF_BOUTON ;\r
+ call A2.BMoins.EFF_BOUTON ;\r
+ call Fond_Win.EFF_BOUTON ;\r
+ call Fond_Win.EFF_BOUTON ;\r
+ call Taille.EFF_BOUTON ;\r
+ end EFF_WINDOWS;\r
+ \r
+ begin\r
+ Fond_Win:=new BOUTON (X,Y,X+270,Y+180,3,12,13,5) ;\r
+ Taille:= new BOUTON (X+270,Y+180,X+290,Y+200,0,15,15,15) ;\r
+ call Fond_Win.AFF_BOUTON ;\r
+ call Color (0) ;\r
+ (* double cadre dans la fen\88tre *)\r
+ call Move (X+34,Y+4) ; call Draw (X+34,Y+176) ;\r
+ call Move (X+36,Y+4) ; call Draw (X+36,Y+176) ;\r
+ call Move (X+4,Y+27) ; call Draw (X+266,Y+27) ;\r
+ call Move (X+4,Y+29) ; call Draw (X+266,Y+29) ;\r
+ for i:=1 to 3\r
+ do\r
+ (* Cadre s\82parant les valeures *)\r
+ call Move (X+36+(i*58),Y+4) ; call Draw (X+36+(i*58),Y+176) ;\r
+ call Move (X+4,Y+29+(i*38)) ; call Draw (X+266,Y+29+(i*38)) ;\r
+ od ;\r
+ A1 := new ASCENSEUR(True,maxi-4,X,Y+180,270,7,8,15) ;\r
+ A2 := new ASCENSEUR(False,maxi-4,X+270,Y,180,7,8,15) ;\r
+ call A1.AFF_ASC ;\r
+ call A2.AFF_ASC ;\r
+ call Taille.AFF_BOUTON ;\r
+ call Outstring (X+7,Y+10,Titre,12,4) ;\r
+ call track (X+273,Y+184,Maxi,15,0) ;\r
+ end WINDOWS ;\r
+ (********** WINDOWS *********)\r
+ \r
+ (********** AIDE *********)\r
+ (* Class g\82rant les diff\82rents \82cran d'aide\r
+ B1 .. B6 : Six bouton permettant l'affichage des menu d'aide,\r
+ FinAide : Bool\82en qui permet de quitter le menu d'aide,\r
+ Interrupt, x_s, y_s, Key1, Key2, Flags, Num_Mouse : Permet la\r
+ gestion des \82v\8anement de la souris *)\r
+ unit AIDE : procedure ;\r
+ var B1, B2, B3, B4, B5, B6 : BOUTON,\r
+ FinAIDE, Interupt : Boolean,\r
+ x_s,y_s,Key1,Key2,Flags,Num_Mouse : integer ;\r
+ \r
+ (* Texte du menu g\82n\82ral *)\r
+ unit AIDE_GRL : procedure ;\r
+ begin\r
+ call outstring (170, 80,"Pour utiliser cette aide cliquez sur le bouton",0,3) ;\r
+ call outstring (170,100,"de votre choix.",0,3) ;\r
+ call outstring (170,130,"Vous trouverez une aide sur :",0,3) ;\r
+ call outstring (170,155," -->",0,3) ;\r
+ call outstring (219,155,"Menu :",4,3) ;\r
+ call outstring (170,175," Explication des choix du menu.",0,3) ;\r
+ call outstring (170,200," -->",0,3) ;\r
+ call outstring (219,200,"Principe du calcul :",4,3) ;\r
+ call outstring (170,220," STRASSEN ou diviser pour r\82gner.",0,3) ;\r
+ call outstring (170,245," -->",0,3) ;\r
+ call outstring (219,245,"Am\82lioration :",4,3) ;\r
+ call outstring (170,265," Comment utiliser des matrices de grandeurs",0,3) ;\r
+ call outstring (170,285," diff\82rentes.",0,3) ;\r
+ call outstring (170,310,"Remarques Le signe '>' dans les menus signifie",5,3) ;\r
+ call outstring (170,330," qu'une fen\88tre d\82pend de ce menu.",5,3);\r
+ call outstring (170,360," Vous pouvez activer un choix du menu",5,3);\r
+ call outstring (170,380," soit en cliquant dessus, soit en tapant",5,3);\r
+ call outstring (170,400," la lettre en noire.",5,3);\r
+ \r
+ end AIDE_GRL ;\r
+ \r
+ (* Texte du menu "Aide" *)\r
+ unit AIDE_MENU : procedure ;\r
+ begin\r
+ call outstring (170,75,"Quitter :",4,3) ;\r
+ call outstring (170,95," Retourne au syst\8ame d'exploitation.",0,3) ;\r
+ call outstring (170,120,"Variables :",4,3) ;\r
+ call outstring (170,140," Affichage de l'\82tat des 7 variables de travail",0,3) ;\r
+ call outstring (170,160," ainsi que le nombre de multiplications et",0,3) ;\r
+ call outstring (170,180," d'additions utilis\82es en r\82cursif normal, ou par",0,3) ;\r
+ call outstring (170,200," STRASSEN.",0,3) ;\r
+ call outstring (170,225,"Suite :",4,3) ;\r
+ call outstring (170,245," Etape suivante du calcul.",0,3) ;\r
+ call outstring (170,270,"R\82sultat :",4,3) ;\r
+ call outstring (170,290," Calcul direct (pas d'\82tapes interm\82diaires).",0,3) ;\r
+ call outstring (170,315,"Affichage :",4,3) ;\r
+ call outstring (170,335," Permet de changer le format des grands nombres.",0,3) ;\r
+ call outstring (170,360,"Aide :",4,3) ;\r
+ call outstring (170,380," Pour que la vie soit plus douce ....",0,3) ;\r
+ end ;\r
+ \r
+ (* Texte du menu "Calcul" *)\r
+ unit AIDE_CAL : procedure ;\r
+ begin\r
+ call outstring (170,100,"Soit \85 multiplier 2 matrices n x n.",0,3) ;\r
+ call outstring (170,130,"Principe :",0,3) ;\r
+ call outstring (170,160,"1. Si n > 2 : Calcul de 7 matrices n/2 x n/2",0,3) ;\r
+ call outstring (170,180," Remarque : A chaque fois qu'un produit de",0,3) ;\r
+ call outstring (170,200," sous_matrices sera rencontr\82 dans le calcul,",0,3) ;\r
+ call outstring (170,220," il faudra refaire de m\88me; d'o\97 la r\82cursivit\82.",0,3) ;\r
+ call outstring (170,250,"2. Sinon : Les diff\82rentes composantes de la",0,3) ;\r
+ call outstring (170,270," matrice_r\82sultat se d\82duisent directement en",0,3) ;\r
+ call outstring (170,290," rempla\87ant la m\82thode classique du produit ",0,3) ;\r
+ call outstring (170,310," scalaire par une m\82thode propre \85 Strassen.",0,3) ;\r
+ call outstring (170,330,"N.B. : On \82conomise une multiplication pour",0,3) ;\r
+ call outstring (170,350," plusieurs additions.",0,3) ;\r
+ end AIDE_CAL ;\r
+ \r
+ (* Texte du menu "Am\82lioration" *)\r
+ unit AIDE_AMEL : procedure ;\r
+ begin\r
+ call outstring (170,100,"L'algorithme de STRASSEN n\82cessite deux matrices",0,3) ;\r
+ call outstring (170,130,"carr\82es de taille identique et dont l'ordre doit",0,3) ;\r
+ call outstring (170,160,"\88tre sous la forme d'une puissance exacte de deux",0,3) ;\r
+ call outstring (170,190,"(ordre = 2 ).",0,3) ;\r
+ call outstring (170+80,180,"k",0,3) ;\r
+ call outstring (170,230,"Le programme accepte des matrices ne satisfaisant",0,3) ;\r
+ call outstring (170,260,"pas \85 ces conditions. Il ajuste ensuite celles-ci",0,3) ;\r
+ call outstring (170,290,"en compl\82tant, \82ventuellement, avec des 0.",0,3) ;\r
+ call outstring (170,330,"Le programme laisse donc \85 l'utilisateur une plus",0,3) ;\r
+ call outstring (170,360,"grande souplesse d'utilisation.",0,3) ;\r
+ end AIDE_AMEL ;\r
+ \r
+ \r
+ begin\r
+ (* Bouton du fond de l'aide *)\r
+ B1:=new BOUTON (150,31,600,431,2,3,11,1) ;\r
+ (* Bouton du fond du menu de l'aide *)\r
+ B2:=new BOUTON (156,37,256,60,2,7,15,8) ;\r
+ (* Bouton du menu "Menu" *)\r
+ B3:=new BOUTON (258,37,358,60,2,7,15,8) ;\r
+ (* Bouton du menu "Calcul" *)\r
+ B4:=new BOUTON (360,37,490,60,2,7,15,8) ;\r
+ (* Bouton du menu "Am\82lioration" *)\r
+ B5:=new BOUTON (492,37,592,60,2,7,15,8) ;\r
+ (* Bouton du menu "Fermer" *)\r
+ B6:=new BOUTON (160,70,580,421,0,3,3,3) ;\r
+ call B1.AFF_BOUTON ;\r
+ call B2.AFF_BOUTON ;\r
+ call outstring (162,40,"Menu >",1,7) ;\r
+ call outstring (162,40,"M",0,7) ;\r
+ call B3.AFF_BOUTON ;\r
+ call outstring (264,40,"Calcul >",1,7) ;\r
+ call outstring (264,40,"C",0,7) ;\r
+ call B4.AFF_BOUTON ;\r
+ call outstring (366,40,"Am\82lioration >",1,7) ;\r
+ call outstring (366,40,"A",0,7) ;\r
+ call B5.AFF_BOUTON ;\r
+ call outstring (498,40,"Fermer",1,7) ;\r
+ call outstring (498,40,"F",0,7) ;\r
+ call B6.AFF_BOUTON ;\r
+ call AIDE_GRL ;\r
+ FinAIDE:=False ;\r
+ while (not FinAIDE)\r
+ do\r
+ Interupt:=getpress(x_s,y_s,Key1,Key2,Flags,Num_Mouse) ;\r
+ if Interupt and (Num_Mouse=1 or key2=102 or key2=109 or\r
+ key2=99 or key2=97)\r
+ then\r
+ if B5.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=102\r
+ then\r
+ (* On ferme ... *)\r
+ FinAIDE:=True ;\r
+ call B6.EFF_BOUTON ;\r
+ call B5.EFF_BOUTON ;\r
+ call B3.EFF_BOUTON ;\r
+ call B2.EFF_BOUTON ;\r
+ call B1.EFF_BOUTON ;\r
+ fi ;\r
+ if B2.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=109\r
+ then\r
+ (* Appel \85 l'aide sur les menus *)\r
+ call B6.EFF_BOUTON ;\r
+ call B6.AFF_BOUTON ;\r
+ call AIDE_MENU ;\r
+ fi ;\r
+ if B3.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=99\r
+ then\r
+ (* Appel \85 l'aide sur le calcul *)\r
+ call B6.EFF_BOUTON ;\r
+ call B6.AFF_BOUTON ;\r
+ call AIDE_CAL ;\r
+ fi ;\r
+ if B4.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=97\r
+ then\r
+ (* Appel \85 l'aide sur l'am\82lioration *)\r
+ call B6.EFF_BOUTON ;\r
+ call B6.AFF_BOUTON ;\r
+ call AIDE_AMEL ;\r
+ fi ;\r
+ fi ;\r
+ od ;\r
+ end AIDE;\r
+ (********** AIDE *********)\r
+ \r
+ \r
+ unit AFF_NUM : procedure (X, Y : integer, M : arrayof arrayof integer) ;\r
+ var B1, B2, B3 : BOUTON,\r
+ FinAFF, Interupt : Boolean,\r
+ x_s,y_s,Key1,Key2,Flags,Num_Mouse : integer ;\r
+ begin\r
+ B1:=new BOUTON (X,Y,X+380,Y+300,2,3,11,1) ;\r
+ B2:=new BOUTON (X+10,Y+270,X+160,Y+290,2,7,8,15) ;\r
+ B3:=new BOUTON (X+270,Y+270,X+370,Y+290,2,7,8,15) ;\r
+ call B1.AFF_BOUTON ;\r
+ call B2.AFF_BOUTON ;\r
+ call B3.AFF_BOUTON ;\r
+ call outstring (X+15,Y+50," AFFICHAGE DES GRANDS NOMBRES",4,3) ;\r
+ call outstring (X+15,Y+90,"Les grands nombres (> 9999999 et <-100000)",0,3) ;\r
+ call outstring (X+15,Y+120,"risquent de provoquer des affichages",0,3) ;\r
+ call outstring (X+15,Y+150,"disgracieux. Ces nombres sont donc, par",0,3) ;\r
+ call outstring (X+15,Y+180,"d\82faut remplac\82s par des #####. Si toutefois",0,3) ;\r
+ call outstring (X+15,Y+210,"vous souhaitez afficher ces valeurs, cliquez",0,3) ;\r
+ call outstring (X+15,Y+240,"sur 'Affiche num\82rique'.",0,3) ;\r
+ call outstring (X+275,Y+273,"Fermer",1,7) ;\r
+ call outstring (X+275,Y+273,"F",0,7) ;\r
+ if Aff_Num_Grd\r
+ then\r
+ call outstring (X+15,Y+273,"Affiche ##### ",1,7) ;\r
+ else\r
+ call outstring (X+15,Y+273,"Affiche num\82rique",1,7) ;\r
+ fi ;\r
+ call outstring (X+15,Y+273,"A",0,7) ;\r
+ FinAFF:=False ;\r
+ while (not FinAFF)\r
+ do\r
+ Interupt:=getpress(x_s,y_s,Key1,Key2,Flags,Num_Mouse) ;\r
+ if Interupt and (Num_Mouse=1 or key2=102 or key2=97)\r
+ then\r
+ if B3.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=102\r
+ then\r
+ FinAFF:=True ;\r
+ call B3.EFF_BOUTON ;\r
+ call B2.EFF_BOUTON ;\r
+ call B1.EFF_BOUTON ;\r
+ fi ;\r
+ if B2.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=97\r
+ then\r
+ FinAFF:=True ;\r
+ call B3.EFF_BOUTON ;\r
+ call B2.EFF_BOUTON ;\r
+ call B1.EFF_BOUTON ;\r
+ if Aff_Num_Grd\r
+ then\r
+ Aff_Num_Grd:=False ;\r
+ else\r
+ Aff_Num_Grd:=True ;\r
+ fi ;\r
+ call W3.AFF_MATRICE (M) ;\r
+ fi ;\r
+ fi ;\r
+ od ;\r
+ end AFF_NUM;\r
+ \r
+ \r
+ (* Procedure de saisie d'une matrice *)\r
+ unit SAISIE_MATRICE : procedure (Mat : String ;\r
+ output M : Arrayof arrayof integer) ;\r
+ var Bouton_Saisie, Bout_Pourcent : BOUTON,\r
+ i, j, n1, n2, Nb : integer ;\r
+ begin\r
+ Bouton_Saisie := new BOUTON (50,230,400,430,3,7,15,8) ;\r
+ Bout_Pourcent := new BOUTON (70,390,370,410,3,7,8,15) ;\r
+ \r
+ call Bouton_Saisie.AFF_BOUTON ;\r
+ call outstring (120,240,"SAISIE DE LA MATRICE",4,7) ;\r
+ call outstring (290,240,Mat,4,7) ;\r
+ call outstring (60,270,"Nombre de lignes (de 1 \85 32) :",0,7) ;\r
+ (* Nombre de lignes et de colonnes ??? *)\r
+ n1:=hfont(330,270,4,1,32,1,8,0,15) ;\r
+ call outstring (60,290,"Nombre de colonnes (de 1 \85 32) :",0,7) ;\r
+ n2:=hfont(330,290,4,1,32,1,8,0,15) ;\r
+ \r
+ M:= CREATION (n1,n2) ;\r
+ \r
+ call Bouton_Saisie.EFF_BOUTON ;\r
+ call Bouton_Saisie.AFF_BOUTON ;\r
+ call outstring (120,240,"SAISIE DE LA MATRICE",4,7) ;\r
+ call outstring (290,240,Mat,4,7) ;\r
+ call Bout_Pourcent.AFF_BOUTON ;\r
+ call outstring (70,270,"Entrez la valeur pour la ligne : ",0,7) ;\r
+ call outstring (70,290," et de la colonne : ",0,7) ;\r
+ call outstring (70,310," (valeur entre -999 et 999)",0,7) ;\r
+ call outstring (70,370,"0 % SAISIE 100 % ",1,7) ;\r
+ \r
+ nb:=0 ;\r
+ for j:=1 to upper(M)\r
+ do\r
+ call outstring(355,270," ",7,0) ;\r
+ call track (355,270,j,0,7) ;\r
+ for i:=1 to upper(M(j))\r
+ do\r
+ call outstring(355,290," ",7,0) ;\r
+ call track (355,290,i,0,7) ;\r
+ (* saisie des matrices *)\r
+ M(j,i):=hfont(330,310,6,-999,999,0,8,0,15) ;\r
+ nb:=nb+1 ;\r
+ (* remplissage de la barre de pourcentage *)\r
+ call patern(74,394,74+(292*(nb)/(n1*n2)),406,1,1) ;\r
+ od ;\r
+ od ;\r
+ call Bouton_Saisie.EFF_BOUTON ;\r
+ end SAISIE_MATRICE ;\r
+ \r
+ unit HORLOGE : procedure ;\r
+ begin\r
+ (* on fait tourner l'aiguille de l'horloge*)\r
+ call color (7) ;\r
+ call move (395,245) ;\r
+ case Num\r
+ when 2 : call draw(395,245-8) ;\r
+ when 3 : call draw(395+8,245-8) ;\r
+ when 4 : call draw(395+8,245) ;\r
+ when 5 : call draw(395+8,245+8) ;\r
+ when 6 : call draw(395,245+10) ;\r
+ when 7 : call draw(395-8,245+8) ;\r
+ when 8 : call draw(395-8,245) ;\r
+ when 1 : call draw(395-8,245-8) ;\r
+ esac ;\r
+ call color (15) ;\r
+ call move (395,245) ;\r
+ case Num\r
+ when 1 : Num:=2 ; call draw(395,245-8) ;\r
+ when 2 : Num:=3 ; call draw(395+8,245-8) ;\r
+ when 3 : Num:=4 ; call draw(395+8,245) ;\r
+ when 4 : Num:=5 ; call draw(395+8,245+8) ;\r
+ when 5 : Num:=6 ; call draw(395,245+10) ;\r
+ when 6 : Num:=7 ; call draw(395-8,245+8) ;\r
+ when 7 : Num:=8 ; call draw(395-8,245) ;\r
+ when 8 : Num:=1 ; call draw(395-8,245-8) ;\r
+ esac ;\r
+ end ;\r
+ \r
+ \r
+ (* Procedure de d\82roulement pas \85 pas de l'algo. de Strassen *)\r
+ unit PASAPAS : procedure (M : arrayof arrayof integer ;\r
+ VarTmp : arrayof integer ; Nb : integer) ;\r
+ var Interupt, Reprise : boolean,\r
+ i, x_s, y_s, Key1, Key2, Flags, Num_Mouse : integer ;\r
+ begin\r
+ if (not Menu)\r
+ then\r
+ (* La premi\8are fois on fait ...\r
+ Affichage du curseur,\r
+ initialisation des boutons,\r
+ affichage du menu,\r
+ affichage des trois matrices. *)\r
+ call showcursor ;\r
+ (* Bouton1 : Bouton du fond du menu *)\r
+ Bouton1:=new BOUTON (0,0,639,30,3,9,11,1) ;\r
+ \r
+ (* B2 .. B6 : Boutons menu (Quitte, Variables, suite, R\82sultat, Aide). *)\r
+ Bouton2:=new BOUTON (4,4,100,26,0,9,1,11) ;\r
+ Bouton3:=new BOUTON (102,4,202,26,0,9,1,11) ;\r
+ Bouton4:=new BOUTON (204,4,304,26,0,9,1,11) ;\r
+ Bouton5:=new BOUTON (306,4,406,26,0,9,1,11) ;\r
+ Bouton12:=new BOUTON (408,4,508,26,0,9,1,11) ;\r
+ Bouton6:=new BOUTON (510,4,610,26,0,9,1,11) ;\r
+ \r
+ (* Boutons contextuelles (7 Variables, 8 fin variables,\r
+ 10 calcul direct). *)\r
+ Bouton7:=new BOUTON (102,31,252,371,3,3,11,1) ;\r
+ Bouton8:=new BOUTON (147,330,207,355,2,7,8,15) ;\r
+ \r
+ call Bouton1.AFF_BOUTON ;\r
+ call Bouton2.AFF_BOUTON ;\r
+ call Outstring (9,7,"Quitter",10,9) ;\r
+ call Outstring (9,7,"Q",0,9) ;\r
+ call Bouton3.AFF_BOUTON ;\r
+ call Outstring (107,7,"Variables >",10,9) ;\r
+ call Outstring (107,7,"V",0,9) ;\r
+ call Bouton4.AFF_BOUTON ;\r
+ call Outstring (209,7,"Suite",10,9) ;\r
+ call Outstring (209,7,"S",0,9) ;\r
+ call Bouton5.AFF_BOUTON ;\r
+ call Outstring (311,7,"R\82sultat",10,9) ;\r
+ call Outstring (311,7,"R",0,9) ;\r
+ call Bouton6.AFF_BOUTON ;\r
+ call Outstring (515,7,"Aide >",10,9) ;\r
+ call Outstring (523,7,"i",0,9) ;\r
+ call Bouton12.AFF_BOUTON ;\r
+ call Outstring (413,7,"Affichage >",10,9) ;\r
+ call Outstring (413,7,"A",0,9) ;\r
+ \r
+ W1:= new WINDOWS("A",upper(V),15,265) ;\r
+ W2:= new WINDOWS("B",upper(V),335,50) ;\r
+ W3:= new WINDOWS("Tmp",0,335,265) ;\r
+ \r
+ call W1.AFF_MATRICE (V) ;\r
+ call W2.AFF_MATRICE (W) ;\r
+ \r
+ Menu:=true ;\r
+ fi ;\r
+ \r
+ if (nb=1 and (Bouton4.BOUTON_Aff or Bouton5.BOUTON_Aff))\r
+ then\r
+ (* si les calculs sont finis mais qu'il reste les boutons\r
+ suite et r\82sultat, alors on les effaces *)\r
+ call Bouton4.EFF_BOUTON ;\r
+ call Bouton5.EFF_BOUTON ;\r
+ W3.Titre:="Res" ;\r
+ call Outstring (342,275,"Res",12,4) ;\r
+ fi ;\r
+ \r
+ if (B_PasAPAS or nb=1)\r
+ then\r
+ (* Si on est toujours en Pas \85 Pas ou que les calculs sont fini,\r
+ on attend un clique sur quitter, suite ou r\82sultat. *)\r
+ if Bouton10.Bouton_Aff\r
+ then\r
+ call Bouton10.EFF_BOUTON ;\r
+ fi ;\r
+ W3.Maxi:=upper(M) ;\r
+ W3.A1.Max:=upper(M)-4 ;\r
+ W3.A2.Max:=upper(M)-4 ;\r
+ call W3.Taille.EFF_BOUTON ;\r
+ call W3.Taille.AFF_BOUTON ;\r
+ call track (W3.X+273,W3.Y+184,W3.Maxi,15,0) ;\r
+ call W3.AFF_MATRICE (M) ;\r
+ Reprise:=false ;\r
+ while (not reprise)\r
+ do\r
+ Interupt:= getpress(x_s, y_s, Key1, Key2, Flags, Num_Mouse) ;\r
+ if Interupt and (Num_Mouse=1 or Key2=97 or Key2=102 or Key2=105 or\r
+ (Key2>112 and Key2<116) or Key2=118)\r
+ then\r
+ (* Si le bouton gauche de la souris est enfonc\82 alors *)\r
+ if Bouton7.BOUTON_Aff\r
+ then\r
+ if Bouton8.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or key2=102\r
+ then\r
+ (* Si le menu Variables est ouvert et que l'on a cliquer\r
+ sur fermer alors ... *)\r
+ call Bouton8.EFF_BOUTON ;\r
+ call Bouton7.EFF_BOUTON ;\r
+ fi ;\r
+ else\r
+ if Bouton2.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or key2=113\r
+ then\r
+ (* Clique sur quitter *)\r
+ call groff ;\r
+ call endrun ;\r
+ fi ;\r
+ if Bouton3.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=118\r
+ then\r
+ call Bouton7.AFF_BOUTON ;\r
+ if nb>1\r
+ then\r
+ (* clique variables *)\r
+ for i:=1 to 7\r
+ do\r
+ call outstring (113,30+(i*20),"x :",10,3) ;\r
+ call track(123,33+(i*20),i,3,10) ;\r
+ call track(153,30+(i*20),VarTmp(i),3,10) ;\r
+ od ;\r
+ fi ;\r
+ call outstring (108,200,"M\82thode STRASSEN",4,3) ;\r
+ call outstring (108,270,"M\82thode normale",4,3) ;\r
+ call outstring (113,220,"Xø :",1,3) ;\r
+ call track (153,220,Opp(1),3,10) ;\r
+ call outstring (113,240,"+ø :",1,3) ;\r
+ call track (153,240,Opp(2),3,10) ;\r
+ call outstring (113,290,"Xø :",1,3) ;\r
+ call track (153,290,Opp(3),3,10) ;\r
+ call outstring (113,310,"+ø :",1,3) ;\r
+ call track (153,310,Opp(4),3,10) ;\r
+ call Bouton8.AFF_BOUTON ;\r
+ call Outstring (153,335,"Fermer",1,7) ;\r
+ call Outstring (153,335,"F",0,7) ;\r
+ fi ;\r
+ if Bouton4.BOUTON_Aff and (Bouton4.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=115)\r
+ then\r
+ (* clique sur suite *)\r
+ Reprise:=True ;\r
+ fi ;\r
+ if Bouton5.BOUTON_Aff and (Bouton5.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=114)\r
+ then\r
+ (* clique sur r\82sultat *)\r
+ call Bouton4.EFF_BOUTON ;\r
+ call Bouton5.EFF_BOUTON ;\r
+ W3.Titre:="Res" ;\r
+ call Outstring (342,275,"Res",12,4) ;\r
+ Reprise:=True ;\r
+ B_PasAPAS := False ;\r
+ call Bouton10.AFF_BOUTON ;\r
+ call outstring (310,210,"Patience, je calcule.",0,7) ;\r
+ Num:=1 ;\r
+ \r
+ call patern(380,230,410,260,0,0) ;\r
+ call move (380,230) ; call draw (384,234) ;\r
+ call move (380,260) ; call draw (384,256) ;\r
+ call move (410,260) ; call draw (406,256) ;\r
+ call move (410,230) ; call draw (406,234) ;\r
+ \r
+ call move (380,245) ; call draw (384,245) ;\r
+ call move (410,245) ; call draw (406,245) ;\r
+ call move (395,230) ; call draw (395,234) ;\r
+ call move (395,260) ; call draw (395,256) ;\r
+ fi ;\r
+ if Bouton6.BOUTON_Aff and Bouton6.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=105\r
+ then\r
+ (* clique sur aide *)\r
+ call AIDE ;\r
+ fi ;\r
+ if Bouton12.BOUTON_ENFONCE(1,Num_Mouse,x_s,y_s) or Key2=97\r
+ then\r
+ (* clique sur afficahge des nombres *)\r
+ call AFF_NUM (100,100,M) ;\r
+ fi ;\r
+ call W1.MOUVE_ASC(V,W1.A1,Num_Mouse,X_S,Y_S) ;\r
+ call W1.MOUVE_ASC(V,W1.A2,Num_Mouse,X_S,Y_S) ;\r
+ call W2.MOUVE_ASC(W,W2.A1,Num_Mouse,X_S,Y_S) ;\r
+ call W2.MOUVE_ASC(W,W2.A2,Num_Mouse,X_S,Y_S) ;\r
+ call W3.MOUVE_ASC(M,W3.A1,Num_Mouse,X_S,Y_S) ;\r
+ call W3.MOUVE_ASC(M,W3.A2,Num_Mouse,X_S,Y_S) ;\r
+ fi ;\r
+ fi ;\r
+ od ;\r
+ else\r
+ call HORLOGE ;\r
+ fi ;\r
+ if (Nb=1)\r
+ then\r
+ call groff ;\r
+ fi ;\r
+ end PASAPAS ;\r
+ \r
+ \r
+ (* Gestion de l'\82cran de pr\82sentation *)\r
+ unit PRESENTATION : procedure ;\r
+ Var Bout_Pres : BOUTON,\r
+ i, j, touche_pres,x_s, y_s, special, flags, Etat_souris : integer,\r
+ Map : arrayof integer,\r
+ Interupt:boolean,\r
+ Stars : arrayof arrayof integer ;\r
+ \r
+ (* Allume des \82toiles sur le fond *)\r
+ unit ALLUME : procedure (Num : integer) ;\r
+ begin\r
+ Stars(Num,1):=Random*638 ;\r
+ Stars(Num,2):=Random*478 ;\r
+ Stars(Num,3):=Random*200 ;\r
+ Stars(Num,4):=Random*15 ;\r
+ if ((Stars(Num,1)>174) and (Stars(Num,1)<466) and\r
+ (Stars(Num,2)>139) and (Stars(Num,2)<341))\r
+ then\r
+ Stars(Num,3):=0 ;\r
+ fi ;\r
+ if Stars(Num,3)>0\r
+ then\r
+ call color (Stars(Num,4)) ;\r
+ call Point (Stars(Num,1),Stars(Num,2)) ;\r
+ call Point (Stars(Num,1)+1,Stars(Num,2)) ;\r
+ call Point (Stars(Num,1),Stars(Num,2)+1) ;\r
+ call Point (Stars(Num,1)+1,Stars(Num,2)+1) ;\r
+ fi ;\r
+ end ALLUME ;\r
+ \r
+ (* Efface les \82toiles *)\r
+ unit ETEIND : procedure (Num : integer) ;\r
+ begin\r
+ if not ((Stars(Num,1)>174) and (Stars(Num,1)<466) and\r
+ (Stars(Num,2)>139) and (Stars(Num,2)<341))\r
+ then\r
+ call color (0) ;\r
+ call Point(Stars(Num,1),Stars(Num,2)) ;\r
+ call Point (Stars(Num,1)+1,Stars(Num,2)) ;\r
+ call Point (Stars(Num,1),Stars(Num,2)+1) ;\r
+ call Point (Stars(Num,1)+1,Stars(Num,2)+1) ;\r
+ fi ;\r
+ end ETEIND ;\r
+ \r
+ begin\r
+ call gron(0) ;\r
+ call ranset(100) ;\r
+ array Stars dim (1:50) ;\r
+ for i:=1 to 50\r
+ do\r
+ array Stars(i) dim (1:4) ;\r
+ call ALLUME(i) ;\r
+ od ;\r
+ \r
+ Bout_Pres:=new BOUTON (175,140,465,340,4,7,15,8) ;\r
+ call Bout_Pres.AFF_BOUTON ;\r
+ call color (1) ;\r
+ call move (190,155) ; call draw (450,155) ;\r
+ call draw (450,217) ; call draw (190,217) ;\r
+ for i:=1 to 30\r
+ do\r
+ call move (190,155+(i*2)) ; call draw (230,155+(i*2)) ;\r
+ od ;\r
+ call color (7) ;\r
+ for i:=0 to 1\r
+ do\r
+ call move (226,159+(i*2)) ; call draw (194+i,159+(i*2)) ;\r
+ call draw (194+i,187-(i*2)) ; call draw (225+i,187-(i*2)) ;\r
+ call draw (225+i,211+(i*2)) ; call draw (194,211+(i*2)) ;\r
+ od ;\r
+ call outstring (236,200,"trassen",1,7) ;\r
+ call outstring (188,230,"Multiplication de deux matrices",4,7) ;\r
+ call outstring (188,250,"selon l'algorithme de STRASSEN.",4,7) ;\r
+ call outstring (188,275,"Auteurs : AKPAMOLI E. HANNOYER P.",0,7) ;\r
+ call outstring (188,295,"R\82alis\82 en Loglan [Janvier 1995]",0,7) ;\r
+ call color (5) ;\r
+ call patern(184,273,450,310,5,0) ;\r
+ for i:=1 to 2\r
+ do\r
+ call move (450+(i*2),273+(7*i)) ;\r
+ call draw (450+(i*2),310+(2*i)) ;\r
+ call draw (184+(i*7),310+(2*i)) ;\r
+ od ;\r
+ Map:=GET_MAP (Bout_Pres.X,Bout_Pres.Y,Bout_Pres.XX,Bout_Pres.YY) ;\r
+ call outstring (188,315,"<Entr\82e> pour continuer ...",15,7) ;\r
+ touche_pres:=0 ;\r
+ while (not touche_pres=13)\r
+ do\r
+ for i:=1 to 50\r
+ do\r
+ if Stars(i,3)=0 then\r
+ call ETEIND (i) ;\r
+ call ALLUME (i) ;\r
+ else\r
+ Stars(i,3):=Stars(i,3)-1 ;\r
+ fi ;\r
+ od ;\r
+ Interupt:=getpress(x_s,y_s,special,touche_pres,flags,Etat_souris) ;\r
+ od ;\r
+ for i:=1 to 50\r
+ do\r
+ call ETEIND (i) ;\r
+ od ;\r
+ call Bout_Pres.EFF_BOUTON ;\r
+ call Bout_Pres.CHG_BOUTON_XY(15,50) ;\r
+ call Bout_Pres.AFF_BOUTON ;\r
+ call PUT_MAP (Bout_Pres.X,Bout_Pres.Y,Map) ;\r
+ call init (1,0) ;\r
+ end PRESENTATION;\r
+ \r
+ \r
+ (* FIN PARTIE GRAPHIQUE *)\r
+ \r
+ \r
+ (* DEBUT PARTIE CALCUL *)\r
+ \r
+ (* Retourne deux matrice selon la norme pour le calcul avec l'algo. de\r
+ Strassen (les deux matrices sont de tailles identiques, et leur ordre\r
+ est une puissance enti\8are de deux). *)\r
+ unit AJUSTE_MATRICE : procedure (inout M1, M2 : arrayof arrayof integer) ;\r
+ var i, j : integer,\r
+ Tmp1, Tmp2 : arrayof arrayof integer,\r
+ Calcul, Max : integer ;\r
+ begin\r
+ (* Mais quel est la valeure la plus grande entre les lignes et les colonnes\r
+ des deux tableaux ???? (attention si 1 alors 2). *)\r
+ Max:=imax(2,(imax(imax(upper(M1),upper(M1(1))),imax(upper(M2),upper(M2(1)))))) ;\r
+ Calcul := LN(Max)/LN(2) ;\r
+ if (Calcul<>LN(Max)/LN(2))\r
+ then\r
+ (* Max n'est pas une puissance enti\8are de deux alors normalisons : *)\r
+ Max:=EXPO(2,(Calcul+1)) ;\r
+ fi ;\r
+ if upper(M1)<Max or upper(M1(1))<Max or upper(M2)<Max or upper(M2(1))<Max\r
+ then\r
+ array Tmp1 dim (1:Max) ;\r
+ array Tmp2 dim (1:Max) ;\r
+ for i:=1 to max\r
+ do\r
+ array Tmp1(i) dim (1:Max) ;\r
+ array Tmp2(i) dim (1:Max) ;\r
+ for j:=1 to imax(upper(M1(1)),upper(M2(1)))\r
+ do\r
+ (* Optimisation en ne parcourant que au maximum les colonnes du\r
+ plus grand des deux Matrices M1 ou M2 *)\r
+ if i <= upper(M1) and j <= upper (M1(1))\r
+ then\r
+ (* on ne rempli que les cases de Tmp1 qu'avec les cases\r
+ de M1 qui \82taient saisies *)\r
+ Tmp1(i,j):=M1(i,j) ;\r
+ fi ;\r
+ if i <= upper(M2) and j <= upper (M2(1))\r
+ then\r
+ (* on ne rempli que les cases de Tmp2 qu'avec les cases\r
+ de M2 qui \82taient saisies *)\r
+ Tmp2(i,j):=M2(i,j) ;\r
+ fi ;\r
+ od ;\r
+ od ;\r
+ M1:=Tmp1 ;\r
+ M2:=Tmp2 ;\r
+ fi ;\r
+ end AJUSTE_MATRICE;\r
+ \r
+ \r
+ (* Fonction retournant une matrice de n1 x n2 *)\r
+ unit CREATION: function (lignes,colonnes:integer) : arrayof arrayof integer ;\r
+ var i:integer;\r
+ begin\r
+ array result dim(1:lignes);\r
+ for i:=1 to lignes\r
+ do\r
+ array result(i) dim(1:colonnes);\r
+ od;\r
+ end CREATION;\r
+ \r
+ \r
+ (* Fonction retournant le r\82sultat d'une soustraction de deux matrices *)\r
+ unit SOUST_MATRICE:function(X,Y:arrayof arrayof integer):arrayof arrayof integer;\r
+ var i,j:integer;\r
+ begin\r
+ result:=CREATION(upper(X),upper(X));\r
+ for i:=1 to upper(X)\r
+ do\r
+ for j:=1 to upper(X(i))\r
+ do\r
+ result(i,j):=X(i,j)-Y(i,j);\r
+ od\r
+ od\r
+ end SOUST_MATRICE;\r
+ \r
+ (* Fonction retournant le r\82sultat d'une somme de deux matrices *)\r
+ unit SOMME_MATRICE:function(X,Y:arrayof arrayof integer):arrayof arrayof integer;\r
+ var i,j:integer;\r
+ begin\r
+ result:=CREATION(upper(X),upper(X));\r
+ for i:=1 to upper(X)\r
+ do\r
+ for j:=1 to upper(X(i))\r
+ do\r
+ result(i,j):=X(i,j)+Y(i,j);\r
+ od\r
+ od\r
+ end SOMME_MATRICE;\r
+ \r
+ \r
+ (* Fonction retournant une matrice qui est la somme de deux portions d'une\r
+ matrice pass\82 en param\8atre *)\r
+ unit SOMME_PORTION : function(X:arrayof arrayof integer;a,b:integer) :\r
+ arrayof arrayof integer;\r
+ var sous_ordre,i,j:integer;\r
+ begin\r
+ sous_ordre:=upper(X) div 2;\r
+ result:=CREATION(sous_ordre,sous_ordre);\r
+ if a=1\r
+ then\r
+ case b\r
+ when 4 :\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i,j)+X(i+sous_ordre,j+sous_ordre);\r
+ od\r
+ od\r
+ when 2 :\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i,j)+X(i,j+sous_ordre);\r
+ od\r
+ od\r
+ esac\r
+ else\r
+ if a=3 and b=4\r
+ then\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i+sous_ordre,j)+X(i+sous_ordre,j+sous_ordre);\r
+ od\r
+ od\r
+ fi;\r
+ fi;\r
+ end SOMME_PORTION;\r
+ \r
+ \r
+ (* Fonction retournant une matrice qui est la diff\82rence de deux portions\r
+ d'une matrice pass\82 en param\8atre *)\r
+ unit SOUST_PORTION : function(X:arrayof arrayof integer;a,b:integer) :\r
+ arrayof arrayof integer;\r
+ var sous_ordre,i,j:integer;\r
+ begin\r
+ sous_ordre:=upper(X) div 2;\r
+ result:=CREATION(sous_ordre,sous_ordre);\r
+ if a=2 and b=4\r
+ then\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i,j+sous_ordre)-X(i+sous_ordre,j+sous_ordre);\r
+ od\r
+ od\r
+ else\r
+ if a=3 and b=1\r
+ then\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i+sous_ordre,j)-X(i,j);\r
+ od\r
+ od\r
+ fi\r
+ fi\r
+ end SOUST_PORTION;\r
+ \r
+ \r
+ (* Fonction retournant une portion de la matrice X, (retourne\r
+ soit la partie X(1,1) soit la partie X(2,2)). *)\r
+ unit PORTION:function (X : arrayof arrayof integer;a:integer) :\r
+ arrayof arrayof integer;\r
+ var i,j,sous_ordre:integer;\r
+ begin\r
+ sous_ordre:=upper(X) div 2;\r
+ result:=CREATION(sous_ordre,sous_ordre);\r
+ case a\r
+ when 1:\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i,j);\r
+ od\r
+ od\r
+ when 4:\r
+ for i:=1 to sous_ordre\r
+ do\r
+ for j:=1 to sous_ordre\r
+ do\r
+ result(i,j):=X(i+sous_ordre,j+sous_ordre);\r
+ od\r
+ od\r
+ esac\r
+ end PORTION;\r
+ \r
+ \r
+ (* Proc\82dure r\82cursive permettant de multiplier les deux matrices pass\82es en\r
+ param\8atres.\r
+ Nb : Niveau de parcour en profondeur (si = 1 transmis dans PasAPas\r
+ signifie que les calculs sont termin\82s,\r
+ ordre : Ordre des deux Matrices,\r
+ A, B : Deux matrices de travail,\r
+ C : Matrice r\82sultat. *)\r
+ unit STRASSEN:procedure(nb : integer ; ordre:integer; A, B :\r
+ arrayof arrayof integer ; output C:arrayof arrayof integer);\r
+ var i,j,m:integer,\r
+ (* X : tableau contenant les 7 variables de travail *)\r
+ x : arrayof integer,\r
+ (* P1 .. P7 : 7 Matrices temporaires *)\r
+ P1,P2,P3,P4,P5,P6,P7:arrayof arrayof integer;\r
+ begin\r
+ C:=CREATION(ordre,ordre);\r
+ array X dim (1:7) ;\r
+ nb:=nb+1 ;\r
+ if ordre>2\r
+ then\r
+ (* si l'ordre est plus grand que deux en d\82coupe les matrices en\r
+ rappelant r\82cursivement STRASSEN*)\r
+ m:=ordre div 2;\r
+ call STRASSEN(nb,m,SOMME_PORTION(A,1,4),SOMME_PORTION(B,1,4),P1);\r
+ call STRASSEN(nb,m,SOMME_PORTION(A,3,4),PORTION(B,1),P2);\r
+ call STRASSEN(nb,m,PORTION(A,1),SOUST_PORTION(B,2,4),P3);\r
+ call STRASSEN(nb,m,PORTION(A,4),SOUST_PORTION(B,3,1),P4);\r
+ call STRASSEN(nb,m,SOMME_PORTION(A,1,2),PORTION(B,4),P5);\r
+ call STRASSEN(nb,m,SOUST_PORTION(A,3,1),SOMME_PORTION(B,1,2),P6);\r
+ call STRASSEN(nb,m,SOUST_PORTION(A,2,4),SOMME_PORTION(B,3,4),P7);\r
+ for i:=1 to m\r
+ do\r
+ for j:=1 to m\r
+ do\r
+ C(i,j):=SOUST_MATRICE(SOMME_MATRICE(P1,P4),SOUST_MATRICE(P5,P7))(i,j);\r
+ od;\r
+ od;\r
+ for i:=m+1 to ordre\r
+ do\r
+ for j:=1 to m\r
+ do\r
+ C(i,j):=SOMME_MATRICE(P2,P4)(i-m,j);\r
+ od;\r
+ od;\r
+ for i:=1 to m\r
+ do\r
+ for j:=m+1 to ordre\r
+ do\r
+ C(i,j):=SOMME_MATRICE(P3,P5)(i,j-m);\r
+ od;\r
+ od;\r
+ for i:=m+1 to ordre\r
+ do\r
+ for j:=m+1 to ordre\r
+ do\r
+ C(i,j):=SOMME_MATRICE(SOUST_MATRICE(P1,P2),SOMME_MATRICE(P3,P6))(i-m,j-m);\r
+ od;\r
+ od;\r
+ else\r
+ (* calcul des 7 variables de travail *)\r
+ x(1):=(A(1,1)+A(2,2))*(B(1,1)+B(2,2));\r
+ x(2):=(A(2,1)+A(2,2))*B(1,1);\r
+ x(3):=A(1,1)*(B(1,2)-B(2,2));\r
+ x(4):=A(2,2)*(B(2,1)-B(1,1));\r
+ x(5):=(A(1,1)+A(1,2))*B(2,2);\r
+ x(6):=(A(2,1)-A(1,1))*(B(1,1)+B(1,2));\r
+ x(7):=(A(1,2)-A(2,2))*(B(2,1)+B(2,2));\r
+ (* Calcul du nombre d'opp\82ration :\r
+ 1, 2 : xø, +ø pour la m\82thode r\82cursive de Strassen,\r
+ 3, 4 : xø, +ø pour la m\82thode r\82cursive traditionnelle. *)\r
+ Opp(1):=Opp(1)+7 ; Opp(2):= Opp(2) + 18 ;\r
+ Opp(3):=Opp(3)+8 ; Opp(4):= Opp(4) + 4 ;\r
+ (* Calcul de la matrice r\82sultat avec les variables de travail *)\r
+ C(1,1):=x(1)+x(4)-x(5)+x(7);\r
+ C(2,1):=x(2)+x(4);\r
+ C(1,2):=x(3)+x(5);\r
+ C(2,2):=x(1)-x(2)+x(3)+x(6);\r
+ fi ;\r
+ call PASAPAS (C,x,nb) ;\r
+ end STRASSEN;\r
+ \r
+ (* Function calculant A**B *)\r
+ unit EXPO : function (A, B : integer):Integer ;\r
+ begin\r
+ if (B=0)\r
+ then\r
+ result:=1 ;\r
+ else\r
+ result:=EXPO(A,B-1)*A ;\r
+ fi ;\r
+ end EXPO ;\r
+ \r
+ var Prof,Num : integer,\r
+ W1, W2, W3, W4 : WINDOWS ,\r
+ Menu, Aff_Num_Grd, B_PasAPAS : boolean,\r
+ Opp : arrayof integer,\r
+ Bouton1,\r
+ Bouton2, Bouton3, Bouton4, Bouton5, Bouton6, bouton12,\r
+ Bouton7, Bouton8, Bouton10 : Bouton,\r
+ V, W, Z : arrayof arrayof integer ;\r
+ \r
+ begin\r
+ array Opp dim (1:4) ;\r
+ call PRESENTATION ;\r
+ call SAISIE_MATRICE("A",V);\r
+ call SAISIE_MATRICE("B",W);\r
+ call AJUSTE_MATRICE(V,W) ;\r
+ call init (1,1) ;\r
+ B_PasAPAS:=True ;\r
+ Bouton10:=new BOUTON (300,200,490,270,2,7,15,8) ;\r
+ call STRASSEN (Prof,upper(V),V,W,Z) ;\r
+ end ;\r
+ end ;\r
+end STRAS;\r
+ \r
+ \r
--- /dev/null
+program gar;\r
+ \r
+(* DEFINITION DE LA PAGE GRAPHIQUE GENERALE *)\r
+ \r
+BEGIN\r
+ \r
+PREF iiuwgraph BLOCK\r
+ \r
+(* PROCEDURE PAUSE POUR ATTENTE AU CLAVIER *)\r
+ \r
+UNIT PAUSE:procedure;\r
+ VAR touche:char;\r
+BEGIN\r
+ call color(12);\r
+ call move(100,320);\r
+ call outstring(" Appuyer sur ENTREE pour passer a la suite");\r
+ read(touche);\r
+END PAUSE;\r
+ \r
+(* PROCEDURE D ATTENTE PAR BOUCLE ACTIVE *)\r
+ \r
+UNIT attend:procedure(tmp:integer);\r
+ VAR i:integer;\r
+BEGIN\r
+ for i:=0 to tmp * 10 do od;\r
+END attend;\r
+ \r
+(* PROCEDURE D ATTENTE AVEC COMPTEUR POUR LA SORTIE DE L APPLICATION *)\r
+ \r
+UNIT attend_sortie:procedure;\r
+ VAR x,y,i,k,j:integer;\r
+BEGIN\r
+ j:=9;\r
+ x:=300;\r
+ y:=200;\r
+ for k:=1 to 10 do\r
+ call color(11);\r
+ call move(300,200);\r
+ call HASCII(j+48);\r
+ for i:=0 to 4000 do od;\r
+ call color(0);\r
+ call rectangle_double(x,y-1,x+25,y+9);\r
+ call rectangle_double(x+1,y,x+24,y+8);\r
+ call rectangle_double(x+4,y+2,x+22,y+6);\r
+ call rectangle_double(x+5,y+3,x+21,y+5);\r
+ j:=j-1;\r
+ od;\r
+END attend_sortie;\r
+ \r
+(* PAGE DE PRESENTATION GENERALE DE DEBUT *)\r
+ \r
+UNIT presentation:iiuwgraph procedure;\r
+BEGIN\r
+ (* creation d'une bordure*)\r
+ call border(13);\r
+ \r
+ (*creation d'un cadre pour la fenetre*)\r
+ call move(10,10);\r
+ call draw(10,340);\r
+ call draw( 628,340);\r
+ call draw(628,10);\r
+ call draw(10,10);\r
+ call color(2);\r
+ \r
+ (*contenu du titre*)\r
+ call move(180,80);\r
+ call outstring("IMPLEMENTATION D'UNE SIMULATION");\r
+ call move(260,100);\r
+ call outstring("DE GARE SNCF");\r
+ call color(12);\r
+ call move(250,180);\r
+ call outstring("PROJET NUMERO 2");\r
+ call color(14);\r
+ call move(130,280);\r
+ call outstring("PAR : Mr AC'H Fabrice et CLAVERIE Jean-Fran\87ois");\r
+ call move(130,300);\r
+ call outstring(" Mr GOUGEON Jean-Yves et Mr RICHARD Jerome");\r
+ \r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ call PAUSE;\r
+ \r
+ (*appel de l'effacage de l'ecran*)\r
+ call cls;\r
+END presentation;\r
+ \r
+(* FONCTION DEFINISSANT UNE MESSAGE-BOX *)\r
+(* ARGUMENTS : Text_message, Longueur_message, Couleur_text, Coordonnees *)\r
+ \r
+UNIT msgbox : function(message:string,long,couleur,x,y:integer):boolean;\r
+ VAR centrage:integer,reponse:boolean,\r
+ h,v,b,i:integer;\r
+BEGIN\r
+ PREF mouse BLOCK\r
+ BEGIN\r
+ \r
+ (* si texte petit met longueur a 6 par defaut *)\r
+ if(long<6) then long:=6; fi;\r
+ \r
+ call move(x,y);\r
+ call color(couleur);\r
+ call rectangle_double(x,y,x+(long * 9 + 20)+2,y + 52);\r
+ \r
+ (* centrage du texte dans le rectangle *)\r
+ centrage:=((long * 9+20) div 2) - ((long div 2)*8);\r
+ \r
+ for i:=(y + 3) to (y+49) do\r
+ call color(7);\r
+ call move(x+3,i);\r
+ call draw(x+(long * 9) +19 ,i);\r
+ od;\r
+ call color(couleur);\r
+ call move(x+centrage,y+5);\r
+ call outstring(message);\r
+ call color(14);\r
+ \r
+ (* definition des boutons OUI et NON *)\r
+ \r
+ call rectangle(x+centrage+1,y+29,x+centrage+26,y+41);\r
+ call move(x+centrage+2,y+32);\r
+ call outstring("OUI");\r
+ call rectangle(x+(long * 9) -centrage +1,y+29,x+(long * 9) -centrage +26,y+41);\r
+ call move(x+(long * 9) - centrage +2,y+32);\r
+ call outstring("NON");\r
+ call showcursor;\r
+ do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ if(gauche) then\r
+ if((v> y + 29)and(v> y + 32)) then\r
+ if((h>(x+centrage+1))and(h<(x+centrage+26)))\r
+ then reponse:=true; gauche:=false; exit;\r
+ else\r
+ if((h>(x+(long * 9)-centrage +1))and(h<(x+(long * 9)-centrage +26)))\r
+ then reponse:=false;gauche:=false; exit;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ result:=reponse;\r
+ END;\r
+END msgbox;\r
+ \r
+(* PROCEDURE DE TRACAGE DE RECTANGLE SIMPLE *)\r
+ \r
+UNIT rectangle:iiuwgraph procedure(x_h,y_h,x_b,y_b:integer);\r
+BEGIN\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+END rectangle;\r
+ \r
+(* PROCEDURE DE TRACAGE DE RECTANGLE DOUBLE AVEC RECTANGLE SIMPLE *)\r
+ \r
+UNIT rectangle_double : iiuwgraph procedure(x_h,y_h,x_b,y_b:integer);\r
+BEGIN\r
+ call rectangle(x_h,y_h,x_b,y_b);\r
+ call rectangle(x_h+2,y_h+2,x_b-2,y_b-2);\r
+END rectangle_double;\r
+ \r
+(* PROCEDURE DE CHOIX DES PARAMETRES DE LA SIMULATION *)\r
+(* RENVOIE LA DUREE ET LE TYPE DE SIMULATION *)\r
+ \r
+UNIT param : iiuwgraph procedure(inout duree,typ :integer);\r
+ VAR haut,bas:boolean,h,v,b:integer;\r
+BEGIN\r
+ PREF mouse BLOCK\r
+ BEGIN\r
+ \r
+ (*initialisation *)\r
+ haut:=true;\r
+ typ:=0;\r
+ duree:=0;\r
+ h:=0;v:=0;b:=0;\r
+ bas:=true;\r
+ call color(14);\r
+ call move(100,40);\r
+ call outstring(" CHER UTILISATEUR CHOISISSEZ UNE DUREE PARMI :");\r
+ call rectangle_double(100,60,550,100);\r
+ \r
+ (* fait les bares verticales *)\r
+ call move(150,62);\r
+ call draw(150,98);\r
+ call move(200,62);\r
+ call draw(200,98);\r
+ call move(250,62);\r
+ call draw(250,98);\r
+ call move(300,62);\r
+ call draw(300,98);\r
+ call move(350,62);\r
+ call draw(350,98);\r
+ call move(400,62);\r
+ call draw(400,98);\r
+ call move(450,62);\r
+ call draw(450,98);\r
+ call move(500,62);\r
+ call draw(500,98);\r
+ \r
+ (* fin bare verticales *)\r
+ (*texte*)\r
+ call color(15);\r
+ call move(105,78);call outstring("1 min");\r
+ call move(155,78);call outstring("2 min");\r
+ call move(205,78);call outstring("3 min");\r
+ call move(255,78);call outstring("4 min");\r
+ call move(305,78);call outstring("5 min");\r
+ call move(355,78);call outstring("6 min");\r
+ call move(405,78);call outstring("7 min");\r
+ call move(455,78);call outstring("8 min");\r
+ call move(505,78);call outstring("9 min");\r
+ (*fin texte*)\r
+ \r
+ call color(14);\r
+ call move(100,150);\r
+ call outstring(" ET UN TYPE DE SIMULATION ( densite des VOYAGEURs ) :");\r
+ call rectangle_double(100,170,550,210);\r
+ \r
+ (* bares verticales *)\r
+ call move(250,172);\r
+ call draw(250,208);\r
+ call move(400,172);\r
+ call draw(400,208);\r
+ (* fin bare verticales *)\r
+ \r
+ (*texte*)\r
+ call color(15);\r
+ call move(121,184);call outstring(" Nuit");\r
+ call move(275,184);call outstring(" Jour");\r
+ call move(425,184);call outstring(" Dense");\r
+ (*fin texte*)\r
+ \r
+ (* definition de la souris *)\r
+ call showcursor;\r
+ while(haut or bas) do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ if (gauche) then\r
+ if(h>100 and h<550) then\r
+ call HIDECURSOR;\r
+ if(haut) then\r
+ if(v>60 and v<100) then\r
+ if(h>100 and h<150) then duree:=10;\r
+ \r
+ call color(0);\r
+ call move(105,78);\r
+ call outstring("1 min");\r
+ \r
+ call color(12);\r
+ call move(105,78);\r
+ call outstring("1 min");\r
+ else\r
+ if(h>150 and h<200) then duree:=20;\r
+ \r
+ call color(0);\r
+ call move(155,78);\r
+ call outstring("2 min");\r
+ \r
+ call color(12);\r
+ call move(155,78);\r
+ call outstring("2 min");\r
+ \r
+ else\r
+ if(h>200 and h<250) then duree:=30;\r
+ \r
+ call color(0);\r
+ call move(205,78);\r
+ call outstring("3 min");\r
+ \r
+ call color(12);\r
+ call move(205,78);\r
+ call outstring("3 min");\r
+ \r
+ else\r
+ if(h>250 and h<300) then duree:=40;\r
+ \r
+ call color(0);\r
+ call move(255,78);\r
+ call outstring("4 min");\r
+ \r
+ call color(12);\r
+ call move(255,78);\r
+ call outstring("4 min");\r
+ \r
+ else\r
+ if(h>300 and h<350) then duree:=50;\r
+ \r
+ call color(0);\r
+ call move(305,78);\r
+ call outstring("5 min");\r
+ \r
+ call color(12);\r
+ call move(305,78);\r
+ call outstring("5 min");\r
+ \r
+ else\r
+ if(h>350 and h<400) then duree:=60;\r
+ \r
+ call color(0);\r
+ call move(355,78);\r
+ call outstring("6 min");\r
+ \r
+ call color(12);\r
+ call move(355,78);\r
+ call outstring("6 min");\r
+ \r
+ else\r
+ if(h>400 and h<450) then duree:=70;\r
+ \r
+ call color(0);\r
+ call move(405,78);\r
+ call outstring("7 min");\r
+ \r
+ call color(12);\r
+ call move(405,78);\r
+ call outstring("7 min");\r
+ \r
+ else\r
+ if(h>450 and h<500) then duree:=80;\r
+ \r
+ call color(0);\r
+ call move(455,78);\r
+ call outstring("8 min");\r
+ \r
+ call color(12);\r
+ call move(455,78);\r
+ call outstring("8 min");\r
+ \r
+ else\r
+ if (h>500 and h<550) then duree:=90;\r
+ \r
+ call color(0);\r
+ call move(505,78);\r
+ call outstring("9 min");\r
+ \r
+ call color(12);\r
+ call move(505,78);\r
+ call outstring("9 min");\r
+ \r
+ fi;fi;fi;fi;fi;fi;fi;fi;fi;\r
+ haut:=false;\r
+ fi;\r
+ fi;\r
+ if (bas) then\r
+ if(v>170 and v<210) then\r
+ if (h>100 and h<250) then typ:=1;\r
+ \r
+ call color(0);\r
+ call move(121,184);\r
+ call outstring(" Nuit");\r
+ \r
+ call color(12);\r
+ call move(121,184);\r
+ call outstring(" Nuit");\r
+ \r
+ else\r
+ if (h>250 and h<400) then typ:=2;\r
+ \r
+ call color(0);\r
+ call move(275,184);\r
+ call outstring(" Jour");\r
+ \r
+ call color(12);\r
+ call move(275,184);\r
+ call outstring(" Jour");\r
+ else\r
+ if (h>400 and h<550) then typ:=3;\r
+ \r
+ call color(0);\r
+ call move(425,184);\r
+ call outstring(" Dense");\r
+ \r
+ call color(12);\r
+ call move(425,184);\r
+ call outstring(" Dense");\r
+ fi;fi;fi;\r
+ bas:=false;\r
+ fi;\r
+ fi;\r
+ call SHOWCURSOR;\r
+ fi;\r
+ gauche:=false;\r
+ fi;\r
+ od;\r
+ call color(10);\r
+ call move(100,300);\r
+ call outstring(" La duree sera de : ");call color(15);\r
+ case duree\r
+ when 10:call outstring("1 min");\r
+ when 20:call outstring("2 min");\r
+ when 30:call outstring("3 min");\r
+ when 40:call outstring("4 min");\r
+ when 50:call outstring("5 min");\r
+ when 60:call outstring("6 min");\r
+ when 70:call outstring("7 min");\r
+ when 80:call outstring("8 min");\r
+ when 90:call outstring("9 min");\r
+ esac;\r
+ call color(10);\r
+ call outstring(" et le type sera : ");call color(15);\r
+ case typ\r
+ when 1:call outstring("Nuit");\r
+ when 2:call outstring("Jour");\r
+ when 3:call outstring("Dense");\r
+ esac;\r
+ call PAUSE;\r
+ call hidecursor;\r
+ call cls;\r
+ END;\r
+END param;\r
+ \r
+(* PROCEDURE D ECRITURE D UN ENTIER A L ECRAN *)\r
+(* PARAMETRES TEMPS:REAL et COORDONNEES *)\r
+ \r
+UNIT ecrit_chiffre : procedure(TIME:real,x,y:integer);\r
+ VAR wtime :integer;\r
+BEGIN\r
+ call move(x,y);\r
+ call HASCII(0);\r
+ wtime:=entier(TIME);\r
+ (* temps <1000 *);\r
+ if(wtime>=100) then\r
+ call HASCII(wtime div 100+48);\r
+ wtime:=wtime mod 100;\r
+ else call HASCII(0);\r
+ fi;\r
+ call HASCII(wtime div 10 + 48);\r
+ call HASCII(wtime mod 10 + 48);\r
+END ecrit_chiffre;\r
+ \r
+(* PROCEDURE D EFFACEMENT DU CHIFFRE ECRIT *)\r
+ \r
+UNIT EFFACE_chiffre : procedure(x,y:integer);\r
+BEGIN\r
+ call color(0);\r
+ call rectangle_double(x,y-1,x+25,y+9);\r
+ call rectangle_double(x+1,y,x+24,y+8);\r
+ call rectangle_double(x+4,y+2,x+22,y+6);\r
+ call rectangle_double(x+5,y+3,x+21,y+5);\r
+END EFFACE_chiffre;\r
+ \r
+(* PROCEDURE DE TRACAGE DES VOIES *)\r
+ \r
+UNIT voie:iiuwgraph procedure;\r
+BEGIN\r
+ call color(9);\r
+ call rectangle_double(4,170,635,176);\r
+ call rectangle_double(5,171,634,175);\r
+ call move(5,171);\r
+ call color(14);\r
+ call outstring("QUAI 1");\r
+ call color(9);\r
+ call rectangle(4,177,635,195);\r
+ call color(10);\r
+ call rectangle_double(4,220,635,226);\r
+ call rectangle_double(5,221,634,225);\r
+ call move(5,221);\r
+ call color(14);\r
+ call outstring("QUAI 2");\r
+ call color(10);\r
+ call rectangle(4,227,635,245);\r
+ call color(11);\r
+ call rectangle_double(4,270,635,276);\r
+ call rectangle_double(5,271,634,275);\r
+ call move(5,271);\r
+ call color(14);\r
+ call outstring("QUAI 3");\r
+ call color(11);\r
+ call rectangle(4,277,635,295);\r
+ call color(12);\r
+ call rectangle_double(4,320,635,326);\r
+ call rectangle_double(5,321,634,325);\r
+ call move(5,321);\r
+ call color(14);\r
+ call outstring("QUAI 4");\r
+ call color(12);\r
+ call rectangle(4,327,635,345);\r
+END voie;\r
+ \r
+(* PROCEDURE DE TRACAGE DES CAISSES *)\r
+ \r
+UNIT caisse : iiuwgraph procedure;\r
+BEGIN\r
+ call color(15);\r
+ \r
+ (*caisse1*)\r
+ call rectangle_double(10,3,80,23);\r
+ \r
+ (*caisse2*)\r
+ call rectangle_double(10,26,80,43);\r
+ \r
+ (*caisse3*)\r
+ call rectangle_double(10,47,80,65);\r
+ \r
+ (*caisse4*)\r
+ call rectangle_double(10,68,80,86);\r
+ \r
+ (*texte caisse*)\r
+ call color(9);\r
+ call move(14,9);\r
+ call outstring("Caisse 1");\r
+ call move(14,31);\r
+ call color(10);\r
+ call outstring("Caisse 2");\r
+ call move(14,52);\r
+ call color(11);\r
+ call outstring("Caisse 3");\r
+ call move(14,73);\r
+ call color(12);\r
+ call outstring("Caisse 4");\r
+END caisse;\r
+ \r
+(* PROCEDURE D ECRITURE DES MESSAGES D ARRIVEE DES TRAIN DANS TABLEAU *)\r
+ \r
+UNIT mes_train :procedure(num:integer);\r
+BEGIN\r
+ case num\r
+ when 1:\r
+ call color(9);\r
+ call move(435,9);\r
+ call outstring("le train quai 1 arrive");\r
+ when 2:\r
+ call color(10);\r
+ call move(435,31);\r
+ call outstring("le train quai 2 arrive");\r
+ when 3:\r
+ call color(11);\r
+ call move(435,52);\r
+ call outstring("le train quai 3 arrive");\r
+ when 4:\r
+ call color(12);\r
+ call move(435,73);\r
+ call outstring("le train quai 4 arrive");\r
+ \r
+ esac;\r
+END mes_train;\r
+ \r
+UNIT mes_train_rep :procedure(num:integer);\r
+BEGIN\r
+ case num\r
+ when 1:\r
+ call color(9);\r
+ call move(435,9);\r
+ call outstring("le train quai 1 REPART");\r
+ when 2:\r
+ call color(10);\r
+ call move(435,31);\r
+ call outstring("le train quai 2 REPART");\r
+ when 3:\r
+ call color(11);\r
+ call move(435,52);\r
+ call outstring("le train quai 3 REPART");\r
+ when 4:\r
+ call color(12);\r
+ call move(435,73);\r
+ call outstring("le train quai 4 REPART");\r
+ \r
+ esac;\r
+END mes_train_rep;\r
+ \r
+UNIT eff_mestrn:procedure(num:integer);\r
+BEGIN\r
+ call color(0);\r
+ case num\r
+ when 1:\r
+ call move(435,9);\r
+ call outstring("le train quai 1 arrive");\r
+ when 2:\r
+ call move(435,31);\r
+ call outstring("le train quai 2 arrive");\r
+ when 3:\r
+ call move(435,52);\r
+ call outstring("le train quai 3 arrive");\r
+ when 4:\r
+ call move(435,73);\r
+ call outstring("le train quai 4 arrive");\r
+ \r
+ esac;\r
+END eff_mestrn;\r
+ \r
+UNIT eff_mestrn_rep:procedure(num:integer);\r
+BEGIN\r
+ call color(0);\r
+ case num\r
+ when 1:\r
+ call move(435,9);\r
+ call outstring("le train quai 1 REPART");\r
+ when 2:\r
+ call move(435,31);\r
+ call outstring("le train quai 2 REPART");\r
+ when 3:\r
+ call move(435,52);\r
+ call outstring("le train quai 3 REPART");\r
+ when 4:\r
+ call move(435,73);\r
+ call outstring("le train quai 4 REPART");\r
+ \r
+ esac;\r
+END eff_mestrn_rep;\r
+ \r
+(* PROCEDURE DE TRACAGE DES TRAINS *)\r
+ \r
+ UNIT DESSINE_TRAIN : procedure(num,deplacement :integer);\r
+ VAR wdepl,wbdepl:integer;\r
+ BEGIN\r
+ wdepl:=deplacement+5;\r
+ wbdepl:=deplacement+100;\r
+ if wdepl >=632 then wdepl:=632; fi;\r
+ if wbdepl>=632 then wbdepl:=632; fi;\r
+ \r
+ case num\r
+ when 1:\r
+ call color(9);\r
+ call rectangle_double(wdepl,179,wbdepl,193);\r
+ when 2:\r
+ call color(10);\r
+ call rectangle_double(wdepl,229,wbdepl,243);\r
+ when 3:\r
+ call color(11);\r
+ call rectangle_double(wdepl,279,wbdepl,293);\r
+ when 4:\r
+ call color(12);\r
+ call rectangle_double(wdepl,329,wbdepl,343);\r
+ esac;\r
+ END DESSINE_TRAIN;\r
+ \r
+ \r
+UNIT EFFACE_TRAIN : iiuwgraph procedure(num,deplacement :integer);\r
+ VAR wdepl,wbdepl :integer;\r
+BEGIN\r
+ wdepl:=deplacement+5;\r
+ wbdepl:=deplacement+100;\r
+ if wdepl >=632 then wdepl:=632; fi;\r
+ if wbdepl>=632 then wbdepl:=632 fi;\r
+ call color(0);\r
+ case num\r
+ when 1:\r
+ call rectangle_double(wdepl,179,wbdepl,193);\r
+ when 2:\r
+ call rectangle_double(wdepl,229,wbdepl,243);\r
+ when 3:\r
+ call rectangle_double(wdepl,279,wbdepl,293);\r
+ when 4:\r
+ call rectangle_double(wdepl,329,wbdepl,343);\r
+ esac;\r
+END EFFACE_TRAIN;\r
+ \r
+UNIT arrive_TRAIN:procedure(num:integer);\r
+ VAR indice,temp:integer;\r
+BEGIN\r
+ call mes_train(num);\r
+ for indice:=0 to 100 do\r
+ call DESSINE_TRAIN(num,indice);\r
+ call EFFACE_TRAIN(num,indice);\r
+ od;\r
+ call DESSINE_TRAIN(num,indice);\r
+END arrive_TRAIN;\r
+ \r
+UNIT REPART_TRAIN:procedure(num:integer);\r
+ VAR indice,temp:integer;\r
+BEGIN\r
+ call eff_mestrn(num);\r
+ call mes_train_rep(num);\r
+ for indice:=100 to 636 do\r
+ call DESSINE_TRAIN(num,indice);\r
+ call EFFACE_TRAIN(num,indice);\r
+ od;\r
+ call eff_mestrn_rep(num);\r
+END REPART_TRAIN;\r
+ \r
+(* PROCEDURE DE TRACAGE DU TABLEAU DES ARRIVEES *)\r
+ \r
+UNIT tableau : iiuwgraph procedure;\r
+BEGIN\r
+ call color(15);\r
+ call rectangle(350,3,635,86);\r
+ call rectangle(410,5,633,19);\r
+ call rectangle(410,28,633,42);\r
+ call rectangle(410,49,633,63);\r
+ call rectangle(410,70,633,84);\r
+ \r
+ (*texte tableau*)\r
+ call color(9);\r
+ call move(354,9);\r
+ call outstring("Quai 1");\r
+ call move(354,31);\r
+ call color(10);\r
+ call outstring("Quai 2");\r
+ call move(354,52);\r
+ call color(11);\r
+ call outstring("Quai 3");\r
+ call move(354,73);\r
+ call color(12);\r
+ call outstring("Quai 4");\r
+ \r
+END tableau;\r
+ \r
+(* PROCEDURE DE TRACAGE DES VOYAGEURS *)\r
+ \r
+UNIT VOYAGEUR:iiuwgraph procedure(x,y:integer);\r
+BEGIN\r
+ call move(x,y);\r
+ call draw(x,y+6);\r
+ call draw(x-2,y+10);\r
+ call move(x,y+6);\r
+ call draw(x+2,y+10);\r
+ call move(x-2,y+2);\r
+ call draw(x+2,y+2);\r
+ call move(x-2,y+2);\r
+ call draw(x-4,y+4);\r
+ call move(x+2,y+2);\r
+ call draw(x+4,y+4)\r
+END;\r
+ \r
+UNIT affiche_VOYAGEUR:iiuwgraph procedure(x,y:integer);\r
+BEGIN\r
+ call color(14);\r
+ call VOYAGEUR(x,y);\r
+END affiche_VOYAGEUR;\r
+ \r
+UNIT EFFACE_VOYAGEUR:iiuwgraph procedure(x,y:integer);\r
+BEGIN\r
+ call color(0);\r
+ call VOYAGEUR(x,y);\r
+END EFFACE_VOYAGEUR;\r
+ \r
+(* PROCEDURE D AFFICHAGE DE LA GARE *)\r
+ \r
+UNIT gar:iiuwgraph procedure;\r
+BEGIN\r
+ call color(15);\r
+ call attend(400);\r
+ call rectangle_double(0,0,639,349);\r
+ call caisse;\r
+ call voie;\r
+ call tableau;\r
+ call composteuse;\r
+END gar;\r
+ \r
+(* PROCEDURE DE TRACAGE DU COMPOSTEUR *)\r
+ \r
+UNIT composteuse : iiuwgraph procedure;\r
+BEGIN\r
+ call color(7);\r
+ call move(3,125);\r
+ call draw(460,125);\r
+ call move(3,126);\r
+ call draw(460,126);\r
+ call rectangle(500,125,633,150);\r
+ call move(528,135);\r
+ call outstring("COMPOSTEUR");\r
+END composteuse;\r
+ \r
+UNIT PRIORITYQUEUE: CLASS;\r
+(* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+ \r
+ UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+ UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+ END QUEUEHEAD;\r
+ \r
+ UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS: COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ call outstring(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ call outstring(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+ UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+ UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+ UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+ UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+ END SCHEDULE;\r
+ \r
+ UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+ UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+ UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+ END RUN;\r
+ \r
+ UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+ UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOISIR THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN\r
+ WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+ END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+ \r
+UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+ \r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ \r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE\r
+ FI;\r
+ END FIRST;\r
+ \r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+ \r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT:PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE;\r
+ FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI;\r
+ FI;\r
+ END INTO;\r
+ END LINK;\r
+ \r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+ \r
+END LISTS;\r
+ \r
+UNIT GARE:LISTS CLASS; (*AN GARE*)\r
+ \r
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);\r
+ (* GUICHET WITH VOYAGEURS QUEUEING UP *)\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* SERVICE OF THIS GUICHET WILL BE PRECISED LATER *)\r
+ END SERVICE;\r
+ \r
+ VAR CSTM:VOYAGEUR, (*THE VOYAGEUR BEING SERVED*)\r
+ REST,PAUSE:REAL,\r
+ COMPTEUR : INTEGER;\r
+ \r
+ BEGIN\r
+ PAUSE:=TIME;\r
+ DO\r
+ REST:=REST+TIME-PAUSE;\r
+ WHILE NOT QUEUE.EMPTY DO\r
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;\r
+ CALL SERVICE;\r
+ OD;\r
+ PAUSE:=TIME;\r
+ CALL PASSIVATE;\r
+ OD;\r
+ END TILL;\r
+ \r
+ UNIT VOYAGEUR:SIMPROCESS CLASS;\r
+ \r
+ VAR ELLIST:ELEM, K:INTEGER,NUMGUICHET:INTEGER;\r
+ UNIT ARRIVAL:PROCEDURE(S:TILL);\r
+ (* le VOYAGEUR va a un guichet ou au composteur *)\r
+ BEGIN\r
+ IF S=/=NONE THEN\r
+ ELLIST:=NEW ELEM(THIS VOYAGEUR);\r
+ call ELLIST.INTO(S.QUEUE); (* mit dans la file d'attente*)\r
+ case NUMGUICHET\r
+ when 1: call affiche_VOYAGEUR(90+S.COMPTEUR*10,10);\r
+ when 2: call affiche_VOYAGEUR(90+S.COMPTEUR*10,33);\r
+ when 3: call affiche_VOYAGEUR(90+S.COMPTEUR*10,54);\r
+ when 4: call affiche_VOYAGEUR(90+S.COMPTEUR*10,75);\r
+ when 5: call affiche_VOYAGEUR(500-S.COMPTEUR*10,110);\r
+ esac;\r
+ S.COMPTEUR:=S.COMPTEUR+1;\r
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME); FI;\r
+ call PASSIVATE;\r
+ FI;\r
+ END ARRIVAL;\r
+ END VOYAGEUR;\r
+ \r
+ UNIT TRAIN:SIMPROCESS CLASS;\r
+ \r
+ UNIT ARRIVAL:PROCEDURE(inout QUAI:integer);\r
+ (* le train arrive en gare, prend les voyageurs et REPART*)\r
+ VAR CLI : VOYAGEUR,TEMP:INTEGER;\r
+ BEGIN\r
+ IF (NOT TAB_STOPQ(QUAI)) THEN\r
+ TAB_STOPQ(QUAI):=TRUE; \r
+ TEMP:=RANDOM*10;\r
+ call HOLD(TEMP); \r
+ call arrive_TRAIN(QUAI);\r
+ if(TEMP>0) THEN\r
+ (* DEPLACER TRAIN JUSQU'A DEBUT FILE *)\r
+ (* CHARGER VOYAGEUR*)\r
+ call attend(20);\r
+ write(chr(07));\r
+ \r
+ CASE QUAI\r
+ WHEN 1 :(* QUAI 1 *)\r
+ while(CPTQU1>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU1*20,155);\r
+ CPTQU1:=CPTQU1-1;\r
+ call HOLD(RANDOM * 10);\r
+ od;\r
+ CPTQU1:=0;\r
+ WHEN 2 :(* QUAI 2 *)\r
+ while(CPTQU2>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU2*20,205);\r
+ CPTQU2:=CPTQU2-1;\r
+ call HOLD(RANDOM * 11);\r
+ od;\r
+ CPTQU2:=0;\r
+ WHEN 3 :(* QUAI 3 *)\r
+ while(CPTQU3>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU3*20,255);\r
+ CPTQU3:=CPTQU3-1;\r
+ call HOLD(RANDOM * 12);\r
+ od;\r
+ CPTQU3:=0;\r
+ WHEN 4 :(* QUAI 4 *)\r
+ while(CPTQU4>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU4*20,305);\r
+ CPTQU4:=CPTQU4-1;\r
+ call HOLD(RANDOM * 13);\r
+ od;\r
+ CPTQU4:=0;\r
+ ESAC;\r
+ write(chr(07));\r
+ write(chr(07)); \r
+ fi;\r
+ call REPART_TRAIN(QUAI);\r
+ TAB_STOPQ(QUAI) := FALSE;\r
+ call HOLD(10); \r
+ (* le train sort de la gare *)\r
+ fi;\r
+ END ARRIVAL;\r
+ END TRAIN;\r
+ \r
+END GARE;\r
+ \r
+UNIT GAREDEPARTMENT:GARE CLASS;\r
+ \r
+ UNIT COMPOSTEUR:TILL CLASS;\r
+ VAR SERVICETIME:REAL;\r
+ VAR nbvoyageurQ1,nbvoyageurQ2,nbvoyageurQ3,nbvoyageurQ4 : integer;\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* represente le service dispense par le composteur *)\r
+ BEGIN\r
+ CALL CSTM.ELLIST.OUT; (* un voyageur a composte son billet\r
+ et sort de la file du composteur*)\r
+ call EFFACE_VOYAGEUR(500-COMPTEUR*10,110);\r
+ COMPTEUR:= COMPTEUR-1;\r
+ SERVICETIME:=RANDOM*4+nb4;\r
+ CALL HOLD(SERVICETIME);\r
+ (* on attends le temps passe pour composter le billet *)\r
+ CSTM.NUMGUICHET := RANDOM * 4 + 1; (* 4 = nombre de quais *)\r
+ while (TAB_STOPQ(CSTM.NUMGUICHET) ) do\r
+ call HOLD(1);\r
+ CSTM.NUMGUICHET := RANDOM *4 +1;\r
+ od;\r
+ (* le voyageur va sur le bon quai *)\r
+ CASE CSTM.NUMGUICHET\r
+ when 1 : (* QUAI 1 *)\r
+ nbvoyageurQ1 := nbvoyageurQ1 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU1*20,155);\r
+ CPTQU1:=CPTQU1+1;\r
+ when 2 : (* QUAI 2 *)\r
+ nbvoyageurQ2 := nbvoyageurQ2 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU2*20,205);\r
+ CPTQU2:=CPTQU2+1;\r
+ when 3 :(* QUAI 3 *)\r
+ nbvoyageurQ3 := nbvoyageurQ3 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU3*20,255);\r
+ CPTQU3:=CPTQU3+1;\r
+ when 4 :(* QUAI 4*)\r
+ nbvoyageurQ4 := nbvoyageurQ4 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU4*20,305);\r
+ CPTQU4:=CPTQU4+1;\r
+ ESAC;\r
+ END SERVICE;\r
+ END COMPOSTEUR;\r
+ \r
+\r
+ UNIT GUICHET:TILL CLASS(NUMBER:INTEGER);\r
+ VAR SERVICETIME:REAL;\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* service dispense au guichet de la gare*)\r
+ BEGIN\r
+ case CSTM.NUMGUICHET\r
+ when 1: call EFFACE_VOYAGEUR(90+COMPTEUR*10,10);\r
+ when 2: call EFFACE_VOYAGEUR(90+COMPTEUR*10,33);\r
+ when 3: call EFFACE_VOYAGEUR(90+COMPTEUR*10,54);\r
+ when 4: call EFFACE_VOYAGEUR(90+COMPTEUR*10,75);\r
+ esac;\r
+ CALL CSTM.ELLIST.OUT; (* sort de la file du guichet *)\r
+ COMPTEUR := COMPTEUR -1;\r
+ SERVICETIME:=RANDOM*4+10; (*augmente temps du guichet*)\r
+ CALL HOLD(SERVICETIME); \r
+ (* attend le temp du service au guichet *)\r
+ CSTM.NUMGUICHET:=5; (* 5 = COMPOSTEUR *)\r
+ CALL CSTM.ARRIVAL(COMPOSTBOX);\r
+ (* le voyageur va au composteur *)\r
+ END SERVICE;\r
+ END GUICHET;\r
+ UNIT GENERATORVOYAGEUR:SIMPROCESS CLASS(nb1,nb2 : integer);\r
+ (* VOYAGEURS GENERATION *)\r
+ VAR nbvoyageurs,wtime : integer;\r
+ BEGIN\r
+ DO\r
+ call move(500,100);\r
+ call color(12);\r
+ call outstring("TEMPS:");\r
+ call EFFACE_chiffre(550,100);\r
+ call color(12);\r
+ call ecrit_chiffre(TIME,550,100);\r
+ \r
+ call SCHEDULE(NEW GAREVOYAGEUR(RANDOM*100+1),TIME);\r
+ nbvoyageurs := nbvoyageurs+1;\r
+ (* temps d'attente entre la generation deux voyageurs *)\r
+ call HOLD(RANDOM * nb1);\r
+ \r
+ call move(500,100);\r
+ call color(12);\r
+ call outstring("TEMPS:");\r
+ call EFFACE_chiffre(550,100);\r
+ call color(12);\r
+ call ecrit_chiffre(TIME,550,100);\r
+ \r
+ call SCHEDULE(NEW GAREVOYAGEUR(RANDOM*100+1),TIME);\r
+ nbvoyageurs := nbvoyageurs+1;\r
+ (* temps d'attente entre la generation de deux voyageurs *)\r
+ call HOLD(RANDOM * nb2);\r
+ OD\r
+ END GENERATORVOYAGEUR;\r
+ \r
+ UNIT GENERATORTRAIN:SIMPROCESS CLASS(nb3 : integer,numquai :integer);\r
+ (* TRAIN GENERATION *)\r
+ VAR nbtrains,wtime: integer;\r
+ BEGIN\r
+ DO\r
+ call move(500,100);\r
+ call color(12);\r
+ call outstring("TEMPS:");\r
+ call EFFACE_chiffre(550,100);\r
+ call color(12);\r
+ call ecrit_chiffre(TIME,550,100);\r
+ \r
+ call SCHEDULE(NEW GARETRAIN(numquai),TIME);\r
+ nbtrains := nbtrains + 1;\r
+ (* temps d'attente entre la generation de deux trains*)\r
+ call HOLD(RANDOM * nb3);\r
+ OD\r
+ END GENERATORTRAIN;\r
+ \r
+\r
+ UNIT GAREVOYAGEUR:VOYAGEUR CLASS(NO:INTEGER);\r
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOISIRGUICHET:INTEGER;\r
+ BEGIN\r
+ I:=I+1;\r
+ K:=I;\r
+ ARRIVALTIME:=TIME;\r
+ CHOISIRGUICHET:=RANDOM*nombreguichets +1;\r
+ NUMGUICHET := CHOISIRGUICHET;\r
+ (* un voyageur va a un guichet de la gare *)\r
+ CALL ARRIVAL(GUICHETS(CHOISIRGUICHET));\r
+ STAYTIME:=TIME-ARRIVALTIME;\r
+ END GAREVOYAGEUR;\r
+ \r
+ UNIT GARETRAIN:TRAIN CLASS(numquai : integer);\r
+ VAR ARRIVALTIME,STAYTIME:REAL;\r
+ BEGIN\r
+ ARRIVALTIME:=TIME;\r
+ (* un train arrive en gare sur un quai *)\r
+ CALL ARRIVAL(numquai);\r
+ STAYTIME:=TIME-ARRIVALTIME;\r
+ END GARETRAIN;\r
+ \r
+ VAR COMPOSTBOX:COMPOSTEUR,I:INTEGER,dur : integer;\r
+ VAR nombreguichets, nbvoyageurs, nbtrains :integer;\r
+ VAR GUICHETS:ARRAYOF GUICHET;\r
+ var nb1,nb2,nb3,nb4,billcomp1,billcomp2,billcomp3,pourcent : integer; \r
+ \r
+\r
+BEGIN (* NEW GARE DEPARTMENT GENERATION *)\r
+ call param(dur,affluence);\r
+ call color(14);\r
+ call move(3,130);\r
+ call outstring(" La duree est de : ");call color(15);\r
+ case dur\r
+ when 10:call outstring("1 min");\r
+ when 20:call outstring("2 min");\r
+ when 30:call outstring("3 min");\r
+ when 40:call outstring("4 min");\r
+ when 50:call outstring("5 min");\r
+ when 60:call outstring("6 min");\r
+ when 70:call outstring("7 min");\r
+ when 80:call outstring("8 min");\r
+ when 90:call outstring("9 min");\r
+ esac;\r
+ call color(14);\r
+ call outstring(" et le type est : ");call color(15);\r
+ case affluence\r
+ when 1:call outstring("Nuit");\r
+ when 2:call outstring("Jour");\r
+ when 3:call outstring("Dense");\r
+ esac;\r
+\r
+ case affluence\r
+ when 1 :nb1:=40; nb2:=35;\r
+ nb3:= 1200;nb4:=2;nombreguichets := 2;\r
+ call move(100,52);\r
+ call color(11);\r
+ call outstring("FERMEE");\r
+ call move(100,73);\r
+ call color(12);\r
+ call outstring("FERMEE");\r
+ \r
+ when 2 :nb1:=26; nb2:=27; nb3:= 400;nb4:=5;\r
+ nombreguichets := 3;\r
+ call move(100,73);\r
+ call color(12);\r
+ call outstring("FERMEE");\r
+ \r
+ when 3 :nb1:=10; nb2:=12; nb3:= 400;nb4:=5;\r
+ nombreguichets := 4;\r
+ esac;\r
+ COMPOSTBOX:=NEW COMPOSTEUR(NEW HEAD); (* creation du composteur *)\r
+ ARRAY GUICHETS DIM(1:nombreguichets); (* WE DEAL WITH 5 TELLES *)\r
+ (* creation des guichets *)\r
+ FOR I:=1 TO nombreguichets DO\r
+ GUICHETS(I):=NEW GUICHET(NEW HEAD,I);\r
+ OD;\r
+ I:=0;\r
+\r
+END GAREDEPARTMENT;\r
+\r
+ var gauche,droit,centre,rep,rep1,choix:boolean,\r
+ affluence,i : integer;\r
+ VAR CPTQU1,CPTQU2,CPTQU3,CPTQU4 : integer;\r
+ VAR TAB_STOPQ : ARRAYOF boolean;\r
+ \r
+ \r
+ \r
+ BEGIN (* OF PROGRAM *)\r
+ ARRAY TAB_STOPQ DIM(1:4);\r
+ TAB_STOPQ(1):= false;\r
+ TAB_STOPQ(2):= false;\r
+ TAB_STOPQ(3):= false;\r
+ TAB_STOPQ(4):= false;\r
+ i:= exec(unpack("new-1.exe"));\r
+ droit:=FALSE;\r
+ centre:=FALSE;\r
+ gauche:=FALSE;\r
+ call HPAGE(0,0,0);\r
+ call HPAGE(0,639,639);\r
+ call GRON(0);\r
+ choix:=TRUE;\r
+ call presentation;\r
+ while (choix) do \r
+ PREF GAREDEPARTMENT BLOCK\r
+ VAR generatecli : GENERATORVOYAGEUR; \r
+ VAR generatetr1, generatetr2, generatetr3,generatetr4: GENERATORTRAIN; \r
+ BEGIN\r
+ call gar;\r
+ (* creation du generateur de voyageurs *)\r
+ generatecli := NEW GENERATORVOYAGEUR(nb1,nb2);\r
+ call SCHEDULE(generatecli,TIME);\r
+ (* creation du generateur de trains pour le quai 1*)\r
+ generatetr1 := NEW GENERATORTRAIN(nb3,1);\r
+ call SCHEDULE(generatetr1,TIME);\r
+ (* creation du generateur de trains pour le quai 2 *)\r
+ generatetr2 := NEW GENERATORTRAIN(nb3,2);\r
+ call SCHEDULE(generatetr2,TIME);\r
+ (* creation du generateur de trains pour le quai 3 *)\r
+ generatetr3 := NEW GENERATORTRAIN(nb3,3);\r
+ call SCHEDULE(generatetr3,TIME);\r
+ (* creation du generateur de trains pour le quai 4 *)\r
+ generatetr4 := NEW GENERATORTRAIN(nb3,4);\r
+ call SCHEDULE(generatetr4,TIME);\r
+ \r
+ call HOLD (dur * 10);\r
+ \r
+ rep1:=msgbox("Voulez-vous les statistiques sur la simulation ?",48,14,100,200);\r
+ if (rep1) then\r
+ call cls;\r
+ call move(150,10);\r
+ call color(13);\r
+ call outstring("CHER UTILISATEUR VOICI LES STATISTIQUES !!!");\r
+ call move(120,40);\r
+ call color(3);\r
+ call outstring("le nombre total de voyageurs est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(generatecli.nbvoyageurs,420,40);\r
+ call move(20,70);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 1 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr1.nbtrains,420,70);\r
+ call move(20,90);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 2 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr2.nbtrains,420,90);\r
+ call move(20,110);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 3 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr3.nbtrains,420,110);\r
+ call move(20,130);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 4 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr4.nbtrains,420,130);\r
+ call move(120,170);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai1 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ1,420,170);\r
+ call move(120,190);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai2 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ2,420,190);\r
+ call move(120,210);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai3 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ3,420,210);\r
+ call move(120,230);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai4 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ4,420,230);\r
+ call move(60,280);\r
+ call color(3);\r
+ call outstring("total voyageurs ayant compost\82s leur billet : ");\r
+ call color(11);\r
+ billcomp1 := COMPOSTBOX.nbvoyageurQ1+COMPOSTBOX.nbvoyageurQ2;\r
+ billcomp2 := COMPOSTBOX.nbvoyageurQ3+COMPOSTBOX.nbvoyageurQ4;\r
+ billcomp3:=billcomp1+billcomp2;\r
+ \r
+ call ecrit_chiffre(billcomp3,420,280);\r
+ pourcent:=100-((100*billcomp3)DIV generatecli.nbvoyageurs);\r
+ IF (pourcent >= 30) THEN\r
+ call move(70,300);\r
+ call color(10);\r
+ call outstring(" REMARQUE : Il serait utile de rajouter un composteur");\r
+ FI;\r
+ call PAUSE;\r
+ \r
+ fi;\r
+ choix:=msgbox("VOULEZ-VOUS CONTINUER (O/N)?",30,14,200,175);\r
+ call cls;\r
+ TAB_STOPQ(1):= false;\r
+ TAB_STOPQ(2):= false;\r
+ TAB_STOPQ(3):= false;\r
+ TAB_STOPQ(4):= false;\r
+ \r
+ END;\r
+ od;\r
+ call color(14);\r
+ call move(65,150);\r
+ call outstring(" MERCI POUR L'UTILISATION DE CETTE SUPERBE APPLICATION");\r
+ call move(250,320);\r
+ call outstring("VEUILLEZ PATIENTER");\r
+ call attend_sortie;\r
+ call GROFF;\r
+ END;\r
+END gar;\r
+(****************************\r
+************************************************)\r
+ \r
--- /dev/null
+PROGRAM OTOCZKA;\r
+ \r
+(*Program znajduje najmniejszy wypukly wielokat zawierajacy zadany zbior*)\r
+(* punktow. *)\r
+(* autor: Joanna Hybel *)\r
+(*program nr 5 jest przedmiotem zal. PP II *)\r
+ \r
+VAR i,j,k,licz,ix:integer,\r
+ pom:punkt,\r
+ punkty:arrayof punkt; (*zbior punktow*)\r
+ \r
+UNIT punkt:class;\r
+ var\r
+ x,y:integer,\r
+ theta:real;\r
+end punkt;\r
+ \r
+ \r
+begin\r
+ pref iiuwgraph block\r
+ \r
+ UNIT hframe:procedure(x,y,length,width:integer);\r
+ (*---------------------------------------------*)\r
+ begin\r
+ call move(x,y);\r
+ call draw(x+width,y);\r
+ call draw(x+width,y+length);\r
+ call draw(x,y+length);\r
+ call draw(x,y);\r
+ end hframe;\r
+ \r
+ UNIT hwrite:procedure(tekst:string;x,y:integer);\r
+ (*---------------------------------------------*)\r
+ var i:integer,\r
+ tab:arrayof char;\r
+ begin\r
+ tab:=unpack(tekst);\r
+ call move(x,y);\r
+ for i:=lower(tab) to upper(tab)\r
+ do\r
+ call hascii(ord(tab(i)));\r
+ od;\r
+ end;\r
+ \r
+UNIT inchar:function:integer;\r
+ (*---------------------------------------------*)\r
+var ii:integer;\r
+begin\r
+do\r
+ ii:=inkey;\r
+ if ii<>0 then exit fi;\r
+od;\r
+result:=ii;\r
+end inchar;\r
+ \r
+ UNIT zmaz :procedure(x,y,dl,sz:integer);\r
+ (*---------------------------------------------*)\r
+ begin\r
+ dl:=dl div 8;\r
+ sz:=sz div 8;\r
+ for i:=1 to dl do\r
+ for j:=1 to sz do\r
+ call move(x+(j-1)*8,y+(i-1)*8);\r
+ call hascii(0);\r
+ od;\r
+ od;\r
+ end zmaz;\r
+ \r
+UNIT wpisz_theta:procedure;\r
+ (*---------------------------------------------*)\r
+ \r
+ UNIT uzup_theta:function(p:punkt):real;\r
+ var dx,dy:integer,\r
+ th:real;\r
+begin\r
+ dx:=p.x-punkty(1).x;\r
+ dy:=p.y-punkty(1).y;\r
+ if dx=0 and dy=0 then th:=0\r
+ else\r
+ th:=dy/(abs(dx)+abs(dy));\r
+ fi;\r
+ if dx<0 then th:=2-th\r
+ else\r
+ if dy<0 then th:=th+4 fi;\r
+ fi;\r
+ result:=th*90.0;\r
+end uzup_theta;\r
+begin\r
+ for i:=1 to licz do\r
+ punkty(i).theta:=uzup_theta(punkty(i));\r
+ od;\r
+end wpisz_theta;\r
+ \r
+UNIT rys_otocz:procedure;\r
+ (*---------------------------------------------*)\r
+ UNIT czysc:procedure(p1,p2:punkt);\r
+ begin\r
+ call move(p2.x,p2.y);\r
+ call color(0);\r
+ call draw(p1.x,p1.y);\r
+ call color(1);\r
+ call cirb(p2.x,p2.y,2,3,3,1,1,2,2);\r
+ call cirb(p1.x,p1.y,2,3,3,1,1,2,2);\r
+ end czysc;\r
+ \r
+ UNIT rys:procedure(p1,p2:punkt);\r
+ begin\r
+ call color(11);\r
+ call move(p2.x,p2.y);\r
+ call draw(p1.x,p1.y);\r
+ end rys;\r
+ \r
+UNIT po_tej_samej_str: function(p1,p2,p3:punkt):boolean;\r
+ (*Czy punkty punkty(1),p3 leza po tej samej stronie prostej p1,p2?*)\r
+ var dx1,dx2,dx3,dy1,dy2,dy3,k,l:real;\r
+ begin\r
+ dx1:=p2.x-p1.x;\r
+ dy1:=p2.y-p1.y;\r
+ dx2:=p3.x-p1.x;\r
+ dy2:=p3.y-p1.y;\r
+ dx3:=punkty(1).x-p1.x;\r
+ dy3:=punkty(1).y-p1.y;\r
+ k:=(dy2*dx1-dy1*dx2);\r
+ l:=(dy3*dx1-dy1*dx3);\r
+ if k=0 orif l=0 then result:=true;\r
+ else\r
+ if k>0 then result:=(l>0);\r
+ else result:=(l<0);\r
+ fi;\r
+ fi;\r
+ end po_tej_samej_str;\r
+begin\r
+ call hwrite("press any key to draw a CONVEX HULL",24,316);\r
+ i:=2; k:=3;\r
+ call rys(punkty(1),punkty(2));\r
+ for j:=3 to licz\r
+ do\r
+ ix:=inchar;\r
+ k:=j;\r
+ do\r
+ if po_tej_samej_str(punkty(i-1),punkty(i),punkty(k)) then\r
+ i:=i+1; exit;\r
+ else\r
+ call czysc(punkty(i-1),punkty(i));\r
+ i:=i-1;\r
+ fi;\r
+ od;\r
+ pom:=punkty(i);\r
+ punkty(i):=punkty(k);\r
+ punkty(k):=pom;\r
+ call rys(punkty(i-1),punkty(i));\r
+ od;\r
+ call rys(punkty(i),punkty(1));\r
+ call zmaz(24,304,32,580);\r
+end rys_otocz;\r
+ \r
+UNIT dane :procedure;\r
+ (*---------------------------------------------*)\r
+ UNIT los_gen:procedure;\r
+ var x1,y1:integer;\r
+ begin\r
+ for i:=1 to licz do\r
+ do\r
+ x1:=random*400+100;\r
+ if x1>5 andif x1<614 then\r
+ punkty(i).x:=x1;\r
+ exit;\r
+ fi;\r
+ od;\r
+ do\r
+ y1:=random*200+50;\r
+ if y1>35 andif y1<300 then\r
+ punkty(i).y:=y1;\r
+ exit;\r
+ fi;\r
+ od;\r
+ call cirb(x1,y1,2,3,3,11,1,2,2);\r
+ od;\r
+ end los_gen;\r
+ \r
+ UNIT uzyt_gen :procedure;\r
+ begin\r
+ call hwrite("USE ARROWS TO MOVE THE CURSOR",24,308);\r
+ call hwrite("END - finishes",24,320);\r
+ \r
+ call track(300,150);\r
+ k:=0;\r
+ do\r
+ if inxpos>5 andif inxpos<514 then\r
+ if inypos>35 andif inypos<287 then\r
+ k:=k+1;\r
+ punkty(k).x:=inxpos;\r
+ punkty(k).y:=inypos;\r
+ call cirb(inxpos,inypos,2,3,3,11,1,2,2);\r
+ fi\r
+ fi;\r
+ if k=licz then exit fi;\r
+ call track(inxpos+3,inypos)\r
+ od;\r
+ call zmaz(24,304,32,580);\r
+ end uzyt_gen;\r
+begin\r
+ call zmaz(24,304,32,580);\r
+ call hwrite("the number of points 3",20,291);\r
+ call hwrite("1 - if you would like less points ",20,303);\r
+ call hwrite("2 - if you would like more points ",20,315);\r
+ call hwrite("ENTER - to continue execution",20,327);\r
+ licz:=3;\r
+do\r
+ ix:=inchar;\r
+ case ix\r
+ when 50 : if licz<99 then licz:=licz+1 ;\r
+ call move(252,291);\r
+ call hascii(0);\r
+ call move(260,291);\r
+ call hascii(0);\r
+ call move(252,291);\r
+ if licz>9 then call hascii(licz div 10+48) fi;\r
+ call hascii(licz mod 10 +48);\r
+ fi;\r
+ when 49 : if licz>3 then licz:=licz-1 ;\r
+ call move(252,291);\r
+ call hascii(0);\r
+ call move(260,291);\r
+ call hascii(0);\r
+ call move(252,291);\r
+ if licz>9 then call hascii(licz div 10+48) fi;\r
+ call hascii(licz mod 10 +48);\r
+ \r
+ fi;\r
+ when 13 : exit;\r
+ otherwise;\r
+ esac;\r
+od;\r
+array punkty dim (1:licz);\r
+for i:=1 to licz do\r
+ punkty(i):=new punkt;\r
+od;\r
+call zmaz(20,291,48,580);\r
+call hwrite("M E N U :",20,291);\r
+call hwrite("1 - random generation of points",20,303);\r
+call hwrite("2 - points given by user",20,315);\r
+do\r
+ ix:=inchar;\r
+ if ix=49 orif ix=50 then exit fi;\r
+od;\r
+ call zmaz(20,291,48,580);\r
+ case ix\r
+ when 49:call los_gen;\r
+ when 50:call uzyt_gen;\r
+ otherwise;\r
+ esac;\r
+end dane;\r
+ \r
+ UNIT znajdz_max_y:procedure;\r
+ (*---------------------------------------------*)\r
+ begin\r
+ pom:=punkty(1);\r
+ j:=1;\r
+ for i:=1 to licz do\r
+ if pom.y> punkty(i).y then(*bylo <*)\r
+ pom:=punkty(i);\r
+ j:=i;\r
+ else\r
+ if pom.y=punkty(i).y then\r
+ if pom.x> punkty(i).x then\r
+ pom:=punkty(i);\r
+ j:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ pom:=punkty(1);\r
+ punkty(1):=punkty(j);\r
+ punkty(j):=pom;\r
+ end znajdz_max_y;\r
+ \r
+ (*funkcje okreslajace wzgl. czego sortujemy : *)\r
+ \r
+ unit l1 :function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.theta<p2.theta);\r
+ end l1;\r
+ unit l2:function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.y<p2.y);\r
+ end l2;\r
+ unit l3:function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.x <p2.x);\r
+ end l3;\r
+ \r
+ \r
+ UNIT posortuj:procedure;\r
+ (*---------------------------------------------*)\r
+ \r
+ (* Sortowanie punktow wzgledem kata jaki tworza z prosta pozioma, *)\r
+ (* przechodzaca przez punkt o najmniejszej wspolrz.y i x *)\r
+ var kon,pocz:integer,\r
+ lg,lg1:boolean;\r
+ \r
+ UNIT sort:procedure (function log(p1,p2:punkt):boolean);\r
+ \r
+ unit quicksort:procedure(l,p:integer);\r
+ var i,j:integer,\r
+ x,w:punkt;\r
+ begin\r
+ i:=l; j:=p;\r
+ x:=punkty((l+p) div 2);\r
+ do\r
+ while log(punkty(i),x) do\r
+ i:=i+1 od;\r
+ while log(x,punkty(j)) do\r
+ j:=j-1 od;\r
+ if i<=j then\r
+ w:=punkty(i); punkty(i):=punkty(j); punkty(j):=w;\r
+ i:=i+1;\r
+ j:=j-1;\r
+ fi;\r
+ if i>j then exit fi;\r
+ od;\r
+ if l<j then call quicksort(l,j) fi;\r
+ if i<p then call quicksort(i,p) fi;\r
+ \r
+ end quicksort;\r
+ \r
+ \r
+ begin\r
+ call quicksort(pocz,kon);\r
+ end sort;\r
+ \r
+ begin (*posortuj*)\r
+ kon:=licz;\r
+ pocz:=1;\r
+ call sort(l1);\r
+ k:=1;\r
+ i:=1;\r
+ while i<licz do\r
+ j:=i;\r
+ if punkty(i).theta=0 then lg1:=true fi;\r
+ do\r
+ lg:=(punkty(i).theta=punkty(i+1).theta);\r
+ if lg then i:=i+1 ;\r
+ else\r
+ exit;\r
+ fi;\r
+ if i=licz then exit fi;\r
+ od;\r
+ if lg1 and i=j then lg1:=false fi;\r
+ if i<>j then\r
+ kon:=i;\r
+ pocz:=j;\r
+ if lg1 then lg1:=false;\r
+ (*porzadkowanie punktow lezacych na prostej poziomej,przechodzacych przez*)\r
+ (*punkt zaczepienia - punkty(1) ;tj.tworza kat zerowy z punktem zaczepienia *)\r
+ call sort(l3) ;\r
+ else\r
+ (*porzadkowanie punktow tworzacych ten sam kat rozny od zerowego*)\r
+ call sort(l2);\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ end posortuj;\r
+(*---------------------------------------------------------------------------*)\r
+begin (*PROGRAM GLOWNY*)\r
+ call gron(1);\r
+ call color(14);\r
+ call hframe(5,3,342,610);\r
+ call hframe(4,2,340,612);\r
+ call hframe(5,287,54,610);\r
+ call hframe(5,7,28,610);\r
+ call color(15);\r
+ call hwrite("CONVEX HULL by Joanna Hybel",185,17);\r
+ do\r
+ call dane;\r
+ call znajdz_max_y;\r
+ call wpisz_theta;\r
+ call posortuj;\r
+ call rys_otocz;\r
+ call hwrite("ESC - end of program execution",24,308);\r
+ call hwrite("ENTER - continue ",24,320);\r
+ do\r
+ ix:=inchar;\r
+ case ix\r
+ when 13:call zmaz(6,37,246,608);\r
+ exit;\r
+ when 27:exit exit;\r
+ otherwise;\r
+ esac;\r
+ od;\r
+ od;\r
+ call groff;\r
+end;\r
+end;\r
--- /dev/null
+ PROGRAM OT;\r
+(* Program zaliczeniowy Joanny Chromiec. Rysowanie otoczki wypuklej. *)\r
+BEGIN\r
+ \r
+pref IIUWgraph block\r
+ \r
+(* procedury i funkcje EKPAKU i funkcja wsp - pomagajace organizowac ekran *)\r
+ \r
+unit inchar: function:integer;\r
+ var ii:integer;\r
+ begin\r
+ do\r
+ ii:=inkey;\r
+ if ii<>0 then exit fi;\r
+ od;\r
+ result:=ii;\r
+end inchar;\r
+ \r
+unit NewPage : procedure;\r
+begin\r
+ write( chr(27), "[2J")\r
+end NewPage;\r
+ \r
+unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+end SetCursor;\r
+ \r
+unit wsp:function(arg:real;czy_x:boolean):integer;\r
+begin\r
+ result:= arg+5;\r
+ if czy_x then\r
+ result:=5+result\r
+ fi\r
+end wsp;\r
+ \r
+(* rysowanie strony tytulowej *)\r
+ \r
+unit tytul:procedure;\r
+begin\r
+ call newpage;\r
+ call setcursor(5,20);\r
+ writeln(" C O N V E X H U L L ");\r
+ call setcursor(10,10);\r
+ writeln(" written by JOANNA CHROMIEC ");\r
+ call setcursor(11,10);\r
+ WRITELN(" in LOGLAN programming language");\r
+ call setcursor(25,26);\r
+ WRITE ("press any key ");\r
+ control:=INCHAR\r
+end tytul;\r
+ \r
+(* wczytanie ilosci punktow, wylosowanie ich inarysowanie na ekranie *)\r
+ \r
+unit menu:procedure;\r
+ unit ramka : procedure;\r
+ var i:integer;\r
+ begin\r
+ call gron(0); call move(0,0); call draw(0,347);\r
+ call draw(719,347); call draw(719,0); call draw(0,0);\r
+ call move(0,310); call draw(719,310); call move(9,6);\r
+ call draw(11,6); call move(8,7); call draw(12,7);\r
+ call move(7,8); call draw(13,8); call move(10,5);\r
+ call draw(10,305); call draw(710,305); call move(709,304);\r
+ call draw(709,306); call move(708,304); call draw(708,306);\r
+ call move(707,303); call draw(707,307); call move(706,303);\r
+ call draw(706,307); call move(8,105); call draw(12,105);\r
+ call move(8,205); call draw(12,205); call move(109,304);\r
+ call draw(109,306); call move(110,304); call draw(110,306);\r
+ call move(209,304); call draw(209,306); call move(210,304);\r
+ call draw(210,306); call move(309,304); call draw(309,306);\r
+ call move(310,304); call draw(310,306); call move(409,304);\r
+ call draw(409,306); call move(410,304); call draw(410,306);\r
+ call move(509,304); call draw(509,306); call move(510,304);\r
+ call draw(510,306); call move(609,304); call draw(609,306);\r
+ call move(610,304); call draw(610,306);\r
+ end ramka;\r
+ \r
+ unit losowo:procedure;\r
+ begin\r
+ for i:=1 to n\r
+ do\r
+ punkty(i):=new punkt;\r
+ punkty(i).y:=(entier(random*1000)) mod 300;\r
+ punkty(i).x:=(entier(random*1000)+350) mod 700;\r
+ od;\r
+ for i:=1 to n\r
+ do\r
+ call cirb(wsp(punkty(i).x,true),wsp(punkty(i).y,false),2,2,2,1,1,5,5)\r
+ od\r
+ end losowo;\r
+ \r
+begin\r
+ CALL NEWPAGE;\r
+ CAll setcursor(5,5);\r
+ write("give a number of points : ");\r
+ readln(n);\r
+ array punkty dim(1:n);\r
+ call gron(0);\r
+ call ramka;\r
+ call losowo;\r
+end menu;\r
+ \r
+(* wybor punktu poczatkowego, wyliczenie thety dla reszty i posortowanie ich *)\r
+ \r
+unit przygotowanie : procedure;\r
+ \r
+ unit poy : function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.y>p2.y);\r
+ end poy;\r
+ \r
+ unit poth : function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.theta<p2.theta);\r
+ end poth;\r
+ \r
+ unit pox : function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.x<p2.x);\r
+ end pox;\r
+ \r
+ unit sort : procedure(poc,kon:integer;function porzadek(p1,p2:punkt):boolean);\r
+ \r
+ unit quicksort:procedure(l,p:integer);\r
+ var i,j:integer,\r
+ sr,w:punkt;\r
+ begin\r
+ i:=l; j:=p;\r
+ sr:=punkty((l+p) div 2);\r
+ do\r
+ while porzadek(punkty(i),sr) do i:=i+1 od;\r
+ while porzadek(sr,punkty(j)) do j:=j-1 od;\r
+ if i<=j then\r
+ w:=punkty(i);\r
+ punkty(i):=punkty(j);\r
+ punkty(j):=w;\r
+ i:=i+1;\r
+ j:=j-1;\r
+ fi;\r
+ if i>j then exit fi;\r
+ od;\r
+ if l<j then call quicksort(l,j) fi;\r
+ if i<p then call quicksort(i,p) fi;\r
+ end quicksort;\r
+ \r
+ begin\r
+ call quicksort(poc,kon);\r
+ end sort;\r
+ \r
+ unit wpisztheta : procedure;\r
+ unit licztheta : function (p:punkt):real;\r
+ var a, b, dx,dy:integer,\r
+ th:real;\r
+ begin\r
+ dx:=p.x-punkty(1).x;\r
+ dy:=p.y-punkty(1).y;\r
+ a:=abs (dx);\r
+ b:=abs (dy);\r
+ if dx=0 and dy=0 then th:=0\r
+ else\r
+ th:=dy/(a+b);\r
+ fi;\r
+ if dx<0 then th:=2-th\r
+ else\r
+ if dy<0 then th:=th+4 fi;\r
+ fi;\r
+ result:=th*90;\r
+ end licztheta;\r
+ \r
+ var i:integer;\r
+ \r
+ begin\r
+ for i:=2 to n\r
+ do\r
+ punkty(i).theta:=licztheta(punkty(i));\r
+ od;\r
+ end wpisztheta;\r
+ \r
+ unit znajdzdobry : procedure;\r
+ var pom:punkt,\r
+ tu:integer;\r
+ begin\r
+ tu:=1;\r
+ for i:=2 to n\r
+ do\r
+ if punkty(tu).y<punkty(i).y then\r
+ tu:=i\r
+ else\r
+ if punkty(tu).y=punkty(i).y then\r
+ if punkty(tu).x>punkty(i).x then tu:=i fi\r
+ fi\r
+ fi;\r
+ od;\r
+ pom:=punkty(tu);\r
+ punkty(tu):=punkty(1);\r
+ punkty(1):=pom\r
+ end znajdzdobry;\r
+ \r
+var i1, j1 :integer;\r
+ \r
+begin (* przygotowanie *)\r
+ call znajdzdobry;\r
+ call wpisztheta;\r
+ call sort(2,n,poth);\r
+ i1:=1;\r
+ do\r
+ if punkty(i1+1).theta=0 then i1:=i1+1 else exit fi;\r
+ if i1=n then exit fi;\r
+ od;\r
+ call sort(1,i1,pox);\r
+ i1:=i1+1;\r
+ j1:=i1;\r
+ while i1<n\r
+ do\r
+ do\r
+ if punkty(i1+1).theta=punkty(j1).theta then i1:=i1+1 else exit fi;\r
+ if i1=n then exit fi;\r
+ od;\r
+ call sort(j1,i1,poy);\r
+ i1:=i1+1;\r
+ j1:=i1\r
+ od;\r
+end przygotowanie;\r
+ \r
+(* procedura, szukajaca punktow otoczki za pomoca stosu *)\r
+ \r
+unit dzialaj:procedure;\r
+ \r
+var ind:integer,\r
+ pom:punkt;\r
+ \r
+ unit dobrze:function:boolean;\r
+ var dx,dx1,dx2,dy,dy1,dy2:real;\r
+ begin\r
+ dx:=stos.topd qua punkt.x-stos.topg qua punkt.x;\r
+ dy:=stos.topd qua punkt.y-stos.topg qua punkt.y;\r
+ dx1:=punkty(1).x-stos.topg qua punkt.x;\r
+ dy1:=punkty(1).y-stos.topg qua punkt.y;\r
+ dx2:=punkty(ind+1).x-stos.topd qua punkt.x;\r
+ dy2:=punkty(ind+1).y-stos.topd qua punkt.y;\r
+ result:=(dx*dy1-dy*dx1)*(dx*dy2-dy*dx2)>=0\r
+ end dobrze;\r
+ \r
+ unit rysodc: procedure;\r
+ begin\r
+ call move(wsp(stos.topg qua punkt.x,true),wsp(stos.topg qua punkt.y,false));\r
+ call draw(wsp(stos.topd qua punkt.x,true),wsp(stos.topd qua punkt.y,false));\r
+ end rysodc;\r
+ \r
+ unit zmazodc: procedure;\r
+ begin\r
+ call color(0);\r
+ call move(wsp(stos.topg qua punkt.x,true),wsp(stos.topg qua punkt.y,false));\r
+ call draw(wsp(stos.topd qua punkt.x,true),wsp(stos.topd qua punkt.y,false));\r
+ call color(1);\r
+ end zmazodc;\r
+ \r
+ unit typstos:class;\r
+ \r
+ var szczytg, szczytd : elstosu;\r
+ \r
+ unit topg : function : elstosu;\r
+ begin\r
+ result:=szczytg;\r
+ end topg;\r
+ \r
+ unit topd : function : elstosu;\r
+ begin\r
+ result:=szczytd;\r
+ end topd;\r
+ \r
+ unit usun:procedure;\r
+ begin\r
+ if szczytg<> none then\r
+ szczytg:=szczytd;\r
+ if szczytd<>none then szczytd:=szczytd.dowiazanie fi;\r
+ fi\r
+ end usun;\r
+ \r
+ unit wloz : procedure (el:elstosu);\r
+ begin\r
+ el.dowiazanie:=szczytg;\r
+ szczytd:=szczytg;\r
+ szczytg:=el;\r
+ end wloz;\r
+ \r
+ end typstos;\r
+ \r
+ var stos:typstos;\r
+ \r
+begin\r
+ stos:=new typstos;\r
+ for i:=1 to 2\r
+ do\r
+ pom:=copy(punkty(i));\r
+ call stos.wloz(pom);\r
+ od;\r
+ call rysodc;\r
+ for j:=1 to 200 do od;\r
+ for ind:=3 to n-1\r
+ do\r
+ pom:=copy(punkty(ind));\r
+ call stos.wloz(pom);\r
+ call rysodc;\r
+ for j:=1 to 200 do od;\r
+ while not dobrze\r
+ do\r
+ call zmazodc;\r
+ for j:=1 to 200 do od;\r
+ call stos.usun\r
+ od;\r
+ call rysodc\r
+ od;\r
+ pom:=copy(punkty(n));\r
+ call stos.wloz(pom) ;\r
+ call rysodc;\r
+ for j:=1 to 200 do od;\r
+ pom:=copy(punkty(1));\r
+ call stos.wloz(pom);\r
+ call rysodc;\r
+ for j:=1 to 200 do od;\r
+ (* tutaj rysowanie napisu czy chcesz dzialac dalej *)\r
+ call move(30,325);\r
+ call hascii(ord('r')); call hascii(ord('e')); \r
+ call hascii(ord('p')); call hascii(ord('e')); call hascii(ord('a')); \r
+ call hascii(ord('t')); call hascii(ord('?')); call hascii(ord('('));\r
+ call hascii(ord('y')); call hascii(ord('/'));\r
+ call hascii(ord('n'));\r
+ call hascii(ord(')'));\r
+ \r
+ control:=inchar;\r
+ \r
+end dzialaj;\r
+ \r
+ \r
+unit elstosu:class;\r
+ var dowiazanie:elstosu;\r
+end elstosu;\r
+ \r
+ \r
+unit punkt : elstosu class;\r
+ var\r
+ x,y:integer,\r
+ theta:real;\r
+end punkt;\r
+ \r
+var punkty:arrayof punkt;\r
+ \r
+var n,control,i,j:integer;\r
+ \r
+begin (* bloku *)\r
+ call tytul;\r
+ control:=ord('y');\r
+ while control=ord('y')\r
+ do\r
+ call menu;\r
+ call przygotowanie;\r
+ call dzialaj;\r
+ call groff\r
+ od\r
+end;\r
+END;\r
--- /dev/null
+PROGRAM GRAFIKA ;\r
+ \r
+BEGIN\r
+ \r
+PREF IIUWGRAPH BLOCK ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+SIGNAL error ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+CONST PI = 3.1415926536 ;\r
+ \r
+(*===========================================================================*)\r
+(* ZMIENNE GLOBALNE *)\r
+(*===========================================================================*)\r
+ \r
+VAR\r
+ datapoints : points ,\r
+ N : integer , (* Liczba punktow *)\r
+ srodek : punkt ,\r
+ stack : lifo ,\r
+ debug : file ,\r
+ pierjeryw : integer ,\r
+ monitor,message : okno ;\r
+ \r
+ \r
+ \r
+(*===========================================================================*)\r
+(* LIFO *)\r
+(*===========================================================================*)\r
+ \r
+ \r
+unit lifo: class ;\r
+ \r
+ VAR p : punkt ,\r
+ next : lifo ;\r
+end lifo ;\r
+ \r
+ (* *)\r
+ (* PUSH i POP *)\r
+ (* *)\r
+ \r
+ unit PUSH : procedure (p:punkt ;inout stos:lifo) ;\r
+ \r
+ VAR pom : lifo ;\r
+ BEGIN\r
+ pom := new lifo ;\r
+ pom.p := p ;\r
+ pom.next:=stos ;\r
+ stos := pom\r
+ \r
+ end PUSH ;\r
+ \r
+ unit pops : procedure (inout stos :lifo ) ;\r
+ \r
+ VAR pom : lifo ;\r
+ \r
+ BEGIN\r
+ pom := stos ;\r
+ stos := stos.next ;\r
+ kill (pom)\r
+ end pops ;\r
+ \r
+ \r
+ \r
+ \r
+(*===========================================================================*)\r
+(* Grafika *)\r
+(*===========================================================================*)\r
+ \r
+UNIT sufit :function (x:real):integer ;\r
+Begin\r
+ result := entier (x) ;\r
+ if result <> x then result := result + 1 fi\r
+end sufit ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT punkt : class (x,y : real) ;\r
+ \r
+ Unit kart : class ;\r
+ var xk , yk :real ;\r
+ begin\r
+ xk := x - srodek.x ;\r
+ yk := y - srodek.y\r
+ End kart ;\r
+ \r
+ \r
+end punkt ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT prosta : class ( A,B :punkt ) ;\r
+ \r
+Begin\r
+ if A.x = B.x andif A.y = B.y then raise error fi ;\r
+LASTWILL\r
+ kill (a) ;\r
+ kill (b)\r
+END prosta ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT segment : procedure ( a,b : punkt ) ;\r
+ \r
+VAR x,y,z,t :integer ;\r
+ \r
+BEGIN\r
+ call pushxy ;\r
+ x := 21 + (a.x * 55);\r
+ y := 284 - (a.y * 35);\r
+ z :=21 + (b.x * 55);\r
+ t := 284 - (b.y * 35);\r
+ call move (x ,y ) ;\r
+ call draw ( z ,t ) ;\r
+ call color (1) ;\r
+ call point (x , y ) ;\r
+ call cirb (x,y,2,0,0,1,1,1,1) ;\r
+ call point (z,t) ;\r
+ call cirb (z,t,2,0,0,1,1,1,1) ;\r
+ call popxy\r
+END segment ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT kursor : class (wr,kol : integer) ;\r
+ \r
+end kursor ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT okno : class (lg,pd : punkt ) ;\r
+ \r
+Var map : arrayof integer ,\r
+ rozm : integer ;\r
+ \r
+begin\r
+ rozm := 4 + ( pd.y-lg.y) * sufit((pd.x -lg.x ) / 8) ;\r
+ rozm := rozm div 2 + 1 ;\r
+ call move (lg.x,lg.y) ;\r
+ map := getmap(pd.x,pd.y) ;\r
+ kill (lg) ;\r
+ kill (pd)\r
+end okno ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT points : class ;\r
+ \r
+Var p : punkt ,\r
+ next : points ;\r
+ \r
+end points ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT uklad : procedure ;\r
+ \r
+VAR i,j : integer ,\r
+ pom1,pom2 : punkt ;\r
+ \r
+BEGIN\r
+ call move (20,10) ;\r
+ call draw (15,20) ;\r
+ call move (25,20) ;\r
+ call draw (20,10) ;\r
+ call draw (20,285) ;\r
+ call draw (545,285) ;\r
+ call draw (535,280) ;\r
+ call move (535,290) ;\r
+ call draw (545,285) ;\r
+ call move (9,288) ;\r
+ call hascii (48) ;\r
+ j := 0 ;\r
+ for i := 75 step 55 to 530 do\r
+ j := j+1 ;\r
+ call move (i,283) ;\r
+ call draw (i,287) ;\r
+ call move (i-4,288) ;\r
+ call hascii (48 + j)\r
+ od ;\r
+ j := 0 ;\r
+ for i := 250 step 35 downto 25 do\r
+ j := j+1 ;\r
+ call move (22,i) ;\r
+ call draw (18,i) ;\r
+ call move (9,i-4) ;\r
+ call hascii (48 + j) ;\r
+ od ;\r
+ \r
+END uklad ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT nwrite : procedure (n : integer ) ;\r
+BEGIN\r
+ if not (0 <= n and n <= 99) then\r
+ raise error\r
+ fi ;\r
+ call hascii (48 + n div 10 ) ;\r
+ call hascii (48 + n mod 10 )\r
+END nwrite ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+UNIT hwrite :procedure(s:string) ;\r
+ \r
+VAR i : integer ,\r
+ tab : arrayof character ;\r
+ \r
+BEGIN\r
+ tab := unpack (s) ;\r
+ for i := lower(tab) to upper(tab) do\r
+ call hascii(ord(tab(i)))\r
+ od ;\r
+ kill (tab)\r
+END hwrite ;\r
+ \r
+(*===========================================================================*)\r
+(* A N S I *)\r
+(*===========================================================================*)\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+ \r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ \r
+ unit EraseLine : procedure;\r
+ begin\r
+ write( chr(27), "[K")\r
+ end EraseLine;\r
+ \r
+ unit inchar : function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
+ unit CursorLeft : procedure (columns : integer);\r
+ var e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := columns div 10;\r
+ j := columns mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", e, f, "D")\r
+ end CursorLeft;\r
+ \r
+ unit CursorRight : procedure (columns : integer);\r
+ var e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := columns div 10;\r
+ j := columns mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", e, f, "C")\r
+ end CursorRight;\r
+ \r
+ unit CursorUp : procedure (rows : integer);\r
+ var c,d : char,\r
+ i,j : integer;\r
+ begin\r
+ i := rows div 10;\r
+ j := rows mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ write( chr(27), "[", c, d, "A")\r
+ end CursorUp;\r
+ \r
+ unit CursorDown : procedure (rows : integer);\r
+ var c,d : char,\r
+ i,j : integer;\r
+ begin\r
+ i := rows div 10;\r
+ j := rows mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ write( chr(27), "[", c, d, "B")\r
+ end CursorDown;\r
+ \r
+ \r
+UNIT czekaj :procedure ;\r
+ Var i :integer ;\r
+ Begin\r
+ i := inchar\r
+End czekaj ;\r
+ \r
+UNIT przerwa : procedure ;\r
+ Var i : integer ;\r
+ Begin\r
+ for i := 1 to pierjeryw do od\r
+End przerwa ;\r
+ \r
+(*========================================================================*)\r
+(*------------------------------------------------------------------------*)\r
+(* MENU GLOWNE *)\r
+(*------------------------------------------------------------------------*)\r
+(*========================================================================*)\r
+ \r
+ \r
+UNIT menu : procedure ;\r
+ \r
+VAR i,j :integer ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ Unit list : class ;\r
+ \r
+ Var nast,pop : list ;\r
+ \r
+ Unit virtual proc : procedure ;\r
+ Begin\r
+ End proc ;\r
+ \r
+ End ;\r
+ \r
+ VAR lista : list ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ UNIT run : list class ;\r
+ \r
+ unit virtual proc : procedure ;\r
+ \r
+ Var x,y : real ,\r
+ punkty : arrayof tpunkt ,\r
+ pr : prosta ,\r
+ poms : lifo ,\r
+ a,b : punkt ,\r
+ poml1 : points ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Unit tpunkt : punkt class ;\r
+ \r
+ Var b : bieg ;\r
+ \r
+ Unit bieg : class ;\r
+ var a,r : real ;\r
+ begin\r
+ writeln (debug , "353(bieg) reached");\r
+ r := sqrt ( (x - srodek.x)*(x - srodek.x) +\r
+ (y - srodek.y)*(y - srodek.y) ) ;\r
+ if (x - srodek.x) = 0 then\r
+ if (y - srodek.y) > 0 then\r
+ a := PI/2\r
+ else\r
+ a := -PI/2\r
+ fi\r
+ else\r
+ if (x - srodek.x) > 0 then\r
+ a := atan ((y - srodek.y)/(x - srodek.x))\r
+ else\r
+ a := atan ((y - srodek.y)/(x - srodek.x)) ;\r
+ a := PI + a\r
+ fi\r
+ fi\r
+ End bieg ;\r
+ \r
+ Begin\r
+ b := new bieg ;\r
+ Lastwill\r
+ kill (b)\r
+ End tpunkt ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Unit sort :procedure(a:arrayof tpunkt ;\r
+ function less (p1,p2 : tpunkt):boolean) ;\r
+ \r
+ Unit sorting:procedure (l,p : integer ) ;\r
+ var i,j : integer ,\r
+ x,w : punkt ;\r
+ Begin\r
+ i := l ; j := p ;\r
+ x := a ((l+p) div 2 ) ;\r
+ Do\r
+ while less (a(i),x) do i := i + 1 od ;\r
+ while less (x,a(j)) do j := j - 1 od ;\r
+ if i <= j then\r
+ w := a(i) ;\r
+ a(i) := a(j) ;\r
+ a(j) := w ;\r
+ i := i+1 ; j := j-1\r
+ fi ;\r
+ if i > j then exit fi\r
+ Od ;\r
+ if l < j then call sorting (l , j) fi ;\r
+ if i < p then call sorting (i , p) fi\r
+ End sorting ;\r
+ \r
+ Begin\r
+ call sorting (lower(a) , upper(a) )\r
+ End sort ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Unit prep:procedure ;\r
+ \r
+ Var miny : punkt ;\r
+ \r
+ Begin\r
+ poml1 := datapoints.next ;\r
+ miny := poml1.p ;\r
+ while poml1 <> none\r
+ do\r
+ if poml1.p.y < miny.y then\r
+ miny := poml1.p\r
+ fi ;\r
+ poml1 := poml1.next\r
+ od ;\r
+ srodek := miny\r
+ End prep ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Unit less1 : function (p1,p2 : tpunkt) : boolean ;\r
+ Begin\r
+ result := p1.b.a = p2.b.a ;\r
+ if result then\r
+ result := p1.b.r < p2.b.r\r
+ else\r
+ result := p1.b.a < p2.b.a\r
+ fi\r
+ End less1 ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Unit sameside : function (p1,p2 : punkt ; pr : prosta ) : boolean ;\r
+ \r
+ Var a,b : real ;\r
+ \r
+ Begin\r
+ a := (pr.B.y - pr.A.y) / (pr.B.x - pr.A.x) ;\r
+ b := pr.B.y - a * pr.B.x ;\r
+ result := (a * p1.x + b - p1.y) * (a * p2.x + b - p2.y) >= 0\r
+ End sameside ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Handlers\r
+ when error : terminate ;\r
+ End handlers ;\r
+ \r
+(* - - - - - - - - - - - - - - - - - - *)\r
+ \r
+ Begin\r
+ if N < 3 then raise error fi ;\r
+ call pushxy ;\r
+ writeln(debug,"");\r
+ writeln(debug,"RUN starts");\r
+ call move (100,320) ;\r
+ call hwrite("Quicksort working ");\r
+ call prep ;\r
+ writeln(debug,"PREP done");\r
+ array punkty dim (1 : N-1) ;\r
+ poml1 := datapoints.next ;\r
+ i := 1 ;\r
+ while poml1 <> none\r
+ do\r
+ if poml1.p <> srodek then\r
+ punkty (i) := new tpunkt(poml1.p.x,poml1.p.y) ;\r
+ i := i + 1 ;\r
+ writeln(debug,"PUNKTY (",i:2,") done");\r
+ fi ;\r
+ poml1 := poml1.next ;\r
+ od ;\r
+ if i <> N then raise error fi ;\r
+ writeln(debug,"PUNKTY done");\r
+ call sort (punkty,less1) ;\r
+ call hwrite("done !") ;\r
+ writeln(debug,"QUICKSORT done");\r
+ for I := 1 to N-1\r
+ do\r
+ writeln (debug,punkty(i).b.a) ;\r
+ od ;\r
+ \r
+ \r
+ (*------------- T O J E S T D U S Z A P R O G R A M U ----------------*)\r
+ \r
+ call color (1) ;\r
+ call push (srodek,stack ) ;\r
+ call push (punkty (1) , stack ) ;\r
+ call segment (srodek,stack.p) ;\r
+ call przerwa ;\r
+ call push (punkty (2) , stack ) ;\r
+ call przerwa ;\r
+ call segment (stack.next.p,stack.p) ;\r
+ for i := 3 to N-1\r
+ do\r
+ call color (1) ;\r
+ call przerwa ;\r
+ call segment (stack.p,punkty(i)) ;\r
+ a :=copy (stack.p) ;b:=copy (stack.next.p) ;\r
+ pr := new prosta(a,b) ;\r
+ while not sameside (punkty(i),srodek,pr)\r
+ do\r
+ call color (0) ;\r
+ call przerwa ;\r
+ call segment (punkty(i) , stack.p) ;\r
+ call przerwa ;\r
+ call segment (stack.p,stack.next.p) ;\r
+ call pops (stack) ;\r
+ call color (1) ;\r
+ call przerwa ;\r
+ call segment (stack.p,punkty(i) ) ;\r
+ kill (pr.a);kill(pr.b) ;\r
+ kill (pr) ;\r
+ a := copy (stack.p) ;\r
+ b := copy (stack.next.p) ;\r
+ pr := new prosta(a,b) ;\r
+ od ;\r
+ kill (pr.a);kill(pr.b) ;\r
+ kill (pr) ;\r
+ call push (punkty(i),stack)\r
+ od ;\r
+ call color (1) ;\r
+ call przerwa ;\r
+ call segment (stack.p,srodek) ;\r
+ writeln(debug,"OTOCZKA DONE") ;\r
+ poms := stack.next ;\r
+ writeln(debug,"a done") ;\r
+ while poms.p <> none\r
+ do\r
+ call segment (stack.p, poms.p) ;\r
+ writeln(debug,"b done") ;\r
+ stack := poms ;\r
+ poms := poms.next ;\r
+ if poms = none then exit fi\r
+ od ;\r
+ writeln(debug,"STACK REWRITTEN") ;\r
+ poml1 := datapoints.next ;\r
+ while poml1 <> none\r
+ do\r
+ x := 21 + (poml1.p.x * 55) ;\r
+ y := 284 - (poml1.p.y * 35) ;\r
+ call point ( x , y ) ;\r
+ call cirb (x,y,2,0,0,1,1,1,1) ;\r
+ poml1 := poml1.next\r
+ od ;\r
+ writeln(debug,"POINTS REWRITTEN") ;\r
+ message := new okno (new punkt(100,320),new punkt(530,330)) ;\r
+ call move(100,320) ;\r
+ call xormap(message.map);\r
+ kill (message.map) ;\r
+ kill (message) ;\r
+ poms := stack ;\r
+ while stack <> none\r
+ do\r
+ poms := poms.next ;\r
+ kill (stack) ;\r
+ stack := poms\r
+ od ;\r
+ writeln(debug,"stack killed") ;\r
+ for i := 1 to N-1\r
+ do\r
+ kill (punkty(i).b) ;\r
+ kill (punkty(i))\r
+ od ;\r
+ kill (punkty) ;\r
+ call popxy\r
+ end proc ;\r
+ \r
+ End run\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ Unit randp : list class ;\r
+ \r
+ Unit virtual proc : procedure ;\r
+ \r
+ Var M,i,j : integer ,\r
+ poml1 : points ,\r
+ x,y : real ;\r
+ Begin\r
+ call pushxy ;\r
+ call move (150,305) ;\r
+ call hwrite ("There are ");\r
+ call nwrite(N) ;\r
+ call hwrite (" points now .") ;\r
+ call move (150 , 327) ;\r
+ call hwrite ("How many new points generate ?") ;\r
+ call move (440,316) ;\r
+ call hwrite("M = ") ;\r
+ i := 0 ;\r
+ while i<48 or i>57\r
+ do\r
+ i := inchar\r
+ od ;\r
+ call hascii ( i ) ;\r
+ j := 0 ;\r
+ while (j<48 or j>57) and j<>13\r
+ do\r
+ j := inchar\r
+ od ;\r
+ if j = 13 then\r
+ M := i-48\r
+ else\r
+ call haSCII (j) ;\r
+ M := (i-48)*10 + j-48 ;\r
+ while i <> 13 do i := inchar od\r
+ fi ;\r
+ \r
+ if N + M > 99 then M := 99 - N fi ;\r
+ N := N + M ;\r
+ poml1 := datapoints ;\r
+ while poml1.next <> none\r
+ do\r
+ poml1 := poml1.next\r
+ od ;\r
+ for i := 1 to M\r
+ do\r
+ poml1.next := new points ;\r
+ poml1 := poml1.next ;\r
+ poml1.p := new punkt (random * 9 , random * 7 ) ;\r
+ x := 21 + (poml1.p.x * 55) ;\r
+ y := 284 - (poml1.p.y * 35) ;\r
+ call point ( x , y ) ;\r
+ call cirb (x,y,2,0,0,1,1,1,1) ;\r
+ od ;\r
+ call move (6,301) ;\r
+ message := new okno (new punkt(6,301),new punkt (549,339) );\r
+ call xormap (message.map) ;\r
+ kill (message.map) ;\r
+ kill (message) ;\r
+ call popxy\r
+ \r
+ end proc\r
+ End randp ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ Unit Inputp : list class ;\r
+ \r
+ Unit virtual proc :procedure ;\r
+ \r
+ Var poml1 : points ,\r
+ a,b : integer ,\r
+ x,y : real ;\r
+ \r
+ begin\r
+ call pushxy ;\r
+ if N = 99 then\r
+ call move (70,315);\r
+ call hwrite (" To many points (Ok?)") ;\r
+ while i <> 13\r
+ do\r
+ i := inchar\r
+ od ;\r
+ call move (50,315) ;\r
+ message := new okno(new punkt(50,315),new punkt(60,550));\r
+ call xormap (message.map) ;\r
+ kill (message.map) ;\r
+ kill (message) ;\r
+ else\r
+ poml1 := datapoints ;\r
+ while poml1.next <> none\r
+ do\r
+ poml1 := poml1.next\r
+ od ;\r
+ call move(100,315) ;\r
+ call hwrite("Press 'End' when ready") ;\r
+ call move (225,150) ;\r
+ call track (inxpos,inypos) ;\r
+ if 20 < inxpos andif inxpos < 548 andif\r
+ 7 < inypos andif inypos < 280 then\r
+ x := inxpos ;\r
+ y := inypos ;\r
+ call point ( x , y ) ;\r
+ call cirb (x,y,2,0,0,1,1,1,1) ;\r
+ Writeln(debug,"Nowy punkt -",x:3,",",y:3);\r
+ poml1.next := new points ;\r
+ poml1 := poml1.next ;\r
+ poml1.p := new punkt ((x-20)/55,(285-y)/35 ) ;\r
+ N := N + 1\r
+ fi ;\r
+ call move (100,315) ;\r
+ message := new okno(new punkt(100,315),new punkt(500,330)) ;\r
+ call xormap(message.map) ;\r
+ kill (message.map) ;\r
+ kill (message) ;\r
+ poml1 := datapoints ;\r
+ i := 0;\r
+ while poml1.next <> none\r
+ do\r
+ poml1 := poml1.next ;\r
+ I := I + 1\r
+ od ;\r
+ writeln (debug,i : 3,"PUNKTOW wlozonych") ;\r
+ fi ;\r
+ call popxy ;\r
+ end proc ;\r
+ \r
+ End inputp ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ UNIT delp : list class ;\r
+ \r
+ Unit virtual proc :procedure ;\r
+ \r
+ Var poml1,poml2 : points ;\r
+ \r
+ Begin\r
+ call pushxy ;\r
+ call move ( 50,315) ;\r
+ call hwrite ("Are you sure ? (y/n) ") ;\r
+ i := 0 ;\r
+ while i <> 121 and i <> 110\r
+ do\r
+ i := inchar\r
+ od ;\r
+ if i = 121 then\r
+ poml1 := datapoints.next ;\r
+ while poml1 <> none\r
+ do\r
+ poml2 := poml1.next ;\r
+ kill (poml1.p) ;\r
+ kill (poml1) ;\r
+ poml1 := poml2\r
+ od ;\r
+ N := 0 ;\r
+ monitor := new okno (new punkt (6,6),new punkt(549,299) ) ;\r
+ call move (6,6) ;\r
+ call xormap(monitor.map) ;\r
+ kill (monitor.map) ;\r
+ kill (monitor) ;\r
+ call uklad ;\r
+ fi ;\r
+ call move (50,315) ;\r
+ for i := 1 to 21\r
+ do\r
+ call hascii(0) ;\r
+ call move (inxpos+8,inypos)\r
+ od ;\r
+ \r
+ call popxy\r
+ end proc ;\r
+ \r
+ begin\r
+ End delp ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+UNIT Clrscr : list class ;\r
+ \r
+Unit virtual proc : procedure ;\r
+ \r
+Var x,y : real ,\r
+ poml1 : points ;\r
+ \r
+Begin\r
+ call pushxy ;\r
+ monitor := new okno (new punkt(6,6),new punkt(549,299)) ;\r
+ call xormap (monitor.map) ;\r
+ kill (monitor.map) ;\r
+ kill (monitor) ;\r
+ call uklad ;\r
+ poml1 := datapoints.next ;\r
+ while poml1 <> none\r
+ do\r
+ x := 21 + (poml1.p.x * 55) ;\r
+ y := 284 - (poml1.p.y * 35) ;\r
+ call point ( x , y ) ;\r
+ call cirb (x,y,2,0,0,1,1,1,1) ;\r
+ poml1 := poml1.next\r
+ od ;\r
+ call popxy\r
+End proc ;\r
+ \r
+END clrscr ;\r
+ \r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ Unit pstryczek : procedure (a,b : integer );\r
+ \r
+ Unit ramka: procedure(a,b:integer) ;\r
+ begin\r
+ call move (a-1,b-1) ;\r
+ call draw (a+19*8+2 , b-1) ;\r
+ call draw (a+19*8+2 , b+9) ;\r
+ call draw (a-1,b+9 ) ;\r
+ call draw (a-1,b-1) ;\r
+ call move (a,b)\r
+ end ramka ;\r
+ \r
+ \r
+ Begin\r
+ call COLOR (0) ;\r
+ call ramka(inxpos,inypos) ;\r
+ call move (a,b) ;\r
+ call color (11) ;\r
+ call ramka(a,b) ;\r
+ \r
+ End pstryczek ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ BEGIN\r
+ lista:= new randp ;\r
+ lista.pop := new clrscr ;\r
+ lista.pop.nast := lista ;\r
+ lista.nast := new inputp ;\r
+ lista.nast.pop := lista ;\r
+ lista.nast.nast := new delp ;\r
+ lista.nast.nast.pop := lista.nast ;\r
+ lista.nast.nast.nast := new run ;\r
+ lista.nast.nast.nast.pop :=lista.nast.nast ;\r
+ lista.nast.nast.nast.nast := lista.pop ;\r
+ lista.pop.pop := lista.nast.nast.nast ;\r
+ \r
+ call move (580,50);\r
+ call hwrite("Random points ") ;\r
+ call move (580,80) ;\r
+ call hwrite("Input point") ;\r
+ call move (580,110) ;\r
+ call hwrite("Del points") ;\r
+ call move (580,140) ;\r
+ call hwrite("R U N") ;\r
+ call move (580,170) ;\r
+ call hwrite("Clr scr") ;\r
+ call move (560 , 300) ;\r
+ call hwrite ("Press 'Esc' to quit") ;\r
+ \r
+ call pstryczek (555,50) ;\r
+ j := 50 ;\r
+ DO\r
+ i := inchar ;\r
+ if i = 27 then exit fi ;\r
+ if i = 13 then\r
+ call lista.proc\r
+ else\r
+ \r
+ case i + 80\r
+ \r
+ when 0 : lista := lista.nast ;\r
+ if j = 170 then\r
+ j := 50 ;\r
+ call pstryczek (555,50) ;\r
+ else\r
+ j :=j+30 ;\r
+ call pstryczek (555,j)\r
+ fi ;\r
+ \r
+ when 8 : lista := lista.pop ;\r
+ if j = 50 then\r
+ j := 170 ;\r
+ call pstryczek (555,170) ;\r
+ else\r
+ j :=j-30 ;\r
+ call pstryczek (555,j)\r
+ fi ;\r
+ esac\r
+ fi\r
+ OD\r
+ \r
+ END menu ;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+(* KONIEC MENU GLOWNEGO *)\r
+(*------------------------------------------------------------------------*)\r
+ \r
+UNIT welcome : procedure ;\r
+ \r
+ Unit ramka : procedure ;\r
+ \r
+ end ramka ;\r
+ \r
+begin\r
+ call newpage ;\r
+ \r
+ \r
+ call setcursor (10,30)\r
+ \r
+end welcome ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+HANDLERS\r
+ when error : call groff ;\r
+ writeln (" BLAD ! ") ;\r
+ call czekaj ;\r
+ call endrun\r
+END handlers ;\r
+ \r
+(*===========================================================================*)\r
+ \r
+BEGIN (* BLOKU GLOWNY *)\r
+ pierjeryw := 20 ;\r
+ datapoints := new points ;\r
+ stack := new lifo ;\r
+ open (debug,text,unpack("debug.dub"));\r
+ call rewrite(debug) ;\r
+ call gron(1);\r
+ call move (5,5) ;\r
+ call draw (715,5) ;\r
+ call draw (715,340) ;\r
+ call draw (5,340) ;\r
+ call draw (5,5) ;\r
+ call move (550,5) ;\r
+ call draw (550,340) ;\r
+ call move (550,300) ;\r
+ call draw (5,300) ;\r
+ call uklad ;\r
+ call menu ;\r
+ call groff ;\r
+ \r
+END\r
+ \r
+END GRAFIKA\r
--- /dev/null
+PROGRAM convexhull;\r
+\r
+ (* BAYEUL St\82phane Licence Informatique Groupe 1 *)\r
+\r
+VAR p : ARRAYOF points,\r
+ taille,i,j,n,O12,guziki,c : INTEGER,\r
+ choix,souris,valeur,chaine : ARRAYOF CHAR,\r
+ ligne : LINE,\r
+ inst,quitter : BOOLEAN;\r
+\r
+\r
+(***********************************************************************)\r
+ UNIT POINTS : CLASS;\r
+(***********************************************************************)\r
+VAR x,y : INTEGER,\r
+ z : CHAR;\r
+END points;\r
+\r
+(***********************************************************************)\r
+ UNIT LINE : CLASS;\r
+(***********************************************************************)\r
+VAR p1,p2 : points;\r
+END line;\r
+\r
+(***********************************************************************)\r
+ UNIT NEWPAGE : PROCEDURE;\r
+(***********************************************************************)\r
+BEGIN\r
+ WRITE ( CHR (27), "[2J");\r
+END newpage;\r
+\r
+(***********************************************************************)\r
+ UNIT SETCURSOR : PROCEDURE (ROW,COLUMN : INTEGER);\r
+(***********************************************************************)\r
+VAR c,d,e,f : CHAR,\r
+ i,j : INTEGER;\r
+ BEGIN\r
+ i := row DIV 10;\r
+ j := row MOD 10;\r
+ c := CHR (48+i);\r
+ d := CHR (48+j);\r
+ i := column DIV 10;\r
+ j := column MOD 10;\r
+ e := CHR (48+i);\r
+ f := CHR (48+j);\r
+ WRITE ( CHR (27), "[", c, d, ";", e, f, "H");\r
+END setcursor;\r
+\r
+(***********************************************************************)\r
+ UNIT TRANSENTIER : PROCEDURE (INPUT chaine : ARRAYOF char;\r
+ OUTPUT nbr : INTEGER);\r
+(***********************************************************************)\r
+\r
+ (* TRANSFORME UNE CHAINE DE CARACTERES EN UN ENTIER *)\r
+\r
+VAR i : INTEGER;\r
+BEGIN\r
+ nbr := 0;\r
+ FOR i := 1 to UPPER (chaine) DO\r
+ CASE chaine(i)\r
+ WHEN '0','1','2','3','4','5','6','7','8','9' :\r
+ nbr := (nbr*10)+(ord(chaine(i))-48);\r
+ ESAC;\r
+ OD;\r
+END transentier;\r
+\r
+(***********************************************************************)\r
+ UNIT FILL : PROCEDURE (X,Y,Large,Haut,Col:INTEGER) ;\r
+(***********************************************************************)\r
+\r
+VAR I : INTEGER ;\r
+BEGIN\r
+ PREF IIUWGRAPH BLOCK\r
+ BEGIN\r
+ CALL COLOR (Col) ;\r
+ FOR I:=Y TO Y+Haut\r
+ DO\r
+ CALL MOVE(X,I) ;\r
+ CALL DRAW(X+Large,I) ;\r
+ OD ;\r
+ END ;\r
+END FILL;\r
+\r
+(***********************************************************************)\r
+ UNIT TEXTE : PROCEDURE (X,Y : INTEGER;\r
+ S : STRING);\r
+(***********************************************************************)\r
+\r
+ (* Saisie d'un string en colonne X et ligne Y *)\r
+\r
+BEGIN\r
+ PREF IIUWGRAPH BLOCK\r
+ BEGIN\r
+ CALL MOVE (X,Y);\r
+ CALL OUTSTRING(s);\r
+ END ;\r
+END Texte;\r
+\r
+(***********************************************************************)\r
+ UNIT SAISIECHAINE : PROCEDURE (INPUT Col,Lig : INTEGER;\r
+ OUTPUT Valeur : ARRAYOF CHAR);\r
+(***********************************************************************)\r
+\r
+ (* Saisie d'une chaine de caract\8ares en graphique *)\r
+\r
+VAR C,I,X : INTEGER;\r
+\r
+BEGIN\r
+PREF IIUWGRAPH BLOCK\r
+BEGIN\r
+ ARRAY VALEUR DIM (1:5);\r
+ X := COL;\r
+ C := 0;\r
+ I := 1;\r
+ DO\r
+ C := 0 ;\r
+ WHILE C = 0\r
+ DO\r
+ CALL COLOR (12) ;\r
+ CALL TEXTE (X,LIG-4," ");\r
+ C := INKEY;\r
+ CALL TEXTE (X,LIG,"-");\r
+ OD;\r
+ CALL MOVE (X,LIG-4) ;\r
+ IF (C=13) THEN CALL MOVE (X,LIG-4);CALL HASCII(0);EXIT; FI;\r
+ IF (C=8) THEN\r
+ IF X > COL THEN\r
+ I := I-1;\r
+ X := X-8;\r
+ CALL MOVE (X,LIG-4);\r
+ CALL HASCII (0);\r
+ CALL TEXTE (X,LIG," ");\r
+ CALL MOVE (X,LIG-4);\r
+ FI;\r
+ ELSE\r
+ IF I <= 5 THEN\r
+ CALL HASCII (0) ;\r
+ CALL HASCII (c);\r
+ VALEUR (i) := CHR (C);\r
+ I:=I+1;\r
+ X:=X+8;\r
+ ELSE\r
+ CALL COLOR(11);\r
+ CALL TEXTE(105,258,"Chaine trop longue ");\r
+ CALL TEXTE(105,274,"Appuyez sur une touche pour continuer");\r
+ WHILE INKEY=0 DO OD;\r
+ CALL FILL (101,251,398,58,0) ;\r
+ FI;\r
+ FI;\r
+ OD;\r
+END;\r
+END SAISIECHAINE;\r
+\r
+(***********************************************************************)\r
+ UNIT TAB_PREDEFINI : PROCEDURE;\r
+(***********************************************************************)\r
+BEGIN\r
+ (******************************************************)\r
+ (* 0 <= X >= 52 et 0 <= Y >= 26 *)\r
+ (******************************************************)\r
+ taille := 16;\r
+ ARRAY p DIM (0:taille+1);\r
+ FOR i:=0 TO taille+1 DO\r
+ p(i) := NEW points;\r
+ OD;\r
+ p(1).x:=3 ;p(1).y:=9 ;p(1).z:='A' ;p(2).x:=11 ;p(2).y:=1 ;p(2).z:='B' ;\r
+ p(3).x:=6 ;p(3).y:=8 ;p(3).z:='C' ;p(4).x:=4 ;p(4).y:=3 ;p(4).z:='D' ;\r
+ p(5).x:=5 ;p(5).y:=15 ;p(5).z:='E' ;p(6).x:=8 ;p(6).y:=11 ;p(6).z:='F' ;\r
+ p(7).x:=1 ;p(7).y:=6 ;p(7).z:='G' ;p(8).x:=7 ;p(8).y:=4 ;p(8).z:='H' ;\r
+ p(9).x:=9 ;p(9).y:=7 ;p(9).z:='I' ;p(10).x:=14;p(10).y:=5 ;p(10).z:='J';\r
+ p(11).x:=10;p(11).y:=13;p(11).z:='K';p(12).x:=15;p(12).y:=14;p(12).z:='L';\r
+ p(13).x:=15;p(13).y:=2 ;p(13).z:='M';p(14).x:=13;p(14).y:=16;p(14).z:='N';\r
+ p(15).x:=2 ;p(15).y:=12;p(15).z:='O';p(16).x:=12;p(16).y:=10;p(16).z:='P';\r
+ p(0):=p(16);p(17):=p(1);\r
+END tab_predefini;\r
+\r
+(***********************************************************************)\r
+ UNIT SAISIE_SOURIS : MOUSE PROCEDURE;\r
+(***********************************************************************)\r
+ VAR h,v,t,b,nbr : INTEGER,\r
+ l,r,c,fin : BOOLEAN;\r
+ BEGIN\r
+ PREF IIUWgraph BLOCK\r
+ BEGIN\r
+ CALL cls; CALL affiche_grille;\r
+ b:=0;\r
+ inst := INIT (guziki);\r
+ IF NOT inst THEN\r
+ CALL TEXTE(100,100,"Erreur d'installation de la souris");EXIT;\r
+ FI;\r
+ CALL DEFCURSOR (1,11,12);\r
+ CALL SHOWCURSOR;\r
+ CALL STATUS (h,v,l,r,c);\r
+ nbr := 1;\r
+ fin := FALSE;\r
+ WHILE NOT fin AND nbr<=taille DO\r
+ CALL GETPRESS (b,h,v,t,l,r,c);\r
+ IF l THEN\r
+ IF 0 <= h DIV 012 ANDIF h DIV O12 <= (640-11) DIV O12 ANDIF\r
+ 0 <= (316-v) DIV O12 ANDIF (316-v) DIV O12 <= 319 DIV O12 THEN\r
+ (* COORDONNEES VALABLES *);\r
+ p(nbr) := NEW points;\r
+ p(nbr).x := h DIV O12;\r
+ p(nbr).y := (316-v) DIV O12;\r
+ p(nbr).z := CHR (64+nbr);\r
+ CALL MOVE (h,v) ;\r
+ CALL MOVE (p(nbr).x*O12+9,316-(p(nbr).y*O12));\r
+ CALL HIDECURSOR ; CALL COLOR (2);\r
+ CALL HASCII (ord(p(nbr).z));\r
+ CALL SHOWCURSOR ; CALL COLOR (3);\r
+ FOR i:=1 TO 3000 DO OD;\r
+ nbr:=nbr+1;\r
+ ELSE (* COORDONNEES NON VALABLES *);\r
+ CALL GETPRESS (b,h,v,t,l,r,c);\r
+ FI;\r
+ FI;\r
+ OD;\r
+ p(0) := p(taille); p(taille+1) := p(1);\r
+ CALL HIDECURSOR;\r
+ END;\r
+END saisie_souris;\r
+\r
+(***********************************************************************)\r
+ UNIT SAISIE_POINTS : IIUWgraph PROCEDURE;\r
+(***********************************************************************)\r
+VAR\r
+ size,i : INTEGER,\r
+ valable : BOOLEAN;\r
+BEGIN\r
+ CALL TEXTE (100,230," 0 <= X >= 52 et 0 <= Y >= 26 ");\r
+ FOR i:=1 TO taille DO\r
+ p(i) := NEW points;\r
+ valable := FALSE;\r
+ WHILE NOT valable DO\r
+ CALL COLOR (7);\r
+ CALL TEXTE (100,240,"Abscisses du point nø : ");\r
+ CALL TEXTE (100,250,"Ordonn\82es du point nø : ");\r
+ CALL COLOR (10);\r
+ CALL MOVE (290,240);CALL HASCII (64+i);\r
+ CALL MOVE (290,250);CALL HASCII (64+i);\r
+ CALL COLOR (4);\r
+ CALL SAISIECHAINE (350,244,chaine);\r
+ CALL TRANSENTIER (chaine,p(i).x);\r
+ CALL SAISIECHAINE (350,254,chaine);\r
+ CALL TRANSENTIER (chaine,p(i).y);\r
+ IF p(i).x<0 ORIF p(i).x > ((640-11) DIV O12) THEN\r
+ valable:=FALSE;\r
+ ELSE IF p(i).y<0 ORIF p(i).y > (319 DIV O12) THEN\r
+ valable:=FALSE;\r
+ ELSE valable := TRUE;\r
+ FI;\r
+ FI;\r
+ p(i).z := CHR (64+i);\r
+ CALL TEXTE (290,254," ");\r
+ CALL TEXTE (290,244," ");\r
+ OD;\r
+ OD;\r
+ p(0) := p(taille); p(taille+1) := p(1);\r
+END saisie_points;\r
+\r
+(***********************************************************************)\r
+ UNIT AFFICHE_GRILLE : mouse PROCEDURE;\r
+(***********************************************************************)\r
+VAR i : INTEGER;\r
+BEGIN\r
+ PREF IIUWgraph BLOCK\r
+ BEGIN (* Graduations *)\r
+ CALL COLOR (7);\r
+ FOR i := 11 STEP O12 TO 640 DO\r
+ CALL TEXTE (i,314,".");\r
+ OD;\r
+ FOR i := 315 STEP O12 DOWNTO 0 DO\r
+ CALL TEXTE (11,i,".");\r
+ OD; (* Reperes *)\r
+ CALL TEXTE (8,16,"Y");\r
+ CALL TEXTE (8,26,"^");\r
+ CALL TEXTE (614,316,"> X");\r
+ CALL MOVE (618,319);\r
+ CALL DRAW (11,319); (* Ligne horizontale *)\r
+ CALL DRAW (11,26); (* Ligne verticale *)\r
+ END;\r
+END affiche_grille;\r
+\r
+(***********************************************************************)\r
+ UNIT THETA : FUNCTION(P1,P2 : POINTS): REAL;\r
+(***********************************************************************)\r
+VAR dx,dy,ax,ay : INTEGER,\r
+ t : REAL;\r
+BEGIN\r
+ dx := p2.x - p1.x; ax := ABS (dx);\r
+ dy := p2.y - p1.y; ay := ABS (dy);\r
+ IF (dx=0) AND (dy=0) THEN\r
+ t := 0;\r
+ ELSE t := dy/(ax+ay);\r
+ FI;\r
+ IF dx<0 THEN\r
+ t := 2-t;\r
+ ELSE IF dy<0 THEN\r
+ t := 4+t;\r
+ FI;\r
+ FI;\r
+ result := t*90.0;\r
+END theta;\r
+\r
+(***********************************************************************)\r
+ UNIT WRAP : PROCEDURE (INOUT N : INTEGER);\r
+(***********************************************************************)\r
+VAR j,i,min,m : INTEGER,\r
+ minangle,v : REAL,\r
+ t,tb,p1,p2,prec : points,\r
+ ligne : line;\r
+BEGIN\r
+ min :=1 ; tb := NEW points; t := NEW points;\r
+ p1 := NEW points; p2 := NEW points;\r
+ ligne := NEW line ; prec := NEW points;\r
+ (* Choix du premier point *)\r
+ FOR i := 2 TO taille DO\r
+ IF p(i).y<p(min).y THEN\r
+ min := i;\r
+ ELSE IF p(i).y=p(min).y THEN\r
+ IF p(i).x>p(min).x THEN\r
+ min := i;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ (* Initialisations *)\r
+ m := 0; p(taille+1) := p(min); minangle := 0.0;\r
+ (* Boucle de Recherche *)\r
+ DO\r
+ m:=m+1 ; t:=p(m) ; p(m):=p(min) ;p(min):=t;\r
+ min:=taille+1; v:=minangle; minangle:=360.0;\r
+ FOR i:=m+1 TO taille+1 DO\r
+ (* Recherche du plus petit angle *)\r
+ IF theta (p(m),p(i))>v THEN\r
+ (* Recherche du point suivant *)\r
+ IF theta (p(m),p(i)) < minangle THEN\r
+ min := i; minangle := theta (p(m),p(min));\r
+ FI;\r
+ (* Cas ou plusieurs points sont alignes *)\r
+ IF theta (p(m),p(i)) = minangle ANDIF p(min)<>p(i) THEN\r
+ ligne.p1 := p(m); ligne.p2 := p(min);\r
+ IF NOT on (ligne,p(i)) THEN\r
+ min := i; minangle := theta (p(m),p(min));\r
+ FI;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ IF min = taille+1 THEN EXIT;\r
+ FI;\r
+ OD;\r
+ n:=M;\r
+END wrap;\r
+\r
+(***********************************************************************)\r
+ UNIT ON : FUNCTION (L:LINE;P1:POINTS):BOOLEAN;\r
+(***********************************************************************)\r
+BEGIN\r
+ result := FALSE;\r
+ IF (l.p1.x=p1.x) THEN\r
+ IF l.p1.y>=p1.y ANDIF p1.y>=l.p2.y THEN\r
+ result:=TRUE\r
+ ELSE IF l.p2.y>=p1.Y ANDIF p1.Y>=l.p1.y THEN\r
+ result:=TRUE;\r
+ FI;\r
+ FI;\r
+ ELSE\r
+ IF (l.p1.y=p1.Y) THEN\r
+ IF l.p1.x<=p1.x ANDIF p1.x<=l.p2.x THEN\r
+ result:=TRUE\r
+ ELSE IF l.p2.x<=p1.x ANDIF p1.X<=l.p1.x THEN\r
+ result:=TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+END on;\r
+\r
+(***********************************************************************)\r
+ UNIT AFFICHE_ENVELOPPE : IIUWgraph PROCEDURE;\r
+(***********************************************************************)\r
+BEGIN\r
+ PREF mouse BLOCK\r
+ BEGIN\r
+ CALL COLOR(8);\r
+ CALL HIDECURSOR;\r
+ FOR i:=1 TO n-1 DO\r
+ CALL MOVE ((p(i).x*O12)+ O12,316-(p(i).y*O12)+O12 DIV 4);\r
+ CALL DRAW ((p(i+1).x*O12)+ O12,316-(p(i+1).y*O12)+O12 DIV 4);\r
+ OD;\r
+ CALL MOVE ((p(n).x*O12)+ O12,316-(p(n).y*O12)+O12 DIV 4);\r
+ CALL DRAW ((p(1).x*O12)+ O12,316-(p(1).y*O12)+O12 DIV 4);\r
+ CALL SHOWCURSOR;\r
+ END;\r
+ CALL COLOR (6);\r
+ CALL TEXTE (50,335,"L'enveloppe convexe est :");\r
+ FOR i:=1 TO n DO\r
+ CALL MOVE (300+(i*10),335);\r
+ CALL HASCII (ord(p(i).z));\r
+ OD;\r
+ CALL COLOR (5);\r
+ CALL TEXTE (150,325,"Appuyez sur ENTREE pour continuer");\r
+ C := 0;\r
+ WHILE C <> 13 DO\r
+ C := INKEY;\r
+ OD;\r
+END affiche_enveloppe;\r
+\r
+(***********************************************************************)\r
+(* Programme principal *)\r
+(***********************************************************************)\r
+BEGIN\r
+ PREF IIUWgraph BLOCK\r
+ BEGIN\r
+ O12:=12;\r
+ CALL GRON(nocard);\r
+ quitter:=FALSE;\r
+ WHILE NOT quitter DO\r
+ CALL CLS; CALL COLOR (1);\r
+ CALL TEXTE (100,10,"ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿");\r
+ CALL TEXTE (100,20,"³ Enveloppe convexe ³");\r
+ CALL TEXTE (100,30,"ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ");\r
+ CALL COLOR (2);\r
+ CALL TEXTE (80,100,"Voulez_vous : aisir des points");\r
+ CALL TEXTE (80,110," tiliser des points pr\82d\82finis");\r
+ CALL TEXTE (80,120," uitter");\r
+ CALL COLOR (14);\r
+ CALL MOVE (192,100);CALL OUTSTRING("S");\r
+ CALL MOVE (192,110);CALL OUTSTRING("U");\r
+ CALL MOVE (192,120);CALL OUTSTRING("Q");\r
+ CALL COLOR (5);\r
+ CALL TEXTE (80,140,"Votre choix : ");\r
+ CALL SAISIECHAINE (190,144,choix);\r
+ CALL COLOR (3);\r
+ WHILE choix(1)<>'u' AND choix(1)<>'s' AND choix(1)<>'q' AND\r
+ choix(1)<>'U' AND choix(1)<>'S' AND choix(1)<>'Q' DO\r
+ CALL SAISIECHAINE (190,144,choix);\r
+ OD;\r
+ CASE choix(1)\r
+ WHEN 'u','U' : CALL tab_predefini;\r
+ WHEN 's','S' : CALL TEXTE (100,200,\r
+ "Combien de points voulez_vous saisir :");\r
+ CALL SAISIECHAINE (420,204,chaine);\r
+ CALL TRANSENTIER (chaine,taille);\r
+ ARRAY p DIM (0:taille+1);\r
+ CALL TEXTE (100,210,\r
+ "Voulez-vous utiliser la souris (o/n) ?");\r
+ CALL SAISIECHAINE (410,214,souris);\r
+ WHILE souris(1)<>'O' AND souris(1)<>'N'\r
+ AND souris(1)<>'o' AND souris(1)<>'n' DO\r
+ CALL SAISIECHAINE (410,214,souris);\r
+ OD;\r
+ IF souris(1)='N' ORIF souris(1)='n' THEN\r
+ CALL saisie_points;\r
+ ELSE CALL saisie_souris;\r
+ FI;\r
+ WHEN 'q','Q' : quitter:=TRUE;CALL GROFF; EXIT;\r
+ ESAC;\r
+ CALL CLS;\r
+ CALL COLOR (9);\r
+ FOR i:=1 TO taille DO\r
+ CALL MOVE (p(i).x*O12+9,316-(p(i).y*O12));\r
+ CALL HASCII (ord(p(i).z));\r
+ OD;\r
+ CALL affiche_grille;\r
+ CALL wrap(n);\r
+ CALL affiche_enveloppe;\r
+ FOR i:=0 TO taille+1 DO KILL (p(i));OD;\r
+ OD;\r
+ END; (*block*)\r
+\r
+END convex_hull;\1a
\ No newline at end of file
--- /dev/null
+PROGRAM Infographie;\r
+\r
+(* Auteurs: Peyrard Fabrice & Pianelo Patrice *)\r
+\r
+BEGIN\r
+ Pref Mouse Block\r
+ VAR\r
+ h,v,p,lg,b,vitd,vith : Integer,\r
+ l,r,z : Boolean,\r
+ cour,debut: Cub;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// CUB \\\\\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Cub : Class;\r
+Var\r
+ x,y : Real,\r
+ suiv : Cub;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// DROITE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Droite : Coroutine;\r
+Var\r
+ dif,dif1,b : Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x,cour.y);\r
+ dif := (b - y) - (x+lg+lg Div 3);\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vith) Then\r
+ x := x + dif1;\r
+ Else\r
+ x := x + vith;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Droite;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// GAUCHE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Gauche: Coroutine;\r
+Var\r
+ dif,dif1,b : Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x+lg+lg Div 3,cour.y);\r
+ dif := x-(b - y);\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vith) Then\r
+ x := x - dif1;\r
+ Else\r
+ x := x - vith;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Gauche;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// HAUT \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Haut: Coroutine;\r
+Var\r
+ dif,dif1: Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ dif := y-(lg Div 2) - cour.y;\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vitd) Then\r
+ y := y - dif1;\r
+ x := x + dif1;\r
+ Else\r
+ y := y - vitd;\r
+ x := x + vitd;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Haut;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º//////////////////////// BAS \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Bas: Coroutine;\r
+Var\r
+ dif,dif1: Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ dif := cour.y-(lg Div 2) - y;\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vitd) Then\r
+ y := y + dif1;\r
+ x := x - dif1;\r
+ Else\r
+ y := y + vitd;\r
+ x := x - vitd;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Bas;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// CUBE \\\\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Cube: IIUWGraph Procedure (x,y,c : Integer);\r
+Begin\r
+ Call Color (c);\r
+ Call Move (x,y);\r
+ Call Draw (x + lg + lg Div 3,y);\r
+ Call Draw (x + lg + lg Div 2 + lg Div 3,y - lg Div 2);\r
+ Call Draw (x + lg Div 2,y - lg Div 2);\r
+ Call Draw (x,y);\r
+ Call Draw (x,y + lg);\r
+ Call Draw (x + lg + lg Div 3,y + lg);\r
+ Call Draw (x + lg + lg Div 3,y);\r
+ Call Move (x + lg + lg Div 3,y + lg);\r
+ Call Draw (x + lg + lg Div 2 + lg Div 3,y + lg Div 2);\r
+ Call Draw (x + lg + lg Div 2 + lg Div 3,y - lg Div 2);\r
+End Cube;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// NOIR \\\\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Noir: IIUWGraph Procedure (x,y,c : Integer);\r
+Var\r
+ i : Integer;\r
+Begin\r
+ Call Color (c);\r
+ For i:= x + 1 To x + (lg+lg Div 3) - 1 Do\r
+ Call Move (i,y+1);\r
+ Call Draw (i,y+lg-1);\r
+ Od;\r
+ For i := y To y + lg-2 Do\r
+ Call Move (x+(lg+lg Div 3)+1,i);\r
+ Call Draw (x+(lg+lg Div 2+lg Div 3)-1,i-(lg Div 2)+2);\r
+ Od;\r
+ For i:= x + 2 To x + (lg+lg Div 3) Do\r
+ Call Move (i,y-1);\r
+ Call Draw (i+(lg Div 2)-2,y-(lg Div 2)+1);\r
+ Od;\r
+End Noir;\r
+ \r
+Unit Calcul_b: Function (vx,vy:Integer):Integer;\r
+Begin\r
+ result := vx + vy;\r
+End Calcul_b;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º////////////////////// DEPLACE \\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+UNIT Deplace: IIUWGraph Procedure;\r
+Var\r
+ i : Integer,\r
+ err : Boolean,\r
+ Ba : Bas,\r
+ Ha : Haut,\r
+ Ga : Gauche,\r
+ Dr : Droite,\r
+ c1 : Cub;\r
+Begin\r
+ Ba := New Bas;\r
+ Ha := New Haut;\r
+ Ga := New Gauche;\r
+ Dr := New Droite;\r
+ \r
+ Call Setposition (x+(4*lg) Div 6,y+lg Div 2);\r
+ Call Hidecursor;\r
+ Do\r
+ i := Inkey;\r
+ Call Status (h,v,l,r,z);\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// DROITE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -77) OR (h>=x+(lg+lg Div 3))) Then\r
+ If (x+lg+lg Div 3 < 595-vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x,cour.y);\r
+ If (y = -(x+lg+lg Div 3) + b) Then\r
+ If ((y-lg Div 2 < cour.y) AND (y > cour.y-lg Div 2)) Then\r
+ err := True;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Dr);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// GAUCHE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -75) OR (h<=x)) Then\r
+ If (x > vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x+lg+lg Div 3,cour.y);\r
+ If (y = -x+b) Then\r
+ If ((y-lg Div 2 < cour.y) AND (y > cour.y-lg Div 2)) Then\r
+ err := True;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Ga);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º//////////////////////// BAS \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -80) OR (v>=y+lg)) Then\r
+ If (y+lg < 300-vitd) AND (x > vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ If (y = cour.y-(lg Div 2)) Then\r
+ If ((x <= cour.x+(lg+lg Div 2+lg Div 3)) AND\r
+ (x >= cour.x-(lg Div 2+lg Div 3))) Then\r
+ err := True;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Ba);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// HAUT \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -72) OR (v<=y)) Then\r
+ If (y-lg Div 2 > vitd) AND (x+lg+lg Div 3 < 595-vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ If (y-(lg Div 2) = cour.y) Then\r
+ If ((x+(lg + lg Div 2 + lg Div 3) >= cour.x) AND\r
+ (x+(lg Div 2) <= cour.x+(lg + lg Div 3))) Then\r
+ err := True;\r
+ Exit;\r
+ FI;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Ha);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º///////////////////// VALIDATION \\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = 27) OR l) Then\r
+ cour := debut;\r
+ C1 := new Cub;\r
+ C1.x := x;\r
+ C1.y := y;\r
+ Do\r
+ b := Calcul_b (debut.x+lg+lg Div 3,debut.y);\r
+ If ((y-lg Div 2) < debut.y) AND (x < (b-y))\r
+ OR ((y) < (debut.y-lg Div 2) AND (x >= (b-y))) Then\r
+ C1.suiv := debut;\r
+ debut := C1;\r
+ Exit;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ cour.suiv := C1;\r
+ C1.suiv := NONE;\r
+ Exit;\r
+ Fi;\r
+ b := Calcul_b (cour.suiv.x+lg+lg Div 3,cour.suiv.y);\r
+ If ((y-lg Div 2) < cour.suiv.y) AND (x < (b-y))\r
+ OR ((y) < (cour.suiv.y-lg Div 2) AND (x >= (b-y))) Then\r
+ C1.suiv := cour.suiv;\r
+ cour.suiv := C1;\r
+ Exit;\r
+ Fi;\r
+ cour := cour.suiv;\r
+ Od;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ Call Noir (cour.x,cour.y,0);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Exit;\r
+ Fi;\r
+ Od;\r
+ Kill (Ba);\r
+ Kill (Ha);\r
+ Kill (Ga);\r
+ Kill (Dr);\r
+End Deplace;\r
+ \r
+End Cub;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º///////////////////// RECTANGLE \\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Rectangle: IIUWGraph Procedure (x1,y1,x2,y2,c : Integer);\r
+Begin\r
+ Call Color (c);\r
+ Call Move (x1,y1);\r
+ Call Draw (x2,y1);\r
+ Call Draw (x2,y2);\r
+ Call Draw (x1,y2);\r
+ Call Draw (x1,y1);\r
+ Call Move (x1+1,y1+1);\r
+ Call Draw (x2-1,y1+1);\r
+ Call Draw (x2-1,y2-1);\r
+ Call Draw (x1+1,y2-1);\r
+ Call Draw (x1+1,y1+1);\r
+End Rectangle;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º////////////////////// EFFACE \\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Efface: IIUWGraph Procedure (x1,y1,x2,y2,c : Integer);\r
+Var\r
+ i : Integer;\r
+Begin\r
+ Call Color (c);\r
+ For i:=y1 To y2 Do\r
+ Call Move (x1,i);\r
+ Call Draw (x2,i);\r
+ Od;\r
+End Efface;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º////////////////////// TEXTE \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Texte: IIUWGraph Procedure (x,y : Integer,ch:String);\r
+Begin\r
+ Call Color (9);\r
+ Call Move (x,y);\r
+ Call Outstring (ch);\r
+End Texte;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º///////////////////// OPTIONS \\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Options: IIUWGraph Procedure;\r
+Var\r
+ cc: Cub,\r
+ i: Integer;\r
+Begin\r
+ lg := 30;\r
+ cc := New Cub;\r
+ Call cc.Cube (290,50,15);\r
+ Call cc.Noir (290,50,1);\r
+ Call cc.Cube (235,40,15);\r
+ Call cc.Noir (235,40,2);\r
+ Call cc.Cube (360,35,15);\r
+ Call cc.Noir (360,35,3);\r
+ Call cc.Cube (200,70,15);\r
+ Call cc.Noir (200,70,4);\r
+ Call cc.Cube (260,80,15);\r
+ Call cc.Noir (260,80,5);\r
+ Call cc.Cube (320,75,15);\r
+ Call cc.Noir (320,75,6);\r
+ Call Color (2);\r
+ Call Move (260,135);\r
+ Call Outstring ("OPTIONS");\r
+ Call Color (15);\r
+ Call Move (100,150);\r
+ Call Outstring ("Vitesse");\r
+ Call Move (410,150);\r
+ Call Outstring ("Taille");\r
+ Call Rectangle (150,170,165,185,9);\r
+ Call Rectangle (150,200,165,215,9);\r
+ Call Rectangle (150,230,165,245,9);\r
+ Call Color (15);\r
+ Call Move (180,178);\r
+ Call Outstring ("Lent");\r
+ Call Move (180,208);\r
+ Call Outstring ("Moyen");\r
+ Call Move (180,238);\r
+ Call Outstring ("Rapide");\r
+ Call Rectangle (450,170,465,185,9);\r
+ Call Rectangle (450,200,465,215,9);\r
+ Call Rectangle (450,230,465,245,9);\r
+ Call Color (15);\r
+ Call Move (480,178);\r
+ Call Outstring ("Petit");\r
+ Call Move (480,208);\r
+ Call Outstring ("Moyen");\r
+ Call Move (480,238);\r
+ Call Outstring ("Gros");\r
+ Call Rectangle (250,300,350,330,14);\r
+ Call Texte (265,310,"Continuer");\r
+ Call Efface (152,202,163,213,7);\r
+ Call Efface (452,202,463,213,7);\r
+ lg := 60;\r
+ vitd := 4;\r
+ vith := 6;\r
+ z := Init (i);\r
+ Call Setwindow (0,630,0,330);\r
+ Call Showcursor;\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (l) Then\r
+ Call Hidecursor;\r
+ If ((h >= 250) AND (h <= 350)) AND ((v >= 300) AND (v <= 330)) Then\r
+ Exit;\r
+ Fi;\r
+ If ((h >= 150) AND (h <= 165)) AND ((v >= 170) AND (v <= 185)) Then\r
+ Case (vitd)\r
+ When 2: Call Efface (152,172,163,183,0);\r
+ When 4: Call Efface (152,202,163,213,0);\r
+ When 10: Call Efface (152,232,163,243,0);\r
+ Esac;\r
+ Call Efface (152,172,163,183,7);\r
+ vitd := 2;\r
+ vith := 4;\r
+ Fi;\r
+ If ((h >= 150) AND (h <= 165)) AND ((v >= 200) AND (v <= 215)) Then\r
+ Case (vitd)\r
+ When 2: Call Efface (152,172,163,183,0);\r
+ When 4: Call Efface (152,202,163,213,0);\r
+ When 10: Call Efface (152,232,163,243,0);\r
+ Esac;\r
+ Call Efface (152,202,163,213,7);\r
+ vitd := 4;\r
+ vith := 6;\r
+ Fi;\r
+ If ((h >= 150) AND (h <= 165)) AND ((v >= 230) AND (v <= 245)) Then\r
+ Case (vitd)\r
+ When 2: Call Efface (152,172,163,183,0);\r
+ When 4: Call Efface (152,202,163,213,0);\r
+ When 10: Call Efface (152,232,163,243,0);\r
+ Esac;\r
+ Call Efface (152,232,163,243,7);\r
+ vitd := 10;\r
+ vith := 12;\r
+ Fi;\r
+ If ((h >= 450) AND (h <= 465)) AND ((v >= 170) AND (v <= 185)) Then\r
+ Case (lg)\r
+ When 30: Call Efface (452,172,463,183,0);\r
+ When 60: Call Efface (452,202,463,213,0);\r
+ When 80: Call Efface (452,232,463,243,0);\r
+ Esac;\r
+ Call Efface (452,172,463,183,7);\r
+ lg := 30;\r
+ Fi;\r
+ If ((h >= 450) AND (h <= 465)) AND ((v >= 200) AND (v <= 215)) Then\r
+ Case (lg)\r
+ When 30: Call Efface (452,172,463,183,0);\r
+ When 60: Call Efface (452,202,463,213,0);\r
+ When 80: Call Efface (452,232,463,243,0);\r
+ Esac;\r
+ Call Efface (452,202,463,213,7);\r
+ lg := 60;\r
+ Fi;\r
+ If ((h >= 450) AND (h <= 465)) AND ((v >= 230) AND (v <= 245)) Then\r
+ Case (lg)\r
+ When 30: Call Efface (452,172,463,183,0);\r
+ When 60: Call Efface (452,202,463,213,0);\r
+ When 80: Call Efface (452,232,463,243,0);\r
+ Esac;\r
+ Call Efface (452,232,463,243,7);\r
+ lg := 80\r
+ Fi;\r
+ Call Showcursor;\r
+ Fi;\r
+ Od;\r
+ Call Efface (0,0,640,350,0);\r
+ Kill (cc);\r
+End Options;\r
+ \r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////// PROGRAMME PRINCIPAL \\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+BEGIN\r
+ Pref IIUWGraph Block\r
+ VAR\r
+ i,j,nb : Integer,\r
+ C : Cub;\r
+ Begin\r
+ nb := 13;\r
+ z := Init (j);\r
+ Call Gron (nocard);\r
+ Call Border (5);\r
+ Call Options;\r
+ Call Color (3);\r
+ Call Move (0,300);\r
+ Call Draw (605,300);\r
+ Call Draw (605,310);\r
+ Call Draw (0,310);\r
+ Call Move (605,300);\r
+ Call Draw (638,267);\r
+ Call Move (605,310);\r
+ Call Draw (638,277);\r
+ Call Move (0,320);\r
+ Call Color (15);\r
+ C := New Cub;\r
+ C.x := 200;\r
+ C.y := 150;\r
+ Call C.Cube (C.x,C.y,2);\r
+ debut := C;\r
+ For i:=1 to nb Do\r
+ Call Rectangle (520,315,600,345,14);\r
+ Call Texte (535,325,"Quitter");\r
+ Call Rectangle (420,315,500,345,14);\r
+ Call Texte (435,325,"Suivant");\r
+ z := Init (j);\r
+ Call Setwindow (0,630,0,330);\r
+ Call Showcursor;\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (l) Then\r
+ If ((h >= 520) AND (h <= 600)) AND\r
+ ((v >= 315) AND (v <= 345)) Then\r
+ Call Hidecursor;\r
+ Call Efface (520,315,600,345,0);\r
+ Call Efface (420,315,500,345,0);\r
+ Exit\r
+ Exit;\r
+ Fi;\r
+ If ((h >= 420) AND (h <= 500)) AND\r
+ ((v >= 315) AND (v <= 345)) Then\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Call Hidecursor;\r
+ Call Efface (520,315,600,345,0);\r
+ Call Efface (420,315,500,345,0);\r
+ Call Color (15);\r
+ Call Move (10,320);\r
+ Call Outstring ("D\82placez le cube, et fixez");\r
+ Call Outstring (" le en cliquant sur le bouton de GAUCHE.");\r
+ C := New Cub;\r
+ C.x := 595-lg-lg Div 3;\r
+ C.y := 290-lg;\r
+ Call C.Cube (C.x,C.y,15);\r
+ z := Init (j);\r
+ Call C.Deplace;\r
+ Call Move (10,320);\r
+ Call Outstring (" ");\r
+ Call Outstring (" ");\r
+ Od;\r
+ Call Move (0,320);\r
+ Call Color (15);\r
+ Call Outstring ("Cliquez sur le bouton de DROITE");\r
+ Call Outstring (" pour obtenir une figure en couleurs. ");\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (r) Then\r
+ i := 1;\r
+ cour := debut;\r
+ Do\r
+ Call C.Cube (cour.x,cour.y,15);\r
+ Call C.Noir (cour.x,cour.y,i);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ i := i + 1;\r
+ Od;\r
+ Exit;\r
+ Fi;\r
+ Od;\r
+ Call Move (0,320);\r
+ Call Color (15);\r
+ Call Outstring ("Cliquez sur le bouton de GAUCHE");\r
+ Call Outstring (" pour sortir ... ");\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (l) Then\r
+ Exit;\r
+ Fi;\r
+ Od;\r
+ Call Groff;\r
+ End;\r
+End;\r
+END Infographie.\r
+ \r
--- /dev/null
+program Pierw;\r
+ const PI=3.14159;\r
+ unit sgn:function(x:real):real;\r
+ begin\r
+ if x>0\r
+ then result:=1\r
+ else\r
+ if x=0 \r
+ then result:=0\r
+ else result:=-1\r
+ fi\r
+ fi\r
+ end sgn;\r
+ unit sqr:function(x:real):real;\r
+ begin\r
+ result:=x*x\r
+ end sqr;\r
+ unit grafika:class(Xlewe,Xprawe,Ygorne,Ydolne:real);\r
+ \r
+ unit punkt:class(x,y:real);\r
+(* unit zaznacz:procedure;\r
+ begin\r
+ call ekran.krzyzyk(x,y)\r
+ end zaznacz;\r
+ \r
+ unit opisz:procedure(zn:char);\r
+ begin\r
+ call ekran.opis(x,y,zn)\r
+ end opisz;*)\r
+ end punkt;\r
+ \r
+(*=========================================================================*) \r
+\r
+ unit prosta:class(a,b:punkt);\r
+ var k1,k2:punkt;\r
+ \r
+(* unit RysujProsta:procedure;\r
+ var l:real;\r
+ begin\r
+ l:=(odleglosc(new punkt(Xlewe,Ydolne),\r
+ new punkt(Xprawe,Ygorne))/odleglosc(a,b);\r
+ k1:=new punkt(l*(a.x-b.x)+a.x,l*(a.y-b.y)+a.y);\r
+ k2:=new punkt(l*(b.x-a.x)+b.x,l*(b.y-a.y)+b.y);\r
+ call ekran.odcinek(k1.x,k1.y,k2.x,k2.y)\r
+ end RysujProsta;\r
+ \r
+ unit RysujOdcinek:procedure(c:punkt);\r
+ begin\r
+ { ZAKLADAMY, ZE C JEST NA PROSTEJ }\r
+ { JESLI K1=NONE, TO K2=NONE }\r
+ \r
+ if k1=none \r
+ then \r
+ k1,k2:=c;\r
+ call ekran.odcineczek(a.x,a.y,b.x,b.y,k1.x,k1.y)\r
+ else\r
+ if lewy(k1,c)=c\r
+ then\r
+ call ekran.odcinek(c.x,c.y,k1.x,k1.y);\r
+ k1:=c\r
+ else\r
+ if prawy(k2,c)=c\r
+ then\r
+ call ekran.odcinek(k2.x,k2.y,c.x,c.y);\r
+ k2:=c\r
+ fi\r
+ fi\r
+ fi\r
+ end RysujOdcinek;\r
+ \r
+ unit RysujPolprPr(c:punkt);\r
+ var l:real;\r
+ begin\r
+ l:=(odleglosc(new punkt(Xlewe,Ydolne),\r
+ new punkt(Xprawe,Ygorne))/odleglosc(a,b);\r
+ k2:=new punkt(l*(b.x-a.x)+b.x,l*(b.y-a.y)+b.y);\r
+ call ekran.odcinek(c.x,c.y,k2.x,k2.y)\r
+ end RysujPolprPr;\r
+ \r
+ unit RysujPolprLw(c:punkt);\r
+ var l:real;\r
+ begin\r
+ l:=(odleglosc(new punkt(Xlewe,Ydolne),\r
+ new punkt(Xprawe,Ygorne))/odleglosc(a,b);\r
+ k1:=new punkt(l*(a.x-b.x)+a.x,l*(a.y-b.y)+a.y);\r
+ call ekran.odcinek(k1.x,k1.y,c.x,c.y)\r
+ end RysujPolprLw; *)\r
+ \r
+ unit lewy:function(c,d:punkt):punkt;\r
+ begin\r
+ if (sgn(b.x-a.x)=sgn(d.x-c.x)) orif\r
+ (sgn(b.y-a.y)=sgn(d.y-c.y))\r
+ then result:=c\r
+ else result:=d\r
+ fi\r
+ end lewy;\r
+ \r
+ unit prawy:function(c,d:punkt):punkt;\r
+ begin\r
+ if (sgn(b.x-a.x)=sgn(d.x-c.x)) orif\r
+ (sgn(b.y-a.y)=sgn(d.y-c.y))\r
+ then result:=d\r
+ else result:=c\r
+ fi\r
+ end prawy;\r
+ \r
+ end prosta;\r
+ \r
+(*=========================================================================*) \r
+\r
+ unit okrag:class(S:punkt,r:real);\r
+ \r
+(* unit RysujOkrag:procedure;\r
+ begin\r
+ call ekran.okrag(S.x,S.y,r,0.0,2*PI)\r
+ end RysujOkrag;\r
+ \r
+ unit RysLuk1:procedure(A:punkt);\r
+ var alfa:real;\r
+ begin\r
+ alfa:=asin((A.y-S.y)/r)\r
+ end RysLuk1;\r
+ \r
+ unit RysLuk2:procedure(A,B:punkt);\r
+ begin\r
+ call ekran.okrag(S.x,S.y,r,asin((A.y-S.y)/r)-0.18,\r
+ asin((B.y-S.y)/r)+0.18)\r
+ end;*)\r
+ \r
+(* unit PrawoLewo:class(OdCzego,A,B:punkt);\r
+ var alfa,beta,gamma:real;\r
+ begin\r
+ gamma:=asin((OdCzego.y-S.y)/r);\r
+ alfa:=asin((A.y-S.y)/r)-gamma;\r
+ beta:=asin((B.y-S.y)/r)-gamma; \r
+ \r
+ if alfa<0.0 then alfa:=alfa+2*PI fi;\r
+ if beta<0.0 then beta:=beta+2*PI fi;\r
+ end PrawoLewo;\r
+ \r
+ unit NaPrawo:PrawoLewo function :punkt;\r
+ begin\r
+ if alfa<beta then result:=A\r
+ else result:=B\r
+ fi\r
+ end NaPrawo;\r
+ \r
+ unit NaLewo:PrawoLewo function :punkt;\r
+ begin\r
+ if alfa<beta then result:=B\r
+ else result:=A\r
+ fi\r
+ end NaLewo;*)\r
+ \r
+ end okrag;\r
+ \r
+(*=========================================================================*)\r
+\r
+ unit odleglosc:function(A,B:punkt):real;\r
+ begin\r
+ result:=sqrt(sqr(a.x-b.x)+sqr(a.y-b.y))\r
+ end odleglosc;\r
+ \r
+(*========================================================================*)\r
+\r
+ unit CzWPP:procedure(P1,P2:prosta;output Q1,Q2:punkt);\r
+ var W,W1,W2,teta1,delta_x,delta_y,deltaP1x,\r
+ deltaP2x,deltaP1y,deltaP2y:real;\r
+ const epsilon=0.0000001192;\r
+ begin\r
+ deltaP1x:=P1.b.x-P1.a.x;\r
+ deltaP2x:=P2.b.x-P2.a.x;\r
+ deltaP1y:=P1.b.y-P1.a.y;\r
+ deltaP2y:=P2.b.y-P2.a.y;\r
+ delta_x:=P2.a.x-P1.a.x;\r
+ delta_y:=P2.a.y-P1.a.y;\r
+ \r
+ W:=-deltaP1x*deltaP2y+deltaP1y*deltaP2x;\r
+ W1:=deltaP2x*delta_y-deltaP2y*delta_x;\r
+ W2:=deltaP1x*delta_y-deltaP1y*delta_x;\r
+ \r
+ if abs(W)<=epsilon\r
+ then \r
+ if (abs(W1)<=epsilon) or (abs(W2)<=epsilon)\r
+ then (* continuum rozwiazan *)\r
+ Q1:=P1.a;\r
+ Q2:=P1.b;\r
+ else (* brak rozwiazan *)\r
+ Q1,Q2:=none\r
+ fi\r
+ else\r
+ teta1:=W1/W;\r
+ Q1:=new punkt(P1.a.x+teta1*deltaP1x,P1.a.y+teta1*deltaP1y);\r
+ Q2:=none\r
+ fi\r
+ end CZwPP;\r
+ \r
+(*======================================================================*)\r
+\r
+ unit CzwOO: procedure(O1,O2:okrag;output Q1,Q2:punkt);\r
+ var d,S2x,S2y,x,y,sin_alfa,cos_alfa:real;\r
+ begin\r
+ d:=odleglosc(O1.S,O2.S);\r
+ if (d>(O1.r+O2.r)) or (abs(O1.r-O2.r)>d) then return fi;\r
+ \r
+ (* Przesuwamy uklad wsp. o wektor O1.S *)\r
+ S2x:=O2.S.x-O1.S.x;\r
+ S2y:=O2.S.y-O1.S.y;\r
+ \r
+ (* Obracamy uklad wsp. o kat alfa pod jakim O1 O2 przecina\r
+ os odcietych *)\r
+ sin_alfa:=S2y/d;\r
+ cos_alfa:=S2x/d;\r
+ \r
+ (* Obliczamy wsp jednego punktu przeciecia *)\r
+ x:=(sqr(O1.r)-sqr(O2.r))/(2*d)+d/2;\r
+ y:=sqrt(sqr(O1.r)-sqr(x));\r
+ (* Drugi punkt przeciecia jest symetryczny wzgledem os OX *)\r
+ \r
+ (* Wracamy do ukladu sprzed obrotu *)\r
+ Q1:=new punkt (x*cos_alfa-y*sin_alfa,x*sin_alfa+y*cos_alfa);\r
+ Q2:=new punkt(x*cos_alfa+y*sin_alfa,x*sin_alfa-y*cos_alfa);\r
+ \r
+ (* Wracamy do ukladu sprzed przesuniecia *)\r
+ Q2.x:=Q2.x+O1.S.x;\r
+ Q2.y:=Q2.y+O1.S.y;\r
+ Q1.x:=Q1.x+O1.S.x;\r
+ Q1.y:=Q1.y+O1.S.y\r
+ end CzwOO;\r
+ \r
+(*======================================================================*)\r
+ \r
+ unit CzwOP:procedure(O:okrag,P:prosta;output Q1,Q2:punkt);\r
+ var A,B,C,x,y,pom,d,odl,wersorX,wersorY,ax,ay,bx,by:real;\r
+ begin\r
+ ax:=P.a.x-O.S.x;\r
+ bx:=P.b.x-O.S.x;\r
+ ay:=P.a.y-O.S.y;\r
+ by:=P.b.y-O.S.y;\r
+ \r
+ A:=by-ay;\r
+ B:=ax-bx;\r
+ C:=bx*ay-ax*by;\r
+ \r
+ pom:=-C/(A*A+B*B);\r
+ x:=A*pom;\r
+ y:=B*pom;\r
+ \r
+ d:=odleglosc(P.a,P.b);\r
+ wersorX:=(bx-ax)/d;\r
+ wersorY:=(by-ay)/d;\r
+\r
+ odl:=sqr(O.r)-(sqr(x)+(sqr(y)));\r
+ if odl<0 then return fi;\r
+ odl:=sqrt(odl);\r
+ \r
+ Q1:=new punkt(x+wersorX*odl+O.S.x,y+wersorY*odl+O.S.y);\r
+ Q2:=new punkt(x-wersorX*odl+O.S.x,y-wersorY*odl+O.S.y)\r
+ end CzwOP\r
+ \r
+ end grafika;\r
+begin\r
+ pref grafika(-100,100,100,-100) block\r
+ var punkty:array_of punkt,\r
+ okregi:array_of okrag,\r
+ proste:array_of prosta,\r
+ konce1,konce2,srodki:array_of integer,\r
+ i,j,k,l,m,n:integer,\r
+ c,c1:char,\r
+ x,y,z:real;\r
+ unit piszwynik :procedure(i,j:integer);\r
+ begin\r
+ writeln("nrp x y");\r
+ write(i," ");\r
+ if punkty(i)=none then writeln("none")\r
+ else writeln(punkty(i).x,punkty(i).y)\r
+ fi;\r
+ write(j," ");\r
+ if punkty(j)=none then writeln("none")\r
+ else writeln(punkty(j).x,punkty(j).y)\r
+ fi\r
+ end piszwynik;\r
+ \r
+ begin\r
+ writeln("Jakie n?");\r
+ readln(n);\r
+ array punkty dim(1:n);\r
+ array okregi dim(1:n);\r
+ array proste dim(1:n);\r
+ array srodki dim(1:n);\r
+ array konce1 dim(1:n);\r
+ array konce2 dim(1:n);\r
+ \r
+ do\r
+ write(" Point Line Circle Intersection Quit :");\r
+ readln(c);\r
+ case c\r
+ when 'p':\r
+ write("New List :");\r
+ readln(c1);\r
+ case c1\r
+ when 'n':\r
+ write("point: nr x y ");\r
+ readln(i,x,y);\r
+ punkty(i):=new punkt(x,y);\r
+ when 'l':\r
+ j:=1;\r
+ for i:=1 to n do\r
+ if (j mod 25)=1 then \r
+ write("nr x y");\r
+ j:=j+1;\r
+ readln\r
+ fi;\r
+ if punkty(i)<>none then\r
+ writeln(i," ",punkty(i).x," ",\r
+ punkty(i).y);\r
+ j:=j+1\r
+ fi\r
+ od;\r
+ esac;\r
+ when 'l':\r
+ write("New List ");\r
+ readln(c1);\r
+ case c1\r
+ when 'n':\r
+ write("nrl nrp nrp :");\r
+ readln(i,j,k);\r
+ proste(i):=new prosta(punkty(j),punkty(k));\r
+ konce1(i):=j;\r
+ konce2(i):=k;\r
+ when 'l':\r
+ j:=1;\r
+ for i:=1 to n do\r
+ if (j mod 25)=1 then \r
+ write("nrl nrp nrp");\r
+ j:=j+1;\r
+ readln\r
+ fi;\r
+ if proste(i)<>none then\r
+ writeln(i," ",konce1(i)," ",\r
+ konce2(i));\r
+ j:=j+1\r
+ fi\r
+ od;\r
+ esac;\r
+ when 'c':\r
+ write("New List ");\r
+ readln(c1);\r
+ case c1\r
+ when 'n':\r
+ write("nrc nrp rad :");\r
+ readln(i,j,x);\r
+ okregi(i):=new okrag(punkty(j),x);\r
+ srodki(i):=j;\r
+ when 'l':\r
+ j:=1;\r
+ for i:=1 to n do\r
+ if (j mod 25)=1 then \r
+ write("nrc nrp rad");\r
+ j:=j+1;\r
+ readln\r
+ fi;\r
+ if okregi(i)<>none then\r
+ writeln(i," ",srodki(i)," ",\r
+ okregi(i).r);\r
+ j:=j+1\r
+ fi\r
+ od;\r
+ esac;\r
+ when 'i':\r
+ write (" 1-LL 2-CL 3-CC ");\r
+ readln(c1);\r
+ case c1\r
+ when '1':\r
+ write("nrp nrp nrl nrl ");\r
+ readln(i,j,k,l);\r
+ call CZwPP(proste(k),proste(l),punkty(i),punkty(j));\r
+ call piszwynik(i,j);\r
+ when '2':\r
+ write("nrp nrp nrc nrl ");\r
+ readln(i,j,k,l);\r
+ call CZwOP(okregi(k),proste(l),punkty(i),punkty(j));\r
+ call piszwynik(i,j);\r
+ when '3':\r
+ write("nrp nrp nrc nrc ");\r
+ readln(i,j,k,l);\r
+ call CZwOO(okregi(k),okregi(l),punkty(i),punkty(j));\r
+ call piszwynik(i,j);\r
+ esac;\r
+ when 'q': call endrun;\r
+ esac;\r
+ od\r
+ end\r
+end.\1a
\ No newline at end of file
--- /dev/null
+program geo;\r
+(*****************************************************************************)\r
+(* BOGDAN WIERCZYNSKI 1989-06 *)\r
+(* *)\r
+(* I N W E R S J A *)\r
+(* Program ten dokonuje inwersji przy uzyciu tylko cyrkla (okregi). *)\r
+(*****************************************************************************)\r
+ \r
+ \r
+ unit grafika:iiuwgraph class;\r
+ \r
+ const poczY=310,(* Rzedna piksela odpowiadajacemu poczatkowi ukladu na\r
+ ekranie *)\r
+ poczX=20,(* Odcieta piksela odpowiadajacemu poczatkowi ukladu na\r
+ ekranie *)\r
+ skala=18,(* Liczba pikseli na jednostke w pionie *)\r
+ wysekranu=320,\r
+ aspekt=1.334,\r
+ szerekranu=620;\r
+ \r
+ var liczba:arrayof string;\r
+ \r
+ unit inchar :function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ \r
+ unit ryspunkt:procedure(x,y:real);\r
+ (* Procedura rysuje punkt jako krzyzyk *)\r
+ var x1,y1:integer;\r
+ begin\r
+ call color(14);\r
+ y1:=entier(poczY-y*skala);\r
+ x1:=entier(x*skala*aspekt+poczX);\r
+ call move(x1,y1+3);\r
+ call draw(x1,y1-3);\r
+ call move(x1-4,y1);\r
+ call draw(x1+4,y1);\r
+ end ryspunkt;\r
+ \r
+ unit rys_ukl_wsp:procedure;\r
+ (* Rysowanie ukladu wspolrzednych na ekranie oraz skali na osi OX i OY *)\r
+ var i,y,x:integer;\r
+ begin\r
+ call color(14);\r
+ call move(poczX,poczY);\r
+ call hfill(szerekranu);\r
+ call draw(poczX,0);\r
+ i:=1;\r
+ x:=0;\r
+ y:=skala;\r
+ while y>= skala do\r
+ y:=poczY - i*skala;\r
+ if y >= 4 then\r
+ call move(0,y-4)\r
+ else\r
+ call move(0,y);\r
+ fi;\r
+ call outstring(liczba(i));\r
+ call move(poczX-2,y);\r
+ call draw(poczX,y);\r
+ i:=i+1;\r
+ od;\r
+ i:=1;\r
+ while x<=(szerekranu-skala*aspekt) do\r
+ x:=poczX+i*skala*aspekt;\r
+ if x <= (szerekranu-5) then\r
+ call move(x-9,poczY+5);\r
+ else\r
+ call move(x-13,poczY+5);\r
+ fi;\r
+ call outstring(liczba(i));\r
+ call move(x,poczY);\r
+ call draw(x,poczY+3);\r
+ i :=i+1;\r
+ od;\r
+ end rys_ukl_wsp;\r
+ \r
+ \r
+ unit rysokrag:procedure(x,y,promien:real);\r
+ (* Rysowanie okregu na ekranie w ten sposob aby nie przecinal osi *)\r
+ (* ukladu wspolrzednych, jesli okrag nie miesci sie na ekranie to *)\r
+ (* rysowany jest tylko wycinek *)\r
+ const srodek=0,\r
+ prawo=1,\r
+ lewo=2,\r
+ gora=4,\r
+ dol=7,\r
+ goraprawo=5,\r
+ goralewo=6,\r
+ dolprawo=8,\r
+ dollewo=9,\r
+ goradol=11,\r
+ goraprawodol=12,\r
+ goralewodol=13,\r
+ pi=3.1415926536;\r
+ var x1,x2,y1,y2,a,b,r,katpocz,katkon:real,\r
+ polozenie:integer;\r
+ begin\r
+ call color(11);\r
+ a:=x;\r
+ b:=y;\r
+ r:=promien;\r
+ polozenie:=srodek;\r
+ katpocz,katkon:=0;\r
+ if (a+r)>29 then polozenie:=prawo fi;\r
+ if (a-r)<0 then polozenie:=polozenie+lewo fi;\r
+ if (b+r)>18 then polozenie:=polozenie+gora fi;\r
+ if (b-r)<0 then polozenie:=polozenie+dol fi;\r
+ case polozenie\r
+ when gora:x1:=sqrt(r*r-(18-b)*(18-b));\r
+ katpocz:=pi-atan((18-b)/x1);\r
+ katkon:=atan((18-b)/x1);\r
+ when dol: x1:=sqrt(r*r-b*b);\r
+ katpocz:=2*pi-atan(b/x1);\r
+ katkon:=pi+atan(b/x1);\r
+ when prawo:y1:=sqrt(r*r-(29-a)*(29-a));\r
+ katpocz:=atan(y1/(29-a));\r
+ katkon:=2*pi-atan(y1/(29-a));\r
+ when lewo: y1:=sqrt(r*r-a*a);\r
+ katpocz:=pi+atan(y1/a);\r
+ katkon:=pi-atan(y1/a);\r
+ when goraprawo:x1:=sqrt(r*r-(18-b)*(18-b));\r
+ y1:=sqrt(r*r-(29-b)*(29-b));\r
+ katpocz:=0.5*pi+atan(x1/(18-b));\r
+ katkon:=2*pi-atan(y1/(29-a));\r
+ when goralewo:x1:=sqrt(r*r-(18-b)*(18-b));\r
+ y1:=sqrt(r*r-a*a);\r
+ katpocz:=pi+atan(y1/a);\r
+ katkon:=atan((18-b)/x1);\r
+ otherwise\r
+ case polozenie\r
+ when dolprawo:y1:=sqrt(r*r-(29-a)*(29-a));\r
+ x1:=sqrt(r*r-b*b);\r
+ katpocz:=atan(y1/(29-a));\r
+ katkon:=pi+atan(b/x1);\r
+ when dollewo: x1:=sqrt(r*r-b*b);\r
+ y1:=sqrt(r*r-a*a);\r
+ katpocz:=2*pi-atan(b/x1);\r
+ katkon:=pi-atan(y1/a);\r
+ when goradol: x1:=sqrt(r*r-(18-b)*(18-b));\r
+ x2:=sqrt(r*r-b*b);\r
+ katpocz:=pi-atan((18-b)/x1);\r
+ katkon:=pi+atan(b/x2);\r
+ call cirb(entier(a*skala*aspekt+poczX),\r
+ entier(poczY-b*skala),\r
+ entier(r*skala*aspekt),\r
+ katpocz,katkon,1,0,1,1);\r
+ x1:=a+sqrt(r*r-(18-b)*(18-b));\r
+ x2:=a+sqrt(r*r-b*b);\r
+ katpocz:=2*pi-atan(b/(x2-a));\r
+ katkon:=atan((18-b)/(x1-a));\r
+ when goraprawodol:x1:=sqrt(r*r-(18-b)*(18-b));\r
+ x2:=sqrt(r*r-b*b);\r
+ katpocz:=pi-atan((18-b)/x1);\r
+ katkon:=pi+atan(b/x2);\r
+ when goralewodol:x1:=sqrt(r*r-(18-b)*(18-b));\r
+ x2:=sqrt(r*r-b*b);\r
+ katpocz:=2*pi-atan(b/x2);\r
+ katkon:=atan((18-b)/x1);\r
+ esac;\r
+ esac;\r
+ \r
+ call cirb(entier(a*skala*aspekt+poczX),entier(poczY-b*skala),\r
+ entier(r*skala*aspekt),katpocz,katkon,11,0,1,1);\r
+ end rysokrag;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ begin\r
+ array liczba dim(1:29);\r
+ liczba(1):=" 1";\r
+ liczba(2):=" 2";\r
+ liczba(3):=" 3";\r
+ liczba(4):=" 4";\r
+ liczba(5):=" 5";\r
+ liczba(6):=" 6";\r
+ liczba(7):=" 7";\r
+ liczba(8):=" 8";\r
+ liczba(9):=" 9";\r
+ liczba(10):="10";\r
+ liczba(11):="11";\r
+ liczba(12):="12";\r
+ liczba(13):="13";\r
+ liczba(14):="14";\r
+ liczba(15):="15";\r
+ liczba(16):="16";\r
+ liczba(17):="17";\r
+ liczba(18):="18";\r
+ liczba(19):="19";\r
+ liczba(20):="20";\r
+ liczba(21):="21";\r
+ liczba(22):="22";\r
+ liczba(23):="23";\r
+ liczba(24):="24";\r
+ liczba(25):="25";\r
+ liczba(26):="26";\r
+ liczba(27):="27";\r
+ liczba(28):="28";\r
+ liczba(29):="29";\r
+ \r
+ end grafika;\r
+ \r
+ \r
+ \r
+ unit geometria:grafika class;\r
+ \r
+ \r
+ unit punkt:class(x,y:real);\r
+ begin\r
+ call ryspunkt(x,y);\r
+ end punkt;\r
+ \r
+ unit okrag:class(srodek:punkt;promien:real);\r
+ var i:integer;\r
+ begin\r
+ call rysokrag(srodek.x,srodek.y,promien);\r
+ i := inchar ; (*** czekaj nich popatrze ***)\r
+ end okrag;\r
+ \r
+ \r
+ \r
+ unit odleglosc:function(a,b:punkt):real;\r
+ var a1,a2:real;\r
+ begin\r
+ a1:=b.x-a.x;\r
+ a2:=b.y-a.y;\r
+ result:=sqrt((a1*a1)+(a2*a2));\r
+ end odleglosc;\r
+ \r
+ \r
+ unit dalszy:function(od_punktu,P1,P2:punkt):punkt;\r
+ begin\r
+ if odleglosc(od_punktu,P1) > odleglosc(od_punktu,P2) then\r
+ result:=P1\r
+ else\r
+ result:=P2\r
+ fi;\r
+ end dalszy;\r
+ \r
+ unit przeciecieokr:procedure(k1,k2:okrag;output Apunkt,Bpunkt:punkt);\r
+ (* Procedura ta oblicza wspolrzedne punktow przeciecia sie\r
+ dwoch okregow k1, k2 rozwiazujac uklad dwoch rownan\r
+ kwadratowych opisujacych okregi k1 i k2 .I tak\r
+ k1 - srodek (a,b) ,promien r\r
+ k2 - srodek (c,d) ,promien R *)\r
+ var f,aa,bb,cc,sqrdel,delta,\r
+ a,b,c,d,e,r2,r1,c_a,r1_2,r1_2_r2_2:real;\r
+ var x1,x2,y1,y2:real;\r
+ begin\r
+ a:=k1.srodek.x;\r
+ b:=k1.srodek.y;\r
+ c:=k2.srodek.x;\r
+ d:=k2.srodek.y;\r
+ r1:=k1.promien;\r
+ r2:=k2.promien;\r
+ r1_2:=r1*r1;\r
+ r1_2_r2_2:=r1_2-(r2*r2);\r
+ if a=c then\r
+ y1:=r1_2_r2_2/(2*(d-b))+(d+b)/2;\r
+ y2:=y1;\r
+ sqrdel:=sqrt(r1_2-(y1-b)*(y1-b));\r
+ x1:=a-sqrdel;\r
+ x2:=a+sqrdel;\r
+ else\r
+ if b=d then\r
+ x1:=r1_2_r2_2/(2*(c-a))+(c+a)/2;\r
+ x2:=x1;\r
+ sqrdel:=sqrt(r1_2-(x1-a)*(x1-a));\r
+ y1:=b-sqrdel;\r
+ y2:=b+sqrdel\r
+ else\r
+ c_a:=c-a;\r
+ e:=(c+a)/2+(r1_2_r2_2-b*b+d*d)/(2*c_a);\r
+ f:=(b-d)/c_a;\r
+ aa:=(f*f)+1;\r
+ bb:=2*(f*(e-a)-b);\r
+ cc:=(e*e)-(2*e*a)+(a*a)+(b*b)-(r1*r1);\r
+ delta:=(bb*bb)-(4*aa*cc);\r
+ y1:=((-bb)-sqrt(delta))/(2*aa);\r
+ y2:=((-bb)+sqrt(delta))/(2*aa);\r
+ x1:=e+f*y1;\r
+ x2:=e+f*y2;\r
+ fi;\r
+ fi;\r
+ Apunkt:=new punkt(x1,y1);\r
+ Bpunkt:=new punkt(x2,y2);\r
+end przeciecieokr;\r
+ \r
+ \r
+ unit wydluz2x:function(P,K:punkt):punkt;\r
+ var P1,P2,P3,P4,P5:punkt,\r
+ KP,PK:okrag;\r
+ begin\r
+ KP:=new okrag(K,odleglosc(K,P));\r
+ PK:=new okrag(P,KP.promien);\r
+ call przeciecieokr(KP,PK,P1,P2);\r
+ kill(P2);\r
+ kill(PK);\r
+ PK:=new okrag(P1,KP.promien);\r
+ call przeciecieokr(KP,PK,P2,P3);\r
+ P4:=copy(dalszy(P,P2,P3));\r
+ kill(P3);\r
+ kill(P2);\r
+ kill(PK);\r
+ PK:=new okrag(P4,KP.promien);\r
+ call przeciecieokr(KP,PK,P3,P4);\r
+ P5:=copy(dalszy(P1,P3,P4));\r
+ kill(P4);\r
+ kill(P3);\r
+ kill(P1);\r
+ kill(P2);\r
+ result:=P5;\r
+ kill(KP);\r
+ kill(PK);\r
+ end wydluz2x;\r
+ \r
+ \r
+ \r
+ begin\r
+ end geometria;\r
+ \r
+begin\r
+ \r
+pref geometria block\r
+const ek_rob=0,\r
+ cls_ek=1,\r
+ exit_con=2,\r
+ inwer=3,\r
+ enter=13,\r
+ st_w_dol=-80,\r
+ st_w_gore=-72,\r
+ esc=27;\r
+ \r
+ \r
+unit inwersja:geometria procedure(x,y:real);\r
+ var P,P1,P2,P3,P4:punkt,\r
+ i,odl:integer,\r
+ KPS,KP1,KP2:okrag;\r
+ begin\r
+ call color(14);\r
+ if (S.x=/=x) or (S.y=/=y) then\r
+ odl:=0;\r
+ P:=new punkt(x,y); (* PUNKT KTORY MA BYC PRZEKSZTALCONY *)\r
+ call outstring("P");\r
+ if odleglosc(P,S)<= (KS.promien/2) then\r
+ (* NALEZY PRZESUNAC P POZA OKRAG INWERSJI DOKONAC INWERSJI I *)\r
+ (* PRZESUNAC TYLE SAMO RAZY CO POPRZEDNIO *)\r
+ P1:=copy(P);\r
+ P2:=copy(S);\r
+ while odleglosc(P1,S)<=KS.promien do\r
+ P3:=wydluz2x(P2,P1);\r
+ kill( P2);\r
+ P2:=P1;\r
+ P1:=P3;\r
+ odl:=odl+1;\r
+ od;\r
+ kill( P2);\r
+ kill( P);\r
+ P:=P1;\r
+ P1:=none;\r
+ P3:=none;\r
+ call ryspunkt(P.x,P.y);\r
+ call outstring("P1'");\r
+ fi;\r
+ KPS:=new okrag(P,odleglosc(P,S));\r
+ call przeciecieokr(KPS,KS,P1,P2);\r
+ kill( KPS);\r
+ kill( P);\r
+ KP1:=new okrag(P1,KS.promien);\r
+ KP2:=new okrag(P2,KS.promien);\r
+ call przeciecieokr(KP1,KP2,P3,P4);\r
+ kill( P1);\r
+ kill( P2);\r
+ kill( KP1);\r
+ kill( KP2);\r
+ P:=copy(dalszy(S,P3,P4));\r
+ call ryspunkt(P.x,P.y);\r
+ if odl>0 then\r
+ call outstring("P2'")\r
+ else\r
+ call outstring("P'")\r
+ fi;\r
+ kill( P3);\r
+ kill( P4);\r
+ P1:=copy(S);\r
+ for i:=1 to odl do\r
+ P3:=wydluz2x(P1,P);\r
+ kill( P1);\r
+ P1:=P;\r
+ P:=P3;\r
+ od;\r
+ call ryspunkt(P.x,P.y);\r
+ call outstring("P' ");\r
+ kill(P);\r
+ kill(P1);\r
+ fi;\r
+ end inwersja;\r
+ \r
+ \r
+unit strzalka:procedure(x,y:integer);\r
+begin\r
+ call cirb(x,y,29,2.9,3.3,0,1,1,1);\r
+end strzalka;\r
+ \r
+ \r
+unit rys_menu:procedure;\r
+begin\r
+ call color(14);\r
+ call move(519,0);\r
+ call hfill(619);\r
+ call draw(519,25);\r
+ call hfill(619);\r
+ call draw(519,50);\r
+ call hfill(619);\r
+ call draw(519,75);\r
+ call hfill(619);\r
+ call draw(519,100);\r
+ call draw(619,100);\r
+ call draw(619,0);\r
+ call move(533,5);\r
+ call outstring("SHAW AUX");\r
+ call move(533,30);\r
+ call outstring("CLEAR AUX");\r
+ call move(533,55);\r
+ call outstring("END");\r
+ call move(533,80);\r
+ call outstring("INVERSION");\r
+end rys_menu;\r
+ \r
+ \r
+unit czyt_licz:function:real;\r
+const kropka=46;\r
+var ulamek:bool,\r
+ wykladnik,res:real,\r
+ lzn,(*liczba wczytanych znakow *)\r
+ znak:integer;(*kod wczytanego znaku*)\r
+begin\r
+ ulamek:=false;\r
+ wykladnik:=1;\r
+ result:=0;\r
+ do\r
+ znak:=inchar;\r
+ case znak\r
+ when kropka: ulamek:=true;\r
+ wykladnik:=1;\r
+ lzn:=lzn+1;\r
+ call hascii(znak);\r
+ when enter: exit;\r
+ otherwise lzn:=lzn+1;\r
+ if lzn <= 5 then\r
+ if ulamek then\r
+ wykladnik:=wykladnik/10;\r
+ result:=result+(znak-ord('0'))*wykladnik;\r
+ else\r
+ result:=result*wykladnik+(znak-ord('0'));\r
+ wykladnik:=wykladnik*10;\r
+ fi;\r
+ call hascii(znak);\r
+ else\r
+ exit\r
+ fi;\r
+ esac;\r
+ od;\r
+end czyt_licz;\r
+ \r
+ \r
+var i,stan,znak:integer,\r
+ S:punkt,\r
+ KS:okrag,\r
+ wsp_strz:arrayof arrayof integer,\r
+ x,y:real;\r
+begin\r
+ \r
+ array wsp_strz dim(0:5);\r
+ for i:=0 to 5 do\r
+ array wsp_strz(i) dim(1:2);\r
+ od;\r
+ for i:=0 to 5 do\r
+ wsp_strz(i,1):=515;\r
+ od;\r
+ wsp_strz(0,2):=15;\r
+ wsp_strz(1,2):=40;\r
+ wsp_strz(2,2):=65;\r
+ wsp_strz(3,2):=90;\r
+ wsp_strz(4,2):=120;\r
+ wsp_strz(5,2):=140;\r
+ stan:=0;\r
+ call gron(0); (* 0 - STRONA ROBOCZA *)\r
+ call rys_ukl_wsp;\r
+ \r
+ (******* RYSUJ OKRAG INWERSJI ***********)\r
+ \r
+ call color(2);\r
+ S:=new punkt(11.5,9.5);\r
+ call outstring(" S");\r
+ KS:=new okrag(S,4);\r
+ kill(S);\r
+ kill(KS);\r
+ call hpage(1,1,0); (* 1 - STRONA Z MENU *)\r
+ call cls;\r
+ call rys_ukl_wsp;\r
+ \r
+ (******* RYSUJ OKRAG INWERSJI ***********)\r
+ call color(14);\r
+ S:=new punkt(11.5,9.5);\r
+ call outstring(" S");\r
+ KS:=new okrag(S,4);\r
+ call rys_menu;\r
+ call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));\r
+ do\r
+ znak:=inchar;\r
+ case znak\r
+ when st_w_dol: call color(0); (**** 0 - kolor tla *****)\r
+ call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));\r
+ stan:=(stan+1) mod 4;\r
+ call color(14); (**** 14 - kolor znaku *****)\r
+ call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));\r
+ when st_w_gore:call color(0); (**** 0 - kolor tla *****)\r
+ call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));\r
+ stan:=(stan+3) mod 4;\r
+ call color(14); (**** 1 - kolor znaku *****)\r
+ call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));\r
+ when enter: case stan\r
+ when ek_rob: call hpage(0,1,0);\r
+ znak:=inchar;\r
+ call hpage(1,1,0);\r
+ \r
+ when cls_ek: call hpage(0,1,0);\r
+ call cls;\r
+ call rys_ukl_wsp;\r
+ call rysokrag(S.x,S.y,KS.promien);\r
+ call ryspunkt(S.x,S.y);\r
+ call outstring(" S");\r
+ call hpage(1,1,0);\r
+ \r
+ when exit_con: exit;\r
+ \r
+ when inwer: call move(519,115);\r
+ call outstring("X=");\r
+ call move(540,112);\r
+ call draw(590,112);\r
+ call move(540,112);\r
+ call draw(540,125);\r
+ call draw(590,125);\r
+ call draw(590,112);\r
+ call move(546,115);\r
+ (*wczytnie x*)\r
+ x:=czyt_licz;\r
+ call move(519,145);\r
+ call outstring("Y=");\r
+ call move(540,142);\r
+ call draw(590,142);\r
+ call move(540,142);\r
+ call draw(540,155);\r
+ call draw(590,155);\r
+ call draw(590,142);\r
+ call move(546,145);\r
+ (*wczytnie y*)\r
+ y:=czyt_licz;\r
+ call color(0);\r
+ for i:=112 to 155 do\r
+ call move(515,i);\r
+ call draw(595,i);\r
+ od;\r
+ call color(11);\r
+ call hpage(0,1,0);\r
+ if (x>0) andif (y>0) andif (x<29) andif (y<18)\r
+ then\r
+ call inwersja(x,y);\r
+ znak:=inchar;\r
+ call hpage(1,1,0);\r
+ else\r
+ call move(360,180);\r
+ \r
+ call outstring(" bad data ");\r
+ call move(360,200);\r
+ call outstring(" press ESC ");\r
+ do\r
+ znak:=inchar;\r
+ if znak=Esc then exit fi;\r
+ od;\r
+ call cls;\r
+ call rys_ukl_wsp;\r
+ call rysokrag(S.x,S.y,KS.promien);\r
+ call ryspunkt(S.x,S.y);\r
+ call outstring(" S");\r
+ call hpage(1,1,0);\r
+ fi;\r
+ esac;\r
+ esac;\r
+ od;\r
+ call groff;\r
+ end;\r
+end geo\r
--- /dev/null
+program geopol;\r
+(******* geometryczne znajdywanie pierwiastka kwadratowego ********)\r
+ \r
+ unit zbior:class;\r
+ end zbior;\r
+ \r
+ unit punkt:zbior class;\r
+ var x,y:real;\r
+ \r
+ unit rowne:function (a:punkt):boolean;\r
+ begin\r
+ result:=(a.x=x) and (a.y=y);\r
+ end rowne;\r
+ \r
+ unit odleglosc:function (a:punkt):real;\r
+ begin\r
+ if a=/=none then\r
+ result:=sqrt((x-a.x)*(x-a.x)+(y-a.y)*(y-a.y))\r
+ fi\r
+ end odleglosc;\r
+ \r
+ end punkt; \r
+\r
+ unit rozwiaz:function(a,b,c:real):punkt;\r
+ (* Funkcja rozwiazuje rownanie kwadratowe i jesli ma rozwiazanie\r
+ to zwraca je na wspolrzednych punktu*)\r
+ var d:real;\r
+ begin\r
+ if (a=/=0) or (b=/=0) then\r
+ if a=0 then\r
+ result:=new punkt;\r
+ result.x:=-c/b;\r
+ result.y:=-c/b;\r
+ else\r
+ d:=b*b-4*a*c;\r
+ if d>=0 then\r
+ result:=new punkt;\r
+ result.x:=(-b+sqrt(d))/(2*a);\r
+ result.y:=(-b-sqrt(d))/(2*a);\r
+ fi\r
+ fi\r
+ fi;\r
+ end rozwiaz;\r
+ \r
+ unit odcinek:zbior class;\r
+ var a,b:punkt;\r
+ \r
+ unit dlugosc:function:real;\r
+ begin\r
+ result:=a.odleglosc(b);\r
+ end dlugosc;\r
+ \r
+ end odcinek;\r
+\r
+ unit okrag:zbior class;\r
+ var o:punkt,\r
+ r:real;\r
+ \r
+ unit przeczokreg:function (a:okrag):prosta;\r
+ var pom1,pom2:real;\r
+ begin\r
+ if a=/=none then\r
+ pom1:= r*r-o.x*o.x-o.y*o.y;\r
+ pom2:= a.r*a.r-a.o.x*a.o.x-a.o.y*a.o.y;\r
+ result := new prosta;\r
+ result.a:=2*(a.o.x-o.x);\r
+ result.b:=2*(a.o.y-o.y);\r
+ result.c:=pom2-pom1;\r
+ fi\r
+ end przeczokreg;\r
+ \r
+ unit przeczprost:function(l:prosta):odcinek;\r
+ var pom:punkt;\r
+ \r
+ begin\r
+ if l.a=/=0 then\r
+ pom:=rozwiaz(1+(l.b/l.a)*(l.b/l.a),2*(l.b*l.c/l.a+o.x*l.b/l.a-o.y),\r
+ 2*o.x*l.c/l.a+(l.c*l.c)/(l.a*l.a)+o.x*o.x+o.y*o.y-r*r);\r
+ result:=new odcinek;\r
+ result.a:=new punkt;\r
+ result.a.x:=-(pom.x*l.b/l.a+l.c/l.a);\r
+ result.a.y:=pom.x;\r
+ result.b:=new punkt;\r
+ result.b.x:=-(pom.y*l.b/l.a+l.c/l.a);\r
+ result.b.y:=pom.y;\r
+ else\r
+ pom:=rozwiaz(1+(l.a/l.b)*(l.a/l.b),2*(l.a*l.c/l.b+o.x*l.a/l.b-o.y),\r
+ 2*o.x*l.c/l.b+(l.c*l.c)/(l.b*l.b)+o.x*o.x+o.y*o.y-r*r);\r
+ result:=new odcinek;\r
+ result.a:=new punkt;\r
+ result.a.y:=-(pom.x*l.a/l.b+l.c/l.b);\r
+ result.a.x:=pom.x;\r
+ result.b:=new punkt;\r
+ result.b.y:=-(pom.y*l.a/l.b+l.c/l.b);\r
+ result.b.x:=pom.y;\r
+ fi;\r
+ end przeczprost;\r
+ end okrag;\r
+\r
+ unit prosta:zbior class;\r
+ var a,b,c:real;\r
+ \r
+ unit przeczprost:function (l:prosta):punkt;\r
+ var pom:real;\r
+ begin\r
+ if (l=/=none) and (not rownolega(l)) then\r
+ pom:= 1/(l.a*b-l.b*a);\r
+ result:=new punkt;\r
+ result.x:=-pom*(b*l.c-c*l.b);\r
+ result.y:=pom*(a*l.c-c*l.a);\r
+ fi\r
+ end przeczprost;\r
+\r
+ unit rownolega:function(l:prosta):boolean;\r
+ begin\r
+ if l=/=none then\r
+ if a*l.b-b*l.a=0 then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi \r
+ fi\r
+ end rownolega;\r
+ \r
+ end prosta;\r
+\r
+ unit ekran:iiuwgraph class;\r
+\r
+ (* Klasa obslugujaca ekran *)\r
+ const skala=10,\r
+ wysekr=348,\r
+ szerekr=620,\r
+ poczpoz=szerekr div 2,\r
+ poczpio=wysekr div 2,\r
+ p=3,\r
+ q=4,\r
+ aspekt=p/q;\r
+ \r
+ unit inchar:function:integer;\r
+ begin\r
+ while result=0 do\r
+ result:=inkey;\r
+ od;\r
+ end inchar;\r
+ \r
+ unit punktnaekr:class;\r
+ var x,y:integer;\r
+ end punktnaekr;\r
+ \r
+ unit naekranie:function(a:punktnaekr):boolean;\r
+ begin\r
+ result:=((a.x>0) and (a.x<szerekr)) and ((a.y>0) and (a.y<wysekr));\r
+ end naekranie;\r
+ \r
+ unit rysodc:procedure(a,b:punkt);\r
+ (* Procedura rysuje odcinek o ile znajduje sie caly w ekranie *)\r
+ var c,d:punktnaekr;\r
+ begin\r
+ c:=new punktnaekr;\r
+ d:=new punktnaekr;\r
+ c.x:=entier(a.x*skala+poczpoz);\r
+ c.y:=entier(a.y*skala*aspekt+poczpio);\r
+ d.x:=entier(b.x*skala+poczpoz);\r
+ d.y:=entier(b.y*skala*aspekt+poczpio);\r
+ if naekranie(c) and naekranie(d) then\r
+ call move(c.x,c.y);\r
+ call draw(d.x,d.y);\r
+ fi;\r
+ end rysodc;\r
+ \r
+ unit rysokr:procedure(o:okrag);\r
+ (* Procedura rysuje okrag wedlug algorytmu podanego przez p.Jankowskiego *)\r
+ \r
+ var x,y,r,pp,pp4,pp8,qq,qq4,qq8,fx,fy,fs:integer;\r
+ \r
+ unit rysczw:procedure(x,y:integer);\r
+ (* Procedura rysuje cztery punkty symetryczne wzgledem *)\r
+ (* osi ukladu wspolrzednych *)\r
+ var a:punktnaekr;\r
+ \r
+ begin\r
+ a:=new punktnaekr;\r
+ a.x:=entier(x+poczpoz+o.o.x*skala);\r
+ a.y:=entier(y+poczpio+o.o.y*skala*aspekt);\r
+ if naekranie(a) then\r
+ call move(a.x,a.y);\r
+ call draw(a.x,a.y);\r
+ fi;\r
+ a.x:=entier(-x+poczpoz+o.o.x*skala);\r
+ if naekranie(a) then\r
+ call move(a.x,a.y);\r
+ call draw(a.x,a.y);\r
+ fi;\r
+ a.y:=entier(-y+poczpio+o.o.y*skala*aspekt);\r
+ if naekranie(a) then\r
+ call move(a.x,a.y);\r
+ call draw(a.x,a.y);\r
+ fi;\r
+ a.x:=entier(x+poczpoz+o.o.x*skala);\r
+ if naekranie(a) then\r
+ call move(a.x,a.y);\r
+ call draw(a.x,a.y);\r
+ fi;\r
+ end rysczw;\r
+ \r
+ begin\r
+ r:=entier(o.r*skala);\r
+ x:=0;\r
+ y:=r;\r
+ pp:=p*p;\r
+ pp4:=4*pp;\r
+ pp8:=8*pp;\r
+ qq:=q*q;\r
+ qq4:=4*qq;\r
+ qq8:=8*qq;\r
+ fx:=0;\r
+ fy:=qq8*r;\r
+ fs:=pp4-qq4*r+qq;\r
+ while fx<fy do\r
+ call rysczw(x,y);\r
+ x:=x+1;\r
+ fx:=fx+qq8;\r
+ if fs<=0 then \r
+ fs:=fs+fx+pp4;\r
+ else\r
+ y:=y-1;\r
+ fy:=fy-qq8;\r
+ fs:=fs+fx+pp4-fy;\r
+ fi;\r
+ od;\r
+ fs:=fs-(fx-fy) div 2+3*(pp-qq);\r
+ while y>=0 do\r
+ call rysczw(x,y);\r
+ y:=y-1;\r
+ fy:=fy-qq8;\r
+ if fs<=0 then\r
+ x:=x+1;\r
+ fx:=fx+pp8;\r
+ fs:=fs+fx-fy+qq4;\r
+ else\r
+ fs:=fs-fy+qq4;\r
+ fi;\r
+ od;\r
+ end rysokr;\r
+ \r
+ unit poczatek:procedure;\r
+ begin\r
+ call gron(0);\r
+ end poczatek;\r
+ \r
+ unit koniec:procedure;\r
+ begin\r
+ call groff;\r
+ end koniec;\r
+ \r
+ unit czysc:procedure;\r
+ begin\r
+ call cls;\r
+ end czysc;\r
+ \r
+ end ekran;\r
+ \r
+ var pr,ppr:prosta,\r
+ okg:okrag,\r
+ ppom,po,pk,pp:punkt,\r
+ odp:odcinek,\r
+ okl,okp:okrag,\r
+ i:real,\r
+ j:integer,\r
+ a:char,\r
+ ekr:ekran;\r
+ \r
+ begin\r
+ ekr:=new ekran;\r
+ do\r
+ i:=0;\r
+ while (i<1) or (i>9) do\r
+ writeln("Podaj dlugosc odcinka");\r
+ readln(i);\r
+ od;\r
+ call ekr.poczatek;\r
+ call ekr.czysc;\r
+ pr:=new prosta;\r
+ pr.a:=0;\r
+ pr.b:=1;\r
+ pr.c:=0;\r
+ pp:=new punkt;\r
+ pp.x:=-1;\r
+ pp.y:=0;\r
+ pk:=new punkt;\r
+ pk.x:=i;\r
+ pk.y:=0;\r
+ call ekr.rysodc(pp,pk);\r
+ okg:=new okrag;\r
+ okg.o:=new punkt;\r
+ okg.o.x:=(i-1)/2;\r
+ okg.o.y:=0;\r
+ okg.r:=(i+1)/2;\r
+ call ekr.rysokr(okg);\r
+ okl:=new okrag;\r
+ okl.o:=pp;\r
+ okl.r:=2;\r
+ call ekr.rysokr(okl);\r
+ okp:=new okrag;\r
+ okp.o:=new punkt;\r
+ okp.o.x:=1;\r
+ okp.o.y:=0;\r
+ okp.r:=2;\r
+ call ekr.rysokr(okp);\r
+ ppr:=okl.przeczokreg(okp);\r
+ odp:=okg.przeczprost(ppr);\r
+ call ekr.rysodc(odp.a,odp.b);\r
+ ppom:=pr.przeczprost(ppr);\r
+ j := inchar;\r
+ call ekr.koniec;\r
+ writeln("Punkt przeciecia,x=",ppom.x," y=",ppom.y);\r
+ writeln("punkt gorny,x=",odp.a.x," y=",odp.a.y);\r
+ writeln("Dlugosc d=",ppom.odleglosc(odp.a));\r
+ writeln(" CZY CHCESZ JESZCZE RAZ?(T/N) ");\r
+ readln(a);\r
+ if (a=/='t') and (a=/='T') then exit fi;\r
+ od;\r
+ end;\1a
\ No newline at end of file
--- /dev/null
+program pierwiastek;\r
+begin\r
+pref IIUWgraph block\r
+const\r
+ aspekt=1.33333333333,\r
+ Pi=3.1415926536,\r
+ jednostka=25;\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+ unit WaitMoment:procedure;\r
+ var r:integer;\r
+ begin\r
+ call move(290,320);\r
+ call outstring("Press any key!");\r
+ while r = 0 do\r
+ r:=inkey\r
+ od;\r
+ call move(290,320);\r
+ call outstring(" * ");\r
+ end WaitMoment;\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+unit punkt:class(x,y:real);\r
+ unit plot:procedure;\r
+ begin\r
+ call move(round(x*aspekt)-3,round(y));\r
+ call draw(round(x*aspekt)+3,round(y));\r
+ call move(round(x*aspekt),round(y)-2);\r
+ call draw(round(x*aspekt),round(y)+3);\r
+ end plot;\r
+end punkt;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit okrag :class (S:punkt;r:real);\r
+ unit cirb:procedure(alfa,beta:real);\r
+ var gamma,x,y:real;\r
+ begin\r
+ if alfa<beta then\r
+ gamma:=alfa\r
+ else gamma:=beta;\r
+ beta:=alfa\r
+ fi;\r
+ x:=round(aspekt*(S.x+(r*cos(gamma))));\r
+ y:=round(S.y+(r*sin(gamma)));\r
+ call move(x,y);\r
+ while gamma<=beta do\r
+ x:=round(aspekt*(S.x+(r*cos(gamma))));\r
+ y:=round(S.y+(r*sin(gamma)));\r
+ call draw(x,y);\r
+ gamma:=gamma+0.01\r
+ od\r
+ end cirb;\r
+ unit rys:procedure(A:punkt);\r
+ var alfa,pom:real;\r
+ begin\r
+ pom:=(A.y-S.y)/(A.x-S.x);\r
+ alfa:=atan(pom);\r
+ if A.x-S.x<0 then\r
+ alfa:=Pi+alfa\r
+ fi;\r
+ call cirb(alfa-0.3,alfa+0.3);\r
+ end rys;\r
+end okrag;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit odcinek:class(A,B:punkt);\r
+begin\r
+call move(round(A.x*aspekt),round(A.y));\r
+call draw(round(B.x*aspekt),round(B.y))\r
+end odcinek;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit odleglosc:function(A,B:punkt):real;\r
+begin\r
+ result:=sqrt((B.x-A.x)*(B.x-A.x)+(B.y-A.y)*(B.y-A.y))\r
+end odleglosc;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit srodek_odcinka:function(GH:odcinek):punkt;\r
+ var\r
+ o2,o3:okrag,\r
+ C,D:punkt,\r
+ CD:odcinek;\r
+begin\r
+ o2:=new okrag(GH.A,odleglosc(GH.A,GH.B));\r
+ o3:=new okrag(GH.B,odleglosc(GH.A,GH.B));\r
+ call okrag_okrag(o2,o3,C,D);\r
+ call WaitMoment;\r
+ CD:=new odcinek(C,D);\r
+ result:=odcinek_odcinek(GH,CD)\r
+end srodek_odcinka;\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit okrag_okrag:procedure(o2,o1:okrag;output G,H:punkt);\r
+var\r
+ ax2,ay2,cx2,cy2,r12,r22:real,\r
+ A,B:punkt,\r
+ AB:odcinek;\r
+begin\r
+ ax2:=o1.S.x * o1.S.x;\r
+ ay2:=o1.S.y * o1.S.y;\r
+ cx2:=o2.S.x * o2.S.x;\r
+ cy2:=o2.S.y * o2.S.y;\r
+ r12:=o1.r * o1.r;\r
+ r22:=o2.r * o2.r;\r
+ A:=new punkt(0,(r12-r22-ay2-ax2+cx2+cy2)/(2*(o2.S.y-o1.s.y)));\r
+B:=new punkt(1,(r12-r22-ay2-ax2+cx2+cy2+2*o1.s.x-2*o2.s.x)/(2*(o2.S.y-o1.s.y)));\r
+ AB:=new odcinek(A,B);\r
+ call okrag_odcinek(o1,AB,G,H);\r
+ call o1.rys(G);\r
+ call o2.rys(G);\r
+ call G.plot;\r
+ call outstring("G");\r
+ call o1.rys(H);\r
+ call o2.rys(H);\r
+ call H.plot;\r
+ call outstring("H");\r
+end okrag_okrag;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit okrag_odcinek:procedure(o:okrag;p:odcinek;output G,H:punkt);\r
+var\r
+ a,b,c,x,y,delta,m:real;\r
+begin\r
+\r
+ m:=(p.B.y - p.A.y) / (p.B.x - p.A.x);\r
+ a:=(m * m) + 1;\r
+ b:=(-2) * ((m * m * p.A.x) - (m * p.A.y)+(o.s.x)+(m*o.s.y));\r
+ c:=m * p.A.x *(m * p.A.x - 2 * p.A.y) + (p.A.y * p.A.y) - (o.r * o.r);\r
+ c:=c+(o.s.x*o.s.x)+(o.s.y*o.s.y)-(2*p.a.y*o.s.y);\r
+ c:=c+(2*m*p.a.x*o.s.y);\r
+ delta :=b * b -(4 * a * c);\r
+ if delta < 0 then\r
+ G:=none;\r
+ H:=none;\r
+ else\r
+ if delta = 0 then\r
+ x:= -b / (2 * a);\r
+ y:= m *(x - p.A.x) + p.A.y;\r
+ G:=new punkt(x ,y);\r
+ else delta:=sqrt(delta);\r
+ x:= (-b - delta) / (2 * a);\r
+ y:= m *(x - p.A.x) + p.A.y;\r
+ G:=new punkt(x ,y);\r
+ x:= (-b + delta) / (2 * a);\r
+ y:= m *(x - p.A.x) + p.A.y;\r
+ H:=new punkt(x ,y);\r
+ fi\r
+ fi\r
+end okrag_odcinek;\r
+\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit punkt_odlegly:function(AB:odcinek;odl:integer):punkt;\r
+(* Funkcja zwraca punkt odlegly w poziomie o odl lezacy na prostej AB. *)\r
+var\r
+ G,H:punkt,\r
+ o:okrag;\r
+begin\r
+ o:=new okrag(AB.B,odl*jednostka);\r
+ call okrag_odcinek(o,AB,G,H);\r
+ if odleglosc(AB.A,G)<odleglosc(AB.A,H) then\r
+ result:=H\r
+ else\r
+ result:=G\r
+ fi\r
+end punkt_odlegly;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit odcinek_odcinek:function(AB,CD:odcinek):punkt;\r
+var\r
+ m1,m2,x,y:real;\r
+begin\r
+ m1:=(AB.B.y-AB.A.y)/(AB.B.x-AB.A.x);\r
+ m2:=(CD.B.y-CD.A.y)/(CD.B.x-CD.A.x);\r
+ x:=(m1*AB.A.x-AB.A.y-m2*CD.A.x+CD.A.y)/(m1-m2);\r
+ y:=m1*(x-AB.A.x)+AB.A.y;\r
+ result:=new punkt(x,y)\r
+end odcinek_odcinek;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+unit prostopadla:function(AC:odcinek;B:punkt):odcinek;\r
+var\r
+ o1,o2,o3:okrag,\r
+ G,H,K,L:punkt;\r
+begin\r
+o1:=new okrag(B,odleglosc(B,AC.B));\r
+call okrag_odcinek(o1,AC,G,H);\r
+o2:=new okrag(G,2*odleglosc(B,AC.B));\r
+o3:=new okrag(H,2*odleglosc(B,AC.B));\r
+call okrag_okrag(o2,o3,K,L);\r
+result:=new odcinek (K,L)\r
+end prostopadla;\r
+\r
+(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)\r
+\r
+\r
+\r
+var\r
+ A,B,C,D,E,F,G:punkt,\r
+ o1:okrag,\r
+ AC,AB,BE,BF:odcinek,\r
+ wynik:real;\r
+begin\r
+\r
+ call gron(0);\r
+ A:=new punkt(200,100);\r
+ call A.plot;\r
+ call outstring ("A");\r
+ call move (100,300);\r
+ call outstring("Choose second point and press <END>.");\r
+ call track(303,202);\r
+ B:=new punkt(inxpos*(1/aspekt),inypos);\r
+ call B.plot;\r
+ call outstring ("B");\r
+ call move (100,300);\r
+ call outstring(" ");\r
+ AB:=new odcinek(A,B);\r
+ C:=punkt_odlegly(AB,1);\r
+ call C.plot;\r
+ call outstring ("C");\r
+ AC:=new odcinek(A,C);\r
+ call WaitMoment;\r
+ D:=srodek_odcinka(AC);\r
+ call D.plot;\r
+ call outstring("D");\r
+ call WaitMoment;\r
+ o1:=new okrag(D,odleglosc(D,C));\r
+ call cirb(round(D.x*aspekt),round(d.y),round(odleglosc(D,C)*aspekt),1,1,1,0,1,1);\r
+ BE:=prostopadla(AC,B);\r
+ call WaitMoment;\r
+ call okrag_odcinek(o1,BE,F,G);\r
+ wynik:=odleglosc(B,F);\r
+ call F.plot;\r
+ call outstring("F");\r
+ BF:=new odcinek(B,F);\r
+ call move(100,310);\r
+ call outstring("Dlugosc odcinka BF wynosi pierwiastek z dlugosci odcinka AB.");\r
+ call WaitMoment;\r
+ call groff\r
+ end\r
+end.\r
+\1a
\ No newline at end of file
--- /dev/null
+program Seg;\r
+begin;\r
+pref IIUWGRAPH block;\r
+\r
+unit Welcome : Ansi procedure ;\r
+const X = 100 ,\r
+ Y = 80 ,\r
+ Height = 150 ,\r
+ Width = 80 ,\r
+ Room = 20;\r
+\r
+var P : point ,\r
+ i : integer ;\r
+ \r
+ unit DrawO : procedure( P : Point );\r
+ begin\r
+ call Move( P.X,P.Y );\r
+ call Draw( P.X + Width , P.Y );\r
+ call Draw( P.X + Width , P.Y + Height );\r
+ call Draw( P.X , P.Y + Height );\r
+ call Draw( P.X , P.Y );\r
+ end;\r
+ \r
+ unit DrawD : procedure( P : Point );\r
+ begin\r
+ call DrawO( P );\r
+ call Move( P.X + 2,P.Y );\r
+ call Draw( P.X + 2 ,P.Y + Height );\r
+ end;\r
+ \r
+ unit DrawC : procedure( P : point );\r
+ begin\r
+ call Move( P.X + Width ,P.Y );\r
+ call Draw( P.X, P.Y );\r
+ call Draw( P.X , P.Y + Height );\r
+ call Draw( P.X + Width , P.Y + Height ); \r
+ end;\r
+ \r
+ unit DrawI : procedure( P : point );\r
+ begin\r
+ call Move( P.X,P.Y );\r
+ call Draw( P.X + 2, P.Y );\r
+ call Draw( P.X + 2, P.Y + Height );\r
+ call Draw( P.X,P.Y + Height );\r
+ call Draw( P.X, P.Y );\r
+ end;\r
+ \r
+ unit DrawN : procedure( P : point );\r
+ begin \r
+ call Move( P.X , P.Y + Height );\r
+ call Draw( P.X , P.Y );\r
+ call Draw( P.X + Width , P.Y + Height );\r
+ call Draw( P.X + Width , P.Y );\r
+ end DrawN ;\r
+ \r
+ unit DrawK : procedure( P : point );\r
+ begin\r
+ call Move( P.X , P.Y );\r
+ call Draw( P.X, P.Y + Height );\r
+ call Move( P.X + Width , P.Y );\r
+ call Draw( P.X , P.Y + Height div 2 );\r
+ call Draw( P.X + Width , P.Y + Height );\r
+ end;\r
+\r
+ begin\r
+ call Gron( 1 );\r
+ P := new point ( X,Y ); \r
+ call DrawO( P ); \r
+ P.X := P.X + Width + Room;\r
+ call DrawD( P );\r
+ P.X := P.X + Width + Room ;\r
+ call DrawC( P );\r
+ P.X := P.X + Width + Room ;\r
+ call DrawI( P );\r
+ P.X := P.X + Room;\r
+ call DrawN( P );\r
+ P.X := P.X + Width + Room ;\r
+ call DrawK( P );\r
+ P.X := P.X + Width + Room ;\r
+ call DrawI( P );\r
+ P.Y := 300 ;\r
+ P.X := 20;\r
+ call MyWrite( P, "Copyright by Anna Wosinska " );\r
+ i := inchar ;\r
+ if i = Hlp then call Help ; fi ;\r
+ call Groff;\r
+ end Welcome;\r
+ \r
+ \r
+ \r
+ \r
+unit Point : class ( X, Y : integer);\r
+end Point;\r
+\r
+unit Interval : class( x1, x2 : integer );\r
+ \r
+ unit Assign : procedure( y1,y2 : integer );\r
+\r
+ begin\r
+ if y1 > y2 then call Swap( y1,y2 ); fi; \r
+ x1 := y1;\r
+ x2 := y2;\r
+ end Assign; \r
+\r
+begin\r
+ if x1 > x2 then call Swap ( x1,x2 ); fi; \r
+end Interval; \r
+\r
+unit Swap : procedure( inout y1,y2 : integer );\r
+ var x : integer;\r
+begin\r
+ x := y1;\r
+ y1 := y2;\r
+ y2 := x;\r
+end Swap; \r
+\r
+ unit Elem : class( Info : integer );\r
+ var next : Elem;\r
+ end Elem ;\r
+ \r
+unit IncidList : class( Key : integer );\r
+ var Head : Elem;\r
+ \r
+ unit Into : procedure( i : integer );\r
+ var Aux : Elem;\r
+ \r
+ begin\r
+ if Head = none then\r
+ Head := new Elem( i );\r
+ else \r
+ Aux := new Elem( i );\r
+ Aux.next := Head.next ;\r
+ Head.next := Aux;\r
+ fi; \r
+ end Into;\r
+ \r
+ unit KillList : procedure ;\r
+ \r
+ unit KL : procedure( inout u : Elem );\r
+ begin\r
+ if u <> none then\r
+ if u.next = none then\r
+ kill ( u );\r
+ else \r
+ call KL( u.next ); \r
+ fi; \r
+ fi; \r
+ end KL;\r
+ \r
+ begin \r
+ call KL( Head );\r
+ end KillList ;\r
+ \r
+end IncidList;\r
+\r
+unit Node : class( Key, Info : integer );\r
+var l, r : node ;\r
+end Node ;\r
+\r
+unit BST : class ;\r
+close Delete, Insert ;\r
+\r
+ var root : node;\r
+\r
+(* Nodes in this BST are sorted according to their Key value( k ) *)\r
+\r
+ unit Insert : procedure( k,i : integer );\r
+ \r
+ unit Ins : procedure( inout u : node );\r
+ begin\r
+ if u <> none then\r
+ if k <= u.Key then call Ins( u.l );\r
+ else call Ins( u.r );\r
+ fi;\r
+ else\r
+ u := new node( k, i );\r
+ fi;\r
+ end Ins;\r
+ \r
+ begin (* Insert *)\r
+ call Ins( root );\r
+ end Insert;\r
+ \r
+ unit Build : procedure( P : integer);\r
+ var i : integer;\r
+ \r
+ begin\r
+ for i := 1 to Act do\r
+ if Tree( P,i ) = 0 then exit ; \r
+ else\r
+ if not Lines( Tree( P,i) ).Vertical then\r
+ call Insert( Lines( Tree( P,i )).Pe.X , Tree( P,i ));\r
+ call Insert( Lines( Tree( P,i )).Pb.X , Tree( P,i ));\r
+ \r
+ else\r
+ (* Lines( Tree( P,i )).Vertical *)\r
+ if Min( Lines( Tree( P,i )).Pb.Y , Lines( Tree( P,i )).Pe.Y ) = P \r
+ then\r
+ call Insert( Lines( Tree( P,i )).Pb.X , Tree( P,i ));\r
+ fi; \r
+ fi; \r
+ fi;\r
+ od;\r
+ end Build;\r
+ \r
+\r
+ unit Update : procedure( P : integer ) ;\r
+ var i : integer ;\r
+ \r
+ begin\r
+ for i := 1 to Act do\r
+ if Tree( P,i ) = 0 then exit ; fi;\r
+ \r
+ if Lines( Tree( P,i )).Vertical then\r
+ if Max( Lines( Tree( P,i )).Pb.Y , Lines( Tree( P,i )).Pe.Y ) = P \r
+ then\r
+ call Delete( Lines( Tree( P,i )).Pb.X , Tree( P,i ) ) ;\r
+ fi;\r
+ \r
+ else \r
+ call Delete( Lines( Tree( P,i )).Pb.X , Tree( P,i ) );\r
+ call Delete( Lines( Tree( P,i )).Pe.X , Tree( P,i ) ); \r
+ fi;\r
+ od;\r
+ end Update ; \r
+ \r
+ \r
+ unit Delete : procedure( k,i : integer );\r
+ \r
+ unit Del : procedure( inout u : node );\r
+ var Q : node ;\r
+ \r
+ unit DelMax : procedure( inout v : node );\r
+ begin\r
+ if v.r <> none then call DelMax( v.r );\r
+ else\r
+ (* v.r = none *)\r
+ Q.Key := v.Key;\r
+ Q.Info := v.Info ;\r
+ Q := v ;\r
+ v := v.l ;\r
+ fi;\r
+ end; \r
+ \r
+ begin\r
+ if u <> none then\r
+ if k < u.key then call Del ( u.l );\r
+ else\r
+ if k > u.key then call Del( u.r );\r
+ else\r
+ if i <> u.info then call Del( u.l );\r
+ else\r
+ (* k = u.key *)\r
+ (* i = u.info *) \r
+ Q := u;\r
+ if u.r = none then u := u.l ;\r
+ else\r
+ (* u.r <> none *)\r
+ if u.l = none then u := u.r ;\r
+ else\r
+ (* u.r <> none *)\r
+ (* u.l <> none *)\r
+ call DelMax( Q.l );\r
+ kill(Q);\r
+ (* Q = maximal in left subtree of u *)\r
+ fi;\r
+ fi;\r
+ fi; \r
+ fi;\r
+ fi; \r
+ fi;\r
+ end Del;\r
+ \r
+ begin\r
+ call Del ( root );\r
+ end Delete ; \r
+\r
+ unit Range : procedure ( x1, x2, Index : integer );\r
+ \r
+ unit Ran : procedure( v : node );\r
+ var tx1, tx2 : boolean;\r
+ \r
+ begin\r
+ if v <> none then\r
+ if x1 > x2 then call Swap( x1,x2 ); fi ;\r
+ tx1 := v.Key >= x1;\r
+ tx2 := v.Key <= x2;\r
+ \r
+(* x1 < v.key < x2 *)\r
+ if v.info = 0 then\r
+ call Groff;\r
+ writeln("v.info = 0 ");\r
+ call Endrun ;\r
+ fi;\r
+ \r
+ if tx2 and tx1 then call Information( Index ).Into( v.info ) ;fi;\r
+ \r
+ if tx2 then call Ran( v.r ); fi;\r
+ fi; \r
+ end Ran;\r
+ \r
+ begin (* Range *);\r
+ call Ran( root );\r
+ end Range;\r
+\r
+\r
+ \r
+end BST;\r
+\r
+\r
+unit Murderer : procedure( T : BST );\r
+\r
+ unit Killer : procedure( u : Node ); \r
+ begin\r
+ if u <> none then\r
+ if u.l <> none then\r
+ call Killer( u.l );fi;\r
+ if u.r <> none then \r
+ call Killer( u.r ); fi;\r
+ kill( u );\r
+ fi;\r
+ end Killer; \r
+ \r
+ begin\r
+ if T <> none then \r
+ call Killer( T.Root );\r
+ fi; \r
+end Murderer;\r
+\r
+unit BuildTree : procedure;\r
+\r
+ var j,i : integer; \r
+ \r
+begin\r
+ array Tree dim ( MinY : MaxY );\r
+ for i := MinY to MaxY do\r
+ array Tree( i ) dim ( 1 : Act + 1 );\r
+ od ;\r
+ \r
+ for i := 1 to Act do\r
+ j := 1;\r
+ while Tree( Lines( i ).Pb.Y,j ) <> 0 do j := j + 1 ; od;\r
+ \r
+ Tree( Lines( i ).Pb.Y, j ) := i ;\r
+ \r
+ if Lines( i ).Vertical then \r
+ j := 1;\r
+ while Tree( Lines( i ).Pe.Y,j ) <> 0 do j := j + 1; od;\r
+ Tree( Lines( i ).Pe.Y, j ) := i ;\r
+ fi;\r
+ od;\r
+end BuildTree ; \r
+\r
+unit Scan : procedure ;\r
+var XTree : BST,\r
+ Aux : Elem,\r
+ k,l : integer ;\r
+begin\r
+ Xtree := new BST ;\r
+ for k := MinY to MaxY do\r
+ if Tree( k,1 ) <> 0 then \r
+ call BegScanLine( k ) ;\r
+ call XTree.Build( k ); \r
+ for l := 1 to Act do\r
+ if Tree( k,l ) = 0 then exit ; fi;\r
+ call XTree.Range( Lines( Tree( k,l)).Pb.X, Lines( Tree( k,l)).Pe.X ,\r
+ Tree( k,l ) );\r
+\r
+ Aux := Information( Tree( k,l )).Head;\r
+ block\r
+ \r
+handlers\r
+ when conerror : call groff ;\r
+ writeln("k = ", k) ;\r
+ writeln("l = ", l) ;\r
+ if k < lower(Tree) orif k > upper(Tree)\r
+ orif l < lower(Tree(k)) orif l > upper(Tree(k)) then\r
+ writeln(" Excessed bounds of Tree ") ;\r
+ else\r
+ writeln("Tree(k,l) = ", Tree(k,l));\r
+ writeln("Aux.Info = ", Aux.Info) ;\r
+ if Tree(k,l) < lower(Lines) \r
+ orif Tree(k,l) > upper(Lines) \r
+ orif Aux.Info < lower(Lines)\r
+ orif Aux.Info > upper(Lines) then\r
+ writeln("Excessed bounds of Lines, which are (", \r
+ lower(Lines), ":", upper(Lines), ")") ;\r
+ fi ;\r
+ fi ;\r
+ call endrun ;\r
+ end handlers ; \r
+ begin \r
+ while Aux <> none do\r
+ call CrossPoint( Lines( Tree( k,l )),Lines( Aux.Info ));\r
+ Aux := Aux.next;\r
+ od; \r
+ end ;\r
+ od;\r
+\r
+ call Xtree.Update( k );\r
+(* call kill ( Tree( k )); *)\r
+ call EndScanLine( k ) ;\r
+ fi;\r
+ od;\r
+ call Murderer( XTree );\r
+end Scan ; \r
+\r
+unit ANSI : class;\r
+ \r
+ \r
+ unit Inchar : IIUWgraph function : integer ;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+\r
+end Ansi;\r
+\r
+unit MyWrite : procedure( Pos : Point, Word : string );\r
+var i : integer,\r
+ A : arrayof char;\r
+ \r
+begin;\r
+ A := unpack( Word );\r
+ call Move( Pos.X, Pos.Y );\r
+ for i := lower( A ) to upper( A ) do\r
+ call HASCII( 0 );\r
+ call HASCII( ord( A( i )));\r
+ od;\r
+ kill ( A ); \r
+end MyWrite;\r
+\r
+unit Erase : procedure( Line : integer );\r
+var Aux : Point;\r
+\r
+begin\r
+ Aux := new Point( Left + M, Line );\r
+ call Mywrite(Aux,\r
+ " ");\r
+ kill ( Aux );\r
+end Erase; \r
+\r
+unit Frame : procedure( P1, P2 : point );\r
+begin\r
+ call Move ( P1.X, P1.Y );\r
+ call Draw ( P1.X, P2.Y );\r
+ call Draw ( P2.X, P2.Y );\r
+ call Draw ( P2.X, P1.Y );\r
+ call Draw ( P1.X, P1.Y );\r
+end Frame;\r
+\r
+unit SysDraw : procedure;\r
+\r
+ unit GradVert : procedure( P : Point, Number : integer );\r
+ var i,j : integer;\r
+ \r
+ begin\r
+ call Move( P.X - M, P.Y );\r
+ call Draw( P.X + M, P.Y );\r
+ if Number < 10 then \r
+ call Move( P.X - 2 * M - LetDim , P.Y - LetDim div 2 );\r
+ call HASCII( 0 );\r
+ call HASCII( Number + 48 );\r
+ else \r
+ i := Number div 10; \r
+ j := Number - i * 10; \r
+ call Move( P.X - 2 * M - 2 * LetDim , P.Y - LetDim div 2 ); \r
+ call HASCII( 0 ); \r
+ call Hascii( i + 48 ); \r
+ call Move( P.X - 2 * M - LetDim , P.Y - LetDim div 2 ); \r
+ call Hascii( 0 ); \r
+ call Hascii( j + 48 ); \r
+ fi;\r
+ end GradVert;\r
+ \r
+ unit GradHor : procedure( P : Point , Number : integer );\r
+ var i,j : integer;\r
+ \r
+ begin\r
+ call Move( P.X, P.Y - M );\r
+ call Draw( P.X, P.Y + M );\r
+ if Number < 10 then\r
+ call Move( P.X - LetDim div 2, P.Y + 4 * M );\r
+ call HASCII( 0 );\r
+ call HASCII( Number + 48 );\r
+ else\r
+ i := Number div 10;\r
+ j := Number - i * 10;\r
+ call Move( P.X - LetDim div 2 , P.Y + 4 * M ); \r
+ call HASCII( 0 );\r
+ call Hascii( i + 48 );\r
+ call Hascii( 0 );\r
+ call Hascii( j + 48 );\r
+ fi; \r
+ end GradHor;\r
+\r
+ unit ArVert : procedure( X, Y : integer);\r
+ begin\r
+ call Move( X - 2 * M, Y + 2 * M );\r
+ call Draw( X, Y );\r
+ call Draw( X + 2 * M, Y + 2 * M );\r
+ end ArVert;\r
+ \r
+ unit ArHor : procedure( X,Y : integer );\r
+ begin\r
+ call Move( X - 2 * M, Y - 2 * M );\r
+ call Draw( X, Y );\r
+ call Draw( X - 2 * M, Y + 2 * M );\r
+ end ArHor;\r
+ \r
+var i : integer,\r
+ P : Point; \r
+ \r
+begin\r
+ call Move( LeftMargin,UpMargin );\r
+ call Draw( LeftMargin, DimY - DownMargin );\r
+ call Draw( DimX - RightMargin, DimY - DownMargin );\r
+ call ArVert( LeftMargin, UpMargin );\r
+ call ArHor( DimX - RightMargin, DimY - DownMargin ); \r
+ \r
+call Move( LeftMargin - 2 * M - 2 * LetDim, DimY - DownMargin - LetDim div 2);\r
+ call Hascii( 0 );\r
+ call Hascii( 48 );\r
+ call Hascii( 48 );\r
+ \r
+ P := new Point( LeftMargin, DimY - DownMargin );\r
+ for i := MinX + 1 to MaxX do\r
+ P.X := P.X + Sc;\r
+ call GradHor( P , i ); \r
+ od;\r
+ kill ( P ); \r
+ \r
+ P := new Point ( LeftMargin, DimY - DownMargin ); \r
+ for i := MinY + 1 to MaxY do\r
+ P.Y := P.Y - Sc;\r
+ call GradVert( P , i );\r
+ od; \r
+ kill ( P );\r
+end SysDraw;\r
+\r
+unit Segment : class( pb , pe : Point, Vert : boolean );\r
+hidden Vert;\r
+\r
+ unit Vertical : function : boolean;\r
+ begin\r
+ result := Vert ;\r
+ end Vertical;\r
+\r
+ \r
+end Segment;\r
+\r
+unit SegKill : procedure( inout S : Segment );\r
+begin\r
+ kill ( S.Pb );\r
+ kill ( S.Pe );\r
+ kill ( S );\r
+end SegKill ;\r
+\r
+unit GenSeg : function : Segment ;\r
+\r
+var X1, Y1, X2, Y2 : integer; \r
+ \r
+begin\r
+ if Random < 0.5 then \r
+ (* Generates horizontal segment *)\r
+ do\r
+ X1 := Random * MaxX ;\r
+ Y1 := Random * MaxY ;\r
+ X2 := Random * MaxX ;\r
+ Y2 := Y1;\r
+ if X1 <> X2 and Y2 > MinX then exit ; fi;\r
+ od;\r
+ result := new Segment( new Point( X1 ,Y1 ), new Point( X2,Y2 ),false); \r
+ else\r
+ (* Generates vertical segment *) \r
+ do\r
+ X1 := Random * MaxX ;\r
+ Y1 := Random * MaxY ;\r
+ X2 := X1;\r
+ Y2 := Random * MaxY ;\r
+ if Y1 <> Y2 and X2 > MinX then exit; fi;\r
+ od; \r
+ result := new Segment( new Point( X1 ,Y1 ), new Point( X2,Y2 ),true);\r
+ fi;\r
+\r
+end GenSeg;\r
+\r
+unit SegDraw : procedure( S : Segment );\r
+\r
+begin;\r
+ if S.Vertical then\r
+ call Move( LeftMargin + Sc*S.Pb.X + M, DimY - ( Sc*S.Pb.Y + DownMargin));\r
+ call Draw( LeftMargin + Sc*S.Pb.X - M, DimY - ( Sc*S.Pb.Y + DownMargin)); \r
+ call Move( LeftMargin + Sc*S.Pb.X, DimY - ( Sc*S.Pb.Y + DownMargin));\r
+ call Draw( LeftMargin + Sc*S.Pe.X, DimY - ( Sc*S.Pe.Y + DownMargin));\r
+ call Move( LeftMargin + Sc*S.Pe.X + M, DimY - ( Sc*S.Pe.Y + DownMargin)); \r
+ call Draw( LeftMargin + Sc*S.Pe.X - M, DimY - ( Sc*S.Pe.Y + DownMargin));\r
+ else\r
+ call Move( LeftMargin + Sc*S.Pb.X , DimY - ( Sc*S.Pb.Y + DownMargin) + M );\r
+ call Draw( LeftMargin + Sc*S.Pb.X , DimY - ( Sc*S.Pb.Y + DownMargin) - M); \r
+ call Move( LeftMargin + Sc*S.Pb.X, DimY - ( Sc*S.Pb.Y + DownMargin));\r
+ call Draw( LeftMargin + Sc*S.Pe.X, DimY - ( Sc*S.Pe.Y + DownMargin));\r
+ call Move( LeftMargin + Sc*S.Pe.X , DimY - ( Sc*S.Pe.Y + DownMargin) + M);\r
+ call Draw( LeftMargin + Sc*S.Pe.X , DimY - ( Sc*S.Pe.Y + DownMargin) - M); \r
+ fi;\r
+end SegDraw;\r
+\r
+unit KeyServer : Ansi procedure;\r
+var PrevChar , i : integer;\r
+\r
+begin\r
+ while not Over do\r
+ i := inchar;\r
+ case i \r
+ when Esc : call Escape;\r
+ when NSys : Over := true;\r
+ when Hlp : call Help; \r
+ when NewSeg : if PrevChar <> NewSeg then call ClearWindow; fi;\r
+ Act := Act + 1;\r
+ Lines( Act ) := GenSeg;\r
+ call SegEdit( Act );\r
+ call SegDraw( Lines( Act )); \r
+ \r
+ when Termin : exit;\r
+ \r
+ when Enter : call ClearWindow; \r
+ call SegRead;\r
+ \r
+ otherwise;\r
+ esac;\r
+ PrevChar := i;\r
+ od; \r
+ call ClearWindow ;\r
+end KeyServer ;\r
+\r
+unit Pause : procedure( T : integer );\r
+var i : integer;\r
+begin\r
+ for i := 1 to T do; od;\r
+end Pause ; \r
+ \r
+\r
+unit Help : Ansi procedure;\r
+var i : integer ,\r
+ Aux : Point ;\r
+begin;\r
+ Aux := new Point( LeftMargin + Distance, DimY - Window + 2 * M ) ;\r
+ call Clearwindow ;\r
+call MyWrite\r
+ ( Aux," Esc - terminates program, Del - new system of coordinates ");\r
+ Aux.Y := Aux.Y + LetDim + M ;\r
+call Mywrite( Aux," Enter - generates new segment, End - scanning ");\r
+ Aux.Y := Aux.Y + LetDim + M ;\r
+call MyWrite( Aux," Space - you enter new segment ");\r
+ kill ( Aux ) ;\r
+ i := inchar ;\r
+ call ClearWindow ;\r
+end Help;\r
+\r
+unit SegRead : procedure;\r
+\r
+\r
+ unit ReadInteger : ANSI function : integer;\r
+\r
+ \r
+ var X,Y,i, OrdN, j : integer,\r
+ Number : arrayof integer;\r
+(* i - liczba wprowadzonych znakow *)\r
+ begin\r
+ array Number dim( 1 : NumbLenght );\r
+ i:= 0 ;\r
+ X := InXPos;\r
+ Y := InYPos;\r
+ do\r
+ OrdN:=inchar;\r
+ if i = NumbLenght or (OrdN < 48 and OrdN > 57) then exit fi;\r
+\r
+ case OrdN\r
+ when 48 :i:=i+1;\r
+ Number(i):=0;\r
+ when 49 :i:=i+1;\r
+ Number(i):=1;\r
+ when 50 :i:=i+1;\r
+ Number(i):=2;\r
+ when 51 :i:=i+1;\r
+ Number(i):=3;\r
+ when 52 :i:=i+1;\r
+ Number(i):=4;\r
+ when 53 :i:=i+1;\r
+ Number(i):=5;\r
+ when 54 :i:=i+1;\r
+ Number(i):=6;\r
+ when 55 :i:=i+1;\r
+ Number(i):=7;\r
+ when 56 :i:=i+1;\r
+ Number(i):=8;\r
+ when 57 :i:=i+1;\r
+ Number(i):=9;\r
+ when 8 :if i>0 then\r
+ Number( i ) := 0;\r
+ i := i - 1;\r
+ fi;\r
+ when 13 :if i > 0 then exit fi ;\r
+\r
+ esac;\r
+ \r
+ if Number( 1 ) <> 0 then\r
+ call Move( X,Y );\r
+ call hascii( 0 );\r
+ call hascii(48+Number( 1 ));\r
+ call hascii( 0 );\r
+\r
+ fi;\r
+ \r
+ if i = 2 then\r
+ call Move( X + LetDim, Y ); \r
+ call hascii( 0 );\r
+ call hascii( 48 + Number( 2 )); \r
+ call hascii( 0 );\r
+ fi; \r
+ od;\r
+ \r
+ if Number( 1 ) = 0 and Number( 2 ) = 0 then\r
+ call Move( X,Y );\r
+ call hascii( 0 );\r
+ call hascii( 48 );\r
+ call hascii( 0 ); \r
+ fi; \r
+ \r
+ if i = 1 then result := Number( 1 );\r
+ else\r
+ result := 10 * Number( 1 ) + Number ( 2 );\r
+ fi;\r
+ kill( Number );\r
+ end ReadInteger;\r
+ \r
+const StrLenght = 26;\r
+ \r
+var Aux : Point,\r
+ X1, X2, Y1, Y2 : integer;\r
+ \r
+begin\r
+ Aux := new Point( LeftMargin + Distance, DimY - Window + 2 * M ) ;\r
+ call MyWrite( Aux," ENTER NEW SEGMENT : X1 = " );\r
+ X1 := ReadInteger;\r
+ Aux.X := Aux.X + StrLenght * LetDim + NumbLenght * LetDim; \r
+ call MyWrite( Aux ," Y1 = " );\r
+ Y1 := ReadInteger;\r
+ \r
+ Aux.X := Aux.X - (NumbLenght + 6) * LetDim;\r
+ Aux.Y := Aux.Y + M + LetDim;\r
+ call MyWrite( Aux, " X2 = " );\r
+ X2 := ReadInteger; \r
+ Aux.X := Aux.X + (NumbLenght + 6 ) * LetDim ;\r
+ call Mywrite( Aux, " Y2 = " );\r
+ Y2 := ReadInteger;\r
+ Aux.X := Aux.X - StrLenght * LetDim - NumbLenght * LetDim; \r
+ Aux.Y := Aux.Y + M + LetDim;\r
+ if ( X1 <> X2 ) and ( Y1 <> Y2 ) then \r
+ call MyWrite( Aux," THIS SEGMENT IS NEITHER HORIZONTAL NOR VERTICAL ! ");\r
+ else\r
+ if X1 < MaxX and X2 < MaxX and Y1 < MaxY and Y2 < MaxY then\r
+ Act := Act + 1;\r
+ if X1 = X2 then\r
+ Lines( Act ) := new Segment( new Point( X1,Y1 ),\r
+ new Point( X2,Y2 ), true );\r
+ else\r
+ Lines( Act ) := new Segment( new Point( X1,Y1 ),\r
+ new Point( X2,Y2 ), false );\r
+ fi;\r
+ call SegDraw( Lines( Act ));\r
+ else\r
+ call MyWrite( Aux," THE SEGMENT IS TOO BIG ! " );\r
+ fi;\r
+ fi;\r
+ kill ( Aux );\r
+end SegRead;\r
+\r
+unit WriteInteger : procedure( Number : integer );\r
+begin\r
+ if Number < 10 then\r
+ call HASCII( 0 );\r
+ call HASCII( Number + 48 );\r
+ call Hascii( 0 );\r
+ else\r
+ i := Number div 10;\r
+ j := Number - i * 10;\r
+ call HASCII( 0 );\r
+ call Hascii( i + 48 );\r
+ call Hascii( 0 );\r
+ call Hascii( j + 48 );\r
+ fi; \r
+end WriteInteger;\r
+ \r
+unit SegEdit : procedure( Cur : integer );\r
+\r
+\r
+const StrLenght = 24;\r
+\r
+var Aux : Point;\r
+\r
+begin;\r
+ Aux := new Point( LeftMargin + Distance, DimY - Window + 2 * M ); \r
+ call MyWrite( Aux," CURRENT SEGMENT : ");\r
+ call WriteInteger( Act );\r
+ \r
+ Aux.Y := Aux.Y + M + LetDim ;\r
+ call Mywrite( Aux," BEGIN : X1 = ");\r
+ call WriteInteger( Lines( Cur ).Pb.X );\r
+ Aux.X := Aux.X + StrLenght * LetDim + NumbLenght * LetDim ;\r
+ call MyWrite( Aux," Y1 = ");\r
+ call WriteInteger( Lines( Cur ).Pb.Y );\r
+ \r
+ Aux.X := Aux.X - StrLenght * LetDim - NumbLenght * LetDim ;\r
+ Aux.Y := Aux.Y + M + LetDim ; \r
+ call Mywrite( Aux," END : X2 = ");\r
+ call WriteInteger( Lines( Cur ).Pe.X );\r
+ Aux.X := Aux.X + StrLenght * LetDim + NumbLenght * LetDim ;\r
+ call MyWrite( Aux," Y2 = ");\r
+ call WriteInteger( Lines( Cur ).Pe.Y );\r
+ kill ( Aux );\r
+end SegEdit;\r
+\r
+unit ClearWindow : procedure ;\r
+var \r
+ Line, i : integer;\r
+ \r
+begin\r
+ for i := 0 to (( Window - Down ) div LetDim) - 1 do\r
+ call Erase( DimY - Window + i * LetDim + M );\r
+ od;\r
+end ClearWindow ; \r
+\r
+unit Escape : procedure;\r
+begin;\r
+ Over := true;\r
+ Continue := false;\r
+end Escape;\r
+\r
+\r
+\r
+unit CrossPoint : procedure ( S1, S2 : segment ) ;\r
+var X1,X2,X3,X4,Y1,Y2,Y3,Y4 : integer ;\r
+\r
+begin\r
+ if S1.Vertical then\r
+ if not S2.Vertical then\r
+ (* S1 is vertical and S2 is horizontal *)\r
+ call Mark( S1.pe.X, S2.pe.Y); \r
+ else\r
+ (* both S1 and S2 are vertical *)\r
+ Y1 := min( S1.pb.Y, S1.pe.Y );\r
+ Y2 := max( S1.pb.Y, S1.pe.Y );\r
+ Y3 := min( S2.pb.Y, S2.pe.Y );\r
+ Y4 := max( S2.pb.Y, S2.pe.Y );\r
+ if not( Y1 = Y3 and Y2 = Y4 ) then \r
+ if Y2 > Y4 then\r
+ if Y1 > Y3 then\r
+ call Mark( S1.pb.X, Y4 );\r
+ call Mark( S1.pb.X, Y1 );\r
+ else\r
+ call Mark( S1.pb.X, Y4 );\r
+ call Mark( S1.pb.X, Y3 ); \r
+ fi; \r
+ else\r
+ if Y1 > Y3 then\r
+ call Mark( S1.pb.X, Y2 );\r
+ call Mark( S1.pb.X, Y1);\r
+ else\r
+ call Mark( S1.pb.X, Y2 ); \r
+ call Mark( S1.pb.X, Y3);\r
+ fi; \r
+ fi; \r
+ fi;\r
+ fi; \r
+ else\r
+ if S2.Vertical then\r
+ (* S1 is horizontal and S2 is vertical *)\r
+ call Mark( S2.Pb.X, S1.Pb.Y);\r
+ else\r
+ (* both are horizontal *) \r
+ X1 := min( S1.pb.X, S1.pe.X );\r
+ X2 := max( S1.pb.X, S1.pe.X );\r
+ X3 := min( S2.pb.X, S2.pe.X );\r
+ X4 := max( S2.pb.X, S2.pe.X );\r
+ if not( X1 = X3 and X2 = X4 ) then\r
+ if X2 > X4 then\r
+ if X3 > X1 then\r
+ call Mark( X4, S1.pb.Y);\r
+ call Mark( X3, S1.pb.Y); \r
+ else\r
+ call Mark( X1, S1.pb.Y);\r
+ call Mark( X4, S1.pb.Y);\r
+ fi; \r
+ else\r
+ if X3 > X1 then\r
+ call Mark( X3, S1.pb.Y);\r
+ call Mark( X2, S1.pb.Y); \r
+ else\r
+ call Mark( X1, S1.pb.Y); \r
+ call Mark( X2, S1.pb.Y);\r
+ fi; \r
+ fi; \r
+ fi; \r
+ fi;\r
+ fi;\r
+end CrossPoint ; \r
+\r
+unit Mark : procedure( input X,Y : integer );\r
+\r
+begin\r
+ if X >= 0 and Y >= 0 then\r
+ x := X * Sc + LeftMargin ;\r
+ y := DimY - ( DownMargin + Y * Sc ) ; \r
+ call cirb( x,y,R,1,1,1,0,1,1 );\r
+ fi; \r
+end Mark; \r
+\r
+unit Min : function( x,y : integer ): integer ;\r
+begin\r
+ if x < y then result := x ;\r
+ else result := y; fi;\r
+end Min ; \r
+\r
+unit Max: function( x,y : integer ) : integer ;\r
+begin\r
+ if x < y then result := y ;\r
+ else result := x; fi;\r
+end Max ;\r
+\r
+var Aux : Point, \r
+ LongHLine : arrayof integer ;\r
+ \r
+unit BegScanLine : procedure( y : integer );\r
+\r
+begin\r
+ call Move( LeftMargin , DimY - DownMargin - y * Sc );\r
+ LongHLine:= GetMap( DimX - RightMargin, DimY - DownMargin - y * Sc) ;\r
+ call Move( LeftMargin, DimY - DownMargin - y * Sc);\r
+ call Draw( DimX - RightMargin, DimY - DownMargin - y * Sc) ;\r
+ Aux := new Point( LeftMargin + Distance, DimY - Window + 2 * M ) ;\r
+ call MyWrite( Aux," SCANNING ... : ");\r
+ call WriteInteger( y );\r
+end BegScanLine ; \r
+\r
+\r
+unit EndScanLine : procedure( y : integer );\r
+\r
+begin\r
+ call Move( LeftMargin, DimY - DownMargin - y * Sc);\r
+ call PutMap( LongHLine );\r
+ kill ( LongHLine );\r
+ call Erase( Aux.Y );\r
+ kill ( Aux );\r
+end EndScanLine;\r
+ \r
+\r
+\r
+ \r
+const\r
+ NumbLenght = 2,\r
+ DimX = 619,\r
+ DimY = 348,\r
+ M = 2, \r
+ R = 3,\r
+ LetDim = 8,\r
+ Distance = 20, \r
+ Window = 40,\r
+ Left = 0,\r
+ Right = 0, \r
+ Up = 0,\r
+ Down = 2, \r
+ LeftMargin = 25,\r
+ RightMargin = 10,\r
+ UpMargin = 10,\r
+ DownMargin = 60,\r
+ Sc = 20,\r
+ MaxX = 29,\r
+ MinX = 0,\r
+ MaxY = 14,\r
+ MinY = 0,\r
+ Esc = 27, (* Escape *)\r
+ Hlp = - 59, (* F1 *)\r
+ NSys = - 83,(* Del *)\r
+ Enter = 13, (* enter *)\r
+ Termin = - 79,(* End *)\r
+ NewSeg = 32, (* space bar *)\r
+ Numb = 100; \r
+\r
+\r
+var Tree : arrayof arrayof integer ,\r
+ Act, j, i : integer,\r
+ Continue,Over : boolean,\r
+ Information : arrayof IncidList,\r
+ Lines : arrayof segment;\r
+ \r
+begin (* Seg *);\r
+ call Welcome ;\r
+ Continue := true;\r
+ while Continue do\r
+ Act := 0;\r
+ Over := false;\r
+ call Gron( 1 );\r
+ call Frame( new Point( Left, Up ),\r
+ new Point( DimX - Right, DimY - Window - M ));\r
+ call Frame( new Point( Left, DimY - Window ),\r
+ new Point( DimX - Right, DimY - Down )); \r
+ call SysDraw;\r
+ array Lines dim( 1 : Numb );\r
+ call KeyServer;\r
+ if not Over and Act > 0 then\r
+ call BuildTree;\r
+ array Information dim ( 1 : Act );\r
+ for i := 1 to Act do\r
+ Information( i ) := new IncidList( i );\r
+ od; \r
+ call Scan;\r
+ write( chr( 7 ));\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit; fi;\r
+ od; \r
+ call Groff;\r
+ if i = Esc then exit ; fi ;\r
+ \r
+ for i := 1 to Act do\r
+ if Information( i ) <> none then\r
+ call Information( i ). KillList;\r
+ fi; \r
+ od;\r
+ kill ( Information );\r
+ for i:=1 to Act do\r
+ call SegKill( Lines( i )); \r
+ od;\r
+ kill ( Lines ); \r
+ for i := MinY to MaxY do kill ( Tree( i )); od;\r
+ kill ( Tree );\r
+ fi; \r
+ od; \r
+ call Groff ; \r
+end ;\r
+end;\r
+\1a
\ No newline at end of file
--- /dev/null
+PROGRAM P3D;\r
+ signal WIN1, WIN2, WIN3, PLEIN;\r
+ \r
+ UNIT INCHAR : IIuwgraph function : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ UNIT INIT_GRAPH : procedure;\r
+ begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call hpage(0,1,1);\r
+ end\r
+ end init_graph;\r
+\r
+(* DEFINIT LES 27 ZONES ACTIVE DE L'ECRAN\r
+ OU L'ON PEUT CLIQUER A LA SOURIS *)\r
+\r
+ UNIT MOUSEPOS : function : integer;\r
+ var x, y : integer,\r
+ pressed, l, r, c : boolean;\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,b,l,r,c);\r
+ if l then\r
+ if ((x>110) and (x<130))\r
+ then if ((y>290) and (y<310)) then result := 1; exit fi;\r
+ if ((y>190) and (y<210)) then result := 11; exit fi;\r
+ if ((y>090) and (y<110)) then result := 21; exit fi;\r
+ fi;\r
+ if ((x>260) and (x<280))\r
+ then if ((y>290) and (y<310)) then result := 2; exit fi;\r
+ if ((y>190) and (y<210)) then result := 12; exit fi;\r
+ if ((y>090) and (y<110)) then result := 22; exit fi;\r
+ fi;\r
+ if ((x>410) and (x<430))\r
+ then if ((y>290) and (y<310)) then result := 3; exit fi;\r
+ if ((y>190) and (y<210)) then result := 13; exit fi;\r
+ if ((y>090) and (y<110)) then result := 23; exit fi;\r
+ fi;\r
+ if ((x>160) and (x<180))\r
+ then if ((y>250) and (y<270)) then result := 4; exit fi;\r
+ if ((y>150) and (y<170)) then result := 14; exit fi;\r
+ if ((y>050) and (y<070)) then result := 24; exit fi;\r
+ fi;\r
+ if ((x>310) and (x<330))\r
+ then if ((y>250) and (y<270)) then result := 5; exit fi;\r
+ if ((y>150) and (y<170)) then result := 15; exit fi;\r
+ if ((y>050) and (y<070)) then result := 25; exit fi;\r
+ fi;\r
+ if ((x>460) and (x<480))\r
+ then if ((y>250) and (y<270)) then result := 6; exit fi;\r
+ if ((y>150) and (y<170)) then result := 16; exit fi;\r
+ if ((y>050) and (y<070)) then result := 26; exit fi;\r
+ fi;\r
+ if ((x>210) and (x<230))\r
+ then if ((y>210) and (y<230)) then result := 7; exit fi;\r
+ if ((y>110) and (y<130)) then result := 17; exit fi;\r
+ if ((y>010) and (y<030)) then result := 27; exit fi;\r
+ fi;\r
+ if ((x>360) and (x<380))\r
+ then if ((y>210) and (y<230)) then result := 8; exit fi;\r
+ if ((y>110) and (y<130)) then result := 18; exit fi;\r
+ if ((y>010) and (y<030)) then result := 28; exit fi;\r
+ fi;\r
+ if ((x>510) and (x<530))\r
+ then if ((y>210) and (y<230)) then result := 9; exit fi;\r
+ if ((y>110) and (y<130)) then result := 19; exit fi;\r
+ if ((y>010) and (y<030)) then result := 29; exit fi;\r
+ fi;\r
+ fi\r
+ od;\r
+ call hidecursor;\r
+ end\r
+ end mousepos;\r
+\r
+(* STRUCTURE DEFINISSANT 3 CASES (BOX) ALIGNEES DANS LE CUBE *)\r
+\r
+ UNIT LIGNE : class(tab_nb : arrayof integer);\r
+ var suiv, pred : ligne,\r
+ occur : arrayof box,\r
+ i : integer;\r
+ \r
+ UNIT box : class(nb : integer);\r
+ var no : integer,\r
+ flag : boolean;\r
+ begin\r
+ no := nb;\r
+ flag := false\r
+ end box;\r
+ \r
+ begin\r
+ array occur dim(1:3);\r
+ for i := 1 to 3 do occur(i) := new box(tab_nb(i)) od\r
+ end ligne;\r
+ \r
+(* LISTE DOUBLEMENT CHAINEE : POSSIBILITES D'UN JOUEUR *)\r
+\r
+ UNIT POSS : class;\r
+ var tactik,fin : ligne;\r
+ \r
+ UNIT VIDE : function : boolean;\r
+ begin\r
+ result := tactik = NONE\r
+ end vide;\r
+ \r
+ UNIT DELPOSS : procedure;\r
+ begin\r
+ do\r
+ if vide then exit fi;\r
+ call supprimer(tactik);\r
+ od\r
+ end delposs;\r
+ \r
+ UNIT SUPPRIMER : procedure(e : ligne);\r
+ var aux : ligne;\r
+ begin\r
+ if e=tactik\r
+ then\r
+ tactik:=tactik.suiv;\r
+ kill(e);\r
+ exit\r
+ else\r
+ if e=fin\r
+ then\r
+ fin := fin.pred;\r
+ kill(e);\r
+ exit\r
+ else\r
+ fi\r
+ fi;\r
+ aux := tactik.suiv;\r
+ do\r
+ if aux=e\r
+ then\r
+ aux.pred.suiv := aux.suiv;\r
+ aux.suiv.pred := aux.pred;\r
+ kill(aux);\r
+ exit\r
+ else\r
+ aux := aux.suiv\r
+ fi\r
+ od\r
+ end supprimer;\r
+ \r
+ UNIT AJOUTER : procedure(e : ligne);\r
+ var i : integer;\r
+ begin\r
+ if vide then tactik,fin := e\r
+ else fin.suiv := e;\r
+ e.pred := fin;\r
+ fin := e\r
+ fi\r
+ end ajouter;\r
+ end poss;\r
+ \r
+ UNIT ELEMENT : class;\r
+ var tab : arrayof integer,\r
+ suivant : element;\r
+ begin\r
+ array tab dim(1:3)\r
+ end element;\r
+\r
+(* PILE D'ELEMENTS : LISTE DE TOUTES LES SOLUTIONS POUR UNE CASE DONNEE *)\r
+\r
+ UNIT PILE : class;\r
+ var tete : element;\r
+ \r
+ UNIT PILEVIDE : function : boolean;\r
+ begin\r
+ result := tete = NONE\r
+ end pilevide;\r
+ \r
+ UNIT EMPILER : procedure(e : element);\r
+ begin\r
+ if not pilevide then e.suivant := tete fi;\r
+ tete := e\r
+ end empiler;\r
+ \r
+ UNIT DEPILER : function : element;\r
+ var aux : element;\r
+ begin\r
+ result := tete;\r
+ if not pilevide then tete := tete.suivant fi\r
+ end depiler;\r
+ \r
+ UNIT DELPILE : procedure;\r
+ var aux : element;\r
+ begin\r
+ do if pilevide then exit fi;\r
+ aux := tete;\r
+ tete := tete.suivant;\r
+ kill(aux)\r
+ od\r
+ end delpile;\r
+ end pile;\r
+\r
+(* LISTE DE NUMEROS DE CASE A NE PAS JOUER *)\r
+\r
+ UNIT LISTE : class;\r
+ var tete, queue : numero;\r
+ \r
+ UNIT NUMERO : class(val : integer);\r
+ var next : numero;\r
+ end numero;\r
+ \r
+ UNIT LISTEVIDE : function : boolean;\r
+ begin\r
+ if tete = NONE then result := true fi\r
+ end listevide;\r
+ \r
+ UNIT AJOUT : procedure(e : integer);\r
+ var aux : numero;\r
+ begin\r
+ if listevide then tete, queue := new numero(e)\r
+ else aux := new numero(e);\r
+ queue.next := aux;\r
+ queue := aux\r
+ fi\r
+ end ajout;\r
+ \r
+ UNIT MEMBER : function(e : integer) : boolean;\r
+ var aux : numero;\r
+ begin\r
+ if listevide then exit fi;\r
+ aux := tete;\r
+ do if aux = NONE then exit fi;\r
+ if aux.val = e then result := true;\r
+ exit\r
+ else aux := aux.next\r
+ fi\r
+ od\r
+ end member;\r
+ \r
+ UNIT DELLISTE : procedure;\r
+ var aux : numero;\r
+ begin\r
+ do if listevide then exit fi;\r
+ aux := tete.next;\r
+ kill(tete);\r
+ tete := aux\r
+ od\r
+ end delliste;\r
+ end liste;\r
+\r
+(* INITIALISATION DU CUBE MATERIALISE PAR UN TABLEAU A TROIS DIMENSIONS *)\r
+\r
+ UNIT M3D : class;\r
+ var i, j, k : integer,\r
+ chape : arrayof arrayof arrayof integer;\r
+ \r
+ begin\r
+ array chape dim (1:3);\r
+ for i := 1 to 3\r
+ do\r
+ array chape(i) dim (1:3)\r
+ od;\r
+ for j := 1 to 3\r
+ do\r
+ for k := 1 to 3\r
+ do\r
+ array chape(j,k) dim (1:3)\r
+ od\r
+ od\r
+ end M3D;\r
+ \r
+(* TRANSFORME UN ENTIER X (0 < X < 28) EN COORDONNEES DU CUBE I,J,K *)\r
+ UNIT INT_COORD : procedure (val : integer; output i, j, k : integer);\r
+ begin\r
+ k := (val div 10)+1;\r
+ i := (((val mod 10)-1) div 3)+1;\r
+ j := (((val mod 10)-1) mod 3)+1;\r
+ end int_coord;\r
+\r
+(* MISE A JOUR DU TABLEAU DES COUPS OPTIMUMS *)\r
+\r
+ UNIT MAJTOP : procedure(topcoup : arrayof integer);\r
+ var i : integer,\r
+ lig : ligne;\r
+ begin\r
+ for i := 1 to 29 do topcoup(i) := 0 od;\r
+ lig := jeu1.tactik;\r
+ do\r
+ if lig = NONE then exit fi;\r
+ for i := 1 to 3\r
+ do\r
+ if (not(lig.occur(i).flag) and (MDJ.disponible(lig.occur(i).no)))\r
+ then topcoup(lig.occur(i).no) := topcoup(lig.occur(i).no) + 1\r
+ fi\r
+ od;\r
+ lig := lig.suiv\r
+ od\r
+ end MAJTOP;\r
+\r
+(* MISE A JOUR DES LISTES DOUBLEMENT CHAINEES EN FONCTION DU COUPS JOUE *)\r
+\r
+ UNIT MAJJEU : procedure (poss1 : poss);\r
+ var poss2 : poss,\r
+ sol : element,\r
+ lig, nouv : ligne,\r
+ i, pasbon : integer,\r
+ identique, good : boolean;\r
+ begin\r
+ if MDJ.premier then pasbon := 2;\r
+ poss2 := jeu2;\r
+ else pasbon := 1;\r
+ poss2 := jeu1\r
+ fi;\r
+ do\r
+ if pile_sol.pilevide then exit fi;\r
+ sol := pile_sol.depiler;\r
+ lig := poss1.tactik;\r
+ do\r
+ if lig = NONE then exit fi;\r
+ identique := true;\r
+ for i := 1 to 3\r
+ do if lig.occur(i).no = clic then lig.occur(i).flag := true fi;\r
+ if lig.occur(i).no <> sol.tab(i)\r
+ then identique := false\r
+ fi\r
+ od;\r
+ if identique then exit fi;\r
+ lig := lig.suiv;\r
+ od;\r
+ if not identique\r
+ then\r
+ good := true;\r
+ for i := 1 to 3\r
+ do\r
+ if MDJ.joue(sol.tab(i)) = pasbon\r
+ then\r
+ good := false;\r
+ exit\r
+ fi\r
+ od;\r
+ if good then\r
+ nouv := new ligne(sol.tab);\r
+ call poss1.ajouter(nouv);\r
+ for i := 1 to 3\r
+ do if ((MDJ.joue(poss1.fin.occur(i).no) <> 0) or\r
+ (poss1.fin.occur(i).no = clic))\r
+ then poss1.fin.occur(i).flag := true\r
+ fi\r
+ od\r
+ fi\r
+ fi\r
+ od;\r
+ lig := poss2.tactik;\r
+ do\r
+ if lig = NONE then exit fi;\r
+ for i := 1 to 3\r
+ do if lig.occur(i).no = clic\r
+ then\r
+ nouv := lig.suiv;\r
+ call poss2.supprimer(lig);\r
+ exit\r
+ else nouv := lig.suiv\r
+ fi\r
+ od;\r
+ lig := nouv;\r
+ od;\r
+ end majjeu;\r
+\r
+ UNIT ERREURCLIC : procedure;\r
+ begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call hpage(1,1,1);\r
+ call move(125,90);\r
+ call color(12);\r
+ call outstring("Cher utilisateur,");\r
+ call move (100,100);\r
+ call outstring("Vous ne pouvez jouer que sur des cases marrons !");\r
+ call move(400,340);\r
+ call color(14);\r
+ call outstring("< Appuyez sur une touche >");\r
+ i := 0;\r
+ pref mouse block\r
+ begin\r
+ do\r
+ if driver then\r
+ call getpress(0,xm,ym,b,l,r,c);\r
+ if l then l := false;\r
+ call setposition(xm+20,ym+20);\r
+ exit fi;\r
+ fi;\r
+ i:=inkey;\r
+ if i<>0 then exit fi\r
+ od\r
+ end;\r
+ call hpage(0,1,0);\r
+ end\r
+ end erreurclic;\r
+\r
+(* LE MAITRE DU JEU *)\r
+\r
+ UNIT ARBITRE : class;\r
+\r
+(* DESSINE LE CUBE EN MODE GRAPHIQUE *)\r
+ UNIT INIT_AFFCUBE : procedure;\r
+ var i, j , k, x, y, couleur : integer;\r
+ begin\r
+ pref iiuwgraph block\r
+ begin\r
+ x := 120; y := 300;\r
+ call color(9);\r
+ call move(x,y);\r
+ call draw(x,y-200); call draw(x+300,y-200);\r
+ call draw(x+300,y); call draw(x,y);\r
+ y := y-200; call move(x,y);\r
+ call draw(x+100,y-75); call draw(x+400,y-75); call draw(x+300,y);\r
+ call move(x+400,y-75);\r
+ call draw(x+400,y+125); call draw(x+300,y+200);\r
+ y := y+200; call move(x+350,y-37);\r
+ call draw(x+350,y-237); call draw(x+50,y-237);\r
+ call move(x+150,y);\r
+ call draw(x+150,y-200); call draw(x+250,y-275);\r
+ call move(x,y-100);\r
+ call draw(x+300,y-100); call draw(x+400,y-175);\r
+ call style(5); call move(x,y);\r
+ call draw(x+100,y-75); call draw(x+100,y-275);\r
+ call move(x+100,y-75); call draw(x+400,y-75);\r
+ call move(x+350,y-37);\r
+ call draw(x+50,y-37); call draw(x+50,y-237);\r
+ call move(x+150,y);\r
+ call draw(x+250,y-75); call draw(x+250,y-275);\r
+ call move(x,y-100);\r
+ call draw(x+100,y-175); call draw(x+400,y-175);\r
+ call move(x+200,y-37); call draw(x+200,y-237);\r
+ call move(x+50,y-137); call draw(x+350,y-137);\r
+ call move(x+150,y-100); call draw(x+250,y-175);\r
+ call style(1);\r
+ call color(6);\r
+ couleur := 6;\r
+ for k := 1 to 3\r
+ do if k > 1 then call color(15); couleur := 15 fi;\r
+ for j := 1 to 3\r
+ do for i := 1 to 3\r
+ do x := 120+(j-1)*150+(i-1)*50;\r
+ y := 300-((k-1)*100+(i-1)*37);\r
+ call cirb(x, y, 3, 0.0, 0.0, couleur, couleur, 1, 1);\r
+ od\r
+ od\r
+ od\r
+ end\r
+ end init_affcube;\r
+\r
+(* AFFICHE SUR LE CUBE L'ENDROIT OU A ETE JOUE LE COUPS *)\r
+ UNIT AFFCOUPS : procedure(i,j,k : integer);\r
+ var x, y : integer;\r
+ begin\r
+ pref iiuwgraph block\r
+ begin\r
+ x := 120+(j-1)*150+(i-1)*50;\r
+ y := 300-((k-1)*100+(i-1)*37);\r
+ x := x-3; y := y-4;\r
+ call move(x,y);\r
+ if MDJ.premier then call color(12)\r
+ else call color(10)\r
+ fi;\r
+ call outstring("Û");\r
+ call move(x-5,y-3);\r
+ call draw(x+12,y-3); call draw(x+12,y+10);\r
+ call draw(x-5,y+10); call draw(x-5,y-3);\r
+ call color(15);\r
+ end\r
+ end affcoups;\r
+ \r
+(* INITIALISATION DES 13 FACES CONTENUES DANS LE CUBE :\r
+ ASSOCIATION DE 9 NUMEROS DE CASES POUR CHACUNE D'ELLES *)\r
+\r
+ UNIT INIT_FACES : procedure;\r
+ var i, j, k, t : integer;\r
+ begin\r
+ array face dim(1:13);\r
+ for i:= 1 to 13\r
+ do array face(i) dim(1:9)\r
+ od;\r
+ for i := 1 to 9\r
+ do face (1,i) := i;\r
+ face (2,i) := i+10;\r
+ face (3,i) := i+20;\r
+ face (12,i) := 3*i;\r
+ od;\r
+ for i := 1 to 3\r
+ do for j := 1 to 3\r
+ do face (3+i, j) := i+3*(j-1);\r
+ face (3+i,j+3) := i+10+3*(j-1);\r
+ face (3+i,j+6) := i+20+3*(j-1);\r
+ od;\r
+ od;\r
+ k := 1;\r
+ for t := 1 to 3\r
+ do for i := 7 to 9\r
+ do for j := 1 to 3\r
+ do face (i,j+3*(t-1)) := k;\r
+ k := k+1;\r
+ od;\r
+ od;\r
+ k := k+1;\r
+ od;\r
+ for i := 1 to 3\r
+ do face (10,i) := i;\r
+ face (10,i+3) := i+13;\r
+ face (10,i+6) := i+26;\r
+ od;\r
+ for i := 1 to 3\r
+ do face (11,i) := i+6;\r
+ face (11,i+3) := i+13;\r
+ face (11,i+6) := i+20;\r
+ od;\r
+ for i := 1 to 3\r
+ do face (13,i) := 1+3*(i-1);\r
+ face (13,i+3) := face (13,i)+11;\r
+ face (13,i+6) := face (13,i)+22;\r
+ od;\r
+ end init_faces;\r
+\r
+(* CREATION DU MASQUE POUR TROUVER TOUTES LES SOLUTIONS SELON UNE CASE *)\r
+ UNIT INIT_MASK : procedure;\r
+ var i : integer;\r
+ begin\r
+ array mask dim(1:8);\r
+ for i := 1 to 8\r
+ do array mask(i) dim(1:3) od;\r
+ for i := 1 to 3 do mask(1,i) := i od;\r
+ for i := 1 to 3 do mask(2,i) := i+3 od;\r
+ for i := 1 to 3 do mask(3,i) := i+6 od;\r
+ for i := 1 to 3 do mask(4,i) := 1+3*(i-1) od;\r
+ for i := 1 to 3 do mask(5,i) := 2+3*(i-1) od;\r
+ for i := 1 to 3 do mask(6,i) := 3+3*(i-1) od;\r
+ for i := 1 to 3 do mask(7,i) := 1+4*(i-1) od;\r
+ for i := 1 to 3 do mask(8,i) := 2*i+1 od;\r
+ end INIT_MASK;\r
+\r
+(* EMPILE TOUTES LES SOLUTIONS SELON UNE CASE CHOISIE *)\r
+ UNIT SOLUTIONS : procedure(nobox : integer);\r
+ var i, j, k, l, m,z : integer,\r
+ e : element;\r
+ begin\r
+ call pile_sol.delpile;\r
+ for i := 1 to 13\r
+ do for j := 1 to 9\r
+ do if face(i,j) = nobox\r
+ then for k := 1 to 8\r
+ do for l := 1 to 3\r
+ do if mask(k,l) = j\r
+ then\r
+ e := new element;\r
+ for m := 1 to 3\r
+ do\r
+ e.tab(m) := face(i,mask(k,m)) od;\r
+ call pile_sol.empiler(e);\r
+ fi\r
+ od\r
+ od\r
+ fi\r
+ od\r
+ od\r
+ end solutions;\r
+\r
+(* INDIQUE SI LA CASE CHOISIE PAR UN JOUEUR EST ACCESSIBLE OU NON *)\r
+ UNIT DISPONIBLE : function (choix : integer) : boolean;\r
+ var i, j, k : integer;\r
+ begin\r
+ result := false;\r
+ call int_coord(choix,i,j,k);\r
+ if dispo(i,j) = choix then result := true fi\r
+ end disponible;\r
+\r
+(* MISE A JOUR DE LA MATRICE CONTENANT TOUTES LES CASE DISPONIBLES.\r
+ CHANGEMENT DE COULEUR POUR LE PION SITUE AU DESSUS DU COUPS JOUE *)\r
+\r
+ UNIT MAJDISPO : procedure(i, j ,k : integer);\r
+ var x, y, h, c, l : integer;\r
+ begin\r
+ dispo(i,j) := dispo(i,j)+10;\r
+ pref iiuwgraph block\r
+ begin\r
+ if dispo(i,j) > 29\r
+ then dispo(i,j) := 0\r
+ else call int_coord(dispo(i,j), c, l, h);\r
+ x := 120+(l-1)*150+(c-1)*50;\r
+ y := 300-((h-1)*100+(c-1)*37);\r
+ call color(6);\r
+ call cirb(x, y, 3, 0.0, 0.0, 6, 6, 1, 1);\r
+ fi\r
+ end\r
+ end majdispo;\r
+\r
+(* RENVOIE, POUR UNE CASE DONNEE, LE NUMERO DU JOUEUR QUI A JOUE DESSUS *)\r
+ UNIT JOUE : function(endroit : integer) : integer;\r
+ var i, j, k : integer;\r
+ begin\r
+ call int_coord(endroit, i, j, k);\r
+ result := cube.chape(i,j,k)\r
+ end joue;\r
+\r
+(* MISE A JOUR DES NUMEROS DU CUBE POUR SAVOIR QUI A JOUE A QUEL ENDROIT.\r
+ POR SAVOIR SI LE CUBE EST PLEIN OU SI UN JOUEUR A GAGNE *)\r
+\r
+ UNIT MAJCUBE : function(i, j, k : integer; nojoueur : boolean) : integer;\r
+ var m, n : integer,\r
+ x, y, x1, y1, z1, x2, y2, z2 : integer,\r
+ pasfini : boolean,\r
+ poss1 : poss,\r
+ aux : ligne;\r
+ begin\r
+ result := 0;\r
+ pasfini := false;\r
+ if nojoueur then cube.chape(i, j, k) := 1;\r
+ else cube.chape(i, j, k) := 2\r
+ fi;\r
+ for m := 1 to 3\r
+ do for n := 1 to 3\r
+ do if cube.chape(m,n,3) = 0\r
+ then pasfini := true;\r
+ exit exit\r
+ fi\r
+ od\r
+ od;\r
+ if not pasfini then result := FINI fi;\r
+ if MDJ.premier then poss1 := jeu1\r
+ else poss1 := jeu2\r
+ fi;\r
+ aux := poss1.tactik;\r
+ pasfini := false;\r
+ while ((aux <> NONE) and (not pasfini))\r
+ do if (aux.occur(1).flag AND\r
+ aux.occur(2).flag AND\r
+ aux.occur(3).flag)\r
+ then pref iiuwgraph block\r
+ begin\r
+ call color(11);\r
+ call int_coord(aux.occur(1).no,x1,y1,z1);\r
+ call int_coord(aux.occur(3).no,x2,y2,z2);\r
+ x := 120+(y1-1)*150+(x1-1)*50;\r
+ y := 300-((z1-1)*100+(x1-1)*37);\r
+ call move(x,y);\r
+ x := 120+(y2-1)*150+(x2-1)*50;\r
+ y := 300-((z2-1)*100+(x2-1)*37);\r
+ call draw(x,y);\r
+ call color(15);\r
+ end;\r
+ pasfini := true;\r
+ else aux := aux.suiv\r
+ fi;\r
+ od;\r
+ if pasfini then\r
+ result := GAGNE fi;\r
+ end majcube;\r
+\r
+(* DECLARATIONS DES VARIABLES DE L'ARBITRE *)\r
+ const GAGNE = 1, FINI = 2;\r
+ var cube : M3D,\r
+ face, mask : arrayof arrayof integer,\r
+ premier : boolean,\r
+ x, y, z,\r
+ i, j,\r
+ resultat : integer,\r
+ joueur1 : strat1,\r
+ joueur2 : strat2,\r
+ joueur3 : user;\r
+\r
+\r
+(* LE MAITRE DE JEU ENGAGE LA PARTIE *)\r
+\r
+ UNIT START_GAME : procedure;\r
+ begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pile_sol := new pile;\r
+ listdef := new liste;\r
+ call init_faces;\r
+ call init_mask;\r
+ cube := new M3D;\r
+ call init_affcube;\r
+ array dispo dim(1:3);\r
+ for i := 1 to 3\r
+ do array dispo(i) dim(1:3);\r
+ for j := 1 to 3 do dispo(i,j) := i*3+j-3 od\r
+ od;\r
+ premier := true;\r
+ do\r
+ call move(100,320);\r
+ call color(4);\r
+ if nbjoueur\r
+ then call outstring("Choisissez la premi\8are case du joueur ROUGE");\r
+ else call outstring("Choisissez la premi\8are case pour l'ORDINATEUR")\r
+ fi;\r
+ joueur1 := new strat1;\r
+ if disponible(clic) then exit fi;\r
+ call erreurclic;\r
+ kill(joueur1)\r
+ od;\r
+ call int_coord(clic, x, y, z);\r
+ call solutions(clic);\r
+ i := majcube(x,y,z,premier);\r
+ call majdispo(x, y, z);\r
+ call majjeu(jeu1);\r
+ call affcoups(x,y,z);\r
+ premier := not premier;\r
+ do\r
+ call move(100,320);\r
+ if nbjoueur\r
+ then\r
+ call color(2);\r
+ call outstring("Choisissez la premi\8are case du joueur VERT ");\r
+ joueur2 := new strat2;\r
+ if disponible(clic) then exit fi;\r
+ call erreurclic;\r
+ kill(joueur2)\r
+ else\r
+ call outstring(" ");\r
+ call move(100,320);\r
+ call color(14);\r
+ call outstring("Votre choix ? ");\r
+ joueur3 := new user;\r
+ if disponible(clic) then exit fi;\r
+ call erreurclic;\r
+ kill(joueur3)\r
+ fi;\r
+ od;\r
+ call move(100,320);\r
+ call outstring(" ");\r
+ call int_coord(clic, x, y, z);\r
+ call solutions(clic);\r
+ i := majcube(x,y,z,premier);\r
+ call majdispo(x, y, z);\r
+ call majjeu(jeu2);\r
+ call affcoups(x, y, z);\r
+ premier := not premier;\r
+ do\r
+ do\r
+ if premier then attach(joueur1)\r
+ else if nbjoueur then attach(joueur2)\r
+ else attach(joueur3)\r
+ fi\r
+ fi;\r
+ if disponible(clic) then exit fi;\r
+ od;\r
+ call int_coord(clic, x, y, z);\r
+ resultat := majcube(x, y, z, premier);\r
+ call affcoups(x, y, z);\r
+ if resultat = GAGNE\r
+ then if premier then raise WIN1\r
+ else if nbjoueur then raise WIN2\r
+ else raise WIN3\r
+ fi\r
+ fi\r
+ fi;\r
+ if resultat = FINI then raise PLEIN fi;\r
+ call majdispo(x, y, z);\r
+ premier := not premier;\r
+ od;\r
+ lastwill : call move(70,340);\r
+ call color(3);\r
+ call outstring("Arbitre : Belle partie n'est-ce pas ?");\r
+ call move (410,340);\r
+ call color(14);\r
+ call outstring("< Appuyez sur une touche >");\r
+ i := 0;\r
+ pref mouse block\r
+ begin\r
+ do\r
+ if driver\r
+ then\r
+ call getpress(0,xm,ym,b,l,r,c);\r
+ if l then l := false;\r
+ call setposition(xm+20,ym+20);\r
+ exit fi\r
+ fi;\r
+ i:=inkey;\r
+ if i<>0 then exit fi\r
+ od;\r
+ if driver then call hidecursor fi\r
+ end;\r
+ call hpage(0,0,0);\r
+ end\r
+ end start_game;\r
+ end arbitre;\r
+\r
+(* STRATEGIE COMMUNE AUX DEUX JOUEURS : ATTAQUE OU DEFENSE IMMEDIATE *)\r
+ \r
+ UNIT STRATEGIE : procedure(output priorite : boolean);\r
+ var nb_flag,i : integer,\r
+ lig : ligne,\r
+ poss1, poss2 : poss;\r
+ begin\r
+ if MDJ.premier then poss1 := jeu1;\r
+ poss2 := jeu2\r
+ else poss1 := jeu2;\r
+ poss2 := jeu1\r
+ fi;\r
+ priorite := false;\r
+ lig := poss1.tactik;\r
+ do\r
+ if lig = NONE then exit fi;\r
+ nb_flag := 0;\r
+ for i:=1 to 3\r
+ do if lig.occur(i).flag then nb_flag := nb_flag+1 fi\r
+ od;\r
+ if nb_flag = 2\r
+ then for i := 1 to 3\r
+ do if not lig.occur(i).flag then exit fi\r
+ od;\r
+ if MDJ.disponible(lig.occur(i).no)\r
+ then priorite := true;\r
+ clic := lig.occur(i).no;\r
+ exit\r
+ fi\r
+ fi;\r
+ lig := lig.suiv\r
+ od;\r
+ if not priorite\r
+ then\r
+ lig := poss2.tactik;\r
+ call listdef.delliste;\r
+ do\r
+ if lig = NONE then exit fi;\r
+ nb_flag := 0;\r
+ for i:=1 to 3\r
+ do if lig.occur(i).flag then nb_flag := nb_flag+1 fi od;\r
+ if nb_flag = 2\r
+ then\r
+ for i := 1 to 3\r
+ do\r
+ if not lig.occur(i).flag then exit fi\r
+ od;\r
+ if MDJ.disponible(lig.occur(i).no)\r
+ then\r
+ priorite := true;\r
+ clic := lig.occur(i).no;\r
+ exit\r
+ else call listdef.ajout(lig.occur(i).no-10);\r
+ fi\r
+ fi;\r
+ lig := lig.suiv\r
+ od\r
+ fi\r
+ end strategie;\r
+ \r
+(* STRATEGIE D'ATTAQUE DU JOUEUR 1 *)\r
+\r
+ UNIT STRAT1 : coroutine;\r
+ var trouve,priorite : boolean,\r
+ i, j, k, max, imax, min : integer;\r
+ \r
+ begin\r
+ pref mouse block\r
+ begin\r
+ if driver then clic := mousepos\r
+ else read(clic)\r
+ fi\r
+ end;\r
+ return;\r
+ do\r
+ call strategie(priorite);\r
+ if not priorite then\r
+ call majtop(topcoups1);\r
+ for i := 29 downto 1\r
+ do if ((topcoups1(i) > max) and (not listdef.member(i)))\r
+ then\r
+ max := topcoups1(i);\r
+ imax := i;\r
+ trouve := true;\r
+ fi;\r
+ od;\r
+ if trouve\r
+ then clic := imax\r
+ else min := 30;\r
+ for i := 1 to 3\r
+ do for j := 1 to 3\r
+ do\r
+ if ((dispo(i,j) < min) and (dispo(i,j) > 0))\r
+ then min := dispo(i,j)\r
+ fi\r
+ od\r
+ od;\r
+ clic := min\r
+ fi\r
+ fi;\r
+ call MDJ.solutions(clic);\r
+ call majjeu(jeu1);\r
+ call int_coord(clic, i, j, k);\r
+ max := MDJ.majcube(i, j, k, MDJ.premier);\r
+ detach\r
+ od\r
+ end strat1;\r
+\r
+(* STRATEGIE DE DEFENSE DU JOUEUR 2 *)\r
+\r
+ UNIT STRAT2 : coroutine;\r
+ var trouve, priorite : boolean,\r
+ i, j, k, max, imax : integer;\r
+ \r
+ begin\r
+ pref mouse block\r
+ begin\r
+ if driver then clic := mousepos\r
+ else read(clic)\r
+ fi\r
+ end;\r
+ return;\r
+ do\r
+ call strategie(priorite);\r
+ if not priorite then\r
+ call majtop(topcoups1);\r
+ for i := 29 downto 1\r
+ do if ((topcoups1(i) > max) and (not listdef.member(i)))\r
+ then\r
+ max := topcoups1(i);\r
+ imax := i;\r
+ trouve := true\r
+ fi;\r
+ od;\r
+ if trouve\r
+ then clic := imax\r
+ else max := 1;\r
+ for i := 1 to 3\r
+ do for j := 1 to 3\r
+ do\r
+ if dispo(i,j) > max\r
+ then max := dispo(i,j)\r
+ fi\r
+ od\r
+ od;\r
+ clic := max\r
+ fi\r
+ fi;\r
+ call MDJ.solutions(clic);\r
+ call majjeu(jeu2);\r
+ call int_coord(clic, i, j, k);\r
+ max := MDJ.majcube(i, j, k, MDJ.premier);\r
+ detach\r
+ od\r
+ end strat2;\r
+ \r
+(* CAS OU L'UTILISATEUR EST LE JOUEUR 2 *)\r
+\r
+ UNIT USER : coroutine;\r
+ var i, j, k, max : integer;\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ if driver then clic := mousepos\r
+ else read(clic)\r
+ fi\r
+ end;\r
+ return;\r
+ pref iiuwgraph block\r
+ begin\r
+ do\r
+ call move(100,320);\r
+ call outstring(" ");\r
+ call move(100,320);\r
+ call color(14);\r
+ call outstring("Votre choix ? ");\r
+ do\r
+ pref mouse block\r
+ begin\r
+ if driver then clic := mousepos\r
+ else read(clic)\r
+ fi\r
+ end;\r
+ if MDJ.disponible(clic) then exit fi;\r
+ call erreurclic;\r
+ od;\r
+ call move(100,320);\r
+ call outstring(" ");\r
+ call MDJ.solutions(clic);\r
+ call majjeu(jeu2);\r
+ call int_coord(clic, i, j, k);\r
+ max := MDJ.majcube(i, j, k, MDJ.premier);\r
+ detach\r
+ od\r
+ end\r
+ end user;\r
+\r
+(* DECLARATIONS DES VARIABLES DU PROGRAMME PRINCIPAL *)\r
+ var dispo : arrayof arrayof integer,\r
+ jeu1, jeu2 : poss,\r
+ topcoups1,\r
+ topcoups2 : arrayof integer,\r
+ MDJ : arbitre,\r
+ pile_sol : pile,\r
+ listdef : liste,\r
+ clic, i, b,\r
+ xm, ym : integer,\r
+ nbjoueur,\r
+ driver, a, l, r, c : boolean;\r
+\r
+(* TRAITEMENT DES SIGNAUX *)\r
+ handlers\r
+ when WIN1 : pref iiuwgraph block\r
+ begin\r
+ call move(100,325);\r
+ call color(4);\r
+ call outstring("MA STRATEGIE D'ATTAQUE ETAIT IMPARABLE !");\r
+ call color(15);\r
+ end;\r
+ wind;\r
+ when WIN2 : pref iiuwgraph block\r
+ begin\r
+ call move(100,325);\r
+ call color(10);\r
+ call outstring("MA DEFENSE M'A MEME EMMENE A LA VICTOIRE !!!! ");\r
+ call color(15);\r
+ end;\r
+ wind;\r
+ when WIN3 : pref iiuwgraph block\r
+ begin\r
+ call move(80,325);\r
+ call color(13);\r
+ call outstring\r
+ ("Bravo, vous venez de gagner contre un professionnel !!!! ");\r
+ call color(15);\r
+ end;\r
+ wind;\r
+ when PLEIN : pref iiuwgraph block\r
+ begin\r
+ call move(100,325);\r
+ call color(15);\r
+ call outstring("Le cube est plein, aucun joueur n'a gagn\82");\r
+ end;\r
+ wind;\r
+ end handlers;\r
+ \r
+begin (* MAIN *)\r
+ write(chr(27),"[2J");\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ call gron(5);\r
+ driver := init(b);\r
+ call init_graph;\r
+ call move (210,150);\r
+ call color(3);\r
+ call outstring("M O R P I O N 3 D");\r
+ call move(20,250);\r
+ call color(13);\r
+ call outstring("Voulez-vous jouer avec l'ordinateur (o/n) ?");\r
+ b := inchar;\r
+ if b = 111 then nbjoueur := false;\r
+ call color(2);\r
+ call move(20,270);\r
+ call outstring("Vous \88tes le joueur VERT.");\r
+ call move(360,340);\r
+ call color(14);\r
+ call outstring("< Appuyez sur une touche >");\r
+ b := 0;\r
+ do if driver\r
+ then\r
+ call getpress(0,xm,ym,b,l,r,c);\r
+ if l then l := false;\r
+ call setposition(xm+20,ym+20);\r
+ exit fi\r
+ fi;\r
+ b:=inkey;\r
+ if b<>0 then exit fi\r
+ od;\r
+ else nbjoueur := true\r
+ fi;\r
+ call init_graph;\r
+ jeu1 := new poss;\r
+ jeu2 := new poss;\r
+ array topcoups1 dim (1:29);\r
+ array topcoups2 dim (1:29);\r
+ mdj := new arbitre;\r
+ call mdj.start_game;\r
+end\r
+end\r
+end P3D.\r
--- /dev/null
+BLOCK\r
+ UNIT BACKTRACK: CLASS;\r
+ HIDDEN SE,ELEM,TOP;\r
+ VAR ROOT:NODE,SEARCH:SE,FOUND,OPT:NODE,\r
+ NUMBER_OF_NODES,NUMBER_OF_LEAVES,NUMBER_OF_ANSWERS:INTEGER;\r
+ \r
+ UNIT NODE: COROUTINE(FATHER:NODE);\r
+ VAR NSONS,LEVEL: INTEGER , DEADEND:BOOLEAN;\r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ END LEAF;\r
+ UNIT VIRTUAL ANSWER :FUNCTION :BOOLEAN;\r
+ END ANSWER;\r
+ UNIT VIRTUAL LASTSON: FUNCTION : BOOLEAN;\r
+ END LASTSON;\r
+ UNIT VIRTUAL NEXTSON: FUNCTION : NODE;\r
+ END NEXTSON;\r
+ UNIT VIRTUAL EQUAL : FUNCTION (W:NODE):BOOLEAN;\r
+ END EQUAL;\r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ END COST;\r
+ BEGIN\r
+ IF FATHER =/= NONE\r
+ THEN\r
+ LEVEL:=FATHER.LEVEL+1\r
+ ELSE\r
+ LEVEL:=0\r
+ FI;\r
+ END NODE;\r
+ \r
+ UNIT OK: FUNCTION (V:NODE):BOOLEAN;\r
+ VAR W:NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RESULT:=FALSE; RETURN FI;\r
+ RESULT:=TRUE; W:=V.FATHER;\r
+ WHILE W =/= NONE\r
+ DO\r
+ IF V.EQUAL(W) THEN RESULT:=FALSE; RETURN FI;\r
+ W:=W.FATHER\r
+ OD\r
+ END OK;\r
+ \r
+ UNIT PURGE: PROCEDURE (V:NODE);\r
+ VAR W: NODE;\r
+ BEGIN\r
+ IF V=NONE THEN RETURN FI;\r
+ DO\r
+ W:=V.FATHER; KILL(V);\r
+ IF W=NONE THEN RETURN FI;\r
+ W.NSONS:=W.NSONS-1;\r
+ IF W.NSONS =/= 0 THEN RETURN FI;\r
+ V:=W\r
+ OD;\r
+ END PURGE;\r
+\r
+ VAR TOP:ELEM;\r
+\r
+ UNIT ELEM: CLASS (NEXT:ELEM, V:NODE);\r
+ END ELEM;\r
+ \r
+ UNIT VIRTUAL INSERT: PROCEDURE(V:NODE);\r
+ BEGIN\r
+ TOP:=NEW ELEM(TOP,V); \r
+ END INSERT;\r
+ \r
+ UNIT VIRTUAL DELETE: FUNCTION :NODE;\r
+ VAR E:ELEM;\r
+ BEGIN\r
+ IF TOP =/= NONE\r
+ THEN\r
+ RESULT:=TOP.V; \r
+ E:=TOP; TOP:=TOP.NEXT; KILL(E);\r
+ FI; \r
+ END DELETE;\r
+ \r
+ UNIT SE: COROUTINE ;\r
+ VAR I:INTEGER,V,W:NODE;\r
+ BEGIN\r
+ RETURN; CALL INSERT(ROOT);\r
+ DO\r
+ V:=DELETE; \r
+ IF V=NONE THEN EXIT FI;\r
+ ATTACH(V); \r
+ IF V.ANSWER\r
+ THEN\r
+ NUMBER_OF_ANSWERS:=NUMBER_OF_ANSWERS+1;\r
+ FOUND:=V;\r
+ IF OPT=NONE ORIF V.COST < OPT.COST\r
+ THEN\r
+ OPT:=V\r
+ FI;\r
+ DETACH;\r
+ (* HERE THE USER OF BACKTRACK MAY UNDERTAKE SOME ACTIONS\r
+ ON THE ANSWER NODES. IF NOT NECESSARY DO ATTACH *) \r
+ ELSE\r
+ IF V.DEADEND\r
+ THEN\r
+ NUMBER_OF_LEAVES:=NUMBER_OF_LEAVES+1;\r
+ CALL PURGE(V);\r
+ ELSE\r
+ DO\r
+ W:=V.NEXTSON; V.NSONS:=V.NSONS+1;\r
+ NUMBER_OF_NODES:=NUMBER_OF_NODES+1; \r
+ IF OK(W)\r
+ THEN \r
+ W.DEADEND:=W.LEAF; CALL INSERT(W);\r
+ FI;\r
+ IF V.LASTSON THEN EXIT FI; \r
+ OD;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ FOUND:=NONE;\r
+ END SE;\r
+ \r
+ \r
+ UNIT KILLALL :PROCEDURE;\r
+ VAR V:NODE;\r
+ BEGIN\r
+ DO\r
+ V:=DELETE;\r
+ IF V=NONE THEN RETURN FI;\r
+ CALL PURGE(V);\r
+ OD;\r
+ END KILLALL;\r
+\r
+ BEGIN\r
+ SEARCH:=NEW SE;\r
+ INNER;\r
+ KILL(SEARCH); CALL KILLALL;\r
+ END BACKTRACK;\r
+ \r
+ \r
+ VAR N,M,I,J:INTEGER,H1,H2,H3:CHAR;\r
+ VAR INC: ARRAYOF ARRAYOF BOOLEAN; \r
+ BEGIN \r
+ DO\r
+ WRITE(" NUMBER OF VERTICES= ");\r
+ READLN(N);\r
+ IF N=0 THEN EXIT FI;\r
+ WRITE(" NUMBER OF COLOURS= ");\r
+ READLN(M);\r
+ ARRAY INC DIM (1:N);\r
+ FOR I:=1 TO N DO ARRAY INC(I) DIM (1:I); OD;\r
+ WRITELN(" GIVE A GRAPH BY DEFINING SUCCESSIVE EDGES");\r
+ WRITELN(" TO END A LIST WRITE 0");\r
+ FOR I:=1 TO N\r
+ DO\r
+ WRITELN(" VERTEX ",I:3," IS INCIDENT WITH VERTICES=");\r
+ DO\r
+ READ(J);\r
+ IF J>1 AND J<=N THEN INC(J,I):=TRUE ELSE EXIT FI;\r
+ OD;\r
+ WRITELN(" END OF EDGES WITH VERTEX", I:3)\r
+ OD;\r
+ WRITELN(" GRAPH HAS THE FOLLOWING INCIDENCE MATRIX");\r
+ FOR I:=1 TO N\r
+ DO\r
+ FOR J:=1 TO I\r
+ DO\r
+ IF INC(I,J) THEN WRITE(1:2) ELSE WRITE(0:2) FI;\r
+ OD;\r
+ WRITELN;\r
+ OD; \r
+ PREF BACKTRACK BLOCK\r
+ VAR K:INTEGER;\r
+ UNIT STATE: NODE CLASS(I,J,NC:INTEGER);\r
+ \r
+ (*I- VERTEX, J-COLOUR, NC-NUMBER OF COLOURS *)\r
+\r
+ UNIT VIRTUAL ANSWER: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= I=N AND OKGO(THIS STATE)\r
+ END ANSWER;\r
+ \r
+ UNIT VIRTUAL LEAF: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:=I=N OR NOT OKGO(THIS STATE)\r
+ END LEAF;\r
+ \r
+ UNIT OKGO: FUNCTION(V:STATE) : BOOLEAN;\r
+ VAR I,J:INTEGER;\r
+ BEGIN\r
+ I:=V.I; J:=V.J;\r
+ DO\r
+ V:=V.FATHER;\r
+ IF V=NONE THEN RESULT:=TRUE; EXIT FI;\r
+ IF V.J=J AND INC(I,V.I) THEN EXIT FI;\r
+ OD;\r
+ END OKGO;\r
+\r
+ \r
+ UNIT VIRTUAL LASTSON: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ IF K=M\r
+ THEN\r
+ RESULT:=TRUE;\r
+ K:=0;\r
+ FI; \r
+ END LASTSON;\r
+ \r
+ UNIT VIRTUAL NEXTSON : FUNCTION :STATE;\r
+ VAR V:STATE,NCK:INTEGER;\r
+ BEGIN\r
+ V:=THIS STATE;\r
+ K:=K+1;\r
+ NCK:=NC;\r
+ DO\r
+ IF V=NONE THEN NCK:=NCK+1; EXIT FI;\r
+ IF V.J=K THEN EXIT FI;\r
+ V:=V.FATHER;\r
+ OD; \r
+ RESULT:=NEW STATE(THIS STATE,I+1,K,NCK);\r
+ END NEXTSON;\r
+\r
+ UNIT VIRTUAL EQUAL: FUNCTION(S:STATE):BOOLEAN;\r
+ BEGIN\r
+ RESULT:=I=S.I AND J=S.J\r
+ END EQUAL;\r
+ \r
+ UNIT VIRTUAL COST: FUNCTION :REAL;\r
+ BEGIN\r
+ RESULT:=NC\r
+ END COST;\r
+ \r
+ \r
+ BEGIN\r
+ RETURN;\r
+ DO\r
+ DETACH \r
+ OD;\r
+ END STATE;\r
+\r
+ \r
+ UNIT DISPLAY: PROCEDURE(V:STATE);\r
+ BEGIN\r
+ IF V=NONE THEN WRITELN(" NO SOLUTIONS"); RETURN FI;\r
+ WRITELN("VERTEX COLOUR");\r
+ DO\r
+ WRITE(V.I); WRITE(" "); WRITELN(V.J);\r
+ V:=V.FATHER;\r
+ IF V=NONE THEN EXIT FI \r
+ OD;\r
+ WRITELN;\r
+ END DISPLAY;\r
+ \r
+ BEGIN\r
+ READLN;\r
+ ROOT:=NEW STATE(NONE,1,1,1); \r
+ WRITE("DO YOU WANT TO OPTIMIZE ");\r
+ WRITELN("OR TO PRINT ALL THE SOLUTIONS ?");\r
+ WRITELN(" (ANSWER OPT OR ALL)");\r
+ READLN(H1,H2,H3);\r
+ IF H1='O' AND H2='P' AND H3='T'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ IF OPT =/= NONE ANDIF OPT.COST<FOUND.COST\r
+ THEN\r
+ EXIT\r
+ FI; \r
+ OD;\r
+ IF OPT =/= NONE\r
+ THEN\r
+ CALL DISPLAY(OPT);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ ELSE\r
+ WRITELN("NO SOLUTIONS");\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ FI;\r
+ ELSE \r
+ IF H1='A' AND H2='L' AND H3='L'\r
+ THEN\r
+ DO\r
+ ATTACH(SEARCH); \r
+ CALL DISPLAY(FOUND);\r
+ WRITELN("NUMBER OF NODES=",NUMBER_OF_NODES);\r
+ WRITELN("NUMBER OF LEAVES=",NUMBER_OF_LEAVES);\r
+ WRITELN("NUMBER OF ANSWERS=",NUMBER_OF_ANSWERS);\r
+ IF FOUND=NONE THEN EXIT FI;\r
+ WRITELN("DO YOU WANT TO CONTINUE?");\r
+ READ(H1,H2);\r
+ IF H1=/='Y' ORIF H2=/='E' THEN EXIT FI;\r
+ READLN(H3);\r
+ IF H3=/='S' THEN EXIT FI;\r
+ OD;\r
+ FI\r
+ FI;\r
+ END;\r
+ OD;\r
+\r
+ \r
+ \r
+ END; \r
+ \r
+END\r
+\r
+ \r
--- /dev/null
+program belote;\r
+\r
+(* \r
+ ************************************************************************\r
+ * *\r
+ * TP LI1 : Mai 1995 *\r
+ * *\r
+ * Co-auteurs : R\82gis BRETTE *\r
+ * Jean-Yves LAGARDE * \r
+ * *\r
+ * SUJET : A partir du langage LOGLAN, r\82aliser *\r
+ * une application utilisant les coroutines. *\r
+ * *\r
+ * MACHINE : DOS 386, Systeme LOGLAN-82 *\r
+ * Version de classe graphisme : IIUWgraph *\r
+ * Ecran : 640 X 480 * \r
+ * *\r
+ * REALISATION : Cette application permet de simuler un * \r
+ * jeu de cartes : la belote. Les diff\82rents *\r
+ * joueurs sont simul\82s par des coroutines. *\r
+ * *\r
+ * MODE D'EMPLOI : On clique \85 la souris avec le bouton gauche* \r
+ * sur les boutons pr\82sents \85 l'\82cran. *\r
+ * *\r
+ * * \r
+ * * \r
+ * *\r
+ * *\r
+ ************************************************************************\r
+\r
+*)\r
+\r
+\r
+CONST\r
+ noir =0,\r
+ bleu =1,\r
+ vert =2,\r
+ cyan =3,\r
+ rouge =4,\r
+ magenta =5,\r
+ marron =6,\r
+ gris_clair =7,\r
+ gris_fonce =8,\r
+ bleu_clair =9,\r
+ vert_clair =10,\r
+ cyan_clair =11,\r
+ rouge_clair =12,\r
+ magenta_clair =13,\r
+ jaune =14,\r
+ blanc =15,\r
+ vide =0,\r
+ plein =1,\r
+ \r
+ larg_caract = 8,\r
+ haut_caract = 8,\r
+\r
+ nb_pli = 8,\r
+ defaut = 500,\r
+\r
+ sept = 1,\r
+ huit = 2,\r
+ neuf = 3,\r
+ valet = 4,\r
+ dame = 5,\r
+ roi = 6,\r
+ dix = 7,\r
+ as = 8,\r
+\r
+ P = 1,\r
+ T = 2,\r
+ CA = 3,\r
+ CO = 4;\r
+\r
+Begin \r
+Pref iiuwgraph block (* fonctions graphiques *)\r
+Begin\r
+Pref mouse block (* souris *)\r
+\r
+ var \r
+ P1,P2,P3,P4,P5,P6,P7,P8,T1,T2,T3,T4,T5,T6,T7,T8 : carte,\r
+ CA1,CA2,CA3,CA4,CA5,CA6,CA7,CA8,CO1,CO2,CO3,CO4,\r
+ CO5,CO6,CO7,CO8 : carte,\r
+ carte_ret,carte_oui : carte,\r
+ atout_joue : arrayof boolean,\r
+ score1,score2,tour,atout,fin_donne1,fin_donne2 : integer,\r
+ oui,non,b_pic,b_trefle,b_carreau,b_aide_atout : bouton_relief,\r
+ b_coeur,rien,carre,b_option,b_debut,b_fin : bouton_relief,\r
+ nom : string, \r
+ image,image2,depart,save_menu : arrayof integer,\r
+ del_menu,terrain,save_joueur : arrayof integer,\r
+ he,ve,pe,le,re,ce : integer,\r
+ dede,on_prend,termine : boolean,\r
+ joueur_prend,adv1_prend,part_prend,adv2_prend : boolean,\r
+ belote_joueur,belote_adversaire1 : boolean,\r
+ belote_partenaire,belote_adversaire2 : boolean,\r
+ s,e1,e2,e11,e22 : PILE,\r
+ user : joueur,\r
+ part : partenaire,\r
+ adv1 : adversaire1,\r
+ adv2 : adversaire2,\r
+ ca_u : carte_user,\r
+ j_jeu,p_jeu,a1_jeu,a2_jeu : arrayof carte_user,\r
+ pli : arrayof carte,\r
+ tx,ty : arrayof integer,\r
+ commence,i,j,k,abscisse,ordonnee,coul,\r
+ cpt_pli,eval,attente,total,lg : integer;\r
+\r
+ (*************************************)\r
+ (* Bouton en relief *) \r
+ (*************************************) \r
+\r
+Unit BOUTON_RELIEF : class (x1,y1,x2,y2,nb_car:integer,titre:string);\r
+var selectionne : boolean; \r
+\r
+ Unit print : procedure;\r
+ begin\r
+ if not selectionne \r
+ then\r
+ call patern(x1,y1,x2,y2,gris_clair,plein);\r
+ call patern(x1,y1,x2,y2,noir,vide);\r
+ call patern(x1+1,y1+1,x1+1,y2-1,blanc,plein);\r
+ call patern(x1+2,y1+2,x1+2,y2-2,blanc,plein);\r
+ call patern(x1+1,y1+1,x2-1,y1+1,blanc,plein);\r
+ call patern(x1+2,y1+2,x2-2,y1+2,blanc,plein);\r
+ call patern(x2-1,y1+1,x2-1,y2-1,gris_fonce,plein);\r
+ call patern(x2-2,y1+2,x2-2,y2-2,gris_fonce,plein);\r
+ call patern(x1+1,y2-1,x2-1,y2-1,gris_fonce,plein);\r
+ call patern(x1+2,y2-2,x2-2,y2-2,gris_fonce,plein);\r
+ call patern(x1+5,y1+5,x2-5,y2-5,gris_fonce,vide);\r
+ call outstring(ENTIER((x2-x1-nb_car*larg_caract)/2)+x1,\r
+ ENTIER((y2-y1-haut_caract)/2)+y1,titre,noir,gris_clair);\r
+ else\r
+ call patern(x1,y1,x2,y2,gris_clair,plein);\r
+ call patern(x1,y1,x2,y2,noir,vide);\r
+ call patern(x1+1,y1+1,x1+1,y2-1,noir,plein);\r
+ call patern(x1+2,y1+2,x1+2,y2-2,noir,plein); \r
+ call patern(x1+1,y1+1,x2-1,y1+1,noir,plein);\r
+ call patern(x1+2,y1+2,x2-2,y1+2,noir,plein); \r
+ call patern(x1+5,y1+5,x2-5,y2-5,gris_fonce,vide);\r
+ call outstring(ENTIER((x2-x1-nb_car*larg_caract)/2)+x1+1,\r
+ ENTIER((y2-y1-haut_caract)/2)+y1+1,titre,noir,gris_clair);\r
+ fi ;\r
+ end print;\r
+\r
+ Unit choix : procedure ;\r
+ var pause : integer;\r
+ begin\r
+ selectionne:=TRUE;\r
+ call print;\r
+ (* on attend un peu pour visualiser l'effet de pression..*)\r
+ for pause:=1 to 1000 do od;\r
+ selectionne:=FALSE;\r
+ call print;\r
+ end choix; \r
+\r
+ Unit dedans : function(h,v :integer):boolean;\r
+ begin\r
+ result := (v>y1 and v<y2 and h>x1 and h<x2);\r
+ end dedans ;\r
+\r
+\r
+begin \r
+(* On initialise le bouton_relief \85 faux *)\r
+selectionne:=FALSE;\r
+\r
+end BOUTON_RELIEF;\r
+\r
+\r
+\r
+ (*************************************)\r
+ (* Bouton en relief 2 *) \r
+ (*************************************) \r
+\r
+Unit BOUTON_ENFONCE : class (x1,y1,x2,y2,nb_car:integer,titre:string);\r
+\r
+ Unit print : procedure;\r
+ begin\r
+ call patern(x1,y1,x2,y2,gris_clair,plein);\r
+ call patern(x1,y1,x2,y2,noir,vide);\r
+ call patern(x1+1,y1+1,x1+1,y2-1,blanc,plein);\r
+ call patern(x1+2,y1+2,x1+2,y2-2,blanc,plein);\r
+ call patern(x1+1,y1+1,x2-1,y1+1,blanc,plein);\r
+ call patern(x1+2,y1+2,x2-2,y1+2,blanc,plein);\r
+ call patern(x2-1,y1+1,x2-1,y2-1,gris_fonce,plein);\r
+ call patern(x2-2,y1+2,x2-2,y2-2,gris_fonce,plein);\r
+ call patern(x1+1,y2-1,x2-1,y2-1,gris_fonce,plein);\r
+ call patern(x1+2,y2-2,x2-2,y2-2,gris_fonce,plein);\r
+ call outstring(ENTIER((x2-x1-nb_car*larg_caract)/2)+x1,\r
+ ENTIER((y2-y1-haut_caract)/2)+y1,titre,noir,gris_clair);\r
+ end print;\r
+\r
+ Unit choix : procedure ;\r
+ begin\r
+ call patern(x1,y1,x2,y2,gris_clair,plein);\r
+ call patern(x1,y1,x2,y2,noir,vide);\r
+ call patern(x1+1,y1+1,x1+1,y2-1,noir,plein);\r
+ call patern(x1+2,y1+2,x1+2,y2-2,noir,plein); \r
+ call patern(x1+1,y1+1,x2-1,y1+1,noir,plein);\r
+ call patern(x1+2,y1+2,x2-2,y1+2,noir,plein); \r
+ call outstring(ENTIER((x2-x1-nb_car*larg_caract)/2)+x1+1,\r
+ ENTIER((y2-y1-haut_caract)/2)+y1+1,titre,noir,gris_clair);\r
+ end choix; \r
+\r
+ Unit dedans : function(h,v :integer):boolean;\r
+ begin\r
+ result := (v>y1 and v<y2 and h>x1 and h<x2);\r
+ end dedans ;\r
+\r
+end bouton_enfonce;\r
+\r
+(********************************************************************)\r
+ (****************************************)\r
+ (* Representation des cartes *)\r
+ (****************************************)\r
+\r
+ Unit sept_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"7",couleur,blanc);\r
+ call outstring(x+40,y+87,"7",couleur,blanc);\r
+ call outstring(x+40,y+2,"7",couleur,blanc);\r
+ call outstring(x+3,y+87,"7",couleur,blanc);\r
+\r
+ end sept_print;\r
+\r
+ Unit huit_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"8",couleur,blanc);\r
+ call outstring(x+40,y+87,"8",couleur,blanc);\r
+ call outstring(x+40,y+2,"8",couleur,blanc);\r
+ call outstring(x+3,y+87,"8",couleur,blanc);\r
+\r
+ end huit_print;\r
+\r
+ Unit neuf_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"9",couleur,blanc);\r
+ call outstring(x+40,y+87,"9",couleur,blanc);\r
+ call outstring(x+40,y+2,"9",couleur,blanc);\r
+ call outstring(x+3,y+87,"9",couleur,blanc);\r
+\r
+ end neuf_print;\r
+\r
+ Unit dix_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"10",couleur,blanc);\r
+ call outstring(x+34,y+87,"10",couleur,blanc);\r
+ call outstring(x+34,y+2,"10",couleur,blanc);\r
+ call outstring(x+3,y+87,"10",couleur,blanc);\r
+\r
+ end dix_print;\r
+\r
+ Unit valet_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"V",couleur,blanc);\r
+ call outstring(x+40,y+87,"V",couleur,blanc);\r
+ call outstring(x+40,y+2,"V",couleur,blanc);\r
+ call outstring(x+3,y+87,"V",couleur,blanc);\r
+\r
+ end valet_print;\r
+\r
+ Unit dame_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"D",couleur,blanc);\r
+ call outstring(x+40,y+87,"D",couleur,blanc);\r
+ call outstring(x+40,y+2,"D",couleur,blanc);\r
+ call outstring(x+3,y+87,"D",couleur,blanc);\r
+\r
+ end dame_print;\r
+\r
+ Unit roi_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"R",couleur,blanc);\r
+ call outstring(x+40,y+87,"R",couleur,blanc);\r
+ call outstring(x+40,y+2,"R",couleur,blanc);\r
+ call outstring(x+3,y+87,"R",couleur,blanc);\r
+\r
+ end roi_print;\r
+\r
+ Unit as_print : procedure(x,y:integer,couleur:integer);\r
+ begin\r
+ call outstring(x+3,y+2,"1",couleur,blanc);\r
+ call outstring(x+40,y+87,"1",couleur,blanc);\r
+ call outstring(x+40,y+2,"1",couleur,blanc);\r
+ call outstring(x+3,y+87,"1",couleur,blanc);\r
+\r
+ end as_print;\r
+\r
+\r
+\r
+ Unit pic : procedure(x,y : integer);\r
+ var tabx,taby : arrayof integer; \r
+ begin\r
+ array tabx dim(1:7);\r
+ array taby dim(1:7);\r
+ tabx(1):=X+10;taby(1):=Y+25;\r
+ tabx(2):=X+6;taby(2):=Y+38;\r
+ tabx(3):=X+14;taby(3):=Y+38;\r
+ tabx(4):=X+10;taby(4):=Y+25;\r
+ tabx(5):=X+0;taby(5):=Y+25;\r
+ tabx(6):=X+10;taby(6):=Y+10;\r
+ tabx(7):=X+20;taby(7):=Y+25;\r
+ call intens(7,tabx,taby,noir,plein);\r
+ call cirb(x+5+6/2,y+25+6/2,6/2,6/2,0,3600,noir,plein);\r
+ call cirb(x+15+6/2,y+25+6/2,6/2,6/2,0,3600,noir,plein);\r
+ end pic;\r
+\r
+ Unit trefle : procedure(x,y : integer);\r
+ var tabx,taby : arrayof integer; \r
+ begin\r
+ array tabx dim(1:3);\r
+ array taby dim(1:3);\r
+ tabx(1):=X+10;taby(1):=Y+23;\r
+ tabx(2):=X+6;taby(2):=Y+38;\r
+ tabx(3):=X+14;taby(3):=Y+38;\r
+ call intens(3,tabx,taby,noir,plein);\r
+ call cirb(x+10+6/2,y+15+6/2,6/2,6/2,0,3600,noir,plein);\r
+ call cirb(x+1+6/2,y+25+6/2,6/2,6/2,0,3600,noir,plein);\r
+ call cirb(x+19+6/2,y+25+6/2,6/2,6/2,0,3600,noir,plein);\r
+ end trefle;\r
+\r
+ Unit carreau : procedure(x,y : integer);\r
+ var tabx,taby : arrayof integer; \r
+ begin\r
+ array tabx dim(1:4);\r
+ array taby dim(1:4);\r
+ tabx(1):=X+0;taby(1):=Y+25;\r
+ tabx(2):=X+10;taby(2):=Y+40;\r
+ tabx(3):=X+20;taby(3):=Y+25;\r
+ tabx(4):=X+10;taby(4):=Y+10; \r
+ call intens(4,tabx,taby,rouge,plein);\r
+ end carreau;\r
+\r
+ Unit coeur : procedure(x,y : integer);\r
+ var tabx,taby : arrayof integer; \r
+ begin\r
+ array tabx dim(1:4);\r
+ array taby dim(1:4);\r
+ tabx(1):=X+10;taby(1):=Y+25;\r
+ tabx(2):=X-2;taby(2):=Y+25;\r
+ tabx(3):=X+10;taby(3):=Y+40;\r
+ tabx(4):=X+22;taby(4):=Y+25;\r
+ call intens(4,tabx,taby,rouge,plein);\r
+ call cirb(x+5+7/2,y+22+7/2,7/2,7/2,0,3600,rouge,plein);\r
+ call cirb(x+15+7/2,y+22+7/2,7/2,7/2,0,3600,rouge,plein);\r
+ \r
+ end coeur;\r
+\r
+ (******************************************)\r
+ (* Creation des cartes *)\r
+ (******************************************)\r
+\r
+ Unit carte : class(couleur,valeur:integer);\r
+\r
+ Unit dedans :function(h,v : integer):boolean;\r
+ begin\r
+ result := (v>y and v<y+100 and h>x and h<x+50);\r
+ end dedans ;\r
+\r
+ Unit print : procedure;\r
+ var tmp : integer;\r
+ begin\r
+ call patern(x,y,x+50,y+100,blanc,plein);\r
+ call patern(x-1,y-1,x+51,y+101,noir,vide);\r
+ case couleur\r
+ when P : call pic(x+15,y+30);\r
+ tmp:=noir;\r
+ when T : call trefle(x+15,y+30);\r
+ tmp:=noir;\r
+ when CA : call carreau(x+15,y+30);\r
+ tmp:=rouge;\r
+ when CO : call coeur(x+15,y+30);\r
+ tmp:=rouge;\r
+ esac;\r
+ case valeur\r
+ when sept : call sept_print(x,y,tmp);\r
+ when huit : call huit_print(x,y,tmp);\r
+ when neuf : call neuf_print(x,y,tmp);\r
+ when dix : call dix_print(x,y,tmp);\r
+ when valet : call valet_print(x,y,tmp);\r
+ when dame : call dame_print(x,y,tmp);\r
+ when roi : call roi_print(x,y,tmp);\r
+ when as : call as_print(x,y,tmp);\r
+\r
+ esac;\r
+ end print;\r
+\r
+ Unit efface : procedure;\r
+ begin\r
+ call patern(x-1,y-1,x+51,y+101,bleu,plein);\r
+ end efface;\r
+\r
+ var\r
+ x,y:integer;\r
+ begin\r
+ x:=0;\r
+ y:=0;\r
+ end carte;\r
+ \r
+ Unit CARTE_USER : class;\r
+ var c : carte,\r
+ present : boolean;\r
+ begin\r
+ c:=new carte(P,sept);\r
+ present:=FALSE;\r
+ end carte_user; \r
+\r
+\r
+ (*************************************)\r
+ (* Implementation d'une pile *) \r
+ (* de cartes *)\r
+ (*************************************) \r
+\r
+\r
+Unit PILE:class;\r
+ unit elem:class (valeur:carte,suivant:elem);\r
+ end elem;\r
+ var sommet:elem;\r
+ \r
+ unit empty:function:boolean;\r
+ begin\r
+ if sommet=none\r
+ then result:=true;\r
+ else result:=false;\r
+ fi;\r
+ end empty;\r
+\r
+ unit push:procedure(c:carte);\r
+ begin\r
+ sommet:=new elem(c,sommet);\r
+ end push;\r
+\r
+ unit pop:function:carte;\r
+ begin\r
+ if sommet=/=none\r
+ then \r
+ result:=sommet.valeur;\r
+ sommet:=sommet.suivant;\r
+ fi;\r
+ end pop;\r
+end PILE;\r
+\r
+(*********************************************************************)\r
+\r
+ (*************************************)\r
+ (* Creation des 4 coroutines *) \r
+ (*************************************) \r
+\r
+\r
+Unit joueur : coroutine;\r
+var i,n,abscisse,ordonnee:integer;\r
+\r
+ Unit donne1 : procedure; \r
+ begin \r
+ call patern(0,362,640,480,bleu,plein);\r
+ call b_aide_atout.print;\r
+ abscisse:=100;\r
+ ordonnee:=370;\r
+ for i:=1 to 2\r
+ do\r
+ j_jeu(i).c:=s.pop;\r
+ j_jeu(i).present:=true;\r
+ j_jeu(i).c.x:=abscisse;\r
+ j_jeu(i).c.y:=ordonnee;\r
+ call j_jeu(i).c.print;\r
+ abscisse:=abscisse+55;\r
+ od;\r
+ attach(adv1);\r
+ for i:=1 to 7000 do od;\r
+ for i:=3 to 5\r
+ do\r
+ j_jeu(i).c:=s.pop;\r
+ j_jeu(i).present:=true;\r
+ j_jeu(i).c.x:=abscisse;\r
+ j_jeu(i).c.y:=ordonnee;\r
+ call j_jeu(i).c.print;\r
+ abscisse:=abscisse+55;\r
+ od;\r
+ for i:=1 to 7000 do od;\r
+ fin_donne1:=fin_donne1+1;\r
+ attach(adv1);\r
+ if fin_donne1=4\r
+ then\r
+ fin_donne1:=0;\r
+ attach(main);\r
+ fi;\r
+ end donne1;\r
+\r
+ Unit tour1 : procedure;\r
+ begin\r
+ on_prend:=false;\r
+ joueur_prend:=false;\r
+ do\r
+ dede:=getpress(he,ve,pe,le,re,ce);\r
+ case (ce)\r
+ when 1 : \r
+ if (oui.dedans(he,ve))\r
+ then\r
+ call oui.choix;\r
+ on_prend:=true;\r
+ atout:=carte_ret.couleur;\r
+ joueur_prend:=true;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ attach(main);\r
+ exit;\r
+ fi;\r
+ if (non.dedans(he,ve))\r
+ then\r
+ call non.choix;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ call carte_ret.print;\r
+ attach(adv1);\r
+ exit; \r
+ fi;\r
+ esac\r
+ od;\r
+ \r
+ end tour1;\r
+\r
+ Unit tour2 : procedure;\r
+ begin\r
+ dede:=false;\r
+ do\r
+ dede:=getpress(he,ve,pe,le,re,ce);\r
+ case (ce)\r
+ when 1 : \r
+ if (b_pic.dedans(he,ve))\r
+ then\r
+ call b_pic.choix;\r
+ on_prend:=true;\r
+ joueur_prend:=true;\r
+ atout:=P;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ attach(main);\r
+ exit;\r
+ fi;\r
+ if (b_trefle.dedans(he,ve))\r
+ then\r
+ call b_trefle.choix;\r
+ on_prend:=true;\r
+ joueur_prend:=true;\r
+ atout:=T;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ attach(main);\r
+ exit;\r
+ fi;\r
+ if (b_carreau.dedans(he,ve))\r
+ then\r
+ call b_carreau.choix;\r
+ on_prend:=true;\r
+ joueur_prend:=true;\r
+ atout:=CA;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ attach(main);\r
+ exit;\r
+ fi;\r
+ if (b_coeur.dedans(he,ve))\r
+ then\r
+ call b_coeur.choix;\r
+ on_prend:=true;\r
+ joueur_prend:=true;\r
+ atout:=CO;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ attach(main);\r
+ exit;\r
+ fi;\r
+\r
+ if (rien.dedans(he,ve))\r
+ then\r
+ call rien.choix;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call move(0,41);\r
+ call putmap(terrain);\r
+ call carte_ret.print;\r
+ attach(adv1);\r
+ exit; \r
+ fi;\r
+ esac\r
+ od;\r
+ end tour2;\r
+\r
+ Unit donne2 : procedure;\r
+ var i,j,abscisse,ordonnee : integer;\r
+ begin\r
+ call move(0,0);\r
+ call putmap(image);\r
+ abscisse:=375;\r
+ ordonnee:=370;\r
+ if joueur_prend\r
+ then\r
+ for j:=1 to 7000 do od;\r
+ j_jeu(6).c:=carte_ret; \r
+ j_jeu(6).present:=true;\r
+ j_jeu(6).c.x:=abscisse;\r
+ j_jeu(6).c.y:=ordonnee;\r
+ call j_jeu(6).c.print;\r
+ abscisse:=abscisse+55;\r
+ \r
+ for j:=1 to 7000 do od;\r
+ for i:=7 to 8\r
+ do\r
+ j_jeu(i).c:=s.pop;\r
+ j_jeu(i).present:=true;\r
+ j_jeu(i).c.x:=abscisse;\r
+ j_jeu(i).c.y:=ordonnee;\r
+ call j_jeu(i).c.print;\r
+ abscisse:=abscisse+55;\r
+ od;\r
+ else \r
+ for j:=1 to 7000 do od;\r
+ for i:=6 to 8\r
+ do\r
+ j_jeu(i).c:=s.pop;\r
+ j_jeu(i).present:=true;\r
+ j_jeu(i).c.x:=abscisse;\r
+ j_jeu(i).c.y:=ordonnee;\r
+ call j_jeu(i).c.print;\r
+ abscisse:=abscisse+55;\r
+ od;\r
+ fi; \r
+ (* belote ou non ? *)\r
+ belote_joueur:=false;\r
+ for i:=1 to 8\r
+ do\r
+ if j_jeu(i).c.couleur=atout and j_jeu(i).c.valeur=dame\r
+ then\r
+ for j:=1 to 8\r
+ do\r
+ if j_jeu(j).c.couleur=atout and j_jeu(j).c.valeur=roi\r
+ then\r
+ belote_joueur:=true;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+ fin_donne2:=fin_donne2+1;\r
+ attach(adv1);\r
+ if fin_donne2=4\r
+ then\r
+ fin_donne2:=0;\r
+ attach(main);\r
+ fi;\r
+ \r
+end donne2;\r
+\r
+Unit jouer_carte : procedure;\r
+var\r
+ dede : boolean,\r
+ he,ve,pe,le,re,ce : integer;\r
+begin\r
+ dede:=false;\r
+ \r
+ do\r
+ dede:=getpress(he,ve,pe,le,re,ce);\r
+ case (ce)\r
+ when 1 : \r
+ if b_aide_atout.dedans(he,ve)\r
+ then\r
+ call b_aide_atout.choix;\r
+ call move(0,0);\r
+ save_joueur:=getmap(640,480);\r
+ call affiche_atout;\r
+ call move(0,0);\r
+ call putmap(save_joueur);\r
+ fi;\r
+ if (j_jeu(1).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(1).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(1).c;\r
+ j_jeu(1).present:=false;\r
+ if j_jeu(1).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(1).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(1).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(2).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(2).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(2).c;\r
+ j_jeu(2).present:=false;\r
+ if j_jeu(2).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(2).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(2).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(3).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(3).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(3).c;\r
+ j_jeu(3).present:=false;\r
+ if j_jeu(3).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(3).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(3).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(4).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(4).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(4).c;\r
+ j_jeu(4).present:=false;\r
+ if j_jeu(4).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(4).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(4).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(5).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(5).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(5).c;\r
+ j_jeu(5).present:=false;\r
+ if j_jeu(5).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(5).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(5).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(6).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(6).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(6).c;\r
+ j_jeu(6).present:=false;\r
+ if j_jeu(6).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(6).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(6).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(7).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(7).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(7).c;\r
+ j_jeu(7).present:=false;\r
+ if j_jeu(7).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(7).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(7).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ if (j_jeu(8).c.dedans(he,ve))\r
+ then\r
+ if j_jeu(8).present\r
+ then\r
+ for i:=1 to 10000 do od;\r
+ pli(cpt_pli):=j_jeu(8).c;\r
+ j_jeu(8).present:=false;\r
+ if j_jeu(8).c.couleur=atout\r
+ then\r
+ atout_joue(j_jeu(8).c.valeur):=true;\r
+ fi;\r
+ call j_jeu(8).c.efface;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ esac;\r
+ od;\r
+ pli(cpt_pli).x:=295;\r
+ pli(cpt_pli).y:=240;\r
+ call pli(cpt_pli).print; \r
+ for i:=1 to 30000 do od;\r
+\r
+ \r
+end jouer_carte;\r
+\r
+begin\r
+ return;\r
+\r
+ call donne1;\r
+ if not(on_prend)\r
+ then\r
+ oui:=new bouton_relief(260,95,310,125,3,"oui");\r
+ non:=new bouton_relief(330,95,390,125,3,"non");\r
+ call patern(200,55,440,135,gris_clair,plein);\r
+ call patern(200,55,440,135,noir,vide);\r
+ call outstring(235,60,"Desirez-vous prendre ?",noir,gris_clair);\r
+ call oui.print;\r
+ call non.print;\r
+ call tour1;\r
+ fi;\r
+(* 2ieme tour *) \r
+ if not(on_prend)\r
+ then\r
+ call move(0,0);\r
+ call putmap(image);\r
+ b_pic:=new bouton_relief(210,85,280,125,3,"Pic");\r
+ b_trefle:=new bouton_relief(290,85,360,125,6,"Trefle");\r
+ b_carreau:=new bouton_relief(210,135,280,175,7,"Carreau");\r
+ b_coeur:=new bouton_relief(290,135,360,175,5,"Coeur");\r
+ rien:=new bouton_relief(370,110,430,150,6,"Aucune");\r
+ carre:=new bouton_relief(175,55,465,195,0,"");\r
+ call carre.print;\r
+ call outstring(235,60,"choisissez une couleur ?",noir,gris_clair);\r
+ call b_pic.print;\r
+ call b_trefle.print;\r
+ call b_carreau.print;\r
+ call b_coeur.print;\r
+ call rien.print;\r
+ call tour2;\r
+ fi;\r
+ if on_prend \r
+ then\r
+ call donne2;\r
+ for n:=1 to 8\r
+ do\r
+ call jouer_carte;\r
+ attach(main);\r
+ od;\r
+ fi;\r
+\r
+ attach(main);\r
+end joueur;\r
+\r
+\r
+\r
+\r
+Unit adversaire1 : coroutine;\r
+var i,j,n,cumul,attente : integer;\r
+\r
+ Unit donne1 : procedure;\r
+ begin\r
+ for i:=1 to 2\r
+ do\r
+ a1_jeu(i).c:=s.pop;\r
+ a1_jeu(i).present:=true;\r
+ od;\r
+ attach(part);\r
+ for i:=1 to 7000 do od;\r
+ for i:=3 to 5\r
+ do\r
+ a1_jeu(i).c:=s.pop;\r
+ a1_jeu(i).present:=true;\r
+ od;\r
+ fin_donne1:=fin_donne1+1;\r
+ attach(part);\r
+ if fin_donne1=4\r
+ then\r
+ fin_donne1:=0;\r
+ attach(main);\r
+ fi;\r
+ \r
+ end donne1;\r
+\r
+ Unit tour1 : procedure;\r
+ begin\r
+ on_prend:=false;\r
+ adv1_prend:=false;\r
+ (* peut-il prendre ? *) \r
+ cumul:=evalue(carte_ret);\r
+ for i:=1 to 5\r
+ do\r
+ if (a1_jeu(i).c.couleur=carte_ret.couleur)\r
+ then\r
+ cumul:=cumul+evalue(a1_jeu(i).c);\r
+ fi;\r
+ od;\r
+ if (cumul>=50) \r
+ then\r
+ call outstring(300,26,"EST prend",noir,gris_clair);\r
+ for i:=1 to 27000 do od;\r
+ call outstring(300,26," ",noir,gris_clair); \r
+ adv1_prend:=true;\r
+ on_prend:=true;\r
+ atout:=carte_ret.couleur;\r
+ attach(main);\r
+ else\r
+ call outstring(250,26,"EST ne prend pas ",noir,gris_clair);\r
+ for i:=1 to 27000 do od;\r
+ call outstring(250,26," ",noir,gris_clair);\r
+ attach(part);\r
+ fi;\r
+\r
+ end tour1;\r
+\r
+ Unit tour2 : procedure;\r
+ begin\r
+ j:=1;\r
+ while ((j<=4) and not(on_prend))\r
+ do\r
+ coul:=j;\r
+ cumul:=0;\r
+ if (coul=/=carte_ret.couleur)\r
+ then\r
+ for i:=1 to 5\r
+ do\r
+ if (a1_jeu(i).c.couleur=coul)\r
+ then\r
+ cumul:=cumul+evalue(a1_jeu(i).c);\r
+ fi;\r
+ od;\r
+ if (cumul>=50) \r
+ then\r
+ call outstring(300,26,"EST prend",noir,gris_clair);\r
+ for i:=1 to 17000 do od;\r
+ call outstring(300,26," ",noir,gris_clair);\r
+ adv1_prend:=true;\r
+ on_prend:=true;\r
+ atout:=coul;\r
+ else\r
+ call outstring(250,26,"EST ne prend pas ",noir,gris_clair);\r
+ for i:=1 to 17000 do od;\r
+ call outstring(250,26," ",noir,gris_clair);\r
+ fi;\r
+ fi;\r
+ j:=j+1;\r
+ od;\r
+ if adv1_prend\r
+ then\r
+ attach(main);\r
+ else\r
+ attach(part);\r
+ fi;\r
+\r
+end tour2;\r
+\r
+ Unit donne2 : procedure;\r
+ var i : integer;\r
+ begin\r
+ if adv1_prend\r
+ then\r
+ a1_jeu(6).c:=carte_ret; \r
+ a1_jeu(6).present:=true;\r
+ for i:=7 to 8\r
+ do\r
+ a1_jeu(i).c:=s.pop;\r
+ a1_jeu(i).present:=true;\r
+ od;\r
+ else \r
+ for i:=6 to 8\r
+ do\r
+ a1_jeu(i).c:=s.pop;\r
+ a1_jeu(i).present:=true;\r
+ od;\r
+ fi; \r
+ (* belote ou non ? *)\r
+ belote_adversaire1:=false;\r
+ for i:=1 to 8\r
+ do\r
+ if a1_jeu(i).c.couleur=atout and a1_jeu(i).c.valeur=dame\r
+ then\r
+ for j:=1 to 8\r
+ do\r
+ if a1_jeu(j).c.couleur=atout and a1_jeu(j).c.valeur=roi\r
+ then\r
+ belote_adversaire1:=true;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+\r
+ fin_donne2:=fin_donne2+1;\r
+ attach(part);\r
+ if fin_donne2=4\r
+ then\r
+ fin_donne2:=0;\r
+ attach(main);\r
+ fi;\r
+\r
+end donne2;\r
+\r
+\r
+Unit jouer_carte : procedure;\r
+var trouve,pas_encore : boolean,\r
+ i,remember,forte : integer;\r
+\r
+begin\r
+ i:=1;\r
+ remember:=0;\r
+ trouve:=false; \r
+ if cpt_pli=1 (* c'est lui qui joue en premier *)\r
+ then\r
+ if adv1_prend or adv2_prend\r
+ then\r
+ (* ils ont pris *)\r
+ (* adv1 joue atout si possible *)\r
+ while i<9 and not trouve\r
+ do\r
+ if a1_jeu(i).c.couleur=atout and a1_jeu(i).present\r
+ then \r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ a1_jeu(i).present:=false;\r
+ atout_joue(a1_jeu(i).c.valeur):=true;\r
+ trouve:=true;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ i:=1;\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* adv1 n'a pas d'atout, alors il joue as sinon indien *)\r
+ if a1_jeu(i).present\r
+ then\r
+ if pas_encore\r
+ then\r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if pli(cpt_pli).valeur=as\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if a1_jeu(i).c.valeur=as\r
+ then\r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite de son jeu *)\r
+ if pli(cpt_pli).valeur>a1_jeu(i).c.valeur\r
+ then\r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ (* il joue donc la carte nø remember *)\r
+ if remember<>0\r
+ then\r
+ a1_jeu(remember).present:=false;\r
+ if a1_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(a1_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ fi;\r
+ else\r
+ (* Ils n'ont pas pris *)\r
+ i:=1;\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* adv1 joue as sinon indien different d'atout *)\r
+ if a1_jeu(i).c.couleur<>atout\r
+ then\r
+ if a1_jeu(i).present\r
+ then\r
+ if pas_encore\r
+ then\r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if pli(cpt_pli).valeur=as\r
+ then \r
+ trouve:=true;\r
+ a1_jeu(remember).present:=false;\r
+ if a1_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(a1_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if a1_jeu(i).c.valeur=as\r
+ then\r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ remember:=i;\r
+ a1_jeu(remember).present:=false;\r
+ if a1_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(a1_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite carte de son jeu *)\r
+ if pli(cpt_pli).valeur>a1_jeu(i).c.valeur\r
+ then\r
+ pli(cpt_pli):=a1_jeu(i).c;\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il ne lui reste que de l'atout *)\r
+ (* il est donc oblige de jouer atout *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv1 joue le plus petit atout *)\r
+ if a1_jeu(i).present\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if not compare_atout(a1_jeu(i).c.valeur,a1_jeu(remember).c.valeur)\r
+ (* a1_jeu(i).c.valeur<a1_jeu(remember).c.valeur *)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ a1_jeu(remember).present:=false;\r
+ if a1_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(a1_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ pli(cpt_pli):=a1_jeu(remember).c;\r
+ fi;\r
+ else (* s'il ne joue pas en premier .............................. *) \r
+ i:=1;\r
+ if pli(1).couleur<>atout\r
+ then\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* Il joue as sinon indien dans couleur demandee different d'atout *)\r
+ if a1_jeu(i).present and a1_jeu(i).c.couleur=pli(1).couleur\r
+ then\r
+ if pas_encore\r
+ then\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if a1_jeu(remember).c.valeur=as\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if a1_jeu(i).c.valeur=as\r
+ then\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite de son jeu *)\r
+ if a1_jeu(remember).c.valeur>a1_jeu(i).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il n'a pas de la couleur demandee, il essaie de jouer atout *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv1 joue le plus petit atout *)\r
+ if a1_jeu(i).present and a1_jeu(i).c.couleur=atout\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if not compare_atout(a1_jeu(i).c.valeur,a1_jeu(remember).c.valeur)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il ne peut pas couper *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv1 joue sa plus petite carte *)\r
+ if a1_jeu(i).present \r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if a1_jeu(i).c.valeur<a1_jeu(remember).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ fi;\r
+ else \r
+ (* c'est atout demandee *)\r
+ (* il est oblige de monter *)\r
+ forte:=0;\r
+ for i:=1 to cpt_pli\r
+ do\r
+ if pli(i).couleur=atout\r
+ then\r
+ if not compare_atout(forte,pli(i).valeur)\r
+ then \r
+ forte:=pli(i).valeur\r
+ fi;\r
+ fi;\r
+ od;\r
+ i:=1;\r
+ while i<9 and not trouve\r
+ do\r
+ if a1_jeu(i).present and a1_jeu(i).c.couleur=atout\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ if compare_atout(a1_jeu(i).c.valeur,forte)\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ if compare_atout(a1_jeu(i).c.valeur,forte)\r
+ then\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ if not compare_atout(a1_jeu(i).c.valeur,a1_jeu(remember).c.valeur)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* adv1 n'a pas d'atout, il joue un indien *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv1 joue sa plus petite carte *)\r
+ if a1_jeu(i).present \r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if a1_jeu(i).c.valeur<a1_jeu(remember).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ fi;\r
+ pli(cpt_pli):=a1_jeu(remember).c;\r
+ a1_jeu(remember).present:=false;\r
+ if a1_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(a1_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ fi;\r
+ pli(cpt_pli).x:=400;\r
+ pli(cpt_pli).y:=170;\r
+ call pli(cpt_pli).print; \r
+ for i:=1 to 30000 do od;\r
+ \r
+end jouer_carte;\r
+\r
+\r
+begin\r
+ return;\r
+\r
+ call donne1;\r
+ if not(on_prend)\r
+ then\r
+ call tour1;\r
+ fi;\r
+(* 2ieme tour *) \r
+ if not(on_prend)\r
+ then\r
+ call tour2;\r
+ fi;\r
+ if on_prend\r
+ then\r
+ call donne2;\r
+ for n:=1 to 8\r
+ do\r
+ call jouer_carte;\r
+ attach(main);\r
+ od;\r
+ fi;\r
+\r
+ attach(main); \r
+end adversaire1;\r
+\r
+\r
+Unit partenaire : coroutine;\r
+var i,j,n,cumul : integer;\r
+\r
+ Unit donne1 : procedure;\r
+ begin\r
+ for i:=1 to 2\r
+ do\r
+ p_jeu(i).c:=s.pop;\r
+ p_jeu(i).present:=true;\r
+ od;\r
+ for i:=1 to 7000 do od;\r
+ attach(adv2);\r
+ for i:=1 to 7000 do od;\r
+ for i:=3 to 5\r
+ do\r
+ p_jeu(i).c:=s.pop;\r
+ p_jeu(i).present:=true;\r
+ od;\r
+ for i:=1 to 7000 do od;\r
+ fin_donne1:=fin_donne1+1;\r
+ attach(adv2);\r
+ if fin_donne1=4\r
+ then\r
+ fin_donne1:=0;\r
+ attach(main);\r
+ fi;\r
+\r
+\r
+ end donne1;\r
+\r
+ Unit tour1 : procedure;\r
+ begin\r
+ on_prend:=false;\r
+ part_prend:=false;\r
+ (* peut-il prendre ? *) \r
+ cumul:=evalue2(carte_ret);\r
+ for i:=1 to 5\r
+ do\r
+ if (p_jeu(i).c.couleur=carte_ret.couleur)\r
+ then\r
+ cumul:=cumul+evalue2(p_jeu(i).c);\r
+ fi;\r
+ od;\r
+ if (cumul>=50) \r
+ then\r
+ call outstring(300,26,"NORD prend",noir,gris_clair);\r
+ for i:=1 to 27000 do od;\r
+ call outstring(300,26," ",noir,gris_clair);\r
+ part_prend:=true;\r
+ on_prend:=true;\r
+ atout:=carte_ret.couleur;\r
+ attach(main);\r
+ else\r
+ call outstring(250,26,"NORD ne prend pas ",noir,gris_clair);\r
+ for i:=1 to 27000 do od;\r
+ call outstring(250,26," ",noir,gris_clair);\r
+ attach(adv2);\r
+ fi;\r
+\r
+end tour1;\r
+\r
+Unit tour2 : procedure;\r
+begin\r
+ j:=1;\r
+ while ((j<=4) and not(on_prend))\r
+ do\r
+ coul:=j;\r
+ cumul:=0;\r
+ if (coul=/=carte_ret.couleur)\r
+ then\r
+ for i:=1 to 5\r
+ do\r
+ if (p_jeu(i).c.couleur=coul)\r
+ then\r
+ cumul:=cumul+evalue2(p_jeu(i).c);\r
+ fi;\r
+ od;\r
+ if (cumul>=50) \r
+ then\r
+ call outstring(300,26,"NORD prend",noir,gris_clair);\r
+ for i:=1 to 17000 do od;\r
+ call outstring(300,26," ",noir,gris_clair);\r
+ part_prend:=true;\r
+ on_prend:=true;\r
+ atout:=coul;\r
+ else\r
+ call outstring(250,26,"NORD ne prend pas ",noir,gris_clair);\r
+ for i:=1 to 17000 do od;\r
+ call outstring(250,26," ",noir,gris_clair);\r
+ fi;\r
+ fi;\r
+ j:=j+1;\r
+ od;\r
+ if part_prend\r
+ then\r
+ attach(main);\r
+ else\r
+ attach(adv2);\r
+ fi;\r
+\r
+end tour2;\r
+\r
+Unit donne2 : procedure;\r
+ var i : integer;\r
+ begin\r
+ if part_prend\r
+ then\r
+ p_jeu(6).c:=carte_ret; \r
+ p_jeu(6).present:=true;\r
+ for i:=7 to 8\r
+ do\r
+ p_jeu(i).c:=s.pop;\r
+ p_jeu(i).present:=true;\r
+ od;\r
+ else \r
+ for i:=6 to 8\r
+ do\r
+ p_jeu(i).c:=s.pop;\r
+ p_jeu(i).present:=true;\r
+ od;\r
+ fi; \r
+ belote_partenaire:=false;\r
+ for i:=1 to 8\r
+ do\r
+ if p_jeu(i).c.couleur=atout and p_jeu(i).c.valeur=dame\r
+ then\r
+ for j:=1 to 8\r
+ do\r
+ if p_jeu(j).c.couleur=atout and p_jeu(j).c.valeur=roi\r
+ then\r
+ belote_partenaire:=true;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+\r
+ fin_donne2:=fin_donne2+1;\r
+ attach(adv2);\r
+ if fin_donne2=4\r
+ then\r
+ fin_donne2:=0;\r
+ attach(main);\r
+ fi;\r
+\r
+end donne2;\r
+\r
+Unit jouer_carte : procedure;\r
+var trouve,pas_encore : boolean,\r
+ i,remember,forte,grand,petit,maitre : integer;\r
+\r
+begin\r
+ i:=1;\r
+ remember:=0;\r
+ trouve:=false; \r
+ if cpt_pli=1 (* c'est lui qui joue en premier *)\r
+ then\r
+ if joueur_prend or part_prend\r
+ then\r
+ (* ils ont pris *)\r
+ (* part joue atout si possible *)\r
+ grand:=0;\r
+ petit:=0;\r
+ while i<9\r
+ do\r
+ if p_jeu(i).present\r
+ then\r
+ if p_jeu(i).c.couleur=atout and grand=0\r
+ then\r
+ grand:=i;\r
+ petit:=i;\r
+ else\r
+ if p_jeu(i).c.couleur=atout\r
+ then\r
+ if compare_atout(p_jeu(i).c.valeur,p_jeu(grand).c.valeur)\r
+ then\r
+ grand:=i;\r
+ fi;\r
+ if not compare_atout(p_jeu(i).c.valeur,p_jeu(petit).c.valeur)\r
+ then\r
+ petit:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if grand<>0\r
+ then\r
+ maitre:=at_fort;\r
+ if p_jeu(grand).c.valeur=maitre\r
+ then\r
+ remember:=grand;\r
+ else\r
+ remember:=petit;\r
+ fi;\r
+ pli(cpt_pli):=p_jeu(remember).c;\r
+ fi;\r
+ i:=1;\r
+ pas_encore:=true;\r
+ while i<9 and not trouve and grand=0\r
+ do\r
+ (* part n'a pas d'atout, alors il joue as sinon indien *)\r
+ if p_jeu(i).present\r
+ then\r
+ if pas_encore\r
+ then\r
+ pli(cpt_pli):=p_jeu(i).c;\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if pli(cpt_pli).valeur=as\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if p_jeu(i).c.valeur=as\r
+ then\r
+ pli(cpt_pli):=p_jeu(i).c;\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite de son jeu *)\r
+ if pli(cpt_pli).valeur>p_jeu(i).c.valeur\r
+ then\r
+ pli(cpt_pli):=p_jeu(i).c;\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ (* il joue donc la carte nø remember *)\r
+ if remember<>0\r
+ then\r
+ p_jeu(remember).present:=false;\r
+ fi;\r
+ else\r
+ (* Ils n'ont pas pris *)\r
+ i:=1;\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* part joue as sinon indien different d'atout *)\r
+ if p_jeu(i).c.couleur<>atout\r
+ then\r
+ if p_jeu(i).present\r
+ then\r
+ if pas_encore\r
+ then\r
+ pli(cpt_pli):=p_jeu(i).c;\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if pli(cpt_pli).valeur=as\r
+ then \r
+ trouve:=true;\r
+ p_jeu(remember).present:=false;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if p_jeu(i).c.valeur=as\r
+ then\r
+ pli(cpt_pli):=p_jeu(i).c;\r
+ remember:=i;\r
+ p_jeu(remember).present:=false;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite carte de son jeu *)\r
+ if pli(cpt_pli).valeur>p_jeu(i).c.valeur\r
+ then\r
+ pli(cpt_pli):=p_jeu(i).c;\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il ne lui reste que de l'atout *)\r
+ (* il est donc oblige de jouer atout *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* part joue le plus petit atout *)\r
+ if p_jeu(i).present\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if not compare_atout(p_jeu(i).c.valeur,p_jeu(remember).c.valeur)\r
+ (* p_jeu(i).c.valeur<p_jeu(remember).c.valeur *)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ p_jeu(remember).present:=false;\r
+ pli(cpt_pli):=p_jeu(remember).c;\r
+ fi;\r
+ else (* s'il ne joue pas en premier .............................. *) \r
+ i:=1;\r
+ if pli(1).couleur<>atout\r
+ then\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* Il joue as sinon indien dans couleur demandee different d'atout *)\r
+ if p_jeu(i).present and p_jeu(i).c.couleur=pli(1).couleur\r
+ then\r
+ if pas_encore\r
+ then\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if p_jeu(remember).c.valeur=as\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if p_jeu(i).c.valeur=as\r
+ then\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite de son jeu *)\r
+ if p_jeu(remember).c.valeur>p_jeu(i).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il n'a pas de la couleur demandee, il essaie de jouer atout *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* part joue le plus petit atout *)\r
+ if p_jeu(i).present and p_jeu(i).c.couleur=atout\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if not compare_atout(p_jeu(i).c.valeur,p_jeu(remember).c.valeur)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il ne peut pas couper *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* part joue sa plus petite carte *)\r
+ if p_jeu(i).present \r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if p_jeu(i).c.valeur<p_jeu(remember).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ fi;\r
+ else \r
+ (* c'est atout demandee *)\r
+ (* il est oblige de monter *)\r
+ forte:=0;\r
+ for i:=1 to cpt_pli\r
+ do\r
+ if pli(i).couleur=atout\r
+ then\r
+ if not compare_atout(forte,pli(i).valeur)\r
+ then \r
+ forte:=pli(i).valeur\r
+ fi;\r
+ fi;\r
+ od;\r
+ i:=1;\r
+ while i<9 and not trouve\r
+ do\r
+ if p_jeu(i).present and p_jeu(i).c.couleur=atout\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ if compare_atout(p_jeu(i).c.valeur,forte)\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ if compare_atout(p_jeu(i).c.valeur,forte)\r
+ then\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ if not compare_atout(p_jeu(i).c.valeur,p_jeu(remember).c.valeur)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* part n'a pas d'atout, il joue un indien *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* part joue sa plus petite carte *)\r
+ if p_jeu(i).present \r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if p_jeu(i).c.valeur<p_jeu(remember).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ fi;\r
+ pli(cpt_pli):=p_jeu(remember).c;\r
+ p_jeu(remember).present:=false;\r
+ fi;\r
+ if remember<>0\r
+ then\r
+ if p_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(p_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ fi;\r
+ \r
+\r
+ pli(cpt_pli).x:=295;\r
+ pli(cpt_pli).y:=100;\r
+ call pli(cpt_pli).print; \r
+ for i:=1 to 30000 do od;\r
+\r
+end jouer_carte;\r
+\r
+begin\r
+ return;\r
+\r
+ call donne1;\r
+ if not(on_prend)\r
+ then\r
+ call tour1;\r
+ fi;\r
+(* 2ieme tour *) \r
+ if not(on_prend)\r
+ then\r
+ call tour2;\r
+ fi;\r
+\r
+ if on_prend\r
+ then \r
+ call donne2;\r
+ for n:=1 to 8\r
+ do\r
+ call jouer_carte;\r
+ attach(main);\r
+ od;\r
+ fi;\r
+\r
+\r
+ attach(main);\r
+end partenaire;\r
+\r
+\r
+\r
+\r
+Unit adversaire2 : coroutine;\r
+var i,j,n,cumul : integer;\r
+\r
+ Unit donne1 : procedure;\r
+ begin\r
+ for i:=1 to 2\r
+ do\r
+ a2_jeu(i).c:=s.pop;\r
+ a2_jeu(i).present:=true;\r
+ od;\r
+ for i:=1 to 7000 do od;\r
+ attach(user);\r
+ for i:=1 to 7000 do od;\r
+ for i:=3 to 5\r
+ do\r
+ a2_jeu(i).c:=s.pop;\r
+ a2_jeu(i).present:=true;\r
+ od;\r
+ for i:=1 to 7000 do od;\r
+ fin_donne1:=fin_donne1+1;\r
+ attach(user);\r
+ if fin_donne1=4\r
+ then\r
+ fin_donne1:=0;\r
+ attach(main);\r
+ fi;\r
+\r
+ end donne1;\r
+\r
+ Unit tour1 : procedure;\r
+ begin\r
+ on_prend:=false;\r
+ adv2_prend:=false;\r
+ (* peut-il prendre ? *) \r
+ cumul:=evalue(carte_ret);\r
+ for i:=1 to 5\r
+ do\r
+ if (a2_jeu(i).c.couleur=carte_ret.couleur)\r
+ then\r
+ cumul:=cumul+evalue(a2_jeu(i).c);\r
+ fi;\r
+ od;\r
+ if (cumul>=50) \r
+ then\r
+ call outstring(290,26,"OUEST prend",noir,gris_clair);\r
+ for i:=1 to 27000 do od;\r
+ call outstring(290,26," ",noir,gris_clair);\r
+ adv2_prend:=true;\r
+ on_prend:=true;\r
+ atout:=carte_ret.couleur;\r
+ attach(main);\r
+ else\r
+ call outstring(240,26,"OUEST ne prend pas",noir,gris_clair);\r
+ for i:=1 to 27000 do od;\r
+ call outstring(240,26," ",noir,gris_clair);\r
+ attach(user); \r
+ fi;\r
+\r
+ (* attach(user); *)\r
+\r
+end tour1;\r
+\r
+Unit tour2 : procedure;\r
+begin\r
+ j:=1;\r
+ while ((j<=4) and not(on_prend))\r
+ do\r
+ coul:=j;\r
+ cumul:=0;\r
+ if (coul=/=carte_ret.couleur)\r
+ then\r
+ for i:=1 to 5\r
+ do\r
+ if (a2_jeu(i).c.couleur=coul)\r
+ then\r
+ cumul:=cumul+evalue(a2_jeu(i).c);\r
+ fi;\r
+ od;\r
+ if (cumul>=50) \r
+ then\r
+ call outstring(290,26,"OUEST prend",noir,gris_clair);\r
+ for i:=1 to 17000 do od;\r
+ call outstring(290,26," ",noir,gris_clair);\r
+ adv2_prend:=true;\r
+ on_prend:=true;\r
+ atout:=coul;\r
+ else\r
+ call outstring(240,26,"OUEST ne prend pas",noir,gris_clair);\r
+ for i:=1 to 17000 do od;\r
+ call outstring(240,26," ",noir,gris_clair);\r
+ fi;\r
+ fi;\r
+ j:=j+1;\r
+ od;\r
+ if adv2_prend\r
+ then\r
+ attach(main);\r
+ else\r
+ attach(user);\r
+ fi;\r
+\r
+end tour2;\r
+\r
+ Unit donne2 : procedure;\r
+ var i : integer;\r
+ begin\r
+ if adv2_prend\r
+ then\r
+ a2_jeu(6).c:=carte_ret; \r
+ a2_jeu(6).present:=true;\r
+ for i:=7 to 8\r
+ do\r
+ a2_jeu(i).c:=s.pop;\r
+ a2_jeu(i).present:=true;\r
+ od;\r
+ else \r
+ for i:=6 to 8\r
+ do\r
+ a2_jeu(i).c:=s.pop;\r
+ a2_jeu(i).present:=true;\r
+ od;\r
+ fi; \r
+ belote_adversaire2:=false;\r
+ for i:=1 to 8\r
+ do\r
+ if a2_jeu(i).c.couleur=atout and a2_jeu(i).c.valeur=dame\r
+ then\r
+ for j:=1 to 8\r
+ do\r
+ if a2_jeu(j).c.couleur=atout and a2_jeu(j).c.valeur=roi\r
+ then\r
+ belote_adversaire2:=true;\r
+ fi;\r
+ od;\r
+ fi;\r
+ od;\r
+\r
+ fin_donne2:=fin_donne2+1;\r
+ attach(user);\r
+ if fin_donne2=4\r
+ then\r
+ fin_donne2:=0;\r
+ attach(main);\r
+ fi;\r
+ \r
+end donne2;\r
+\r
+Unit jouer_carte : procedure;\r
+var trouve,pas_encore : boolean,\r
+ i,remember,forte,grand,petit,maitre : integer;\r
+\r
+begin\r
+ i:=1;\r
+ remember:=0;\r
+ trouve:=false; \r
+ if cpt_pli=1 (* c'est lui qui joue en premier *)\r
+ then\r
+ if adv1_prend or adv2_prend\r
+ then\r
+ (* ils ont pris *)\r
+ (* adv2 joue atout si possible *)\r
+ grand:=0;\r
+ petit:=0;\r
+ while i<9\r
+ do\r
+ if a2_jeu(i).present\r
+ then\r
+ if a2_jeu(i).c.couleur=atout and grand=0\r
+ then\r
+ grand:=i;\r
+ petit:=i;\r
+ else\r
+ if a2_jeu(i).c.couleur=atout\r
+ then\r
+ if compare_atout(p_jeu(i).c.valeur,a2_jeu(grand).c.valeur)\r
+ then\r
+ grand:=i;\r
+ fi;\r
+ if not compare_atout(a2_jeu(i).c.valeur,a2_jeu(petit).c.valeur)\r
+ then\r
+ petit:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if grand<>0\r
+ then\r
+ maitre:=at_fort;\r
+ if a2_jeu(grand).c.valeur=maitre\r
+ then\r
+ remember:=grand;\r
+ else\r
+ remember:=petit;\r
+ fi;\r
+ pli(cpt_pli):=a2_jeu(remember).c;\r
+ fi;\r
+ i:=1;\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* adv2 n'a pas d'atout, alors il joue as sinon indien *)\r
+ if a2_jeu(i).present\r
+ then\r
+ if pas_encore\r
+ then\r
+ pli(cpt_pli):=a2_jeu(i).c;\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if pli(cpt_pli).valeur=as\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if a2_jeu(i).c.valeur=as\r
+ then\r
+ pli(cpt_pli):=a2_jeu(i).c;\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite de son jeu *)\r
+ if pli(cpt_pli).valeur>a2_jeu(i).c.valeur\r
+ then\r
+ pli(cpt_pli):=a2_jeu(i).c;\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ (* il joue donc la carte nø remember *)\r
+ if remember<>0\r
+ then\r
+ a2_jeu(remember).present:=false;\r
+ fi;\r
+ else\r
+ (* Ils n'ont pas pris *)\r
+ i:=1;\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* adv2 joue as sinon indien different d'atout *)\r
+ if a2_jeu(i).c.couleur<>atout\r
+ then\r
+ if a2_jeu(i).present\r
+ then\r
+ if pas_encore\r
+ then\r
+ pli(cpt_pli):=a2_jeu(i).c;\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if pli(cpt_pli).valeur=as\r
+ then \r
+ trouve:=true;\r
+ a2_jeu(remember).present:=false;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if a2_jeu(i).c.valeur=as\r
+ then\r
+ pli(cpt_pli):=a2_jeu(i).c;\r
+ remember:=i;\r
+ a2_jeu(remember).present:=false;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite carte de son jeu *)\r
+ if pli(cpt_pli).valeur>a2_jeu(i).c.valeur\r
+ then\r
+ pli(cpt_pli):=a2_jeu(i).c;\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il ne lui reste que de l'atout *)\r
+ (* il est donc oblige de jouer atout *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv2 joue le plus petit atout *)\r
+ if a2_jeu(i).present\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if not compare_atout(a2_jeu(i).c.valeur,a2_jeu(remember).c.valeur)\r
+ (* a2_jeu(i).c.valeur<a2_jeu(remember).c.valeur *)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ a2_jeu(remember).present:=false;\r
+ pli(cpt_pli):=a2_jeu(remember).c;\r
+ fi;\r
+ else (* s'il ne joue pas en premier .............................. *) \r
+ i:=1;\r
+ if pli(1).couleur<>atout\r
+ then\r
+ pas_encore:=true;\r
+ while i<9 and not trouve\r
+ do\r
+ (* Il joue as sinon indien dans couleur demandee different d'atout *)\r
+ if a2_jeu(i).present and a2_jeu(i).c.couleur=pli(1).couleur\r
+ then\r
+ if pas_encore\r
+ then\r
+ remember:=i;\r
+ pas_encore:=false;\r
+ if a2_jeu(remember).c.valeur=as\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ (* il n'a pas encore trouve d'as, et il lui reste des cartes\r
+ a comparer *)\r
+ if a2_jeu(i).c.valeur=as\r
+ then\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ (* si toujours pas d'as, il prend la plus petite de son jeu *)\r
+ if a2_jeu(remember).c.valeur>a2_jeu(i).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il n'a pas de la couleur demandee, il essaie de jouer atout *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv2 joue le plus petit atout *)\r
+ if a2_jeu(i).present and a2_jeu(i).c.couleur=atout\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if not compare_atout(a2_jeu(i).c.valeur,a2_jeu(remember).c.valeur)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* il ne peut pas couper *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv2 joue sa plus petite carte *)\r
+ if a2_jeu(i).present \r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if a2_jeu(i).c.valeur<a2_jeu(remember).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ fi;\r
+ else \r
+ (* c'est atout demandee *)\r
+ (* il est oblige de monter *)\r
+ forte:=0;\r
+ for i:=1 to cpt_pli\r
+ do\r
+ if pli(i).couleur=atout\r
+ then\r
+ if not compare_atout(forte,pli(i).valeur)\r
+ then \r
+ forte:=pli(i).valeur\r
+ fi;\r
+ fi;\r
+ od;\r
+ i:=1;\r
+ while i<9 and not trouve\r
+ do\r
+ if a2_jeu(i).present and a2_jeu(i).c.couleur=atout\r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ if compare_atout(a2_jeu(i).c.valeur,forte)\r
+ then \r
+ trouve:=true;\r
+ fi;\r
+ else\r
+ if compare_atout(a2_jeu(i).c.valeur,forte)\r
+ then\r
+ remember:=i;\r
+ trouve:=true;\r
+ else\r
+ if not compare_atout(a2_jeu(i).c.valeur,a2_jeu(remember).c.valeur)\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if remember=0\r
+ then\r
+ (* adv2 n'a pas d'atout, il joue un indien *)\r
+ i:=1;\r
+ while i<9\r
+ do\r
+ (* adv2 joue sa plus petite carte *)\r
+ if a2_jeu(i).present \r
+ then\r
+ if remember=0\r
+ then\r
+ remember:=i;\r
+ else\r
+ if a2_jeu(i).c.valeur<a2_jeu(remember).c.valeur\r
+ then\r
+ remember:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ fi;\r
+ fi;\r
+ pli(cpt_pli):=a2_jeu(remember).c;\r
+ a2_jeu(remember).present:=false;\r
+ fi;\r
+ if remember<>0\r
+ then\r
+ if a2_jeu(remember).c.couleur=atout\r
+ then\r
+ atout_joue(a2_jeu(remember).c.valeur):=true;\r
+ fi;\r
+ fi;\r
+\r
+\r
+ pli(cpt_pli).x:=190;\r
+ pli(cpt_pli).y:=170;\r
+ call pli(cpt_pli).print; \r
+ for i:=1 to 30000 do od;\r
+\r
+end jouer_carte;\r
+\r
+begin\r
+ return;\r
+\r
+ call donne1;\r
+ if not(on_prend)\r
+ then\r
+ call tour1;\r
+ fi;\r
+(* 2ieme tour *) \r
+ if not(on_prend)\r
+ then\r
+ call tour2;\r
+ fi;\r
+ if on_prend\r
+ then\r
+ call donne2;\r
+ for n:=1 to 8\r
+ do\r
+ call jouer_carte;\r
+ attach(main);\r
+ od;\r
+ fi;\r
+\r
+ attach(main);\r
+end adversaire2;\r
+\r
+(* *********************** fin des coroutines ************************* *)\r
+\r
+\r
+ (*************************************)\r
+ (* On coupe le jeu de cartes *) \r
+ (*************************************) \r
+\r
+\r
+Unit COUPE_JEU : procedure;\r
+var i,j : integer,\r
+ tmp1,tmp2 : pile;\r
+begin\r
+ tmp1:=new pile;\r
+ tmp2:=new pile;\r
+ call RANSET(1000);\r
+ i:=entier(RANDOM*32);\r
+ if i<3 or i>29\r
+ then\r
+ i:=15;\r
+ fi;\r
+ for j:=1 to i\r
+ do\r
+ call tmp1.push(s.pop);\r
+ od;\r
+ while not s.empty\r
+ do\r
+ call tmp2.push(s.pop);\r
+ od;\r
+ while not tmp1.empty\r
+ do\r
+ call s.push(tmp1.pop);\r
+ od;\r
+ while not tmp2.empty\r
+ do\r
+ call s.push(tmp2.pop);\r
+ od;\r
+ kill(tmp1);\r
+ kill(tmp2);\r
+\r
+end coupe_jeu;\r
+\r
+\r
+ (*************************************)\r
+ (* Melange du jeu de cartes *) \r
+ (*************************************) \r
+\r
+Unit MELANGE : procedure;\r
+var\r
+ tab : arrayof carte,\r
+ tampon : carte,\r
+ a,b,i,j,attente : integer;\r
+\r
+begin\r
+ array tab dim(0:31);\r
+ tab(0):=P1;\r
+ tab(1):=P2;\r
+ tab(2):=P3;\r
+ tab(3):=P4;\r
+ tab(4):=P5;\r
+ tab(5):=P6;\r
+ tab(6):=P7;\r
+ tab(7):=P8;\r
+ tab(8):=T1;\r
+ tab(9):=T2;\r
+ tab(10):=T3;\r
+ tab(11):=T4;\r
+ tab(12):=T5;\r
+ tab(13):=T6;\r
+ tab(14):=T7;\r
+ tab(15):=T8;\r
+ tab(16):=CA1;\r
+ tab(17):=CA2;\r
+ tab(18):=CA3;\r
+ tab(19):=CA4;\r
+ tab(20):=CA5;\r
+ tab(21):=CA6;\r
+ tab(22):=CA7;\r
+ tab(23):=CA8;\r
+ tab(24):=CO1;\r
+ tab(25):=CO2;\r
+ tab(26):=CO3;\r
+ tab(27):=CO4;\r
+ tab(28):=CO5;\r
+ tab(29):=CO6;\r
+ tab(30):=CO7;\r
+ tab(31):=CO8;\r
+ for a:=1 to 10\r
+ do\r
+ call RANSET(1000);\r
+ i:=entier(RANDOM*10);\r
+ for attente:=1 to 2000 do od;\r
+ call RANSET(1500);\r
+ j:=entier(RANDOM*10);\r
+ for b:=1 to 15\r
+ do\r
+ tampon:=tab(i);\r
+ tab(i):=tab((i+j) mod 31);\r
+ tab((i+j) mod 31):=tampon;\r
+ i:=(i+4) mod 31;\r
+ j:=(j+3) mod 31;\r
+ tampon:=tab(i);\r
+ tab(i):=tab((i+j) mod 31);\r
+ tab((i+j) mod 31):=tampon;\r
+ i:=(i+1) mod 31;\r
+ j:=(j+7) mod 31;\r
+ od;\r
+ od;\r
+ for a:=0 to 31 \r
+ do\r
+ call s.push(tab(a));\r
+ od;\r
+\r
+end melange;\r
+\r
+ (**************************************************)\r
+ (* Renvoie la valeur de l'atout le plus fort *) \r
+ (* qui n'a pas encore ete joue *)\r
+ (**************************************************) \r
+\r
+Unit AT_FORT : function : integer;\r
+begin\r
+ if not atout_joue(valet)\r
+ then\r
+ result:=valet;\r
+ else\r
+ if not atout_joue(neuf)\r
+ then\r
+ result:=neuf;\r
+ else\r
+ for i:=8 downto 1\r
+ do\r
+ if not atout_joue(i)\r
+ then\r
+ result:=i;\r
+ fi;\r
+ od;\r
+ fi;\r
+ fi;\r
+end at_fort;\r
+\r
+\r
+\r
+\r
+ (**************************************************)\r
+ (* Ordre de croissance des cartes a l'atout *) \r
+ (* --> retourne vrai si c1>c2 *)\r
+ (**************************************************) \r
+\r
+Unit COMPARE_ATOUT : function(c1,c2 : integer): boolean;\r
+begin\r
+ if c1=valet\r
+ then \r
+ result:=true;\r
+ else \r
+ if c2=valet\r
+ then\r
+ result:=false;\r
+ else\r
+ if c1=neuf\r
+ then \r
+ result:=true;\r
+ else \r
+ if c2=neuf\r
+ then\r
+ result:=false;\r
+ else\r
+ (* il n'y a ni valet ni neuf *)\r
+ if c1>c2\r
+ then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+end compare_atout;\r
+\r
+ (**************************************************)\r
+ (* Attribue une valeur pour chaque carte *) \r
+ (**************************************************) \r
+ \r
+Unit EVALUE : function(c : carte): integer;\r
+begin\r
+ case c.valeur\r
+ when sept : result:=5;\r
+ when huit : result:=7;\r
+ when dame : result:=10;\r
+ when roi : result:=13;\r
+ when dix : result:=15;\r
+ when as : result:=18;\r
+ when neuf : result:=22;\r
+ when valet: result:=30;\r
+ esac;\r
+end evalue;\r
+\r
+ (**************************************************)\r
+ (* Attribue une valeur pour chaque carte *) \r
+ (**************************************************) \r
+ \r
+Unit EVALUE2 : function(c : carte): integer;\r
+begin\r
+ case c.valeur\r
+ when sept : result:=4;\r
+ when huit : result:=4;\r
+ when dame : result:=6;\r
+ when roi : result:=6;\r
+ when dix : result:=10;\r
+ when as : result:=15;\r
+ when neuf : result:=15;\r
+ when valet: result:=25;\r
+ esac;\r
+end evalue2;\r
+\r
+ (*************************************)\r
+ (* Affichage du menu *)\r
+ (*************************************) \r
+\r
+Unit PREMIER_MENU : procedure;\r
+begin\r
+ b_option:=new bouton_relief(280,140,360,180,6,"Option");\r
+ b_debut:=new bouton_relief(280,200,360,240,5,"Jouer");\r
+ b_fin:=new bouton_relief(280,260,360,300,7,"Quitter");\r
+ call patern(220,50,420,320,gris_clair,plein);\r
+ call patern(220,50,420,320,gris_fonce,vide);\r
+ call patern(221,51,419,51,gris_fonce,plein);\r
+ call patern(222,52,418,52,gris_fonce,plein);\r
+ call patern(221,51,221,319,gris_fonce,plein);\r
+ call patern(222,52,222,318,gris_fonce,plein);\r
+ call patern(419,51,419,319,gris_fonce,plein);\r
+ call patern(418,52,418,318,gris_fonce,plein);\r
+ call patern(221,319,419,319,gris_fonce,plein);\r
+ call patern(222,318,418,318,gris_fonce,plein);\r
+ \r
+ call outstring(293,70,"M E N U",noir,gris_clair);\r
+ call patern(285,85,355,85,noir,plein);\r
+ call outstring(275,90 ,"JYL & REDGE ",noir,gris_clair);\r
+ call outstring(275,105," 1995 ",noir,gris_clair);\r
+ call b_option.print;\r
+ call b_debut.print;\r
+ call b_fin.print;\r
+ call patern(0,0,640,40,gris_clair,plein);\r
+ (* affichage des bandes de commentaires en gris du haut *)\r
+ call move(0,20);\r
+ call color(noir);\r
+ call draw(640,20);\r
+ call move(0,40);\r
+ call draw(640,40);\r
+ call outstring(270,4,"B-E-L-O-T-E",noir,gris_clair);\r
+ (* sauvegarde menu *)\r
+ call move(100,50);\r
+ save_menu:=getmap(540,370);\r
+ call menu;\r
+end premier_menu;\r
+\r
+\r
+ (*************************************)\r
+ (* MENU *)\r
+ (*************************************) \r
+\r
+Unit MENU : procedure;\r
+var h,v,p,l,r,c : integer,\r
+ d : boolean;\r
+begin\r
+ call move(100,50);\r
+ call putmap(save_menu);\r
+ d:=false;\r
+ do\r
+ d:=getpress(h,v,p,l,r,c);\r
+ case (c)\r
+ when 1 : \r
+ if b_option.dedans(h,v)\r
+ then\r
+ call b_option.choix;\r
+ call option;\r
+ else\r
+ if b_debut.dedans(h,v)\r
+ then\r
+ call b_debut.choix;\r
+ (* affichage des bandes de commentaires en gris du haut *)\r
+ call move(0,20);\r
+ call color(noir);\r
+ call draw(640,20);\r
+ call move(0,40);\r
+ call draw(640,40);\r
+ call outstring(270,2,"B-E-L-O-T-E",noir,gris_clair);\r
+ call move(219,49);\r
+ call putmap(del_menu);\r
+ exit;\r
+ else\r
+ if b_fin.dedans(h,v)\r
+ then\r
+ call b_fin.choix;\r
+ termine:=true;\r
+ call fermeture;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ esac\r
+ od;\r
+end menu; \r
+\r
+ (*************************************)\r
+ (* SOUS-MENU *)\r
+ (*************************************) \r
+ \r
+Unit OPTION : procedure;\r
+var h,v,p,l,r,c,i : integer,\r
+ op1,op2,op3 : bouton_enfonce,\r
+ valide : bouton_relief,\r
+ d : boolean;\r
+begin\r
+ op1:=new bouton_enfonce(210,200,270,240,3,"5OO");\r
+ op2:=new bouton_enfonce(290,200,350,240,4,"1OOO");\r
+ op3:=new bouton_enfonce(370,200,430,240,4,"15OO");\r
+ valide:=new bouton_relief(280,255,360,295,2,"OK");\r
+ call patern(190,130,450,310,gris_clair,plein);\r
+ call patern(190,130,450,310,noir,vide);\r
+\r
+ call patern(191,131,449,131,blanc,plein);\r
+ call patern(192,132,448,132,blanc,plein);\r
+ call patern(191,131,191,309,blanc,plein);\r
+ call patern(192,132,192,308,blanc,plein);\r
+\r
+ call patern(449,131,449,309,gris_fonce,plein);\r
+ call patern(448,132,448,308,gris_fonce,plein);\r
+ call patern(191,309,449,309,gris_fonce,plein);\r
+ call patern(192,308,448,308,gris_fonce,plein);\r
+\r
+\r
+ call outstring(260,145,"Nombre de points",noir,gris_clair);\r
+ call outstring(260,165," par partie",noir,gris_clair);\r
+ call op1.choix;\r
+ call op2.print;\r
+ call op3.print;\r
+ call valide.print;\r
+\r
+ d:=false;\r
+ do\r
+ d:=getpress(h,v,p,l,r,c);\r
+ case (c)\r
+ when 1 : \r
+ if op1.dedans(h,v)\r
+ then\r
+ call op1.choix;\r
+ call op2.print;\r
+ call op3.print;\r
+ total:=300;\r
+ fi;\r
+ if op2.dedans(h,v)\r
+ then\r
+ call op1.print;\r
+ call op2.choix;\r
+ call op3.print;\r
+ total:=1000;\r
+ fi;\r
+ if op3.dedans(h,v)\r
+ then\r
+ call op1.print;\r
+ call op2.print;\r
+ call op3.choix;\r
+ total:=1500;\r
+ fi;\r
+ if valide.dedans(h,v)\r
+ then\r
+ call valide.choix;\r
+ for i:=1 to 5000 do od;\r
+ call move(100,50);\r
+ call putmap(save_menu);\r
+ exit;\r
+ fi;\r
+\r
+ esac\r
+ od;\r
+end option; \r
+\r
+\r
+ (*************************************)\r
+ (* Calcul du score pour *)\r
+ (* chaque equipe *)\r
+ (*************************************) \r
+ \r
+Unit CALCUL_SCORE : procedure;\r
+var s1,s2,i,attente : integer,\r
+ dedans,capot : boolean;\r
+\r
+begin\r
+ s1:=0;\r
+ s2:=0;\r
+ (* prise en compte du 10 de der *)\r
+ if commence=1 or commence=3\r
+ then\r
+ s1:=s1+10;\r
+ else\r
+ s2:=s2+10;\r
+ fi;\r
+ \r
+ while not(e1.empty) \r
+ do\r
+ if e1.sommet.valeur.couleur=atout and e1.sommet.valeur.valeur=valet\r
+ then\r
+ s1:=s1+20;\r
+ else\r
+ if e1.sommet.valeur.couleur=atout and e1.sommet.valeur.valeur=neuf\r
+ then\r
+ s1:=s1+14;\r
+ else\r
+ case e1.sommet.valeur.valeur\r
+ when dix : s1:=s1+10;\r
+ when valet : s1:=s1+2;\r
+ when dame : s1:=s1+3;\r
+ when roi : s1:=s1+4;\r
+ when as : s1:=s1+11;\r
+ esac;\r
+ fi;\r
+ fi;\r
+ call e11.push(e1.pop);\r
+ od;\r
+ while not(e2.empty) \r
+ do\r
+ if e2.sommet.valeur.couleur=atout and e2.sommet.valeur.valeur=valet\r
+ then\r
+ s2:=s2+20;\r
+ else\r
+ if e2.sommet.valeur.couleur=atout and e2.sommet.valeur.valeur=neuf\r
+ then\r
+ s2:=s2+14;\r
+ else\r
+ case e2.sommet.valeur.valeur\r
+ when dix : s2:=s2+10;\r
+ when valet : s2:=s2+2;\r
+ when dame : s2:=s2+3;\r
+ when roi : s2:=s2+4;\r
+ when as : s2:=s2+11;\r
+ esac;\r
+ fi;\r
+ fi;\r
+ call e22.push(e2.pop);\r
+ od;\r
+ dedans:=false;\r
+ capot:=false;\r
+ if (s1=0)\r
+ then \r
+ score2:=score2+250;\r
+ capot:=true;\r
+ call outstring(270,22,"Equipe1 est capot",noir,gris_clair);\r
+ for i:=1 to 40000 do od;\r
+ call outstring(270,22," ",noir,gris_clair); \r
+ else\r
+ if (s2=0)\r
+ then \r
+ score1:=score1+250;\r
+ capot:=true;\r
+ call outstring(270,22,"Equipe2 est capot",noir,gris_clair);\r
+ for i:=1 to 40000 do od;\r
+ call outstring(270,22," ",noir,gris_clair); \r
+\r
+ else\r
+ if joueur_prend or part_prend\r
+ then\r
+ if s1<s2\r
+ then\r
+ score2:=score2+162;\r
+ call outstring(255,22,"Equipe1 est dedans",noir,gris_clair);\r
+ for i:=1 to 40000 do od;\r
+ call outstring(255,22," ",noir,gris_clair); \r
+ dedans:=true;\r
+ fi;\r
+ else \r
+ if s2<s1\r
+ then\r
+ score1:=score1+162;\r
+ call outstring(255,22,"Equipe2 est dedans",noir,gris_clair);\r
+ for i:=1 to 40000 do od;\r
+ call outstring(255,22," ",noir,gris_clair); \r
+ dedans:=true; \r
+ fi;\r
+ fi;\r
+ fi;\r
+ if not dedans and not capot\r
+ then\r
+ score1:=score1+s1;\r
+ score2:=score2+s2;\r
+ fi;\r
+ fi;\r
+ if belote_joueur or belote_partenaire\r
+ then\r
+ score1:=score1+20;\r
+ call outstring(210,25,"Equipe1 avait la belote",noir,gris_clair);\r
+ for attente:=1 to 30000 do od;\r
+ call outstring(210,25," ",noir,gris_clair); \r
+ fi;\r
+ if belote_adversaire1 or belote_adversaire2\r
+ then\r
+ score2:=score2+20;\r
+ call outstring(210,25,"Equipe2 avait la belote",noir,gris_clair);\r
+ for attente:=1 to 30000 do od;\r
+ call outstring(210,25," ",noir,gris_clair); \r
+ fi;\r
+ \r
+\r
+\r
+end CALCUL_SCORE;\r
+\r
+\r
+ (*************************************)\r
+ (* mise_a_jour des plis *)\r
+ (* par equipe *)\r
+ (*************************************) \r
+ \r
+\r
+Unit MAJ_PLI : procedure;\r
+var i : integer;\r
+begin\r
+ if commence=1 or commence=3\r
+ then \r
+ for i:=1 to 4\r
+ do\r
+ call e1.push(pli(i));\r
+ od;\r
+ else \r
+ for i:=1 to 4\r
+ do\r
+ call e2.push(pli(i));\r
+ od;\r
+ fi;\r
+ \r
+end maj_pli;\r
+\r
+ (*************************************)\r
+ (* Qui a fait le pli ? *) \r
+ (*************************************) \r
+\r
+Unit EVALUE_PLI : function : integer;\r
+var\r
+ i,gagnant : integer;\r
+ \r
+begin\r
+ gagnant:=0;\r
+ for i:=1 to 4\r
+ do\r
+ if pli(i).couleur=atout and pli(i).valeur=valet\r
+ then gagnant:=i;\r
+ fi;\r
+ od;\r
+ if gagnant=0\r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if pli(i).couleur=atout and pli(i).valeur=neuf\r
+ then gagnant:=i;\r
+ fi;\r
+ od;\r
+ fi;\r
+ if gagnant=0\r
+ then\r
+ for i:=1 to 4\r
+ do\r
+ if pli(i).couleur=atout\r
+ then\r
+ if gagnant<>0\r
+ then\r
+ if pli(gagnant).valeur<pli(i).valeur\r
+ then gagnant:=i;\r
+ fi;\r
+ else gagnant:=i;\r
+ fi;\r
+ fi;\r
+ od;\r
+ fi; \r
+ if gagnant=0\r
+ then\r
+ gagnant:=1;\r
+ for i:=1 to 4\r
+ do\r
+ if pli(i).couleur=pli(gagnant).couleur\r
+ and pli(i).valeur>pli(gagnant).valeur\r
+ then gagnant:=i;\r
+ fi;\r
+ od;\r
+ fi;\r
+ result:=gagnant;\r
+end EVALUE_PLI;\r
+\r
+ (*******************************************************)\r
+ (* On remet les cartes des joueurs dans le jeu *) \r
+ (*******************************************************) \r
+\r
+Unit PERSONNE_A_PRIS : procedure;\r
+var\r
+ i : integer;\r
+begin\r
+ for i:=1 to 5\r
+ do \r
+ call s.push(j_jeu(i).c);\r
+ od;\r
+ for i:=1 to 5\r
+ do \r
+ call s.push(a1_jeu(i).c);\r
+ od;\r
+ for i:=1 to 5\r
+ do \r
+ call s.push(p_jeu(i).c);\r
+ od;\r
+ for i:=1 to 5\r
+ do \r
+ call s.push(a2_jeu(i).c);\r
+ od;\r
+ call s.push(carte_ret);\r
+end personne_a_pris;\r
+\r
+ (*************************************)\r
+ (* Affichage des atouts *) \r
+ (*************************************) \r
+\r
+Unit affiche_atout : procedure;\r
+var i : integer;\r
+begin\r
+ call patern(180,395,460,460,gris_clair,plein);\r
+ call patern(180,395,460,395,blanc,plein); \r
+ call patern(181,396,459,396,blanc,plein); \r
+ call patern(180,395,180,460,blanc,plein); \r
+ call patern(181,396,181,459,blanc,plein); \r
+\r
+ call patern(182,397,458,397,blanc,plein); \r
+ call patern(182,397,182,458,blanc,plein); \r
+ call patern(458,397,458,458,gris_fonce,plein); \r
+ call patern(182,458,458,458,gris_fonce,plein); \r
+\r
+ call patern(180,460,460,460,gris_fonce,plein); \r
+ call patern(181,459,459,459,gris_fonce,plein); \r
+ call patern(460,395,460,460,gris_fonce,plein); \r
+ call patern(459,396,459,459,gris_fonce,plein); \r
+ call outstring(200,400," 7 ",noir,blanc); \r
+ call outstring(230,400," 8 ",noir,blanc); \r
+ call outstring(260,400," 9 ",noir,blanc); \r
+ call outstring(290,400," V ",noir,blanc); \r
+ call outstring(320,400," D ",noir,blanc); \r
+ call outstring(350,400," R ",noir,blanc); \r
+ call outstring(380,400," 10 ",noir,blanc); \r
+ call outstring(410,400," A ",noir,blanc); \r
+ for i:=1 to 8\r
+ do\r
+ if atout_joue(i)\r
+ then \r
+ call patern(200+(i-1)*30,420,200+i*30,450,gris_fonce,plein);\r
+ fi;\r
+ call patern(200+(i-1)*30,420,200+i*30,450,noir,vide);\r
+ od;\r
+ for i:=1 to 100000 do od;\r
+end affiche_atout;\r
+\r
+ (*************************************)\r
+ (* Affichage du score *) \r
+ (*************************************) \r
+ \r
+Unit AFFICHE_SCORE : procedure;\r
+begin\r
+ call outstring(500,2,"Equipe 1 :",noir,gris_clair);\r
+ call track(600,2,score1,gris_clair,noir);\r
+ call outstring(500,22,"Equipe 2 :",noir,gris_clair);\r
+ call track(600,22,score2,gris_clair,noir);\r
+end affiche_score;\r
+\r
+ (*************************************)\r
+ (* Affichage du vainqueur *) \r
+ (*************************************) \r
+ \r
+Unit AFFICHE_VAINQUEUR : procedure;\r
+var \r
+ d : boolean,\r
+ h,v,p,l,r,c : integer,\r
+ ok : bouton_relief;\r
+\r
+begin\r
+ ok:=new bouton_relief(270,150,370,190,4,"O.K.");\r
+ call move(0,0);\r
+ call putmap(depart);\r
+ if score1<score2\r
+ then\r
+ call outstring(240,22,"Vainqueur : Equipe2",noir,gris_clair);\r
+ else\r
+ if score1>score2\r
+ then\r
+ call outstring(240,22,"Vainqueur : Equipe1",noir,gris_clair);\r
+ else\r
+ (* on ne sait jamais ... *)\r
+ call outstring(240,22," Match nul !",noir,gris_clair);\r
+ fi;\r
+ fi;\r
+ call affiche_score;\r
+ call ok.print;\r
+ d:=false;\r
+ do\r
+ d:=getpress(h,v,p,l,r,c);\r
+ case (c)\r
+ when 1 : \r
+ if ok.dedans(h,v)\r
+ then\r
+ call ok.choix;\r
+ call move(0,0);\r
+ call putmap(depart);\r
+ call MENU; \r
+ exit;\r
+ fi;\r
+ esac\r
+ od;\r
+\r
+end affiche_vainqueur;\r
+ \r
+\r
+ (***************************************)\r
+ (* Affichage du tapis de cart *) \r
+ (***************************************) \r
+\r
+Unit Affiche_tapis : procedure;\r
+begin\r
+ call patern(160,90,480,350,25,plein);\r
+ call patern(160,90,480,350,gris_fonce,vide);\r
+ call patern(161,91,479,349,gris_fonce,vide);\r
+ call intens(4,tx,ty,26,plein);\r
+ call coeur(170,95);\r
+ call carreau(445,290);\r
+ call pic(170,290);\r
+ call trefle(445,95);\r
+end affiche_tapis;\r
+\r
+ (***************************************)\r
+ (* Initialisation de l'ecran *) \r
+ (***************************************) \r
+ \r
+Unit INIT_ECRAN : procedure;\r
+var nord,est,ouest:bouton_relief;\r
+begin\r
+ nord:=new bouton_relief(280,49,360,79,4,"NORD");\r
+ est:=new bouton_relief(540,195,620,235,3,"EST");\r
+ ouest:=new bouton_relief(20,195,100,235,5,"OUEST");\r
+ call patern(0,0,640,40,gris_clair,plein);\r
+ (* affichage des bandes de commentaires en gris du haut *)\r
+ call move(0,20);\r
+ call color(noir);\r
+ call draw(640,20);\r
+ call move(0,40);\r
+ call draw(640,40);\r
+ call outstring(270,2,"B-E-L-O-T-E",noir,gris_clair);\r
+ call nord.print;\r
+ call est.print;\r
+ call ouest.print;\r
+ call move(0,41);\r
+ terrain:=getmap(640,361);\r
+ (* sauvegarde de l'ecran *)\r
+ call move(0,0);\r
+ depart:=getmap(640,480);\r
+end init_ecran;\r
+\r
+ (*****************************************************)\r
+ (* Initialisation diverses (cartes, jeu...) *) \r
+ (*****************************************************) \r
+\r
+Unit INITIALISATION : procedure;\r
+var i : integer;\r
+begin\r
+ P1:=new carte(P,sept); \r
+ P2:=new carte(P,huit);\r
+ P3:=new carte(P,neuf); \r
+ P4:=new carte(P,dix);\r
+ P5:=new carte(P,valet); \r
+ P6:=new carte(P,dame);\r
+ P7:=new carte(P,roi); \r
+ P8:=new carte(P,as);\r
+ T1:=new carte(T,sept); \r
+ T2:=new carte(T,huit);\r
+ T3:=new carte(T,neuf); \r
+ T4:=new carte(T,dix);\r
+ T5:=new carte(T,valet); \r
+ T6:=new carte(T,dame);\r
+ T7:=new carte(T,roi); \r
+ T8:=new carte(T,as);\r
+ CA1:=new carte(CA,sept); \r
+ CA2:=new carte(CA,huit);\r
+ CA3:=new carte(CA,neuf); \r
+ CA4:=new carte(CA,dix);\r
+ CA5:=new carte(CA,valet); \r
+ CA6:=new carte(CA,dame);\r
+ CA7:=new carte(CA,roi); \r
+ CA8:=new carte(CA,as);\r
+ CO1:=new carte(CO,sept); \r
+ CO2:=new carte(CO,huit);\r
+ CO3:=new carte(CO,neuf); \r
+ CO4:=new carte(CO,dix);\r
+ CO5:=new carte(CO,valet); \r
+ CO6:=new carte(CO,dame);\r
+ CO7:=new carte(CO,roi); \r
+ CO8:=new carte(CO,as);\r
+ s:=new pile;\r
+ e1:=new pile;\r
+ e2:=new pile;\r
+ e11:=new pile;\r
+ e22:=new pile;\r
+ b_aide_atout:=new bouton_relief(600,420,630,450,1,"?");\r
+ user:=new joueur;\r
+ part:=new partenaire;\r
+ adv1:=new adversaire1;\r
+ adv2:=new adversaire2;\r
+ array j_jeu dim(1:8);\r
+ array p_jeu dim(1:8);\r
+ array a1_jeu dim(1:8);\r
+ array a2_jeu dim(1:8);\r
+ array pli dim(1:4);\r
+ array atout_joue dim(1:8);\r
+ for i:=1 to 8\r
+ do \r
+ j_jeu(i):=new carte_user;\r
+ p_jeu(i):=new carte_user;\r
+ a1_jeu(i):=new carte_user;\r
+ a2_jeu(i):=new carte_user;\r
+ atout_joue(i):=false;\r
+ od;\r
+ for i:=1 to 4\r
+ do \r
+ pli(i):=new carte(P,SEPT);\r
+ od;\r
+ array tx dim(1:4);\r
+ array ty dim(1:4);\r
+ tx(1):=320;\r
+ tx(2):=162;\r
+ tx(3):=320;\r
+ tx(4):=478;\r
+ ty(1):=92;\r
+ ty(2):=220;\r
+ ty(3):=348;\r
+ ty(4):=220;\r
+\r
+end initialisation;\r
+\r
+ (*****************************************)\r
+ (* Initialisation des variables *) \r
+ (*****************************************) \r
+\r
+Unit INIT_VARIABLES : procedure;\r
+var i : integer;\r
+begin\r
+ s:=new pile;\r
+ e1:=new pile;\r
+ e2:=new pile;\r
+ e11:=new pile;\r
+ e22:=new pile;\r
+ user:=new joueur;\r
+ part:=new partenaire;\r
+ adv1:=new adversaire1;\r
+ adv2:=new adversaire2;\r
+ array pli dim(1:4);\r
+ for i:=1 to 8\r
+ do \r
+ j_jeu(i):=new carte_user;\r
+ p_jeu(i):=new carte_user;\r
+ a1_jeu(i):=new carte_user;\r
+ a2_jeu(i):=new carte_user;\r
+ od;\r
+ for i:=1 to 4\r
+ do \r
+ pli(i):=new carte(P,SEPT);\r
+ od;\r
+ score1:=0;\r
+ score2:=0;\r
+ tour:=1;\r
+ for i:=1 to 8\r
+ do \r
+ j_jeu(i):=new carte_user;\r
+ p_jeu(i):=new carte_user;\r
+ a1_jeu(i):=new carte_user;\r
+ a2_jeu(i):=new carte_user;\r
+ od;\r
+ for i:=1 to 4\r
+ do \r
+ pli(i):=new carte(P,SEPT);\r
+ od;\r
+\r
+\r
+end init_variables;\r
+\r
+\r
+ (******************************************************)\r
+ (* Distribue 5 cartes pour chaque joueur puis *)\r
+ (* retourne une carte *)\r
+ (******************************************************) \r
+\r
+Unit DISTRIBUE_1 : procedure;\r
+begin\r
+ (* on desire distribuer les cartes *)\r
+ case tour\r
+ when 1 : attach(user);\r
+ when 2 : attach(adv1);\r
+ when 3 : attach(part);\r
+ when 4 : attach(adv2);\r
+ esac;\r
+ \r
+ call move(0,0);\r
+ image:=getmap(640,480);\r
+(* on retourne une carte *)\r
+ carte_ret:=s.pop; \r
+ carte_ret.x:=295;\r
+ carte_ret.y:=190;\r
+ call carte_ret.print;\r
+end distribue_1;\r
+\r
+ (*********************************)\r
+ (* On demande qui veut prendre *)\r
+ (*********************************)\r
+\r
+Unit QUI_PREND : procedure;\r
+begin\r
+ case tour\r
+ when 1 : attach(user);\r
+ when 2 : attach(adv1);\r
+ when 3 : attach(part);\r
+ when 4 : attach(adv2);\r
+ esac;\r
+end qui_prend;\r
+\r
+ (*************************************************************)\r
+ (* On distribue les cartes restantes et on affiche l'atout *)\r
+ (*************************************************************)\r
+ \r
+Unit DISTRIBUE_2 : procedure;\r
+begin\r
+ (* on effectue la troisieme donne *)\r
+ case tour\r
+ when 1 : attach(user);\r
+ when 2 : attach(adv1);\r
+ when 3 : attach(part);\r
+ when 4 : attach(adv2);\r
+ esac;\r
+ (* on affiche l'atout *)\r
+ case atout\r
+ when 1 :\r
+ call outstring(2,5,"ATOUT PIC",noir,gris_clair);\r
+ when 2 :\r
+ call outstring(2,5,"ATOUT TREFLE",noir,gris_clair);\r
+ when 3 :\r
+ call outstring(2,5,"ATOUT CARREAU",noir,gris_clair);\r
+ when 4 :\r
+ call outstring(2,5,"ATOUT COEUR",noir,gris_clair);\r
+ esac;\r
+ if joueur_prend\r
+ then \r
+ call outstring(2,25,"Preneur : SUD",noir,gris_clair);\r
+ fi; \r
+ if adv1_prend\r
+ then \r
+ call outstring(2,25,"Preneur : EST",noir,gris_clair);\r
+ fi; \r
+ if part_prend\r
+ then \r
+ call outstring(2,25,"Preneur : NORD",noir,gris_clair);\r
+ fi; \r
+ if adv2_prend\r
+ then \r
+ call outstring(2,25,"Preneur : OUEST",noir,gris_clair);\r
+ fi; \r
+end distribue_2;\r
+\r
+ (*************************************)\r
+ (* Ouverture mode graphique *) \r
+ (*************************************) \r
+\r
+Unit OUVERTURE : procedure;\r
+begin\r
+ call gron(1);\r
+ call border(bleu_clair);\r
+ call cls;\r
+ (*for i:=32 to 40\r
+ do\r
+ call patern(300,300,100,100,i,plein);\r
+ call track(50,40,i,noir,blanc);\r
+ for attente:=1 to 10000 do od;\r
+ od;\r
+ *)\r
+ call cls;\r
+ call init(1,0);\r
+ call showcursor;\r
+ call move(219,49);\r
+ del_menu:=getmap(421,361);\r
+ call move(150,80);\r
+ image2:=getmap(500,360);\r
+end OUVERTURE;\r
+\r
+ (*************************************)\r
+ (* Fermeture mode graphique *) \r
+ (*************************************) \r
+ \r
+Unit FERMETURE : procedure;\r
+begin\r
+ call groff;\r
+end FERMETURE;\r
+\r
+ (******************************************************************)\r
+ (* debut PROGRAMME PRINCIPAL *) \r
+ (******************************************************************) \r
+\r
+\r
+\r
+begin\r
+\r
+call OUVERTURE;\r
+total:=defaut;\r
+termine:=false;\r
+call initialisation;\r
+call init_ecran;\r
+call premier_menu;\r
+while not termine\r
+do\r
+ call init_variables;\r
+ call melange;\r
+ call move(0,0);\r
+ call putmap(depart);\r
+ call affiche_score;\r
+\r
+ while score1<total and score2<total\r
+ do\r
+ call coupe_jeu;\r
+ if tour=5 \r
+ then\r
+ tour:=1;\r
+ fi;\r
+ case tour\r
+ when 1 : \r
+ call outstring(270,22,"OUEST distribue...",noir,gris_clair);\r
+ when 2 : \r
+ call outstring(275,22,"SUD distribue...",noir,gris_clair);\r
+ when 3 : \r
+ call outstring(275,22,"EST distribue...",noir,gris_clair);\r
+ when 4 : \r
+ call outstring(270,22,"NORD distribue...",noir,gris_clair);\r
+ esac;\r
+ for attente:=1 to 30000 do od;\r
+ call outstring(270,22," ",noir,gris_clair);\r
+ call distribue_1;\r
+ call qui_prend;\r
+ if on_prend\r
+ then\r
+ call distribue_2;\r
+ cpt_pli:=1;\r
+ commence:=tour;\r
+ call affiche_tapis;\r
+ case commence\r
+ when 1 :\r
+ attach(user);\r
+ cpt_pli:=2;\r
+ attach(adv1);\r
+ cpt_pli:=3;\r
+ attach(part);\r
+ cpt_pli:=4;\r
+ attach(adv2);\r
+ when 2 :\r
+ attach(adv1);\r
+ cpt_pli:=2;\r
+ attach(part);\r
+ cpt_pli:=3;\r
+ attach(adv2);\r
+ cpt_pli:=4;\r
+ attach(user);\r
+ when 3 :\r
+ attach(part);\r
+ cpt_pli:=2;\r
+ attach(adv2);\r
+ cpt_pli:=3;\r
+ attach(user);\r
+ cpt_pli:=4;\r
+ attach(adv1);\r
+ when 4 :\r
+ attach(adv2);\r
+ cpt_pli:=2;\r
+ attach(user);\r
+ cpt_pli:=3;\r
+ attach(adv1);\r
+ cpt_pli:=4;\r
+ attach(part);\r
+ esac;\r
+ (* on a effectue le premier pli *)\r
+ k:=2;\r
+ while k<=nb_pli \r
+ do\r
+ for i:=1 to 20000 do od;\r
+ eval:=EVALUE_PLI;\r
+ eval:=(eval+commence-1) mod 4;\r
+ if eval=0 then eval:=4 fi;\r
+ commence:=eval;\r
+ call maj_pli;\r
+ call move(150,80);\r
+ call putmap(image2);\r
+ call affiche_tapis;\r
+ cpt_pli:=1; \r
+ case commence\r
+ when 1 :\r
+ call outstring(240,22,"SUD remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(240,22," ",noir,gris_clair);\r
+ attach(user);\r
+ cpt_pli:=2;\r
+ attach(adv1);\r
+ cpt_pli:=3;\r
+ attach(part);\r
+ cpt_pli:=4;\r
+ attach(adv2);\r
+\r
+ when 2 :\r
+ call outstring(235,22,"EST remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(235,22," ",noir,gris_clair);\r
+ attach(adv1);\r
+ cpt_pli:=2;\r
+ attach(part);\r
+ cpt_pli:=3;\r
+ attach(adv2);\r
+ cpt_pli:=4;\r
+ attach(user);\r
+ \r
+ when 3 :\r
+ call outstring(240,22,"NORD remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(240,22," ",noir,gris_clair);\r
+ attach(part);\r
+ cpt_pli:=2;\r
+ attach(adv2);\r
+ cpt_pli:=3;\r
+ attach(user);\r
+ cpt_pli:=4;\r
+ attach(adv1);\r
+\r
+ when 4 :\r
+ call outstring(230,22,"OUEST remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(230,22," ",noir,gris_clair);\r
+ attach(adv2);\r
+ cpt_pli:=2;\r
+ attach(user);\r
+ cpt_pli:=3;\r
+ attach(adv1);\r
+ cpt_pli:=4;\r
+ attach(part);\r
+ esac;\r
+ k:=k+1;\r
+ od;\r
+ for i:=1 to 8\r
+ do\r
+ atout_joue(i):=false;\r
+ od;\r
+ eval:=EVALUE_PLI;\r
+ eval:=(eval+commence-1) mod 4;\r
+ if eval=0 then eval:=4 fi;\r
+ commence:=eval;\r
+ call maj_pli;\r
+ case commence\r
+ when 1 :\r
+ call outstring(240,22,"SUD remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(240,22," ",noir,gris_clair);\r
+ when 2 :\r
+ call outstring(235,22,"EST remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(235,22," ",noir,gris_clair);\r
+ when 3 :\r
+ call outstring(240,22,"NORD remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(240,22," ",noir,gris_clair);\r
+ when 4 :\r
+ call outstring(230,22,"OUEST remporte le pli !",noir,gris_clair);\r
+ for attente:=1 to 35000 do od;\r
+ call outstring(230,22," ",noir,gris_clair);\r
+ esac;\r
+ call calcul_score;\r
+ (* on remet tous les plis dans le jeu s *)\r
+ while not(e11.empty)\r
+ do\r
+ call s.push(e11.pop);\r
+ od;\r
+ while not(e22.empty)\r
+ do\r
+ call s.push(e22.pop);\r
+ od;\r
+ \r
+ on_prend:=false;\r
+ joueur_prend:=false;\r
+ adv1_prend:=false;\r
+ part_prend:=false;\r
+ adv2_prend:=false;\r
+ else\r
+ call personne_a_pris;\r
+ fi;\r
+ user:=new joueur;\r
+ part:=new partenaire;\r
+ adv1:=new adversaire1;\r
+ adv2:=new adversaire2;\r
+ call move(0,0);\r
+ call putmap(depart);\r
+ call affiche_score;\r
+ tour:=tour+1;\r
+\r
+ od;\r
+ call affiche_vainqueur;\r
+ \r
+od;\r
+ end; (* souris *)\r
+ end; (* IIUWgraph*)\r
+end;\r
+\r
--- /dev/null
+ program philos5;\r
+ \r
+ (********************************************************)\r
+ (* procedure qui efface l'\82cran *)\r
+ (********************************************************)\r
+ UNIT NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J");\r
+ END Newpage;\r
+ \r
+ \r
+ (********************************************************)\r
+ (* Processus gerant l'\82cran pour chaque philosophe *)\r
+ (********************************************************)\r
+ UNIT ecran : iiuwgraph process (n : integer);\r
+ const PI = 3.14159;\r
+ var compteur : integer,\r
+ xf, yf, xa, ya, ra, r, i : integer,\r
+ angle : real;\r
+ \r
+ (********************************************************)\r
+ (* procedure qui dessine une fourchette \85 l'\82cran *)\r
+ (********************************************************)\r
+ UNIT fourchette : procedure(num_phi, o, couleur : integer);\r
+ var r1, r2, r3, r4, x, y : integer,\r
+ angle : real;\r
+ begin\r
+ call color(couleur);\r
+ r1 := 30;\r
+ r2 := 15;\r
+ r3 := 15;\r
+ r4 := 15;\r
+ angle := (num_phi * 2 + o) * PI/5;\r
+ x := round((rt-50) *cos(angle) + xt);\r
+ y := round((rt-50) *sin(angle) + yt);\r
+ call move(x,y);\r
+ call draw(round(r1*cos(angle)+x), round(r1*sin(angle)+y));\r
+ call move(x,y);\r
+ call draw(round(r2*cos(angle+3*PI/4)+x),round(r2*sin(angle+3*PI/4)+y));\r
+ call move(x,y);\r
+ call draw(round(r3*cos(angle-3*PI/4)+x),round(r3*sin(angle-3*PI/4)+y));\r
+ call move(x,y);\r
+ call draw(round(r4*cos(angle+PI)+x),round(r4*sin(angle+PI)+y));\r
+ call color(7);\r
+ END fourchette;\r
+ \r
+ \r
+ (********************************************************)\r
+ (* procedure qui dessine un guardien \85 l'\82cran *)\r
+ (********************************************************)\r
+ \r
+ UNIT Guard : procedure(x,y,c:integer);\r
+ begin\r
+ call color(c);\r
+ call cirb(x, y, 15, 1, 0, 1, 1, 1, 1);\r
+ call move(x,y+15);\r
+ call draw(x,y+50);\r
+ \r
+ call draw(x-25,y+100);\r
+ call move(x,y+50);\r
+ call draw(x+25,y+100);\r
+ call move(x-25,y+25); call draw(x+25,y+25);\r
+ call cirb(x+25,y+25,5,0,0,1,1,1,1);\r
+ call cirb(x-25,y+25,5,0,0,1,1,1,1);\r
+ call move(x+25,y-20); call draw(x+25,y+95);\r
+ end Guard;\r
+ \r
+ (********************************************************)\r
+ (* procedure affichant les bulles dans lesquelles les *)\r
+ (* philosophes pourront \82crire leurs actions *)\r
+ (********************************************************)\r
+ UNIT bulles : procedure(n : integer);\r
+ var x1, x2, x3, y1, y2, y3, num, r1, r2, r3 : integer,\r
+ angle : real;\r
+ begin\r
+ num := n - 1;\r
+ angle := (2*num+1)*PI/5;\r
+ r1 := rt + 5;\r
+ r2 := r1 + 15;\r
+ r3 := r1 + 55;\r
+ x1 := round(r1*cos(angle) + xt);\r
+ y1 := round(r1*sin(angle) + yt);\r
+ x2 := round(r2*cos(angle + PI/64) + xt);\r
+ y2 := round(r2*sin(angle + PI/64) + yt);\r
+ x3 := round(r3*cos(angle - PI/64) + xt);\r
+ y3 := round(r3*sin(angle - PI/64) + yt);\r
+ call cirb(x1, y1, 5, 0, 0, 1, 0, 1, 1);\r
+ call cirb(x2, y2, 10, 0, 0, 1, 0, 1, 1);\r
+ call cirb(x3, y3, 35, 0, 0, 1, 0, 1, 1);\r
+ END bulles;\r
+ \r
+ (********************************************************)\r
+ (* procedure qui affiche les actions des philosophes *)\r
+ (********************************************************)\r
+ UNIT actionp : procedure(n, action : integer);\r
+ var x1, x2, x3, y1, y2, y3, num, r1, r2, r3, i, j : integer,\r
+ angle : real;\r
+ begin\r
+ num := n - 1;\r
+ angle := (2*num+1)*PI/5;\r
+ r1 := rt + 5;\r
+ r3 := r1 + 55;\r
+ x3 := round(r3*cos(angle - PI/64) + xt);\r
+ y3 := round(r3*sin(angle - PI/64) + yt);\r
+ j := x3 - 32;\r
+ i := y3 - 5;\r
+ call move(j,i);\r
+ case action\r
+ when 1: call outstring(" PENSER ");\r
+ when 2: call outstring(" RENTRER");\r
+ when 3: call outstring(" MANGER ");\r
+ \r
+ when 4: call outstring(" SORTIR ");\r
+ when 5: call outstring(" ANORMAL");\r
+ when 6: call outstring("G RENDUE");\r
+ call fourchette(n,0,14);\r
+ \r
+ \r
+ when 7: call outstring("D RENDUE");\r
+ call fourchette(n-1,0,14);\r
+ \r
+ \r
+ when 8: call outstring(" PARTIR ");\r
+ when 9: call outstring("G PRISE ");\r
+ call fourchette(n ,0,0);\r
+ \r
+ \r
+ when 10: call outstring("D PRISE ");\r
+ call fourchette(n-1,0,0);\r
+ \r
+ \r
+ when 11: call outstring("G REFUS ");\r
+ when 12: call outstring("D REFUS ");\r
+ esac;\r
+ call color(7);\r
+ END actionp;\r
+ \r
+ (*******************************************************)\r
+ (* procedure affichant un cercle *)\r
+ (*******************************************************)\r
+ UNIT cercle : procedure (x,y,r : integer);\r
+ var xp, yp, xn, yn, i : integer,\r
+ Dangle, angle : real;\r
+ begin\r
+ Dangle := 2*PI/100;\r
+ xp := r + x;\r
+ yp := yt;\r
+ for i := 0 to 100\r
+ do\r
+ angle := Dangle * i;\r
+ xn := round((r*cos(angle)) + x);\r
+ yn := round((r*sin(angle)) + y);\r
+ call move(xp, yp);\r
+ call draw(xn, yn);\r
+ xp := xn;\r
+ yp := yn;\r
+ od;\r
+ END cercle;\r
+ \r
+ unit table: procedure(xt,yt,rt : integer);\r
+ begin\r
+ (* affichage de la table *)\r
+ call cercle(xt, yt, rt);\r
+ (* affichage des assiettes *)\r
+ for i := 0 to 4\r
+ do\r
+ angle := ( (i*2)+1 ) *PI/5;\r
+ r := rt - ra - 5;\r
+ xa := round ( (r*cos(angle)) + xt);\r
+ ya := round ( (r*sin(angle)) + yt);\r
+ call color(2);\r
+ call cirb(xa, ya, ra, 0, 0, 1, 1, 1, 1);\r
+ call move(xa, ya);\r
+ call color(0);\r
+ call hascii (48 + (i-1) div 10);\r
+ call Hascii (48 + (i+1) mod 10);\r
+ call color(7);\r
+ od;\r
+ end table;\r
+ \r
+ UNIT finir : procedure;\r
+ begin\r
+ compteur := compteur + 1;\r
+ if compteur = 5\r
+ then call groff;\r
+ call endrun;\r
+ fi;\r
+ END finir;\r
+ \r
+ begin\r
+ call gron(1);\r
+ ra :=30;\r
+ return;\r
+ do\r
+ accept bulles, fourchette, finir,guard, table,actionp, cercle;\r
+ od;\r
+ END ecran;\r
+ \r
+ (*******************************************************)\r
+ (* processus philosophe *)\r
+ (*******************************************************)\r
+ UNIT philosophe : iiuwgraph process( node, num_phi : integer,\r
+ gardien : doorman, fourch_g, fourch_d : fork, e : ecran);\r
+ var i, compt_m : integer,\r
+ Goccupee, Doccupee : boolean;\r
+ \r
+ unit waitt : procedure(n:integer);\r
+ var j : integer;\r
+ begin\r
+ for j := 1 to n do od;\r
+ end waitt;\r
+ begin\r
+ return;\r
+ compt_m := 1;\r
+ call e.bulles(num_phi);\r
+ call e.actionp(num_phi, 1);\r
+ call waitt(1500);\r
+ while (compt_m < 3)\r
+ do\r
+ call gardien.dem_entrer(num_phi);\r
+ call e.actionp(num_phi, 2);\r
+ call waitt(1500);\r
+ (* tant que le philosophe n'a pas les deux fourchettes *)\r
+ while ( (not Goccupee) or (not Doccupee) )\r
+ do\r
+ (* demander \85 avoir la fourchette de gauche *)\r
+ if (not Goccupee) then\r
+ call fourch_g.prendref(Goccupee,num_phi,0);\r
+ call waitt(1500);\r
+ fi;\r
+ \r
+ (* demander \85 avoir la fourchette de droite *)\r
+ if (not Doccupee) then\r
+ call fourch_d.prendref(Doccupee,num_phi,1);\r
+ call waitt(1500);\r
+ fi;\r
+ od;\r
+ (* le philosophe a obtenu les 2 fourchettes *)\r
+ (* il mange *)\r
+ call e.actionp(num_phi, 3);\r
+ call waitt(4000);\r
+ (* le philosophe a fini de manger *)\r
+ (* il rend la fourchette de gauche *)\r
+ call fourch_g.rendref(Goccupee,num_phi,0);\r
+ call waitt(1500);\r
+ \r
+ (* il rend la fourchette de droite *)\r
+ call fourch_d.rendref(Doccupee, num_phi,1);\r
+ call waitt(1500);\r
+ \r
+ (* le philosophe demande \85 sortir de table *)\r
+ call gardien.sortir(num_phi);\r
+ \r
+ call waitt(5000);\r
+ \r
+ compt_m := compt_m + 1;\r
+ od;\r
+ (* le philosophe a mange 5 fois *)\r
+ (* il part d\82finitivement *)\r
+ call e.actionp(num_phi, 8);\r
+ call waitt(1500);\r
+ call e.finir;\r
+ END philosophe;\r
+ \r
+ (*******************************************************)\r
+ (* processus qui gere les entrees et sorties des *)\r
+ (* philosophes *)\r
+ (*******************************************************)\r
+ UNIT doorman : iiuwgraph process(node, place_dispo : integer, e : ecran);\r
+ \r
+ UNIT dem_entrer : procedure(num : integer);\r
+ begin\r
+ if place_dispo > 0\r
+ then\r
+ (* il y a des places disponibles \85 table *)\r
+ (* le philosophe peut rentrer *)\r
+ place_dispo := place_dispo - 1;\r
+ call e.actionp(num, 2);\r
+ if place_dispo = 0 then\r
+ (* il n'y a plus de places disponibles *)\r
+ (* aucun philosophe ne peut entrer *)\r
+ return disable dem_entrer;\r
+ fi;\r
+ else\r
+ call e.actionp(num, 5);\r
+ return;\r
+ fi;\r
+ END dem_entrer;\r
+ \r
+ UNIT sortir : procedure(num : integer);\r
+ begin\r
+ (* un philosophe sort de la salle *)\r
+ (* une place est liberee *)\r
+ place_dispo := place_dispo + 1;\r
+ call e.actionp(num, 4);\r
+ return enable dem_entrer;\r
+ END sortir;\r
+ \r
+ begin\r
+ enable dem_entrer, sortir;\r
+ return;\r
+ do od;\r
+ END doorman;\r
+ \r
+ (*******************************************************)\r
+ (* processus permettant de prendre et rendre les *)\r
+ (* fourchettes *)\r
+ (*******************************************************)\r
+ UNIT fork : iiuwgraph process (node : integer,e:ecran);\r
+ var aux : boolean;\r
+ \r
+ UNIT prendref : procedure (output foccupee : boolean;\r
+ input num,i:integer);\r
+ begin\r
+ if aux\r
+ then foccupee := true;\r
+ aux := false;\r
+ \r
+ else foccupee := false;\r
+ fi;\r
+ if i=0 then\r
+ if foccupee\r
+ then\r
+ call e.actionp(num, 9);\r
+ else\r
+ call e.actionp(num, 11);\r
+ fi;\r
+ else\r
+ if foccupee\r
+ then\r
+ call e.actionp(num, 10);\r
+ else\r
+ call e.actionp(num, 12);\r
+ fi;\r
+ fi;\r
+ END prendref;\r
+ \r
+ UNIT rendref : procedure (output foccup : boolean;\r
+ input num:integer,i:integer);\r
+ begin\r
+ aux := true;\r
+ foccup := false;\r
+ if i=0 then call e.actionp(num, 6)\r
+ else call e.actionp(num,7 ) fi;\r
+ END rendref;\r
+ \r
+ begin\r
+ aux := true;\r
+ enable prendref, rendref;\r
+ return;\r
+ do\r
+ accept prendref, rendref;\r
+ od;\r
+ END fork;\r
+ \r
+ (*******************************************************)\r
+ (* PROGRAMME PRINCIPAL *)\r
+ (*******************************************************)\r
+ CONST\r
+ xt = 300,\r
+ yt = 170,\r
+ rt = 105;\r
+ \r
+ VAR i : integer,\r
+ gardien : doorman,\r
+ f : arrayof fork,\r
+ f0 : fork,\r
+ ph : arrayof philosophe,\r
+ ph0 : philosophe,\r
+ e : ecran;\r
+ \r
+ BEGIN (********* programme principale ***********)\r
+ \r
+ call newpage;\r
+ e := new ecran(0);\r
+ resume(e);\r
+ \r
+ call e.table(xt,yt,rt);\r
+ \r
+ (* affichage des fourchettes *)\r
+ for i := 0 to 4\r
+ do\r
+ call e.fourchette(i, 0, 14);\r
+ od;\r
+ (* affichage de gardien *)\r
+ call e.guard(50,250,14);\r
+ gardien := new doorman(0, 4, e);\r
+ array ph dim (1:5);\r
+ array f dim (0:4);\r
+ for i := 0 to 4\r
+ do\r
+ f0 := new fork(0,e);\r
+ f(i) := f0;\r
+ resume(f(i));\r
+ od;\r
+ resume (gardien);\r
+ for i:= 1 to 5\r
+ do\r
+ ph0 := new philosophe(0, i, gardien, f(i mod 5), f(i-1), e);\r
+ ph(i) :=ph0;\r
+ od;\r
+ for i := 1 to 5\r
+ do\r
+ resume(ph(i));\r
+ od;\r
+ \r
+ \r
+END philos5.\r
--- /dev/null
+BLOCK\r
+ \r
+(*****************************************************************************)\r
+(********************************** F I F O **********************************)\r
+(*****************************************************************************)\r
+ \r
+unit FIFO : class ( type T);\r
+ \r
+ var HEAD,LAST : ELEM;\r
+ \r
+ unit ELEM : class ( INFO : T);\r
+ var NEXT : ELEM;\r
+ begin\r
+ end ELEM;\r
+ \r
+ unit EMPTY : function : boolean;\r
+ begin\r
+ result := (HEAD=NONE)\r
+ end EMPTY;\r
+ \r
+ unit INTO : procedure ( INFO : T );\r
+ begin\r
+ if EMPTY then\r
+ HEAD := new ELEM(INFO);\r
+ LAST := HEAD\r
+ else\r
+ LAST.NEXT := new ELEM(INFO);\r
+ LAST := LAST.NEXT\r
+ fi\r
+ end INTO;\r
+ \r
+ unit FIRST : function : T;\r
+ begin\r
+ result := HEAD.INFO\r
+ end FIRST;\r
+ \r
+ unit OUT_FIRST : procedure;\r
+ begin\r
+ if not EMPTY\r
+ then\r
+ HEAD := HEAD.NEXT\r
+ fi\r
+ end OUT_FIRST;\r
+ \r
+ unit CARDINAL : function : integer;\r
+ var HLP : ELEM;\r
+ begin\r
+ HLP := HEAD;\r
+ while HLP <> NONE\r
+ do\r
+ result :=result + 1;\r
+ HLP := HLP.NEXT\r
+ od\r
+ end CARDINAL;\r
+ \r
+ end FIFO;\r
+ \r
+ \r
+(*****************************************************************************)\r
+(************************** E N D F I F O *******************************)\r
+(*****************************************************************************)\r
+ \r
+(* * * * * * * * *)\r
+ \r
+(*****************************************************************************)\r
+(************************* S I M U L A T I O N *******************************)\r
+(*****************************************************************************)\r
+ \r
+UNIT PRIORITYQUEUE: IIUWGRAPH CLASS;\r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(E:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= E.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ \r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ \r
+ CALL CORRECT(E,FALSE)\r
+ END INSERT;\r
+ \r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ if y<>none then Y.RIGHT:= LAST else root :=none fi;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ \r
+ z.left.right := none;\r
+ z.ns := 0;\r
+ z.left, z.right, z.up := none;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+END QUEUEHEAD;\r
+ \r
+ \r
+UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ \r
+UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ hidden curr, pq;\r
+ signal ERROR1, ERROR2;\r
+ VAR CURR : SIMPROCESS, (* ACTIVE PROCESS *)\r
+ PQ : QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR : MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS: COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ \r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN raise ERROR1; FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ handlers\r
+ when ERROR1 :\r
+ WRITELN(" AN ATTEMPT TO ACTIVATE AN IDLE PROCESS TIME");\r
+ attach(main);\r
+ when ERROR2 :\r
+ WRITELN(" AN ATTEMPT TO ACTIVATE A TERMINATED PROCESS TIME");\r
+ attach(MAIN);\r
+ end handlers;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ raise ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+ UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE\r
+ THEN\r
+ RESULT:= FALSE\r
+ ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR<= X.PRIOR);\r
+ FI;\r
+ END LESS;\r
+ \r
+ END EVENTNOTICE;\r
+ \r
+ \r
+ UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+ UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+ UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+ UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF *)\r
+ (* "PRIOR"- PRIORITY WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ \r
+ if p.terminated then raise ERROR2 fi;\r
+ \r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI;\r
+ FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+ END SCHEDULE;\r
+ \r
+ UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE current PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ fi;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ BEGIN\r
+ (**** poprawka 10-93 ****)\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+ \r
+(*****************************************************************************)\r
+(************************ E N D S I M U L A T I O N *********************)\r
+(*****************************************************************************)\r
+ \r
+ \r
+(* B U S S I M U L A T I O N *)\r
+begin\r
+ pref iiuwgraph block\r
+ \r
+ BEGIN\r
+ PREF SIMULATION BLOCK\r
+ const pojemnosc=30;\r
+ var\r
+ autobusy:arrayof bus,\r
+ przystan:arrayof przystanek,\r
+ inf:info,cl:zegar,\r
+ ws:integer,\r
+ c:char,\r
+ praz:boolean,\r
+ i,j,jj,p,czas_sym,czas,ilosc_przystankow,\r
+ ilosc_auto,czestosc,odstep1,odstep2,podst1,podst2:integer;\r
+ \r
+ unit wsp:class(x,y,i:integer);\r
+ begin\r
+ end wsp;\r
+ \r
+ unit nast:function(w:wsp):wsp;\r
+ var pom:wsp;\r
+ begin\r
+ if w.i <= ilosc_przystankow div 2\r
+ then\r
+ pom:=new wsp(w.x,w.y - odstep1,i mod ilosc_przystankow +1)\r
+ else\r
+ if w.x>550\r
+ then\r
+ pom:=new wsp(600-w.x,20,i mod ilosc_przystankow+1)\r
+ else\r
+ pom:=new wsp(w.x,w.y+odstep1,i mod ilosc_przystankow+1)\r
+ fi\r
+ fi;\r
+ result:=pom\r
+ end nast;\r
+ \r
+ unit bus:simprocess class(kolor:integer);\r
+ var i,j,kier,\r
+ wolnych_miejsc : integer,\r
+ dokad : arrayof integer,\r
+ ws : wsp,\r
+ wsiadajacy:pasazer;\r
+ begin\r
+ array dokad dim (1: ilosc_przystankow);\r
+ wolnych_miejsc := pojemnosc;\r
+ praz := true;\r
+ \r
+ ws := new wsp(480,282,1);\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ write(chr(7));\r
+ write(chr(7));\r
+ i:= entier(random*10);\r
+ call hold(10+i);\r
+ i:=1;\r
+ (* dojazd do pierwszego przystanku *)\r
+ while ws.y>przystan(i).ws.y\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call auto(0 ,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-2;\r
+ \r
+ od;\r
+ \r
+ do (* petla w ktorej pracuje autobus *)\r
+ \r
+ ws.y:=przystan(i).ws.y;\r
+ ws.i:=i;\r
+ if i <= ilosc_przystankow div 2\r
+ then\r
+ kier:=1; ws.x := 480 else kier := -1; ws.x :=420;\r
+ fi;\r
+ \r
+ call auto(kolor,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ \r
+ (* autobus jest na przystanku *)\r
+ praz:=false;\r
+ wolnych_miejsc:=wolnych_miejsc + dokad(i);\r
+ (* z autobusu wysiadlo dokad(i) pasazerow *)\r
+ call auto(kolor,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ \r
+ call hold(2);\r
+ \r
+ (*** teraz pasazerowie wsiadaja ***)\r
+ while (wolnych_miejsc > 0) and (not przystan(i).kolejka.empty)\r
+ do\r
+ wsiadajacy:=przystan(i).kolejka.first;\r
+ dokad(wsiadajacy.dokad) := dokad(wsiadajacy.dokad) +1;\r
+ call usun(przystan(i).ws.x,przystan(i).ws.y,\r
+ kier*przystan(i).kolejka.cardinal);\r
+ call przystan(i).kolejka.out_first;\r
+ wolnych_miejsc:=wolnych_miejsc - 1;\r
+ \r
+ call auto(0,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ call auto(kolor,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ \r
+ call run(wsiadajacy);\r
+ call run(inf);\r
+ kill(wsiadajacy)\r
+ od;\r
+ \r
+ (* autobus rusza z przystanku *)\r
+ call auto(0,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ if i= ilosc_przystankow div 2\r
+ then\r
+ while ws.y> 26\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-2;\r
+ od;\r
+ ws.x := 420; (*autobus przeskakuje na druga strone ulicy*)\r
+ kier := -1;\r
+ fi;\r
+ \r
+ if i=ilosc_przystankow then\r
+ while ws.y< 282\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y+2;\r
+ od;\r
+ ws.x := 480; (*autobus przeskakuje na druga strone ulicy*)\r
+ kier := 1;\r
+ i :=0;\r
+ fi;\r
+ \r
+ if i<ilosc_przystankow div 2\r
+ then\r
+ while ws.y>przystan(i+1).ws.y\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-kier*2;\r
+ od;\r
+ else\r
+ \r
+ while ws.y< przystan(i+1).ws.y\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-kier*2;\r
+ od;\r
+ fi;\r
+ \r
+ i:=i mod ilosc_przystankow + 1;\r
+ od\r
+ end bus;\r
+ \r
+ unit pasazer:simprocess class(nr,kolor:integer);\r
+ var czas_przyjscia,czas_oczekiwania:integer,\r
+ dokad : integer;\r
+ begin\r
+ dokad := 1+entier(random*(ilosc_przystankow-1));\r
+ czas_przyjscia:=time;\r
+ call passivate;\r
+ czas_oczekiwania:=time-czas_przyjscia;\r
+ przystan(nr).laczny_czas:=przystan(nr).laczny_czas +\r
+ czas_oczekiwania;\r
+ przystan(nr).sredniczas:=przystan(nr).laczny_czas /\r
+ przystan(nr).total\r
+ end pasazer;\r
+ \r
+ \r
+ unit przystanek:simprocess class(nr:integer);\r
+ var k , jak_czesto : integer;\r
+ var\r
+ kolejka:FIFO,\r
+ new_pas:pasazer,\r
+ ws:wsp,\r
+ kier,ilosc_pas,total,laczny_czas,czas_do_nast:integer,\r
+ sredniczas:real;\r
+ begin\r
+ kolejka:=new FIFO(pasazer);\r
+ czas_do_nast:=3;\r
+ (*to powinno byc zalezne od szybkosci autobusu*)\r
+ (* i odleglosci miedzy przystankami*)\r
+ \r
+ if nr<=ilosc_przystankow div 2 then\r
+ ws:=new wsp(510,290-podst1-(nr-1)*odstep1,nr)\r
+ else\r
+ ws:=new wsp(390,podst2+(nr-ilosc_przystankow div 2-1)*odstep2,nr)\r
+ fi;\r
+ \r
+ if ws.x>450 then\r
+ call move(ws.x-15,ws.y+10)\r
+ else\r
+ call move(ws.x,ws.y+10)\r
+ fi;\r
+ call color(15);\r
+ call wypisz(ws.i);\r
+ call hold(2);\r
+ do\r
+ \r
+ call hold(20);(* jak_czesto sa losowani pasazerowie *)\r
+ if nr<= ilosc_przystankow div 2 \r
+ then kier :=1 else kier :=-1 fi;\r
+ k:= entier(random*12)+2; (*kolor pasazera*)\r
+ new_pas:=new pasazer(nr,k);\r
+ total:=total+1;\r
+ call kolejka.into(new_pas);\r
+ call kol(ws.x,ws.y,kier*kolejka.cardinal,k);\r
+ call schedule(new_pas,time);\r
+ \r
+ od;\r
+ end przystanek;\r
+ \r
+ \r
+ (*------------------------------------------------------------------------*)\r
+ (*-------------------- PROCEDURY POMOCNICZE ----------------------------*)\r
+ (*------------------------------------------------------------------------*)\r
+ \r
+ unit ludzik:procedure(x,y,k :integer);\r
+ begin\r
+ call color(k);\r
+ call move(x,y);\r
+ call draw(x,y+6);\r
+ call draw(x-2,y+10);\r
+ call move(x,y+6);\r
+ call draw(x+2,y+10);\r
+ call move(x-2,y+2);\r
+ call draw(x+2,y+2);\r
+ call move(x-2,y+2);\r
+ call draw(x-4,y+4);\r
+ call move(x+2,y+2);\r
+ call draw(x+4,y+4);\r
+ call color(15);\r
+ end;\r
+ \r
+ \r
+ unit usun:procedure(x,y,m:integer);\r
+ var i:integer;\r
+ begin\r
+ if m<=15\r
+ then\r
+ call color(0);\r
+ call ludzik(x+8*m,y,0);\r
+ call color(15)\r
+ fi\r
+ end;\r
+ \r
+ unit kol:procedure(x,y,m,k:integer);\r
+ var i:integer;\r
+ begin\r
+ if m<=15\r
+ then\r
+ call ludzik(x+8*m,y,k)\r
+ fi\r
+ end;\r
+ \r
+ \r
+ unit wypisz : procedure(x:integer);\r
+ unit CHRTYP :function ( x:integer):string;\r
+ (* zamiana liczby na tekst *)\r
+ begin\r
+ case x\r
+ when 1 : result:="1";\r
+ when 2 : result:="2";\r
+ when 3 : result:="3";\r
+ when 4 : result:="4";\r
+ when 5 : result:="5";\r
+ when 6 : result:="6";\r
+ when 7 : result:="7";\r
+ when 8 : result:="8";\r
+ when 9 : result:="9";\r
+ when 0 : result:="0"\r
+ esac\r
+ end;\r
+ begin\r
+ \r
+ if x<0 then call outstring("ujemna liczba")\r
+ else\r
+ call outstring(chrtyp(x div 10));\r
+ call outstring(chrtyp(x mod 10))\r
+ fi\r
+ end wypisz;\r
+ \r
+ \r
+ unit zegar:simprocess class;\r
+ var i,j:integer;\r
+ begin\r
+ call color(4);\r
+ call ramka(420,310,480,335);\r
+ call ramka(422,312,478,333);\r
+ call ramka(421,311,479,334);\r
+ call color(15);\r
+ do\r
+ call color(1);\r
+ call move(433,320);\r
+ call wypisz(i);\r
+ call outstring(":");\r
+ call wypisz(j);\r
+ j:=j+1;\r
+ if j=60 then j:=0;i:=i+1 fi;\r
+ call hold(1);\r
+ od\r
+ end zegar;\r
+ \r
+ \r
+ unit info:simprocess class;\r
+ var i:integer;\r
+ begin\r
+ call color(4);\r
+ call ramka(0,0,324,140+10*ilosc_przystankow);\r
+ call ramka(1,1,326,141+10*ilosc_przystankow);\r
+ call color(15);\r
+ call move(10,50);\r
+ call outstring("Max. nb. of persons in the bus:");\r
+ call outstring("30 os.");\r
+ call move(10,70);\r
+ call outstring("Time przejazdu miedzy");\r
+ call move(10,80);\r
+ call outstring("przystankami:");\r
+ call outstring(" 3 min.");\r
+ call move(10,10);\r
+ call outstring("The time of Simulation:");\r
+ if czas_sym div 60=/=0\r
+ then\r
+ call wypisz(czas_sym div 60);\r
+ call outstring(" h. ")\r
+ fi;\r
+ call wypisz(czas_sym mod 60);\r
+ call outstring(" min.");\r
+ call move(10,30);\r
+ call outstring("Frequency :");\r
+ call wypisz(czestosc);\r
+ call outstring(" min.");\r
+ call move(200,100);\r
+ call outstring("Avrage ");\r
+ call move(200,110);\r
+ call outstring("waiting-time:");\r
+ call move(30,100);\r
+ call outstring("BUS");\r
+ call move(30,110);\r
+ call outstring("STOP");\r
+ call outstring(" ");\r
+ call move(90,100);\r
+ call outstring("Number");\r
+ call move(90,110);\r
+ call outstring("of persons");\r
+ call color(4);\r
+ call ramka(530,5,610,20);\r
+ call move(535,10);\r
+ call outstring("Esc - END");\r
+ call color(15);\r
+ do\r
+ if inkey=27 then call run(mainpr) fi;\r
+ call color(15);\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ call move(30,120+i*10);\r
+ call wypisz(i);\r
+ call outstring(" ");\r
+ call move(90,120+i*10);\r
+ call wypisz(przystan(i).kolejka.cardinal);\r
+ call outstring(" ");\r
+ call move(200,120+i*10);\r
+ call wypisz(entier(przystan(i).sredniczas));\r
+ call outstring(".");\r
+ call wypisz(entier(przystan(i).sredniczas*10) mod 10);\r
+ call outstring(" min. ")\r
+ od;\r
+ call hold(0.5)\r
+ od\r
+ end info;\r
+ \r
+ \r
+ \r
+ unit ramka : procedure(x1,y1,x2,y2:integer);\r
+ begin\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1)\r
+ end ramka;\r
+ \r
+ \r
+ unit pr:procedure(x,y,dx,dy:integer);\r
+ begin\r
+ call ramka(x-dx div 2,y-dy div 2,x+dx div 2,y+dy div 2)\r
+ end pr;\r
+ \r
+ unit auto:procedure(k,x,y,n:integer);\r
+ begin (* ilosc miejsc wolnych w aucie *)\r
+ call color(k);\r
+ call pr(x,y,8,18);\r
+ call pr(x,y,10,20);\r
+ call pr(x,y,10,2);\r
+ call wypisz(n); (* ilosc pasazerow w autobusie *)\r
+ end auto;\r
+ \r
+ \r
+ \r
+ unit zabij_pas:procedure(i:integer);\r
+ var p:pasazer;\r
+ begin\r
+ while przystan(i).kolejka.cardinal>0\r
+ do\r
+ p:=przystan(i).kolejka.first;\r
+ call przystan(i).kolejka.out_first;\r
+ if p.event=/=none then call cancel(p) fi;\r
+ kill(p)\r
+ od\r
+ end zabij_pas;\r
+ \r
+ unit wstep:procedure;\r
+ begin\r
+ call gron(0);\r
+ call ramka(230,120,480,220);\r
+ call ramka(228,118,482,222);\r
+ call ramka(226,116,484,224);\r
+ call move(250,140);\r
+ call outstring(" PROJET 6 ");\r
+ call move(250,160);\r
+ call outstring(" BUS SIMULATION ");\r
+ call move(250,180);\r
+ call outstring("Author: Nguyen Tuan Trung");\r
+ call move(250,200);\r
+ call outstring(" Warsaw 24 - 05 - 1990");\r
+ WHILE INKEY=0 DO OD;\r
+ call groff\r
+ end wstep;\r
+ \r
+ (*----------- PROGRAM GLOWNY---------------------------------------------*)\r
+ \r
+ \r
+ begin\r
+ call wstep;\r
+ do (* to repeat simulation *)\r
+ \r
+ do\r
+ write("Simulation time = ");\r
+ readln(czas_sym);\r
+ if czas_sym > 0\r
+ then exit\r
+ else writeln(" The simulation time must be >0 ")\r
+ fi\r
+ od;\r
+ do\r
+ write("Number of bus-stops (1-20) = ");\r
+ readln(ilosc_przystankow);\r
+ if ilosc_przystankow>1 and ilosc_przystankow < 21 then exit\r
+ else writeln("It must be not bigger than 20!")\r
+ fi\r
+ od;\r
+ do\r
+ write("Number of buses (>0) = ");\r
+ readln(ilosc_auto);\r
+ if ilosc_auto>0 then\r
+ exit\r
+ else\r
+ writeln("Must be bigger than 0 !")\r
+ fi\r
+ od;\r
+ do\r
+ write("Frequency of buses (>10) = ");\r
+ readln(czestosc);\r
+ if czestosc>=10 then exit\r
+ else\r
+ writeln("Must be bigger than 9 !")\r
+ fi;\r
+ od;\r
+ \r
+ call gron(0);\r
+ call color(2); (* ta ramka odpowiada jezdni *)\r
+ call ramka(400,3,502,300);\r
+ call ramka(399,2,503,301);\r
+ call ramka(398,1,504,302);\r
+ call ramka(395,0,507,305);\r
+ call color(15);\r
+ odstep1:=290 div (ilosc_przystankow div 2 + 1);\r
+ podst1:=(290- (ilosc_przystankow div 2-1)*odstep1) div 2;\r
+ odstep2:=290 div (ilosc_przystankow -\r
+ ilosc_przystankow div 2 + 1);\r
+ podst2:=(290- (ilosc_przystankow-\r
+ ilosc_przystankow div 2-1)*odstep2) div 2;\r
+ \r
+ for i:=1 to 7\r
+ do\r
+ (* rysowanie pasa srodkowego jezdni *)\r
+ call color(14);\r
+ call ramka(448,300-i*40,452,320-i*40);\r
+ call ramka(449,300-i*40,451,320-i*40);\r
+ call ramka(450,300-i*40,450,320-i*40);\r
+ call color(15);\r
+ od;\r
+ \r
+ \r
+ array przystan dim(1:ilosc_przystankow);\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ przystan(i):=new przystanek(i);\r
+ call schedule(przystan(i),time)\r
+ od;\r
+ array autobusy dim(1:ilosc_auto);\r
+ for i:=1 to ilosc_auto\r
+ do\r
+ j:= entier(random*5)+2; (*kolor autobusu*)\r
+ autobusy(i):=new bus(j) ;\r
+ call schedule(autobusy(i),time+(i-1)*czestosc+0.6)\r
+ od;\r
+ cl:=new zegar;\r
+ call schedule(cl,time);\r
+ inf:=new info;\r
+ call schedule(inf,time+0.5);\r
+ call hold(czas_sym+0.7);\r
+ \r
+ (* dlaczgo to mi sie wykonuje tak rzadko ????? *)\r
+ \r
+ call ramka(520,290,620,345);\r
+ call ramka(521,291,619,344);\r
+ call move(530,300);\r
+ \r
+ call outstring("TIME IS OUT");\r
+ call move(530,320);\r
+ call outstring("GO ON(y/n)?");\r
+ i:=inkey;\r
+ while i=0 do i:=inkey od;\r
+ if (i=ord('y'))\r
+ then\r
+ \r
+ call move(530,320);\r
+ call outstring("add: ");\r
+ call move(565,320);\r
+ jj:=0;\r
+ for p:=1 to 2\r
+ do\r
+ i:=inkey;\r
+ while ( not( i>=ord('0') and i<=ord('9')) and i=0)\r
+ do i:= inkey od;\r
+ call hascii(i);\r
+ jj := 10*jj+ (i-ord('0'));\r
+ od;\r
+ czas := czas+jj;\r
+ call outstring(" min");\r
+ fi; (******************************????*)\r
+ for j:=1 to 2000 do od;\r
+ call color(0);\r
+ call ramka(520,290,620,345);\r
+ call ramka(521,291,619,344);\r
+ \r
+ call move(530,300);\r
+ call outstring(" ");\r
+ call move(530,320);\r
+ call outstring(" ");\r
+ \r
+ czas_sym:=czas_sym+czas;\r
+ call color(15);\r
+ call move(10,10);\r
+ call outstring(" ");\r
+ call move(10,10);\r
+ call outstring("Czas symulacji:");\r
+ if czas_sym div 60<>0\r
+ then\r
+ call wypisz(czas_sym div 60);\r
+ call outstring(" godz. ")\r
+ fi;\r
+ if czas_sym mod 60 <>0 then\r
+ call wypisz(czas_sym mod 60);\r
+ call outstring(" min.");\r
+ fi;\r
+ call hold(czas);\r
+ \r
+ \r
+ for i:=1 to ilosc_auto\r
+ do\r
+ call cancel(autobusy(i));\r
+ kill (autobusy(i))\r
+ od;\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ call zabij_pas(i);\r
+ call cancel(przystan(i));\r
+ kill (przystan(i))\r
+ od;\r
+ kill (autobusy);\r
+ kill (przystan);\r
+ call cancel(cl);\r
+ kill (cl);\r
+ call cancel(inf);\r
+ kill (inf);\r
+ call groff;\r
+ write("Do you like to repeat the simulation process (y/n) ?");\r
+ read(c);\r
+ if c<> 'y' then exit fi ;\r
+ OD;\r
+ end\r
+ end\r
+end.\r
--- /dev/null
+PROGRAM OTOCZKA;\r
+ \r
+(*Program znajduje najmniejszy wypukly wielokat zawierajacy zadany zbior*)\r
+(* punktow. *)\r
+(* autor: Joanna Hybel *)\r
+(*program nr 5 jest przedmiotem zal. PP II *)\r
+ \r
+VAR i,j,k,licz,ix:integer,\r
+ pom:punkt,\r
+ punkty:arrayof punkt; (*zbior punktow*)\r
+ \r
+UNIT punkt:class;\r
+ var\r
+ x,y:integer,\r
+ theta:real;\r
+end punkt;\r
+ \r
+ \r
+begin\r
+ pref iiuwgraph block\r
+ \r
+ UNIT hframe:procedure(x,y,length,width:integer);\r
+ (*---------------------------------------------*)\r
+ begin\r
+ call move(x,y);\r
+ call draw(x+width,y);\r
+ call draw(x+width,y+length);\r
+ call draw(x,y+length);\r
+ call draw(x,y);\r
+ end hframe;\r
+ \r
+ UNIT hwrite:procedure(tekst:string;x,y:integer);\r
+ (*---------------------------------------------*)\r
+ var i:integer,\r
+ tab:arrayof char;\r
+ begin\r
+ tab:=unpack(tekst);\r
+ call move(x,y);\r
+ for i:=lower(tab) to upper(tab)\r
+ do\r
+ call hascii(ord(tab(i)));\r
+ od;\r
+ end;\r
+ \r
+UNIT inchar:function:integer;\r
+ (*---------------------------------------------*)\r
+var ii:integer;\r
+begin\r
+do\r
+ ii:=inkey;\r
+ if ii<>0 then exit fi;\r
+od;\r
+result:=ii;\r
+end inchar;\r
+ \r
+ UNIT zmaz :procedure(x,y,dl,sz:integer);\r
+ (*---------------------------------------------*)\r
+ begin\r
+ dl:=dl div 8;\r
+ sz:=sz div 8;\r
+ for i:=1 to dl do\r
+ for j:=1 to sz do\r
+ call move(x+(j-1)*8,y+(i-1)*8);\r
+ call hascii(0);\r
+ od;\r
+ od;\r
+ end zmaz;\r
+ \r
+UNIT wpisz_theta:procedure;\r
+ (*---------------------------------------------*)\r
+ \r
+ UNIT uzup_theta:function(p:punkt):real;\r
+ var dx,dy:integer,\r
+ th:real;\r
+begin\r
+ dx:=p.x-punkty(1).x;\r
+ dy:=p.y-punkty(1).y;\r
+ if dx=0 and dy=0 then th:=0\r
+ else\r
+ th:=dy/(abs(dx)+abs(dy));\r
+ fi;\r
+ if dx<0 then th:=2-th\r
+ else\r
+ if dy<0 then th:=th+4 fi;\r
+ fi;\r
+ result:=th*90.0;\r
+end uzup_theta;\r
+begin\r
+ for i:=1 to licz do\r
+ punkty(i).theta:=uzup_theta(punkty(i));\r
+ od;\r
+end wpisz_theta;\r
+ \r
+UNIT rys_otocz:procedure;\r
+ (*---------------------------------------------*)\r
+ UNIT czysc:procedure(p1,p2:punkt);\r
+ begin\r
+ call move(p2.x,p2.y);\r
+ call color(0);\r
+ call draw(p1.x,p1.y);\r
+ call color(1);\r
+ call cirb(p2.x,p2.y,2,3,3,1,1,2,2);\r
+ call cirb(p1.x,p1.y,2,3,3,1,1,2,2);\r
+ end czysc;\r
+ \r
+ UNIT rys:procedure(p1,p2:punkt);\r
+ begin\r
+ call color(11);\r
+ call move(p2.x,p2.y);\r
+ call draw(p1.x,p1.y);\r
+ end rys;\r
+ \r
+UNIT po_tej_samej_str: function(p1,p2,p3:punkt):boolean;\r
+ (*Czy punkty punkty(1),p3 leza po tej samej stronie prostej p1,p2?*)\r
+ var dx1,dx2,dx3,dy1,dy2,dy3,k,l:real;\r
+ begin\r
+ dx1:=p2.x-p1.x;\r
+ dy1:=p2.y-p1.y;\r
+ dx2:=p3.x-p1.x;\r
+ dy2:=p3.y-p1.y;\r
+ dx3:=punkty(1).x-p1.x;\r
+ dy3:=punkty(1).y-p1.y;\r
+ k:=(dy2*dx1-dy1*dx2);\r
+ l:=(dy3*dx1-dy1*dx3);\r
+ if k=0 orif l=0 then result:=true;\r
+ else\r
+ if k>0 then result:=(l>0);\r
+ else result:=(l<0);\r
+ fi;\r
+ fi;\r
+ end po_tej_samej_str;\r
+begin\r
+ call hwrite("press any key to draw a CONVEX HULL",24,316);\r
+ i:=2; k:=3;\r
+ call rys(punkty(1),punkty(2));\r
+ for j:=3 to licz\r
+ do\r
+ ix:=inchar;\r
+ k:=j;\r
+ do\r
+ if po_tej_samej_str(punkty(i-1),punkty(i),punkty(k)) then\r
+ i:=i+1; exit;\r
+ else\r
+ call czysc(punkty(i-1),punkty(i));\r
+ i:=i-1;\r
+ fi;\r
+ od;\r
+ pom:=punkty(i);\r
+ punkty(i):=punkty(k);\r
+ punkty(k):=pom;\r
+ call rys(punkty(i-1),punkty(i));\r
+ od;\r
+ call rys(punkty(i),punkty(1));\r
+ call zmaz(24,304,32,580);\r
+end rys_otocz;\r
+ \r
+UNIT dane :procedure;\r
+ (*---------------------------------------------*)\r
+ UNIT los_gen:procedure;\r
+ var x1,y1:integer;\r
+ begin\r
+ for i:=1 to licz do\r
+ do\r
+ x1:=random*400+100;\r
+ if x1>5 andif x1<614 then\r
+ punkty(i).x:=x1;\r
+ exit;\r
+ fi;\r
+ od;\r
+ do\r
+ y1:=random*200+50;\r
+ if y1>35 andif y1<300 then\r
+ punkty(i).y:=y1;\r
+ exit;\r
+ fi;\r
+ od;\r
+ call cirb(x1,y1,2,3,3,11,1,2,2);\r
+ od;\r
+ end los_gen;\r
+ \r
+ UNIT uzyt_gen :procedure;\r
+ begin\r
+ call hwrite("USE ARROWS TO MOVE THE CURSOR",24,308);\r
+ call hwrite("END - finishes",24,320);\r
+ \r
+ call track(300,150);\r
+ k:=0;\r
+ do\r
+ if inxpos>5 andif inxpos<514 then\r
+ if inypos>35 andif inypos<287 then\r
+ k:=k+1;\r
+ punkty(k).x:=inxpos;\r
+ punkty(k).y:=inypos;\r
+ call cirb(inxpos,inypos,2,3,3,11,1,2,2);\r
+ fi\r
+ fi;\r
+ if k=licz then exit fi;\r
+ call track(inxpos+3,inypos)\r
+ od;\r
+ call zmaz(24,304,32,580);\r
+ end uzyt_gen;\r
+begin\r
+ call zmaz(24,304,32,580);\r
+ call hwrite("the number of points 3",20,291);\r
+ call hwrite("1 - if you would like less points ",20,303);\r
+ call hwrite("2 - if you would like more points ",20,315);\r
+ call hwrite("ENTER - to continue execution",20,327);\r
+ licz:=3;\r
+do\r
+ ix:=inchar;\r
+ case ix\r
+ when 50 : if licz<99 then licz:=licz+1 ;\r
+ call move(252,291);\r
+ call hascii(0);\r
+ call move(260,291);\r
+ call hascii(0);\r
+ call move(252,291);\r
+ if licz>9 then call hascii(licz div 10+48) fi;\r
+ call hascii(licz mod 10 +48);\r
+ fi;\r
+ when 49 : if licz>3 then licz:=licz-1 ;\r
+ call move(252,291);\r
+ call hascii(0);\r
+ call move(260,291);\r
+ call hascii(0);\r
+ call move(252,291);\r
+ if licz>9 then call hascii(licz div 10+48) fi;\r
+ call hascii(licz mod 10 +48);\r
+ \r
+ fi;\r
+ when 13 : exit;\r
+ otherwise;\r
+ esac;\r
+od;\r
+array punkty dim (1:licz);\r
+for i:=1 to licz do\r
+ punkty(i):=new punkt;\r
+od;\r
+call zmaz(20,291,48,580);\r
+call hwrite("M E N U :",20,291);\r
+call hwrite("1 - random generation of points",20,303);\r
+call hwrite("2 - points given by user",20,315);\r
+do\r
+ ix:=inchar;\r
+ if ix=49 orif ix=50 then exit fi;\r
+od;\r
+ call zmaz(20,291,48,580);\r
+ case ix\r
+ when 49:call los_gen;\r
+ when 50:call uzyt_gen;\r
+ otherwise;\r
+ esac;\r
+end dane;\r
+ \r
+ UNIT znajdz_max_y:procedure;\r
+ (*---------------------------------------------*)\r
+ begin\r
+ pom:=punkty(1);\r
+ j:=1;\r
+ for i:=1 to licz do\r
+ if pom.y> punkty(i).y then(*bylo <*)\r
+ pom:=punkty(i);\r
+ j:=i;\r
+ else\r
+ if pom.y=punkty(i).y then\r
+ if pom.x> punkty(i).x then\r
+ pom:=punkty(i);\r
+ j:=i;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ pom:=punkty(1);\r
+ punkty(1):=punkty(j);\r
+ punkty(j):=pom;\r
+ end znajdz_max_y;\r
+ \r
+ (*funkcje okreslajace wzgl. czego sortujemy : *)\r
+ \r
+ unit l1 :function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.theta<p2.theta);\r
+ end l1;\r
+ unit l2:function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.y<p2.y);\r
+ end l2;\r
+ unit l3:function(p1,p2:punkt):boolean;\r
+ begin\r
+ result:=(p1.x <p2.x);\r
+ end l3;\r
+ \r
+ \r
+ UNIT posortuj:procedure;\r
+ (*---------------------------------------------*)\r
+ \r
+ (* Sortowanie punktow wzgledem kata jaki tworza z prosta pozioma, *)\r
+ (* przechodzaca przez punkt o najmniejszej wspolrz.y i x *)\r
+ var kon,pocz:integer,\r
+ lg,lg1:boolean;\r
+ \r
+ UNIT sort:procedure (function log(p1,p2:punkt):boolean);\r
+ \r
+ unit quicksort:procedure(l,p:integer);\r
+ var i,j:integer,\r
+ x,w:punkt;\r
+ begin\r
+ i:=l; j:=p;\r
+ x:=punkty((l+p) div 2);\r
+ do\r
+ while log(punkty(i),x) do\r
+ i:=i+1 od;\r
+ while log(x,punkty(j)) do\r
+ j:=j-1 od;\r
+ if i<=j then\r
+ w:=punkty(i); punkty(i):=punkty(j); punkty(j):=w;\r
+ i:=i+1;\r
+ j:=j-1;\r
+ fi;\r
+ if i>j then exit fi;\r
+ od;\r
+ if l<j then call quicksort(l,j) fi;\r
+ if i<p then call quicksort(i,p) fi;\r
+ \r
+ end quicksort;\r
+ \r
+ \r
+ begin\r
+ call quicksort(pocz,kon);\r
+ end sort;\r
+ \r
+ begin (*posortuj*)\r
+ kon:=licz;\r
+ pocz:=1;\r
+ call sort(l1);\r
+ k:=1;\r
+ i:=1;\r
+ while i<licz do\r
+ j:=i;\r
+ if punkty(i).theta=0 then lg1:=true fi;\r
+ do\r
+ lg:=(punkty(i).theta=punkty(i+1).theta);\r
+ if lg then i:=i+1 ;\r
+ else\r
+ exit;\r
+ fi;\r
+ if i=licz then exit fi;\r
+ od;\r
+ if lg1 and i=j then lg1:=false fi;\r
+ if i<>j then\r
+ kon:=i;\r
+ pocz:=j;\r
+ if lg1 then lg1:=false;\r
+ (*porzadkowanie punktow lezacych na prostej poziomej,przechodzacych przez*)\r
+ (*punkt zaczepienia - punkty(1) ;tj.tworza kat zerowy z punktem zaczepienia *)\r
+ call sort(l3) ;\r
+ else\r
+ (*porzadkowanie punktow tworzacych ten sam kat rozny od zerowego*)\r
+ call sort(l2);\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ end posortuj;\r
+(*---------------------------------------------------------------------------*)\r
+begin (*PROGRAM GLOWNY*)\r
+ call gron(1);\r
+ call color(14);\r
+ call hframe(5,3,342,610);\r
+ call hframe(4,2,340,612);\r
+ call hframe(5,287,54,610);\r
+ call hframe(5,7,28,610);\r
+ call color(15);\r
+ call hwrite("CONVEX HULL by Joanna Hybel",185,17);\r
+ do\r
+ call dane;\r
+ call znajdz_max_y;\r
+ call wpisz_theta;\r
+ call posortuj;\r
+ call rys_otocz;\r
+ call hwrite("ESC - end of program execution",24,308);\r
+ call hwrite("ENTER - continue ",24,320);\r
+ do\r
+ ix:=inchar;\r
+ case ix\r
+ when 13:call zmaz(6,37,246,608);\r
+ exit;\r
+ when 27:exit exit;\r
+ otherwise;\r
+ esac;\r
+ od;\r
+ od;\r
+ call groff;\r
+end;\r
+end;\r
--- /dev/null
+PROGRAM Infographie;\r
+\r
+(* Auteurs: Peyrard Fabrice & Pianelo Patrice *)\r
+\r
+BEGIN\r
+ Pref Mouse Block\r
+ VAR\r
+ h,v,p,lg,b,vitd,vith : Integer,\r
+ l,r,z : Boolean,\r
+ cour,debut: Cub;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// CUB \\\\\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Cub : Class;\r
+Var\r
+ x,y : Real,\r
+ suiv : Cub;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// DROITE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Droite : Coroutine;\r
+Var\r
+ dif,dif1,b : Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x,cour.y);\r
+ dif := (b - y) - (x+lg+lg Div 3);\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vith) Then\r
+ x := x + dif1;\r
+ Else\r
+ x := x + vith;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Droite;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// GAUCHE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Gauche: Coroutine;\r
+Var\r
+ dif,dif1,b : Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x+lg+lg Div 3,cour.y);\r
+ dif := x-(b - y);\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vith) Then\r
+ x := x - dif1;\r
+ Else\r
+ x := x - vith;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Gauche;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// HAUT \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Haut: Coroutine;\r
+Var\r
+ dif,dif1: Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ dif := y-(lg Div 2) - cour.y;\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vitd) Then\r
+ y := y - dif1;\r
+ x := x + dif1;\r
+ Else\r
+ y := y - vitd;\r
+ x := x + vitd;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Haut;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º//////////////////////// BAS \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Bas: Coroutine;\r
+Var\r
+ dif,dif1: Integer;\r
+Begin\r
+ Return;\r
+ Do\r
+ dif1 := 640;\r
+ cour := debut;\r
+ Do\r
+ dif := cour.y-(lg Div 2) - y;\r
+ If ((dif < dif1) AND (dif > 0)) Then\r
+ dif1 := dif;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Call Cube (x,y,0);\r
+ If (dif1 < vitd) Then\r
+ y := y + dif1;\r
+ x := x - dif1;\r
+ Else\r
+ y := y + vitd;\r
+ x := x - vitd;\r
+ Fi;\r
+ Call Cube (x,y,15);\r
+ Call Setwindow (x,x+(lg+lg Div 3),y,y+lg);\r
+ Detach;\r
+ Od;\r
+End Bas;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// CUBE \\\\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Cube: IIUWGraph Procedure (x,y,c : Integer);\r
+Begin\r
+ Call Color (c);\r
+ Call Move (x,y);\r
+ Call Draw (x + lg + lg Div 3,y);\r
+ Call Draw (x + lg + lg Div 2 + lg Div 3,y - lg Div 2);\r
+ Call Draw (x + lg Div 2,y - lg Div 2);\r
+ Call Draw (x,y);\r
+ Call Draw (x,y + lg);\r
+ Call Draw (x + lg + lg Div 3,y + lg);\r
+ Call Draw (x + lg + lg Div 3,y);\r
+ Call Move (x + lg + lg Div 3,y + lg);\r
+ Call Draw (x + lg + lg Div 2 + lg Div 3,y + lg Div 2);\r
+ Call Draw (x + lg + lg Div 2 + lg Div 3,y - lg Div 2);\r
+End Cube;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// NOIR \\\\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Noir: IIUWGraph Procedure (x,y,c : Integer);\r
+Var\r
+ i : Integer;\r
+Begin\r
+ Call Color (c);\r
+ For i:= x + 1 To x + (lg+lg Div 3) - 1 Do\r
+ Call Move (i,y+1);\r
+ Call Draw (i,y+lg-1);\r
+ Od;\r
+ For i := y To y + lg-2 Do\r
+ Call Move (x+(lg+lg Div 3)+1,i);\r
+ Call Draw (x+(lg+lg Div 2+lg Div 3)-1,i-(lg Div 2)+2);\r
+ Od;\r
+ For i:= x + 2 To x + (lg+lg Div 3) Do\r
+ Call Move (i,y-1);\r
+ Call Draw (i+(lg Div 2)-2,y-(lg Div 2)+1);\r
+ Od;\r
+End Noir;\r
+ \r
+Unit Calcul_b: Function (vx,vy:Integer):Integer;\r
+Begin\r
+ result := vx + vy;\r
+End Calcul_b;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º////////////////////// DEPLACE \\\\\\\\\\\\\\\\\\\ º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+UNIT Deplace: IIUWGraph Procedure;\r
+Var\r
+ i : Integer,\r
+ err : Boolean,\r
+ Ba : Bas,\r
+ Ha : Haut,\r
+ Ga : Gauche,\r
+ Dr : Droite,\r
+ c1 : Cub;\r
+Begin\r
+ Ba := New Bas;\r
+ Ha := New Haut;\r
+ Ga := New Gauche;\r
+ Dr := New Droite;\r
+ \r
+ Call Setposition (x+(4*lg) Div 6,y+lg Div 2);\r
+ Call Hidecursor;\r
+ Do\r
+ i := Inkey;\r
+ Call Status (h,v,l,r,z);\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// DROITE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -77) OR (h>=x+(lg+lg Div 3))) Then\r
+ If (x+lg+lg Div 3 < 595-vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x,cour.y);\r
+ If (y = -(x+lg+lg Div 3) + b) Then\r
+ If ((y-lg Div 2 < cour.y) AND (y > cour.y-lg Div 2)) Then\r
+ err := True;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Dr);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// GAUCHE \\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -75) OR (h<=x)) Then\r
+ If (x > vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ b := Calcul_b (cour.x+lg+lg Div 3,cour.y);\r
+ If (y = -x+b) Then\r
+ If ((y-lg Div 2 < cour.y) AND (y > cour.y-lg Div 2)) Then\r
+ err := True;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Ga);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º//////////////////////// BAS \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -80) OR (v>=y+lg)) Then\r
+ If (y+lg < 300-vitd) AND (x > vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ If (y = cour.y-(lg Div 2)) Then\r
+ If ((x <= cour.x+(lg+lg Div 2+lg Div 3)) AND\r
+ (x >= cour.x-(lg Div 2+lg Div 3))) Then\r
+ err := True;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Ba);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////////////// HAUT \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = -72) OR (v<=y)) Then\r
+ If (y-lg Div 2 > vitd) AND (x+lg+lg Div 3 < 595-vith) Then\r
+ err := False;\r
+ cour := debut;\r
+ Do\r
+ If (y-(lg Div 2) = cour.y) Then\r
+ If ((x+(lg + lg Div 2 + lg Div 3) >= cour.x) AND\r
+ (x+(lg Div 2) <= cour.x+(lg + lg Div 3))) Then\r
+ err := True;\r
+ Exit;\r
+ FI;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ If Not err Then\r
+ Attach (Ha);\r
+ Fi;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º///////////////////// VALIDATION \\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+ If ((i = 27) OR l) Then\r
+ cour := debut;\r
+ C1 := new Cub;\r
+ C1.x := x;\r
+ C1.y := y;\r
+ Do\r
+ b := Calcul_b (debut.x+lg+lg Div 3,debut.y);\r
+ If ((y-lg Div 2) < debut.y) AND (x < (b-y))\r
+ OR ((y) < (debut.y-lg Div 2) AND (x >= (b-y))) Then\r
+ C1.suiv := debut;\r
+ debut := C1;\r
+ Exit;\r
+ Fi;\r
+ If (cour.suiv = NONE) Then\r
+ cour.suiv := C1;\r
+ C1.suiv := NONE;\r
+ Exit;\r
+ Fi;\r
+ b := Calcul_b (cour.suiv.x+lg+lg Div 3,cour.suiv.y);\r
+ If ((y-lg Div 2) < cour.suiv.y) AND (x < (b-y))\r
+ OR ((y) < (cour.suiv.y-lg Div 2) AND (x >= (b-y))) Then\r
+ C1.suiv := cour.suiv;\r
+ cour.suiv := C1;\r
+ Exit;\r
+ Fi;\r
+ cour := cour.suiv;\r
+ Od;\r
+ cour := debut;\r
+ Do\r
+ Call Cube (cour.x,cour.y,2);\r
+ Call Noir (cour.x,cour.y,0);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ Od;\r
+ Exit;\r
+ Fi;\r
+ Od;\r
+ Kill (Ba);\r
+ Kill (Ha);\r
+ Kill (Ga);\r
+ Kill (Dr);\r
+End Deplace;\r
+ \r
+End Cub;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º///////////////////// RECTANGLE \\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Rectangle: IIUWGraph Procedure (x1,y1,x2,y2,c : Integer);\r
+Begin\r
+ Call Color (c);\r
+ Call Move (x1,y1);\r
+ Call Draw (x2,y1);\r
+ Call Draw (x2,y2);\r
+ Call Draw (x1,y2);\r
+ Call Draw (x1,y1);\r
+ Call Move (x1+1,y1+1);\r
+ Call Draw (x2-1,y1+1);\r
+ Call Draw (x2-1,y2-1);\r
+ Call Draw (x1+1,y2-1);\r
+ Call Draw (x1+1,y1+1);\r
+End Rectangle;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º////////////////////// EFFACE \\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Efface: IIUWGraph Procedure (x1,y1,x2,y2,c : Integer);\r
+Var\r
+ i : Integer;\r
+Begin\r
+ Call Color (c);\r
+ For i:=y1 To y2 Do\r
+ Call Move (x1,i);\r
+ Call Draw (x2,i);\r
+ Od;\r
+End Efface;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º////////////////////// TEXTE \\\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Texte: IIUWGraph Procedure (x,y : Integer,ch:String);\r
+Begin\r
+ Call Color (9);\r
+ Call Move (x,y);\r
+ Call Outstring (ch);\r
+End Texte;\r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º///////////////////// OPTIONS \\\\\\\\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+Unit Options: IIUWGraph Procedure;\r
+Var\r
+ cc: Cub,\r
+ i: Integer;\r
+Begin\r
+ lg := 30;\r
+ cc := New Cub;\r
+ Call cc.Cube (290,50,15);\r
+ Call cc.Noir (290,50,1);\r
+ Call cc.Cube (235,40,15);\r
+ Call cc.Noir (235,40,2);\r
+ Call cc.Cube (360,35,15);\r
+ Call cc.Noir (360,35,3);\r
+ Call cc.Cube (200,70,15);\r
+ Call cc.Noir (200,70,4);\r
+ Call cc.Cube (260,80,15);\r
+ Call cc.Noir (260,80,5);\r
+ Call cc.Cube (320,75,15);\r
+ Call cc.Noir (320,75,6);\r
+ Call Color (2);\r
+ Call Move (260,135);\r
+ Call Outstring ("OPTIONS");\r
+ Call Color (15);\r
+ Call Move (100,150);\r
+ Call Outstring ("Vitesse");\r
+ Call Move (410,150);\r
+ Call Outstring ("Taille");\r
+ Call Rectangle (150,170,165,185,9);\r
+ Call Rectangle (150,200,165,215,9);\r
+ Call Rectangle (150,230,165,245,9);\r
+ Call Color (15);\r
+ Call Move (180,178);\r
+ Call Outstring ("Lent");\r
+ Call Move (180,208);\r
+ Call Outstring ("Moyen");\r
+ Call Move (180,238);\r
+ Call Outstring ("Rapide");\r
+ Call Rectangle (450,170,465,185,9);\r
+ Call Rectangle (450,200,465,215,9);\r
+ Call Rectangle (450,230,465,245,9);\r
+ Call Color (15);\r
+ Call Move (480,178);\r
+ Call Outstring ("Petit");\r
+ Call Move (480,208);\r
+ Call Outstring ("Moyen");\r
+ Call Move (480,238);\r
+ Call Outstring ("Gros");\r
+ Call Rectangle (250,300,350,330,14);\r
+ Call Texte (265,310,"Continuer");\r
+ Call Efface (152,202,163,213,7);\r
+ Call Efface (452,202,463,213,7);\r
+ lg := 60;\r
+ vitd := 4;\r
+ vith := 6;\r
+ z := Init (i);\r
+ Call Setwindow (0,630,0,330);\r
+ Call Showcursor;\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (l) Then\r
+ Call Hidecursor;\r
+ If ((h >= 250) AND (h <= 350)) AND ((v >= 300) AND (v <= 330)) Then\r
+ Exit;\r
+ Fi;\r
+ If ((h >= 150) AND (h <= 165)) AND ((v >= 170) AND (v <= 185)) Then\r
+ Case (vitd)\r
+ When 2: Call Efface (152,172,163,183,0);\r
+ When 4: Call Efface (152,202,163,213,0);\r
+ When 10: Call Efface (152,232,163,243,0);\r
+ Esac;\r
+ Call Efface (152,172,163,183,7);\r
+ vitd := 2;\r
+ vith := 4;\r
+ Fi;\r
+ If ((h >= 150) AND (h <= 165)) AND ((v >= 200) AND (v <= 215)) Then\r
+ Case (vitd)\r
+ When 2: Call Efface (152,172,163,183,0);\r
+ When 4: Call Efface (152,202,163,213,0);\r
+ When 10: Call Efface (152,232,163,243,0);\r
+ Esac;\r
+ Call Efface (152,202,163,213,7);\r
+ vitd := 4;\r
+ vith := 6;\r
+ Fi;\r
+ If ((h >= 150) AND (h <= 165)) AND ((v >= 230) AND (v <= 245)) Then\r
+ Case (vitd)\r
+ When 2: Call Efface (152,172,163,183,0);\r
+ When 4: Call Efface (152,202,163,213,0);\r
+ When 10: Call Efface (152,232,163,243,0);\r
+ Esac;\r
+ Call Efface (152,232,163,243,7);\r
+ vitd := 10;\r
+ vith := 12;\r
+ Fi;\r
+ If ((h >= 450) AND (h <= 465)) AND ((v >= 170) AND (v <= 185)) Then\r
+ Case (lg)\r
+ When 30: Call Efface (452,172,463,183,0);\r
+ When 60: Call Efface (452,202,463,213,0);\r
+ When 80: Call Efface (452,232,463,243,0);\r
+ Esac;\r
+ Call Efface (452,172,463,183,7);\r
+ lg := 30;\r
+ Fi;\r
+ If ((h >= 450) AND (h <= 465)) AND ((v >= 200) AND (v <= 215)) Then\r
+ Case (lg)\r
+ When 30: Call Efface (452,172,463,183,0);\r
+ When 60: Call Efface (452,202,463,213,0);\r
+ When 80: Call Efface (452,232,463,243,0);\r
+ Esac;\r
+ Call Efface (452,202,463,213,7);\r
+ lg := 60;\r
+ Fi;\r
+ If ((h >= 450) AND (h <= 465)) AND ((v >= 230) AND (v <= 245)) Then\r
+ Case (lg)\r
+ When 30: Call Efface (452,172,463,183,0);\r
+ When 60: Call Efface (452,202,463,213,0);\r
+ When 80: Call Efface (452,232,463,243,0);\r
+ Esac;\r
+ Call Efface (452,232,463,243,7);\r
+ lg := 80\r
+ Fi;\r
+ Call Showcursor;\r
+ Fi;\r
+ Od;\r
+ Call Efface (0,0,640,350,0);\r
+ Kill (cc);\r
+End Options;\r
+ \r
+ \r
+(*ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»*)\r
+(*º/////////////// PROGRAMME PRINCIPAL \\\\\\\\\\\\\\\º*)\r
+(*ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ*)\r
+ \r
+BEGIN\r
+ Pref IIUWGraph Block\r
+ VAR\r
+ i,j,nb : Integer,\r
+ C : Cub;\r
+ Begin\r
+ nb := 13;\r
+ z := Init (j);\r
+ Call Gron (nocard);\r
+ Call Border (5);\r
+ Call Options;\r
+ Call Color (3);\r
+ Call Move (0,300);\r
+ Call Draw (605,300);\r
+ Call Draw (605,310);\r
+ Call Draw (0,310);\r
+ Call Move (605,300);\r
+ Call Draw (638,267);\r
+ Call Move (605,310);\r
+ Call Draw (638,277);\r
+ Call Move (0,320);\r
+ Call Color (15);\r
+ C := New Cub;\r
+ C.x := 200;\r
+ C.y := 150;\r
+ Call C.Cube (C.x,C.y,2);\r
+ debut := C;\r
+ For i:=1 to nb Do\r
+ Call Rectangle (520,315,600,345,14);\r
+ Call Texte (535,325,"Quitter");\r
+ Call Rectangle (420,315,500,345,14);\r
+ Call Texte (435,325,"Suivant");\r
+ z := Init (j);\r
+ Call Setwindow (0,630,0,330);\r
+ Call Showcursor;\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (l) Then\r
+ If ((h >= 520) AND (h <= 600)) AND\r
+ ((v >= 315) AND (v <= 345)) Then\r
+ Call Hidecursor;\r
+ Call Efface (520,315,600,345,0);\r
+ Call Efface (420,315,500,345,0);\r
+ Exit\r
+ Exit;\r
+ Fi;\r
+ If ((h >= 420) AND (h <= 500)) AND\r
+ ((v >= 315) AND (v <= 345)) Then\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Call Hidecursor;\r
+ Call Efface (520,315,600,345,0);\r
+ Call Efface (420,315,500,345,0);\r
+ Call Color (15);\r
+ Call Move (10,320);\r
+ Call Outstring ("D\82placez le cube, et fixez");\r
+ Call Outstring (" le en cliquant sur le bouton de GAUCHE.");\r
+ C := New Cub;\r
+ C.x := 595-lg-lg Div 3;\r
+ C.y := 290-lg;\r
+ Call C.Cube (C.x,C.y,15);\r
+ z := Init (j);\r
+ Call C.Deplace;\r
+ Call Move (10,320);\r
+ Call Outstring (" ");\r
+ Call Outstring (" ");\r
+ Od;\r
+ Call Move (0,320);\r
+ Call Color (15);\r
+ Call Outstring ("Cliquez sur le bouton de DROITE");\r
+ Call Outstring (" pour obtenir une figure en couleurs. ");\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (r) Then\r
+ i := 1;\r
+ cour := debut;\r
+ Do\r
+ Call C.Cube (cour.x,cour.y,15);\r
+ Call C.Noir (cour.x,cour.y,i);\r
+ If (cour.suiv = NONE) Then\r
+ Exit;\r
+ Else\r
+ cour := cour.suiv;\r
+ Fi;\r
+ i := i + 1;\r
+ Od;\r
+ Exit;\r
+ Fi;\r
+ Od;\r
+ Call Move (0,320);\r
+ Call Color (15);\r
+ Call Outstring ("Cliquez sur le bouton de GAUCHE");\r
+ Call Outstring (" pour sortir ... ");\r
+ Do\r
+ Call Status (h,v,l,r,z);\r
+ If (l) Then\r
+ Exit;\r
+ Fi;\r
+ Od;\r
+ Call Groff;\r
+ End;\r
+End;\r
+END Infographie.\r
+ \r
--- /dev/null
+program dominate;\r
+\r
+Unit elem:class;\r
+var couleur:integer,x:integer,y:integer;\r
+end elem;\r
+\r
+Unit init_tab:procedure;\r
+var i,j,valx,valy:integer;\r
+begin\r
+(* INITIALISATION DES COULEURS *)\r
+for i:=-1 to 10\r
+do\r
+ for j:=-1 to 10\r
+ do\r
+ tab(i,j):=new elem;\r
+ verif(i,j):=new elem;\r
+ tab(i,j).couleur:=0;\r
+ verif(i,j).couleur:=0;\r
+ \r
+ od;\r
+od;\r
+for i:=-2 to 11\r
+do\r
+ for j:=-2 to 11\r
+ do\r
+ simul(i,j):=new elem;\r
+ simul(i,j).couleur:=0;\r
+ od;\r
+od;\r
+tab(1,1).couleur:=1;\r
+tab(8,8).couleur:=1;\r
+tab(8,1).couleur:=2;\r
+tab(1,8).couleur:=2;\r
+verif(1,1).couleur:=1;\r
+verif(8,8).couleur:=1;\r
+verif(8,1).couleur:=2;\r
+verif(1,8).couleur:=2;\r
+(* INITIALISATION DES POSITIONS *)\r
+valx:= 120;\r
+valy:= 50;\r
+for i:=-1 to 10\r
+do\r
+ tab(-1,i).x:=0;\r
+ tab(i,-1).x:=0;\r
+ tab(-1,i).x:=0;\r
+ tab(i,-1).x:=0;\r
+od;\r
+for i:=-1 to 10\r
+do\r
+ tab(10,i).x:=0;\r
+ tab(i,10).x:=0;\r
+ tab(10,i).x:=0;\r
+ tab(i,10).x:=0;\r
+od;\r
+\r
+for i:=1 to 8\r
+do\r
+ for j:=1 to 8\r
+ do\r
+ tab(i,j).x := valx;\r
+ tab(i,j).y := valy;\r
+ valx:=valx+50;\r
+ od;\r
+ valx:=120;\r
+ valy:=valy+50;\r
+od; \r
+end init_tab;\r
+\r
+Unit aff_tab:procedure;\r
+var i,j:integer;\r
+begin\r
+for i:=1 to 8\r
+do\r
+ for j:=1 to 8\r
+ do\r
+ write(tab(i,j).couleur);\r
+ od;\r
+ writeln;\r
+od;\r
+end aff_tab;\r
+\r
+Unit aff_simul:procedure;\r
+var i,j:integer;\r
+begin\r
+for i:=1 to 8\r
+do\r
+ for j:=1 to 8\r
+ do\r
+ write(simul(i,j).couleur);\r
+ od;\r
+ writeln;\r
+od;\r
+end aff_simul;\r
+\r
+Unit aff_verif:procedure;\r
+var i,j:integer;\r
+begin\r
+for i:=1 to 8\r
+do\r
+ for j:=1 to 8\r
+ do\r
+ write(verif(i,j).couleur);\r
+ od;\r
+ writeln;\r
+od;\r
+end aff_verif;\r
+\r
+\r
+Unit creatab:procedure;\r
+var i:integer;\r
+begin\r
+array tab dim(-1:10);\r
+ for i:=-1 to 10\r
+ do\r
+ array tab(i) dim(-1:10);\r
+ od;\r
+array verif dim(-1:10);\r
+ for i:=-1 to 10\r
+ do\r
+ array verif(i) dim(-1:10);\r
+ od;\r
+array simul dim(-2:11);\r
+ for i:=-2 to 11\r
+ do\r
+ array simul(i) dim(-2:11);\r
+ od;\r
+\r
+end creatab;\r
+\r
+unit recopie : procedure;\r
+var i,j:integer;\r
+begin\r
+for i:=-1 to 10\r
+do\r
+ for j:=-1 to 10\r
+ do\r
+ simul(i,j).couleur:=tab(i,j).couleur;\r
+ od;\r
+od;\r
+end recopie;\r
+\r
+unit ecran : procedure;\r
+begin\r
+ pref IIUWGRAPH block\r
+ \r
+ unit sortie:procedure;\r
+ begin\r
+ call groff;\r
+ end sortie;\r
+ \r
+ var i:integer,rep:char ;\r
+ begin\r
+ pref MOUSE block\r
+ \r
+ unit presentation:procedure;\r
+ begin\r
+ call bouton(110,150,530,330);\r
+ call outstring(230,220," PROJET nø2 DE LI1 ",15,7);\r
+ call outstring(230,240,"DOMINATE : jeu de strategie",15,7);\r
+ call outstring(0,0,"ANTON JEAN-FRANCOIS",15,0);\r
+ call outstring(0,20,"LAVIGNOTTE SEBASTIEN",15,0);\r
+ call outstring(0,40,"Licence Informatique - Groupe II",15,0);\r
+ call outstring(0,60,"Annee universitaire 1994/1995",15,0);\r
+ call outstring(200,450,"Appuyer sur le bouton GAUCHE de votre souris...",15,0);\r
+ \r
+ (* Attente de l'appui de la souris *)\r
+ while (Num_Mouse <> 1)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ od;\r
+ \r
+ call cls;\r
+ call cadre;\r
+ call menu0;\r
+ end presentation;\r
+ \r
+ unit finir : procedure;\r
+ var i,j:integer,modifie :boolean;\r
+ begin\r
+ modifie:=false;\r
+ if num_joueur=1 then num_joueur:=2;\r
+ else num_joueur:=1;\r
+ \r
+ fi;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ if tab(i,j).couleur=0 \r
+ then \r
+ tab(i,j).couleur:=num_joueur;\r
+ modifie:=true;\r
+ fi;\r
+ if modifie\r
+ then\r
+ call affic;\r
+ call compte;\r
+ modifie:=false;\r
+ fi;\r
+ od;\r
+ od;\r
+ call compte;\r
+ call affic;\r
+ call finjeu;\r
+ \r
+ end finir;\r
+\r
+ unit finjeu : procedure;\r
+ begin\r
+ call bouton(214,200,428,320);\r
+ if ( nombre1 > nombre2 ) then\r
+ call outstring(250,230,"VAINQUEUR : JOUEUR 1",15,7);\r
+ else\r
+ call outstring(250,230,"VAINQUEUR : JOUEUR 2",15,7);\r
+ fi;\r
+ call bouton(270,270,380,300);\r
+ call outstring(280,280,"cliquez ici",15,7); \r
+ while (Num_Mouse<>3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=270 and x_s<=380) and (y_s>=270 and y_s<=300)\r
+ then call cls;\r
+ call cadre;\r
+ call menu0;\r
+ fi;\r
+ fi;\r
+ od;\r
+ end finjeu;\r
+\r
+ unit tirage : procedure;\r
+ var x:real,i,premier:integer;\r
+ begin\r
+ premier:=0;\r
+ call bouton(214,200,428,320);\r
+ call outstring(265,230,"Tirage au sort",15,7);\r
+ x:=random;\r
+ if (x>=0 and x<0.5) then premier:=1;fi;\r
+ if (x>=0.5 and x<1) then premier:=2;fi;\r
+ for i:=1 to 1000\r
+ do\r
+ call outstring(321,285,"³",15,7);\r
+ call outstring(321,285,"\",15,7);\r
+ call outstring(321,285," ",15,7);\r
+ call outstring(321,285,"Ä",15,7);\r
+ call outstring(321,285,"/",15,7);\r
+ call outstring(321,285," ",15,7);\r
+ od;\r
+ if (premier=1) then\r
+ call outstring(220,285,"Le JOUEUR 1 va commencer",15,7);\r
+ num_joueur:=1;\r
+ else call outstring(220,285,"Le JOUEUR 2 va commencer",15,7);\r
+ num_joueur:=2;\r
+ fi;\r
+ call bouton(250,250,360,280);\r
+ call outstring(260,260,"cliquez ici",15,7); \r
+ while (Num_Mouse<>3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=250 and x_s<=360) and (y_s>=240 and y_s<=270)\r
+ then call cls;\r
+ call cadre;\r
+ if num_joueur=1 then\r
+ case type1\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ else\r
+ case type2\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ end tirage;\r
+ \r
+ unit info1 : procedure;\r
+ begin\r
+ call patern(10,100,20,110,4,1);\r
+ call outstring(30,100,"JOUEUR 1",4,0);\r
+ call patern(100,100,110,110,4,1);\r
+ call outstring(10,150,"POINTS : ",4,0);\r
+ call track(80,150,nombre1,0,4); \r
+ end info1;\r
+\r
+ unit info2 : procedure;\r
+ begin\r
+ call patern(530,100,540,110,9,1);\r
+ call outstring(550,100,"JOUEUR 2",9,0);\r
+ call patern(620,100,630,110,9,1);\r
+ call outstring(530,150,"POINTS : ",9,0);\r
+ call track(600,150,nombre2,0,9);\r
+ end info2;\r
+ \r
+ unit erreur : procedure;\r
+ begin\r
+ call patern(0,460,640,479,10,1);\r
+ call outstring(260,465,"COUP IMPOSSIBLE A REALISER",15,10);\r
+ call cls;\r
+ call cadre;\r
+ call tourjeu;\r
+ end erreur;\r
+ \r
+ unit choix : procedure;\r
+ begin\r
+ call bouton(189,175,453,345);\r
+ call point(321,177);\r
+ call draw(321,343);\r
+ call outstring(223,185,"JOUEUR 1",0,7);\r
+ call outstring(200,210,"humain",0,7);\r
+ call patern(305,210,315,225,15,1);\r
+ call outstring(200,240,"expansion",0,7);\r
+ call patern(305,240,315,255,15,1);\r
+ call outstring(200,270,"destruction",0,7);\r
+ call patern(305,270,315,285,15,1);\r
+ call outstring(355,185,"JOUEUR 2",0,7);\r
+ call outstring(332,210,"humain",0,7);\r
+ call patern(437,210,447,225,15,1);\r
+ call outstring(332,240,"expansion",0,7);\r
+ call patern(437,240,447,255,15,1);\r
+ call outstring(332,270,"destruction",0,7);\r
+ call patern(437,270,447,285,15,1);\r
+ call bouton(306,300,336,320);\r
+ call outstring(315,305,"OK",15,7);\r
+ case type1\r
+ when 1 : call outstring(306,211,"X",0,15);\r
+ when 2 : call outstring(306,241,"X",0,15);\r
+ when 3 : call outstring(306,271,"X",0,15);\r
+ esac;\r
+ case type2\r
+ when 1 : call outstring(438,211,"X",0,15);\r
+ when 2 : call outstring(438,241,"X",0,15);\r
+ when 3 : call outstring(438,271,"X",0,15);\r
+ esac;\r
+ while (Num_mouse <> 3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=306 and x_s<=336) and (y_s>=300 and y_s<=320)\r
+ then call cls;\r
+ call cadre;\r
+ call tirage;\r
+ fi;\r
+ if (x_s>=305 and x_s<=315) and (y_s>=210 and y_s<=220)\r
+ then call patern(305,210,315,225,15,1);\r
+ call patern(305,240,315,255,15,1);\r
+ call patern(305,270,315,285,15,1);\r
+ call outstring(306,211,"X",0,15);\r
+ type1:=1;\r
+ fi;\r
+ if (x_s>=305 and x_s<=315) and (y_s>=240 and y_s<=250)\r
+ then call patern(305,210,315,225,15,1);\r
+ call patern(305,240,315,255,15,1);\r
+ call patern(305,270,315,285,15,1);\r
+ call outstring(306,241,"X",0,15);\r
+ type1:=2;\r
+ fi;\r
+ if (x_s>=305 and x_s<=315) and (y_s>=270 and y_s<=280)\r
+ then call patern(305,210,315,225,15,1);\r
+ call patern(305,240,315,255,15,1);\r
+ call patern(305,270,315,285,15,1);\r
+ call outstring(306,271,"X",0,15);\r
+ type1:=3;\r
+ fi;\r
+ if (x_s>=437 and x_s<=447) and (y_s>=210 and y_s<=220)\r
+ then call patern(437,210,447,225,15,1);\r
+ call patern(437,240,447,255,15,1);\r
+ call patern(437,270,447,285,15,1);\r
+ call outstring(438,211,"X",0,15);\r
+ type2:=1;\r
+ fi;\r
+ if (x_s>=437 and x_s<=447) and (y_s>=240 and y_s<=250)\r
+ then call patern(437,210,447,225,15,1);\r
+ call patern(437,240,447,255,15,1);\r
+ call patern(437,270,447,285,15,1);\r
+ call outstring(438,241,"X",0,15);\r
+ type2:=2;\r
+ fi;\r
+ if (x_s>=437 and x_s<=447) and (y_s>=270 and y_s<=280)\r
+ then call patern(437,210,447,225,15,1);\r
+ call patern(437,240,447,255,15,1);\r
+ call patern(437,270,447,285,15,1);\r
+ call outstring(438,271,"X",0,15);\r
+ type2:=3;\r
+ fi;\r
+\r
+ fi;\r
+ od; \r
+ \r
+ end choix;\r
+ \r
+ unit aide : procedure;\r
+ begin\r
+call bouton(10,50,632,460);\r
+call outstring(304,80,"AIDE",15,7);\r
+call point(300,95);\r
+call draw(336,95);\r
+call outstring(20,110,"CONTROLE ET REGLE DU JEU",15,7);\r
+call outstring(20,125,"Bienvenue sur DOMINATE. Ce jeu est bas\82 sur les r\8agles du",0,7); \r
+call outstring(20,140,"tr\8as vieux et tr\8as c\82l\8abre 'GO'. C'est donc un jeu de",0,7); \r
+call outstring(20,155,"strat\82gie de plateau o\97 le but est de recouvrir un",0,7);\r
+call outstring(20,170,"maximum d'espaces avec la couleur de votre joueur.",0,7);\r
+call outstring(20,185,"MOUVEMENT DURANT LE JEU",15,7);\r
+call outstring(20,200,"Quand c'est votre tour de jouer, choisissez simplement la",0,7);\r
+call outstring(20,215,"pi\8ace \85 bouger en cliquant dessus \85 l'aide du bouton",0,7);\r
+call outstring(20,230,"gauche de la souris. Durant le jeu, il est possible de",0,7);\r
+call outstring(20,245,"bouger sur une case voisine dans n'importe quelle",0,7); \r
+call outstring(20,260,"direction ou sauter horizontalement et verticalement par",0,7);\r
+call outstring(20,275,"dessus un obstacle. Si vous sautez, l'espace par dessus",0,7);\r
+call outstring(20,290,"lequel vous bougez garde son \82tat initial, malgr\82 que la",0,7);\r
+call outstring(20,305,"case de destination change de couleur.",0,7);\r
+call outstring(20,320,"Apr\82s votre mouvement toutes les pi\8aces adversaires ",0,7);\r
+call outstring(20,335,"voisines \85 la case de destination deviennent de votre",0,7); \r
+call outstring(20,350,"couleur.",0,7);\r
+call outstring(20,365,"GAGNER UNE PARTIE",15,7);\r
+call outstring(20,380,"Lorsque toutes les cases du plateau sont utilis\82es, ou si",0,7);\r
+call outstring(20,395,"un des deux joueurs ne peut plus bouger, l'ordinateur",0,7);\r
+call outstring(20,410,"remplit les cases libres, en correspondance avec les",0,7);\r
+call outstring(20,425,"mouvements de chaque joueur, le joueur qui poss\8ade alors",0,7);\r
+call outstring(20,440," le plus de cases du plateau est le vainqueur.",0,7); \r
+call bouton(490,390,600,420);\r
+ call outstring(500,400,"cliquez ici",15,7); \r
+ while (Num_Mouse<>3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=490 and x_s<=600) and (y_s>=390 and y_s<=420)\r
+ then call cls;\r
+ call cadre;\r
+ call menu0; \r
+ fi;\r
+ fi;\r
+ od;\r
+ end aide;\r
+\r
+ unit cadre : procedure;\r
+ var i,j:integer;\r
+ begin\r
+ if num_joueur=1 then call patern(25,95,95,115,15,0);\r
+ else call patern(545,95,615,115,15,0);\r
+ fi; \r
+ call bouton(5,5,640,30);\r
+ call outstring(20,13,"QUITTER",15,7);\r
+ call outstring(125,13,"JEU",15,7);\r
+ call outstring(200,13,"AIDE",15,7);\r
+ call info1;\r
+ call info2;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ call patern(tab(i,j).x,tab(i,j).y,tab(i,j).x+50,tab(i,j).y+50,15,0);\r
+ \r
+ od;\r
+ od;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ case tab(i,j).couleur\r
+ when 0 : ;\r
+ when 1 : call patern(tab(i,j).x+1,tab(i,j).y+1,tab(i,j).x+49,tab(i,j).y+49,4,1);\r
+ when 2 : call patern(tab(i,j).x+1,tab(i,j).y+1,tab(i,j).x+49,tab(i,j).y+49,9,1);\r
+ when 3 : call patern(tab(i,j).x,tab(i,j).y,tab(i,j).x+50,tab(i,j).y+50,2,0);\r
+ when 4 : call patern(tab(i,j).x,tab(i,j).y,tab(i,j).x+50,tab(i,j).y+50,14,0);\r
+ esac; \r
+ \r
+ \r
+ od;\r
+ od;\r
+ end cadre;\r
+\r
+ unit affic : procedure;\r
+ var i,j:integer;\r
+ begin\r
+ if num_joueur=1 then call patern(25,95,95,115,15,0);\r
+ call patern(545,95,615,115,0,0); \r
+ else call patern(545,95,615,115,15,0);\r
+ call patern(25,95,95,115,0,0);\r
+ fi; \r
+ call patern(79,149,95,172,0,1); \r
+ call track(80,150,nombre1,0,4);\r
+ call patern(599,149,615,172,0,1);\r
+ call track(600,150,nombre2,0,9);\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ case tab(i,j).couleur\r
+ when 0 : call patern(tab(i,j).x+1,tab(i,j).y+1,tab(i,j).x+49,tab(i,j).y+49,0,1);\r
+ when 1 : call patern(tab(i,j).x+1,tab(i,j).y+1,tab(i,j).x+49,tab(i,j).y+49,4,1);\r
+ when 2 : call patern(tab(i,j).x+1,tab(i,j).y+1,tab(i,j).x+49,tab(i,j).y+49,9,1);\r
+ when 3 : call patern(tab(i,j).x,tab(i,j).y,tab(i,j).x+50,tab(i,j).y+50,2,0);\r
+ when 4 : call patern(tab(i,j).x,tab(i,j).y,tab(i,j).x+50,tab(i,j).y+50,14,0);\r
+ esac; \r
+ \r
+ \r
+ od;\r
+ od;\r
+ end affic;\r
+ unit vraiquit : procedure;\r
+ begin\r
+ call bouton(214,200,428,320);\r
+ call outstring(290,230,"QUITTER ?",15,7);\r
+ call bouton(250,300,300,280);\r
+ call outstring(260,285,"OUI",15,7);\r
+ call bouton(342,300,392,280);\r
+ call outstring(352,285,"NON",15,7);\r
+ while (Num_Mouse<>3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=250 and x_s<=300) and (y_s>=280 and y_s<=300)\r
+ then call groff;\r
+ call endrun;\r
+ fi;\r
+ if (x_s>=342 and x_s<=392) and (y_s>=280 and y_s<=300)\r
+ then call cls;\r
+ call cadre;\r
+ call menu0; \r
+ fi;\r
+ \r
+ fi;\r
+ od;\r
+ end vraiquit;\r
+\r
+ unit noujeu : procedure;\r
+ begin\r
+ call bouton(214,200,428,320);\r
+ call outstring(270,230,"NOUVEAU JEU ?",15,7);\r
+ call bouton(250,300,300,280);\r
+ call outstring(260,285,"OUI",15,7);\r
+ call bouton(342,300,392,280);\r
+ call outstring(352,285,"NON",15,7);\r
+ while (Num_Mouse<>3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=250 and x_s<=300) and (y_s>=280 and y_s<=300)\r
+ then call init_tab;\r
+ call compte;\r
+ call cls;\r
+ call cadre;\r
+ call choix;\r
+ fi;\r
+ if (x_s>=342 and x_s<=392) and (y_s>=280 and y_s<=300)\r
+ then call cls;\r
+ call cadre;\r
+ call menu0;\r
+ fi;\r
+ \r
+ fi;\r
+ od;\r
+ end noujeu;\r
+\r
+ unit menu0 : procedure;\r
+ var i:integer;\r
+ (*\r
+ * Affichage et gestion du premier\r
+ * menu utilisateur du programme.\r
+ *)\r
+ begin\r
+ \r
+ while (Num_Mouse<>3)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse) ;\r
+ if num_mouse = 1 then\r
+ if (x_s>=20 and x_s<=80) and (y_s>=5 and y_s<=30)\r
+ then call vraiquit;\r
+ fi;\r
+ if (x_s>=125 and x_s<=155) and (y_s>=5 and y_s<=30)\r
+ then call noujeu;\r
+ \r
+ fi;\r
+ if (x_s>=200 and x_s<=240) and (y_s>=5 and y_s<=30)\r
+ then call aide; \r
+ fi;\r
+ \r
+ if (x_s>=120 and x_s<=520) and (y_s>=50 and y_s<=450)\r
+ then\r
+ if num_joueur=1 then\r
+ case type1\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ else\r
+ case type2\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ \r
+ end menu0;\r
+ \r
+\r
+ unit tourjeu : procedure;\r
+ var inter:integer;\r
+ begin\r
+ inter:=0;\r
+ fini:=false;\r
+ trouve:=false;\r
+ termine:=false;\r
+ call remis0(tab);\r
+ call remis0(verif); \r
+ call cadre;\r
+possible:=false;\r
+call verifjeu;\r
+if (possible) then \r
+ while (not fini)\r
+ do \r
+ \r
+ while (not trouve)\r
+ do \r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse);\r
+ if (num_mouse = 1) then\r
+ if y_s <30 then call menu0;fi;\r
+ call reccase1(x_s,y_s);\r
+ fi;\r
+ od; \r
+ if (tab(coury,courx).couleur = num_joueur)\r
+ then\r
+ call remis0(tab);\r
+ call remis0(verif); \r
+ call affpos;\r
+ call affic;\r
+ else call tourjeu;\r
+ fi; \r
+ \r
+ while (not termine)\r
+ do\r
+ Mouse:=getpress(x_s,y_s,Keyb1,Keyb2,Flag,Num_Mouse);\r
+ if (num_mouse = 1) then\r
+ if y_s <30 then call menu0;fi;\r
+ call reccase2(x_s,y_s);\r
+ fi;\r
+ od;\r
+ if ( (indx=courx) and (indy=coury))\r
+ then call tourjeu;\r
+ else\r
+ \r
+ if ((tab(indy,indx).couleur <>3) and (tab(indy,indx).couleur <>4)) \r
+ then\r
+ call tourjeu;\r
+ else\r
+ \r
+ case tab(indy,indx).couleur \r
+ when 3 :tab(indy,indx).couleur:=num_joueur;\r
+ verif(indy,indx).couleur:=num_joueur;\r
+ fini:=true;\r
+ termine:=true;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ call consequence;\r
+ call affic;\r
+ \r
+ \r
+ when 4 : tab(coury,courx).couleur:=0;\r
+ tab(indy,indx).couleur:=num_joueur;\r
+ verif(coury,courx).couleur:=0;\r
+ verif(indy,indx).couleur:=num_joueur;\r
+ fini:=true;\r
+ termine:=true;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ call consequence;\r
+ call affic;\r
+ esac; \r
+ fi;fi;\r
+ od;\r
+ call compte; \r
+ if (fini) then\r
+ if num_joueur=1 then num_joueur:=2;\r
+ else \r
+ num_joueur:=1;\r
+ \r
+ fi;\r
+ trouve:=false;\r
+ termine:=false;\r
+ call affic;\r
+ if num_joueur=1 then\r
+ courx:=1;coury:=1;\r
+ case type1\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ else\r
+ case type2\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ fi;\r
+ \r
+ fi; \r
+else\r
+call finir;\r
+fi; \r
+ end tourjeu;\r
+\r
+ unit expansion : procedure;\r
+ var i,j,a,b:integer,ok:boolean;\r
+ \r
+ begin\r
+ call verifjeu;\r
+ ok:=false;\r
+ if (possible)\r
+ then\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ if tab(i,j).couleur=num_joueur\r
+ then\r
+ indy:=i;indx:=j;\r
+ courx:=j;coury:=i;\r
+ call affpos;\r
+ fi;\r
+ od;\r
+ od;\r
+ for a:=1 to 8\r
+ do\r
+ for b:=1 to 8\r
+ do\r
+ if (tab(a,b).couleur = 3) then\r
+ if (not ok) then\r
+ tab(a,b).couleur:=num_joueur;\r
+ verif(a,b).couleur:=num_joueur;\r
+ ok:=true;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ indx:=b;indy:=a;\r
+ call consequence;\r
+ call affic;\r
+ fi;\r
+ fi;\r
+ od;\r
+ od;\r
+ \r
+ for a:=1 to 8\r
+ do\r
+ for b:=1 to 8\r
+ do\r
+ case tab(a,b).couleur \r
+ when 4 : if (not ok) then\r
+ tab(coury,courx).couleur:=0;\r
+ tab(a,b).couleur:=num_joueur;\r
+ verif(coury,courx).couleur:=0;\r
+ verif(a,b).couleur:=num_joueur;\r
+ ok:=true;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ indx:=b;indy:=a;\r
+ call consequence;\r
+ call affic;\r
+ fi;\r
+ esac; \r
+ od;\r
+ od;\r
+ \r
+ if (ok)\r
+ then\r
+ if num_joueur=1 then num_joueur:=2;\r
+ else \r
+ num_joueur:=1;\r
+ fi;\r
+ call compte;\r
+ call affic;\r
+ if num_joueur=1 then\r
+ case type1\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ else\r
+ case type2\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac; \r
+ fi;\r
+ fi; \r
+ else\r
+ call finir;\r
+ fi; \r
+ \r
+ end expansion;\r
+\r
+ unit destruction : procedure;\r
+ var i,j,a,b,premx,premy,derx,dery,actuel : integer,teremi:boolean;\r
+ begin\r
+ call verifjeu;\r
+ if possible\r
+ then\r
+ call recopie;\r
+ teremi := false;\r
+ if num_joueur=1 then actuel:=nombre1;\r
+ else actuel:=nombre2;\r
+ fi;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do call remis0(tab);\r
+ call recopie;\r
+ if tab(i,j).couleur=num_joueur\r
+ then\r
+ indx:=j;indy:=i;\r
+ call affpos;\r
+ if (pos <> 0 )\r
+ then\r
+ for a:=i-2 to i+2\r
+ do\r
+ for b:=j-2 to j+2\r
+ do\r
+ if (a>=1 and a<=8) and (b>=1 and b<=8)\r
+ then\r
+ case tab(a,b).couleur \r
+ when 3 : simul(a,b).couleur:=num_joueur;\r
+ ix:=b;iy:=a;\r
+ call cons;\r
+ call simcom;\r
+ if ( nomb > actuel )\r
+ then\r
+ premx:=j;premy:=i;\r
+ derx:=b;dery:=a;\r
+ actuel:=nomb; \r
+ fi;\r
+ when 4 : simul(a,b).couleur:=num_joueur;\r
+ simul(i,j).couleur:=0;\r
+ ix:=b;iy:=a;\r
+ call cons;\r
+ call simcom;\r
+ if ( nomb > actuel )\r
+ then\r
+ premx:=j;premy:=i;\r
+ derx:=b;dery:=a;\r
+ actuel:=nomb; \r
+ fi;\r
+ esac;\r
+ call recopie;\r
+ fi;\r
+ od;\r
+ od;\r
+ fi;\r
+ fi; \r
+ od;\r
+ call remis0(tab);\r
+ od;\r
+\r
+ if (tab(premy,premx).couleur = num_joueur) then\r
+ indx:=premx;indy:=premy;\r
+ call affpos;\r
+ case tab(dery,derx).couleur\r
+ when 3 : tab(dery,derx).couleur:=num_joueur;\r
+ verif(dery,derx).couleur:=num_joueur;\r
+ teremi:=true;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ indx:=derx;indy:=dery;\r
+ call consequence;\r
+ call affic;\r
+ when 4 : tab(premy,premx).couleur:=0;\r
+ tab(dery,derx).couleur:=num_joueur;\r
+ verif(premy,premx).couleur:=0;\r
+ verif(dery,derx).couleur:=num_joueur;\r
+ teremi:=true;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ indx:=derx;indy:=dery;\r
+ call consequence;\r
+ call affic;\r
+ esac; \r
+ fi;\r
+\r
+ if (teremi)\r
+ then\r
+ if num_joueur=1 then num_joueur:=2;\r
+ else \r
+ num_joueur:=1;\r
+ fi;\r
+ call compte;\r
+ call affic;\r
+ if num_joueur=1 then\r
+ case type1\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac;\r
+ else\r
+ case type2\r
+ when 1 : call tourjeu;\r
+ when 2 : call expansion;\r
+ when 3 : call destruction;\r
+ esac; \r
+ fi;\r
+ fi;\r
+ else call finir;\r
+ fi; \r
+ call recopie;\r
+ call remis0(tab);\r
+ call remis0(verif);\r
+ end destruction;\r
+\r
+ unit compte : procedure;\r
+ var\r
+ i,j,jou1,jou2:integer;\r
+ begin\r
+ jou1:=0;\r
+ jou2:=0;\r
+ for i:=1 to 8 \r
+ do\r
+ for j:=1 to 8\r
+ do \r
+ if tab(i,j).couleur=1 then jou1:=jou1+1;fi;\r
+ if tab(i,j).couleur=2 then jou2:=jou2+1;fi;\r
+ \r
+ od;\r
+ od;\r
+ nombre1:=jou1;\r
+ nombre2:=jou2;\r
+ end compte;\r
+\r
+ unit simcom : procedure;\r
+ var\r
+ i,j,jou1,jou2:integer;\r
+ begin\r
+ jou1:=0;\r
+ jou2:=0;\r
+ for i:=1 to 8 \r
+ do\r
+ for j:=1 to 8\r
+ do \r
+ if simul(i,j).couleur=1 then jou1:=jou1+1;fi;\r
+ if simul(i,j).couleur=2 then jou2:=jou2+1;fi;\r
+ od;\r
+ od;\r
+ if num_joueur=1\r
+ then\r
+ nomb:=jou1;\r
+ else\r
+ nomb:=jou2;\r
+ fi;\r
+ end simcom;\r
+\r
+ unit consequence : procedure;\r
+ begin\r
+ if tab(indy-1,indx-1).couleur<>0 then \r
+ tab(indy-1,indx-1).couleur:=num_joueur;\r
+ verif(indy-1,indx-1).couleur:=num_joueur;fi;\r
+ if tab(indy-1,indx).couleur<>0 then\r
+ tab(indy-1,indx).couleur:=num_joueur;\r
+ verif(indy-1,indx).couleur:=num_joueur;fi;\r
+ if tab(indy-1,indx+1).couleur<>0 then \r
+ tab(indy-1,indx+1).couleur:=num_joueur;\r
+ verif(indy-1,indx+1).couleur:=num_joueur;fi;\r
+ if tab(indy,indx-1).couleur<>0 then \r
+ tab(indy,indx-1).couleur:=num_joueur;\r
+ verif(indy,indx-1).couleur:=num_joueur;fi;\r
+ if tab(indy,indx+1).couleur<>0 then \r
+ tab(indy,indx+1).couleur:=num_joueur;\r
+ verif(indy,indx+1).couleur:=num_joueur;fi;\r
+ if tab(indy+1,indx-1).couleur<>0 then \r
+ tab(indy+1,indx-1).couleur:=num_joueur;\r
+ verif(indy+1,indx-1).couleur:=num_joueur;fi;\r
+ if tab(indy+1,indx).couleur<>0 then \r
+ tab(indy+1,indx).couleur:=num_joueur;\r
+ verif(indy+1,indx).couleur:=num_joueur;fi;\r
+ if tab(indy+1,indx+1).couleur<>0 then \r
+ tab(indy+1,indx+1).couleur:=num_joueur;\r
+ verif(indy+1,indx+1).couleur:=num_joueur;fi;\r
+ \r
+ end consequence;\r
+\r
+unit cons : procedure;\r
+ begin\r
+ call remis0(simul);\r
+ if simul(iy-1,ix-1).couleur<>0 then \r
+ simul(iy-1,ix-1).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy-1,ix).couleur<>0 then\r
+ simul(iy-1,ix).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy-1,ix+1).couleur<>0 then \r
+ simul(iy-1,ix+1).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy,ix-1).couleur<>0 then \r
+ simul(iy,ix-1).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy,ix+1).couleur<>0 then \r
+ simul(iy,ix+1).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy+1,ix-1).couleur<>0 then \r
+ simul(iy+1,ix-1).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy+1,ix).couleur<>0 then \r
+ simul(iy+1,ix).couleur:=num_joueur;\r
+ fi;\r
+ if simul(iy+1,ix+1).couleur<>0 then \r
+ simul(iy+1,ix+1).couleur:=num_joueur;\r
+ fi;\r
+ \r
+ end cons;\r
+\r
+\r
+ unit affpos : procedure;\r
+ var i,j : integer;\r
+ begin\r
+ j:=indx;i:=indy;\r
+ pos:=0; \r
+ if (tab(i,j).couleur=num_joueur) then \r
+ if tab(i-1,j-1).couleur=0 then tab(i-1,j-1).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i-1,j).couleur=0 then tab(i-1,j).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i-1,j+1).couleur=0 then tab(i-1,j+1).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i,j-1).couleur=0 then tab(i,j-1).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i,j+1).couleur=0 then tab(i,j+1).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i+1,j-1).couleur=0 then tab(i+1,j-1).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i+1,j).couleur=0 then tab(i+1,j).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i+1,j+1).couleur=0 then tab(i+1,j+1).couleur:=3;pos:=pos+1;fi;\r
+ if tab(i+2,j).couleur=0 then tab(i+2,j).couleur:=4;pos:=pos+1;fi;\r
+ if tab(i-2,j).couleur=0 then tab(i-2,j).couleur:=4;pos:=pos+1;fi;\r
+ if tab(i,j+2).couleur=0 then tab(i,j+2).couleur:=4;pos:=pos+1;fi;\r
+ if tab(i,j-2).couleur=0 then tab(i,j-2).couleur:=4;pos:=pos+1;fi;\r
+ fi;\r
+ \r
+ \r
+ end affpos;\r
+ \r
+ \r
+\r
+ unit reccase1 : procedure(x_s,y_s:integer);\r
+ var px,py :integer;\r
+ begin\r
+ px:=120;py:=50;courx:=1;coury:=1;\r
+ trouve:=false;\r
+ (* recherche de x *)\r
+ if ((x_s<120) or (y_s>520)) then call erreur;\r
+ else\r
+ while (not trouve) \r
+ do\r
+ if ((x_s>=px) and (x_s<px+50))\r
+ then\r
+ trouve:= true;\r
+ else\r
+ px:=px+50;\r
+ courx:=courx+1;\r
+ fi; \r
+ od; \r
+ fi;\r
+ (* recherche de y *)\r
+ trouve:=false;\r
+ if ((y_s<50) or (y_s>450)) then call erreur;\r
+ else\r
+ while (not trouve)\r
+ do\r
+ if ((y_s>=py) and (y_s<py+50))\r
+ then\r
+ trouve:= true;\r
+ else\r
+ py:=py+50;\r
+ coury:=coury+1;\r
+ fi; \r
+ od; \r
+ fi;\r
+ \r
+ end reccase1;\r
+\r
+unit reccase2 : procedure(x_s,y_s:integer);\r
+ var px,py :integer;\r
+ begin\r
+ px:=120;py:=50;indx:=1;indy:=1;\r
+ termine:=false;\r
+ (* recherche de x *)\r
+ if ((x_s<120) or (x_s>520)) then call erreur;\r
+ else\r
+ while (not termine) \r
+ do\r
+ if ((x_s>=px) and (x_s<px+50))\r
+ then\r
+ termine:= true;\r
+ else\r
+ px:=px+50;\r
+ indx:=indx+1;\r
+ fi; \r
+ od; \r
+ fi;\r
+ (* recherche de y *)\r
+ termine:=false;\r
+ if ((y_s<50) or (y_s>450)) then call erreur;\r
+ else\r
+ while (not termine)\r
+ do\r
+ if ((y_s>=py) and (y_s<py+50))\r
+ then\r
+ termine:= true;\r
+ else\r
+ py:=py+50;\r
+ indy:=indy+1;\r
+ fi; \r
+ od; \r
+ fi;\r
+ \r
+ end reccase2;\r
+\r
+ unit verifjeu : procedure;\r
+ var a,b : integer;\r
+ begin\r
+ possible:=false;\r
+ call remis0(verif);\r
+ for a:=1 to 8\r
+ do\r
+ for b:=1 to 8\r
+ do\r
+ if (verif(a,b).couleur=num_joueur) then\r
+ if verif(a-1,b-1).couleur=0 then verif(a-1,b-1).couleur:=3;fi;\r
+ if verif(a-1,b).couleur=0 then verif(a-1,b).couleur:=3;fi;\r
+ if verif(a-1,b+1).couleur=0 then verif(a-1,b+1).couleur:=3;fi;\r
+ if verif(a,b-1).couleur=0 then verif(a,b-1).couleur:=3;fi;\r
+ if verif(a,b+1).couleur=0 then verif(a,b+1).couleur:=3;fi;\r
+ if verif(a+1,b-1).couleur=0 then verif(a+1,b-1).couleur:=3;fi;\r
+ if verif(a+1,b).couleur=0 then verif(a+1,b).couleur:=3;fi;\r
+ if verif(a+1,b+1).couleur=0 then verif(a+1,b+1).couleur:=3;fi;\r
+ if verif(a+2,b).couleur=0 then verif(a+2,b).couleur:=4;fi;\r
+ if verif(a-2,b).couleur=0 then verif(a-2,b).couleur:=4;fi;\r
+ if verif(a,b+2).couleur=0 then verif(a,b+2).couleur:=4;fi;\r
+ if verif(a,b-2).couleur=0 then verif(a,b-2).couleur:=4;fi;\r
+ fi;\r
+ od;\r
+ od;\r
+ possible:=false;\r
+ for a:=1 to 8\r
+ do\r
+ for b:=1 to 8\r
+ do\r
+ case verif(a,b).couleur\r
+ when 3 : possible:=true;\r
+ when 4 : possible:=true;\r
+ esac;\r
+ od;\r
+ od;\r
+ call remis0(verif); \r
+ if num_joueur=1 and nombre1=0 then possible:=false;fi;\r
+ if num_joueur=2 and nombre2=0 then possible:=false;fi; \r
+ end verifjeu;\r
+ \r
+ unit remis0 : procedure(rem : arrayof arrayof elem);\r
+ var i,j : integer;\r
+ begin\r
+ for i:=-1 to 10\r
+ do\r
+ for j:=-1 to 10\r
+ do\r
+ if ((rem(i,j).couleur=3) or (rem(i,j).couleur=4))\r
+ then\r
+ rem(i,j).couleur:=0; \r
+ fi;\r
+ od;\r
+ od;\r
+ end remis0;\r
+\r
+ unit Bouton:procedure(xa,ya,xb,yb:integer);\r
+ (*\r
+ * Affiche un cadre \85 la WINDOWS.\r
+ *)\r
+ begin\r
+ (* BLANC = 15 *)\r
+ call patern(xa ,ya ,xb ,yb ,8 ,1 );\r
+ call patern(xa+3,ya+3,xb-2,yb-2,0 ,1);\r
+ call patern(xa+4,ya+4,xb-1,yb-1,15,1);\r
+ call patern(xa+4,ya+4,xb-3,yb-3,7 ,1);\r
+ \r
+ end;\r
+ \r
+ \r
+ (* Variable du programme Principal *)\r
+ var\r
+ Mouse : boolean ,\r
+ x_pos ,\r
+ y_pos ,\r
+ X_s ,\r
+ Y_s ,\r
+ Keyb1 ,\r
+ Keyb2 ,\r
+ Flag ,\r
+ Num_Mouse :integer;\r
+ \r
+ begin (* Begin du block : \82cran *)\r
+ call gron(0);\r
+ call init(1,0);\r
+ call showcursor;\r
+ call presentation;\r
+ end;\r
+end;\r
+end ecran;\r
+\r
+\r
+\r
+\r
+Var\r
+ tab : arrayof arrayof elem,\r
+ simul : arrayof arrayof elem,\r
+ verif : arrayof arrayof elem, \r
+ nombre1,nombre2,num_joueur,indx,indy,courx,\r
+ type1,type2,coury,nomb,ix,iy,pos:integer,\r
+ termine,possible,trouve,fini : boolean;\r
+\r
+Begin\r
+ nombre1:=2;\r
+ nombre2:=2;\r
+ type1:=1;\r
+ type2:=1;\r
+ num_joueur:=1; \r
+ call creatab;\r
+ call init_tab;\r
+ call ecran;\r
+end dominate;\r
+ \r
--- /dev/null
+program morp3d;\r
+(***************************************************************************)\r
+(* Fabien JOBIN Fr\82d\82ric GAUTIER *)\r
+(* LICENCE INFORMATIQUE 1995 *)\r
+(* 2eme Groupe *)\r
+(* MORPION en 3 DIMENSIONS *)\r
+(***************************************************************************)\r
+\r
+ begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+\r
+ (* Fonction de lecture au clavier *)\r
+ unit inchar:function:integer;\r
+ var i:integer;\r
+ begin\r
+ do\r
+ i:=inkey;\r
+ if i<>0 then exit fi;\r
+ od;\r
+ result:=i;\r
+ end inchar;\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* OPERATIONS SUR LA MATRICE EN 3 DIMENSION *)\r
+(*--------------------------------------------------------------------------*)\r
+\r
+ (* Description d'un \82l\82ment d'une matrice en 3 dimensions *)\r
+ (* val : valeur du cube plac\82e par le joueur lorsqu'il colorie celui-ci*)\r
+ (* marque : indique si le cube a \82t\82 jou\82 (= 1) ou non (=0) *)\r
+ (* x,y : position du cube \85 l'\82cran *)\r
+ unit elem:class;\r
+ var x,y,val,marque:integer;\r
+ end elem;\r
+\r
+ (* Description d'une matrice en 3 dimensions *)\r
+ unit mat_3d:class(l,c,e:integer);\r
+\r
+ (* Copie le contenu d'une matrice 3d dans une autre *)\r
+ unit copy_mat3d:function:mat_3d;\r
+ var i,j,k:integer;\r
+ begin\r
+ result:=new mat_3d(l,c,e);\r
+ for i:=1 to l\r
+ do\r
+ for j:=1 to c\r
+ do\r
+ for k:=1 to e\r
+ do\r
+ result.tab(i,j,k).val := tab(i,j,k).val;\r
+ result.tab(i,j,k).marque := tab(i,j,k).marque;\r
+ result.tab(i,j,k).x := tab(i,j,k).x;\r
+ result.tab(i,j,k).y := tab(i,j,k).y;\r
+ od;\r
+ od;\r
+ od;\r
+ end copy_mat3d;\r
+\r
+ var tab:arrayof arrayof arrayof elem,\r
+ i,j,k:integer;\r
+ begin\r
+ array tab dim(1:l);\r
+ for i:=1 to l\r
+ do\r
+ array tab(i) dim (1:c);\r
+ od;\r
+ for i:=1 to l\r
+ do\r
+ for j:=1 to c\r
+ do\r
+ array tab(i,j) dim (1:e);\r
+ od;\r
+ od;\r
+\r
+ for i:=1 to l\r
+ do\r
+ for j:=1 to c\r
+ do\r
+ for k:=1 to e\r
+ do\r
+ tab(i,j,k) := new elem;\r
+ od;\r
+ od;\r
+ od;\r
+ end mat_3d;\r
+\r
+ (* Initialise la matrice *)\r
+ unit init_mat:procedure(inout mat:mat_3d);\r
+ var i,j,k,x,y:integer;\r
+ begin\r
+ for i:=1 to mat.l\r
+ do\r
+ for j:=1 to mat.c\r
+ do\r
+ x := 292-((j-1)*20);\r
+ y := 100+((j-1)*20)+((i-1)*110);\r
+ for k:=1 to mat.e\r
+ do\r
+ mat.tab(i,j,k).x :=x;\r
+ mat.tab(i,j,k).y :=y;\r
+ mat.tab(i,j,k).val := 0;\r
+ mat.tab(i,j,k).marque := 0;\r
+ x := x + 25;\r
+ od;\r
+ od;\r
+ od;\r
+ end init_mat;\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* GRAPHISMES *)\r
+(*--------------------------------------------------------------------------*)\r
+\r
+(*-------- DESSIN DE LA MATRICE, D'UN ELEMENT DE LA MATRICE, ... -----------*)\r
+\r
+ (* Dessin d'un carr\82 de face *)\r
+ unit carre_face:procedure(x,y,c,ep,coul,vide:integer);\r
+ begin\r
+ if vide = 1 then\r
+ (* carre de face vide *)\r
+ call patern(x,y,x+c,y+c,15,0);\r
+ else\r
+ (* carre de face plein *)\r
+ (* partie cadre noir *)\r
+ call patern(x+1,y+1,x+c-1,y+c-1,0,0);\r
+ (* partie pleine *)\r
+ call patern(x+2,y+2,x+c-2,y+c-2,coul,1);\r
+ fi;\r
+ end carre_face;\r
+\r
+ (* Dessin d'un carr\82 haut *)\r
+ unit carre_haut:procedure(x,y,c,ep,coul,vide:integer);\r
+ var i:integer;\r
+ begin\r
+ if vide = 1 then\r
+ (* carre haut vide *)\r
+ call color(15);\r
+ call move(x,y);\r
+ call draw(x+ep,y-ep);\r
+ call draw(x+ep+c,y-ep);\r
+ call draw(x+c,y);\r
+ else\r
+ (* carre haut plein *)\r
+ (* partie cadre noir *)\r
+ call color(0);\r
+ call move(x+2,y-1);\r
+ call draw(x+ep,y-ep+1);\r
+ call draw(x+c+ep-2,y-ep+1);\r
+ call draw(x+c,y-1);\r
+ call draw(x+2,y-1);\r
+ (* partie pleine *)\r
+ call color(coul);\r
+ for i:=2 to 22\r
+ do\r
+ call move(x+2+i,y-2);\r
+ call draw(x+ep,y-ep+2);\r
+ call draw(x+ep+c-2-i,y-ep+2);\r
+ call draw(x+c,y-2);\r
+ call draw(x+2+i,y-2);\r
+ od;\r
+ fi;\r
+ end carre_haut;\r
+\r
+ (* Dessin d'un carr\82 droit *)\r
+ unit carre_droit:procedure(x,y,c,ep,coul,vide:integer);\r
+ var i:integer;\r
+ begin\r
+ if vide = 1 then\r
+ (* carre droit vide *)\r
+ call color(15);\r
+ call move(x+c,y+c);\r
+ call draw(x+c+ep,y+c-ep);\r
+ call draw(x+c+ep,y-ep);\r
+ else\r
+ (* carre droit plein *)\r
+ (* partie cadre noir *)\r
+ call color(0);\r
+ call move(x+c+1,y+c-2);\r
+ call draw(x+c+ep-1,y+c-ep);\r
+ call draw(x+c+ep-1,y-ep+2);\r
+ call draw(x+c+1,y);\r
+ call draw(x+c+1,y+c-2);\r
+ (* partie pleine *)\r
+ call color(coul);\r
+ for i:=2 to 22\r
+ do\r
+ call move(x+c+2,y+c-2-i);\r
+ call draw(x+c+ep-2,y+c-ep);\r
+ call draw(x+c+ep-2,y-ep+2+i);\r
+ call draw(x+c+2,y);\r
+ call draw(x+c+2,y+c-2-i);\r
+ od;\r
+ fi;\r
+ end carre_droit;\r
+\r
+ (* Un cube est le dessin d'un \82l\82ment d'une matrice en 3 dimensions *)\r
+ (* Un cube (3d) est compos\82 : *)\r
+ (* - d'un carr\82 de face *)\r
+ (* - d'un carr\82 haut *)\r
+ (* - d'uncarr\82 droit *)\r
+ (* x et y coordonn\82es du sommet en haut \85 gauche appartenant au carr\82 *)\r
+ (* de face *)\r
+ (* c : longueur du cot\82 du cube *)\r
+ (* coul : couleur *)\r
+ (* ep : epaisseur du cube *)\r
+ unit cube:procedure(x,y,c,ep,coul,vide:integer);\r
+ var i:integer;\r
+ begin\r
+ call carre_face(x,y,c,ep,coul,vide);\r
+ call carre_haut(x,y,c,ep,coul,vide);\r
+ call carre_droit(x,y,c,ep,coul,vide);\r
+ end cube;\r
+\r
+ (* Un plan est constitu\82 de 9 cubes *)\r
+ (* x et y coordonn\82es du cube du fond \85 gauche *)\r
+ unit plan:procedure(x,y,c,ep,coul:integer);\r
+ begin\r
+ (* cubes du fond *)\r
+ call cube(x,y,c,ep,coul,1);\r
+ call cube(x+c,y,c,ep,coul,1);\r
+ call cube(x+2*c,y,c,ep,coul,1);\r
+\r
+ (* cubes du milieu *)\r
+ call cube(x-ep,y+ep,c,ep,coul,1);\r
+ call cube(x-ep+c,y+ep,c,ep,coul,1);\r
+ call cube(x-ep+2*c,y+ep,c,ep,coul,1);\r
+\r
+ (* cubes du debut *)\r
+ call cube(x-2*ep,y+2*ep,c,ep,coul,1);\r
+ call cube(x-2*ep+c,y+2*ep,c,ep,coul,1);\r
+ call cube(x-2*ep+2*c,y+2*ep,c,ep,coul,1);\r
+ end plan;\r
+\r
+ (* Une matrice en 3 dimensions est constitu\82e de 3 plans *)\r
+ (* x et y coordonn\82es du plan en haut *)\r
+ unit des_mat_3d:procedure(x,y,c,ep,coul:integer);\r
+ begin\r
+ (* plan en haut *)\r
+ call plan(x,y,c,ep,coul);\r
+ (* plan en bas *)\r
+ call plan(x,y+4*ep+30,c,ep,coul);\r
+ (* plan du milieu *)\r
+ call plan(x,y+8*ep+60,c,ep,coul);\r
+ end des_mat_3d;\r
+\r
+ (* Affiche la matrice *)\r
+ unit affic:procedure(c,ep:integer);\r
+ var i,j,k:integer;\r
+ begin\r
+ for i:=1 to mat.l\r
+ do\r
+ for j:=1 to mat.c\r
+ do\r
+ for k:=1 to mat.e\r
+ do\r
+ call affic_elem(i,j,k,c,ep);\r
+ od;\r
+ od;\r
+ od;\r
+ end affic;\r
+\r
+ (* Affiche un \82l\82ment de la matrice *)\r
+ unit affic_elem:procedure(i,j,k,c,ep:integer);\r
+ var coul:integer;\r
+ begin\r
+ (* cubes dont le carre haut est visible *)\r
+ if (mat.tab(i,j,k).x=292 or\r
+ mat.tab(i,j,k).x=317 or\r
+ mat.tab(i,j,k).x=272 or\r
+ mat.tab(i,j,k).x=297) then\r
+ if (mat.tab(i,j,k).y=100 or\r
+ mat.tab(i,j,k).y=120 or\r
+ mat.tab(i,j,k).y=210 or\r
+ mat.tab(i,j,k).y=230 or\r
+ mat.tab(i,j,k).y=320 or\r
+ mat.tab(i,j,k).y=340) then\r
+ if mat.tab(i,j,k).val = 0 then\r
+ coul:=0;\r
+ else\r
+ if mat.tab(i,j,k).val = 1 then\r
+ coul:=12;\r
+ else\r
+ if mat.tab(i,j,k).val = 2 then\r
+ coul:=10;\r
+ else\r
+ if mat.tab(i,j,k).val = 3 or\r
+ mat.tab(i,j,k).val = 4 then\r
+ coul:=9;\r
+ else\r
+ if mat.tab(i,j,k).val = 9 then\r
+ coul:=15;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call carre_haut(mat.tab(i,j,k).x,\r
+ mat.tab(i,j,k).y,c,ep,coul,0);\r
+ fi;\r
+ else\r
+ (* cubes dont le carre haut et le carre droit sont *)\r
+ (* visibles *)\r
+ if (mat.tab(i,j,k).x=342 or\r
+ mat.tab(i,j,k).x=322) then\r
+ if (mat.tab(i,j,k).y=100 or\r
+ mat.tab(i,j,k).y=120 or\r
+ mat.tab(i,j,k).y=210 or\r
+ mat.tab(i,j,k).y=230 or\r
+ mat.tab(i,j,k).y=320 or\r
+ mat.tab(i,j,k).y=340) then\r
+ if mat.tab(i,j,k).val = 0 then\r
+ coul:=0;\r
+ else\r
+ if mat.tab(i,j,k).val = 1 then\r
+ coul:=12;\r
+ else\r
+ if mat.tab(i,j,k).val = 2 then\r
+ coul:=10;\r
+ else\r
+ if mat.tab(i,j,k).val = 3 or\r
+ mat.tab(i,j,k).val = 4 then\r
+ coul:=9;\r
+ else\r
+ if mat.tab(i,j,k).val = 9 then\r
+ coul:=15;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call carre_haut(mat.tab(i,j,k).x,\r
+ mat.tab(i,j,k).y,c,ep,coul,0);\r
+ call carre_droit(mat.tab(i,j,k).x,\r
+ mat.tab(i,j,k).y,c,ep,coul,0);\r
+ fi;\r
+ else\r
+ (* cubes dont le carre haut et le carre face sont *)\r
+ (* visibles *)\r
+ if (mat.tab(i,j,k).x=252 or\r
+ mat.tab(i,j,k).x=277) then\r
+ if (mat.tab(i,j,k).y=140 or\r
+ mat.tab(i,j,k).y=250 or\r
+ mat.tab(i,j,k).y=360) then\r
+ if mat.tab(i,j,k).val = 0 then\r
+ coul:=0;\r
+ else\r
+ if mat.tab(i,j,k).val = 1 then\r
+ coul:=12;\r
+ else\r
+ if mat.tab(i,j,k).val = 2 then\r
+ coul:=10;\r
+ else\r
+ if mat.tab(i,j,k).val = 3 or\r
+ mat.tab(i,j,k).val = 4 then\r
+ coul:=9;\r
+ else\r
+ if mat.tab(i,j,k).val = 9 then\r
+ coul:=15;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call carre_face(mat.tab(i,j,k).x,\r
+ mat.tab(i,j,k).y,c,ep,coul,0);\r
+ call carre_haut(mat.tab(i,j,k).x,\r
+ mat.tab(i,j,k).y,c,ep,coul,0);\r
+ fi;\r
+ else\r
+ (* cubes dont le carre haut,face et droit sont *)\r
+ (* visibles *)\r
+ if (mat.tab(i,j,k).x=302) then\r
+ if (mat.tab(i,j,k).y=140 or\r
+ mat.tab(i,j,k).y=250 or\r
+ mat.tab(i,j,k).y=360) then\r
+ if mat.tab(i,j,k).val = 0 then\r
+ coul:=0;\r
+ else\r
+ if mat.tab(i,j,k).val = 1 then\r
+ coul:=12;\r
+ else\r
+ if mat.tab(i,j,k).val = 2 then\r
+ coul:=10;\r
+ else\r
+ if mat.tab(i,j,k).val = 3 or\r
+ mat.tab(i,j,k).val = 4 then\r
+ coul:=9;\r
+ else\r
+ if mat.tab(i,j,k).val = 9 then\r
+ coul:=15;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call cube(mat.tab(i,j,k).x,\r
+ mat.tab(i,j,k).y,c,ep,coul,0);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end affic_elem;\r
+\r
+ (* recherche_elem donne i,j,k en fonction de x et y *)\r
+ (* Ceci permet d'acc\82der aux indices d'un \82l\82ment *)\r
+ (* de la matrice en fonction de la position de la *)\r
+ (* case (ou du cube) \85 l'\82cran. *)\r
+ unit recherche_elem:procedure(x,y:integer;output i,j,k:integer);\r
+ var trouve:boolean;\r
+ begin\r
+ trouve:=false;\r
+ i:=1;\r
+ while (i<=mat.l and not trouve)\r
+ do\r
+ j:=1;\r
+ while (j<=mat.c and not trouve)\r
+ do\r
+ k:=1;\r
+ while (k<=mat.e and not trouve)\r
+ do\r
+ if (mat.tab(i,j,k).x =x and mat.tab(i,j,k).y =y) then\r
+ trouve:=true;\r
+ fi;\r
+ k:=k+1;\r
+ od;\r
+ j:=j+1;\r
+ od;\r
+ i:=i+1;\r
+ od;\r
+ i:=i-1;j:=j-1;k:=k-1;\r
+ end recherche_elem;\r
+\r
+ (* indique si le point (x1,y1) est en_dessous du segment de droite *)\r
+ (* passant par (x2,y2) et (x3,y3) *)\r
+ (* Ceci permet de savoir si le pointeur de la souris est sur un *)\r
+ (* carre haut ou un carre droit du cube. En effet, ces carr\82s ont *)\r
+ (* des c\93t\82s inclin\82s. *)\r
+ unit en_dessous:function(x1,y1,x2,y2,x3,y3:real):boolean;\r
+ var y_calcul:real;\r
+ begin\r
+ y_calcul:=(( ((y2-y3)/(x2-x3)) )*(x1-x3))+y3;\r
+ if y1 > y_calcul then\r
+ result:=true;\r
+ else\r
+ result:=false;\r
+ fi;\r
+ end en_dessous;\r
+\r
+ (* Cette proc\82dure colorie un cube *)\r
+ unit coloriage:procedure(i,j,k,val:integer);\r
+ begin\r
+ if val = 3 or val = 4 then\r
+ if mat.tab(i,j,k).marque=0 then\r
+ (* Le joueur 1 colorie un cube *)\r
+ if val = 3 then mat.tab(i,j,k).val:=1 fi;\r
+ (* Le joueur 2 colorie un cube *)\r
+ if val = 4 then mat.tab(i,j,k).val:=4 fi;\r
+ (* la saisie est prise en compte *)\r
+ mat.tab(i,j,k).marque:=1;\r
+ joue:=true;\r
+ fi;\r
+ else\r
+ if mat.tab(i,j,k).marque=0 then\r
+ (* Coloriage ou effacage du coloriage d'un cube *)\r
+ (* cette saisie n'est pas prise en compte *)\r
+\r
+ (* le joueur2 colorie le cube *)\r
+ if val = 2 then val:=val+2 fi;\r
+\r
+ mat.tab(i,j,k).val:=val;\r
+ fi;\r
+ fi;\r
+ end coloriage;\r
+\r
+ (* Effectue la modification d'un \82l\82ment de la matrice. *)\r
+ (* A partir des coordonn\82es du pointeur de la souris *)\r
+ (* qui d\82signe un cube \85 l'\82cran, on acc\8ade \85 un *)\r
+ (* \82l\82ment de la matrice, on colorie le cube en fonction *)\r
+ (* du joueur et on affiche le cube \85 l'\82cran. *)\r
+ unit modification:procedure(xmouse,ymouse,ep,c,val,cpt:integer);\r
+ var i,j,k:integer;\r
+ begin\r
+ (* Point dans cube en haut \85 gauche *)\r
+ if (xmouse>=292 and xmouse<=292+ep+c and\r
+ ymouse<=100+cpt and ymouse>=100-ep+cpt and\r
+ en_dessous(xmouse,ymouse,292,100+cpt,292+ep,100-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,292+c,100+cpt,292+ep+c,100-ep+cpt))) then\r
+\r
+ call recherche_elem(292,100+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+ (* Point dans cube en haut au milieu *)\r
+ if (xmouse>=317 and xmouse<=317+ep+c and\r
+ ymouse<=100+cpt and ymouse>=100-ep+cpt and\r
+ en_dessous(xmouse,ymouse,317,100+cpt,317+ep,100-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,317+c,100+cpt,317+ep+c,100-ep+cpt))) then\r
+\r
+ call recherche_elem(317,100+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+ (* Point dans cube en haut \85 droite *)\r
+ if ((xmouse>=342 and xmouse<=342+ep+c and\r
+ ymouse<=100+cpt and ymouse>=100-ep+cpt and\r
+ en_dessous(xmouse,ymouse,342,100+cpt,342+ep,100-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,342+c,100+cpt,342+ep+c,100-ep+cpt))) or\r
+ (xmouse>=342+c and xmouse<=342+ep+c and\r
+ ymouse<=100+c+cpt and ymouse>=100-ep+cpt and\r
+ en_dessous(xmouse,ymouse,342+c,100+cpt,342+ep+c,100-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,342+c,100+c+cpt,342+ep+c,100-ep+c+cpt)))) then\r
+\r
+ call recherche_elem(342,100+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+ (* Point dans cube au milieu \85 gauche *)\r
+ if (xmouse>=272 and xmouse<=272+ep+c and\r
+ ymouse<=120+cpt and ymouse>=120-ep+cpt and\r
+ en_dessous(xmouse,ymouse,272,120+cpt,272+ep,120-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,272+c,120+cpt,272+ep+c,120-ep+cpt))) then\r
+\r
+ call recherche_elem(272,120+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+\r
+ (* Point dans cube au milieu au milieu *)\r
+ if (xmouse>=297 and xmouse<=297+ep+c and\r
+ ymouse<=120+cpt and ymouse>=120-ep+cpt and\r
+ en_dessous(xmouse,ymouse,297,120+cpt,297+ep,120-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,297+c,120+cpt,297+ep+c,120-ep+cpt))) then\r
+\r
+ call recherche_elem(297,120+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+\r
+ (* Point dans cube au milieu \85 droite *)\r
+ if ((xmouse>=322 and xmouse<=322+ep+c and\r
+ ymouse<=120+cpt and ymouse>=120-ep+cpt and\r
+ en_dessous(xmouse,ymouse,322,120+cpt,322+ep,120-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,322+c,120+cpt,322+ep+c,120-ep+cpt))) or\r
+ (xmouse>=322+c and xmouse<=322+ep+c and\r
+ ymouse<=120+c+cpt and ymouse>=120-ep+cpt and\r
+ en_dessous(xmouse,ymouse,322+c,120+cpt,322+ep+c,120-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,322+c,120+c+cpt,322+ep+c,120-ep+c+cpt)))) then\r
+\r
+ call recherche_elem(322,120+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+\r
+ (* Point dans cube en bas \85 gauche *)\r
+ if ((xmouse>=252 and xmouse<=252+ep+c and\r
+ ymouse<=140+cpt and ymouse>=140-ep+cpt and\r
+ en_dessous(xmouse,ymouse,252,140+cpt,252+ep,140-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,252+c,140+cpt,252+ep+c,140-ep+cpt))) or\r
+ (xmouse>=252 and xmouse<=252+c and\r
+ ymouse<=140+c+cpt and ymouse>=140+cpt)) then\r
+\r
+ call recherche_elem(252,140+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+\r
+ (* Point dans cube en bas au milieu *)\r
+ if ((xmouse>=277 and xmouse<=277+ep+c and\r
+ ymouse<=140+cpt and ymouse>=140-ep+cpt and\r
+ en_dessous(xmouse,ymouse,277,140+cpt,277+ep,140-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,277+c,140+cpt,277+ep+c,140-ep+cpt))) or\r
+ (xmouse>=277 and xmouse<=277+c and\r
+ ymouse<=140+c+cpt and ymouse>=140+cpt)) then\r
+\r
+ call recherche_elem(277,140+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ else\r
+\r
+ (* Point dans cube en bas \85 droite *)\r
+ if ((xmouse>=302 and xmouse<=302+ep+c and\r
+ ymouse<=140+cpt and ymouse>=140-ep+cpt and\r
+ en_dessous(xmouse,ymouse,302,140+cpt,302+ep,140-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,302+c,140+cpt,302+ep+c,140-ep+cpt))) or\r
+\r
+ (xmouse>=302+c and xmouse<=302+ep+c and\r
+ ymouse<=140+c+cpt and ymouse>=140-ep+cpt and\r
+ en_dessous(xmouse,ymouse,302+c,140+cpt,302+ep+c,140-ep+cpt) and\r
+ not(en_dessous(xmouse,ymouse,302+c,140+c+cpt,302+ep+c,140-ep+c+cpt))) or\r
+\r
+ (xmouse>=302 and xmouse<=302+c and\r
+ ymouse<=140+c+cpt and ymouse>=140+cpt)) then\r
+\r
+ call recherche_elem(302,140+cpt,i,j,k);\r
+ call coloriage(i,j,k,val);\r
+ call affic_elem(i,j,k,c,ep);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end modification;\r
+\r
+ (* Saisie (colorie) un \82l\82ment de la matrice *)\r
+ unit saisie:procedure(xmouse,ymouse,bouton_mouse,ep,c,num_joueur:integer);\r
+ var val:integer;\r
+ begin\r
+ if bouton_mouse = 1 or bouton_mouse = 2 or bouton_mouse = 3 then\r
+ (* Le joueur1 colorie le cube mais cette saisie *)\r
+ (* n'est pas prise en compte (il ne joue pas) *)\r
+ if bouton_mouse = 1 and num_joueur = 1 then val := 1 fi;\r
+\r
+ (* Le joueur2 colorie le cube mais cette saisie *)\r
+ (* n'est pas prise en compte (il ne joue pas) *)\r
+ if bouton_mouse = 1 and num_joueur = 2 then val := 2 fi;\r
+\r
+ (* Le joueur efface le coloriage du cube *)\r
+ if bouton_mouse = 2 then val := 0 fi;\r
+\r
+ (* Le joueur1 colorie un cube et cette saisie *)\r
+ (* est prise en compte (le joueur joue) *)\r
+ if bouton_mouse = 3 and num_joueur = 1 then val := 3 fi;\r
+\r
+ (* Le joueur2 colorie un cube et cette saisie *)\r
+ (* est prise en compte (le joueur joue) *)\r
+ if bouton_mouse = 3 and num_joueur = 2 then val := 4 fi;\r
+\r
+ (* Pointeur de la souris dans le plan en haut *)\r
+ if (ymouse>=100-ep and ymouse<=140+ep) then\r
+ call modification(xmouse,ymouse,ep,c,val,0);\r
+ else\r
+ (* Pointeur de la souris dans le plan au milieu *)\r
+ if (ymouse>=210-ep and ymouse<=250+ep) then\r
+ call modification(xmouse,ymouse,ep,c,val,110);\r
+ else\r
+ (* Pointeur de la souris dans le plan en bas *)\r
+ if (ymouse>=320-ep and ymouse<=360+ep) then\r
+ call modification(xmouse,ymouse,ep,c,val,220);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end saisie;\r
+\r
+ (* Affiche les 3 cubes align\82s par un joueur en les faisant *)\r
+ (* clignoter *)\r
+ unit affic_3_alignes:procedure(i1,j1,k1,i2,j2,k2,i3,j3,k3:integer);\r
+ var val,l,k:integer;\r
+ var image1,image2:arrayof integer;\r
+ begin\r
+ (* on sauvegarde la valeur des cubes *)\r
+ val:=mat.tab(i1,j1,k1).val;\r
+ array image1 dim(1:100);\r
+ array image2 dim(1:100);\r
+ (* image1 contient l'\82cran avec les 3 cubes de la couleur du joueur *)\r
+ call move(0,0);\r
+ image1:=getmap(640,480);\r
+\r
+ (* On met 9 dans la valeur des cubes pour les faire afficher *)\r
+ (* en blanc *)\r
+ mat.tab(i1,j1,k1).val:=9;\r
+ call affic_elem(i1,j1,k1,25,20);\r
+ mat.tab(i2,j2,k2).val:=9;\r
+ call affic_elem(i2,j2,k2,25,20);\r
+ mat.tab(i3,j3,k3).val:=9;\r
+ call affic_elem(i3,j3,k3,25,20);\r
+\r
+ (* image2 contient l'\82cran avec les 3 cubes de couleur blanc *)\r
+ call move(0,0);\r
+ image2:=getmap(640,480);\r
+\r
+ (* On remet les valeurs pr\82c\82dentes des cubes *)\r
+ mat.tab(i1,j1,k1).val:=val;\r
+ mat.tab(i2,j2,k2).val:=val;\r
+ mat.tab(i3,j3,k3).val:=val;\r
+\r
+ (* On fait afficher en alternance image1 et image2 *)\r
+ for l:=1 to 7\r
+ do\r
+ call move(0,0);\r
+ call putmap(image1);\r
+ for k:=1 to 100 do k:=k+1 od;\r
+ call move(0,0);\r
+ call putmap(image2);\r
+ for k:=1 to 100 do k:=k+1 od;\r
+ od;\r
+ (* On restitue l'\82cran tel qu'il \82tait avant le clignotement des 3 *)\r
+ (* cubes *)\r
+ call move(0,0);\r
+ call putmap(image1);\r
+ end affic_3_alignes;\r
+\r
+(*------------------- DESSIN DE BOUTON ET MESSAGE D'ERREUR -----------------*)\r
+\r
+ (* Affichage d'un bouton *)\r
+ unit bouton:procedure(x1,y1,x2,y2,x3,y3 : integer;chaine : string;\r
+ couleur_fond,couleur1,couleur2,couleur3 : integer);\r
+ begin\r
+ call patern(x1,y1,x2,y2,couleur_fond,1);\r
+ call color(couleur1);\r
+ call move(x1,y1); call draw(x2,y1);\r
+ call move(x1,y1); call draw(x1,y2);\r
+ call move(x1+1,y1+1); call draw(x2-1,y1+1);\r
+ call move(x1+1,y1+2); call draw(x2-2,y1+2);\r
+ call move(x1+1,y1+1); call draw(x1+1,y2-1);\r
+ call move(x1+2,y1+2); call draw(x1+2,y2-2);\r
+ call color(couleur2);\r
+ call move(x1,y2); call draw(x2,y2);\r
+ call move(x1+1,y2-1); call draw(x2-1,y2-1);\r
+ call move(x1+2,y2-2); call draw(x2-2,y2-2);\r
+ call move(x2,y2); call draw(x2,y1);\r
+ call move(x2-1,y2-1); call draw(x2-1,y1+1);\r
+ call move(x2-2,y2-2); call draw(x2-2,y1+2);\r
+ call outstring(x3,y3,chaine,couleur3,couleur_fond);\r
+ end bouton;\r
+\r
+ (* Cette proc\82dure affiche un message d'erreur *)\r
+ unit message_erreur:procedure(x1,y1,x2,y2,x3,y3:integer;chaine1:string;\r
+ x7:integer;chaine2:string;x4,y4,x5,y5,x6,y6:integer);\r
+ var i : integer;\r
+ var tab:arrayof integer;\r
+ begin\r
+ array tab dim(1:100);\r
+ call move(x1,y1);\r
+ tab:=getmap(x2,y2);\r
+ call bouton(x1,y1,x2,y2,x3,y3,chaine1,12,15,6,14);\r
+ call outstring(x7,y3+30,chaine2,14,0);\r
+ call patern(x4-4,y4-4,x5+4,y5+4,0,1);\r
+ call bouton(x4,y4,x5,y5,x6,y6,"OK",9,11,1,15);\r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if c = 1 and (v>=x4 and v<=x5) and (p>=y4 and p<=y5) then\r
+ exit;\r
+ fi;\r
+ od;\r
+ call bouton(x4,y4,x5,y5,x6,y6,"OK",1,9,11,7);\r
+ for i:=1 to 5000 do i := i + 1 od;\r
+ call bouton(x4,y4,x5,y5,x6,y6,"OK",9,11,1,15);\r
+ for i:=1 to 5500 do i := i + 1 od;\r
+ call move(x1,y1);\r
+ call putmap(tab);\r
+ end message_erreur;\r
+\r
+ (* Affiche le cadre d'un bouton *)\r
+ unit cadre_bouton:procedure(x1,y1,x2,y2 : integer);\r
+ begin\r
+ call patern(x1-4,y1-4,x2+4,y2+4,0,1);\r
+ end cadre_bouton;\r
+\r
+(*-- AFFICHAGE DE LA MATRICE PAR LES TOUCHES (haut, bas, droite, gauche) ---*)\r
+\r
+ (* Copie un \82l\82ment de la matrice dans un \82l\82ment d'une autre matrice *)\r
+ unit copy_elem:procedure(inout B:mat_3d;lb,cb,j:integer;\r
+ A:mat_3d;la,ca,i:integer);\r
+ begin\r
+ B.tab(lb,cb,j).val := A.tab(la,ca,i).val;\r
+ B.tab(lb,cb,j).marque := A.tab(la,ca,i).marque;\r
+ end copy_elem;\r
+\r
+ (* Affiche le contenu de la matrice vers le haut *)\r
+ unit haut:procedure;\r
+ var i,j:integer;\r
+ var aux:mat_3d;\r
+ begin\r
+ aux := new mat_3d(3,3,3);\r
+ call init_mat(aux);\r
+ for j:=1 to 3\r
+ do\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,1,j,i,mat,j,3,i);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,2,j,i,mat,j,2,i);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,3,j,i,mat,j,1,i);\r
+ od;\r
+ od;\r
+ mat := none;\r
+ mat := aux.copy_mat3d;\r
+ call affic(25,20);\r
+ end haut;\r
+\r
+ (* Affiche le contenu de la matrice vers le bas *) \r
+ unit bas:procedure;\r
+ var i,j:integer;\r
+ var aux:mat_3d;\r
+ begin\r
+ aux := new mat_3d(3,3,3);\r
+ call init_mat(aux);\r
+ for j:=1 to 3\r
+ do\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,3,i,mat,1,j,i);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,2,i,mat,2,j,i);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,1,i,mat,3,j,i);\r
+ od;\r
+ od;\r
+ mat := none;\r
+ mat := aux.copy_mat3d;\r
+ call affic(25,20);\r
+ end bas;\r
+\r
+ (* Affiche le contenu de la matrice vers la droite *) \r
+ unit droit:procedure;\r
+ var i,j:integer;\r
+ var aux:mat_3d;\r
+ begin\r
+ aux := new mat_3d(3,3,3);\r
+ call init_mat(aux);\r
+ for j:=1 to 3\r
+ do\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,3,i,mat,j,i,1);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,2,i,mat,j,i,2);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,1,i,mat,j,i,3);\r
+ od;\r
+ od;\r
+ mat := none;\r
+ mat := aux.copy_mat3d;\r
+ call affic(25,20);\r
+ end droit;\r
+\r
+ (* Affiche le contenu de la matrice vers la gauche *) \r
+ unit gauche:procedure;\r
+ var i,j:integer;\r
+ var aux:mat_3d;\r
+ begin\r
+ aux := new mat_3d(3,3,3);\r
+ call init_mat(aux);\r
+ for j:=1 to 3\r
+ do\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,i,1,mat,j,3,i);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,i,2,mat,j,2,i);\r
+ od;\r
+ for i:=1 to 3\r
+ do\r
+ call copy_elem(aux,j,i,3,mat,j,1,i);\r
+ od;\r
+ od;\r
+ mat := none;\r
+ mat := aux.copy_mat3d;\r
+ call affic(25,20);\r
+ end gauche;\r
+\r
+(*-------------------------------- AIDE ------------------------------------*)\r
+\r
+ (* Cette proc\82dure affiche l'aide du jeu *)\r
+ unit aide:procedure;\r
+ var i : integer;\r
+ var tab:arrayof integer;\r
+ begin\r
+ array tab dim(1:100);\r
+ call move(0,0);\r
+ tab:=getmap(640,480);\r
+ call bouton(10,10,630,470,0,0,"",12,15,6,14);\r
+ call cadre_bouton(270,410,370,440);\r
+ call bouton(270,410,370,440,310,417,"OK",9,11,1,15);\r
+\r
+ call outstring(30,20,"REGLES DU JEU :",14,12);\r
+ call outstring(50,35, "-Il s'agit d'aligner 3 cases de la",15,12);\r
+ call outstring(330,35,"m\88me couleur que ce soit en ligne,",15,12);\r
+ call outstring(30,50, "colonne ou diagonale.",15,12);\r
+ call outstring(50,65, "-Chaque joueur colorie une case \85 ",15,12);\r
+ call outstring(320,65,"tour de r\93le. ",15,12);\r
+ call outstring(50,80, "-Si les 27 cases ont \82t\82 colori\82es",15,12);\r
+ call outstring(330,80,"et qu'il n'y a pas 3 cases de la",15,12);\r
+ call outstring(30,95,"m\88me couleur align\82es alors la ",15,12);\r
+ call outstring(280,95,"partie est nulle.",15,12);\r
+\r
+ call outstring(30,125,"MENU ET SOUS-MENUS :",14,12);\r
+ call outstring(50,140,"-Pour s\82lectionner une option,",15,12);\r
+ call outstring(300,140,"cliquez dessus avec le bouton gauche",15,12);\r
+ call outstring(30,155,"de la souris.",15,12);\r
+ call outstring(50,170,"-Pour sortir d'un sous-menu,",15,12);\r
+ call outstring(280,170,"appuyez sur le bouton droit de la souris.",15,12);\r
+ call outstring(50,185,"-Pour jouer, cliquez sur 'JEU'",15,12);\r
+ call outstring(300,185,"puis cliquez sur 'Nouvelle partie'.",15,12);\r
+ call outstring(50,200,"-Pour sauvegarder votre partie,",15,12);\r
+ call outstring(310,200,"cliquez sur 'JEU' puis cliquez sur",15,12);\r
+ call outstring(30,215,"'Enregistrer la partie'.",15,12);\r
+ call outstring(50,230,"-Pour continuer une partie enregistr\82e,",15,12);\r
+ call outstring(370,230,"cliquez sur 'JEU' puis cliquez",15,12);\r
+ call outstring(30,245,"sur 'Charger une partie'.",15,12);\r
+\r
+ call outstring(30,275,"COLORIER UNE CASE :",14,12);\r
+ call outstring(50,290,"-Pour colorier une case sans",15,12);\r
+ call outstring(290,290,"que cette saisie soit prise en compte,",15,12);\r
+ call outstring(30,305,"cliquez sur la case avec le bouton gauche",15,12);\r
+ call outstring(370,305,"de la souris.",15,12);\r
+ call outstring(50,320,"-Pour effacer le coloriage d'une",15,12);\r
+ call outstring(320,320,"case dont la saisie n'a pas \82t\82 prise",15,12);\r
+ call outstring(30,335,"en compte, cliquez sur la case avec le",15,12);\r
+ call outstring(340,335,"bouton droit de la souris.",15,12);\r
+ call outstring(50,350,"-Pour colorier une case et que cette",15,12);\r
+ call outstring(350,350,"saisie soit en prise en compte,",15,12);\r
+ call outstring(30,365,"cliquez sur la case avec les boutons droit et",15,12);\r
+ call outstring(400,365,"gauche de la souris.",15,12);\r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if c = 1 and (v>=270 and v<=370) and (p>=410 and p<=440) then\r
+ exit;\r
+ fi;\r
+ od;\r
+ call bouton(270,410,370,440,310,417,"OK",1,9,11,7);\r
+ for i:=1 to 5000 do i := i + 1 od;\r
+ call bouton(270,410,370,440,310,417,"OK",9,11,1,15);\r
+ for i:=1 to 5500 do i := i + 1 od;\r
+ call move(0,0);\r
+ call putmap(tab);\r
+ end aide;\r
+\r
+(*--------------------------- ANIMATION GRAPHIQUE --------------------------*)\r
+(*--------------- Debut de l'animation du generique --------------------*)\r
+\r
+(*----------------------------------------------------------------------*)\r
+(* *)\r
+(* Cette procedure calcul les coefficients de transformation *)\r
+(* *)\r
+(*----------------------------------------------------------------------*)\r
+unit sin_cos:procedure(alpha,beta,gamma:real;output a,b,c,d,e,f,g,h,i:real);\r
+begin\r
+ a:=cos(gamma)*cos(beta);\r
+ b:=sin(gamma)*cos(beta);\r
+ c:=-sin(beta);\r
+ d:=-sin(gamma)*cos(alpha)+cos(gamma)*sin(beta)*sin(alpha);\r
+ e:=cos(gamma)*cos(alpha)+sin(gamma)*sin(beta)*sin(alpha);\r
+ f:=cos(beta)*sin(alpha);\r
+ g:=sin(gamma)*sin(alpha)+cos(gamma)*sin(beta)*cos(alpha);\r
+ h:=-cos(gamma)*sin(alpha)+sin(gamma)*sin(beta)*cos(alpha);\r
+ i:=cos(beta)*cos(alpha);\r
+end sin_cos;\r
+\r
+(*----------------------------------------------------------------------*)\r
+(* *)\r
+(* Cette procedure calcul la transformation d'un point 3d en point 2d *)\r
+(* *)\r
+(*----------------------------------------------------------------------*)\r
+unit trois_d_vers_2d:procedure(a,b,c,d,e,f,g,h,i,xe,ye,ze,xdep,\r
+ydep,zdep:real;output xp,yp:real);\r
+var q,pt_fuite:real;\r
+begin\r
+ pt_fuite:=-1000;\r
+ q:=1-(c*xe+f*ye+i*ze+zdep)/pt_fuite;\r
+ xp:=(a*xe+d*ye+g*ze+xdep)/q;\r
+ yp:=(b*xe+e*ye+h*ze+ydep)/q;\r
+end trois_d_vers_2d;\r
+\r
+(*----------------------------------------------------------------------*)\r
+(* *)\r
+(* Cette procedure initialise les tableaux decrivant les objets *)\r
+(* *)\r
+(*----------------------------------------------------------------------*)\r
+unit init_obj:procedure(inout xe,ye,ze,tab_ligne:arrayof real);\r
+begin\r
+\r
+(* tableaux des points *)\r
+(* M *)\r
+ xe(1):=-70; ye(1):=-25; ze(1):=0;\r
+ xe(2):=-70; ye(2):=0; ze(2):=0;\r
+ xe(3):=-65; ye(3):=-25; ze(3):=0;\r
+ xe(4):=-65; ye(4):=-20; ze(4):=0;\r
+ xe(5):=-65; ye(5):=0; ze(5):=0;\r
+ xe(6):=-60; ye(6):=-20; ze(6):=0;\r
+ xe(7):=-60; ye(7):=-15; ze(7):=0;\r
+ xe(8):=-55; ye(8):=-25; ze(8):=0;\r
+ xe(9):=-55; ye(9):=-20; ze(9):=0;\r
+ xe(10):=-55; ye(10):=0; ze(10):=0;\r
+ xe(11):=-50; ye(11):=-25; ze(11):=0;\r
+ xe(12):=-50; ye(12):=0; ze(12):=0;\r
+\r
+(* O *)\r
+ xe(13):=-45; ye(13):=-25; ze(13):=0;\r
+ xe(14):=-45; ye(14):=0; ze(14):=0;\r
+ xe(15):=-40; ye(15):=-20; ze(15):=0;\r
+ xe(16):=-40; ye(16):=-5; ze(16):=0;\r
+ xe(17):=-35; ye(17):=-20; ze(17):=0;\r
+ xe(18):=-35; ye(18):=-5; ze(18):=0;\r
+ xe(19):=-30; ye(19):=-25; ze(19):=0;\r
+ xe(20):=-30; ye(20):=0; ze(20):=0;\r
+\r
+(* R *)\r
+ xe(21):=-25; ye(21):=-25; ze(21):=0;\r
+ xe(22):=-25; ye(22):=0; ze(22):=0;\r
+ xe(23):=-20; ye(23):=-20; ze(23):=0;\r
+ xe(24):=-20; ye(24):=-15; ze(24):=0;\r
+ xe(25):=-20; ye(25):=-10; ze(25):=0;\r
+ xe(26):=-20; ye(26):=0; ze(26):=0;\r
+ xe(27):=-15; ye(27):=-20; ze(27):=0;\r
+ xe(28):=-15; ye(28):=-15; ze(28):=0;\r
+ xe(29):=-15; ye(29):=-10; ze(29):=0;\r
+ xe(30):=-15; ye(30):=-5; ze(30):=0;\r
+ xe(31):=-15; ye(31):=0; ze(31):=0;\r
+ xe(32):=-10; ye(32):=-25; ze(32):=0;\r
+ xe(33):=-10; ye(33):=-15; ze(33):=0;\r
+ xe(34):=-10; ye(34):=-5; ze(34):=0;\r
+ xe(35):=-10; ye(35):=0; ze(35):=0;\r
+\r
+(* P *)\r
+ xe(36):=-5; ye(36):=-25; ze(36):=0;\r
+ xe(37):=10; ye(37):=-25; ze(37):=0;\r
+ xe(38):=10; ye(38):=-10; ze(38):=0;\r
+ xe(39):=0; ye(39):=-10; ze(39):=0;\r
+ xe(40):=0; ye(40):=0; ze(40):=0;\r
+ xe(41):=-5; ye(41):=0; ze(41):=0;\r
+ xe(42):=0; ye(42):=-20; ze(42):=0;\r
+ xe(43):=5; ye(43):=-20; ze(43):=0;\r
+ xe(44):=5; ye(44):=-15; ze(44):=0;\r
+ xe(45):=0; ye(45):=-15; ze(45):=0;\r
+\r
+(* I *)\r
+ xe(46):=15; ye(46):=-25; ze(46):=0;\r
+ xe(47):=15; ye(47):=0; ze(47):=0;\r
+ xe(48):=20; ye(48):=-25; ze(48):=0;\r
+ xe(49):=20; ye(49):=0; ze(49):=0;\r
+\r
+(* O *)\r
+ xe(50):=25; ye(50):=-25; ze(50):=0;\r
+ xe(51):=25; ye(51):=0; ze(51):=0;\r
+ xe(52):=30; ye(52):=-20; ze(52):=0;\r
+ xe(53):=30; ye(53):=-5; ze(53):=0;\r
+ xe(54):=35; ye(54):=-20; ze(54):=0;\r
+ xe(55):=35; ye(55):=-5; ze(55):=0;\r
+ xe(56):=40; ye(56):=-25; ze(56):=0;\r
+ xe(57):=40; ye(57):=0; ze(57):=0;\r
+\r
+(* N *)\r
+ xe(58):=45; ye(58):=-25; ze(58):=0;\r
+ xe(59):=45; ye(59):=0; ze(59):=0;\r
+ xe(60):=50; ye(60):=-25; ze(60):=0;\r
+ xe(61):=50; ye(61):=-15; ze(61):=0;\r
+ xe(62):=50; ye(62):=0; ze(62):=0;\r
+ xe(63):=60; ye(63):=-25; ze(63):=0;\r
+ xe(64):=60; ye(64):=-10; ze(64):=0;\r
+ xe(65):=60; ye(65):=0; ze(65):=0;\r
+ xe(66):=65; ye(66):=-25; ze(66):=0;\r
+ xe(67):=65; ye(67):=0; ze(67):=0;\r
+\r
+(* 3 *)\r
+ xe(68):=-15; ye(68):=5; ze(68):=0;\r
+ xe(69):=-15; ye(69):=10; ze(69):=0;\r
+ xe(70):=-15; ye(70):=25; ze(70):=0;\r
+ xe(71):=-15; ye(71):=30; ze(71):=0;\r
+ xe(72):=-10; ye(72):=15; ze(72):=0;\r
+ xe(73):=-10; ye(73):=20; ze(73):=0;\r
+ xe(74):=-5; ye(74):=10; ze(74):=0;\r
+ xe(75):=-5; ye(75):=15; ze(75):=0;\r
+ xe(76):=-5; ye(76):=20; ze(76):=0;\r
+ xe(77):=-5; ye(77):=25; ze(77):=0;\r
+ xe(78):=0; ye(78):=5; ze(78):=0;\r
+ xe(79):=0; ye(79):=30; ze(79):=0;\r
+\r
+(* D *)\r
+ xe(80):=5; ye(80):=5; ze(80):=0;\r
+ xe(81):=5; ye(81):=30; ze(81):=0;\r
+ xe(82):=10; ye(82):=10; ze(82):=0;\r
+ xe(83):=10; ye(83):=25; ze(83):=0;\r
+ xe(84):=15; ye(84):=10; ze(84):=0;\r
+ xe(85):=15; ye(85):=25; ze(85):=0;\r
+ xe(86):=20; ye(86):=5; ze(86):=0;\r
+ xe(87):=20; ye(87):=15; ze(87):=0;\r
+ xe(88):=20; ye(88):=20; ze(88):=0;\r
+ xe(89):=20; ye(89):=30; ze(89):=0;\r
+ xe(90):=25; ye(90):=10; ze(90):=0;\r
+ xe(91):=25; ye(91):=25; ze(91):=0;\r
+\r
+(* tableau des lignes *)\r
+(* M *)\r
+ tab_ligne(1):=1; tab_ligne(2):=2;\r
+ tab_ligne(3):=2; tab_ligne(4):=5;\r
+ tab_ligne(5):=5; tab_ligne(6):=4;\r
+ tab_ligne(7):=4; tab_ligne(8):=7;\r
+ tab_ligne(9):=7; tab_ligne(10):=9;\r
+ tab_ligne(11):=9; tab_ligne(12):=10;\r
+ tab_ligne(13):=10; tab_ligne(14):=12;\r
+ tab_ligne(15):=12; tab_ligne(16):=11;\r
+ tab_ligne(17):=11; tab_ligne(18):=8;\r
+ tab_ligne(19):=8; tab_ligne(20):=6;\r
+ tab_ligne(21):=6; tab_ligne(22):=3;\r
+ tab_ligne(23):=3; tab_ligne(24):=1;\r
+\r
+(* O *)\r
+ tab_ligne(25):=13; tab_ligne(26):=14;\r
+ tab_ligne(27):=14; tab_ligne(28):=20;\r
+ tab_ligne(29):=20; tab_ligne(30):=19;\r
+ tab_ligne(31):=19; tab_ligne(32):=13;\r
+ tab_ligne(33):=15; tab_ligne(34):=16;\r
+ tab_ligne(35):=16; tab_ligne(36):=18;\r
+ tab_ligne(37):=18; tab_ligne(38):=17;\r
+ tab_ligne(39):=17; tab_ligne(40):=15;\r
+\r
+(* R *)\r
+ tab_ligne(41):=21; tab_ligne(42):=22;\r
+ tab_ligne(43):=22; tab_ligne(44):=26;\r
+ tab_ligne(45):=26; tab_ligne(46):=25;\r
+ tab_ligne(47):=25; tab_ligne(48):=30;\r
+ tab_ligne(49):=30; tab_ligne(50):=31;\r
+ tab_ligne(51):=31; tab_ligne(52):=35;\r
+ tab_ligne(53):=35; tab_ligne(54):=34;\r
+ tab_ligne(55):=34; tab_ligne(56):=29;\r
+ tab_ligne(57):=29; tab_ligne(58):=33;\r
+ tab_ligne(59):=33; tab_ligne(60):=32;\r
+ tab_ligne(61):=32; tab_ligne(62):=21;\r
+ tab_ligne(63):=23; tab_ligne(64):=24;\r
+ tab_ligne(65):=24; tab_ligne(66):=28;\r
+ tab_ligne(67):=28; tab_ligne(68):=27;\r
+ tab_ligne(69):=27; tab_ligne(70):=23;\r
+\r
+(* P *)\r
+ tab_ligne(71):=36; tab_ligne(72):=41;\r
+ tab_ligne(73):=41; tab_ligne(74):=40;\r
+ tab_ligne(75):=40; tab_ligne(76):=39;\r
+ tab_ligne(77):=39; tab_ligne(78):=38;\r
+ tab_ligne(79):=38; tab_ligne(80):=37;\r
+ tab_ligne(81):=37; tab_ligne(82):=36;\r
+ tab_ligne(83):=42; tab_ligne(84):=43;\r
+ tab_ligne(85):=43; tab_ligne(86):=44;\r
+ tab_ligne(87):=44; tab_ligne(88):=45;\r
+ tab_ligne(89):=45; tab_ligne(90):=42;\r
+\r
+(* I *)\r
+ tab_ligne(91):=46; tab_ligne(92):=47;\r
+ tab_ligne(93):=47; tab_ligne(94):=49;\r
+ tab_ligne(95):=49; tab_ligne(96):=48;\r
+ tab_ligne(97):=48; tab_ligne(98):=46;\r
+\r
+(* O *)\r
+ tab_ligne(99):=50; tab_ligne(100):=51;\r
+ tab_ligne(101):=51; tab_ligne(102):=57;\r
+ tab_ligne(103):=57; tab_ligne(104):=56;\r
+ tab_ligne(105):=56; tab_ligne(106):=50;\r
+ tab_ligne(107):=52; tab_ligne(108):=53;\r
+ tab_ligne(109):=53; tab_ligne(110):=55;\r
+ tab_ligne(111):=55; tab_ligne(112):=54;\r
+ tab_ligne(113):=54; tab_ligne(114):=52;\r
+\r
+(* N *)\r
+ tab_ligne(115):=58; tab_ligne(116):=59;\r
+ tab_ligne(117):=59; tab_ligne(118):=62;\r
+ tab_ligne(119):=62; tab_ligne(120):=61;\r
+ tab_ligne(121):=61; tab_ligne(122):=65;\r
+ tab_ligne(123):=65; tab_ligne(124):=67;\r
+ tab_ligne(125):=67; tab_ligne(126):=66;\r
+ tab_ligne(127):=66; tab_ligne(128):=63;\r
+ tab_ligne(129):=63; tab_ligne(130):=64;\r
+ tab_ligne(131):=64; tab_ligne(132):=60;\r
+ tab_ligne(133):=60; tab_ligne(134):=58;\r
+\r
+(* 3 *)\r
+ tab_ligne(135):=68; tab_ligne(136):=69;\r
+ tab_ligne(137):=69; tab_ligne(138):=74;\r
+ tab_ligne(139):=74; tab_ligne(140):=75;\r
+ tab_ligne(141):=75; tab_ligne(142):=72;\r
+ tab_ligne(143):=72; tab_ligne(144):=73;\r
+ tab_ligne(145):=73; tab_ligne(146):=76;\r
+ tab_ligne(147):=76; tab_ligne(148):=77;\r
+ tab_ligne(149):=77; tab_ligne(150):=70;\r
+ tab_ligne(151):=70; tab_ligne(152):=71;\r
+ tab_ligne(153):=71; tab_ligne(154):=79;\r
+ tab_ligne(155):=79; tab_ligne(156):=78;\r
+ tab_ligne(157):=78; tab_ligne(158):=68;\r
+\r
+(* D *)\r
+ tab_ligne(159):=80; tab_ligne(160):=81;\r
+ tab_ligne(161):=81; tab_ligne(162):=89;\r
+ tab_ligne(163):=89; tab_ligne(164):=91;\r
+ tab_ligne(165):=91; tab_ligne(166):=90;\r
+ tab_ligne(167):=90; tab_ligne(168):=86;\r
+ tab_ligne(169):=86; tab_ligne(170):=80;\r
+ tab_ligne(171):=82; tab_ligne(172):=83;\r
+ tab_ligne(173):=83; tab_ligne(174):=85;\r
+ tab_ligne(175):=85; tab_ligne(176):=88;\r
+ tab_ligne(177):=88; tab_ligne(178):=87;\r
+ tab_ligne(179):=87; tab_ligne(180):=84;\r
+ tab_ligne(181):=84; tab_ligne(182):=82;\r
+\r
+end init_obj;\r
+\r
+(*----------------------------------------------------------------------*)\r
+(* *)\r
+(* Cette procedure calcul l'animation de l'objet dans l'espace *)\r
+(* *)\r
+(*----------------------------------------------------------------------*)\r
+unit ligne:procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+end ligne;\r
+\r
+(*----------------------------------------------------------------------*)\r
+(* *)\r
+(* Cette procedure affiche l'objet a l'ecran *)\r
+(* *)\r
+(*----------------------------------------------------------------------*)\r
+unit affiche_obj:procedure(x,y,tab_ligne:arrayof real;nb_ligne:integer);\r
+var i,j:integer;\r
+var x1,y1,x2,y2:real;\r
+begin\r
+ i:=1;\r
+ while i<nb_ligne\r
+ do\r
+ j:=tab_ligne(i);\r
+ x1:=x(j); y1:=y(j);\r
+ i:=i+1;\r
+ j:=tab_ligne(i);\r
+ x2:=x(j); y2:=y(j);\r
+ i:=i+1;\r
+ x1:=x1+320; y1:=y1+200;\r
+ x2:=x2+320; y2:=y2+200;\r
+ call ligne(x1,y1,x2,y2,10);\r
+ od;\r
+end affiche_obj;\r
+\r
+(*----------------------------------------------------------------------*)\r
+(* *)\r
+(* Cette procedure calcul l'animation de l'objet *)\r
+(* *)\r
+(*----------------------------------------------------------------------*)\r
+unit animation:procedure;\r
+var alpha,beta,gamma,xdep,ydep,zdep:real;\r
+var a,b,c,d,e,f,g,h,i:real;\r
+var xe,ye,ze,x,y,tab_ligne:arrayof real;\r
+var j,nb_pt,nb_ligne,touche:integer;\r
+var image:arrayof integer;\r
+begin\r
+ nb_pt:=91;\r
+ nb_ligne:=182;\r
+ array xe dim (1:nb_pt);\r
+ array ye dim (1:nb_pt);\r
+ array ze dim (1:nb_pt);\r
+ array x dim (1:nb_pt);\r
+ array y dim (1:nb_pt);\r
+ array tab_ligne dim(1:nb_ligne);\r
+ array image dim (1:100);\r
+\r
+ call init_obj(xe,ye,ze,tab_ligne);\r
+ call bouton(0,0,640,480,0,0,"",12,15,6,14);\r
+ call bouton(3,3,637,477,0,0,"",12,15,6,14);\r
+ call move(0,0);\r
+ image:=getmap(640,480);\r
+ zdep:=1000;\r
+ while zdep>-500\r
+ do\r
+ zdep:=zdep-100;\r
+ call sin_cos(alpha,beta,gamma,a,b,c,d,e,f,g,h,i);\r
+ for j:=1 to nb_pt\r
+ do\r
+ call trois_d_vers_2d(a,b,c,d,e,f,g,h,i,xe(j),ye(j),\r
+ ze(j),xdep,ydep,zdep,x(j),y(j));\r
+ od;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call affiche_obj(x,y,tab_ligne,nb_ligne);\r
+ od;\r
+ beta:=0;\r
+ while beta<6.28\r
+ do\r
+ beta:=beta+(30*3.1415927/180);(* on tourne de 30ø *)\r
+ call sin_cos(alpha,beta,gamma,a,b,c,d,e,f,g,h,i);\r
+ for j:=1 to nb_pt\r
+ do\r
+ call trois_d_vers_2d(a,b,c,d,e,f,g,h,i,xe(j),ye(j),\r
+ ze(j),xdep,ydep,zdep,x(j),y(j));\r
+ od;\r
+ call move(0,0);\r
+ call putmap(image);\r
+ call affiche_obj(x,y,tab_ligne,nb_ligne);\r
+ od;\r
+ call outstring(20,20,"FABIEN JOBIN",14,12);\r
+ call outstring(500,20,"FREDERIC GAUTIER",14,12);\r
+ call outstring(230,440,"LICENCE INFORMATIQUE 1995",14,12);\r
+ touche:=inchar;\r
+end animation;\r
+(*------------------ fin de l'animation du generique -------------------*)\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* EXPLORATION DES 49 COMBINAISONS POSSIBLES *)\r
+(*--------------------------------------------------------------------------*)\r
+\r
+ (* Cherche une ligne ayant nb cubes align\82s du m\88me joueur *)\r
+ (* et les indices i,j,k d'un cube libre *)\r
+ unit rech_ligne:procedure(i,val,nb:integer;output trouve:boolean;\r
+ output j,k:integer);\r
+ var som,num:integer;\r
+ var jlibre,klibre:integer;\r
+ begin\r
+ som:=0;\r
+ trouve:=false; \r
+ j:=1;\r
+ while j<= 3 and not trouve\r
+ do\r
+ som:=0;\r
+ num:=0;\r
+ k:=1;\r
+ while k<= 3 and not trouve\r
+ do\r
+ som := som + mat.tab(i,j,k).val;\r
+ if mat.tab(i,j,k).marque = 0 then\r
+ jlibre:=j;\r
+ klibre:=k;\r
+ else\r
+ if mat.tab(i,j,k).val = val then\r
+ num:=num+1;\r
+ fi;\r
+ fi;\r
+ k:=k+1;\r
+ od;\r
+ if som = nb*val and num = nb then\r
+ trouve:=true;\r
+ fi;\r
+ j:=j+1;\r
+ od;\r
+ if trouve then\r
+ (* Si on cherche 3 cubes align\82s on les affiche en clignotant *)\r
+ if nb = 3 then\r
+ call affic_3_alignes(i,j-1,1,i,j-1,2,i,j-1,3);\r
+ fi;\r
+ j:=jlibre;\r
+ k:=klibre;\r
+ fi;\r
+ end rech_ligne;\r
+\r
+ (* Cherche une colonne ayant nb cubes align\82s du m\88me joueur et *)\r
+ (* et renvoie les coordonn\82es i,j,k d'un cube libre *)\r
+ unit rech_col:procedure(i,val,nb:integer;output trouve:boolean;\r
+ output j,k:integer);\r
+ var som,num:integer;\r
+ var jlibre,klibre:integer;\r
+ begin\r
+ som:=0;\r
+ trouve:=false;\r
+ k:=1;\r
+ while k<= 3 and not trouve\r
+ do\r
+ som:=0; num:=0;\r
+ j:=1;\r
+ while j<= 3 and not trouve\r
+ do\r
+ som := som + mat.tab(i,j,k).val;\r
+ if mat.tab(i,j,k).marque = 0 then\r
+ jlibre:=j;\r
+ klibre:=k;\r
+ else\r
+ if mat.tab(i,j,k).val = val then\r
+ num:=num+1;\r
+ fi;\r
+ fi;\r
+ j:=j+1;\r
+ od;\r
+ if som = nb*val and num = nb then\r
+ trouve:=true;\r
+ fi;\r
+ k:=k+1;\r
+ od;\r
+ if trouve then\r
+ (* Si on cherche 3 cubes align\82s on les affiche en clignotant *) \r
+ if nb = 3 then\r
+ call affic_3_alignes(i,1,k-1,i,2,k-1,i,3,k-1);\r
+ fi;\r
+ j:=jlibre;\r
+ k:=klibre;\r
+ fi;\r
+ end rech_col;\r
+\r
+ (* Cherche une diagonale ayant nb cubes align\82s du m\88me joueur *)\r
+ (* et renvoie les coordonn\82es i,j,k d'un cube libre *)\r
+ unit rech_diag:procedure(i,val,nb:integer;output trouve:boolean;\r
+ output j,k:integer);\r
+ var som,num:integer;\r
+ var jlibre,klibre:integer;\r
+ begin\r
+ (* Diagonale haut gauche vers bas droit *)\r
+ som:=0;num:=0;\r
+ trouve:=false;\r
+ k:=1;\r
+ while k<= 3 and not trouve\r
+ do\r
+ som := som + mat.tab(i,k,k).val;\r
+ if mat.tab(i,k,k).marque = 0 then\r
+ klibre:=k;\r
+ else\r
+ if mat.tab(i,k,k).val = val then\r
+ num:=num+1;\r
+ fi;\r
+ fi;\r
+ k:=k+1;\r
+ od;\r
+ if som = nb*val and num = nb then\r
+ if nb = 3 then\r
+ call affic_3_alignes(i,1,1,i,2,2,i,3,3);\r
+ fi;\r
+ trouve:=true;\r
+ j:=klibre;\r
+ k:=klibre;\r
+ else\r
+ (* Diagonale haut droit vers bas gauche *)\r
+ som := 0;num:=0;\r
+ som := mat.tab(i,1,3).val + mat.tab(i,2,2).val + mat.tab(i,3,1).val;\r
+ if mat.tab(i,1,3).marque = 0 then\r
+ j:=1;k:=3;\r
+ else\r
+ if mat.tab(i,1,3).val = val then\r
+ num := num + 1;\r
+ fi;\r
+ fi;\r
+ if mat.tab(i,2,2).marque = 0 then\r
+ j:=2;k:=2;\r
+ else\r
+ if mat.tab(i,2,2).val = val then\r
+ num := num + 1;\r
+ fi;\r
+ fi;\r
+ if mat.tab(i,3,1).marque = 0 then\r
+ j:=3;k:=1;\r
+ else\r
+ if mat.tab(i,3,1).val = val then\r
+ num := num + 1;\r
+ fi;\r
+ fi;\r
+ if som = nb*val and num =nb then\r
+ (* Si on cherche 3 cubes align\82s on les affiche en clignotant *) \r
+ if nb = 3 then\r
+ call affic_3_alignes(i,3,1,i,2,2,i,1,3);\r
+ fi;\r
+ trouve:=true;\r
+ fi;\r
+ fi;\r
+ end rech_diag;\r
+\r
+ (* Cherche une colonne 3d ayant nb cubes align\82s du m\88me joueur *)\r
+ (* et renvoie les coordonn\82es i,j,k d'un cube libre. *)\r
+ (* Par colonne 3d, il faut entendre qu'il s'agit d'une colonne *)\r
+ (* qui passe par les 3 plans. *)\r
+ unit rech_col_3d:procedure(val,nb,j,k:integer;output i:integer;\r
+ output trouve:boolean);\r
+ var som,num:integer;\r
+ begin\r
+ som := mat.tab(1,j,k).val+mat.tab(2,j,k).val+mat.tab(3,j,k).val;\r
+ num:=0;\r
+ if mat.tab(1,j,k).marque = 0 then\r
+ i:=1;\r
+ else\r
+ if mat.tab(1,j,k).val = val then\r
+ num := num + 1;\r
+ fi;\r
+ fi;\r
+ if mat.tab(2,j,k).marque = 0 then\r
+ i:=2;\r
+ else\r
+ if mat.tab(2,j,k).val = val then\r
+ num := num + 1;\r
+ fi;\r
+ fi;\r
+ if mat.tab(3,j,k).marque = 0 then\r
+ i:=3;\r
+ else\r
+ if mat.tab(3,j,k).val = val then\r
+ num := num + 1;\r
+ fi;\r
+ fi;\r
+ if som = nb*val and num =nb then\r
+ (* Si on cherche 3 cubes align\82s on les affiche en clignotant *) \r
+ if nb = 3 then\r
+ call affic_3_alignes(1,j,k,2,j,k,3,j,k);\r
+ fi;\r
+ trouve:=true;\r
+ fi;\r
+\r
+ end rech_col_3d;\r
+\r
+ (* Cherche une diagonale 3d ayant nb cubes align\82s du m\88me joueur *)\r
+ (* et renvoie les coordonn\82es i,j,k d'un cube libre. *)\r
+ (* Par diagonale 3d, il faut entendre qu'il s'agit d'une diagonale *)\r
+ (* qui passe par les 3 plans. *)\r
+ unit rech_diag_3d:procedure(i1,j1,k1,i2,j2,k2,i3,j3,k3,val,nb:integer;\r
+ output i,j,k:integer;output trouve:boolean);\r
+ var som,num:integer;\r
+ begin\r
+ som := mat.tab(i1,j1,k1).val+mat.tab(i2,j2,k2).val+mat.tab(i3,j3,k3).val;\r
+ num:=0;\r
+ if mat.tab(i1,j1,k1).marque = 0 then\r
+ i:=i1;j:=j1;k:=k1;\r
+ else\r
+ if mat.tab(i1,j1,k1).val = val then\r
+ num:=num+1;\r
+ fi;\r
+ fi;\r
+ if mat.tab(i2,j2,k2).marque = 0 then\r
+ i:=i2;j:=j2;k:=k2;\r
+ else\r
+ if mat.tab(i2,j2,k2).val = val then\r
+ num:=num+1;\r
+ fi;\r
+ fi;\r
+ if mat.tab(i3,j3,k3).marque = 0 then\r
+ i:=i3;j:=j3;k:=k3;\r
+ else\r
+ if mat.tab(i3,j3,k3).val = val then\r
+ num:=num+1;\r
+ fi;\r
+ fi;\r
+ if som = nb*val and num =nb then\r
+ (* Si on cherche 3 cubes align\82s on les affiche en clignotant *) \r
+ if nb = 3 then\r
+ call affic_3_alignes(i1,j1,k1,i2,j2,k2,i3,j3,k3);\r
+ fi;\r
+ trouve:=true;\r
+ fi;\r
+ end rech_diag_3d;\r
+\r
+ (* Cette proc\82dure cherche dans les 49 combinaisons possibles *)\r
+ (* si il y a nb cubes align\82s du joueur qui marque les cubes *)\r
+ (* par val. Si cette combinaison de cubes a \82t\82 trouv\82e, les *)\r
+ (* indices d'un cube libre appartenant \85 cette combinaison *)\r
+ (* sont renvoy\82s. *)\r
+ unit trouve_aligne:procedure(val,nb:integer;output i,j,k:integer;\r
+ output trouve:boolean);\r
+ begin\r
+ trouve:=false;\r
+ i:=1;\r
+ (* i caract\82rise un plan *)\r
+ while i<=3 and not trouve\r
+ do\r
+ call rech_ligne(i,val,nb,trouve,j,k);\r
+ if not trouve then\r
+ call rech_col(i,val,nb,trouve,j,k);\r
+ if not trouve then\r
+ call rech_diag(i,val,nb,trouve,j,k);\r
+ fi;\r
+ fi;\r
+ i:=i+1;\r
+ od;\r
+ if not trouve then\r
+ (* Parties communes (colonnes et diagonales) aux 3 plans *)\r
+ (* Recherche dans les colonnes *)\r
+ j:=1;\r
+ while j<=3 and not trouve\r
+ do\r
+ k:=1;\r
+ while k<=3 and not trouve\r
+ do\r
+ call rech_col_3d(val,nb,j,k,i,trouve);\r
+ k:=k+1;\r
+ od;\r
+ j:=j+1;\r
+ od;\r
+ if trouve then\r
+ k:=k-1;j:=j-1;\r
+ else\r
+ (* Recherche dans les diagonales *)\r
+ call rech_diag_3d(1,2,1,2,2,2,3,2,3,val,nb,i,j,k,trouve);\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,2,2,2,2,3,3,2,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,2,3,2,2,2,3,2,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,2,2,2,2,3,1,2,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,1,2,1,2,3,1,3,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,1,2,2,1,3,3,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,1,2,2,2,3,3,3,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,3,2,1,2,3,1,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,3,2,2,3,3,3,3,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,1,3,2,2,2,3,3,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,3,2,3,2,3,3,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,3,2,2,3,3,1,3,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,3,2,2,2,3,1,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,1,2,3,2,3,3,3,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,1,2,2,1,3,1,1,val,nb,i,j,k,trouve);\r
+ fi;\r
+ if not trouve then\r
+ call rech_diag_3d(1,3,1,2,2,2,3,1,3,val,nb,i,j,k,trouve);\r
+ fi;\r
+ fi;\r
+ else\r
+ i:=i-1;\r
+ fi;\r
+ end trouve_aligne;\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* STRATEGIES ET UTILISATEUR *)\r
+(*--------------------------------------------------------------------------*)\r
+\r
+(*--------------------------------- STRATEGIE1 -----------------------------*)\r
+\r
+ (* La strat\82gie1 joue : *)\r
+ (* Le cube est marqu\82 par 2 et affich\82 *)\r
+ unit jouer:procedure(i,j,k:integer);\r
+ begin\r
+ mat.tab(i,j,k).val:=2;\r
+ mat.tab(i,j,k).marque:=1;\r
+ call affic_elem(i,j,k,25,20);\r
+ end jouer;\r
+\r
+ (* Strat\82gie1 *)\r
+ unit strategie1:class;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ end titre;\r
+ unit virtual trouve_3_pions:procedure;\r
+ begin\r
+ end trouve_3_pions;\r
+ unit virtual trouve_2_pions:procedure;\r
+ begin\r
+ end trouve_2_pions;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ end adversaire_joue;\r
+ unit virtual gagne:procedure;\r
+ begin\r
+ end gagne;\r
+ unit virtual perdu:procedure;\r
+ begin\r
+ end perdu;\r
+ var i,j,k:integer;\r
+ var trouve:boolean;\r
+ begin\r
+ return;\r
+ do\r
+ call titre;\r
+ inner;\r
+ call outstring(430,120,"Coups jou\82s : ",14,3);\r
+ call track(550,120,nb_coups,3,3);\r
+ call track(550,120,nb_coups,3,14);\r
+ (* La strat\82gie1 joue au centre *)\r
+ if mat.tab(2,2,2).marque=0 then\r
+ call jouer(2,2,2);\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ else\r
+ call trouve_3_pions;\r
+ if trouve then\r
+ (* Si l'utilisateur a 3 pions align\82s il a gagn\82 *)\r
+ call gagne;\r
+ attach(main);\r
+ else\r
+ call trouve_aligne(2,2,i,j,k,trouve);\r
+ if trouve then\r
+ (* Si la strat\82gie1 a 2 pions align\82s, elle rajoute *)\r
+ (* le troisi\8ame et elle gagne donc l'utilisateur perd *)\r
+ call jouer(i,j,k);\r
+ call track(550,120,nb_coups,3,3);\r
+ nb_coups:=nb_coups+1;\r
+ call track(550,120,nb_coups,3,14);\r
+ call trouve_aligne(2,3,i,j,k,trouve);\r
+ call perdu;\r
+ attach(main);\r
+ else\r
+ (* Sinon la strat\82gie 1 bloque l'utilisateur si il a 2 *)\r
+ (* pions align\82s *)\r
+ call trouve_2_pions;\r
+ if trouve then\r
+ call jouer(i,j,k);\r
+ else\r
+ (* On cherche un pion de la strat\82gie1 et *)\r
+ (* on aligne un pion de fa\87on \85 avoir 2 *)\r
+ (* pions align\82s pour la strat\82gie1 *)\r
+ call trouve_aligne(2,1,i,j,k,trouve);\r
+ call jouer(i,j,k);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ fi;\r
+ od;\r
+ end strategie1;\r
+\r
+ (* Strat\82gie1 contre joueur *)\r
+ unit strategie1_user1:strategie1 coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"L'utilisateur joue...",3,3);\r
+ call outstring(430,90,"La strat\82gie1 joue...",10,3);\r
+ end titre;\r
+ unit virtual trouve_3_pions:procedure;\r
+ begin\r
+ call trouve_aligne(1,3,i,j,k,trouve);\r
+ end trouve_3_pions;\r
+ unit virtual trouve_2_pions:procedure;\r
+ begin\r
+ call trouve_aligne(1,2,i,j,k,trouve);\r
+ end trouve_2_pions;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(user1);\r
+ end adversaire_joue;\r
+ unit virtual gagne:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,255,209,\r
+ "Vous avez gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ end gagne;\r
+ unit virtual perdu:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,255,209,\r
+ "Vous avez perdu",125,"",\r
+ 270,240,370,270,310,247);\r
+ end perdu;\r
+ begin\r
+ end strategie1_user1;\r
+\r
+ (* Strat\82gie1 contre strat\82gie2 *)\r
+ unit strategie1_strat2:strategie1 coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"La strat\82gie2 joue...",3,3);\r
+ call outstring(430,90,"La strat\82gie1 joue...",10,3);\r
+ end titre;\r
+ unit virtual trouve_3_pions:procedure;\r
+ begin\r
+ call trouve_aligne(3,3,i,j,k,trouve);\r
+ end trouve_3_pions;\r
+ unit virtual trouve_2_pions:procedure;\r
+ begin\r
+ call trouve_aligne(3,2,i,j,k,trouve);\r
+ end trouve_2_pions;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(S22);\r
+ end adversaire_joue;\r
+ unit virtual gagne:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,225,209,\r
+ "La strat\82gie2 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ end gagne;\r
+ unit virtual perdu:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,225,209,\r
+ "La strat\82gie1 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ end perdu;\r
+ var cpt:integer;\r
+ begin\r
+ for cpt:=1 to 30000 do cpt:=cpt+1 od;\r
+ if nb_coups=27 then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "Egalit\82 entre la strat\82gie1 et la strat\82gie2",125,"",\r
+ 270,240,370,270,310,247);\r
+ attach(main);\r
+ fi;\r
+ end strategie1_strat2;\r
+\r
+(*-------------------------------- STRATEGIE2 ------------------------------*)\r
+\r
+ (* La strat\82gie2 joue : *)\r
+ (* Le cube est marqu\82 par 3 et affich\82 *)\r
+ unit jouer2:procedure(i,j,k:integer);\r
+ begin\r
+ mat.tab(i,j,k).val:=3;\r
+ mat.tab(i,j,k).marque:=1;\r
+ call affic_elem(i,j,k,25,20);\r
+ end jouer2;\r
+\r
+ (* Strat\82gie2 *)\r
+ unit strategie2:class;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ end titre;\r
+ unit virtual trouve_3_pions:procedure;\r
+ begin\r
+ end trouve_3_pions;\r
+ unit virtual trouve_2_pions:procedure;\r
+ begin\r
+ end trouve_2_pions;\r
+ unit virtual trouve_1_pion:procedure;\r
+ begin\r
+ end trouve_1_pion;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ end adversaire_joue;\r
+ unit virtual gagne:procedure;\r
+ begin\r
+ end gagne;\r
+ unit virtual perdu:procedure;\r
+ begin\r
+ end perdu;\r
+ var i,j,k:integer;\r
+ var trouve:boolean;\r
+ begin\r
+ joue1:=false;\r
+ joue2:=false;\r
+ return;\r
+ do\r
+ call titre;\r
+ call outstring(430,120,"Coups jou\82s : ",14,3);\r
+ call track(550,120,nb_coups,3,3);\r
+ call track(550,120,nb_coups,3,14);\r
+ inner;\r
+ if mat.tab(1,1,1).marque=0 then\r
+ call jouer2(1,1,1);\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ else\r
+ if nb_coups = 2 then\r
+ if mat.tab(1,1,3).marque=0 then\r
+ call jouer2(1,1,3);\r
+ joue1:=true;\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ else\r
+ if mat.tab(1,3,1).marque=0 then\r
+ call jouer2(1,3,1);\r
+ joue2:=true;\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ fi;\r
+ fi;\r
+ else\r
+ call trouve_3_pions;\r
+ if trouve then\r
+ (* Si l'utilisateur a 3 pions align\82s il a gagn\82 *)\r
+ call gagne;\r
+ attach(main);\r
+ else\r
+ call trouve_aligne(3,2,i,j,k,trouve);\r
+ if trouve then\r
+ (* Si la strat\82gie2 a 2 pions align\82s, elle rajoute *)\r
+ (* le troisi\8ame et elle gagne donc l'utilisateur perd *)\r
+ call jouer2(i,j,k);\r
+ call track(550,120,nb_coups,3,3);\r
+ nb_coups:=nb_coups+1;\r
+ call track(550,120,nb_coups,3,14);\r
+ call trouve_aligne(3,3,i,j,k,trouve);\r
+ call perdu;\r
+ attach(main);\r
+ else\r
+ call trouve_2_pions;\r
+ (* Sinon la strat\82gie2 bloque l'utilisateur si il a 2 *)\r
+ (* pions align\82s *)\r
+ if trouve then\r
+ call jouer2(i,j,k);\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ else\r
+ if joue1 and mat.tab(2,1,2).marque = 0 then\r
+ call jouer2(2,1,2);\r
+ nb_coups:=nb_coups+1;\r
+ joue1:=false;\r
+ call adversaire_joue;\r
+ else\r
+ if joue2 and mat.tab(2,2,1).marque = 0 then\r
+ call jouer2(2,2,1);\r
+ nb_coups:=nb_coups+1;\r
+ joue2:=false;\r
+ call adversaire_joue;\r
+ else\r
+ (* La strat\82gie2 aligne un pion avec un pion *)\r
+ (* de l'adversaire *)\r
+ call trouve_1_pion;\r
+ call jouer2(i,j,k);\r
+ nb_coups:=nb_coups+1;\r
+ call adversaire_joue;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ end strategie2;\r
+\r
+ (* Strat\82gie2 contre joueur *)\r
+ unit strategie2_user2:strategie2 coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"L'utilisateur joue...",3,3);\r
+ call outstring(430,90,"La strat\82gie2 joue...",9,3);\r
+ end titre;\r
+ unit virtual trouve_3_pions:procedure;\r
+ begin\r
+ call trouve_aligne(1,3,i,j,k,trouve);\r
+ end trouve_3_pions;\r
+ unit virtual trouve_2_pions:procedure;\r
+ begin\r
+ call trouve_aligne(1,2,i,j,k,trouve);\r
+ end trouve_2_pions;\r
+ unit virtual trouve_1_pion:procedure;\r
+ begin\r
+ call trouve_aligne(1,1,i,j,k,trouve);\r
+ end trouve_1_pion;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(user2);\r
+ end adversaire_joue;\r
+ unit virtual gagne:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,255,209,\r
+ "Vous avez gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ end gagne;\r
+ unit virtual perdu:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,255,209,\r
+ "Vous avez perdu",125,"",\r
+ 270,240,370,270,310,247);\r
+ end perdu;\r
+ begin\r
+ end strategie2_user2;\r
+\r
+ (* Strat\82gie2 contre strat\82gie1 *)\r
+ unit strategie2_strat1:strategie2 coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"La strat\82gie1 joue...",3,3);\r
+ call outstring(430,90,"La strat\82gie2 joue...",9,3);\r
+ end titre;\r
+ unit virtual trouve_3_pions:procedure;\r
+ begin\r
+ call trouve_aligne(2,3,i,j,k,trouve);\r
+ end trouve_3_pions;\r
+ unit virtual trouve_2_pions:procedure;\r
+ begin\r
+ call trouve_aligne(2,2,i,j,k,trouve);\r
+ end trouve_2_pions;\r
+ unit virtual trouve_1_pion:procedure;\r
+ begin\r
+ call trouve_aligne(2,1,i,j,k,trouve);\r
+ end trouve_1_pion;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(S12);\r
+ end adversaire_joue;\r
+ unit virtual gagne:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,225,209,\r
+ "La strat\82gie1 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ end gagne;\r
+ unit virtual perdu:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,225,209,\r
+ "La strat\82gie2 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ end perdu;\r
+ var cpt:integer;\r
+ begin\r
+ for cpt:=1 to 30000 do cpt:=cpt+1 od;\r
+ end strategie2_strat1;\r
+\r
+(*-------------------------------- UTILISATEUR -----------------------------*)\r
+\r
+ (* Utilisateur ou joueur *)\r
+ unit utilisateur:class;\r
+ unit virtual titre:procedure;\r
+ end titre;\r
+ unit virtual adversaire_joue:procedure;\r
+ end adversaire_joue;\r
+ unit virtual saisie_joueur:procedure;\r
+ end saisie_joueur;\r
+ unit virtual egalite:procedure;\r
+ begin\r
+ end egalite;\r
+ var i:integer;\r
+ begin\r
+ return;\r
+ do\r
+ inner;\r
+ call titre;\r
+ call outstring(430,120,"Coups jou\82s : ",14,3);\r
+ call track(550,120,nb_coups,3,3);\r
+ call track(550,120,nb_coups,3,14);\r
+ c:=0; joue:=false;\r
+ (* On attend que le joueur colorie un cube et que cette saisie *)\r
+ (* soit prise en compte. On attend donc que le joueur appuie *)\r
+ (* sur les boutons gauche et droite de la souris pour colorier *)\r
+ (* un cube. *) \r
+ while c <> 3 or not(joue)\r
+ do\r
+\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if c=1 then\r
+ (* Touches d'affichage de la matrice *)\r
+ call gestion_touches(v,p,c);\r
+ fi;\r
+ if c=1 or c=2 or c=3 then\r
+ (* Le joueur colorie ou efface le coloriage d'un cube *)\r
+ (* ou il joue : le coloriage est pris en compte *)\r
+ call saisie_joueur;\r
+ fi;\r
+ if c=1 then\r
+ (* Acc\8as au menu principal *)\r
+ call gestion_menu(v,p,c);\r
+ fi;\r
+ od;\r
+ nb_coups:=nb_coups+1;\r
+ if nb_coups=27 then\r
+ call egalite;\r
+ attach(main);\r
+ else\r
+ call adversaire_joue;\r
+ fi;\r
+ od;\r
+ end utilisateur;\r
+\r
+ (* Joueur contre la strat\82gie1 *)\r
+ unit utilisateur1:utilisateur coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"La strat\82gie1 joue...",3,3);\r
+ call outstring(430,90,"L'utilisateur joue...",12,3);\r
+ end titre;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(S11);\r
+ end adversaire_joue;\r
+ unit virtual saisie_joueur:procedure;\r
+ begin\r
+ call saisie(v,p,c,20,25,1);\r
+ end saisie_joueur;\r
+ unit virtual egalite:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "Egalit\82 entre le joueur et la strat\82gie1",125,"",\r
+ 270,240,370,270,310,247);\r
+ end egalite;\r
+ begin\r
+ end utilisateur1;\r
+\r
+ (* Joueur contre la strat\82gie2 *)\r
+ unit utilisateur2:utilisateur coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"La strat\82gie2 joue...",3,3);\r
+ call outstring(430,90,"L'utilisateur joue...",12,3);\r
+ end titre;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(S21);\r
+ end adversaire_joue;\r
+ unit virtual saisie_joueur:procedure;\r
+ begin\r
+ call saisie(v,p,c,20,25,1);\r
+ end saisie_joueur;\r
+ begin\r
+ if nb_coups=27 then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "Egalit\82 entre le joueur et la strat\82gie2",125,"",\r
+ 270,240,370,270,310,247);\r
+ attach(main);\r
+ fi;\r
+ end utilisateur2;\r
+\r
+ (* Joueur1 contre Joueur2 *)\r
+ unit utilisateur3:utilisateur coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"Le joueur2 joue...",3,3);\r
+ call outstring(430,90,"Le joueur1 joue...",12,3);\r
+ end titre;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(user4);\r
+ end adversaire_joue;\r
+ unit virtual saisie_joueur:procedure;\r
+ begin\r
+ call saisie(v,p,c,20,25,1);\r
+ end saisie_joueur;\r
+ unit virtual egalite:procedure;\r
+ begin\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "Egalit\82 entre le joueur1 et le joueur2",125,"",\r
+ 270,240,370,270,310,247);\r
+ end egalite;\r
+ var i,j,k:integer;\r
+ var trouve:boolean;\r
+ begin\r
+ joueur:=1;\r
+ call trouve_aligne(4,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,255,209,\r
+ "Le joueur2 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ attach(main);\r
+ fi;\r
+ end utilisateur3;\r
+\r
+ (* Joueur2 contre Joueur1 *)\r
+ unit utilisateur4:utilisateur coroutine;\r
+ unit virtual titre:procedure;\r
+ begin\r
+ call outstring(430,90,"Le joueur1 joue...",3,3);\r
+ call outstring(430,90,"Le joueur2 joue...",9,3);\r
+ end titre;\r
+ unit virtual adversaire_joue:procedure;\r
+ begin\r
+ attach(user3);\r
+ end adversaire_joue;\r
+ unit virtual saisie_joueur:procedure;\r
+ begin\r
+ call saisie(v,p,c,20,25,2);\r
+ end saisie_joueur;\r
+ var i,j,k:integer;\r
+ var trouve:boolean;\r
+ begin\r
+ joueur:=2;\r
+ call trouve_aligne(1,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,255,209,\r
+ "Le joueur1 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ attach(main);\r
+ fi;\r
+ end utilisateur4;\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* FICHIERS *)\r
+(*--------------------------------------------------------------------------*) \r
+\r
+ (* Charger une matrice 3d \85 partir d'un fichier *)\r
+ unit charger:procedure;\r
+ var rep : arrayof char;\r
+ var f : file;\r
+ var i,j,k : integer;\r
+ var trouve:boolean;\r
+ begin\r
+ call patern(400,30,630,150,3,1);\r
+ call hidecursor;\r
+ call init(0,0);\r
+ call outstring(410,250,"Nom du fichier : ",15,3);\r
+ rep:=hfont8(545,250,10,80,"Nom",3,15,15);\r
+ open(f,integer,rep);\r
+ call reset(f);\r
+ get(f,mode);\r
+ get(f,joueur);\r
+ get(f,nb_coups);\r
+ for i := 1 to 3\r
+ do\r
+ for j := 1 to 3\r
+ do\r
+ for k:= 1 to 3\r
+ do\r
+ get(f,mat.tab(i,j,k).val);\r
+ get(f,mat.tab(i,j,k).marque);\r
+ get(f,mat.tab(i,j,k).x);\r
+ get(f,mat.tab(i,j,k).y);\r
+ od;\r
+ od;\r
+ od;\r
+ kill(f);\r
+ call patern(400,220,630,260,3,1);\r
+\r
+ call init(1,0);\r
+ call showcursor;\r
+ call setposition(275,445);\r
+ for j:=1 to 5\r
+ do\r
+ call outstring(280,425,"Veuillez appuyer sur un des boutons",14,3);\r
+ call outstring(280,445," de la souris",14,3);\r
+ for i:=1 to 10000 do i:=i+1 od;\r
+ call outstring(280,425,"Veuillez appuyer sur un des boutons",3,3);\r
+ call outstring(280,445," de la souris",3,3);\r
+ for i:=1 to 10000 do i:=i+1 od;\r
+ od;\r
+\r
+ (* Affichage de la matrice *)\r
+ call affic(25,20);\r
+ call outstring(410,275,"Chargement termin\82",15,3);\r
+ for i:=1 to 10000 do i:=i+1 od;\r
+ call outstring(410,275,"Chargement termin\82",3,3);\r
+\r
+ call outstring(430,120,"Coups jou\82s : ",14,3);\r
+ call track(550,120,nb_coups,3,14);\r
+ case mode\r
+ when 1:\r
+ call outstring(400,60,"JOUEUR",12,3);\r
+ call outstring(460,60,"CONTRE",0,3);\r
+ call outstring(520,60,"STRATEGIE1",10,3);\r
+\r
+ if nb_coups = 27 then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, et il y a \82galit\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(1,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, le joueur a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(2,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, la strat\82gie1 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ S11:=new strategie1_user1;\r
+ user1:=new utilisateur1;\r
+ attach(user1);\r
+ kill(user1); kill(S11);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ when 2:\r
+ call outstring(400,60,"JOUEUR",12,3);\r
+ call outstring(460,60,"CONTRE",0,3);\r
+ call outstring(520,60,"STRATEGIE2",9,3);\r
+ if nb_coups = 27 then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, et il y a \82galit\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(1,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, le joueur a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(3,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, la strat\82gie2 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ S21:=new strategie2_user2;\r
+ user2:=new utilisateur2;\r
+ attach(user2);\r
+ kill(user2); kill(S21);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ when 3:\r
+ call outstring(400,60,"STRATEGIE1",10,3);\r
+ call outstring(485,60,"CONTRE",0,3);\r
+ call outstring(540,60,"STRATEGIE2",9,3);\r
+ if nb_coups = 27 then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, et il y a \82galit\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(2,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, la strat\82gie1 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(3,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, la strat\82gie2 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ when 4:\r
+ call outstring(400,60,"JOUEUR1",12,3);\r
+ call outstring(465,60,"CONTRE",0,3);\r
+ call outstring(525,60,"JOUEUR2",9,3);\r
+ if nb_coups = 27 then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, et il y a \82galit\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(1,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, le joueur1 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ call trouve_aligne(4,3,i,j,k,trouve);\r
+ if trouve then\r
+ call message_erreur(105,200,535,280,155,209,\r
+ "La partie est termin\82e, le joueur2 a gagn\82",125,"",\r
+ 270,240,370,270,310,247);\r
+ else\r
+ user3:=new utilisateur3;\r
+ user4:=new utilisateur4;\r
+ if joueur=1 then\r
+ attach(user3);\r
+ else\r
+ if joueur=2 then\r
+ attach(user4);\r
+ fi;\r
+ fi;\r
+ kill(user3); kill(user4);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ esac;\r
+ end charger;\r
+\r
+ (* Enregistrement de la matrice 3d dans un fichier *)\r
+ unit enregistrer:procedure;\r
+ var f : file;\r
+ var i,j,k : integer;\r
+ var rep : arrayof char;\r
+ begin\r
+ call hidecursor;\r
+ call init(0,0);\r
+ call outstring(410,250,"Nom du fichier : ",15,3);\r
+ rep:=hfont8(545,250,10,80,"Nom",3,15,15);\r
+ open(f,integer,rep);\r
+ call rewrite(f);\r
+ put(f,mode);\r
+ put(f,joueur);\r
+ put(f,nb_coups);\r
+ for i := 1 to 3\r
+ do\r
+ for j := 1 to 3\r
+ do\r
+ for k:= 1 to 3\r
+ do\r
+ put(f,mat.tab(i,j,k).val);\r
+ put(f,mat.tab(i,j,k).marque);\r
+ put(f,mat.tab(i,j,k).x);\r
+ put(f,mat.tab(i,j,k).y);\r
+ od;\r
+ od;\r
+ od;\r
+ kill(f);\r
+ call outstring(410,275,"Enregistrement termin\82",15,3);\r
+ for i:=1 to 10000 do i:=i+1 od;\r
+ call outstring(410,275,"Enregistrement termin\82",3,3);\r
+ call patern(400,220,630,260,3,1);\r
+\r
+ call init(1,0);\r
+ call showcursor;\r
+ call setposition(275,445);\r
+ for j:=1 to 5\r
+ do\r
+ call outstring(280,425,"Veuillez appuyer sur un des boutons",14,3);\r
+ call outstring(280,445," de la souris",14,3);\r
+ for i:=1 to 10000 do i:=i+1 od;\r
+ call outstring(280,425,"Veuillez appuyer sur un des boutons",3,3);\r
+ call outstring(280,445," de la souris",3,3);\r
+ for i:=1 to 10000 do i:=i+1 od;\r
+ od;\r
+ end enregistrer;\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* MENU PRINCIPAL ET SOUS-MENUS *)\r
+(*--------------------------------------------------------------------------*) \r
+\r
+ (* G\8are les touches (gauche,haut,droite,bas) de l'affichage *)\r
+ (* du morpion 3d *)\r
+ unit gestion_touches:procedure(xmouse,ymouse,bouton_mouse:integer);\r
+ var tab : arrayof integer;\r
+ var i : integer;\r
+ begin\r
+ array tab dim (1:100);\r
+ (* Bouton du haut *)\r
+ if (xmouse >= 110 and xmouse <= 145 and ymouse >= 360 and\r
+ ymouse <= 390 and bouton_mouse = 1) then\r
+ call move(110,360);\r
+ tab := getmap(145,390);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call bouton(110,360,145,390,120,370,"/\",7,8,15,4);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call move(110,360);\r
+ call putmap(tab);\r
+ call haut;\r
+ else\r
+ (* Bouton du bas *)\r
+ if (xmouse >= 110 and xmouse <= 145 and ymouse >= 410 and\r
+ ymouse <= 440 and bouton_mouse = 1) then\r
+ call move(110,410);\r
+ tab := getmap(145,440);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call bouton(110,410,145,440,120,420,"\/",7,8,15,4);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call move(110,410);\r
+ call putmap(tab);\r
+ call bas;\r
+ else\r
+ (* Bouton droit *)\r
+ if (xmouse >= 170 and xmouse <= 205 and ymouse >= 410 and\r
+ ymouse <= 440 and bouton_mouse = 1) then\r
+ call move(170,410);\r
+ tab := getmap(205,440);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call bouton(170,410,205,440,180,420,">>",7,8,15,4);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call move(170,410);\r
+ call putmap(tab);\r
+ call droit;\r
+ else\r
+ (* Bouton gauche *)\r
+ if (xmouse >= 50 and xmouse <= 85 and ymouse >= 410 and\r
+ ymouse <= 440 and bouton_mouse = 1) then\r
+ call move(50,410);\r
+ tab := getmap(85,440);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call bouton(50,410,85,440,60,420,"<<",7,8,15,4);\r
+ for i:=1 to 1000 do i := i + 1 od;\r
+ call move(50,410);\r
+ call putmap(tab);\r
+ call gauche;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end gestion_touches;\r
+\r
+ (* Cette proc\82dure effectue les diff\82rents jeux possibles selon le *)\r
+ (* choix de l'utilisateur *) \r
+ unit gestion_mode_joueur:procedure(xmouse,ymouse,bouton_mouse:integer;\r
+ tab2:arrayof integer);\r
+ var tab : arrayof integer;\r
+ var i:integer;\r
+ begin\r
+ if (xmouse>=195 and xmouse <= 445 and ymouse >= 140\r
+ and ymouse <= 180 and bouton_mouse =1) then\r
+ mode:=1;\r
+ call move(195,140);\r
+ tab := getmap(445,180);\r
+ for i:=1 to 1000 do i:=i+1; od;\r
+ call bouton(195,140,445,180,225,152,\r
+ "Joueur contre strat\82gie1",7,8,15,4);\r
+ for i:=1 to 5000 do i:=i+1; od;\r
+ call move(195,140);\r
+ call putmap(tab);\r
+ call move(186,110);\r
+ call putmap(tab2);\r
+ S11:=new strategie1_user1;\r
+ user1:=new utilisateur1;\r
+ call outstring(400,60,"JOUEUR",12,3);\r
+ call outstring(460,60,"CONTRE",0,3);\r
+ call outstring(520,60,"STRATEGIE1",10,3);\r
+ attach(user1);\r
+ kill(user1); kill(S11);\r
+ c:=2;\r
+ efface:=true;\r
+ else\r
+ if (xmouse>=195 and xmouse <= 445 and ymouse >= 190\r
+ and ymouse <= 230 and bouton_mouse=1) then\r
+ mode:=2;\r
+ call move(195,190);\r
+ tab := getmap(445,230);\r
+ for i:=1 to 1000 do i:=i+1; od;\r
+ call bouton(195,190,445,230,225,202,\r
+ "Joueur contre strat\82gie2",7,8,15,4);\r
+ for i:=1 to 5000 do i:=i+1; od;\r
+ call move(195,190);\r
+ call putmap(tab);\r
+ call move(186,110);\r
+ call putmap(tab2);\r
+ S21:=new strategie2_user2;\r
+ user2:=new utilisateur2;\r
+ call outstring(400,60,"JOUEUR",12,3);\r
+ call outstring(460,60,"CONTRE",0,3);\r
+ call outstring(520,60,"STRATEGIE2",9,3);\r
+ attach(S21);\r
+ kill(user2); kill(S21);\r
+ c:=2;\r
+ efface:=true;\r
+ else\r
+ if (xmouse>=195 and xmouse <= 445 and ymouse >= 240\r
+ and ymouse <= 280 and bouton_mouse=1) then\r
+ mode:=3;\r
+ call move(195,240);\r
+ tab := getmap(445,280);\r
+ for i:=1 to 1000 do i:=i+1; od;\r
+ call bouton(195,240,445,280,210,252,\r
+ "Strat\82gie1 contre strat\82gie2",7,8,15,4);\r
+ for i:=1 to 5000 do i:=i+1; od;\r
+ call move(195,240);\r
+ call putmap(tab);\r
+ call move(186,110);\r
+ call putmap(tab2);\r
+ S12:=new strategie1_strat2;\r
+ S22:=new strategie2_strat1;\r
+ call outstring(400,60,"STRATEGIE1",10,3);\r
+ call outstring(485,60,"CONTRE",0,3);\r
+ call outstring(540,60,"STRATEGIE2",9,3);\r
+ attach(S22);\r
+ kill(S12); kill(S22);\r
+ c:=2;\r
+ efface:=true;\r
+ else\r
+ if (xmouse>=195 and xmouse <= 445 and ymouse >= 290\r
+ and ymouse <= 330 and bouton_mouse=1) then\r
+ mode:=4;\r
+ call move(195,290);\r
+ tab := getmap(445,330);\r
+ for i:=1 to 1000 do i:=i+1; od;\r
+ call bouton(195,290,445,330,230,302,\r
+ "Joueur1 contre Joueur2",7,8,15,4);\r
+ for i:=1 to 5000 do i:=i+1; od;\r
+ call move(195,290);\r
+ call putmap(tab);\r
+ call move(186,110);\r
+ call putmap(tab2);\r
+ efface:=true;\r
+ user3:=new utilisateur3;\r
+ user4:=new utilisateur4;\r
+ call outstring(400,60,"JOUEUR1",12,3);\r
+ call outstring(465,60,"CONTRE",0,3);\r
+ call outstring(525,60,"JOUEUR2",9,3);\r
+ attach(user3);\r
+ kill(user3); kill(user4);\r
+ c:=2;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end gestion_mode_joueur;\r
+\r
+ (* Affiche le sous-menu mode joueur *)\r
+ unit mode_joueur:procedure(xmouse,ymouse,bouton_mouse:integer);\r
+ var tab : arrayof integer;\r
+ begin\r
+ call patern(400,30,630,150,3,1);\r
+ call init_mat(mat);\r
+ call affic(25,20);\r
+ nb_coups:=0;\r
+ mode:=0;joueur:=0;\r
+ array tab dim (1:100);\r
+ call move(186,110);\r
+ tab := getmap(453,337);\r
+\r
+ call bouton(186,110,453,337,210,117,\r
+ "Choisissez votre mode de jeu",12,15,6,15);\r
+\r
+ call cadre_bouton(195,140,445,180);\r
+ call bouton(195,140,445,180,225,152,\r
+ "Joueur contre strat\82gie1",7,15,8,14);\r
+\r
+ call cadre_bouton(195,190,445,230);\r
+ call bouton(195,190,445,230,225,202,\r
+ "Joueur contre strat\82gie2",7,15,8,14);\r
+\r
+ call cadre_bouton(195,240,445,280);\r
+ call bouton(195,240,445,280,210,252,\r
+ "Strat\82gie1 contre strat\82gie2",7,15,8,14);\r
+\r
+ call cadre_bouton(195,290,445,330);\r
+ call bouton(195,290,445,330,230,302,\r
+ "Joueur1 contre Joueur2",7,15,8,14);\r
+\r
+ efface:=false;\r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ call gestion_mode_joueur(v,p,c,tab);\r
+ if c = 2 then exit fi;\r
+ od;\r
+ if not efface then\r
+ call move(186,110);\r
+ call putmap(tab);\r
+ fi;\r
+ end mode_joueur;\r
+\r
+ (* G\8are le sous-menu comprenant : *)\r
+ (* - une nouvelle partie *)\r
+ (* - le chargement d'une partie *)\r
+ (* - l'enregistrement de la partie *)\r
+ unit gestion_sous_menu:procedure(xmouse,ymouse,bouton_mouse:integer;\r
+ tab:arrayof integer);\r
+ var i:integer;\r
+ begin\r
+ if (xmouse>=30 and xmouse <= 202 and ymouse >= 32\r
+ and ymouse <= 42 and bouton_mouse=1) then\r
+ call outstring(30,30,"Nouvelle partie ",12,8);\r
+ for i:= 1 to 10000 do i:=i+1 od;\r
+ call move(20,20);\r
+ call putmap(tab);\r
+ call outstring(20,3,"Jeu",14,7);\r
+ call mode_joueur(xmouse,ymouse,bouton_mouse);\r
+ else\r
+ if (xmouse>=30 and xmouse <= 202 and ymouse >= 52\r
+ and ymouse <= 62 and bouton_mouse=1) then\r
+ call outstring(30,50,"Charger une partie ",12,8);\r
+ for i:= 1 to 10000 do i:=i+1 od;\r
+ call outstring(30,50,"Charger une partie ",14,7);\r
+ call move(20,20);\r
+ call putmap(tab);\r
+ call outstring(20,3,"Jeu",14,7);\r
+ call charger;\r
+ c:=2;\r
+ else\r
+ if (xmouse>=30 and xmouse <= 202 and ymouse >= 72\r
+ and ymouse <= 82 and bouton_mouse=1) then\r
+ call outstring(30,70,"Enregistrer la partie ",12,8);\r
+ for i:= 1 to 10000 do i:=i+1 od;\r
+ call outstring(30,70,"Enregistrer la partie ",14,7);\r
+ call move(20,20);\r
+ call putmap(tab);\r
+ call outstring(20,3,"Jeu",14,7);\r
+ call enregistrer;\r
+ c:=2;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end gestion_sous_menu;\r
+\r
+ (* Affiche le sous-menu de l 'option "JEU" du menu principal *)\r
+ unit sous_menu:procedure;\r
+ var tab : arrayof integer;\r
+ begin\r
+ array tab dim (1:100);\r
+ call move(20,20);\r
+ tab := getmap(210,95);\r
+ call bouton(20,20,210,95,0,0,"",7,15,8,14);\r
+ call outstring(30,30,"Nouvelle partie ",14,7);\r
+ call outstring(30,50,"Charger une partie ",14,7);\r
+ call outstring(30,70,"Enregistrer la partie ",14,7);\r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ call gestion_sous_menu(v,p,c,tab);\r
+ if c = 2 then exit fi;\r
+ od;\r
+ call move(20,20);\r
+ call putmap(tab);\r
+ end sous_menu;\r
+\r
+ (* Cette proc\82dure g\8are le menu principal *)\r
+ unit gestion_menu:procedure(xmouse,ymouse,bouton_mouse:integer);\r
+ var i:integer;\r
+ begin\r
+ if (xmouse>=20 and xmouse <= 42 and ymouse >= 3\r
+ and ymouse <= 15 and bouton_mouse=1) then\r
+ call outstring(20,3,"Jeu",12,8);\r
+ call sous_menu;\r
+ call outstring(20,3,"Jeu",14,7);\r
+ else\r
+ if (xmouse>=90 and xmouse <= 122 and ymouse >= 3\r
+ and ymouse <= 15 and bouton_mouse = 1) then\r
+ call outstring(90,3,"Aide",12,8);\r
+ call aide;\r
+ call outstring(90,3,"Aide",14,7);\r
+ else\r
+ if (xmouse>=160 and xmouse <= 215 and ymouse >= 3\r
+ and ymouse <= 15 and bouton_mouse=1) then\r
+ call outstring(160,3,"Quitter",12,8);\r
+ call groff;\r
+ call endrun;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end gestion_menu;\r
+\r
+ (* Menu principal *)\r
+ unit menu:procedure;\r
+ begin\r
+ call bouton(0,0,640,20,0,0,"",7,15,8,14);\r
+ call outstring(20,3,"Jeu",14,7);\r
+ call outstring(90,3,"Aide",14,7);\r
+ call outstring(160,3,"Quitter",14,7);\r
+ do\r
+ d:=getpress(v,p,h,l,r,c);\r
+ if c=1 then\r
+ call gestion_touches(v,p,c);\r
+ fi;\r
+ call gestion_menu(v,p,c);\r
+ od;\r
+ end menu;\r
+\r
+(*--------------------------------------------------------------------------*)\r
+(* PROGRAMME PRINCIPAL *)\r
+(*--------------------------------------------------------------------------*)\r
+ var user1:utilisateur1; (* Joueur contre strat\82gie1 *)\r
+ var user2:utilisateur2; (* Joueur contre strat\82gie2 *)\r
+ var user3:utilisateur3; (* Joueur1 contre joueur2 *)\r
+ var user4:utilisateur4; (* Joueur2 contre joueur1 *)\r
+\r
+ var S11:strategie1_user1; (* Strat\82gie1 contre joueur *)\r
+ var S12:strategie1_strat2; (* Strat\82gie1 contre strat\82gie2 *)\r
+\r
+ var S21:strategie2_user2; (* Strat\82gie2 contre joueur *)\r
+ var S22: strategie2_strat1; (* Strat\82gie2 contre strat\82gie1 *)\r
+\r
+ var v,p,h,l,r,c:integer; (* Variables utilis\82es pour la souris : *)\r
+ var d:boolean; (* v : position x du pointeur de la souris *)\r
+ (* p : position y du pointeur de la souris *)\r
+ (* c : bouton appuy\82 de la souris : *)\r
+ (* 1 : bouton gauche appuy\82 *)\r
+ (* 2 : bouton droit appuy\82 *)\r
+ (* 3 : boutons droit et gauche appuy\82s *)\r
+\r
+ var mat:mat_3d; (* Matrice 3d repr\82sentant le morpion 3d *)\r
+\r
+ var nb_coups:integer; (* Nombre de coups jou\82s pour une partie *)\r
+\r
+ var joue:boolean; (* indique si l'utilisateur a jou\82 *)\r
+\r
+ var joue1:boolean; (* servent \85 la strat\82gie2 pour savoir si elle a *)\r
+ var joue2:boolean; (* jou\82 son coup d'attaque *)\r
+\r
+ var efface : boolean; (* indique que l'image que contenait tab2 a \82t\82 *)\r
+ (* restitu\82e *)\r
+\r
+ var mode:integer; (* indique le mode de jeu choisi par l'utilisateur *)\r
+ var joueur:integer; (* indique pour le mode de jeu 4 (joueur1 contre *)\r
+ (* joueur2) si le joueur1 joue (joueur=1) ou le *)\r
+ (* joueur2 (joueur=2). De cette fa\87on, lorqu'on *)\r
+ (* reprend une partie sauvegard\82e sur fichier, *)\r
+ (* on sait si c'est \85 partir du joueur1 ou du *)\r
+ (* joueur2 que la partie a \82t\82 enregistr\82e. *)\r
+\r
+ begin\r
+ (* Cr\82ation et initialisation de la matrice 3d *)\r
+ mat := new mat_3d(3,3,3);\r
+ call init_mat(mat);\r
+\r
+ nb_coups:=0;\r
+\r
+ call gron(0);\r
+\r
+ call animation;\r
+\r
+ (* Affichage du fond *)\r
+ call bouton(0,22,640,480,100,100,"",3,11,8,10);\r
+ call bouton(3,25,637,477,100,100,"",3,11,8,10);\r
+\r
+ (* Affichage des boutons de visualisation du morpion 3d *)\r
+ call cadre_bouton(110,360,145,390);\r
+ call bouton(110,360,145,390,120,370,"/\",7,15,8,14);\r
+\r
+ call cadre_bouton(50,410,85,440);\r
+ call bouton(50,410,85,440,60,420,"<<",7,15,8,14);\r
+\r
+ call cadre_bouton(110,410,145,440);\r
+ call bouton(110,410,145,440,120,420,"\/",7,15,8,14);\r
+\r
+ call cadre_bouton(170,410,205,440);\r
+ call bouton(170,410,205,440,180,420,">>",7,15,8,14);\r
+\r
+ (* affichage des bordures de la matrice morpion 3d *)\r
+ call des_mat_3d(292,100,25,20,11);\r
+\r
+ (* Affichage du contenu de la matrice morpion 3d *)\r
+ call affic(25,20);\r
+\r
+ (* initialisation de la souris *)\r
+ call init(1,0);\r
+ call showcursor;\r
+ call getmovement(1,1);\r
+\r
+ call menu;\r
+\r
+ call groff;\r
+ end\r
+ end\r
+end.\r
+\r
--- /dev/null
+Program MORPS;\r
+(*\r
+ Û\ /Û /ÛÛÛ\ ÛÛÛÛ\ ÛÛÛÛ\ /ÛÛÛ\\r
+ ÛÛ-ÛÛ Û Û Û Û Û Û Û Û\r
+ Û Û Û Û Û Û Û Û Û Û\r
+ Û Û Û Û Û Û Û Û \ÛÛÛ\\r
+ Û Û Û Û ÛÛÛÛ( ÛÛÛÛ/ Û\r
+ Û Û Û Û Û Û Û Û Û\r
+ Û Û \ÛÛÛ/ Û Û Û \ÛÛÛ/\r
+ ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ\r
+ ± ± ±±± ± ± ± ±±±\r
+ ± ± ± ± ±±±± ±±±± ± ±\r
+ ± ± ± ± ± ± ± ± ± ±±±\r
+ ±± ±± ± ± ± ± ± ± ± ±\r
+ ± ± ±±± ±±±± ±±±± ±±±\r
+\r
+ Deuxi\8ame Projet Loglan\r
+\r
+ ڿ ڿ\r
+ ÀÅÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÙ\r
+ ³ ³\r
+ ³ Licence Info ³\r
+ ³ ³\r
+ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´\r
+ ³ ³\r
+ ³ Arnaud FABREGUETTE ³\r
+ ³ ³\r
+ ³ Jeff DELEAU ³\r
+ ³ ³\r
+ ÚÅÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅ¿\r
+ ÀÙ ÀÙ\r
+*)\r
+\r
+\r
+\r
+begin\r
+ pref iiuwgraph block\r
+\r
+begin\r
+ pref mouse block\r
+\r
+(************************************************************************)\r
+(* *)\r
+(* DECLARATION DES VARIABLES *)\r
+(* *)\r
+(************************************************************************)\r
+\r
+var\r
+ align, (* nombre de pions \85 aligner *)\r
+ coup, (* num\82ro du coup \85 jouer *)\r
+ debut_x,debut_y,fin_x,fin_y, (* coordonn\82es du damier *)\r
+ xjoue,yjoue, (* coordonn\82es de l'ordi *)\r
+ xjoue2,yjoue2, (* dernier pion jou\82 *)\r
+ xjoue3,yjoue3,\r
+ taille, (* taille du damier *)\r
+ player,commence : integer, (* num\82ro de joueur *)\r
+ NB_AIDES, (* nombre d'aides utilis\82es *)\r
+ NB_UNDOS, (* nombre de oops utilis\82s *)\r
+ JOUEUR, (* type de joueur (ordi,humain) *)\r
+ STRATEGIE, (* style de l'ordi (attaque,def) *)\r
+ INT, (* intelligence r\82gl\82e de l'ordi *)\r
+ CHOIX_PION : TABLEAUX, (* couleurs des pions *)\r
+ TAB_PION : TABDOUBLE, (* matrice de jeu *)\r
+ POSS : COUP_POSS, (* liste des possibilit\82s *)\r
+ COEFS : TABCOEF, (* coefficients *)\r
+ JEU : TABJEU, (* sauvegarde de tous les coups *)\r
+\r
+ j_qui_a_comm : INTEGER, (* num\82ro du joueur qui a commenc\82 *)\r
+ coef,coefsomm : INTEGER, (* coefficients des cases *)\r
+ sommposs,maxsommposs : INTEGER, (* possibilit\82s des cases *)\r
+ attaquant : INTEGER, (* num\82ro du joueur attaquant *)\r
+ nbcases : INTEGER, (* nombre de cases libres *)\r
+ megaliste : MEGA, (* listes de possibilit\82s *)\r
+ megaliste2 : MEGA2,\r
+ partie_terminee : BOOLEAN, (* vrai si la partie est finie *)\r
+ partie_gagnee : BOOLEAN, (* vrai si quelqu'un a gagn\82 *)\r
+ partie : INTEGER, (* nø de la partie en cours *)\r
+ nb_par_fin : INTEGER, (* nombre de parties finies *)\r
+ (* nombre de parties gagn\82es par joueur *)\r
+ nb_par_gagn : TABLEAUX,\r
+ (* nombre de parties perdues par joueur *)\r
+ nb_par_perd : TABLEAUX,\r
+ nb_mtch_nuls : INTEGER, (* nombre de matches nuls *)\r
+ nb_par_avort : INTEGER, (* nombre de parties non termin\82es *)\r
+ (* nombre de coups jou\82s par chacun des joueurs *)\r
+ coups_joues : TABLEAUX,\r
+\r
+\r
+\r
+ savescr : arrayof integer,\r
+ ch : char,\r
+ boolee : boolean,\r
+\r
+\r
+ MEMOIRE : arrayof arrayof POSIT, (* Strat\82gie de l'ordinateur *)\r
+ maxmem : integer, (* m\82moire de l'ordi *)\r
+ stratype,\r
+ strasave : integer,\r
+ marge : integer, (* marge utilis\82e *)\r
+\r
+ mousex,mousey,p,h,l,r,c : integer, (* gestion souris *)\r
+ reponse : boolean, (* gestion souris *)\r
+\r
+\r
+\r
+ (* declaration des coroutines *)\r
+ joueur1_hum : human_play,\r
+ joueur2_hum : human_play,\r
+ joueur1_cpu : cpu_play,\r
+ joueur2_cpu : cpu_play,\r
+ arb : ARBITRE;\r
+\r
+\r
+\r
+\r
+(************************************************************************)\r
+(* *)\r
+(* DECLARATION DES CLASSES *)\r
+(* *)\r
+(************************************************************************)\r
+\r
+unit TABLEAUX : class;\r
+var\r
+\r
+ TAB : arrayof INTEGER;\r
+ begin\r
+ array TAB dim (1:2);\r
+end TABLEAUX;\r
+\r
+\r
+unit TABDOUBLE : class;\r
+var\r
+ TAB : arrayof arrayof integer,\r
+ i : integer;\r
+begin\r
+ array TAB dim (0:13);\r
+ for i := 0 to 13 do\r
+ array TAB(i) dim (0:13);\r
+ od;\r
+end TABDOUBLE;\r
+\r
+\r
+unit POSIT : class;\r
+ var x,y : integer;\r
+end POSIT;\r
+\r
+\r
+unit COUP_POSS : class;\r
+ unit ENR_ELEMENTS : class;\r
+ var\r
+coef : integer, (* coefficient de la case = attaque + d\82fense*)\r
+attaque : integer, (* coefficient d'attaque *)\r
+defense : integer, (* coefficient de d\82fense *)\r
+att_reste1 : BOOLEAN, (* vrai si 1 pion pour terminer une ligne *)\r
+def_reste1 : BOOLEAN, (* idem mais pour l'adversaire *)\r
+att_reste2ouv : BOOLEAN, (* vrai si 2 pion pour une ligne ouverte*)\r
+def_reste2ouv : BOOLEAN, (* idem mais pour l'adversaire *)\r
+att_gagnante : BOOLEAN, (* vrai si la case est obligatoirement gagnante *)\r
+def_gagnante : BOOLEAN, (* idem pour l'adversaire *)\r
+att_gagnante_2 : BOOLEAN, (* vrai s'il est possible de gagner en 2 fois *)\r
+def_gagnante_2 : BOOLEAN, (* idem pour l'adversaire *)\r
+att_gagnante_3 : BOOLEAN, (* vrai s'il est possible de gagner en 3 fois *)\r
+att_gagnante_3o : BOOLEAN,\r
+def_gagnante_3 : BOOLEAN, (* idem pour l'adversaire *)\r
+def_gagnante_3o : BOOLEAN,\r
+attaquant : INTEGER, (* attaquant si le pion est mis sur cette case *)\r
+contre_attaque : BOOLEAN, (* vrai si la cases est un point fictif *)\r
+contre_defense : BOOLEAN, (* point fictif de l'adversaire *)\r
+contre_attaque2 : BOOLEAN, (* point fictif gagnant *)\r
+coefsomm : integer; (* somme des coeffs*)\r
+end ENR_ELEMENTS;\r
+var\r
+ TAB : arrayof arrayof ENR_ELEMENTS,\r
+ j : integer,\r
+ i : integer ;\r
+begin\r
+ array TAB DIM (1:12);\r
+ for i := 1 to 12 do\r
+ array TAB(i) DIM (1:12);\r
+ for j := 1 to 12 do\r
+ tab (i,j) := new ENR_ELEMENTS;\r
+ od;\r
+ Od;\r
+END COUP_POSS;\r
+\r
+\r
+unit TABCOEF : class;\r
+var\r
+\r
+ TAB : arrayof INTEGER;\r
+ begin\r
+ array TAB dim (0:12);\r
+end TABCOEF;\r
+\r
+\r
+unit MEGA : class;\r
+ unit ENR_ELEMENTS : class;\r
+ var\r
+ coef : INTEGER, (* coefficient de la case *)\r
+ coefsomm : INTEGER, (* somme des propri\82t\82s de la case *)\r
+ x : INTEGER, (* colonne de la case *)\r
+ y : INTEGER, (* ligne de la case *)\r
+ attaquant : INTEGER; (* nø du joueur attaquant *)\r
+ end ENR_ELEMENTS;\r
+\r
+var\r
+ TAB : arrayof ENR_ELEMENTS,\r
+ i : integer ;\r
+begin\r
+ array TAB DIM (1:12*12);\r
+ for i := 1 to 12*12 do\r
+ TAB(i) := new ENR_ELEMENTS;\r
+ od;\r
+END MEGA;\r
+\r
+\r
+\r
+unit MEGA2 : class ;\r
+ unit ENR_ELEMENTS : class;\r
+ unit ENR_EL : class ;\r
+ var\r
+ coef : INTEGER, (* coefficient de la case *)\r
+ coefsomm : INTEGER , (* somme des propri\82t\82s de la case *)\r
+ x : INTEGER, (* colonne de la case *)\r
+ y : INTEGER, (* ligne de la case *)\r
+ attaquant : INTEGER; (* nø du joueur attaquant *)\r
+ end ENR_EL\r
+ var\r
+ nb_elem : INTEGER, (* nombre d'\82l\82ments dans le sous tableau *)\r
+ t : ARRAYOF ENR_EL, (* tableau des cases *)\r
+ i : integer ;\r
+ begin\r
+ ARRAY t DIM (1:12*12);\r
+ for i := 1 to 12*12 do\r
+ t(i) := new ENR_EL;\r
+ od ;\r
+ end ENR_ELEMENTS;\r
+var\r
+ TAB : arrayof ENR_ELEMENTS,\r
+ i : integer;\r
+begin\r
+ array TAB dim (0:9);\r
+ for i := 0 to 9\r
+ do\r
+ TAB(i) := new ENR_ELEMENTS;\r
+ od\r
+end MEGA2;\r
+\r
+\r
+(* Trace du jeu (pour magn\82toscope) *)\r
+\r
+unit TABJEU : class;\r
+ unit ENR_EL : class;\r
+ VAR\r
+ a : INTEGER, (* nø du joueur attaquant lors de ce coup *)\r
+ p : INTEGER, (* nø du joueur qui joue *)\r
+ x : INTEGER, (* colonne du pion *)\r
+ y : INTEGER; (* ligne du pion *)\r
+ END ENR_EL;\r
+ VAR\r
+ fini : BOOLEAN, (* vrai si le jeu est fini *)\r
+ gagne : INTEGER, (* 0=pas de gagnant, autres=nø joueur *)\r
+ offset : INTEGER, (* compteur pour le magn\82toscope *)\r
+ maxi : INTEGER, (* idem *)\r
+ nbpions : INTEGER, (* idem *)\r
+ i : INTEGER,\r
+ coord : arrayof ENR_EL;\r
+ BEGIN\r
+ array coord dim (1:144);\r
+ for i:=1 to 144 do\r
+ coord(i) := new ENR_EL;\r
+ od;\r
+END TABJEU;\r
+\r
+\r
+\r
+(**************************************************************************)\r
+(* SOUS - PROGRAMMES *)\r
+(**************************************************************************)\r
+\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* INC *)\r
+(***---------------------------------------------------------------------***)\r
+(* Ajoute nbre2 \85 la variable nbre1 *)\r
+(***************************************************************************)\r
+\r
+unit INC : procedure (inout nbre1 : integer; nbre2 : integer);\r
+begin\r
+ nbre1 := nbre1 + nbre2;\r
+end INC;\r
+\r
+\r
+\r
+\r
+\r
+\r
+(**************************************************************************)\r
+(* PROCEDURES DE GRAPHISMES *)\r
+(**************************************************************************)\r
+\r
+(**************************************************************************)\r
+(* RECTANGLE_PLEIN *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affiche un rectangle de couleur coul et de contour contour *)\r
+(**************************************************************************)\r
+\r
+UNIT RECTANGLE_PLEIN : procedure(x_h,y_h,x_b,y_b,\r
+ coul,contour:integer);\r
+var\r
+ i : integer ;\r
+\r
+BEGIN\r
+ call color (coul);\r
+ for i:= y_h to y_b\r
+ do\r
+ call move (x_h,i);\r
+ call hfill (x_b);\r
+ od;\r
+ call color (contour);\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+ END RECTANGLE_PLEIN;\r
+\r
+\r
+(**************************************************************************)\r
+(* RECTANGLE *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affiche un rectangle *)\r
+(**************************************************************************)\r
+\r
+UNIT RECTANGLE: procedure(x_h,y_h,x_b,y_b:integer);\r
+BEGIN\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+END RECTANGLE;\r
+\r
+\r
+(***------------------------------------------------------------------***)\r
+(* CADRE *)\r
+(***------------------------------------------------------------------***)\r
+(* Affiche un cadre en relief aux coordonn\82es \82cran indiqu\82es *)\r
+(***------------------------------------------------------------------***)\r
+(* x1,x2,y1,y2 : coordonn\82es du cadre *)\r
+(* nb : largeur en pixels du cadre *)\r
+(* c1 : couleur des bords haut et gauche *)\r
+(* c2 : couleur des bords bas et droite *)\r
+(* c3 : couleur des coins *)\r
+(***------------------------------------------------------------------***)\r
+\r
+unit CADRE : procedure (x1,y1,x2,y2,nb,c1,c2,c3 : INTEGER);\r
+VAR\r
+ i : INTEGER;\r
+BEGIN\r
+ FOR i:=0 TO nb-1 DO\r
+ call color(c1);\r
+ call LINE (x1+i,y1,x1+i,y2-i);\r
+\r
+ call LINE (x1,y1+i,x2-i,y1+i);\r
+\r
+ call color (c2);\r
+ call LINE (x2-i,y2,x2-i,y1+i);\r
+\r
+ call LINE (x2,y2-i,x1+i,y2-i);\r
+ OD;\r
+ call color (c3);\r
+\r
+ call LINE (x1,y2,x1+nb-1,y2-nb+1);\r
+ call LINE (x2,y1,x2-nb+1,y1+nb-1);\r
+END CADRE;\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHER_CADRE *)\r
+(***************************************************************************)\r
+(* Affiche la rang\82e de boutons du nombre de pions et de la taille de la *)\r
+(* grille de jeu. *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHER_CADRE : procedure ;\r
+VAR\r
+ i : INTEGER;\r
+BEGIN\r
+ FOR i:=0 TO 11 DO\r
+ IF (i+1) = taille\r
+ THEN (* afficher le bouton actif avec des couleurs invers\82es *)\r
+ call cadre (168+i*24,135,168+i*24+22,155,2,8,15,8)\r
+ ELSE\r
+ call cadre (168+i*24,135,168+i*24+22,155,2,15,8,15);\r
+ fi;\r
+ IF (i+1) = align THEN\r
+ call cadre (168+i*24,130+50,168+i*24+22,150+50,2,8,15,8)\r
+ ELSE\r
+ call cadre (168+i*24,130+50,168+i*24+22,150+50,2,15,8,15);\r
+ fi;\r
+ OD;\r
+END AFFICHER_CADRE;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHER_TXT_OPT *)\r
+(***************************************************************************)\r
+(* Affiche les num\82ros sur les boutons du haut, et pose une ombre sur les *)\r
+(* boutons non disponibles. *)\r
+(***************************************************************************)\r
+\r
+unit AFF_TXT_OPTIONS : procedure;\r
+VAR\r
+ i : INTEGER;\r
+BEGIN\r
+ FOR i:=1 TO 12\r
+ DO\r
+ (* afficher les nombres *)\r
+ call track (172+(i-1)*24,139,i,7,8);\r
+ call track (172+(i-1)*24,154+30,i,7,8);\r
+ OD;\r
+END;\r
+\r
+(**************************************************************************)\r
+(* OPT_JEU *)\r
+(***--------------------------------------------------------------------***)\r
+(* Sous-programme de gestion des options de jeu *)\r
+(**************************************************************************)\r
+\r
+unit OPT_JEU : procedure ;\r
+ (*********************************************************************)\r
+ (* AFF_LISTE_PIONS *)\r
+ (***---------------------------------------------------------------***)\r
+ (* Affichage des pions de couleur \85 choisir *)\r
+ (*********************************************************************)\r
+ unit aff_liste_pions : procedure;\r
+ begin\r
+ for i := 0 to 5\r
+ do\r
+ if (i+1)= CHOIX_PION.TAB(1) then\r
+ call CASE_CHOIX_PION (168+i*43,227,8,15,1,i+1);\r
+ call COLOR (4);\r
+ call RECTANGLE (168+i*43-1,227-1,168+i*43+38+1,227+38+1);\r
+ else\r
+ call CASE_CHOIX_PION (168+i*43,227,8,15,1,i+1);\r
+ fi;\r
+ if (i+1) = CHOIX_PION.TAB(2) then\r
+ call CASE_CHOIX_PION (168+i*43,333,8,15,2,i+1);\r
+ call COLOR (4);\r
+ call RECTANGLE (168+i*43-1,333,168+i*43+38+1,333+38+1);\r
+ ELSE\r
+ call CASE_CHOIX_PION (168+i*43,333,8,15,2,i+1);\r
+ fi;\r
+ od;\r
+ end;\r
+var\r
+ A : arrayof integer,\r
+ ch : char,\r
+ anc_taille,i,j,anc_align,anc_choixpion1,anc_choixpion2 : INTEGER,\r
+ confirm,annuler,alerte : BOOLEAN;\r
+\r
+begin\r
+ confirm := false;\r
+ annuler := false;\r
+ anc_taille := taille; (* sauvegarder les anciennes donn\82es *)\r
+ anc_align := align;\r
+ anc_choixpion1 := choix_pion.tab(1);\r
+ anc_choixpion2 := choix_pion.tab(2);\r
+\r
+ array A dim (1:3050);\r
+ call move (160,80);\r
+ (* sauver l'ecran *)\r
+ a := GETMAP (479+15,359+24+42+20+15);\r
+ (* afficher le panneau des options *)\r
+ call RECTANGLE_PLEIN (160+4,80+4,479-4,359-4+24+42+20,7,7);\r
+ call cadre (160,80,479,359+24+42+20,4,15,8,15);\r
+ call cadre (168,421,300,437,1,15,8,15);\r
+ call TEXTE_GRAVE (200,423,"CONFIRMER",7,7);\r
+ call cadre (340,421,472,437,1,15,8,15);\r
+ call TEXTE_GRAVE (380,423,"ANNULER",7,7);\r
+ call cadre (160+8,80+8,479-8,80+24,1,15,8,15);\r
+ call OUTSTRING (270,90,"Options de Jeu",15,0);\r
+ call cadre (168,115,310,131,1,15,8,15);\r
+ call TEXTE_GRAVE (170,117,"Taille du damier",7,7);\r
+ call cadre (168,120+40,310,136+40,1,15,8,15);\r
+ call TEXTE_GRAVE (170,122+40,"Pions \85 aligner",7,7);\r
+ call cadre (168,206,300,222,1,15,8,15);\r
+ call TEXTE_GRAVE (170,208,"Pion Joueur 1",7,7);\r
+ call cadre (168,312,300,328,1,15,8,15);\r
+ call TEXTE_GRAVE (170,314,"Pion Joueur 2",7,7);\r
+ call AFFICHER_CADRE;\r
+ call AFF_TXT_OPTIONS;\r
+ call aff_liste_pions;\r
+do\r
+if OK then\r
+ call hidecursor;\r
+ IF mousein (mousex,mousey,168+48,135,456,155) then\r
+ taille := ENTIER((mousex-168)/24)+1;\r
+ IF taille<align THEN\r
+ align := taille;\r
+ FI;\r
+ call AFFICHER_CADRE;\r
+ FI;\r
+\r
+ IF mousein (mousex,mousey,168+48,180,456-24*2-1,200) THEN\r
+ align := ENTIER((mousex-168)/24)+1;\r
+ IF align > taille THEN\r
+ taille := align;\r
+ FI;\r
+ call AFFICHER_CADRE;\r
+ FI;\r
+ (* choix d'un pion pour le joueur nø1 *)\r
+ IF mousein (mousex,mousey,168,227,469,313) THEN\r
+ IF choix_pion.tab(1) < 7 THEN\r
+ call case_choix_pion (168+(choix_pion.tab(1)-1)*43,227,8,15,1,\r
+ choix_pion.tab(1));\r
+ call COLOR (7);\r
+ call RECTANGLE (168+(choix_pion.tab(1)-1)*43-1,227-1,\r
+ 168+(choix_pion.tab(1)-1)*43+38+1,227+38+1);\r
+ FI;\r
+ choix_pion.tab(1) := ENTIER((mousex-168)/43)+1;\r
+ if (choix_pion.tab(1)<>choix_pion.tab(2)) then\r
+ if mousey < 270 then\r
+ call case_choix_pion (168+(choix_pion.tab(1)-1)*43,\r
+ 227,8,15,1,choix_pion.tab(1));\r
+ call COLOR (6);\r
+ call RECTANGLE (168+(choix_pion.tab(1)-1)*43-1,\r
+ 227-1,168+(choix_pion.tab(1)-1)*43+38+1,227+38+1);\r
+ FI;\r
+ else\r
+ choix_pion.tab(1) :=anc_choixpion1;\r
+ call COLOR (4);\r
+ call RECTANGLE (168+(choix_pion.tab(1)-1)*43-1,227-1,\r
+ 168+(choix_pion.tab(1)-1)*43+38+1,227+38+1);\r
+ call showcursor;\r
+ alerte := x_alerte ("Ce pion est choisi par le joueur 2 ");\r
+ call aff_liste_pions;\r
+ FI;\r
+ FI;\r
+ (* choix d'un pion pour le joueur nø2 *)\r
+ IF mousein(mousex,mousey,168,333,469,419) THEN\r
+ IF choix_pion.tab(2) <= 7 THEN\r
+ call case_choix_pion (168+(choix_pion.tab(2)-1)*43,\r
+ 333,8,15,2,choix_pion.tab(2));\r
+ call COLOR (7);\r
+ call RECTANGLE (168+(choix_pion.tab(2)-1)*43-1,\r
+ 333-1,168+(choix_pion.tab(2)-1)*43+38+1,333+38+1);\r
+ FI;\r
+ choix_pion.tab(2) := ENTIER((mousex-168)/43)+1;\r
+ if (choix_pion.tab(2)<>choix_pion.tab(1)) then\r
+ IF mousey < 376 THEN\r
+ call case_choix_pion (168+(choix_pion.tab(2)-1)*43,\r
+ 333,8,15,2,choix_pion.tab(2));\r
+ call COLOR (4);\r
+ call RECTANGLE (168+(choix_pion.tab(2)-1)*43-1,\r
+ 333-1,168+(choix_pion.tab(2)-1)*43+38+1,333+38+1);\r
+ FI;\r
+ else\r
+ choix_pion.tab(2) := anc_choixpion2;\r
+ call COLOR (4);\r
+ call RECTANGLE (168+(choix_pion.tab(2)-1)*43-1,\r
+ 333-1,168+(choix_pion.tab(2)-1)*43+38+1,333+38+1);\r
+ call showcursor;\r
+ alerte := x_alerte ("Ce pion est choisi par le joueur 1 ");\r
+ call aff_liste_pions;\r
+ FI;\r
+ FI;\r
+\r
+\r
+ IF mousein(mousex,mousey,168,421,300,437) THEN\r
+ confirm := true;\r
+ exit;\r
+ FI;\r
+ IF mousein(mousex,mousey,340,421,472,437) THEN\r
+ annuler := true;\r
+ exit ;\r
+ FI;\r
+FI;\r
+call showcursor;\r
+od;\r
+ call move (160,80);\r
+ call PUTMAP (a);\r
+\r
+ IF annuler THEN (* si annulation *)\r
+ taille := anc_taille; (* restituer les anciennes donn\82es *)\r
+ align := anc_align;\r
+ choix_pion.tab(1) := anc_choixpion1;\r
+ choix_pion.tab(2) := anc_choixpion2;\r
+ else\r
+(* call AFF_GRILLES; *)\r
+ call AFF_INFOS_DEBUT;\r
+ call AFF_INFOS_PARTIES;\r
+ call AFF_TEXTE_FIN;\r
+ IF (taille <> anc_taille) OR (align <> anc_align) THEN\r
+ call RECTANGLE_PLEIN (0,0,474,479,9,9);\r
+ call cadre (0,0,638,479,3,15,8,15);\r
+ call RESETGAME;\r
+ call AFFICHE_DERNIER_COUP;\r
+ FI;\r
+ IF (choix_pion.tab(1) <> anc_choixpion1) OR\r
+ (choix_pion.tab(2) <> anc_choixpion2) THEN\r
+ FOR i:=1 TO taille DO\r
+ FOR j:=1 TO taille DO\r
+ IF tab_pion.tab(j,i)=1 THEN\r
+ call case_pleine(i,j,taille,1,choix_pion.tab(1));\r
+ ELSE\r
+ IF tab_pion.tab(j,i)=2 THEN\r
+ call case_pleine(i,j,taille,2,choix_pion.tab(2));\r
+ FI;\r
+ FI;\r
+ OD;\r
+ OD;\r
+ FI;\r
+ FI;\r
+ (* coordonn\82es de la nouvelle grille *)\r
+ debut_x := entier((12-taille)*(39/2))+4;\r
+ debut_y := entier((12-taille)*(39/2))+11;\r
+ fin_x := debut_x+(taille)*39-1;\r
+ fin_y := debut_y+(taille)*39-1;\r
+\r
+end OPT_JEU;\r
+\r
+(**************************************************************************)\r
+(* LINE *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage d'une ligne *)\r
+(**************************************************************************)\r
+\r
+unit LINE : procedure (x,y,xx,yy:integer);\r
+begin\r
+ call move (x,y);\r
+ call draw (xx,yy);\r
+end LINE;\r
+\r
+\r
+(**************************************************************************)\r
+(* EFFACE *)\r
+(***--------------------------------------------------------------------***)\r
+(* Effa\87age progressif de l'\82cran *)\r
+(**************************************************************************)\r
+\r
+unit EFFACE : procedure (x1,y1,x2,y2,c1,c2,c3 : integer);\r
+var\r
+ i,j,k : integer;\r
+begin\r
+ i := x2-x1;\r
+ j := y2-y1;\r
+ k := 0;\r
+ call color (c1);\r
+ while (k<=j) and (k<=i) do\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ i := i-1;\r
+ j := j-1;\r
+ k := k+1;\r
+\r
+ od;\r
+ call color (c2);\r
+ while (k>=0) do\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ call RECTANGLE (x1+k,y1+k,x2-k,y2-k);\r
+ i := i+1;\r
+ j := j+1;\r
+ k := k-1;\r
+ od;\r
+ call color (c3);\r
+ call RECTANGLE (x1,y1,x2,y2);\r
+end EFFACE;\r
+\r
+\r
+\r
+(**************************************************************************)\r
+(* PUTPIXEL *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affiche un point de couleur coul *)\r
+(**************************************************************************)\r
+\r
+unit PUTPIXEL : procedure (x,y,coul:integer);\r
+begin\r
+ call color (coul);\r
+ call point (x,y);\r
+end PUTPIXEL ;\r
+\r
+\r
+(***------------------------------------------------------------------***)\r
+(* AFF_CASE *)\r
+(***------------------------------------------------------------------***)\r
+(* Affiche une case dans la grille de jeu *)\r
+(***------------------------------------------------------------------***)\r
+(* col,lig : coordonn\82es de la case *)\r
+(* nb : taille de la grille (par ex. 10) *)\r
+(* coul1 : couleur de fond *)\r
+(* coul2 : autre couleur de fond si l'on d\82sire un tramage *)\r
+(***------------------------------------------------------------------***)\r
+\r
+unit AFF_CASE : procedure (col,lig,nb,coul1,coul2,p,num_pion : INTEGER);\r
+VAR\r
+ origine_x,origine_y : INTEGER,\r
+ xcase,ycase : INTEGER,\r
+ i,x1,y1,x2,y2 : INTEGER;\r
+BEGIN\r
+ origine_x := entier((12-nb)*(39/2))+4;\r
+ origine_y := entier((12-nb)*(39/2))+11;\r
+ xcase := origine_x+(col-1)*39;\r
+ ycase := origine_y+(lig-1)*39;\r
+ call RECTANGLE_PLEIN (xcase+1,ycase+1,xcase+37,ycase+37,coul1,coul1);\r
+ call color (15);\r
+ call LINE (xcase,ycase,xcase+37,ycase);\r
+ (* remplir les bords *)\r
+ call LINE (xcase,ycase,xcase,ycase+37);\r
+ call color (8);\r
+ call LINE (xcase+1,ycase+38,xcase+38,ycase+38);\r
+ call LINE (xcase+38,ycase+1,xcase+38,ycase+38);\r
+ call PUTPIXEL (xcase+38,ycase,7); (* mettre les coins *)\r
+ call PUTPIXEL (xcase,ycase+38,7);\r
+ IF coul1<>coul2 THEN (* si tramage voulu *)\r
+ x1 := xcase+1;\r
+ y1 := ycase+1;\r
+ x2 := xcase+37;\r
+ y2 := ycase+37;\r
+ call color (coul2);\r
+ i := x1;\r
+ WHILE i<=x2 DO\r
+ call LINE (i,y1,i,y2);\r
+ i:=i+2;\r
+ OD;\r
+ i := x1+1;\r
+ WHILE i<=x2 DO\r
+ call LINE (i,y1,i,y2);\r
+ (* afficher la trame *)\r
+ i:=i+2;\r
+ OD;\r
+ fi;\r
+ call AFF_PION (xcase,ycase,p,num_pion);\r
+END AFF_CASE;\r
+\r
+\r
+(**************************************************************************)\r
+(* AFF_PION *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affiche un pion sur le damier *)\r
+(**************************************************************************)\r
+\r
+unit AFF_PION : procedure (x,y,p,num_pion:integer);\r
+begin\r
+ case num_pion\r
+\r
+ when 1:\r
+ call CIRB (x+27,y+27,8,8,0,180000,1,1);\r
+ call CIRB (x+26,y+26,7,7,0,180000,9,1);\r
+ when 2:\r
+ call CIRB (x+27,y+27,8,8,0,180000,2,1);\r
+ call CIRB (x+26,y+26,7,7,0,180000,10,1);\r
+ when 3:\r
+ call CIRB (x+27,y+27,8,8,0,180000,3,1);\r
+ call CIRB (x+26,y+26,7,7,0,180000,11,1);\r
+ when 4:\r
+ call CIRB (x+27,y+27,8,8,0,180000,4,1);\r
+ call CIRB (x+26,y+26,7,7,0,180000,12,1);\r
+ when 5:\r
+ call CIRB (x+27,y+27,8,8,0,180000,15,1);\r
+ call CIRB (x+26,y+26,7,7,0,180000,14,1);\r
+ when 6:\r
+ call CIRB (x+27,y+27,8,8,0,180000,5,1);\r
+ call CIRB (x+26,y+26,7,7,0,180000,13,1);\r
+ esac;\r
+end AFF_PION;\r
+\r
+(***------------------------------------------------------------------***)\r
+(* CASE_PLEINE *)\r
+(***------------------------------------------------------------------***)\r
+(* Affiche une case et un pion dans la grille de jeu *)\r
+(***------------------------------------------------------------------***)\r
+(* col,lig : coordonn\82es de la case *)\r
+(* nb : taille de la grille (par ex. 10) *)\r
+(* p : num\82ro du joueur *)\r
+(* num : num\82ro du pion du joueur *)\r
+(***------------------------------------------------------------------***)\r
+unit CASE_PLEINE : procedure (col,lig,nb,p,num_pion : INTEGER);\r
+VAR\r
+ origine_x,origine_y : INTEGER,\r
+ xcase,ycase : INTEGER;\r
+BEGIN\r
+ origine_x := entier((12-nb)*(39/2))+4; (*calcul des coordonn\82es *)\r
+ origine_y := entier((12-nb)*(39/2))+11;\r
+ xcase := origine_x+(col-1)*39;\r
+ ycase := origine_y+(lig-1)*39;\r
+(* call aff_case (col,lig,nb,8,15,p,num_pion);*)\r
+ (* afficher le pion *)\r
+ call AFF_PION (xcase,ycase,p,num_pion);\r
+END CASE_PLEINE;\r
+\r
+(***------------------------------------------------------------------***)\r
+(* CASE_CHOIX_PION *)\r
+(***------------------------------------------------------------------***)\r
+(* Affiche un pion aux coordonn\82es \82cran indiqu\82es *)\r
+(* couleurs des bords sont invers\82es. *)\r
+(***------------------------------------------------------------------***)\r
+(* xp,yp : coordonn\82es \82cran du pion *)\r
+(* c1,c2 : couleurs du bord du pion *)\r
+(* p : num\82ro du joueur *)\r
+(* num : choix du pion du joueur *)\r
+(***------------------------------------------------------------------***)\r
+unit CASE_CHOIX_PION : procedure (xp,yp,c1,c2,p,num_pion : INTEGER);\r
+VAR\r
+ xcase,ycase : INTEGER;\r
+BEGIN\r
+ xcase := xp;\r
+ ycase := yp;\r
+ call COLOR (c1);\r
+ call LINE (xcase,ycase,xcase+37,ycase);\r
+ call LINE (xcase,ycase,xcase,ycase+37);\r
+ call COLOR (c2);\r
+ call LINE (xcase+1,ycase+38,xcase+38,ycase+38);\r
+ call LINE (xcase+38,ycase+1,xcase+38,ycase+38);\r
+ call PUTPIXEL (xcase+38,ycase,7);\r
+ call PUTPIXEL (xcase,ycase+38,7);\r
+ call AFF_PION (xcase,ycase,p,num_pion);\r
+END;\r
+\r
+(***------------------------------------------------------------------***)\r
+(* TEXTE_GRAVE *)\r
+(***------------------------------------------------------------------***)\r
+(* Affiche un texte en relief *)\r
+(***------------------------------------------------------------------***)\r
+(* xt,yt : coordonn\82es du texte *)\r
+(* txt : chaine de caract\8ares *)\r
+(* col1 : couleur de fond *)\r
+(* col2 : couleur du texte *)\r
+(***------------------------------------------------------------------***)\r
+unit TEXTE_GRAVE : procedure (xt,yt : INTEGER ; txt : STRING;\r
+ col1,col2 : INTEGER);\r
+BEGIN\r
+ call OUTSTRING (xt,yt,txt,8,col1);\r
+ call OUTSTRING (xt-1,yt-1,txt,8,col2);\r
+END TEXTE_GRAVE;\r
+\r
+\r
+(**************************************************************************)\r
+(* AFF_INFOS_PARTIES *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affiche les informations de la partie en cours *)\r
+(**************************************************************************)\r
+\r
+unit AFF_INFOS_PARTIES : procedure;\r
+BEGIN\r
+ call track (498+7*8,390,partie,7,8);\r
+ call track (498+7*8-8,410,coup,7,8);\r
+ call track (498+8*8,430,NB_AIDES.TAB(player),7,8);\r
+ call track (498+7*8,450,NB_UNDOS.TAB(player),7,8);\r
+ (* affiche dernier coup *)\r
+ call AFFICHE_DERNIER_COUP;\r
+END AFF_INFOS_PARTIES;\r
+\r
+\r
+(**************************************************************************)\r
+(* AFF_TEXTE_FIN *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage du panneau d'informations de la partie, avec les infos *)\r
+(**************************************************************************)\r
+\r
+unit AFF_TEXTE_FIN : procedure;\r
+BEGIN\r
+ call cadre (483,388,627,404,1,8,15,8);\r
+ call cadre (483,408,627,424,1,8,15,8);\r
+ call cadre (483,428,627,444,1,8,15,8);\r
+ call cadre (483,448,627,464,1,8,15,8);\r
+ call TEXTE_GRAVE (488,390,"Partie ",7,7);\r
+ call TEXTE_GRAVE (488,410,"Coup nø ",7,7);\r
+ call TEXTE_GRAVE (488,430,"Aides : ",7,7);\r
+ call TEXTE_GRAVE (488,450,"Oops : ",7,7);\r
+ call aff_infos_parties;\r
+ call AFFICHE_DERNIER_COUP;\r
+END AFF_TEXTE_FIN;\r
+\r
+(**************************************************************************)\r
+(* AFF_INFOS_DEBUT *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage des informations en d\82but de partie *)\r
+(**************************************************************************)\r
+unit AFF_INFOS_DEBUT : procedure;\r
+BEGIN\r
+ call RECTANGLE_PLEIN (479,336,631,471,7,7);\r
+ call RECTANGLE_PLEIN (475,324,635,335,7,7);\r
+ call cadre (475,332,635,475,4,8,15,8);\r
+ call cadre (483,340,627,384,1,8,15,8);\r
+ call CASE_CHOIX_PION (585,343,8,15,player,CHOIX_PION.TAB(player));\r
+ call TEXTE_GRAVE (490,345,"Au tour ",7,7); (* texte statique *)\r
+ call TEXTE_GRAVE (490,357,"du joueur ",7,7);\r
+ call TRACK (572,357,player,7,8);\r
+ IF JOUEUR.TAB(player)=1 THEN call TEXTE_GRAVE (490,370,"Humain ",7,7)\r
+ ELSE\r
+ call TEXTE_GRAVE (490,369,"CPU ",7,7);\r
+ fi;\r
+ call aff_texte_fin;\r
+END AFF_INFOS_DEBUT;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_INFOS *)\r
+(***************************************************************************)\r
+(* Affichage du panneau d'informations en cours de partie. Pas d'affichage *)\r
+(* de texte statique. *)\r
+(***************************************************************************)\r
+\r
+unit affiche_infos : procedure;\r
+BEGIN\r
+\r
+ call case_choix_pion (585,343,15,8,player,choix_pion.tab(player));\r
+ call rectangle_plein (490+9*8+6,354,490+10*8+6,364,7,7);\r
+ call track (490+10*8,357,player,7,8);\r
+ call rectangle_plein (490-1,366+3,490+6*8,376+3,7,7);\r
+ IF joueur.tab(player)=1 THEN\r
+ call outstring (490,369,"Humain",8,7)\r
+ ELSE\r
+ call outstring (490,369,"CPU",8,7);\r
+ FI;\r
+\r
+ call aff_infos_parties;\r
+\r
+END;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_GAGNANT *)\r
+(***************************************************************************)\r
+(* Affichage du panneau d'informations en fin de partie dans le cas d'une *)\r
+(* partie gagn\82e par l'un des joueurs. *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_GAGNANT : procedure;\r
+\r
+BEGIN\r
+ coup := coup - 1 ;\r
+ call RECTANGLE_PLEIN (479,336,631,471,7,7);\r
+ call cadre (475,332,635,475,4,8,15,15);\r
+ call cadre (483,340,627,384,1,8,15,15);\r
+ call CASE_CHOIX_PION (585,343,15,8,3-player,CHOIX_PION.TAB(3-player));\r
+ call TEXTE_GRAVE (490,345,"GAGNANT :",7,7);\r
+ call TEXTE_GRAVE (490,357,"joueur",7,7);\r
+ call TRACK (538,357,3-player,7,8);\r
+ IF joueur.TAB(3-player)=1 THEN call TEXTE_GRAVE (490,370,"(Humain)",7,7);\r
+ ELSE call TEXTE_GRAVE (490,370,"(CPU)",7,7);\r
+ FI;\r
+ call AFF_TEXTE_FIN;\r
+ coup := coup + 1;\r
+END AFFICHE_GAGNANT;\r
+\r
+\r
+(**************************************************************************)\r
+(* AFFICHE_MATCHNUL *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage du panneau d'informations en fin de partie en cas de match *)\r
+(* nul. *)\r
+(**************************************************************************)\r
+\r
+unit AFFICHE_MATCHNUL : procedure;\r
+\r
+BEGIN\r
+ coup := coup - 1 ;\r
+ call RECTANGLE_PLEIN (479,336,631,471,7,7);\r
+ call cadre (475,332,635,475,4,8,15,15);\r
+ call cadre (483,340,627,384,1,8,15,15);\r
+ call CASE_CHOIX_PION (585,343,15,8,3-player,CHOIX_PION.TAB(3-player));\r
+ call TEXTE_GRAVE (490,345,"MATCH NUL",7,7);\r
+\r
+ call TEXTE_GRAVE (490,357,"joueur",7,7);\r
+ call TRACK (538,357,3-player,7,8);\r
+ IF joueur.TAB(3-player)=1 THEN call TEXTE_GRAVE (490,370,"(Humain)",7,7);\r
+ ELSE call TEXTE_GRAVE (490,370,"(CPU)",7,7);\r
+ FI;\r
+\r
+ call AFF_TEXTE_FIN;\r
+ coup := coup + 1;\r
+END AFFICHE_MATCHNUL;\r
+\r
+(**************************************************************************)\r
+(* AFFICHE_DERNIER_COUP *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage des informations en cours de partie *)\r
+(**************************************************************************)\r
+\r
+unit AFFICHE_DERNIER_COUP : procedure;\r
+VAR\r
+ xjeff : integer,\r
+ ch : char;\r
+BEGIN\r
+ IF coup<>1 THEN\r
+ call RECTANGLE_PLEIN (488+9*8+6,410,488+16*8+10,420,7,7);\r
+ call TEXTE_GRAVE (570,410,"(",7,7);\r
+ xjeff := 578;\r
+ if (xjoue2 div 10) <> 0\r
+ then\r
+ call track (xjeff,410,xjoue2 div 10,7,8);\r
+ xjeff := xjeff + 8;\r
+ fi;\r
+ call track (xjeff,410,xjoue2 mod 10,7,8);\r
+ xjeff := xjeff + 8;\r
+ call TEXTE_GRAVE (xjeff,410,",",7,7);\r
+ xjeff := xjeff + 8;\r
+ if (yjoue2 div 10) <> 0\r
+ then\r
+ call track (xjeff,410,yjoue2 div 10,7,8);\r
+ xjeff := xjeff + 8;\r
+ fi;\r
+ call track (xjeff,410,yjoue2 mod 10,7,8);\r
+ xjeff := xjeff + 8;\r
+ call TEXTE_GRAVE (xjeff,410,")",7,7);\r
+ fi;\r
+END AFFICHE_DERNIER_COUP;\r
+\r
+\r
+(**************************************************************************)\r
+(* CONFIRMER *)\r
+(**************************************************************************)\r
+(* Ouvre une bo\8cte, affiche un texte dans la bo\8cte, et demande *)\r
+(* confirmation. La fonction renvoie un bool\82en VRAI en cas de *)\r
+(* confirmation. *)\r
+(**************************************************************************)\r
+\r
+unit CONFIRMER : function (texte : string ):boolean ;\r
+VAR\r
+ i,j : INTEGER,\r
+ A : arrayof integer,\r
+ ch : char,\r
+ conf,ann : BOOLEAN;\r
+BEGIN\r
+ array A dim (0:1000);\r
+ (* sauver l'image de fond *)\r
+ call move (139,200);\r
+ a:= GETMAP (499+20,279+20);\r
+ (* affichage de la bo\8cte *)\r
+ call RECTANGLE_PLEIN (139+2,200+2,499-2,279-2,7,7);\r
+ call cadre (139,200,499,279,3,15,8,15);\r
+ call cadre (149,230,314,270,3,15,8,15);\r
+ call cadre (324,230,489,270,3,15,8,15);\r
+ call cadre (139+8,200+8,499-8,200+8+19,1,15,8,15);\r
+ (* affichage du texte *)\r
+ call OUTSTRING (183,213,texte,8,7);\r
+ call OUTSTRING (183-1,213-1,texte,8,7);\r
+ call OUTSTRING (195,247,"Confirmer",8,7);\r
+ call OUTSTRING (385,247,"Annuler",8,7);\r
+ call OUTSTRING (195-1,247-1,"Confirmer",8,7);\r
+ call OUTSTRING (385-1,247-1,"Annuler",8,7);\r
+do\r
+ if ok then\r
+ IF mousein (mousex,mousey,149,230,314,270) then\r
+ call hidecursor;\r
+ result := true;\r
+ exit ;\r
+ fi;\r
+ if mousein (mousex,mousey,324,230,489,270) THEN\r
+ call hidecursor;\r
+ result := false;\r
+ exit ;\r
+ fi;\r
+ call showcursor;\r
+ fi;\r
+od;\r
+\r
+ call move (139,200);\r
+ call PUTMAP (a);\r
+ kill (A);\r
+END CONFIRMER;\r
+\r
+\r
+(**************************************************************************)\r
+(* X_ALERTE *)\r
+(**************************************************************************)\r
+(* Ouvre une bo\8cte, affiche un texte dans la bo\8cte, et demande *)\r
+(* confirmation. La fonction renvoie toujours un bool\82en VRAI *)\r
+(**************************************************************************)\r
+\r
+unit X_ALERTE : function (texte : string ):boolean ;\r
+VAR\r
+ i,j : INTEGER,\r
+ A : arrayof integer,\r
+ ch : char,\r
+ conf,ann : BOOLEAN;\r
+BEGIN\r
+ array A dim (0:1000);\r
+ (* sauver l'image de fond *)\r
+ call move (139,200);\r
+ a:= GETMAP (499+20,279+20);\r
+ (* affichage de la bo\8cte *)\r
+ call RECTANGLE_PLEIN (139+2,200+2,499-2,279-2,7,7);\r
+ call cadre (139,200,499,279,3,15,8,15);\r
+ call cadre (149,230,489,270,3,15,8,15);\r
+ call cadre (139+8,200+8,499-8,200+8+19,1,15,8,15);\r
+ (* affichage du texte *)\r
+ call OUTSTRING (183,213,texte,8,7);\r
+ call OUTSTRING (183-1,213-1,texte,8,7);\r
+ call OUTSTRING (295,247,"OK",8,7);\r
+ call OUTSTRING (295-1,247-1,"OK",8,7);\r
+do\r
+ if ok then\r
+ IF mousein (mousex,mousey,149,230,489,270) then\r
+ call hidecursor;\r
+ result := true;\r
+ exit ;\r
+ fi;\r
+ call showcursor;\r
+ fi;\r
+od;\r
+\r
+ call move (139,200);\r
+ call PUTMAP (a);\r
+END X_ALERTE;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFF_ICONES *)\r
+(***---------------------------------------------------------------------***)\r
+(* Affiche les ic\93nes \85 cliquer \85 droite de l'\82cran *)\r
+(***************************************************************************)\r
+\r
+unit AFF_ICONES : procedure;\r
+var\r
+ i : integer;\r
+begin\r
+ for i := 0 to 4\r
+ do\r
+ call RECTANGLE_PLEIN (484,12+64*i,547,60+64*i,8,8);\r
+ call RECTANGLE_PLEIN (564,12+64*i,627,60+64*i,8,8);\r
+ call cadre (484,12+64*i,547,60+64*i,3,15,7,15);\r
+ call cadre (564,12+64*i,627,60+64*i,3,15,7,15);\r
+ od;\r
+ call outstring (503,29,"NEW",15,8);\r
+ call outstring (496,93,"STATS",15,8);\r
+ call outstring (488,157,"OPTIONS",15,8);\r
+ call outstring (499,221,"AIDE",15,8);\r
+ call outstring (492,285,"REGLES",15,8);\r
+ call outstring (576,29,"OOPS!",15,8);\r
+ call outstring (573,93,"NIVEAU",15,8);\r
+ call outstring (568,157,"JOUEURS",15,8);\r
+ call outstring (568,221,"MAGNETO",15,8);\r
+ call outstring (568,285,"QUITTER",15,8);\r
+end AFF_ICONES;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* PRESENTATION *)\r
+(***---------------------------------------------------------------------***)\r
+(* Ecran de pr\82sentation du jeu *)\r
+(***************************************************************************)\r
+\r
+unit PRESENTATION : procedure ;\r
+\r
+var\r
+x,y,sauve_y,i : integer;\r
+begin\r
+\r
+ call outstring (100,460,\r
+ "MORPS par DELEAU JEAN-FRANCOIS & FABREGUETTE ARNAUD ",7,0);\r
+ call RECTANGLE_PLEIN (60,80,580,12*12+120,7,7);\r
+ call cadre (60,80,580,12*12+120,5,8,15,15);\r
+ for y:=0 to 10 do\r
+ for x:=0 to 38 do\r
+ if inpix(100+x,460+y) <> 0 then\r
+ call RECTANGLE_PLEIN (x*12+80,y*12+100,x*12+80+11,\r
+ y*12+100+11,9,9);\r
+ call cadre (x*12+80,y*12+100,x*12+80+11,y*12+100+11,3,15,\r
+ 1,15);\r
+ fi;\r
+ od;\r
+ od;\r
+ call showcursor;\r
+ DO\r
+ if ok then\r
+ call hidecursor;\r
+ exit;\r
+ fi;\r
+ call showcursor;\r
+ OD;\r
+\r
+end PRESENTATION;\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFF_GRILLES *)\r
+(***---------------------------------------------------------------------***)\r
+(* Affichage d'un nouveau damier vide *)\r
+(***************************************************************************)\r
+\r
+unit AFF_GRILLES : procedure;\r
+var\r
+ i,j : integer;\r
+begin\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ call AFF_CASE (i,j,taille,7,7,0,0);\r
+ od;\r
+ od;\r
+end AFF_GRILLES;\r
+\r
+unit AFF_GRAPH : procedure;\r
+begin\r
+ call RECTANGLE_PLEIN (0,0,474,479,9,9);\r
+ call cadre (639-64-80-16-4,328+4,639-4,479-4,4,8,15,8);\r
+ call cadre (639-64-80-16-4,0+4,639-4,319+4,4,8,15,8);\r
+ call cadre (0,0,638,479,3,15,8,15);\r
+ call AFF_ICONES;\r
+end AFF_GRAPH;\r
+\r
+\r
+(**************************************************************************)\r
+(* REGLES *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage de la r\8agle du jeu *)\r
+(**************************************************************************)\r
+\r
+unit REGLES : procedure;\r
+\r
+var\r
+ a : arrayof integer;\r
+begin\r
+\r
+ array A dim (1:3050);\r
+ call move (160,80);\r
+ (* sauver l'ecran *)\r
+ a := GETMAP (479+15,359+24+42+20+15);\r
+ (* afficher le panneau des options *)\r
+\r
+ call RECTANGLE_PLEIN (160+4,80+4,479-4,359-4+24+42+20,7,7);\r
+ call cadre (160,80,479,359+24+42+20,4,15,8,15);\r
+ call cadre (268,421,400,437,1,15,8,15);\r
+ call cadre (160+8,80+8,479-8,80+24,1,15,8,15);\r
+ call OUTSTRING (274,90,"REGLES du Jeu",15,0);\r
+ call outstring (175,130,"Vous devez aligner un certain nombre ",8,7);\r
+ call outstring (175,160,"de pions d'une m\88me couleur.",8,7);\r
+ call outstring (175,190,"Pour cela il suffit de cliquer",8,7);\r
+ call outstring (175,220,"sur les cases de votre choix.",8,7);\r
+ call outstring (175,250,"Le premier qui aligne le nombre de",8,7);\r
+ call outstring (175,280,"pions param\82tr\82 remporte la partie...",8,7);\r
+ call outstring (230,332,"GOOD LUCK !",8,7);\r
+ call outstring (325,422,"OK",8,7);\r
+ DO\r
+ if ok then\r
+ call hidecursor;\r
+ if mousein (mousex,mousey,268,421,400,437) then\r
+ exit;\r
+ fi;\r
+ fi;\r
+ call showcursor;\r
+ OD;\r
+ call move (160,80);\r
+ call PUTMAP (a);\r
+end REGLES;\r
+\r
+\r
+(**************************************************************************)\r
+(* STATS *)\r
+(***--------------------------------------------------------------------***)\r
+(* Affichage des statistiques de jeu *)\r
+(**************************************************************************)\r
+\r
+unit STATS : procedure;\r
+\r
+var\r
+ a : arrayof integer;\r
+begin\r
+\r
+ array A dim (1:3050);\r
+ call move (160,80);\r
+ (* sauver l'ecran *)\r
+ a := GETMAP (479+15,359+24+42+20+15);\r
+ (* afficher le panneau des options *)\r
+\r
+ call RECTANGLE_PLEIN (160+4,80+4,479-4,359-4+24+42+20,7,7);\r
+ call cadre (160,80,479,359+24+42+20,4,15,8,15);\r
+ call cadre (268,421,400,437,1,15,8,15);\r
+ call cadre (160+8,80+8,479-8,80+24,1,15,8,15);\r
+ call OUTSTRING (274,90,"STATISTIQUES",15,0);\r
+ call outstring (325,422,"OK",8,7);\r
+ call outstring (170,120,"Parties gagn\82es par le joueur 1 :",8,7);\r
+ call outstring (170,140,"Parties perdues par le joueur 1 :",8,7);\r
+ call outstring (170,180,"Parties gagn\82es par le joueur 2 :",8,7);\r
+ call outstring (170,200,"Parties perdues par le joueur 2 :",8,7);\r
+ call outstring (170,240,"Nombre de matches nuls :",8,7);\r
+ call outstring (170,260,"Nombre de parties avort\82es :",8,7);\r
+ call track (450,120,nb_par_gagn.tab(1),7,8);\r
+ call track (450,140,nb_par_perd.tab(1),7,8);\r
+ call track (450,180,nb_par_gagn.tab(2),7,8);\r
+ call track (450,200,nb_par_perd.tab(2),7,8);\r
+ call track (450,240,nb_mtch_nuls,7,8);\r
+ call track (450,260,nb_par_avort,7,8);\r
+\r
+ DO\r
+ if ok then\r
+ call hidecursor;\r
+ if mousein (mousex,mousey,268,421,400,437) then\r
+ exit;\r
+ fi;\r
+ fi;\r
+ call showcursor;\r
+ OD;\r
+ call move (160,80);\r
+ call PUTMAP (a);\r
+end STATS;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*************************************************************************)\r
+(* *)\r
+(* Fonction MAGNETOSCOPE du MORPS. *)\r
+(* *)\r
+(*************************************************************************)\r
+\r
+\r
+(*************************************************************************)\r
+(* TRIANGLE *)\r
+(*************************************************************************)\r
+(* Trace un triangle aux coordonn\82es sp\82cifi\82es. La taille, la couleur, *)\r
+(* et le pas d'incr\82mentation (triangle orient\82 et + ou - allong\82) sont *)\r
+(* pass\82s en param\8atre. *)\r
+(*************************************************************************)\r
+\r
+unit TRIANGLE : procedure (x,y,pas,tailletri,col : INTEGER);\r
+VAR\r
+ i : INTEGER;\r
+BEGIN\r
+ call COLOR (col);\r
+ FOR i:=0 TO tailletri\r
+ DO\r
+ call LINE (x+(tailletri-i)*pas,y+i+tailletri,x,y+i+tailletri);\r
+ call LINE (x+(tailletri-i)*pas,y-i+tailletri,x,y-i+tailletri);\r
+ OD;\r
+END TRIANGLE;\r
+\r
+\r
+(*************************************************************************)\r
+(* BARRE *)\r
+(*************************************************************************)\r
+(* Trace une barre verticale aux coordonn\82es sp\82cifi\82es. La hauteur et *)\r
+(* la couleur de la barre sont pass\82es en param\8atre. *)\r
+(*************************************************************************)\r
+unit BARRE : procedure (x,y,taillebarre,col : INTEGER);\r
+BEGIN\r
+ call RECTANGLE_PLEIN(x,y,x+3,y+taillebarre*2,col,col);\r
+END BARRE;\r
+\r
+\r
+(*************************************************************************)\r
+(* EJECTION_STOP *)\r
+(*************************************************************************)\r
+(* Trace le bouton STOP/EJECT du magn\82toscope. *)\r
+(*************************************************************************)\r
+\r
+unit EJECTION_STOP : procedure (x,y,col : INTEGER);\r
+VAR\r
+ i : INTEGER;\r
+BEGIN\r
+ call COLOR (col);\r
+ FOR i:=0 TO 15\r
+ DO\r
+ call LINE (x-15+i,y-i,x+15-i,y-i);\r
+ OD;\r
+ call RECTANGLE_PLEIN (x-15,y-23,x+15,y-20,col,col);\r
+ call RECTANGLE_PLEIN (x+59,y-22,x+79,y-2,col,col);\r
+END EJECTION_STOP;\r
+\r
+\r
+(*************************************************************************)\r
+(* TRACE_MAGNETO *)\r
+(*************************************************************************)\r
+(* Dessine le panneau de fonctions du magn\82toscope. *)\r
+(*************************************************************************)\r
+unit TRACE_MAGNETO : procedure;\r
+CONST\r
+ ecart = 2; (* taille des bordures des boutons du magn\82toscope *)\r
+VAR\r
+ i,j,x,y : INTEGER;\r
+BEGIN\r
+ call RECTANGLE_PLEIN (479,8,631,319,7,7);\r
+ call cadre (ecart+489,ecart+18,621-ecart,68-ecart,4,15,8,15);\r
+ call cadre (ecart+489,ecart+74,489+63-ecart,124-ecart,4,15,8,15);\r
+ call cadre (ecart+621-63,ecart+74,621-ecart,124-ecart,4,15,8,15);\r
+ call cadre (ecart+489,ecart+130,489+63-ecart,180-ecart,4,15,8,15);\r
+ call cadre (ecart+621-63,ecart+130,621-ecart,180-ecart,4,15,8,15);\r
+ call cadre (ecart+489,ecart+195,621-ecart,245-ecart,4,15,8,15);\r
+ call cadre (ecart+489,ecart+260,489+63-ecart,310-ecart,4,15,8,15);\r
+ call cadre (ecart+621-63,ecart+260,621-ecart,310-ecart,4,15,8,15);\r
+\r
+ call cadre (489,18,621,68,1,15,8,15);\r
+ call cadre (489,74,489+63,124,1,15,8,15);\r
+ call cadre (621-63,74,621,124,1,15,8,15);\r
+ call cadre (489,130,489+63,180,1,15,8,15);\r
+ call cadre (621-63,130,621,180,1,15,8,15);\r
+ call cadre (489,195,621,245,1,15,8,15);\r
+ call cadre (489,260,489+63,310,1,15,8,15);\r
+ call cadre (621-63,260,621,310,1,15,8,15);\r
+\r
+ call triangle (530,28,2,15,15);\r
+ call barre (570,28,15,15);\r
+ call barre (580,28,15,15);\r
+ call triangle (535,87,-2,12,15);\r
+ call barre (505,87,12,15);\r
+ call triangle (575,87,2,12,15);\r
+ call barre (602,87,12,15);\r
+ call triangle (540,142,-2,12,15);\r
+ call triangle (527,142,-2,12,15);\r
+ call barre (498,142,12,15);\r
+ call triangle (570,142,2,12,15);\r
+ call triangle (583,142,2,12,15);\r
+ call barre (609,142,12,15);\r
+\r
+ call triangle (530-1,28-1,2,15,8);\r
+ call barre (570-1,28-1,15,8);\r
+ call barre (580-1,28-1,15,8);\r
+\r
+ call triangle (535-1,87-1,-2,12,8);\r
+ call barre (505-1,87-1,12,8);\r
+\r
+ call triangle (575-1,87-1,2,12,8);\r
+ call barre (602-1,87-1,12,8);\r
+\r
+ call triangle (540-1,142-1,-2,12,8);\r
+ call triangle (527-1,142-1,-2,12,8);\r
+ call barre (498-1,142-1,12,8);\r
+\r
+ call triangle (570-1,142-1,2,12,8);\r
+ call triangle (583-1,142-1,2,12,8);\r
+ call barre (609-1,142-1,12,8);\r
+\r
+ call ejection_stop (520,297,15);\r
+ call ejection_stop (519,296,8);\r
+ call TEXTE_GRAVE (510,218,"MAGNETOSCOPE",7,7);\r
+END TRACE_MAGNETO;\r
+\r
+\r
+(**************************************************************************)\r
+(* MAGNETOSCOPE *)\r
+(***--------------------------------------------------------------------***)\r
+(* Sous-programme de gestion du magn\82toscope. *)\r
+(**************************************************************************)\r
+\r
+unit magnetoscope : procedure;\r
+VAR\r
+ i,j,x,y : INTEGER,\r
+ ecart : integer,\r
+ eject,stopx : BOOLEAN,\r
+ tab2,tab3 : ARRAYOF ARRAYOF INTEGER,\r
+ ic1,ic2 : REAL,\r
+ rm1,rm2 : INTEGER,\r
+ maxic : REAL,\r
+ maxrm : INTEGER,\r
+ cj1,cj2 : INTEGER,\r
+ pl : INTEGER,\r
+ cp : INTEGER,\r
+ pg,pt,jf: BOOLEAN,\r
+ jg : INTEGER,\r
+ at : INTEGER,\r
+ compteur : INTEGER,\r
+ play : BOOLEAN,\r
+ a : arrayof integer;\r
+BEGIN\r
+ ecart := 2;\r
+ array a dim (1:10000);\r
+ call hidecursor; (* cacher la souris *)\r
+ call move (479,8);\r
+ a := getmap (631,319); (* sauvegarder le fond *)\r
+\r
+ call trace_magneto; (* afficher le panneau de fonctions *)\r
+\r
+ jeu.maxi := jeu.offset; (* se positionner en fin de partie *)\r
+\r
+ (* on travaille avec de nouvelles variables...*)\r
+ (* pour ne pas effacer les anciennes *)\r
+\r
+ array tab2 dim (0:13);\r
+ for i:=0 to 13 do\r
+ array tab2(i) dim (0:13);\r
+ for j:=0 to 13 do\r
+ tab2(i,j) := tab_pion.tab(i,j);\r
+ od;\r
+ od;\r
+\r
+ cj1 := coups_joues.tab(1);\r
+ cj2 := coups_joues.tab(2);\r
+ pl := player;\r
+ cp := coup;\r
+ pt := partie_terminee;\r
+ pg := partie_gagnee;\r
+ jf := jeu.fini;\r
+ jg := jeu.gagne;\r
+ at := attaquant;\r
+\r
+ call showcursor; (* montrer la souris *)\r
+\r
+ eject := FALSE; (* param\8atres du magn\82toscope *)\r
+ stopx := FALSE;\r
+ play := FALSE;\r
+ compteur := 0;\r
+\r
+ DO (* boucle principale *)\r
+ IF play THEN (* lecture *)\r
+ call INC (compteur,1);\r
+ FI;\r
+ (* on avance chaque fois qu'un compteur arrive \85 200 *)\r
+ IF (compteur = 200) AND (jeu.offset>=jeu.maxi) THEN\r
+ compteur := 0;\r
+ play := FALSE; (* fin de bande : on arr\88te *)\r
+ call hidecursor;\r
+ call cadre (ecart+489,ecart+18,621-ecart,68-ecart,4,15,8,15);\r
+ call showcursor;\r
+ ELSE\r
+ IF (compteur = 200) AND (jeu.offset<jeu.maxi) THEN\r
+ compteur := 0; (* pas \85 la fin : on continue \85 jouer *)\r
+ (*step IN*)\r
+ xjoue2 := jeu.coord(jeu.offset).x;\r
+ yjoue2 := jeu.coord(jeu.offset).y;\r
+ call hidecursor; (* afficher le nouveau pion *)\r
+ call case_pleine (jeu.coord(jeu.offset).x,\r
+ jeu.coord(jeu.offset).y,\r
+ taille,player,choix_pion.tab(player));\r
+ call showcursor;\r
+ tab_pion.tab (jeu.coord(jeu.offset).y,\r
+ jeu.coord(jeu.offset).x) := player;\r
+ attaquant := jeu.coord(jeu.offset).a;\r
+ call INC (coups_joues.tab(player),1);\r
+ player := 3-player; (* joueur suivant *)\r
+ call INC (jeu.offset,1);\r
+ call INC (coup,1);\r
+ (* si fin de bande *)\r
+ IF (jeu.offset=jeu.maxi) AND (jf) THEN\r
+ IF jg<>0 THEN (* si il y a un gagnant *)\r
+ (* afficher le gagnant dans le panneau d'informations *)\r
+ call affiche_gagnant;\r
+ call detecter_ligne;\r
+ ELSE\r
+ (* sinon afficher le match nul *)\r
+ call affiche_matchnul;\r
+ FI;\r
+ jeu.fini := jf;\r
+ partie_terminee := pt;\r
+ partie_gagnee := pg;\r
+ jeu.gagne :=jg;\r
+ ELSE\r
+ (* si pas fin de bande on affiche un nouveau panneau d'info *)\r
+ call affiche_infos;\r
+ FI;\r
+ FI;\r
+ FI;\r
+\r
+ call showcursor;\r
+ if ok then\r
+ (* si clic souris *)\r
+ IF mousein (mousex,mousey,489,18,621,68) THEN\r
+ (* lecture / pause *)\r
+ play := NOT play; (* passer \85 l'\82tat inverse *)\r
+ call hidecursor;\r
+ IF NOT play THEN\r
+ call cadre (ecart+489,ecart+18,621-ecart,68-ecart,4,15,8,15);\r
+ ELSE\r
+ call cadre (ecart+489,ecart+18,621-ecart,68-ecart,4,8,15,8);\r
+ FI;\r
+ call showcursor;\r
+\r
+ ELSE\r
+ IF mousein (mousex,mousey,489,74,489+63,124) AND\r
+ (jeu.offset>1) THEN\r
+ (* retour *)\r
+ (*step OUT*)\r
+\r
+ if jeu.offset>=3 then\r
+ xjoue2 := jeu.coord(jeu.offset-2).x;\r
+ yjoue2 := jeu.coord(jeu.offset-2).y;\r
+ fi;\r
+ call hidecursor; (* vider la derni\8are case *)\r
+\r
+ call aff_case (jeu.coord(jeu.offset-1).x,\r
+ jeu.coord(jeu.offset-1).y,\r
+ taille,7,7,0,0);\r
+ call showcursor;\r
+ tab_pion.tab (jeu.coord(jeu.offset-1).y,\r
+ jeu.coord(jeu.offset-1).x) := 0;\r
+ if jeu.offset>=3 then\r
+ attaquant := jeu.coord(jeu.offset-2).a;\r
+ fi;\r
+ (* mettre \85 jour les stats *)\r
+ call inc (coups_joues.tab(3-player),-1);\r
+ player := 3-player;\r
+\r
+ call inc (jeu.offset,-1); (* on passe au coup pr\82c\82dent *)\r
+ call inc (coup,-1);\r
+\r
+\r
+ (* tester si fin de partie *)\r
+\r
+ IF (jeu.offset=jeu.maxi-1) AND (jeu.fini) THEN\r
+ call hidecursor;\r
+ IF jeu.gagne<>0 THEN\r
+\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ IF tab_pion.tab(j,i)=jeu.gagne THEN\r
+\r
+ (* call case_pleine(i,j,taille,jeu.gagne,\r
+ choix_pion.tab(jeu.gagne));*)\r
+ call aff_case(i,j,taille,7,7,jeu.gagne,\r
+ choix_pion.tab(jeu.gagne));\r
+ FI;\r
+ OD;\r
+ OD;\r
+ FI;\r
+ call showcursor;\r
+ jeu.fini := FALSE;\r
+ jeu.gagne := 0;\r
+ partie_gagnee := FALSE;\r
+ partie_terminee := FALSE;\r
+ call aff_infos_debut;\r
+ ELSE\r
+ call affiche_infos;\r
+ FI;\r
+ ELSE\r
+ IF mousein (mousex,mousey,621-63,74,621,124) AND\r
+ (jeu.offset<jeu.maxi) THEN\r
+ (* avance *)\r
+ (*step IN*)\r
+ xjoue2 := jeu.coord(jeu.offset).x;\r
+ yjoue2 := jeu.coord(jeu.offset).y;\r
+ call hidecursor; (* afficher le nouveau pion *)\r
+ call case_pleine (jeu.coord(jeu.offset).x,\r
+ jeu.coord(jeu.offset).y,\r
+ taille,player,choix_pion.tab(player));\r
+ call showcursor;\r
+ tab_pion.tab (jeu.coord(jeu.offset).y,\r
+ jeu.coord(jeu.offset).x) := player;\r
+ (* mettre \85 jour les stats *)\r
+ attaquant := jeu.coord(jeu.offset).a;\r
+ (* passer au coup et joueur suivant *)\r
+ call INC (coups_joues.tab(player),1);\r
+ player := 3-player;\r
+ call INC (jeu.offset,1);\r
+ call INC (coup,1);\r
+ (* tester si fin de partie *)\r
+ IF (jeu.offset=jeu.maxi) AND (jf) THEN\r
+ IF jg<>0 THEN\r
+ call affiche_gagnant;\r
+ call detecter_ligne;\r
+ ELSE\r
+ call affiche_matchnul;\r
+ FI;\r
+ jeu.fini := jf;\r
+ partie_terminee := pt;\r
+ partie_gagnee := pg;\r
+ jeu.gagne :=jg;\r
+ ELSE\r
+ call affiche_infos;\r
+ FI;\r
+ ELSE\r
+ IF mousein (mousex,mousey,489,130,489+63,180) THEN\r
+ (* retour rapide *)\r
+ (*start*)\r
+ call hidecursor;\r
+ FOR j:=1 TO taille DO (* vider la grille *)\r
+ FOR i:=1 TO taille DO\r
+ call aff_case (i,j,taille,7,7,0,0);\r
+ tab_pion.tab (j,i) := 0;\r
+ OD;\r
+ OD;\r
+ call showcursor;\r
+ player := j_qui_a_comm; (* remise \85 0 des donn\82es *)\r
+ attaquant := player;\r
+ coups_joues.tab(1) := 0;\r
+ coups_joues.tab(2) := 0;\r
+ coup := 1; (* positionnement sur le 1er coup *)\r
+ jeu.offset := 1;\r
+ partie_terminee := FALSE;\r
+ partie_gagnee := FALSE;\r
+ jeu.gagne := 0;\r
+ jeu.fini := FALSE;\r
+ call aff_infos_debut;\r
+ ELSE\r
+ IF mousein (mousex,mousey,621-63,130,621,180) THEN\r
+ (* avance rapide *)\r
+ (*finish*)\r
+ call hidecursor;\r
+ FOR j:=1 TO taille DO (* remplir tout le tableau *)\r
+ FOR i:=1 TO taille DO\r
+ IF tab2(j,i)<>0 THEN\r
+ call case_pleine (i,j,taille,tab2(j,i),\r
+ choix_pion.tab(tab2(j,i)));\r
+ FI;\r
+ OD;\r
+ OD;\r
+ call showcursor;\r
+ jeu.offset := jeu.maxi; (* se positionner en fin de partie *)\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ tab_pion.tab(i,j) := tab2(i,j);\r
+ OD;\r
+ OD;\r
+\r
+ coups_joues.tab(1) := cj1;\r
+ coups_joues.tab(2) := cj2;\r
+ player := pl;\r
+ coup := cp;\r
+ partie_terminee := pt;\r
+ partie_gagnee := pg;\r
+ jeu.fini := jf;\r
+ jeu.gagne := jg;\r
+ attaquant := at;\r
+ IF jeu.fini THEN\r
+ IF jeu.gagne=0 THEN\r
+ call affiche_matchnul;\r
+ ELSE\r
+ call affiche_gagnant;\r
+ call detecter_ligne;\r
+ FI;\r
+ ELSE\r
+ call affiche_infos;\r
+ FI;\r
+ ELSE\r
+ IF mousein (mousex,mousey,489,260,489+63,310) THEN\r
+ (* eject *)\r
+ call hidecursor;\r
+ (* restitution de toutes les donn\82es de la partie *)\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ IF tab2(j,i)<>0 THEN\r
+ call case_pleine (i,j,taille,tab2(j,i),\r
+ choix_pion.tab(tab2(j,i)));\r
+ FI;\r
+ OD;\r
+ OD;\r
+ call showcursor;\r
+ jeu.offset := jeu.maxi; (* se positionner en fin de partie *)\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ tab_pion.tab(i,j) := tab2(i,j);\r
+ OD;\r
+ OD;\r
+\r
+ coups_joues.tab(1) := cj1;\r
+ coups_joues.tab(2) := cj2;\r
+ player := pl;\r
+ coup := cp;\r
+ partie_terminee := pt;\r
+ partie_gagnee := pg;\r
+ jeu.fini := jf;\r
+ jeu.gagne := jg;\r
+ attaquant := at;\r
+ xjoue2 := jeu.coord(jeu.maxi-1).x;\r
+ yjoue2 := jeu.coord(jeu.maxi-1).y;\r
+ IF jeu.fini THEN\r
+ IF jeu.gagne=0 THEN\r
+ call affiche_matchnul;\r
+ ELSE\r
+ call affiche_gagnant;\r
+ call detecter_ligne;\r
+ FI;\r
+ FI;\r
+ eject := TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+\r
+ FI;\r
+ if eject OR stopx then exit; fi; (* quitter si EJECT ou STOP *)\r
+ od;\r
+ call hidecursor;\r
+ call move (479,8);\r
+ call putmap (a); (* restituer le fond *)\r
+ call showcursor;\r
+ call aff_icones; (* afficher toutes les ic\93nes *)\r
+END magnetoscope;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* Modification des caract\82ristiques des 2 *)\r
+(* joueurs. *)\r
+(* *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_COMMENCE *)\r
+(***************************************************************************)\r
+(* Affiche quel est le joueur qui doit commencer (1,2,ou RANDOM). *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_COMMENCE : procedure;\r
+\r
+BEGIN\r
+ (* afficher les cadres diff\82remment selon les cas *)\r
+ case commence\r
+ when 1:\r
+ call cadre (280,309,350,326,2,8,15,15);\r
+ call cadre (280,329,350,346,2,15,8,15);\r
+ call cadre (280,349,350,366,2,15,8,15);\r
+ when 2:\r
+ call cadre (280,309,350,326,2,15,8,15);\r
+ call cadre (280,329,350,346,2,15,8,15);\r
+ call cadre (280,349,350,366,2,8,15,15);\r
+ when 3:\r
+ call cadre (280,309,350,326,2,15,8,15);\r
+ call cadre (280,329,350,346,2,8,15,15);\r
+ call cadre (280,349,350,366,2,15,8,15);\r
+ ESAC;\r
+ call OUTSTRING (313,311,"1",8,7);\r
+ call OUTSTRING (293,331,"RANDOM",8,7);\r
+ call OUTSTRING (313,351,"2",8,7);\r
+ END AFFICHE_COMMENCE;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_STRATEGIE2 *)\r
+(***************************************************************************)\r
+(* Affiche quelle est la strat\82gie du joueur 2. (ATTAQUE,NORMAL,DEFENSE) *)\r
+(***************************************************************************)\r
+unit AFFICHE_STRATEGIE2 : procedure;\r
+BEGIN\r
+ case STRATEGIE.TAB(2)\r
+ when 1:\r
+ call cadre (270-3,180+100,320+3,196+100,2,8,15,15);\r
+ call cadre (330-3,180+100,380+3,196+100,2,15,8,15);\r
+ call cadre (390-3,180+100,440+3,196+100,2,15,8,15);\r
+ when 2:\r
+ call cadre (270-3,180+100,320+3,196+100,2,15,8,15);\r
+ call cadre (330-3,180+100,380+3,196+100,2,8,15,15);\r
+ call cadre (390-3,180+100,440+3,196+100,2,15,8,15);\r
+ when 3:\r
+ call cadre (270-3,180+100,320+3,196+100,2,15,8,15);\r
+ call cadre (330-3,180+100,380+3,196+100,2,15,8,15);\r
+ call cadre (390-3,180+100,440+3,196+100,2,8,15,15);\r
+ ESAC;\r
+END AFFICHE_STRATEGIE2;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_INT2 *)\r
+(***************************************************************************)\r
+(* Affiche quel est le niveau d'intelligence du joueur 2. *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_INT2 : procedure;\r
+BEGIN\r
+ call RECTANGLE_PLEIN (270,151+100,270+int.TAB(2),165+100,4,4);\r
+ IF INT.TAB(2)<>100 THEN\r
+ call RECTANGLE_PLEIN (270+int.TAB(2)+1,151+100,370,165+100,14,14);\r
+ fi;\r
+ call RECTANGLE_PLEIN (394,151+100,421,165+100,7,7);\r
+ call track (396,152+100,int.TAB(2),7,0);\r
+END AFFICHE_INT2;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_STRATEGIE1 *)\r
+(***************************************************************************)\r
+(* Affiche quelle est la strat\82gie du joueur 1. (ATTAQUE,NORMAL,DEFENSE) *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_STRATEGIE1 : procedure;\r
+BEGIN\r
+ CASE strategie.TAB(1)\r
+ when 1:\r
+ call cadre (270-3,180,320+3,196,2,8,15,15);\r
+ call cadre (330-3,180,380+3,196,2,15,8,15);\r
+ call cadre (390-3,180,440+3,196,2,15,8,15);\r
+ when 2:\r
+ call cadre (270-3,180,320+3,196,2,15,8,15);\r
+ call cadre (330-3,180,380+3,196,2,8,15,15);\r
+ call cadre (390-3,180,440+3,196,2,15,8,15);\r
+ when 3:\r
+ call cadre (270-3,180,320+3,196,2,15,8,15);\r
+ call cadre (330-3,180,380+3,196,2,15,8,15);\r
+ call cadre (390-3,180,440+3,196,2,8,15,15);\r
+ ESAC;\r
+END AFFICHE_STRATEGIE1;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_INT1 *)\r
+(***************************************************************************)\r
+(* Affiche quel est le niveau d'intelligence du joueur 1. *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_INT1 : procedure;\r
+BEGIN\r
+ call RECTANGLE_PLEIN (270,151,270+int.tab(1),165,4,4);\r
+ IF int.TAB(1)<>100 THEN\r
+ call RECTANGLE_PLEIN (270+int.tab(1)+1,151,370,165,14,14);\r
+ fi;\r
+ call RECTANGLE_PLEIN (394,151,421,165,7,7);\r
+ call track (396,152,int.TAB(1),7,0);\r
+END AFFICHE_INT1;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_JOUEUR1 *)\r
+(***************************************************************************)\r
+(* Affiche quel est le TYPE du joueur 1 (humain ou CPU). *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_JOUEUR1 : procedure;\r
+BEGIN\r
+ IF joueur.TAB(1) = 1 THEN\r
+ call cadre (260,120,350,136,2,8,15,15);\r
+ call cadre (360,120,450,136,2,15,8,15);\r
+ ELSE\r
+ call cadre (260,120,350,136,2,15,8,15);\r
+ call cadre (360,120,450,136,2,8,15,15);\r
+ fi;\r
+END AFFICHE_JOUEUR1;\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_JOUEUR2 *)\r
+(***************************************************************************)\r
+(* Affiche quel est le TYPE du joueur 2 (humain ou CPU). *)\r
+(***************************************************************************)\r
+unit AFFICHE_JOUEUR2 : procedure;\r
+BEGIN\r
+ if JOUEUR.TAB(2) = 1 THEN\r
+ call cadre (260,120+100,350,136+100,2,8,15,15);\r
+ call cadre (360,120+100,450,136+100,2,15,8,15);\r
+ ELSE\r
+ call cadre (260,120+100,350,136+100,2,15,8,15);\r
+ call cadre (360,120+100,450,136+100,2,8,15,15);\r
+ fi;\r
+END AFFICHE_JOUEUR2;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_OPT_JOUEUR *)\r
+(***************************************************************************)\r
+(* Affiche toutes les caract\82ristiques des joueurs. *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_OPT_JOUEURS : procedure;\r
+\r
+BEGIN\r
+ call cadre (160+8,80+8,479-8,80+24,1,8,15,15);\r
+ call OUTSTRING (210,90,"Caract\82ristiques des joueurs",15,0);\r
+ (* joueur 1 *)\r
+ call cadre (160+8,120,240,136,1,8,15,15);\r
+ call TEXTE_GRAVE (172,122,"Joueur 1",7,7);\r
+ call TEXTE_GRAVE (282,122,"Humain",7,7);\r
+ call TEXTE_GRAVE (395,122,"CPU",7,7);\r
+ call OUTSTRING (170,152+100,"INTELLIGENCE",15,7);\r
+ call OUTSTRING (170,152,"INTELLIGENCE",15,7);\r
+ call OUTSTRING (200,182,"STYLE",15,7);\r
+ call OUTSTRING (200,282,"STYLE",15,7);\r
+\r
+\r
+ call AFFICHE_JOUEUR1;\r
+\r
+ call cadre (167,145,450,200,3,8,15,15); (* ici *)\r
+ call cadre (269,150,371,166,1,8,15,15);\r
+ call AFFICHE_INT1;\r
+\r
+ call cadre (375,150,391,166,1,15,8,15);\r
+ call TEXTE_GRAVE (380,152,"-",7,7);\r
+\r
+ call cadre (393,150,422,166,1,8,15,15);\r
+\r
+ call cadre (424,150,440,166,1,15,8,15);\r
+ call TEXTE_GRAVE (429,152,"+",7,7);\r
+\r
+ call TEXTE_GRAVE (285,182,"Att",7,7);\r
+ call TEXTE_GRAVE (333,182,"Normal",7,7);\r
+ call TEXTE_GRAVE (405,182,"Def",7,7);\r
+ call AFFICHE_STRATEGIE1;\r
+ (* joueur 2 *)\r
+ call cadre (160+8,120+100,240,136+100,1,8,15,15);\r
+ call TEXTE_GRAVE (172,122+100,"Joueur 2",7,7);\r
+ call TEXTE_GRAVE (282,122+100,"Humain",7,7);\r
+ call TEXTE_GRAVE (395,122+100,"CPU",7,7);\r
+ call AFFICHE_JOUEUR2;\r
+\r
+ call cadre (167,145+100,450,200+100,3,8,15,15); (* ici *)\r
+ call cadre (269,150+100,371,166+100,1,8,15,15);\r
+ call AFFICHE_INT2;\r
+\r
+ call cadre (375,150+100,391,166+100,1,15,8,15);\r
+ call TEXTE_GRAVE (380,152+100,"-",7,7);\r
+\r
+ call cadre (393,150+100,422,166+100,1,8,15,15);\r
+\r
+ call cadre (424,150+100,440,166+100,1,15,8,15);\r
+ call TEXTE_GRAVE (429,152+100,"+",7,7);\r
+\r
+ call TEXTE_GRAVE(285,182+100,"Att",7,7);\r
+ call TEXTE_GRAVE(333,182+100,"Normal",7,7);\r
+ call TEXTE_GRAVE(405,182+100,"Def",7,7);\r
+ call AFFICHE_STRATEGIE2;\r
+ (* nø du joueur qui commence *)\r
+ call AFFICHE_COMMENCE;\r
+END AFFICHE_OPT_JOUEURS;\r
+\r
+(***************************************************************************)\r
+(* JOUEURS *)\r
+(***---------------------------------------------------------------------***)\r
+(* Modification des caract\82ristiques des 2 *)\r
+(* joueurs. *)\r
+(***************************************************************************)\r
+\r
+unit JOUEURS : procedure ;\r
+VAR\r
+ okay,annuler,joueur_change : BOOLEAN,\r
+ a : arrayof integer,\r
+ s_com,s_int1,s_int2,\r
+ s_strategie1,s_strategie2,s_joueur1,s_joueur2 : INTEGER;\r
+BEGIN\r
+ (* sauver le fond de l'image *)\r
+\r
+ array A dim (1:3050);\r
+ call move (160,80);\r
+\r
+ (* sauver l'ecran *)\r
+\r
+ a := GETMAP (479+15,359+24+42+20+15);\r
+\r
+ (* sauver les caract\82ristiques en cas d'annulation *)\r
+ s_com := commence;\r
+ s_joueur1 := joueur.TAB(1);\r
+ s_joueur2 := joueur.TAB(2);\r
+ s_strategie1 := strategie.TAB(1);\r
+ s_strategie2 := strategie.TAB(2);\r
+ s_int1 := int.TAB(1);\r
+ s_int2 := int.TAB(2);\r
+ (* affichage du panneau *)\r
+ call RECTANGLE_PLEIN (160+4,80+4,479-4,309-4+24+42+20,7,7);\r
+ call cadre (160,80,479,309+24+42+20,4,15,8,15);\r
+ call cadre (168,421-50,300,437-50,1,15,8,15);\r
+ call TEXTE_GRAVE (200,423-50,"CONFIRMER",7,7);\r
+\r
+ call cadre (340,421-50,472,437-50,1,15,8,15);\r
+ call TEXTE_GRAVE (380,423-50,"ANNULER",7,7);\r
+\r
+ call cadre (160+8,80+8,479-8,80+24,1,8,15,15);\r
+ call OUTSTRING (210,90,"Caract\82ristiques des joueurs",15,0);\r
+ (* afficher toutes les caract\82ristiques *)\r
+ call AFFICHE_OPT_JOUEURS;\r
+ (* gestion de la souris *)\r
+ annuler := false;\r
+\r
+ okay := FALSE;\r
+ annuler := FALSE;\r
+ joueur_change := false;\r
+ DO\r
+ IF ok THEN\r
+ call hidecursor;\r
+ IF mousein (mousex,mousey,260,120,350,136) THEN\r
+ (* TYPE du joueur 1 = humain *)\r
+ IF joueur.tab(1)<>1 THEN\r
+ joueur.tab(1) := 1;\r
+ call affiche_joueur1;\r
+ joueur_change := true;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,360,120,450,136) THEN\r
+ (* TYPE du joueur 1 = CPU *)\r
+ IF joueur.tab(1)<>2 THEN\r
+ joueur.tab(1) := 2;\r
+ joueur_change := true;\r
+ call affiche_joueur1;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,375,150,391,166) THEN\r
+ (* - d'intelligence pour le joueur 1 *)\r
+ IF int.tab(1)>1 THEN\r
+ call inc (int.tab(1),-1);\r
+ call affiche_int1;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,424,150,440,166) THEN\r
+ (* + d'intelligence pour le joueur 1 *)\r
+ IF int.tab(1)<100 THEN\r
+ call INC (int.tab(1),1);\r
+ call affiche_int1;\r
+ FI;\r
+ FI;\r
+ (* r\82glage de l'intelligence \85 la souris *)\r
+ IF mousein (mousex,mousey,271,150,370,166) THEN\r
+ int.tab(1) := mousex-270;\r
+ call affiche_int1;\r
+ FI;\r
+\r
+ (* strat\82gie du joueur 1 = ATTAQUE *)\r
+ IF mousein (mousex,mousey,267,180,323,196) THEN\r
+ IF strategie.tab(1) <> 1 THEN\r
+ strategie.tab(1) := 1;\r
+ call affiche_strategie1;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,327,180,373,196) THEN\r
+ (* strat\82gie du joueur 1 = NORMAL *)\r
+ IF strategie.tab(1) <> 2 THEN\r
+ strategie.tab(1) := 2;\r
+ call affiche_strategie1;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,387,180,443,196) THEN\r
+ (* strat\82gie du joueur 2 = DEFENSE *)\r
+ IF strategie.tab(1) <> 3 THEN\r
+ strategie.tab(1) := 3;\r
+ call affiche_strategie1;\r
+ FI;\r
+ FI;\r
+\r
+ IF mousein (mousex,mousey,260,120+100,350,136+100) THEN\r
+ (* TYPE du joueur 2 = humain *)\r
+ IF joueur.tab(2)<>1 THEN\r
+ joueur.tab(2) := 1;\r
+ joueur_change := true;\r
+ call affiche_joueur2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,360,120+100,450,136+100) THEN\r
+ (* TYPE du joueur 2 = CPU *)\r
+ IF joueur.tab(2)<>2 THEN\r
+ joueur.tab(2) := 2;\r
+ joueur_change := true;\r
+ call affiche_joueur2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,375,150+100,391,166+100) THEN\r
+ (* - d'intelligence pour le jouer 2 *)\r
+ IF int.tab(2)>1 THEN\r
+ call inc (int.tab(2),-1);\r
+ call affiche_int2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,424,150+100,440,166+100) THEN\r
+ (* + d'intelligence pour le joueur 2 *)\r
+ IF int.tab(2)<100 THEN\r
+ call INC (int.tab(2),1);\r
+ call affiche_int2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,271,150+100,370,166+100) THEN\r
+ (* intelligence r\82gl\82e \85 la souris *)\r
+ int.tab(2) := mousex-270;\r
+ call affiche_int2;\r
+ FI;\r
+\r
+ IF mousein (mousex,mousey,267,180+100,323,196+100) THEN\r
+ (* strat\82gie du joueur 2 = ATTAQUE *)\r
+ IF strategie.tab(2) <> 1 THEN\r
+ strategie.tab(2) := 1;\r
+ call affiche_strategie2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,327,180+100,373,196+100) THEN\r
+ (* strat\82gie du joueur 2 = NORMAL *)\r
+ IF strategie.tab(2) <> 2 THEN\r
+ strategie.tab(2) := 2;\r
+ call affiche_strategie2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,387,180+100,443,196+100) THEN\r
+ (* strat\82gie du joueur 2 = DEFENSE *)\r
+ IF strategie.tab(2) <> 3 THEN\r
+ strategie.tab(2) := 3;\r
+ call affiche_strategie2;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,280,310,350,326) THEN\r
+ (* joueur 1 commence *)\r
+ IF commence<>1 THEN\r
+ commence := 1;\r
+ call affiche_commence;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,280,330,350,346) THEN\r
+ (* joueur al\82atoire commence *)\r
+ IF commence<>3 THEN\r
+ commence := 3;\r
+ call affiche_commence;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,280,350,350,366) THEN\r
+ (* joueur 2 commence *)\r
+ IF commence<>2 THEN\r
+ commence := 2;\r
+ call affiche_commence;\r
+ FI;\r
+ FI;\r
+ IF mousein(mousex,mousey,168,421-50,300,437-50) THEN\r
+ okay := TRUE;\r
+ exit;\r
+ FI;\r
+ IF mousein(mousex,mousey,340,421-50,472,437-50) THEN\r
+ annuler := TRUE;\r
+ exit;\r
+ FI;\r
+ FI;\r
+ call showcursor;\r
+ OD;\r
+\r
+ call move (160,80);\r
+ call putmap (a);\r
+\r
+ (* si annulation, restituer les anciennes caract\82ristiques *)\r
+ IF annuler THEN\r
+ commence := s_com;\r
+ joueur.TAB(1) := s_joueur1;\r
+ joueur.TAB(2) := s_joueur2;\r
+ strategie.TAB(1) := s_strategie1;\r
+ strategie.TAB(2) := s_strategie2;\r
+ int.TAB(1) := s_int1;\r
+ int.TAB(2) := s_int2;\r
+ ELSE\r
+\r
+ call resetgame;\r
+ call aff_infos_debut;\r
+ if joueur_change then\r
+ call resetgame_joueur;\r
+ fi;\r
+\r
+ fi;\r
+END JOUEURS;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_MARGE *)\r
+(***************************************************************************)\r
+(* Affiche la marge de calcul en cas de strategie rapide. *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_MARGE : procedure;\r
+BEGIN\r
+ CASE marge\r
+ when 1:\r
+ call cadre (270-3,180,320+3,196,2,8,15,15);\r
+ call cadre (390-3,180,440+3,196,2,15,8,15);\r
+ when 2:\r
+ call cadre (270-3,180,320+3,196,2,15,8,15);\r
+ call cadre (390-3,180,440+3,196,2,8,15,15);\r
+ ESAC;\r
+END AFFICHE_MARGE;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_MEM *)\r
+(***************************************************************************)\r
+(* Affiche le niveau de m\82moire des ordinateurs en cas de strat\82gie rapide *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_MEM : procedure;\r
+BEGIN\r
+ call RECTANGLE_PLEIN (270,151,270+maxmem*2,165,4,4);\r
+ IF maxmem<>50 THEN\r
+ call RECTANGLE_PLEIN (270+maxmem*2+1,151,370,165,14,14);\r
+ fi;\r
+ call RECTANGLE_PLEIN (394,151,421,165,7,7);\r
+ call track (396,152,maxmem,7,0);\r
+END AFFICHE_MEM;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_TYPSTRA *)\r
+(***************************************************************************)\r
+(* Affiche quel est le type de strat\82gie de l'ordinateur *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_TYPSTRA : procedure;\r
+BEGIN\r
+ IF stratype = 1 THEN\r
+ call cadre (260,120,350,136,2,8,15,15);\r
+ call cadre (360,120,450,136+6,2,15,8,15);\r
+ ELSE\r
+ call cadre (260,120,350,136,2,15,8,15);\r
+ call cadre (360,120,450,136+6,2,8,15,15);\r
+ fi;\r
+END AFFICHE_TYPSTRA;\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFFICHE_STRATEG *)\r
+(***************************************************************************)\r
+(* Affiche les caract\82ristiques de la strat\82gie de l'ordinateur *)\r
+(***************************************************************************)\r
+\r
+unit AFFICHE_STRATEG : procedure;\r
+\r
+BEGIN\r
+ call cadre (160+8,80+8,479-8,80+24,1,8,15,15);\r
+ call OUTSTRING (222,90,"Strategie de l'ordinateur",15,0);\r
+ (* joueur 1 *)\r
+ call cadre (160+8,120,240,136,1,8,15,15);\r
+ call TEXTE_GRAVE (172,122,"Type",7,7);\r
+ call TEXTE_GRAVE (290,123,"SURE",7,7);\r
+ call TEXTE_GRAVE (385,123+3,"RAPIDE",7,7);\r
+ call OUTSTRING (194,152,"MEMOIRE",15,7);\r
+ call OUTSTRING (200,182,"MARGE",15,7);\r
+\r
+ call AFFICHE_TYPSTRA;\r
+\r
+ call cadre (167,145,450,210,3,8,15,15); (* ici *)\r
+ call cadre (269,150,371,166,1,8,15,15);\r
+ call AFFICHE_MEM;\r
+\r
+ call cadre (375,150,391,166,1,15,8,15);\r
+ call TEXTE_GRAVE (380,152,"-",7,7);\r
+\r
+ call cadre (393,150,422,166,1,8,15,15);\r
+\r
+ call cadre (424,150,440,166,1,15,8,15);\r
+ call TEXTE_GRAVE (429,152,"+",7,7);\r
+\r
+ call TEXTE_GRAVE (293,182,"1",7,7);\r
+ call TEXTE_GRAVE (413,182,"2",7,7);\r
+ call AFFICHE_MARGE;\r
+\r
+END AFFICHE_STRATEG;\r
+\r
+\r
+(***************************************************************************)\r
+(* STRATEG *)\r
+(***---------------------------------------------------------------------***)\r
+(* Modification des caract\82ristiques de la strat\82gie de l'ordinateur *)\r
+(***************************************************************************)\r
+\r
+unit STRATEG : procedure ;\r
+VAR\r
+ okay,annuler : BOOLEAN,\r
+ a : arrayof integer,\r
+ s_mem,s_typ,s_marg : integer;\r
+BEGIN\r
+ (* sauver le fond de l'image *)\r
+\r
+ array A dim (1:3050);\r
+ call move (160,80);\r
+\r
+ (* sauver l'ecran *)\r
+\r
+ a := GETMAP (479+15,360);\r
+\r
+ (* sauver les caract\82ristiques en cas d'annulation *)\r
+ s_mem := maxmem;\r
+ s_typ := stratype;\r
+ s_marg := marge;\r
+\r
+ (* affichage du panneau *)\r
+ call RECTANGLE_PLEIN (160+4,80+4,479-4,309-4-15,7,7);\r
+ call cadre (160,80,479,309-15,4,15,8,15);\r
+ call cadre (168,421-150,300,437-150,1,15,8,15);\r
+ call TEXTE_GRAVE (200,423-150,"CONFIRMER",7,7);\r
+\r
+ call cadre (340,421-150,472,437-150,1,15,8,15);\r
+ call TEXTE_GRAVE (380,423-150,"ANNULER",7,7);\r
+\r
+ call cadre (160+8,80+8,479-8,80+24,1,8,15,15);\r
+ call OUTSTRING (222,90,"Strategie de l'ordinateur",15,0);\r
+ (* afficher toutes les caract\82ristiques *)\r
+ call AFFICHE_STRATEG;\r
+ (* gestion de la souris *)\r
+ annuler := false;\r
+\r
+ okay := FALSE;\r
+ annuler := FALSE;\r
+\r
+ DO\r
+ IF ok THEN\r
+ call hidecursor;\r
+ IF mousein (mousex,mousey,260,120,350,136) THEN\r
+ IF stratype<>1 THEN\r
+ stratype := 1;\r
+ call affiche_typstra;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,360,120,450+6,136) THEN\r
+ IF stratype<>2 THEN\r
+ stratype := 2;\r
+ call affiche_typstra;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,375,150,391,166) THEN\r
+ IF maxmem>1 THEN\r
+ call inc (maxmem,-1);\r
+ call affiche_mem;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,424,150,440,166) THEN\r
+ IF maxmem<50 THEN\r
+ call INC (maxmem,1);\r
+ call affiche_mem;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,271,150,370,166) THEN\r
+ maxmem := (mousex-270) div 2;\r
+ call affiche_mem;\r
+ FI;\r
+\r
+ IF mousein (mousex,mousey,267,180,323,196) THEN\r
+ IF marge <> 1 THEN\r
+ marge := 1;\r
+ call affiche_marge;\r
+ FI;\r
+ FI;\r
+ IF mousein (mousex,mousey,387,180,443,196) THEN\r
+ IF marge <> 2 THEN\r
+ marge := 2;\r
+ call affiche_marge;\r
+ FI;\r
+ FI;\r
+\r
+ IF mousein(mousex,mousey,168,421-150,300,437-150) THEN\r
+ okay := TRUE;\r
+ exit;\r
+ FI;\r
+ IF mousein(mousex,mousey,340,421-150,472,437-150) THEN\r
+ annuler := TRUE;\r
+ exit;\r
+ FI;\r
+ FI;\r
+ call showcursor;\r
+ OD;\r
+\r
+ call move (160,80);\r
+ call putmap (a);\r
+\r
+ (* si annulation, restituer les anciennes caract\82ristiques *)\r
+ IF annuler THEN\r
+ maxmem := s_mem;\r
+ stratype := s_typ;\r
+ marge := s_marg;\r
+ ELSE\r
+ call resetgame;\r
+ call aff_infos_debut;\r
+ fi;\r
+END STRATEG;\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* MOUSEIN *)\r
+(***---------------------------------------------------------------------***)\r
+(* Teste si la souris se trouve dans les coordonn\82es sp\82cifi\82es *)\r
+(***************************************************************************)\r
+\r
+unit mousein : function (mouse_x,mouse_y,x1,y1,x2,y2 : INTEGER) : BOOLEAN;\r
+BEGIN\r
+ IF ((mouse_x >= x1) AND (mouse_x <= x2) AND\r
+ (mouse_y >= y1) AND (mouse_y <= y2)) THEN\r
+ result := TRUE\r
+ ELSE\r
+ result := FALSE;\r
+ fi;\r
+END mousein;\r
+\r
+(***************************************************************************)\r
+(* OK *)\r
+(***---------------------------------------------------------------------***)\r
+(* Test du bouton de la souris et mise \85 jour de ses coordonn\82es *)\r
+(***************************************************************************)\r
+\r
+unit OK : function : boolean;\r
+var\r
+ mx2,my2,h2,l2,r2,c2 : integer;\r
+begin\r
+\r
+ result := false;\r
+ reponse:=getpress(mousex,mousey,h,l,r,c);\r
+ if reponse then\r
+ if c<>0 then\r
+ result := true;\r
+ while boutonpresse do od;\r
+ fi;\r
+ fi;\r
+\r
+end OK;\r
+\r
+(***************************************************************************)\r
+(* BOUTONPRESSE *)\r
+(***---------------------------------------------------------------------***)\r
+(* Test du bouton de la souris *)\r
+(***************************************************************************)\r
+\r
+unit boutonpresse : function : boolean;\r
+var\r
+ mx2,my2,h2,l2,r2,c2 : integer;\r
+begin\r
+ reponse:=getpress(mx2,my2,h2,l2,r2,c2);\r
+ if c2<>0 then\r
+ result := true;\r
+ fi;\r
+end boutonpresse;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* AFF_TEXTE_INDICE *)\r
+(***---------------------------------------------------------------------***)\r
+(* Affiche le panneau d'indice de calcul de l'ordinateur *)\r
+(***************************************************************************)\r
+\r
+\r
+unit AFF_TEXTE_INDICE : procedure ;\r
+begin\r
+ call move (160,0);\r
+ savescr := getmap (320,48-5);\r
+\r
+ call rectangle_plein (165,20,315,40-5,8,8);\r
+ call color (0);\r
+ call rectangle (165,20,315,40-5);\r
+\r
+ call RECTANGLE_PLEIN (160,0,320,48-5,7,7);\r
+ call CADRE (160,0,320,48-5,4,8,15,15);\r
+ call color (8);\r
+ call outstring (168,5,"CALCUL STRATEGIQUE",8,7);\r
+ call rectangle_plein (165,20,315,40-5,8,8);\r
+ call color (0);\r
+ call rectangle (165,20,315,40-5);\r
+end AFF_TEXTE_INDICE;\r
+\r
+(***************************************************************************)\r
+(* EFF_TEXTE_INDICE *)\r
+(***---------------------------------------------------------------------***)\r
+(* Efface le panneau d'indice de calcul de l'ordinateur *)\r
+(***************************************************************************)\r
+\r
+\r
+unit EFF_TEXTE_INDICE : procedure;\r
+begin\r
+ call move (160,0);\r
+ call putmap (savescr);\r
+end EFF_TEXTE_INDICE;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFF_INDICE *)\r
+(***---------------------------------------------------------------------***)\r
+(* Affiche l'indice de calcul de l'ordinateur pour une strat\82gie sure *)\r
+(***************************************************************************)\r
+\r
+unit AFF_INDICE : procedure (j,i : integer);\r
+var\r
+ val : integer;\r
+begin\r
+\r
+ val := ((148 * ((j-1)*taille+i)) / (taille*taille)) + 166;\r
+ call RECTANGLE_PLEIN (166,21,val,39-5,4,4);\r
+end AFF_INDICE;\r
+\r
+\r
+(***************************************************************************)\r
+(* AFF_INDICE2 *)\r
+(***---------------------------------------------------------------------***)\r
+(* Affiche l'indice de calcul de l'ordinateur pour une strat\82gie rapide *)\r
+(***************************************************************************)\r
+\r
+unit AFF_INDICE2 : procedure (n,m : integer);\r
+var\r
+ val : integer;\r
+begin\r
+\r
+ val := (148 * n / m) + 166;\r
+ call RECTANGLE_PLEIN (166,21,val,39-5,4,4);\r
+end AFF_INDICE2;\r
+\r
+\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* MEILLEURES_CASES *)\r
+(***---------------------------------------------------------------------***)\r
+(* Pioche dans la liste des possibilit\82s que l'ordinateur a calcul\82e, les *)\r
+(* 13 meilleures cases jouables, et colorie les cases en fonction de leur *)\r
+(* ordre d'importance. *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit meilleures_cases : procedure;\r
+\r
+VAR\r
+ cols : ARRAYOF INTEGER ,\r
+ i : INTEGER,\r
+ n : INTEGER;\r
+BEGIN\r
+ array cols dim (1:4);\r
+\r
+ cols (1) := 15; cols (2) := 15;\r
+ cols (3) := 3; cols (4) := 0;\r
+\r
+\r
+ IF nbcases > 3 THEN\r
+ n := 3;\r
+ ELSE\r
+ n := nbcases;\r
+ FI;\r
+\r
+ FOR i:=1 TO n DO\r
+\r
+ call AFF_CASE (megaliste.tab(nbcases+1-i).x,megaliste.tab(nbcases+1-i).y,\r
+ taille,cols(i),cols(i+1),0,0);\r
+ OD;\r
+ read (ch);\r
+\r
+ FOR i:=1 TO n DO\r
+ call AFF_CASE (megaliste.tab(nbcases+1-i).x,megaliste.tab(nbcases+1-i).y,\r
+ taille,7,7,0,0);\r
+ OD;\r
+ kill (cols);\r
+END meilleures_cases;\r
+\r
+(***-------------------------------------------------------------------***)\r
+(* *)\r
+(* OOPS *)\r
+(* *)\r
+(***-------------------------------------------------------------------***)\r
+(* *)\r
+(* Fonction 'OOPS' du MORPS. Enl\8ave les 2 derniers pions jou\82s. *)\r
+(* *)\r
+(***-------------------------------------------------------------------***)\r
+\r
+unit oops : procedure;\r
+var\r
+i,j : integer;\r
+\r
+BEGIN\r
+ IF partie_gagnee OR partie_terminee THEN\r
+ IF partie_terminee OR partie_gagnee THEN\r
+ IF partie_gagnee THEN\r
+ nb_par_gagn.tab(jeu.gagne):= nb_par_gagn.tab(jeu.gagne) -1;\r
+ ELSE\r
+ call inc (nb_mtch_nuls,-1);\r
+ FI;\r
+ call inc (nb_par_fin,-1);\r
+ jeu.gagne := 0;\r
+ FI;\r
+ IF (player = j_qui_a_comm) THEN\r
+ call inc (coup,-2);\r
+ ELSE\r
+ call inc (coup,-2);\r
+ FI;\r
+ ELSE\r
+ call inc (coup,-2);\r
+ FI;\r
+ IF partie_gagnee THEN\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ IF tab_pion.tab(j,i) = 3-player THEN\r
+ call aff_case (i,j,taille,7,7,3-player,choix_pion.tab(3-player));\r
+ FI;\r
+ OD;\r
+ OD;\r
+ jeu.gagne := 0;\r
+ partie_gagnee := FALSE;\r
+ partie_terminee := FALSE;\r
+ jeu.fini := FALSE;\r
+ FI;\r
+ IF partie_terminee THEN\r
+ jeu.gagne := 0;\r
+ partie_gagnee := FALSE;\r
+ partie_terminee := FALSE;\r
+ jeu.fini := FALSE;\r
+ FI;\r
+ call aff_case (jeu.coord(jeu.offset-1).x,jeu.coord(jeu.offset-1).y,\r
+ taille,7,7,0,0);\r
+ call aff_case (jeu.coord(jeu.offset-2).x,jeu.coord(jeu.offset-2).y,\r
+ taille,7,7,0,0);\r
+\r
+ (* mettre \85 jour la matrice de jeu *)\r
+ tab_pion.tab (jeu.coord(jeu.offset-1).y,jeu.coord(jeu.offset-1).x) := 0;\r
+ tab_pion.tab (jeu.coord(jeu.offset-2).y,jeu.coord(jeu.offset-2).x) := 0;\r
+ attaquant := jeu.coord(jeu.offset-2).a;\r
+\r
+ call inc (coups_joues.tab(player),-1);\r
+ call inc (coups_joues.tab(3-player),-1);\r
+\r
+ call inc (jeu.offset,-2);\r
+ call aff_infos_debut;\r
+END oops;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* INITIALISATIONS *)\r
+(***---------------------------------------------------------------------***)\r
+(* D\82claration des tableaux et des param\8atres par d\82faut *)\r
+(***************************************************************************)\r
+\r
+unit INITIALISATIONS : procedure;\r
+var\r
+ i,j : integer;\r
+begin\r
+ NB_AIDES := new TABLEAUX;\r
+ NB_UNDOS := new TABLEAUX;\r
+ JOUEUR := new TABLEAUX;\r
+ CHOIX_PION := new TABLEAUX;\r
+ STRATEGIE := new TABLEAUX;\r
+ INT := new TABLEAUX;\r
+ TAB_PION := new TABDOUBLE;\r
+ POSS := new COUP_POSS;\r
+ COEFS := new TABCOEF;\r
+ JEU := new TABJEU;\r
+ MEGALISTE := new MEGA;\r
+ MEGALISTE2 := new MEGA2;\r
+ NB_PAR_GAGN := new TABLEAUX;\r
+ NB_PAR_PERD := new TABLEAUX;\r
+ COUPS_JOUES := new TABLEAUX;\r
+\r
+ maxmem := 20;\r
+ marge := 2;\r
+ stratype := 2;\r
+\r
+ array MEMOIRE dim (1:2);\r
+ array MEMOIRE(1) dim (1:100);\r
+ array MEMOIRE(2) dim (1:100);\r
+\r
+ array savescr dim (0:10000);\r
+\r
+ STRATEGIE.TAB(1) := 2 ;\r
+ STRATEGIE.TAB(2) := 2 ;\r
+ INT.TAB(1) := 100 ;\r
+ INT.TAB(2) := 100 ;\r
+\r
+ CHOIX_PION.TAB(1) := 1;\r
+ CHOIX_PION.TAB(2) := 2;\r
+\r
+ JOUEUR.TAB(1) := 1;\r
+ JOUEUR.TAB(2) := 2;\r
+ xjoue2 := 0;\r
+ yjoue2 := 0;\r
+ align := 5;\r
+ taille := 10;\r
+ partie := 0;\r
+ player := 1;\r
+ coup := 1;\r
+ commence := 1;\r
+ nb_par_avort := -1;\r
+ nb_par_fin := 0;\r
+ nb_mtch_nuls := 0;\r
+\r
+\r
+end INITIALISATIONS;\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* RESETGAME *)\r
+(***---------------------------------------------------------------------***)\r
+(* Annule la partie en cours, remet \85 jour tous les param\8atres de jeu *)\r
+(***************************************************************************)\r
+\r
+unit RESETGAME : procedure;\r
+var\r
+ i,j : integer;\r
+begin\r
+\r
+\r
+ player := commence; (* choisir le joueur qui commence *)\r
+ IF player=3 THEN\r
+ player := RANDOM*2+1;\r
+ FI;\r
+ j_qui_a_comm := player;\r
+ attaquant := player;\r
+\r
+ call INC (partie,1); (* mise \85 jour des statistiques *)\r
+ coup := 1;\r
+ xjoue := 1;\r
+ yjoue := 1;\r
+ xjoue2 := 1;\r
+ yjoue2 := 1;\r
+ nb_aides.tab(1) := 0;\r
+ nb_aides.tab(2) := 0;\r
+ nb_undos.tab(1) := 0;\r
+ nb_undos.tab(2) := 0;\r
+ coups_joues.tab(1) := 0;\r
+ coups_joues.tab(2) := 0;\r
+ jeu.offset := 1;\r
+ jeu.maxi := 1;\r
+ jeu.gagne := 0;\r
+ jeu.fini := FALSE;\r
+ IF NOT partie_terminee AND NOT partie_gagnee THEN\r
+ call INC (nb_par_avort,1);\r
+ FI;\r
+ partie_terminee := FALSE;\r
+ partie_gagnee := FALSE;\r
+\r
+ call calc_coefs;\r
+\r
+ for i:= 1 to 12 do\r
+ for j := 1 to 12 do\r
+ TAB_PION.TAB(i,j):=0;\r
+ od;\r
+ od;\r
+ for i:= 1 to taille do\r
+ for j := 1 to taille do\r
+ call aff_case (j,i,taille,7,7,0,0);\r
+ od;\r
+ od;\r
+\r
+ FOR i := 0 TO taille+1 DO\r
+ TAB_PION.TAB(0,i) := 255;\r
+ TAB_PION.TAB(taille+1,i) := 255;\r
+ TAB_PION.TAB(i,0) := 255;\r
+ TAB_PION.TAB(i,taille+1) := 255;\r
+ OD;\r
+\r
+ FOR j := 1 to 2 DO\r
+ FOR i := 1 to 100 DO\r
+ MEMOIRE(j,i) := new POSIT;\r
+ MEMOIRE(j,i).x := taille div 2 - align div 2 + random*align;\r
+ MEMOIRE(j,i).y := taille div 2 - align div 2 + random*align;\r
+ OD;\r
+ OD;\r
+\r
+\r
+ (* coordonn\82es de la nouvelle grille *)\r
+ debut_x := entier((12-taille)*(39/2))+4;\r
+ debut_y := entier((12-taille)*(39/2))+11;\r
+ fin_x := debut_x+(taille)*39-1;\r
+ fin_y := debut_y+(taille)*39-1;\r
+\r
+end RESETGAME;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* RESETGAME_JOUEURS *)\r
+(***---------------------------------------------------------------------***)\r
+(* Relance les nouvelles coroutines des joueurs en fonction de leur type *)\r
+(***************************************************************************)\r
+\r
+unit RESETGAME_JOUEUR : procedure;\r
+begin\r
+ (* creation des coroutines *)\r
+ if joueur.tab(1)=1 then\r
+ joueur1_hum := new human_play;\r
+ else\r
+ joueur1_cpu := new cpu_play;\r
+ fi;\r
+ if joueur.tab(2)=1 then\r
+ joueur2_hum := new human_play;\r
+ else\r
+ joueur2_cpu := new cpu_play;\r
+ fi;\r
+end RESETGAME_JOUEUR;\r
+\r
+\r
+\r
+\r
+ (*******************************)\r
+ (* *)\r
+ (* STRATEGIE DE L'ORDINATEUR *)\r
+ (* *)\r
+ (*******************************)\r
+\r
+\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* AJCOEFS *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Ajoute une valeur au coefficient d'attaque actuel de la case \82tudi\82e. *)\r
+(* Cette valeur est fonction : *)\r
+(* - du nombre de pions restant pour former une ligne *)\r
+(* - du TYPE de ligne formable (bloqu\82e d'un cot\82 ou pas) *)\r
+(* - de la position du pion dans cette ligne (extr\82mit\82s ou milieu) *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit ajcoefs: procedure (m,i,j,nbpions : integer;\r
+ inout nb_dangers,nb_dangers2,nb_dangers3 : integer;\r
+ inout ouv1,ouv2,ad1,ad2,ad3 : boolean);\r
+VAR\r
+ nbrest : INTEGER;\r
+BEGIN\r
+ (* calcul du nombre de pions restant pour former une ligne *)\r
+ nbrest := align-nbpions;\r
+ (* cas d'une case potentiellement gagnante un coup apr\8as *)\r
+ IF nbrest = 1 THEN\r
+ poss.tab(j,i).att_reste1 := TRUE;\r
+ FI;\r
+ IF nbrest<0 THEN\r
+ nbrest := 0;\r
+ FI;\r
+ (* cas d'une case obligatoirement gagnante *)\r
+ IF nbrest = 0 THEN\r
+ poss.tab(j,i).att_gagnante := TRUE;\r
+ FI;\r
+ (* cas d'une case potentiellement gagnante 3 coups apr\8as *)\r
+ IF (nbrest<=3) AND NOT ad3 THEN\r
+ nb_dangers3 := nb_dangers3 + 1;\r
+ (* ne pas repasser par l\85 pour une m\88me direction de ligne *)\r
+ ad3 := TRUE;\r
+ FI;\r
+ (* si la ligne n'est bloqu\82e d'aucun cot\82 *)\r
+ IF ouv1 AND ouv2 THEN\r
+ (* s'il reste 2 pions pour terminer la ligne *)\r
+ IF (nbrest<=2) AND NOT ad2 THEN\r
+ nb_dangers2 := nb_dangers2 + 1;\r
+ ad2 := TRUE;\r
+ FI;\r
+ (* s'il reste au plus 1 pion pour terminer la ligne *)\r
+ IF (nbrest<=1) AND NOT ad1 THEN\r
+ nb_dangers := nb_dangers + 1;\r
+ ad1 := TRUE;\r
+ FI;\r
+ IF (nbrest-1>=0) THEN\r
+ (* les cases dont les lignes formables ne sont bloqu\82es... *)\r
+ (* d'aucun cot\82 sont consid\82r\82es comme des lignes bloqu\82es...*)\r
+ (* d'un cot\82 mais ayant un pion de plus, pour la valeur du...*)\r
+ (* coefficient. *)\r
+ IF nbrest=1 THEN\r
+ nbrest := nbrest - 1;\r
+ ELSE\r
+ poss.tab(j,i).attaque := poss.tab(j,i).attaque + 1;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ (* si le pion est au milieu d'une ligne *)\r
+ IF (m<>0) AND (m<>align-1) THEN\r
+ (* on majore la valeur du coefficient *)\r
+ poss.tab(j,i).attaque := poss.tab(j,i).attaque + align-nbrest;\r
+ FI;\r
+ (* ajout d'une valeur au coefficient d'attaque *)\r
+ poss.tab(j,i).attaque := poss.tab(j,i).attaque + coefs.tab(nbrest);\r
+END ajcoefs;\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* AJCOEFSDEF *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Ajoute une valeur au coefficient de d\82fense actuel de la case \82tudi\82e. *)\r
+(* Cette valeur est fonction : *)\r
+(* - du nombre de pions restant pour former une ligne *)\r
+(* - du TYPE de ligne formable (bloqu\82e d'un cot\82 ou pas) *)\r
+(* - de la position du pion dans cette ligne (extr\82mit\82s ou milieu) *)\r
+(* *)\r
+(* La structure du sous programme est identique \85 AJCOEFS, mais l'action *)\r
+(* est vue du point de vue de l'ennemi. On \82tudie quelles seraient ses *)\r
+(* possibilit\82s s'il jouait sur cette case. Cette fois ci c'est le *)\r
+(* coefficient de d\82fense qui est incr\82ment\82. *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit ajcoefsdef: procedure (m,i,j,nbpions : integer;\r
+ inout nb_dangers,nb_dangers2,nb_dangers3 : integer;\r
+ inout ouv1,ouv2,ad1,ad2,ad3 : boolean);\r
+\r
+VAR\r
+ nbrest : INTEGER;\r
+BEGIN\r
+ nbrest := align-nbpions;\r
+ IF nbrest = 1 THEN\r
+ poss.tab(j,i).def_reste1 := TRUE;\r
+ FI;\r
+ IF nbrest<0 THEN\r
+ nbrest := 0;\r
+ FI;\r
+ IF nbrest = 0 THEN\r
+ poss.tab(j,i).def_gagnante := TRUE;\r
+ FI;\r
+ IF (nbrest<=3) AND NOT ad3 THEN\r
+ nb_dangers3 := nb_dangers3 + 1;\r
+ ad3 := TRUE;\r
+ FI;\r
+ IF ouv1 AND ouv2 THEN\r
+ IF (nbrest<=2) AND NOT ad2 THEN\r
+ nb_dangers2 := nb_dangers2 + 1;\r
+ ad2 := TRUE;\r
+ FI;\r
+ IF (nbrest<=1) AND NOT ad1 THEN\r
+ nb_dangers := nb_dangers + 1;\r
+ ad1 := TRUE;\r
+ FI;\r
+ IF (nbrest-1>=0) THEN\r
+ IF nbrest=1 THEN\r
+ nbrest := nbrest - 1;\r
+ ELSE\r
+ poss.tab(j,i).defense := poss.tab(j,i).defense + 1;\r
+ FI;\r
+ FI;;\r
+\r
+ FI;\r
+ IF (m<>0) AND (m<>align-1) THEN\r
+ poss.tab(j,i).defense := poss.tab(j,i).defense +align-nbrest;\r
+ FI;\r
+ poss.tab(j,i).defense := poss.tab(j,i).defense + coefs.tab(nbrest);\r
+(* writeln (nbpions,nbrest,poss.tab(j,i).defense,coefs.tab(nbrest));*)\r
+END ajcoefsdef;\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* CALCPOSS *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Calcul de la possibilit\82 majeure de ligne de chaque case. La *)\r
+(* possibilit\82 majeure de ligne correspond au num\82ro de classe (1 des 10 *)\r
+(* listes primaires) dans laquelle la case en question doit s'inscrire. *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* i,j : coordonn\82es de la case *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit calcposs : procedure (i,j : INTEGER);\r
+BEGIN\r
+ sommposs := 0;\r
+\r
+ IF strategie.tab(player) = 1 THEN\r
+ IF poss.tab(j,i).att_gagnante THEN sommposs:=9;\r
+ ELSE IF poss.tab(j,i).def_gagnante THEN sommposs:=8;\r
+ ELSE IF poss.tab(j,i).contre_attaque2 THEN sommposs:=7;\r
+ ELSE IF poss.tab(j,i).contre_attaque THEN sommposs:=6;\r
+ ELSE IF poss.tab(j,i).contre_defense THEN sommposs:=5;\r
+ ELSE IF poss.tab(j,i).att_gagnante_2 THEN sommposs:=4;\r
+ ELSE IF poss.tab(j,i).att_gagnante_3 THEN sommposs:=3;\r
+ ELSE IF poss.tab(j,i).def_gagnante_2 THEN sommposs:=2;\r
+ ELSE IF poss.tab(j,i).def_gagnante_3 THEN sommposs:=1;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ ELSE\r
+ IF strategie.tab(player) = 2 THEN\r
+ IF poss.tab(j,i).att_gagnante THEN sommposs:=9;\r
+ ELSE IF poss.tab(j,i).def_gagnante THEN sommposs:=8;\r
+ ELSE IF poss.tab(j,i).contre_attaque2 THEN sommposs:=7;\r
+ ELSE IF poss.tab(j,i).contre_attaque THEN sommposs:=6;\r
+ ELSE IF poss.tab(j,i).contre_defense THEN sommposs:=5;\r
+ ELSE IF poss.tab(j,i).att_gagnante_2 OR\r
+ poss.tab(j,i).def_gagnante_2 OR\r
+ poss.tab(j,i).att_gagnante_3 OR\r
+ poss.tab(j,i).def_gagnante_3 THEN sommposs:=4;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ ELSE\r
+ IF poss.tab(j,i).att_gagnante THEN sommposs:=9;\r
+ ELSE IF poss.tab(j,i).def_gagnante THEN sommposs:=8;\r
+ ELSE IF poss.tab(j,i).contre_attaque2 THEN sommposs:=7;\r
+ ELSE IF poss.tab(j,i).contre_attaque THEN sommposs:=6;\r
+ ELSE IF poss.tab(j,i).contre_defense THEN sommposs:=5;\r
+ ELSE IF poss.tab(j,i).def_gagnante_2 THEN sommposs:=4;\r
+ ELSE IF poss.tab(j,i).def_gagnante_3 THEN sommposs:=3;\r
+ ELSE IF poss.tab(j,i).att_gagnante_2 THEN sommposs:=2;\r
+ ELSE IF poss.tab(j,i).att_gagnante_3 THEN sommposs:=1;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ FI;\r
+END calcposs;\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* cal_ctr_attq *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Recherche des points fictifs. *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(*\r
+ Rechercher les points fictifs de l'ennemi\r
+ SI l'ennemi poss\8ade un point fictif ALORS\r
+ Rechercher les points fictifs meilleurs que les siens\r
+ SI j'ai de meilleurs points fictifs ALORS\r
+ Les cases trouv\82es me font passer\r
+ attaquant si je les jouent\r
+ FSI\r
+ FSI\r
+*)\r
+\r
+unit cal_ctr_attq : procedure (inout fin : BOOLEAN);\r
+VAR\r
+ i,j : INTEGER,\r
+ reste : INTEGER;\r
+BEGIN\r
+ IF NOT fin THEN\r
+ reste := 4;\r
+ FOR j:=1 TO taille DO (* regarder si l'adversaire pourrait *)\r
+ FOR i:=1 TO taille DO (* se cr\82er des points fictifs *)\r
+ IF tab_pion.tab(j,i) = 0 THEN\r
+ IF poss.tab(j,i).def_reste2ouv AND (reste=4) THEN\r
+ reste := 3;\r
+ FI;\r
+ IF poss.tab(j,i).def_reste1 AND (reste=4) THEN\r
+ reste := 3;\r
+ FI;\r
+ IF poss.tab(j,i).def_gagnante_3o AND (reste>=3) THEN\r
+ reste := 2;\r
+ FI;\r
+ IF poss.tab(j,i).def_reste2ouv AND\r
+ poss.tab(j,i).def_reste1 AND (reste>=2) THEN\r
+ reste := 1;\r
+ FI;\r
+ IF poss.tab(j,i).def_gagnante_2 THEN (* prendre le *)\r
+ (* meilleur type de point fictif *)\r
+ i := taille; (* meilleur TYPE trouv\82 : *)\r
+ j := taille; (* inutile de continuer \85 chercher *)\r
+ reste := 0;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ OD;\r
+ IF (reste<>4) THEN (* si l'adversaire peut se cr\82er *)\r
+ (* un point fictif *)\r
+ FOR j:=1 TO taille DO (* rechercher si l'on poss\8ade *)\r
+ FOR i:=1 TO taille DO (* un point fictif meilleur *)\r
+ IF tab_pion.tab(j,i)=0 THEN\r
+ IF (reste=0) AND\r
+ (poss.tab(j,i).att_gagnante_2 OR\r
+ poss.tab(j,i).att_reste1) THEN\r
+ (* si on a un point fictif meilleur *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_attaque := TRUE;\r
+ (* si cette case est jou\82e, on passe en position d'attaque *)\r
+ poss.tab(j,i).attaquant := player;\r
+ FI;\r
+ IF (reste=1) AND (poss.tab(j,i).att_gagnante_2 OR\r
+ poss.tab(j,i).att_reste1) THEN\r
+ (* si on a un point fictif meilleur *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_attaque := TRUE;\r
+ (* si cette case est jou\82e, on passe en position d'attaque *)\r
+ poss.tab(j,i).attaquant := player;\r
+ FI;\r
+ IF (reste=2) AND (poss.tab(j,i).att_gagnante_3o\r
+ OR poss.tab(j,i).att_gagnante_2 OR\r
+ (poss.tab(j,i).att_reste1\r
+ AND poss.tab(j,i).att_reste2ouv)) THEN\r
+ (* si on a un point fictif meilleur *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_attaque := TRUE;\r
+ (* si cette case est jou\82e, on passe en position d'attaque *)\r
+ poss.tab(j,i).attaquant := player;\r
+ FI;\r
+ IF (reste=3) AND (poss.tab(j,i).att_reste1\r
+ OR poss.tab(j,i).att_gagnante_2\r
+ OR poss.tab(j,i).att_gagnante_3o\r
+ OR poss.tab(j,i).att_reste2ouv) THEN\r
+ (* si on a un point fictif *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_attaque := TRUE;\r
+ (* si cette case est jou\82e, on passe en position d'attaque *)\r
+ poss.tab(j,i).attaquant := player;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ OD;\r
+ FI;\r
+ FI;\r
+END cal_ctr_attq;\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* cal_ctr_def *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Recherche des points fictifs de l'ennemi. *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(*\r
+ Rechercher le meilleur de ses propres points fictifs\r
+ SI JE poss\8ade un point fictif ALORS\r
+ Rechercher les points fictifs ennemis meilleurs que les miens\r
+ SI l'ennemi a de meilleurs points fictifs ALORS\r
+ Les cases trouv\82es font passer l'ennemi\r
+ attaquant si JE les jouent\r
+ FSI\r
+ FSI\r
+*)\r
+unit cal_ctr_def : procedure (inout fin : BOOLEAN);\r
+VAR\r
+ i,j : INTEGER,\r
+ reste : INTEGER;\r
+BEGIN\r
+\r
+ IF NOT fin THEN\r
+ reste := 4;\r
+ FOR j:=1 TO taille DO (* regarder si on peut se *)\r
+ FOR i:=1 TO taille DO (* cr\82er des points fictifs *)\r
+ IF tab_pion.tab(j,i) = 0 THEN\r
+ IF poss.tab(j,i).att_reste2ouv AND (reste=4) THEN\r
+ reste := 3;\r
+ FI;\r
+ IF poss.tab(j,i).att_reste1 AND (reste=4) THEN\r
+ reste := 3;\r
+ FI;\r
+ IF poss.tab(j,i).att_gagnante_3o AND (reste>=3) THEN\r
+ reste := 2;\r
+ FI;\r
+ IF poss.tab(j,i).att_gagnante_3o AND (reste>=2) THEN\r
+ reste := 1;\r
+ FI;\r
+ IF poss.tab(j,i).att_gagnante_2 THEN (* prendre le *)\r
+ (* meilleur des points fictifs *)\r
+ i := taille;\r
+ j := taille;\r
+ reste := 0;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ OD;\r
+\r
+ IF (reste<>4) THEN (* si on a trouv\82 une possibilit\82 *)\r
+ (* de point fictif *)\r
+ FOR j:=1 TO taille DO (* rechercher si l'ennemi *)\r
+ FOR i:=1 TO taille DO (* poss\8ade un meilleur point fictif *)\r
+ IF tab_pion.tab(j,i)=0 THEN\r
+ IF (reste=0) AND (poss.tab(j,i).def_gagnante_2\r
+ OR poss.tab(j,i).def_reste1) THEN\r
+ (* si on a un point fictif *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_defense := TRUE;\r
+\r
+ poss.tab(j,i).attaquant := 3-player;\r
+ FI;\r
+ IF (reste=1) AND (poss.tab(j,i).def_gagnante_2\r
+ OR poss.tab(j,i).def_reste1) THEN\r
+ (* si on a un point fictif *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_defense := TRUE;\r
+ (* si cette case est jou\82e, on n'est plus en position d'attaque *)\r
+ poss.tab(j,i).attaquant := 3-player;\r
+ FI;\r
+ IF (reste=2) AND (poss.tab(j,i).def_gagnante_2 OR\r
+ poss.tab(j,i).def_reste1) THEN\r
+ (* si on a un point fictif *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_defense := TRUE;\r
+ (* si cette case est jou\82e, on n'est plus en position d'attaque *)\r
+ poss.tab(j,i).attaquant := 3-player;\r
+ FI;\r
+ IF (reste=3) AND (poss.tab(j,i).def_gagnante_2 OR\r
+ poss.tab(j,i).def_gagnante_3o OR\r
+ poss.tab(j,i).def_reste1) THEN\r
+ (* si on a un point fictif *)\r
+ (* le signaler dans les possibilit\82s de la case trouv\82e *)\r
+ poss.tab(j,i).contre_defense := TRUE;\r
+ (* si cette case est jou\82e, on n'est plus en position d'attaque *)\r
+ poss.tab(j,i).attaquant := 3-player;\r
+ FI;\r
+ FI;\r
+ OD;\r
+ OD;\r
+ FI; (* if reste *)\r
+ FI; (* if not fin *)\r
+END cal_ctr_def;\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* cal_ctr_attq2 *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Recherche des points fictifs les meilleurs. *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit cal_ctr_attq2 : procedure (inout fin : BOOLEAN);\r
+VAR\r
+ i,j : INTEGER;\r
+BEGIN\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ IF poss.tab(j,i).contre_attaque AND\r
+ (poss.tab(j,i).att_reste1\r
+ (*OR poss.tab(j,i).att_reste2ouv*))\r
+ AND (poss.tab(j,i).att_gagnante_2) THEN\r
+ poss.tab(j,i).contre_attaque2 := TRUE;\r
+ poss.tab(j,i).attaquant := player;\r
+ FI;\r
+ OD;\r
+ OD;\r
+END cal_ctr_attq2;\r
+\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* CALCSOMMPOSS *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Calcul de la somme des possibilit\82s de lignes de chaque case. *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* i,j : coordonn\82es de la case *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+\r
+unit calcsommposs : procedure (i,j : integer);\r
+BEGIN\r
+ sommposs := 0;\r
+ IF strategie.tab(player) = 1 THEN (* strat\82gie ATTAQUE *)\r
+ IF poss.tab(j,i).att_gagnante THEN call INC(sommposs,256); FI;\r
+ IF poss.tab(j,i).def_gagnante THEN call INC(sommposs,128); FI;\r
+ (* attaque prioritaire sur d\82fense *)\r
+ IF poss.tab(j,i).contre_attaque2 THEN call INC(sommposs,64); FI;\r
+ IF poss.tab(j,i).contre_attaque THEN call INC(sommposs,32); FI;\r
+ IF poss.tab(j,i).contre_defense THEN call INC(sommposs,16); FI;\r
+ (* attaque prioritaire sur d\82fense *)\r
+ IF poss.tab(j,i).att_gagnante_2 THEN call INC(sommposs,8); FI;\r
+ IF poss.tab(j,i).att_gagnante_3 THEN call INC(sommposs,4); FI;\r
+ IF poss.tab(j,i).def_gagnante_2 THEN call INC(sommposs,2); FI;\r
+ IF poss.tab(j,i).def_gagnante_3 THEN call INC(sommposs,1); FI;\r
+ ELSE\r
+ IF strategie.tab(player) = 2 THEN (* strat\82gie NORMALE *)\r
+ IF poss.tab(j,i).att_gagnante THEN call INC(sommposs,256); FI;\r
+ IF poss.tab(j,i).def_gagnante THEN\r
+ call INC(sommposs,128); FI;\r
+ IF poss.tab(j,i).contre_attaque2 THEN\r
+ call INC(sommposs,64); FI;\r
+ IF poss.tab(j,i).contre_attaque THEN\r
+ call INC(sommposs,32); FI;\r
+ IF poss.tab(j,i).contre_defense THEN\r
+ call INC(sommposs,16); FI;\r
+ (* alternance attaque/d\82fense *)\r
+ IF poss.tab(j,i).att_gagnante_2 THEN\r
+ call INC(sommposs,4); FI;\r
+ IF poss.tab(j,i).def_gagnante_2 THEN\r
+ call INC(sommposs,4); FI;\r
+ IF poss.tab(j,i).att_gagnante_3 THEN\r
+ call INC(sommposs,4); FI;\r
+ IF poss.tab(j,i).def_gagnante_3 THEN\r
+ call INC(sommposs,4); FI;\r
+ ELSE (* strat\82gie DEFENSE *)\r
+ IF poss.tab(j,i).att_gagnante THEN\r
+ call INC(sommposs,256); FI;\r
+ (* d\82fense prioritaire sur attaque *)\r
+ IF poss.tab(j,i).def_gagnante THEN\r
+ call INC(sommposs,128); FI;\r
+ IF poss.tab(j,i).contre_attaque2 THEN\r
+ call INC(sommposs,64); FI;\r
+ IF poss.tab(j,i).contre_attaque THEN\r
+ call INC(sommposs,32); FI;\r
+ IF poss.tab(j,i).contre_defense THEN\r
+ call INC(sommposs,16); FI;\r
+ IF poss.tab(j,i).def_gagnante_2 THEN\r
+ call INC(sommposs,8); FI;\r
+ IF poss.tab(j,i).def_gagnante_3 THEN\r
+ call INC(sommposs,4); FI;\r
+ IF poss.tab(j,i).att_gagnante_2 THEN\r
+ call INC(sommposs,2); FI;\r
+ IF poss.tab(j,i).att_gagnante_3 THEN\r
+ call INC(sommposs,1); FI;\r
+ FI;\r
+ FI;\r
+END;\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* CALC_COEFS *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Initialise le tableau des coefficients. Il y a 1 coefficient par nombre *)\r
+(* de pions \85 aligner pour former un ligne. S'il faut aligner 5 pions il y *)\r
+(* aura 6 coefficients \82gaux \85 8^(align-pions_restant_a_aligner). *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit calc_coefs : procedure;\r
+VAR\r
+ n : integer,\r
+ i : INTEGER;\r
+BEGIN\r
+ n := 1;\r
+ FOR i:=align downto 0 DO (* se placer su le dernier \82l\82ment *)\r
+ coefs.tab(i) := n;\r
+ n := n*8;\r
+ OD;\r
+ coefs.tab(align) := 0;\r
+ (* en cas de d\82passement on attribue la valeur maxi sur 32 bits *)\r
+ FOR i:=0 TO align-1 DO\r
+ IF coefs.tab(i) = 0 THEN coefs.tab(i) := 2147483647;\r
+ FI;\r
+ OD;\r
+END calc_coefs;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* SWAP *)\r
+(***---------------------------------------------------------------------***)\r
+(* Proc\82dure d'\82change de 2 \82l\82ments dans le quick-sort *)\r
+(***************************************************************************)\r
+\r
+unit SWAP : procedure (ind1 , ind2 , k : integer );\r
+var\r
+ minimum,mini_coef,mini_coefsomm : INTEGER,\r
+ mini_x,mini_y,mini_attaquant : INTEGER;\r
+begin\r
+ minimum := megaliste2.TAB(k).t(ind1).coef;\r
+ mini_x := megaliste2.TAB(k).t(ind1).x;\r
+ mini_y := megaliste2.TAB(k).t(ind1).y;\r
+ mini_coefsomm := megaliste2.TAB(k).t(ind1).coefsomm;\r
+ mini_attaquant := megaliste2.TAB(k).t(ind1).attaquant;\r
+\r
+\r
+ megaliste2.TAB(k).t(ind1).coef :=\r
+ megaliste2.TAB(k).t(ind2).coef ;\r
+ megaliste2.TAB(k).t(ind1).coefsomm :=\r
+ megaliste2.TAB(k).t(ind2).coefsomm ;\r
+ megaliste2.TAB(k).t(ind1).attaquant:=\r
+ megaliste2.TAB(k).t(ind2).attaquant;\r
+ megaliste2.TAB(k).t(ind1).x :=\r
+ megaliste2.TAB(k).t(ind2).x ;\r
+ megaliste2.TAB(k).t(ind1).y :=\r
+ megaliste2.TAB(k).t(ind2).y ;\r
+\r
+ megaliste2.TAB(k).t(ind2).coef := minimum;\r
+ megaliste2.TAB(k).t(ind2).coefsomm := mini_coefsomm;\r
+ megaliste2.TAB(k).t(ind2).attaquant:= mini_attaquant;\r
+ megaliste2.TAB(k).t(ind2).x := mini_x;\r
+ megaliste2.TAB(k).t(ind2).y := mini_y;\r
+\r
+end SWAP;\r
+\r
+(***************************************************************************)\r
+(* QUICK_SORT *)\r
+(***---------------------------------------------------------------------***)\r
+(* Tri rapide des listes de possibilit\82s *)\r
+(***************************************************************************)\r
+\r
+unit QUICK_SORT : procedure (k,gauche,droite : integer );\r
+\r
+var\r
+ moy,ibas,ihaut,coefmoy : integer ;\r
+begin\r
+ (* initialisation des indices bas et haut *)\r
+ ibas := gauche;\r
+ ihaut := droite;\r
+ (* choix d'une valeur mediane *)\r
+ moy := (gauche + droite) div 2+1;\r
+ coefmoy := megaliste2.TAB(k).t(moy).coef;\r
+ (* echange pour que valeurs gauches <= pivot <= valeurs droites *)\r
+ do\r
+ (* recherche de la premiere valeur de gauche mal placee *)\r
+ if ibas<droite then\r
+ while (megaliste2.TAB(k).t(ibas).coef < coefmoy)\r
+ do\r
+ ibas := ibas + 1;\r
+ if ibas>=droite then exit; fi;\r
+ od;\r
+ fi;\r
+ (* recherche de la premiere valeur de droite mal placee *)\r
+ if ihaut>1 then\r
+ while (coefmoy < megaliste2.TAB(k).t(ihaut).coef)\r
+ do\r
+ ihaut := ihaut - 1;\r
+ if ihaut=1 then exit; fi;\r
+ od;\r
+ fi;\r
+ (* echange eventuel de 2 valeurs mal classees *)\r
+ if ibas <= ihaut then\r
+ call SWAP (ibas,ihaut,k);\r
+ if ibas = moy then\r
+ moy := ihaut;\r
+ else if ihaut = moy then\r
+ moy := ibas;\r
+ fi;\r
+ fi;\r
+ ibas := ibas + 1;\r
+ ihaut := ihaut - 1;\r
+ fi;\r
+ if ibas > ihaut then exit;\r
+ fi;\r
+ od;\r
+ (* recursion si les sous-intervalles ne sont pas d\82j\85 tri\82s *)\r
+ if ihaut > gauche then\r
+ call QUICK_SORT (k,gauche,ihaut);\r
+ fi;\r
+ if ibas < droite then\r
+ call QUICK_SORT (k,ibas,droite);\r
+ fi;\r
+\r
+end QUICK_SORT;\r
+\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(* STRA *)\r
+(* *)\r
+(***---------------------------------------------------------------------***)\r
+(* *)\r
+(* Sous programme principal de strat\82gie de l'ordinateur. Celui ci \82tudie *)\r
+(* successivement chaque case et \82tablit pour chaque case une liste de *)\r
+(* caract\82ristiques, et un coefficient qui caract\82rise le degr\82 de danger *)\r
+(* que repr\82sente celle-ci. *)\r
+(* *)\r
+(* La deuxi\8ame phase consiste \85 rep\82rer les points fictifs (les siens et *)\r
+(* ceux de l'adversaire). *)\r
+(* *)\r
+(* La troisi\8ame phase consiste \85 s\82parer cette liste unique en 10 listes *)\r
+(* distinctes, qui caract\82risent chacune une caract\82ristique principale *)\r
+(* de la case (ex: cases obligatoirement gagnantes, points fictifs etc...).*)\r
+(* Les listes ne sont pas class\82es dans le m\88me ordre selon la strat\82gie *)\r
+(* choisie pour l'ordinateur (attaque, normal ou d\82fense). Une *)\r
+(* caract\82riqtique peut \88tre essentielle pour une strat\82gie, et secondaire *)\r
+(* pour une autre. *)\r
+(* *)\r
+(* La quatri\8ame phase consiste \85 trier chacune des 10 listes sur le *)\r
+(* coefficient croissant des cases qui y sont pr\82sentes. *)\r
+(* *)\r
+(* La cinqui\8ame phase consiste \85 trier dans chacune des 10 listes les *)\r
+(* cases qui ont le m\88me coefficient. On attribue alors aux cases qui ont *)\r
+(* le m\88me coefficient une valeur qui est la somme des caract\82ristiques de *)\r
+(* la case. Le tri se fait alors sur cette valeur entre les cases *)\r
+(* concern\82es. Ceci permet d'ordonner des cases qui ont en apparence des *)\r
+(* caract\82ristiques \82gales. *)\r
+(* *)\r
+(* La sixi\8ame phase consiste \85 concat\82ner les 10 listes pour former une *)\r
+(* liste unique. Cette liste ainsi constitu\82e contient en son premier *)\r
+(* la case la moins bonne \85 jouer, et en dernier \82l\82ment la case la *)\r
+(* meilleure. *)\r
+(* *)\r
+(* La septi\8ame phase consiste \85 choisir une cases parmi la liste. Ceci *)\r
+(* est fonction du pourcentage d'intelligence attribu\82 \85 l'ordinateur. Si *)\r
+(* celui-ci est r\82gl\82 sur 100% alors il choisira la derni\8are case de la *)\r
+(* liste, c'est \85 dire la meilleure. *)\r
+(***---------------------------------------------------------------------***)\r
+(* ALGORITHME SIMPLIFIE DE STRATEGIE DE L'ORDINATEUR\r
+ -------------------------------------------------\r
+ NB : taille = nombre de lignes et de colonnes\r
+\r
+POUR colonne de 1 \85 taille FRE\r
+POUR ligne de 1 \85 taille FRE\r
+ placer un pion \85 moi aux coordonn\82es (ligne,colonne)\r
+ calculer la valeur offensive des lignes horizontales\r
+ possibles \85 partir de cette case\r
+ calculer la valeur offensive des\r
+ lignes verticales possibles \85 partir de cette case\r
+ calculer la valeur offensive des lignes\r
+ diagonales \ possibles \85 partir de cette case\r
+ calculer la valeur offensive des\r
+ lignes diagonales / possibles \85 partir de cette case\r
+ faire la somme pour trouver le coefficient offensif de la case\r
+ rechercher les caract\82ristiques offensives particuli\8ares de cette case\r
+ placer un pion ennemi aux coordonn\82es (ligne,colonne)\r
+ calculer la valeur offensive des lignes horizontales\r
+ possibles \85 partir de cette case\r
+ calculer la valeur offensive des lignes verticales\r
+ possibles \85 partir de cette case\r
+ calculer la valeur offensive des lignes\r
+ diagonales \ possibles \85 partir de cette case\r
+ calculer la valeur offensive des lignes\r
+ diagonales / possibles \85 partir de cette case\r
+ faire la somme pour trouver le coefficient d\82fensif de la case\r
+ rechercher les caract\82ristiques d\82fensives particuli\8ares de cette case\r
+ attribuer au coefficient de la case la\r
+ somme des coefficients offensifs et d\82fensifs\r
+ enlever le pion aux coordonn\82es (ligne,colonne)\r
+ FPOUR\r
+FPOUR\r
+\r
+ Chercher nos points fictifs\r
+\r
+ Chercher les points fictifs ennemis\r
+\r
+ Chercher les points fictifs les meilleurs\r
+\r
+ POUR colonne de 1 \85 taille FRE\r
+ POUR ligne de 1 \85 taille FRE\r
+ Calculer la valeur attribu\82e aux caract\82ristiques\r
+ de la case (ligne,colonne)\r
+ Placer cette case dans la liste correspondant\r
+ \85 cette valeur parmi les 10 possibles\r
+ FPOUR\r
+ FPOUR\r
+\r
+ POUR liste de 0 \85 9 FRE\r
+ trier la liste sur le coefficient des cases qui y sont pr\82sentes\r
+ FPOUR\r
+\r
+ POUR liste de 0 \85 9 FRE\r
+ Trier les \82l\82ments de m\88me coefficient de la liste \82tudi\82e\r
+ FPOUR\r
+\r
+ POUR liste de 0 \85 9 FRE\r
+ Ajouter la liste \85 la liste unique\r
+ FPOUR\r
+\r
+ Choisir une case parmi la liste\r
+\r
+*)\r
+\r
+unit STRA : procedure;\r
+\r
+ (* Calcul des possibilit\82s de la case (j,i) *)\r
+ unit calculer_strategie : procedure;\r
+ begin\r
+ if poss.tab(j,i).coef = 0 then\r
+\r
+\r
+\r
+ (* on n'\82tudie que les cases vides *)\r
+ IF TAB_PION.TAB(j,i) = 0 THEN\r
+\r
+ nb_dangers := 0; (* initialisation des caract\82ristiques de la case *)\r
+ nb_dangers2 := 0;\r
+ nb_dangers3 := 0;\r
+\r
+ TAB_PION.TAB(j,i) := player; (* placer un pion sur cette case *)\r
+\r
+ coeftempo2 := 0; (* coefficient de la case = 0 avant les calculs *)\r
+\r
+ IF (align<>4) OR (coup<>3) THEN\r
+(*--------------------------------- HORIZONTALES -------------------------*)\r
+\r
+ (* initialisation des caract\82ristiques des lignes horizontales *)\r
+ nbpions := 0;\r
+ nbvides := 0;\r
+ k := i;\r
+ l := j;\r
+ coeftempo := 0;\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+(*parcourir toutes les positions possibles du pion dans la ligne potentielle*)\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF i-m>0 THEN\r
+ (* parcourir toute la longueur de la ligne potentielle *)\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ (* lire le pion pr\82sent \85 dcet endroit *)\r
+ pionlu := TAB_PION.TAB(j,i-m+n);\r
+ (* si c'est \85 nous : 1 pion de plus *)\r
+ IF pionlu = player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=3-player) THEN\r
+ (* si c'est un bord ou un pion ennemi on arr\88te *)\r
+ arret := TRUE;\r
+ FI;\r
+ ELSE (* if not arret *)\r
+ exit;\r
+ FI;\r
+\r
+ OD; (* passer au pion suivant *)\r
+(* si on s'est arr\88t\82 on consid\8are que la ligne fait 0 pions de longueur *)\r
+ IF arret THEN\r
+ nbpions := 0\r
+ ELSE\r
+ (* d\82tecter si la ligne est bloqu\82e d'un c\93t\82 ou de l'autre *)\r
+ IF ((TAB_PION.TAB(j,i-m)=0) AND (TAB_PION.TAB(j,i-m+align)=0))\r
+ OR ((TAB_PION.TAB(j,i-m-1)=0) AND (TAB_PION.TAB(j,i-m+align-1)=0)) THEN\r
+ (* la ligne n'est pas bloqu\82e *)\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI; (* if arret *)\r
+ FI; (* bug *)\r
+ (* rechercher le coefficient de la possibilit\82 actuelle *)\r
+ POSS.TAB(j,i).attaque := 0;\r
+ call ajcoefs (m,i,j,nbpions,nb_dangers,nb_dangers2,nb_dangers3,\r
+ ouv1,ouv2,ad1,ad2,ad3);\r
+ (* l'ajouter au coefficient de d\82fense *)\r
+ coeftempo := coeftempo + POSS.TAB(j,i).attaque;\r
+ OD;\r
+ (* passer \85 la position suivante du pion dans la ligne potentielle *)\r
+ coeftempo2 := coeftempo;\r
+ (* mettre le coef trouv\82 dans le coefficient d'attaque temporaire *)\r
+(*--------------------------------- VERTICALES ----------------------------*)\r
+\r
+ coeftempo := 0;\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF j-m>0 THEN\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j-m+n,i);\r
+ IF pionlu = player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=3-player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ ELse exit;\r
+ FI;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j-m,i)=0) AND (TAB_PION.TAB(j-m+align,i)=0))\r
+ OR ((TAB_PION.TAB(j-m-1,i)=0) AND (TAB_PION.TAB(j-m+align-1,i)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ POSS.TAB(j,i).attaque := 0;\r
+ call ajcoefs(m,i,j,nbpions,nb_dangers,\r
+ nb_dangers2,nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+ coeftempo := coeftempo + POSS.TAB(j,i).attaque;\r
+\r
+ OD;\r
+ coeftempo2 := coeftempo2 + coeftempo;\r
+ FI; (* if align <> 4 *)\r
+(*--------------------------------- DIAGONALES \ -------------------------*)\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ coeftempo := 0;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF (j-m>0) AND (i-m>0) THEN\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j-m+n,i-m+n);\r
+ IF pionlu = player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=3-player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ else exit;\r
+ fi;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0;\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j-m,i-m)=0) AND (TAB_PION.TAB(j-m+align,i-m+align)=0))\r
+ OR ((TAB_PION.TAB(j-m-1,i-m-1)=0)\r
+ AND (TAB_PION.TAB(j-m+align-1,i-m+align-1)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ POSS.TAB(j,i).attaque := 0;\r
+ call ajcoefs(m,i,j,nbpions,nb_dangers,nb_dangers2,\r
+ nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+ coeftempo := coeftempo + POSS.TAB(j,i).attaque;\r
+ OD;\r
+ coeftempo2 := coeftempo2 + coeftempo;\r
+(*--------------------------------- DIAGONALES / -------------------------*)\r
+\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ coeftempo := 0;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF (j-m>0) AND (i+m<=taille)\r
+ (*\r
+ AND (i+m-align+1>=0)\r
+ AND (j-m+align-1>=0) *)THEN (* nouveau *)\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j-m+n,i+m-n);\r
+ IF pionlu = player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=3-player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ else exit;\r
+ FI;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j-m,i+m)=0) AND (TAB_PION.TAB(j-m+align,i+m-align)=0))\r
+ OR ((TAB_PION.TAB(j-m-1,i+m+1)=0)\r
+ AND (TAB_PION.TAB(j-m+align-1,i+m-align+1)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ POSS.TAB(j,i).attaque := 0;\r
+ call ajcoefs(m,i,j,nbpions,nb_dangers,nb_dangers2,\r
+ nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+ coeftempo := coeftempo + POSS.TAB(j,i).attaque;\r
+ OD;\r
+ coeftempo2 := coeftempo2 + coeftempo;\r
+ (* coefficient d'attaque g\82n\82ral = somme de tous les coefs d'attaque *)\r
+ POSS.TAB(j,i).attaque := coeftempo2;\r
+\r
+(* recherche des caract\82ristiques particuli\8ares de la case *)\r
+\r
+ IF (nb_dangers>=1) THEN\r
+ (* attaque potentiellement gagnante en 2 coups *)\r
+ POSS.TAB(j,i).att_gagnante_2 := TRUE;\r
+ FI;\r
+ IF nb_dangers2>=2 THEN\r
+ POSS.TAB(j,i).att_gagnante_3o := TRUE;\r
+ FI;\r
+ IF (nb_dangers2>=1) THEN\r
+ POSS.TAB(j,i).att_reste2ouv := TRUE;\r
+ POSS.TAB(j,i).att_gagnante_3 := TRUE;\r
+ FI;\r
+\r
+(* APPLICATION DE LA strategie \85 l'ennemi *)\r
+ nb_dangers := 0;\r
+ nb_dangers2 := 0;\r
+ nb_dangers3 := 0;\r
+\r
+ TAB_PION.TAB(j,i) := 3-player; (* placer un pion adverse *)\r
+\r
+\r
+(*--------------------------------- HORIZONTALES -------------------------*)\r
+ nbpions := 0;\r
+ nbvides := 0;\r
+\r
+ k := i;\r
+ l := j;\r
+\r
+ coeftempo2 := 0;\r
+ coeftempo := 0;\r
+\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF i-m>0 THEN\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j,i-m+n);\r
+ IF pionlu = 3-player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ else\r
+ exit;\r
+ FI;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j,i-m)=0) AND (TAB_PION.TAB(j,i-m+align)=0))\r
+ OR ((TAB_PION.TAB(j,i-m-1)=0)\r
+ AND (TAB_PION.TAB(j,i-m+align-1)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ POSS.TAB(j,i).defense := 0;\r
+ call ajcoefsdef(m,i,j,nbpions,nb_dangers,nb_dangers2,\r
+ nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+\r
+ coeftempo := coeftempo + POSS.TAB(j,i).defense;\r
+ OD;\r
+ coeftempo2 := coeftempo2 + coeftempo;\r
+(*--------------------------------- VERTICALES ----------------------------*)\r
+\r
+ coeftempo := 0;\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF j-m>0 THEN\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j-m+n,i);\r
+ IF pionlu = 3-player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ else exit;\r
+ FI;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0;\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j-m,i)=0) AND (TAB_PION.TAB(j-m+align,i)=0))\r
+ OR ((TAB_PION.TAB(j-m-1,i)=0) AND (TAB_PION.TAB(j-m+align-1,i)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI; (* if arret *)\r
+ FI; (* if j-m *)\r
+ POSS.TAB(j,i).defense := 0;\r
+ call ajcoefsdef(m,i,j,nbpions,nb_dangers,nb_dangers2,\r
+ nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+ coeftempo := coeftempo + POSS.TAB(j,i).defense;\r
+\r
+ OD; (* for m *)\r
+ coeftempo2 := coeftempo2 + coeftempo;\r
+(*--------------------------------- DIAGONALES \ -------------------------*)\r
+\r
+ coeftempo := 0;\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF (j-m>0) AND (i-m>0) THEN\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j-m+n,i-m+n);\r
+ IF pionlu = 3-player THEN\r
+ nbpions := nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ else exit;\r
+ FI;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0;\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j-m,i-m)=0) AND (TAB_PION.TAB(j-m+align,i-m+align)=0))\r
+ OR ((TAB_PION.TAB(j-m-1,i-m-1)=0)\r
+ AND (TAB_PION.TAB(j-m+align-1,i-m+align-1)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI; (* if arret *)\r
+ FI; (* if j-m *)\r
+ POSS.TAB(j,i).defense := 0;\r
+ call ajcoefsdef(m,i,j,nbpions,nb_dangers,nb_dangers2,\r
+ nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+ coeftempo := coeftempo + POSS.TAB(j,i).defense;\r
+ OD; (* for m *)\r
+ coeftempo2 := coeftempo2 + coeftempo;\r
+\r
+(*--------------------------------- DIAGONALES / -------------------------*)\r
+\r
+ coeftempo := 0;\r
+ ad1 := FALSE;\r
+ ad2 := FALSE;\r
+ ad3 := FALSE;\r
+ FOR m:=0 TO align-1 DO\r
+ nbpions := 0;\r
+ arret := FALSE;\r
+ ouv1 := FALSE;\r
+ ouv2 := FALSE;\r
+ IF (j-m>0) AND (i+m<=taille)\r
+ (* AND (i+m-align+1>=0)\r
+ AND (j-m+align-1>=0)*) THEN (* nouveau *)\r
+\r
+ FOR n:=0 TO align-1 DO\r
+ IF NOT arret THEN\r
+ pionlu := TAB_PION.TAB(j-m+n,i+m-n);\r
+ IF pionlu = 3-player THEN\r
+ nbpions:=nbpions + 1;\r
+ FI;\r
+ IF (pionlu = 255) OR (pionlu=player) THEN\r
+ arret := TRUE;\r
+ FI;\r
+ else exit;\r
+ FI;\r
+ OD;\r
+ IF arret THEN\r
+ nbpions := 0\r
+ ELSE\r
+ IF ((TAB_PION.TAB(j-m,i+m)=0) AND (TAB_PION.TAB(j-m+align,i+m-align)=0))\r
+ OR ((TAB_PION.TAB(j-m-1,i+m+1)=0)\r
+ AND (TAB_PION.TAB(j-m+align-1,i+m-align+1)=0)) THEN\r
+ ouv1 := TRUE;\r
+ ouv2 := TRUE;\r
+ FI;\r
+ FI; (* if arret *)\r
+ FI; (* if j-m *)\r
+ POSS.TAB(j,i).defense := 0;\r
+ call ajcoefsdef(m,i,j,nbpions,nb_dangers,nb_dangers2,\r
+ nb_dangers3,ouv1,ouv2,ad1,ad2,ad3);\r
+ coeftempo := coeftempo + POSS.TAB(j,i).defense;\r
+ OD; (* for m *)\r
+ coeftempo2:= coeftempo2 + coeftempo;\r
+\r
+\r
+ (* coefficient de d\82fense g\82n\82ral = coefficient d'attaque pour l'ennemi *)\r
+ POSS.TAB(j,i).defense := coeftempo2;\r
+(* Recherche des caract\82ristiques particuli\8ares de la case *)\r
+\r
+ IF (nb_dangers>=1) THEN\r
+ POSS.TAB(j,i).def_gagnante_2 := TRUE;\r
+ FI;\r
+ IF nb_dangers2>=2 THEN\r
+ POSS.TAB(j,i).def_gagnante_3o := TRUE;\r
+ FI;\r
+ IF (nb_dangers2>=1) THEN\r
+ POSS.TAB(j,i).def_reste2ouv := TRUE;\r
+ POSS.TAB(j,i).def_gagnante_3 := TRUE;\r
+ FI;\r
+ IF (nb_dangers3>=3) THEN\r
+ POSS.TAB(j,i).def_gagnante_3 := TRUE;\r
+ FI;\r
+\r
+ (* coef g\82n\82ral de la case = coef d'attaque + coef de d\82fense *)\r
+ POSS.TAB(j,i).coef := POSS.TAB(j,i).attaque+POSS.TAB(j,i).defense;\r
+ (* enlevier le pion adverse de la case *)\r
+ TAB_PION.TAB(j,i):= 0;\r
+ ELSE\r
+ FI; (* if tab *)\r
+(* OD;*) (* for j *)\r
+ Else (* nouveau *)\r
+ if stratype=2 then\r
+ memoire (player,essais).x := 0;\r
+ memoire (player,essais).y := 0;\r
+ fi;\r
+ FI;\r
+\r
+ end ;\r
+VAR\r
+ i,j,k,l,m,n,essais,essaismax : INTEGER,\r
+ nbpions : INTEGER,\r
+ nbvides : INTEGER,\r
+ nbtri : integer,\r
+ (*nombre de lignes ouvertes reste 1 ou 2*)\r
+ nb_dangers,nb_dangers2,nb_dangers3 :INTEGER,\r
+ ouv1,ouv2 : BOOLEAN,\r
+ fin : BOOLEAN,\r
+ pionlu, nbpionslocal : INTEGER,\r
+ arret : BOOLEAN,\r
+ ad1,ad2,ad3 : BOOLEAN,\r
+ ind,ind_courant,ind_mini : INTEGER,\r
+ minimum,mini_coef,mini_coefsomm : INTEGER,\r
+ mini_x,mini_y,mini_attaquant : INTEGER,\r
+ coeftempo : INTEGER,\r
+ coeftempo2 : INTEGER;\r
+BEGIN\r
+\r
+ call AFF_TEXTE_INDICE;\r
+\r
+ (* Initialisation de la m\82moire de l'ordinateur en cas de strat\82gie rapide *)\r
+ essaismax := 16+maxmem;\r
+ memoire(player,maxmem+1).x := xjoue2-1;\r
+ memoire(player,maxmem+1).y := yjoue2;\r
+ memoire(player,maxmem+2).x := xjoue2+1;\r
+ memoire(player,maxmem+2).y := yjoue2;\r
+ memoire(player,maxmem+3).x := xjoue2;\r
+ memoire(player,maxmem+3).y := yjoue2-1;\r
+ memoire(player,maxmem+4).x := xjoue2;\r
+ memoire(player,maxmem+4).y := yjoue2+1;\r
+ memoire(player,maxmem+5).x := xjoue2-1;\r
+ memoire(player,maxmem+5).y := yjoue2-1;\r
+ memoire(player,maxmem+6).x := xjoue2-1;\r
+ memoire(player,maxmem+6).y := yjoue2+1;\r
+ memoire(player,maxmem+7).x := xjoue2+1;\r
+ memoire(player,maxmem+7).y := yjoue2+1;\r
+ memoire(player,maxmem+8).x := xjoue2+1;\r
+ memoire(player,maxmem+8).y := yjoue2-1;\r
+ memoire(player,maxmem+9).x := xjoue3-1;\r
+ memoire(player,maxmem+9).y := yjoue3;\r
+ memoire(player,maxmem+10).x := xjoue3+1;\r
+ memoire(player,maxmem+10).y := yjoue3;\r
+ memoire(player,maxmem+11).x := xjoue3;\r
+ memoire(player,maxmem+11).y := yjoue3-1;\r
+ memoire(player,maxmem+12).x := xjoue3;\r
+ memoire(player,maxmem+12).y := yjoue3+1;\r
+ memoire(player,maxmem+13).x := xjoue3-1;\r
+ memoire(player,maxmem+13).y := yjoue3-1;\r
+ memoire(player,maxmem+14).x := xjoue3+1;\r
+ memoire(player,maxmem+14).y := yjoue3-1;\r
+ memoire(player,maxmem+15).x := xjoue3+1;\r
+ memoire(player,maxmem+15).y := yjoue3+1;\r
+ memoire(player,maxmem+16).x := xjoue3-1;\r
+ memoire(player,maxmem+16).y := yjoue3+1;\r
+ if marge=2 then\r
+ memoire(player,maxmem+17).x := xjoue2-2;\r
+ memoire(player,maxmem+17).y := yjoue2;\r
+ memoire(player,maxmem+18).x := xjoue2+2;\r
+ memoire(player,maxmem+18).y := yjoue2;\r
+ memoire(player,maxmem+19).x := xjoue2;\r
+ memoire(player,maxmem+19).y := yjoue2-2;\r
+ memoire(player,maxmem+20).x := xjoue2;\r
+ memoire(player,maxmem+20).y := yjoue2+2;\r
+ memoire(player,maxmem+21).x := xjoue2-2;\r
+ memoire(player,maxmem+21).y := yjoue2-2;\r
+ memoire(player,maxmem+22).x := xjoue2-2;\r
+ memoire(player,maxmem+22).y := yjoue2+2;\r
+ memoire(player,maxmem+23).x := xjoue2+2;\r
+ memoire(player,maxmem+23).y := yjoue2+2;\r
+ memoire(player,maxmem+24).x := xjoue2+2;\r
+ memoire(player,maxmem+24).y := yjoue2-2;\r
+ memoire(player,maxmem+25).x := xjoue3-2;\r
+ memoire(player,maxmem+25).y := yjoue3;\r
+ memoire(player,maxmem+26).x := xjoue3+2;\r
+ memoire(player,maxmem+26).y := yjoue3;\r
+ memoire(player,maxmem+27).x := xjoue3;\r
+ memoire(player,maxmem+27).y := yjoue3-2;\r
+ memoire(player,maxmem+28).x := xjoue3;\r
+ memoire(player,maxmem+28).y := yjoue3+2;\r
+ memoire(player,maxmem+29).x := xjoue3-2;\r
+ memoire(player,maxmem+29).y := yjoue3-2;\r
+ memoire(player,maxmem+30).x := xjoue3+2;\r
+ memoire(player,maxmem+30).y := yjoue3-2;\r
+ memoire(player,maxmem+31).x := xjoue3+2;\r
+ memoire(player,maxmem+31).y := yjoue3+2;\r
+ memoire(player,maxmem+32).x := xjoue3-2;\r
+ memoire(player,maxmem+32).y := yjoue3+2;\r
+ essaismax := 32+maxmem;\r
+ fi;\r
+\r
+\r
+ (* parcourir toutes les lignes de la grille de jeu *)\r
+\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+\r
+ IF TAB_PION.TAB(j,i) = 0 THEN\r
+ poss.tab(j,i).att_reste1 := false;\r
+ poss.tab(j,i).def_reste1 := false;\r
+ poss.tab(j,i).att_reste2ouv := false;\r
+ poss.tab(j,i).def_reste2ouv := false;\r
+ poss.tab(j,i).att_gagnante := false;\r
+ poss.tab(j,i).def_gagnante := false;\r
+ poss.tab(j,i).att_gagnante_2 := false;\r
+ poss.tab(j,i).def_gagnante_2 := false;\r
+ poss.tab(j,i).att_gagnante_3 := false;\r
+\r
+ poss.tab(j,i).att_gagnante_3o := false;\r
+ poss.tab(j,i).def_gagnante_3 := false;\r
+ poss.tab(j,i).def_gagnante_3o := false;\r
+ poss.tab(j,i).attaquant := 0;\r
+ poss.tab(j,i).contre_attaque := false;\r
+ poss.tab(j,i).contre_defense := false;\r
+ poss.tab(j,i).contre_attaque2 := false;\r
+ poss.tab(j,i).coefsomm := 0;\r
+ poss.tab(j,i).coef := 0;\r
+\r
+ FI;\r
+ OD;\r
+ OD;\r
+\r
+\r
+ if stratype=1 then\r
+ FOR j:=1 TO taille DO\r
+ (* afficher la souris pour ne pas qu'elle paraisse bloqu\82e *)\r
+ call showcursor;\r
+ (* parcourir toutes les colonnes *)\r
+ FOR i:=1 TO taille DO\r
+ call AFF_INDICE (j,i);\r
+ call calculer_strategie;\r
+ OD;\r
+ OD;\r
+\r
+ fi;\r
+ if stratype=2 then\r
+ call showcursor;\r
+ FOR essais := 1 to essaismax DO\r
+ call AFF_INDICE2 (essais,essaismax);\r
+ i := memoire(player,essais).x;\r
+ j := memoire(player,essais).y;\r
+ IF i>0 and j>0 and i<=taille and j<=taille then\r
+\r
+ call calculer_strategie;\r
+ FI;\r
+ OD;\r
+ fi;\r
+\r
+\r
+\r
+ fin := FALSE;\r
+\r
+(* adjonction d'informations par d\82faut *)\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ IF TAB_PION.TAB(j,i)=0 THEN\r
+ POSS.TAB(j,i).attaquant := attaquant;\r
+ FI;\r
+ OD;\r
+ OD;\r
+\r
+(* calcul des cas particuliers *)\r
+ call cal_ctr_attq (fin);\r
+ call cal_ctr_attq2 (fin);\r
+ call cal_ctr_def (fin);\r
+\r
+(* initialisation du tableau des possibilit\82s *)\r
+ FOR i:=0 TO 9\r
+ DO\r
+ megaliste2.TAB(i).nb_elem := 0;\r
+ OD;\r
+\r
+(* r\82partition par classe ( les 10 listes primaires ) *)\r
+ FOR j:=1 TO taille DO\r
+ FOR i:=1 TO taille DO\r
+ IF TAB_PION.TAB(j,i)=0 THEN\r
+ call calcposs (i,j);\r
+ m := megaliste2.TAB(sommposs).nb_elem+1;\r
+ megaliste2.TAB(sommposs).nb_elem := m;\r
+ megaliste2.TAB(sommposs).t(m).x := i;\r
+ megaliste2.TAB(sommposs).t(m).y := j;\r
+ megaliste2.TAB(sommposs).t(m).coef := POSS.TAB(j,i).coef;\r
+ megaliste2.TAB(sommposs).t(m).coefsomm := sommposs;\r
+ megaliste2.TAB(sommposs).t(m).attaquant := POSS.TAB(j,i).attaquant;\r
+ FI;\r
+ OD;\r
+ OD;\r
+\r
+(* calcul du nombre total d'\82l\82ments par classe *)\r
+ n := 0;\r
+ FOR i:=0 TO 9\r
+ DO\r
+ n:= n + megaliste2.TAB(i).nb_elem;\r
+ OD;\r
+\r
+ nbtri := 0;\r
+\r
+(* tri sur le coefficient croissant dans chacune des 10 classes *)\r
+\r
+ FOR k:=9 DOWNTO 0\r
+ DO\r
+ call QUICK_SORT (k,1,megaliste2.TAB(k).nb_elem);\r
+ OD;\r
+\r
+\r
+(* s\82paration des possibilit\82s \85 coeficients \82gaux *)\r
+ FOR k:=3 TO 9\r
+ DO\r
+ i := 1;\r
+ WHILE i<=megaliste2.TAB(k).nb_elem DO\r
+ coefsomm := megaliste2.TAB(k).t(i).coefsomm;\r
+ coef := megaliste2.TAB(k).t(i).coef;\r
+ j := i;\r
+ i:=i+1;\r
+ WHILE (megaliste2.TAB(k).t(i).coefsomm=coefsomm)\r
+ AND (megaliste2.TAB(k).t(i).coef=coef)\r
+ AND (i<=megaliste2.TAB(k).nb_elem) DO\r
+ call calcsommposs (megaliste2.TAB(k).t(i).x,\r
+ megaliste2.TAB(k).t(i).y);\r
+ megaliste2.TAB(k).t(i).coefsomm := sommposs;\r
+ i := i + 1;\r
+ OD;\r
+\r
+ IF i>j+1 THEN\r
+ call calcsommposs (megaliste2.TAB(k).t(j).x,\r
+ megaliste2.TAB(k).t(j).y);\r
+ megaliste2.TAB(k).t(j).coefsomm := sommposs;\r
+\r
+ FOR ind:=j TO i-2 DO\r
+ minimum := megaliste2.TAB(k).t(ind).coefsomm;\r
+ mini_x := megaliste2.TAB(k).t(ind).x;\r
+ mini_y := megaliste2.TAB(k).t(ind).y;\r
+ mini_coef := megaliste2.TAB(k).t(ind).coef;\r
+ mini_attaquant := megaliste2.TAB(k).t(ind).attaquant;\r
+ ind_mini := ind;\r
+ FOR ind_courant := ind TO i-1 DO\r
+ IF megaliste2.TAB(k).t(ind_courant).coefsomm < minimum THEN\r
+ minimum := megaliste2.TAB(k).t(ind_courant).coefsomm;\r
+ mini_x := megaliste2.TAB(k).t(ind_courant).x;\r
+ mini_y := megaliste2.TAB(k).t(ind_courant).y;\r
+ mini_coef := megaliste2.TAB(k).t(ind_courant).coef;\r
+ mini_attaquant := megaliste2.TAB(k).t(ind_courant).attaquant;\r
+ ind_mini := ind_courant;\r
+ FI;\r
+ OD;\r
+ IF ind_mini <> ind THEN\r
+ megaliste2.TAB(k).t(ind_mini).coefsomm :=\r
+ megaliste2.TAB(k).t(ind).coefsomm;\r
+ megaliste2.TAB(k).t(ind_mini).x :=\r
+ megaliste2.TAB(k).t(ind).x;\r
+ megaliste2.TAB(k).t(ind_mini).y :=\r
+ megaliste2.TAB(k).t(ind).y;\r
+ megaliste2.TAB(k).t(ind_mini).coef :=\r
+ megaliste2.TAB(k).t(ind).coef;\r
+ megaliste2.TAB(k).t(ind_mini).attaquant :=\r
+ megaliste2.TAB(k).t(ind).attaquant;\r
+ megaliste2.TAB(k).t(ind).coefsomm := minimum;\r
+ megaliste2.TAB(k).t(ind).coef := mini_coef;\r
+ megaliste2.TAB(k).t(ind).attaquant := mini_attaquant;\r
+ megaliste2.TAB(k).t(ind).x := mini_x;\r
+ megaliste2.TAB(k).t(ind).y := mini_y;\r
+ FI; (* if ind_mini *)\r
+ OD; (* for ind *)\r
+ FI;\r
+ OD;\r
+ OD;\r
+\r
+\r
+(* pr\82paration de la liste finale \85 partir des 10 listes primaires *)\r
+ m := 0;\r
+ FOR k:=0 TO 9 DO\r
+ FOR i:=1 TO megaliste2.TAB(k).nb_elem DO\r
+ m:=m+1;\r
+ megaliste.TAB(m).x := megaliste2.TAB(k).t(i).x;\r
+ megaliste.TAB(m).y := megaliste2.TAB(k).t(i).y;\r
+ megaliste.TAB(m).coef := megaliste2.TAB(k).t(i).coef;\r
+ megaliste.TAB(m).coefsomm := megaliste2.TAB(k).t(i).coefsomm;\r
+ megaliste.TAB(m).attaquant := megaliste2.TAB(k).t(i).attaquant;\r
+ OD;\r
+ OD;\r
+\r
+\r
+\r
+\r
+(* choix d'une possibilit\82 si joueur = cpu *)\r
+ nbcases := n;\r
+ xjoue := megaliste.TAB(n).x;\r
+ yjoue := megaliste.TAB(n).y;\r
+ fin := true;\r
+ IF (joueur.tab(player)=2) AND (stratype=1) THEN\r
+ fin := FALSE;\r
+ j := int.tab(player);\r
+ DO\r
+ i := RANDOM*100/j;\r
+ IF i=0 THEN\r
+ xjoue := megaliste.TAB(n).x;\r
+ yjoue := megaliste.TAB(n).y;\r
+ IF megaliste.TAB(n).attaquant<>0 THEN\r
+ attaquant := megaliste.TAB(n).attaquant;\r
+ FI;\r
+ fin := TRUE;\r
+ FI;\r
+ j:=j+1;\r
+ n:=n-1;\r
+ IF fin OR (n=0) THEN\r
+ exit;\r
+ FI;\r
+ OD;\r
+ (* si rien de choisi alors on prends la plus mauvaise possibilit\82 *)\r
+ IF NOT fin THEN\r
+ xjoue := megaliste.TAB(1).x;\r
+ yjoue := megaliste.TAB(1).y;\r
+ IF megaliste.TAB(1).attaquant<>0 THEN\r
+ attaquant := megaliste.TAB(1).attaquant;\r
+ FI;\r
+ FI;\r
+ FI;\r
+ m := maxmem;\r
+ if m>nbcases then\r
+ m := nbcases;\r
+ fi;\r
+ for i:=1 to m do\r
+ memoire(player,i).x := megaliste.tab(nbcases-i+1).x;\r
+ memoire(player,i).y := megaliste.tab(nbcases-i+1).y;\r
+ od;\r
+ call EFF_TEXTE_INDICE;\r
+END STRA;\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* CHERCHER_GAGNANT *)\r
+(***---------------------------------------------------------------------***)\r
+(* D\82tection de la ligne compl\8ate, dont le dernier pion jou\82 fais partie. *)\r
+(* Renvoie un bool\82en VRAI si une ligne compl\8ate est d\82tect\82e. *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit chercher_gagnant : function : boolean;\r
+VAR\r
+ nbpions : INTEGER, (* taille de la ligne trouv\82e *)\r
+ pion : INTEGER, (* valeur du pion lu *)\r
+ x,y,i,j : INTEGER, (* coordonn\82es dans la grille *)\r
+ bouba : boolean,\r
+ newplayer : INTEGER;\r
+BEGIN\r
+ bouba := false;\r
+\r
+ newplayer := player;\r
+ x := xjoue2; (* coordonn\82es du dernier pion jou\82 *)\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ (* recherche d'une ligne horizontale *)\r
+ do\r
+ call INC (nbpions,1);\r
+ call INC (x,1); (* parcourir vers la droite *)\r
+ IF tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+\r
+Od;\r
+ x := xjoue2; (* revenir \85 la position initiale *)\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,-1); (* parcourir vers la gauche *)\r
+ IF tab_pion.tab(y,x)<>newplayer THEN exit;\r
+ FI;\r
+OD;\r
+ IF nbpions > align THEN (* si la ligne est compl\8ate *)\r
+ bouba := true;\r
+ FI;\r
+ x := xjoue2; (* revenir aux coordonn\82es initiales *)\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ DO (* recherche d'une ligne verticale *)\r
+ call INC (nbpions,1);\r
+ call INC (y,1); (* parcourir vers le bas *)\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ y := yjoue2;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (y,-1); (* parcourir vers le haut *)\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ IF nbpions > align THEN\r
+ bouba := true;\r
+ FI;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ DO (* recherche des diagonales *)\r
+ call INC (nbpions,1);\r
+ call INC (x,1);\r
+ call INC (y,1);\r
+ IF tab_pion.tab(y,x)<>newplayer then exit ;\r
+ FI;\r
+ OD;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,-1);\r
+ call INC (y,-1);\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ IF nbpions > align THEN\r
+ bouba := true;\r
+ FI;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,1);\r
+ call INC (y,-1);\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,-1);\r
+ call INC (y,1);\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ fi;\r
+ OD;\r
+ IF nbpions > align THEN\r
+ bouba := true;\r
+ FI;\r
+ result := bouba;\r
+END chercher_gagnant;\r
+\r
+\r
+\r
+(***---------------------------------------------------------------------***)\r
+(* DETECTER_LIGNE *)\r
+(***---------------------------------------------------------------------***)\r
+(* D\82tection de la ligne compl\8ate, dont le dernier pion jou\82 fais partie. *)\r
+(* Le lignes contenant un surplus de pions, et les lignes compl\8ates *)\r
+(* crois\82es sont d\82tect\82es. Les lignes trouv\82es sont affich\82es ombr\82es. *)\r
+(***---------------------------------------------------------------------***)\r
+\r
+unit detecter_ligne : procedure;\r
+VAR\r
+ nbpions : INTEGER, (* taille de la ligne trouv\82e *)\r
+ pion : INTEGER, (* valeur du pion lu *)\r
+ x,y,i,j : INTEGER, (* coordonn\82es dans la grille *)\r
+ fin : BOOLEAN,\r
+ tab2 : ARRAYOF ARRAYOF INTEGER,\r
+ newplayer : INTEGER;\r
+BEGIN\r
+ array tab2 dim (1:12);\r
+ for i := 1 to 12 do\r
+ array tab2(i) dim (1:12);\r
+ for j := 1 to 12 do\r
+ tab2(i,j) := 0 ;\r
+ OD;\r
+ OD;\r
+\r
+ newplayer := 3-player;\r
+ x := xjoue2; (* coordonn\82es du dernier pion jou\82 *)\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ (* recherche d'une ligne horizontale *)\r
+ do\r
+ call INC (nbpions,1);\r
+ call INC (x,1); (* parcourir vers la droite *)\r
+ IF tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+\r
+Od;\r
+ x := xjoue2; (* revenir \85 la position initiale *)\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,-1); (* parcourir vers la gauche *)\r
+ IF tab_pion.tab(y,x)<>newplayer THEN exit;\r
+ FI;\r
+OD;\r
+ IF nbpions > align THEN (* si la ligne est compl\8ate *)\r
+ (* inscrire des 1 dans le nouveau tab_pion.tableau *)\r
+ FOR i:=2 TO nbpions\r
+ DO\r
+ tab2 (x+(i-1),y) := 1;\r
+ OD;\r
+ FI;\r
+ x := xjoue2; (* revenir aux coordonn\82es initiales *)\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ DO (* recherche d'une ligne verticale *)\r
+ call INC (nbpions,1);\r
+ call INC (y,1); (* parcourir vers le bas *)\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ y := yjoue2;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (y,-1); (* parcourir vers le haut *)\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ IF nbpions > align THEN\r
+ FOR i:=2 TO nbpions DO\r
+ tab2 (x,y+(i-1)) := 1;\r
+ OD;\r
+ FI;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ DO (* recherche des diagonales *)\r
+ call INC (nbpions,1);\r
+ call INC (x,1);\r
+ call INC (y,1);\r
+ IF tab_pion.tab(y,x)<>newplayer then exit ;\r
+ FI;\r
+ OD;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,-1);\r
+ call INC (y,-1);\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ IF nbpions > align THEN\r
+ FOR i:=2 TO nbpions DO\r
+ tab2(x+(i-1),y+(i-1)) := 1;\r
+ OD;\r
+ FI;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ nbpions := 0;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,1);\r
+ call INC (y,-1);\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ FI;\r
+ OD;\r
+ x := xjoue2;\r
+ y := yjoue2;\r
+ DO\r
+ call INC (nbpions,1);\r
+ call INC (x,-1);\r
+ call INC (y,1);\r
+ if tab_pion.tab(y,x)<>newplayer then exit;\r
+ fi;\r
+ OD;\r
+ IF nbpions > align THEN\r
+ FOR i:=2 TO nbpions DO\r
+ tab2(x+(i-1),y-(i-1)) := 1;\r
+ OD;\r
+ FI;\r
+ FOR i:=1 TO taille DO\r
+ FOR j:=1 TO taille DO\r
+ (* afficher une case ombr\82e aux emplacements des lignes *)\r
+ IF tab2(i,j) = 1 THEN\r
+ call AFF_CASE (i,j,taille,8,8,newplayer,CHOIX_PION.TAB(newplayer));\r
+ FI;\r
+ OD;\r
+ OD;\r
+END detecter_ligne;\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* VERIFIE_SI_GAGNANT *)\r
+(***---------------------------------------------------------------------***)\r
+(* Si la partie est gagn\82e, affichage de la ligne gagnante en ombr\82. *)\r
+(***************************************************************************)\r
+\r
+unit verifie_si_gagnant : procedure;\r
+begin\r
+ (* si il y a un gagnant *)\r
+ IF partie_gagnee THEN\r
+ (* afficher le gagnant dans le panneau d'informations *)\r
+ call affiche_gagnant;\r
+ (* d\82tecter et afficher la ligne form\82e *)\r
+ call detecter_ligne;\r
+ ELSE IF partie_terminee AND (coup>taille*taille) THEN (* si match nul *)\r
+ call affiche_matchnul;\r
+ FI;\r
+ FI;\r
+end verifie_si_gagnant;\r
+\r
+\r
+\r
+\r
+ (*******************************)\r
+ (* *)\r
+ (* COROUTINES *)\r
+ (* *)\r
+ (*******************************)\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* HUMAN_PLAY *)\r
+(***---------------------------------------------------------------------***)\r
+(* Fais jouer un humain lorsque c'est son tour et qu'il a cliqu\82 sur une *)\r
+(* case. *)\r
+(***************************************************************************)\r
+\r
+unit HUMAN_PLAY : coroutine;\r
+var\r
+alerte : boolean;\r
+BEGIN\r
+ return;\r
+ do\r
+ (* r\82cup\8are les coordonn\82es de jeu *)\r
+ xjoue := entier((mousex-debut_x)/39)+1;\r
+ yjoue := entier((mousey-debut_y)/39)+1;\r
+ (* continuer si la case est libre *)\r
+ IF tab_pion.tab(yjoue,xjoue)=0 THEN\r
+\r
+ xjoue3 := xjoue2;\r
+ yjoue3 := yjoue2;\r
+ xjoue2 := xjoue;\r
+ yjoue2 := yjoue;\r
+\r
+ call case_pleine (xjoue2,yjoue2,taille,player,\r
+ choix_pion.tab(player));\r
+\r
+ (* placer le pion dans la matrice *)\r
+ tab_pion.tab(yjoue2,xjoue2) := player;\r
+\r
+\r
+ jeu.coord(jeu.offset).x := xjoue2;\r
+ jeu.coord(jeu.offset).y := yjoue2;\r
+ jeu.coord(jeu.offset).p := player;\r
+ jeu.coord(jeu.offset).a := attaquant;\r
+ call INC (jeu.offset,1);\r
+\r
+ (* changer de joueur attaquant si besoin est *)\r
+ IF poss.tab(yjoue2,xjoue2).attaquant<>0 THEN\r
+ attaquant := poss.tab(yjoue2,xjoue2).attaquant;\r
+ FI;\r
+\r
+ (* si la partie est gagn\82e *)\r
+ IF stratype=1 THEN\r
+ IF poss.tab(yjoue2,xjoue2).att_gagnante THEN\r
+ partie_gagnee := TRUE;\r
+ call INC(nb_par_gagn.tab(player),1);\r
+ call INC(nb_par_perd.tab(3-player),1);\r
+ call INC (nb_par_fin,1);\r
+ jeu.gagne := player;\r
+ jeu.fini := TRUE;\r
+ FI;\r
+ ELSE\r
+ if chercher_gagnant then\r
+ partie_gagnee := TRUE;\r
+ call INC(nb_par_gagn.tab(player),1);\r
+ call INC(nb_par_perd.tab(3-player),1);\r
+ call INC (nb_par_fin,1);\r
+ jeu.gagne := player;\r
+ jeu.fini := TRUE;\r
+ fi;\r
+ FI;\r
+\r
+ call INC (coups_joues.tab(player),1);\r
+ player := 3-player; (* passer au joueur suivant *)\r
+ call INC (coup,1);\r
+\r
+ IF coup>taille*taille THEN (* tester si match nul *)\r
+ partie_terminee := TRUE;\r
+ call INC (nb_mtch_nuls,1);\r
+ call INC (nb_par_fin,1);\r
+ jeu.fini := TRUE;\r
+ FI;\r
+\r
+ (* afficher un nouveau panneau d'informations *)\r
+ IF NOT partie_terminee THEN\r
+ call affiche_infos;\r
+ FI;\r
+ else\r
+ call showcursor;\r
+ alerte := x_alerte ("!!! Cette case est deja occup\82e !!!");\r
+ FI;\r
+ call showcursor;\r
+ detach;\r
+ od;\r
+END HUMAN_PLAY;\r
+\r
+(***************************************************************************)\r
+(* CPU_PLAY *)\r
+(***---------------------------------------------------------------------***)\r
+(* Fais jouer l'ordinateur lorsque c'est son tour. *)\r
+(***************************************************************************)\r
+\r
+unit cpu_play : coroutine;\r
+var\r
+ alerte : boolean;\r
+BEGIN\r
+ return;\r
+ do\r
+ call stra; (* appliquer la strat\82gie *)\r
+\r
+ xjoue3 := xjoue2;\r
+ yjoue3 := yjoue2;\r
+\r
+ xjoue2 := xjoue; (* r\82cup\8are les coordonn\82es \85 jouer *)\r
+ yjoue2 := yjoue;\r
+ tab_pion.tab(yjoue,xjoue) := player;(* placer le pion dans la matrice *)\r
+\r
+ jeu.coord(jeu.offset).x := xjoue; (* garder une trace du pion jou\82 *)\r
+ jeu.coord(jeu.offset).y := yjoue;\r
+ jeu.coord(jeu.offset).p := player;\r
+ jeu.coord(jeu.offset).a := attaquant;\r
+ call INC (jeu.offset,1);\r
+\r
+\r
+ IF poss.tab(yjoue,xjoue).attaquant<>0 THEN\r
+ (* changer de joueur attaquant si besoin est *)\r
+ attaquant := poss.tab(yjoue,xjoue).attaquant;\r
+ FI;\r
+\r
+\r
+ (* afficher le pion jou\82 *)\r
+ call case_pleine (xjoue,yjoue,taille,player,choix_pion.tab(player));\r
+\r
+\r
+ IF poss.tab(yjoue,xjoue).att_gagnante THEN\r
+ (* si la case jou\82e est gagnante *)\r
+ partie_gagnee := TRUE; (* fin de la partie *)\r
+ call INC(nb_par_gagn.tab(player),1);\r
+ call INC(nb_par_perd.tab(3-player),1);\r
+ call INC (nb_par_fin,1);\r
+ jeu.gagne := player;\r
+ jeu.fini := TRUE;\r
+ FI;\r
+\r
+\r
+\r
+ call INC (coups_joues.tab(player),1);\r
+ player := 3-player; (* passer au joueur suivant *)\r
+ call INC (coup,1);\r
+\r
+ IF coup>taille*taille THEN (* tester si match nul *)\r
+ partie_terminee := TRUE;\r
+ call INC (nb_mtch_nuls,1);\r
+ call INC (nb_par_fin,1);\r
+ jeu.fini := TRUE;\r
+ FI;\r
+ IF NOT partie_terminee THEN call affiche_infos; (* affiche un nouveau *)\r
+ FI; (* panneau d'informations *)\r
+ call showcursor;\r
+ detach;\r
+ od;\r
+END cpu_play;\r
+\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* ARBITRE *)\r
+(***---------------------------------------------------------------------***)\r
+(* Coroutine qui fais jouer successivement chaque joueur et qui g\8are *)\r
+(* toutes les options. *)\r
+(***************************************************************************)\r
+\r
+unit arbitre : coroutine;\r
+\r
+begin\r
+ return;\r
+do\r
+\r
+ IF NOT partie_terminee AND NOT partie_gagnee THEN\r
+ IF joueur.tab(player)=2 THEN\r
+ if player=1 then\r
+ attach (joueur1_cpu);\r
+ else\r
+ attach (joueur2_cpu);\r
+ fi;\r
+\r
+ call verifie_si_gagnant;\r
+ FI;\r
+ FI;\r
+\r
+ if ok then\r
+ IF NOT partie_terminee AND NOT partie_gagnee THEN\r
+ IF (joueur.tab(player)=1) AND\r
+ mousein(mousex,mousey,debut_x,debut_y,fin_x,fin_y) THEN\r
+ if player=1 then\r
+ attach (joueur1_hum);\r
+ else\r
+ attach (joueur2_hum);\r
+ fi;\r
+ call verifie_si_gagnant;\r
+ FI;\r
+ FI;\r
+ if mousein (mousex,mousey,484,12,547,60) then\r
+ call showcursor;\r
+ if confirmer("Etes-vous sur de vouloir recommencer ?") then\r
+ call resetgame;\r
+ call aff_infos_debut;\r
+ FI;\r
+\r
+ FI;\r
+\r
+ if mousein (mousex,mousey,484,76,547,124) then\r
+ call showcursor;\r
+ call STATS;\r
+ FI;\r
+\r
+ if mousein (mousex,mousey,484,140,574,188) then\r
+ call showcursor;\r
+ call OPT_JEU;\r
+ fi;\r
+\r
+ if mousein (mousex,mousey,484,268,574,316) then\r
+ call showcursor;\r
+ call REGLES;\r
+ fi;\r
+\r
+ if mousein(mousex,mousey,484,204,547,252) then\r
+ call showcursor;\r
+ strasave := stratype;\r
+ stratype := 1;\r
+ call stra;\r
+ stratype := strasave;\r
+ call inc (nb_aides.tab(player),1);\r
+ call affiche_infos;\r
+ call meilleures_cases;\r
+ FI;\r
+\r
+\r
+\r
+ IF mousein(mousex,mousey,564,12,627,60) THEN\r
+ call showcursor;\r
+ call inc (nb_undos.tab(player),1);\r
+ call oops;\r
+ if stratype = 2 then\r
+ stratype := 1;\r
+ call stra;\r
+ stratype := 2\r
+ fi;\r
+ fi;\r
+ IF mousein(mousex,mousey,564,140,627,188) THEN\r
+ call showcursor;\r
+ call JOUEURS;\r
+ FI;\r
+ IF mousein(mousex,mousey,564,76,627,124) THEN\r
+ call showcursor;\r
+ call STRATEG;\r
+ FI;\r
+ IF mousein(mousex,mousey,564,204,627,252) THEN\r
+ call showcursor;\r
+ call magnetoscope;\r
+ FI;\r
+ IF mousein(mousex,mousey,484,76,547,124) THEN\r
+ call showcursor;\r
+ call stats;\r
+ FI;\r
+\r
+\r
+\r
+ if mousein (mousex,mousey,564,268,627,316) then\r
+ call showcursor;\r
+ if confirmer ("Quitter MORPS !!! en \88tes-vous sur ?") then\r
+ detach;\r
+ fi;\r
+ fi;\r
+\r
+ call showcursor;\r
+ fi;\r
+od;\r
+end arbitre;\r
+\r
+\r
+(***************************************************************************)\r
+(* P r o g r a m m e P r i n c i p a l *)\r
+(***************************************************************************)\r
+\r
+Begin\r
+ call gron(1);\r
+ call INITIALISATIONS;\r
+ call resetgame_joueur;\r
+ call PRESENTATION ; (* Pr\82sentation *)\r
+ call rectangle_plein (0,0,639,479,0,0);\r
+ call AFF_GRAPH;\r
+ call RESETGAME; (* initialisations *)\r
+ call AFF_INFOS_DEBUT;\r
+ call AFF_INFOS_PARTIES;\r
+ call AFF_TEXTE_FIN;\r
+ call init(1,0);\r
+ call showcursor;\r
+ arb := new ARBITRE;\r
+ attach (arb); (* Lance le jeu *)\r
+ call efface(0,0,639,479,7,0,0);\r
+ call groff;\r
+end;\r
+end;\r
+End MORPS.
\ No newline at end of file
--- /dev/null
+Program BArbres;\r
+(*****************************************************************************)\r
+(* *)\r
+(* PROJET LI1 Nø1 pour le 15/01/94 *)\r
+(* *)\r
+(* PATAUD Frederic *)\r
+(* PEYRAT Francois *)\r
+(* *)\r
+(* Structure des Barbres *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+\r
+(*****************************************************************************)\r
+(* Structure d'une donnees *)\r
+(*****************************************************************************)\r
+Unit STData : class;\r
+var data : integer;\r
+End STData;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* Structure d'une page d'un B_Arbre *)\r
+(*****************************************************************************)\r
+Unit STPage : class (N : integer);\r
+Var pere : STPage;\r
+var nbdata : integer;\r
+var data : arrayof STData;\r
+var fils : arrayof STPage;\r
+Begin\r
+ nbdata:=0; (* A l'initialisation il n'y a pas de data *)\r
+ array data dim (1:2*N); (* Il y a au plus 2n donnees dans une page *)\r
+ array fils dim (1:2*N+1);(* et au plus 2n+1 fils. *)\r
+ pere:=none; (* Aucun pere n'est definit \85 la creation. *)\r
+End STPage;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 > elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Superieur : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data>elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Superieur;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 < elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Inferieur : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data<elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Inferieur;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* retourne 1 si elmt1 = elmt2 sinon 0 *)\r
+(*****************************************************************************)\r
+Unit Egalite : function (elmt1,elmt2 : STData) : boolean;\r
+Begin\r
+ if elmt1.data=elmt2.data\r
+ then result:=true\r
+ else result:=false\r
+ fi\r
+End Egalite;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(*****************************************************************************)\r
+Unit Barbre : class (N : integer);\r
+Var root : STPage;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne un booleen indiquant si l'arbre est vide *)\r
+ (****************************************************************************)\r
+ Unit Vide : function : boolean;\r
+ Begin\r
+ result:=root.nbdata=0; (* Si la racine n'a pas d'element alors arbre vide *)\r
+ End Vide;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne la valeur du minimun de l'arbre *)\r
+ (****************************************************************************)\r
+ Unit Minimum : function (output data : STData) : boolean;\r
+ var page : STPage\r
+ Begin\r
+ call outgtext("Recherche minimum...");\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ if page.fils(1)=none (* le minimum se trouve le plus en bas *)\r
+ then data:=page.data(1); (* \85 gauche de l'arbre *)\r
+ exit\r
+ fi;\r
+ page:=page.fils(1);\r
+ od;\r
+ result:=true;\r
+ else call outgtext("L'arbre est vide !!!"); (* il y a une erreur *)\r
+ result:=false;\r
+ fi\r
+ End Minimum;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne la valeur du maximum de l'arbre *)\r
+ (****************************************************************************)\r
+ Unit Maximum : function (output data : STData) : boolean;\r
+ Var page : STPage;\r
+ Begin\r
+ call outgtext("Recherche maximum...");\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ if page.fils(page.nbdata)=none (* le maximum est l'element le *)\r
+ then data:=page.data(page.nbdata); (* plus \85 droite de l'arbre *)\r
+ exit\r
+ fi;\r
+ page:=page.fils(page.nbdata+1);\r
+ od;\r
+ result:=true;\r
+ else call outgtext("L'arbre est vide !!!");\r
+ result:=false;\r
+ fi;\r
+ End Maximum;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Retourne vraie si l'element elmt est dans l'arbre ainsi que la page *)\r
+ (* la recherche va se faire par dichotomie, ameliorant le nombre de *)\r
+ (* comparaisons necessaire pour trouver : *)\r
+ (* -soit l'element dans la page courante *)\r
+ (* -soit la page suivante a examiner *)\r
+ (****************************************************************************)\r
+ Unit Membre : function (input elmt : STData; output page : STPage) : boolean;\r
+ Var a,milieu,b : integer;\r
+ Begin\r
+ call outgtext("Recherche donn\82e...");\r
+ result:=false;\r
+ if not vide\r
+ then page:=root;\r
+ do\r
+ a:=0; (* a=debut de l'intervalle *)\r
+ b:=page.nbdata+1; (* b=fin de l'intervalle *)\r
+ do\r
+ milieu:=(a+b) div 2; (* milieu = milieu de l'intervalle *)\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if Egalite(page.data(milieu),elmt)\r
+ then result:=true; (* on a trouve l'element *)\r
+ exit\r
+ else if (b-a)=1 (* on sort sans avoir touver *)\r
+ then exit\r
+ fi;\r
+ fi\r
+ od;\r
+ if result\r
+ then exit\r
+ fi;\r
+ if page.fils(1)=none (* si plus de page alors on sort *)\r
+ then exit\r
+ fi;\r
+ if Superieur(page.data(milieu),elmt) (* sinon on change de page *)\r
+ then page:=page.fils(milieu)\r
+ else page:=page.fils(milieu+1)\r
+ fi\r
+ od\r
+ else call outgtext("L'arbre est vide!!!");\r
+ fi;\r
+ End Membre;\r
+\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Insertion d'un element *)\r
+ (****************************************************************************)\r
+ Unit Insertion : procedure (elmt : STData);\r
+ Var a,milieu,b,i : integer;\r
+ var aux_fils : arrayof STPage;\r
+ var aux_data : arrayof STData;\r
+ var pagenew,page : STPage;\r
+ var sauv1,sauv2 : STPage;\r
+ Begin\r
+ page:=root;\r
+ if vide (* on insert la premiere donnee dans l'arbre *)\r
+ then page.data(1):=elmt;\r
+ page.nbdata:=1;\r
+ call outgtext("L'element a ete ajoute.")\r
+ else if not membre(elmt,page) (* l'element elmt n'existe pas deja *)\r
+ then do\r
+ if page <> none (* s'il ne faut pas creer une nouvelle page *)\r
+ then a:=0;\r
+ b:=page.nbdata+1;\r
+ do (* recherche dichotomique de la position dans la page *)\r
+ milieu:=(a+b) div 2;\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if (b-a)=1\r
+ then exit\r
+ fi;\r
+ od;\r
+ if Inferieur(page.data(milieu),elmt)\r
+ then milieu:=milieu+1\r
+ fi;\r
+ if page.nbdata < 2*N (* si on n'a pas le maximum d'elments*)\r
+ then for i:=page.nbdata downto milieu\r
+ do (* on decale pour inserer l'element *)\r
+ page.data(i+1):=page.data(i);\r
+ page.fils(i+2):=page.fils(i+1)\r
+ od;\r
+ page.data(milieu):=elmt; (* on insert l'element *)\r
+ page.fils(milieu+1):=pagenew;\r
+ page.nbdata:=page.nbdata+1;\r
+ exit\r
+ else a:=1;\r
+ b:=page.nbdata+1;\r
+ array aux_data dim (a:b);\r
+ array aux_fils dim (a:b+1);\r
+ for i:=1 to milieu-1 (* on sauve les donnees *)\r
+ do\r
+ aux_data(i):=page.data(i);\r
+ aux_fils(i):=page.fils(i);\r
+ od;\r
+ aux_fils(i):=page.fils(i);\r
+ aux_data(milieu):=elmt;\r
+ aux_fils(milieu+1):=pagenew;\r
+ for i:=milieu to 2*N\r
+ do\r
+ aux_data(i+1):=page.data(i);\r
+ aux_fils(i+2):=page.fils(i);\r
+ od;\r
+ pagenew:= new STPage(N);\r
+ page.nbdata:=n;\r
+ pagenew.nbdata:=n;\r
+ for i:=1 to n (* on coupe en deux *)\r
+ do\r
+ pagenew.data(i):=aux_data(n+1+i);\r
+ page.data(i):=aux_data(i);\r
+ pagenew.fils(i):=aux_fils(n+1+i);\r
+ page.fils(i):=aux_fils(i);\r
+ od;\r
+ pagenew.fils(i):=aux_fils(n+1+i);\r
+ page.fils(i):=aux_fils(i);\r
+ elmt:=aux_data(n+1);\r
+ sauv1:=page;\r
+ if page.fils(1) <> none (* on rechaine les parents *)\r
+ then for i:=1 to n+1\r
+ do\r
+ pagenew.fils(i).pere:=pagenew;\r
+ od\r
+ fi;\r
+ pagenew.pere:=page.pere;\r
+ page:=page.pere;\r
+ kill(aux_data); (* on efface les *)\r
+ kill(aux_fils); (* variables intermediaires *)\r
+ fi\r
+ else sauv2:=pagenew;\r
+ pagenew:= new STPage(N); (* creation d'une nouvelle page *)\r
+ pagenew.nbdata:=1;\r
+ pagenew.data(1):=elmt;\r
+ pagenew.fils(1):=sauv1;\r
+ pagenew.fils(2):=sauv2;\r
+ sauv1.pere:=pagenew;\r
+ sauv2.pere:=pagenew;\r
+ root:=pagenew; (* il y a changement de racine *)\r
+ exit\r
+ fi\r
+ od;\r
+ call outgtext("L'\82l\82ment a ete ajoute.");\r
+ else call outgtext("L'\82l\82ment existe deja!");(* l'element existe deja *)\r
+ fi\r
+ fi\r
+ End Insertion;\r
+\r
+\r
+ (****************************************************************************)\r
+ (* Suppression d'un element *)\r
+ (****************************************************************************)\r
+ Unit Supprimer : procedure (elmt : STData);\r
+ var a,milieu,b,i : integer;\r
+ var aux_data : arrayof STData;\r
+ var aux_fils : arrayof STPage;\r
+ var page,avant : STPage;\r
+ var courant,pere : STPage;\r
+ var pred,aux : integer;\r
+\r
+ Begin\r
+ if vide (* l'arbre est vide ?! *)\r
+ then call outgtext("L'arbre est vide!!!")\r
+ else page:=root;\r
+ if not membre(elmt,page) (* l'element n'est pas dans l'arbre ?! *)\r
+ then call outgtext("Donn\82e pas ds l'arbre.");\r
+ else courant:=page;\r
+ a:=0; (* on recherche par dichotomie la place de l'element *)\r
+ b:=courant.nbdata+1;\r
+ do\r
+ milieu:=(a+b) div 2;\r
+ if Superieur(page.data(milieu),elmt)\r
+ then b:=milieu\r
+ else a:=milieu\r
+ fi;\r
+ if Egalite(page.data(milieu),elmt)\r
+ then exit\r
+ fi\r
+ od; (* on a sa place *)\r
+ if courant.fils(milieu) <> none\r
+ then courant:=courant.fils(milieu)\r
+ fi;\r
+ while courant.fils(courant.nbdata+1) <> none\r
+ do\r
+ courant:=courant.fils(courant.nbdata+1)\r
+ od;\r
+ if page.fils(1) <> none\r
+ then page.data(milieu):=courant.data(courant.nbdata)\r
+ else for i:=milieu to courant.nbdata-1\r
+ do\r
+ page.data(i):=page.data(i+1)\r
+ od\r
+ fi;\r
+ courant.nbdata:=courant.nbdata-1;\r
+ if courant.nbdata < N\r
+ then if courant=root\r
+ then exit\r
+ fi;\r
+ do\r
+ pere:=courant.pere;\r
+ i:=1;\r
+ do\r
+ if pere.fils(i)=courant\r
+ then exit\r
+ fi;\r
+ i:=i+1\r
+ od;\r
+ pred:=i-1;\r
+ if pred <> 0\r
+ then avant:=pere.fils(pred)\r
+ else avant:=courant;\r
+ pred:=1;\r
+ courant:=pere.fils(2)\r
+ fi;\r
+ if avant.nbdata <= N\r
+ then if courant.nbdata > N\r
+ then array aux_data dim (1:3*N);\r
+ array aux_fils dim (1:3*N+1);\r
+ for i:=1 to avant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=avant.fils(i)\r
+ od;\r
+ aux_fils(i):=avant.fils(i);\r
+ aux_data(i):=pere.data(pred);\r
+ for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
+ od;\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
+ aux:=avant.nbdata+1+courant.nbdata;\r
+ milieu:=aux div 2 +1;\r
+ for i:=1 to milieu-1\r
+ do\r
+ avant.data(i):=aux_data(i);\r
+ avant.fils(i):=aux_fils(i)\r
+ od;\r
+ avant.fils(i):=aux_fils(i);\r
+ avant.nbdata:=milieu-1;\r
+ pere.data(pred):=aux_data(milieu);\r
+ for i:=milieu+1 to aux\r
+ do\r
+ courant.data(i-milieu):=aux_data(i);\r
+ courant.fils(i-milieu):=aux_fils(i)\r
+ od;\r
+ courant.fils(i-milieu):=aux_fils(i);\r
+ courant.nbdata:=aux-avant.nbdata-1\r
+ else for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ avant.data(i):=courant.data(i-avant.nbdata-1);\r
+ avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
+ if courant.fils(i-avant.nbdata-1) <> none\r
+ then courant.fils(i-avant.nbdata-1).pere:=avant\r
+ fi\r
+ od;\r
+ avant.fils(i):=courant.fils(i-avant.nbdata-1);\r
+ if courant.fils(i-avant.nbdata-1) <> none\r
+ then courant.fils(i-avant.nbdata-1).pere:=avant\r
+ fi;\r
+ avant.data(avant.nbdata+1):=pere.data(pred);\r
+ avant.nbdata:=avant.nbdata+1+courant.nbdata;\r
+ for i:=pred+1 to pere.nbdata\r
+ do\r
+ pere.data(i-1):=pere.data(i);\r
+ pere.fils(i):=pere.fils(i+1)\r
+ od;\r
+ pere.fils(pere.nbdata+1):=none;\r
+ pere.nbdata:=pere.nbdata-1;\r
+ if pere.nbdata=0\r
+ then root:=avant;\r
+ root.pere:=none\r
+ fi\r
+ fi\r
+ else array aux_data dim (1:3*N);\r
+ array aux_fils dim (1:3*N+1);\r
+ for i:=1 to avant.nbdata\r
+ do\r
+ aux_data(i):=avant.data(i);\r
+ aux_fils(i):=avant.fils(i)\r
+ od;\r
+ aux_fils(i):=avant.fils(i);\r
+ aux_data(i):=pere.data(pred);\r
+ for i:=avant.nbdata+2 to avant.nbdata+1+courant.nbdata\r
+ do\r
+ aux_data(i):=courant.data(i-avant.nbdata-1);\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1)\r
+ od;\r
+ aux_fils(i):=courant.fils(i-avant.nbdata-1);\r
+ aux:=avant.nbdata+1+courant.nbdata;\r
+ milieu:=aux div 2 +1;\r
+ for i:=1 to milieu-1\r
+ do\r
+ avant.data(i):=aux_data(i);\r
+ avant.fils(i):=aux_fils(i)\r
+ od;\r
+ avant.fils(i):=aux_fils(i);\r
+ avant.nbdata:=milieu-1;\r
+ pere.data(pred):=aux_data(milieu);\r
+ for i:=milieu+1 to aux\r
+ do\r
+ courant.data(i-milieu):=aux_data(i);\r
+ courant.fils(i-milieu):=aux_fils(i)\r
+ od;\r
+ courant.fils(i-milieu):=aux_fils(i);\r
+ courant.nbdata:=aux-avant.nbdata-1\r
+ fi;\r
+ if avant <> root\r
+ then avant:=pere;\r
+ if avant <> root\r
+ then if avant.nbdata < N\r
+ then pere:=pere.pere;\r
+ i:=1;\r
+ do\r
+ if pere.fils(i)=avant\r
+ then exit\r
+ fi;\r
+ i:=i+1\r
+ od;\r
+ courant:=pere.fils(i+1);\r
+ if courant=none\r
+ then courant:=avant;\r
+ avant:=pere.fils(i-1)\r
+ fi\r
+ else exit\r
+ fi\r
+ else exit\r
+ fi\r
+ else exit\r
+ fi\r
+ od\r
+ fi;\r
+ call outgtext("El\82ment supprim\82.")\r
+ fi\r
+ fi\r
+ End Supprimer;\r
+\r
+Begin\r
+ root:=new STPage(N);\r
+End Barbre;\r
+\r
+(****************************************************************************)\r
+(* dessine une ligne entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit line : procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ call color(colore);\r
+ end\r
+end line;\r
+\r
+(****************************************************************************)\r
+(* dessine une boite entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit rectanglef : procedure(x1,y1,x2,y2,c:integer);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ for i:=y1 to y2\r
+ do\r
+ call line(x1,i,x2,i,c);\r
+ od;\r
+ call color(colore);\r
+ end\r
+end rectanglef;\r
+\r
+(****************************************************************************)\r
+(* dessine un rectangle entre les points (x1,y1) et (x2,y2) de la couleur c *)\r
+(****************************************************************************)\r
+unit rectangle : procedure(x1,y1,x2,y2,c:integer);\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(x1,y1,x2,y1,c);\r
+ call line(x2,y1,x2,y2,c);\r
+ call line(x2,y2,x1,y2,c);\r
+ call line(x1,y2,x1,y1,c);\r
+ call color(colore);\r
+ end\r
+end rectangle;\r
+\r
+(****************************************************************************)\r
+(* dessine un rectangle en pointilles entre (x1,y1) et (x2,y2) *)\r
+(****************************************************************************)\r
+unit rectpoint : procedure(x1,y1,x2,y2,c:integer);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ for i:=x1 step 4 to x2-2\r
+ do\r
+ call line(i,y1,i+2,y1,c);\r
+ call line(i,y2,i+2,y2,c);\r
+ od;\r
+ for i:=y1 step 4 to y2-2\r
+ do\r
+ call line(x1,i,x1,i+2,c);\r
+ call line(x2,i,x2,i+2,c);\r
+ od\r
+ end\r
+end rectpoint;\r
+\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche le bandeau de commande en premiere ligne de l'ecran *)\r
+(****************************************************************************)\r
+unit affiche : procedure;\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call rectanglef(0,0,640,9,colorf);\r
+ call color(colore);\r
+ call move(1,1);\r
+ for i:=1 to nbitem\r
+ do\r
+ call move(10+espace*(i-1),1);\r
+ call outstring(item(i));\r
+ od;\r
+ call rectangle(1,15,196,340,colorf);\r
+ call rectangle(200,15,639,320,colorf);\r
+ call rectangle(200,325,639,340,colorf);\r
+ call move(202,330);\r
+ call outstring(" BArbre d'ordre 3 Li1 : PATAUD F. - PEYRAT F.");\r
+ end\r
+end affiche;\r
+\r
+(****************************************************************************)\r
+(* gere le menu, retourne le code action soit clavier soit souris *)\r
+(****************************************************************************)\r
+unit mousegest : function : integer;\r
+var l,r,c : boolean;\r
+var x,y : integer;\r
+var rep : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then if (y<=10 and y>=1)\r
+ then result:=(x-10)/espace+1; exit;\r
+ fi\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep>=-65 and rep<=-59)\r
+ then result:=-rep-58;\r
+ exit\r
+ fi;\r
+ od\r
+ end\r
+ end\r
+end mousegest;\r
+\r
+(****************************************************************************)\r
+(* initialise le menu et effectue l'action demand\82e *)\r
+(****************************************************************************)\r
+unit maine : procedure;\r
+var i : integer;\r
+var action : integer;\r
+begin\r
+ pref mouse block\r
+ begin\r
+ colorf:=9;\r
+ colore:=10;\r
+ espace:=90;\r
+ nbitem:=7;\r
+ array item dim (1:nbitem);\r
+ item(1):=" Inserer ";\r
+ item(2):=" Effacer ";\r
+ item(3):=" Affiche ";\r
+ item(4):=" Membre? ";\r
+ item(5):=" Minimum ";\r
+ item(6):=" Maximum ";\r
+ item(7):=" Quitter ";\r
+ call affiche;\r
+ call showcursor;\r
+ colore:=2;\r
+ do\r
+ action:=mousegest;\r
+ case action\r
+ when 1: call menu_ins;\r
+ when 2: call menu_del;\r
+ when 3: call menu_aff;\r
+ when 4: call menu_mem;\r
+ when 5: call menu_min;\r
+ when 6: call menu_max;\r
+ when 7: if menu_qui then exit fi;\r
+ esac;\r
+ od;\r
+ end\r
+end maine;\r
+\r
+(****************************************************************************)\r
+(* procedure d'affichage dans l'ecran de commandes, fait un scroll si besoin*)\r
+(****************************************************************************)\r
+unit outgtext : procedure(id : string);\r
+var i,savx : integer;\r
+var tmap1 : arrayof integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call color(colore);\r
+ call move(10,posy);\r
+ call outstring(id);\r
+ posy:=posy+10;\r
+ if (posy>=320) (* on est en fin de page, on fait un scroll d'une ligne *)\r
+ then savx:=inxpos;\r
+(* array tmap1 dim (1:300); *)\r
+(* for i:=1 step 10 to 281 *)\r
+(* do*)\r
+(* call move(1,36+i);*)\r
+(* tmap1:=getmap(196,46+i);*)\r
+(* call move(1,16+i);*)\r
+(* call putmap(tmap1);*)\r
+(* od;*)\r
+(* call rectanglef(2,317,195,337,0);*)\r
+(* posy:=310; *)\r
+(* call move(savx,posy); *)\r
+ call rectanglef(2,16,195,337,0);\r
+ posy:=20;\r
+ fi;\r
+ end\r
+end outgtext;\r
+\r
+(****************************************************************************)\r
+(* lecture d'un entier en mode graphique, esc revient au debut de saisie *)\r
+(****************************************************************************)\r
+unit gscanf : function : integer;\r
+var valeur : integer;\r
+var sauvx,sauvy : integer;\r
+var flag : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ valeur:=0;\r
+ sauvx:=inxpos;\r
+ sauvy:=inypos;\r
+ do\r
+ do\r
+ flag:=inkey;\r
+ if (flag>=48 and flag<=57) orif (flag=13) orif (flag=27) then exit fi\r
+ od;\r
+ if (flag>=48 and flag<=57)\r
+ then valeur:=valeur*10+flag-48;\r
+ call move(inxpos,inypos);\r
+ call hascii(flag);\r
+ fi;\r
+ if (flag=13) then exit fi;\r
+ if (flag=27) (* on a demand\82 annulation *)\r
+ then valeur:=0;\r
+ call rectanglef(sauvx-1,sauvy-3,inxpos,sauvy+7,0);\r
+ call color(colore);\r
+ call move(sauvx,sauvy);\r
+ fi;\r
+ od;\r
+ end;\r
+ result:=valeur;\r
+end gscanf;\r
+\r
+(****************************************************************************)\r
+(* affiche un entier en mode graphique, maximum 6 chiffres *)\r
+(****************************************************************************)\r
+unit writint : procedure( valeur : integer);\r
+var flag,i : integer;\r
+var tbl : arrayof integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ array tbl dim (1:6);\r
+ flag:=1; (* on 'empile' en ordre reverse *)\r
+ while valeur<>0\r
+ do\r
+ tbl(flag):=valeur mod 10;\r
+ valeur:=valeur div 10;\r
+ flag:=flag+1;\r
+ od;\r
+ for i:=flag-1 downto 1 (* on affiche dans le bon ordre *)\r
+ do\r
+ call hascii(48+tbl(i));\r
+ od;\r
+ end\r
+end writint;\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche ds l'ecran de droite la page courante *)\r
+(****************************************************************************)\r
+unit affiche_page : procedure (page : STPage);\r
+var i :integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ if page<>arbr.root\r
+ then call line(420,82,420,97,colorf);\r
+ call cirb(420,77,5,0,0,colorf,0,1,1);\r
+ fi;\r
+ for i:=1 to 6\r
+ do\r
+ call rectpoint(339+(i-1)*27,97,339+i*27,117,colorf);\r
+ if i<=page.nbdata\r
+ then call move(339+(i-1)*27+3,105);\r
+ call writint(page.data(i).data);\r
+ fi;\r
+ od;\r
+ end\r
+end affiche_page;\r
+\r
+(****************************************************************************)\r
+(* affiche ds l'ecran de droite la page fille de gauche *)\r
+(****************************************************************************)\r
+unit affiche_gche : procedure (page : STPage);\r
+var i : integer;\r
+var savi : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(312,220,312,240,colorf);\r
+ for i:=1 to 6\r
+ do\r
+ call rectangle(204+i*27,240,204+(i+1)*27,260,colorf);\r
+ if i<=page.nbdata\r
+ then call move(204+i*27+3,248);\r
+ call writint(page.data(i).data);\r
+ savi:=i;\r
+ if page.fils(i) <> none\r
+ then if i=4\r
+ then call line(204+i*27,260,204+i*27,275,colorf);\r
+ else if i<4\r
+ then call line(204+i*27,260,204+i*27-5,275,colorf);\r
+ else call line(204+i*27,260,204+i*27+5,275,colorf);\r
+ fi\r
+ fi\r
+ fi\r
+ fi;\r
+ od;\r
+ if page.fils(i) <> none\r
+ then if savi<>3 (* comme on part gche->dte on a soit | soit \ *)\r
+ then call line(204+(savi+1)*27,260,204+(savi+1)*27+5,275,colorf);\r
+ else call line(204+(savi+1)*27,260,204+(savi+1)*27,275,colorf);\r
+ fi;\r
+ fi;\r
+ end\r
+end affiche_gche;\r
+\r
+(****************************************************************************)\r
+(* affiche ds ecran de droite la page fille droite *)\r
+(****************************************************************************)\r
+unit affiche_drte : procedure (page :STPage);\r
+var i : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call line(527,220,527,240,colorf);\r
+ for i:=1 to 6\r
+ do\r
+ call rectangle(635-(i+1)*27,240,635-i*27,260,colorf);\r
+ if (6-i+1)<=page.nbdata\r
+ then call move(635-(i+1)*27+3,248);\r
+ call writint(page.data(6-i+1).data);\r
+ if page.fils(6-i+1) <> none\r
+ then if (6-i+1)=4\r
+ then call line(635-i*27,260,635-i*27,275,colorf);\r
+ else if (6-i+1)>4\r
+ then call line(635-i*27,260,635-i*27+5,275,colorf);\r
+ else call line(635-i*27,260,635-i*27-5,275,colorf);\r
+ fi\r
+ fi\r
+ fi\r
+ fi;\r
+ od;\r
+ if page.fils(1) <> none\r
+ then call line(635-i*27,260,635-i*27-5,275,colorf);\r
+ fi;\r
+ end\r
+end affiche_drte;\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* Lecture de la donn\82e de STData *)\r
+(****************************************************************************)\r
+unit lect_data : function : STData;\r
+var d : STData;\r
+begin\r
+ d:=new STData;\r
+ call outgtext("Entrez la donn\82e :");\r
+ d.data:=gscanf;\r
+ result:=d;\r
+end lect_data;\r
+\r
+(****************************************************************************)\r
+(* menu insertion *)\r
+(****************************************************************************)\r
+unit menu_ins : procedure;\r
+var d : STData;\r
+begin\r
+ d:=lect_data;\r
+ call arbr.insertion(d);\r
+ call outgtext("");\r
+end menu_ins;\r
+\r
+\r
+(****************************************************************************)\r
+(* menu effacement *)\r
+(****************************************************************************)\r
+unit menu_del : procedure;\r
+var d : STData;\r
+begin\r
+ d:=lect_data;\r
+ call arbr.supprimer(d);\r
+ call outgtext("");\r
+end menu_del;\r
+\r
+(****************************************************************************)\r
+(* menu de parcours de l'arbre dans la fenetre droite *)\r
+(****************************************************************************)\r
+unit menu_aff : procedure;\r
+var pos,spos: integer;\r
+var rep,x,y : integer;\r
+var l,r,c : boolean;\r
+var page : STPage;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ pos:=1;\r
+ page:=arbr.root;\r
+ call rectangle(210,25,245,36,colorf);\r
+ call move(212,27);\r
+ call outstring("Exit");\r
+ do\r
+ call hidecursor;\r
+ call outgtext("MENU AFF");\r
+ call rectanglef(201,37,638,319,0);\r
+ call affiche_page(page);\r
+ if page.fils(pos) <> none\r
+ then call affiche_gche(page.fils(pos));\r
+ fi;\r
+ if page.fils(pos+1) <> none\r
+ then call affiche_drte(page.fils(pos+1));\r
+ fi;\r
+ call rectangle(339+(pos-1)*27,97,339+pos*27,117,colorf);\r
+ if page.fils(pos) <> none\r
+ then call line(339+(pos-1)*27,117,339+(pos-1)*27-5,132,colorf);\r
+ fi;\r
+ if page.fils(pos+1) <> none\r
+ then call line(339+pos*27,117,339+pos*27+5,132,colorf);\r
+ fi;\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then if (y<36 and y>25 and x>211 and x<245) (* button exit *)\r
+ then exit exit\r
+ fi;\r
+ if (x<501 and x>339 and y<117 and y>97) (* ds pere chgt gch dte *)\r
+ then spos:=((x-339) div 27)+1;\r
+ if spos<=page.nbdata\r
+ then pos:=spos\r
+ fi;\r
+ exit\r
+ fi;\r
+ if (x>231 and x<393 and y>240 and y<260) (* fils gche devient pere*)\r
+ then page:=page.fils(pos);\r
+ pos:=1;\r
+ exit;\r
+ fi;\r
+ if (x>446 and x<608 and y>240 and y<260) (* fils dte devient pere *)\r
+ then page:=page.fils(pos+1);\r
+ pos:=1;\r
+ exit;\r
+ fi;\r
+ if (page<>arbr.root) and (x>415 and x<425 and y>72 and y<82)\r
+ then page:=page.pere; (* on remonte d'un niveau *)\r
+ pos:=1;\r
+ exit\r
+ fi;\r
+ fi;\r
+ rep:=inkey;\r
+ if rep=27\r
+ then exit exit\r
+ else if (rep>=49 and rep<=54)\r
+ then pos:=rep-48;\r
+ exit\r
+ fi;\r
+ fi;\r
+ od;\r
+ od;\r
+ call hidecursor;\r
+ call rectanglef(201,24,638,319,0);\r
+ call showcursor;\r
+ end\r
+ end\r
+end menu_aff;\r
+\r
+(****************************************************************************)\r
+(* menu membre *)\r
+(****************************************************************************)\r
+unit menu_mem : procedure;\r
+var d : STData;\r
+var page : STPage;\r
+begin\r
+ d:=lect_data;\r
+ if arbr.Membre(d,page)\r
+ then call outgtext("Donn\82e pr\82sente ds arbre");\r
+ else call outgtext("Donn\82e absente ds arbre");\r
+ fi;\r
+ call outgtext("");\r
+end menu_mem;\r
+\r
+(****************************************************************************)\r
+(* menu minimum *)\r
+(****************************************************************************)\r
+unit menu_min : procedure;\r
+var d : STData;\r
+begin\r
+ if arbr.Minimum(d)\r
+ then call writint(d.data);\r
+ fi;\r
+ call outgtext("");\r
+end menu_min;\r
+\r
+(****************************************************************************)\r
+(* menu maximum *)\r
+(****************************************************************************)\r
+unit menu_max : procedure;\r
+var d : STData;\r
+begin\r
+ if arbr.Maximum(d)\r
+ then call writint(d.data);\r
+ fi;\r
+ call outgtext("");\r
+end menu_max;\r
+\r
+(****************************************************************************)\r
+(* menu quitte *)\r
+(****************************************************************************)\r
+unit menu_qui : function : boolean;\r
+var rep : boolean;\r
+var a : integer;\r
+begin\r
+ pref iiuwgraph block\r
+ begin\r
+ call outgtext("Voulez-vous quitter");\r
+ call outgtext(" (o/n) ?");\r
+ call move(inxpos+8,inypos);\r
+ do\r
+ a:=inkey;\r
+ if (a=111 or a=79)\r
+ then result:=true;\r
+ call outgtext("o");\r
+ exit\r
+ fi;\r
+ if (a=110 or a=78)\r
+ then result:=false;\r
+ call outgtext("n");\r
+ exit\r
+ fi;\r
+ od;\r
+ call outgtext("");\r
+ end\r
+end menu_qui;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(*****************************************************************************)\r
+(* *)\r
+(* P R O G R A M M E P R I N C I P A L *)\r
+(* *)\r
+(*****************************************************************************)\r
+(*****************************************************************************)\r
+var colorf,colore : integer;\r
+var nbitem : integer;\r
+var espace : integer;\r
+var item : arrayof string;\r
+var nbbot : integer;\r
+var flag : boolean;\r
+var posy : integer;\r
+var arbr : Barbre;\r
+\r
+Begin\r
+ pref iiuwgraph block\r
+ begin\r
+ pref mouse block\r
+ begin\r
+ arbr:=new Barbre(3);\r
+ call gron(1);\r
+ flag:=init(nbbot);\r
+ call hpage(0,1,1);\r
+ posy:=20;\r
+ call maine;\r
+ call hidecursor;\r
+ call groff;\r
+ end\r
+ end\r
+End BArbres.\r
--- /dev/null
+Program tri;\r
+\r
+(*******************************************************************)\r
+\r
+Unit newpage:procedure;\r
+begin\r
+ write(chr(27),"[2J");\r
+end newpage;\r
+\r
+(*******************************************************************)\r
+\r
+Unit gotoxy : procedure (row, column : integer);\r
+ var c, d, e, f : char,\r
+ i, j : integer;\r
+begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr (48+i);\r
+ d := chr (48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr (48+i);\r
+ f := chr (48+j);\r
+ write (chr(27), "[", c, d, ";", e, f, "H");\r
+ end gotoxy;\r
+\r
+(*******************************************************************)\r
+\r
+Unit pause:procedure(input seconde:integer);\r
+ var temps:integer;\r
+begin\r
+ for temps:=1 to (9000*seconde) do od;\r
+end pause;\r
+\r
+(*******************************************************************)\r
+\r
+Unit affiche:procedure(input position:integer;\r
+ inout tableau:arrayof integer);\r
+var i:integer;\r
+begin\r
+for i:=1 to upper(tableau) do\r
+ if i=position then write(chr(27),"[33m");\r
+ write(" ",tableau(i):4," ");\r
+ write(chr(27),"[36m")\r
+ else\r
+ write(" ",tableau(i):4," ") fi;\r
+od;\r
+writeln;\r
+end affiche;\r
+\r
+(*******************************************************************)\r
+\r
+Unit A:process(n:integer;p:B);\r
+var tabA:arrayof integer,\r
+ max,position,nb,i,nombre,j:integer,\r
+ bo:boolean;\r
+\r
+ (********************)\r
+\r
+Unit rech_max:procedure(output max,position:integer);\r
+(* Recherche du plus grand \82l\82ment de tabA *)\r
+var i:integer;\r
+begin\r
+max:=tabA(1);\r
+position:=1;\r
+for i:=2 to nb do\r
+ if tabA(i)>max then max:=tabA(i);\r
+ position:=i;\r
+ fi;\r
+od;\r
+end rech_max;\r
+\r
+ (********************)\r
+\r
+begin\r
+ call gotoxy(2,20);\r
+ write(chr(27),"[33m");\r
+ writeln("- SAISIE DU TABLEAU A -");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(4,1);\r
+ write("Quelle est la dimension de tabA ? ");\r
+ read(nb);\r
+ array tabA dim (1:nb);\r
+ for i:=1 to nb do\r
+ write("Donnez tabA(",i:3,") : ");\r
+ readln(nombre);\r
+ tabA(i):=nombre;\r
+ od;\r
+ call newpage;\r
+ call gotoxy(2,15);\r
+ writeln("AFFICHAGE DES DIFFERENTES ETAPES DU TRI");\r
+ writeln;\r
+ return;\r
+ j:=0;\r
+ do\r
+\r
+ call rech_max(max,position);\r
+ writeln;\r
+ if j<>0 then writeln("Etape ",j:2," : ") fi;\r
+ call p.ec;\r
+ write("TabA = ");\r
+ call affiche(position,tabA);\r
+ call p.rire;\r
+ call p.echange(max,bo);\r
+ tabA(position):=max;\r
+ j:=j+1;\r
+ if bo then exit fi;\r
+ od;\r
+ position:=0;\r
+ write(chr(27),"[32m");\r
+ writeln("Resultat Final : ");\r
+ write(chr(27),"[36m");\r
+ call p.ec;\r
+ write("TabA = ");\r
+ call affiche(position,tabA);\r
+ call p.rire;\r
+end A;\r
+\r
+(*******************************************************************)\r
+\r
+Unit B:process(n:integer);\r
+var tabB:arrayof integer,\r
+ min,position,nb,i,nombre,j:integer,\r
+ bidon:char,\r
+ arret:boolean;\r
+\r
+ (********************)\r
+\r
+Unit rech_min:procedure(output min,position:integer);\r
+(* Recherche du plus petit \82l\82ment de tabB *)\r
+var i:integer;\r
+begin\r
+min:=tabB(1);\r
+position:=1;\r
+for i:=2 to nb do\r
+ if tabB(i)<min then min:=tabB(i);\r
+ position:=i;\r
+ fi;\r
+od;\r
+end rech_min;\r
+\r
+ (********************)\r
+\r
+Unit echange:procedure(inout max:integer;\r
+ output bo:boolean);\r
+begin\r
+ if min<max then tabB(position):=max;\r
+ max:=min;\r
+ bo:=false\r
+ else bo:=true;\r
+ arret:=true fi;\r
+end echange;\r
+\r
+Unit ec:procedure;\r
+end ec;\r
+\r
+Unit rire:procedure;\r
+end rire;\r
+\r
+ (********************)\r
+\r
+begin\r
+ call gotoxy(2,20);\r
+ write(chr(27),"[33m");\r
+ writeln("- SAISIE DU TABLEAU B -");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(4,1);\r
+ write("Quelle est la dimension de tabB ? ");\r
+ read(nb);\r
+ array tabB dim (1:nb);\r
+ for i:=1 to nb do\r
+ write("Donnez tabB(",i:3,") : ");\r
+ readln(nombre);\r
+ tabB(i):=nombre;\r
+ od;\r
+ call newpage;\r
+ return;\r
+ j:=0;\r
+ do\r
+\r
+ call rech_min(min,position);\r
+ accept ec;\r
+ accept rire;\r
+ write("TabB = ");\r
+ call affiche(position,tabB);\r
+ writeln;\r
+ j:=j+1;\r
+ if (j mod 4)=0 then write(chr(27),"[32m");\r
+ writeln("< Appuyez sur Retour >");\r
+ write(chr(27),"[36m");\r
+ read(bidon);\r
+ call newpage fi;\r
+\r
+ accept echange;\r
+ if arret then exit fi;\r
+ od;\r
+ accept ec;\r
+ accept rire;\r
+ position:=0;\r
+ write("TabB = ");\r
+ call affiche(position,tabB);\r
+end B;\r
+\r
+(*******************************************************************)\r
+\r
+Unit baniere:procedure;\r
+begin\r
+ call newpage;\r
+ write(chr(27),"[31m");\r
+ call gotoxy(7,22);\r
+ writeln("PARTITION DE DEUX ENSEMBLES :");\r
+ call gotoxy(9,31);\r
+ writeln("Min & Max");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(15,29);\r
+ writeln("Presented by");\r
+ call gotoxy(22,26);\r
+ write(chr(27),"[32m");\r
+ writeln("- Dupin Christophe -");\r
+ call pause(2);\r
+ write(chr(27),"[36m");\r
+ call newpage;\r
+end baniere;\r
+\r
+(************************* Programme principal *****************************)\r
+\r
+var arret:boolean,\r
+ processusA : A,\r
+ processusB : B;\r
+\r
+begin\r
+ call baniere;\r
+ processusB:=new B(0);\r
+ processusA:=new A(0,processusB);\r
+ resume(processusA);\r
+ resume(processusB);\r
+end tri;\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+\r
+Program chinois;\r
+const blanc=15,bleu=1,vert=2,vertpetrole=3,rouge=4,violet=5,marron=6,grisclair=7,\r
+ grisfonce=8,bleuroi=9,vertclair=10,free=-1;\r
+\r
+ \r
+ UNIT coord2D:class(x,y:integer);\r
+ end;\r
+ \r
+ UNIT coord3D:class(x,y,h:integer);\r
+ end;\r
+\r
+\r
+UNIT gestion_caractere: IIUWGRAPH class;\r
+\r
+ UNIT SAISIE:function(ti,e,x,y:integer):arrayof char;\r
+ var i,n:integer,\r
+ c: integer,\r
+ t :arrayof char;\r
+ begin\r
+ \r
+ array t dim(1:e);\r
+ for i:=1 to e do\r
+ t(i):=' ';\r
+ od;\r
+ \r
+ do\r
+ i:=1;\r
+ c:=inkey;\r
+ while c<>13 and c<>27 and i<=e do\r
+ \r
+ case ti\r
+ when 1:\r
+ if c>=48 and c<=57 then\r
+ t(i):=chr(c);\r
+ call move(x+i*9,y);\r
+ call hascii(c);\r
+ i:=i+1;\r
+ fi;\r
+ when 2:\r
+ \r
+ if c>64 then\r
+ t(i):=chr(c);\r
+ call move(x+i*9,y);\r
+ call hascii(c);\r
+ i:=i+1;\r
+ fi;\r
+ esac;\r
+ c:=inkey;\r
+ od;\r
+ if t(1)<>' ' then exit; fi;\r
+ od;\r
+ result:=t;\r
+ end SAISIE;\r
+\r
+ UNIT ConvEnt:function(t:arrayof char):integer;\r
+ var n,i:integer;\r
+ begin\r
+ n:=0;\r
+ for i:=1 to upper(t) do\r
+ if t(i)<>' ' then\r
+ n:=n*10+(ord(t(i))-48);\r
+ fi;\r
+ od;\r
+ \r
+ result:=n;\r
+ end ConvEnt;\r
+\r
+ UNIT displaystring:procedure(t:arrayof char,x,y,coul:integer);\r
+ var i:integer;\r
+ begin\r
+ call color(coul); \r
+ for i:=1 to upper(t)\r
+ do\r
+ call move(x+i*9,y);\r
+ call hascii(ord(t(i)));\r
+ od; \r
+ end; \r
+END;\r
+\r
+\r
+UNIT element:class;\r
+var x,i,j,h:integer;\r
+END;\r
+\r
+\r
+UNIT ARBTAS : class; (* structure utilis\82e par la coroutine ordinateur *)\r
+\r
+ var tab : arrayof element, (* tableau contenant les elements du tas *)\r
+ nb : integer, (* entier le nombre d'elements du tas *)\r
+ dimen: integer;\r
+ (* fonction testant si le tas est vide ou non *)\r
+ unit vide : function : boolean; \r
+ begin\r
+ if (tab(1) = none)\r
+ then result := true;\r
+ fi;\r
+ end vide;\r
+\r
+ (* fonction retournant le minimum du tas *)\r
+ unit mini : function : element;\r
+ begin\r
+ if not vide\r
+ then result := tab(1);\r
+ fi;\r
+ end mini;\r
+\r
+ (* fonction retournant la position d'un element dans le tas *)\r
+ unit membre : function(elem:element) : integer;\r
+ var i : integer;\r
+ begin\r
+ if not vide\r
+ then for i:=1 to nb\r
+ do\r
+ if tab(i).x = elem.x\r
+ then result := i;\r
+ exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ end membre;\r
+\r
+ (* procedure pour inserer un nouvel element dans le tas *)\r
+ unit inserer : procedure(elem : element);\r
+ var i : integer,\r
+ aux : element,\r
+ tabaux : arrayof element;\r
+ begin\r
+ if (nb >= dimen) (* on aggrandit le tableau trop petit *)\r
+ then array tabaux dim (1:nb+1);\r
+ for i:=1 to nb \r
+ do\r
+ tabaux(i) := tab(i);\r
+ od;\r
+ tab := tabaux;\r
+ dimen := dimen + 1; (* la dimension du tableau est *)\r
+ (* incremente de 1 *) \r
+ fi;\r
+ nb := nb + 1; (* le nombre d'elements est incremente de 1 *)\r
+ tab(nb) := elem; (* l'element a inserer est place a la fin *)\r
+ i := nb;\r
+ aux := new element;\r
+ do (* on effectue des echanges tant que le fils est inferieur *)\r
+ (* au pere *) \r
+ if (i <= 1 ) orif ( tab(i).x >= tab(i div 2).x )\r
+ then exit;\r
+ fi;\r
+ aux := tab(i DIV 2); (* echange pere-fils *)\r
+ tab(i DIV 2) := tab(i);\r
+ tab(i) := aux;\r
+ i := i div 2;\r
+ od;\r
+ end inserer;\r
+\r
+ (* procedure pour supprimer un element du tas *)\r
+ unit supprimer : procedure(elem : element);\r
+ var i,j : integer,\r
+ aux : element;\r
+ begin\r
+ i := membre(elem);\r
+ if ( i <> 0 ) (* on teste si l'element appartient au tas *) \r
+ then kill(tab(i));\r
+ tab(i) := tab(nb); (* le dernier element est place *)\r
+ (* a l'endroit de l'element supprime *) \r
+ nb := nb - 1; (* on decremente le nombre d'elements *)\r
+ aux := new element;\r
+\r
+ while ( i <= (nb div 2) )\r
+ do (* tant que tab(i) n'est pas une feuille *)\r
+\r
+ if (2*i = nb) orif (tab(2*i).x < tab(2*i + 1).x)\r
+ then j := 2*i; (* on calcule l'indice du plus petit *)\r
+ else j := 2*i + 1; (* des 2 fils *)\r
+ fi;\r
+\r
+ if tab(i).x > tab(j).x\r
+ then aux := tab(i); (* echange si la condition d'ordre *)\r
+ tab(i) := tab(j);(* n'est pas satisfaite *)\r
+ tab(j) := aux;\r
+ i := j;\r
+ else exit;\r
+ fi;\r
+ od;\r
+ tab(nb + 1) := none; (* le dernier element est supprime *)\r
+ fi;\r
+ end supprimer;\r
+\r
+begin\r
+ array tab dim (1:10);\r
+ nb := 0;\r
+ dimen:=10;\r
+end ARBTAS;\r
+\r
+\r
+\r
+UNIT elem:class(i,j,k:integer);\r
+var prec:elem;\r
+end;\r
+\r
+\r
+UNIT pile:class; (* structure utilis\82e par la coroutine controle*)\r
+ var pointeur:elem;\r
+\r
+ UNIT empiler:procedure(e:elem);\r
+ begin\r
+ e.prec:=pointeur;\r
+ pointeur:=e;\r
+ end;\r
+\r
+ UNIT depiler:procedure;\r
+ var tampon:elem;\r
+ begin\r
+ if not vide then\r
+ tampon:=pointeur;\r
+ pointeur:=pointeur.prec;\r
+ kill(tampon);\r
+ fi;\r
+ end;\r
+\r
+ UNIT sommet:function:elem;\r
+ begin\r
+ result:=pointeur;\r
+ end;\r
+\r
+ UNIT vide:function:boolean;\r
+ begin\r
+ result:=(pointeur=none);\r
+ end;\r
+begin\r
+pointeur:=none;\r
+END;\r
+\r
+UNIT drawrect: IIUWGRAPH procedure(x1,y1,x2,y2,couleur:integer);\r
+begin\r
+ call color(couleur);\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1);\r
+end;\r
+\r
+\r
+UNIT player: gestion_caractere class(couleur:integer,pl:plateau_jeu);\r
+END; \r
+\r
+\r
+\r
+UNIT ordi: player coroutine;\r
+\r
+var coinlibre,find:boolean,\r
+ coin,c,quel,version:integer,\r
+ place:coord3D,\r
+ pos:integer,cointab:arrayof coord2D,\r
+ posajouer:arrayof arrayof integer,\r
+ mem:arbtas,\r
+ adver,moi:arrayof info;\r
+ \r
+\r
+\r
+UNIT info: class(n,sur:integer);\r
+var rangee:arrayof arrayof combinaison;\r
+begin\r
+\r
+ block\r
+ var i,j:integer;\r
+ \r
+ begin\r
+ array rangee dim(1:n);\r
+ for i:=1 to n do array rangee(i) dim (1:sur); od;\r
+ for i:=1 to n do\r
+ for j:=1 to sur do\r
+ rangee(i,j):=new combinaison;\r
+ od;\r
+ od;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+UNIT find_place:function(quoi,l,x,h:integer;inout p:coord3D):boolean;\r
+const ligne=1,colonne=2,lignediag=3,coldiag=4,axe=5,dbdiag=7,bigdiag=6;\r
+var i:integer,\r
+ trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ case quoi\r
+ \r
+ when dbdiag:\r
+ \r
+ case x\r
+ when 1:\r
+ case h\r
+ when 1:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,i,i)=free then\r
+ if i=posajouer(i,i) then trouve:=true; \r
+ p.x:=i;p.y:=i;p.h:=i;\r
+ exit; fi;\r
+ fi;\r
+ od;\r
+ when 2:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,i,(4-i)+1)=free then\r
+ if posajouer(i,i)=(4-i)+1 then trouve:=true; \r
+ p.x:=i;p.y:=i;p.h:=(4-i)+1;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ esac; \r
+ when 2:\r
+ case h\r
+ when 1:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,(4-i)+1,i)=free then\r
+ if i=posajouer(i,(4-i)+1) then trouve:=true; \r
+ p.x:=i;p.y:=(4-i)+1;p.h:=i;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ when 2:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,(4-i)+1,(4-i)+1)=free then\r
+ if posajouer(i,(4-i)+1)=(4-i)+1 then trouve:=true; \r
+ p.x:=i;p.y:=(4-i)+1;p.h:=(4-i)+1;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ esac;\r
+ esac;\r
+\r
+ when bigdiag:\r
+ \r
+ case l\r
+ when 1:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,i,h)=free then\r
+ if h=posajouer(i,i) then trouve:=true; \r
+ p.x:=i;p.y:=i;p.h:=h;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ when 2:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,(4-i)+1,h)=free then\r
+ if h=posajouer(i,(4-i)+1) then trouve:=true; \r
+ p.x:=i;p.y:=(4-i)+1;p.h:=h;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ esac;\r
+ when ligne: (* recherche d'une place dans la ligne sp\82cifi\82e *)\r
+ for i:=1 to 4 do\r
+ if pl.jeu(x,i,h)=free then \r
+ if h=posajouer(x,i) then trouve:=true; fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ if trouve then\r
+ p.x:=x;\r
+ p.y:=i;\r
+ p.h:=posajouer(x,i);\r
+\r
+ fi;\r
+ when colonne: (* recherche d'une place dans la colonne sp\82cifi\82e *)\r
+ for i:=1 to 4 do\r
+ if pl.jeu(i,x,h)=free then \r
+ if posajouer(i,x)=h then trouve:=true; \r
+ p.x:=i;p.y:=x;p.h:=posajouer(i,x);\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+\r
+ \r
+\r
+ when lignediag:(* recherche d'une place dans la diagonnal ligne sp\82cifi\82e *)\r
+ case l\r
+ when 1: for i:=1 to 4 do\r
+ if pl.jeu(x,i,i)=free then \r
+ if posajouer(x,i)=i then trouve:=true;\r
+ p.x:=x;p.y:=i;p.h:=i;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ \r
+\r
+ when 2: for i:=1 to 4 do\r
+ if pl.jeu(x,i,(4-i)+1)=free then \r
+ if posajouer(x,i)=(4-i)+1 then trouve:=true;\r
+ p.x:=x;p.y:=i;p.h:=(4-i)+1;\r
+ fi;\r
+ exit; \r
+ fi;\r
+ od;\r
+ \r
+\r
+ esac;\r
+ when axe: (* recherche d'une place dans l'axe sp\82cifi\82e *)\r
+ if posajouer(x,h)<>5 then\r
+ p.x:=x;\r
+ p.y:=h;\r
+ p.h:=posajouer(x,h);\r
+ trouve:=true;\r
+ fi;\r
+ when coldiag:(* recherche d'une place dans la diagonnal colonne sp\82cifi\82e *)\r
+ case l\r
+ when 1: for i:=1 to 4 do\r
+ if pl.jeu(i,x,i)=free then \r
+ if posajouer(i,x)=i then trouve:=true;\r
+ p.x:=i;p.y:=x;p.h:=i;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ \r
+\r
+ when 2: for i:=1 to 4 do\r
+ if pl.jeu(i,x,(4-i)+1)=free then \r
+ if posajouer(i,x)=(4-i)+1 then trouve:=true;\r
+ p.x:=i;p.y:=x;p.h:=(4-i)+1;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ esac;\r
+\r
+ esac;\r
+ result:=trouve;\r
+ \r
+end;\r
+\r
+UNIT isintwodiag:function(x,y,h:integer;inout a,b:integer):boolean;\r
+var trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ if (h=x) and (x=y) then trouve:=true;\r
+ a:=1;b:=1;\r
+ else \r
+ if (x=y) and (h=(4-x)+1) then trouve:=true;\r
+ a:=1;b:=2;\r
+ else\r
+ if (x=(4-y)+1) and (h=x) then trouve:=true; \r
+ a:=2;b:=1;\r
+ else\r
+ if (x=(4-y)+1) and (h=y) then trouve:=true; \r
+ a:=2;b:=2;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ result:=trouve;\r
+end;\r
+\r
+UNIT isinbigdiag:function(x,y:integer;inout quel:integer):boolean;\r
+const droite=1,gauche=2;\r
+var i:integer,\r
+ trouve:boolean;\r
+begin\r
+ quel:=0;\r
+ trouve:=false;\r
+ if (x=y) then trouve:=true; \r
+ quel:=1;\r
+ else\r
+ if (x=(4-y)+1) then trouve:=true; \r
+ quel:=2 \r
+ fi;\r
+ fi; \r
+ \r
+ result:=trouve;\r
+end;\r
+\r
+\r
+UNIT isindiag:function(l,h:integer;inout dg:integer):boolean;\r
+var trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ if h=l then trouve:=true; \r
+ dg:=1;\r
+ else\r
+ if h=(4-l)+1 then trouve:=true; \r
+ dg:=2;\r
+ fi;\r
+ fi;\r
+ result:=trouve;\r
+end;\r
+\r
+\r
+unit troisboules:function(tab:arrayof info;inout p:coord3D):boolean;\r
+var i,j:integer,\r
+ trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ if p<>none then \r
+ \r
+\r
+ if tab(1).rangee(p.x,p.h).nbre_boule=3 then\r
+ trouve:=find_place(1,0,p.x,p.h,p);\r
+ \r
+ else if tab(2).rangee(p.y,p.h).nbre_boule=3 then\r
+ trouve:=find_place(2,0,p.y,p.h,p);\r
+ \r
+ else \r
+ if tab(5).rangee(p.x,p.y).nbre_boule=3 then\r
+ trouve:=find_place(5,0,p.x,p.y,p);\r
+ \r
+ else \r
+ if isinbigdiag(p.x,p.y,i) then\r
+ if tab(6).rangee(p.h,i).nbre_boule=3 then\r
+ trouve:=find_place(6,i,p.x,p.h,p);\r
+ fi;\r
+ fi;\r
+ if isintwodiag(p.x,p.y,p.h,i,j) then\r
+ if tab(7).rangee(i,j).nbre_boule=3 then \r
+ trouve:=find_place(7,0,i,j,p);\r
+ fi;\r
+ fi;\r
+ for i:=1 to 2 do\r
+ if tab(3).rangee(p.x,i).nbre_boule=3 then\r
+ trouve:=find_place(3,i,p.y,p.h,p);\r
+ exit; fi; \r
+ if tab(4).rangee(p.y,i).nbre_boule=3 then \r
+ trouve:=find_place(4,i,p.x,p.h,p);\r
+ exit; fi;\r
+ od; \r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ result:=trouve;\r
+end;\r
+\r
+UNIT addcombinaison:procedure(tab:arrayof info,x,y,h:integer);\r
+begin\r
+\r
+ call tab(1).rangee(x,h).plus; \r
+ call tab(2).rangee(y,h).plus; \r
+ call tab(5).rangee(x,y).plus;\r
+ if isindiag(y,h,quel) then\r
+ call tab(3).rangee(x,quel).plus;\r
+ fi; \r
+ if isindiag(x,h,quel) then\r
+ call tab(4).rangee(y,quel).plus;\r
+ fi; \r
+ if isinbigdiag(x,y,quel) then\r
+ call tab(6).rangee(h,quel).plus;\r
+ fi;\r
+ if isintwodiag(x,y,h,quel,version) then\r
+ call tab(7).rangee(quel,version).plus;\r
+ fi;\r
+\r
+end;\r
+UNIT delcombinaison:procedure(tab:arrayof info,x,y,h:integer);\r
+var quel,version:integer;\r
+begin\r
+\r
+ (* si une boule a deja ete mise *)\r
+ call tab(1).rangee(x,h).elimine;\r
+ call tab(2).rangee(y,h).elimine;\r
+ \r
+ if isindiag(y,h,version) then (* diagonnale ligne*)\r
+ call tab(3).rangee(x,version).elimine; fi;\r
+ if isindiag(x,h,version) then (* diagonnale colonne*)\r
+ call tab(4).rangee(y,version).elimine; fi;\r
+ call tab(5).rangee(x,y).elimine;\r
+ if isinbigdiag(x,y,quel) then\r
+ call tab(6).rangee(h,quel).elimine; fi;\r
+ if isintwodiag(x,y,h,quel,version) then\r
+ call tab(7).rangee(quel,version).elimine; fi;\r
+end;\r
+\r
+UNIT selectcoup: procedure(inout p:coord3D);\r
+var coup:element,\r
+ trouve,bien:boolean;\r
+ \r
+begin\r
+ trouve:=false;\r
+ while (not mem.vide) and (not trouve) do\r
+ coup:=mem.mini;\r
+ \r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)+1;\r
+ p.x:=coup.i;\r
+ p.y:=coup.j;\r
+ p.h:=coup.h+1;\r
+ if p.h<>5 then \r
+ if not troisboules(adver,p) then \r
+ p.h:=coup.h;\r
+ p.x:=coup.i;\r
+ p.y:=coup.j;\r
+ trouve:=true;\r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)-1;\r
+ else \r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)-1;\r
+ call mem.supprimer(coup);\r
+ fi;\r
+ else trouve:=true;\r
+ p.h:=coup.h;\r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)-1;\r
+ fi;\r
+ od;\r
+ while not mem.vide do\r
+ call mem.supprimer(mem.mini);\r
+ od;\r
+end;\r
+\r
+\r
+UNIT stratego:procedure;\r
+var coup:coord3D,\r
+ e:element,\r
+ poid,n,version,quel,x,i,j:integer;\r
+begin\r
+\r
+ for i:=1 to 4 do\r
+ for j:=1 to 4 do\r
+ if posajouer(i,j)<5 then\r
+ coup:=new coord3D(i,j,posajouer(i,j));\r
+\r
+ poid:=0;\r
+ n:=0;\r
+ \r
+ \r
+ if moi(1).rangee(coup.x,coup.h).possible then \r
+ case moi(1).rangee(coup.x,coup.h).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(1).rangee(coup.x,coup.h).nbre_boule;\r
+ esac; \r
+ n:=n+1;\r
+ fi;\r
+ if moi(2).rangee(coup.y,coup.h).possible then\r
+ case moi(2).rangee(coup.y,coup.h).nbre_boule \r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=moi(2).rangee(coup.y,coup.h).nbre_boule+poid;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ \r
+ if isindiag(coup.y,coup.h,quel) then\r
+ if moi(3).rangee(coup.x,quel).possible then\r
+ case moi(3).rangee(coup.x,quel).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(3).rangee(coup.x,quel).nbre_boule;\r
+ esac;\r
+ n:=n+1; \r
+ fi; \r
+ fi;\r
+ if isindiag(coup.x,coup.h,quel) then\r
+ if moi(4).rangee(coup.y,quel).possible then \r
+ case moi(4).rangee(coup.y,quel).nbre_boule \r
+ when 3: poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(4).rangee(coup.y,quel).nbre_boule; \r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ \r
+ if moi(5).rangee(coup.x,coup.y).possible then\r
+ case moi(5).rangee(coup.x,coup.y).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(5).rangee(coup.x,coup.y).nbre_boule;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ if isinbigdiag(coup.x,coup.y,quel) then\r
+ if moi(6).rangee(coup.h,quel).possible then\r
+ case moi(6).rangee(coup.h,quel).nbre_boule\r
+ when 3: poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(6).rangee(coup.h,quel).nbre_boule;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ if isintwodiag(coup.x,coup.y,coup.h,quel,version) then\r
+ if moi(7).rangee(quel,version).possible then\r
+ case moi(7).rangee(quel,version).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(7).rangee(quel,version).nbre_boule;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+\r
+ if adver(1).rangee(coup.x,coup.h).possible and \r
+ adver(2).rangee(coup.y,coup.h).possible then \r
+ if adver(1).rangee(coup.x,coup.h).nbre_boule=2 and\r
+ adver(2).rangee(coup.y,coup.h).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ if adver(1).rangee(coup.x,coup.h).possible and \r
+ isindiag(coup.x,coup.h,quel) then\r
+\r
+ if adver(4).rangee(coup.y,quel).possible then \r
+ if adver(1).rangee(coup.x,coup.h).nbre_boule=2 and\r
+ adver(4).rangee(coup.y,quel).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ \r
+ x:=coup.x;\r
+ for c:=1 to 2 do\r
+ if adver(c).rangee(x,coup.h).possible and \r
+ adver(5).rangee(coup.x,coup.y).possible then \r
+ if adver(c).rangee(x,coup.h).nbre_boule=2 and\r
+ adver(5).rangee(coup.x,coup.y).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ if adver(c).rangee(x,coup.h).possible and \r
+ isinbigdiag(coup.x,coup.y,quel) then\r
+\r
+ if adver(6).rangee(coup.h,quel).possible then \r
+ if adver(c).rangee(x,coup.h).nbre_boule=2 and\r
+ adver(6).rangee(coup.h,quel).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ if adver(c).rangee(x,coup.h).possible and \r
+ isintwodiag(coup.x,coup.y,coup.h,quel,version) then\r
+\r
+ if adver(7).rangee(quel,version).possible then \r
+ if adver(c).rangee(x,coup.h).nbre_boule=2 and\r
+ adver(7).rangee(quel,version).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ x:=coup.y;\r
+ od;\r
+\r
+ if adver(1).rangee(coup.x,coup.h).possible then \r
+ case adver(1).rangee(coup.x,coup.h).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ if adver(2).rangee(coup.y,coup.h).possible then\r
+ case adver(2).rangee(coup.y,coup.h).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise \r
+ poid:=1+poid;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ \r
+ if isindiag(coup.y,coup.h,quel) then\r
+ if adver(3).rangee(coup.x,quel).possible then\r
+ case adver(3).rangee(coup.x,quel).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1; \r
+ fi; \r
+ fi;\r
+ if isindiag(coup.x,coup.h,quel) then\r
+ if adver(4).rangee(coup.y,quel).possible then \r
+ case adver(4).rangee(coup.y,quel).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1; \r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ \r
+ if adver(5).rangee(coup.x,coup.y).possible then\r
+ case adver(5).rangee(coup.x,coup.y).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ if isinbigdiag(coup.x,coup.y,quel) then\r
+ if adver(6).rangee(coup.h,quel).possible then\r
+ case adver(6).rangee(coup.h,quel).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ if isintwodiag(coup.x,coup.y,coup.h,quel,version) then\r
+ if adver(7).rangee(quel,version).possible then\r
+ case adver(7).rangee(quel,version).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ if coinlibre and poid<20 then\r
+ do\r
+ pos:=round(random*3)+1;\r
+ coup.x:=cointab(pos).x;\r
+ coup.y:=cointab(pos).y;\r
+ coup.h:=1;\r
+\r
+ if pl.jeu(coup.x,coup.y,coup.h)=free then \r
+ coin:=coin-1;poid:=poid+20;\r
+ if coin=0 then coinlibre:=false; fi;\r
+ exit; fi;\r
+ \r
+ od;\r
+ fi;\r
+ poid:=(-poid);\r
+ e:=new element;\r
+ e.x:=poid; e.i:=coup.x;e.j:=coup.y;e.h:=coup.h;\r
+ call mem.inserer(e);\r
+ \r
+ fi;\r
+ od;\r
+ od;\r
+end;\r
+\r
+unit combinaison:class;\r
+ var nb:integer,\r
+ possible:boolean;\r
+ \r
+ unit incremente:function:integer;\r
+ begin \r
+ nb:=nb+1;\r
+ result:=nb;\r
+ end;\r
+ \r
+ unit plus:procedure;\r
+ begin \r
+ nb:=nb+1;\r
+ end;\r
+ \r
+ unit nbre_boule:function:integer;\r
+ begin\r
+ result:=nb;\r
+ end;\r
+\r
+ unit elimine:procedure;\r
+ begin\r
+ possible:=false;\r
+ end;\r
+\r
+begin\r
+ nb:=0;\r
+ possible:=true;\r
+END;\r
+\r
+begin\r
+ mem:=new arbtas;\r
+ array cointab dim(1:4);\r
+ cointab(1):=new coord2D(1,1);\r
+ cointab(2):=new coord2D(4,4);\r
+ cointab(3):=new coord2D(1,4);\r
+ cointab(4):=new coord2D(4,1);\r
+ coinlibre:=true;\r
+ coin:=4;\r
+ block\r
+ var i,j:integer;\r
+ begin\r
+ array adver dim (1:7);\r
+ array moi dim (1:7);\r
+ \r
+ array posajouer dim(1:4);\r
+ for i:=1 to 4 do\r
+ \r
+ array posajouer(i) dim(1:4);\r
+ \r
+ if (i<3) then\r
+ adver(i):=new info(4,4);\r
+ moi(i):=new info(4,4);\r
+ else\r
+ adver(i):=new info(4,2);\r
+ moi(i):=new info(4,2);\r
+ fi;\r
+ \r
+ od; \r
+ adver(5):=new info(4,4);\r
+ moi(5):=new info(4,4);\r
+ adver(6):=new info(4,2);\r
+ moi(6):=new info(4,2);\r
+ adver(7):=new info(2,2);\r
+ moi(7):=new info(2,2);\r
+\r
+\r
+ for i:=1 to 4 do\r
+ for j:=1 to 4 do\r
+ posajouer(i,j):=1;\r
+ od;\r
+ od;\r
+ end;\r
+\r
+ return;\r
+ place:=new coord3D(1,1,1);\r
+ DO \r
+ find:=false;\r
+ call pl.arrow.ligne(pl.line,0);\r
+ call pl.arrow.colonne(pl.col,0);\r
+ \r
+ (*****************************************)\r
+ (* elimination de quelques combinaisons *)\r
+ (*****************************************) \r
+ if pl.haut<>0 then \r
+ call addcombinaison(adver,pl.line,pl.col,pl.haut); \r
+ call delcombinaison(moi,pl.line,pl.col,pl.haut);\r
+ posajouer(pl.line,pl.col):=posajouer(pl.line,pl.col)+1;\r
+\r
+\r
+ (*********************************)\r
+ (*** est ce que j'ai gagne ? !!!!*)\r
+ (*********************************)\r
+ \r
+ find:=troisboules(moi,place);\r
+ \r
+ (*********************************)\r
+ (* contre des 3 boules align\82es *)\r
+ (*********************************) \r
+ if (pl.haut=1 and \r
+ ((pl.line=4 or pl.line=1) and (pl.col=1 or pl.col=4))) then\r
+ coin:=coin-1; fi;\r
+ if coin=0 then coinlibre:=false; fi;\r
+ \r
+ if not find then\r
+ \r
+ if (adver(1).rangee(pl.line,pl.haut).nbre_boule=3) and \r
+ (adver(1).rangee(pl.line,pl.haut).possible) then \r
+ find:=find_place(1,0,pl.line,pl.haut,place);\r
+ \r
+ fi; \r
+ if (adver(2).rangee(pl.col,pl.haut).nbre_boule=3) and \r
+ (adver(2).rangee(pl.col,pl.haut).possible) then \r
+ find:=find_place(2,0,pl.col,pl.haut,place);\r
+ \r
+ fi;\r
+ if (adver(5).rangee(pl.line,pl.col).nbre_boule=3) and \r
+ (adver(5).rangee(pl.line,pl.col).possible) then \r
+ find:=find_place(5,0,pl.line,pl.col,place);\r
+ \r
+ fi;\r
+ \r
+ if isindiag(pl.col,pl.haut,quel) then\r
+ \r
+ if (adver(3).rangee(pl.line,quel).nbre_boule=3) and\r
+ (adver(3).rangee(pl.line,quel).possible) then \r
+ find:=find_place(3,quel,pl.line,pl.haut,place);\r
+ fi;\r
+ fi; \r
+ if isindiag(pl.line,pl.haut,quel) then\r
+ \r
+ if (adver(4).rangee(pl.col,quel).nbre_boule=3) and\r
+ (adver(4).rangee(pl.col,quel).possible) then\r
+ find:=find_place(4,quel,pl.col,pl.haut,place);\r
+ fi;\r
+ \r
+ fi; \r
+ if isinbigdiag(pl.line,pl.col,quel) then\r
+ if (adver(6).rangee(pl.haut,quel).nbre_boule=3) and\r
+ (adver(6).rangee(pl.haut,quel).possible) then \r
+ find:=find_place(6,quel,pl.line,pl.haut,place);\r
+ fi;\r
+ fi;\r
+ if isintwodiag(pl.line,pl.col,pl.haut,quel,version) then\r
+ if (adver(7).rangee(quel,version).nbre_boule=3) and\r
+ (adver(7).rangee(quel,version).possible) then\r
+ find:=find_place(7,0,quel,version,place);\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+ fi;\r
+ (******************************************)\r
+ (* jouer les coins du niveau 1 en premier *)\r
+ (******************************************)\r
+ \r
+ \r
+ IF not find then \r
+ \r
+ \r
+ (*********************)\r
+ (* quel coup jouer ? *)\r
+ (*********************)\r
+ call stratego; (* evaluation de toutes les combinaisons*)\r
+ call selectcoup(place); (* choisi un coup a jouer *)\r
+ \r
+ FI;\r
+ \r
+ (*****************************************)\r
+ (* on incremente le nombre de boules... *)\r
+ (*****************************************)\r
+ call addcombinaison(moi,place.x,place.y,place.h);\r
+ call delcombinaison(adver,place.x,place.y,place.h);\r
+ posajouer(place.x,place.y):=posajouer(place.x,place.y)+1;\r
+\r
+ \r
+ \r
+ if pl.enfiler(place.x,place.y,couleur) then \r
+ call pl.arrow.ligne(place.x,blanc);\r
+ call pl.arrow.colonne(place.y,blanc);\r
+ fi;\r
+ \r
+ \r
+ detach;\r
+ od;\r
+end;\r
+\r
+UNIT humain:player COROUTINE;\r
+ var i,j:integer;\r
+ begin\r
+ i,j:=1;\r
+ return;\r
+ do\r
+ \r
+ do\r
+ \r
+ call pl.arrow.selectaxe(i,j);\r
+ if pl.enfiler(i,j,couleur) then exit; fi;\r
+ od;\r
+ detach;\r
+ od;\r
+ \r
+ end;\r
+ \r
+UNIT joueurs:class;\r
+var couleur:integer,\r
+ joueur:player,\r
+ nom:arrayof char;\r
+begin\r
+array nom dim(1:8);\r
+end;\r
+\r
+\r
+UNIT controle:iiuwgraph coroutine(equipe:arrayof joueurs,pl:Plateau_Jeu);\r
+var tour:integer,\r
+ aux: arrayof arrayof arrayof integer,\r
+ difference: pile,\r
+ pion:elem;\r
+\r
+\r
+ UNIT AquiLeTour:procedure;\r
+ begin\r
+ tour:=tour+1;\r
+ if tour=3 then tour:=1; fi;\r
+ end;\r
+\r
+ UNIT copie_jeu:procedure;\r
+ var k:integer;\r
+ begin\r
+ for k:=1 to 4 \r
+ do\r
+ aux(pl.line,pl.col,k):=pl.jeu(pl.line,pl.col,k);\r
+ od;\r
+ end;\r
+ \r
+ UNIT coup:function:boolean;\r
+ var i,j,k,n,c:integer;\r
+ \r
+ begin\r
+ call pl.arrow.ligne(pl.line,0);\r
+ call pl.arrow.colonne(pl.col,0);\r
+\r
+ n:=0;\r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ for k:=1 to 4\r
+ do\r
+ if (pl.jeu(i,j,k)<>aux(i,j,k)) then\r
+\r
+ n:=n+1; \r
+ pion:=new elem(i,j,k);\r
+ call difference.empiler(pion);\r
+ fi; \r
+ od; \r
+ od; \r
+ od; \r
+ \r
+ if n>1 or n=0 then result:=false;\r
+ else \r
+\r
+ pion:=difference.sommet;\r
+ if pl.jeu(pion.i,pion.j,pion.k)=equipe(tour).couleur then \r
+ result:=true;\r
+ pl.line:=pion.i;pl.col:=pion.j;pl.haut:=pion.k;\r
+ call pl.arrow.ligne(pl.line,blanc);\r
+ call pl.arrow.colonne(pl.col,blanc);\r
+\r
+ else result:=false;\r
+ fi;\r
+ \r
+ fi;\r
+ end;\r
+\r
+unit alignee_ligne:function(couleur:integer):integer;\r
+var a,n:integer;\r
+begin\r
+ n:=0;\r
+ for a:=1 to 4\r
+ do\r
+\r
+ if pl.jeu(a,pion.j,pion.k)=couleur then n:=n+1; fi;\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+unit colhaut:function(couleur:integer):integer;\r
+var a,n:integer;\r
+begin\r
+ n:=0;\r
+ for a:=1 to 4\r
+ do\r
+\r
+ if pl.jeu(pion.i,pion.j,a)=couleur then n:=n+1; fi;\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+\r
+unit alignee_colonne:function(couleur:integer):integer;\r
+var j,n:integer;\r
+begin\r
+ n:=0;\r
+ for j:=1 to 4\r
+ do\r
+ if pl.jeu(pion.i,j,pion.k)=couleur then n:=n+1; fi;\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+unit diag_colonne:function(dir,couleur:integer):integer;\r
+var k,i,n:integer;\r
+begin\r
+\r
+ n:=0;i:=1;\r
+ if dir=-1 then k:=4;\r
+ else k:=1;\r
+ fi;\r
+ for i:=1 to 4\r
+ do\r
+ if pl.jeu(i,pion.j,k)=couleur then n:=n+1; fi;\r
+ k:=k+(1*dir);\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+unit diagonnale: function(quel,couleur:integer):integer;\r
+var n,j,i:integer;\r
+\r
+begin\r
+ n:=0;\r
+ if quel=11 then \r
+ j:=1;\r
+ for i:=1 to 4\r
+ do\r
+ if pl.jeu(i,j,pion.k)=couleur then n:=n+1; fi;\r
+ j:=j+1;\r
+ od;\r
+ else \r
+ j:=1;\r
+ for i:=4 downto 1\r
+ do\r
+ if pl.jeu(i,j,pion.k)=couleur then n:=n+1; fi;\r
+ j:=j+1;\r
+ od;\r
+ fi;\r
+ result :=n;\r
+\r
+end;\r
+ \r
+unit doublediagonnale: function(quel,dir,couleur:integer):integer;\r
+var n,i,j,k:integer;\r
+\r
+begin\r
+ \r
+ n:=0;i:=1;\r
+ if dir=-1 then k:=4;\r
+ else k:=1;\r
+ fi;\r
+ \r
+ if quel=11 then \r
+ j:=1;\r
+ for i:=1 to 4\r
+ do\r
+ if pl.jeu(i,j,k)=couleur then n:=n+1; fi;\r
+ j:=j+1;k:=k+(1*dir);\r
+ od;\r
+ else \r
+ j:=1;\r
+ for i:=4 downto 1\r
+ do\r
+ if pl.jeu(i,j,k)=couleur then n:=n+1; fi;\r
+ j:=j+1; k:=k+(1*dir);\r
+ od;\r
+ fi;\r
+ result :=n;\r
+\r
+end;\r
+ \r
+ \r
+unit diag_ligne:function(dir,couleur:integer):integer;\r
+var k,j,n:integer;\r
+begin\r
+\r
+ n:=0;j:=1;\r
+ if dir=-1 then k:=4;\r
+ else k:=1;\r
+ fi;\r
+ for j:=1 to 4\r
+ do\r
+ if pl.jeu(pion.i,j,k)=couleur then n:=n+1; fi;\r
+ k:=k+(1*dir);\r
+ od;\r
+ result:=n;\r
+end;\r
+ \r
+\r
+UNIT gagne:function:boolean;\r
+const droite=-1,gauche=1;\r
+var rangee:boolean;\r
+ \r
+\r
+ begin\r
+ pion:=difference.sommet; \r
+ rangee:=false;\r
+ if alignee_ligne(equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if alignee_colonne(equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if diag_colonne(droite,equipe(tour).couleur)=4 then rangee:= true;fi;\r
+ if diag_colonne(gauche,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if diag_ligne(droite,equipe(tour).couleur)=4 then rangee:= true; fi;\r
+ if diag_ligne(gauche,equipe(tour).couleur)=4 then rangee:= true; fi;\r
+ \r
+ if colhaut(equipe(tour).couleur)=4 then rangee:=true; fi;\r
+\r
+ if diagonnale(11,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if doublediagonnale(11,droite,equipe(tour).couleur)=4 then rangee:=true;fi;\r
+ if doublediagonnale(11,gauche,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if diagonnale(41,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if doublediagonnale(41,droite,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if doublediagonnale(41,gauche,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+\r
+ result:=rangee;\r
+ call difference.depiler; (* pile est maintenant vide *)\r
+ end;\r
+\r
+\r
+\r
+\r
+UNIT restore:procedure;\r
+ begin\r
+ while (not (difference.vide)) do\r
+ pion:=difference.sommet;\r
+ pl.jeu(pion.i,pion.j,pion.k):=aux(pion.i,pion.j,pion.k);\r
+ call pl.boulle(pion.i,pion.j,pion.k,aux(pion.i,pion.j,pion.k));\r
+ call difference.depiler;\r
+ od;\r
+ end;\r
+ \r
+UNIT nom_joueur: gestion_caractere procedure(nom:arrayof char,couleur:integer);\r
+ var i,j:integer;\r
+ begin\r
+ call dialog1;\r
+ call color(couleur);\r
+ for i:=1 to 20\r
+ do \r
+ call move(430,240+i);\r
+ call draw(450,240+i);\r
+ od; \r
+ call displaystring(nom,460,245,blanc);\r
+ end; \r
+\r
+begin\r
+ block\r
+ var i,j,k:integer;\r
+ begin \r
+ array aux dim(1:4);\r
+\r
+ for i:=1 to 4\r
+ do\r
+ array aux(i) dim(1:4);\r
+ for j:=1 to 4\r
+ do\r
+ array aux(i,j) dim (1:4);\r
+ od;\r
+ od;\r
+ \r
+ \r
+ \r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ for k:=1 to 4\r
+ do\r
+ aux(i,j,k):=-1;\r
+ od;\r
+ od;\r
+ od;\r
+ \r
+ end;\r
+\r
+ difference:=new pile;\r
+ call pl.initialisation;\r
+ tour:=0;\r
+ return;\r
+ \r
+ do\r
+ call AquiLeTour;\r
+ do\r
+ call nom_joueur(equipe(tour).nom,equipe(tour).couleur);\r
+ if equipe(tour).joueur is humain then \r
+ call move(450,300);\r
+ call outstring("A VOTRE TOUR !"); fi;\r
+ attach(equipe(tour).joueur);\r
+ call color(0);\r
+ call move(450,300);\r
+ call outstring(" ");\r
+ if coup then exit; \r
+ else call restore; fi;\r
+ od;\r
+ if gagne then attach(main);\r
+ else call copie_jeu; fi;\r
+ od; \r
+END; \r
+\r
+UNIT pause: IIUWGRAPH procedure(t:string,x,y,couleur:integer);\r
+var c:integer;\r
+begin\r
+ call move(x,y);\r
+ call color(couleur);\r
+ call outstring(t);\r
+ c:=inkey;\r
+ do\r
+ if c<>0 then exit; fi;\r
+ c:=inkey;\r
+ od;\r
+end;\r
+\r
+\r
+UNIT Plateau_Jeu: IIUWGRAPH class;\r
+\r
+ VAR grille:arrayof arrayof coord2D,\r
+ line,col,haut:integer,\r
+ jeu: arrayof arrayof arrayof integer;\r
+\r
+ UNIT cadre: procedure;\r
+ begin \r
+ \r
+ call move(179,321);\r
+ call draw(392,250);\r
+ call draw(282,140);\r
+ call draw(69,211);\r
+ call draw(179,321);\r
+\r
+ end;\r
+\r
+\r
+ UNIT ombre: procedure(cx,cy,cxx,cyy,fill_color:integer);\r
+ var x,y,xx,yy,i:integer;\r
+ begin\r
+ call move(cx,cy);\r
+ call draw(cxx,cyy);\r
+ xx:=cxx;\r
+ yy:=cyy;\r
+ x:=cx;\r
+ y:=cy;\r
+ for i:=1 to 109\r
+ do \r
+ x:=x+1;\r
+ y:=y+1;\r
+ xx:=xx+1;\r
+ yy:=yy+1;\r
+ call move(x,y);\r
+ call draw(xx,yy);\r
+ od;\r
+ end;\r
+ \r
+ UNIT enlever:procedure(a,b:integer);\r
+ var niveau:integer,\r
+ occupe:boolean;\r
+ begin\r
+ niveau:=4;\r
+ occupe:=false;\r
+ while not occupe do\r
+ occupe:=(jeu(a,b,niveau)<>free);\r
+ if not occupe then\r
+ niveau:=niveau-1;\r
+ fi;\r
+ od;\r
+ jeu(a,b,niveau):=free;\r
+ end;\r
+ \r
+ UNIT enfiler:function(a,b,couleur:integer):boolean;\r
+ var niveau,c:integer,\r
+ libre:boolean;\r
+ begin\r
+ niveau:=5;\r
+ libre:=true;\r
+ while libre do\r
+ niveau:=niveau-1;\r
+ if niveau<>0 then \r
+ libre:= (jeu(a,b,niveau)=-1);\r
+ else libre:=false;\r
+ fi;\r
+ od;\r
+ \r
+ niveau:=niveau+1;\r
+ if niveau=5 then result:=false;\r
+ else\r
+ jeu(a,b,niveau):=couleur;\r
+ call boulle(grille(b,a).x,grille(b,a).y,niveau,couleur);\r
+ result:=true;\r
+ fi;\r
+ end;\r
+\r
+\r
+ UNIT boulle:procedure(x,y,h,couleur:integer);\r
+ \r
+ begin\r
+ call color(couleur);\r
+ call move(x,y-(26*(h-1)));\r
+ call draw(x,y-(26*(h-1))-26);\r
+ call move(x+1,y-(26*(h-1))-1);\r
+ call draw(x+1,y-(26*(h-1))-26);\r
+ call move(x-1,y-(26*(h-1))-1);\r
+ call draw(x-1,y-(26*(h-1))-26);\r
+ call move(x+1,y-(26*(h-1))+1);\r
+ call draw(x+1,y-(26*(h-1))-26);\r
+ end;\r
+ \r
+ \r
+ UNIT axe: procedure(x,y:integer);\r
+ begin\r
+ call move(x+1,y-1);\r
+ call draw(x+1,y-108);\r
+ call move(x,y);\r
+ call draw(x,y-108);\r
+ call move(x-1,y-1);\r
+ call draw(x-1,y-108);\r
+ call move(x+1,y+1);\r
+ call draw(x+1,y-108);\r
+ end; \r
+ \r
+ UNIT plan: procedure(x,y,i:integer);\r
+ var xx,yy:integer;\r
+ begin\r
+ xx:=x;\r
+ yy:=y;\r
+ call axe(xx,yy);\r
+ grille(i,1):=new coord2D(xx,yy);\r
+ xx:=xx-42;\r
+ yy:=yy-42;\r
+ call axe(xx,yy);\r
+ grille(i,2):=new coord2D(xx,yy);\r
+\r
+ call move(xx,yy);\r
+ call draw(136,278);\r
+ \r
+ xx:=xx-26;\r
+ yy:=yy-26;\r
+ call axe(xx,yy);\r
+ grille(i,3):=new coord2D(xx,yy);\r
+ call move(xx,yy);\r
+ call draw(110,252);\r
+\r
+ xx:=xx-41;\r
+ yy:=yy-41;\r
+ call axe(xx,yy);\r
+ grille(i,4):=new coord2D(xx,yy);\r
+ call move(xx,yy);\r
+ call draw(x,y);\r
+\r
+ end;\r
+\r
+ \r
+ unit rangee: procedure;\r
+\r
+ begin\r
+ call plan(round(213*0.38)+178,round(-71*0.38)+320,2);\r
+ call plan(round(213*0.65)+178,round(-71*0.65)+320,3);\r
+ call plan(213+178,-71+320,4);\r
+ end;\r
+ \r
+ \r
+ UNIT initialisation:procedure;\r
+ var i,j,k:integer;\r
+ begin\r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ for k:=1 to 4\r
+ do\r
+ jeu(i,j,k):=-1;\r
+ od;\r
+ od;\r
+ od;\r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ call boulle(grille(i,j).x,grille(i,j).y,3,blanc);\r
+ call boulle(grille(i,j).x,grille(i,j).y,1,blanc);\r
+ call boulle(grille(i,j).x,grille(i,j).y,4,blanc);\r
+ call boulle(grille(i,j).x,grille(i,j).y,2,blanc);\r
+\r
+ od;\r
+ od;\r
+ \r
+ end;\r
+\r
+ \r
+ UNIT fleche: class;\r
+ \r
+ var \r
+ tab_coord:arrayof arrayof coord2D;\r
+\r
+ unit ligne:procedure(i,couleur:integer);\r
+ \r
+ var y1:integer;\r
+ \r
+ begin\r
+ call color(couleur);\r
+ \r
+ y1:=(-(tab_coord(1,i).x-20)+tab_coord(1,i).x+3*tab_coord(1,i).y)div 3;\r
+ call move(tab_coord(1,i).x,tab_coord(1,i).y);\r
+ call draw(tab_coord(1,i).x-20,y1);\r
+ \r
+ y1:=(-(tab_coord(1,i).x-5)+tab_coord(1,i).x+3*tab_coord(1,i).y)div 3;\r
+ call move(tab_coord(1,i).x-5-3,y1-3);\r
+ call draw(tab_coord(1,i).x,tab_coord(1,i).y);\r
+ \r
+ call move(tab_coord(1,i).x,tab_coord(1,i).y+5);\r
+ call draw(tab_coord(1,i).x,tab_coord(1,i).y);\r
+ end; \r
+ \r
+ unit colonne:procedure(i,couleur:integer); \r
+ \r
+ begin\r
+ call color(couleur);\r
+ call move(tab_coord(2,i).x,tab_coord(2,i).y);\r
+ call draw(tab_coord(2,i).x+15,tab_coord(2,i).y+15);\r
+ \r
+ call move(tab_coord(2,i).x,tab_coord(2,i).y);\r
+ call draw(tab_coord(2,i).x+5,tab_coord(2,i).y);\r
+ \r
+ call move(tab_coord(2,i).x,tab_coord(2,i).y);\r
+ call draw(tab_coord(2,i).x,tab_coord(2,i).y+5);\r
+ \r
+ end;\r
+ \r
+ \r
+ UNIT SelectAxe:procedure(inout i,j:integer);\r
+ const droite=-77,gauche=-75,hauts=-72,bas=-80,retour=13;\r
+ var key:integer;\r
+ begin\r
+ call drawrect(0,0,413,349,rouge);\r
+ call ligne(line,15);\r
+ call colonne(col,15); \r
+ do\r
+ do\r
+ key:=inkey;\r
+ if key<>0 then exit; fi; \r
+ od;\r
+ \r
+ case key\r
+ when hauts : call ligne(line,0);\r
+ if line+1<=4 then\r
+ line:=line+1;fi;\r
+ call ligne(line,15);\r
+ when bas : call ligne(line,0);\r
+ if line-1>=1 then\r
+ line:=line-1; fi;\r
+ call ligne(line,15);\r
+ when gauche : call colonne(col,0);\r
+ if col-1>=1 then\r
+ col:=col-1; fi;\r
+ call colonne(col,15);\r
+ when droite : call colonne(col,0);\r
+ if col+1<=4 then\r
+ col:=col+1; fi;\r
+ call colonne(col,15);\r
+ when retour : i:=line;\r
+ j:=col;\r
+ exit;\r
+ esac; \r
+ od; \r
+ call ligne(line,0);\r
+ call colonne(col,0);\r
+ call drawrect(0,0,413,349,blanc);\r
+ end;\r
+\r
+\r
+ begin\r
+ array tab_coord dim(1:2);\r
+ for line:=2 downto 1\r
+ do \r
+ array tab_coord(line) dim(1:4);\r
+ od;\r
+ line:=line+1;\r
+ tab_coord(1,4):=new coord2D(53,219);\r
+ tab_coord(1,3):=new coord2D(92,258);\r
+ tab_coord(1,2):=new coord2D(116,282);\r
+ tab_coord(1,1):=new coord2D(160,326);\r
+ tab_coord(2,1):=new coord2D(190,332);\r
+ tab_coord(2,2):=new coord2D(271,305);\r
+ tab_coord(2,3):=new coord2D(328,286);\r
+ tab_coord(2,4):=new coord2D(398,256);\r
+\r
+ end; \r
+\r
+\r
+ var arrow:fleche;\r
+\r
+BEGIN\r
+ block\r
+ var i,j:integer;\r
+ begin\r
+call gron(1);\r
+\r
+array grille dim(1:4);\r
+\r
+for i:=1 to 4\r
+ do\r
+ array grille(i) dim(1:4);\r
+ od;\r
+\r
+array jeu dim(1:4);\r
+\r
+for i:=1 to 4\r
+ do\r
+ array jeu(i) dim(1:4);\r
+ for j:=1 to 4\r
+ do\r
+ array jeu(i,j) dim (1:4);\r
+ od;\r
+ od;\r
+\r
+\r
+call color(grisfonce);\r
+call ombre(69,223,282,152,4);\r
+call color(grisclair);\r
+call ombre(69,211,282,140,0);\r
+\r
+call color(blanc);\r
+call plan(178,320,1);\r
+call rangee;\r
+call cadre;\r
+call move(440,10);\r
+call outstring("PUISSANCE 4 CHINOIS");\r
+\r
+call drawrect(418,220,620,349,blanc);\r
+call drawrect(0,0,413,349,blanc);\r
+line,col:=2;\r
+haut:=0;\r
+arrow:= new fleche;\r
+end;\r
+END; (* fin Plateau_Jeu *)\r
+\r
+UNIT menu: gestion_caractere function:integer;\r
+var choix:integer;\r
+begin\r
+ call dialog2;\r
+ call drawrect(418,220,620,349,blanc);\r
+ call drawrect(418,50,620,200,rouge);\r
+ call color(blanc);\r
+ call move(480,60);\r
+ call outstring(" OPTIONS ");\r
+ call move(420,80);\r
+ call outstring("[1] Un joueur");\r
+ call move(420,100);\r
+ call outstring("[2] Deux joueurs");\r
+ call move(420,120);\r
+ call outstring("[0] Quitter");\r
+ call move(470,180);\r
+ call outstring("Votre choix :");\r
+ do\r
+ choix:=ConvENT(saisie(1,1,570,180));\r
+ if choix>=0 and choix<=2 then exit; fi;\r
+ od;\r
+ result:=choix;\r
+ call drawrect(418,50,620,200,blanc);\r
+ call drawrect(418,220,620,349,rouge);\r
+end;\r
+UNIT withwho: gestion_caractere function:integer;\r
+var choix:integer;\r
+begin\r
+ call dialog2;\r
+ call drawrect(418,220,620,349,blanc);\r
+ call drawrect(418,50,620,200,rouge);\r
+ call color(blanc);\r
+ call move(480,60);\r
+ call outstring(" OPTIONS ");\r
+ call move(420,80);\r
+ call outstring("[1] Ordinateur");\r
+ call move(440,90);\r
+ call outstring(" contre Vous");\r
+ call move(420,110);\r
+ call outstring("[2] Ordinateur");\r
+ call move(440,120);\r
+ call outstring(" contre Ordinateur");\r
+\r
+ call move(420,140);\r
+ call outstring("[0] Retour");\r
+ call move(470,180);\r
+ call outstring("Votre choix :");\r
+ do\r
+ choix:=ConvENT(saisie(1,1,570,180));\r
+ if choix>=0 and choix<=2 then exit; fi;\r
+ od;\r
+ result:=choix;\r
+ call drawrect(418,50,620,200,blanc);\r
+ call drawrect(418,220,620,349,rouge);\r
+end;\r
+\r
+UNIT dialog1:iiuwgraph procedure;\r
+var i:integer;\r
+begin\r
+ call color(0);\r
+ for i:=1 to 108\r
+ do\r
+ call move(419,220+i);\r
+ call draw(619,220+i);\r
+ od;\r
+ \r
+end;\r
+UNIT dialog2:iiuwgraph procedure;\r
+var i:integer;\r
+begin\r
+ call color(0);\r
+ for i:=1 to 148\r
+ do\r
+ call move(419,51+i);\r
+ call draw(619,51+i);\r
+ od;\r
+ \r
+end;\r
+\r
+UNIT name:gestion_caractere function(i:integer):arrayof char;\r
+begin\r
+ \r
+ call dialog1;\r
+ call drawrect(418,220,620,349,rouge);\r
+ call color(blanc);\r
+ call move(420,230);\r
+ if i=1 then\r
+ call outstring("Nom du joueur 1:");\r
+ else call outstring("Nom du joueur 2:");\r
+ fi;\r
+ result:=saisie(2,8,430,250);\r
+ call drawrect(418,220,620,349,blanc);\r
+end;\r
+\r
+UNIT whostart:gestion_caractere function:integer;\r
+var i,c,a:integer;\r
+begin\r
+ call dialog1;\r
+ call drawrect(418,220,620,349,rouge);\r
+ call color(blanc);\r
+ call move(420,230);\r
+ call outstring(" Voulez-vous que"); \r
+ call move(420,240);\r
+ call outstring("je commence la partie ?");\r
+ i:=1;\r
+ call move(440,260);\r
+ call color(grisfonce);\r
+ call outstring("NON");\r
+ call move(540,260);\r
+ call color(grisclair);\r
+ call outstring("OUI");\r
+ \r
+ c:=inkey;\r
+ while c<>13 do\r
+ if c<>0 then\r
+ i:=i+1;\r
+ if i>2 then i:=1; fi;\r
+\r
+ case i\r
+ when 1:call move(440,260);\r
+ call color(grisfonce);\r
+ call outstring("NON");\r
+ call move(540,260);\r
+ call color(grisclair);\r
+ call outstring("OUI");\r
+ when 2:call move(440,260);\r
+ call color(grisclair);\r
+ call outstring("NON");\r
+ call move(540,260);\r
+ call color(grisfonce);\r
+ call outstring("OUI");\r
+ esac; \r
+ fi; \r
+ c:=inkey; \r
+ od;\r
+ result:=i;\r
+end;\r
+\r
+unit thegame: gestion_caractere procedure;\r
+var a:integer;\r
+begin\r
+ call dialog2;\r
+ call displaystring(team(1).nom,430,90,bleuroi);\r
+ call move(490,120);\r
+ call color(blanc);\r
+ call outstring("contre");\r
+ call displaystring(team(2).nom,530,150,bleuroi);\r
+end;\r
+\r
+\r
+UNIT quelcouleur:gestion_caractere function(t:arrayof char):integer;\r
+const droite=-77,gauche=-75;\r
+var i,c,a:integer;\r
+begin\r
+ call dialog1;\r
+ call drawrect(418,220,620,349,rouge);\r
+ call displaystring(t,420,230,blanc);\r
+\r
+ call move(440,250);\r
+ call outstring("Boule:"); \r
+ c:=inkey;\r
+ i:=1;a:=2;\r
+ if i=boule then\r
+ i:=i+1; \r
+ a:=a+1 fi;\r
+\r
+ call move(500,250);\r
+ call color(i);\r
+ call outstring("<Couleur>");\r
+ call displaystring(unpack("->:couleur suivante"),420,310,grisfonce);\r
+ call displaystring(unpack("<-:couleur pr\82c\82dente"),420,320,grisfonce);\r
+ while c<>13 do\r
+ if c<>0 then \r
+ case c\r
+ when droite:\r
+ i:=i+1;\r
+ if i>14 then i:=1; fi;\r
+ if i=boule then\r
+ i:=i+1; fi;\r
+ if i>14 then i:=1; fi;\r
+ when gauche:\r
+ i:=i-1;\r
+ if i<1 then i:=14; fi;\r
+ if i=boule then i:=i-1;fi;\r
+ if i<1 then i:=14; fi;\r
+ esac; \r
+ \r
+ fi;\r
+ if i<>a then\r
+ a:=i;\r
+ call move(500,250);\r
+ call color(i);\r
+ call outstring("<Couleur>");\r
+ fi;\r
+ c:=inkey;\r
+ od;\r
+ result:=i;\r
+ call drawrect(418,220,620,349,blanc);\r
+end;\r
+\r
+signal quitter,gagner;\r
+VAR plateau:plateau_jeu,\r
+ team: arrayof joueurs,\r
+ c,i,j,boule:integer,\r
+ partie:boolean,\r
+ arbitre:controle;\r
+\r
+handlers\r
+ when quitter:\r
+ pref iiuwgraph block\r
+ begin\r
+ kill(arbitre);\r
+ kill(team(1).joueur);\r
+ kill(team(2).joueur);\r
+ kill(team(1));\r
+ kill(team(2));\r
+ call groff;\r
+ end;\r
+ wind;\r
+ when gagner:\r
+ pref iiuwgraph block\r
+ begin\r
+ kill(team(1).joueur);\r
+ kill(team(2).joueur);\r
+ kill(arbitre);\r
+ call color(0);\r
+ call move(450,270);\r
+ call outstring(" ");\r
+\r
+ call color(rouge);\r
+ call move(500,270);\r
+ call outstring(" A GAGNE !");\r
+ end;\r
+ return;\r
+ \r
+\r
+end;\r
+\r
+\r
+BEGIN\r
+plateau:=new plateau_jeu;\r
+array team dim(1:2);\r
+\r
+ team(1):=new joueurs;\r
+ team(2):=new joueurs;\r
+pref gestion_caractere block \r
+\r
+begin\r
+do\r
+ boule:=0;\r
+ partie:=false;\r
+ case menu\r
+ when 2:team(1).nom:=name(1); \r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ boule:=team(1).couleur;\r
+ team(1).joueur:=new humain(team(1).couleur,plateau);\r
+ team(2).nom:=name(2);\r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ team(2).joueur:=new humain(team(2).couleur,plateau);\r
+ partie:=true;\r
+ \r
+ when 1: \r
+ case withwho\r
+ when 1:\r
+ case whostart \r
+ when 2:team(1).nom:=name(1); \r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ boule:=team(1).couleur;\r
+ team(1).joueur:=new humain(team(1).couleur,plateau);\r
+ team(2).nom:=unpack("COMPUTER");\r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ team(2).joueur:=new ordi(team(2).couleur,plateau);\r
+ partie:=true;\r
+\r
+ when 1:team(2).nom:=name(2); \r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ boule:=team(2).couleur;\r
+ team(2).joueur:=new humain(team(2).couleur,plateau);\r
+ team(1).nom:=unpack("COMPUTER");\r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ team(1).joueur:=new ordi(team(1).couleur,plateau);\r
+ partie:=true;\r
+\r
+ esac;\r
+ when 2:team(1).nom:=unpack("Computer1"); \r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ boule:=team(1).couleur;\r
+ team(1).joueur:=new ordi(team(1).couleur,plateau);\r
+ team(2).nom:=unpack("Computer2");\r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ team(2).joueur:=new ordi(team(2).couleur,plateau);\r
+ partie:=true;\r
+ esac;\r
+ when 0: raise quitter;\r
+ \r
+ \r
+ esac;\r
+ if partie then \r
+ call thegame;\r
+ arbitre:=new controle(team,plateau);\r
+ attach(arbitre);\r
+ raise gagner;\r
+ kill(arbitre);\r
+ fi;\r
+ od;\r
+ \r
+end;\r
+\r
+END;\r
--- /dev/null
+ program QMsort;\r
+ \r
+(*_____________________________________________________*)\r
+ \r
+(* Pawel Susicki 1988/89 *)\r
+(* Two sorting algorithms: quick-sort and merge-sort *)\r
+(* Warning : int /m8000 qsort *)\r
+(* The maximal number of elements < 46 *)\r
+(*_____________________________________________________*)\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
+ unit Initialization : procedure(output max , min : integer);\r
+ begin\r
+ call NewPage;\r
+ call SetCursor(5,20);\r
+ writeln("TWO SORTING ALGORITHMES");\r
+ call SetCursor(7, 20);\r
+ write("by Pawel Susicki 1988/1989");\r
+ call SetCursor(12,10);\r
+ write("This program presents the parralel realisation of the ");\r
+ call SetCursor(13,10);\r
+ write("Merge-sort and Quick-sort Algoriths.");\r
+ call SetCursor(14,10);\r
+ writeln("The Elements of the sequence are chosen randomly.");\r
+ Call SetCursor(20,5);\r
+ write("Number of elements : ");readln(max);\r
+ write(" min for a process :");readln(min);\r
+ write(" press CR to start"); readln;\r
+ end Initialization;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ unit ekran:IIUWGRAPH process(nr:integer,skip:integer);\r
+ \r
+ unit print:procedure(begin_line,index,val,kolor :integer);\r
+ begin\r
+ call color(kolor);\r
+ call move(1+index*skip,begin_line);\r
+ call draw(1+index*skip,begin_line-val);\r
+ call color(0);\r
+ call move(1+index*skip,begin_line-val-1);\r
+ call draw(1+index*skip,begin_line-150);\r
+ call move(index*skip,begin_line);\r
+ call draw(index*skip,begin_line-150);\r
+ call move(2+index*skip,begin_line);\r
+ call draw(2+index*skip,begin_line-150);\r
+ end print;\r
+ \r
+ unit lightprint:procedure(begin_line,index,val,kolor:integer);\r
+ begin\r
+ call color(kolor);\r
+ for i := 0 to 2 do\r
+ call move(i+index*skip,begin_line);\r
+ call draw(i+index*skip,begin_line-val);\r
+ od;\r
+ call color(0);\r
+ for i :=0 to 1 do\r
+ call move(i+index*skip,begin_line-val-1);\r
+ call draw(i+index*skip,begin_line-150);\r
+ od;\r
+ end lightprint;\r
+ \r
+ \r
+ unit printchr:procedure(x,y:integer,s:string);\r
+ var A : arrayof char,i : integer;\r
+ begin\r
+ A := unpack(s);\r
+ call move(x,y);\r
+ call color(14);\r
+ for i := lower(A) to upper(A)\r
+ do\r
+ call HASCII(0);\r
+ call hascii(ord(A(i)));\r
+ od;\r
+ end printchr;\r
+ \r
+ begin\r
+ call gron(0);\r
+ call cls;\r
+ return;\r
+ do\r
+ accept print,lightprint,printchr;\r
+ od;\r
+end ekran;\r
+ \r
+(*-------------------------------------------------------------------*)\r
+ \r
+ \r
+unit A: process(nr:integer,begin_line:integer,ile:integer,\r
+ E:ekran,kolor:integer);\r
+(* This process is used to keep the given sequence of elements *)\r
+(* and to do all necessary manipulations on it. *)\r
+ \r
+ var tab:arrayof integer;\r
+ \r
+ unit take:function(i:integer):integer;\r
+ begin\r
+ result:=tab(i);\r
+ end take;\r
+ \r
+ unit put_tab:procedure(i,val:integer);\r
+ begin\r
+ tab(i):=val;\r
+ call E.print(begin_line,i,val,kolor);\r
+ end put_tab;\r
+ \r
+ unit light:procedure(i:integer);\r
+ begin\r
+ call E.lightprint(begin_line,i,tab(i),kolor);\r
+ end light;\r
+ \r
+ unit normal:procedure(i:integer);\r
+ begin\r
+ call E.print(begin_line,i,tab(i),kolor);\r
+ end normal;\r
+ \r
+ unit swap:procedure(i,j:integer);\r
+ var aux:integer;\r
+ begin\r
+ aux:=tab(i);\r
+ tab(i):=tab(j);\r
+ tab(j):=aux;\r
+ call E.print(begin_line,i,tab(i),kolor);\r
+ call E.print(begin_line,j,tab(j),kolor);\r
+ end swap;\r
+ \r
+ unit comp:function(i,j:integer):integer;\r
+ begin\r
+ if tab(i)<tab(j)\r
+ then result:=-1;\r
+ else\r
+ if tab(i)>tab(j)\r
+ then result:=1;\r
+ else result:=0;\r
+ fi;\r
+ fi;\r
+ end comp;\r
+ \r
+ unit printchr:procedure(x,y:integer,s:string);\r
+ begin\r
+ call E.printchr(x,begin_line-y,s);\r
+ end printchr;\r
+ \r
+ handlers\r
+ when ACCERROR:call E.printchr(325,325,"ACCERROR");\r
+ call E.groff;call endrun;\r
+ when CONERROR:call E.printchr(325,325,"CONERROR");\r
+ call E.groff;call endrun;\r
+ when LOGERROR:call E.printchr(325,325,"LOGERROR");\r
+ call E.groff;call endrun;\r
+ when MEMERROR:call E.printchr(325,325,"MEMERROR");\r
+ call E.groff;call endrun;\r
+ when NUMERROR:call E.printchr(325,325,"NUMERROR");\r
+ call E.groff;call endrun;\r
+ when TYPERROR:call E.printchr(325,325,"TYPERROR");\r
+ call E.groff;call endrun;\r
+ when SYSERROR:call E.printchr(325,325,"SYSERROR");\r
+ call E.groff;call endrun;\r
+ end handlers;\r
+ \r
+ begin\r
+ array tab dim(1:ile);\r
+ return;\r
+ do\r
+ accept take,put_tab,swap,comp,light,normal,printchr;\r
+ od;\r
+ end A;\r
+ \r
+(*----------------------------------------------------------------*)\r
+unit sync:process(nr:integer);\r
+(*This process is used uniquely for the sake of synchronization*)\r
+ unit slock:procedure;\r
+ begin\r
+ accept sunlock;\r
+ end slock;\r
+ \r
+ unit sunlock:procedure;\r
+ begin\r
+ end sunlock;\r
+ \r
+ begin\r
+ return;\r
+ do\r
+ accept slock;\r
+ od;\r
+end sync;\r
+ \r
+(*--------------------------------------------------------------------*)\r
+ \r
+unit BS:process(nr:integer,from,until:integer,T:A,father:P);\r
+(* Bubbel-sort algorithm. Both main-processes PMS and PQS use *)\r
+(* this algorithm in the case the longeur of the table is<min *)\r
+ \r
+ var left:integer, l:boolean;\r
+ begin\r
+ return;\r
+ do\r
+ l:=true;\r
+ left:=from;\r
+ do\r
+ call T.normal(left);\r
+ if T.comp(left,left+1)>0 then\r
+ call T.swap(left,left+1);\r
+ l:=false;\r
+ fi;\r
+ if left=from then call T.light(left); fi;\r
+ left:=left+1;\r
+ if left >= until then exit; fi;\r
+ call T.normal(left);(*bylo reverse*)\r
+ od;\r
+ call T.normal(from);\r
+ if l then exit; fi;\r
+ od;\r
+ call father.sync;\r
+end BS;\r
+(*---------------------------------------------------------------*)\r
+ \r
+unit P: process(nr, from,until,min:integer, T:A, father:P,\r
+ b:boolean,S:sync);\r
+(* Process- prefix for both Quick and Merge sort *)\r
+ var kolega:P, bubble:BS, left,right:integer;\r
+ \r
+ unit sync:procedure;\r
+ end sync;\r
+ \r
+handlers\r
+ when ACCERROR:call T.E.GROFF;writeln("ACCERROR");call endrun;\r
+ when CONERROR:call T.E.GROFF;writeln("CONERROR");call endrun;\r
+ when LOGERROR:call T.E.GROFF;writeln("LOGERROR");call endrun;\r
+ when MEMERROR:call T.E.GROFF;writeln("MEMERROR");call endrun;\r
+ when NUMERROR:call T.E.GROFF;writeln("NUMERROR");call endrun;\r
+ when TYPERROR:call T.E.GROFF;writeln("TYPERROR");call endrun;\r
+ when SYSERROR:call T.E.GROFF;writeln("SYSERROR");call endrun;\r
+end handlers;\r
+ \r
+end P;\r
+ \r
+unit PMS:P process;\r
+(* Algorithm MERGE-SORT. *)\r
+ var ll,rr:integer;\r
+ var tab:arrayof integer;\r
+ var l,r:boolean;\r
+ \r
+ begin\r
+ return;\r
+ call T.light(from);\r
+ left:=from+(until-from)div 2;\r
+ right:=left+1;\r
+ l:=false;\r
+ r:=true;\r
+ if left > from\r
+ then\r
+ l:=true;\r
+ if right-from+1 > min\r
+ then\r
+ kolega:=new PMS(0,from,left,min,T,this PMS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,from,left,T,this PMS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ if until > right\r
+ then\r
+ r:=true;\r
+ if until-right+1 > min\r
+ then\r
+ kolega:=new PMS(0,right,until,min,T,this PMS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,right,until,T,this PMS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ if l then accept sync; fi;\r
+ if r then accept sync; fi;\r
+ array tab dim(from:until);\r
+ left:=from;\r
+ ll:=from;\r
+ rr:=right;\r
+ do\r
+ if left>=rr\r
+ then\r
+ tab(ll):=T.take(right);\r
+ right:=right+1;\r
+ else\r
+ if right>until\r
+ then\r
+ tab(ll):=T.take(left);\r
+ left:=left+1;\r
+ else\r
+ if T.comp(left,right)<0\r
+ then\r
+ tab(ll):=T.take(left);\r
+ left:=left+1;\r
+ else\r
+ tab(ll):=T.take(right);\r
+ right:=right+1;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ ll:=ll+1;\r
+ if ll>until then exit; fi;\r
+ od;\r
+ left:=from;\r
+ do\r
+ call T.put_tab(left,tab(left));\r
+ left:=left+1;\r
+ if left>until then exit; fi;\r
+ od;\r
+ if not b\r
+ then call father.sync;\r
+ else\r
+ call T.printchr(50,60,"MERGE - SORT" );\r
+ call S.sunlock;\r
+ fi;\r
+end PMS;\r
+ \r
+unit PQS:P process;\r
+ \r
+ var counter:integer;\r
+ \r
+ unit shuffle:procedure;\r
+ begin\r
+ call T.light(from);\r
+ left:=from+1;\r
+ right:=until;\r
+ do\r
+ while T.comp(from,left) >=0 do\r
+ call T.normal(left);\r
+ left:=left+1;\r
+ if left < right then call T.normal(left); fi;\r
+ if left > right then exit; fi;\r
+ od;\r
+ while T.comp(from,right)<=0 do\r
+ call T.normal(right);\r
+ right:=right-1;\r
+ if left < right then call T.normal(right); fi;\r
+ if left > right then exit; fi;\r
+ od;\r
+ if left<right then\r
+ call T.swap(left,right);\r
+ call T.normal(left);\r
+ call T.normal(right);\r
+ fi;\r
+ if left >= right then exit; fi;\r
+ od;\r
+ call T.swap(from,right);\r
+ end shuffle;\r
+ \r
+ unit gen:procedure(from,until:integer; inout c:integer);\r
+ begin\r
+ if from < until\r
+ then\r
+ c:=c+1;\r
+ if until-right > min\r
+ then\r
+ kolega:=new PQS(0,from,until,min,T,this PQS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,from,until,T,this PQS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ end gen;\r
+ \r
+ begin\r
+ counter:=0;\r
+ return;\r
+ call shuffle;\r
+ while imax(right-from,until-right) > min+1 do\r
+ if until-right < right-from\r
+ then\r
+ call gen(right+1,until,counter);\r
+ until:=right-1;\r
+ else\r
+ call gen(from,right-1,counter);\r
+ from:=right+1;\r
+ fi;\r
+ call shuffle;\r
+ od;\r
+ call gen(right+1,until,counter);\r
+ call gen(from,right-1,counter);\r
+ while counter > 0 do\r
+ accept sync;\r
+ counter:=counter-1;\r
+ od;\r
+ if not b\r
+ then call father.sync;\r
+ else\r
+ call T.printchr(50,60,"QUICK - SORT");\r
+ call S.sunlock;\r
+ fi;\r
+end PQS;\r
+(*--------------------------------------------------------------------*)\r
+ \r
+ \r
+var E:ekran,T0,T1:A, S:sync, P1:PMS, P2:PQS,\r
+ i,x,max,min:integer;\r
+ \r
+begin\r
+ call Initialization(max,min);\r
+ \r
+ E:=new ekran(0,600/max);\r
+ resume(E);\r
+ (* the processes TO and T1 are used to operate on the given sequence*)\r
+ T0:=new A(0,160,max,E,10);\r
+ T1:=new A(0,320,max,E,11);\r
+ resume(T0);\r
+ resume(T1);\r
+ \r
+ i:=1;\r
+ while i <= max do\r
+ x := random*150;\r
+ call T0.put_tab(i,x);\r
+ call T1.put_tab(i,x);\r
+ i:=i+1;\r
+ od;\r
+ \r
+ S:=new sync(0);\r
+ resume(S);\r
+ \r
+ P1:=new PMS(0,1,max,min,T0,none,true,S);\r
+ P2:=new PQS(0,1,max,min,T1,none,true,S);\r
+ resume(P1);\r
+ resume(P2);\r
+ call S.slock;(* main wait for all other processes *)\r
+ call S.slock;\r
+ \r
+ call E.printchr(450,325,"press CR"); readln;\r
+ call E.groff;\r
+ call endrun;\r
+end qsort.\r
--- /dev/null
+PROGRAM station;\r
+(*_________________________________________________________*)\r
+(* loglan station h+ *)\r
+(* hgen station *)\r
+(* egahint /m50000 station *)\r
+(*---------------------------------------------------------*)\r
+ \r
+(*----------------------------------------------------------*)\r
+(* CALSSE DEFINISSANT LES PROCEDURES DE GRAPHISME UTILISEES *)\r
+(*----------------------------------------------------------*)\r
+ UNIT graph : IIUWGRAPH CLASS;\r
+ CONST MAXx = 635,\r
+ MAXy = 348,\r
+ LETDIMY = 08, (* Hauteur lettre *)\r
+ LETDIMX = 8, (* Largeur lettre *)\r
+ Fgauche = -75, (* Fleche gauche *)\r
+ Fdroite = -77, (* Fleche droite *)\r
+ ESC = 27, (* Touche escape *)\r
+ RETOUR = 13, (* Touche return *)\r
+ BKSPACE = 8, (* Touche Backspace *)\r
+ MOINS = 45; (* Touche signe moins *)\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant d'utiliser le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ UNIT initgraph : PROCEDURE;\r
+ BEGIN CALL GRON(1); END initgraph;\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant de fermer le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ UNIT closegraph : PROCEDURE;\r
+ BEGIN CALL GROFF; END closegraph;\r
+ \r
+ \r
+ (*-----------------------------------------------------------------*)\r
+ (* AFFICHAGE en (x,y) d'un RECTANGLE de longueur l et de hauteur h *)\r
+ (*-----------------------------------------------------------------*)\r
+ UNIT rectangle : PROCEDURE(x,y,l,h : INTEGER);\r
+ BEGIN\r
+ CALL MOVE (x,y);\r
+ CALL DRAW (x+l,y);\r
+ CALL DRAW(x+l,y+h);\r
+ CALL DRAW(x,y+h);\r
+ CALL DRAW(x,y);\r
+ END rectangle;\r
+ \r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* ECRITURE d'une CHAINE de caracteres sur l'ecran graphique en (x,y) *)\r
+ (*--------------------------------------------------------------------*)\r
+ UNIT ecrit_text : PROCEDURE(x,y : INTEGER;str : string);\r
+ VAR ch : ARRAYOF CHARACTER,\r
+ lg,i : INTEGER;\r
+ BEGIN\r
+ call color(14);\r
+ CALL move (x,y);\r
+ ch := UNPACK(str);\r
+ lg := UPPER(ch) - LOWER(ch) + 1;\r
+ FOR i := 1 TO lg DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(ORD(ch(i)));\r
+ OD;\r
+ call color(15);\r
+ END;\r
+ \r
+ (*---------------------------------*)\r
+ (* LECTURE d'une touche au clavier *)\r
+ (*---------------------------------*)\r
+ UNIT inchar : FUNCTION : INTEGER;\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ DO\r
+ i := INKEY;\r
+ IF i =/= 0 THEN EXIT;\r
+ FI;\r
+ OD;\r
+ result := i;\r
+ END inchar;\r
+ \r
+ (*-------------------------------------------------------------------*)\r
+ (* LECTURE d'un ENTIER au clavier et AFFICHAGE sur l'ecran graphique *)\r
+ (*-------------------------------------------------------------------*)\r
+ UNIT lire_entier: FUNCTION(x,y:INTEGER;OUTPUT valeur :INTEGER): BOOLEAN;\r
+ VAR nbchiffre,key,i,cas : INTEGER,\r
+ negatif : BOOLEAN;\r
+ BEGIN\r
+ CALL MOVE(x,y);\r
+ FOR i := 1 TO 6 DO\r
+ CALL HASCII(0);\r
+ CALL MOVE(INXPOS+8,INYPOS);\r
+ OD;\r
+ CALL MOVE(x,y);\r
+ DO\r
+ DO (* Lecture de la touche *)\r
+ key := inchar;\r
+ cas := key;\r
+ IF (key >= 48 AND key <= 57)\r
+ THEN cas := 1;\r
+ EXIT;\r
+ FI;\r
+ IF (key = RETOUR) OR (key = ESC) OR (key = MOINS) OR (key = BKSPACE)\r
+ THEN EXIT;\r
+ FI;\r
+ OD;\r
+ CASE cas\r
+ WHEN 1 : (* Saisie d'un chiffre *)\r
+ IF (nbchiffre < 5 )\r
+ THEN valeur := valeur*10 + key - 48;\r
+ IF x = INXPOS\r
+ THEN negatif := FALSE;\r
+ FI;\r
+ CALL HASCII(0);\r
+ CALL HASCII(key);\r
+ nbchiffre := nbchiffre + 1;\r
+ ELSE valeur :=(valeur DIV 10)*10 + key - 48;\r
+ CALL MOVE(inxpos-8,y);\r
+ CALL HASCII(0);\r
+ CALL HASCII(key);\r
+ FI;\r
+ WHEN MOINS : (* Saisie du signe moins *)\r
+ IF x = INXPOS\r
+ THEN negatif := TRUE;\r
+ CALL HASCII(0);\r
+ CALL HASCII(MOINS);\r
+ FI;\r
+ WHEN RETOUR : (* Validation du chiffre eventuellement entre *)\r
+ IF negatif\r
+ THEN valeur := 0 - valeur;\r
+ FI;\r
+ IF nbchiffre > 0\r
+ THEN result := true;\r
+ FI;\r
+ RETURN;\r
+ WHEN ESC : (* Abandon de la saisie *)\r
+ RETURN;\r
+ WHEN BKSPACE : (* Saisie de la touche Backspace *)\r
+ IF nbchiffre > 0\r
+ THEN valeur := valeur DIV 10;\r
+ CALL MOVE(INXPOS-8,y);\r
+ CALL HASCII(0);\r
+ nbchiffre := nbchiffre -1\r
+ ELSE IF negatif\r
+ THEN negatif := FALSE;\r
+ CALL MOVE(inxpos-8,y);\r
+ CALL HASCII(0);\r
+ FI;\r
+ FI;\r
+ ESAC;\r
+ OD;\r
+ END lire_entier;\r
+ \r
+ (*---------------------------------------------------------------------*)\r
+ (* ECRITURE d'un ENTIER sur l'\82cran graphique au coordonn\82es courantes *)\r
+ (*---------------------------------------------------------------------*)\r
+ UNIT ecrit_entier : PROCEDURE (x : INTEGER);\r
+ VAR val,i : INTEGER,\r
+ strx : ARRAYOF CHARACTER;\r
+ BEGIN\r
+ ARRAY strx DIM(1:7);\r
+ i := 7;\r
+ val := ABS(x);\r
+ DO\r
+ strx(i) := chr(48+(val MOD 10));\r
+ val := val DIV 10;\r
+ IF (val = 0) THEN EXIT; FI;\r
+ i := i - 1;\r
+ OD;\r
+ IF x < 0\r
+ THEN i := i - 1;\r
+ strx(i) := chr(MOINS);\r
+ FI;\r
+ WHILE i <= 7 DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(ORD(strx(i)));\r
+ i := i + 1;\r
+ OD;\r
+ END ecrit_entier;\r
+ \r
+ (*-------------------------------------------------------*)\r
+ (* PROCEDURE d'ECRITURE de l'HEURE sur l'\82cran graphique *)\r
+ (*-------------------------------------------------------*)\r
+ UNIT ecrit_heure : PROCEDURE(posx,posy : INTEGER,time : REAL);\r
+ VAR h,m,s : INTEGER;\r
+ BEGIN\r
+ h := ENTIER(time / 3600.0);\r
+ m := ENTIER(time - ENTIER(time/3600)*3600) DIV 60;\r
+ s := ENTIER(time - ENTIER(time/3600)*3600) MOD 60;\r
+ IF ( h < 10)\r
+ THEN CALL ecrit_text(posx,posy,"0");\r
+ ELSE CALL MOVE(posx,posy);\r
+ FI;\r
+ CALL ecrit_entier(h);\r
+ CALL ecrit_text(INXPOS,INYPOS,":");\r
+ IF ( m < 10) THEN CALL ecrit_text(INXPOS,INYPOS,"0"); FI;\r
+ CALL ecrit_entier(m);\r
+ CALL ecrit_text(INXPOS,INYPOS,":");\r
+ IF ( s < 10) THEN CALL ecrit_text(INXPOS,INYPOS,"0"); FI;\r
+ CALL ecrit_entier(s);\r
+ END ecrit_heure;\r
+ \r
+ END graph;\r
+ \r
+ \r
+(*----------------------------------------------------------*)\r
+(* IMPLEMENTATION d'une QUEUE DE PRIORITE sous forme de TAS *)\r
+(*----------------------------------------------------------*)\r
+UNIT priorityqueue : graph CLASS;\r
+ \r
+ (*----------------------------*)\r
+ (* CLASSE repr\82sentant le TAS *)\r
+ (*----------------------------*)\r
+ UNIT queuehead: CLASS;\r
+ VAR last,root:node;\r
+ \r
+ (*---------------------------------------------*)\r
+ (* FONCTION renvoyant l'ELEMENT MINIMUM du TAS *)\r
+ (*---------------------------------------------*)\r
+ UNIT min: FUNCTION: elem;\r
+ BEGIN\r
+ IF root=/= NONE THEN RESULT:=root.el FI;\r
+ END MIN;\r
+ \r
+ (*------------------------------------*)\r
+ (* INSERTION d'un element dans le TAS *)\r
+ (*------------------------------------*)\r
+ UNIT insert: PROCEDURE(r:elem);\r
+ VAR x,z:node;\r
+ BEGIN\r
+ x:= r.lab;\r
+ IF last=NONE\r
+ THEN root:=x;\r
+ root.left,root.right,last:=root\r
+ ELSE IF last.ns=0\r
+ THEN last.ns:=1;\r
+ z:=last.left;\r
+ last.left:=x;\r
+ x.up:=last;\r
+ x.left:=z;\r
+ z.right:=x;\r
+ ELSE last.ns:=2;\r
+ z:=last.right;\r
+ last.right:=x;\r
+ x.right:=z;\r
+ x.up:=last;\r
+ z.left:=x;\r
+ last.left.right:=x;\r
+ x.left:=last.left;\r
+ last:=z;\r
+ FI;\r
+ FI;\r
+ CALL correct(R,FALSE)\r
+ END insert;\r
+ \r
+ (*---------------------------------*)\r
+ (* SUPPRESSION d'un ELEMENT du TAS *)\r
+ (*---------------------------------*)\r
+ UNIT delete: PROCEDURE(r: elem);\r
+ VAR x,Y,z:node;\r
+ BEGIN\r
+ x:=r.lab;\r
+ z:=last.left;\r
+ IF last.ns =0\r
+ THEN Y:= z.up;\r
+ if y<>none then (*!!!!!!!!dopisalam !!!!!*)\r
+ Y.right:= last else root :=none fi;\r
+ last.left:=Y;\r
+ last:=Y;\r
+ ELSE Y:= z.left;\r
+ Y.right:= last;\r
+ last.left:= Y;\r
+ FI;\r
+ z.el.lab:=x;\r
+ x.el:= z.el;\r
+ last.ns:= last.ns-1;\r
+ r.lab:=z;\r
+ z.el:=R;\r
+ IF x.less(x.up)\r
+ THEN CALL correct(x.el,FALSE)\r
+ ELSE CALL correct(x.el,TRUE)\r
+ FI;\r
+ END delete;\r
+ \r
+ (*------------------------------------------------------------------------*)\r
+ (* CORRECTION-REEQUILIBRAGE du TAS apr\8as une insertion ou une suppression *)\r
+ (*------------------------------------------------------------------------*)\r
+ UNIT correct: PROCEDURE(r:elem,down:BOOLEAN);\r
+ VAR x,z:node,\r
+ t:elem,\r
+ fin,log:BOOLEAN;\r
+ BEGIN\r
+ z:=r.lab;\r
+ IF down\r
+ THEN WHILE NOT fin DO\r
+ IF z.ns =0\r
+ THEN fin:=TRUE;\r
+ ELSE IF z.ns=1\r
+ THEN x:=z.left;\r
+ ELSE IF z.left.less(z.right)\r
+ THEN x:=z.left;\r
+ ELSE x:=z.right;\r
+ FI;\r
+ FI;\r
+ IF z.less(x)\r
+ THEN fin:=TRUE;\r
+ ELSE t:=x.el;\r
+ x.el:=z.el;\r
+ z.el:=t;\r
+ z.el.lab:=z;\r
+ x.el.lab:=x\r
+ FI;\r
+ FI;\r
+ z:=x;\r
+ OD;\r
+ ELSE x:=z.up; (* !!!!!!!!!!refference to none **********)\r
+ IF x=NONE\r
+ THEN log:=TRUE;\r
+ ELSE log:=x.less(z);\r
+ FI;\r
+ WHILE NOT log DO\r
+ t:=z.el;\r
+ z.el:=x.el;\r
+ x.el:=t;\r
+ x.el.lab:=x;\r
+ z.el.lab:=z;\r
+ z:=x;\r
+ x:=z.up;\r
+ IF x=NONE\r
+ THEN log:=TRUE\r
+ ELSE log:=x.less(z);\r
+ FI;\r
+ OD;\r
+ FI;\r
+ END correct;\r
+ \r
+END queuehead;\r
+ \r
+(*-----------------------------------*)\r
+(* NOEUD du TAS contenant un element *)\r
+(*-----------------------------------*)\r
+UNIT node: CLASS (el:elem);\r
+VAR left,right,up: node, ns:INTEGER;\r
+ \r
+ (*-----------------------------------*)\r
+ (* COMPARAISON de deux NOEUDS du TAS *)\r
+ (*-----------------------------------*)\r
+ UNIT less: FUNCTION(x:node): BOOLEAN;\r
+ BEGIN\r
+ IF x= NONE\r
+ THEN RESULT:=FALSE\r
+ ELSE RESULT:=el.less(x.el)\r
+ FI;\r
+ END less;\r
+END node;\r
+ \r
+(*-----------------------------------*)\r
+(* TYPE generique des element du TAS *)\r
+(*-----------------------------------*)\r
+UNIT elem: CLASS(prior:REAL);\r
+VAR lab: node;\r
+ \r
+ (*----------------------------------------------------*)\r
+ (* FONCTION generique de comparaison de deux elements *)\r
+ (*----------------------------------------------------*)\r
+ UNIT VIRTUAL less: FUNCTION(x:elem):BOOLEAN;\r
+ BEGIN\r
+ IF x=NONE\r
+ THEN RESULT:= FALSE\r
+ ELSE RESULT:= prior< x.prior\r
+ FI;\r
+ END less;\r
+ \r
+ BEGIN\r
+ lab:= NEW node(THIS elem);\r
+ END elem;\r
+ \r
+END priorityqueue;\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+ \r
+(*--------------------------------*)\r
+(* MODULE GENERIQUE de SIMULATION *)\r
+(*--------------------------------*)\r
+UNIT simulation: priorityqueue CLASS;\r
+ \r
+VAR curr: simprocess, (* Processus actif *)\r
+ pq:queuehead, (* L'axe des temps *)\r
+ mainpr: mainprogram;\r
+ \r
+ UNIT simprocess: COROUTINE;\r
+ VAR event,\r
+ eventaux: eventnotice,\r
+ finish: BOOLEAN;\r
+ \r
+ (*---------------------------------------------------------*)\r
+ (* FONCTION permettant de savoir si le processus est actif *)\r
+ (*---------------------------------------------------------*)\r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* FONCTION permettant de savoir si le processus est termin\82 *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= finish;\r
+ END TERMINATED;\r
+ \r
+ UNIT evtime: FUNCTION: REAL;\r
+ BEGIN\r
+ IF IDLE\r
+ THEN CALL ERROR1;\r
+ FI;\r
+ RESULT := event.eventtime;\r
+ END evtime;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(main);\r
+ WRITELN(" Erreur tentative d'acces a un processus endormi");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(main);\r
+ WRITELN(" Erreur : tentative d'acces a un processus deja termine");\r
+ END ERROR2;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ finish:=TRUE;\r
+ CALL passivate;\r
+ CALL ERROR2;\r
+ END simprocess;\r
+ \r
+ (*-------------------------------------------------*)\r
+ (* PLACEMENT du processus actif sur l'axe du temps *)\r
+ (*-------------------------------------------------*)\r
+ UNIT eventnotice: elem CLASS;\r
+ VAR eventtime: REAL, proc: simprocess;\r
+ \r
+ UNIT VIRTUAL less: FUNCTION(x: eventnotice):BOOLEAN;\r
+ BEGIN\r
+ IF x=NONE\r
+ THEN RESULT:= FALSE;\r
+ ELSE RESULT:= eventtime< x.eventtime OR\r
+ (eventtime=x.eventtime AND prior< x.prior);\r
+ FI;\r
+ END less;\r
+ \r
+ END eventnotice;\r
+ \r
+ UNIT mainprogram: simprocess CLASS;\r
+ BEGIN\r
+ DO\r
+ ATTACH(main);\r
+ OD;\r
+ END mainprogram;\r
+ (*-----------------------------------------------------------*)\r
+ (* FONCTION permettant de savoir quel est le processus actif *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT time:FUNCTION:REAL;\r
+ BEGIN\r
+ RESULT:=current.evtime;\r
+ END time;\r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* FONCTION retournant le premier processus place sur l'axe des temps *)\r
+ (*--------------------------------------------------------------------*)\r
+ UNIT current: FUNCTION: simprocess;\r
+ BEGIN\r
+ RESULT:=curr;\r
+ END current;\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* PROCEDURE permettant d'activer le processus p \85 l'heure t *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT schedule: PROCEDURE(p:simprocess,t:REAL);\r
+ BEGIN\r
+ IF t<time\r
+ THEN t:= time\r
+ FI;\r
+ IF p=current\r
+ THEN CALL hold(T-time)\r
+ ELSE IF p.IDLE AND p.eventaux=NONE\r
+ THEN p.event,p.eventaux:= NEW eventnotice(RANDOM);\r
+ p.event.proc:=p ;\r
+ ELSE IF p.IDLE\r
+ THEN p.event:= p.eventaux;\r
+ p.event.prior:=RANDOM;\r
+ ELSE p.event.prior:=RANDOM;\r
+ CALL pq.delete(p.event);\r
+ \r
+ FI;\r
+ FI;\r
+ p.event.eventtime:= T;\r
+ CALL pq.insert(p.event);\r
+ FI;\r
+ END schedule;\r
+ \r
+ UNIT hold:PROCEDURE(t:REAL);\r
+ BEGIN\r
+ CALL pq.delete(current.event);\r
+ current.event.prior:=RANDOM;\r
+ IF t<0 THEN t:=0; FI;\r
+ current.event.eventtime:=time+T;\r
+ CALL pq.insert(current.event);\r
+ CALL choiceprocess;\r
+ END hold;\r
+ \r
+ (*----------------------------------------------------------*)\r
+ (* PROCEDURE permettant de desactiver le processus p et *)\r
+ (* d'activer le suivant processus situ\82 sur l'axe des temps *)\r
+ (*----------------------------------------------------------*)\r
+ UNIT passivate: PROCEDURE;\r
+ BEGIN\r
+ CALL pq.delete(current.event);\r
+ current.event:=NONE;\r
+ (* Choix du processus suivant \85 activer *)\r
+ CALL choiceprocess\r
+ END passivate;\r
+ \r
+ UNIT run: PROCEDURE(P:simprocess);\r
+ BEGIN\r
+ current.event.prior:=RANDOM;\r
+ IF NOT p.IDLE (* !!! SL-chain cut off !!!!!!*)\r
+ THEN p.event.prior:=0;\r
+ p.event.eventtime:=time;\r
+ CALL pq.correct(p.event,FALSE);\r
+ ELSE IF p.eventaux=NONE\r
+ THEN p.event,p.eventaux:=NEW eventnotice(0);\r
+ p.event.eventtime:=time;\r
+ p.event.proc:=p;\r
+ CALL pq.insert(p.event);\r
+ ELSE p.event:=p.eventaux;\r
+ p.event.prior:=0;\r
+ p.event.eventtime:=time;\r
+ p.event.proc:=p;\r
+ CALL pq.insert(p.event);\r
+ FI;\r
+ FI;\r
+ CALL choiceprocess;\r
+ END run;\r
+ \r
+ UNIT cancel:PROCEDURE(P: simprocess);\r
+ BEGIN\r
+ IF p= current\r
+ THEN CALL passivate;\r
+ ELSE CALL pq.delete(p.EVENT);\r
+ p.EVENT:=NONE;\r
+ FI;\r
+ END cancel;\r
+ \r
+ (*---------------------------------------------------------------------*)\r
+ (* PROCEDURE permettant de choisir le prochain processus qui va etre *)\r
+ (* activer , c'est \85 dir le premier de l'axe des temps *)\r
+ (*---------------------------------------------------------------------*)\r
+ UNIT choiceprocess:PROCEDURE;\r
+ VAR p:simprocess;\r
+ BEGIN\r
+ p:=curr;\r
+ curr:= pq.MIN QUA eventnotice.proc;\r
+ IF curr=NONE\r
+ THEN WRITE(" ERREUR DANS LE TAS"); WRITELN;\r
+ ATTACH(main);\r
+ ELSE ATTACH(curr);\r
+ FI;\r
+ END choiceprocess;\r
+ \r
+BEGIN\r
+ (* Simulation de l'axe des temps *)\r
+ pq:=NEW queuehead;\r
+ curr,mainpr:=NEW mainprogram;\r
+ mainpr.event,mainpr.eventaux:=NEW eventnotice(0);\r
+ mainpr.event.eventtime:=0;\r
+ mainpr.event.proc:=mainpr;\r
+ (* Insertion du processus sur l'axe des temps *)\r
+ CALL pq.insert(mainpr.event);\r
+ INNER;\r
+ PQ:=NONE;\r
+END simulation;\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+ \r
+ \r
+(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)\r
+(* * SIMULATION D'UNE STATION SERVICE DE 4 POMPES * *)\r
+(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)\r
+ \r
+UNIT stationservice : simulation CLASS;\r
+ \r
+(* DECLARATION DE CONSTANTES PERMETTANT DE DEFINIR LA HAUTEUR ET LA *)\r
+(* LONGUEUR D'UNE POMPE, DE LA CAISSE ET D'UNE VOITURE *)\r
+const lhpompe =90,\r
+ hhpompe = 40,\r
+ lbpompe = 20,\r
+ hbpompe = 20,\r
+ lcaisse = 90,\r
+ hcaisse = 40,\r
+ lvoiture = 25,\r
+ hvoiture = 15;\r
+ \r
+ (*-----------------------------------------------------------------*)\r
+ (* Processus permettant l'affichage du temps courant de simulation *)\r
+ (*-----------------------------------------------------------------*)\r
+ UNIT clock : simprocess CLASS;\r
+ BEGIN\r
+ CALL rectangle (1,330,150,18);\r
+ CALL ecrit_text (3,334,"TIME");\r
+ \r
+ (* BOUCLE INFINIE : AFFICHAGE de l'HEURE \85 CHAQUE FOIS que la *)\r
+ (* proc\82dure est REVEILLE *)\r
+ DO\r
+ CALL ecrit_heure (55,334,time);\r
+ CALL HOLD(60);\r
+ OD;\r
+ END clock;\r
+ \r
+ \r
+ (*----------------------------------------*)\r
+ (* Processus simulant une POMPE *)\r
+ (*----------------------------------------*)\r
+ (* tip : Style de carburant de la pompe *)\r
+ (* tipe : Numero de la pompe *)\r
+ (* lig : Coordonn\82es Y de l'\82cran *)\r
+ (* col : Coordonn\82es X de l'\82cran *)\r
+ (*----------------------------------------*)\r
+ UNIT pompe : simprocess CLASS(tip : string,tipe,lig,col : INTEGER);\r
+ \r
+ VAR nbcli : integer, (* Nbre de clients a la pompe *)\r
+ libre: boolean,(* Booleen indiquant si la pompe est libre *)\r
+ cli : client,\r
+ i,li :INTEGER;\r
+ BEGIN\r
+ \r
+ i := pos_carb+(tipe-1)*80;\r
+ (* TANT QUE la pompe est en attente *)\r
+ \r
+ (* BOUCLE INFINIE : FONCTIONNEMENT DES POMPES *)\r
+ DO\r
+ \r
+ (* Si des clients attendent pour etre servis *)\r
+ IF (file_pompe(tipe).tete =/= NONE and libre)\r
+ THEN\r
+ \r
+ cli := file_pompe(tipe).tete.el;\r
+ \r
+ (* Mise en marche de la pompe libre *)\r
+ CALL ecrit_text (205,i,"MARCHE ");\r
+ \r
+ (* Affichage du numero du client qui est actuellement servi *)\r
+ call move (265,i);\r
+ call ecrit_entier(cli.num);\r
+ \r
+ \r
+ (* CHOIX al\82atoire du nombre de litres de carburant *)\r
+ li:=irandom (1,30);\r
+ libre := false; (* la pompe est occupe par le client *)\r
+ (* D\82roulement du service de li litres de carburant *)\r
+ CALL HOLD(60*li);\r
+ \r
+ (* Mise en attente de la pompe et decrementation du *)\r
+ (* nombre de clients souhaitant etre servi \85 cette m\88me pompe *)\r
+ \r
+ nbcli := nbcli - 1;\r
+ call move(253,i+25 );\r
+ call ecrit_entier(nbcli);\r
+ \r
+ (* Affichage \85 l'\82cran des differents clients d\82sirant prendre *)\r
+ (* du carburant \85 cette pompe *)\r
+ call file_pompe(tipe).supprimer;\r
+ call aff_queue_pompe(file_pompe(tipe), tipe);\r
+ \r
+ (* AFFICHAGE sur la pompe signalant qu'elle est bloque *)\r
+ CALL ecrit_text (205,i,"BLOQUE ");\r
+ \r
+ call schedule(cli, time);\r
+ call hold(60);\r
+ \r
+ ELSE (* S'il n'y a pas de client : DESACTIVATION du processus *)\r
+ CALL PASSIVATE;\r
+ FI;\r
+ \r
+ OD;\r
+ \r
+ END pompe;\r
+ \r
+ \r
+ (*-----------------------------------------------*)\r
+ (* AFFICHAGE \85 l'\82cran d'une POMPE et du TYPE de *)\r
+ (* carburant qu'elle distribue *)\r
+ (*-----------------------------------------------*)\r
+ UNIT aff_pompe : PROCEDURE(x : pompe);\r
+ VAR i,ligne : INTEGER;\r
+ BEGIN\r
+ CALL rectangle (x.col,x.lig,lhpompe,hhpompe);\r
+ CALL rectangle (x.col-2,x.lig-2,lhpompe+4,hhpompe+4);\r
+ CALL rectangle (x.col+20,x.lig +hhpompe,lbpompe,hbpompe);\r
+ CALL ecrit_text (x.col + 3, x.lig +10,x.tip);\r
+ END aff_pompe;\r
+ \r
+ \r
+ (*--------------------------------------------------*)\r
+ (* Processus simulant la caisse *)\r
+ (*--------------------------------------------------*)\r
+ UNIT caisse : simprocess CLASS;\r
+ VAR cli : client,\r
+ i,num, nbcli : INTEGER,\r
+ libre : boolean;\r
+ BEGIN\r
+ (* BOUCLE INFINIE : FONCTIONNEMENT DE LA CAISSE *)\r
+ \r
+ DO\r
+ call move (45,180);\r
+ call ecrit_entier(nbcli);\r
+ \r
+ (* SI la FILE de la caisse n'est pas vide *)\r
+ (* ALORS traitement du client *)\r
+ (* SINON desactivation du processus caisse *)\r
+ IF (file_caisse.tete =/= NONE and libre)\r
+ THEN\r
+ cli := file_caisse.tete.el;\r
+ nbc:=nbc +1;\r
+ \r
+ (* MISE en marche de la caisse *)\r
+ CALL ecrit_text (35,170,"MARCHE ");\r
+ libre := false;\r
+ (* SUPPRESSION du client de la file d'attente de la caisse *)\r
+ CALL file_caisse.supprimer;\r
+ \r
+ (* AFFICHAGE des clients se trouvant la la FILE de la caisse *)\r
+ (* apr\8as le passage de ce client *)\r
+ CALL affiche_queue(file_caisse);\r
+ \r
+ (* AFFICHAGE du numero du client se trouvant \85 la caisse *)\r
+ call move (90,170);\r
+ call ecrit_entier(cli.num);\r
+ call color(cli.col);\r
+ \r
+ (* AFFICHAGE le client qui paye?? a la caisse *)\r
+ call aff_voiture(70,200,cli.num);\r
+ call color(15);\r
+ \r
+ (* La dur\82e du PAIEMENT est de 10x60 *)\r
+ CALL HOLD(300*random);\r
+ \r
+ (* MISE A L'ARRET de la caisee *)\r
+ (* AFFICHAGE du nombre de client se trouvant dans la file *)\r
+ nbcli := nbcli-1;\r
+ CALL move (45,180);\r
+ CALL ecrit_entier(nbcli);\r
+ \r
+ CALL ecrit_text (35,170,"STOP ");\r
+ call ecrit_text (90,170," ");\r
+ \r
+ (* CALCUL du temps total n\82c\82ssaire pour se servir et payer *)\r
+ cli.temps_attente := time - cli.temps_arrive;\r
+ \r
+ (* CUMUL des differents temps d'attente *)\r
+ temps := temps + cli.temps_attente;\r
+ \r
+ (* effacement de client qui deja paye *)\r
+ call color(0);\r
+ call aff_voiture(70,200,cli.num);\r
+ \r
+ call color(15);\r
+ i := cli.val;\r
+ KILL (cli);\r
+ libre := true;\r
+ (* ACTIVATION de la pompe qui viend d'\88tre liberer apr\8as *)\r
+ (* paiement \85 la caisse *)\r
+ mach_pompe(i).libre := true;\r
+ call schedule(mach_pompe(i), time);\r
+ i := pos_carb+(i-1)*80;\r
+ CALL ecrit_text (205,i,"PRET ");\r
+ call hold(120);\r
+ ELSE CALL passivate;\r
+ FI;\r
+ OD;\r
+ CALL passivate;\r
+ END caisse;\r
+ \r
+ (*-------------------------------------------------*)\r
+ (* AFFICHAGE de la caisse *)\r
+ (*-------------------------------------------------*)\r
+ UNIT aff_caisse : PROCEDURE( x : caisse);\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ CALL rectangle (30,150,90,40);\r
+ CALL ecrit_text (33,160,"CAISSE");\r
+ END aff_caisse;\r
+ \r
+ (*------------------------------------------------*)\r
+ (* AFFICHAGE DE LA FILE D'ATTENTE DES POMPES *)\r
+ (*------------------------------------------------*)\r
+ \r
+ \r
+ UNIT aff_queue_pompe : PROCEDURE ( q:file_attente, tip : integer);\r
+ VAR val:client;\r
+ BEGIN\r
+ posx(tip):=300;\r
+ \r
+ (* POUR CHAQUE element du tas *)\r
+ WHILE (q.prem <> NONE) DO\r
+ (* AFFICHAGE eventuel de la voiture \85 l'\82cran, c'est *)\r
+ (* \85 dire s'il y a assez de place sur l'\82cran *)\r
+ IF ((posx(tip) >= 635) OR ((posx(tip) +25) >=635)) THEN EXIT; FI;\r
+ call color(q.prem.el.col);\r
+ CALL aff_voiture(posx(tip),posy(tip),q.prem.el.num);\r
+ \r
+ q.prem:=q.prem.succ;\r
+ posx(tip):=posx(tip)+30;\r
+ OD;\r
+ \r
+ (* EFFACEMENT de la derniere voiture qui vient d'avancer *)\r
+ IF ((posx(tip) < 635) AND ((posx(tip) +25) <635)) THEN\r
+ FOR i := posy(tip) TO (posy(tip)+25)\r
+ DO\r
+ CALL ecrit_text(posx(tip),i," ");\r
+ OD;\r
+ FI;\r
+ \r
+ END aff_queue_pompe;\r
+ \r
+ \r
+ \r
+ \r
+ (*--------------------------------------------------*)\r
+ (* AFFICHAGE DE LA FILE D'ATTENTE DE LA CAISSE *)\r
+ (*--------------------------------------------------*)\r
+ \r
+ UNIT affiche_queue : PROCEDURE( q:file_attente ) ;\r
+ BEGIN\r
+ poscay:= 150;\r
+ \r
+ (* POUR CHAQUE element du tas *)\r
+ WHILE (q.prem <> NONE) DO\r
+ call ecrit_text(poscax+5,poscay+2," ");\r
+ call color(q.prem.el.col);\r
+ (* AFFICHAGE de la voiture \85 l'\82cran *)\r
+ CALL aff_voiture(poscax,poscay,q.prem.el.num);\r
+ q.prem:=q.prem.succ;\r
+ poscay:=poscay-30;\r
+ if poscay<50 then exit fi;\r
+ OD;\r
+ \r
+ (* EFFACEMENT de la derniere voiture qui vient d'avancer *)\r
+ FOR i := poscay TO (poscay+20) DO\r
+ CALL ecrit_text(poscax,i," ");\r
+ OD;\r
+ \r
+ END affiche_queue;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ (*----------------------------------------------*)\r
+ (* AFFICHAGE d'une voiture \85 l'\82cran *)\r
+ (*----------------------------------------------*)\r
+ (* posx : position X de la voiture *)\r
+ (* posy : position Y de la voiture *)\r
+ (* x : Numero \85 afficher sur la voiture, *)\r
+ (* c'est \85 dire le num\82ro du client *)\r
+ (*----------------------------------------------*)\r
+ UNIT aff_voiture : PROCEDURE(posx,posy,x:INTEGER);\r
+ BEGIN\r
+ CALL rectangle(posx,posy,25,15);\r
+ CALL move (posx+5,posy+2);\r
+ CALL ecrit_entier(x);\r
+ END aff_voiture;\r
+ \r
+ (*----------------------------------------------------*)\r
+ (* FONCTION RETOURNANT UN NOMBRE COMPRIS ENTRE a ET b *)\r
+ (*----------------------------------------------------*)\r
+ UNIT irandom : FUNCTION(a,b:INTEGER):INTEGER;\r
+ begin\r
+ result := entier((b-a)*random +a)\r
+ end irandom;\r
+ \r
+ \r
+ (*--------------------------------------------------------*)\r
+ (* Processus simulant UN CLIENT de la station *)\r
+ (*--------------------------------------------------------*)\r
+ UNIT client : simprocess CLASS(num : INTEGER);\r
+ VAR val, col : integer, (* numero de pompe et couleur de voiture choisit*)\r
+ bb : boolean, (* bb= true si le client est premier*)\r
+ temps_attente,temps_arrive : REAL; (* Temps d'attente dans la file *)\r
+ \r
+ (* On DETERMINE a l'ARRIVEE du client quel type de carburant il *)\r
+ (* souhaite *)\r
+ UNIT arrive : PROCEDURE;\r
+ VAR i,j : INTEGER;\r
+ BEGIN\r
+ \r
+ (* CHOIX ALEATOIRE du numero de pompe P que le client choisit *)\r
+ val := irandom(1,5);\r
+ col := irandom(1,14);\r
+ \r
+ (* SELON le numero de pompe : *)\r
+ (* - INSERTION du client dans la file d'attente de la pompe P *)\r
+ (* - INCREMENTATION et AFFICHAGE du nombre de client se *)\r
+ (* trouvant \85 la pompe *)\r
+ \r
+ call file_pompe(val).inserer(this client);\r
+ \r
+ j:= mach_pompe(val).nbcli + 1;\r
+ call move(253,75+(val-1)*80);\r
+ call ecrit_entier(j);\r
+ mach_pompe(val).nbcli :=j;\r
+ \r
+ \r
+ (* AFFICHAGE de la voiture du nouveau client *)\r
+ call color(col);\r
+ CALL aff_queue_pompe(file_pompe(val),val);\r
+ call color(15);\r
+ END arrive;\r
+ \r
+ BEGIN\r
+ \r
+ CALL arrive;\r
+ temps_arrive := time;\r
+ if (mach_pompe(val).libre and mach_pompe(val).idle )\r
+ then\r
+ call run(mach_pompe(val))\r
+ fi;\r
+ \r
+ call passivate;\r
+ \r
+ (* INSERTION du client dans la liste d'attente de la caisse *)\r
+ CALL file_caisse.inserer(this client);\r
+ \r
+ (* AFFICHAGE de l'ensemble des voitures qui se trouvent dans la *)\r
+ (* file d'attente de la caisse et du nombre decrement\82 du *)\r
+ (* de clients se trouvant dans la caisse *)\r
+ CALL affiche_queue(file_caisse);\r
+ caissiere.nbcli:= caissiere.nbcli +1;\r
+ if (caissiere.libre and caissiere.idle )\r
+ then\r
+ CALL run(caissiere) else call passivate;\r
+ fi;\r
+ \r
+ END client;\r
+ \r
+ (*-------------------------------------------*)\r
+ (* GENERATEUR de client *)\r
+ (*-------------------------------------------*)\r
+ UNIT gen_client : simprocess CLASS;\r
+ BEGIN\r
+ noclient := 0;\r
+ nombre := 1;\r
+ (* BOUCLE INFINIE : GENERATION D'UN CLIENT *)\r
+ DO\r
+ IF (noclient = 100)\r
+ THEN noclient := 1;\r
+ FI;\r
+ \r
+ (* GENERATION des clients plus ou moins rapide *)\r
+ (* selon la m\82t\82o qu'il fait *)\r
+ CALL schedule(NEW client(nombre),time);\r
+ CASE (weather)\r
+ WHEN 1 : CALL hold(RANDOM*300 +50);\r
+ WHEN 2 : CALL hold(RANDOM*300 +100);\r
+ WHEN 3 : CALL hold(RANDOM*300 +500);\r
+ ESAC;\r
+ noclient := noclient +1;\r
+ nombre := nombre + 1;\r
+ OD;\r
+ END gen_client;\r
+ \r
+(*---------------------------------------------*)\r
+(* TYPE des elements mis dans la file *)\r
+(*---------------------------------------------*)\r
+ UNIT link : CLASS(el : client);\r
+ VAR succ : link;\r
+ END;\r
+ \r
+ UNIT file_attente : CLASS;\r
+ VAR tete, queue,prem : link;\r
+ \r
+ (* INSERTION d'un CLIENT dans la FILE D'ATTENTE *)\r
+ UNIT inserer : PROCEDURE(x : client);\r
+ VAR inter : INTEGER;\r
+ BEGIN\r
+ IF tete = NONE\r
+ THEN tete := NEW LINK(x);\r
+ queue := tete;\r
+ ELSE queue.succ := NEW link(x);\r
+ queue := queue.succ;\r
+ FI;\r
+ prem:=tete;\r
+ END inserer;\r
+ \r
+ (* SUPPRESSION d'un client de la file d'attente *)\r
+ UNIT supprimer: PROCEDURE;\r
+ BEGIN\r
+ IF (tete =/= NONE)\r
+ THEN\r
+ tete := tete.succ;\r
+ FI;\r
+ prem:=tete;\r
+ END supprimer;\r
+END file_attente;\r
+ \r
+ \r
+(*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*)\r
+(*/*/*/*/*/* P R O G R A M M E P R I N C I P A L */*/*/*/*/*)\r
+(*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*)\r
+ CONST poscax = 150,\r
+ pos_carb = 50;\r
+ VAR\r
+ posx,posy : ARRAYOF INTEGER,(* Indice pour l'affichage *)\r
+ caissiere :caisse, (* Caisse *)\r
+ mach_pompe : ARRAYOF pompe, (* TABLEAU d'\82l\82ments de type pompe *)\r
+ poscay, (* Indice de positionnement de la caisse *)\r
+ nombre, (* Nombre de clients g\82n\82r\82s *)\r
+ nbc, (* Nombre de clients servis de carburant *)\r
+ (* et ayant pay\82 *)\r
+ i, (* Variable de boucle *)\r
+ noclient, (* Nbre totale des clients *)\r
+ y, (* *)\r
+ car, (* Variable permettant la saisie d'une touche *)\r
+ time_simulation,\r
+ weather : INTEGER, (* Variable signalant le temps qu'il fait *)\r
+ horloge : clock, (* Compteur de l'heure *)\r
+ cli : client, (* UN client *)\r
+ file_pompe : ARRAYOF file_attente, (* TABLEAU de FILES D'ATTENTE *)\r
+ (* pour les pompes *)\r
+ file_caisse : file_attente, (* FILE D'ATTENTE de la caisse *)\r
+ temps :real, (* TEMPS MOYEN d'attente de chaque client *)\r
+ bol: boolean;(* booleen retourn\82 par une fonction de la class GRAPH *)\r
+ \r
+ \r
+ BEGIN\r
+ \r
+ (* CREATION et INITIALISATION DES DIFFERENTS TABLEAUX *)\r
+ (* d'indice pour les affichages graphiques *)\r
+ \r
+ ARRAY posy DIM(1:4);\r
+ ARRAY posx DIM(1:4);\r
+ FOR i:=1 TO 4 DO\r
+ posx(i):=300;\r
+ OD;\r
+ posy(1):=45;\r
+ posy(2):=125;\r
+ posy(3):=205;\r
+ posy(4):=285;\r
+ \r
+ (* OUVERTURE DU MODE GRAPHIQUE *)\r
+ CALL initgraph;\r
+ \r
+ (* AFFICHAGE sommaire du sujet de la simulation et de la presentation *)\r
+ CALL cls;\r
+ CALL rectangle (1,1,635,348);\r
+ CALL move (15,174);\r
+ CALL ecrit_text (15,174,\r
+ " SIMULATION D'UNE STATION SERVICE COMPRENANT 4 POMPES\r
+ ET D'UNE CAISSE ");\r
+ \r
+ (* LECTURE ET CONTROLE d'une hypothese n\82c\82ssaire *)\r
+ (* au d\82roulement de la simulation *)\r
+ (* (temps qu'il fait) *)\r
+ CALL ecrit_text (50,190," 1 - BEAU TEMPS");\r
+ CALL ecrit_text (50,210," 2 - TEMPS COUVERT");\r
+ CALL ecrit_text (50,230," 3 - NUIT");\r
+ CALL ecrit_text (50,250," VOTRE CHOIX :");\r
+ DO\r
+ bol:= lire_entier(250,250,weather);\r
+ IF (weather>0 and weather<4) then\r
+ exit\r
+ ELSE\r
+ CALL ecrit_text (50,250,"REDONNER VOTRE CHOIX :");\r
+ FI;\r
+ OD;\r
+ call ecrit_text (50, 270," simulation time en minutes: ");\r
+ bol := lire_entier(270,270,time_simulation);\r
+ CALL ecrit_text (200,300,"< TAPER SUR UNE TOUCHE POUR CONTINUER >");\r
+ \r
+ (* CREATION de la file d'attente de clients pour chaque pompe *)\r
+ ARRAY file_pompe DIM(1:4);\r
+ FOR i:= 1 TO 4\r
+ DO\r
+ file_pompe(i) := new file_attente;\r
+ OD;\r
+ \r
+ (* CREATION de la file d'attente de clients pour la caisse *)\r
+ file_caisse := NEW file_attente;\r
+ \r
+ (* CREATION de l'HORLOGE de la simulation *)\r
+ horloge := NEW clock;\r
+ CALL schedule(horloge,time);\r
+ \r
+ (* CREATION de 4 POMPES *)\r
+ ARRAY mach_pompe DIM(1:4);\r
+ mach_pompe(1) := new pompe ("ESSENCE",1,25,200);\r
+ mach_pompe(2) := new pompe ("SUPER",2,105,200);\r
+ mach_pompe(3) := new pompe ("S PLOMB",3,185,200);\r
+ mach_pompe(4) := new pompe ("GAZOIL",4,265,200);\r
+ \r
+ \r
+ (* AFFICHAGE d'une page vierge *)\r
+ CALL cls;\r
+ CALL rectangle (1,1,635,348);\r
+ \r
+ (* AFFICHAGE des 4 pompes de la STATION *)\r
+ y := pos_carb;\r
+ FOR i := 1 TO 4 DO\r
+ CALL color(i+1);\r
+ CALL aff_pompe(mach_pompe(i));\r
+ CALL ecrit_text(205,y,"LIBRE ");\r
+ mach_pompe(i).libre := true;\r
+ y := y +80;\r
+ OD;\r
+ CALL color(15);\r
+ \r
+ (* CREATION de la caisse *)\r
+ caissiere := NEW caisse;\r
+ CALL aff_caisse(caissiere);\r
+ Call ecrit_text(35,170,"LIBRE ");\r
+ caissiere.libre := true;\r
+ \r
+ CALL ecrit_text (60,10,"FILE DE LA CAISSE ");\r
+ CALL ecrit_text (360,10, "FILES D'ATTENTE DES POMPES");\r
+END;\r
+ \r
+BEGIN\r
+ PREF stationservice BLOCK\r
+ VAR car,sauv : INTEGER;\r
+ \r
+ (* Procedure permettant la recherche du type de pompe qu'il faut rajouter *)\r
+ (* \85 la station service *)\r
+ UNIT recherche :PROCEDURE(i,j:integer);\r
+ var n : integer;\r
+ BEGIN\r
+ for n :=1 to 4 do\r
+ IF mach_pompe(n).nbcli>=j THEN\r
+ case n\r
+ when 1 : CALL ecrit_text(300,i,"- ESSENCE");\r
+ when 2 : CALL ecrit_text(300,i,"- SUPER");\r
+ when 3 : CALL ecrit_text(300,i,"- S PLOMB");\r
+ when 4 : CALL ecrit_text(300,i,"- GAZOIL ");\r
+ esac;\r
+ i:=i+10;\r
+ FI;\r
+ od;\r
+ \r
+ END recherche;\r
+ \r
+ BEGIN\r
+ CALL schedule(NEW gen_client,TIME);\r
+ CALL hold(Time_simulation*60);\r
+ CALL ecrit_text (400,324,"FIN DE LA SIMULATION");\r
+ CALL ecrit_text (200,335,"< TAPER SUR UNE TOUCHE POUR CONTINUER >");\r
+ car := inchar;\r
+ CALL cls;\r
+ CALL ecrit_text(100,10,\r
+ " OBSERVATION FINALE DE LA SIMULATION DE LA STATION");\r
+ \r
+ (* SI le nombre de client ayant pay\82 est diff\82rent de z\82ro *)\r
+ IF (nbc <> 0) THEN\r
+ \r
+ (* AFFICHAGE DES OBSERVATIONS FINALES SELON LA METEO *)\r
+ temps := (temps/nbc);\r
+ CALL ecrit_text (100,100,"PENDANT LE TEMPS DE LA SIMILATION, SEULEMENT ");\r
+ CALL move (460,100);\r
+ CALL ecrit_entier(nbc);\r
+ CALL ecrit_text (100,125,"PERSONNES ONT ETE TOTALEMENT SATISFAITES");\r
+ CALL ecrit_text (100,150,"LE TEMPS MOYEN PASSE A LA STATION EST : ");\r
+ CALL ecrit_heure (450,150,temps);\r
+ \r
+ \r
+ \r
+ sauv := 0;\r
+ for i :=1 to 4 do\r
+ y := mach_pompe(i).nbcli;\r
+ if sauv< y then sauv := y fi;\r
+ od;\r
+ \r
+ \r
+ case weather\r
+ when 1 : If ((sauv <=6) and (temps <=3000)) then\r
+ CALL ecrit_text (50,200,"LA STATION FONCTIONNE BIEN ");\r
+ fi;\r
+ If ((sauv <=6) and (temps >3000)) then\r
+ CALL ecrit_text (50,200,\r
+ "LES POMPES NE SONT PAS ASSEZ PUISSANTES");\r
+ fi;\r
+ If ((sauv >6) and (temps <=3000)) then\r
+ CALL ecrit_text (50,200,\r
+ "LES POMPES NE SONT PAS ASEZ PUISSANTES\r
+VEILLEZ A AJOUTER DES POMPES : ");\r
+ CALL RECHERCHE (225,6)\r
+ fi;\r
+ If ((sauv >6) and (temps >3000)) then\r
+ CALL ecrit_text (50,200,"LA CONSTRUCTION D'UNE AUTRE STATION");\r
+ CALL ecrit_text (50,225," PARAIT NECESSAIRE ");\r
+ fi;\r
+ when 2 : If ((sauv <=5) and (temps <=2400)) then\r
+ CALL ecrit_text (50,200,"LA STATION FONCTIONNE BIEN ");\r
+ fi;\r
+ If ((sauv <=5) and (temps >2400)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASSEZ PUISSANTES");\r
+ fi;\r
+ If ((sauv >5) and (temps <=2400)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASEZ PUISSANTES\r
+VEILLEZ A AJOUTER DES POMPES : ");\r
+ CALL RECHERCHE (225,5)\r
+ fi;\r
+ If ((sauv >5) and (temps >2400)) then\r
+ CALL ecrit_text (50,200,"LA CONSTRUCTION D'UNE AUTRE STATION");\r
+ CALL ecrit_text (50,225," PARAIT NECESSAIRE ");\r
+ fi;\r
+ when 3 : If ((sauv <=2) and (temps <=1800)) then\r
+ CALL ecrit_text (50,200,"LA STATION FONCTIONNE BIEN COMPTE\r
+TENUE QUE C'EST LA NUIT ");\r
+ fi;\r
+ If ((sauv <=2) and (temps >1800)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASSEZ PUISSANTES");\r
+ fi;\r
+ If ((sauv >2) and (temps <=1800)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASEZ PUISSANTES\r
+VEILLEZ A AJOUTER DES POMPES : ");\r
+ CALL RECHERCHE (225,2)\r
+ fi;\r
+ If ((sauv >2) and (temps >1800)) then\r
+ CALL ecrit_text (50,200,"LA CONSTRUCTION D'UNE AUTRE STATION");\r
+ CALL ecrit_text (50,225," PARAIT NECESSAIRE ");\r
+ fi;\r
+ \r
+ esac;\r
+ \r
+ (* SINON AFFICHAGE D'UN MESSAGE SIGNALANT QU'AUCUN CLIENT N'A PAYE *)\r
+ ELSE CALL ecrit_text (100,150,"AUCUN CLIENT N'A EU LE TEMPS DE SE SERVIR\r
+ET DE PAYER");\r
+ FI;\r
+ CALL rectangle (1,1,635,348);\r
+ CALL rectangle (10,30,612,300);\r
+ car:=inchar;\r
+ \r
+ (* FERMETURE DU MODE GRAPHIQUE *)\r
+ CALL closegraph;\r
+ \r
+ END;\r
+END station;\r
+ \r
--- /dev/null
+\r
+PROGRAM p2;\r
+begin\r
+\r
+ (* auteur: VERNAZOBRES Fr\82d\82ric 1992/1993 *)\r
+ \r
+pref iiuwgraph block;\r
+ \r
+ \r
+(****************************************************************************)\r
+(* Attente d'un caract\82re \85 lire au clavier *)\r
+(****************************************************************************)\r
+ \r
+ UNIT Readkey:FUNCTION:CHAR;\r
+ VAR Car:CHAR;\r
+ BEGIN\r
+ Car:=CHR(0);\r
+ WHILE (Car=CHR(0))\r
+ DO\r
+ CAR:=CHR(INKEY);\r
+ OD;\r
+ RESULT:=Car;\r
+ END Readkey;\r
+ \r
+(****************************************************************************)\r
+(* Affichage des allumettes *)\r
+(****************************************************************************)\r
+ \r
+ unit alumet:procedure(x,y:integer);\r
+ begin\r
+ call color(6);\r
+ call move(160+y*20,50+x*50);\r
+ call draw(163+y*20,50+x*50);\r
+ call draw(163+y*20,20+x*50);\r
+ call draw(160+y*20,20+x*50);\r
+ call draw(160+y*20,50+x*50);\r
+ call color(4);\r
+ call cirb(161+y*20,20+x*50,3,10,10,4,2,3,2);\r
+ end;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ UNIT dessin_all:procedure(x:integer);\r
+ var i,j,k,s:integer;\r
+ begin\r
+ s:=x div 16;\r
+ for j:=1 to s\r
+ do\r
+ for i:=0 to 14\r
+ do\r
+ call alumet(j,i);\r
+ od;\r
+ od;\r
+ FOR i:=0 to ((x mod 16)+s-1)\r
+ do\r
+ call alumet(s+1,i);\r
+ od\r
+ end;\r
+ \r
+ \r
+(****************************************************************************)\r
+(* Effacement d'une allumette *)\r
+(****************************************************************************)\r
+ \r
+ unit feu:coroutine;\r
+ var i,j,s,t,k,l:integer,c:char,y,z:real;\r
+ begin\r
+ return;\r
+ do\r
+ t:=nb;\r
+ for i:=1 to x\r
+ do\r
+ s:=(t-1) div 15;\r
+ if (s=0) then j:=t mod 16-1 else j:=t mod (15*s+1) fi;\r
+ s:=s+1;\r
+ for k:=0 to 28\r
+ do\r
+ call color(4);\r
+ call cirb(161+j*20,20+s*50+k,3,10,10,2,2,2,2);\r
+ call move(157+j*20,18+s*50+k);\r
+ call color(2);\r
+ call draw(162+j*20,11+s*50+k);\r
+ call draw(165+j*20,18+s*50+k);\r
+ for l:=1 to 300 do od;\r
+ call color(0);\r
+ call cirb(161+j*20,20+s*50+k,3,10,10,0,2,2,2);\r
+ call move(157+j*20,18+s*50+k);\r
+ call color(0);\r
+ call draw(162+j*20,11+s*50+k);\r
+ call draw(165+j*20,18+s*50+k);\r
+ od;\r
+ t:=t-1;\r
+ od;\r
+ detach;\r
+ od;\r
+ end feu;\r
+ \r
+ \r
+ \r
+(****************************************************************************)\r
+(* Strategie nø1 (l'ordinateur gagne si le nb d'allumettes =/= 4n+5) *)\r
+(****************************************************************************)\r
+ \r
+ \r
+ UNIT strategie1:coroutine;\r
+ var g,l:integer,c:char,f:feu;\r
+ begin\r
+ return;\r
+ do\r
+ if (nb>=5)\r
+ then\r
+ x:=(nb-5) mod 4;\r
+ if (x=0) then x:=1 fi;\r
+ else\r
+ x:=nb-1\r
+ fi;\r
+ call move(100,280);\r
+ call color(2);\r
+ c:=chr(48+x);\r
+ if (rep=3) then call outstring(" strat\82gie 1:") fi;\r
+ call outstring(" j'enl\8ave ");\r
+ call hascii(48+x);\r
+ call outstring(" allumette(s)");\r
+ for l:=1 to 6800 do od;\r
+ f:=new feu;\r
+ attach(f);\r
+ kill(f);\r
+ call move(100,280);\r
+ call outstring(" ");\r
+ nb:=nb-x;\r
+ detach;\r
+ od;\r
+ end;\r
+ \r
+ \r
+(****************************************************************************)\r
+(* Strategie Nø2 (arbre de jeu) *)\r
+(****************************************************************************)\r
+ \r
+ \r
+ \r
+ Unit noeud:class;\r
+ var valeur:integer,\r
+ gauche,centre,droit:noeud;\r
+ end noeud;\r
+ \r
+ \r
+ \r
+ \r
+ Unit arbre_jeu:procedure(nb:integer;inout pair:boolean;inout cpt:integer);\r
+ var tree:noeud;\r
+ begin\r
+ tree:=new noeud;\r
+ tree.valeur:=nb;\r
+ if tree.valeur=1\r
+ then\r
+ if pair then cpt:=cpt-1 else cpt:=cpt+1 fi;\r
+ fi;\r
+ pair:=not pair;\r
+ if nb>1 then call arbre_jeu(nb-1,pair,cpt) fi;\r
+ if nb>2 then call arbre_jeu(nb-2,pair,cpt) fi;\r
+ if nb>3 then call arbre_jeu(nb-3,pair,cpt) fi;\r
+ kill (tree);\r
+ end;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ Unit undeuxtrois:procedure(nb:integer;output choix:integer);\r
+ var cptg,cptc,cptd:integer,\r
+ pair:boolean;\r
+ begin\r
+ cptg:=0;\r
+ cptc:=0;\r
+ cptd:=0;\r
+ pair:=true;\r
+ if nb>1 then call arbre_jeu(nb-1,pair,cptg) fi;\r
+ if nb>2 then call arbre_jeu(nb-2,pair,cptc) fi;\r
+ if nb>3 then call arbre_jeu(nb-3,pair,cptd) fi;\r
+ if ((cptg<=cptc) and (cptg<=cptd))\r
+ then\r
+ choix:=1\r
+ else\r
+ if ((cptc<=cptg) and (cptc<=cptd))\r
+ then\r
+ choix:=2\r
+ else\r
+ if ((cptd<=cptg) and (cptd<=cptc))\r
+ then\r
+ choix:=3\r
+ fi;\r
+ fi;\r
+ fi;\r
+ end;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ Unit strategie2:coroutine;\r
+ var l:integer,f:feu;\r
+ begin\r
+ return;\r
+ do\r
+ call move(100,280);\r
+ call outstring(" je reflechis !!!");\r
+ call undeuxtrois(nb,x);\r
+ call move(100,280);\r
+ call outstring(" ");\r
+ call move(100,280);\r
+ call color(2);\r
+ if (rep=3) then call outstring(" strat\82gie 2:") fi;\r
+ call outstring(" j'enl\8ave ");\r
+ call hascii(48+x);\r
+ call outstring(" allumette(s)");\r
+ for l:=1 to 6800 do od;\r
+ f:=new feu;\r
+ attach(f);\r
+ kill(f);\r
+ call move(100,280);\r
+ call outstring(" ");\r
+ nb:=nb-x;\r
+ detach;\r
+ od;\r
+ end;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+(****************************************************************************)\r
+(* programme principal *)\r
+(****************************************************************************)\r
+ \r
+ var c,ch,car:char,x,rep,y,amoi,nb,g:integer,\r
+ s1:strategie1,f:feu,s2:strategie2;\r
+ begin\r
+ do\r
+ \r
+ \r
+ do\r
+ write(chr(27),"[2J");\r
+ writeln;\r
+ writeln;\r
+ writeln;\r
+ writeln("1: Jouer contre l'ordinateur niveau facile");\r
+ writeln("2: Jouer contre l'ordinateur niveau difficile ");\r
+ writeln("3: Mode d\82monstration");\r
+ writeln("4: Sortir");\r
+ writeln;\r
+ write("R\82ponse:");\r
+ readln(rep);\r
+ if (rep>0) and (rep<5) then exit fi;\r
+ od;\r
+ \r
+ \r
+ \r
+ if (rep=4) then exit fi;\r
+ \r
+ \r
+ \r
+ do\r
+ writeln;\r
+ writeln;\r
+ if (rep=2) then\r
+ write("Avec combien d'allumettes(2<= =>30) voulez vous jouer?: ")\r
+ else\r
+ write("Avec combien d'allumettes(2<= =>16) voulez vous jouer?: ");\r
+ fi;\r
+ readln(nb);\r
+ if (rep=2) then\r
+ if (nb>=2) and (nb<=30) then exit fi;\r
+ else\r
+ if (nb>=2) and (nb<=15) then exit fi;\r
+ fi;\r
+ od;\r
+ \r
+ \r
+ c:='n';\r
+ if (rep<3) then\r
+ do\r
+ writeln;\r
+ writeln;\r
+ write("Voulez vous commencer (y/n)?: ");\r
+ readln(c);\r
+ if (c='y') orif (c='n') then exit fi;\r
+ od;\r
+ fi;\r
+ \r
+ \r
+ call gron(1);\r
+ call cls;\r
+ call color(5);\r
+ call move(70,250);\r
+ call draw(455,250);\r
+ call draw(455,310);\r
+ call draw(70,310);\r
+ call draw(70,250);\r
+ if (c='n') then g:=0 else g:=1 fi;\r
+ if (rep=2) orif (rep=3) then s1:=new strategie1 fi;\r
+ if (rep=1) orif (rep=3) then s2:=new strategie2 fi;\r
+ \r
+ \r
+ do\r
+ call dessin_all(nb);\r
+ if (c='n')\r
+ then\r
+ if (nb=1) then exit fi;\r
+ if (rep=1) orif (rep=3)\r
+ then\r
+ attach(s2)\r
+ else\r
+ attach(s1)\r
+ fi;\r
+ g:=1-g;\r
+ if nb=1 then exit fi;\r
+ fi;\r
+ c:='n';\r
+ \r
+ \r
+ if (rep<>3) then\r
+ do\r
+ call color(2);\r
+ call move(110,280);\r
+ call outstring("Combien voulez vous enlever");\r
+ call move(110,290);\r
+ call outstring("d'allumettes (entre 1 et 3) ? : ");\r
+ car:=readkey;\r
+ x:=(ord(car)-48);\r
+ call hascii(x+48);\r
+ if (car='1') orif (car='2') orif (car='3')\r
+ then\r
+ if (nb-x>=1) then exit fi;\r
+ fi\r
+ od;\r
+ \r
+ \r
+ f:=new feu;\r
+ attach(f);\r
+ kill(f);\r
+ call move(100,280);\r
+ call outstring(" ");\r
+ call move(100,290);\r
+ call outstring(" ");\r
+ nb:=nb-x;\r
+ else\r
+ attach(s1)\r
+ fi;\r
+ g:=1-g;\r
+ od;\r
+ \r
+ \r
+ call move(210,290);\r
+ call color(2);\r
+ if (g=0) then\r
+ if (rep=3) then call outstring("strategie 2: ") fi;\r
+ call outstring("J'AI PERDU")\r
+ else\r
+ if (rep=3)\r
+ then\r
+ call outstring("strategie 1: J'AI PERDU")\r
+ else\r
+ call outstring("VOUS AVEZ PERDU")\r
+ fi;\r
+ fi;\r
+ ch:=readkey;\r
+ call groff;\r
+ od;\r
+ end;\r
+ \r
+ \r
+END p2;\r
--- /dev/null
+program dames;\r
+(*----------------------------------------------------------------------*)\r
+(* Auteurs:BERNARD Didier licence informatique *)\r
+(* DUCAMP Denis ann\82e 1992-1993 *)\r
+(* *)\r
+(* JEU DE DAMES *)\r
+(*----------------------------------------------------------------------*)\r
+const vide=0,pion=1,dame=2,bloc=4,noir=-1,blanc=1,damenoire=-2,dameblanche=2;\r
+ var quit:boolean,\r
+ horiz,vert,debhoriz,debvert,horiz1,vert1,horiz2,\r
+ coulblanc,coulnoir,coulrouge:integer,\r
+ damier:arrayof integer,\r
+ liste,h_g,h_d,b_g,b_d:arrayof arrayof integer,\r
+ ap:aff_pions,\r
+ arb:arbitre,\r
+ cc:calc_coord,\r
+ clc:calcul_liste_coup,\r
+ clr:clear;\r
+\r
+unit init_deplact:procedure;\r
+(* Cette proc\82dure calcule pour chaque case le num\82ro de la case au *)\r
+(* dessus \85 gauche, au dessus \85 droite, en bas \85 gauche et en bas \85 droite *)\r
+\r
+var i,j,k:integer;\r
+begin\r
+ array h_g dim(noir:blanc);\r
+ array h_g(noir) dim(1:50); array h_g(blanc) dim(1:50);\r
+ array h_d dim(noir:blanc);\r
+ array h_d(noir) dim(1:50); array h_d(blanc) dim(1:50);\r
+ array b_g dim(noir:blanc);\r
+ array b_g(noir) dim(1:50); array b_g(blanc) dim(1:50);\r
+ array b_d dim(noir:blanc);\r
+ array b_d(noir) dim(1:50); array b_d(blanc) dim(1:50);\r
+ for i:=1 to 50 do\r
+ j:=i mod 10; k:=(i-1)mod 10;\r
+ if i<=5 or j=6 then h_g(blanc,i):=0;\r
+ else if k<5 then h_g(blanc,i):=i-5;\r
+ else h_g(blanc,i):=i-6; fi; fi;\r
+ if i<=5 or j=5 then h_d(blanc,i):=0;\r
+ else if k<5 then h_d(blanc,i):=i-4;\r
+ else h_d(blanc,i):=i-5; fi; fi;\r
+ if i>=46 or j=6 then b_g(blanc,i):=0;\r
+ else if k<5 then b_g(blanc,i):=i+5;\r
+ else b_g(blanc,i):=i+4; fi; fi;\r
+ if i>=46 or j=5 then b_d(blanc,i):=0;\r
+ else if k<5 then b_d(blanc,i):=i+6;\r
+ else b_d(blanc,i):=i+5; fi; fi;\r
+ h_d(noir,i):=b_g(blanc,i); h_g(noir,i):=b_d(blanc,i);\r
+ b_d(noir,i):=h_g(blanc,i); b_g(noir,i):=h_d(blanc,i);\r
+ od;\r
+end init_deplact;\r
+\r
+unit calcul_liste_coup:coroutine;\r
+(* Cette coroutine calcule la liste des coups du joueur qui \85 la main *)\r
+\r
+var i,nc,joueur,nbmax,nb_coup:integer,\r
+ coup,damier:arrayof integer,\r
+ liste_coup:arrayof arrayof integer,\r
+ saut:boolean,\r
+ ec:enreg_coup;\r
+\r
+unit enreg_coup:coroutine;\r
+(* Cette coroutine enregistre un coup dans la liste des coups *)\r
+\r
+var i,nb:integer;\r
+begin\r
+return;\r
+do;\r
+ if nb=nbmax then \r
+ nb_coup:=nb_coup+1;\r
+ array liste_coup(nb_coup) dim(1:nb);\r
+ for i:=1 to nb do liste_coup(nb_coup,i):=coup(i); od;\r
+ else if nb>nbmax then\r
+ (* La longueur du nouveau coup est sup\82rieure \85 celle des autres *) \r
+ (* donc on peut supprimer les anciens qui ne peuvent plus etre jou\82s *)\r
+ for i:=1 to nb_coup do kill(liste_coup(i)); od;\r
+ array liste_coup(1) dim(1:nb);\r
+ nb_coup:=1;\r
+ nbmax:=nb;\r
+ for i:=1 to nb do liste_coup(1,i):=coup(i); od;\r
+ fi; fi;\r
+ detach;\r
+od;\r
+end enreg_coup;\r
+\r
+unit recurse_pion:procedure\r
+(damier:arrayof integer,num,sautee,caz:integer,prof:boolean);\r
+(* Cette proc\82dure recherche tous les coups possibles pour un pion donn\82 *)\r
+(* Elle s'appelle r\82cursivement si le pion peut en sauter au moins une fois *)\r
+\r
+var rec:boolean,\r
+ nc,nc2:integer,\r
+ damier2:arrayof integer;\r
+begin\r
+ rec:=false;\r
+ if prof then\r
+ coup(num):=sautee;\r
+ num:=num+1;\r
+ fi;\r
+ coup(num):=caz;\r
+ nc:=h_g(joueur,caz);\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=h_g(joueur,nc);\r
+ if nc2=/=0 then\r
+ if damier(nc2)=vide then\r
+ rec:=true;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc),damier2(caz):=vide;\r
+ call recurse_pion(damier2,num+1,nc,nc2,true);\r
+ fi; fi; fi; fi;\r
+ nc:=h_d(joueur,caz);\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=h_d(joueur,nc);\r
+ if nc2=/=0 then\r
+ if damier(nc2)=vide then\r
+ rec:=true;\r
+ if damier2<>none then kill(damier2); fi;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc),damier2(caz):=vide;\r
+ call recurse_pion(damier2,num+1,nc,nc2,true);\r
+ fi; fi; fi; fi;\r
+ nc:=b_g(joueur,caz);\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=b_g(joueur,nc);\r
+ if nc2=/=0 then\r
+ if damier(nc2)=vide then\r
+ rec:=true;\r
+ if damier2<>none then kill(damier2); fi;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc),damier2(caz):=vide;\r
+ call recurse_pion(damier2,num+1,nc,nc2,true);\r
+ fi; fi; fi; fi;\r
+ nc:=b_d(joueur,caz);\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=b_d(joueur,nc);\r
+ if nc2=/=0 then\r
+ if damier(nc2)=vide then\r
+ rec:=true;\r
+ if damier2<>none then kill(damier2); fi;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc),damier2(caz):=vide;\r
+ call recurse_pion(damier2,num+1,nc,nc2,true);\r
+ fi; fi; fi; fi;\r
+ if rec then kill(damier2)\r
+ else if prof then\r
+ saut:=true;\r
+ ec.nb:=num;\r
+ attach(ec);\r
+ fi; fi;\r
+end recurse_pion;\r
+\r
+unit recurse_dame:procedure\r
+(damier:arrayof integer,num,sautee,caz:integer,prof:boolean);\r
+(* Cette proc\82dure recherche tous les coups possible pour une dame *)\r
+(* Elle s'appelle r\82cursivement si la dame peut sauter au moins une fois *)\r
+\r
+var rec:boolean,\r
+ nc,nc2:integer,\r
+ damier2:arrayof integer;\r
+begin\r
+ rec:=false;\r
+ if prof then\r
+ coup(num):=sautee;\r
+ num:=num+1;\r
+ fi;\r
+ coup(num):=caz;\r
+ nc:=caz;\r
+ do\r
+ nc:=h_g(joueur,nc);\r
+ if nc=0 orif damier(nc)=/=vide then exit; fi;\r
+ od;\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=h_g(joueur,nc);\r
+ while nc2=/=0 do\r
+ if damier(nc2)=/=vide then exit; fi;\r
+ rec:=true;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc):=bloc*joueur;\r
+ damier2(caz):=vide;\r
+ call recurse_dame(damier2,num+1,nc,nc2,true);\r
+ nc2:=h_g(joueur,nc2);\r
+ od;\r
+ fi; fi;\r
+ nc:=caz;\r
+ do\r
+ nc:=h_d(joueur,nc);\r
+ if nc=0 orif damier(nc)=/=vide then exit; fi;\r
+ od;\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=h_d(joueur,nc);\r
+ while nc2=/=0 do\r
+ if damier(nc2)=/=vide then exit; fi;\r
+ rec:=true;\r
+ if damier2=/=none then kill(damier2); fi;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc):=bloc*joueur;\r
+ damier2(caz):=vide;\r
+ call recurse_dame(damier2,num+1,nc,nc2,true);\r
+ nc2:=h_d(joueur,nc2);\r
+ od;\r
+ fi; fi;\r
+ nc:=caz;\r
+ do\r
+ nc:=b_g(joueur,nc);\r
+ if nc=0 orif damier(nc)=/=vide then exit; fi;\r
+ od;\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=b_g(joueur,nc);\r
+ while nc2=/=0 do\r
+ if damier(nc2)=/=vide then exit; fi;\r
+ rec:=true;\r
+ if damier2=/=none then kill(damier2); fi;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc):=bloc*joueur;\r
+ damier2(caz):=vide;\r
+ call recurse_dame(damier2,num+1,nc,nc2,true);\r
+ nc2:=b_g(joueur,nc2);\r
+ od;\r
+ fi; fi;\r
+ nc:=caz;\r
+ do\r
+ nc:=b_d(joueur,nc);\r
+ if nc=0 orif damier(nc)=/=vide then exit; fi;\r
+ od;\r
+ if nc=/=0 then\r
+ if damier(nc)*joueur<0 then\r
+ nc2:=b_d(joueur,nc);\r
+ while nc2=/=0 do\r
+ if damier(nc2)=/=vide then exit; fi;\r
+ rec:=true;\r
+ if damier2=/=none then kill(damier2); fi;\r
+ damier2:=copy(damier);\r
+ damier2(nc2):=damier(caz);\r
+ damier2(nc):=bloc*joueur;\r
+ damier2(caz):=vide;\r
+ call recurse_dame(damier2,num+1,nc,nc2,true);\r
+ nc2:=b_d(joueur,nc2);\r
+ od;\r
+ fi; fi;\r
+ if rec then kill(damier2) \r
+ else if prof then\r
+ saut:=true;\r
+ ec.nb:=num;\r
+ attach(ec);\r
+ fi; fi;\r
+end recurse_dame;\r
+\r
+begin (* calcul_liste_coup *)\r
+ ec:=new enreg_coup;\r
+ array coup dim(1:21);\r
+return;\r
+do;\r
+ saut:=false;\r
+ nbmax:=2;\r
+ nb_coup:=0;\r
+ if liste_coup<>none then\r
+ for i:=1 to upper(liste_coup) do\r
+ if liste_coup(i)<>none then kill(liste_coup(i)); fi;\r
+ od; fi;\r
+ for i:=1 to 50 do\r
+ if damier(i)*joueur>0 then\r
+ if abs(damier(i))=pion then\r
+ call recurse_pion(damier,1,0,i,false);\r
+ if not saut then\r
+ nc:=h_g(joueur,i);\r
+ if nc=/=0 then\r
+ if damier(nc)=vide then\r
+ coup(1):=i;\r
+ coup(2):=nc;\r
+ ec.nb:=2;\r
+ attach(ec);\r
+ fi; fi;\r
+ nc:=h_d(joueur,i);\r
+ if nc=/=0 then\r
+ if damier(nc)=vide then\r
+ coup(1):=i;\r
+ coup(2):=nc;\r
+ ec.nb:=2;\r
+ attach(ec);\r
+ fi; fi; fi;\r
+ else call recurse_dame(damier,1,0,i,false);\r
+ if not saut then\r
+ nc:=h_g(joueur,i);\r
+ while nc=/=0 do\r
+ if damier(nc)=/=vide then exit; fi;\r
+ coup(1):=i;\r
+ coup(2):=nc;\r
+ ec.nb:=2;\r
+ attach(ec);\r
+ nc:=h_g(joueur,nc);\r
+ od;\r
+ nc:=h_d(joueur,i);\r
+ while nc=/=0 do\r
+ if damier(nc)=/=vide then exit; fi;\r
+ coup(1):=i;\r
+ coup(2):=nc;\r
+ ec.nb:=2;\r
+ attach(ec);\r
+ nc:=h_d(joueur,nc);\r
+ od;\r
+ nc:=b_g(joueur,i);\r
+ while nc=/=0 do\r
+ if damier(nc)=/=vide then exit; fi;\r
+ coup(1):=i;\r
+ coup(2):=nc;\r
+ ec.nb:=2;\r
+ attach(ec);\r
+ nc:=b_g(joueur,nc);\r
+ od;\r
+ nc:=b_d(joueur,i);\r
+ while nc=/=0 do\r
+ if damier(nc)=/=vide then exit; fi;\r
+ coup(1):=i;\r
+ coup(2):=nc;\r
+ ec.nb:=2;\r
+ attach(ec);\r
+ nc:=b_d(joueur,nc);\r
+ od;\r
+ fi; fi; fi;\r
+ od;\r
+ detach;\r
+od;\r
+ kill(coup);\r
+end calcul_liste_coup;\r
+\r
+unit valide:coroutine;\r
+(* Renvoie TRUE si une ligne de Liste_Coup est \82gal \85 Coup, FALSE sinon *)\r
+\r
+var egaux:boolean,\r
+ i,j,long1,long2,n_coup:integer,\r
+ coup:arrayof integer,\r
+ liste_coup:arrayof arrayof integer;\r
+begin\r
+return;\r
+do\r
+ long1:=upper(coup);\r
+ long2:=upper(liste_coup(1));\r
+ if (long1=long2) then\r
+ for i:=1 to n_coup do\r
+ egaux:=true;\r
+ for j:=1 to long1 do\r
+ if liste_coup(i,j)<>coup(j) then\r
+ egaux:=false;\r
+ exit;\r
+ fi;\r
+ od;\r
+ if egaux then exit; fi;\r
+ od;\r
+ else egaux:=false;\r
+ fi;\r
+ detach;\r
+od;\r
+end valide;\r
+\r
+unit init_damier:procedure(inout damier:arrayof integer);\r
+(* Initialise le damier en m\82moire *)\r
+(* en positionnant les pions comme en d\82but de partie *)\r
+\r
+var i:integer;\r
+begin\r
+ if damier=none then array damier dim(1:50); fi;\r
+ for i:=1 to 20 do damier(i):=noir; od;\r
+ for i:=21 to 30 do damier(i):=vide; od;\r
+ for i:=31 to 50 do damier(i):=blanc; od;\r
+end init_damier;\r
+\r
+unit aff_pions:coroutine;\r
+(* Coroutine qui affiche \85 l'\82cran tous les pions du *)\r
+(* damier en fonction du tableau damier en m\82moire *)\r
+\r
+var i:integer;\r
+begin\r
+return;\r
+do\r
+ for i:=1 to 50 do\r
+ if damier(i)=blanc then call aff_blanc(i)\r
+ else if damier(i)=noir then call aff_noir(i)\r
+ else if damier(i)=dameblanche then call aff_dameblanche(i)\r
+ else if damier(i)=damenoire then call aff_damenoire(i)\r
+ else call del_case(i);\r
+ fi; fi; fi; fi;\r
+ od;\r
+ detach;\r
+od;\r
+end aff_pions;\r
+\r
+unit calc_coord:coroutine;\r
+(* Calcule les coordonn\82es du coin haut gauche de la case caz *)\r
+\r
+var caz,h,v:integer;\r
+begin\r
+return;\r
+do\r
+ caz:=caz-1;\r
+ if((caz div 5)mod 2=0)then h:=debhoriz+horiz+(caz mod 5)*horiz2;\r
+ else h:=debhoriz+(caz mod 5)*horiz2; fi;\r
+ v:=debvert+vert*(caz div 5);\r
+ detach;\r
+od;\r
+end calc_coord;\r
+\r
+unit aff_dameblanche:procedure(caz:integer);\r
+(* Affiche une dame blanche sur la case caz *)\r
+\r
+var h,v:integer;\r
+begin\r
+ cc.caz:=caz; attach(cc); h:=cc.h; v:=cc.v; clr.h:=h; clr.v:=v;\r
+ clr.long:=horiz1; clr.haut:=vert1; clr.col:=coulnoir; attach(clr);\r
+ clr.h:=h+9; clr.v:=v+4; clr.long:=15; clr.haut:=12;\r
+ clr.col:=coulblanc; attach(clr);\r
+ clr.h:=h+5; clr.v:=v+8; attach(clr);\r
+end aff_dameblanche;\r
+\r
+unit aff_damenoire:IIUWGraph procedure(caz:integer);\r
+(* Affiche une dame noire sur la case caz *)\r
+\r
+var h,v:integer;\r
+begin\r
+ cc.caz:=caz; attach(cc); h:=cc.h; v:=cc.v;\r
+ clr.h:=h; clr.v:=v; clr.long:=horiz1; clr.haut:=vert1;\r
+ clr.col:=coulnoir; attach(clr);\r
+ call color(coulblanc); call move(h+9,v+8);\r
+ call draw(h+9,v+4); call draw(h+24,v+4);\r
+ call draw(h+24,v+16); call draw(h+20,v+16);\r
+ call move(h+5,v+8);\r
+ call draw(h+20,v+8); call draw(h+20,v+20);\r
+ call draw(h+5,v+20); call draw(h+5,v+8);\r
+end aff_damenoire;\r
+\r
+unit aff_blanc:procedure(caz:integer);\r
+(* affiche un pion blanc sur la case caz *)\r
+\r
+var h,v:integer;\r
+begin\r
+ cc.caz:=caz; attach(cc); h:=cc.h; v:=cc.v;\r
+ clr.h:=h; clr.v:=v; clr.long:=horiz1; clr.haut:=vert1;\r
+ clr.col:=coulnoir; attach(clr);\r
+ clr.h:=h+7; clr.v:=v+6; clr.long:=14; clr.haut:=12;\r
+ clr.col:=coulblanc; attach(clr);\r
+end aff_blanc;\r
+\r
+unit aff_noir:IIUWGraph procedure(caz:integer);\r
+(* Affiche un pion noir sur la case caz *)\r
+\r
+var h,v:integer;\r
+begin\r
+ cc.caz:=caz; attach(cc); h:=cc.h; v:=cc.v;\r
+ clr.h:=h; clr.v:=v; clr.long:=horiz1; clr.haut:=vert1;\r
+ clr.col:=coulnoir; attach(clr);\r
+ call color(coulblanc); call move(h+7,v+6); call draw(h+21,v+6);\r
+ call draw(h+21,v+18); call draw(h+7,v+18); call draw(h+7,v+6);\r
+end aff_noir;\r
+\r
+unit aff_damier:IIUWGraph procedure;\r
+(* Affiche un damier vide \85 l'\82cran *)\r
+\r
+var i,j,bord,h,v:integer;\r
+begin\r
+ clr.h:=debhoriz-1; clr.v:=debvert-1;\r
+ clr.long:=10*horiz+1; clr.haut:=10*vert+1;\r
+ clr.col:=coulblanc; attach(clr);\r
+ bord:=horiz; clr.v:=debvert;\r
+ clr.long:=horiz1; clr.haut:=vert1; clr.col:=coulnoir;\r
+ for i:=1 to 10 do\r
+ clr.h:=debhoriz+bord;\r
+ for j:=1 to 5 do\r
+ attach(clr);\r
+ clr.h:=clr.h+60;\r
+ od;\r
+ bord:=horiz-bord;\r
+ clr.v:=clr.v+vert;\r
+ od;\r
+end aff_damier;\r
+\r
+unit del_case:procedure(caz:integer);\r
+(* Efface tout ce qui pourrait se trouver sur la case caz *) \r
+\r
+var h,v:integer;\r
+begin\r
+ cc.caz:=caz; attach(cc); h:=cc.h; v:=cc.v;\r
+ clr.h:=h; clr.v:=v; clr.long:=horiz1; clr.haut:=vert1;\r
+ clr.col:=coulnoir; attach(clr);\r
+end del_case;\r
+\r
+unit clear:IIUWGraph coroutine;\r
+(* Dessine un rectangle de coin haut gauche h,v et bas droit h+long,v+haut *)\r
+\r
+var h,v,long,haut,col,i:integer;\r
+begin\r
+return;\r
+do\r
+ call color(col);\r
+ for i:=0 to haut do\r
+ call move(h,v+i);\r
+ call draw(h+long,v+i);\r
+ od;\r
+ detach;\r
+od;\r
+end clear;\r
+\r
+unit aff_tab_car:IIUWGraph procedure(h,v:integer,tab:arrayof char);\r
+(* Affiche une cha\8cne de caract\8ares \85 l'\82cran *)\r
+\r
+var i:integer;\r
+begin\r
+ clr.h:=h; clr.v:=v; clr.long:=(upper(tab)-lower(tab)+1)*8-1;\r
+ clr.haut:=7; clr.col:=coulnoir; attach(clr);\r
+ call color(coulblanc); call move(h,v);\r
+ for i:=lower(tab) to upper(tab) do\r
+ call hascii(ord(tab(i)));\r
+ od;\r
+end aff_tab_car;\r
+\r
+unit aff_nb:procedure(h,v,n,l:integer);\r
+(* Transforme un nombre en tableau de chiffres puis appelle la *)\r
+(* proc\82dure Aff_Tab_Car pour l'afficher sur un \82cran graphique *)\r
+\r
+var tab,bat:arrayof char,\r
+ i,j,k:integer;\r
+begin\r
+ if n=0 then\r
+ array tab dim(1:l);\r
+ tab(1):='0';\r
+ for i:=2 to l do tab(i):=' '; od;\r
+ call aff_tab_car(h,v,tab);\r
+ else\r
+ array tab dim(1:6);\r
+ if n<0 then\r
+ tab(1):='-';\r
+ i:=1;\r
+ n:=-n;\r
+ fi;\r
+ while n>0 do\r
+ i:=i+1;\r
+ tab(i):=chr((n mod 10)+48);\r
+ n:=n div 10;\r
+ od;\r
+ array bat dim(1:l);\r
+ if tab(1)='-' then\r
+ bat(1):='-';\r
+ k:=1;\r
+ fi;\r
+ for j:=k+1 to i do\r
+ bat(j):=tab(i);\r
+ i:=i-1;\r
+ od;\r
+ for i:=j to l do bat(i):=' '; od;\r
+ call aff_tab_car(h,v,bat);\r
+ kill(bat);\r
+ fi;\r
+ kill(tab);\r
+end aff_nb;\r
+\r
+unit attend_bouton:mouse procedure(output h,v:integer);\r
+(* Cette proc\82dure renvoie les coordonn\82es du pixel point\82 par la *)\r
+(* souris lorsque le bouton gauche a \82t\82 cliqu\82 pour la derni\8are fois *)\r
+\r
+var l,r,c:boolean,\r
+ h1,v1,p:integer;\r
+begin\r
+ do\r
+ call getpress(0,h1,v1,p,l,r,c);\r
+ if not l and not r and not c then exit fi;\r
+ od;\r
+ do\r
+ call getpress(0,h,v,p,l,r,c);\r
+ if l or r then exit fi;\r
+ od;\r
+ if r then \r
+ pref IIUWGraph block begin\r
+ call groff;\r
+ writeln("Abandon d'un joueur");\r
+ call endrun;\r
+ end;\r
+ fi; \r
+end attend_bouton;\r
+\r
+unit sur_damier:function(h,v:integer):boolean;\r
+(* Retourne TRUE si le pixel de coordonn\82es *)\r
+(* (h,v) est sur une case num\82rot\82e du damier *) \r
+\r
+begin\r
+ if h>=debhoriz and v>=debvert and h<debhoriz+10*horiz and v<debvert+10*vert\r
+ then result:=true\r
+ else result:=false;\r
+ fi;\r
+end sur_damier;\r
+\r
+unit num_caz:function(h,v:integer):integer;\r
+(* Calcule le num\82ro de la case \85 laquelle *)\r
+(* appartient le pixel de coordonn\82e (h,v) *)\r
+\r
+var ligne,colon:integer;\r
+begin\r
+ ligne:=(v-debvert)div vert;\r
+ colon:=(h-debhoriz)div horiz;\r
+ if(ligne mod 2)+(colon mod 2)=1\r
+ then result:=1+(5*ligne)+(colon div 2)\r
+ else result:=0;\r
+ fi;\r
+end num_caz;\r
+\r
+\r
+unit quelle_caz:IIUWGraph function:integer; \r
+(* Renvoie le num\82ro de la case o\97 on vient de cliquer *)\r
+\r
+var h,v,n_c:integer;\r
+begin\r
+ do\r
+ call attend_bouton(h,v);\r
+ if sur_damier(h,v) then n_c:=num_caz(h,v); fi;\r
+ if(h=0 or v=0)then quit:=true; fi;\r
+ if n_c<>0 or quit then exit fi;\r
+ od;\r
+ result:=n_c;\r
+end quelle_caz;\r
+\r
+unit maj_aff:procedure(damier,coup:arrayof integer);\r
+(* Met \85 jour l'affichage du damier en actualisant *)\r
+(* \85 l'\82cran les cases point\82es par le tableau Coup *)\r
+\r
+var i,n:integer;\r
+begin\r
+ for i:=1 to upper(coup) do\r
+ n:=coup(i);\r
+ case damier(n)\r
+ when blanc: call aff_blanc(n);\r
+ when noir: call aff_noir(n);\r
+ when dameblanche: call aff_dameblanche(n);\r
+ when damenoire: call aff_damenoire(n);\r
+ otherwise call del_case(n);\r
+ esac;\r
+ od;\r
+end maj_aff;\r
+\r
+unit maj_damier:procedure(damier,coup:arrayof integer,joueur:integer);\r
+(* Met \85 jour le damier en m\82moire en jouant le coup *)\r
+\r
+var deb,fin,i,n:integer;\r
+begin\r
+ n:=upper(coup);\r
+ deb:=coup(1);\r
+ fin:=coup(n);\r
+ for i:=2 step 2 to n-1 do damier(coup(i)):=0; od;\r
+ if joueur=blanc then\r
+ if fin<6\r
+ then damier(fin):=dameblanche\r
+ else damier(fin):=damier(deb); fi;\r
+ else if fin>45\r
+ then damier(fin):=damenoire\r
+ else damier(fin):=damier(deb); fi;\r
+ fi;\r
+ if fin<>deb then damier(deb):=vide; fi;\r
+end maj_damier;\r
+\r
+unit aff_croix:IIUWGraph procedure(caz:integer);\r
+(* Affiche une croix sur la case caz du damier *)\r
+\r
+var h,v:integer;\r
+begin\r
+ cc.caz:=caz; attach(cc); h:=cc.h; v:=cc.v;\r
+ call color(coulrouge); call move(h,v);\r
+ call draw(h+horiz1,v+vert1);\r
+ call move(h,v+vert1);\r
+ call draw(h+horiz1,v);\r
+ call color(coulblanc);\r
+end aff_croix;\r
+\r
+unit arbitre:IIUWGraph coroutine;\r
+(* Cette coroutine initialise la partie (damier et coroutines), *)\r
+(* g\8are la partie en donnant alternativement la main aux deux joueurs, *)\r
+(* v\82rifie la validit\82 des coups jou\82s et g\8are leur affichage *)\r
+\r
+var joueur,nmax,ncoup,coul,rep,rep1,i:integer,\r
+ coup:arrayof integer,\r
+ liste:arrayof arrayof integer,\r
+ joueur1,joueur2:participant,\r
+ val:valide;\r
+begin\r
+ call init_damier(damier);\r
+ array liste dim(1:50);\r
+ call init_deplact;\r
+ clc:=new calcul_liste_coup;\r
+ cc:=new calc_coord;\r
+ ap:=new aff_pions;\r
+ clr:=new clear;\r
+ val:=new valide;\r
+ for i:=1 to 25 do writeln; od;\r
+ writeln(" JEU DE DAMES");\r
+ writeln;\r
+ writeln("Voici les options de ce jeu:");\r
+ writeln;writeln;\r
+ writeln("1 - Jouer contre l'ordinateur");\r
+ writeln("2 - Deux joueurs");\r
+ writeln("3 - Deux ordinateurs");\r
+ writeln;\r
+ do\r
+ write("Quel est votre choix ? ");read(rep);writeln;\r
+ if(rep>=1 and rep<=3) then exit; fi;\r
+ od;\r
+ case rep\r
+ when 1:\r
+ do \r
+ write("Sous quelle couleur voulez-vous jouer (noir=-1/blanc=1)? ");\r
+ read(coul);writeln;\r
+ if (abs(coul)=1) then exit; fi;\r
+ od;\r
+ do\r
+ write("A quel niveau l'ordinateur doit-il jouer (1,2,etc)? ");\r
+ read(rep);writeln;\r
+ if rep>0 then exit; fi;\r
+ od;\r
+ if coul=blanc then\r
+ joueur1:=new player(damier,coul);\r
+ joueur2:=new computer(damier,-coul,rep);\r
+ rep1:=rep;\r
+ else\r
+ joueur1:=new computer(damier,-coul,rep);\r
+ joueur2:=new player(damier,coul);\r
+ fi;\r
+ when 2:\r
+ joueur1:=new player(damier,blanc);\r
+ joueur2:=new player(damier,noir);\r
+ when 3:\r
+ do\r
+ write("A quel niveau l'ordinateur BLANC doit-il jouer (1,2,etc)? ");\r
+ read(rep);writeln;\r
+ if rep>0 then exit; fi;\r
+ od;\r
+ joueur1:=new computer(damier,blanc,rep);\r
+ do\r
+ write("A quel niveau l'ordinateur NOIR doit-il jouer (1,2,etc)? ");\r
+ read(rep1);writeln;\r
+ if rep1>0 then exit; fi;\r
+ od;\r
+ joueur2:=new computer(damier,noir,rep);\r
+ esac;\r
+ call gron(5);\r
+ call cls;\r
+ call aff_damier;\r
+ attach(ap);\r
+ call aff_tab_car((debhoriz-40)div 2,debvert,unpack("Blanc"));\r
+ call aff_tab_car(debhoriz+10*horiz+(debhoriz-32)div 2,debvert,\r
+ unpack("Noir"));\r
+ call aff_tab_car(240,(debvert-8)div 2,unpack("Joueur actif:"));\r
+ if joueur1 is computer then\r
+ call aff_tab_car((debhoriz-144)div 2,debvert+vert,\r
+ unpack("Machine niveau:"));\r
+ call aff_nb((debhoriz-144)div 2+128,debvert+vert,rep,1);\r
+ else\r
+ call aff_tab_car((debhoriz-48)div 2,debvert+vert,unpack("Humain"));\r
+ fi;\r
+ if joueur2 is computer then\r
+ call aff_tab_car(debhoriz+10*horiz+(debhoriz-144)div 2,debvert+vert,\r
+ unpack("Machine niveau:"));\r
+ call aff_nb(debhoriz+10*horiz+(debhoriz-144)div 2+128,debvert+vert,rep1,1);\r
+ else\r
+ call aff_tab_car(debhoriz+10*horiz+(debhoriz-48)div 2,debvert+vert,\r
+ unpack("Humain"));\r
+ fi;\r
+ joueur:=blanc;\r
+ call aff_tab_car((debhoriz-144)div 2,debvert+2*vert,\r
+ unpack("Dernier coup jou\82:"));\r
+ call aff_tab_car(debhoriz+10*horiz+(debhoriz-144)div 2,debvert+2*vert,\r
+ unpack("Dernier coup jou\82:"));\r
+ return;\r
+ pref mouse block begin\r
+ call showcursor;\r
+ end;\r
+ do\r
+ clc.joueur:=joueur; clc.damier:=damier; clc.liste_coup:=liste;\r
+ attach(clc); nmax:=clc.nbmax; ncoup:=clc.nb_coup;\r
+ if ncoup=0 then\r
+ call groff;\r
+ if joueur=blanc\r
+ then writeln("Les BLANCS ont PERDU...")\r
+ else writeln("Les NOIRS ont PERDU...");\r
+ fi;\r
+ call endrun;\r
+ fi;\r
+ for i:=1 to ncoup do\r
+ kill(liste(i));\r
+ od;\r
+ pref mouse block begin \r
+ call hidecursor;\r
+ if(joueur=blanc) then\r
+ call aff_tab_car(360,(debvert-8)div 2,unpack("blanc"));\r
+ call showcursor;\r
+ attach(joueur1);\r
+ coup:=joueur1.coupjou;\r
+ else\r
+ call aff_tab_car(360,(debvert-8)div 2,unpack("noir "));\r
+ call showcursor;\r
+ attach(joueur2);\r
+ coup:=joueur2.coupjou;\r
+ fi;\r
+ end;\r
+ do\r
+ clc.joueur:=joueur; clc.damier:=damier; clc.liste_coup:=liste;\r
+ attach(clc); nmax:=clc.nbmax; ncoup:=clc.nb_coup;\r
+ val.liste_coup:=liste; val.coup:=coup; val.n_coup:=ncoup;\r
+ attach(val); if val.egaux then exit; fi;\r
+ if (joueur=blanc) then\r
+ attach(joueur1);\r
+ coup:=joueur1.coupjou;\r
+ else\r
+ attach(joueur2);\r
+ coup:=joueur2.coupjou;\r
+ fi;\r
+ od;\r
+ pref mouse block begin\r
+ call hidecursor;\r
+ call maj_damier(damier,coup,joueur);\r
+ call maj_aff(damier,coup);\r
+ if (joueur=blanc) then\r
+ call aff_nb((debhoriz-40)div 2,debvert+3*vert,coup(1),2);\r
+ call aff_nb((debhoriz-40)div 2+24,debvert+3*vert,\r
+ coup(upper(coup)),2);\r
+ else\r
+ call aff_nb(debhoriz+10*horiz+(debhoriz-40)div 2,\r
+ debvert+3*vert,coup(1),2);\r
+ call aff_nb(debhoriz+10*horiz+(debhoriz-40)div 2+24,\r
+ debvert+3*vert,coup(upper(coup)),2);\r
+ fi;\r
+ call showcursor;\r
+ joueur:=-joueur;\r
+ end;\r
+ od;\r
+end arbitre;\r
+\r
+unit participant:mouse coroutine(damier:arrayof integer,moi:integer);\r
+(* Cette coroutine pr\82fixe les coroutines computer et player *)\r
+\r
+var coupjou:arrayof integer;\r
+begin\r
+end participant;\r
+\r
+unit computer:participant coroutine(prof:integer);\r
+(* Calcule le coup que l'ordianteur va jouer *)\r
+\r
+var alf,i,k,maxi,ncoup,nmax,num,valeur:integer,\r
+ damierec:arrayof integer,\r
+ listejou:arrayof arrayof integer,\r
+ rec:recurrence;\r
+ \r
+unit recurrence:coroutine(jeu:arrayof integer);\r
+(* Cette coroutine pr\82fixe les coroutines note, alpha et beta *)\r
+\r
+var alf,bet,resultat:integer;\r
+begin\r
+end recurrence;\r
+\r
+unit note:recurrence coroutine(moi:integer);\r
+(* Attribut une note \85 la position du damier: *)\r
+(* positive si elle est favorable \85 l'ordinateur, n\82gative sinon *)\r
+\r
+var c,i,k:integer,\r
+ val,val2,val3,val4:arrayof integer;\r
+begin\r
+ array val dim(1:50); array val2 dim(1:50);\r
+ array val3 dim(1:50); array val4 dim(1:50);\r
+ val(3):=18;\r
+ val(2),val(8),val(13),val(9),val(4):=17;\r
+ val(1),val(7),val(12),val(18),val(23),val(19),val(14),val(10),val(5):=16;\r
+ val(6),val(11),val(17),val(22),val(28):=15;\r
+ val(33),val(29),val(24),val(20),val(15):=15;\r
+ val(16),val(21),val(27),val(32),val(38):=14;\r
+ val(43),val(39),val(34),val(30),val(25):=14;\r
+ val(26),val(31),val(37),val(42),val(48):=13;\r
+ val(49),val(44),val(40),val(35):=13;\r
+ val(36),val(41),val(47),val(50),val(45):=12;\r
+ val(46):=11;\r
+ if moi=noir then\r
+ i:=50;\r
+ for c:=1 to 50 do\r
+ k:=val(c); val(c):=val(i); val(i):=k; i:=i-1;\r
+ od; fi;\r
+ i:=50;\r
+ for c:=1 to 50 do\r
+ val2(c):=val(i); i:=i-1;\r
+ val3(c):=30+val(c);\r
+ val4(c):=30+val2(c);\r
+ od;\r
+return;\r
+do\r
+ resultat:=0;\r
+ for i:=1 to 50 do\r
+ k:=jeu(i)*moi;\r
+ case k\r
+ when blanc: resultat:=resultat+val(i);\r
+ when noir: resultat:=resultat-val2(i);\r
+ when dameblanche: resultat:=resultat+val3(i);\r
+ when damenoire: resultat:=resultat-val4(i);\r
+ esac;\r
+ od;\r
+ detach;\r
+od;\r
+end note;\r
+\r
+unit alpha:recurrence coroutine(qui,prof:integer);\r
+(* Maximise les coups de l'ordinateur *)\r
+\r
+var i,k,maxi,ncoup,nmax,valeur:integer,\r
+ damier:arrayof integer,\r
+ liste:arrayof arrayof integer,\r
+ rec:recurrence;\r
+begin\r
+ array damier dim(1:50);\r
+ array liste dim(1:50);\r
+ if prof>1\r
+ then rec:=new beta(damier,-qui,prof-1)\r
+ else rec:=new note(damier,moi);\r
+ fi;\r
+return;\r
+do\r
+ clc.joueur:=qui; clc.damier:=jeu; clc.liste_coup:=liste;\r
+ attach(clc); nmax:=clc.nbmax; ncoup:=clc.nb_coup;\r
+ if ncoup<=0\r
+ then resultat:=-999\r
+ else\r
+ maxi:=-1000;\r
+ for i:=1 to ncoup do\r
+ for k:=1 to 50 do damier(k):=jeu(k); od;\r
+ call maj_damier(damier,liste(i),qui);\r
+ rec.alf:=alf;\r
+ rec.bet:=bet;\r
+ attach(rec);\r
+ valeur:=rec.resultat;\r
+ if maxi<valeur then\r
+ maxi:=valeur;\r
+ if alf<maxi then alf:=maxi; fi;\r
+ if maxi>=bet then\r
+ exit;\r
+ fi; fi;\r
+ kill(liste(i));\r
+ od;\r
+ for k:=i to ncoup do kill(liste(k));od;\r
+ resultat:=maxi;\r
+ fi;\r
+ detach;\r
+od;\r
+end alpha;\r
+\r
+unit beta:recurrence coroutine(qui,prof:integer);\r
+(* Minimise les coups du joueur *)\r
+\r
+var i,k,maxi,ncoup,nmax,valeur:integer,\r
+ damier:arrayof integer,\r
+ liste:arrayof arrayof integer,\r
+ rec:recurrence;\r
+begin\r
+ array damier dim(1:50);\r
+ array liste dim(1:50);\r
+ if prof>1\r
+ then rec:=new alpha(damier,-qui,prof-1)\r
+ else rec:=new note(damier,moi);\r
+ fi;\r
+return;\r
+do\r
+ clc.joueur:=qui; clc.damier:=jeu; clc.liste_coup:=liste;\r
+ attach(clc); nmax:=clc.nbmax; ncoup:=clc.nb_coup;\r
+ if ncoup<=0\r
+ then resultat:=999\r
+ else\r
+ maxi:=1000;\r
+ for i:=1 to ncoup do\r
+ for k:=1 to 50 do damier(k):=jeu(k); od;\r
+ call maj_damier(damier,liste(i),qui);\r
+ rec.alf:=alf;\r
+ rec.bet:=bet;\r
+ attach(rec);\r
+ valeur:=rec.resultat;\r
+ if maxi>valeur then\r
+ maxi:=valeur;\r
+ if bet>maxi then bet:=maxi; fi;\r
+ if maxi<=alf then\r
+ exit;\r
+ fi; fi;\r
+ kill(liste(i));\r
+ od;\r
+ for k:=i to ncoup do kill(liste(k));od;\r
+ resultat:=maxi;\r
+ fi;\r
+ detach;\r
+od;\r
+end beta;\r
+\r
+begin (*computer*)\r
+ array listejou dim(1:50);\r
+ array damierec dim(1:50);\r
+ rec:=new beta(damierec,-moi,prof);\r
+return;\r
+ call hidecursor;\r
+ if moi=blanc then\r
+ call aff_tab_car((debhoriz-80)div 2,debvert+6*vert,unpack("Note: "));\r
+ call aff_tab_car((debhoriz-112)div 2,debvert+4*vert,\r
+ unpack("Meilleur coup:"));\r
+ call aff_tab_car((debhoriz-120)div 2,debvert+7*vert,\r
+ unpack("Coup en calcul:"));\r
+ else\r
+ call aff_tab_car((debhoriz+10*horiz+(debhoriz-80)div 2),\r
+ debvert+6*vert,unpack("Note: "));\r
+ call aff_tab_car((debhoriz+10*horiz+(debhoriz-112)div 2),\r
+ debvert+4*vert,unpack("Meilleur coup:"));\r
+ call aff_tab_car((debhoriz+10*horiz+(debhoriz-120)div 2),\r
+ debvert+7*vert,unpack("Coup en calcul:"));\r
+ fi;\r
+ do\r
+ if moi=blanc then\r
+ call aff_tab_car((debhoriz-40)div 2,debvert+5*vert,unpack("-- --"));\r
+ call aff_tab_car(((debhoriz-80)div 2)+48,debvert+6*vert,\r
+ unpack(" "));\r
+ else\r
+ call aff_tab_car((debhoriz+10*horiz+(debhoriz-40)div 2),\r
+ debvert+5*vert,unpack("-- --"));\r
+ call aff_tab_car((debhoriz+10*horiz+(debhoriz-80)div 2+48),\r
+ debvert+6*vert,unpack(" "));\r
+ fi;\r
+ call showcursor;\r
+ clc.joueur:=moi; clc.damier:=damier; clc.liste_coup:=listejou;\r
+ attach(clc); nmax:=clc.nbmax; ncoup:=clc.nb_coup;\r
+ if ncoup=1 then\r
+ coupjou:=listejou(1);\r
+ listejou(1):=none;\r
+ else\r
+ maxi:=-1000;\r
+ alf:=-999;\r
+ for i:=1 to ncoup do\r
+ call hidecursor;\r
+ if moi=blanc then\r
+ call aff_nb(((debhoriz-40)div 2),debvert+8*vert,\r
+ listejou(i,1),4);\r
+ call aff_nb(((debhoriz-40)div 2)+24,debvert+8*vert,\r
+ listejou(i,upper(listejou(i))),4);\r
+ else\r
+ call aff_nb((debhoriz+10*horiz+(debhoriz-40)div 2),\r
+ debvert+8*vert,listejou(i,1),4);\r
+ call aff_nb((debhoriz+10*horiz+(debhoriz-40)div 2)+24,\r
+ debvert+8*vert,listejou(i,upper(listejou(i))),4);\r
+ fi;\r
+ call showcursor;\r
+ for k:=1 to 50 do damierec(k):=damier(k); od;\r
+ call maj_damier(damierec,listejou(i),moi);\r
+ rec.alf:=alf;\r
+ rec.bet:=999;\r
+ attach(rec);\r
+ valeur:=rec.resultat;\r
+ if valeur=maxi then\r
+ if moi=blanc then\r
+ if random<0.75 then\r
+ kill(coupjou);\r
+ coupjou:=copy(listejou(i));\r
+ kill(listejou(i));\r
+ fi;\r
+ else if random>0.75 then\r
+ kill(coupjou);\r
+ coupjou:=copy(listejou(i));\r
+ kill(listejou(i));\r
+ fi; fi; fi;\r
+ if maxi<valeur then\r
+ maxi:=valeur;\r
+ if alf<maxi then alf:=maxi; fi;\r
+ kill(coupjou);\r
+ coupjou:=copy(listejou(i));\r
+ kill(listejou(i));\r
+ fi;\r
+ call hidecursor;\r
+ if moi=blanc then\r
+ call aff_nb(((debhoriz-80)div 2)+48,debvert+6*vert,maxi,4);\r
+ call aff_nb(((debhoriz-40)div 2),debvert+5*vert,\r
+coupjou(1) (*listejou(num,1)*) ,4);\r
+ call aff_nb(((debhoriz-40)div 2)+24,debvert+5*vert,\r
+coupjou(nmax) (*listejou(num,upper(listejou(num)))*) ,4);\r
+ else\r
+ call aff_nb((debhoriz+10*horiz+(debhoriz-80)div 2)+48,\r
+ debvert+6*vert,maxi,4);\r
+ call aff_nb((debhoriz+10*horiz+(debhoriz-40)div 2),\r
+debvert+5*vert,coupjou(1) (*listejou(num,1)*) ,4);\r
+ call aff_nb((debhoriz+10*horiz+(debhoriz-40)div 2)+24,\r
+debvert+5*vert,coupjou(nmax) (*listejou(num,upper(listejou(num)))*) ,4);\r
+ fi;\r
+ call showcursor;\r
+ od;\r
+ call hidecursor;\r
+ if moi=blanc then\r
+ call aff_tab_car((debhoriz-40)div 2,debvert+8*vert,unpack("-- --"));\r
+ else\r
+ call aff_tab_car((debhoriz+10*horiz+(debhoriz-40)div 2),\r
+ debvert+8*vert,unpack("-- --"));\r
+ fi;\r
+ call showcursor;\r
+(*coupjou:=listejou(num);*)\r
+ fi;\r
+ detach;\r
+ call showcursor;\r
+ od;\r
+end computer;\r
+\r
+unit player:participant coroutine;\r
+(* Enregistre le coup jou\82 par l'utilisateur *)\r
+\r
+var ok,q,ret,saute:boolean,\r
+ cas,deb,fin,i,j,k,ncoup,nmax,prof:integer,\r
+ coupe,damierjou:arrayof integer,\r
+ listejou:arrayof arrayof integer;\r
+begin\r
+ array listejou dim(1:50);\r
+return;\r
+do\r
+ clc.joueur:=moi; clc.damier:=damier; clc.liste_coup:=listejou;\r
+ attach(clc); nmax:=clc.nbmax; ncoup:=clc.nb_coup;\r
+ damierjou:=damier; array coupe dim(1:21); \r
+ do\r
+ do \r
+ ok:=false;\r
+ deb:=1;\r
+ prof:=1;\r
+ cas:=quelle_caz;\r
+ if(cas<>0) then\r
+ if(damier(cas)=moi or damier(cas)=(moi+moi))then\r
+ i:=1;\r
+ coupe(i):=cas;\r
+ exit;\r
+ fi; fi;\r
+ od;\r
+ j:=deb;\r
+ while(j<=ncoup) do\r
+ if coupe(1)=listejou(j,1) then \r
+ ok:=true;\r
+ deb:=j;\r
+ exit;\r
+ fi;\r
+ j:=j+1; \r
+ od;\r
+ while((j<=ncoup) and ok) do\r
+ if coupe(1)=listejou(j,1)\r
+ then j:=j+1;\r
+ else exit;\r
+ fi;\r
+ od;\r
+ fin:=j-1;\r
+ if ok then exit; fi;\r
+ od; \r
+(* pref mouse block begin*)\r
+ call hidecursor;\r
+ call aff_croix(cas);\r
+ call showcursor;\r
+ cas:=quelle_caz;\r
+ if (upper(listejou(1))>2)\r
+ then saute:=true;\r
+ else saute:=false;\r
+ fi;\r
+ do\r
+ deb:=1;\r
+ fin:=ncoup;\r
+ ret:=false;\r
+ if saute\r
+ then i:=i+2;\r
+ else i:=i+1;\r
+ fi;\r
+ coupe(i):=cas;\r
+ q:=false;\r
+ ok:=false;\r
+ if i>1 andif not(saute) andif coupe(i)=coupe(i-1) then \r
+ i:=i-1;\r
+ ret:=true;\r
+ fi;\r
+ if i>2 andif saute andif coupe(i)=coupe(i-2) then \r
+ i:=i-2;\r
+ ret:=true;\r
+ fi;\r
+ if ret then \r
+ call hidecursor;\r
+ case damier(coupe(i))\r
+ when blanc: call aff_blanc(coupe(i));\r
+ when noir: call aff_noir(coupe(i));\r
+ when dameblanche: call aff_dameblanche(coupe(i));\r
+ when damenoire: call aff_damenoire(coupe(i));\r
+ otherwise call del_case(coupe(i));\r
+ esac;\r
+ if saute\r
+ then i:=i-2;\r
+ else i:=i-1;\r
+ fi;\r
+ call showcursor;\r
+ else \r
+ if i=2 then\r
+ if (damier(coupe(1))=moi and(coupe(2)=h_d(moi,coupe(1)) \r
+ or coupe(2)=h_g(moi,coupe(1))))\r
+ then saute:=false;\r
+ else\r
+ if (damier(coupe(1))=moi) then\r
+ i:=i+1;\r
+ coupe(3):=coupe(2);\r
+ saute:=true;\r
+ fi; fi; fi;\r
+ j:=deb;\r
+ if (i<=nmax) then\r
+ while(j<=fin) do\r
+ ok:=true;\r
+ k:=1;\r
+ while k<=i do\r
+ if coupe(k)<>listejou(j,k) then \r
+ ok:=false;\r
+ exit;\r
+ fi;\r
+ if saute\r
+ then k:=k+2;\r
+ else k:=k+1;\r
+ fi;\r
+ od;\r
+ if ok then\r
+ deb:=j;\r
+ exit;\r
+ else j:=j+1; \r
+ fi;\r
+ od;\r
+ j:=deb;\r
+ while((j<=fin) and ok) do\r
+ k:=1;\r
+ while k<=i do\r
+ if coupe(k)<>listejou(j,k) then\r
+ q:=true;\r
+ exit; \r
+ fi;\r
+ if saute\r
+ then k:=k+2;\r
+ else k:=k+1;\r
+ fi;\r
+ od;\r
+ if q then exit; fi;\r
+ j:=j+1;\r
+ od;\r
+ fin:=j-1;\r
+ else\r
+ saute:=false;\r
+ i:=i-1;\r
+ fi;\r
+ if ok then\r
+ call hidecursor;\r
+ call aff_croix(cas);\r
+ call showcursor;\r
+ else\r
+ if saute\r
+ then i:=i-2;\r
+ else i:=i-1;\r
+ fi; fi;\r
+ if (i=nmax) then exit; fi;\r
+ fi; \r
+ cas:=quelle_caz;\r
+ od;\r
+ array coupjou dim (1:i);\r
+ for i:=1 to upper(coupjou) do\r
+ coupjou(i):=listejou(deb,i);\r
+ od;\r
+(* end;*)\r
+ detach;\r
+od;\r
+end player;\r
+\r
+begin (*main*)\r
+ pref mouse block;\r
+ var driver:boolean,\r
+ bouton:integer;\r
+ begin\r
+ (* v\82rifie qu'un gestionnaire de souris est install\82 *)\r
+\r
+ driver:=init(bouton);\r
+ if driver\r
+ then writeln("Une souris avec ",bouton:1, " boutons a \82t\82 d\82tect\82e");\r
+ else writeln("Erreur: aucune souris n'a \82t\82 d\82tect\82e\r
+ , celle-ci est obligatoire"); exit;\r
+ fi;\r
+ pref IIUWGraph block\r
+ begin\r
+ (*v\82rifie que la carte vid\82o pr\82sente est support\82e par le programme*)\r
+\r
+ case nocard\r
+ when 5:\r
+ (* Cas d'une carte EGA/VGA/SVGA *)\r
+ writeln("Une carte EGA ou compatible VGA a \82t\82 d\82tect\82e");\r
+ coulblanc:=15;coulnoir:=0;coulrouge:=12;\r
+ horiz:=30;vert:=25;debhoriz:=160;debvert:=50;\r
+ horiz1:=29;vert1:=24;horiz2:=60;\r
+ otherwise\r
+ writeln("La carte vid\82o pr\82sente n'est pas supportee\r
+ par le programme: ",nocard);\r
+ writeln("Une carte EGA ou compatible VGA est obligatoire");\r
+ exit;\r
+ esac;\r
+ arb:=new arbitre;\r
+ attach(arb);\r
+ end (*IIUWGraph*);\r
+ end (* mouse *)\r
+end (* program *)\r
--- /dev/null
+PROGRAM ARAIGNEE;\r
+ \r
+(************************************************************************)\r
+(** **)\r
+(** **)\r
+(** ORONOS Marielle & PELAT Joseph **)\r
+(** **)\r
+(** Jeu de strategie : ARAIGNEE **)\r
+(** **)\r
+(** Licence Informatique **)\r
+(** Groupe 3 **)\r
+(** **)\r
+(** Universite de Pau et des Pays de l'Adour 2 Avril 1993 **)\r
+(** **)\r
+(** **)\r
+(************************************************************************)\r
+ \r
+Begin\r
+ \r
+Pref iiuwgraph block; (** Utilisation du graphisme **)\r
+ \r
+ \r
+ \r
+(************************************************************************)\r
+(** Structure de donnees utilisee pour representer la table de jeu : **)\r
+(** un Cube **)\r
+(************************************************************************)\r
+ \r
+UNIT cube : CLASS ;\r
+ \r
+(****************************)\r
+(** 0 : le point est libre **)\r
+(** 1 : pion du joueur1 **)\r
+(** 2 : pion du joueur2 **)\r
+(****************************)\r
+ \r
+VAR cub : arrayof arrayof arrayof integer ,\r
+ i,j : integer;\r
+BEGIN\r
+ array cub dim (1:3);\r
+ for i:=1 to 3 do\r
+ array cub(i) dim (1:3) ;\r
+ for j:=1 to 3 do\r
+ array cub(i,j) dim (1:3) ;\r
+ od;\r
+ od;\r
+END;\r
+ \r
+ \r
+(************************************************************************)\r
+(** Structure de donnees utilisee pour representer un point du cube **)\r
+(************************************************************************)\r
+ \r
+UNIT elt : CLASS ;\r
+VAR x,y,z : INTEGER ;\r
+END elt;\r
+ \r
+ \r
+(************************************************************************)\r
+(** Representation d'une ligne du cube **)\r
+(** Chaque ligne comporte 3 points **)\r
+(************************************************************************)\r
+ \r
+UNIT ligne : CLASS ;\r
+VAR pt1,pt2,pt3 : elt ;\r
+BEGIN\r
+ pt1 := new elt;\r
+ pt2 := new elt;\r
+ pt3 := new elt ;\r
+END ligne;\r
+ \r
+ \r
+(*************************************************************************)\r
+(** Determine la ligne et la colonne d'affichage d'un point du cube a **)\r
+(** l'ecran **)\r
+(*************************************************************************)\r
+ \r
+UNIT AffichPt : Procedure ( pt : elt);\r
+VAR lig,col : integer;\r
+ \r
+BEGIN\r
+ If (pt.x <> 2) AND (pt.y = 2) Then\r
+ col := 230;\r
+ Fi;\r
+ If (pt.y = 1) AND ( pt.z = 1) Then\r
+ col := 142;\r
+ Fi;\r
+ If (pt.y = 1) AND ( pt.z = 2) Then\r
+ col := 100;\r
+ Fi;\r
+ If (pt.y = 1) AND ( pt.z = 3) Then\r
+ col := 60;\r
+ Fi;\r
+ If (pt.y = 3) AND ( pt.z = 1) Then\r
+ col := 315;\r
+ Fi;\r
+ If (pt.y = 3) AND ( pt.z = 2) Then\r
+ col := 359;\r
+ Fi;\r
+ If (pt.y = 3) AND ( pt.z = 3) Then\r
+ col := 400;\r
+ Fi;\r
+ If ( pt.x = 1) AND ( pt.z = 1) Then\r
+ lig := 120;\r
+ Fi;\r
+ If ( pt.x = 1) AND ( pt.z = 2) Then\r
+ lig := 90;\r
+ Fi;\r
+ If ( pt.x = 1) AND ( pt.z = 3) Then\r
+ lig := 60;\r
+ Fi;\r
+ If ( pt.x = 3) AND ( pt.z = 1) Then\r
+ lig := 240;\r
+ Fi;\r
+ If ( pt.x = 3) AND ( pt.z = 2) Then\r
+ lig := 270;\r
+ Fi;\r
+ If ( pt.x = 3) AND ( pt.z = 3) Then\r
+ lig := 300;\r
+ Fi;\r
+ If ( pt.x = 2) AND ( pt.y <> 2) Then\r
+ lig := 180;\r
+ Fi;\r
+ call move ( col , lig);\r
+ \r
+END AffichPt;\r
+ \r
+(*************************************************************************)\r
+(** Affichage du mot INTERDIT s'il y a une mauvaise action **)\r
+(*************************************************************************)\r
+ \r
+UNIT Erreur1 : PROCEDURE;\r
+ \r
+VAR i : integer ;\r
+ \r
+ BEGIN\r
+ call color(15);\r
+ call move(2,2);\r
+ call HASCII(0);call Hascii (ord('I'));\r
+ call HASCII(0);call Hascii (ord('N'));\r
+ call HASCII(0);call Hascii (ord('T'));\r
+ call HASCII(0);call Hascii (ord('E'));\r
+ call HASCII(0);call Hascii (ord('R'));\r
+ call HASCII(0);call Hascii (ord('D'));\r
+ call HASCII(0);call Hascii (ord('I'));\r
+ call HASCII(0);call Hascii (ord('T'));\r
+ call HASCII(0);call Hascii (ord('!'));\r
+ call HASCII(0);call Hascii (ord('!'));\r
+ call HASCII(0);call Hascii (ord('!'));\r
+ \r
+ call move (2,2);\r
+ tab := GETMAP(300,20);\r
+ \r
+ call move (2,2);\r
+ For i := 1 To 10 Do\r
+ call PUTMAP (tab);\r
+ call move (2,2);\r
+ tab := GETMAP(300,20);\r
+ Od;\r
+ call move (2,2);\r
+ For i := 1 To 11 Do\r
+ call HASCII(0);call Hascii (ord(' '));\r
+ Od;\r
+ \r
+ END Erreur1;\r
+ \r
+(*************************************************************************)\r
+(** Procedure pour l'affichage de la table de jeu **)\r
+(*************************************************************************)\r
+ \r
+UNIT AfficheTable : Procedure ;\r
+ Begin\r
+ call cls;\r
+ call move (60,60); call draw(60,300 ); call draw(400,300);\r
+ call move (60,60); call draw(400,60); call draw(400,300);\r
+ \r
+ call move (100,90); call draw(100,270); call draw(359,270);\r
+ call move (100,90); call draw(359,90); call draw(359,270);\r
+ \r
+ call move (142,120); call draw(142,240); call draw(315,240);\r
+ call move (142,120); call draw(315,120); call draw(315,240);\r
+ \r
+ call move (230,60); call draw(230,120);\r
+ call move (60,180); call draw(142,180);\r
+ call move (315,180); call draw(400,180);\r
+ call move (230,240); call draw(230,300);\r
+ \r
+ call move(60,60) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(230,60) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(400,60) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(400,180) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(400,300) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(230,300) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(60,300) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(60,180) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(100,90) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(100,180) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(100,270) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(142,120) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(142,180) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(142,240) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(230,90) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(230,120) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(230,240) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(230,270) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(315,120) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(315,180) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(315,240) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(359,270) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(359,180) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(359,90) ; call HASCII(0) ; call HASCII(ord('+'));\r
+ call move(500,130) ; call HASCII(0) ; call HASCII(ord('A'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('R'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('A'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('I'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('G'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('N'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('E'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('E'));\r
+ \r
+End afficheTable;\r
+ \r
+(*************************************************************************)\r
+(** Affichage du joueur courant **)\r
+(*************************************************************************)\r
+ \r
+UNIT AfficheJoueur : Procedure (i : integer);\r
+ Begin\r
+ If i = 1 then call color(3) else call color(5) ; fi;\r
+ call move(530,170) ; call HASCII(0) ; call HASCII(ord('J'));\r
+ call HASCII(0) ; call HASCII(ord('o'));\r
+ call HASCII(0) ; call HASCII(ord('u'));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord('u'));\r
+ call HASCII(0) ; call HASCII(ord('r'));\r
+ End AfficheJoueur;\r
+ \r
+ \r
+(*************************************************************************)\r
+(** Affichage de la phase courante **)\r
+(** - 0 : Placement **)\r
+(** - 1 : Deplacement **)\r
+(** - 2 : Deplacement de moins de 3 pions **)\r
+(** - 3 : Manger **)\r
+(*************************************************************************)\r
+ \r
+UNIT AffichePhase : Procedure (i : integer);\r
+ Begin\r
+ call color(15);\r
+ call move(160,330) ;\r
+ tab := GETMAP(600,340);\r
+ If i = 0 then\r
+ call HASCII(0) ; call HASCII(ord('P'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('l'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('a'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('c'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('m'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('n'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('t'));\r
+ Fi;\r
+ if i = 1 then\r
+ call HASCII(0) ; call HASCII(ord('D'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('p'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('l'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('a'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('c'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('m'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('n'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('t'));\r
+ Fi;\r
+ If i = 2 then\r
+ call HASCII(0) ; call HASCII(ord('D'));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord('p'));\r
+ call HASCII(0) ; call HASCII(ord('l'));\r
+ call HASCII(0) ; call HASCII(ord('a'));\r
+ call HASCII(0) ; call HASCII(ord('c'));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord('m'));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord('n'));\r
+ call HASCII(0) ; call HASCII(ord('t'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('m'));\r
+ call HASCII(0) ; call HASCII(ord('o'));\r
+ call HASCII(0) ; call HASCII(ord('i'));\r
+ call HASCII(0) ; call HASCII(ord('n'));\r
+ call HASCII(0) ; call HASCII(ord('s'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('d'));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('3'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('p'));\r
+ call HASCII(0) ; call HASCII(ord('i'));\r
+ call HASCII(0) ; call HASCII(ord('o'));\r
+ call HASCII(0) ; call HASCII(ord('n'));\r
+ call HASCII(0) ; call HASCII(ord('s'));\r
+ Fi;\r
+ If i = 3 then\r
+ call HASCII(0) ; call HASCII(ord('M'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('a'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('n'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('g'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('e'));\r
+ Fi;\r
+ For i := 1 To 20 Do\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ Od;\r
+ \r
+End AffichePhase;\r
+ \r
+ \r
+ \r
+(*************************************************************************)\r
+(** Dans une ligne comportant 3 points : pt1, pt2, pt3 **)\r
+(** recherche du ou des points se trouvant a proximite de pt1 **)\r
+(*************************************************************************)\r
+ \r
+ \r
+Unit RechPtProx : function (lig : ligne) : integer ;\r
+ \r
+(**********************************)\r
+(** Result = 1 ==> point 2 **)\r
+(** 2 3 **)\r
+(** 3 point 3-2 **)\r
+(**********************************)\r
+ \r
+Begin\r
+ result := 0 ;\r
+ IF (lig.pt1.x = lig.pt2.x) AND (* Recherche des *)\r
+ (lig.pt2.x = lig.pt3.x) AND (* lignes *)\r
+ (lig.pt1.y = lig.pt2.y) AND (* en profondeur *)\r
+ (lig.pt2.y = lig.pt3.y)\r
+ THEN\r
+ \r
+ IF (lig.pt1.z = (lig.pt2.z+1)) OR\r
+ (lig.pt1.z = (lig.pt2.z-1))\r
+ THEN\r
+ result := result + 1 ;\r
+ FI;\r
+ \r
+ IF (lig.pt1.z = (lig.pt3.z+1)) OR\r
+ (lig.pt1.z = (lig.pt3.z-1))\r
+ THEN\r
+ result := result + 2 ;\r
+ FI;\r
+ \r
+ ELSE (** Recherche des lignes a l'interieur d'un cadre **)\r
+ \r
+ IF (lig.pt1.x = (lig.pt2.x+1)) OR\r
+ (lig.pt1.x = (lig.pt2.x-1)) OR\r
+ (lig.pt1.y = (lig.pt2.y+1)) OR\r
+ (lig.pt1.y = (lig.pt2.y-1))\r
+ THEN\r
+ result := result + 1 ;\r
+ FI;\r
+ \r
+ IF (lig.pt1.x = (lig.pt3.x+1)) OR\r
+ (lig.pt1.x = (lig.pt3.x-1)) OR\r
+ (lig.pt1.y = (lig.pt3.y+1)) OR\r
+ (lig.pt1.y = (lig.pt3.y-1))\r
+ THEN\r
+ result := result + 2 ;\r
+ FI;\r
+ FI;\r
+End RechPtProx;\r
+ \r
+ \r
+(*************************************************************************)\r
+(** Procedure verifiant que la priorite 1 ou 2 (suivant l'appelant) **)\r
+(** peut etre validee **)\r
+(*************************************************************************)\r
+ \r
+Unit DeplPrior12 : procedure (ligne1,ligne2:ligne;output sortie : boolean);\r
+ \r
+Var prox : integer;\r
+ \r
+Begin\r
+ \r
+(** S'il existe un pion appartenant au joueur courant,a proximite de **)\r
+(** l'intersection des 2 lignes, sur la ligne 2, la priorite peut etre **)\r
+(** validee **)\r
+ \r
+ sortie := false ;\r
+ prox := RechPtProx (ligne2);\r
+ IF Not defense\r
+ THEN\r
+ IF ((prox = 1) OR (prox = 3)) AND\r
+ (table.cub(ligne2.pt2.x,ligne2.pt2.y,ligne2.pt2.z) = Numjoueur)\r
+ THEN\r
+ ptdep.x := ligne2.pt2.x;\r
+ ptdep.y := ligne2.pt2.y;\r
+ ptdep.z := ligne2.pt2.z;\r
+ ptarr.x := ligne1.pt1.x;\r
+ ptarr.y := ligne1.pt1.y;\r
+ ptarr.z := ligne1.pt1.z;\r
+ sortie := true ;\r
+ ELSE\r
+ IF ((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(ligne2.pt3.x,ligne2.pt3.y,ligne2.pt3.z) = Numjoueur)\r
+ THEN\r
+ ptdep.x := ligne2.pt3.x;\r
+ ptdep.y := ligne2.pt3.y;\r
+ ptdep.z := ligne2.pt3.z;\r
+ ptarr.x := ligne1.pt1.x;\r
+ ptarr.y := ligne1.pt1.y;\r
+ ptarr.z := ligne1.pt1.z;\r
+ sortie := true ;\r
+ FI ;\r
+ FI;\r
+ ELSE\r
+ IF (prox = 3) AND\r
+ (((table.cub(ligne2.pt2.x,ligne2.pt2.y,ligne2.pt2.z) = Numjoueur) AND\r
+ (table.cub(ligne2.pt3.x,ligne2.pt3.y,ligne2.pt3.z) = (3 - Numjoueur)))\r
+ OR\r
+ ((table.cub(ligne2.pt3.x,ligne2.pt3.y,ligne2.pt3.z) = Numjoueur) AND\r
+ (table.cub(ligne2.pt2.x,ligne2.pt2.y,ligne2.pt2.z) = (3 - Numjoueur))))\r
+ THEN\r
+ IF (table.cub(ligne2.pt2.x,ligne2.pt2.y,ligne2.pt2.z) = Numjoueur)\r
+ THEN\r
+ ptdep.x := ligne2.pt2.x;\r
+ ptdep.y := ligne2.pt2.y;\r
+ ptdep.z := ligne2.pt2.z;\r
+ ELSE\r
+ ptdep.x := ligne2.pt3.x;\r
+ ptdep.y := ligne2.pt3.y;\r
+ ptdep.z := ligne2.pt3.z;\r
+ FI;\r
+ ptarr.x := ligne1.pt1.x;\r
+ ptarr.y := ligne1.pt1.y;\r
+ ptarr.z := ligne1.pt1.z;\r
+ sortie := true ;\r
+ FI ;\r
+ FI;\r
+ \r
+End DeplPrior12 ;\r
+ \r
+ \r
+ \r
+(*************************************************************************)\r
+(** Procedure permettant de rechercher toutes les lignes valides dans **)\r
+(** le cube **)\r
+(*************************************************************************)\r
+ \r
+Unit RechLigne : procedure (i,j,k : integer;\r
+ inout lig1 : ligne;\r
+ output sortie : boolean);\r
+Begin\r
+ sortie := true ;\r
+ IF ((i = 2) OR (j = 2))\r
+ THEN\r
+ (** Creation des lignes en profondeur **)\r
+ \r
+ IF i <> j (* la ligne du milieu du cube est inexistante *)\r
+ THEN\r
+ IF k = 1\r
+ THEN\r
+ (** On cree ces lignes seuleument une fois ==> quand k = 1 **)\r
+ lig1.pt1.x,lig1.pt2.x,lig1.pt3.x := i;\r
+ lig1.pt1.y,lig1.pt2.y,lig1.pt3.y := j;\r
+ lig1.pt1.z:=k;\r
+ lig1.pt2.z:=k+1;\r
+ lig1.pt3.z:=k+2;\r
+ ELSE\r
+ sortie := false;\r
+ return;\r
+ FI;\r
+ ELSE\r
+ sortie := false;\r
+ return;\r
+ FI;\r
+ \r
+ ELSE\r
+ (** Creation des lignes pour chaque cadre **)\r
+ \r
+ lig1.pt1.z ,lig1.pt2.z, lig1.pt3.z := k;\r
+ \r
+ If (( i = 1 ) AND ( j = 1 )) OR\r
+ (( i = 3 ) AND ( j = 3 ))\r
+ Then\r
+ \r
+ (** Creation des lignes horizontales **)\r
+ lig1.pt1.x,lig1.pt2.x,lig1.pt3.x := i;\r
+ lig1.pt1.y := (j mod 3) + 1;\r
+ lig1.pt2.y := ((j + 1) mod 3) + 1;\r
+ lig1.pt3.y := ((j + 2) mod 3) + 1;\r
+ Fi;\r
+ If (( i = 1 ) AND ( j = 3 )) OR\r
+ (( i = 3 ) AND ( j = 1 ))\r
+ Then\r
+ (** Creation des lignes verticales **)\r
+ lig1.pt1.y,lig1.pt2.y,lig1.pt3.y := i;\r
+ lig1.pt1.x := (j mod 3) + 1;\r
+ lig1.pt2.x := ((j + 1) mod 3) + 1;\r
+ lig1.pt3.x := ((j + 2) mod 3) + 1;\r
+ Fi;\r
+ \r
+ Fi;\r
+ \r
+End RechLigne;\r
+ \r
+ \r
+ \r
+(*************************************************************************)\r
+(** Procedure permettant de rechercher les 2 lignes valides qui **)\r
+(** s'intersectent dans le cube a partir d'un point donne **)\r
+(*************************************************************************)\r
+ \r
+Unit RechLignesCrois : procedure (i,j,k : integer;\r
+ inout lig1,lig2 : ligne;\r
+ output sortie : boolean);\r
+ \r
+(** Cette procedure renvoie 2 lignes qui se croisent au point (i,j,k) *)\r
+ \r
+Begin\r
+ \r
+ sortie := true;\r
+ \r
+ lig1.pt1.x,lig2.pt1.x := i; (* Creation du point *)\r
+ lig1.pt1.y,lig2.pt1.y := j; (* d'intersection *)\r
+ lig1.pt1.z,lig2.pt1.z := k; (* ==> pt1 *)\r
+ \r
+ IF (i = 2) OR (j = 2)\r
+ THEN\r
+ (** Recherche des lignes qui s'intersectent avec celles en profondeur **)\r
+ \r
+ IF (i<>j) (* la ligne du milieu est inexistante *)\r
+ THEN\r
+ \r
+ (* creation de la ligne appartenant au cadre *)\r
+ lig1.pt2.z,lig1.pt3.z := k;\r
+ IF (i = 2)\r
+ THEN\r
+ lig1.pt2.x := 1 ; (* Creation d'une *)\r
+ lig1.pt3.x := 3 ; (* ligne *)\r
+ lig1.pt2.y := j; (* horrizontale *)\r
+ lig1.pt3.y := j;\r
+ FI;\r
+ IF (j = 2)\r
+ THEN\r
+ lig1.pt2.x := i; (* Creation d'une *)\r
+ lig1.pt3.x := i; (* ligne *)\r
+ lig1.pt2.y := 1 ; (* verticale *)\r
+ lig1.pt3.y := 3 ;\r
+ FI;\r
+ \r
+ (* Creation de la ligne en profondeur *)\r
+ lig2.pt2.x,lig2.pt3.x := i;\r
+ lig2.pt2.y,lig2.pt3.y := j;\r
+ IF (k = 1)\r
+ THEN\r
+ lig2.pt2.z := 2;\r
+ lig2.pt3.z := 3;\r
+ ELSE\r
+ IF (k = 2)\r
+ THEN\r
+ lig2.pt2.z := 1;\r
+ lig2.pt3.z := 3;\r
+ ELSE\r
+ lig2.pt2.z := 1;\r
+ lig2.pt3.z := 2;\r
+ FI;\r
+ FI;\r
+ ELSE\r
+ sortie := false ;\r
+ return;\r
+ FI;\r
+ \r
+ ELSE\r
+ (** Recherche des lignes qui se croisent dans le meme cadre **)\r
+ \r
+ (* Tous les points ont le meme cadre *)\r
+ lig1.pt2.z, lig1.pt3.z, lig2.pt2.z, lig2.pt3.z := k;\r
+ \r
+ (* les points sur la ligne horizontale ont la meme abscisse *)\r
+ lig1.pt2.x,lig1.pt3.x := i;\r
+ \r
+ (* les points sur la ligne verticale ont la meme ordonnee *)\r
+ lig2.pt2.y, lig2.pt3.y := j;\r
+ \r
+ (* Calcul des abscisses de la ligne verticale *)\r
+ If ( i = 1) Then\r
+ lig2.pt2.x := 2;\r
+ lig2.pt3.x := 3 ;\r
+ Else\r
+ lig2.pt2.x := 1;\r
+ lig2.pt3.x := 2 ;\r
+ Fi;\r
+ \r
+ (* Calcul des ordonnees de la ligne horizontale *)\r
+ If ( j = 1) Then\r
+ lig1.pt2.y := 2;\r
+ lig1.pt3.y := 3 ;\r
+ Else\r
+ lig1.pt2.y := 1;\r
+ lig1.pt3.y := 2 ;\r
+ Fi;\r
+ \r
+ Fi;\r
+ \r
+End RechLignesCrois;\r
+ \r
+ \r
+(*************************************************************************)\r
+(** Procedure permettant de determiner un point du cube ayant pour **)\r
+(** valeur le parametre n, de facon aleatoire **)\r
+(*************************************************************************)\r
+ \r
+Unit RandomPlac : Procedure ( n : integer );\r
+ \r
+Var i, j, k : integer,\r
+ a, b, c : real;\r
+ \r
+Begin\r
+ a := Random;\r
+ ptarr.x := ((Round( a * 10000) ) mod 3) + 1; (* Calcul de *)\r
+ b := Random;\r
+ ptarr.y := ((Round( b * 10000) ) mod 3) + 1; (* 3 coordonnees *)\r
+ c := Random;\r
+ ptarr.z := ((Round( c * 10000) ) mod 3) + 1; (* aleatoires *)\r
+ \r
+ (** A partir du point calcule on cherche on cherche un point tel que\r
+ sa valeur dans le cube soit n **)\r
+ \r
+ If (table.cub( ptarr.x, ptarr.y, ptarr.z ) <> n) OR\r
+ ((ptarr.x = 2) AND (ptarr.y = 2))\r
+ Then\r
+ For k := ptarr.z To 3 Do\r
+ For j := ptarr.y To 3 Do\r
+ For i := ptarr.x To 3 Do\r
+ If (i = 2) AND (j = 2) Then\r
+ repeat;\r
+ Fi;\r
+ If table.cub(i,j,k) = n Then\r
+ ptarr.x := i;\r
+ ptarr.y := j;\r
+ ptarr.z := k;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Od;\r
+ Od;\r
+ Od;\r
+ Fi;\r
+ \r
+ If (table.cub( ptarr.x, ptarr.y, ptarr.z ) <> n) OR\r
+ ((ptarr.x = 2) AND (ptarr.y = 2))\r
+ Then\r
+ For k := ptarr.z Downto 1 Do\r
+ For j := ptarr.y Downto 1 Do\r
+ For i := ptarr.x Downto 1 Do\r
+ If (i = 2) AND (j = 2) Then\r
+ repeat;\r
+ Fi;\r
+ If table.cub(i,j,k) = n Then\r
+ ptarr.x := i;\r
+ ptarr.y := j;\r
+ ptarr.z := k;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Od;\r
+ Od;\r
+ Od;\r
+ Fi;\r
+ \r
+End RandomPlac;\r
+ \r
+ \r
+ \r
+(*************************************************************************)\r
+(** Procedure permettant de determiner, de facon aleatoire, deux points **)\r
+(** du cube : - l'un ayant pour valeur le parametre n **)\r
+(** - l'autre,se trouvant a la proximite du premier,ayant **)\r
+(** la valeur 0 **)\r
+(*************************************************************************)\r
+ \r
+Unit RandomDepl : Procedure ( lig1, lig2: ligne, n : integer );\r
+ \r
+Var trouve, sortie : boolean,\r
+ i, j, k, prox : integer,\r
+ a, b, c : real;\r
+ \r
+Begin\r
+ \r
+trouve := false;\r
+WHILE not trouve Do\r
+ a := random;\r
+ ptdep.x := ((Round(a * 10000)) mod 3) + 1; (* Calcul *)\r
+ b := Random;\r
+ ptdep.y := ((Round(b * 10000)) mod 3) + 1; (* du *)\r
+ c := Random;\r
+ ptdep.z := ((Round(c * 10000)) mod 3) + 1; (* point de depart *)\r
+ \r
+ (* A partir du point calcule on cherche un point tel que sa valeur\r
+ soit n dans la table *)\r
+ \r
+ If (table.cub( ptdep.x, ptdep.y, ptdep.z ) <> n) OR\r
+ ((ptdep.x = 2) AND (ptdep.y = 2))\r
+ Then\r
+ For k := ptdep.z To 3 Do\r
+ For j := ptdep.y To 3 Do\r
+ For i := ptdep.x To 3 Do\r
+ If (i = 2) AND (j = 2) Then\r
+ repeat;\r
+ Fi;\r
+ If table.cub(i,j,k) = n Then\r
+ ptdep.x := i;\r
+ ptdep.y := j;\r
+ ptdep.z := k;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Od;\r
+ Od;\r
+ Od;\r
+ Fi;\r
+ \r
+ If (table.cub( ptdep.x, ptdep.y, ptdep.z ) <> n) OR\r
+ ((ptdep.x = 2) AND (ptdep.y = 2))\r
+ Then\r
+ For k := ptdep.z Downto 1 Do\r
+ For j := ptdep.y Downto 1 Do\r
+ For i := ptdep.x Downto 1 Do\r
+ If (i = 2) AND (j = 2) Then\r
+ repeat;\r
+ Fi;\r
+ If table.cub(i,j,k) = n Then\r
+ ptdep.x := i;\r
+ ptdep.y := j;\r
+ ptdep.z := k;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Od;\r
+ Od;\r
+ Od;\r
+ Fi;\r
+ \r
+ call RechLignesCrois (ptdep.x, ptdep.y, ptdep.z, lig1, lig2, sortie);\r
+ (** Recherche d'une case libre sur la ligne lig1 *)\r
+ prox := RechPtProx (lig1);\r
+ \r
+ If ((prox = 1) OR (prox = 3))\r
+ AND (table.cub(lig1.pt2.x, lig1.pt2.y, lig1.pt2.z) = 0 )\r
+ Then\r
+ trouve := true;\r
+ ptarr.x := lig1.pt2.x;\r
+ ptarr.y := lig1.pt2.y;\r
+ ptarr.z := lig1.pt2.z;\r
+ exit;\r
+ Else\r
+ If ((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(lig1.pt3.x, lig1.pt3.y, lig1.pt3.z) = 0 )\r
+ Then\r
+ trouve := true;\r
+ ptarr.x := lig1.pt3.x;\r
+ ptarr.y := lig1.pt3.y;\r
+ ptarr.z := lig1.pt3.z;\r
+ exit;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (* Recherche d'une case libre sur la ligne lig2 *)\r
+ prox := RechPtProx (lig2);\r
+ \r
+ If ((prox = 1) OR (prox = 3))\r
+ AND (table.cub(lig2.pt2.x, lig2.pt2.y, lig2.pt2.z) = 0 )\r
+ Then\r
+ trouve := true;\r
+ ptarr.x := lig2.pt2.x;\r
+ ptarr.y := lig2.pt2.y;\r
+ ptarr.z := lig2.pt2.z;\r
+ exit;\r
+ Else\r
+ If ((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(lig2.pt3.x, lig2.pt3.y, lig2.pt3.z) = 0 )\r
+ Then\r
+ trouve := true;\r
+ ptarr.x := lig2.pt3.x;\r
+ ptarr.y := lig2.pt3.y;\r
+ ptarr.z := lig2.pt3.z;\r
+ exit;\r
+ Fi;\r
+ Fi;\r
+ OD;\r
+ \r
+End RandomDepl;\r
+ \r
+ \r
+ \r
+(*************************************************************************)\r
+(** Phase de placement des pions **)\r
+(** Cette phase est commune au 2 joueurs **)\r
+(** Mais suivant le joueur il observe une strategie offensive ou **)\r
+(** defensive **)\r
+(*************************************************************************)\r
+ \r
+UNIT Phase0 : PROCEDURE ( lig1 , lig2 : ligne);\r
+ \r
+VAR priorite : integer ,\r
+ x1, x2, x3, y1, y2, y3, z1, z2, z3 : integer ,\r
+ xx2, xx3, yy2, yy3, zz2, zz3 : integer ,\r
+ i, j, k : integer,\r
+ sortie : boolean;\r
+ \r
+BEGIN\r
+ priorite := 6; (* Par defaut priorite maximum *)\r
+ \r
+ FOR k := 1 TO 3 DO\r
+ FOR j := 1 TO 3 DO\r
+ FOR i := 1 TO 3 DO\r
+ \r
+ (* Recherche de placement pour chaque ligne *)\r
+ \r
+ CALL RechLigne (i,j,k,lig1,sortie);\r
+ \r
+ x1 := lig1.pt1.x; y1 := lig1.pt1.y; z1 := lig1.pt1.z;\r
+ x2 := lig1.pt2.x; y2 := lig1.pt2.y; z2 := lig1.pt2.z;\r
+ x3 := lig1.pt3.x; y3 := lig1.pt3.y; z3 := lig1.pt3.z;\r
+ \r
+ IF sortie THEN\r
+ \r
+ (** Priorite = 1 **)\r
+ \r
+ (** Si sur une meme ligne il y a 2 pions du joueur1 on place **)\r
+ (** le pion du joueur courant sur le troisieme point si la **)\r
+ (** place n'est pas deja occupe **)\r
+ (** Si le joueur courant est le joueur1 **)\r
+ (** ==> alignement de pions **)\r
+ (** Sinon **)\r
+ (** ==>empechement d'alignement **)\r
+ \r
+ \r
+ IF (table.cub(x1,y1,z1) = 1) AND\r
+ (table.cub(x2,y2,z2) = 1) AND\r
+ (table.cub(x3,y3,z3) = 0)\r
+ THEN\r
+ priorite := 1 ;\r
+ ptarr.x := x3;\r
+ ptarr.y := y3;\r
+ ptarr.z := z3;\r
+ exit;exit;exit;\r
+ FI;\r
+ \r
+ IF (table.cub(x1,y1,z1) = 1) AND\r
+ (table.cub(x2,y2,z2) = 0) AND\r
+ (table.cub(x3,y3,z3) = 1)\r
+ THEN\r
+ priorite := 1 ;\r
+ ptarr.x := x2;\r
+ ptarr.y := y2;\r
+ ptarr.z := z2;\r
+ exit;exit;exit;\r
+ FI;\r
+ \r
+ IF (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = 1) AND\r
+ (table.cub(x3,y3,z3) = 1)\r
+ THEN\r
+ priorite := 1 ;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ exit;exit;exit;\r
+ FI;\r
+ \r
+ \r
+ (** Priorite = 2 **)\r
+ \r
+ (** Si sur une meme ligne il y a 2 pions du joueur2 on place **)\r
+ (** le pion du joueur courant sur le troisieme point si la **)\r
+ (** place n'est pas deja occupe **)\r
+ (** Si le joueur courant est le joueur2 **)\r
+ (** ==> alignement de pions **)\r
+ (** Sinon **)\r
+ (** ==>empechement d'alignement **)\r
+ \r
+ IF (table.cub(x1,y1,z1) = 2) AND\r
+ (table.cub(x2,y2,z2) = 2) AND\r
+ (table.cub(x3,y3,z3) = 0) AND\r
+ (priorite > 2)\r
+ THEN\r
+ priorite := 2 ;\r
+ ptarr.x := x3;\r
+ ptarr.y := y3;\r
+ ptarr.z := z3;\r
+ FI;\r
+ \r
+ IF (table.cub(x1,y1,z1) = 2) AND\r
+ (table.cub(x2,y2,z2) = 0) AND\r
+ (table.cub(x3,y3,z3) = 2) AND\r
+ (priorite > 2)\r
+ THEN\r
+ priorite := 2 ;\r
+ ptarr.x := x2;\r
+ ptarr.y := y2;\r
+ ptarr.z := z2;\r
+ FI;\r
+ \r
+ IF (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = 2) AND\r
+ (table.cub(x3,y3,z3) = 2) AND\r
+ (priorite > 2)\r
+ THEN\r
+ priorite := 2 ;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ FI;\r
+ \r
+ \r
+ (** Priorite = 5 **)\r
+ \r
+ (** Si le point de coordonnees (1,2,2) est libre on choisit **)\r
+ (** ce point **)\r
+ \r
+ IF (table.cub(1,2,2) = 0) AND (priorite = 6)\r
+ THEN\r
+ ptarr.x := 1;\r
+ ptarr.y := 2;\r
+ ptarr.z := 2;\r
+ priorite := 5 ;\r
+ FI;\r
+ \r
+ FI;\r
+ \r
+ OD;\r
+ OD;\r
+ OD;\r
+ \r
+ IF priorite > 2\r
+ THEN\r
+ \r
+ (** On traite toutes les lignes qui s'intersectent **)\r
+ \r
+ FOR k := 1 TO 3 DO\r
+ FOR j := 1 TO 3 DO\r
+ FOR i := 1 TO 3 DO\r
+ \r
+ (* Recherche pour chaque paire ligne qui s'intersectent *)\r
+ \r
+ CALL RechLignesCrois (i,j,k,lig1,lig2,sortie);\r
+ \r
+ x1 := lig1.pt1.x; y1 := lig1.pt1.y; z1 := lig1.pt1.z;\r
+ x2 := lig1.pt2.x; y2 := lig1.pt2.y; z2 := lig1.pt2.z;\r
+ x3 := lig1.pt3.x; y3 := lig1.pt3.y; z3 := lig1.pt3.z;\r
+ \r
+ xx2 := lig2.pt2.x; yy2 := lig2.pt2.y; zz2 := lig2.pt2.z;\r
+ xx3 := lig2.pt3.x; yy3 := lig2.pt3.y; zz3 := lig2.pt3.z;\r
+ IF sortie\r
+ THEN\r
+ \r
+ (** Priorite = 3 **)\r
+ \r
+ (** Pour chaque paire de lignes qui s'intersectent a une **)\r
+ (** case (x, y, z) de valeur 0 **)\r
+ (** Si les valeurs des pions sur les 2 lignes sont **)\r
+ (** 1, 0, 0 dans n'importe quel ordre alors on choisit **)\r
+ (** la case (x, y, z) **)\r
+ \r
+ IF (table.cub(x1,y1,z1) = 0) AND\r
+ \r
+ (((table.cub(x2,y2,z2) = 1) AND\r
+ (table.cub(x3,y3,z3) = 0)) OR\r
+ \r
+ ((table.cub(x2,y2,z2) = 0) AND\r
+ (table.cub(x3,y3,z3) = 1))) AND\r
+ \r
+ (((table.cub(xx2,yy2,zz2) = 1) AND\r
+ (table.cub(xx3,yy3,zz3) = 0)) OR\r
+ \r
+ ((table.cub(xx2,yy2,zz2) = 0) AND\r
+ (table.cub(xx3,yy3,zz3) = 1)))\r
+ \r
+ THEN\r
+ priorite := 3;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ exit;exit;exit;\r
+ FI;\r
+ \r
+ \r
+ (** Priorite = 4 **)\r
+ \r
+ (** Pour chaque paire de lignes qui s'intersectent a une **)\r
+ (** case (x, y, z) de valeur 0 **)\r
+ (** Si les valeurs des pions sur les 2 lignes sont **)\r
+ (** 2, 0, 0 dans n'importe quel ordre alors on choisit **)\r
+ (** la case (x, y, z) **)\r
+ \r
+ IF (table.cub(x1,y1,z1) = 0) AND\r
+ \r
+ (((table.cub(x2,y2,z2) = 2) AND\r
+ (table.cub(x3,y3,z3) = 0)) OR\r
+ \r
+ ((table.cub(x2,y2,z2) = 0) AND\r
+ (table.cub(x3,y3,z3) = 2))) AND\r
+ \r
+ (((table.cub(xx2,yy2,zz2) = 2) AND\r
+ (table.cub(xx3,yy3,zz3) = 0)) OR\r
+ \r
+ ((table.cub(xx2,yy2,zz2) = 0) AND\r
+ (table.cub(xx3,yy3,zz3) = 2))) AND\r
+ \r
+ (priorite > 4)\r
+ \r
+ THEN\r
+ priorite := 4;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ FI;\r
+ \r
+ FI;\r
+ \r
+ OD;\r
+ OD;\r
+ OD;\r
+ FI;\r
+ \r
+ (** Prioite = 6 **)\r
+ \r
+ (** Recherche aleatoire du pion a placer **)\r
+ \r
+ IF (priorite = 6)\r
+ THEN\r
+ CALL RandomPlac (0);\r
+ FI;\r
+ \r
+ \r
+ For i := 1 To temps Do\r
+ call color(10);\r
+ call AffichPt(ptarr);\r
+ call HASCII(0);\r
+ call HASCII(ord('#'));\r
+ Od;\r
+ \r
+END Phase0;\r
+ \r
+(*************************************************************************)\r
+(** Phase de deplacement des pions **)\r
+(** Cette phase est commune au 2 joueurs **)\r
+(** Dans certains cas, le joueur 1 observe une strategie offensive **)\r
+(** et le joueur 2 une strategie defensive **)\r
+(*************************************************************************)\r
+ \r
+UNIT Phase1 : PROCEDURE (lig1 , lig2 : ligne);\r
+ \r
+VAR priorite, prox : integer,\r
+ x1, x2, x3, y1, y2, y3, z1, z2, z3 : integer ,\r
+ xx2, xx3, yy2, yy3, zz2, zz3 : integer ,\r
+ i, j, k : integer ,\r
+ sortie, ok : boolean;\r
+ \r
+BEGIN\r
+ \r
+ priorite := 6; (* Priorite initialise au maximum par defaut *)\r
+ \r
+ FOR k := 1 TO 3 DO\r
+ FOR j := 1 TO 3 DO\r
+ FOR i := 1 TO 3 DO\r
+ \r
+ (* On recherche les deplacements possibles sur des lignes\r
+ qui s'intersectent car :\r
+ - Il faut trouver le pion a deplacer\r
+ - on doit regarder si le deplacement est possible\r
+ dans les lignes qui passent par ce point *)\r
+ \r
+ call RechLignesCrois(i,j,k,lig1,lig2,sortie);\r
+ \r
+ x1 := lig1.pt1.x; y1 := lig1.pt1.y; z1 := lig1.pt1.z;\r
+ x2 := lig1.pt2.x; y2 := lig1.pt2.y; z2 := lig1.pt2.z;\r
+ x3 := lig1.pt3.x; y3 := lig1.pt3.y; z3 := lig1.pt3.z;\r
+ \r
+ xx2 := lig2.pt2.x; yy2 := lig2.pt2.y; zz2 := lig2.pt2.z;\r
+ xx3 := lig2.pt3.x; yy3 := lig2.pt3.y; zz3 := lig2.pt3.z;\r
+ \r
+ IF sortie THEN\r
+ \r
+ (** Priorite = 1 **)\r
+ (** Si sur une ligne il y a 2 pions du joueur1, et sur\r
+ l'autre ligne il y a a proximite un autre pion du\r
+ - joueur1 on place le pion du joueur1 \85 l'intersection\r
+ ==> alignement\r
+ - joueur2 on place le pion du joueur2 \85 l'intersection\r
+ ==> empechement d'alignement **)\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = 1) AND\r
+ (table.cub(x3,y3,z3) = 1)\r
+ Then\r
+ If numjoueur = 1 Then\r
+ defense := false;\r
+ Else\r
+ defense := true;\r
+ Fi;\r
+ call DeplPrior12 (lig1,lig2,ok);\r
+ If ok Then\r
+ priorite := 1;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(xx2,yy2,zz2) = 1) AND\r
+ (table.cub(xx3,yy3,zz3) = 1)\r
+ Then\r
+ If numjoueur = 1 Then\r
+ defense := false;\r
+ Else\r
+ defense := true;\r
+ Fi;\r
+ call DeplPrior12 (lig2,lig1,ok);\r
+ If ok Then\r
+ priorite := 1;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** Priorite = 2 **)\r
+ \r
+ (** Si sur une ligne il y a 2 pions du joueur2, et sur\r
+ l'autre ligne il y a a proximite un autre pion du\r
+ - joueur2 on place le pion du joueur2 \85 l'intersection\r
+ ==> alignement\r
+ - joueur1 on place le pion du joueur1 \85 l'intersection\r
+ ==> empechement d'alignement **)\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = 2) AND\r
+ (table.cub(x3,y3,z3) = 2) AND\r
+ (priorite > 2)\r
+ Then\r
+ If numjoueur = 2 Then\r
+ defense := false;\r
+ Else\r
+ defense := true;\r
+ Fi;\r
+ call DeplPrior12 (lig1,lig2,ok);\r
+ If ok Then\r
+ priorite := 2;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(xx2,yy2,zz2) = 2) AND\r
+ (table.cub(xx3,yy3,zz3) = 2) AND\r
+ (priorite > 2)\r
+ Then\r
+ If numjoueur = 2 Then\r
+ defense := false;\r
+ Else\r
+ defense := true;\r
+ Fi;\r
+ call DeplPrior12 (lig2,lig1,ok);\r
+ If ok Then\r
+ priorite := 2;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** Priorite = 3 **)\r
+ \r
+ (** Si sur une meme ligne il y a trois pions du meme\r
+ joueur et a proximite une case libre, on deplace\r
+ le pion sur la case libre ==> possibilite d'aligne\r
+ ment pour le prochain coup **)\r
+ \r
+ If (table.cub(x1,y1,z1) = Numjoueur ) AND\r
+ (table.cub(x2,y2,z2) = Numjoueur ) AND\r
+ (table.cub(x3,y3,z3) = Numjoueur ) AND\r
+ (priorite > 3)\r
+ Then\r
+ prox := RechPtProx(lig2);\r
+ If ((prox = 1) Or (prox = 3)) And\r
+ (table.cub(xx2,yy2,zz2) = 0)\r
+ Then\r
+ priorite := 3;\r
+ ptdep.x := x1;\r
+ ptdep.y := y1;\r
+ ptdep.z := z1;\r
+ \r
+ ptarr.x := xx2;\r
+ ptarr.y := yy2;\r
+ ptarr.z := zz2;\r
+ Else\r
+ If ((prox = 2) Or (prox = 3)) And\r
+ (table.cub(xx3,yy3,zz3) = 0)\r
+ Then\r
+ priorite := 3;\r
+ ptdep.x := x1;\r
+ ptdep.y := y1;\r
+ ptdep.z := z1;\r
+ \r
+ ptarr.x := xx3;\r
+ ptarr.y := yy3;\r
+ ptarr.z := zz3;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (table.cub(x1,y1,z1) = Numjoueur ) AND\r
+ (table.cub(xx2,yy2,zz2) = Numjoueur ) AND\r
+ (table.cub(xx3,yy3,zz3) = Numjoueur ) AND\r
+ (priorite > 3)\r
+ Then\r
+ prox := RechPtProx(lig1);\r
+ If ((prox = 1) Or (prox = 3)) And\r
+ (table.cub(x2,y2,z2) = 0)\r
+ Then\r
+ priorite := 3;\r
+ ptdep.x := x1;\r
+ ptdep.y := y1;\r
+ ptdep.z := z1;\r
+ \r
+ ptarr.x := x2;\r
+ ptarr.y := y2;\r
+ ptarr.z := z2;\r
+ Else\r
+ If ((prox = 2) Or (prox = 3)) And\r
+ (table.cub(x3,y3,z3) = 0)\r
+ Then\r
+ priorite := 3;\r
+ ptdep.x := x1;\r
+ ptdep.y := y1;\r
+ ptdep.z := z1;\r
+ \r
+ ptarr.x := x3;\r
+ ptarr.y := y3;\r
+ ptarr.z := z3;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** Priorite = 4 **)\r
+ \r
+ (** Si sur une meme ligne on a 2 pions d'un meme joueur\r
+ et qu'il y ait possibilite de rapprocher un eventuel\r
+ troisieme pion du meme joueur, on effectue le\r
+ deplacement ==> possibilite d'alignement au prochain\r
+ coup **)\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = Numjoueur) AND\r
+ (table.cub(x3,y3,z3) = Numjoueur) AND\r
+ \r
+ (((table.cub(xx2,yy2,zz2) = Numjoueur)AND\r
+ (table.cub(xx3,yy3,zz3) = 0))OR\r
+ \r
+ ((table.cub(xx3,yy3,zz3) = Numjoueur)AND\r
+ (table.cub(xx2,yy2,zz2) = 0)))\r
+ AND\r
+ (priorite > 4)\r
+ Then\r
+ priorite := 4;\r
+ If table.cub(xx2,yy2,zz2) = Numjoueur\r
+ Then\r
+ ptdep.x := xx2;\r
+ ptdep.y := yy2;\r
+ ptdep.z := zz2;\r
+ ptarr.x := xx3;\r
+ ptarr.y := yy3;\r
+ ptarr.z := zz3;\r
+ Else\r
+ ptdep.x := xx3;\r
+ ptdep.y := yy3;\r
+ ptdep.z := zz3;\r
+ ptarr.x := xx2;\r
+ ptarr.y := yy2;\r
+ ptarr.z := zz2;\r
+ Fi;\r
+ \r
+ Fi;\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(xx2,yy2,zz2) = Numjoueur) AND\r
+ (table.cub(xx3,yy3,zz3) = Numjoueur) AND\r
+ \r
+ (((table.cub(x2,y2,z2) = Numjoueur)AND\r
+ (table.cub(x3,y3,z3) = 0))OR\r
+ \r
+ ((table.cub(x3,y3,z3) = Numjoueur)AND\r
+ (table.cub(x2,y2,z2) = 0)))\r
+ AND\r
+ (priorite > 4)\r
+ Then\r
+ priorite := 4;\r
+ If table.cub(x2,y2,z2) = Numjoueur\r
+ Then\r
+ ptdep.x := x2;\r
+ ptdep.y := y2;\r
+ ptdep.z := z2;\r
+ ptarr.x := x3;\r
+ ptarr.y := y3;\r
+ ptarr.z := z3;\r
+ Else\r
+ ptdep.x := x3;\r
+ ptdep.y := y3;\r
+ ptdep.z := z3;\r
+ ptarr.x := x2;\r
+ ptarr.y := y2;\r
+ ptarr.z := z2;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** priorite = 5 **)\r
+ \r
+ (** Pour chaque paire de lignes qui s'intersectent a une\r
+ case (x, y, z) de valeur 0\r
+ Si les valeurs des pions sur les 2 lignes sont\r
+ 1, 0, 0 dans n'importe quel ordre alors on aligne\r
+ deux pions ou on rapproche un pion ==> possibilite\r
+ d'alignement de deux pions au prochain coup **)\r
+ \r
+ If (table.cub(x1,y1,z1) = 0) AND\r
+ \r
+ (((table.cub(x2,y2,z2) = Numjoueur) AND\r
+ (table.cub(x3,y3,z3) = 0)) OR\r
+ \r
+ ((table.cub(x2,y2,z2) = 0) AND\r
+ (table.cub(x3,y3,z3) = Numjoueur)))\r
+ \r
+ AND\r
+ \r
+ (((table.cub(xx2,yy2,zz2) = Numjoueur) AND\r
+ (table.cub(xx3,yy3,zz3) = 0)) OR\r
+ \r
+ ((table.cub(xx2,yy2,zz2) = 0) AND\r
+ (table.cub(xx3,yy3,zz3) = Numjoueur)))\r
+ \r
+ AND\r
+ (priorite > 5)\r
+ \r
+ Then\r
+ priorite := 5;\r
+ prox := RechPtProx(lig1);\r
+ \r
+ (* si on peut aligne 2 pions on le fait sinon on\r
+ avance un pion pour que le coup d'apres on puisse\r
+ aligner les 2 pions *)\r
+ \r
+ If ((prox = 1) OR (prox = 3)) AND\r
+ (table.cub(x2,y2,z2) = Numjoueur )\r
+ Then\r
+ ptdep.x := x2;\r
+ ptdep.y := y2;\r
+ ptdep.z := z2;\r
+ \r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ Else\r
+ If ((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(x3,y3,z3) = Numjoueur)\r
+ Then\r
+ ptdep.x := x3;\r
+ ptdep.y := y3;\r
+ ptdep.z := z3;\r
+ \r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ Else\r
+ prox := RechPtProx(lig2);\r
+ If ((prox = 1) OR (prox = 3)) AND\r
+ (table.cub(xx2,yy2,zz2)=Numjoueur)\r
+ Then\r
+ ptdep.x := xx2;\r
+ ptdep.y := yy2;\r
+ ptdep.z := zz2;\r
+ \r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ Else\r
+ If ((prox=2) OR (prox =3)) AND\r
+ (table.cub(xx3,yy3,zz3)=Numjoueur)\r
+ Then\r
+ ptdep.x := xx3;\r
+ ptdep.y := yy3;\r
+ ptdep.z := zz3;\r
+ \r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ Else\r
+ If (prox = 1) Then\r
+ ptdep.x := xx3;\r
+ ptdep.y := yy3;\r
+ ptdep.z := zz3;\r
+ \r
+ ptarr.x := xx2;\r
+ ptarr.y := yy2;\r
+ ptarr.z := zz2;\r
+ Else\r
+ ptdep.x := xx2;\r
+ ptdep.y := yy2;\r
+ ptdep.z := zz2;\r
+ \r
+ ptarr.x := xx3;\r
+ ptarr.y := yy3;\r
+ ptarr.z := zz3;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ \r
+ OD;\r
+ OD;\r
+ OD;\r
+ \r
+ (** Priorite = 6 **)\r
+ \r
+ (** Deplacement aleatoire **)\r
+ \r
+ IF priorite = 6 Then\r
+ Call RandomDepl(lig1,lig2,Numjoueur);\r
+ Fi;\r
+ \r
+ For i := 1 To temps Do\r
+ call color(10);\r
+ call AffichPt (ptdep);\r
+ call HASCII(0);\r
+ call HASCII(219);\r
+ call Affichpt(ptarr);\r
+ call HASCII(0);\r
+ call HASCII(ord('#'));\r
+ Od;\r
+ \r
+END Phase1;\r
+ \r
+(*************************************************************************)\r
+(** Phase de deplacement des pions lorsqu'il y a 3 pions ou moins **)\r
+(** Cette phase est commune au 2 joueurs **)\r
+(** Dans certains cas, le joueur 1 observe une strategie offensive **)\r
+(** et le joueur 2 une strategie defensive **)\r
+(*************************************************************************)\r
+ \r
+UNIT Phase2 : PROCEDURE (lig1 , lig2 : ligne );\r
+ \r
+VAR priorite, prox, cpt : integer,\r
+ x1, x2, x3, y1, y2, y3, z1, z2, z3 : integer ,\r
+ xx2, xx3, yy2, yy3, zz2, zz3 : integer ,\r
+ i, j, k : integer ,\r
+ sortie : boolean ,\r
+ pion1, pion2, pion3 : elt ,\r
+ pion11, pion12 : elt;\r
+ \r
+BEGIN\r
+ \r
+ pion1 := NEW elt;\r
+ pion2 := NEW elt;\r
+ pion3 := NEW elt;\r
+ pion11 := NEW elt;\r
+ pion12 := NEW elt;\r
+ \r
+ priorite := 4;\r
+ cpt := 1;\r
+ For k := 1 To 3 Do\r
+ For j := 1 To 3 Do\r
+ For i := 1 To 3 Do\r
+ \r
+ call RechLignesCrois(i,j,k,lig1,lig2,sortie);\r
+ \r
+ x1 := lig1.pt1.x; y1 := lig1.pt1.y; z1 := lig1.pt1.z;\r
+ x2 := lig1.pt2.x; y2 := lig1.pt2.y; z2 := lig1.pt2.z;\r
+ x3 := lig1.pt3.x; y3 := lig1.pt3.y; z3 := lig1.pt3.z;\r
+ \r
+ xx2 := lig2.pt2.x; yy2 := lig2.pt2.y; zz2 := lig2.pt2.z;\r
+ xx3 := lig2.pt3.x; yy3 := lig2.pt3.y; zz3 := lig2.pt3.z;\r
+ \r
+ If sortie Then\r
+ \r
+ (** On recherche l'action a faire et on localise les pions\r
+ du joueur 1 **)\r
+ \r
+ (** Priorite = 1 **)\r
+ \r
+ (** On cherche \85 aligner 3 pions du joueur1 ou\r
+ a contrer l'alignement **)\r
+ \r
+ If (((nbpion1 = 3) AND (Numjoueur = 1)) Or\r
+ (Numjoueur = 2)) AND\r
+ (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = 1) AND\r
+ (table.cub(x3,y3,z3) = 1) AND\r
+ (priorite > 1)\r
+ Then\r
+ priorite := 1;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ \r
+ If Numjoueur = 1 Then\r
+ pion11.x := x2;\r
+ pion11.y := y2;\r
+ pion11.z := z2;\r
+ \r
+ pion12.x := x3;\r
+ pion12.y := y3;\r
+ pion12.z := z3;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (((nbpion1 = 3) AND (Numjoueur = 1)) Or\r
+ (Numjoueur = 2)) AND\r
+ (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(xx2,yy2,zz2) = 1) AND\r
+ (table.cub(xx3,yy3,zz3) = 1) AND\r
+ (priorite > 1)\r
+ Then\r
+ priorite := 1;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ \r
+ If Numjoueur = 1 Then\r
+ pion11.x := xx2;\r
+ pion11.y := yy2;\r
+ pion11.z := zz2;\r
+ \r
+ pion12.x := xx3;\r
+ pion12.y := yy3;\r
+ pion12.z := zz3;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** Priorite = 2 **)\r
+ \r
+ (** On cherche a aligner 3 pions du joueur2 ou a\r
+ contrer l'alignement **)\r
+ \r
+ If (((nbpion2 = 3) And (Numjoueur = 2)) OR\r
+ (numjoueur = 1)) AND\r
+ (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(x2,y2,z2) = 2) AND\r
+ (table.cub(x3,y3,z3) = 2) AND\r
+ (priorite > 2)\r
+ Then\r
+ priorite := 2;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ \r
+ If Numjoueur = 2 Then\r
+ pion11.x := x2;\r
+ pion11.y := y2;\r
+ pion11.z := z2;\r
+ \r
+ pion12.x := x3;\r
+ pion12.y := y3;\r
+ pion12.z := z3;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (((nbpion2 = 3) And (Numjoueur = 2)) OR\r
+ (numjoueur = 1)) AND\r
+ (table.cub(x1,y1,z1) = 0) AND\r
+ (table.cub(xx2,yy2,zz2) = 2) AND\r
+ (table.cub(xx3,yy3,zz3) = 2) AND\r
+ (priorite > 2)\r
+ Then\r
+ priorite := 2;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ \r
+ If Numjoueur = 2 Then\r
+ pion11.x := xx2;\r
+ pion11.y := yy2;\r
+ pion11.z := zz2;\r
+ \r
+ pion12.x := xx3;\r
+ pion12.y := yy3;\r
+ pion12.z := zz3;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** Priorite = 3 **)\r
+ \r
+ (** On essaie d'aligner 2 pions si le joueur possede\r
+ exactement 3 pions **)\r
+ \r
+ If (table.cub(x1,y1,z1) = 0 ) AND\r
+ ((table.cub(x2,y2,z2) = Numjoueur ) OR\r
+ (table.cub(x3,y3,z3) = Numjoueur ))\r
+ AND (priorite >3)\r
+ AND (nbpion1 = 3)\r
+ Then\r
+ priorite := 3;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ If table.cub(x2,y2,z2) = Numjoueur\r
+ Then\r
+ pion11.x := x2;\r
+ pion11.y := y2;\r
+ pion11.z := z2;\r
+ Else\r
+ pion11.x := x3;\r
+ pion11.y := y3;\r
+ pion11.z := z3;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (table.cub(x1,y1,z1) = 0 ) AND\r
+ ((table.cub(xx2,yy2,zz2) = Numjoueur ) OR\r
+ (table.cub(xx3,yy3,zz3) = Numjoueur ))\r
+ AND (priorite >3)\r
+ AND (nbpion1 = 3)\r
+ Then\r
+ priorite := 3;\r
+ ptarr.x := x1;\r
+ ptarr.y := y1;\r
+ ptarr.z := z1;\r
+ If table.cub(xx2,yy2,zz2) = Numjoueur\r
+ Then\r
+ pion11.x := xx2;\r
+ pion11.y := yy2;\r
+ pion11.z := zz2;\r
+ Else\r
+ pion11.x := xx3;\r
+ pion11.y := yy3;\r
+ pion11.z := zz3;\r
+ Fi;\r
+ Fi;\r
+ (** On situe les 3 pions du joueur 1 **)\r
+ If table.cub(x1,y1,z1) = Numjoueur\r
+ Then\r
+ If cpt = 1 Then\r
+ pion1.x := x1;\r
+ pion1.y := y1;\r
+ pion1.z := z1;\r
+ Fi;\r
+ If cpt = 2 Then\r
+ pion2.x := x1;\r
+ pion2.y := y1;\r
+ pion2.z := z1;\r
+ Fi;\r
+ If cpt = 3 Then\r
+ pion3.x := x1;\r
+ pion3.y := y1;\r
+ pion3.z := z1;\r
+ Fi;\r
+ cpt := cpt + 1;\r
+ Fi;\r
+ \r
+ Fi;\r
+ Od;\r
+ Od;\r
+ Od;\r
+ \r
+ (** Priorite = 4 **)\r
+ \r
+ (** Placement aleatoire **)\r
+ \r
+ If priorite = 4 Then\r
+ call RandomPlac(0);\r
+ Fi;\r
+ \r
+ (** Determination du point de depart **)\r
+ \r
+ If ((priorite = 1) And (Numjoueur = 1)) OR\r
+ ((priorite = 2) And (Numjoueur = 2))\r
+ Then\r
+ If ((pion3.x<>pion11.x) Or (pion3.y<>pion11.y) Or (pion3.z<>pion11.z))\r
+ AND\r
+ ((pion3.x<>pion12.x) Or (pion3.y<>pion12.y) Or (pion3.z<>pion12.z))\r
+ Then\r
+ ptdep.x := pion3.x;\r
+ ptdep.y := pion3.y;\r
+ ptdep.z := pion3.z;\r
+ Fi;\r
+ If ((pion2.x<>pion11.x) Or (pion2.y<>pion11.y) Or (pion2.z<>pion11.z))\r
+ AND\r
+ ((pion2.x<>pion12.x) Or (pion2.y<>pion12.y) Or (pion2.z<>pion12.z))\r
+ Then\r
+ ptdep.x := pion2.x;\r
+ ptdep.y := pion2.y;\r
+ ptdep.z := pion2.z;\r
+ Fi;\r
+ If ((pion1.x<>pion11.x) Or (pion1.y<>pion11.y) Or (pion1.z<>pion11.z))\r
+ AND\r
+ ((pion1.x<>pion12.x) Or (pion1.y<>pion12.y) Or (pion1.z<>pion12.z))\r
+ Then\r
+ ptdep.x := pion1.x;\r
+ ptdep.y := pion1.y;\r
+ ptdep.z := pion1.z;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If priorite = 3 Then\r
+ If (pion1.x<>pion11.x) Or (pion1.y<>pion11.y) Or (pion1.z<>pion11.z)\r
+ Then\r
+ ptdep.x := pion1.x;\r
+ ptdep.y := pion1.y;\r
+ ptdep.z := pion1.z;\r
+ Else\r
+ ptdep.x := pion2.x;\r
+ ptdep.y := pion2.y;\r
+ ptdep.z := pion2.z;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If ((priorite = 2) And (Numjoueur = 1)) Or\r
+ ((priorite = 1) And (Numjoueur = 2)) Or\r
+ (priorite = 4)\r
+ Then\r
+ ptdep.x := pion1.x;\r
+ ptdep.y := pion1.y;\r
+ ptdep.z := pion1.z;\r
+ Fi;\r
+ \r
+ kill (pion1);\r
+ kill (pion2);\r
+ kill (pion3);\r
+ kill (pion11);\r
+ kill (pion12);\r
+ \r
+ For i := 1 To temps Do\r
+ call color(10);\r
+ call AffichPt(ptdep);\r
+ call HASCII(0);\r
+ call HASCII(219);\r
+ call AffichPt(ptarr);\r
+ call HASCII(0);\r
+ call HASCII(ord('#'));\r
+ Od;\r
+ \r
+END Phase2;\r
+ \r
+(*************************************************************************)\r
+(** Phase "Manger" a la suite d'un alignement **)\r
+(** Cette phase est commune au deux joueurs **)\r
+(*************************************************************************)\r
+ \r
+ \r
+UNIT Phase3 : PROCEDURE ( lig1 , lig2 : ligne );\r
+ \r
+VAR priorite, prox : integer,\r
+ x1, x2, x3, y1, y2, y3, z1, z2, z3 : integer ,\r
+ xx2, xx3, yy2, yy3, zz2, zz3 : integer ,\r
+ i, j, k : integer ,\r
+ sortie : boolean;\r
+ \r
+BEGIN\r
+ \r
+ priorite := 4 ; (* priorite initialise au maximum *)\r
+ \r
+ For k := 1 To 3 Do\r
+ For j := 1 To 3 Do\r
+ For i := 1 To 3 Do\r
+ call RechLignesCrois(i,j,k,lig1,lig2,sortie);\r
+ \r
+ x1 := lig1.pt1.x; y1 := lig1.pt1.y; z1 := lig1.pt1.z;\r
+ x2 := lig1.pt2.x; y2 := lig1.pt2.y; z2 := lig1.pt2.z;\r
+ x3 := lig1.pt3.x; y3 := lig1.pt3.y; z3 := lig1.pt3.z;\r
+ \r
+ xx2 := lig2.pt2.x; yy2 := lig2.pt2.y; zz2 := lig2.pt2.z;\r
+ xx3 := lig2.pt3.x; yy3 := lig2.pt3.y; zz3 := lig2.pt3.z;\r
+ \r
+ If Sortie Then\r
+ \r
+ (** Priorite = 1 **)\r
+ \r
+ (** Si l'adversaire a une possibilite d'aligner 3\r
+ pions au prochain coup on lui en mange un **)\r
+ \r
+ If (table.cub(x1, y1, z1) = 0) AND\r
+ (table.cub(x2, y2, z2) = (3 - Numjoueur)) AND\r
+ (table.cub(x3, y3, z3) = (3 - Numjoueur))\r
+ Then\r
+ prox := RechPtProx(lig2);\r
+ If ((( prox = 1) OR (prox = 3)) AND\r
+ (table.cub(xx2,yy2,zz2)= (3 - Numjoueur)))OR\r
+ (((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(xx3,yy3,zz3)= (3 - Numjoueur)))\r
+ Then\r
+ priorite := 1 ;\r
+ prox := RechPtProx(lig1);\r
+ If prox = 1 Then\r
+ ptmange.x := x2;\r
+ ptmange.y := y2;\r
+ ptmange.z := z2;\r
+ Else\r
+ ptmange.x := x3;\r
+ ptmange.y := y3;\r
+ ptmange.z := z3;\r
+ Fi;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (table.cub(x1, y1, z1) = 0) AND\r
+ (table.cub(xx2, yy2, zz2) = (3 - Numjoueur)) AND\r
+ (table.cub(xx3, yy3, zz3) = (3 - Numjoueur))\r
+ Then\r
+ prox := RechPtProx(lig1);\r
+ If (((prox = 1) OR (prox = 3)) AND\r
+ (table.cub(x2,y2,z2)= (3 - Numjoueur)))OR\r
+ (((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(x3,y3,z3)= (3 - Numjoueur)))\r
+ Then\r
+ priorite := 1 ;\r
+ prox := RechPtProx(lig2);\r
+ If prox = 1 Then\r
+ ptmange.x := xx2;\r
+ ptmange.y := yy2;\r
+ ptmange.z := zz2;\r
+ Else\r
+ ptmange.x := xx3;\r
+ ptmange.y := yy3;\r
+ ptmange.z := zz3;\r
+ Fi;\r
+ exit;exit;exit;\r
+ Fi;\r
+ Fi;\r
+ \r
+ (** Priorite = 2 **)\r
+ \r
+ (** Si l'adversaire a trois pions alignes on lui en\r
+ mange un **)\r
+ \r
+ If (table.cub (x1, y1, z1) = (3 - Numjoueur))\r
+ AND\r
+ (table.cub (x2, y2, z2) = (3 - Numjoueur))\r
+ AND\r
+ (table.cub (x3, y3, z3) = (3 - Numjoueur))\r
+ AND\r
+ (priorite > 2)\r
+ Then\r
+ priorite := 2;\r
+ ptmange.x := x1;\r
+ ptmange.y := y1;\r
+ ptmange.z := z1;\r
+ Fi;\r
+ \r
+ If (table.cub (x1, y1, z1) = (3 - Numjoueur))\r
+ AND\r
+ (table.cub (xx2, yy2, zz2) = (3 - Numjoueur))\r
+ AND\r
+ (table.cub (xx3, yy3, zz3) = (3 - Numjoueur))\r
+ AND\r
+ (priorite > 2)\r
+ Then\r
+ priorite := 2;\r
+ ptmange.x := x1;\r
+ ptmange.y := y1;\r
+ ptmange.z := z1;\r
+ Fi;\r
+ \r
+ (** Priorite = 3 **)\r
+ \r
+ (** Si on a possibilite d'aligner 3 pions au prochain\r
+ coup et que l'adversaire nous bloque on lui mange\r
+ le pion **)\r
+ \r
+ If (priorite > 3) AND\r
+ (table.cub (x1, y1, z1) = (3 - Numjoueur))\r
+ AND\r
+ (table.cub (x2, y2, z2) = Numjoueur)\r
+ AND\r
+ (table.cub (x3, y3, z3) = Numjoueur)\r
+ Then\r
+ prox := RechPtProx(lig2);\r
+ If (((prox = 1) OR (prox = 3)) AND\r
+ (table.cub(xx2,yy2,zz2) = Numjoueur))\r
+ OR\r
+ (((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(xx3,yy3,zz3) = Numjoueur))\r
+ Then\r
+ priorite := 3;\r
+ ptmange.x := x1;\r
+ ptmange.y := y1;\r
+ ptmange.z := z1;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If (priorite > 3) AND\r
+ (table.cub (x1, y1, z1) = (3 - Numjoueur))\r
+ AND\r
+ (table.cub (xx2, yy2, zz2) = Numjoueur)\r
+ AND\r
+ (table.cub (xx3, yy3, zz3) = Numjoueur)\r
+ Then\r
+ prox := RechPtProx(lig1);\r
+ If (((prox = 1) OR (prox = 3)) AND\r
+ (table.cub(x2,y2,z2) = Numjoueur))\r
+ OR\r
+ (((prox = 2) OR (prox = 3)) AND\r
+ (table.cub(x3,y3,z3) = Numjoueur))\r
+ Then\r
+ priorite := 3;\r
+ ptmange.x := x1;\r
+ ptmange.y := y1;\r
+ ptmange.z := z1;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Od;\r
+ Od;\r
+ \r
+ (** Priorite = 4 **)\r
+ \r
+ (** Placement aleatoire sur un pion du joueur adverse **)\r
+ \r
+ If priorite = 4 Then\r
+ i := 3 - Numjoueur;\r
+ call RandomPlac(i);\r
+ ptmange.x := ptarr.x;\r
+ ptmange.y := ptarr.y;\r
+ ptmange.z := ptarr.z;\r
+ Fi;\r
+ \r
+ For i := 1 To temps Do\r
+ call color(10);\r
+ call AffichPt(ptmange);\r
+ call HASCII(0);\r
+ call HASCII(219);\r
+ Od;\r
+ \r
+END Phase3;\r
+ \r
+ \r
+(***************************************************************************)\r
+(** **)\r
+(** Coroutine : JOUEUR1 **)\r
+(** **)\r
+(** Strategie offensive **)\r
+(** **)\r
+(***************************************************************************)\r
+ \r
+ \r
+UNIT joueur1 : COROUTINE;\r
+ \r
+BEGIN\r
+ \r
+ return;\r
+ \r
+ \r
+ DO\r
+ \r
+ IF phase = 0\r
+ THEN\r
+ (* Placement des pions *)\r
+ \r
+ Call phase0 ( lig1, lig2 );\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ FI; (** Fin de la phase 0 ; Placement de pion **)\r
+ \r
+ \r
+ IF phase = 1 THEN\r
+ (** deplacement d'un pion si le joueur 1 a plus de 3 pions **)\r
+ \r
+ call Phase1 (lig1 , lig2);\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ Fi; (** Fin phase = 1 ; Deplacement de pions . Nbpion1 >3 **)\r
+ \r
+ \r
+ \r
+ \r
+ IF phase = 2 THEN\r
+ (* Deplacement de pions si le nombre de pions du joueur 1 est <= a 3 *)\r
+ \r
+ Call Phase2 (lig1 , lig2);\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ FI; (** Fin phase = 2; Deplacement de pions. Nbpion1 <= 3 **)\r
+ \r
+ \r
+ \r
+ \r
+ IF phase = 3 THEN\r
+ (* Le joueur 1 mange un des pions du joueur 2 *)\r
+ \r
+ Call Phase3 (lig1 , lig2);\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ FI; (** Fin phase = 3; Manger Pion **)\r
+ \r
+OD;\r
+ \r
+END joueur1;\r
+ \r
+ \r
+ \r
+(***************************************************************************)\r
+(** **)\r
+(** Coroutine : JOUEUR2 **)\r
+(** **)\r
+(** Strategie defensive **)\r
+(** **)\r
+(***************************************************************************)\r
+ \r
+ \r
+ \r
+UNIT joueur2 : COROUTINE;\r
+ \r
+ \r
+BEGIN\r
+ \r
+ return;\r
+ \r
+ \r
+ DO\r
+ \r
+ IF phase = 0\r
+ THEN\r
+ (* Placement des pions *)\r
+ \r
+ Call phase0 ( lig1, lig2 );\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ FI; (** Fin de la phase 0 ; Placement de pion **)\r
+ \r
+ \r
+ IF phase = 1 THEN\r
+ (** deplacement d'un pion si le joueur 1 a plus de 3 pions **)\r
+ \r
+ call Phase1 (lig1 , lig2);\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ Fi; (** Fin phase = 1 ; Deplacement de pions . Nbpion1 >3 **)\r
+ \r
+ \r
+ \r
+ \r
+ IF phase = 2 THEN\r
+ (* Deplacement de pions si le nombre de pions du joueur 1 est <= a 3 *)\r
+ \r
+ Call Phase2 (lig1 , lig2);\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ FI; (** Fin phase = 2; Deplacement de pions. Nbpion1 <= 3 **)\r
+ \r
+ \r
+ \r
+ \r
+ IF phase = 3 THEN\r
+ (* Le joueur 1 mange un des pions du joueur 2 *)\r
+ \r
+ Call Phase3 (lig1 , lig2);\r
+ \r
+ detach; (** Retour a la coroutine Arbitre **)\r
+ \r
+ FI; (** Fin phase = 3; Manger Pion **)\r
+ \r
+OD;\r
+ \r
+END joueur2;\r
+ \r
+ \r
+(***************************************************************************)\r
+(** **)\r
+(** Coroutine : ARBITRE **)\r
+(** **)\r
+(***************************************************************************)\r
+ \r
+ \r
+ \r
+UNIT arbitre : COROUTINE ;\r
+ \r
+ \r
+ Unit VerifPt : Class;\r
+ \r
+ (** Verifie :\r
+ - si un joueur a place ou deplace un pion sur une case deja occupee\r
+ - si 3 pions ont ete alignes lors du dernier coup joue\r
+ Valide ou annule le coup **)\r
+ \r
+ Var sortie : boolean;\r
+ \r
+ Begin\r
+ \r
+ (** Verification de la validit\82 du point d'arrivee **)\r
+ okpt := (table.cub(ptarr.x,ptarr.y,ptarr.z)=0);\r
+ \r
+ If okpt Then\r
+ \r
+ If (phase = 1) Or (phase = 2) Then\r
+ table.cub(ptdep.x,ptdep.y,ptdep.z) := 0;\r
+ call color(15);\r
+ call AffichPt(ptdep);\r
+ call HASCII(0);\r
+ call HASCII(ord('+'));\r
+ Fi;\r
+ \r
+ (** Mise a jour de la table de jeu : le cube **)\r
+ \r
+ table.cub(ptarr.x,ptarr.y,ptarr.z) := numjoueur ;\r
+ If numjoueur = 1 Then\r
+ call color(3);\r
+ Else\r
+ call color(5);\r
+ Fi;\r
+ call AffichPt(ptarr);\r
+ call HASCII(0);\r
+ call HASCII(219);\r
+ \r
+ inner;\r
+ \r
+ (* verification aligne ==> manger *)\r
+ \r
+ Call RechLignesCrois (ptarr.x,ptarr.y,ptarr.z,lig1,lig2,sortie);\r
+ \r
+ aligne := ((table.cub(lig1.pt1.x,lig1.pt1.y,lig1.pt1.z)=Numjoueur) And\r
+ (table.cub(lig1.pt2.x,lig1.pt2.y,lig1.pt2.z)=Numjoueur) And\r
+ (table.cub(lig1.pt3.x,lig1.pt3.y,lig1.pt3.z)=Numjoueur));\r
+ \r
+ If not aligne Then\r
+ \r
+ aligne := ((table.cub(lig2.pt1.x,lig2.pt1.y,lig2.pt1.z)=Numjoueur) And\r
+ (table.cub(lig2.pt2.x,lig2.pt2.y,lig2.pt2.z)=Numjoueur) And\r
+ (table.cub(lig2.pt3.x,lig2.pt3.y,lig2.pt3.z)=Numjoueur));\r
+ \r
+ Fi;\r
+ \r
+ Else (* mauvais placement *)\r
+ If table.cub(ptarr.x,ptarr.y,ptarr.z) = 1 Then\r
+ call color(3);\r
+ Else\r
+ call color(5);\r
+ Fi;\r
+ \r
+ call AffichPt(ptarr);\r
+ call HASCII(0);\r
+ call HASCII(219);\r
+ Fi;\r
+ \r
+ End VerifPt;\r
+ \r
+ \r
+ \r
+ \r
+ Unit VerifLigne : verifpt Class;\r
+ \r
+ (** Verifie lors de la phase du deplacement de plus de 3 pions le\r
+ bon deplacement du pion :\r
+ - sur la meme ligne\r
+ - dans un point proche **)\r
+ \r
+ Var Absx,Absy,Absz : integer ;\r
+ Begin\r
+ (* Si le deplacement n'est pas sur une ligne existante ou *)\r
+ (* si le pion deplace a saute une ou plusieurs case *)\r
+ (* alors le mouvement est mauvais *)\r
+ \r
+ Absx := Abs(ptdep.x - ptarr.x);\r
+ Absy := Abs(ptdep.y - ptarr.y);\r
+ Absz := Abs(ptdep.z - ptarr.z);\r
+ \r
+ If ((ptdep.x <> 2) And (ptdep.y <> 2) And (ptdep.z <> ptarr.z)) Or\r
+ (Absx > 1) Or (Absy > 1) Or (Absz > 1) Or\r
+ (Absx + Absy + Absz = 3) Or\r
+ (Absx + Absy = 2) Or (Absx + Absz = 2) Or (Absz + Absy = 2)\r
+ Then\r
+ okligne := false;\r
+ \r
+ (* on remet le pion dans sa position initiale *)\r
+ table.cub(ptdep.x,ptdep.y,ptdep.z):= numjoueur ;\r
+ If numjoueur = 1 Then\r
+ call color(3);\r
+ Else\r
+ call color(5);\r
+ Fi;\r
+ \r
+ call AffichPt(ptdep);\r
+ call HASCII(0);\r
+ call HASCII(219);\r
+ \r
+ table.cub(ptarr.x,ptarr.y,ptarr.z):= 0 ;\r
+ call color(15);\r
+ call AffichPt(ptarr);\r
+ call HASCII(0);\r
+ call HASCII(ord('+'));\r
+ \r
+ Else\r
+ okligne := true;\r
+ Fi;\r
+ \r
+ End VerifLigne;\r
+ \r
+ \r
+ Unit Gagne : Function : boolean;\r
+ \r
+ (** D\82termine si le joueur courant a gagne ou pas **)\r
+ \r
+ Begin\r
+ If (nbpion1 < 3) Or (nbpion2 < 3)\r
+ Then\r
+ result := true;\r
+ Else result := false;\r
+ Fi;\r
+ End gagne;\r
+ \r
+ \r
+ Unit PionAligne : Procedure;\r
+ \r
+ Unit VerifMange : Function : boolean;\r
+ \r
+ (** Verifie si le pion mange appartient bien au joueur adverse **)\r
+ \r
+ begin\r
+ \r
+ result:=(table.cub(ptmange.x,ptmange.y,ptmange.z) = (3-Numjoueur));\r
+ If result\r
+ Then\r
+ table.cub(ptmange.x,ptmange.y,ptmange.z) := 0;\r
+ else\r
+ call Erreur1;\r
+ Fi;\r
+ If table.cub(ptmange.x,ptmange.y,ptmange.z) = 0\r
+ Then\r
+ call color(15);\r
+ call AffichPt(ptmange);\r
+ call HASCII (0);\r
+ call HASCII(ord('+'));\r
+ Fi;\r
+ If table.cub(ptmange.x,ptmange.y,ptmange.z) = 1\r
+ Then\r
+ call color(3);\r
+ call AffichPt(ptmange);\r
+ call HASCII (0);\r
+ call HASCII(219);\r
+ Fi;\r
+ If table.cub(ptmange.x,ptmange.y,ptmange.z) = 2\r
+ Then\r
+ call color(5);\r
+ call AffichPt(ptmange);\r
+ call HASCII (0);\r
+ call HASCII(219);\r
+ Fi;\r
+ \r
+ End VerifMange;\r
+ \r
+ (** Pionaligne : appel de la phase 3 et mise a jour du nombre de pions **)\r
+ \r
+ Var mange : boolean;\r
+ \r
+ Begin\r
+ \r
+ mange := false;\r
+ While not mange Do\r
+ phase := 3;\r
+ call affichephase(phase);\r
+ if numjoueur = 1 then\r
+ attach(J1);\r
+ else\r
+ attach(J2);\r
+ fi;\r
+ mange := Verifmange;\r
+ Od;\r
+ If numjoueur = 1 Then\r
+ nbpion2 := nbpion2 - 1;\r
+ Else\r
+ nbpion1 := nbpion1 - 1;\r
+ Fi;\r
+ \r
+ End PionAligne;\r
+ \r
+ \r
+ \r
+VAR\r
+ nbpionpla : integer,\r
+ i : integer,\r
+ \r
+ okpt : boolean,\r
+ aligne : boolean,\r
+ okligne : boolean,\r
+ \r
+ verifpoint : verifpt,\r
+ veriflig : verifligne,\r
+ \r
+ erreur : boolean,\r
+ fini : boolean;\r
+ \r
+BEGIN\r
+ numjoueur := 1;\r
+ nbpionpla := 0;\r
+ Call affichejoueur(numjoueur);\r
+ return;\r
+ \r
+ \r
+ (* PLACEMENT DES PIONS *)\r
+ \r
+ While nbpionpla < 18 Do\r
+ \r
+ phase := 0;\r
+ Call affichephase(phase);\r
+ If numjoueur = 1 Then\r
+ attach(J1);\r
+ Else\r
+ attach(J2);\r
+ Fi;\r
+ \r
+ VerifPoint := NEW VerifPt;\r
+ \r
+ If Not okpt Then\r
+ call erreur1;\r
+ Else\r
+ nbpionpla := nbpionpla + 1;\r
+ If aligne Then call PionAligne; Fi;\r
+ numjoueur := 3 - numjoueur;\r
+ Call affichejoueur(numjoueur);\r
+ Fi;\r
+ kill (VerifPoint);\r
+ Od;\r
+ \r
+ (* DEPLACEMENT DES PIONS *)\r
+ \r
+ Do\r
+ \r
+ erreur := false;\r
+ call affichejoueur(numjoueur);\r
+ \r
+ If numjoueur = 1 Then\r
+ if nbpion1 <= 3 then\r
+ phase := 2;\r
+ call affichephase(phase);\r
+ attach(J1);\r
+ else\r
+ phase := 1;\r
+ call affichephase(phase);\r
+ attach(J1);\r
+ fi;\r
+ Else\r
+ if nbpion2 <= 3 then\r
+ phase := 2;\r
+ call affichephase(phase);\r
+ attach(J2);\r
+ else\r
+ phase := 1;\r
+ call affichephase(phase);\r
+ attach(J2);\r
+ fi;\r
+ Fi;\r
+ \r
+ If ((numjoueur = 1) And (nbpion1 <= 3)) Or\r
+ ((numjoueur = 2) And (nbpion2 <= 3))\r
+ Then\r
+ (** Moins de trois pions ==> Pas de verification sur le deplacement\r
+ par rapport aux lignes **)\r
+ Verifpoint := NEW verifpt;\r
+ Else\r
+ Veriflig := NEW verifligne;\r
+ Fi;\r
+ \r
+ If Not okpt Then\r
+ call erreur1;\r
+ erreur := true;\r
+ Else If ((numjoueur = 1) And (nbpion1 > 3)) Or\r
+ ((numjoueur = 2) And (nbpion2 > 3))\r
+ Then\r
+ if not okligne then\r
+ call erreur1;\r
+ erreur := true;\r
+ else\r
+ if aligne Then call PionAligne;fi;\r
+ fi;\r
+ Else if aligne Then call Pionaligne;fi;\r
+ Fi;\r
+ \r
+ fini := gagne;\r
+ If fini Then\r
+ call affichejoueur(numjoueur);\r
+ call move (520,210);\r
+ call HASCII(0) ; call HASCII(ord('G'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('A'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('G'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('N'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('E'));\r
+ call HASCII(0) ; call HASCII(ord(' '));\r
+ call HASCII(0) ; call HASCII(ord('!'));\r
+ exit;\r
+ Fi;\r
+ Fi;\r
+ \r
+ If not erreur Then\r
+ numjoueur := 3 - numjoueur;\r
+ call affichejoueur(numjoueur);\r
+ Fi;\r
+ \r
+ If ((numjoueur = 1) And (nbpion1 <= 3)) Or\r
+ ((numjoueur = 2) And (nbpion2 <= 3))\r
+ Then\r
+ kill (verifpoint);\r
+ Else\r
+ kill (veriflig);\r
+ Fi;\r
+ \r
+ \r
+ Od;\r
+ \r
+END arbitre;\r
+ \r
+(** Programme principal **)\r
+ \r
+CONST temps = 1000;\r
+ (* Constante permettant de ralentir l'affichage *)\r
+ (* Si l'execution est trop rapide il suffit d'augmenter cette constante*)\r
+ \r
+VAR table : cube,\r
+ tab : arrayof integer,\r
+ Numjoueur : integer,\r
+ ptdep,ptarr,ptmange : elt,\r
+ nbpion1, nbpion2 : integer,\r
+ phase : integer,\r
+ lig1,lig2 : ligne,\r
+ defense : boolean,\r
+ J1 : joueur1,\r
+ J2 : joueur2,\r
+ A : arbitre;\r
+ \r
+BEGIN\r
+ call GRON(0);\r
+ \r
+ table := NEW cube ;\r
+ ptdep := NEW elt;\r
+ ptarr := NEW elt;\r
+ lig1 := NEW ligne;\r
+ lig2 := NEW ligne;\r
+ ptmange := NEW elt ;\r
+ array tab dim (1:800);\r
+ nbpion1, nbpion2 := 9;\r
+ \r
+ call AfficheTable;\r
+ \r
+ J1 := NEW joueur1;\r
+ J2 := NEW joueur2;\r
+ A := NEW arbitre;\r
+ attach(A);\r
+ \r
+END;\r
+END;\r
+ \r
--- /dev/null
+Program LABYRINTHE;\r
+ \r
+Begin\r
+ Pref MOUSE Block\r
+ \r
+ Unit LABYGRAPH: IIUWGRAPH Class;\r
+ \r
+ Unit LIFO: Class;\r
+ \r
+ Unit ELEM: Class (S: SALLE);\r
+ Var ANTE: ELEM;\r
+ End ELEM;\r
+ \r
+ Unit PILE: Class;\r
+ Var PREM: ELEM;\r
+ End PILE;\r
+ \r
+ Unit EMPIL: Procedure (InOut E: ELEM; InOut P: PILE);\r
+ Begin\r
+ If Not VIDE (P)\r
+ Then\r
+ E.ANTE:= P.PREM;\r
+ Fi;\r
+ P.PREM:= E;\r
+ End EMPIL;\r
+ \r
+ Unit DEPIL: Procedure (InOut P: PILE);\r
+ Var AUX: ELEM;\r
+ Begin\r
+ If Not VIDE (P)\r
+ Then\r
+ AUX:= P.PREM;\r
+ If AUX.ANTE=/=None\r
+ Then\r
+ P.PREM:= AUX.ANTE;\r
+ Fi;\r
+ Kill (AUX.S);\r
+ Kill (AUX);\r
+ Fi;\r
+ End DEPIL;\r
+ \r
+ Unit VIDE: Function (P: PILE): Boolean;\r
+ Begin\r
+ Result:= (P.PREM=None);\r
+ End VIDE;\r
+ \r
+ End LIFO;\r
+ \r
+ Unit PIECE: Class (N,E,S,O: Boolean; MARQUE: Boolean);\r
+ End PIECE;\r
+ \r
+ Unit SALLE: Class (L,C: Integer; PC: PIECE);\r
+ End SALLE;\r
+ \r
+ Unit PRINCE: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+5,Y+10); Call Draw (X+5,Y+6);\r
+ Call Move (X+6,Y+5); Call Draw (X+6,Y+6);\r
+ Call Move (X+7,Y+2); Call Draw (X+7,Y+3);\r
+ Call Move (X+7,Y+5); Call Draw (X+7,Y+15);\r
+ Call Point (X+6,Y+15);\r
+ Call Move (X+8,Y+1); Call Draw (X+8,Y+10);\r
+ Call Move (X+9,Y+1); Call Draw (X+9,Y+10);\r
+ Call Move (X+10,Y+2); Call Draw (X+10,Y+3);\r
+ Call Move (X+10,Y+5); Call Draw (X+10,Y+15);\r
+ Call Move (X+11,Y+5); Call Draw (X+11,Y+6);\r
+ Call Point (X+11,Y+15);\r
+ Call Move (X+12,Y+6); Call Draw (X+12,Y+10);\r
+ Call Draw (X+15,Y+13); Call Draw (X+15,Y+15);\r
+ Call Move (X+14,Y+14); Call Draw (X+16,Y+14);\r
+ End;\r
+ \r
+ Unit PRINCNORD: Procedure (OutPut PNORD: ArrayOf Integer);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ X:=0;\r
+ Y:=0;\r
+ Call Cls;\r
+ Call Move (X+5,Y+10); Call Draw (X+5,Y+6);\r
+ Call Move (X+6,Y+5); Call Draw (X+6,Y+6);\r
+ Call Move (X+7,Y+2); Call Draw (X+7,Y+3);\r
+ Call Move (X+7,Y+5); Call Draw (X+7,Y+15);\r
+ Call Point (X+6,Y+14);\r
+ Call Move (X+8,Y+1); Call Draw (X+8,Y+10);\r
+ Call Move (X+9,Y+1); Call Draw (X+9,Y+10);\r
+ Call Move (X+10,Y+2); Call Draw (X+10,Y+3);\r
+ Call Move (X+10,Y+5); Call Draw (X+10,Y+15);\r
+ Call Move (X+11,Y+5); Call Draw (X+11,Y+6);\r
+ Call Point (X+11,Y+14);\r
+ Call Move (X+12,Y+6); Call Draw (X+12,Y+10);\r
+ Call Move (X+13,Y+10); Call Draw (X+13,Y+16);\r
+ Call GOODGET (PNORD);\r
+ End;\r
+ \r
+ Unit PRINCEST: Procedure (OutPut PEST: ArrayOf Integer);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ X:=0;\r
+ Y:=0;\r
+ Call Cls;\r
+ Call Move (X+1,Y+13); Call Draw (X+4,Y+13);\r
+ Call Draw (X+6,Y+11); Call Draw (X+6,Y+9);\r
+ Call Draw (X+10,Y+5); Call Draw (X+10,Y+12);\r
+ Call Draw (X+9,Y+13); Call Draw (X+7,Y+13);\r
+ Call Draw (X+7,Y+14);\r
+ Call Move (X+10,Y+1); Call Draw (X+10,Y+3);\r
+ Call Move (X+11,Y+1); Call Draw (X+11,Y+10);\r
+ Call Move (X+12,Y+1); Call Draw (X+12,Y+3);\r
+ Call Point (X+13,Y+2);\r
+ Call Move (X+12,Y+5); Call Draw (X+12,Y+15);\r
+ Call Point (X+13,Y+15);\r
+ Call Point (X+13,Y+7);\r
+ Call Move (X+14,Y+8); Call Draw (X+15,Y+8);\r
+ Call GOODGET (PEST);\r
+ End;\r
+ \r
+ Unit PRINCSUD: Procedure (OutPut PSUD: ArrayOf Integer);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ X:=0;\r
+ Y:=0;\r
+ Call Cls;\r
+ Call Move (X+4,Y+1); Call Draw (X+4,Y+9);\r
+ Call Point (X+5,Y+10);\r
+ Call Move (X+6,Y+10); Call Draw (X+6,Y+6);\r
+ Call Move (X+7,Y+5); Call Draw (X+7,Y+6);\r
+ Call Move (X+8,Y+2); Call Draw (X+8,Y+3);\r
+ Call Move (X+8,Y+5); Call Draw (X+8,Y+15);\r
+ Call Point (X+7,Y+16);\r
+ Call Move (X+9,Y+1); Call Draw (X+9,Y+10);\r
+ Call Move (X+10,Y+1); Call Draw (X+10,Y+10);\r
+ Call Move (X+11,Y+2); Call Draw (X+11,Y+3);\r
+ Call Move (X+11,Y+5); Call Draw (X+11,Y+15);\r
+ Call Move (X+12,Y+5); Call Draw (X+12,Y+6);\r
+ Call Move (X+12,Y+5); Call Draw (X+12,Y+6);\r
+ Call Point (X+12,Y+16);\r
+ Call Move (X+13,Y+6); Call Draw (X+13,Y+10);\r
+ Call GOODGET (PSUD);\r
+ End;\r
+ \r
+ Unit PRINCOUEST: Procedure (OutPut POUEST: ArrayOf Integer);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ X:=0;\r
+ Y:=0;\r
+ Call Cls;\r
+ Call Move (X+2,Y+8); Call Draw (X+3,Y+8);\r
+ Call Point (X+4,Y+2);\r
+ Call Point (X+4,Y+7);\r
+ Call Move (X+5,Y+1); Call Draw (X+5,Y+3);\r
+ Call Move (X+5,Y+5); Call Draw (X+5,Y+15);\r
+ Call Draw (X+4,Y+15);\r
+ Call Move (X+6,Y+1); Call Draw (X+6,Y+10);\r
+ Call Move (X+7,Y+1); Call Draw (X+7,Y+3);\r
+ Call Move (X+16,Y+4); Call Draw (X+11,Y+4);\r
+ Call Move (X+11,Y+5);\r
+ Call Draw (X+9,Y+7); Call Draw (X+7,Y+5);\r
+ Call Draw (X+7,Y+12); Call Draw (X+8,Y+13);\r
+ Call Draw (X+10,Y+13); Call Draw (X+10,Y+14);\r
+ Call GOODGET (POUEST);\r
+ End;\r
+ \r
+ Unit PRINCESSE: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Point (X+5,Y+5);\r
+ Call Point (X+12,Y+5);\r
+ Call Move (X+8,Y+1); Call Draw (X+11,Y+4);\r
+ Call Move (X+9,Y+1); Call Draw (X+6,Y+4);\r
+ Call Move (X+7,Y+2); Call Draw (X+13,Y+8);\r
+ Call Move (X+10,Y+2); Call Draw (X+4,Y+8);\r
+ Call Point (X+4,Y+12);\r
+ Call Move (X+5,Y+11); Call Draw (X+5,Y+12);\r
+ Call Move (X+6,Y+9); Call Draw (X+6,Y+12);\r
+ Call Point (X+7,Y+6);\r
+ Call Move (X+7,Y+8); Call Draw (X+7,Y+15);\r
+ Call Move (X+8,Y+5); Call Draw (X+8,Y+12);\r
+ Call Move (X+9,Y+5); Call Draw (X+9,Y+12);\r
+ Call Point (X+10,Y+6);\r
+ Call Move (X+10,Y+8); Call Draw (X+10,Y+15);\r
+ Call Move (X+11,Y+9); Call Draw (X+11,Y+12);\r
+ Call Move (X+12,Y+11); Call Draw (X+12,Y+12);\r
+ Call Point (X+13,Y+12);\r
+ End;\r
+ \r
+ Unit COEUR: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+8,Y+5); Call Draw (X+6,Y+3);\r
+ Call Draw (X+4,Y+3); Call Draw (X+2,Y+5);\r
+ Call Draw (X+2,Y+9); Call Draw (X+7,Y+14);\r
+ Call Draw (X+10,Y+14); Call Draw (X+15,Y+9);\r
+ Call Draw (X+15,Y+5); Call Draw (X+13,Y+3);\r
+ Call Draw (X+11,Y+3); Call Draw (X+9,Y+5);\r
+ Call Move (X+4,Y+7); Call Draw (X+4,Y+8);\r
+ Call Draw (X+8,Y+12); Call Draw (X+9,Y+12);\r
+ End;\r
+ \r
+ Unit BBLANC: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+7,Y+3); Call Draw (X+3,Y+7);\r
+ Call Draw (X+3,Y+10); Call Draw (X+7,Y+14);\r
+ Call Draw (X+10,Y+14); Call Draw (X+14,Y+10);\r
+ Call Draw (X+14,Y+7); Call Draw (X+10,Y+3);\r
+ Call Draw (X+7,Y+3);\r
+ Call Move (X+5,Y+8); Call Draw (X+5,Y+9);\r
+ Call Draw (X+8,Y+12); Call Draw (X+9,Y+12);\r
+ End;\r
+ \r
+ Unit BNOIRE: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+3,Y+7); Call Draw (X+3,Y+10);\r
+ Call Move (X+4,Y+6); Call Draw (X+4,Y+11);\r
+ Call Move (X+5,Y+5); Call Draw (X+5,Y+7);\r
+ Call Move (X+5,Y+10); Call Draw (X+5,Y+12);\r
+ Call Move (X+6,Y+4); Call Draw (X+6,Y+9);\r
+ Call Move (X+6,Y+11); Call Draw (X+6,Y+13);\r
+ Call Move (X+7,Y+3); Call Draw (X+7,Y+10);\r
+ Call Move (X+7,Y+12); Call Draw (X+7,Y+14);\r
+ Call Move (X+8,Y+3); Call Draw (X+8,Y+11);\r
+ Call Move (X+8,Y+13); Call Draw (X+8,Y+14);\r
+ Call Move (X+9,Y+3); Call Draw (X+9,Y+11);\r
+ Call Move (X+9,Y+13); Call Draw (X+9,Y+14);\r
+ Call Move (X+10,Y+3); Call Draw (X+10,Y+14);\r
+ Call Move (X+11,Y+4); Call Draw (X+11,Y+13);\r
+ Call Move (X+12,Y+5); Call Draw (X+12,Y+12);\r
+ Call Move (X+13,Y+6); Call Draw (X+13,Y+11);\r
+ Call Move (X+14,Y+7); Call Draw (X+14,Y+10);\r
+ End;\r
+ \r
+ Unit BARNORD: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+5,Y+1); Call Draw (X+5,Y+4);\r
+ Call Move (X+12,Y+1); Call Draw (X+12,Y+4);\r
+ End;\r
+ \r
+ Unit BAROUEST: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+1,Y+5); Call Draw (X+4,Y+5);\r
+ Call Move (X+1,Y+12); Call Draw (X+4,Y+12);\r
+ End;\r
+ \r
+ Unit BARSUD: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+5,Y+13); Call Draw (X+5,Y+16);\r
+ Call Move (X+12,Y+13); Call Draw (X+12,Y+16);\r
+ End;\r
+ \r
+ Unit BAREST: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+13,Y+5); Call Draw (X+16,Y+5);\r
+ Call Move (X+13,Y+12); Call Draw (X+16,Y+12);\r
+ End;\r
+ \r
+ Unit BARHORIZ: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+1,Y+5); Call Draw (X+16,Y+5);\r
+ Call Move (X+1,Y+10); Call Draw (X+16,Y+10);\r
+ Call Move (X+1,Y+12); Call Draw (X+16,Y+12);\r
+ End;\r
+ \r
+ Unit BARVERTI: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+5,Y+1); Call Draw (X+5,Y+16);\r
+ Call Move (X+7,Y+1); Call Draw (X+7,Y+16);\r
+ Call Move (X+12,Y+1); Call Draw (X+12,Y+16);\r
+ End;\r
+ \r
+ Unit TOMBE: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+2,Y+5); Call Draw (X+6,Y+3);\r
+ Call Move (X+4,Y+1); Call Draw (X+4,Y+8);\r
+ Call Draw (X+6,Y+8); Call Draw (X+15,Y+13);\r
+ Call Draw (X+12,Y+16);\r
+ Call Move (X+11,Y+16); Call Draw (X+2,Y+11);\r
+ Call Move (X+2,Y+10); Call Draw (X+4,Y+8);\r
+ Call Move (X+4,Y+11); Call Draw (X+11,Y+14);\r
+ End;\r
+ \r
+ Unit PELOTE: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X+6,Y+2);\r
+ Call Draw (X+2,Y+6); Call Draw (X+2,Y+11);\r
+ Call Draw (X+6,Y+15); Call Draw (X+11,Y+15);\r
+ Call Draw (X+15,Y+11); Call Draw (X+15,Y+6);\r
+ Call Draw (X+11,Y+2); Call Draw (X+6,Y+2);\r
+ Call Draw (X+6,Y+9); Call Draw (X+11,Y+14);\r
+ Call Draw (X+11,Y+8);\r
+ Call Move (X+4,Y+5); Call Draw (X+4,Y+10);\r
+ Call Draw (X+8,Y+14);\r
+ Call Move (X+13,Y+12); Call Draw (X+13,Y+5);\r
+ Call Draw (X+9,Y+9); Call Draw (X+9,Y+11);\r
+ Call Point (X+8,Y+10);\r
+ Call Move (X+9,Y+3); Call Draw (X+7,Y+5);\r
+ Call Move (X+11,Y+4); Call Draw (X+7,Y+8);\r
+ End PELOTE;\r
+ \r
+ \r
+ Unit FIN: Procedure (X,Y: Integer);\r
+ Begin\r
+ Call Move (X,Y); Call Draw (X+32,Y);\r
+ Call Draw (X+32,Y+19); Call Draw (X,Y+19);\r
+ Call Draw (X,Y);\r
+ Call Move (X+10,Y+5);\r
+ Call Draw (X+10,Y+4); Call Draw (X+4,Y+4);\r
+ Call Draw (X+4,Y+15); Call Draw (X+6,Y+15);\r
+ Call Draw (X+6,Y+4);\r
+ Call Point (X+7,Y+10); Call Point (X+8,Y+10);\r
+ Call Point (X+8,Y+11);\r
+ Call Move (X+13,Y+4); Call Draw (X+17,Y+4);\r
+ Call Move (X+13,Y+15); Call Draw (X+17,Y+15);\r
+ Call Move (X+14,Y+5); Call Draw (X+14,Y+14);\r
+ Call Move (X+16,Y+5); Call Draw (X+16,Y+14);\r
+ Call Move (X+22,Y+4); Call Draw (X+20,Y+4);\r
+ Call Draw (X+20,Y+15); Call Draw (X+22,Y+15);\r
+ Call Draw (X+22,Y+4); Call Draw (X+29,Y+15);\r
+ Call Draw (X+29,Y+4); Call Draw (X+28,Y+4);\r
+ End FIN;\r
+ \r
+ Unit BLANC: Procedure (X,Y: Integer);\r
+ Var I: Integer;\r
+ Begin\r
+ Call Color (0);\r
+ For I:=1 To 16\r
+ Do\r
+ Call Move (X+1,Y+I);\r
+ Call Draw (X+16,Y+I);\r
+ Od;\r
+ Call Color (15);\r
+ End BLANC;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit GOODGET: Procedure (OutPut PDIR: ArrayOf Integer);\r
+ Var TAB: ArrayOf Integer,\r
+ I,J: Integer;\r
+ Begin\r
+ Array PDIR Dim (1:66);\r
+ Call Move (1,1);\r
+ TAB:= GetMap (16,16);\r
+ PDIR (1):= TAB (1);\r
+ For I:=1 To 4\r
+ Do\r
+ For J:=1 To 8\r
+ Do\r
+ PDIR (1+8*(I-1)+J):= TAB (1+J);\r
+ Od;\r
+ Od;\r
+ Kill (TAB);\r
+ End GOODGET;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit TEMPO: Procedure (T: Integer);\r
+ Var I: Integer;\r
+ Begin\r
+ For I:=1 To T\r
+ Do\r
+ Od;\r
+ End TEMPO;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit XCASE: Function (XC: Integer): Integer;\r
+ Begin\r
+ Result:= BX+32*(XC-1)+16;\r
+ End;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit YCASE: Function (YC: Integer): Integer;\r
+ Begin\r
+ Result:= BY+32*(YC-1)+16;\r
+ End;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit INITLABY: Procedure (OutPut LABY: ArrayOf ArrayOf PIECE);\r
+ Var I,J,LIG,COL: Integer;\r
+ Begin\r
+ LIG:= 10;\r
+ COL:= 15;\r
+ Array LABY Dim (1:LIG);\r
+ For I:=1 To LIG\r
+ Do\r
+ Array LABY (I) Dim (1:COL);\r
+ For J:=1 to COL\r
+ Do\r
+ LABY (I,J):= New PIECE (True,True,True,True,False);\r
+ Od\r
+ Od;\r
+ BX:= (496-(COL*32+16)) DIV 2;\r
+ BY:= (336-(LIG*32+16)) DIV 2;\r
+ End INITLABY;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit BATIR: Procedure (InOut LABY: ArrayOf ArrayOf PIECE;\r
+ OutPut ENTREE,SORTIE: SALLE);\r
+ \r
+ Unit XBOUL: Function (XB: Integer): Integer;\r
+ Begin\r
+ Result:= BX+32*(XB-1);\r
+ End;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit YBOUL: Function (YB: Integer): Integer;\r
+ Begin\r
+ Result:= BY+32*(YB-1);\r
+ End;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit AFFMUR: Procedure (YDEB,XDEB: Integer; COUL,DIR: Boolean);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ If COUL\r
+ Then\r
+ Call Color (15);\r
+ Else\r
+ Call Color (0);\r
+ Fi;\r
+ X:= XBOUL (XDEB);\r
+ Y:= YBOUL (YDEB);\r
+ If DIR= VERTI\r
+ Then\r
+ Call BARSUD (X,Y);\r
+ Call BARVERTI (X,Y+16);\r
+ Call BARNORD (X,Y+32);\r
+ If XDEB>1\r
+ Then\r
+ LABY(YDEB,XDEB-1).E:= Not COUL;\r
+ Fi;\r
+ If XDEB<=Upper (LABY (1))\r
+ Then\r
+ LABY(YDEB,XDEB).O:= Not COUL;\r
+ Fi;\r
+ Else (* DIR=HORIZ *)\r
+ Call BAREST (X,Y);\r
+ Call BARHORIZ (X+16,Y);\r
+ Call BAROUEST (X+32,Y);\r
+ If YDEB>1\r
+ Then\r
+ LABY(YDEB-1,XDEB).S:= Not COUL;\r
+ Fi;\r
+ If YDEB<=Upper (LABY)\r
+ Then\r
+ LABY(YDEB,XDEB).N:= Not COUL;\r
+ Fi;\r
+ Fi;\r
+ Call Color (15);\r
+ End AFFMUR;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit AFFLONGMUR: Procedure (XDEB,YDEB,XFIN,YFIN: Integer,COUL: Boolean);\r
+ Var DEB,FIN,I: Integer;\r
+ Begin\r
+ If XDEB=XFIN And YDEB=/=YFIN\r
+ Then\r
+ DEB:= IMIN (YDEB,YFIN);\r
+ FIN:= IMAX (YDEB,YFIN);\r
+ For I:= DEB To FIN-1\r
+ Do\r
+ Call AFFMUR (I,XDEB,COUL,VERTI);\r
+ Od;\r
+ Else\r
+ If YDEB=YFIN And XDEB=/=XFIN\r
+ Then\r
+ DEB:= IMIN (XDEB,XFIN);\r
+ FIN:= IMAX (XDEB,XFIN);\r
+ For I:= DEB To FIN-1\r
+ Do\r
+ Call AFFMUR (YDEB,I,COUL,HORIZ);\r
+ Od;\r
+ Else\r
+ Write (Chr(7));\r
+ Fi;\r
+ Fi;\r
+ End AFFLONGMUR;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit CREERLABY: Procedure (InOut LABY: ArrayOf ArrayOf PIECE);\r
+ \r
+ Unit BOULPROCH: Procedure (X,Y: Integer;\r
+ OutPut XBL,YBL: Integer; OutPut ERR: Boolean);\r
+ Begin\r
+ ERR:= False;\r
+ XBL:= (X-BX+8) DIV 32+1;\r
+ If XBL>Upper (LABY (1))+1\r
+ Then\r
+ ERR:= True;\r
+ Else\r
+ YBL:= (Y-BY+8) DIV 32+1;\r
+ If YBL>Upper (LABY)+1\r
+ Then\r
+ ERR:= True;\r
+ Fi;\r
+ Fi;\r
+ End BOULPROCH;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit BOULBLNR: Procedure (XBL,YBL: Integer);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ X:= XBOUL (XBL);\r
+ Y:= YBOUL (YBL);\r
+ Call Move (X,Y);\r
+ Call Color (0);\r
+ Call BBLANC (X,Y);\r
+ Call Color (15);\r
+ Call BNOIRE (X,Y);\r
+ End BOULBLNR;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit BOULNRBL: Procedure (XBL,YBL: Integer);\r
+ Var X,Y: Integer;\r
+ Begin\r
+ X:= XBOUL (XBL);\r
+ Y:= YBOUL (YBL);\r
+ Call Move (X,Y);\r
+ Call Color (0);\r
+ Call BNOIRE (X,Y);\r
+ Call Color (15);\r
+ Call BBLANC (X,Y);\r
+ End BOULNRBL;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Var X,Y,XDEB,YDEB,XFIN,YFIN: Integer,\r
+ LEFT,RIGHT,CENTER,ERREUR,BORD: Boolean;\r
+ Begin\r
+ Call ShowCursor;\r
+ Do\r
+ Call Status (X,Y,LEFT,RIGHT,CENTER);\r
+ If (LEFT Or RIGHT) And X>XFINI And X<XFINI+32\r
+ And Y>YFINI And Y<YFINI+18\r
+ Then\r
+ Exit;\r
+ Else\r
+ If LEFT\r
+ Then\r
+ Call BOULPROCH (X,Y,XDEB,YDEB,ERREUR);\r
+ If Not ERREUR\r
+ Then\r
+ Call HideCursor;\r
+ Call BOULBLNR (XDEB,YDEB);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Do\r
+ Call Status (X,Y,LEFT,RIGHT,CENTER);\r
+ If RIGHT\r
+ Then\r
+ Call HideCursor;\r
+ Call BOULNRBL (XDEB,YDEB);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Exit;\r
+ Else\r
+ If LEFT\r
+ Then\r
+ Call BOULPROCH (X,Y,XFIN,YFIN,ERREUR);\r
+ If Not ERREUR\r
+ Then\r
+ Call HideCursor;\r
+ Call BOULNRBL (XDEB,YDEB);\r
+ BORD:= (XDEB=XFIN And (XDEB=1 Or\r
+ XDEB=Upper (LABY(1))+1)) Or\r
+ (YDEB=YFIN And (YDEB=1 Or\r
+ YDEB=Upper (LABY)+1));\r
+ If Not BORD\r
+ Then\r
+ Call AFFLONGMUR (XDEB,YDEB,XFIN,YFIN,BLANC);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Else\r
+ Call ShowCursor;\r
+ Write (Chr (7));\r
+ Fi;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Else\r
+ If RIGHT\r
+ Then\r
+ Call BOULPROCH (X,Y,XDEB,YDEB,ERREUR);\r
+ If Not ERREUR\r
+ Then\r
+ Call HideCursor;\r
+ Call BOULBLNR (XDEB,YDEB);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Do\r
+ Call Status (X,Y,LEFT,RIGHT,CENTER);\r
+ If LEFT\r
+ Then\r
+ Call HideCursor;\r
+ Call BOULNRBL (XDEB,YDEB);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Exit;\r
+ Else\r
+ If RIGHT\r
+ Then\r
+ Call BOULPROCH (X,Y,XFIN,YFIN,ERREUR);\r
+ If Not ERREUR\r
+ Then\r
+ Call HideCursor;\r
+ Call BOULNRBL (XDEB,YDEB);\r
+ BORD:=(XDEB=XFIN And (XDEB=1 Or\r
+ XDEB=Upper(LABY(1))+1)) Or\r
+ (YDEB=YFIN And (YDEB=1 Or\r
+ YDEB=Upper (LABY)+1));\r
+ If Not BORD\r
+ Then\r
+ Call AFFLONGMUR (XDEB,YDEB,XFIN,YFIN,NOIR);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Else\r
+ Call ShowCursor;\r
+ Write (Chr (7));\r
+ Fi;\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Call HideCursor;\r
+ Call TEMPO (200);\r
+ End CREERLABY;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit PLACENTSORT: Procedure (OutPut ENTREE,SORTIE: SALLE);\r
+ \r
+ Unit CASEPROCH: Procedure (X,Y: Integer;\r
+ OutPut XC,YC: Integer; OutPut ERR: Boolean);\r
+ Begin\r
+ ERR:= False;\r
+ XC:= (X-BX-8) DIV 32+1;\r
+ If XC>Upper (LABY (1)) Or XC<1\r
+ Then\r
+ ERR:= True;\r
+ Else\r
+ YC:= (Y-BY-8) DIV 32+1;\r
+ If YC>Upper (LABY) Or YC<1\r
+ Then\r
+ ERR:= True;\r
+ Fi;\r
+ Fi;\r
+ End CASEPROCH;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Var X,Y,XC,YC: Integer,\r
+ LEFT,RIGHT,CENTER,ERREUR,PLACENTREE,PLACSORTIE,OCCUPEE: Boolean;\r
+ Begin\r
+ Call ShowCursor;\r
+ PLACENTREE:= False;\r
+ PLACSORTIE:= False;\r
+ Do\r
+ Call Status (X,Y,LEFT,RIGHT,CENTER);\r
+ If (LEFT Or RIGHT) And PLACENTREE And PLACSORTIE And X>XFINI\r
+ And X<XFINI+32 And Y>YFINI And Y<YFINI+16\r
+ Then\r
+ Exit;\r
+ Else\r
+ If LEFT\r
+ Then\r
+ Call CASEPROCH (X,Y,XC,YC,ERREUR);\r
+ If Not ERREUR\r
+ Then\r
+ If PLACENTREE AndIf ENTREE.L=YC And ENTREE.C=XC\r
+ Then\r
+ PLACENTREE:= False;\r
+ Kill (ENTREE);\r
+ Call HideCursor;\r
+ Call Color (0);\r
+ Call PRINCE (XCASE (XC),YCASE (YC));\r
+ Call Color (15);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Else\r
+ If Not PLACENTREE\r
+ Then\r
+ If Not PLACSORTIE OrIf (PLACSORTIE And\r
+ (SORTIE.L=/=YC Or SORTIE.C=/=XC))\r
+ Then\r
+ ENTREE:= New SALLE (YC,XC,LABY (YC,XC));\r
+ PLACENTREE:= True;\r
+ Call HideCursor;\r
+ Call PRINCE (XCASE (XC),YCASE (YC));\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Else\r
+ Write (Chr (7));\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Else\r
+ If RIGHT\r
+ Then\r
+ Call CASEPROCH (X,Y,XC,YC,ERREUR);\r
+ If Not ERREUR\r
+ Then\r
+ If PLACSORTIE AndIf SORTIE.L=YC And SORTIE.C=XC\r
+ Then\r
+ PLACSORTIE:= False;\r
+ Kill (SORTIE);\r
+ Call HideCursor;\r
+ Call Color (0);\r
+ Call PRINCESSE (XCASE (XC),YCASE (YC));\r
+ Call Color (15);\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Else\r
+ If Not PLACSORTIE\r
+ Then\r
+ If Not PLACENTREE OrIf (PLACENTREE And\r
+ (ENTREE.L=/=YC Or ENTREE.C=/=XC))\r
+ Then\r
+ SORTIE:= New SALLE (YC,XC,LABY (YC,XC));\r
+ PLACSORTIE:= True;\r
+ Call HideCursor;\r
+ Call PRINCESSE (XCASE (XC),YCASE (YC));\r
+ Call ShowCursor;\r
+ Call TEMPO (200);\r
+ Else\r
+ Write (Chr (7));\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ Call HideCursor;\r
+ Call TEMPO (200);\r
+ End PLACENTSORT;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Const VERTI= True,\r
+ HORIZ= False,\r
+ BLANC= True,\r
+ NOIR = False,\r
+ XFINI= 552,\r
+ YFINI= 310;\r
+ Var LIG,COL: Integer;\r
+ Begin\r
+ Call Cls;\r
+ For LIG:=1 To Upper (LABY)+1\r
+ Do\r
+ For COL:=1 To Upper (LABY (1))+1\r
+ Do\r
+ Call BBLANC (BX+32*(COL-1), BY+32*(LIG-1));\r
+ Od;\r
+ Od;\r
+ Call AFFLONGMUR (1,1,Upper (LABY(1))+1,1,BLANC);\r
+ Call AFFLONGMUR (1,Upper (LABY)+1,\r
+ Upper (LABY(1))+1,Upper (LABY)+1,BLANC);\r
+ Call AFFLONGMUR (1,1,1,Upper (LABY)+1,BLANC);\r
+ Call AFFLONGMUR (Upper (LABY(1))+1,1,\r
+ Upper(LABY(1))+1, Upper (LABY)+1,BLANC);\r
+ Call FIN (XFINI,YFINI);\r
+ Call CREERLABY (LABY);\r
+ Call PLACENTSORT (ENTREE,SORTIE);\r
+ Call Color (0);\r
+ Call FIN (XFINI,YFINI);\r
+ Call Color (15);\r
+ End BATIR;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit CHERCHER: LIFO Procedure (LABY: ArrayOf ArrayOf PIECE,\r
+ ENTREE,SORTIE: SALLE);\r
+ \r
+ Unit DEPNORD: Procedure (E: ELEM; InOut POS: Integer);\r
+ Var I: Integer;\r
+ Begin\r
+ Call Color (COUL);\r
+ If E.S.L+1=/=ENTREE.L Or E.S.C=/=ENTREE.C\r
+ Then\r
+ Case POS\r
+ When 1 : Call Move (XCASE (E.S.C)+12,YCASE (E.S.L)+47);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+32);\r
+ When 2 : Call Move (XCASE (E.S.C),YCASE (E.S.L)+44);\r
+ Call Draw (XCASE (E.S.C)+6,YCASE (E.S.L)+44);\r
+ Call Move (XCASE (E.S.C)+7,YCASE (E.S.L)+43);\r
+ Call Draw (XCASE (E.S.C)+8,YCASE (E.S.L)+43);\r
+ Call Draw (XCASE (E.S.C)+11,YCASE (E.S.L)+40);\r
+ Call Draw (XCASE (E.S.C)+11,YCASE (E.S.L)+39);\r
+ Call Move (XCASE (E.S.C)+12,YCASE (E.S.L)+38);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+32);\r
+ When 4 : Call Move (XCASE (E.S.C)+15,YCASE (E.S.L)+35);\r
+ Call Draw (XCASE (E.S.C)+14,YCASE (E.S.L)+35);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+33);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+32);\r
+ Esac;\r
+ Fi;\r
+ Call Move (XCASE (E.S.C),YCASE (E.S.L)+16);\r
+ Call XorMap (PNORD);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (PNORD);\r
+ Call Move (XCASE (E.S.C)+12,YCASE (E.S.L)+31);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+16);\r
+ Call Move (XCASE (E.S.C),YCASE (E.S.L));\r
+ Call XorMap (PNORD);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (PNORD);\r
+ Call Color (15);\r
+ POS:= 1;\r
+ End DEPNORD;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit DEPEST: Procedure (E: ELEM; InOut POS: Integer);\r
+ Var I: Integer;\r
+ Begin\r
+ Call Color (COUL);\r
+ If E.S.L=/=ENTREE.L Or E.S.C-1=/=ENTREE.C\r
+ Then\r
+ Case POS\r
+ When 2 : Call Move (XCASE (E.S.C)-32,YCASE (E.S.L)+12);\r
+ Call Draw (XCASE (E.S.C)-17,YCASE (E.S.L)+12);\r
+ When 3 : Call Move (XCASE (E.S.C)-29,YCASE (E.S.L));\r
+ Call Draw (XCASE (E.S.C)-29,YCASE (E.S.L)+6);\r
+ Call Move (XCASE (E.S.C)-28,YCASE (E.S.L)+7);\r
+ Call Draw (XCASE (E.S.C)-28,YCASE (E.S.L)+8);\r
+ Call Draw (XCASE (E.S.C)-27,YCASE (E.S.L)+11);\r
+ Call Draw (XCASE (E.S.C)-26,YCASE (E.S.L)+11);\r
+ Call Move (XCASE (E.S.C)-25,YCASE (E.S.L)+12);\r
+ Call Draw (XCASE (E.S.C)-17,YCASE (E.S.L)+12);\r
+ When 1 : Call Move (XCASE (E.S.C)-20,YCASE (E.S.L)+15);\r
+ Call Draw (XCASE (E.S.C)-20,YCASE (E.S.L)+14);\r
+ Call Draw (XCASE (E.S.C)-18,YCASE (E.S.L)+12);\r
+ Call Draw (XCASE (E.S.C)-17,YCASE (E.S.L)+12);\r
+ Esac;\r
+ Fi;\r
+ Call Move (XCASE (E.S.C)-16,YCASE (E.S.L));\r
+ Call XorMap (PEST);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (PEST);\r
+ Call Move (XCASE (E.S.C)-16,YCASE (E.S.L)+12);\r
+ Call Draw (XCASE (E.S.C)-1,YCASE (E.S.L)+12);\r
+ Call Move (XCASE (E.S.C),YCASE (E.S.L));\r
+ Call XorMap (PEST);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (PEST);\r
+ Call Color (15);\r
+ POS:= 2;\r
+ End DEPEST;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit DEPSUD: Procedure (E: ELEM; InOut POS: Integer);\r
+ Var I: Integer;\r
+ Begin\r
+ Call Color (COUL);\r
+ If E.S.L-1=/=ENTREE.L Or E.S.C=/=ENTREE.C\r
+ Then\r
+ Case POS\r
+ When 3 : Call Move (XCASE (E.S.C)+3,YCASE (E.S.L)-32);\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)-17);\r
+ When 4 : Call Move (XCASE (E.S.C)+15,YCASE (E.S.L)-29);\r
+ Call Draw (XCASE (E.S.C)+9,YCASE (E.S.L)-29);\r
+ Call Move (XCASE (E.S.C)+8,YCASE (E.S.L)-28);\r
+ Call Draw (XCASE (E.S.C)+7,YCASE (E.S.L)-28);\r
+ Call Draw (XCASE (E.S.C)+4,YCASE (E.S.L)-27);\r
+ Call Draw (XCASE (E.S.C)+4,YCASE (E.S.L)-26);\r
+ Call Move (XCASE (E.S.C)+3,YCASE (E.S.L)-25);\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)-17);\r
+ When 2 : Call Move (XCASE (E.S.C),YCASE (E.S.L)-20);\r
+ Call Draw (XCASE (E.S.C)+1,YCASE (E.S.L)-20);\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)-18);\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)-17);\r
+ Esac;\r
+ Fi;\r
+ Call Move (XCASE (E.S.C),YCASE (E.S.L)-16);\r
+ Call XorMap (PSUD);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (PSUD);\r
+ Call Move (XCASE (E.S.C)+3,YCASE (E.S.L)-16);\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)-1);\r
+ Call Move (XCASE (E.S.C),YCASE (E.S.L));\r
+ Call XorMap (PSUD);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (PSUD);\r
+ Call Color (15);\r
+ POS:= 3;\r
+ End DEPSUD;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit DEPOUEST: Procedure (E: ELEM; InOut POS: Integer);\r
+ Var I: Integer;\r
+ Begin\r
+ Call Color (COUL);\r
+ If E.S.L=/=ENTREE.L Or E.S.C+1=/=ENTREE.C\r
+ Then\r
+ Case POS\r
+ When 4 : Call Move (XCASE (E.S.C)+47,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+32,YCASE (E.S.L)+3);\r
+ When 1 : Call Move (XCASE (E.S.C)+44,YCASE (E.S.L)+15);\r
+ Call Draw (XCASE (E.S.C)+44,YCASE (E.S.L)+9);\r
+ Call Move (XCASE (E.S.C)+43,YCASE (E.S.L)+8);\r
+ Call Draw (XCASE (E.S.C)+43,YCASE (E.S.L)+7);\r
+ Call Draw (XCASE (E.S.C)+40,YCASE (E.S.L)+4);\r
+ Call Draw (XCASE (E.S.C)+39,YCASE (E.S.L)+4);\r
+ Call Move (XCASE (E.S.C)+38,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+32,YCASE (E.S.L)+3);\r
+ When 3 : Call Move (XCASE (E.S.C)+35,YCASE (E.S.L));\r
+ Call Draw (XCASE (E.S.C)+35,YCASE (E.S.L)+1);\r
+ Call Draw (XCASE (E.S.C)+33,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+32,YCASE (E.S.L)+3);\r
+ Esac;\r
+ Fi;\r
+ Call Move (XCASE (E.S.C)+16,YCASE (E.S.L));\r
+ Call XorMap (POUEST);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (POUEST);\r
+ Call Move (XCASE (E.S.C)+31,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+16,YCASE (E.S.L)+3);\r
+ Call Move (XCASE (E.S.C),YCASE (E.S.L));\r
+ Call XorMap (POUEST);\r
+ Call TEMPO (TEMPS);\r
+ Call XorMap (POUEST);\r
+ Call Color (15);\r
+ POS:= 4;\r
+ End DEPOUEST;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit DEMITOUR: Procedure (E: ELEM; InOut POS: Integer, DMTR: Boolean);\r
+ Begin\r
+ If DMTR\r
+ Then\r
+ Call Color (COUL);\r
+ Case POS\r
+ When 1 : Call Move (XCASE (E.S.C)+3,YCASE (E.S.L));\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)+5);\r
+ Call Draw (XCASE (E.S.C)+5,YCASE (E.S.L)+7);\r
+ Call Draw (XCASE (E.S.C)+10,YCASE (E.S.L)+7);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+5);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L));\r
+ When 2 : Call Move (XCASE (E.S.C)+15,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+10,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+8,YCASE (E.S.L)+5);\r
+ Call Draw (XCASE (E.S.C)+8,YCASE (E.S.L)+10);\r
+ Call Draw (XCASE (E.S.C)+10,YCASE (E.S.L)+12);\r
+ Call Draw (XCASE (E.S.C)+15,YCASE (E.S.L)+12);\r
+ When 3 : Call Move (XCASE (E.S.C)+3,YCASE (E.S.L)+15);\r
+ Call Draw (XCASE (E.S.C)+3,YCASE (E.S.L)+10);\r
+ Call Draw (XCASE (E.S.C)+5,YCASE (E.S.L)+8);\r
+ Call Draw (XCASE (E.S.C)+10,YCASE (E.S.L)+8);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+10);\r
+ Call Draw (XCASE (E.S.C)+12,YCASE (E.S.L)+15);\r
+ When 4 : Call Move (XCASE (E.S.C),YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+5,YCASE (E.S.L)+3);\r
+ Call Draw (XCASE (E.S.C)+7,YCASE (E.S.L)+5);\r
+ Call Draw (XCASE (E.S.C)+7,YCASE (E.S.L)+10);\r
+ Call Draw (XCASE (E.S.C)+5,YCASE (E.S.L)+12);\r
+ Call Draw (XCASE (E.S.C),YCASE (E.S.L)+12);\r
+ Esac;\r
+ Call Color (15);\r
+ POS:= 0;\r
+ DMTR:= False;\r
+ Fi;\r
+ If E.S.L=E.ANTE.S.L\r
+ Then\r
+ If E.S.C>E.ANTE.S.C\r
+ Then\r
+ Call DEPOUEST (E.ANTE,POS);\r
+ Else\r
+ Call DEPEST (E.ANTE,POS);\r
+ Fi;\r
+ Else\r
+ If E.S.L>E.ANTE.S.L\r
+ Then\r
+ Call DEPSUD (E.ANTE,POS);\r
+ Else\r
+ Call DEPNORD (E.ANTE,POS);\r
+ Fi;\r
+ Fi;\r
+ End DEMITOUR;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Const TEMPS= 150,\r
+ COUL= 7;\r
+ Var I,POS: Integer,\r
+ TROUVE,FIN,DMTR: Boolean,\r
+ AUX,ENT: SALLE,\r
+ E: ELEM,\r
+ P: PILE,\r
+ TAB: ArrayOf Integer;\r
+ Begin\r
+ DMTR:= True;\r
+ P:= New PILE;\r
+ ENTREE.PC.MARQUE:= True;\r
+ E:= New ELEM (ENTREE);\r
+ Call EMPIL (E,P);\r
+ Call BLANC (XCASE (ENTREE.C),YCASE (ENTREE.L));\r
+ Call PELOTE (XCASE (ENTREE.C),YCASE (ENTREE.L));\r
+ ENT:= Copy (ENTREE);\r
+ TROUVE:= False;\r
+ While Not TROUVE\r
+ Do\r
+ FIN:= False;\r
+ While Not FIN\r
+ Do\r
+ AUX:= E.S;\r
+ If E.S.PC.N AndIf Not LABY (E.S.L-1,E.S.C).MARQUE\r
+ Then\r
+ E:= New ELEM (New SALLE (AUX.L-1,AUX.C,LABY (AUX.L-1,AUX.C)));\r
+ E.S.PC.MARQUE:= True;\r
+ Call EMPIL (E,P);\r
+ Call DEPNORD (E,POS);\r
+ Else\r
+ If AUX.PC.E AndIf Not LABY (AUX.L,AUX.C+1).MARQUE\r
+ Then\r
+ E:= New ELEM (New SALLE (AUX.L,AUX.C+1,LABY (AUX.L,AUX.C+1)));\r
+ E.S.PC.MARQUE:= True;\r
+ Call EMPIL (E,P);\r
+ Call DEPEST (E,POS);\r
+ Else\r
+ If AUX.PC.S AndIf Not LABY (AUX.L+1,AUX.C).MARQUE\r
+ Then\r
+ E:= New ELEM (New SALLE (AUX.L+1,AUX.C,LABY (AUX.L+1,AUX.C)));\r
+ E.S.PC.MARQUE:= True;\r
+ Call EMPIL (E,P);\r
+ Call DEPSUD (E,POS);\r
+ Else\r
+ If AUX.PC.O AndIf Not LABY (AUX.L,AUX.C-1).MARQUE\r
+ Then\r
+ E:= New ELEM (New SALLE (AUX.L,AUX.C-1,\r
+ LABY (AUX.L,AUX.C-1)));\r
+ E.S.PC.MARQUE:= True;\r
+ Call EMPIL (E,P);\r
+ Call DEPOUEST (E,POS);\r
+ Else\r
+ FIN:= True;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ If Not FIN\r
+ Then\r
+ DMTR:= True;\r
+ If E.S.L=SORTIE.L And E.S.C=SORTIE.C\r
+ Then\r
+ TROUVE:= True;\r
+ FIN:= True;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ If Not TROUVE\r
+ Then\r
+ Call DEMITOUR (E,POS,DMTR);\r
+ Call DEPIL (P);\r
+ If Not VIDE (P)\r
+ Then\r
+ E:= P.PREM;\r
+ Else\r
+ Exit;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ If TROUVE\r
+ Then\r
+ Call BLANC (XCASE (SORTIE.C),YCASE (SORTIE.L));\r
+ Call COEUR (XCASE (SORTIE.C),YCASE (SORTIE.L));\r
+ Write (Chr(7));\r
+ Write (Chr(7));\r
+ Else\r
+ Call BLANC (XCASE (ENT.C),YCASE (ENT.L));\r
+ Call TOMBE (XCASE (ENT.C),YCASE (ENT.L));\r
+ Call BLANC (XCASE (SORTIE.C),YCASE (SORTIE.L));\r
+ Call TOMBE (XCASE (SORTIE.C),YCASE (SORTIE.L));\r
+ Write (Chr(7));\r
+ Fi;\r
+ End CHERCHER;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Unit TOUCHE: Procedure;\r
+ Var I: Integer;\r
+ Begin\r
+ I:= 0;\r
+ While I<>32\r
+ Do\r
+ I:= Inkey;\r
+ Od;\r
+ End TOUCHE;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Var BX,BY,NBOUT: Integer,\r
+ SOURIS: Boolean,\r
+ PNORD,PEST,PSUD,POUEST: ArrayOf Integer;\r
+ Begin\r
+ Call Gron (1);\r
+ Call PRINCNORD (PNORD);\r
+ Call PRINCEST (PEST);\r
+ Call PRINCSUD (PSUD);\r
+ Call PRINCOUEST (POUEST);\r
+ SOURIS:= Init (NBOUT);\r
+ If SOURIS\r
+ Then\r
+ Inner;\r
+ Fi;\r
+ Call TOUCHE;\r
+ Call Groff;\r
+ End LABYGRAPH;\r
+ \r
+(* ------------------------------------------------------------------------- *)\r
+(* ------------------------------------------------------------------------- *)\r
+ \r
+ Begin\r
+ \r
+ Pref LABYGRAPH Block\r
+ Var LABY: ArrayOf ArrayOf PIECE,\r
+ ENTREE,SORTIE: SALLE;\r
+ Begin\r
+ (*Do*)\r
+ Call INITLABY (LABY);\r
+ Call BATIR (LABY,ENTREE,SORTIE);\r
+ Call CHERCHER (LABY,ENTREE,SORTIE);\r
+ (*Od;*)\r
+ End;\r
+ End;\r
+End LABYRINTHE\r
--- /dev/null
+PROGRAM Labyrinthe;\r
+ \r
+BEGIN\r
+ \r
+pref iiuwgraph block ;\r
+ \r
+var entree : couple,\r
+ TailleMax : couple,\r
+ F : file,\r
+ SortieProg : Boolean,\r
+ Choix : Char,\r
+ Mat : Matrice ;\r
+ \r
+UNIT couple : CLASS;\r
+ Var absi, ordo :integer;\r
+END couple;\r
+ \r
+UNIT Link : CLASS (Val: couple);\r
+ Var Next : Link;\r
+END Link;\r
+ \r
+ \r
+UNIT pile : CLASS;\r
+ var top : Link;\r
+End Pile;\r
+ \r
+UNIT empty : FUNCTION (p: pile): boolean;\r
+ Begin\r
+ If p=none\r
+ Then\r
+ result:= True ;\r
+ Else\r
+ Result:= (p.top = none);\r
+ Fi;\r
+ END empty;\r
+ \r
+UNIT push : FUNCTION ( Curseur :couple ; p: pile) : Pile;\r
+Var Aux : link;\r
+ Begin\r
+ aux := New Link( Curseur);\r
+ If(not empty(p)) then\r
+ Aux.next:= p.top;\r
+ Fi;\r
+ Result := New Pile;\r
+ Result.top := Aux;\r
+ END push;\r
+ \r
+UNIT tete : FUNCTION ( P : pile ): couple;\r
+ Begin\r
+ Result := new couple;\r
+ If(not empty(p)) then\r
+ Result := P.top.Val;\r
+ Fi;\r
+ END tete;\r
+ \r
+UNIT pop : FUNCTION (p : pile): pile;\r
+var lk : link;\r
+ Begin\r
+ If(not empty(p))\r
+ Then\r
+ lk := New Link(p.top.val);\r
+ result:= new pile;\r
+ result.top:= p.top.next;\r
+ lk:= p.top;\r
+ kill(lk);\r
+ Fi;\r
+ END pop;\r
+ \r
+ \r
+ \r
+UNIT matrice : CLASS ;\r
+ var A: arrayof arrayof integer;\r
+ var i: integer;\r
+ \r
+ \r
+ UNIT sortie : FUNCTION ( Curseur : couple ) : boolean;\r
+ BEGIN\r
+ If NOT((entree.absi = Curseur.absi) AND\r
+ (entree.ordo = Curseur.ordo)) ANDIF\r
+ ( (Curseur.absi = 1) OR (Curseur.absi = TailleMax.absi) OR\r
+ (Curseur.ordo = 1) OR (Curseur.ordo = TailleMax.ordo) )\r
+ Then\r
+ result:=true;\r
+ Else\r
+ result:=false;\r
+ Fi;\r
+ END sortie;\r
+ \r
+ UNIT droite : FUNCTION ( Curseur : couple ) : boolean;\r
+ BEGIN\r
+ If ( Curseur.Absi <> TailleMax.Absi) ANDIF\r
+ ( A(Curseur.absi + 1, Curseur.ordo) = 1 )\r
+ Then\r
+ result:=true\r
+ Else\r
+ result:=false;\r
+ Fi\r
+ END droite;\r
+ \r
+ UNIT gauche : FUNCTION ( Curseur : couple ) : boolean;\r
+ BEGIN\r
+ If ( Curseur.Absi <> 1 ) ANDIF\r
+ ( A(Curseur.absi-1 , Curseur.ordo) = 1)\r
+ Then\r
+ result:= true\r
+ Else\r
+ result:=false;\r
+ Fi\r
+ END gauche;\r
+ \r
+ UNIT devant : FUNCTION ( Curseur : couple ) : boolean;\r
+ BEGIN\r
+ If ( Curseur.Ordo <> TailleMax.Ordo) ANDIF\r
+ ( A(Curseur.absi , Curseur.ordo+1) = 1 )\r
+ Then\r
+ result:=true\r
+ Else\r
+ result:=false;\r
+ Fi\r
+ END devant;\r
+ \r
+ UNIT derriere : FUNCTION ( Curseur : couple ) : boolean;\r
+ BEGIN\r
+ If ( Curseur.Ordo <> 1 ) ANDIF\r
+ ( A(Curseur.absi , Curseur.ordo-1) = 1 )\r
+ Then\r
+ result:= true;\r
+ Else\r
+ result := false;\r
+ Fi\r
+ END derriere;\r
+ \r
+ END Matrice;\r
+ \r
+ \r
+ UNIT CreatMat : PROCEDURE (mat : matrice);\r
+ var i:integer;\r
+ BEGIN\r
+ Array Mat.A Dim (1 : TailleMax.Absi);\r
+ For i:= 1 To TailleMax.Absi Do\r
+ Array Mat.A(i) dim (1 : TailleMax.Ordo);\r
+ Od;\r
+ END CreatMat;\r
+ \r
+ UNIT InitMat : PROCEDURE (mat : matrice);\r
+ var i, j :integer;\r
+ BEGIN\r
+ (* Initialisation de la matrice; toutes les cases sont des murs *)\r
+ For i:= 1 To TailleMax.Ordo Do\r
+ For j:= 1 To TailleMax.Absi Do\r
+ Mat.A(j,i) := 0;\r
+ Od;\r
+ Od;\r
+END InitMat;\r
+ \r
+ \r
+ \r
+ \r
+(* Procedures n\82cessaires \85 l'affichage de la matrice *)\r
+ \r
+ UNIT Bold : PROCEDURE;\r
+ Begin\r
+ write( chr(27), "[1m")\r
+ End Bold;\r
+ \r
+ UNIT Reverse : PROCEDURE;\r
+ Begin\r
+ write( chr(27), "[7m")\r
+ End Reverse;\r
+ \r
+ UNIT Normal : PROCEDURE;\r
+ Begin\r
+ write( chr(27), "[0m")\r
+ End Normal;\r
+ \r
+ UNIT Underscore : PROCEDURE;\r
+ Begin\r
+ write( chr(27), "[4m")\r
+ End Underscore;\r
+ \r
+ UNIT EraseLine : PROCEDURE;\r
+ Begin\r
+ write( chr(27), "[K")\r
+ End EraseLine;\r
+ \r
+ UNIT inchar : IIUWgraph FUNCTION : integer;\r
+ var i : integer;\r
+ Begin\r
+ Do\r
+ i := inkey;\r
+ If i <> 0 Then exit Fi;\r
+ Od;\r
+ result := i;\r
+ End inchar;\r
+ \r
+ UNIT NewPage : PROCEDURE;\r
+ Begin\r
+ write( chr(27), "[2J")\r
+ End NewPage;\r
+ \r
+ UNIT SetCursor : PROCEDURE (row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ Begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ End SetCursor;\r
+ \r
+ \r
+(* Procedure d'affichage du labyrinthe *)\r
+ \r
+UNIT AffichageLaby : PROCEDURE ( Mat : matrice);\r
+ \r
+var i,j:integer;\r
+ \r
+BEGIN\r
+ call NewPage;\r
+ writeln;\r
+ For i:= 1 To TailleMax.Ordo Do\r
+ Call Normal;\r
+ write (" ");\r
+ For j := 1 To TailleMax.Absi Do\r
+ call Reverse;\r
+ call Bold;\r
+ If Mat.A (j,i) = 0\r
+ Then (* On a un mur *)\r
+ write (" ",chr(88));\r
+ Else\r
+ write (" ");\r
+ Fi;\r
+ Od;\r
+ writeln (" ");\r
+ Od;\r
+ Call Normal;\r
+ \r
+END AffichageLaby;\r
+ \r
+ \r
+UNIT RechChemin : PROCEDURE ( Mat : matrice );\r
+ \r
+Var SolExiste : boolean,\r
+ Curseur,Elem : couple,\r
+ Retour : boolean,\r
+ i : integer,\r
+ P : Pile ;\r
+ \r
+ UNIT AfficheChemin : PROCEDURE ( Curseur : couple , Retour : boolean );\r
+ Var i : integer;\r
+ Begin\r
+ i := 0;\r
+ While i < 10\r
+ Do\r
+ Call SetCursor ( Curseur.ordo + 1 , (Curseur.absi*2) + 1 );\r
+ Call Reverse;\r
+ Call Underscore;\r
+ If Retour\r
+ Then\r
+ write ( "." );\r
+ Else\r
+ write ( chr(254) );\r
+ Fi;\r
+ Call SetCursor ( Curseur.ordo + 1, (Curseur.absi*2) + 1 );\r
+ Call Normal ;\r
+ i := i+1;\r
+ Od;\r
+ End AfficheChemin;\r
+ \r
+BEGIN\r
+ \r
+ Call SetCursor (22,10);\r
+ Call EraseLine;\r
+ Call SetCursor (23,15);\r
+ Call EraseLine;\r
+ Call SetCursor (24,15);\r
+ Call EraseLine;\r
+ \r
+ Curseur := New Couple ;\r
+ Curseur.Absi := Entree.absi;\r
+ Curseur.Ordo := Entree.Ordo;\r
+ Mat.A ( Curseur.absi, Curseur.Ordo ) := 2;\r
+ Retour := False;\r
+ Call AfficheChemin ( Curseur , Retour );\r
+ \r
+ SolExiste := true;\r
+ P := new Pile;\r
+ \r
+ While (Not Mat.Sortie(curseur)) AND ( SolExiste )\r
+ Do\r
+ If Mat.Gauche(curseur)\r
+ Then\r
+ Retour := False;\r
+ Call AfficheChemin ( Curseur, Retour );\r
+ Elem := New Couple ;\r
+ Elem.Absi := Curseur.Absi;\r
+ Elem.Ordo := Curseur.Ordo;\r
+ P := Push ( Elem , P );\r
+ Curseur.absi := Curseur.absi - 1;\r
+ Mat.A ( Curseur.Absi, Curseur.Ordo) := 2;\r
+ Call AfficheChemin ( Curseur, Retour );\r
+ Else\r
+ If Mat.devant(curseur)\r
+ Then\r
+ Retour := False;\r
+ Call AfficheChemin ( Curseur, Retour );\r
+ Elem := New Couple;\r
+ Elem.Absi := Curseur.Absi;\r
+ Elem.Ordo := Curseur.ordo;\r
+ P := Push ( Elem , P );\r
+ Curseur.ordo := Curseur.ordo + 1;\r
+ Mat.A(Curseur.Absi, Curseur.Ordo) := 2;\r
+ Call AfficheChemin ( Curseur, Retour );\r
+ Else\r
+ If Mat.droite(curseur)\r
+ Then\r
+ Retour := False;\r
+ Call AfficheChemin (Curseur, Retour );\r
+ Elem := New Couple;\r
+ Elem.absi := Curseur.absi;\r
+ Elem.ordo := Curseur.ordo;\r
+ P := push ( Elem ,P );\r
+ Curseur.absi := curseur.absi + 1;\r
+ Mat.A(Curseur.Absi, Curseur.Ordo) := 2;\r
+ Call AfficheChemin ( Curseur, Retour );\r
+ Else\r
+ If Mat.Derriere(curseur)\r
+ Then\r
+ Retour := False;\r
+ Call AfficheChemin(Curseur,Retour);\r
+ Elem := New Couple;\r
+ Elem.Absi := Curseur.absi;\r
+ Elem.Ordo := Curseur.ordo;\r
+ P := push ( Elem , P);\r
+ Curseur.ordo := Curseur.ordo - 1;\r
+ Mat.A(Curseur.absi, Curseur.Ordo) := 2;\r
+ Call AfficheChemin ( Curseur,Retour );\r
+ Else\r
+ If not empty (P)\r
+ Then\r
+ (* On revient sur un endroit defja visit\82 *)\r
+ Retour := True;\r
+ Call AfficheChemin ( Curseur, Retour );\r
+ Elem := New Couple;\r
+ Elem := Tete(P);\r
+ Curseur.Ordo:= Elem.Ordo;\r
+ Curseur.Absi := Elem.Absi;\r
+ kill(Elem);\r
+ P := pop(P);\r
+ Call AfficheChemin ( Curseur , Retour);\r
+ Else\r
+ SolExiste := false;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Fi;\r
+ Od;\r
+ call Bold;\r
+ If SolExiste then\r
+ If Curseur.Ordo = 1 then\r
+ call SetCursor(1, (Curseur.Absi*2)+1);\r
+ write("S");\r
+ Fi;\r
+ If Curseur.Ordo = TailleMax.Ordo then\r
+ call SetCursor(TailleMax.Ordo+2, (Curseur.Absi*2)+1);\r
+ write("S");\r
+ Fi;\r
+ If Curseur.Absi = 1 then\r
+ call SetCursor (Curseur.Ordo+1, 1);\r
+ write("S");\r
+ Fi;\r
+ If Curseur.Absi = TailleMax.Absi then\r
+ call SetCursor ( Curseur.ordo+1, (TailleMax.Absi*2)+3);\r
+ write("S");\r
+ Fi;\r
+ else\r
+ call SetCursor(22,15);\r
+ write(" Le labyrinthe n'a pas de sortie ... ");\r
+ fi;\r
+ call Normal;\r
+ call SetCursor(23,15);\r
+ write(" Pour revenir au Menu :");\r
+ call Bold;\r
+ write(" Tapez ",chr(17), chr(217));\r
+ call Normal;\r
+ i := inchar;\r
+ kill(curseur);\r
+ kill(p);\r
+END RechChemin;\r
+ \r
+UNIT ChargeLaby : PROCEDURE (output Mat : Matrice);\r
+var i, j : integer;\r
+ \r
+Begin\r
+ Mat := New Matrice;\r
+ open(F,integer,unpack("donnees.lab"));\r
+ call reset(F);\r
+ get(F, Entree.Absi, Entree.Ordo, TailleMax.Absi, TailleMax.Ordo);\r
+ call CreatMat(Mat);\r
+ for i:= 1 to TailleMax.Ordo do\r
+ for j:= 1 to TailleMax.Absi do\r
+ get(F,Mat.A(j,i));\r
+ od;\r
+ od;\r
+ kill(f);\r
+ call AffichageLaby(Mat);\r
+End ChargeLaby;\r
+ \r
+ \r
+UNIT SauveLaby : PROCEDURE ( Entree : couple,\r
+ TailleMax : couple,\r
+ mat : matrice;\r
+ output F : file);\r
+var i, j : integer;\r
+ \r
+BEGIN\r
+ open(F,integer,unpack("donnees.lab"));\r
+ call rewrite(f);\r
+ put(f, Entree.Absi, Entree.Ordo, TailleMax.Absi, TailleMax.Ordo);\r
+ for i:= 1 to TailleMax.Ordo do\r
+ for j:= 1 to TailleMax.Absi do\r
+ put(f,Mat.A(j,i));\r
+ od;\r
+ od;\r
+ kill(f);\r
+END SauveLaby;\r
+ \r
+ \r
+ \r
+ \r
+UNIT CreationLaby : PROCEDURE ( inout mat : matrice);\r
+ \r
+ UNIT CreationChemin : PROCEDURE (inout Mat : Matrice);\r
+ var Curseur : couple,\r
+ I : integer,\r
+ Erreur : Boolean;\r
+ \r
+ BEGIN\r
+ \r
+ BLOCK; (* Affichage des moyens de deplacement du curseur *)\r
+ \r
+ Begin\r
+ \r
+ Call Bold;\r
+ Call SetCursor(2, 77);\r
+ write("8");\r
+ Call Normal;\r
+ Call SetCursor(3, 77);\r
+ write(chr(30));\r
+ Call Bold;\r
+ Call SetCursor(4, 74);\r
+ write("4");\r
+ Call Normal;\r
+ write(chr(17),"-|-",chr(16));\r
+ Call Bold;\r
+ write("6");\r
+ Call Normal;\r
+ Call SetCursor(5, 77);\r
+ write(chr(31));\r
+ Call Bold;\r
+ Call SetCursor(6, 77);\r
+ write("2");\r
+ \r
+ Call Normal;\r
+ Call SetCursor(22, 10);\r
+ write("Deplacez vous \85 l'aide des fl\82ches ");\r
+ Call SetCursor(23,15);\r
+ write("Selectionnez l'");\r
+ Call Bold;\r
+ write("Entr\82e");\r
+ Call Normal;\r
+ write(" du labyrinthe ");\r
+ Call SetCursor(24, 15);\r
+ write("Validez avec la touche ");\r
+ Call Bold;\r
+ write(chr(17),chr(217));\r
+ \r
+ End; (* block Affichage des moyens de deplacement du curseur *)\r
+ \r
+ \r
+ BLOCK (* Validation de l'entree du Ladyrinthe *)\r
+ \r
+ Begin\r
+ Entree.Ordo:= 0;\r
+ Entree.absi:= 0;\r
+ \r
+ While NOT ( (Entree.Ordo = 1) Or (Entree.Ordo = TailleMax.Ordo) Or\r
+ (Entree.Absi = 1) Or (Entree.Absi = TailleMax.Absi) )\r
+ Do\r
+ (* Verification de la conformit\82 de l'entr\82e *)\r
+ \r
+ If Entree.Ordo <> 0\r
+ Then\r
+ Call Normal;\r
+ Call Reverse;\r
+ Call Bold;\r
+ Call SetCursor ( Entree.ordo + 1 , (Entree.Absi*2) + 1 );\r
+ write(chr(88));\r
+ Call Normal;\r
+ Call Bold;\r
+ Call SetCursor ( 25, 10 ) ;\r
+ write ("L'entr\82e S\82lectionn\82e n'est pas conforme ... Recommencez");\r
+ Fi;\r
+ \r
+ Entree.Ordo := 1;\r
+ Entree.Absi := 1;\r
+ Call SetCursor ( 2, 3 );\r
+ write(chr(219));\r
+ Call SetCursor (2, 3);\r
+ \r
+ I := Inchar ;\r
+ Call SetCursor( 25, 10 );\r
+ Call EraseLine;\r
+ \r
+ Call SetCursor (2 , 3);\r
+ \r
+ While (I <> 13) (* RC *)\r
+ Do\r
+ (* Avant de d\82placer le curseur on reinscrit un mur\r
+ dans la case non validee *)\r
+ Call Reverse;\r
+ write(chr(88)); (* X *)\r
+ Call SetCursor(Entree.ordo + 1 , ( Entree.Absi*2) + 1);\r
+ Call Normal;\r
+ Call Bold;\r
+ \r
+ Case I\r
+ (* Placement de l'entree suivant les touches frappees *)\r
+ When 50 : If Entree.Ordo < TailleMax.Ordo\r
+ Then\r
+ (* Bas *)\r
+ Entree.Ordo := Entree.Ordo + 1;\r
+ Fi;\r
+ When 52 : If Entree.Absi > 1\r
+ Then\r
+ (* Gauche *)\r
+ Entree.Absi := Entree.Absi - 1;\r
+ Fi;\r
+ When 54 : If Entree.Absi < TailleMax.Absi\r
+ Then\r
+ (* Droite *)\r
+ Entree.Absi := Entree.Absi + 1;\r
+ Fi;\r
+ When 56 : If Entree.Ordo > 1\r
+ Then\r
+ (* Derriere *)\r
+ Entree.Ordo := Entree.Ordo - 1;\r
+ Fi;\r
+ Otherwise erreur:=True;\r
+ Esac;\r
+ \r
+ (* On Place le curseur Sur les nouvelles coordonnees de l'entree *)\r
+ Call SetCursor(Entree.ordo + 1 , ( Entree.Absi*2) + 1 );\r
+ write(chr(219));\r
+ Call SetCursor(Entree.ordo + 1 , ( Entree.Absi*2) + 1 );\r
+ \r
+ I:= inchar;\r
+ Od;\r
+ Od;\r
+ \r
+ (* Affichage D'un signe au point d'entree *)\r
+ \r
+ If Entree.Ordo = 1\r
+ Then\r
+ Call SetCursor ( 1, (Entree.Absi*2) + 1 );\r
+ Write("E");\r
+ Call SetCursor ( 1, (Entree.Absi*2) + 1 );\r
+ Fi;\r
+ \r
+ If Entree.Ordo = TailleMax.Ordo\r
+ Then\r
+ Call SetCursor ( Entree.Ordo + 2 , ( Entree.Absi*2 ) + 1 );\r
+ Write("E");\r
+ Call SetCursor ( Entree.Ordo + 2 , ( Entree.Absi*2 ) + 1 );\r
+ Fi;\r
+ \r
+ If Entree.Absi = 1\r
+ Then\r
+ Call SetCursor ( Entree.Ordo + 1, 1);\r
+ Write ("E");\r
+ Call SetCursor ( Entree.Ordo + 1, 1);\r
+ Fi;\r
+ \r
+ If Entree.Absi = TailleMax.Absi\r
+ Then\r
+ Call SetCursor ( Entree.Ordo + 1, (Entree.Absi* 2 ) + 3);\r
+ Write ("E");\r
+ Call SetCursor (Entree.Ordo + 1 , (Entree.Absi* 2) + 3);\r
+ Fi;\r
+ \r
+ End; (* Block Validation de l'entree *)\r
+ \r
+ \r
+ BLOCK (* Affichage des options *)\r
+ Begin\r
+ \r
+ Call SetCursor(10,74);\r
+ write("Espace");\r
+ Call normal;\r
+ Call SetCursor(11, 73);\r
+ write("Restaure");\r
+ Call SetCursor(12, 75);\r
+ write("Mur");\r
+ \r
+ Call SetCursor(23, 15);\r
+ Call EraseLine;\r
+ write("Choisissez les ");\r
+ Call Bold;\r
+ write("Chemins");\r
+ Call Normal;\r
+ write(" du labyrinthe ");\r
+ Call Bold;\r
+ Call SetCursor(Entree.Ordo + 1 , (Entree.Absi*2) + 1 );\r
+ \r
+ End; (* Block Affichage des options *)\r
+ \r
+ \r
+ BLOCK (* Validation du ou des Chemins du Labyrinthe *)\r
+ \r
+ Begin\r
+ (* Positionnement sur le point d'entree *)\r
+ Curseur := New Couple;\r
+ Curseur.Absi := Entree.absi;\r
+ Curseur.Ordo := Entree.ordo;\r
+ Mat.A(Entree.Absi, Entree.Ordo):= 1;\r
+ \r
+ I:= Inchar;\r
+ \r
+ While (I <> 13)\r
+ Do\r
+ (* Creation des chemins *)\r
+ \r
+ (* Affichage de la valeur de la case avant d\82placement du curseur *)\r
+ Call Reverse;\r
+ Call SetCursor(Curseur.Ordo+1, (Curseur.Absi*2) + 1);\r
+ If Mat.A ( Curseur.Absi, Curseur.Ordo ) = 0\r
+ Then\r
+ write ( chr(88) );\r
+ Else\r
+ write(" ");\r
+ Fi;\r
+ Call SetCursor(Curseur.Ordo + 1 , (Curseur.Absi*2) + 1) ;\r
+ Call Normal;\r
+ Call Bold;\r
+ \r
+ Erreur := False;\r
+ \r
+ Case I\r
+ (* Interpretation de la touche frapp\82e *)\r
+ When 50 : If Curseur.Ordo < TailleMax.Ordo\r
+ Then\r
+ (* Bas *)\r
+ Curseur.Ordo := Curseur.Ordo + 1;\r
+ Else\r
+ Erreur := True;\r
+ Fi;\r
+ When 52 : If Curseur.Absi > 1\r
+ Then\r
+ (* Gauche *)\r
+ Curseur.Absi := Curseur.Absi - 1;\r
+ Else\r
+ Erreur := True;\r
+ Fi;\r
+ When 54 : If Curseur.Absi < TailleMax.Absi\r
+ Then\r
+ (* Droite *)\r
+ Curseur.Absi := Curseur.Absi + 1;\r
+ Else\r
+ Erreur := True;\r
+ Fi;\r
+ When 56 : If Curseur.Ordo > 1\r
+ Then\r
+ (* Derriere *)\r
+ Curseur.Ordo:= Curseur.Ordo-1;\r
+ Else\r
+ Erreur := True;\r
+ Fi;\r
+ When 32 : If (Curseur.Ordo = Entree.Ordo) And\r
+ (Curseur.Absi = Entree.Absi)\r
+ Then\r
+ (* On ne peut pas murer l'entree *)\r
+ Erreur := True;\r
+ Fi;\r
+ Otherwise\r
+ Erreur := True;\r
+ \r
+ Esac;\r
+ \r
+ If not Erreur\r
+ Then\r
+ If ( I = 32 ) (*Si on veut murer *)\r
+ Then\r
+ Mat.A(Curseur.Absi,Curseur.Ordo) := 0 ;\r
+ Else\r
+ Mat.A(Curseur.Absi, Curseur.Ordo) := 1;\r
+ Fi;\r
+ Fi;\r
+ \r
+ \r
+ (* Affichage du curseur sur la nouvelle case *)\r
+ \r
+ Call SetCursor (Curseur.Ordo + 1 ,(Curseur.Absi*2) + 1 );\r
+ If Mat.A ( Curseur.Absi, Curseur.Ordo) = 1\r
+ Then\r
+ Write(chr(219));\r
+ Else\r
+ Write (chr(88));\r
+ Fi;\r
+ Call SetCursor(Curseur.Ordo + 1 , (Curseur.Absi*2) + 1 );\r
+ \r
+ I:= Inchar;\r
+ \r
+ Od;\r
+ \r
+ Call SetCursor (Curseur.Ordo + 1, (Curseur.Absi * 2) + 1);\r
+ Call Reverse;\r
+ If Mat.A ( Curseur.Absi, Curseur.Ordo) = 1\r
+ Then\r
+ write (" ");\r
+ Else\r
+ write ( chr(88));\r
+ Fi;\r
+ Call SetCursor (Curseur.Ordo + 1, (Curseur.Absi * 2) + 1);\r
+ Call Normal;\r
+ \r
+ End ; (* Block Validation des chemins *)\r
+ \r
+ END CreationChemin;\r
+ \r
+ BEGIN (* creation labyrinthe *)\r
+ \r
+ Call Newpage;\r
+ TailleMax.Ordo:=0;\r
+ TailleMax.Absi:=0;\r
+ \r
+ While (TailleMax.Ordo < 1) Or (TailleMax.Ordo > 20) Or\r
+ (TailleMax.Absi < 1) Or (TailleMax.Absi > 30)\r
+ Do\r
+ (* Lecture de la taille du labyrinthe *)\r
+ writeln(" Entrez la hauteur du labyrinthe ");\r
+ write(" comprise entre 1 et 20 : ");\r
+ readln(TailleMax.Ordo);\r
+ writeln;\r
+ writeln(" Entrez la largeur du labyrinthe");\r
+ write(" comprise entre 1 et 30 : ");\r
+ readln(TailleMax.Absi);\r
+ writeln;\r
+ Od;\r
+ \r
+ Call CreatMat(mat);\r
+ Call InitMat(Mat);\r
+ Call AffichageLaby(Mat);\r
+ \r
+ Call CreationChemin(Mat);\r
+ call SetCursor(25,1);\r
+ write(" Le labyrinthe cr\82e est sauvegard\82 dans le fichier DONNEES.LAB ... ");\r
+ \r
+ END CreationLaby;\r
+ \r
+UNIT Menu : PROCEDURE (output Choix : char);\r
+ \r
+BEGIN\r
+ call NewPage;\r
+ call Reverse;\r
+ call Underscore;\r
+ call SetCursor(5,32);\r
+ write(" MENU ");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(9,20);\r
+ write("1");\r
+ call Normal;\r
+ call SetCursor(9,22);\r
+ write("- Cr\82ation d'un labyrinthe. ");\r
+ call Bold;\r
+ call SetCursor(12,20);\r
+ write("2");\r
+ call Normal;\r
+ call SetCursor(12,22);\r
+ write("- Chargement d'un labyrinthe.");\r
+ call Bold;\r
+ call SetCursor(15,20);\r
+ write("3");\r
+ call Normal;\r
+ call SetCursor(15,22);\r
+ write("- Sortie du programme.");\r
+ call Bold;\r
+ call SetCursor(19,30);\r
+ write("Choix : ");\r
+ call Normal;\r
+ call SetCursor(22,20);\r
+ write("Validez votre choix avec ");\r
+ call Bold;\r
+ write(chr(17),chr(217));\r
+ call SetCursor(19,38);\r
+ readln(choix);\r
+ while (ord(Choix) <> 49) AND (ord(Choix) <> 50) AND (ord(Choix) <> 51) do\r
+ call Bold;\r
+ call SetCursor(24,10);\r
+ write("Choix incorrect ");\r
+ call Normal;\r
+ call SetCursor(19,38);\r
+ Readln(Choix);\r
+ od;\r
+ \r
+END Menu;\r
+ \r
+BEGIN (* Programme principal *)\r
+ \r
+ SortieProg:= false;\r
+ while not SortieProg do\r
+ call Menu(choix);\r
+ case ord(choix)\r
+ when 49 : Mat := New Matrice;\r
+ Entree := New Couple;\r
+ TailleMax := New Couple;\r
+ call CreationLaby(mat);\r
+ call SauveLaby(Entree, TailleMax, Mat, F);\r
+ call RechChemin(Mat);\r
+ Kill(Mat.A);\r
+ Kill(Mat);\r
+ kill(entree);\r
+ kill(TailleMax);\r
+ \r
+ when 50 : Mat := New Matrice;\r
+ Entree := New Couple;\r
+ TailleMax := New Couple;\r
+ call ChargeLaby(Mat);\r
+ call RechChemin(Mat);\r
+ Kill(Mat.A);\r
+ kill(Mat);\r
+ kill(Entree);\r
+ kill(TailleMax);\r
+ \r
+ when 51 : SortieProg := True;\r
+ esac;\r
+ od;\r
+ end; (* End iiuwgraph *)\r
+ \r
+END; (* End Programme *)\r
--- /dev/null
+ program othello;\r
+\r
+ UNIT NEWPAGE : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end newpage;\r
+\r
+ UNIT gotoxy : procedure (row, column : integer);\r
+ var c, d, e, f : char,\r
+ i, j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr (48+i);\r
+ d := chr (48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr (48+i);\r
+ f := chr (48+j);\r
+ write (chr(27), "[", c, d, ";", e, f, "H");\r
+ end gotoxy;\r
+\r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+\r
+ UNIT INCHAR : IIuwgraph function : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+\r
+ unit pause:procedure(input seconde:integer);\r
+ var temps:integer;\r
+ begin\r
+ for temps:=1 to (9000*seconde) do od;\r
+ end pause;\r
+\r
+ unit grille:class;\r
+ var g:arrayof arrayof integer;\r
+ var i:integer;\r
+ begin\r
+ array g dim (1:8);\r
+ for i:=1 to 8\r
+ do\r
+ array g(i) dim (1:8);\r
+ od;\r
+ end grille;\r
+\r
+ unit initialisegrille : procedure(inout gr: arrayof arrayof integer);\r
+ var i,j:integer;\r
+ begin\r
+ (* creation de la grille *)\r
+ array gr dim (1:8);\r
+ for i:=1 to 8\r
+ do\r
+ array gr(i) dim (1:8);\r
+ od;\r
+ (* initialisation de la grille *)\r
+ (* 0 case vide *)\r
+ (* 1 case avec pion noir *)\r
+ (* 2 case avec pion blanc *)\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ gr(i,j):=0;\r
+ od;\r
+ od;\r
+(* for j:=1 to 8 do gr(8,j):=0 od;*)\r
+ gr(4,4):=1;\r
+ gr(5,5):=1;\r
+ gr(4,5):=2;\r
+ gr(5,4):=2;\r
+ end initialisegrille;\r
+\r
+unit affichecadre:procedure;\r
+begin\r
+call newpage;\r
+call gotoxy(2,2);\r
+writeln(" 1 2 3 4 5 6 7 8 ");\r
+writeln(" ÚÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄ¿");\r
+writeln("1 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("2 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("3 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("4 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("5 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("6 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("7 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÃÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´");\r
+writeln("8 ³ ³ ³ ³ ³ ³ ³ ³ ³");\r
+writeln(" ÀÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÙ");\r
+call gotoxy(22,1);\r
+if souris then\r
+writeln("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+writeln("³ D\82placement : Souris ³ Valider : Bouton 1 ³ Quitter : Bouton 3 ³ ");\r
+writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ");\r
+else\r
+writeln("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+writeln("³ D\82placement : Fl\8aches ³ Valider : RETURN ³ Quitter : ECHAP ³ ");\r
+writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ");\r
+fi;\r
+\r
+end affichecadre;\r
+\r
+ unit affichegrille : procedure(input gr: arrayof arrayof integer);\r
+ (* 0 case vide *)\r
+ (* 1 case avec pion noir *)\r
+ (* 2 case avec pion blanc *)\r
+ var i,j,v,w:integer;\r
+ begin\r
+ v:=4;\r
+ for i:=1 to 8\r
+ do\r
+ w:=5;\r
+ for j:=1 to 8\r
+ do\r
+ if (gr(i,j)=1) then call gotoxy(v,w);write(chr(27),"[33m");\r
+ writeln("x ");write(chr(27),"[36m");fi;\r
+ if (gr(i,j)=2) then call gotoxy(v,w);write(chr(27),"[32m");\r
+ writeln("o ");write(chr(27),"[36m");fi;\r
+ w:=w+5;\r
+ od;\r
+ v:=v+2;\r
+ od;\r
+ call gotoxy(v,1);\r
+ end affichegrille;\r
+\r
+unit deplace:procedure;\r
+var touche,bidon:integer;\r
+begin\r
+ call gotoxy(xx,yy);\r
+ do\r
+ touche := inchar;\r
+ case touche\r
+ when 50 : if xx<18 then xx:=xx+2;ii:=ii+1 fi; (*Touche 2*)\r
+ when 52 : if yy>5 then yy:=yy-5;jj:=jj-1 fi; (*Touche 4*)\r
+ when 54 : if yy<37 then yy:=yy+5;jj:=jj+1 fi; (*Touche 6*)\r
+ when 56 : if xx>4 then xx:=xx-2;ii:=ii-1 fi; (*Touche 8*)\r
+ when 13 : exit; (*Touche RC*)\r
+ when 27 : arreter:=true;exit; (*Touche ECHAP*)\r
+ esac;\r
+ call gotoxy(xx,yy);\r
+ od;\r
+ end deplace;\r
+\r
+ unit direction:procedure(ligne,colonne:integer;\r
+ deplacementcolonne,deplacementligne:integer;\r
+ couleur,invcouleur:integer;\r
+ tab:arrayof arrayof integer;\r
+ output nbpion:integer);\r
+ var retourne:boolean;\r
+ begin\r
+ nbpion:=0;\r
+ retourne:=true;\r
+ do\r
+ colonne:=colonne+deplacementcolonne;\r
+ ligne:=ligne+deplacementligne;\r
+ if (colonne=0) or (colonne=9) or (ligne=0) or (ligne=9) then\r
+ (* debordement du tableau *)\r
+ retourne:=false;\r
+ exit;\r
+ fi;\r
+\r
+ if (tab(ligne,colonne)=invcouleur) then\r
+ (* case de couleur inverse *)\r
+ nbpion:=nbpion+1;\r
+ fi;\r
+\r
+ if (tab(ligne,colonne))=0 then\r
+ (* case vide*)\r
+ retourne:=false;\r
+ exit;\r
+ fi;\r
+\r
+ if (tab(ligne,colonne)=couleur) then\r
+ (* case de meme couleur *)\r
+ exit;\r
+ fi;\r
+ od;\r
+\r
+ if not(retourne) then nbpion:=0;fi;\r
+ end direction;\r
+\r
+unit retourne_pion:procedure(ligne,colonne:integer;\r
+ deplacementcolonne,deplacementligne:integer;\r
+ couleur,invcouleur:integer;\r
+ inout tab:arrayof arrayof integer);\r
+ begin\r
+ do\r
+ colonne:=colonne+deplacementcolonne;\r
+ ligne:=ligne+deplacementligne;\r
+\r
+ if (tab(ligne,colonne)=couleur) then\r
+ (* case de meme couleur *)\r
+ exit;\r
+ fi;\r
+\r
+ if (tab(ligne,colonne)=invcouleur) then\r
+ (* case de couleur inverse *)\r
+ (* on inverse la couleur *)\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ od;\r
+ end retourne_pion;\r
+\r
+ unit nb_de_pion_a_poser:procedure(input couleur:integer;\r
+ input tab:arrayof arrayof integer;\r
+ input on_somme_prio:boolean;\r
+ output nb_pion_a_poser,som_prio:integer);\r
+ var i,j,nb:integer;\r
+ var on_retourne_pion:boolean;\r
+ begin\r
+ nb_pion_a_poser:=0;\r
+ on_retourne_pion:=false;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ if tab(i,j)=0 then\r
+call peut_on_poser_pion(i,j,couleur,tab,on_retourne_pion,on_somme_prio,nb,som_prio);\r
+ if nb<>0 then nb_pion_a_poser:=nb_pion_a_poser+1;fi;\r
+ fi;\r
+ od;\r
+ od;\r
+ end nb_de_pion_a_poser;\r
+\r
+ unit peut_on_poser_pion:procedure(input ligne,colonne:integer;\r
+ input couleur:integer;\r
+ input tab:arrayof arrayof integer;\r
+ input on_retourne_pion,on_somme_prio:boolean;\r
+ output pionretourne,som_prio:integer);\r
+ var nord,sud,ouest,est:boolean;\r
+ var nord_ouest,nord_est,sud_ouest,sud_est:boolean;\r
+ var nbpion,invcouleur,i,j:integer;\r
+ var deplacementcolonne,deplacementligne:integer;\r
+ var prio : integer;\r
+ begin\r
+ prio:=0;\r
+ if (couleur=1) then invcouleur:=2 else invcouleur:=1;fi;\r
+ nord:=true;\r
+ sud:=true;\r
+ ouest:=true;\r
+ est:=true;\r
+ nord_ouest:=true;\r
+ nord_est:=true;\r
+ sud_ouest:=true;\r
+ sud_est:=true;\r
+ if (ligne<=2) then nord:=false;nord_ouest:=false;nord_est:=false;fi;\r
+ if (ligne>=7) then sud:=false;sud_ouest:=false;sud_est:=false;fi;\r
+ if (colonne>=7) then est:=false;sud_est:=false;nord_est:=false;fi;\r
+ if (colonne<=2) then ouest:=false;sud_ouest:=false;nord_ouest:=false;fi;\r
+ pionretourne:=0;\r
+ (* faire chaque direction *)\r
+ if (nord) then deplacementcolonne:=0;\r
+ deplacementligne:=-1;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (sud) then deplacementcolonne:=0;\r
+ deplacementligne:=1;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (ouest) then deplacementcolonne:=-1;\r
+ deplacementligne:=0;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (est) then deplacementcolonne:=1;\r
+ deplacementligne:=0;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (nord_ouest) then deplacementcolonne:=-1;\r
+ deplacementligne:=-1;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (sud_ouest) then deplacementcolonne:=-1;\r
+ deplacementligne:=1;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (nord_est) then deplacementcolonne:=1;\r
+ deplacementligne:=-1;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+\r
+ if (sud_est) then deplacementcolonne:=1;\r
+ deplacementligne:=1;\r
+ call direction(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,nbpion);\r
+ pionretourne:=pionretourne+nbpion;\r
+ if (nbpion<>0) and (on_retourne_pion) then\r
+ call retourne_pion(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab);\r
+ tab(ligne,colonne):=couleur;\r
+ fi;\r
+ if (nbpion<>0) and (on_somme_prio) then\r
+ call prio_pion_retourne(ligne,colonne,\r
+ deplacementcolonne,deplacementligne,\r
+ couleur,invcouleur,tab,gr_p,prio);\r
+ som_prio:=som_prio+prio;\r
+ fi;\r
+ fi;\r
+ end peut_on_poser_pion;\r
+\r
+unit joueur_humain : coroutine;\r
+var i,j,x,y:integer;\r
+begin\r
+ return;\r
+ do\r
+ call gotoxy(21,1);\r
+ if (rep='2') then\r
+ if (pion=1) then\r
+ write("Joueur 1 : ");write(chr(27),"[33m");\r
+ writeln("Noir x ");write(chr(27),"[36m")\r
+ else\r
+ write("Joueur 2 : ");write(chr(27),"[32m");\r
+ writeln("Blanc o ");write(chr(27),"[36m");\r
+ fi\r
+else\r
+ if (rep='o') or (rep='O') then\r
+ write("Joueur : ");write(chr(27),"[33m");\r
+ writeln("Noir x ");write(chr(27),"[36m")\r
+ else\r
+ write("Joueur : ");write(chr(27),"[32m");\r
+ writeln("Blanc o ");write(chr(27),"[36m");\r
+ fi;\r
+ fi;\r
+ call deplace;\r
+ lig:=ii;\r
+ col:=jj;\r
+ detach;\r
+ od;\r
+end joueur_humain;\r
+\r
+unit depace_souris : procedure;\r
+ var x,y:integer;\r
+begin\r
+\r
+ pref mouse block;\r
+\r
+ var o8,dx,dy,gk,h,v,p,b:integer,\r
+ l,r,c:boolean;\r
+ begin\r
+ o8 := 8;\r
+ b:=0;\r
+ call defcursor(1,11,12);\r
+ call showcursor;\r
+ call status(h,v,l,r,c);\r
+ do\r
+ call getpress(b,h,v,p,l,r,c);\r
+ if c\r
+ then\r
+ exit\r
+ fi;\r
+ if l\r
+ then\r
+ dx:=h / o8; dy := v / o8;\r
+ call gotoxy(dy+1,dx+1);\r
+ call SetPosition(h,v);\r
+ if ((dx+1>=4) and (dx+1<=42) and (dy+1>=3) and (dy+1<=18)) then\r
+ if (dx+1<>8) and (dx+1<>13) and(dx+1<>18) and(dx+1<>23)\r
+ and (dx+1<>28) and (dx+1<>33) and (dx+1<>38) then exit;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ if r\r
+ then\r
+ call getpress(1,h,v,p,l,r,c);\r
+ dx :=h div o8;\r
+ dy :=v div o8;\r
+ call gotoxy(dy,dx);\r
+ arreter:=true;\r
+ call SetPosition(h,v); exit;\r
+ fi;\r
+ od;\r
+ x:=dx+1;\r
+ y:=dy+1;\r
+\r
+ if (x>=4) and (x<=7) then x:=1; fi;\r
+ if (x>=9) and (x<=12) then x:=2; fi;\r
+ if (x>=14) and (x<=17) then x:=3; fi;\r
+ if (x>=19) and (x<=22) then x:=4; fi;\r
+ if (x>=24) and (x<=27) then x:=5; fi;\r
+ if (x>=29) and (x<=32) then x:=6; fi;\r
+ if (x>=34) and (x<=37) then x:=7; fi;\r
+ if (x>=39) and (x<=42) then x:=8; fi;\r
+ jj:=x;\r
+\r
+ if (y>=3) and (y<=4) then y:=1; fi;\r
+ if (y>=5) and (y<=6) then y:=2; fi;\r
+ if (y>=7) and (y<=8) then y:=3; fi;\r
+ if (y>=9) and (y<=10) then y:=4; fi;\r
+ if (y>=11) and (y<=12) then y:=5; fi;\r
+ if (y>=13) and (y<=14) then y:=6; fi;\r
+ if (y>=15) and (y<=16) then y:=7; fi;\r
+ if (y>=17) and (y<=18) then y:=8; fi;\r
+ ii:=y;\r
+\r
+ end (* mouse *)\r
+\r
+end depace_souris;\r
+\r
+\r
+\r
+\r
+\r
+unit joueur_humain_souris : coroutine;\r
+var i,j,x,y:integer;\r
+begin\r
+ return;\r
+ do\r
+ call gotoxy(21,1);\r
+ if (rep='2') then\r
+ if (pion=1) then\r
+ write("Joueur 1 : ");write(chr(27),"[33m");\r
+ writeln("Noir x ");write(chr(27),"[36m")\r
+ else\r
+ write("Joueur 2 : ");write(chr(27),"[32m");\r
+ writeln("Blanc o ");write(chr(27),"[36m");\r
+ fi\r
+else\r
+ if (rep='o') or (rep='O') then\r
+ write("Joueur : ");write(chr(27),"[33m");\r
+ writeln("Noir x ");write(chr(27),"[36m")\r
+ else\r
+ write("Joueur : ");write(chr(27),"[32m");\r
+ writeln("Blanc o ");write(chr(27),"[36m");\r
+ fi;\r
+ fi;\r
+\r
+\r
+ call depace_souris;\r
+\r
+ lig:=ii;\r
+ col:=jj;\r
+ detach;\r
+ od;\r
+end joueur_humain_souris;\r
+\r
+\r
+unit copie_tableau:procedure(input t1:arrayof arrayof integer;\r
+ inout t2:arrayof arrayof integer);\r
+var i,j:integer;\r
+begin\r
+\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ t2(i,j):=t1(i,j);\r
+ od;\r
+ od;\r
+end copie_tableau;\r
+\r
+\r
+unit prio_pion_retourne:procedure(ligne,colonne:integer;\r
+ deplacementcolonne,deplacementligne:integer;\r
+ couleur,invcouleur:integer;\r
+ tab,gr_prio:arrayof arrayof integer;\r
+ output som_prio : integer);\r
+ begin\r
+ som_prio:=0;\r
+ do\r
+ colonne:=colonne+deplacementcolonne;\r
+ ligne:=ligne+deplacementligne;\r
+\r
+ if (tab(ligne,colonne)=couleur) then\r
+ (* case de meme couleur *)\r
+ exit;\r
+ fi;\r
+\r
+ if (tab(ligne,colonne)=invcouleur) then\r
+ (* case de couleur inverse *)\r
+ (* on somme la priorite du pion qu'on peut retourner *)\r
+ som_prio:=som_prio+gr_prio(ligne,colonne);\r
+ fi;\r
+ od;\r
+ end prio_pion_retourne;\r
+\r
+unit cherche_pion_a_poser:procedure(input couleur:integer;\r
+ input tab:arrayof arrayof integer;\r
+ inout coup:arrayof arrayof integer;\r
+ inout nb_coup:integer);\r
+ var i,j,k,l,nb:integer;\r
+ var on_retourne_pion:boolean;\r
+ var som_prio:integer;\r
+ var tab_2:arrayof arrayof integer;\r
+ var invcouleur,max,som_adverse:integer;\r
+ begin\r
+ array tab_2 dim (1:8);\r
+ for i:=1 to 8\r
+ do\r
+ array tab_2(i) dim (1:8);\r
+ od;\r
+ if (couleur=1) then invcouleur:=2 else invcouleur:=1;fi;\r
+ on_retourne_pion:=false;\r
+ nb_coup:=0;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ if tab(i,j)=0 then\r
+ call copie_tableau(tab,tab_2);\r
+\r
+ (* simule notre coup *)\r
+ call peut_on_poser_pion(i,j,couleur,tab_2,on_retourne_pion,true,nb,som_prio);\r
+ if nb<>0 then nb_coup:=nb_coup+1;\r
+ coup(nb_coup,1):=i; (* ligne *)\r
+ coup(nb_coup,2):=j; (* colonne *)\r
+ coup(nb_coup,3):=nb; (* pions retourn\82s *)\r
+ coup(nb_coup,4):=gr_p(i,j); (* priorit\82 du pion pos\82 *)\r
+ coup(nb_coup,5):=som_prio; (* priorit\82 pions retourn\82s *)\r
+ (* pose et retourne*)\r
+\r
+ call peut_on_poser_pion(i,j,couleur,tab_2,true,false,nb,som_prio);\r
+ (* simule le coup adverse *)\r
+ max:=-1000;\r
+ for k:=1 to 8\r
+ do\r
+ for l:=1 to 8\r
+ do\r
+ if tab_2(k,l)=0 then\r
+call peut_on_poser_pion(k,l,invcouleur,tab_2,false,true,nb,som_prio);\r
+ if nb<>0 then\r
+ som_adverse:=2*nb+7*gr_p(k,l)+som_prio;\r
+ if max<som_adverse then max:=som_adverse;fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ od;\r
+ coup(nb_coup,6):=max;\r
+\r
+ fi;\r
+ fi;\r
+ od;\r
+ od;\r
+kill(tab_2);\r
+ end cherche_pion_a_poser;\r
+\r
+unit remp_gr_prio:procedure(output gr_prio:arrayof arrayof integer);\r
+var i,j:integer;\r
+begin\r
+array gr_prio dim (1:8);\r
+ for i:=1 to 8\r
+ do\r
+ array gr_prio(i) dim (1:8);\r
+ od;\r
+gr_prio(1,1):=20;\r
+gr_prio(1,8):=20;\r
+gr_prio(8,1):=20;\r
+gr_prio(8,8):=20;\r
+gr_prio(1,3):=14;\r
+gr_prio(1,6):=14;\r
+gr_prio(8,3):=14;\r
+gr_prio(8,6):=14;\r
+gr_prio(3,1):=14;\r
+gr_prio(6,1):=14;\r
+gr_prio(3,8):=14;\r
+gr_prio(6,8):=14;\r
+gr_prio(1,4):=12;\r
+gr_prio(1,5):=12;\r
+gr_prio(8,4):=12;\r
+gr_prio(8,5):=12;\r
+gr_prio(4,1):=12;\r
+gr_prio(5,1):=12;\r
+gr_prio(4,8):=12;\r
+gr_prio(5,8):=12;\r
+gr_prio(1,2):=9;\r
+gr_prio(1,7):=9;\r
+gr_prio(8,2):=9;\r
+gr_prio(8,7):=9;\r
+gr_prio(2,1):=9;\r
+gr_prio(7,1):=9;\r
+gr_prio(2,8):=9;\r
+gr_prio(7,8):=9;\r
+gr_prio(3,3):=6;\r
+gr_prio(3,6):=6;\r
+gr_prio(6,3):=6;\r
+gr_prio(6,6):=6;\r
+gr_prio(3,4):=4;\r
+gr_prio(3,5):=4;\r
+gr_prio(6,4):=4;\r
+gr_prio(6,5):=4;\r
+gr_prio(4,3):=4;\r
+gr_prio(5,3):=4;\r
+gr_prio(4,6):=4;\r
+gr_prio(5,6):=4;\r
+gr_prio(2,3):=2;\r
+gr_prio(2,4):=2;\r
+gr_prio(2,5):=2;\r
+gr_prio(2,6):=2;\r
+gr_prio(7,3):=2;\r
+gr_prio(7,4):=2;\r
+gr_prio(7,5):=2;\r
+gr_prio(7,6):=2;\r
+gr_prio(3,2):=2;\r
+gr_prio(4,2):=2;\r
+gr_prio(5,2):=2;\r
+gr_prio(6,2):=2;\r
+gr_prio(3,7):=2;\r
+gr_prio(4,7):=2;\r
+gr_prio(5,7):=2;\r
+gr_prio(6,7):=2;\r
+gr_prio(2,2):=1;\r
+gr_prio(2,7):=1;\r
+gr_prio(7,2):=1;\r
+gr_prio(7,7):=1;\r
+gr_prio(4,4):=2;\r
+gr_prio(4,5):=2;\r
+gr_prio(5,4):=2;\r
+gr_prio(5,5):=2;\r
+end remp_gr_prio;\r
+\r
+unit modifie_gr_prio : procedure(rep2 : char);\r
+begin\r
+\r
+(* changement des priorites *)\r
+(* on le coin haut-gauche *)\r
+if rep2='1' or rep2='2' or rep2='3' or rep2='4' then\r
+gr_p(1,2):=16;\r
+gr_p(2,1):=16;\r
+gr_p(8,1):=15;\r
+gr_p(1,3):=15;\r
+gr_p(2,2):=15;\r
+gr_p(4,1):=13;\r
+gr_p(1,4):=13;\r
+gr_p(2,3):=13;\r
+gr_p(3,2):=13;\r
+fi;\r
+\r
+(* on le coin haut-droit *)\r
+if rep2='2' or rep2='3' or rep2='4' then\r
+gr_p(1,7):=16;\r
+gr_p(2,8):=16;\r
+gr_p(3,8):=15;\r
+gr_p(1,6):=15;\r
+gr_p(2,7):=15;\r
+gr_p(4,8):=13;\r
+gr_p(1,5):=13;\r
+gr_p(2,6):=13;\r
+gr_p(3,7):=13;\r
+fi;\r
+\r
+(* on le coin bas-droit *)\r
+if rep2='3' or rep2='4' then\r
+gr_p(8,7):=16;\r
+gr_p(7,8):=16;\r
+gr_p(6,8):=15;\r
+gr_p(8,6):=15;\r
+gr_p(7,7):=15;\r
+gr_p(5,8):=13;\r
+gr_p(8,5):=13;\r
+gr_p(7,6):=13;\r
+gr_p(6,7):=13;\r
+fi;\r
+\r
+(* on le coin bas-gauche *)\r
+if rep2='4' then\r
+gr_p(7,1):=16;\r
+gr_p(8,2):=16;\r
+gr_p(8,3):=15;\r
+gr_p(7,2):=15;\r
+gr_p(6,1):=15;\r
+gr_p(8,4):=13;\r
+gr_p(7,3):=13;\r
+gr_p(6,2):=13;\r
+gr_p(5,1):=13;\r
+fi;\r
+\r
+end modifie_gr_prio;\r
+\r
+\r
+unit joueur_machine : coroutine;\r
+var i,j,nb_point,nb_coup,max_pion_retourne,pion :integer;\r
+var coup : arrayof arrayof integer;\r
+begin\r
+array coup dim (1:60);\r
+for i:=1 to 60\r
+ do\r
+ array coup(i) dim (1:7);\r
+ od;\r
+return;\r
+do\r
+call gotoxy(21,1);\r
+if (rep='n') or (rep='N') then\r
+write("Machine : ");write(chr(27),"[33m");\r
+writeln("Noir x");write(chr(27),"[36m")\r
+else\r
+write("Machine : ");write(chr(27),"[32m");\r
+writeln("Blanc o");write(chr(27),"[36m");\r
+fi;\r
+\r
+nb_point:=0;\r
+(* recherche des cases ou l'on peut jouer *)\r
+if (rep='o') or (rep='O') then pion:=2 else pion:=1 fi;\r
+call cherche_pion_a_poser(pion,plateau,coup,nb_coup);\r
+\r
+(*faire la somme des priorit\82*)\r
+for i:=1 to nb_coup do\r
+ coup(i,7):=coup(i,3)*2+coup(i,4)*5+coup(i,5)-coup(i,6);\r
+ od;\r
+(* choix de la meilleure case *)\r
+max_pion_retourne:=-1000;\r
+for i:= 1 to nb_coup\r
+ do\r
+ if coup(i,7)>max_pion_retourne then max_pion_retourne:=coup(i,7);\r
+ lig:=coup(i,1);\r
+ col:=coup(i,2);\r
+ fi;\r
+ od;\r
+ii:=lig;\r
+jj:=col;\r
+(* changement des priorites *)\r
+(* on le coin haut-gauche *)\r
+if lig=1 and col=1 then\r
+gr_p(1,2):=16;\r
+gr_p(2,1):=16;\r
+gr_p(8,1):=15;\r
+gr_p(1,3):=15;\r
+gr_p(2,2):=15;\r
+gr_p(4,1):=13;\r
+gr_p(1,4):=13;\r
+gr_p(2,3):=13;\r
+gr_p(3,2):=13;\r
+fi;\r
+\r
+(* on le coin haut-droit *)\r
+if lig=1 and col=8 then\r
+gr_p(1,7):=16;\r
+gr_p(2,8):=16;\r
+gr_p(3,8):=15;\r
+gr_p(1,6):=15;\r
+gr_p(2,7):=15;\r
+gr_p(4,8):=13;\r
+gr_p(1,5):=13;\r
+gr_p(2,6):=13;\r
+gr_p(3,7):=13;\r
+fi;\r
+\r
+(* on le coin bas-droit *)\r
+if lig=8 and col=8 then\r
+gr_p(8,7):=16;\r
+gr_p(7,8):=16;\r
+gr_p(6,8):=15;\r
+gr_p(8,6):=15;\r
+gr_p(7,7):=15;\r
+gr_p(5,8):=13;\r
+gr_p(8,5):=13;\r
+gr_p(7,6):=13;\r
+gr_p(6,7):=13;\r
+fi;\r
+\r
+(* on le coin bas-gauche *)\r
+if lig=8 and col=1 then\r
+gr_p(7,1):=16;\r
+gr_p(8,2):=16;\r
+gr_p(8,3):=15;\r
+gr_p(7,2):=15;\r
+gr_p(6,1):=15;\r
+gr_p(8,4):=13;\r
+gr_p(7,3):=13;\r
+gr_p(6,2):=13;\r
+gr_p(5,1):=13;\r
+fi;\r
+\r
+\r
+xx:=lig*2+2;\r
+yy:=col*5;\r
+call gotoxy(xx,yy);\r
+detach;\r
+od;\r
+end joueur_machine;\r
+\r
+unit compte_pion:procedure(input tab:arrayof arrayof integer;\r
+ output nb_pion_blanc,nb_pion_noir:integer);\r
+var i,j:integer;\r
+ begin\r
+ nb_pion_blanc:=0;\r
+ nb_pion_noir:=0;\r
+ for i:=1 to 8\r
+ do\r
+ for j:=1 to 8\r
+ do\r
+ if (tab(i,j)=1) then nb_pion_noir:=nb_pion_noir+1;fi;\r
+ if (tab(i,j)=2) then nb_pion_blanc:=nb_pion_blanc+1;fi;\r
+ od;\r
+ od;\r
+end compte_pion;\r
+\r
+unit aff_nb_pion:procedure;\r
+begin\r
+ call gotoxy(3,55);\r
+ writeln("ÚÄÄÄÄÄÄÄ¿");\r
+ call gotoxy(4,55);\r
+ writeln("³ SCORE ³");\r
+ call gotoxy(5,55);\r
+ writeln("ÀÄÄÄÄÄÄÄÙ");\r
+ call gotoxy(6,46);\r
+ write("Nombre de pions ");write(chr(27),"[33m");\r
+ write("noir ");write(chr(27),"[36m");write(": ");\r
+ write(chr(27),"[33m");write(nb_pion_noir);write(chr(27),"[36m");\r
+ call gotoxy(8,46);\r
+ write("Nombre de pions ");write(chr(27),"[32m");\r
+ write("blanc ");write(chr(27),"[36m");write(": ");\r
+ write(chr(27),"[32m");write(nb_pion_blanc);write(chr(27),"[36m");\r
+ call gotoxy(xx,yy);\r
+end aff_nb_pion;\r
+\r
+\r
+(***********************************************************************)\r
+(************************ Programme Principal **************************)\r
+(***********************************************************************)\r
+\r
+var plateau,gr_p:arrayof arrayof integer;\r
+var nb,nb_case_vide:integer;\r
+var joueur1,joueur2:joueur_humain;\r
+var joueur1_s,joueur2_s:joueur_humain_souris;\r
+var joueur3:joueur_machine;\r
+var col,lig,i,xx,yy,ii,jj:integer;\r
+var pion,nb_pion_blanc,nb_pion_noir:integer;\r
+var nb_noir_poser,nb_blanc_poser:integer;\r
+var sec1,sec2:integer;\r
+var arreter:boolean;\r
+var bidon,rep,rep2:char;\r
+var som_prio:integer;\r
+var souris:boolean;\r
+\r
+begin\r
+ call newpage;\r
+ write(chr(27),"[31m");\r
+ call gotoxy(10,19);\r
+ writeln("ÚÄÄÄÄ¿ ÄÄÂÄÄ ³ ³ ÚÄÄÄÄ ³ ³ ÚÄÄÄÄ¿ ");\r
+ call gotoxy(11,19);\r
+ writeln("³ ³ ³ ÃÄÄÄÄ´ ÃÄÄ ³ ³ ³ ³ ");\r
+ call gotoxy(12,19);\r
+ writeln("ÀÄÄÄÄÙ ³ ³ ³ ÀÄÄÄÄ ÀÄÄÄÄ ÀÄÄÄÄ ÀÄÄÄÄÙ ");\r
+ call gotoxy(17,33);\r
+ write(chr(27),"[36m");\r
+ writeln("Presented by");\r
+ call gotoxy(22,11);\r
+ write(chr(27),"[32m");\r
+ writeln("Defeuillet Patrick - Gosset V\82ronique - Dupin Christophe");\r
+ call pause(2);\r
+ do\r
+ write(chr(27),"[36m");\r
+ arreter:=false;\r
+ ii:=1;\r
+ jj:=1;\r
+ xx:=4;\r
+ yy:=5;\r
+ rep := ' ';\r
+ while (rep <> 'o') and (rep <> 'n') and (rep <> 'O') and (rep <> 'N')\r
+ do\r
+ call newpage;\r
+ call gotoxy(8,1);\r
+ writeln(" Avez_vous une souris (O ou N) ? ");\r
+ writeln;\r
+ write(" Votre choix : ");\r
+ readln(rep);\r
+ od;\r
+if (rep='o') or (rep='O') then souris:=true;\r
+else souris:=false;\r
+fi;\r
+ while (rep <> '1') and (rep <> '2')\r
+ do\r
+ call newpage;\r
+ call gotoxy(3,20);\r
+ writeln("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+ call gotoxy(4,20);\r
+ writeln("³ PREPARATION DU JEU ³ ");\r
+ call gotoxy(5,20);\r
+ writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ");\r
+ call gotoxy(8,1);\r
+ writeln(" 1 - UN joueur");\r
+ writeln(" 2 - DEUX joueurs ");\r
+ writeln;\r
+ write(" Votre choix : ");\r
+ readln(rep);\r
+ od;\r
+ rep2:=' ';\r
+ while rep2<>'0' and rep2<>'1' and rep2<>'2' and rep2<>'3' and rep2<>'4'\r
+ do\r
+ call gotoxy(13,1);\r
+ writeln(" Les noirs commencent avec combien de coin(s) (0 \85 4) ? ");\r
+ writeln;\r
+ write(" Votre choix : ");\r
+ readln(rep2);\r
+ od;\r
+ call initialisegrille(plateau);\r
+ if rep2='0' then nb_case_vide:=60;fi;\r
+ if rep2='1' then nb_case_vide:=59;plateau(1,1):=1;fi;\r
+ if rep2='2' then nb_case_vide:=58;plateau(1,1):=1;plateau(1,8):=1;fi;\r
+ if rep2='3' then nb_case_vide:=57;plateau(1,1):=1;plateau(1,8):=1;\r
+ plateau(8,1):=1;fi;\r
+ if rep2='4' then nb_case_vide:=56;plateau(1,1):=1;plateau(1,8):=1;\r
+ plateau(8,1):=1;plateau(8,8):=1;fi;\r
+ if rep = '1' then while (rep <> 'O') and (rep <> 'N') and (rep <> 'o') and (rep <> 'n')\r
+ do\r
+ call gotoxy(18,1);\r
+ writeln(" Voulez_vous commencer (O ou N) ?");\r
+ writeln;\r
+ write(" Votre choix : ");\r
+ readln(rep);\r
+ od;\r
+ if (rep = 'O') or (rep='o') then\r
+ if souris then\r
+ joueur1_s := new joueur_humain_souris\r
+ else\r
+ joueur1 := new joueur_humain;\r
+ fi;\r
+ joueur3 := new joueur_machine;\r
+ else\r
+ joueur3 := new joueur_machine;\r
+ if souris then\r
+ joueur2_s := new joueur_humain_souris\r
+ else\r
+ joueur2 := new joueur_humain;\r
+ fi;\r
+ fi;\r
+ else\r
+ if souris then\r
+ joueur1_s := new joueur_humain_souris;\r
+ joueur2_s := new joueur_humain_souris;\r
+ else\r
+ joueur1 := new joueur_humain;\r
+ joueur2 := new joueur_humain;\r
+ fi;\r
+ fi;\r
+\r
+\r
+ call remp_gr_prio(gr_p);\r
+ if ((rep2<>'0') and (rep='n' or rep='N')) then\r
+ call modifie_gr_prio(rep2);\r
+ fi;\r
+ call affichecadre;\r
+ call affichegrille(plateau);\r
+ call compte_pion(plateau,nb_pion_blanc,nb_pion_noir);\r
+ call aff_nb_pion;\r
+\r
+do\r
+ call nb_de_pion_a_poser(1,plateau,false,nb_noir_poser,som_prio);\r
+ if nb_noir_poser=0 then if nb_case_vide<>0 then\r
+ call gotoxy(10,46);\r
+ writeln("Les noirs ne peuvent pas jouer !");\r
+ call gotoxy(xx,yy);\r
+ call pause(2);\r
+ call gotoxy(10,46);\r
+ writeln(" ");\r
+ call gotoxy(xx,yy);fi;\r
+ fi;\r
+ if nb_noir_poser<>0 then\r
+ do\r
+ (* pion noir *)\r
+ pion:=1;\r
+ if (rep='2') or (rep = 'O') or (rep = 'o') then sec1:=1;\r
+ if souris then attach(joueur1_s) else attach(joueur1);fi;\r
+ fi;\r
+ if (rep = 'N') or (rep = 'n') then sec1:=2;attach(joueur3);fi;\r
+ if arreter then exit fi;\r
+ if plateau(lig,col)=0 then\r
+ call peut_on_poser_pion(lig,col,pion,plateau,true,false,nb,som_prio);\r
+ if nb<>0 then nb_case_vide:=nb_case_vide-1;exit;fi;\r
+ fi;\r
+ od;\r
+ if arreter then exit fi;\r
+ write(chr(27),"[33m");\r
+ call gotoxy(4+2*(ii-1),5+5*(jj-1));\r
+ write("x");\r
+ write(chr(27),"[36m");\r
+ call pause(sec1);\r
+ call affichegrille(plateau);\r
+ call compte_pion(plateau,nb_pion_blanc,nb_pion_noir);\r
+ if nb_pion_blanc=0 then exit;fi;\r
+ call aff_nb_pion;\r
+ fi;\r
+\r
+ if (nb_blanc_poser=0) and (nb_noir_poser=0) then exit;fi;\r
+ call nb_de_pion_a_poser(2,plateau,false,nb_blanc_poser,som_prio);\r
+ if nb_blanc_poser=0 then if nb_case_vide<>0 then\r
+ call gotoxy(10,46);\r
+ writeln("Les blancs ne peuvent pas jouer !");\r
+ call gotoxy(xx,yy);\r
+ call pause(2);\r
+ call gotoxy(10,46);\r
+ writeln(" ");\r
+ call gotoxy(xx,yy);fi;\r
+ fi;\r
+ if nb_blanc_poser<>0 then\r
+ do\r
+ (* pion blanc *)\r
+ pion:=2;\r
+ if (rep='2') or (rep = 'N') or (rep = 'n') then sec2:=1;\r
+ if souris then attach(joueur2_s) else attach(joueur2);fi;\r
+ fi;\r
+ if (rep = 'O') or (rep = 'o') then sec2:=2;attach(joueur3);fi;\r
+ if arreter then exit fi;\r
+ if plateau(lig,col)=0 then\r
+ call peut_on_poser_pion(lig,col,pion,plateau,true,false,nb,som_prio);\r
+ if nb<>0 then nb_case_vide:=nb_case_vide-1;exit;fi;\r
+ fi;\r
+ od;\r
+ if arreter then exit fi;\r
+ write(chr(27),"[32m");\r
+ call gotoxy(4+2*(ii-1),5+5*(jj-1));\r
+ write("o");\r
+ write(chr(27),"[36m");\r
+ call pause(sec2);\r
+ call affichegrille(plateau);\r
+ call compte_pion(plateau,nb_pion_blanc,nb_pion_noir);\r
+ if nb_pion_noir=0 then exit;fi;\r
+ call aff_nb_pion;\r
+ fi;\r
+\r
+ if (nb_blanc_poser=0) and (nb_noir_poser=0) then exit;fi;\r
+ if nb_case_vide=0 then exit;fi;\r
+ od;\r
+\r
+if not arreter then\r
+call aff_nb_pion;\r
+call gotoxy(13,54);\r
+writeln("FIN DE LA PARTIE");\r
+call compte_pion(plateau,nb_pion_blanc,nb_pion_noir);\r
+if nb_pion_blanc=nb_pion_noir then call gotoxy(16,46);\r
+ writeln(" Match nul !");fi;\r
+if nb_pion_blanc<nb_pion_noir then\r
+ call gotoxy(15,46);\r
+ writeln("Les noirs gagnent la partie avec ");\r
+ call gotoxy(16,46);\r
+ writeln(nb_pion_noir," pions noirs contre ");\r
+ call gotoxy(17,46);\r
+ writeln(nb_pion_blanc," pions blancs.");\r
+fi;\r
+if nb_pion_blanc>nb_pion_noir then\r
+ call gotoxy(15,46);\r
+ writeln("Les blancs gagnent la partie avec ");\r
+ call gotoxy(16,46);\r
+ writeln(nb_pion_blanc," pions blancs contre ");\r
+ call gotoxy(17,46);\r
+ writeln(nb_pion_noir," pions noirs.");\r
+fi;\r
+\r
+(* destruction des coroutines *)\r
+if (rep = 'O') orif (rep = 'o') then\r
+ kill (joueur1);\r
+ kill (joueur3);\r
+fi;\r
+if (rep = 'N') orif (rep = 'n') then\r
+ kill (joueur3);\r
+ kill (joueur2);\r
+fi;\r
+if (rep ='2') then\r
+ kill (joueur1);\r
+ kill (joueur2);\r
+fi;\r
+\r
+call gotoxy(19,54);\r
+write(chr(27),"[33m");\r
+writeln("- Faites Retour - ");\r
+read(bidon);\r
+fi;\r
+call newpage;\r
+call normal;\r
+rep := ' ';\r
+ while (rep <> 'o') and (rep <> 'n') and (rep <> 'O') and (rep <> 'N')\r
+ do\r
+ call newpage;\r
+ call gotoxy(8,1);\r
+ writeln(" Voulez_vous faire une autre partie (O ou N) ? ");\r
+ writeln;\r
+ write(" Votre choix : ");\r
+ readln(rep);\r
+ od;\r
+if rep='n' or rep='N' then exit;fi;\r
+od;\r
+call newpage;\r
+write(chr(27),"[33m");\r
+call gotoxy(9,25);\r
+writeln("ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ");\r
+call gotoxy(10,25);\r
+writeln("³ ³ ");\r
+call gotoxy(11,25);\r
+writeln("³ P A P A ! ³ ");\r
+call gotoxy(12,25);\r
+writeln("³ ³ ");\r
+call gotoxy(13,25);\r
+writeln("ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ");\r
+call pause(1);\r
+call normal;\r
+call newpage;\r
+end othello\1a
\ No newline at end of file
--- /dev/null
+\r
+Program chinois;\r
+const blanc=15,bleu=1,vert=2,vertpetrole=3,rouge=4,violet=5,marron=6,grisclair=7,\r
+ grisfonce=8,bleuroi=9,vertclair=10,free=-1;\r
+\r
+ \r
+ UNIT coord2D:class(x,y:integer);\r
+ end;\r
+ \r
+ UNIT coord3D:class(x,y,h:integer);\r
+ end;\r
+\r
+\r
+UNIT gestion_caractere: IIUWGRAPH class;\r
+\r
+ UNIT SAISIE:function(ti,e,x,y:integer):arrayof char;\r
+ var i,n:integer,\r
+ c: integer,\r
+ t :arrayof char;\r
+ begin\r
+ \r
+ array t dim(1:e);\r
+ for i:=1 to e do\r
+ t(i):=' ';\r
+ od;\r
+ \r
+ do\r
+ i:=1;\r
+ c:=inkey;\r
+ while c<>13 and c<>27 and i<=e do\r
+ \r
+ case ti\r
+ when 1:\r
+ if c>=48 and c<=57 then\r
+ t(i):=chr(c);\r
+ call move(x+i*9,y);\r
+ call hascii(c);\r
+ i:=i+1;\r
+ fi;\r
+ when 2:\r
+ \r
+ if c>64 then\r
+ t(i):=chr(c);\r
+ call move(x+i*9,y);\r
+ call hascii(c);\r
+ i:=i+1;\r
+ fi;\r
+ esac;\r
+ c:=inkey;\r
+ od;\r
+ if t(1)<>' ' then exit; fi;\r
+ od;\r
+ result:=t;\r
+ end SAISIE;\r
+\r
+ UNIT ConvEnt:function(t:arrayof char):integer;\r
+ var n,i:integer;\r
+ begin\r
+ n:=0;\r
+ for i:=1 to upper(t) do\r
+ if t(i)<>' ' then\r
+ n:=n*10+(ord(t(i))-48);\r
+ fi;\r
+ od;\r
+ \r
+ result:=n;\r
+ end ConvEnt;\r
+\r
+ UNIT displaystring:procedure(t:arrayof char,x,y,coul:integer);\r
+ var i:integer;\r
+ begin\r
+ call color(coul); \r
+ for i:=1 to upper(t)\r
+ do\r
+ call move(x+i*9,y);\r
+ call hascii(ord(t(i)));\r
+ od; \r
+ end; \r
+END;\r
+\r
+\r
+UNIT element:class;\r
+var x,i,j,h:integer;\r
+END;\r
+\r
+\r
+UNIT ARBTAS : class; (* structure utilis\82e par la coroutine ordinateur *)\r
+\r
+ var tab : arrayof element, (* tableau contenant les elements du tas *)\r
+ nb : integer, (* entier le nombre d'elements du tas *)\r
+ dimen: integer;\r
+ (* fonction testant si le tas est vide ou non *)\r
+ unit vide : function : boolean; \r
+ begin\r
+ if (tab(1) = none)\r
+ then result := true;\r
+ fi;\r
+ end vide;\r
+\r
+ (* fonction retournant le minimum du tas *)\r
+ unit mini : function : element;\r
+ begin\r
+ if not vide\r
+ then result := tab(1);\r
+ fi;\r
+ end mini;\r
+\r
+ (* fonction retournant la position d'un element dans le tas *)\r
+ unit membre : function(elem:element) : integer;\r
+ var i : integer;\r
+ begin\r
+ if not vide\r
+ then for i:=1 to nb\r
+ do\r
+ if tab(i).x = elem.x\r
+ then result := i;\r
+ exit;\r
+ fi;\r
+ od;\r
+ fi;\r
+ end membre;\r
+\r
+ (* procedure pour inserer un nouvel element dans le tas *)\r
+ unit inserer : procedure(elem : element);\r
+ var i : integer,\r
+ aux : element,\r
+ tabaux : arrayof element;\r
+ begin\r
+ if (nb >= dimen) (* on aggrandit le tableau trop petit *)\r
+ then array tabaux dim (1:nb+1);\r
+ for i:=1 to nb \r
+ do\r
+ tabaux(i) := tab(i);\r
+ od;\r
+ tab := tabaux;\r
+ dimen := dimen + 1; (* la dimension du tableau est *)\r
+ (* incremente de 1 *) \r
+ fi;\r
+ nb := nb + 1; (* le nombre d'elements est incremente de 1 *)\r
+ tab(nb) := elem; (* l'element a inserer est place a la fin *)\r
+ i := nb;\r
+ aux := new element;\r
+ do (* on effectue des echanges tant que le fils est inferieur *)\r
+ (* au pere *) \r
+ if (i <= 1 ) orif ( tab(i).x >= tab(i div 2).x )\r
+ then exit;\r
+ fi;\r
+ aux := tab(i DIV 2); (* echange pere-fils *)\r
+ tab(i DIV 2) := tab(i);\r
+ tab(i) := aux;\r
+ i := i div 2;\r
+ od;\r
+ end inserer;\r
+\r
+ (* procedure pour supprimer un element du tas *)\r
+ unit supprimer : procedure(elem : element);\r
+ var i,j : integer,\r
+ aux : element;\r
+ begin\r
+ i := membre(elem);\r
+ if ( i <> 0 ) (* on teste si l'element appartient au tas *) \r
+ then kill(tab(i));\r
+ tab(i) := tab(nb); (* le dernier element est place *)\r
+ (* a l'endroit de l'element supprime *) \r
+ nb := nb - 1; (* on decremente le nombre d'elements *)\r
+ aux := new element;\r
+\r
+ while ( i <= (nb div 2) )\r
+ do (* tant que tab(i) n'est pas une feuille *)\r
+\r
+ if (2*i = nb) orif (tab(2*i).x < tab(2*i + 1).x)\r
+ then j := 2*i; (* on calcule l'indice du plus petit *)\r
+ else j := 2*i + 1; (* des 2 fils *)\r
+ fi;\r
+\r
+ if tab(i).x > tab(j).x\r
+ then aux := tab(i); (* echange si la condition d'ordre *)\r
+ tab(i) := tab(j);(* n'est pas satisfaite *)\r
+ tab(j) := aux;\r
+ i := j;\r
+ else exit;\r
+ fi;\r
+ od;\r
+ tab(nb + 1) := none; (* le dernier element est supprime *)\r
+ fi;\r
+ end supprimer;\r
+\r
+begin\r
+ array tab dim (1:10);\r
+ nb := 0;\r
+ dimen:=10;\r
+end ARBTAS;\r
+\r
+\r
+\r
+UNIT elem:class(i,j,k:integer);\r
+var prec:elem;\r
+end;\r
+\r
+\r
+UNIT pile:class; (* structure utilis\82e par la coroutine controle*)\r
+ var pointeur:elem;\r
+\r
+ UNIT empiler:procedure(e:elem);\r
+ begin\r
+ e.prec:=pointeur;\r
+ pointeur:=e;\r
+ end;\r
+\r
+ UNIT depiler:procedure;\r
+ var tampon:elem;\r
+ begin\r
+ if not vide then\r
+ tampon:=pointeur;\r
+ pointeur:=pointeur.prec;\r
+ kill(tampon);\r
+ fi;\r
+ end;\r
+\r
+ UNIT sommet:function:elem;\r
+ begin\r
+ result:=pointeur;\r
+ end;\r
+\r
+ UNIT vide:function:boolean;\r
+ begin\r
+ result:=(pointeur=none);\r
+ end;\r
+begin\r
+pointeur:=none;\r
+END;\r
+\r
+UNIT drawrect: IIUWGRAPH procedure(x1,y1,x2,y2,couleur:integer);\r
+begin\r
+ call color(couleur);\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1);\r
+end;\r
+\r
+\r
+UNIT player: gestion_caractere class(couleur:integer,pl:plateau_jeu);\r
+END; \r
+\r
+\r
+\r
+UNIT ordi: player coroutine;\r
+\r
+var coinlibre,find:boolean,\r
+ coin,c,quel,version:integer,\r
+ place:coord3D,\r
+ pos:integer,cointab:arrayof coord2D,\r
+ posajouer:arrayof arrayof integer,\r
+ mem:arbtas,\r
+ adver,moi:arrayof info;\r
+ \r
+\r
+\r
+UNIT info: class(n,sur:integer);\r
+var rangee:arrayof arrayof combinaison;\r
+begin\r
+\r
+ block\r
+ var i,j:integer;\r
+ \r
+ begin\r
+ array rangee dim(1:n);\r
+ for i:=1 to n do array rangee(i) dim (1:sur); od;\r
+ for i:=1 to n do\r
+ for j:=1 to sur do\r
+ rangee(i,j):=new combinaison;\r
+ od;\r
+ od;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+UNIT find_place:function(quoi,l,x,h:integer;inout p:coord3D):boolean;\r
+const ligne=1,colonne=2,lignediag=3,coldiag=4,axe=5,dbdiag=7,bigdiag=6;\r
+var i:integer,\r
+ trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ case quoi\r
+ \r
+ when dbdiag:\r
+ \r
+ case x\r
+ when 1:\r
+ case h\r
+ when 1:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,i,i)=free then\r
+ if i=posajouer(i,i) then trouve:=true; \r
+ p.x:=i;p.y:=i;p.h:=i;\r
+ exit; fi;\r
+ fi;\r
+ od;\r
+ when 2:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,i,(4-i)+1)=free then\r
+ if posajouer(i,i)=(4-i)+1 then trouve:=true; \r
+ p.x:=i;p.y:=i;p.h:=(4-i)+1;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ esac; \r
+ when 2:\r
+ case h\r
+ when 1:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,(4-i)+1,i)=free then\r
+ if i=posajouer(i,(4-i)+1) then trouve:=true; \r
+ p.x:=i;p.y:=(4-i)+1;p.h:=i;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ when 2:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,(4-i)+1,(4-i)+1)=free then\r
+ if posajouer(i,(4-i)+1)=(4-i)+1 then trouve:=true; \r
+ p.x:=i;p.y:=(4-i)+1;p.h:=(4-i)+1;\r
+ exit;\r
+ fi;\r
+ fi;\r
+ od;\r
+ esac;\r
+ esac;\r
+\r
+ when bigdiag:\r
+ \r
+ case l\r
+ when 1:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,i,h)=free then\r
+ if h=posajouer(i,i) then trouve:=true; \r
+ p.x:=i;p.y:=i;p.h:=h;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ when 2:\r
+ for i:=1 TO 4 do\r
+ if pl.jeu(i,(4-i)+1,h)=free then\r
+ if h=posajouer(i,(4-i)+1) then trouve:=true; \r
+ p.x:=i;p.y:=(4-i)+1;p.h:=h;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ esac;\r
+ when ligne: (* recherche d'une place dans la ligne sp\82cifi\82e *)\r
+ for i:=1 to 4 do\r
+ if pl.jeu(x,i,h)=free then \r
+ if h=posajouer(x,i) then trouve:=true; fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ if trouve then\r
+ p.x:=x;\r
+ p.y:=i;\r
+ p.h:=posajouer(x,i);\r
+\r
+ fi;\r
+ when colonne: (* recherche d'une place dans la colonne sp\82cifi\82e *)\r
+ for i:=1 to 4 do\r
+ if pl.jeu(i,x,h)=free then \r
+ if posajouer(i,x)=h then trouve:=true; \r
+ p.x:=i;p.y:=x;p.h:=posajouer(i,x);\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+\r
+ \r
+\r
+ when lignediag:(* recherche d'une place dans la diagonnal ligne sp\82cifi\82e *)\r
+ case l\r
+ when 1: for i:=1 to 4 do\r
+ if pl.jeu(x,i,i)=free then \r
+ if posajouer(x,i)=i then trouve:=true;\r
+ p.x:=x;p.y:=i;p.h:=i;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ \r
+\r
+ when 2: for i:=1 to 4 do\r
+ if pl.jeu(x,i,(4-i)+1)=free then \r
+ if posajouer(x,i)=(4-i)+1 then trouve:=true;\r
+ p.x:=x;p.y:=i;p.h:=(4-i)+1;\r
+ fi;\r
+ exit; \r
+ fi;\r
+ od;\r
+ \r
+\r
+ esac;\r
+ when axe: (* recherche d'une place dans l'axe sp\82cifi\82e *)\r
+ if posajouer(x,h)<>5 then\r
+ p.x:=x;\r
+ p.y:=h;\r
+ p.h:=posajouer(x,h);\r
+ trouve:=true;\r
+ fi;\r
+ when coldiag:(* recherche d'une place dans la diagonnal colonne sp\82cifi\82e *)\r
+ case l\r
+ when 1: for i:=1 to 4 do\r
+ if pl.jeu(i,x,i)=free then \r
+ if posajouer(i,x)=i then trouve:=true;\r
+ p.x:=i;p.y:=x;p.h:=i;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ \r
+\r
+ when 2: for i:=1 to 4 do\r
+ if pl.jeu(i,x,(4-i)+1)=free then \r
+ if posajouer(i,x)=(4-i)+1 then trouve:=true;\r
+ p.x:=i;p.y:=x;p.h:=(4-i)+1;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ esac;\r
+\r
+ esac;\r
+ result:=trouve;\r
+ \r
+end;\r
+\r
+UNIT isintwodiag:function(x,y,h:integer;inout a,b:integer):boolean;\r
+var trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ if (h=x) and (x=y) then trouve:=true;\r
+ a:=1;b:=1;\r
+ else \r
+ if (x=y) and (h=(4-x)+1) then trouve:=true;\r
+ a:=1;b:=2;\r
+ else\r
+ if (x=(4-y)+1) and (h=x) then trouve:=true; \r
+ a:=2;b:=1;\r
+ else\r
+ if (x=(4-y)+1) and (h=y) then trouve:=true; \r
+ a:=2;b:=2;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ result:=trouve;\r
+end;\r
+\r
+UNIT isinbigdiag:function(x,y:integer;inout quel:integer):boolean;\r
+const droite=1,gauche=2;\r
+var i:integer,\r
+ trouve:boolean;\r
+begin\r
+ quel:=0;\r
+ trouve:=false;\r
+ if (x=y) then trouve:=true; \r
+ quel:=1;\r
+ else\r
+ if (x=(4-y)+1) then trouve:=true; \r
+ quel:=2 \r
+ fi;\r
+ fi; \r
+ \r
+ result:=trouve;\r
+end;\r
+\r
+\r
+UNIT isindiag:function(l,h:integer;inout dg:integer):boolean;\r
+var trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ if h=l then trouve:=true; \r
+ dg:=1;\r
+ else\r
+ if h=(4-l)+1 then trouve:=true; \r
+ dg:=2;\r
+ fi;\r
+ fi;\r
+ result:=trouve;\r
+end;\r
+\r
+\r
+unit troisboules:function(tab:arrayof info;inout p:coord3D):boolean;\r
+var i,j:integer,\r
+ trouve:boolean;\r
+begin\r
+ trouve:=false;\r
+ if p<>none then \r
+ \r
+\r
+ if tab(1).rangee(p.x,p.h).nbre_boule=3 then\r
+ trouve:=find_place(1,0,p.x,p.h,p);\r
+ \r
+ else if tab(2).rangee(p.y,p.h).nbre_boule=3 then\r
+ trouve:=find_place(2,0,p.y,p.h,p);\r
+ \r
+ else \r
+ if tab(5).rangee(p.x,p.y).nbre_boule=3 then\r
+ trouve:=find_place(5,0,p.x,p.y,p);\r
+ \r
+ else \r
+ if isinbigdiag(p.x,p.y,i) then\r
+ if tab(6).rangee(p.h,i).nbre_boule=3 then\r
+ trouve:=find_place(6,i,p.x,p.h,p);\r
+ fi;\r
+ fi;\r
+ if isintwodiag(p.x,p.y,p.h,i,j) then\r
+ if tab(7).rangee(i,j).nbre_boule=3 then \r
+ trouve:=find_place(7,0,i,j,p);\r
+ fi;\r
+ fi;\r
+ for i:=1 to 2 do\r
+ if tab(3).rangee(p.x,i).nbre_boule=3 then\r
+ trouve:=find_place(3,i,p.y,p.h,p);\r
+ exit; fi; \r
+ if tab(4).rangee(p.y,i).nbre_boule=3 then \r
+ trouve:=find_place(4,i,p.x,p.h,p);\r
+ exit; fi;\r
+ od; \r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi; \r
+ result:=trouve;\r
+end;\r
+\r
+UNIT addcombinaison:procedure(tab:arrayof info,x,y,h:integer);\r
+begin\r
+\r
+ call tab(1).rangee(x,h).plus; \r
+ call tab(2).rangee(y,h).plus; \r
+ call tab(5).rangee(x,y).plus;\r
+ if isindiag(y,h,quel) then\r
+ call tab(3).rangee(x,quel).plus;\r
+ fi; \r
+ if isindiag(x,h,quel) then\r
+ call tab(4).rangee(y,quel).plus;\r
+ fi; \r
+ if isinbigdiag(x,y,quel) then\r
+ call tab(6).rangee(h,quel).plus;\r
+ fi;\r
+ if isintwodiag(x,y,h,quel,version) then\r
+ call tab(7).rangee(quel,version).plus;\r
+ fi;\r
+\r
+end;\r
+UNIT delcombinaison:procedure(tab:arrayof info,x,y,h:integer);\r
+var quel,version:integer;\r
+begin\r
+\r
+ (* si une boule a deja ete mise *)\r
+ call tab(1).rangee(x,h).elimine;\r
+ call tab(2).rangee(y,h).elimine;\r
+ \r
+ if isindiag(y,h,version) then (* diagonnale ligne*)\r
+ call tab(3).rangee(x,version).elimine; fi;\r
+ if isindiag(x,h,version) then (* diagonnale colonne*)\r
+ call tab(4).rangee(y,version).elimine; fi;\r
+ call tab(5).rangee(x,y).elimine;\r
+ if isinbigdiag(x,y,quel) then\r
+ call tab(6).rangee(h,quel).elimine; fi;\r
+ if isintwodiag(x,y,h,quel,version) then\r
+ call tab(7).rangee(quel,version).elimine; fi;\r
+end;\r
+\r
+UNIT selectcoup: procedure(inout p:coord3D);\r
+var coup:element,\r
+ trouve,bien:boolean;\r
+ \r
+begin\r
+ trouve:=false;\r
+ while (not mem.vide) and (not trouve) do\r
+ coup:=mem.mini;\r
+ \r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)+1;\r
+ p.x:=coup.i;\r
+ p.y:=coup.j;\r
+ p.h:=coup.h+1;\r
+ if p.h<>5 then \r
+ if not troisboules(adver,p) then \r
+ p.h:=coup.h;\r
+ p.x:=coup.i;\r
+ p.y:=coup.j;\r
+ trouve:=true;\r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)-1;\r
+ else \r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)-1;\r
+ call mem.supprimer(coup);\r
+ fi;\r
+ else trouve:=true;\r
+ p.h:=coup.h;\r
+ posajouer(coup.i,coup.j):=posajouer(coup.i,coup.j)-1;\r
+ fi;\r
+ od;\r
+ while not mem.vide do\r
+ call mem.supprimer(mem.mini);\r
+ od;\r
+end;\r
+\r
+\r
+UNIT stratego:procedure;\r
+var coup:coord3D,\r
+ e:element,\r
+ poid,n,version,quel,x,i,j:integer;\r
+begin\r
+\r
+ for i:=1 to 4 do\r
+ for j:=1 to 4 do\r
+ if posajouer(i,j)<5 then\r
+ coup:=new coord3D(i,j,posajouer(i,j));\r
+\r
+ poid:=0;\r
+ n:=0;\r
+ \r
+ \r
+ if moi(1).rangee(coup.x,coup.h).possible then \r
+ case moi(1).rangee(coup.x,coup.h).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(1).rangee(coup.x,coup.h).nbre_boule;\r
+ esac; \r
+ n:=n+1;\r
+ fi;\r
+ if moi(2).rangee(coup.y,coup.h).possible then\r
+ case moi(2).rangee(coup.y,coup.h).nbre_boule \r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=moi(2).rangee(coup.y,coup.h).nbre_boule+poid;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ \r
+ if isindiag(coup.y,coup.h,quel) then\r
+ if moi(3).rangee(coup.x,quel).possible then\r
+ case moi(3).rangee(coup.x,quel).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(3).rangee(coup.x,quel).nbre_boule;\r
+ esac;\r
+ n:=n+1; \r
+ fi; \r
+ fi;\r
+ if isindiag(coup.x,coup.h,quel) then\r
+ if moi(4).rangee(coup.y,quel).possible then \r
+ case moi(4).rangee(coup.y,quel).nbre_boule \r
+ when 3: poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(4).rangee(coup.y,quel).nbre_boule; \r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ \r
+ if moi(5).rangee(coup.x,coup.y).possible then\r
+ case moi(5).rangee(coup.x,coup.y).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(5).rangee(coup.x,coup.y).nbre_boule;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ if isinbigdiag(coup.x,coup.y,quel) then\r
+ if moi(6).rangee(coup.h,quel).possible then\r
+ case moi(6).rangee(coup.h,quel).nbre_boule\r
+ when 3: poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(6).rangee(coup.h,quel).nbre_boule;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ if isintwodiag(coup.x,coup.y,coup.h,quel,version) then\r
+ if moi(7).rangee(quel,version).possible then\r
+ case moi(7).rangee(quel,version).nbre_boule\r
+ when 3:poid:=poid+100;\r
+ otherwise\r
+ poid:=poid+moi(7).rangee(quel,version).nbre_boule;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+\r
+ if adver(1).rangee(coup.x,coup.h).possible and \r
+ adver(2).rangee(coup.y,coup.h).possible then \r
+ if adver(1).rangee(coup.x,coup.h).nbre_boule=2 and\r
+ adver(2).rangee(coup.y,coup.h).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ if adver(1).rangee(coup.x,coup.h).possible and \r
+ isindiag(coup.x,coup.h,quel) then\r
+\r
+ if adver(4).rangee(coup.y,quel).possible then \r
+ if adver(1).rangee(coup.x,coup.h).nbre_boule=2 and\r
+ adver(4).rangee(coup.y,quel).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ \r
+ x:=coup.x;\r
+ for c:=1 to 2 do\r
+ if adver(c).rangee(x,coup.h).possible and \r
+ adver(5).rangee(coup.x,coup.y).possible then \r
+ if adver(c).rangee(x,coup.h).nbre_boule=2 and\r
+ adver(5).rangee(coup.x,coup.y).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ if adver(c).rangee(x,coup.h).possible and \r
+ isinbigdiag(coup.x,coup.y,quel) then\r
+\r
+ if adver(6).rangee(coup.h,quel).possible then \r
+ if adver(c).rangee(x,coup.h).nbre_boule=2 and\r
+ adver(6).rangee(coup.h,quel).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ if adver(c).rangee(x,coup.h).possible and \r
+ isintwodiag(coup.x,coup.y,coup.h,quel,version) then\r
+\r
+ if adver(7).rangee(quel,version).possible then \r
+ if adver(c).rangee(x,coup.h).nbre_boule=2 and\r
+ adver(7).rangee(quel,version).nbre_boule=2 then\r
+ poid:=poid+20;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ x:=coup.y;\r
+ od;\r
+\r
+ if adver(1).rangee(coup.x,coup.h).possible then \r
+ case adver(1).rangee(coup.x,coup.h).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ if adver(2).rangee(coup.y,coup.h).possible then\r
+ case adver(2).rangee(coup.y,coup.h).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise \r
+ poid:=1+poid;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ \r
+ if isindiag(coup.y,coup.h,quel) then\r
+ if adver(3).rangee(coup.x,quel).possible then\r
+ case adver(3).rangee(coup.x,quel).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1; \r
+ fi; \r
+ fi;\r
+ if isindiag(coup.x,coup.h,quel) then\r
+ if adver(4).rangee(coup.y,quel).possible then \r
+ case adver(4).rangee(coup.y,quel).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1; \r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ \r
+ if adver(5).rangee(coup.x,coup.y).possible then\r
+ case adver(5).rangee(coup.x,coup.y).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ if isinbigdiag(coup.x,coup.y,quel) then\r
+ if adver(6).rangee(coup.h,quel).possible then\r
+ case adver(6).rangee(coup.h,quel).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ if isintwodiag(coup.x,coup.y,coup.h,quel,version) then\r
+ if adver(7).rangee(quel,version).possible then\r
+ case adver(7).rangee(quel,version).nbre_boule\r
+ when 3:poid:=poid+80;\r
+ otherwise\r
+ poid:=poid+1;\r
+ esac;\r
+ n:=n+1;\r
+ fi;\r
+ fi;\r
+ if coinlibre and poid<20 then\r
+ do\r
+ pos:=round(random*3)+1;\r
+ coup.x:=cointab(pos).x;\r
+ coup.y:=cointab(pos).y;\r
+ coup.h:=1;\r
+\r
+ if pl.jeu(coup.x,coup.y,coup.h)=free then \r
+ coin:=coin-1;poid:=poid+20;\r
+ if coin=0 then coinlibre:=false; fi;\r
+ exit; fi;\r
+ \r
+ od;\r
+ fi;\r
+ poid:=(-poid);\r
+ e:=new element;\r
+ e.x:=poid; e.i:=coup.x;e.j:=coup.y;e.h:=coup.h;\r
+ call mem.inserer(e);\r
+ \r
+ fi;\r
+ od;\r
+ od;\r
+end;\r
+\r
+unit combinaison:class;\r
+ var nb:integer,\r
+ possible:boolean;\r
+ \r
+ unit incremente:function:integer;\r
+ begin \r
+ nb:=nb+1;\r
+ result:=nb;\r
+ end;\r
+ \r
+ unit plus:procedure;\r
+ begin \r
+ nb:=nb+1;\r
+ end;\r
+ \r
+ unit nbre_boule:function:integer;\r
+ begin\r
+ result:=nb;\r
+ end;\r
+\r
+ unit elimine:procedure;\r
+ begin\r
+ possible:=false;\r
+ end;\r
+\r
+begin\r
+ nb:=0;\r
+ possible:=true;\r
+END;\r
+\r
+begin\r
+ mem:=new arbtas;\r
+ array cointab dim(1:4);\r
+ cointab(1):=new coord2D(1,1);\r
+ cointab(2):=new coord2D(4,4);\r
+ cointab(3):=new coord2D(1,4);\r
+ cointab(4):=new coord2D(4,1);\r
+ coinlibre:=true;\r
+ coin:=4;\r
+ block\r
+ var i,j:integer;\r
+ begin\r
+ array adver dim (1:7);\r
+ array moi dim (1:7);\r
+ \r
+ array posajouer dim(1:4);\r
+ for i:=1 to 4 do\r
+ \r
+ array posajouer(i) dim(1:4);\r
+ \r
+ if (i<3) then\r
+ adver(i):=new info(4,4);\r
+ moi(i):=new info(4,4);\r
+ else\r
+ adver(i):=new info(4,2);\r
+ moi(i):=new info(4,2);\r
+ fi;\r
+ \r
+ od; \r
+ adver(5):=new info(4,4);\r
+ moi(5):=new info(4,4);\r
+ adver(6):=new info(4,2);\r
+ moi(6):=new info(4,2);\r
+ adver(7):=new info(2,2);\r
+ moi(7):=new info(2,2);\r
+\r
+\r
+ for i:=1 to 4 do\r
+ for j:=1 to 4 do\r
+ posajouer(i,j):=1;\r
+ od;\r
+ od;\r
+ end;\r
+\r
+ return;\r
+ place:=new coord3D(1,1,1);\r
+ DO \r
+ find:=false;\r
+ call pl.arrow.ligne(pl.line,0);\r
+ call pl.arrow.colonne(pl.col,0);\r
+ \r
+ (*****************************************)\r
+ (* elimination de quelques combinaisons *)\r
+ (*****************************************) \r
+ if pl.haut<>0 then \r
+ call addcombinaison(adver,pl.line,pl.col,pl.haut); \r
+ call delcombinaison(moi,pl.line,pl.col,pl.haut);\r
+ posajouer(pl.line,pl.col):=posajouer(pl.line,pl.col)+1;\r
+\r
+\r
+ (*********************************)\r
+ (*** est ce que j'ai gagne ? !!!!*)\r
+ (*********************************)\r
+ \r
+ find:=troisboules(moi,place);\r
+ \r
+ (*********************************)\r
+ (* contre des 3 boules align\82es *)\r
+ (*********************************) \r
+ if (pl.haut=1 and \r
+ ((pl.line=4 or pl.line=1) and (pl.col=1 or pl.col=4))) then\r
+ coin:=coin-1; fi;\r
+ if coin=0 then coinlibre:=false; fi;\r
+ \r
+ if not find then\r
+ \r
+ if (adver(1).rangee(pl.line,pl.haut).nbre_boule=3) and \r
+ (adver(1).rangee(pl.line,pl.haut).possible) then \r
+ find:=find_place(1,0,pl.line,pl.haut,place);\r
+ \r
+ fi; \r
+ if (adver(2).rangee(pl.col,pl.haut).nbre_boule=3) and \r
+ (adver(2).rangee(pl.col,pl.haut).possible) then \r
+ find:=find_place(2,0,pl.col,pl.haut,place);\r
+ \r
+ fi;\r
+ if (adver(5).rangee(pl.line,pl.col).nbre_boule=3) and \r
+ (adver(5).rangee(pl.line,pl.col).possible) then \r
+ find:=find_place(5,0,pl.line,pl.col,place);\r
+ \r
+ fi;\r
+ \r
+ if isindiag(pl.col,pl.haut,quel) then\r
+ \r
+ if (adver(3).rangee(pl.line,quel).nbre_boule=3) and\r
+ (adver(3).rangee(pl.line,quel).possible) then \r
+ find:=find_place(3,quel,pl.line,pl.haut,place);\r
+ fi;\r
+ fi; \r
+ if isindiag(pl.line,pl.haut,quel) then\r
+ \r
+ if (adver(4).rangee(pl.col,quel).nbre_boule=3) and\r
+ (adver(4).rangee(pl.col,quel).possible) then\r
+ find:=find_place(4,quel,pl.col,pl.haut,place);\r
+ fi;\r
+ \r
+ fi; \r
+ if isinbigdiag(pl.line,pl.col,quel) then\r
+ if (adver(6).rangee(pl.haut,quel).nbre_boule=3) and\r
+ (adver(6).rangee(pl.haut,quel).possible) then \r
+ find:=find_place(6,quel,pl.line,pl.haut,place);\r
+ fi;\r
+ fi;\r
+ if isintwodiag(pl.line,pl.col,pl.haut,quel,version) then\r
+ if (adver(7).rangee(quel,version).nbre_boule=3) and\r
+ (adver(7).rangee(quel,version).possible) then\r
+ find:=find_place(7,0,quel,version,place);\r
+ fi;\r
+ fi;\r
+ fi;\r
+\r
+ fi;\r
+ (******************************************)\r
+ (* jouer les coins du niveau 1 en premier *)\r
+ (******************************************)\r
+ \r
+ \r
+ IF not find then \r
+ \r
+ \r
+ (*********************)\r
+ (* quel coup jouer ? *)\r
+ (*********************)\r
+ call stratego; (* evaluation de toutes les combinaisons*)\r
+ call selectcoup(place); (* choisi un coup a jouer *)\r
+ \r
+ FI;\r
+ \r
+ (*****************************************)\r
+ (* on incremente le nombre de boules... *)\r
+ (*****************************************)\r
+ call addcombinaison(moi,place.x,place.y,place.h);\r
+ call delcombinaison(adver,place.x,place.y,place.h);\r
+ posajouer(place.x,place.y):=posajouer(place.x,place.y)+1;\r
+\r
+ \r
+ \r
+ if pl.enfiler(place.x,place.y,couleur) then \r
+ call pl.arrow.ligne(place.x,blanc);\r
+ call pl.arrow.colonne(place.y,blanc);\r
+ fi;\r
+ \r
+ \r
+ detach;\r
+ od;\r
+end;\r
+\r
+UNIT humain:player COROUTINE;\r
+ var i,j:integer;\r
+ begin\r
+ i,j:=1;\r
+ return;\r
+ do\r
+ \r
+ do\r
+ \r
+ call pl.arrow.selectaxe(i,j);\r
+ if pl.enfiler(i,j,couleur) then exit; fi;\r
+ od;\r
+ detach;\r
+ od;\r
+ \r
+ end;\r
+ \r
+UNIT joueurs:class;\r
+var couleur:integer,\r
+ joueur:player,\r
+ nom:arrayof char;\r
+begin\r
+array nom dim(1:8);\r
+end;\r
+\r
+\r
+UNIT controle:iiuwgraph coroutine(equipe:arrayof joueurs,pl:Plateau_Jeu);\r
+var tour:integer,\r
+ aux: arrayof arrayof arrayof integer,\r
+ difference: pile,\r
+ pion:elem;\r
+\r
+\r
+ UNIT AquiLeTour:procedure;\r
+ begin\r
+ tour:=tour+1;\r
+ if tour=3 then tour:=1; fi;\r
+ end;\r
+\r
+ UNIT copie_jeu:procedure;\r
+ var k:integer;\r
+ begin\r
+ for k:=1 to 4 \r
+ do\r
+ aux(pl.line,pl.col,k):=pl.jeu(pl.line,pl.col,k);\r
+ od;\r
+ end;\r
+ \r
+ UNIT coup:function:boolean;\r
+ var i,j,k,n,c:integer;\r
+ \r
+ begin\r
+ call pl.arrow.ligne(pl.line,0);\r
+ call pl.arrow.colonne(pl.col,0);\r
+\r
+ n:=0;\r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ for k:=1 to 4\r
+ do\r
+ if (pl.jeu(i,j,k)<>aux(i,j,k)) then\r
+\r
+ n:=n+1; \r
+ pion:=new elem(i,j,k);\r
+ call difference.empiler(pion);\r
+ fi; \r
+ od; \r
+ od; \r
+ od; \r
+ \r
+ if n>1 or n=0 then result:=false;\r
+ else \r
+\r
+ pion:=difference.sommet;\r
+ if pl.jeu(pion.i,pion.j,pion.k)=equipe(tour).couleur then \r
+ result:=true;\r
+ pl.line:=pion.i;pl.col:=pion.j;pl.haut:=pion.k;\r
+ call pl.arrow.ligne(pl.line,blanc);\r
+ call pl.arrow.colonne(pl.col,blanc);\r
+\r
+ else result:=false;\r
+ fi;\r
+ \r
+ fi;\r
+ end;\r
+\r
+unit alignee_ligne:function(couleur:integer):integer;\r
+var a,n:integer;\r
+begin\r
+ n:=0;\r
+ for a:=1 to 4\r
+ do\r
+\r
+ if pl.jeu(a,pion.j,pion.k)=couleur then n:=n+1; fi;\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+unit colhaut:function(couleur:integer):integer;\r
+var a,n:integer;\r
+begin\r
+ n:=0;\r
+ for a:=1 to 4\r
+ do\r
+\r
+ if pl.jeu(pion.i,pion.j,a)=couleur then n:=n+1; fi;\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+\r
+unit alignee_colonne:function(couleur:integer):integer;\r
+var j,n:integer;\r
+begin\r
+ n:=0;\r
+ for j:=1 to 4\r
+ do\r
+ if pl.jeu(pion.i,j,pion.k)=couleur then n:=n+1; fi;\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+unit diag_colonne:function(dir,couleur:integer):integer;\r
+var k,i,n:integer;\r
+begin\r
+\r
+ n:=0;i:=1;\r
+ if dir=-1 then k:=4;\r
+ else k:=1;\r
+ fi;\r
+ for i:=1 to 4\r
+ do\r
+ if pl.jeu(i,pion.j,k)=couleur then n:=n+1; fi;\r
+ k:=k+(1*dir);\r
+ od;\r
+ result:=n;\r
+end;\r
+\r
+unit diagonnale: function(quel,couleur:integer):integer;\r
+var n,j,i:integer;\r
+\r
+begin\r
+ n:=0;\r
+ if quel=11 then \r
+ j:=1;\r
+ for i:=1 to 4\r
+ do\r
+ if pl.jeu(i,j,pion.k)=couleur then n:=n+1; fi;\r
+ j:=j+1;\r
+ od;\r
+ else \r
+ j:=1;\r
+ for i:=4 downto 1\r
+ do\r
+ if pl.jeu(i,j,pion.k)=couleur then n:=n+1; fi;\r
+ j:=j+1;\r
+ od;\r
+ fi;\r
+ result :=n;\r
+\r
+end;\r
+ \r
+unit doublediagonnale: function(quel,dir,couleur:integer):integer;\r
+var n,i,j,k:integer;\r
+\r
+begin\r
+ \r
+ n:=0;i:=1;\r
+ if dir=-1 then k:=4;\r
+ else k:=1;\r
+ fi;\r
+ \r
+ if quel=11 then \r
+ j:=1;\r
+ for i:=1 to 4\r
+ do\r
+ if pl.jeu(i,j,k)=couleur then n:=n+1; fi;\r
+ j:=j+1;k:=k+(1*dir);\r
+ od;\r
+ else \r
+ j:=1;\r
+ for i:=4 downto 1\r
+ do\r
+ if pl.jeu(i,j,k)=couleur then n:=n+1; fi;\r
+ j:=j+1; k:=k+(1*dir);\r
+ od;\r
+ fi;\r
+ result :=n;\r
+\r
+end;\r
+ \r
+ \r
+unit diag_ligne:function(dir,couleur:integer):integer;\r
+var k,j,n:integer;\r
+begin\r
+\r
+ n:=0;j:=1;\r
+ if dir=-1 then k:=4;\r
+ else k:=1;\r
+ fi;\r
+ for j:=1 to 4\r
+ do\r
+ if pl.jeu(pion.i,j,k)=couleur then n:=n+1; fi;\r
+ k:=k+(1*dir);\r
+ od;\r
+ result:=n;\r
+end;\r
+ \r
+\r
+UNIT gagne:function:boolean;\r
+const droite=-1,gauche=1;\r
+var rangee:boolean;\r
+ \r
+\r
+ begin\r
+ pion:=difference.sommet; \r
+ rangee:=false;\r
+ if alignee_ligne(equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if alignee_colonne(equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if diag_colonne(droite,equipe(tour).couleur)=4 then rangee:= true;fi;\r
+ if diag_colonne(gauche,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if diag_ligne(droite,equipe(tour).couleur)=4 then rangee:= true; fi;\r
+ if diag_ligne(gauche,equipe(tour).couleur)=4 then rangee:= true; fi;\r
+ \r
+ if colhaut(equipe(tour).couleur)=4 then rangee:=true; fi;\r
+\r
+ if diagonnale(11,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if doublediagonnale(11,droite,equipe(tour).couleur)=4 then rangee:=true;fi;\r
+ if doublediagonnale(11,gauche,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if diagonnale(41,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if doublediagonnale(41,droite,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+ if doublediagonnale(41,gauche,equipe(tour).couleur)=4 then rangee:=true; fi;\r
+\r
+ result:=rangee;\r
+ call difference.depiler; (* pile est maintenant vide *)\r
+ end;\r
+\r
+\r
+\r
+\r
+UNIT restore:procedure;\r
+ begin\r
+ while (not (difference.vide)) do\r
+ pion:=difference.sommet;\r
+ pl.jeu(pion.i,pion.j,pion.k):=aux(pion.i,pion.j,pion.k);\r
+ call pl.boulle(pion.i,pion.j,pion.k,aux(pion.i,pion.j,pion.k));\r
+ call difference.depiler;\r
+ od;\r
+ end;\r
+ \r
+UNIT nom_joueur: gestion_caractere procedure(nom:arrayof char,couleur:integer);\r
+ var i,j:integer;\r
+ begin\r
+ call dialog1;\r
+ call color(couleur);\r
+ for i:=1 to 20\r
+ do \r
+ call move(430,240+i);\r
+ call draw(450,240+i);\r
+ od; \r
+ call displaystring(nom,460,245,blanc);\r
+ end; \r
+\r
+begin\r
+ block\r
+ var i,j,k:integer;\r
+ begin \r
+ array aux dim(1:4);\r
+\r
+ for i:=1 to 4\r
+ do\r
+ array aux(i) dim(1:4);\r
+ for j:=1 to 4\r
+ do\r
+ array aux(i,j) dim (1:4);\r
+ od;\r
+ od;\r
+ \r
+ \r
+ \r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ for k:=1 to 4\r
+ do\r
+ aux(i,j,k):=-1;\r
+ od;\r
+ od;\r
+ od;\r
+ \r
+ end;\r
+\r
+ difference:=new pile;\r
+ call pl.initialisation;\r
+ tour:=0;\r
+ return;\r
+ \r
+ do\r
+ call AquiLeTour;\r
+ do\r
+ call nom_joueur(equipe(tour).nom,equipe(tour).couleur);\r
+ if equipe(tour).joueur is humain then \r
+ call move(450,300);\r
+ call outstring("A VOTRE TOUR !"); fi;\r
+ attach(equipe(tour).joueur);\r
+ call color(0);\r
+ call move(450,300);\r
+ call outstring(" ");\r
+ if coup then exit; \r
+ else call restore; fi;\r
+ od;\r
+ if gagne then attach(main);\r
+ else call copie_jeu; fi;\r
+ od; \r
+END; \r
+\r
+UNIT pause: IIUWGRAPH procedure(t:string,x,y,couleur:integer);\r
+var c:integer;\r
+begin\r
+ call move(x,y);\r
+ call color(couleur);\r
+ call outstring(t);\r
+ c:=inkey;\r
+ do\r
+ if c<>0 then exit; fi;\r
+ c:=inkey;\r
+ od;\r
+end;\r
+\r
+\r
+UNIT Plateau_Jeu: IIUWGRAPH class;\r
+\r
+ VAR grille:arrayof arrayof coord2D,\r
+ line,col,haut:integer,\r
+ jeu: arrayof arrayof arrayof integer;\r
+\r
+ UNIT cadre: procedure;\r
+ begin \r
+ \r
+ call move(179,321);\r
+ call draw(392,250);\r
+ call draw(282,140);\r
+ call draw(69,211);\r
+ call draw(179,321);\r
+\r
+ end;\r
+\r
+\r
+ UNIT ombre: procedure(cx,cy,cxx,cyy,fill_color:integer);\r
+ var x,y,xx,yy,i:integer;\r
+ begin\r
+ call move(cx,cy);\r
+ call draw(cxx,cyy);\r
+ xx:=cxx;\r
+ yy:=cyy;\r
+ x:=cx;\r
+ y:=cy;\r
+ for i:=1 to 109\r
+ do \r
+ x:=x+1;\r
+ y:=y+1;\r
+ xx:=xx+1;\r
+ yy:=yy+1;\r
+ call move(x,y);\r
+ call draw(xx,yy);\r
+ od;\r
+ end;\r
+ \r
+ UNIT enlever:procedure(a,b:integer);\r
+ var niveau:integer,\r
+ occupe:boolean;\r
+ begin\r
+ niveau:=4;\r
+ occupe:=false;\r
+ while not occupe do\r
+ occupe:=(jeu(a,b,niveau)<>free);\r
+ if not occupe then\r
+ niveau:=niveau-1;\r
+ fi;\r
+ od;\r
+ jeu(a,b,niveau):=free;\r
+ end;\r
+ \r
+ UNIT enfiler:function(a,b,couleur:integer):boolean;\r
+ var niveau,c:integer,\r
+ libre:boolean;\r
+ begin\r
+ niveau:=5;\r
+ libre:=true;\r
+ while libre do\r
+ niveau:=niveau-1;\r
+ if niveau<>0 then \r
+ libre:= (jeu(a,b,niveau)=-1);\r
+ else libre:=false;\r
+ fi;\r
+ od;\r
+ \r
+ niveau:=niveau+1;\r
+ if niveau=5 then result:=false;\r
+ else\r
+ jeu(a,b,niveau):=couleur;\r
+ call boulle(grille(b,a).x,grille(b,a).y,niveau,couleur);\r
+ result:=true;\r
+ fi;\r
+ end;\r
+\r
+\r
+ UNIT boulle:procedure(x,y,h,couleur:integer);\r
+ \r
+ begin\r
+ call color(couleur);\r
+ call move(x,y-(26*(h-1)));\r
+ call draw(x,y-(26*(h-1))-26);\r
+ call move(x+1,y-(26*(h-1))-1);\r
+ call draw(x+1,y-(26*(h-1))-26);\r
+ call move(x-1,y-(26*(h-1))-1);\r
+ call draw(x-1,y-(26*(h-1))-26);\r
+ call move(x+1,y-(26*(h-1))+1);\r
+ call draw(x+1,y-(26*(h-1))-26);\r
+ end;\r
+ \r
+ \r
+ UNIT axe: procedure(x,y:integer);\r
+ begin\r
+ call move(x+1,y-1);\r
+ call draw(x+1,y-108);\r
+ call move(x,y);\r
+ call draw(x,y-108);\r
+ call move(x-1,y-1);\r
+ call draw(x-1,y-108);\r
+ call move(x+1,y+1);\r
+ call draw(x+1,y-108);\r
+ end; \r
+ \r
+ UNIT plan: procedure(x,y,i:integer);\r
+ var xx,yy:integer;\r
+ begin\r
+ xx:=x;\r
+ yy:=y;\r
+ call axe(xx,yy);\r
+ grille(i,1):=new coord2D(xx,yy);\r
+ xx:=xx-42;\r
+ yy:=yy-42;\r
+ call axe(xx,yy);\r
+ grille(i,2):=new coord2D(xx,yy);\r
+\r
+ call move(xx,yy);\r
+ call draw(136,278);\r
+ \r
+ xx:=xx-26;\r
+ yy:=yy-26;\r
+ call axe(xx,yy);\r
+ grille(i,3):=new coord2D(xx,yy);\r
+ call move(xx,yy);\r
+ call draw(110,252);\r
+\r
+ xx:=xx-41;\r
+ yy:=yy-41;\r
+ call axe(xx,yy);\r
+ grille(i,4):=new coord2D(xx,yy);\r
+ call move(xx,yy);\r
+ call draw(x,y);\r
+\r
+ end;\r
+\r
+ \r
+ unit rangee: procedure;\r
+\r
+ begin\r
+ call plan(round(213*0.38)+178,round(-71*0.38)+320,2);\r
+ call plan(round(213*0.65)+178,round(-71*0.65)+320,3);\r
+ call plan(213+178,-71+320,4);\r
+ end;\r
+ \r
+ \r
+ UNIT initialisation:procedure;\r
+ var i,j,k:integer;\r
+ begin\r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ for k:=1 to 4\r
+ do\r
+ jeu(i,j,k):=-1;\r
+ od;\r
+ od;\r
+ od;\r
+ for i:=1 to 4\r
+ do\r
+ for j:=1 to 4\r
+ do\r
+ call boulle(grille(i,j).x,grille(i,j).y,3,blanc);\r
+ call boulle(grille(i,j).x,grille(i,j).y,1,blanc);\r
+ call boulle(grille(i,j).x,grille(i,j).y,4,blanc);\r
+ call boulle(grille(i,j).x,grille(i,j).y,2,blanc);\r
+\r
+ od;\r
+ od;\r
+ \r
+ end;\r
+\r
+ \r
+ UNIT fleche: class;\r
+ \r
+ var \r
+ tab_coord:arrayof arrayof coord2D;\r
+\r
+ unit ligne:procedure(i,couleur:integer);\r
+ \r
+ var y1:integer;\r
+ \r
+ begin\r
+ call color(couleur);\r
+ \r
+ y1:=(-(tab_coord(1,i).x-20)+tab_coord(1,i).x+3*tab_coord(1,i).y)div 3;\r
+ call move(tab_coord(1,i).x,tab_coord(1,i).y);\r
+ call draw(tab_coord(1,i).x-20,y1);\r
+ \r
+ y1:=(-(tab_coord(1,i).x-5)+tab_coord(1,i).x+3*tab_coord(1,i).y)div 3;\r
+ call move(tab_coord(1,i).x-5-3,y1-3);\r
+ call draw(tab_coord(1,i).x,tab_coord(1,i).y);\r
+ \r
+ call move(tab_coord(1,i).x,tab_coord(1,i).y+5);\r
+ call draw(tab_coord(1,i).x,tab_coord(1,i).y);\r
+ end; \r
+ \r
+ unit colonne:procedure(i,couleur:integer); \r
+ \r
+ begin\r
+ call color(couleur);\r
+ call move(tab_coord(2,i).x,tab_coord(2,i).y);\r
+ call draw(tab_coord(2,i).x+15,tab_coord(2,i).y+15);\r
+ \r
+ call move(tab_coord(2,i).x,tab_coord(2,i).y);\r
+ call draw(tab_coord(2,i).x+5,tab_coord(2,i).y);\r
+ \r
+ call move(tab_coord(2,i).x,tab_coord(2,i).y);\r
+ call draw(tab_coord(2,i).x,tab_coord(2,i).y+5);\r
+ \r
+ end;\r
+ \r
+ \r
+ UNIT SelectAxe:procedure(inout i,j:integer);\r
+ const droite=-77,gauche=-75,hauts=-72,bas=-80,retour=13;\r
+ var key:integer;\r
+ begin\r
+ call drawrect(0,0,413,349,rouge);\r
+ call ligne(line,15);\r
+ call colonne(col,15); \r
+ do\r
+ do\r
+ key:=inkey;\r
+ if key<>0 then exit; fi; \r
+ od;\r
+ \r
+ case key\r
+ when hauts : call ligne(line,0);\r
+ if line+1<=4 then\r
+ line:=line+1;fi;\r
+ call ligne(line,15);\r
+ when bas : call ligne(line,0);\r
+ if line-1>=1 then\r
+ line:=line-1; fi;\r
+ call ligne(line,15);\r
+ when gauche : call colonne(col,0);\r
+ if col-1>=1 then\r
+ col:=col-1; fi;\r
+ call colonne(col,15);\r
+ when droite : call colonne(col,0);\r
+ if col+1<=4 then\r
+ col:=col+1; fi;\r
+ call colonne(col,15);\r
+ when retour : i:=line;\r
+ j:=col;\r
+ exit;\r
+ esac; \r
+ od; \r
+ call ligne(line,0);\r
+ call colonne(col,0);\r
+ call drawrect(0,0,413,349,blanc);\r
+ end;\r
+\r
+\r
+ begin\r
+ array tab_coord dim(1:2);\r
+ for line:=2 downto 1\r
+ do \r
+ array tab_coord(line) dim(1:4);\r
+ od;\r
+ line:=line+1;\r
+ tab_coord(1,4):=new coord2D(53,219);\r
+ tab_coord(1,3):=new coord2D(92,258);\r
+ tab_coord(1,2):=new coord2D(116,282);\r
+ tab_coord(1,1):=new coord2D(160,326);\r
+ tab_coord(2,1):=new coord2D(190,332);\r
+ tab_coord(2,2):=new coord2D(271,305);\r
+ tab_coord(2,3):=new coord2D(328,286);\r
+ tab_coord(2,4):=new coord2D(398,256);\r
+\r
+ end; \r
+\r
+\r
+ var arrow:fleche;\r
+\r
+BEGIN\r
+ block\r
+ var i,j:integer;\r
+ begin\r
+call gron(1);\r
+\r
+array grille dim(1:4);\r
+\r
+for i:=1 to 4\r
+ do\r
+ array grille(i) dim(1:4);\r
+ od;\r
+\r
+array jeu dim(1:4);\r
+\r
+for i:=1 to 4\r
+ do\r
+ array jeu(i) dim(1:4);\r
+ for j:=1 to 4\r
+ do\r
+ array jeu(i,j) dim (1:4);\r
+ od;\r
+ od;\r
+\r
+\r
+call color(grisfonce);\r
+call ombre(69,223,282,152,4);\r
+call color(grisclair);\r
+call ombre(69,211,282,140,0);\r
+\r
+call color(blanc);\r
+call plan(178,320,1);\r
+call rangee;\r
+call cadre;\r
+call move(440,10);\r
+call outstring("PUISSANCE 4 CHINOIS");\r
+\r
+call drawrect(418,220,620,349,blanc);\r
+call drawrect(0,0,413,349,blanc);\r
+line,col:=2;\r
+haut:=0;\r
+arrow:= new fleche;\r
+end;\r
+END; (* fin Plateau_Jeu *)\r
+\r
+UNIT menu: gestion_caractere function:integer;\r
+var choix:integer;\r
+begin\r
+ call dialog2;\r
+ call drawrect(418,220,620,349,blanc);\r
+ call drawrect(418,50,620,200,rouge);\r
+ call color(blanc);\r
+ call move(480,60);\r
+ call outstring(" OPTIONS ");\r
+ call move(420,80);\r
+ call outstring("[1] Un joueur");\r
+ call move(420,100);\r
+ call outstring("[2] Deux joueurs");\r
+ call move(420,120);\r
+ call outstring("[0] Quitter");\r
+ call move(470,180);\r
+ call outstring("Votre choix :");\r
+ do\r
+ choix:=ConvENT(saisie(1,1,570,180));\r
+ if choix>=0 and choix<=2 then exit; fi;\r
+ od;\r
+ result:=choix;\r
+ call drawrect(418,50,620,200,blanc);\r
+ call drawrect(418,220,620,349,rouge);\r
+end;\r
+UNIT withwho: gestion_caractere function:integer;\r
+var choix:integer;\r
+begin\r
+ call dialog2;\r
+ call drawrect(418,220,620,349,blanc);\r
+ call drawrect(418,50,620,200,rouge);\r
+ call color(blanc);\r
+ call move(480,60);\r
+ call outstring(" OPTIONS ");\r
+ call move(420,80);\r
+ call outstring("[1] Ordinateur");\r
+ call move(440,90);\r
+ call outstring(" contre Vous");\r
+ call move(420,110);\r
+ call outstring("[2] Ordinateur");\r
+ call move(440,120);\r
+ call outstring(" contre Ordinateur");\r
+\r
+ call move(420,140);\r
+ call outstring("[0] Retour");\r
+ call move(470,180);\r
+ call outstring("Votre choix :");\r
+ do\r
+ choix:=ConvENT(saisie(1,1,570,180));\r
+ if choix>=0 and choix<=2 then exit; fi;\r
+ od;\r
+ result:=choix;\r
+ call drawrect(418,50,620,200,blanc);\r
+ call drawrect(418,220,620,349,rouge);\r
+end;\r
+\r
+UNIT dialog1:iiuwgraph procedure;\r
+var i:integer;\r
+begin\r
+ call color(0);\r
+ for i:=1 to 108\r
+ do\r
+ call move(419,220+i);\r
+ call draw(619,220+i);\r
+ od;\r
+ \r
+end;\r
+UNIT dialog2:iiuwgraph procedure;\r
+var i:integer;\r
+begin\r
+ call color(0);\r
+ for i:=1 to 148\r
+ do\r
+ call move(419,51+i);\r
+ call draw(619,51+i);\r
+ od;\r
+ \r
+end;\r
+\r
+UNIT name:gestion_caractere function(i:integer):arrayof char;\r
+begin\r
+ \r
+ call dialog1;\r
+ call drawrect(418,220,620,349,rouge);\r
+ call color(blanc);\r
+ call move(420,230);\r
+ if i=1 then\r
+ call outstring("Nom du joueur 1:");\r
+ else call outstring("Nom du joueur 2:");\r
+ fi;\r
+ result:=saisie(2,8,430,250);\r
+ call drawrect(418,220,620,349,blanc);\r
+end;\r
+\r
+UNIT whostart:gestion_caractere function:integer;\r
+var i,c,a:integer;\r
+begin\r
+ call dialog1;\r
+ call drawrect(418,220,620,349,rouge);\r
+ call color(blanc);\r
+ call move(420,230);\r
+ call outstring(" Voulez-vous que"); \r
+ call move(420,240);\r
+ call outstring("je commence la partie ?");\r
+ i:=1;\r
+ call move(440,260);\r
+ call color(grisfonce);\r
+ call outstring("NON");\r
+ call move(540,260);\r
+ call color(grisclair);\r
+ call outstring("OUI");\r
+ \r
+ c:=inkey;\r
+ while c<>13 do\r
+ if c<>0 then\r
+ i:=i+1;\r
+ if i>2 then i:=1; fi;\r
+\r
+ case i\r
+ when 1:call move(440,260);\r
+ call color(grisfonce);\r
+ call outstring("NON");\r
+ call move(540,260);\r
+ call color(grisclair);\r
+ call outstring("OUI");\r
+ when 2:call move(440,260);\r
+ call color(grisclair);\r
+ call outstring("NON");\r
+ call move(540,260);\r
+ call color(grisfonce);\r
+ call outstring("OUI");\r
+ esac; \r
+ fi; \r
+ c:=inkey; \r
+ od;\r
+ result:=i;\r
+end;\r
+\r
+unit thegame: gestion_caractere procedure;\r
+var a:integer;\r
+begin\r
+ call dialog2;\r
+ call displaystring(team(1).nom,430,90,bleuroi);\r
+ call move(490,120);\r
+ call color(blanc);\r
+ call outstring("contre");\r
+ call displaystring(team(2).nom,530,150,bleuroi);\r
+end;\r
+\r
+\r
+UNIT quelcouleur:gestion_caractere function(t:arrayof char):integer;\r
+const droite=-77,gauche=-75;\r
+var i,c,a:integer;\r
+begin\r
+ call dialog1;\r
+ call drawrect(418,220,620,349,rouge);\r
+ call displaystring(t,420,230,blanc);\r
+\r
+ call move(440,250);\r
+ call outstring("Boule:"); \r
+ c:=inkey;\r
+ i:=1;a:=2;\r
+ if i=boule then\r
+ i:=i+1; \r
+ a:=a+1 fi;\r
+\r
+ call move(500,250);\r
+ call color(i);\r
+ call outstring("<Couleur>");\r
+ call displaystring(unpack("->:couleur suivante"),420,310,grisfonce);\r
+ call displaystring(unpack("<-:couleur pr\82c\82dente"),420,320,grisfonce);\r
+ while c<>13 do\r
+ if c<>0 then \r
+ case c\r
+ when droite:\r
+ i:=i+1;\r
+ if i>14 then i:=1; fi;\r
+ if i=boule then\r
+ i:=i+1; fi;\r
+ if i>14 then i:=1; fi;\r
+ when gauche:\r
+ i:=i-1;\r
+ if i<1 then i:=14; fi;\r
+ if i=boule then i:=i-1;fi;\r
+ if i<1 then i:=14; fi;\r
+ esac; \r
+ \r
+ fi;\r
+ if i<>a then\r
+ a:=i;\r
+ call move(500,250);\r
+ call color(i);\r
+ call outstring("<Couleur>");\r
+ fi;\r
+ c:=inkey;\r
+ od;\r
+ result:=i;\r
+ call drawrect(418,220,620,349,blanc);\r
+end;\r
+\r
+signal quitter,gagner;\r
+VAR plateau:plateau_jeu,\r
+ team: arrayof joueurs,\r
+ c,i,j,boule:integer,\r
+ partie:boolean,\r
+ arbitre:controle;\r
+\r
+handlers\r
+ when quitter:\r
+ pref iiuwgraph block\r
+ begin\r
+ kill(arbitre);\r
+ kill(team(1).joueur);\r
+ kill(team(2).joueur);\r
+ kill(team(1));\r
+ kill(team(2));\r
+ call groff;\r
+ end;\r
+ wind;\r
+ when gagner:\r
+ pref iiuwgraph block\r
+ begin\r
+ kill(team(1).joueur);\r
+ kill(team(2).joueur);\r
+ kill(arbitre);\r
+ call color(0);\r
+ call move(450,270);\r
+ call outstring(" ");\r
+\r
+ call color(rouge);\r
+ call move(500,270);\r
+ call outstring(" A GAGNE !");\r
+ end;\r
+ return;\r
+ \r
+\r
+end;\r
+\r
+\r
+BEGIN\r
+plateau:=new plateau_jeu;\r
+array team dim(1:2);\r
+\r
+ team(1):=new joueurs;\r
+ team(2):=new joueurs;\r
+pref gestion_caractere block \r
+\r
+begin\r
+do\r
+ boule:=0;\r
+ partie:=false;\r
+ case menu\r
+ when 2:team(1).nom:=name(1); \r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ boule:=team(1).couleur;\r
+ team(1).joueur:=new humain(team(1).couleur,plateau);\r
+ team(2).nom:=name(2);\r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ team(2).joueur:=new humain(team(2).couleur,plateau);\r
+ partie:=true;\r
+ \r
+ when 1: \r
+ case withwho\r
+ when 1:\r
+ case whostart \r
+ when 2:team(1).nom:=name(1); \r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ boule:=team(1).couleur;\r
+ team(1).joueur:=new humain(team(1).couleur,plateau);\r
+ team(2).nom:=unpack("COMPUTER");\r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ team(2).joueur:=new ordi(team(2).couleur,plateau);\r
+ partie:=true;\r
+\r
+ when 1:team(2).nom:=name(2); \r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ boule:=team(2).couleur;\r
+ team(2).joueur:=new humain(team(2).couleur,plateau);\r
+ team(1).nom:=unpack("COMPUTER");\r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ team(1).joueur:=new ordi(team(1).couleur,plateau);\r
+ partie:=true;\r
+\r
+ esac;\r
+ when 2:team(1).nom:=unpack("Computer1"); \r
+ team(1).couleur:=quelcouleur(team(1).nom);\r
+ boule:=team(1).couleur;\r
+ team(1).joueur:=new ordi(team(1).couleur,plateau);\r
+ team(2).nom:=unpack("Computer2");\r
+ team(2).couleur:=quelcouleur(team(2).nom);\r
+ team(2).joueur:=new ordi(team(2).couleur,plateau);\r
+ partie:=true;\r
+ esac;\r
+ when 0: raise quitter;\r
+ \r
+ \r
+ esac;\r
+ if partie then \r
+ call thegame;\r
+ arbitre:=new controle(team,plateau);\r
+ attach(arbitre);\r
+ raise gagner;\r
+ kill(arbitre);\r
+ fi;\r
+ od;\r
+ \r
+end;\r
+\r
+END;\r
--- /dev/null
+PROGRAM Reversi;\r
+\r
+(*** 2ø PROJET DE LI1 DU BINOME : LAPORTE-FAURET Olivier\r
+ GOUDOU Pascal ***)\r
+\r
+CONST noir=0, bleu=1, rouge=4, jaune=14, blanc=15,\r
+ bas_g=1, gauche=2, haut_g=3, haut=4,\r
+ haut_d=5, droite=6, bas_d=7, bas=8;\r
+\r
+VAR nb_rouges,nb_bleus,libre : INTEGER,\r
+ grille : ARRAYOF ARRAYOF rectangle,\r
+ gr_prio : ARRAYOF ARRAYOF INTEGER,\r
+ meill_coup : ARRAYOF infos,\r
+ som_prio,nb_pions_pris : INTEGER,\r
+ ligne,colonne : INTEGER;\r
+\r
+\r
+\r
+(***********************************************************************)\r
+\r
+UNIT points : CLASS;\r
+VAR x,y : INTEGER;\r
+END points;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT rectangle : CLASS;\r
+VAR p1, p2 : points,\r
+ occupe : INTEGER;\r
+END rectangle;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT infos : CLASS;\r
+VAR sens : INTEGER,\r
+ li,co : INTEGER;\r
+END infos;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT affiche_grille : PROCEDURE;\r
+\r
+ UNIT init_grille : PROCEDURE;\r
+ (*** Cette proc\82dure permet d'initialiser les grilles et les tableaux\r
+ n\82cessaires au bon d\82roulement du programme. ***)\r
+\r
+ VAR i,j,icks,igrec : INTEGER;\r
+ BEGIN\r
+ (* initialisation de la grille devant contenir les pions rouges et bleus *)\r
+ ARRAY grille DIM (1:8);\r
+ FOR i:=1 TO 8\r
+ DO\r
+ ARRAY grille(i) DIM (1:8);\r
+ OD;\r
+ igrec:=40;\r
+ FOR i:=1 TO 8\r
+ DO\r
+ icks:=10;\r
+ FOR j:=1 TO 8\r
+ DO\r
+ grille(i,j):=NEW rectangle;\r
+ grille(i,j).p1:=NEW points;\r
+ grille(i,j).p2:=NEW points;\r
+ grille(i,j).p1.x:=icks;\r
+ grille(i,j).p1.y:=igrec;\r
+ grille(i,j).p2.x:=icks+36;\r
+ grille(i,j).p2.y:=igrec+30;\r
+ grille(i,j).occupe:=noir;\r
+ icks:=icks+36;\r
+ OD;\r
+ igrec:=igrec+30;\r
+ OD;\r
+ (* initialisation de la grille des priorit\82s *)\r
+ ARRAY gr_prio dim (1:8);\r
+ FOR i:=1 TO 8\r
+ DO\r
+ ARRAY gr_prio(i) DIM (1:8);\r
+ OD;\r
+ gr_prio(1,1):=20;\r
+ gr_prio(1,8):=20;\r
+ gr_prio(8,1):=20;\r
+ gr_prio(8,8):=20;\r
+ gr_prio(1,3):=14;\r
+ gr_prio(1,6):=14;\r
+ gr_prio(8,3):=14;\r
+ gr_prio(8,6):=14;\r
+ gr_prio(3,1):=14;\r
+ gr_prio(6,1):=14;\r
+ gr_prio(3,8):=14;\r
+ gr_prio(6,8):=14;\r
+ gr_prio(1,4):=12;\r
+ gr_prio(1,5):=12;\r
+ gr_prio(8,4):=12;\r
+ gr_prio(8,5):=12;\r
+ gr_prio(4,1):=12;\r
+ gr_prio(5,1):=12;\r
+ gr_prio(4,8):=12;\r
+ gr_prio(5,8):=12;\r
+ gr_prio(1,2):=9;\r
+ gr_prio(1,7):=9;\r
+ gr_prio(8,2):=9;\r
+ gr_prio(8,7):=9;\r
+ gr_prio(2,1):=9;\r
+ gr_prio(7,1):=9;\r
+ gr_prio(2,8):=9;\r
+ gr_prio(7,8):=9;\r
+ gr_prio(3,3):=6;\r
+ gr_prio(3,6):=6;\r
+ gr_prio(6,3):=6;\r
+ gr_prio(6,6):=6;\r
+ gr_prio(3,4):=4;\r
+ gr_prio(3,5):=4;\r
+ gr_prio(6,4):=4;\r
+ gr_prio(6,5):=4;\r
+ gr_prio(4,3):=4;\r
+ gr_prio(5,3):=4;\r
+ gr_prio(4,6):=4;\r
+ gr_prio(5,6):=4;\r
+ gr_prio(2,3):=2;\r
+ gr_prio(2,4):=2;\r
+ gr_prio(2,5):=2;\r
+ gr_prio(2,6):=2;\r
+ gr_prio(7,3):=2;\r
+ gr_prio(7,4):=2;\r
+ gr_prio(7,5):=2;\r
+ gr_prio(7,6):=2;\r
+ gr_prio(3,2):=2;\r
+ gr_prio(4,2):=2;\r
+ gr_prio(5,2):=2;\r
+ gr_prio(6,2):=2;\r
+ gr_prio(3,7):=2;\r
+ gr_prio(4,7):=2;\r
+ gr_prio(5,7):=2;\r
+ gr_prio(6,7):=2;\r
+ gr_prio(4,4):=2;\r
+ gr_prio(4,5):=2;\r
+ gr_prio(5,4):=2;\r
+ gr_prio(5,5):=2;\r
+ gr_prio(2,2):=1;\r
+ gr_prio(2,7):=1;\r
+ gr_prio(7,2):=1;\r
+ gr_prio(7,7):=1;\r
+ END init_grille;\r
+\r
+ UNIT cercles_au_centre : PROCEDURE;\r
+ VAR i,j : INTEGER;\r
+ BEGIN\r
+ CALL dessine_cercle(4,4,rouge);\r
+ CALL dessine_cercle(4,5,bleu);\r
+ CALL dessine_cercle(5,4,bleu);\r
+ CALL dessine_cercle(5,5,rouge);\r
+ nb_rouges:=2; nb_bleus:=2; libre:=60;\r
+ END cercles_au_centre;\r
+\r
+ UNIT chiffres : IIUWGRAPH PROCEDURE;\r
+ VAR i,col,lig : INTEGER;\r
+ BEGIN\r
+ CALL COLOR(blanc);\r
+ col:=28;\r
+ FOR i:=49 TO 56\r
+ DO\r
+ CALL MOVE(col,30);\r
+ CALL HASCII(i);\r
+ col:=col+36;\r
+ OD;\r
+ lig:=55;\r
+ FOR i:=49 TO 56\r
+ DO\r
+ CALL MOVE(0,lig);\r
+ CALL HASCII(i);\r
+ lig:=lig+30;\r
+ OD;\r
+ END chiffres;\r
+\r
+ UNIT quadrillage : IIUWGRAPH PROCEDURE;\r
+ VAR col,lig : INTEGER;\r
+ BEGIN\r
+ CALL COLOR(blanc);\r
+ col:=10;\r
+ WHILE col<=298\r
+ DO\r
+ CALL MOVE(col,40);\r
+ CALL DRAW(col,280);\r
+ col:=col+36;\r
+ OD;\r
+ lig:=40;\r
+ WHILE lig<=280\r
+ DO\r
+ CALL MOVE(10,lig);\r
+ CALL DRAW(296,lig);\r
+ lig:=lig+30;\r
+ OD;\r
+ END quadrillage;\r
+\r
+VAR col,lig,tch : INTEGER;\r
+BEGIN\r
+ CALL init_grille;\r
+ CALL quadrillage;\r
+ CALL cercles_au_centre;\r
+ CALL chiffres;\r
+END affiche_grille;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT dessine_cercle : IIUWGRAPH PROCEDURE(ptx,pty,couleur : INTEGER);\r
+VAR cx,cy : INTEGER;\r
+BEGIN\r
+ PREF MOUSE BLOCK\r
+ BEGIN\r
+ CALL COLOR(couleur);\r
+ cx:=(grille(ptx,pty).p1.x + grille(ptx,pty).p2.x)/2;\r
+ cy:=(grille(ptx,pty).p1.y + grille(ptx,pty).p2.y)/2;\r
+ CALL HIDECURSOR;\r
+ CALL CIRB(cx,cy,16,0.0,0.0,couleur,1,1,1);\r
+ CALL SHOWCURSOR;\r
+ grille(ptx,pty).occupe:=couleur;\r
+ END;\r
+END dessine_cercle;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT efface : IIUWGRAPH PROCEDURE(x,y : INTEGER);\r
+VAR abscis : INTEGER;\r
+BEGIN\r
+ CALL COLOR(noir);\r
+ CALL MOVE (x,y);\r
+ FOR abscis:=x TO 639\r
+ DO\r
+ CALL OUTSTRING(" ");\r
+ CALL MOVE(abscis,y);\r
+ OD;\r
+END efface;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT texte : IIUWGRAPH PROCEDURE (x,y,c : INTEGER; s : STRING);\r
+BEGIN\r
+ PREF MOUSE BLOCK\r
+ BEGIN\r
+ CALL COLOR(c);\r
+ CALL MOVE (x,y);\r
+ CALL OUTSTRING(s);\r
+ END;\r
+END texte;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT fill : IIUWGRAPH PROCEDURE (x,y,large,haut,couleur:INTEGER) ;\r
+VAR i : INTEGER ;\r
+BEGIN\r
+ CALL COLOR(couleur);\r
+ FOR i:=y TO y+haut\r
+ DO\r
+ CALL MOVE(x,i) ;\r
+ CALL DRAW(x+large,i) ;\r
+ OD ;\r
+END fill;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT saisie_rep : IIUWGRAPH PROCEDURE (couleur : INTEGER;\r
+ OUTPUT valeur : CHAR);\r
+VAR c : INTEGER;\r
+BEGIN\r
+ DO\r
+ c:=INKEY;\r
+ IF c=78 ORIF c=79 ORIF c=110 ORIF c=111 THEN EXIT FI;\r
+ (* N *) (* O *) (* n *) (* o *)\r
+ OD;\r
+ valeur:=CHR(c);\r
+ (*CALL COLOR(couleur);\r
+ CALL HASCII(c);\r
+ CALL pause(1);*)\r
+END saisie_rep;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT pause : PROCEDURE(seconde : INTEGER);\r
+VAR temps:INTEGER;\r
+BEGIN\r
+ FOR temps:=1 TO (1000*seconde) DO OD;\r
+END pause;\r
+\r
+\r
+(***********************************************************************)\r
+\r
+UNIT test_couleur : PROCEDURE(couleur : INTEGER);\r
+BEGIN\r
+ IF couleur=rouge THEN\r
+ nb_rouges:=nb_rouges+1;\r
+ nb_bleus:=nb_bleus-1\r
+ ELSE\r
+ nb_bleus:=nb_bleus+1;\r
+ nb_rouges:=nb_rouges-1;\r
+ FI;\r
+END test_couleur;\r
+\r
+(***********************************************************************)\r
+(* Dans les 4 proc\82dures qui suivent, les fl\8aches pr\82sentes sous les en_t\88tes\r
+ indiquent le sens dans lequel s'effectue la coloration *)\r
+\r
+UNIT diagonale_droite : PROCEDURE(xd,yd,xa,ya,colorie : INTEGER);\r
+(* > *)\r
+(* / *)\r
+(* / *)\r
+(* / *)\r
+(* / *)\r
+VAR i,j : INTEGER;\r
+BEGIN\r
+ i:=xd;\r
+ j:=yd;\r
+ WHILE i>=xa AND j<=ya\r
+ DO\r
+ CALL dessine_cercle(i,j,colorie);\r
+ CALL test_couleur(colorie);\r
+ i:=i-1;\r
+ j:=j+1;\r
+ OD;\r
+END diagonale_droite;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT diagonale_gauche : PROCEDURE(xd,yd,xa,ya,colorie : INTEGER);\r
+(* < *)\r
+(* \ *)\r
+(* \ *)\r
+(* \ *)\r
+(* \ *)\r
+VAR i,j : INTEGER;\r
+BEGIN\r
+ i:=xd;\r
+ j:=yd;\r
+ WHILE i>=xa AND j>=ya\r
+ DO\r
+ CALL dessine_cercle(i,j,colorie);\r
+ CALL test_couleur(colorie);\r
+ i:=i-1;\r
+ j:=j-1;\r
+ OD;\r
+END diagonale_gauche;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT verticale : PROCEDURE(xd,xa,y,colorie : INTEGER);\r
+(* | *)\r
+(* | *)\r
+(* | *)\r
+(* | *)\r
+(* v *)\r
+VAR i : INTEGER;\r
+BEGIN\r
+ i:=xd;\r
+ WHILE i<=xa\r
+ DO\r
+ CALL dessine_cercle(i,y,colorie);\r
+ CALL test_couleur(colorie);\r
+ i:=i+1;\r
+ OD;\r
+END verticale;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT horizontale : PROCEDURE(x,yd,ya,colorie : INTEGER);\r
+(* *)\r
+(* *)\r
+(* -----> *)\r
+(* *)\r
+(* *)\r
+VAR j : INTEGER;\r
+BEGIN\r
+ j:=yd;\r
+ WHILE j<=ya\r
+ DO\r
+ CALL dessine_cercle(x,j,colorie);\r
+ CALL test_couleur(colorie);\r
+ j:=j+1;\r
+ OD;\r
+END horizontale;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT cherche_intervalle : IIUWGRAPH PROCEDURE(abscis,ordon,couleur : INTEGER;\r
+ dessinez : BOOLEAN;\r
+ OUTPUT trouve : BOOLEAN);\r
+VAR i,j,inverse : INTEGER,\r
+ somme,nb_pris,so,nbp : INTEGER;\r
+BEGIN\r
+ IF couleur=rouge THEN inverse:=bleu ELSE inverse:=rouge FI;\r
+ IF ordon>2 THEN\r
+ (* recherche en bas \85 gauche *)\r
+ IF abscis<7 THEN\r
+ i:=abscis; j:=ordon;\r
+ DO\r
+ so:=so+gr_prio(i,j);\r
+ i:=i+1; j:=j-1;\r
+ IF i>8 ORIF j<1 THEN EXIT FI;\r
+ IF grille(i,j).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF i<=8 ANDIF i<>abscis+1 ANDIF j>=1 ANDIF j<>ordon-1\r
+ ANDIF grille(i,j).occupe=couleur THEN\r
+ somme:=so; nb_pris:=nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL diagonale_droite(i-1,j+1,abscis+1,ordon-1,couleur);\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+ FI; (*abscis<7*)\r
+\r
+ (* recherche vers la gauche *)\r
+ so:=0; nbp:=0;\r
+ j:=ordon;\r
+ DO\r
+ so:=so+gr_prio(abscis,j);\r
+ j:=j-1;\r
+ IF j<1 THEN EXIT FI;\r
+ IF grille(abscis,j).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF j>=1 ANDIF j<>ordon-1 ANDIF grille(abscis,j).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL horizontale(abscis,j+1,ordon-1,couleur);\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+\r
+ (* recherche en haut \85 gauche *)\r
+ IF abscis>2 THEN\r
+ so:=0; nbp:=0;\r
+ i:=abscis; j:=ordon;\r
+ DO\r
+ so:=so+gr_prio(i,j);\r
+ i:=i-1; j:=j-1;\r
+ IF i<1 ORIF j<1 THEN EXIT FI;\r
+ IF grille(i,j).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF i>=1 ANDIF i<>abscis-1 ANDIF j>=1 ANDIF j<>ordon-1\r
+ ANDIF grille(i,j).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL diagonale_gauche(abscis-1,ordon-1,i+1,j+1,couleur);\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+ FI; (*abscis>2*)\r
+ FI; (*ordon>2*)\r
+\r
+ (* recherche vers le haut *)\r
+ IF abscis>2 THEN\r
+ so:=0; nbp:=0;\r
+ i:=abscis;\r
+ DO\r
+ so:=so+gr_prio(i,ordon);\r
+ i:=i-1;\r
+ IF i<1 THEN EXIT FI;\r
+ IF grille(i,ordon).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF i>=1 ANDIF i<>abscis-1 ANDIF grille(i,ordon).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL verticale(i+1,abscis-1,ordon,couleur);\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+ FI; (*abscis>2*)\r
+\r
+ IF ordon<7 THEN\r
+ (* recherche en haut \85 droite *)\r
+ IF abscis>2 THEN\r
+ so:=0; nbp:=0;\r
+ i:=abscis; j:=ordon;\r
+ DO\r
+ so:=so+gr_prio(i,j);\r
+ i:=i-1; j:=j+1;\r
+ IF i<1 ORIF j>8 THEN EXIT FI;\r
+ IF grille(i,j).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF i>=1 ANDIF i<>abscis-1 ANDIF j<=8 ANDIF j<>ordon+1\r
+ ANDIF grille(i,j).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL diagonale_droite(abscis-1,ordon+1,i+1,j-1,couleur);\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+ FI; (*abscis>2*)\r
+\r
+ (* recherche vers la droite *)\r
+ so:=0; nbp:=0;\r
+ j:=ordon;\r
+ DO\r
+ so:=so+gr_prio(abscis,j);\r
+ j:=j+1;\r
+ IF j>8 THEN EXIT FI;\r
+ IF grille(abscis,j).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF j<=8 ANDIF j<>ordon+1 ANDIF grille(abscis,j).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL horizontale(abscis,ordon+1,j-1,couleur);\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+\r
+ (* recherche en bas \85 droite *)\r
+ IF abscis<7 THEN\r
+ so:=0; nbp:=0;\r
+ i:=abscis; j:=ordon;\r
+ DO\r
+ so:=so+gr_prio(i,j);\r
+ i:=i+1; j:=j+1;\r
+ IF i>8 ORIF j>8 THEN EXIT FI;\r
+ IF grille(i,j).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF i<=8 ANDIF i<>abscis+1 ANDIF j<=8 ANDIF j<>ordon+1\r
+ ANDIF grille(i,j).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN\r
+ CALL diagonale_gauche(i-1,j-1,abscis+1,ordon+1,couleur)\r
+ ELSE\r
+ IF couleur=rouge THEN RETURN FI;\r
+ FI;\r
+ FI;\r
+ FI; (*abscis<7*)\r
+ FI; (*ordon<7*)\r
+\r
+ (* recherche vers le bas *)\r
+ IF abscis<7 THEN\r
+ so:=0; nbp:=0;\r
+ i:=abscis;\r
+ DO\r
+ so:=so+gr_prio(i,ordon);\r
+ i:=i+1;\r
+ IF i>8 THEN EXIT FI;\r
+ IF grille(i,ordon).occupe<>inverse THEN EXIT FI;\r
+ nbp:=nbp+1;\r
+ OD;\r
+ IF i<=8 ANDIF i<>abscis+1 ANDIF grille(i,ordon).occupe=couleur THEN\r
+ somme:=somme+so; nb_pris:=nb_pris+nbp;\r
+ trouve:=TRUE;\r
+ IF dessinez THEN CALL verticale(abscis+1,i-1,ordon,couleur) FI;\r
+ FI;\r
+ FI; (*abscis<7*)\r
+ IF trouve ANDIF dessinez THEN\r
+ CALL dessine_cercle(abscis,ordon,couleur);\r
+ IF couleur=rouge THEN nb_rouges:=nb_rouges+1\r
+ ELSE nb_bleus:=nb_bleus+1;\r
+ FI;\r
+ FI;\r
+ IF somme>=som_prio THEN\r
+ IF nb_pris>nb_pions_pris THEN\r
+ som_prio:=somme;\r
+ nb_pions_pris:=nb_pris;\r
+ ligne:=abscis;\r
+ colonne:=ordon;\r
+ FI;\r
+ FI;\r
+END cherche_intervalle;\r
+\r
+(***********************************************************************)\r
+\r
+\r
+UNIT cherche_case : PROCEDURE(abscis,ordon : INTEGER;\r
+ OUTPUT trouve : BOOLEAN);\r
+\r
+ (* Cette proc\82dure va permettre de rechercher dans la matrice "grille",\r
+ la position du point de coordonn\82es (abscis,ordon) - ce point correspond\r
+ en fait au point de clic de la souris. La case ainsi obtenue se situe\r
+ \85 la ligne lig et en colonne col *)\r
+\r
+VAR verif : BOOLEAN,\r
+ lig,col : INTEGER;\r
+BEGIN\r
+ FOR lig:=1 TO 8\r
+ DO\r
+ IF grille(lig,1).p1.y<=ordon ANDIF ordon<=grille(lig,1).p2.y THEN\r
+ FOR col:=1 TO 8\r
+ DO\r
+ IF grille(lig,col).p1.x<=abscis ANDIF\r
+ abscis<=grille(lig,col).p2.x THEN\r
+ IF grille(lig,col).occupe=noir THEN\r
+ CALL cherche_intervalle(lig,col,rouge,TRUE,trouve);\r
+ FI;\r
+ EXIT;\r
+ FI;\r
+ OD;\r
+ EXIT;\r
+ FI;\r
+ OD;\r
+END cherche_case;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT app_tch : IIUWGRAPH PROCEDURE;\r
+VAR tch : INTEGER;\r
+BEGIN\r
+ CALL texte(150,310,jaune,"APPUYER SUR ENTREE");\r
+ DO\r
+ tch:=INKEY;\r
+ IF tch=13 THEN EXIT FI;\r
+ OD;\r
+END app_tch;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT resultat : PROCEDURE;\r
+BEGIN\r
+ WRITELN("Rouges = ",nb_rouges :2 ,", Bleus = ",nb_bleus :2);\r
+ IF nb_rouges>nb_bleus THEN\r
+ WRITE("Les Rouges ont gagn\82 de ",nb_rouges-nb_bleus :2," point(s)") FI;\r
+ IF nb_rouges<nb_bleus THEN\r
+ WRITE("Les Bleus ont gagn\82 de ",nb_bleus-nb_rouges :2," point(s)") FI;\r
+ IF nb_rouges=nb_bleus THEN\r
+ WRITE("Egalit\82") FI;\r
+ CALL app_tch;\r
+END resultat;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT peut_jouer : PROCEDURE(pion : INTEGER; OUTPUT passe : BOOLEAN);\r
+VAR lig,col : INTEGER,\r
+ trouve : BOOLEAN;\r
+BEGIN\r
+ FOR lig:=1 TO 8\r
+ DO\r
+ FOR col:=1 TO 8\r
+ DO\r
+ IF grille(lig,col).occupe=noir THEN\r
+ CALL cherche_intervalle(lig,col,pion,FALSE,trouve);\r
+ FI;\r
+ IF trouve ANDIF pion=rouge THEN EXIT FI;\r
+ OD;\r
+ IF trouve ANDIF pion=rouge THEN EXIT FI;\r
+ OD;\r
+ IF NOT trouve ANDIF pion=rouge THEN passe:=TRUE FI;\r
+ IF nb_pions_pris=0 ANDIF pion=bleu THEN passe:=TRUE FI;\r
+END peut_jouer;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT passe_son_tour : PROCEDURE(message : STRING);\r
+BEGIN\r
+ CALL fill(339,249,160,10,noir);\r
+ CALL texte(340,150,blanc,message);\r
+ CALL pause(3);\r
+ CALL fill(339,149,240,10,noir);\r
+END passe_son_tour;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT init_souris : MOUSE PROCEDURE;\r
+VAR nb : INTEGER;\r
+BEGIN\r
+ IF NOT INIT(nb) THEN\r
+ CALL texte(300,100,rouge,"Erreur d'installation de la souris");EXIT;\r
+ FI;\r
+ CALL DEFCURSOR(1,11,12);\r
+ CALL SHOWCURSOR;\r
+ CALL SETWINDOW(0,625,0,330);\r
+END init_souris;\r
+\r
+(***********************************************************************)\r
+\r
+UNIT jeu : MOUSE PROCEDURE;\r
+VAR h,v,b,p : INTEGER,\r
+ couleur,indx,indy : INTEGER,\r
+ l,r,c,trouve : BOOLEAN,\r
+ rouge_passe,bleu_passe : BOOLEAN,\r
+ rep : CHAR;\r
+BEGIN\r
+ CALL init_souris;\r
+ DO\r
+ (*** Bloc concernant les pions rouges ***)\r
+ CALL peut_jouer(rouge,rouge_passe);\r
+ IF NOT rouge_passe THEN\r
+ bleu_passe:=FALSE;\r
+ CALL efface(340,250);\r
+ CALL texte(340,250,blanc,"Les Rouges jouent...");\r
+ DO\r
+ CALL GETPRESS(1,h,v,p,l,r,c);\r
+ IF r THEN (* right button *)\r
+ CALL fill(339,249,160,10,noir);\r
+ CALL texte(115,310,jaune,"Etes-vous s\96r de vouloir sortir (o/n) ? ");\r
+ CALL saisie_rep(blanc,rep);\r
+ IF rep='n' OR rep='N' THEN\r
+ CALL fill(114,309,320,10,noir);\r
+ CALL texte(340,250,blanc,"Les Rouges jouent...");\r
+ ELSE RETURN;\r
+ FI;\r
+ FI;\r
+ CALL GETPRESS(0,h,v,p,l,r,c);\r
+ IF l THEN (* left button *)\r
+ IF 10<h ANDIF h<298 ANDIF 40<v ANDIF v<280 THEN\r
+ CALL cherche_case(h,v,rouge,trouve);\r
+ IF trouve THEN\r
+ libre:=64-(nb_rouges+nb_bleus);\r
+ CALL efface(340,250);\r
+ EXIT;\r
+ ELSE\r
+ CALL texte(320,130,blanc,"Vous ne pouvez pas jouer ici !");\r
+ CALL pause(3);\r
+ CALL fill(319,129,250,10,noir);\r
+ FI;(* trouve *)\r
+ FI; (* 10<h ANDIF h<298 ... *)\r
+ FI; (* l ANDIF p=1 *)\r
+ OD;\r
+ IF libre=0 THEN EXIT FI;\r
+ ELSE (* Les Rouges passent leur tour ! *)\r
+ IF bleu_passe THEN EXIT FI;\r
+ CALL passe_son_tour("Vous devez passer votre tour !");\r
+ FI; (* NOT rouge_passe *)\r
+\r
+ (*** Bloc concernant les pions bleus ***)\r
+ CALL texte(340,250,blanc,"Les Bleus jouent...");\r
+ som_prio:=0; nb_pions_pris:=0;\r
+ CALL peut_jouer(bleu,bleu_passe);\r
+ IF NOT bleu_passe THEN\r
+ rouge_passe:=FALSE;\r
+ CALL cherche_intervalle(ligne,colonne,bleu,TRUE,trouve);\r
+ libre:=64-(nb_rouges+nb_bleus);\r
+ CALL efface(340,250);\r
+ ELSE\r
+ IF rouge_passe THEN EXIT FI;\r
+ CALL passe_son_tour("Les Bleus passent leur tour.");\r
+ FI; (* NOT bleu_passe *)\r
+ IF libre=0 THEN EXIT FI;\r
+ OD;\r
+ CALL HIDECURSOR;\r
+ CALL resultat;\r
+END jeu;\r
+\r
+\r
+\r
+(****************** PROGRAMME PRINCIPAL ******************)\r
+\r
+BEGIN\r
+ PREF IIUWGRAPH BLOCK\r
+ BEGIN\r
+ CALL GRON(0);\r
+ CALL affiche_grille;\r
+ CALL jeu;\r
+ CALL GROFF;\r
+ END; (* IIUWGRAPH *)\r
+END Reversi;\r
+\1a
\ No newline at end of file
--- /dev/null
+Program Evaluationdepropositionslogiques;\r
+ \r
+(********************************************)\r
+(* ARDANTZ Jean-Michel *)\r
+(* CAZAUBON Eric *)\r
+(* TOURNIER Vincent *)\r
+(********************************************)\r
+ \r
+Const moinsun = -1,\r
+ moins59 = -59,\r
+ moins60 = -60,\r
+ moins61 = -61,\r
+ moins62 = -62,\r
+ moins68 = -68;\r
+Var ch : Chaine,\r
+ l : Liste,\r
+ e : Elem,\r
+ racine : Noeud,\r
+ i,longueur,xx,y,Z : Integer,\r
+ H : Boolean,\r
+ Valeur : ArrayOf Char,\r
+ Courant,Diagramme,X : Node;\r
+ \r
+ \r
+(******************************************)\r
+(* Lecture d'une chaine de caracteres *)\r
+(******************************************)\r
+ \r
+(* Cette classe lit une chaine de caract\8ares *)\r
+(* et la met dans un tableau "Valeur" *)\r
+ \r
+Unit Chaine : Class;\r
+Var c,d : integer,\r
+ i,X : Integer;\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ X:=110+(longueur*8);\r
+ i := 1+longueur;\r
+ C:=0 ;\r
+ do\r
+ Call Color (12) ;\r
+ C := 0 ;\r
+ while C=0\r
+ Do\r
+ Call Texte(X,184,0," ");\r
+ c:=inkey;\r
+ Call Texte(X,184,15,"-");\r
+ Od;\r
+ Call Color (12) ;\r
+ Call move(X,180) ;\r
+ If (c=97)or(c=98)or(c=99)or(c=100)or(c=120)or(c=121)\r
+ or(c=122)or(c=40)or(c=41)\r
+ Then d:=c;\r
+ c:=0;\r
+ Fi;\r
+ Case C\r
+ When 13 :\r
+ Exit ;\r
+ When moins59 :\r
+ If X < 486 Then\r
+ Call dessine_et(X,180);\r
+ valeur(i):='&' ;\r
+ i:=i+1 ;\r
+ X:=X+8 ;\r
+ Fi;\r
+ When moins60 :\r
+ If X < 486 Then\r
+ Call dessine_ou(X,180);\r
+ valeur(i):='%' ;\r
+ i:=i+1 ;\r
+ X:=X+8 ;\r
+ Fi;\r
+ When moins61 :\r
+ If X < 486 Then\r
+ Call dessine_implique(X,180);\r
+ valeur(i):='>' ;\r
+ i:=i+1 ;\r
+ X:=X+8 ;\r
+ Fi;\r
+ When moins62 :\r
+ If X < 486 Then\r
+ Call dessine_non(X,180);\r
+ valeur(i):='|' ;\r
+ i:=i+1 ;\r
+ X:=X+8 ;\r
+ Fi;\r
+ When moins68 :\r
+ Call groff;\r
+ Writeln;\r
+ Writeln(" pa pa ! ");\r
+ Call Endrun;\r
+ When 8 : If X > 110 Then\r
+ i:=i-1;\r
+ X:=X-8;\r
+ Call move(X,180);\r
+ Call Hascii(0);\r
+ Call texte(X,184,15,"-");\r
+ Call move(X,180);\r
+ Fi;\r
+ When 0 :\r
+ If X < 486 Then\r
+ Call Hascii (0) ;\r
+ Call Hascii (d);\r
+ valeur(i):=chr(d);\r
+ i:=i+1;\r
+ X:=X+8;\r
+ Fi;\r
+ Otherwise\r
+ Call texte(105,258,15,"Caract\8are ill\82gal");\r
+ Call texte(105,274,15,"Appuyez sur une touche pour continuer");\r
+ while inkey=0 do od;\r
+ Call Fill (101,251,398,38,0) ;\r
+ Call move(110+(longueur*8),180);\r
+ esac;\r
+ if i=48 then\r
+ Call texte(105,258,15,"Chaine trop longue ");\r
+ Call texte(105,274,15,"Appuyez sur une touche pour continuer");\r
+ while inkey=0 do od;\r
+ Call Fill (101,251,398,38,0) ;\r
+ Call move(110+(longueur*8),180);\r
+ fi;\r
+ od;\r
+ longueur:=i-1;\r
+End;\r
+End Chaine;\r
+ \r
+(************************************************)\r
+(* Analyseur lexical *)\r
+(************************************************)\r
+ \r
+(* Ces deux proc\82dures v\82rifient la validit\82 *)\r
+(* syntaxique de la chaine *)\r
+ \r
+Unit Evolution : procedure(inout etat:Integer; inout nbre:Integer;\r
+ inout nbcar:Integer; input c:Char);\r
+Begin\r
+ case etat\r
+ when 1 : case c\r
+ when '(' : nbcar := 0;\r
+ nbre:=nbre+1;\r
+ etat := 1 ;\r
+ when 'a','b','c','d','x','y','z' : nbcar := nbcar + 1;\r
+ etat := 2 ;\r
+ when '|' : etat := 3 ;\r
+ otherwise etat := 0;\r
+ esac;\r
+ when 2 : case c\r
+ when '&','%','>' : etat := 1 ;\r
+ when ')' : nbcar := 0;\r
+ nbre:=nbre-1;\r
+ etat := 2 ;\r
+ otherwise etat := 0;\r
+ esac;\r
+ when 3 : case c\r
+ when '(' : nbre:=nbre+1;\r
+ etat := 1 ;\r
+ otherwise etat := 0;\r
+ esac;\r
+ esac;\r
+End Evolution;\r
+ \r
+ \r
+(*La fonction analyseur retourne un booleen selon que la formule\r
+ propositionnel est correcte ou non *)\r
+ \r
+ \r
+Unit Analyseur : function(longueur : Integer) : Boolean;\r
+Var etat,nbre,nbcar,i : Integer,\r
+ b : boolean,\r
+ c : Char;\r
+Begin\r
+ B:=False;\r
+ etat:=1;\r
+ nbre:=0;\r
+ nbcar:=0;\r
+ i:=1;\r
+ while (( etat > 0 ) and (i <= longueur ))\r
+ do\r
+ c := valeur(i);\r
+ If C='>' Or C='&' Or C='%' Or C='|' Then B:=True; Fi;\r
+ call Evolution(etat,nbre,nbcar,c);\r
+ if nbcar>2 then\r
+ etat := -1;\r
+ fi;\r
+ i := i+1;\r
+ Od;\r
+ result:=false;\r
+ If Not B Then\r
+ Call Texte(105,266,15,"Erreur de s\82mantique");\r
+ Else\r
+ case etat\r
+ when 0 : Call texte(105,266,15,"Erreur de syntaxe");\r
+ when moinsun : Call texte(105,266,15,\r
+ "Chaine incorrecte, parenth\82sez vos expressions !");\r
+ otherwise if nbre < 0 then\r
+ Call texte(105,266,15,\r
+ "Chaine incorrecte, caract\8are(s) ( absent(s)");\r
+ else if nbre > 0 then\r
+ Call texte(105,266,15,\r
+ "Chaine incorrecte, caract\8are(s) ) absent(s)");\r
+ fi;\r
+ fi;\r
+ esac;\r
+ If ((etat > 0) and (nbre=0)) then\r
+ Call texte(105,266,15,"Chaine correcte");\r
+ result:=true;\r
+ Fi;\r
+ Fi;\r
+End Analyseur;\r
+ \r
+(***********************************************)\r
+(* Impl\82mentation de la pile *)\r
+(***********************************************)\r
+ \r
+Unit Unepile : Class(type telem);\r
+Var p1,p2 : Pile;\r
+ \r
+ Unit Link : Class;\r
+ Var next : Link,\r
+ valeur : telem;\r
+ End Link;\r
+ \r
+ Unit Pile : Class;\r
+ Var top : Link;\r
+ End Pile;\r
+ \r
+ Unit Push : Function (E : Telem ; S : Pile) : Pile;\r
+ Var aux : Link;\r
+ Begin\r
+ aux := New Link;\r
+ aux.valeur := E;\r
+ if Empty_Pile(S)\r
+ then\r
+ aux.next := None;\r
+ else\r
+ aux.next := S.top;\r
+ fi;\r
+ Result := New Pile;\r
+ result.top := aux;\r
+ End Push;\r
+ \r
+ Unit Empty_Pile : Function (S : Pile) : Boolean;\r
+ Begin\r
+ Result := (S=None);\r
+ End Empty_Pile;\r
+ \r
+ Unit Top : Function (S : Pile) : Telem;\r
+ Begin\r
+ Result := S.top.valeur;\r
+ End Top;\r
+ \r
+ Unit Down : Function (S : Pile) : Pile;\r
+ Begin\r
+ if s.top.next <> none\r
+ then Result := New Pile;\r
+ Result.top := S.top.next;\r
+ else\r
+ Result:=none;\r
+ fi;\r
+ End Down;\r
+ \r
+End Unepile;\r
+ \r
+(************************************************)\r
+(* Recherche des operateurs principaux *)\r
+(************************************************)\r
+ \r
+(* Cette proc\82dure construit l'arbre associ\82 *)\r
+(* la formule entr\82e par l'utilisateur *)\r
+ \r
+Unit Elem : Class;\r
+ Var Valeur:Char;\r
+End Elem;\r
+ \r
+ \r
+Unit Noeud : Class;\r
+Var left , right : Noeud,\r
+ Valeur : Char ;\r
+End Noeud ;\r
+ \r
+ \r
+Unit Operateur : procedure(longueur : Integer; output racine : Noeud);\r
+Var i : Integer,\r
+ n,p,ng,nd : Noeud,\r
+ up1,up2 : UnePile,\r
+ e,aux : Elem,\r
+ c : Char;\r
+ \r
+Begin\r
+ \r
+up1 := new UnePile(Noeud);\r
+up2 := new UnePile(Elem);\r
+for i:=1 to longueur\r
+do\r
+ \r
+c:=valeur(i);\r
+case c\r
+ When 'a','b','c','d','x','y','z' : n := New Noeud;\r
+ n.valeur := c;\r
+ up1.p1 := up1.Push(n,up1.p1);\r
+ when '&','%','>','|' : e := new elem;\r
+ e.valeur := c;\r
+ up2.p2 := up2.Push(e,up2.p2);\r
+ when ')' : if not up2.Empty_Pile(up2.p2)\r
+ then\r
+ aux := up2.top(up2.p2);\r
+ up2.p2 := up2.down(up2.p2);\r
+ nd := up1.top(up1.p1);\r
+ up1.p1 := up1.down(up1.p1);\r
+ if aux.valeur <> '|'\r
+ then ng := up1.top(up1.p1);\r
+ up1.p1 := up1.down(up1.p1);\r
+ else\r
+ ng := none;\r
+ fi;\r
+ p := new Noeud;\r
+ p.left := ng;\r
+ p.right := nd;\r
+ p.valeur := aux.valeur;\r
+ up1.p1 := up1.push(p,up1.p1);\r
+ fi;\r
+esac;\r
+od;\r
+if not up2.Empty_Pile(up2.p2)\r
+then aux := up2.top(up2.p2);\r
+ up2.p2 := up2.down(up2.p2);\r
+ nd := up1.top(up1.p1);\r
+ up1.p1 := up1.down(up1.p1);\r
+ if aux.valeur <> '|' then\r
+ ng := up1.top(up1.p1);\r
+ up1.p1 := up1.down(up1.p1);\r
+ else\r
+ ng := none;\r
+ fi;\r
+ p := new Noeud;\r
+ p.left := ng;\r
+ p.right := nd;\r
+ p.valeur := aux.valeur;\r
+fi;\r
+racine := p;\r
+End;\r
+ \r
+ \r
+ \r
+ \r
+(************************************************)\r
+(* Impl\82mentation de la liste *)\r
+(************************************************)\r
+ \r
+(* Cette impl\82mentation de liste permettra *)\r
+(* d'ins\82rer les variables en fin de liste *)\r
+(* et les op\82rateurs au d\82but *)\r
+ \r
+Unit Node : Class ;\r
+ Var Val: Sequence ,\r
+ Left, Right: Node ;\r
+End Node;\r
+ \r
+Unit Sequence : Class;\r
+ Var Gauche, Droite: Liste ;\r
+End Sequence;\r
+ \r
+Unit Liste : Class;\r
+Var Debut: Noeud,\r
+ suivant : Liste;\r
+End Liste;\r
+ \r
+ \r
+Unit Empty_Liste : function(l:Liste) : Boolean;\r
+Begin\r
+ result := l=none;\r
+End Empty_Liste;\r
+ \r
+ \r
+Unit Insert : Function (E:Noeud;L:Liste) : Liste ;\r
+Var l1,aux : Liste;\r
+Begin\r
+ If Empty_Liste(l)\r
+ Then L := new Liste;\r
+ L.Debut:=New Noeud;\r
+ L.Debut := E;\r
+ Else\r
+ l1:=L;\r
+ aux:=new Liste ;\r
+ If E.Valeur<>'|' Andif E.Valeur<>'%'\r
+ Andif E.Valeur<>'&' Andif E.Valeur<>'>'\r
+ Then\r
+ Aux.Debut := E ;\r
+ While L1.Suivant <> None\r
+ Do\r
+ l1 := L1.Suivant ;\r
+ Od ;\r
+ L1.Suivant := Aux ;\r
+ Else\r
+ Aux.Debut := E ;\r
+ Aux.Suivant := L ;\r
+ L := Aux ;\r
+ Fi ;\r
+ Fi;\r
+ Result := L ;\r
+ \r
+End Insert;\r
+ \r
+ \r
+Unit Delete : Function(L:Liste): Liste;\r
+Begin\r
+ Result := L.suivant;\r
+End Delete;\r
+ \r
+ \r
+(************************************************************)\r
+(* Procedures de d\82composition d'une expression bool\82enne *)\r
+(************************************************************)\r
+ \r
+(* Ces proc\82dures permettent de d\82composer la liste *)\r
+(* initiale gr\85ce \85 la m\82thode de GENTZEN de mani\8are *)\r
+(* \85 n'obtenir que des variables aux feuilles *)\r
+ \r
+ \r
+ \r
+Unit Copie_Liste : Function (L:Liste) : Liste ;\r
+Var Der,Aux:Liste ;\r
+Begin\r
+ Result := New Liste ;\r
+ if L<>None Then Der := New Liste ;\r
+ Der := Copy (L) ;\r
+ l := L.Suivant ;\r
+ Fi ;\r
+ Result := Der ;\r
+ While L <> None\r
+ Do\r
+ Aux := New Liste ;\r
+ Aux := Copy (L) ;\r
+ Der.Suivant := Aux ;\r
+ L := L.Suivant ;\r
+ Der :=Aux ;\r
+ Od ;\r
+End Copie_Liste ;\r
+ \r
+ \r
+ \r
+Unit Op_Negation_G : Procedure(Input Racine:Noeud;Inout D:Node) ;\r
+Var L,R : Liste ,\r
+ X : Node ;\r
+Begin\r
+ \r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ L := Copie_Liste (D.Val.Gauche) ;\r
+ R := Copie_Liste (D.Val.Droite) ;\r
+ L := Delete (L) ;\r
+ R := Insert (Racine.Right,R) ;\r
+ X.Val.Droite:=Copie_Liste (R);\r
+ X.Val.Gauche:=Copie_Liste (L) ;\r
+ D.Right:=New Node;\r
+ D.Right:=X;\r
+ Kill (L) ;\r
+ Kill (R) ;\r
+ \r
+End Op_Negation_G ;\r
+ \r
+ \r
+Unit Op_Alternative_G : Procedure(Input Racine:Noeud;Inout D:Node ) ;\r
+Var L,S : Liste ,\r
+ X,Y : Node ;\r
+Begin\r
+ \r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ Y := new Node ;\r
+ Y.Val := New Sequence ;\r
+ X.Val.Droite:= Copie_Liste (D.Val.Droite) ;\r
+ Y.Val.Droite:= Copie_Liste (D.Val.Droite) ;\r
+ l := Copie_Liste (D.Val.Gauche) ;\r
+ L := Delete (L) ;\r
+ S := Copie_Liste (L) ;\r
+ L := Insert (Racine.Left,L) ;\r
+ S := Insert (Racine.Right,S) ;\r
+ X.Val.Gauche:= Copie_Liste (L) ;\r
+ Y.Val.Gauche:= Copie_Liste (S) ;\r
+ D.Left := New Node ;\r
+ D.Right := New Node ;\r
+ D.Left:= X ;\r
+ D.Right:= Y ;\r
+ Kill (L) ;\r
+ Kill (S) ;\r
+ \r
+End Op_Alternative_G ;\r
+ \r
+Unit Op_Conjonction_G : Procedure (Input Racine:Noeud;Inout D : Node);\r
+Var L : Liste ,\r
+ X : Node;\r
+Begin\r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ L := Copie_Liste (D.val.Gauche) ;\r
+ L := Delete (L) ;\r
+ L := Insert (Racine.Left,L) ;\r
+ L := Insert (Racine.Right,L) ;\r
+ X.Val.Gauche:=Copie_Liste (L) ;\r
+ X.Val.Droite:=Copie_Liste (D.Val.Droite) ;\r
+ D.Right:=New Node ;\r
+ D.Right:=X ;\r
+ Kill (L) ;\r
+ \r
+End Op_Conjonction_G ;\r
+ \r
+Unit Op_Implique_G : Procedure (Input Racine:Noeud;Inout D:Node ) ;\r
+Var L,R : Liste ,\r
+ X,Y : Node ;\r
+Begin\r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ Y := new Node ;\r
+ Y.Val := New Sequence ;\r
+ L := Copie_Liste (D.Val.Gauche) ;\r
+ R := Copie_Liste (D.Val.Droite) ;\r
+ X.val.Droite := Copie_Liste (R) ;\r
+ L := Delete (L) ;\r
+ Y.Val.Gauche := Copie_Liste (L) ;\r
+ Y.Val.Droite := Copie_Liste (Insert (Racine.Left,R)) ;\r
+ X.Val.Gauche := Copie_Liste (Insert (Racine.Right,L)) ;\r
+ D.Left := New Node ;\r
+ D.Right := New Node ;\r
+ D.Left := X ;\r
+ D.Right := Y ;\r
+ Kill (L) ;\r
+ Kill (R) ;\r
+ \r
+End Op_Implique_G ;\r
+ \r
+ \r
+Unit Op_Negation_D : Procedure(Input Racine:Noeud; Inout D : Node ) ;\r
+Var L,R : Liste ,\r
+ X : Node ;\r
+Begin\r
+ \r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ L := Copie_Liste (D.Val.Gauche) ;\r
+ R := Copie_Liste (D.val.Droite) ;\r
+ L := Insert (Racine.Right,L) ;\r
+ R := Delete (R) ;\r
+ X.Val.Droite:=Copie_Liste (R);\r
+ X.Val.Gauche:=Copie_Liste (L) ;\r
+ D.Right := New Node ;\r
+ D.Right:=X;\r
+ Kill (L) ;\r
+ Kill (R) ;\r
+ \r
+End Op_Negation_D ;\r
+ \r
+ \r
+Unit Op_Alternative_D : Procedure(Input Racine:Noeud;Inout D:Node ) ;\r
+Var R : Liste ,\r
+ X : Node ;\r
+Begin\r
+ \r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ R := Copie_Liste (D.Val.Droite) ;\r
+ R := Delete (R) ;\r
+ R := Insert (Racine.Left,R) ;\r
+ R := Insert (Racine.Right,R) ;\r
+ X.Val.Gauche := Copie_Liste (D.Val.Gauche) ;\r
+ X.Val.Droite := Copie_Liste (R) ;\r
+ D.Right := New Node ;\r
+ D.Right := X ;\r
+ Kill (R) ;\r
+ \r
+End Op_Alternative_D ;\r
+ \r
+ \r
+Unit Op_Conjonction_D : Procedure (Input Racine:Noeud;\r
+ Inout D : Node) ;\r
+Var S,R : Liste ,\r
+ X,Y : Node ;\r
+Begin\r
+ \r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ Y := new Node ;\r
+ Y.Val := New Sequence ;\r
+ R := Copie_Liste (D.Val.Droite) ;\r
+ R := Delete (R) ;\r
+ S := Copie_Liste (R) ;\r
+ S := Insert (Racine.Left,S) ;\r
+ R := Insert (Racine.Right,R) ;\r
+ X.Val.Gauche := Copie_Liste (D.Val.Gauche) ;\r
+ X.Val.Droite := Copie_Liste (S) ;\r
+ Y.val.Gauche := Copie_Liste (D.Val.Gauche) ;\r
+ Y.Val.Droite := Copie_Liste (R) ;\r
+ D.Left := New Node ;\r
+ D.Right := New Node ;\r
+ D.Left := X ;\r
+ D.Right := Y ;\r
+ Kill (R) ;\r
+ Kill (S) ;\r
+ \r
+End Op_Conjonction_D ;\r
+ \r
+ \r
+Unit Op_Implique_D : Procedure (Input Racine:Noeud;Inout D:Node ) ;\r
+Var L,R : Liste ,\r
+ X : Node ;\r
+Begin\r
+ \r
+ X := new Node ;\r
+ X.Val := New Sequence ;\r
+ L := Copie_Liste (D.Val.Gauche) ;\r
+ R := Copie_Liste (D.val.Droite) ;\r
+ X.Val.Gauche := Copie_Liste (Insert (Racine.Left,L)) ;\r
+ R := Delete (R) ;\r
+ X.Val.Droite := Copie_Liste (Insert (Racine.Right,R)) ;\r
+ D.Right := New Node ;\r
+ D.Right := X ;\r
+ Kill (L) ;\r
+ Kill (R) ;\r
+ \r
+End Op_Implique_D ;\r
+ \r
+ \r
+Unit Trait_List_G : Procedure (Racine:Noeud;Inout D:Node);\r
+Begin\r
+ \r
+ Case Racine.Valeur\r
+ When '|' : Call Op_Negation_G (Racine,D) ;\r
+ When '%' : Call Op_Alternative_G (Racine,D) ;\r
+ When '&' : Call Op_Conjonction_G (Racine,D) ;\r
+ When '>' : Call Op_Implique_G (Racine,D) ;\r
+ Esac;\r
+ \r
+End trait_List_G ;\r
+ \r
+Unit Trait_List_D : Procedure (Racine:Noeud;Inout D:Node);\r
+ \r
+Begin\r
+ \r
+ Case Racine.Valeur\r
+ When '|' : Call Op_Negation_D (Racine,D) ;\r
+ When '%' : Call Op_Alternative_D (Racine,D) ;\r
+ When '&' : Call Op_Conjonction_D (Racine,D) ;\r
+ When '>' : Call Op_Implique_D (Racine,D) ;\r
+ Esac;\r
+ \r
+End trait_List_D ;\r
+ \r
+ \r
+ \r
+ \r
+Unit Decompose : Procedure (Inout Diagramme : Node);\r
+Var D,X,Y:Node,\r
+ Courant,L : Liste ,\r
+ Fin,Trouve : Boolean ,\r
+ Racine : Noeud ;\r
+Begin\r
+ D := Diagramme ;\r
+ If D<>None\r
+ Then\r
+ If D.Val.Gauche<>None AndIf (D.Val.Gauche.Debut.Valeur='&'\r
+ Or D.Val.Gauche.Debut.Valeur='%'\r
+ Or D.Val.Gauche.Debut.Valeur='>'\r
+ Or D.Val.Gauche.Debut.Valeur='|')\r
+ Then\r
+ Racine := Copy (D.Val.Gauche.Debut) ;\r
+ Call Trait_List_G (Racine,D) ;\r
+ \r
+ Else\r
+ If D.Val.Droite<>None AndIf (D.Val.Droite.Debut.Valeur='&'\r
+ Or D.Val.Droite.Debut.Valeur='%'\r
+ Or D.Val.Droite.Debut.Valeur='>'\r
+ Or D.Val.Droite.Debut.Valeur='|')\r
+ Then Racine := Copy (D.Val.Droite.Debut) ;\r
+ Call Trait_List_D (Racine,D) ;\r
+ Fi ;\r
+ Fi;\r
+ WriteLn ;\r
+ Call Decompose (D.Left) ;\r
+ Call Decompose (D.right) ;\r
+ Diagramme := D ;\r
+ Fi ;\r
+End Decompose ;\r
+ \r
+ \r
+ \r
+Unit Parcours_Arbre_Right : Procedure(racine : Noeud;Sens,I,J:Integer;\r
+ Inout Z:Integer);\r
+Var P : Noeud ;\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ p:=racine;\r
+ If p <> none Then\r
+ If P.Left<>None\r
+ Then Call Move (I+8*Z,J) ;\r
+ Call Hascii (0) ;\r
+ Call Hascii (40) ;\r
+ Z:=Z+1 ;\r
+ Fi ;\r
+ Call Parcours_Arbre_Right(p.Left,Sens,I,J,Z);\r
+ Call Move (I+8*Z,J);\r
+ Call Hascii (0) ;\r
+ Case P.Valeur\r
+ When '&' : Call dessine_et(I+8*Z,J);\r
+ When '%' : Call dessine_ou(I+8*Z,J);\r
+ When '>' : Call dessine_implique(I+8*Z,J);\r
+ When '|' : Call dessine_non(I+8*Z,J);\r
+ otherwise Call Hascii(Ord(P.Valeur));\r
+ esac;\r
+ Z:=Z+1;\r
+ If P.Valeur='|'\r
+ Then Call Move (I+8*Z,J) ;\r
+ Call Hascii (0) ;\r
+ Call Hascii (40) ;\r
+ Z:=Z+1 ;\r
+ Fi;\r
+ call parcours_Arbre_Right(p.Right,Sens,I,J,Z);\r
+ If P.Right<>None Or P.Valeur='|'\r
+ Then Call Move (I+8*Z,J) ;\r
+ Call Hascii (0) ;\r
+ Call Hascii (41) ;\r
+ Z:=Z+1 ;\r
+ Fi ;\r
+ Fi ;\r
+End;\r
+End Parcours_Arbre_Right;\r
+ \r
+ \r
+ \r
+Unit Parcours_Arbre_Left : procedure(racine : Noeud;Sens,I,J:Integer;\r
+ InOut Z:Integer);\r
+Var P : Noeud ;\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ p:=racine;\r
+ If p <> none Then\r
+ If P.Left<>None Or P.Valeur='|'\r
+ Then Call Move (I+8*Z,J) ;\r
+ Call Hascii (0) ;\r
+ Call Hascii (41) ;\r
+ Z:=Z-1 ;\r
+ Fi ;\r
+ Call parcours_Arbre_Left(p.Right,Sens,I,J,Z);\r
+ If P.Valeur='|'\r
+ Then Call Move (I+8*Z,J) ;\r
+ Call Hascii (0) ;\r
+ Call Hascii (40) ;\r
+ Z:=Z-1 ;\r
+ Fi;\r
+ Call Move (I+8*Z,J);\r
+ Call Hascii (0) ;\r
+ Case P.Valeur\r
+ When '&' : Call dessine_et(I+8*Z,J);\r
+ When '%' : Call dessine_ou(I+8*Z,J);\r
+ When '>' : Call dessine_implique(I+8*Z,J);\r
+ When '|' : Call dessine_non(I+8*Z,J);\r
+ otherwise Call Hascii(Ord(P.Valeur));\r
+ esac;\r
+ Z:=Z-1;\r
+ Call parcours_Arbre_Left(p.Left,Sens,I,J,Z);\r
+ If P.Right<>None And P.Valeur<>'|'\r
+ Then Call Move (I+8*Z,J) ;\r
+ Call Hascii (0) ;\r
+ Call Hascii (40) ;\r
+ Z:=Z-1 ;\r
+ Fi ;\r
+ Fi ;\r
+End;\r
+End Parcours_Arbre_Left;\r
+ \r
+ \r
+ \r
+Unit Affiche_Liste : Procedure (Input L:Liste;I,J,Sens:Integer );\r
+Var Z : Integer ;\r
+Begin\r
+ Pref IIUWGRAPH Block\r
+ Begin\r
+ Call color(12);\r
+ Call Move (I,J) ;\r
+ Call dessine_fleche(I,J);\r
+ Z:=0;\r
+ Call color(15);\r
+ If L=None\r
+ Then Call Move(I+Sens,J);\r
+ Call dessine_vide(I+sens,J);\r
+ Fi ;\r
+ While L<>None\r
+ Do\r
+ Z:=0;\r
+ I:=I+Sens;\r
+ Call Move (I,J) ;\r
+ If Sens =-8\r
+ Then Call Parcours_Arbre_Left (L.Debut,Sens,I,J,Z);\r
+ Else Call Parcours_Arbre_Right(L.Debut,Sens,I,J,Z);\r
+ Fi ;\r
+ L := L.Suivant ;\r
+ If L<>None\r
+ Then I:=I+8*Z;\r
+ Call Move (I,J);\r
+ Call Hascii (0) ;\r
+ Call Hascii (44);\r
+ Fi ;\r
+ Od ;\r
+ End;\r
+End Affiche_Liste ;\r
+ \r
+ \r
+Unit Parcours : Procedure(Racine:Node;X,Y,Z:integer);\r
+Var P : Node ;\r
+Begin\r
+ Pref IIUWGRAPH Block\r
+ Begin\r
+ P := Racine;\r
+ If P <> None Then\r
+ Call Affiche_Liste (P.Val.Gauche,X,Y,-8) ;\r
+ Call Affiche_Liste (P.Val.Droite,X,Y,+8) ;\r
+ Call Parcours(P.Left,X-Z,Y+32,Z/2) ;\r
+ If P.Left<>None Then Call color(11);\r
+ Call Move (X,Y+8) ;\r
+ Call Draw (X-Z,Y+30) ;\r
+ Call Move (X,Y+8) ;\r
+ Call Draw (X+Z,Y+30) ;\r
+ Call color(15);\r
+ Call Parcours(P.Right,X+Z,Y+32,Z/2) ;\r
+ Else If P.Right<>None\r
+ Then Call color(11);\r
+ Call Move (X,Y+8) ;\r
+ Call Draw (X,Y+30) ;\r
+ Call color(15);\r
+ Fi ;\r
+ Call Parcours(P.Right,X,Y+32,Z/2) ;\r
+ Fi;\r
+ Fi;\r
+ End;\r
+End Parcours;\r
+ \r
+ \r
+(****************************************************)\r
+(* Evaluation de la Tautologicit\82 de la formule *)\r
+(****************************************************)\r
+ \r
+ \r
+Unit Recherche_Tautologie : Procedure(Left,Right:Liste;X,Y,Z:Integer;\r
+ OutPut H:Boolean) ;\r
+Var Element : Char,\r
+ Large,Xx: Integer,\r
+ Totaul : Boolean,\r
+ L,R : Liste;\r
+ \r
+Begin\r
+ Totaul := False ;\r
+ Large := 24;\r
+ Xx:=x;\r
+ X := X-8;\r
+ H := False ;\r
+ L := Copie_Liste (Left);\r
+ R := Copie_Liste (Right);\r
+ If (Left=None) Or (Right=None)\r
+ Then\r
+ call texte(150,Y+20,11,\r
+ "Cette expression n'est pas une tautologie.") ;\r
+ Else Element := Left.Debut.valeur ;\r
+ Do\r
+ Do\r
+ If Element = Right.Debut.Valeur Then Exit; Fi;\r
+ Right := Right.Suivant ;\r
+ If Right = None Then Exit; Fi;\r
+ Od;\r
+ If Right<>None Then\r
+ call texte(150,Y+20,11,\r
+ "Cette expression est une tautologie.");\r
+ Totaul:=True ;\r
+ H := True ;\r
+ Fi ;\r
+ If Totaul Then Exit; Fi;\r
+ Left := Left.Suivant ;\r
+ If Left = None Then\r
+ call texte(150,Y+20,11,\r
+ "Cette expression n'est pas une tautologie.");\r
+ Exit;\r
+ Fi;\r
+ Right := Copie_Liste(R);\r
+ Od;\r
+ Fi ;\r
+ If Not Totaul\r
+ Then While L<>None\r
+ Do L:=L.Suivant ;\r
+ If L<>None Then X:=X-16;\r
+ Large:=Large+16;\r
+ Fi;\r
+ Od;\r
+ While R<>None\r
+ Do R:=R.Suivant ;\r
+ If R<>None Then Large:=Large+16;\r
+ Fi;\r
+ Od;\r
+ Call Rectangle (X-1,Y,Large+2,8,15) ;\r
+ Fi;\r
+ \r
+End Recherche_Tautologie;\r
+ \r
+ \r
+Unit Affiche_Feuille:Procedure (D:Node;X,Y,Z:Integer;Inout H:Boolean);\r
+Begin\r
+ If D<>None\r
+ Then If Not H Then Return;\r
+ Fi;\r
+ Call Affiche_Feuille (D.Left,X-Z,Y+32,Z/2,H) ;\r
+ If D.Left<>None\r
+ Then Call Affiche_Feuille (D.Right,X+Z,Y+32,Z/2,H) ;\r
+ Else Call Affiche_Feuille (D.Right,X,Y+32,Z/2,H) ;\r
+ Fi ;\r
+ If (D.Left=None) And (D.Right=None)\r
+ Then\r
+ Call Recherche_Tautologie(D.Val.Gauche,D.Val.Droite,X,Y,Z,H);\r
+ Fi ;\r
+ Fi;\r
+End Affiche_Feuille ;\r
+ \r
+ \r
+(************************************)\r
+(* Proc\82dures Graphiques *)\r
+(************************************)\r
+ \r
+ \r
+ \r
+Unit Rectangle : Procedure (X,Y,Large,Haut,Col:Integer) ;\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Color(Col) ;\r
+ Call Move (X,Y) ;\r
+ Call Draw (X+Large,Y) ;\r
+ Call Draw (X+Large,Y+Haut) ;\r
+ Call Draw (X,Y+haut) ;\r
+ Call Draw (X,Y) ;\r
+End ;\r
+End ;\r
+ \r
+ \r
+ \r
+Unit Fill : Procedure (X,Y,Large,Haut,Col:Integer) ;\r
+Var I:Integer ;\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Color (Col) ;\r
+ For I:=Y To Y+Haut\r
+ Do\r
+ Call Move(X,I) ;\r
+ Call Draw(X+Large,I) ;\r
+ Od ;\r
+End ;\r
+End ;\r
+ \r
+ \r
+Unit Texte : Procedure (X,Y,col : integer; s : string);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Color (Col) ;\r
+ Call Move (X,Y);\r
+ Call outstring(s);\r
+End ;\r
+End ;\r
+ \r
+ \r
+Unit dessine_et : Procedure(X,Y : integer);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Hascii(0);\r
+ Call move(X,Y+6);\r
+ Call draw(X+3,Y+2);\r
+ Call draw(X+6,Y+6);\r
+End;\r
+End;\r
+ \r
+ \r
+Unit dessine_ou : Procedure(X,Y : integer);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Hascii(0);\r
+ Call move(X,Y+2);\r
+ Call draw(X+3,Y+6);\r
+ Call draw(X+6,Y+2);\r
+End;\r
+End;\r
+ \r
+ \r
+Unit dessine_implique : Procedure(X,Y : integer);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Hascii(0);\r
+ Call move(X,Y+2);\r
+ Call draw(X+4,Y+2);\r
+ Call move(X,Y+4);\r
+ Call draw(X+4,Y+4);\r
+ Call move(X+3,Y);\r
+ Call draw(X+6,Y+3);\r
+ Call draw(X+3,Y+6);\r
+ \r
+End;\r
+End;\r
+ \r
+ \r
+Unit dessine_non : Procedure(X,Y : integer);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Hascii(0);\r
+ Call move(X+1,Y);\r
+ Call draw(X+3,Y);\r
+ Call draw(X+3,Y+6);\r
+End;\r
+End;\r
+ \r
+ \r
+Unit dessine_vide : Procedure(X,Y : integer);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Hascii(0);\r
+ Call cirb(X+3,Y+4,3,0,0,15,0,1,1);\r
+ Call move(X,Y+7);\r
+ Call draw(X+8,Y);\r
+End;\r
+End;\r
+ \r
+ \r
+Unit dessine_fleche : Procedure(X,Y : integer);\r
+Begin\r
+Pref IIUWGRAPH Block\r
+Begin\r
+ Call Hascii(0);\r
+ Call move(X+1,Y+4);\r
+ Call draw(X+7,Y+4);\r
+ Call move(X+4,Y+1);\r
+ Call draw(X+7,Y+4);\r
+ Call draw(X+4,Y+7);\r
+End;\r
+End;\r
+ \r
+ \r
+(********************************)\r
+(* Programe Principal *)\r
+(********************************)\r
+ \r
+Begin\r
+ array valeur dim(1:47);\r
+ Pref IIUWGRAPH Block\r
+ Begin\r
+ Call Gron (0) ;\r
+ Do\r
+ Call Cls ;\r
+ Call Rectangle (120,10,344,40,15);\r
+ Call Rectangle (125,51,345,6,15);\r
+ Call Rectangle (465,15,6,42,15);\r
+ Call Fill (126,51,344,5,9);\r
+ Call Fill (465,16,5,37,9);\r
+ Call texte(121,27,15,\r
+ " EVALUATION DE PROPOSITIONS LOGIQUES ");\r
+ Call Rectangle (100,150,400,72,15) ;\r
+ Call move(100,200);\r
+ Call draw(500,200);\r
+ Call Rectangle (144,200,44,22,15);\r
+ Call Rectangle (232,200,44,22,15);\r
+ Call texte(105,208,12,"F1:");\r
+ Call dessine_et(131,208);\r
+ Call texte(149,208,12,"F2:");\r
+ Call dessine_ou(175,208);\r
+ Call texte(193,208,12,"F3:");\r
+ Call dessine_implique(219,208);\r
+ Call texte(237,208,12,"F4:");\r
+ Call dessine_non(263,208);\r
+ Call texte(285,208,12,"Variables : a,b,c,d,x,y,z");\r
+ Call texte(105,160,15,"Entrez la proposition : (");\r
+ Call texte(308,160,12,"F10 ");\r
+ Call texte(340,160,15,"pour quitter)");\r
+ Call texte(110,184,15,\r
+ "------------------------------------------------");\r
+ Call Rectangle (100,250,400,60,15) ;\r
+ Call Move (100,290) ;\r
+ Call Draw (500,290) ;\r
+ Call Texte (225,297,12,"Fen\88tre de messages");\r
+ Call Move(110,180);\r
+ longueur:=0;\r
+ \r
+ Do\r
+ Ch := New Chaine;\r
+ If Analyseur(Longueur) Then\r
+ Call texte(153,280,15,"Appuyez sur une touche pour continuer");\r
+ while inkey=0 do od;\r
+ Exit;\r
+ else\r
+ Call texte(153,280,15,"Appuyez sur une touche pour continuer");\r
+ while inkey=0 do od;\r
+ Call Fill (101,251,398,38,0) ;\r
+ Call move(110+(longueur*8),180);\r
+ Fi;\r
+ Od;\r
+ \r
+ call cls ;\r
+ call color(15);\r
+ H := True ;\r
+ i:=1;\r
+ call Operateur(longueur,racine);\r
+ xx :=320;\r
+ Y := 80;\r
+ Z:=256;\r
+ Diagramme := New Node;\r
+ Diagramme.Val := New Sequence ;\r
+ Diagramme.Val.Droite := Insert (Racine,Diagramme.Val.Droite) ;\r
+ Courant := Diagramme ;\r
+ Call decompose(Diagramme) ;\r
+ Call texte(105,32,12,\r
+ "Evolution de la formule suivant la methode de GENTZEN") ;\r
+ Call texte(97,40,12,\r
+ "ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ") ;\r
+ Call color(15);\r
+ Call parcours(Courant,xx,y,Z);\r
+ Call texte(130,320,12,"Appuyez sur une touche pour continuer");\r
+ While inkey=0 do od;\r
+ Call Texte(130,320,12," ");\r
+ Call Affiche_Feuille (Diagramme,320,80,256,H) ;\r
+ While inkey=0 do od;\r
+Od;\r
+ Call Groff;\r
+End ;\r
+End Evaluationdepropositionslogiques;\r
+ \r
--- /dev/null
+Program systemefenetrage;\r
+\r
+(***************************************************************************)\r
+(* Programme de syst\8ame de fenetrage avec boutons et gestion de la souris *)\r
+(* PATAUD Fr\82d\82ric & PEYRAT Fran\87ois 1993/1994 *)\r
+(***************************************************************************)\r
+\r
+Begin\r
+Pref iiuwgraph block\r
+\r
+ Begin\r
+ Pref mouse block\r
+\r
+var\r
+ f : file,\r
+ w : windows;\r
+\r
+ Unit Line : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ End Line;\r
+\r
+ Unit Rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ writeln(f,x1,y1,x2,y2,c);\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1);\r
+ End Rectangle;\r
+\r
+ Unit Rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ var i : integer;\r
+ Begin\r
+ for i:=y1 to y2\r
+ do\r
+ call Line(x1,i,x2,i,c);\r
+ od\r
+ End Rectanglef;\r
+\r
+ Unit windows : class;\r
+ var\r
+ ind,indc,x1,y1,x2,y2: integer,\r
+ rgs_pere : rgs,\r
+ menubar : menu;\r
+\r
+ unit menu : class(nom : string,action : integer,suiv : menu);\r
+ var\r
+ p_rgs : rgs,\r
+ x1,y1,x2,y2,c : integer;\r
+\r
+ unit affiche : procedure;\r
+ begin\r
+ if suiv =/= none\r
+ then\r
+ call suiv.affiche;\r
+ fi;\r
+ call rectanglef(x1+1,y1+1,x2-1,y2-1,7);\r
+ call color(c);\r
+ call move(x1+10,y2-15);\r
+ call outstring(nom);\r
+ call rectangle(x1,y1,x2,y2,c);\r
+ end affiche;\r
+\r
+ begin\r
+ c := indc;\r
+ indc := indc + 1;\r
+ x1 := 20 + ind;\r
+ y1 := 5;\r
+ x2 := 120 + ind;\r
+ y2 := 25;\r
+ p_rgs := rgs_pere;\r
+ while p_rgs.suiv =/= none do p_rgs := p_rgs.suiv;od ;\r
+ p_rgs.suiv := new rgs(x1,y1,x2,y2,action);\r
+ ind := ind + 120;\r
+ end menu;\r
+\r
+ unit gestionnaire : procedure;\r
+ var\r
+ choix,h,v,p,b:integer,\r
+ l,r,c:boolean;\r
+ begin\r
+ call showcursor;\r
+ do\r
+ l,r := false;\r
+ (* call status(h,v,l,r,c);\r
+ if r then exit fi;\r
+ p:=0;\r
+ call status(h,v,l,r,c);*)\r
+ while not l and not r do call getpress(0,h,v,p,l,r,c);od;\r
+ if r then exit fi;\r
+ if p <>0 then\r
+ call rectangle(50,50,h,v,3);\r
+ choix := 0;\r
+ choix := quoi(h,v);\r
+ writeln(f,"choix : ",choix);\r
+ case choix\r
+ when 1 : call rectangle(200,200,250,250,3);\r
+ writeln(f,"r1 ");\r
+ when 2 : call rectangle(160,160,300,300,3);\r
+ writeln(f,"r2");\r
+ when 3 : call rectangle(120,120,350,350,3);\r
+ writeln(f,"r3");\r
+ esac;\r
+ fi;\r
+ p := 0;\r
+ od;\r
+ end;\r
+\r
+ unit quoi : function (h,v : integer) : integer;\r
+ var\r
+ p_rgs : rgs,\r
+ resultat : integer,\r
+ a,b,c : boolean;\r
+ begin\r
+ p_rgs := rgs_pere;\r
+ p_rgs := p_rgs.suiv;\r
+ do\r
+ a:=(p_rgs.x1 < h and p_rgs.x2> h ) ;\r
+ b:=(p_rgs.y1 < v and p_rgs.y2 > v) ;\r
+ c:= a and b;\r
+ if c then\r
+ result := p_rgs.code;\r
+ return;\r
+ fi;\r
+ if p_rgs.suiv =/= none\r
+ then\r
+ p_rgs:=p_rgs.suiv;\r
+ else\r
+ result := 0;\r
+ return;\r
+ fi;\r
+ od;\r
+ end quoi;\r
+\r
+ unit rgs : class(x1,y1,x2,y2,code : integer);\r
+ var\r
+ suiv : rgs;\r
+ begin\r
+ call rectangle(x1,y1+100,x2,y2+100,15);\r
+ end rgs;\r
+\r
+ unit affiche : procedure(x1,y1,x2,y2 : integer);\r
+ begin\r
+ call rectangle(x1,y1,x2,y2,1);\r
+ call rectanglef(x1+3,y1+3,x2-3,30,8);\r
+ call rectangle(x1+3,33,x2-3,y2-3,9);\r
+ end affiche;\r
+\r
+ begin\r
+ ind := 0;\r
+ indc := 4;\r
+ x1 := 0;\r
+ y1 := 0;\r
+ x2 := 639;\r
+ y2 := 479;\r
+ call affiche(x1,y1,x2,y2);\r
+ rgs_pere := new rgs(0,0,0,0,0);\r
+ inner;\r
+ call gestionnaire;\r
+ End windows;\r
+\r
+ Unit monwindows : windows class;\r
+ begin\r
+ menubar := new menu("troisieme",3,\r
+ new menu("deuxieme",2,\r
+ new menu("premier",1,none)));\r
+ call menubar.affiche;\r
+ End monwindows;\r
+\r
+\r
+\r
+\r
+ Begin\r
+ open(f,text,unpack("testing"));\r
+ call rewrite(f);\r
+ call gron(1);\r
+ w := new monwindows;\r
+ call groff;\r
+ kill(f);\r
+ end;\r
+ end;\r
+end.\r
--- /dev/null
+program M;\r
+ (* example of multilevel iheritance *)\r
+ var x: integer;\r
+ unit A: class;\r
+ var x: integer;\r
+ begin\r
+ x := 3;\r
+ inner;\r
+ end A;\r
+begin\r
+ pref A block\r
+ var y: integer, bb: B;\r
+ unit B: class;\r
+ begin\r
+ x := y;\r
+ writeln(x);\r
+ inner;\r
+ end B;\r
+ begin\r
+ y := 2;\r
+ bb := new B;\r
+ pref A block\r
+ var y: integer, cc: C;\r
+ unit C: B class;\r
+ begin\r
+ y := x;\r
+ writeln(y);\r
+ inner;\r
+ end C;\r
+ begin\r
+ y := 4;\r
+ cc := new C;\r
+ end\r
+ end;\r
+ writeln(x);\r
+end program;\r
+
\ No newline at end of file
--- /dev/null
+Program SystemedeFenetrage;\r
+\r
+ (*****************************************************************************)\r
+ (* premiere famille de classes : les classes graphiques *)\r
+ (*****************************************************************************)\r
+ Unit Ptr : Class;\r
+ End Ptr;\r
+\r
+ Unit Windows : Ptr Class(father :windows,x1,y1,x2,y2 : integer);\r
+ Close hauteur,largeur;\r
+ Var lborder,cfond,cborder : integer,\r
+ hauteur,largeur : integer,\r
+ xpos,ypos,xmax,ymax : integer,\r
+ num_id : integer,\r
+ save_map : arrayof integer;\r
+\r
+ Unit Affiche : procedure;\r
+ Begin\r
+ call father.rectanglef(x1,y1,x2,y2,cfond);\r
+ End Affiche;\r
+\r
+ Unit virtual rectangle : procedure(xx1,yy1,xx2,yy2,c :integer);\r
+ Begin\r
+ if(xx1<x2 and xx1>x1 and yy1<y2 and yy2>y1)\r
+ then call father.rectangle(xx1,yy1,xx2,yy2,c);\r
+ fi;\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : procedure(xx1,yy1,xx2,yy2,c : integer);\r
+ End rectanglef;\r
+\r
+\r
+ Begin\r
+ hauteur:=y2-y1-2*lborder;\r
+ largeur:=x2-x1-2*lborder;\r
+ End Windows;\r
+\r
+ Unit Bitmap : Windows Class;\r
+ End Bitmap;\r
+\r
+ Unit Son : Windows Class;\r
+ End Son;\r
+\r
+ Unit Maine : Windows Class;\r
+ End Maine;\r
+\r
+ Unit Dialogue : Son Class;\r
+ End Dialogue;\r
+\r
+ Unit Catalogue : Dialogue Class;\r
+ End Catalogue;\r
+\r
+ Unit Question : Dialogue Class;\r
+ End Question;\r
+\r
+ Unit Widgets : Ptr Class;\r
+ End Widgets;\r
+\r
+ Unit Menu : Widgets Class;\r
+ End Menu;\r
+\r
+ Unit Menu_V : Menu Class;\r
+ End Menu_V;\r
+\r
+ Unit Menu_H : Menu Class;\r
+ End Menu_H;\r
+\r
+ Unit Bottons : Widgets Class;\r
+ End Bottons;\r
+\r
+ Unit Racc : Bottons Class;\r
+ End Racc;\r
+\r
+ Unit Opt_list : Bottons Class;\r
+ End Opt_list;\r
+\r
+ Unit Oneline : Opt_list Class;\r
+ End Oneline;\r
+\r
+ Unit Multiline : Opt_list Class;\r
+ End Multiline;\r
+\r
+ Unit Botton : Bottons Class;\r
+ End Botton;\r
+\r
+ Unit Lift : Widgets Class;\r
+ End Lift;\r
+\r
+ Unit Lift_V : Lift Class;\r
+ End Lift_V;\r
+\r
+ Unit Lift_H : Lift Class;\r
+ End Lift_H;\r
+\r
+ (*****************************************************************************)\r
+ (* deuxieme famille de classes : les structures de donnees *)\r
+ (*****************************************************************************)\r
+ Unit Ensemble : CLass;\r
+ End Ensemble;\r
+\r
+ Unit Queue : Ensemble Class;\r
+ End Queue;\r
+\r
+ Unit Ofpriority : Queue Class;\r
+ End Ofpriority;\r
+\r
+ Unit ListD : Ensemble Class;\r
+ End ListD;\r
+\r
+ Unit Clic : ListD Class;\r
+ End Clic;\r
+\r
+ Unit Bot : ListD Class;\r
+ End Bot;\r
+\r
+ Unit Key : ListD Class;\r
+ End Key;\r
+\r
+ Unit Win : ListD Class;\r
+ End Win;\r
+\r
+ Unit Stack : Ensemble Class;\r
+ End Stack;\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* Famille de process *)\r
+ (*****************************************************************************)\r
+ Unit Applications : process (node : integer);\r
+ End Applications;\r
+\r
+ Unit Gest_event : mouse process (node : integer,gest : gest_wind);\r
+\r
+ Unit ready : procedure;\r
+ End ready;\r
+\r
+ Unit event : function(output v,h,p,l,r,c : integer) : boolean;\r
+ Begin\r
+ result:=getpress(v,h,p,l,r,c);\r
+ End;\r
+\r
+ Var i :integer,\r
+ v,h,p,l,r,c : integer;\r
+ Begin\r
+ return;\r
+ accept ready;\r
+ call init(1,1);\r
+ call showcursor;\r
+ do\r
+ if(event(v,h,p,l,r,c))\r
+ then call gest.event(v,h,p,l,r,c);\r
+ fi;\r
+ od\r
+ End Gest_event;\r
+\r
+ Unit Gest_wind : iiuwgraph process(node,x1,y1,x2,y2 : integer,gest:gest_event);\r
+ Var i :integer,\r
+ v,p,h,l,r,c : integer,\r
+ w : windows,\r
+ j : graph;\r
+\r
+ Unit getinfo : procedure (g : gest_event);\r
+ Begin\r
+ gest:=g;\r
+ disable getinfo;\r
+ End getinfo;\r
+\r
+ Unit event : procedure (input lv,lh,lp,ll,lr,lc : integer);\r
+ Begin\r
+ v:=lv; h:=lh; p:=lp; l:=ll; r:=lr; c:=lc;\r
+ End event;\r
+\r
+ Unit traitement : procedure;\r
+ Begin\r
+ if((h=164 and l=27) or c=3)\r
+ then call fin;\r
+ fi;\r
+ call patern(80,25,130,100,0,1);\r
+ call track(40,10,4,v);\r
+ call track(140,10,4,p);\r
+ call track(80,30,4,h);\r
+ call track(80,50,4,l);\r
+ call track(80,70,4,r);\r
+ call track(80,90,4,c);\r
+ End traitement;\r
+\r
+ Unit fin : procedure;\r
+ begin\r
+ call groff;\r
+ writeln("on ferme");\r
+ call endrun;\r
+ End fin;\r
+\r
+ Unit graph : windows class;\r
+\r
+ Unit virtual rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call patern(x1,y1,x2,y2,c,0);\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call patern(x1,y1,x2,y2,c,1);\r
+ End rectanglef;\r
+\r
+ End graph;\r
+\r
+ Begin\r
+ call gron(0);\r
+ j:=new graph(none,0,0,0,0);\r
+ w:=new windows(j,x1,y1,x2,y2);\r
+ w.cfond:=10;\r
+ call w.affiche;\r
+ return;\r
+ accept getinfo;\r
+ call gest.ready;\r
+ call outstring(10,40,"Windows",0,10);\r
+ do\r
+ accept event;\r
+ call traitement;\r
+ od;\r
+ call groff;\r
+ End Gest_wind;\r
+\r
+ Unit Application : Applications process;\r
+ End Application;\r
+\r
+\r
+(*****************************************************************************)\r
+(* P r o g r a m m e P r i n c i p a l *)\r
+(*****************************************************************************)\r
+Var i : integer,\r
+ G1 : Gest_wind,\r
+ G2 : Gest_event;\r
+handlers\r
+ when memerror : call endrun;\r
+ when syserror : call endrun;\r
+end handlers;\r
+Begin\r
+ G1:=new Gest_wind(0,0,0,640,480,none);\r
+ G2:=new Gest_event(0,G1);\r
+ resume(G1);\r
+ resume(G2);\r
+ call G1.getinfo(G2);\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+Program SystemedeFenetrage;\r
+\r
+Const Noir =0,Bleu =1,Vert =2,Cyan =3,\r
+ Rouge =4,Magenta =5,Marron =6,GrisCLair =7,\r
+ GrisFonce =8,BleuClair =9,VertClair =10,CyanClair =11,\r
+ RougeClair =12,MagentaClair =13,Jaune =14,Blanc =15;\r
+\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* premiere famille de classes : les classes graphiques *)\r
+ (*****************************************************************************)\r
+ Unit Ptr : Class;\r
+ End Ptr;\r
+\r
+ Unit Windows : Ptr Class(father :windows,x1,y1,x2,y2 : integer);\r
+ Close hauteur,largeur;\r
+ Var lborder,cfond,cborder : integer,\r
+ lbande,cfbande,cbbande : integer,\r
+ hauteur,largeur : integer,\r
+ xpos,ypos,xmax,ymax : integer,\r
+ xdeb,ydeb : integer,\r
+ num_id : integer,\r
+ ListM : Lclic,\r
+ ListK : LKey,\r
+ nombande : arrayof char,\r
+ barcde : menu,\r
+ save_map : arrayof integer;\r
+\r
+ Unit option : procedure (l1,l2,l3,l4,l5,l6 : integer,l7 : arrayof char);\r
+ Begin\r
+ cfond:=l1; lborder:=l2; cborder:=l3; lbande:=l4;\r
+ cfbande:=l5; cbbande:=l6;\r
+ nombande:=copy(l7);\r
+ End option;\r
+\r
+ Unit Affiche : procedure;\r
+ Var i,j,k :integer;\r
+ Begin\r
+ call father.rectanglef(x1,y1,x2,y2,cfond);\r
+ for i:=0 to lborder\r
+ do\r
+ call father.rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
+ od;\r
+ i:=y1+lborder+1;\r
+ call father.rectanglef(x1+lborder+1,i,x2-lborder-1,i+imax(14,lbande),cfbande);\r
+ j:=(x2-x1-2*lborder-8*(upper(nombande)-lower(nombande)))/2;\r
+ for i:=lower(nombande) to upper(nombande)\r
+ do\r
+ k:=x1+lborder+j+i*8;\r
+ call father.outxyascii(k,y1+lborder+2,ord(nombande(i)),cbbande,cfbande);\r
+ od;\r
+ call affichesuite;\r
+ if(barcde<>none)\r
+ then call barcde.affichemenu;\r
+ fi\r
+ End Affiche;\r
+\r
+ Unit virtual affichesuite :procedure;\r
+ End affichesuite;\r
+\r
+ Unit virtual rectangle : procedure(xx1,yy1,xx2,yy2,c :integer);\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : procedure(xx1,yy1,xx2,yy2,c : integer);\r
+ End rectanglef;\r
+\r
+ Unit virtual outxyascii : procedure(x,y,car,cf,cb : integer);\r
+ End outxyascii;\r
+\r
+ Unit virtual outxytext : procedure(x,y:integer,chaine:string,c1,c2:integer);\r
+ End outxytext;\r
+\r
+ Begin\r
+ hauteur:=y2-y1-2*lborder;\r
+ largeur:=x2-x1-2*lborder;\r
+ End Windows;\r
+\r
+ Unit Bitmap : Windows Class;\r
+ End Bitmap;\r
+\r
+ Unit Son : Windows Class;\r
+ End Son;\r
+\r
+ Unit Maine : Windows Class;\r
+ End Maine;\r
+\r
+ Unit Dialogue : Son Class;\r
+ End Dialogue;\r
+\r
+ Unit Catalogue : Dialogue Class;\r
+ End Catalogue;\r
+\r
+ Unit Question : Dialogue Class;\r
+ End Question;\r
+\r
+ Unit Widgets : Ptr Class(father : windows);\r
+ End Widgets;\r
+\r
+ (**********************************************************************)\r
+ Unit Menu : Widgets Class(x,y,col_e,col_f: integer);\r
+ Var liste : ensemble;\r
+\r
+ Unit item : element class(nom : string,key : integer,suite :Menu);\r
+ End item;\r
+\r
+ Unit insert : procedure(nom : string,key : integer,s : menu);\r
+ var e : item;\r
+ Begin\r
+ e:=new item(nom,key,s);\r
+ if(liste=none)\r
+ then liste:=new ensemble;\r
+ fi;\r
+ call liste.insert(e);\r
+ End insert;\r
+\r
+ Unit virtual affichemenu : procedure;\r
+ End affichemenu;\r
+\r
+ End Menu;\r
+\r
+ Unit Menu_V : Menu Class;\r
+\r
+ Unit virtual affichemenu : procedure;\r
+ Var cour : item,\r
+ tlen : arrayof char,\r
+ len : integer,\r
+ xx,yy : integer;\r
+ Begin\r
+ call liste.initialise;\r
+ xx:=x; yy:=y;\r
+ if(liste.getelm(cour))\r
+ then while(cour<>none)\r
+ do\r
+ call father.outxytext(xx,yy,cour.nom,col_e,col_f);\r
+ tlen:=unpack(cour.nom);\r
+ len:=upper(tlen)-lower(tlen)+1;\r
+ kill(tlen);\r
+ if(father.ListM=none)\r
+ then father.ListM:=new LClic;\r
+ fi;\r
+ call father.ListM.insert(new elm_c(0 ,xx,yy,xx+len*8,yy+14));\r
+ (* id *)\r
+ yy:=yy+20;\r
+ if not liste.getelm(cour)\r
+ then exit\r
+ fi\r
+ od\r
+ fi\r
+ End affichemenu;\r
+\r
+ End Menu_V;\r
+\r
+ Unit Menu_H : Menu Class;\r
+ End Menu_H;\r
+\r
+ Unit Bottons : Widgets Class;\r
+ End Bottons;\r
+\r
+ Unit Racc : Bottons Class;\r
+ End Racc;\r
+\r
+ Unit Opt_list : Bottons Class;\r
+ End Opt_list;\r
+\r
+ Unit Oneline : Opt_list Class;\r
+ End Oneline;\r
+\r
+ Unit Multiline : Opt_list Class;\r
+ End Multiline;\r
+\r
+ Unit Botton : Bottons Class;\r
+ End Botton;\r
+\r
+ Unit Lift : Widgets Class;\r
+ End Lift;\r
+\r
+ Unit Lift_V : Lift Class;\r
+ End Lift_V;\r
+\r
+ Unit Lift_H : Lift Class;\r
+ End Lift_H;\r
+\r
+ (*****************************************************************************)\r
+ (* deuxieme famille de classes : les structures de donnees *)\r
+ (*****************************************************************************)\r
+ Unit element : class; (* general *)\r
+ End element;\r
+\r
+ Unit elm_c : element class(id,x1,y1,x2,y2 : integer); (* listclic *)\r
+ End elm_c;\r
+\r
+ Unit elm_a : element class(p : Applications); (* liste application *)\r
+ End elm_a;\r
+\r
+\r
+ Unit Ensemble : CLass;\r
+ Var root,last : node,\r
+ courant : node;\r
+\r
+ Unit node : class(elm : element);\r
+ Var next : node;\r
+ End node;\r
+\r
+ Unit virtual insert : procedure(e : element);\r
+ Begin\r
+ if not member(e)\r
+ then if empty\r
+ then root:=new node(e);\r
+ last:=root;\r
+ else last.next:=new node(e);\r
+ last:=last.next;\r
+ fi\r
+ fi\r
+ End insert;\r
+\r
+ Unit virtual delete : procedure(e : element);\r
+ Var flag : node;\r
+ Begin\r
+ if member(e)\r
+ then flag:=courant.next;\r
+ if flag=last\r
+ then last:=courant;\r
+ courant.next:=none;\r
+ kill(flag);\r
+ else if courant.next<>none\r
+ then courant.next:=courant.next.next;\r
+ kill(flag);\r
+ fi\r
+ fi\r
+ fi\r
+ End delete;\r
+\r
+ Unit virtual member : function (e : element) : boolean;\r
+ Var savecou : node,\r
+ bl : boolean;\r
+ Begin\r
+ courant:=root;\r
+ savecou:=courant;\r
+ bl:=false;\r
+ while(courant<>none)\r
+ do\r
+ if not egalite(courant.elm,e)\r
+ then savecou:=courant;\r
+ courant:=courant.next;\r
+ else bl:=true;\r
+ exit;\r
+ fi\r
+ od;\r
+ courant:=savecou;\r
+ result:=bl;\r
+ End member;\r
+\r
+ Unit virtual egalite : function (e1,e2 :element) :boolean;\r
+ End egalite;\r
+\r
+ Unit empty : function : boolean;\r
+ Begin\r
+ result:=(root=none);\r
+ End empty;\r
+\r
+ Unit initialise : procedure;\r
+ Begin\r
+ courant:=root;\r
+ End initialise;\r
+\r
+ Unit getelm : function(output e : element) :boolean;\r
+ Begin\r
+ if(courant<>none)\r
+ then e:=courant.elm;\r
+ result:=true;\r
+ courant:=courant.next;\r
+ else result:=false;\r
+ fi\r
+ End getelm;\r
+\r
+ End Ensemble;\r
+\r
+ Unit Queue : Ensemble Class;\r
+ End Queue;\r
+\r
+ Unit Ofpriority : Queue Class;\r
+ End Ofpriority;\r
+\r
+ Unit ListD : Ensemble Class;\r
+ End ListD;\r
+\r
+ Unit LClic : ListD Class;\r
+\r
+ Unit virtual egalite : function (e1,e2 :element) :boolean;\r
+ Begin\r
+ if (e1 qua elm_c.x1=e2 qua elm_c.x1 and e1 qua elm_c.x2=e2 qua elm_c.x2\r
+ and e1 qua elm_c.y1=e2 qua elm_c.y1 and e1 qua elm_c.y2=e2 qua elm_c.y2)\r
+ then result:=TRUE;\r
+ else result:=FALSE;\r
+ fi\r
+ End egalite;\r
+\r
+ Unit appartient : function (x,y : integer) : boolean;\r
+ Var e : elm_c,\r
+ b : boolean;\r
+ Begin\r
+ call initialise;\r
+ b:=false;\r
+ while(getelm(e))\r
+ do\r
+ if (x>=e.x1 and x<=e.x2 and y>=e.y1 and y<=e.y2)\r
+ then b:=TRUE;\r
+ exit;\r
+ fi\r
+ od;\r
+ result:=b;\r
+ End appartient;\r
+\r
+ End LClic;\r
+\r
+ Unit LBot : ListD Class;\r
+ End LBot;\r
+\r
+ Unit LAppli : ListD Class;\r
+ End LAppli;\r
+\r
+ Unit LKey : ListD Class;\r
+ End LKey;\r
+\r
+ Unit LWin : ListD Class;\r
+ End LWin;\r
+\r
+ Unit Stack : Ensemble Class;\r
+ End Stack;\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* Famille de process *)\r
+ (*****************************************************************************)\r
+ Unit Applications : process (node,x1,y1,x2,y2 : integer,father : Gest_Wind);\r
+ Var w : windows, (* maine *)\r
+ Filles : windows, (* son *)\r
+ i : integer;\r
+\r
+ Unit virtual gestionnaire : procedure(id : integer);\r
+ Begin\r
+ End gestionnaire;\r
+\r
+ Begin\r
+ writeln("coucou");\r
+ w:=new windows(father.getw,x1,y1,x2,y2);\r
+ return;\r
+ writeln("toto");\r
+ call w.option(Noir,3,VertClair,15,VertCLair,Noir,unpack("nom"));\r
+ call w.affiche;\r
+ do\r
+ od;\r
+ End Applications;\r
+\r
+ (************************************************************************)\r
+ (************************************************************************)\r
+ Unit Gest_event : mouse process (node : integer,gest : gest_wind);\r
+\r
+ Unit ready : procedure;\r
+ End ready;\r
+\r
+ Unit event : function(output v,h,p,l,r,c : integer) : boolean;\r
+ Begin\r
+ result:=getpress(v,h,p,l,r,c);\r
+ End;\r
+\r
+ Var i :integer,\r
+ v,h,p,l,r,c : integer;\r
+ Begin\r
+ return;\r
+ accept ready;\r
+ call init(1,1);\r
+ call showcursor;\r
+ do\r
+ if(event(v,h,p,l,r,c))\r
+ then call gest.event(v,h,p,l,r,c);\r
+ fi;\r
+ od\r
+ End Gest_event;\r
+\r
+ (***********************************************************************)\r
+ (***********************************************************************)\r
+ Unit Gest_wind : iiuwgraph process(node,x1,y1,x2,y2 : integer,gest:gest_event);\r
+ Var i,k :integer,\r
+ v,p,h,l,r,c : integer,\r
+ ListK : LKey,\r
+ ListM : LClic,\r
+ ListA : LAppli,\r
+ w : windows,\r
+ j : graph;\r
+\r
+\r
+ Unit getinfo : procedure (g : gest_event);\r
+ Begin\r
+ gest:=g;\r
+ disable getinfo;\r
+ writeln("getinfo");\r
+ End getinfo;\r
+\r
+ Unit event : procedure (input lv,lh,lp,ll,lr,lc : integer);\r
+ Begin\r
+ v:=lv; h:=lh; p:=lp; l:=ll; r:=lr; c:=lc;\r
+ End event;\r
+\r
+ Unit traitement : procedure;\r
+ Begin\r
+ if((h=164 and l=27) or c=3)\r
+ then call fin;\r
+ fi;\r
+\r
+ (* recherche dans un arbre des fenetres filles si l'evenement *)\r
+ (* appartient a qqn *)\r
+\r
+\r
+\r
+ End traitement;\r
+\r
+ Unit fin : procedure;\r
+ begin\r
+ call groff;\r
+ writeln("on ferme");\r
+ call endrun;\r
+ End fin;\r
+\r
+ (***********************************************************************)\r
+ Unit graph : windows class;\r
+\r
+ Unit virtual rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call patern(x1,y1,x2,y2,c,0);\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call patern(x1,y1,x2,y2,c,1);\r
+ End rectanglef;\r
+\r
+ Unit virtual ligne : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ End ligne;\r
+\r
+ Unit virtual outxyascii : procedure (x,y,car,cf,cb :integer);\r
+ Begin\r
+ call move(x,y);\r
+ call color(cf);\r
+ call border(cb);\r
+ call hascii(car);\r
+ End outxyascii;\r
+\r
+ Unit virtual outxytext : procedure (x,y :integer, chaine :string,c1,c2 :integer);\r
+ Begin\r
+ call outstring(x,y,chaine,c1,c2);\r
+ End outxytext;\r
+\r
+ Unit virtual affichesuite : procedure;\r
+ Var x,y : integer;\r
+ Begin\r
+ x:=x1+100-lborder; y:=y1+lbande+lborder+1;\r
+ call rectanglef(x,y,x+lborder,y2-lborder-1,cborder);\r
+ x:=x+lborder; y:=y2-100-lborder;\r
+ call rectanglef(x,y,x2-lborder,y+lborder,cborder);\r
+ xdeb:=x1+100+10;\r
+ ydeb:=y1+lborder+lbande+10;\r
+ End affichesuite;\r
+\r
+ End graph;\r
+\r
+ Unit initialisation1 : procedure;\r
+ Var itermed1 : menu_v,\r
+ i,j : integer;\r
+ Begin\r
+ i:=w.lborder+10+20; j:=y1+w.lborder+10+w.lbande+20*4;\r
+ itermed1:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
+ call itermed1.insert("Nouveau",319,none);\r
+ call itermed1.insert("Ouvrir",320,none);\r
+ call itermed1.insert("D\82placer",321,none);\r
+ call itermed1.insert("Copier",322,none);\r
+ call itermed1.insert("Supprimer",323,none);\r
+ call itermed1.insert("Propri\82t\82",324,none);\r
+ i:=w.lborder+10; j:=y1+w.lborder+10+w.lbande;\r
+ w.barcde:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
+ call w.barcde.insert("Fichier",315,itermed1);\r
+ call w.barcde.insert("Options",316,none);\r
+ call w.barcde.insert("Fenetre",317,none);\r
+ call w.barcde.insert("Aide",318,none);\r
+ End initialisation1;\r
+\r
+ Unit initialisation2 : procedure;\r
+ Begin\r
+ ListA:=new LAppli;\r
+ End initialisation2;\r
+\r
+ Unit xdeb : function : integer;\r
+ Begin\r
+ result:=w.xdeb;\r
+ End xdeb;\r
+\r
+ Unit ydeb : function : integer;\r
+ Begin\r
+ result:=w.ydeb;\r
+ End ydeb;\r
+\r
+ Unit getw : function : windows;\r
+ Begin\r
+ result:=w;\r
+ End getw;\r
+\r
+\r
+ Begin\r
+ call gron(0 ); (* 3 = 1024x768x256 *)\r
+ j:=new graph(none,x1,y1,x2,y2);\r
+ w:=new windows(j,x1,y1,x2,y2);\r
+ call w.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
+ call initialisation1;\r
+ call w.affiche;\r
+ call J.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
+ call j.affichesuite;\r
+ return;\r
+ accept getinfo;\r
+ enable xdeb,ydeb,getw;\r
+ call gest.ready;\r
+ call initialisation2;\r
+ do\r
+ accept event;\r
+ call traitement;\r
+ od;\r
+ call groff;\r
+ End Gest_wind;\r
+\r
+\r
+(*****************************************************************************)\r
+(* P r o g r a m m e P r i n c i p a l *)\r
+(*****************************************************************************)\r
+Var i : integer,\r
+ G1 : Gest_wind,\r
+ Z1 : applications,\r
+ G2 : Gest_event,\r
+ x,y :integer;\r
+Begin\r
+ G1:=new Gest_wind(0,0,0,640,480,none);\r
+ G2:=new Gest_event(0,G1);\r
+ resume(G1);\r
+ resume(G2);\r
+ call G1.getinfo(G2);\r
+\r
+ x:=G1.xdeb;\r
+ writeln("x=",x);\r
+ y:=G1.ydeb;\r
+ writeln("y=",y);\r
+ Z1:=new applications(0,x+10,y+10,x+330,y+210,G1);\r
+\r
+\r
+ call G1.ListA.insert(new elm_a(Z1));\r
+ resume(Z1);\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+Program SystemedeFenetrage;\r
+begin\r
+pref iiuwgraph block\r
+(* version lightweight processus *)\r
+Const Noir =0,Bleu =1,Vert =2,Cyan =3,\r
+ Rouge =4,Magenta =5,Marron =6,GrisCLair =7,\r
+ GrisFonce =8,BleuClair =9,VertClair =10,CyanClair =11,\r
+ RougeClair =12,MagentaClair =13,Jaune =14,Blanc =15;\r
+\r
+\r
+ (*********************************************************************)\r
+ (* notion de lightweight process *)\r
+ (*********************************************************************)\r
+var actualp: proces;\r
+var active: set;\r
+var suspended :set;\r
+\r
+ unit semafor : class;\r
+ hidden close SEM, SUSPENDED;\r
+ var SEM : boolean;\r
+ var SUSPENDED : set;\r
+\r
+ unit tsp : function : boolean;\r
+ begin\r
+ result := SEM;\r
+ sem := true;\r
+ end tsp;\r
+\r
+ unit up : procedure;\r
+ begin\r
+ SEM := false;\r
+ end up;\r
+\r
+ unit lockp : procedure;\r
+ begin\r
+ if SEM\r
+ then\r
+ call active.delete(actualp);\r
+ call suspended.insert(actualp);\r
+ actualp.suspndd := true;\r
+ actualp := active.amember;\r
+ attach(actualp);\r
+ else\r
+ SEM := true\r
+ fi\r
+ end lockp;\r
+\r
+ unit unlockp : procedure;\r
+ var aux : proces;\r
+\r
+ begin\r
+ if suspended.empty\r
+ then\r
+ SEM := false\r
+ else\r
+ aux := suspended.min;\r
+ call suspended.delete(aux);\r
+ aux.suspndd := false;\r
+ call active.insert(aux)\r
+ fi\r
+ end unlockp;\r
+\r
+ begin (* initialization of a semaphore*)\r
+ suspended := new set\r
+ end semafor;\r
+\r
+\r
+ unit set : class;\r
+ (* in this version it will be a queue *)\r
+\r
+ unit link : class(x : proces);\r
+ var next : link\r
+ end link;\r
+\r
+ var head, tail : link;\r
+\r
+ unit insert : procedure(x : proces);\r
+ var ogniwo : link;\r
+ begin\r
+ ogniwo := new link(x);\r
+ if tail = none\r
+ then\r
+ head := ogniwo\r
+ else\r
+ tail.next := ogniwo\r
+ fi;\r
+ tail := ogniwo\r
+ end insert;\r
+\r
+ unit empty : function : boolean;\r
+ begin\r
+ result := (head = none)\r
+ end empty;\r
+\r
+ unit min : function : proces;\r
+ begin\r
+ result := head.x;\r
+ end min;\r
+\r
+ unit delete : procedure (x : proces);\r
+ var o,ogniwo : link;\r
+ begin\r
+ o,ogniwo := head;\r
+ while ogniwo.x =/= x\r
+ do\r
+ o := ogniwo;\r
+ ogniwo := ogniwo.next;\r
+ if ogniwo = none\r
+ then\r
+ writeln(" deleted process does not exist");\r
+ return\r
+ fi;\r
+ od;\r
+ if ogniwo = head\r
+ then\r
+ head := head.next\r
+ fi;\r
+ o.next := ogniwo.next;\r
+ if ogniwo = tail\r
+ then\r
+ tail := o;\r
+ tail.next := none\r
+ fi;\r
+ kill(ogniwo)\r
+ end delete;\r
+\r
+ unit amember : function : proces;\r
+ var o : link;\r
+ begin\r
+ result := head.x;\r
+ if head.next =/= none\r
+ then\r
+ o := head;\r
+ tail.next := o;\r
+ tail := o;\r
+ head := head.next;\r
+ o.next := none\r
+ fi\r
+ end amember;\r
+\r
+ end set;\r
+\r
+\r
+\r
+ unit proces : coroutine;\r
+ (* this class implements notion of process*)\r
+ var nrofsons : integer;\r
+ var waiting, terminated, suspndd : boolean;\r
+ var father, nameofson : proces;\r
+\r
+ unit resumep : procedure(x : proces);\r
+ begin\r
+ if x.suspndd\r
+ then\r
+ call suspended.delete(x);\r
+ call active.insert(x);\r
+ x.suspndd := false;\r
+ else\r
+ if x.terminated\r
+ then\r
+ (* error *)\r
+ writeln(" you are resuming a terminated process?!");\r
+ return\r
+ fi\r
+ fi\r
+ end resumep;\r
+\r
+\r
+ unit stopp : procedure;\r
+ begin\r
+ call active.delete(actualp);\r
+ call suspended.insert(actualp);\r
+ suspndd := true;\r
+ actualp := active.amember;\r
+ attach(actualp)\r
+ end stopp;\r
+\r
+ unit waitp : function(y : proces) : proces;\r
+ begin\r
+ if y = none\r
+ then\r
+ (*error*)\r
+ writeln(" waiting for a process which does not exist");\r
+ return\r
+ fi;\r
+ if y.terminated\r
+ then\r
+ return\r
+ fi;\r
+ if y.father =/= this proces\r
+ then\r
+ (* error *)\r
+ writeln(" y is not your son!");\r
+ return\r
+ fi;\r
+ (* O.K. *)\r
+ nameofson := y;\r
+ waiting := true;\r
+ call stopp;\r
+\r
+ (* here we shall return upon termination of son*)\r
+ result := nameofson;\r
+ waiting := false;\r
+ end waitp;\r
+\r
+\r
+ unit stoppar :procedure (z:semafor);\r
+ begin\r
+ call z.unlockp;\r
+ call stopp\r
+ end stoppar;\r
+\r
+ unit waitn : function : proces;\r
+ begin\r
+ if nrofsons = 0\r
+ then (*error*)\r
+ writeln(" you wait for a son, but it does not exist ");\r
+ return;\r
+ else\r
+ waiting:=true;\r
+ nameofson:=none;\r
+ call stopp;\r
+ (* you return here *)\r
+ result:=nameofson;\r
+ waiting:= false;\r
+ fi;\r
+ end waitn;\r
+\r
+ unit xqmulti : procedure;\r
+ begin\r
+ actualp:=active.amember;\r
+ attach(actualp)\r
+ end xqmulti;\r
+\r
+ begin (*prologue of process*)\r
+ father:= actualp;\r
+ if father =/= none\r
+ then\r
+ father.nrofsons:=father.nrofsons +1;\r
+ fi;\r
+ call suspended.insert (this proces);\r
+ suspndd:=true;\r
+\r
+ inner; (* here comes the body of your process *)\r
+\r
+ (* process epilogue *)\r
+ terminated :=true;\r
+ call active.delete(actualp);\r
+ if father =/= none\r
+ then\r
+ father.nrofsons:=father.nrofsons - 1;\r
+ if father.waiting\r
+ then\r
+ if father.nameofson = none\r
+ then\r
+ father.nameofson := this proces\r
+ fi;\r
+ if father.nameofson = this proces\r
+ then\r
+ call resumep(father)\r
+ fi\r
+ fi;\r
+ actualp:=active.amember;\r
+ attach(actualp);\r
+ else\r
+ attach(main);\r
+ fi;\r
+ end proces;\r
+ unit resumep : procedure(x : proces);\r
+ begin\r
+ if x.suspndd\r
+ then\r
+ call suspended.delete(x);\r
+ call active.insert(x);\r
+ x.suspndd := false;\r
+ else\r
+ if x.terminated\r
+ then\r
+ (* error *)\r
+ writeln(" you are resuming a terminated process?!");\r
+ return\r
+ fi\r
+ fi\r
+ end resumep;\r
+\r
+ unit Arbitrage : procedure;\r
+ begin\r
+ actualp:=active.amember;\r
+ attach(actualp);\r
+ end Arbitrage;\r
+\r
+\r
+\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* premiere famille de classes : les classes graphiques *)\r
+ (*****************************************************************************)\r
+ Unit Ptr : Class;\r
+ End Ptr;\r
+\r
+ Unit Windows : Ptr Class(father :windows,x1,y1,x2,y2 : integer);\r
+ Close hauteur,largeur;\r
+ Var lborder,cfond,cborder : integer,\r
+ lbande,cfbande,cbbande : integer,\r
+ hauteur,largeur : integer,\r
+ xpos,ypos,xmax,ymax : integer,\r
+ xdeb,ydeb : integer,\r
+ num_id : integer,\r
+ ListM : Lclic,\r
+ ListK : LKey,\r
+ nombande : arrayof char,\r
+ barcde : menu,\r
+ save_map : arrayof integer;\r
+\r
+ Unit option : procedure (l1,l2,l3,l4,l5,l6 : integer,l7 : arrayof char);\r
+ Begin\r
+ cfond:=l1; lborder:=l2; cborder:=l3; lbande:=l4;\r
+ cfbande:=l5; cbbande:=l6;\r
+ nombande:=copy(l7);\r
+ writeln("coucou2 l1=",l1);\r
+ End option;\r
+\r
+ Unit Affiche : procedure;\r
+ Var i,j,k :integer;\r
+ Begin\r
+ call father.rectanglef(x1,y1,x2,y2,cfond);\r
+ for i:=0 to lborder\r
+ do\r
+ call father.rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
+ od;\r
+ i:=y1+lborder+1;\r
+ call father.rectanglef(x1+lborder+1,i,x2-lborder-1,i+imax(14,lbande),cfbande);\r
+ j:=(x2-x1-2*lborder-8*(upper(nombande)-lower(nombande)))/2;\r
+ for i:=lower(nombande) to upper(nombande)\r
+ do\r
+ k:=x1+lborder+j+i*8;\r
+ call father.outxyascii(k,y1+lborder+2,ord(nombande(i)),cbbande,cfbande);\r
+ od;\r
+ call affichesuite;\r
+ if(barcde<>none)\r
+ then call barcde.affichemenu;\r
+ fi\r
+ End Affiche;\r
+\r
+ Unit virtual affichesuite :procedure;\r
+ End affichesuite;\r
+\r
+ Unit virtual rectangle : procedure(xx1,yy1,xx2,yy2,c :integer);\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : procedure(xx1,yy1,xx2,yy2,c : integer);\r
+ End rectanglef;\r
+\r
+ Unit virtual outxyascii : procedure(x,y,car,cf,cb : integer);\r
+ End outxyascii;\r
+\r
+ Unit virtual outxytext : procedure(x,y:integer,chaine:string,c1,c2:integer);\r
+ End outxytext;\r
+\r
+ Begin\r
+ hauteur:=y2-y1-2*lborder;\r
+ largeur:=x2-x1-2*lborder;\r
+ End Windows;\r
+\r
+ Unit Bitmap : Windows Class;\r
+ End Bitmap;\r
+\r
+ Unit Son : Windows Class;\r
+ End Son;\r
+\r
+ Unit Maine : Windows Class;\r
+ End Maine;\r
+\r
+ Unit Dialogue : Son Class;\r
+ End Dialogue;\r
+\r
+ Unit Catalogue : Dialogue Class;\r
+ End Catalogue;\r
+\r
+ Unit Question : Dialogue Class;\r
+ End Question;\r
+\r
+ Unit Widgets : Ptr Class(father : windows);\r
+ End Widgets;\r
+\r
+ (**********************************************************************)\r
+ Unit Menu : Widgets Class(x,y,col_e,col_f: integer);\r
+ Var liste : ensemble;\r
+\r
+ Unit item : element class(nom : string,key : integer,suite :Menu);\r
+ End item;\r
+\r
+ Unit insert : procedure(nom : string,key : integer,s : menu);\r
+ var e : item;\r
+ Begin\r
+ e:=new item(nom,key,s);\r
+ if(liste=none)\r
+ then liste:=new ensemble;\r
+ fi;\r
+ call liste.insert(e);\r
+ End insert;\r
+\r
+ Unit virtual affichemenu : procedure;\r
+ End affichemenu;\r
+\r
+ End Menu;\r
+\r
+ Unit Menu_V : Menu Class;\r
+\r
+ Unit virtual affichemenu : procedure;\r
+ Var cour : item,\r
+ tlen : arrayof char,\r
+ len : integer,\r
+ xx,yy : integer;\r
+ Begin\r
+ call liste.initialise;\r
+ xx:=x; yy:=y;\r
+ if(liste.getelm(cour))\r
+ then while(cour<>none)\r
+ do\r
+ call father.outxytext(xx,yy,cour.nom,col_e,col_f);\r
+ tlen:=unpack(cour.nom);\r
+ len:=upper(tlen)-lower(tlen)+1;\r
+ kill(tlen);\r
+ if(father.ListM=none)\r
+ then father.ListM:=new LClic;\r
+ fi;\r
+ call father.ListM.insert(new elm_c(0 ,xx,yy,xx+len*8,yy+14));\r
+ (* id *)\r
+ yy:=yy+20;\r
+ if not liste.getelm(cour)\r
+ then exit\r
+ fi\r
+ od\r
+ fi\r
+ End affichemenu;\r
+\r
+ End Menu_V;\r
+\r
+ Unit Menu_H : Menu Class;\r
+ End Menu_H;\r
+\r
+ Unit Bottons : Widgets Class;\r
+ End Bottons;\r
+\r
+ Unit Racc : Bottons Class;\r
+ End Racc;\r
+\r
+ Unit Opt_list : Bottons Class;\r
+ End Opt_list;\r
+\r
+ Unit Oneline : Opt_list Class;\r
+ End Oneline;\r
+\r
+ Unit Multiline : Opt_list Class;\r
+ End Multiline;\r
+\r
+ Unit Botton : Bottons Class;\r
+ End Botton;\r
+\r
+ Unit Lift : Widgets Class;\r
+ End Lift;\r
+\r
+ Unit Lift_V : Lift Class;\r
+ End Lift_V;\r
+\r
+ Unit Lift_H : Lift Class;\r
+ End Lift_H;\r
+\r
+ (*****************************************************************************)\r
+ (* deuxieme famille de classes : les structures de donnees *)\r
+ (*****************************************************************************)\r
+ Unit element : class; (* general *)\r
+ End element;\r
+\r
+ Unit elm_c : element class(id,x1,y1,x2,y2 : integer); (* listclic *)\r
+ End elm_c;\r
+\r
+ Unit elm_a : element class(p : Applications); (* liste application *)\r
+ End elm_a;\r
+\r
+\r
+ Unit Ensemble : CLass;\r
+ Var root,last : node,\r
+ courant : node;\r
+\r
+ Unit node : class(elm : element);\r
+ Var next : node;\r
+ End node;\r
+\r
+ Unit virtual insert : procedure(e : element);\r
+ Begin\r
+ if not member(e)\r
+ then if empty\r
+ then root:=new node(e);\r
+ last:=root;\r
+ else last.next:=new node(e);\r
+ last:=last.next;\r
+ fi\r
+ fi\r
+ End insert;\r
+\r
+ Unit virtual delete : procedure(e : element);\r
+ Var flag : node;\r
+ Begin\r
+ if member(e)\r
+ then flag:=courant.next;\r
+ if flag=last\r
+ then last:=courant;\r
+ courant.next:=none;\r
+ kill(flag);\r
+ else if courant.next<>none\r
+ then courant.next:=courant.next.next;\r
+ kill(flag);\r
+ fi\r
+ fi\r
+ fi\r
+ End delete;\r
+\r
+ Unit virtual member : function (e : element) : boolean;\r
+ Var savecou : node,\r
+ bl : boolean;\r
+ Begin\r
+ courant:=root;\r
+ savecou:=courant;\r
+ bl:=false;\r
+ while(courant<>none)\r
+ do\r
+ if not egalite(courant.elm,e)\r
+ then savecou:=courant;\r
+ courant:=courant.next;\r
+ else bl:=true;\r
+ exit;\r
+ fi\r
+ od;\r
+ courant:=savecou;\r
+ result:=bl;\r
+ End member;\r
+\r
+ Unit virtual egalite : function (e1,e2 :element) :boolean;\r
+ End egalite;\r
+\r
+ Unit empty : function : boolean;\r
+ Begin\r
+ result:=(root=none);\r
+ End empty;\r
+\r
+ Unit initialise : procedure;\r
+ Begin\r
+ courant:=root;\r
+ End initialise;\r
+\r
+ Unit getelm : function(output e : element) :boolean;\r
+ Begin\r
+ if(courant<>none)\r
+ then e:=courant.elm;\r
+ result:=true;\r
+ courant:=courant.next;\r
+ else result:=false;\r
+ fi\r
+ End getelm;\r
+\r
+ End Ensemble;\r
+\r
+ Unit Queue : Ensemble Class;\r
+ End Queue;\r
+\r
+ Unit Ofpriority : Queue Class;\r
+ End Ofpriority;\r
+\r
+ Unit ListD : Ensemble Class;\r
+ End ListD;\r
+\r
+ Unit LClic : ListD Class;\r
+\r
+ Unit virtual egalite : function (e1,e2 :element) :boolean;\r
+ Begin\r
+ if (e1 qua elm_c.x1=e2 qua elm_c.x1 and e1 qua elm_c.x2=e2 qua elm_c.x2\r
+ and e1 qua elm_c.y1=e2 qua elm_c.y1 and e1 qua elm_c.y2=e2 qua elm_c.y2)\r
+ then result:=TRUE;\r
+ else result:=FALSE;\r
+ fi\r
+ End egalite;\r
+\r
+ Unit appartient : function (x,y : integer) : boolean;\r
+ Var e : elm_c,\r
+ b : boolean;\r
+ Begin\r
+ call initialise;\r
+ b:=false;\r
+ while(getelm(e))\r
+ do\r
+ if (x>=e.x1 and x<=e.x2 and y>=e.y1 and y<=e.y2)\r
+ then b:=TRUE;\r
+ exit;\r
+ fi\r
+ od;\r
+ result:=b;\r
+ End appartient;\r
+\r
+ End LClic;\r
+\r
+ Unit LBot : ListD Class;\r
+ End LBot;\r
+\r
+ Unit LAppli : ListD Class;\r
+ End LAppli;\r
+\r
+ Unit LKey : ListD Class;\r
+ End LKey;\r
+\r
+ Unit LWin : ListD Class;\r
+ End LWin;\r
+\r
+ Unit Stack : Ensemble Class;\r
+ End Stack;\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* Famille de process *)\r
+ (*****************************************************************************)\r
+ Unit Applications : proces class(x1,y1,x2,y2 : integer,father : Gest_Wind);\r
+ Var w : windows, (* maine *)\r
+ Filles : windows, (* son *)\r
+ i : integer;\r
+\r
+ Unit virtual gestionnaire : procedure(id : integer);\r
+ Begin\r
+ End gestionnaire;\r
+\r
+ Begin\r
+ writeln("coucou");\r
+ w:=new windows(father.getw,x1,y1,x2,y2);\r
+ return;\r
+ writeln("toto");\r
+ call w.option(Noir,3,VertClair,15,VertCLair,Noir,unpack("nom"));\r
+ call w.affiche;\r
+\r
+ do\r
+ call Arbitrage;\r
+ od;\r
+ End Applications;\r
+\r
+ (************************************************************************)\r
+ (************************************************************************)\r
+ Unit Gest_event : proces class(gest : gest_wind);\r
+\r
+ Unit ready : procedure;\r
+ Begin\r
+ writeln("Gest_events READY");\r
+ End ready;\r
+\r
+ Unit souris: Mouse coroutine;\r
+ begin\r
+ call init(1,1);\r
+ return;\r
+\r
+(* ici on peut mettre la fermeture de la souris *)\r
+ End souris;\r
+\r
+ Var myszka: souris;\r
+\r
+ Unit event : function(output v,h,p,l,r,c : integer) : boolean;\r
+ Begin\r
+ result:=myszka.getpress(v,h,p,l,r,c);\r
+ End;\r
+\r
+ Var i :integer,\r
+ v,h,p,l,r,c : integer;\r
+ Begin\r
+ myszka := new souris;\r
+ (* accept ready; *)\r
+(* call init(1,1); *)\r
+ call myszka.showcursor;\r
+ return;\r
+ do\r
+ if event(v,h,p,l,r,c)\r
+ then\r
+ call gest.event(v,h,p,l,r,c);\r
+ fi;\r
+ call Arbitrage;\r
+ od;\r
+ End Gest_event;\r
+\r
+ (***********************************************************************)\r
+ (***********************************************************************)\r
+ Unit Gest_wind : proces class(x1,y1,x2,y2 : integer,gest:gest_event);\r
+ Var i,k :integer,\r
+ v,p,h,l,r,c : integer,\r
+ ListK : LKey,\r
+ ListM : LClic,\r
+ ListA : LAppli,\r
+ w : windows,\r
+ j : graph;\r
+\r
+\r
+ Unit getinfo : procedure (g : gest_event);\r
+ Begin\r
+ gest:=g;\r
+ disable getinfo;\r
+ writeln("getinfo");\r
+ End getinfo;\r
+\r
+ Unit event : procedure (input lv,lh,lp,ll,lr,lc : integer);\r
+ Begin\r
+ v:=lv; h:=lh; p:=lp; l:=ll; r:=lr; c:=lc;\r
+ End event;\r
+\r
+ Unit traitement : procedure;\r
+ Begin\r
+ if((h=164 and l=27) or c=3)\r
+ then call fin;\r
+ fi;\r
+\r
+ (* recherche dans un arbre des fenetres filles si l'evenement *)\r
+ (* appartient a qqn *)\r
+\r
+\r
+\r
+ End traitement;\r
+\r
+ Unit fin : procedure;\r
+ begin\r
+(* call groff; *)\r
+ attach (j.gr); (* pour terminer iiuwgraph *)\r
+ writeln("on ferme");\r
+ call endrun;\r
+ End fin;\r
+\r
+ (***********************************************************************)\r
+ Unit graph : windows class;\r
+ \r
+ unit graphi: iiuwgraph coroutine;\r
+ begin\r
+ call gron(0); \r
+ return;\r
+\r
+ end graphi;\r
+\r
+ var gr: graphi;\r
+\r
+ Unit virtual rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call gr.patern(x1,y1,x2,y2,c,0);\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ writeln("coucou3 x1=",x1,"x2=",x2,"y1=",y1,"y2=",y2,"c=",c);\r
+ if gr=none then writeln("NONE!") fi;\r
+ call gr.patern(x1,y1,x2,y2,c,1);\r
+\r
+ End rectanglef;\r
+\r
+ Unit virtual ligne : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call gr.color(c);\r
+ call gr.move(x1,y1);\r
+ call gr.draw(x2,y2);\r
+ End ligne;\r
+\r
+ Unit virtual outxyascii : procedure (x,y,car,cf,cb :integer);\r
+ Begin\r
+ call gr.move(x,y);\r
+ call gr.color(cf);\r
+ call gr.border(cb);\r
+ call gr.hascii(car);\r
+ End outxyascii;\r
+\r
+ Unit virtual outxytext : procedure (x,y :integer, chaine :string,c1,c2 :integer);\r
+ Begin\r
+ call gr.outstring(x,y,chaine,c1,c2);\r
+ End outxytext;\r
+\r
+ Unit virtual affichesuite : procedure;\r
+ Var x,y : integer;\r
+ Begin\r
+ x:=x1+100-lborder; y:=y1+lbande+lborder+1;\r
+ call rectanglef(x,y,x+lborder,y2-lborder-1,cborder);\r
+ x:=x+lborder; y:=y2-100-lborder;\r
+ call rectanglef(x,y,x2-lborder,y+lborder,cborder);\r
+ xdeb:=x1+100+10;\r
+ ydeb:=y1+lborder+lbande+10;\r
+ End affichesuite;\r
+ begin\r
+ gr := none;\r
+ (* gr := new graphi; *)\r
+ End graph;\r
+\r
+ Unit initialisation1 : procedure;\r
+ Var itermed1 : menu_v,\r
+ i,j : integer;\r
+ Begin\r
+ i:=w.lborder+10+20; j:=y1+w.lborder+10+w.lbande+20*4;\r
+ itermed1:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
+ call itermed1.insert("Nouveau",319,none);\r
+ call itermed1.insert("Ouvrir",320,none);\r
+ call itermed1.insert("D\82placer",321,none);\r
+ call itermed1.insert("Copier",322,none);\r
+ call itermed1.insert("Supprimer",323,none);\r
+ call itermed1.insert("Propri\82t\82",324,none);\r
+ i:=w.lborder+10; j:=y1+w.lborder+10+w.lbande;\r
+ w.barcde:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
+ call w.barcde.insert("Fichier",315,itermed1);\r
+ call w.barcde.insert("Options",316,none);\r
+ call w.barcde.insert("Fenetre",317,none);\r
+ call w.barcde.insert("Aide",318,none);\r
+ End initialisation1;\r
+\r
+ Unit initialisation2 : procedure;\r
+ Begin\r
+ ListA:=new LAppli;\r
+ End initialisation2;\r
+\r
+ Unit xdeb : function : integer;\r
+ Begin\r
+ result:=w.xdeb;\r
+ End xdeb;\r
+\r
+ Unit ydeb : function : integer;\r
+ Begin\r
+ result:=w.ydeb;\r
+ End ydeb;\r
+\r
+ Unit getw : function : windows;\r
+ Begin\r
+ result:=w;\r
+ End getw;\r
+\r
+\r
+ Begin\r
+ call gron(0 ); (* 3 = 1024x768x256 *)\r
+ j:=new graph(none,x1,y1,x2,y2);\r
+ w:=new windows(j,x1,y1,x2,y2);\r
+\r
+ call w.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
+ call initialisation1;\r
+ call w.affiche;\r
+\r
+ call J.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
+ call j.affichesuite;\r
+ (* accept getinfo; *)\r
+(* enable xdeb,ydeb,getw; *)\r
+(* call gest.ready; *)\r
+ call initialisation2;\r
+ return;\r
+\r
+ do\r
+ (* accept event; *)\r
+ call traitement;\r
+ call Arbitrage;\r
+ od;\r
+ (* call groff; *)\r
+ attach(j.gr);\r
+ End Gest_wind;\r
+\r
+\r
+(*****************************************************************************)\r
+(* P r o g r a m m e P r i n c i p a l *)\r
+(*****************************************************************************)\r
+Var i : integer,\r
+ G1 : Gest_wind,\r
+ Z1 : applications,\r
+ G2 : Gest_event,\r
+ x,y :integer;\r
+\r
+Begin\r
+ active:= new set;\r
+ suspended :=new set;\r
+ G1:=new Gest_wind(0,0,640,480,none);\r
+ G2:=new Gest_event(G1);\r
+ call resumep(G1);\r
+ call resumep(G2); \r
+ call G1.getinfo(G2);\r
+\r
+ x:=G1.w.xdeb;\r
+ writeln("x=",x);\r
+ y:=G1.w.ydeb;\r
+ writeln("y=",y);\r
+ Z1:=new applications(x+10,y+10,x+330,y+210,G1);\r
+\r
+\r
+ call G1.ListA.insert(new elm_a(Z1));\r
+ call resumep(Z1);\r
+ call Arbitrage;\r
+ writeln("Dobro doszli");\r
+end\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+Program SystemedeFenetrage;\r
+\r
+Const Noir =0,Bleu =1,Vert =2,Cyan =3,\r
+ Rouge =4,Magenta =5,Marron =6,GrisCLair =7,\r
+ GrisFonce =8,BleuClair =9,VertClair =10,CyanClair =11,\r
+ RougeClair =12,MagentaClair =13,Jaune =14,Blanc =15;\r
+\r
+Const MODE = 0;\r
+Const XMAX = 640, YMAX= 480;\r
+\r
+ (*****************************************************************************)\r
+ (* premiere famille de classes : les classes graphiques *)\r
+ (*****************************************************************************)\r
+ Unit Ptr : class;\r
+ End Ptr;\r
+\r
+ Unit Windows : process (node : integer,father :windows,x1,y1,x2,y2 : integer);\r
+ Var lborder,cfond,cborder : integer,\r
+ lbande,cfbande,cbbande : integer,\r
+ hauteur,largeur : integer,\r
+ xpos,ypos,xmax,ymax : integer,\r
+ xdeb,ydeb : integer,\r
+ num_id : integer,\r
+ ListM : Lclic,\r
+ ListK : LKey,\r
+ Bout : arrayof bottons,\r
+ nombande : arrayof char,\r
+ barcde : menu,\r
+ save_map : arrayof integer;\r
+\r
+\r
+ Unit option : procedure (l1,l2,l3,l4,l5,l6 : integer,l7 : string);\r
+ Begin\r
+ cfond:=l1; lborder:=l2; cborder:=l3; lbande:=l4;\r
+ cfbande:=l5; cbbande:=l6;\r
+ nombande:=unpack(l7);\r
+ xdeb:=x1+lborder+3;\r
+ ydeb:=y1+lborder+lbande+3;\r
+ bout(1):=new racc(this windows,x1+lborder+1,y1+lborder+1,x1+lborder+1+\r
+ lbande,y1+lborder+1+lbande,spr_close);\r
+ bout(2):=new racc(this windows,x2-lborder-2-lbande*2,y1+lborder+1,\r
+ x2-lborder-2-lbande,y1+lborder+1+lbande,spr_lower);\r
+ bout(3):=new racc(this windows,x2-lborder-1-lbande,y1+lborder+1,\r
+ x2-lborder-1,y1+lborder+1+lbande,spr_upper);\r
+ End option;\r
+\r
+ Unit Affiche : procedure;\r
+ Var i,j,k :integer;\r
+ Begin\r
+ call father.moveto(x1,y1);\r
+ save_map:=father.getmape(x2,y2);\r
+ call father.rectanglef(x1,y1,x2,y2,cfond);\r
+ for i:=0 to lborder\r
+ do\r
+ call father.rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
+ od;\r
+ i:=y1+lborder+1;\r
+ call father.rectanglef(x1+lborder+1,i,x2-lborder-1,i+imax(14,lbande),cfbande);\r
+ j:=(x2-x1-2*lborder-8*(upper(nombande)-lower(nombande)))/2;\r
+ for i:=lower(nombande) to upper(nombande)\r
+ do\r
+ k:=x1+lborder+j+i*8;\r
+ call father.outxyascii(k,y1+lborder+2,ord(nombande(i)),cbbande,cfbande);\r
+ od;\r
+ call affichesuite;\r
+ if(barcde<>none)\r
+ then call barcde.affichemenu;\r
+ fi;\r
+ call bout(1).affiche;\r
+ call bout(2).affiche;\r
+ call bout(3).affiche;\r
+ call affichesuite;\r
+ End Affiche;\r
+\r
+ Unit virtual affichesuite :procedure;\r
+ End affichesuite;\r
+\r
+ Unit virtual moveto : procedure(x1,y1 : integer);\r
+ Begin\r
+ call father.moveto(x1,y1);\r
+ End moveto;\r
+\r
+ Unit virtual getmape : function(x2,y2 : integer) : arrayof integer;\r
+ Begin\r
+ result:=father.getmape(x2,y2);\r
+ End getmape;\r
+\r
+ Unit virtual putmape : procedure(a : arrayof integer);\r
+ Begin\r
+ call father.putmape(a);\r
+ End putmape;\r
+\r
+ Unit virtual rectangle : procedure(xx1,yy1,xx2,yy2,c :integer);\r
+ Begin\r
+ call father.rectangle(xx1,yy1,xx2,yy2,c);\r
+ End rectangle;\r
+\r
+ Unit virtual ligne : procedure (xx1,yy1,xx2,yy2,c : integer);\r
+ Begin\r
+ call father.ligne(xx1,yy1,xx2,yy2,c);\r
+ End ligne;\r
+\r
+ Unit virtual rectanglef : procedure(xx1,yy1,xx2,yy2,c : integer);\r
+ Begin\r
+ call father.rectanglef(xx1,yy1,xx2,yy2,c);\r
+ End rectanglef;\r
+\r
+ Unit virtual outxyascii : procedure(x,y,car,cf,cb : integer);\r
+ Begin\r
+ call father.outxyascii(x,y,car,cf,cb);\r
+ End outxyascii;\r
+\r
+ Unit virtual outxytext : procedure(x,y:integer,chaine:string,c1,c2:integer);\r
+ Begin\r
+ call father.outxytext(x,y,chaine,c1,c2);\r
+ End outxytext;\r
+\r
+ Unit virtual outxyint : procedure(x,y,val,cf,ce :integer);\r
+ Begin\r
+ call father.outxyint(x,y,val,cf,ce);\r
+ End outxyint;\r
+\r
+ unit ydebut: function: integer;\r
+ begin\r
+ result := ydeb\r
+ end ydebut;\r
+ \r
+ unit xdebut: function: integer;\r
+ begin\r
+ result := xdeb\r
+ end xdebut;\r
+\r
+ Unit EndWindow : procedure;\r
+ Begin\r
+ call father.moveto(x1,y1);\r
+ call putmape(save_map);\r
+ End EndWindow;\r
+\r
+ Begin\r
+ hauteur:=y2-y1-2*lborder;\r
+ largeur:=x2-x1-2*lborder;\r
+ array bout dim (1:3);\r
+ return;\r
+\r
+ enable outxytext, outxyascii, rectanglef, rectangle, affichesuite,\r
+ affiche, option, xdebut, ydebut, outxyint, ligne, moveto ,\r
+ getmape, putmape, Endwindow;\r
+ do\r
+ accept\r
+ od\r
+ End Windows;\r
+\r
+ (***********************************************************************)\r
+ Unit graph : windows class;\r
+\r
+ Unit enablegraph : procedure;\r
+ Begin \r
+ End enablegraph;\r
+ \r
+ Unit disablegraph : procedure;\r
+ Begin\r
+ End disablegraph;\r
+ \r
+ Unit virtual rectangle : iiuwgraph procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call patern(x1,y1,x2,y2,c,0);\r
+ End rectangle;\r
+\r
+ Unit virtual rectanglef : iiuwgraph procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call patern(x1,y1,x2,y2,c,1);\r
+ End rectanglef;\r
+\r
+ Unit virtual ligne : iiuwgraph procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ End ligne;\r
+\r
+ Unit virtual outxyascii : iiuwgraph procedure (x,y,car,cf,cb :integer);\r
+ Begin\r
+ call move(x,y);\r
+ call color(cf);\r
+ call border(cb);\r
+ call hascii(car);\r
+ End outxyascii;\r
+\r
+ Unit virtual outxytext : iiuwgraph procedure (x,y :integer, \r
+ chaine :string,c1,c2 :integer);\r
+ Begin\r
+ call outstring(x,y,chaine,c1,c2);\r
+ End outxytext;\r
+\r
+ Unit virtual outxyint : iiuwgraph procedure (x,y,val,cf,ce :integer);\r
+ Begin\r
+ call track(x,y,val,cf,ce);\r
+ End outxyint;\r
+\r
+ Unit virtual moveto : iiuwgraph procedure (x1,y1 : integer);\r
+ Begin\r
+ call move(x1,y1); \r
+ End moveto;\r
+\r
+ Unit virtual getmape : iiuwgraph function (x2,y2 : integer) : arrayof integer;\r
+ Begin\r
+ result:=getmap(x2,y2);\r
+ End getmape;\r
+\r
+ Unit virtual putmape : iiuwgraph procedure (a : arrayof integer);\r
+ Begin\r
+ call putmap(a);\r
+ End putmape;\r
+\r
+ Unit virtual affichesuite : procedure;\r
+ Var x,y : integer;\r
+ Begin\r
+ x:=x1+100-lborder; y:=y1+lbande+lborder+1;\r
+ call rectanglef(x,y,x+lborder,y2-lborder-1,cborder);\r
+ x:=x+lborder; y:=y2-100-lborder;\r
+ call rectanglef(x,y,x2-lborder,y+lborder,cborder);\r
+ xdeb:=x1+100+10;\r
+ ydeb:=y1+lborder+lbande+10;\r
+ End affichesuite;\r
+ \r
+ Begin\r
+ return;\r
+\r
+ enable affichesuite,affiche, option, xdebut, ydebut,\r
+ enablegraph,disablegraph;\r
+ do\r
+ accept\r
+ od\r
+ End graph;\r
+\r
+\r
+ Unit Bitmap : Windows Class;\r
+ End Bitmap;\r
+\r
+ Unit Son : Windows Class;\r
+ End Son;\r
+\r
+ Unit Maine : Windows Class;\r
+ End Maine;\r
+\r
+ Unit Dialogue : Son Class;\r
+ End Dialogue;\r
+\r
+ Unit Catalogue : Dialogue Class;\r
+ End Catalogue;\r
+\r
+ Unit Question : Dialogue Class;\r
+ End Question;\r
+\r
+ Unit Widgets : class(father : windows);\r
+ End Widgets;\r
+\r
+ (**********************************************************************)\r
+ Unit Menu : Widgets Class(x,y,col_e,col_f: integer);\r
+ Var liste : ensemble;\r
+\r
+ Unit item : element class(nom : string,key : integer,suite :Menu);\r
+ End item;\r
+\r
+ Unit insert : procedure(nom : string,key : integer,s : menu);\r
+ var e : item;\r
+ Begin\r
+ e:=new item(nom,key,s);\r
+ if(liste=none)\r
+ then liste:=new ensemble;\r
+ fi;\r
+ call liste.insert(e);\r
+ End insert;\r
+\r
+ Unit virtual affichemenu : procedure;\r
+ End affichemenu;\r
+\r
+ End Menu;\r
+\r
+ Unit Menu_V : Menu Class;\r
+\r
+ Unit virtual affichemenu : procedure;\r
+ Var cour : item,\r
+ tlen : arrayof char,\r
+ len : integer,\r
+ xx,yy : integer;\r
+ Begin\r
+ (* ... *)\r
+ End affichemenu;\r
+\r
+ End Menu_V;\r
+\r
+ Unit Menu_H : Menu Class;\r
+ \r
+ Unit virtual affichemenu : procedure;\r
+ Var cour : item,\r
+ tlen : arrayof char,\r
+ len : integer,\r
+ xx,yy : integer;\r
+ Begin\r
+ (* ... *)\r
+ End affichemenu;\r
+ \r
+ End Menu_H;\r
+\r
+ (***********************************************************************)\r
+ Unit Bottons : Widgets Class(x1,y1,x2,y2 : integer);\r
+ Unit affiche : procedure;\r
+ Begin\r
+ call father.rectanglef(x1,y1,x2,y2,GrisClair);\r
+ call father.ligne(x1,y1,x2,y1,blanc);\r
+ call father.ligne(x1,y1+1,x2-1,y1+1,blanc);\r
+ call father.ligne(x1,y1,x1,y2,blanc);\r
+ call father.ligne(x1+1,y1+2,x1+1,y2-1,blanc);\r
+ call father.ligne(x1+1,y2,x2,y2,GrisFonce);\r
+ call father.ligne(x1+2,y2-1,x2-1,y2-1,GrisFonce);\r
+ call father.ligne(x2,y2,x2,y1+1,GrisFonce);\r
+ call father.ligne(x2-1,y2-1,x2-1,y1+2,GrisFonce);\r
+ call affichesuite;\r
+ End affiche;\r
+\r
+ Unit virtual affichesuite : procedure;\r
+ End affichesuite;\r
+\r
+ End Bottons;\r
+\r
+ Unit Racc : Bottons Class(procedure sprite(x1,y1,x2,y2,c : integer,\r
+ father :windows));\r
+ Unit virtual affichesuite : procedure;\r
+ Begin\r
+ call sprite(x1,y1,x2,y2,Noir,father);\r
+ End affichesuite;\r
+ End Racc;\r
+\r
+ Unit Opt_list : Bottons Class;\r
+ End Opt_list;\r
+\r
+ Unit Oneline : Opt_list Class;\r
+ End Oneline;\r
+\r
+ Unit Multiline : Opt_list Class;\r
+ End Multiline;\r
+\r
+ Unit Botton : Bottons Class;\r
+ End Botton;\r
+\r
+ Unit Lift : Widgets Class;\r
+ End Lift;\r
+\r
+ Unit Lift_V : Lift Class;\r
+ End Lift_V;\r
+\r
+ Unit Lift_H : Lift Class;\r
+ End Lift_H;\r
+\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage des sprites des boutons *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit spr_upper : procedure(x1,y1,x2,y2,couleur : integer,father:windows);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call father.Ligne(x1+x-i/2,y1+y/2+i,x1+x+i/2,y1+y/2+i,couleur);\r
+ od\r
+ End spr_upper;\r
+\r
+(***************************************************************************)\r
+ Unit spr_lower : procedure(x1,y1,x2,y2,couleur : integer,father:windows);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call father.Ligne(x1+x-i/2,y2-y/2-i,x1+x+i/2,y2-y/2-i,couleur);\r
+ od\r
+ End spr_lower;\r
+\r
+(***************************************************************************)\r
+ Unit spr_left : procedure(x1,y1,x2,y2,couleur : integer,father:windows);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call father.Ligne(x2-x/2-i,y1+y-i/2,x2-x/2-i,y1+y+i/2,couleur);\r
+ od\r
+ End spr_left;\r
+\r
+(***************************************************************************)\r
+ Unit spr_right : procedure(x1,y1,x2,y2,couleur : integer,father:windows);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call father.Ligne(x1+x/2+i,y1+y-i/2,x1+x/2+i,y1+y+i/2,couleur);\r
+ od\r
+ End spr_right;\r
+\r
+(***************************************************************************)\r
+ Unit spr_close : procedure(x1,y1,x2,y2,couleur : integer,father:windows);\r
+ var y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ call father.Rectanglef(x1+3,y1+y-1,x2-3,y1+y+1,couleur);\r
+ End spr_close;\r
+\r
+(***************************************************************************)\r
+ Unit spr_point : procedure(x1,y1,x2,y2,couleur : integer,father:windows);\r
+ var x,y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ x:=(x2-x1)/2;\r
+ call father.Rectanglef(x1+x-1,y1+y-1,x1+x+1,y1+y+1,couleur);\r
+ End spr_point;\r
+\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* deuxieme famille de classes : les structures de donnees *)\r
+ (*****************************************************************************)\r
+ Unit element : class; (* general *)\r
+ End element;\r
+\r
+ Unit elm_c : element class(id,x1,y1,x2,y2 : integer); (* listclic *)\r
+ End elm_c;\r
+\r
+ Unit elm_a : element class(p : Applications); (* liste application *)\r
+ End elm_a;\r
+\r
+\r
+ Unit Ensemble : CLass;\r
+ Var root,last : node,\r
+ courant : node;\r
+\r
+ Unit node : class(elm : element);\r
+ Var next : node;\r
+ End node;\r
+\r
+ Unit virtual insert : procedure(e : element);\r
+ Begin\r
+ if not member(e)\r
+ then if empty\r
+ then root:=new node(e);\r
+ last:=root;\r
+ else last.next:=new node(e);\r
+ last:=last.next;\r
+ fi\r
+ fi\r
+ End insert;\r
+\r
+ Unit virtual delete : procedure(e : element);\r
+ Var flag : node;\r
+ Begin\r
+ if member(e)\r
+ then flag:=courant.next;\r
+ if flag=last\r
+ then last:=courant;\r
+ courant.next:=none;\r
+ kill(flag);\r
+ else if courant.next<>none\r
+ then courant.next:=courant.next.next;\r
+ kill(flag);\r
+ fi\r
+ fi\r
+ fi\r
+ End delete;\r
+\r
+ Unit virtual member : function (e : element) : boolean;\r
+ Var savecou : node,\r
+ bl : boolean;\r
+ Begin\r
+ courant:=root;\r
+ savecou:=courant;\r
+ bl:=false;\r
+ while(courant<>none)\r
+ do\r
+ if not egalite(courant.elm,e)\r
+ then savecou:=courant;\r
+ courant:=courant.next;\r
+ else bl:=true;\r
+ exit;\r
+ fi\r
+ od;\r
+ courant:=savecou;\r
+ result:=bl;\r
+ End member;\r
+\r
+ Unit virtual egalite : function (e1,e2 :element) :boolean;\r
+ End egalite;\r
+\r
+ Unit empty : function : boolean;\r
+ Begin\r
+ result:=(root=none);\r
+ End empty;\r
+\r
+ Unit initialise : procedure;\r
+ Begin\r
+ courant:=root;\r
+ End initialise;\r
+\r
+ Unit getelm : function(output e : element) :boolean;\r
+ Begin\r
+ if(courant<>none)\r
+ then e:=courant.elm;\r
+ result:=true;\r
+ courant:=courant.next;\r
+ else result:=false;\r
+ fi\r
+ End getelm;\r
+\r
+ End Ensemble;\r
+\r
+ Unit Queue : Ensemble Class;\r
+ End Queue;\r
+\r
+ Unit Ofpriority : Queue Class;\r
+ End Ofpriority;\r
+\r
+ Unit ListD : Ensemble Class;\r
+ End ListD;\r
+\r
+ Unit LClic : ListD Class;\r
+\r
+ Unit virtual egalite : function (e1,e2 :element) :boolean;\r
+ Begin\r
+ if (e1 qua elm_c.x1=e2 qua elm_c.x1 and e1 qua elm_c.x2=e2 qua elm_c.x2\r
+ and e1 qua elm_c.y1=e2 qua elm_c.y1 and e1 qua elm_c.y2=e2 qua elm_c.y2)\r
+ then result:=TRUE;\r
+ else result:=FALSE;\r
+ fi\r
+ End egalite;\r
+\r
+ Unit appartient : function (x,y : integer) : boolean;\r
+ Var e : elm_c,\r
+ b : boolean;\r
+ Begin\r
+ call initialise;\r
+ b:=false;\r
+ while(getelm(e))\r
+ do\r
+ if (x>=e.x1 and x<=e.x2 and y>=e.y1 and y<=e.y2)\r
+ then b:=TRUE;\r
+ exit;\r
+ fi\r
+ od;\r
+ result:=b;\r
+ End appartient;\r
+\r
+ End LClic;\r
+\r
+ Unit LBot : ListD Class;\r
+ End LBot;\r
+\r
+ Unit LAppli : ListD Class;\r
+ Unit egalite : function (e1,e2 :elm_a) :boolean;\r
+ Begin\r
+ if (e1 qua elm_a.p = e2 qua elm_a.p)\r
+ then result:=TRUE;\r
+ else result:=FALSE;\r
+ fi;\r
+ End egalite;\r
+ End LAppli;\r
+\r
+ Unit LKey : ListD Class;\r
+ End LKey;\r
+\r
+ Unit LWin : ListD Class;\r
+ End LWin;\r
+\r
+ Unit Stack : Ensemble Class;\r
+ End Stack;\r
+\r
+\r
+\r
+ (*****************************************************************************)\r
+ (* Famille de process *)\r
+ (*****************************************************************************)\r
+ Unit Applications : process (node,x1,y1,x2,y2: integer,father: Gest_Wind);\r
+ Var w : windows, (* maine *)\r
+ j : graph,\r
+ Filles : windows, (* son *)\r
+ i : integer,\r
+ nom : string;\r
+\r
+ Unit virtual gestionnaire : procedure(id : integer);\r
+ Begin\r
+ End gestionnaire;\r
+\r
+ Unit affecte : procedure ( nm : string);\r
+ Begin\r
+ nom:=nm;\r
+ End affecte;\r
+\r
+ Begin\r
+ w:=new windows(0,father.getw,x1,y1,x2,y2);\r
+ resume(w);\r
+ return;\r
+ accept affecte;\r
+ call w.option(Noir,3,Bleu,15,Bleu,Blanc,nom);\r
+ call w.affiche;\r
+ End Applications;\r
+\r
+ (************************************************************************)\r
+ (************************************************************************)\r
+ Unit Gest_event : mouse process (node : integer,gest : gest_wind);\r
+\r
+ Unit ready : procedure;\r
+ End ready;\r
+\r
+ Unit event : function(output v,h,p,l,r,c : integer) : boolean;\r
+ Begin\r
+ result:=getpress(v,h,p,l,r,c);\r
+ End;\r
+\r
+ Var i :integer,\r
+ v,h,p,l,r,c : integer;\r
+ Begin\r
+ return;\r
+ accept ready;\r
+ call init(1,1);\r
+ call showcursor;\r
+ do\r
+ if(event(v,h,p,l,r,c))\r
+ then call gest.event(v,h,p,l,r,c);\r
+ fi;\r
+ od\r
+ End Gest_event;\r
+\r
+ (***********************************************************************)\r
+ (***********************************************************************)\r
+ Unit Gest_wind : iiuwgraph process(node,x1,y1,x2,y2 : integer,\r
+ gest:gest_event);\r
+\r
+ Var i,k,px,py :integer,\r
+ v,p,h,l,r,c : integer,\r
+ ListK : LKey,\r
+ ListM : LClic,\r
+ ListA : LAppli,\r
+ w : windows,\r
+ j : graph;\r
+\r
+\r
+ Unit getinfo : procedure (g : gest_event);\r
+ Begin\r
+ gest:=g;\r
+ disable getinfo;\r
+ End getinfo;\r
+\r
+ Unit event : procedure (input lv,lh,lp,ll,lr,lc : integer);\r
+ Begin\r
+ v:=lv; h:=lh; p:=lp; l:=ll; r:=lr; c:=lc;\r
+ call traitement;\r
+ End event;\r
+\r
+\r
+ Unit traitement : procedure;\r
+ \r
+ Unit fin : procedure;\r
+ begin\r
+ call groff;\r
+ call endrun;\r
+ End fin;\r
+ \r
+ Begin\r
+ if((p=164 and l=27) or c=3)\r
+ then call fin;\r
+ fi;\r
+ (* recherche dans un arbre des fenetres filles si l'evenement *)\r
+ (* appartient a qqn *)\r
+ (* ici c'est a refaire, c'est juste pour tester *)\r
+ if(c=1)\r
+ then if(v>110 and v<400 and h>50 and h<250)\r
+ then writeln("coucou");\r
+ fi;\r
+ fi;\r
+ End traitement;\r
+\r
+\r
+\r
+ Unit initialisation2 : procedure;\r
+ Begin\r
+ ListA:=new LAppli;\r
+ End initialisation2;\r
+\r
+ Unit xdeb : function : integer;\r
+ Begin\r
+ result:=j.xdebut;\r
+ End xdeb;\r
+\r
+ Unit ydeb : function : integer;\r
+ Begin\r
+ result:=j.ydebut;\r
+ End ydeb;\r
+\r
+ Unit getw : function : windows;\r
+ Begin\r
+ result:=w;\r
+ End getw;\r
+\r
+ \r
+ Unit insertA : procedure(e : applications);\r
+ Begin\r
+ call ListA.insert(new elm_a(e));\r
+ end; \r
+ \r
+\r
+\r
+ Begin\r
+ call gron(MODE); (* 5 = 1024x768x256 *)\r
+ j:=new graph(0,none,x1,y1,x2,y2);\r
+ resume(j);\r
+ w:=new windows(0,j,x1,y1,x2,y2);\r
+ resume(w);\r
+ call w.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,"Gest_Wind");\r
+ call w.affiche;\r
+ call J.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,"Gst_Windows");\r
+ call j.affichesuite;\r
+ return;\r
+\r
+ accept getinfo;\r
+ enable xdeb,ydeb,getw,insertA;\r
+ call gest.ready;\r
+ call initialisation2; \r
+ enable event;\r
+ px:=w.xdebut; py:=w.ydebut;\r
+ i:=1;\r
+ do\r
+ call w.outxyint(px,py,i,Bleu,Blanc);\r
+ i:=i+1;\r
+ od;\r
+ call groff;\r
+ End Gest_wind;\r
+\r
+\r
+ Unit Appli : Applications class;\r
+ Var px,py : integer;\r
+ Begin \r
+ px:=w.xdebut; py:=w.ydebut;\r
+ call w.outxytext(px,py,"coucou",Vert,Noir);\r
+ i:=1;\r
+ do\r
+ call w.outxyint(px,py+20,i,Bleu,Blanc);\r
+ i:=i+1;\r
+ od\r
+ End Appli;\r
+\r
+\r
+(*****************************************************************************)\r
+(* P r o g r a m m e P r i n c i p a l *)\r
+(*****************************************************************************)\r
+Var i : integer,\r
+ G1 : Gest_wind,\r
+ Z1,Z2 : appli,\r
+ G2 : Gest_event,\r
+ x,y :integer;\r
+\r
+Begin\r
+ G1:=new Gest_wind(0,0,0,XMAX,YMAX,none);\r
+ G2:=new Gest_event(0,G1);\r
+ resume(G1);\r
+ resume(G2);\r
+ call G1.getinfo(G2);\r
+\r
+ x:=G1.xdeb;\r
+ y:=G1.ydeb;\r
+ \r
+ Z1:=new appli(0,x+10,y+10,x+330,y+210,G1);\r
+ resume(Z1);\r
+ call G1.insertA(Z1);\r
+ call Z1.affecte("Application - 1 -");\r
+ \r
+ Z2:=new appli(0,x+250,y+80,x+520,y+250,G1);\r
+ resume(Z2);\r
+ call G1.insertA(Z2);\r
+ call Z2.affecte("Application - 2 -");\r
+\r
+\r
+End.\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+ \r
+ program processus4;\r
+ \r
+(* czytelnicy pisarze *)\r
+ unit elem : class;\r
+ var ile , nr : integer,qui:pi;\r
+ (*nr procesu ktory zostawil informacje lub ostatni FreePl w buforze*)\r
+ end elem;\r
+ \r
+ unit ecran :IIUWGRAPH process(node:integer);\r
+ \r
+ unit outtext : procedure(x,y:integer, s:string);\r
+ var A: arrayof char, i: integer;\r
+ begin\r
+ call move(x,y);\r
+ call color(14); (* yellow *)\r
+ A := unpack(s);\r
+ for i := lower(A) to upper(A) do\r
+ (* call HASCII(0); *)\r
+ call HASCII(ord(A(i)));\r
+ od;\r
+ end outtext;\r
+ \r
+ unit outmessage: procedure(x,y:integer, s: string);\r
+ var A: arrayof char, i: integer;\r
+ begin\r
+ call move(x,y);\r
+ call color(12); (* rouge clair *)\r
+ A := unpack(s);\r
+ for i := lower(A) to upper(A) do\r
+ call HASCII(ord(A(i)))\r
+ od\r
+ end outmessage;\r
+\r
+ unit circle: procedure(col,x,y,r : integer);\r
+ var i: integer;\r
+ begin\r
+ call color(col);\r
+ call rectangle(x,y,r,r); \r
+ for i := 1 to r-1 do\r
+ call line(col,x,y+i,r,true)\r
+ od\r
+ end circle;\r
+ \r
+ unit line : procedure(col,x,y,dlugosc:integer,poziomo:boolean);\r
+ begin\r
+ call color(col);\r
+ call move(x,y); (* pozycja linii *)\r
+ if poziomo\r
+ then\r
+ call draw(x+dlugosc,y);\r
+ else (* linia pionowa *)\r
+ call draw(x, y+dlugosc);\r
+ fi;\r
+ end line;\r
+ \r
+ \r
+ unit Fin:procedure;\r
+ begin\r
+ call GrOFF; call endRun\r
+ end fin;\r
+ \r
+ unit pisarz: procedure(nr:integer);\r
+ begin\r
+ call color(2*nr+1);\r
+ call circle(2*nr+1,(nr-1)*150+20,8,10);\r
+ (* call rectangle((nr-1)*150+20,10,10,10);*) \r
+ call rectangle((Nr-1)*150+10,20,80,200);\r
+ end pisarz;\r
+ \r
+ unit rectangle:procedure(x,y,dl,wys:integer);\r
+ var i: integer;\r
+ begin\r
+ call move(x,y);\r
+ call draw(x+dl,y);\r
+ call draw(x+dl,y+wys);\r
+ call draw(x,y+wys);\r
+ call draw(x,y);\r
+ end rectangle;\r
+ \r
+ unit magazyn : procedure;\r
+ begin\r
+ call color(1);\r
+ call rectangle(10,250,600,50);\r
+ end magazyn;\r
+ begin\r
+ call gron(1);\r
+ return;\r
+ enable magazyn,pisarz;\r
+ do\r
+ accept Fin, line, circle, outtext, outmessage\r
+ od;\r
+ \r
+ end ecran;\r
+ \r
+ unit pi : elem process(node,nr : integer, M : monitor,ek:ecran);\r
+ (* nr jest numerem pisarza *)\r
+ const stala=62;(* dludosc linii rysowanej przez pisarza *)\r
+ var posX, posY:integer; (* pozycja pisarza na ekranie *)\r
+ \r
+ unit tempo : procedure(n:integer);\r
+ var i : integer;\r
+ begin\r
+ for i :=1 to n do i:=i od\r
+ end tempo;\r
+ \r
+ \r
+ unit wezwij_put : procedure(e:elem);\r
+ var czekaj : boolean;\r
+ begin\r
+ (* najpierw wymazuje z obszaru pisarza *)\r
+ call ek.outtext((nr-1)*150+20,200,"sends ");\r
+ for i := 1 to e.ile\r
+ do\r
+ call ek.line(0,(nr-1)*150+22,32+i,stala, true);\r
+ call tempo(200);\r
+ od;\r
+ call ek.outtext((nr-1)*150+20,200,"waiting ");\r
+ do\r
+ call M.putt(e.nr, e.qui, e.ile, czekaj);\r
+ if czekaj \r
+ then\r
+ call ek.outmessage((nr-1)*150+20,180,"stopped"); \r
+ stop \r
+ else \r
+ exit \r
+ fi;\r
+ od;\r
+ end wezwij_put;\r
+ \r
+ unit wezwij_get : procedure(inout e:elem);\r
+ var czekaj : boolean, qui:pi,n,ch:integer ;\r
+ begin\r
+ \r
+ do\r
+ n := e.nr; qui := e.qui;\r
+ call m.gett(n,qui,ch, czekaj);\r
+ if czekaj then \r
+ call ek.outmessage((nr-1)*150+20,180,"stopped");\r
+ stop\r
+ else\r
+ e:=new elem; e.nr :=n;\r
+ e.qui:=qui; e.ile :=ch;\r
+ call ek.outtext((nr-1)*150+20,200,"receives");\r
+ for i := 1 to ch\r
+ do\r
+ call ek.line(2*n+1,(nr-1)*150+22,32+i,stala,true);\r
+ call tempo(200);\r
+ od;\r
+ call ek.outtext((nr-1)*150+20,200, " ");\r
+(* otrzymalem wiadomosc od pisarza nr *)\r
+ exit\r
+ fi;\r
+ od;\r
+ end wezwij_get;\r
+ \r
+ unit fin : procedure;\r
+ end;\r
+ \r
+var el: elem, r : real;\r
+begin\r
+ call ek.pisarz(nr);\r
+ call ek.outtext((nr-1)*150+36,8,"Actor");\r
+ return;\r
+ do\r
+ r := random*100;\r
+ if r=0 then accept fin; exit fi;\r
+ (* to niezbt dobre rozwiazanie ze wzgl na kolejnosc *)\r
+ if r<50 then\r
+ (* pisarz cos produkuje i chce to wyslac *)\r
+ el := new elem;\r
+ el.qui := this pi;\r
+ el.nr := nr;\r
+ el.ile := random*175;\r
+ call ek.outtext((nr-1)*150+20,200,"writes ");\r
+ for i := 1 to el.ile\r
+ do\r
+ call ek.line(2*nr+1,(nr-1)*150+22,26+i,stala,true);\r
+ call tempo(250);\r
+ od;\r
+ call ek.outtext((nr-1)*150+20,200," ");\r
+ call tempo(400);\r
+ call wezwij_put(el)\r
+ else\r
+ (* pisarz zdecydowal sie cos przeczytac *)\r
+ el := new elem;\r
+ el.nr := nr; el.qui := this pi;\r
+ call ek.outtext((nr-1)*150+20,200,"demands ");\r
+ call wezwij_get(el);\r
+ call ek.outtext((nr-1)*150+20,200," ");\r
+ call tempo(500);\r
+ call ek.outtext((nr-1)*150+20,200,"reads ");\r
+ (* czytam przesylke *)\r
+ for i := el.ile downto 1\r
+ do\r
+ call ek.line(0,(nr-1)*150+22,26+i,stala,true);\r
+ call tempo(250);\r
+ od;\r
+ call ek.outtext((nr-1)*150+20,200," ");\r
+ \r
+ fi;\r
+ od;\r
+end pi;\r
+ \r
+unit monitor : elem process(node,size,max_proc : integer, ek:ecran);\r
+const posX = 30,\r
+ posY = 250;\r
+ unit Belem : class(e:elem,posx:integer);\r
+ end Belem;\r
+ \r
+var buffer : arrayof Belem,\r
+ queue_pour_lire,\r
+ queue_pour_ecrire: queue,\r
+ Qpos:integer,\r
+ counter, ilosc_ak, i,x, nb_proc: integer;\r
+ (* zmienna counter mowi ile jest elementow w buforze *)\r
+ (* ilosc_ak = ilosc miejsca w magazynie juz wykorzystana*)\r
+ (* nb_proc = ilosc procesow stojacuch w obu kolejkach *)\r
+ \r
+ unit qEl: class;\r
+ var qui : pi, next : qEL;\r
+ end qEL;\r
+ \r
+ unit queue: class(pos:integer);\r
+ var first, last : qEL;\r
+ \r
+ unit into : procedure(p: pi,nr: integer (* nr is the no of pi*));\r
+ var aux : qEL, c:integer;\r
+ begin\r
+ \r
+ call ek.circle(2*nr+1,pos+30,339,10);\r
+ pos := pos+30;\r
+ (* rysowanie kolka w odpowiedniej kolejce i odp.kolorem*)\r
+ nb_proc := nb_proc+1;\r
+ aux := new qEL;\r
+ aux .qui :=p;\r
+ aux . next := none;\r
+ if first=none then\r
+ first := aux; last := aux\r
+ else\r
+ last.next := aux;\r
+ last := aux;\r
+ fi;\r
+ end into;\r
+ \r
+ unit out : function : pi;\r
+ begin\r
+ if first=none then exit else\r
+ nb_proc := nb_proc -1;\r
+ call ek.circle(0,pos,339,10);\r
+ pos :=pos-30;\r
+ (* wymazanie kolka w odpowiedniej kolejce *)\r
+ result := first.qui;\r
+ first := first.next;\r
+ fi;\r
+ end out;\r
+ \r
+ unit empty : function: boolean;\r
+ begin\r
+ result := (first=none) ;\r
+ end empty;\r
+ end queue;\r
+ \r
+ unit tempo : procedure(n:integer);\r
+ var j,x:integer;\r
+ begin\r
+ for j := 1 to n do x:=x od;\r
+ end tempo;\r
+ \r
+ unit putt : procedure(n:integer,qui:pi,ch:integer; output czekaj : boolean);\r
+ var aux, i : integer,e : elem;\r
+ begin\r
+ \r
+ if (counter< 20 and ilosc_ak+ch<size)\r
+ then\r
+ e := new elem;\r
+ e.nr :=n;\r
+ e.ile := ch;\r
+ e.qui := qui;\r
+ counter := counter +1;\r
+ buffer(counter) := new Belem(e,x);\r
+ \r
+ (* monitor zapisuje przesylke od *)\r
+ for i :=1 to ch do\r
+ call ek.line(2*n+1,x+i,posY+7,39,false);\r
+ call tempo(300);\r
+ od;\r
+ x := x+ ch;\r
+ ilosc_ak := ilosc_ak+ch;\r
+ czekaj := false;\r
+ if not queue_pour_lire.empty\r
+ then\r
+(* monitor budzi pisarza z kolejki czytelnikow *)\r
+ p := queue_pour_lire.out;\r
+ call ek.outtext((nr-1)*150,180," ");\r
+ resume(p);\r
+ fi;\r
+ else\r
+(* nie ma miejsca w buforze dla pisarza *)\r
+ czekaj := true;\r
+ call queue_pour_ecrire.into(qui,n);\r
+ \r
+ fi;\r
+ end putt;\r
+ \r
+ unit gett:procedure(inout nr:integer, qui:pi, ch:integer, czekaj:boolean);\r
+ var i ,j : integer, e:elem , p:pi;\r
+ begin\r
+ p := qui;\r
+ if counter<> 0 then (* mozna cos zabrac z magazynu *)\r
+ e := buffer(counter).e;\r
+ nr := e.nr; qui := e.qui; ch := e.ile;\r
+ counter := counter - 1;\r
+ czekaj := false;\r
+ for i := x downto x-ch\r
+ do\r
+ call ek.line(0,i,posY+7,39,false);\r
+ call tempo(200);\r
+ \r
+ od;\r
+ x := x-ch;\r
+ ilosc_ak := ilosc_ak-ch;\r
+ (* w magazynie zwolnilo sie miejsce i ktos moze wpisac *)\r
+ \r
+ if not queue_pour_ecrire.empty\r
+ then\r
+ (* writeln("M budzi pisarza ktory chce pisac ");*)\r
+ p := queue_pour_ecrire.out;\r
+ call ek.outtext((nr-1)*150,180," ");\r
+ resume(p);\r
+ fi;\r
+ else (*jezeli counter=0 tzn. nic nie ma w magazynie *)\r
+(* writeln("M wpisuje pisarza",nr,"do kolejki czytelnikow");*)\r
+ czekaj := true;\r
+ qui := p;(* to jest instrukcja niepotrzebna *)\r
+ call queue_pour_lire.into(p,nr);\r
+ fi;\r
+ end gett;\r
+ \r
+begin (* tu sie zaczyna tresc monitora *)\r
+ \r
+ array buffer dim(1:20);\r
+ \r
+ counter := 0;\r
+ x := 12; ilosc_ak := 0;\r
+ Qpos := posX;\r
+ queue_pour_lire := new queue(Qpos);\r
+ queue_pour_ecrire := new queue(Qpos+300);\r
+ call ek.magazyn;\r
+ call ek.outtext(posX,posY-6,"BUFFER");\r
+ call ek.outtext(posX,posY+60,"READERS' QUEUE");\r
+ call ek.outtext(posX+ 300, posY+60,"WRITERS'QUEUE");\r
+ return;\r
+ do\r
+ accept putt, gett;\r
+ if nb_proc = max_proc\r
+ then\r
+ call ek.outmessage(470,339,"DEADLOCK! press CR");\r
+ readln;\r
+ call ek.fin;\r
+ fi;\r
+ od;\r
+end monitor;\r
+ \r
+ \r
+ (* M A I N *) \r
+\r
+var PROC : arrayof pi,p,P1,P2,P3 : pi,\r
+ M : monitor,\r
+ EK : ecran,\r
+ i, NbProc : integer;\r
+ \r
+begin \r
+ \r
+ write("NbProc : ");\r
+ readln(NbProc);\r
+ array Proc dim(1:NbProc);\r
+ \r
+ ek := new ecran(0);\r
+ resume(ek);\r
+ M := new monitor(0,550,NbProc,ek);\r
+ resume(M);\r
+ for i := 1 to NbProc\r
+ do\r
+ P := new pi(0,i,M,ek);\r
+ Proc(i) := P;\r
+ od;\r
+ \r
+ \r
+ call ek.outmessage(550,320,"press CR");\r
+ readln;\r
+ call ek.outtext(550,320," ");\r
+ \r
+ for i :=1 to NbProc\r
+ do p := Proc(i);\r
+ resume(p);\r
+ od;\r
+ \r
+ \r
+end processus4;\r
--- /dev/null
+Program simulation;\r
+\r
+(***************************************************************************)\r
+(* Programme de syst\8ame de fenetrage avec boutons et gestion de la souris *)\r
+(* ainsi que de simulation d'un r\82seau routier en ville. *)\r
+(* BARETS Olivier & PATAUD Fr\82d\82ric & PEYRAT Fran\87ois 1993/1994 *)\r
+(* plateforme : PC-DOS_386 avec clavier 102 touches / mode VGA / souris *)\r
+(* PC 486DX33 16Mo Ram *)\r
+(***************************************************************************)\r
+\r
+Begin\r
+Pref iiuwgraph block\r
+ \r
+ Begin\r
+ Pref mouse block\r
+\r
+ Const Noir = 0, Bleu = 1, Vert = 2, Cyan = 3,\r
+ Rouge = 4, Magenta = 5, Marron = 6, GrisClair = 7,\r
+ GrisFonce = 8, BleuClair = 9, VertClair =10, CyanClair =11,\r
+ RougeClair =12, MagentaClair=13, Jaune =14, Blanc =15;\r
+ \r
+ Const T_F1 =315, T_F2 =316, T_F3 =317, T_F4 =318,\r
+ T_F5 =319, T_F6 =320, T_F7 =321, T_F8 =322,\r
+ T_F9 =323, T_F10 =324, T_SHFTF1 =340, T_SHFTF2 =341,\r
+ T_SHFTF3 =342, T_SHFTF4 =343, T_SHFTF5 =344, T_SHFTF6 =345,\r
+ T_SHFTF7 =346, T_SHFTF8 =347, T_SHFTF9 =348, T_SHFTF10=349,\r
+ T_CTRLF1 =350, T_CTRLF2 =351, T_CTRLF3 =352, T_CTRLF4 =353, \r
+ T_CTRLF5 =354, T_CTRLF6 =355, T_CTRLF7 =356, T_CTRLF8 =357, \r
+ T_CTRLF9 =358, T_CTRLF10=359, T_ALTF1 =360, T_ALTF2 =361, \r
+ T_ALTF3 =362, T_ALTF4 =363, T_ALTF5 =364, T_ALTF6 =365, \r
+ T_ALTF7 =366, T_ALTF8 =367, T_ALTF9 =368, T_ALTF10 =369,\r
+ Tou_Ent =013, T_ESC =027, T_N =078, T_Y =089,\r
+ T_FLGCH =331, T_FLDTE =333, T_FLHAU =328, T_FLBAS =336,\r
+ T_ALT1 =376, T_ALT2 =377, T_PGUP =329, T_PGDOWN =337;\r
+\r
+ Var SIZEX : integer,\r
+ SIZEY : integer;\r
+\r
+\r
+(* les variables du syst\8ame de fenetrage *)\r
+\r
+ Var code : integer,\r
+ Larg_Vil : integer, (* largeur de la ville *)\r
+ Haut_Vil : integer, (* Hauteur de la ville *)\r
+ Larg_Aff : integer, (* largeur de l'interieur de la fenetre maine *)\r
+ Haut_Aff : integer, (* hauteur de l'interieur de la fenetre maine *)\r
+ Xdep_Aff : integer, (* Point de depart de l'affichage en X ds maine *)\r
+ Ydep_Aff : integer, (* point de depart de l'affichage en Y ds maine *)\r
+ COEF_X : real, (* coeficient de zoom en x *)\r
+ COEF_Y : real, (* coeficient de zoom en y *)\r
+ COORD_X : integer, (* coordonn\82e en X de Xdep_Aff en relatif *)\r
+ COORD_Y : integer, (* coordonn\82e en Y de Ydep_Aff en relatif *)\r
+ W : Maine,\r
+ Keys : ListKey,\r
+ M : arrayof Menu,\r
+ clics : cliquer;\r
+\r
+\r
+(* les variables de la simulation *)\r
+\r
+ Var RaciSomm : Sommets,\r
+ RaciArcs : Arcs,\r
+ NbCarActiv : integer,\r
+ NBSOMMETS : integer;\r
+\r
+ Unit pointeur : class;\r
+ End pointeur;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* definition des classes et procedures de simprocess *)\r
+(***************************************************************************)\r
+\r
+\r
+UNIT PRIORITYQUEUE: CLASS;\r
+\r
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+\r
+\r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+\r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+\r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+\r
+END QUEUEHEAD;\r
+\r
+\r
+ UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+\r
+\r
+ UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+\r
+\r
+END PRIORITYQUEUE;\r
+\r
+\r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS: pointeur COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ BEGIN\r
+ \r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+ \r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ \r
+UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+\r
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)\r
+ (* WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+END SCHEDULE;\r
+ \r
+UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE; \r
+END SIMULATION;\r
+ \r
+ \r
+ \r
+UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+ \r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE FI;\r
+ END;\r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+ \r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT:PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+ \r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI FI;\r
+ END INTO;\r
+ END LINK;\r
+\r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+\r
+ END LISTS;\r
+\r
+(***************************************************************************)\r
+(* definition des procedures de lecture des fichiers de donn\82es et mise en *)\r
+(* m\82moire des structures de la ville. *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+(* Structure d une place de parking *)\r
+(***************************************************************************)\r
+\r
+Unit Place : class (N : integer );\r
+var P1 : arrayof boolean;\r
+Begin\r
+ array P1 dim (1:N);\r
+End Place;\r
+\r
+(***************************************************************************)\r
+(* Structure de la liste des arc qui peuvent etre atteind *)\r
+(***************************************************************************)\r
+\r
+Unit Liste : class;\r
+var pointeur: Arcs,\r
+ suivante: Liste;\r
+end Liste;\r
+\r
+(***************************************************************************)\r
+(* Structure des arcs *)\r
+(***************************************************************************)\r
+Unit Arcs : class;\r
+Var Numero : integer, (* Identification de l'arc *)\r
+ Initial : Sommets, (* Sommet initial *)\r
+ Final : Sommets, (* Sommet final *)\r
+ Sens : integer, (* Sens de circulation *)\r
+ Distance : integer, (* Distance de initial a final*)\r
+ NbvoieIF : integer, (* Nombre de voie dans le sens 1 *)\r
+ NbvoieFI : integer, (* Nombre de voie dans le sens -1 *)\r
+ Suivants : Arcs,\r
+ (* pointeur sera de type car lors des affectations *)\r
+ occpsens : arrayof pointeur, (*si <>none alors il y a une voiture cette place*)\r
+ occpinve : arrayof pointeur; (*en sens inverse de initial final *)\r
+End Arcs;\r
+\r
+(***************************************************************************)\r
+(* Structure des sommets *)\r
+(***************************************************************************)\r
+\r
+Unit Sommets : class;\r
+var Nom : char, (* Nom du sommet *) \r
+ typecar : integer, (* Type carrefour 0:feu , 1:priorite , 2:stop *)\r
+ afftype : integer, (* type carrefour 1..9 pour affichage *)\r
+ Ligne : integer, (* Correspond a la position en Y sur ecran *)\r
+ Colonne : integer, (* Correspond a la position en X sur ecran *)\r
+ etat : integer, (* Etat du carrefour *)\r
+ ptrarc : Liste, (* Pointeur sur la liste pointant sur les arcs *)\r
+ suivant : Sommets; (* Pointeur sur les suivants *)\r
+End Sommets;\r
+\r
+(***************************************************************************)\r
+(* Procedure creant la liste des Sommets *)\r
+(* Ici il y a juste creation d un liste simple de sommet en mode pile *)\r
+(***************************************************************************)\r
+\r
+Unit CreeSomm : procedure( f: file);\r
+var Noeud : Sommets,\r
+ tampon: char,\r
+ arret : boolean;\r
+\r
+Begin\r
+ readln(f);\r
+ arret := false;\r
+ while not arret \r
+ do\r
+ read(f,tampon);\r
+ if ( tampon <> '.') then\r
+ Noeud := new Sommets;\r
+ NBSOMMETS:=NBSOMMETS+1; (* on comptabilise le nombre de sommets*)\r
+ Noeud.Nom := tampon;\r
+ read(f,Noeud.typecar);\r
+ read(f,Noeud.afftype);\r
+ read(f,Noeud.colonne);\r
+ if(Noeud.colonne>Larg_Vil) then Larg_Vil:=Noeud.colonne; fi;\r
+ readln(f,Noeud.ligne);\r
+ if(Noeud.ligne>Haut_Vil) then Haut_Vil:=Noeud.ligne; fi;\r
+ Noeud.etat := 0;\r
+ Noeud.ptrarc := none;\r
+ Noeud.Suivant := RaciSomm;\r
+ RaciSomm := Noeud;\r
+ else arret := true;\r
+ fi\r
+ od;\r
+End CreeSomm;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure affichant chaque sommet ainsi que les arcs que l'on peut *)\r
+(* prendre depuis ce sommet en considerant les sens de circulation etc... *)\r
+(***************************************************************************)\r
+Unit ParcSomm : procedure;\r
+var Noeud : Sommets;\r
+var parcours : Liste;\r
+Begin\r
+ Noeud := RaciSomm;\r
+ while (Noeud <> none)\r
+ do\r
+ write("Nom: ");\r
+ writeln(Noeud.Nom);\r
+ writeln("X : ",Noeud.Colonne);\r
+ writeln("Y : ",Noeud.ligne);\r
+ parcours := Noeud.ptrarc;\r
+ while (parcours <> none )\r
+ do\r
+ writeln("Arc: ",parcours.pointeur.Numero);\r
+ parcours := parcours.suivante;\r
+ od;\r
+ Noeud := Noeud.suivant;\r
+ od;\r
+End ParcSomm;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure creant la liste des Arc *)\r
+(* Ici on cree la liste des Arc sur la base d'une pile, puis il y a *)\r
+(* rattachement des pointeurs final et initial avec la liste des sommets *)\r
+(* et ce grace a la procedure rattache. *) \r
+(***************************************************************************)\r
+\r
+Unit CreeArcs : procedure( f: file);\r
+var Noeud : Arcs;\r
+var aux1 : char,\r
+ aux2 : char,\r
+ aux3 : char,\r
+ i : integer;\r
+Begin\r
+ readln(f);\r
+ readln(f);\r
+ while ( not(eof(f)))\r
+ do\r
+ \r
+ i:=i+1; \r
+ call color(Blanc);\r
+ call move(10,400);\r
+ call outstring("coucou");\r
+ call hascii(48+i);\r
+\r
+ Noeud := new Arcs;\r
+ read(f,Noeud.Numero);\r
+ read(f,aux3);\r
+ read(f,aux1);\r
+ read(f,aux3);\r
+ read(f,aux2);\r
+ read(f,aux3);\r
+ read(f,Noeud.Sens);\r
+ read(f,Noeud.distance);\r
+ array Noeud.occpsens dim (1:Noeud.distance); (* on met la voie en place*)\r
+ array Noeud.occpinve dim (1:Noeud.distance);\r
+ read(f,Noeud.NbvoieIF);\r
+ readln(f,Noeud.NbvoieFI);\r
+ Noeud.Initial := none;\r
+ Noeud.Final := none;\r
+ Noeud.Suivants:= RaciArcs;\r
+ RaciArcs := Noeud;\r
+ Call rattache(Noeud,aux1,aux2);\r
+ od;\r
+End CreeArcs;\r
+\r
+(***************************************************************************)\r
+(* Rattachement du pointeur arc avec le sommet *)\r
+(* Cette procedure rattache les pointeurs final et initial des arcs avec *)\r
+(* un sommet de la liste des sommets. *)\r
+(* Puis il y a la procedure creant la liste des arcs que l'on peut *)\r
+(* emprunter depuis ce sommet. Cette procedure est appele ici. *) \r
+(* Pour l appelle de cette procedure RattaListe nous verifions le sens de *)\r
+(* circulation dans les arcs, en effet des arcs ne peuvent pas etre pris a *)\r
+(* partir de certain sommets, donc il ne doivent pas figurer dans cette *)\r
+(* liste( Sens interdits ). *)\r
+(***************************************************************************)\r
+Unit Rattache : procedure ( inout Noeud : Arcs ; aux1,aux2:char);\r
+var Parcours : Sommets;\r
+\r
+begin\r
+ Parcours := RaciSomm;\r
+ while((Parcours<>none) and (Parcours.Nom<>aux1) and (Parcours.Nom<>aux2))\r
+ do\r
+ Parcours := Parcours.suivant;\r
+ od;\r
+ if Parcours.Nom = aux1\r
+ then\r
+ Noeud.Initial := Parcours;\r
+ if Noeud.Sens <> -1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else if Parcours.Nom = aux2 \r
+ then\r
+ Noeud.Final := Parcours; \r
+ if Noeud.Sens <> 1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi\r
+ else\r
+ write("ERREUR de rattachement initial");\r
+ exit;\r
+ fi;\r
+ fi;\r
+ Parcours := Parcours.suivant;\r
+ while((Parcours<>none) and (Parcours.Nom<>aux1) and (Parcours.Nom<>aux2))\r
+ do\r
+ Parcours := Parcours.suivant;\r
+ od;\r
+ if Parcours.Nom = aux1\r
+ then\r
+ Noeud.Initial := Parcours; \r
+ if Noeud.Sens <> -1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else if Parcours.Nom = aux2 \r
+ then\r
+ Noeud.final := parcours;\r
+ if Noeud.Sens <> 1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else\r
+ write("ERREUR de rattachement du final");\r
+ fi;\r
+ fi;\r
+end rattache;\r
+\r
+(***************************************************************************)\r
+(* Rattachement des sommets a la liste des arc qui peuvent etres atteinds *)\r
+(***************************************************************************)\r
+Unit RattaListe : procedure (inout NoeudSom : sommets; NoeudArc : Arcs);\r
+var Noeud : Liste;\r
+\r
+begin\r
+ Noeud := new Liste;\r
+ Noeud.suivante := NoeudSom.ptrarc;\r
+ Noeud.pointeur := NoeudArc;\r
+ NoeudSom.ptrarc := Noeud;\r
+End RattaListe;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure de lecture de la ville appell\82e par bo_load *)\r
+(***************************************************************************)\r
+\r
+Unit Lit_Ville : procedure( fenet : Windows);\r
+var fichier : file,\r
+ flagbool : boolean;\r
+begin\r
+ Larg_Vil:=0;\r
+ Haut_Vil:=0;\r
+ NBSOMMETS:=0;\r
+ open (fichier,text,unpack("Ville.dat"));\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext(".",1);\r
+ call reset (fichier);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("..",2);\r
+ Call CreeSomm(fichier);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("..",2);\r
+ Call CreeArcs(fichier);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("..",2);\r
+end Lit_Ville;\r
+\r
+(***************************************************************************)\r
+(* definition des procedures d'utilitaires graphiques *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit Line : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ End Line;\r
+\r
+(***************************************************************************)\r
+ Unit Linep : procedure (x1,y1,x2,y2,c,s :integer);\r
+ Var i :integer;\r
+ Begin (* ne fonctionne que pour des horizontales ou des verticales *)\r
+ if (x1=x2)\r
+ then for i:=y1 step s*2 to y2 \r
+ do\r
+ call line(x1,i,x1,i+s,c);\r
+ od;\r
+ else if (y1=y2)\r
+ then for i:=x1 step s*2 to x2 \r
+ do\r
+ call line(i,y1,i+s,y1,c);\r
+ od;\r
+ fi;\r
+ fi;\r
+ End linep;\r
+\r
+(***************************************************************************)\r
+ Unit Rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1);\r
+ End Rectangle;\r
+\r
+(***************************************************************************)\r
+ Unit Rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ var i : integer;\r
+ Begin\r
+ for i:=y1 to y2\r
+ do\r
+ call Line(x1,i,x2,i,c);\r
+ od\r
+ End Rectanglef;\r
+\r
+(****************************************************************************)\r
+ Unit Readcara : function (x,y,col_f,col_e : integer) : integer;\r
+ Var i : integer,\r
+ sx,sy : integer;\r
+ Begin\r
+ sx:=x;\r
+ sy:=y;\r
+ i:=inkey;\r
+ while i=0\r
+ do\r
+ call color(col_f);\r
+ call move(x,y);\r
+ call outstring("_");\r
+ for i:=1 to 300 do od;\r
+ call color(col_e);\r
+ call move(x,y);\r
+ call outstring("_");\r
+ for i:=1 to 100 do od;\r
+ i:=inkey;\r
+ od;\r
+ call color(col_f);\r
+ call move(x,y);\r
+ call outstring("_");\r
+ call move(sx,sy);\r
+ call color(col_e);\r
+ result:=i;\r
+ End Readcara;\r
+\r
+(****************************************************************************)\r
+(* lecture d'un entier en mode graphique, esc revient au debut de saisie *)\r
+(****************************************************************************)\r
+ Unit gscanf : function (rangmin,rangmax : integer) : integer;\r
+ Var valeur : integer,\r
+ sauvx : integer,\r
+ sauvy : integer,\r
+ flag : integer;\r
+ Begin\r
+ sauvx:=inxpos;\r
+ sauvy:=inypos;\r
+ do\r
+ valeur:=0;\r
+ do\r
+ flag:=readcara(inxpos,inypos,Noir,BleuClair);\r
+ if (flag>=48 and flag<=57)\r
+ then valeur:=valeur*10+flag-48;\r
+ call move(inxpos,inypos);\r
+ call hascii(flag);\r
+ fi;\r
+ if (flag=13) then exit; fi;\r
+ if (flag=27) (* on a demand\82 annulation *)\r
+ then valeur:=0;\r
+ call rectanglef(sauvx-1,sauvy-1,inxpos,sauvy+13,Noir);\r
+ call color(BleuClair);\r
+ call move(sauvx,sauvy);\r
+ fi;\r
+ od;\r
+ if (valeur>=rangmin and valeur<=rangmax)\r
+ then exit;\r
+ else call rectanglef(sauvx-1,sauvy-1,inxpos,sauvy+13,Noir);\r
+ call color(BleuClair);\r
+ call move(sauvx,sauvy);\r
+ fi;\r
+ od;\r
+ result:=valeur;\r
+ End gscanf;\r
+\r
+\r
+(***************************************************************************)\r
+(* definition des classes d'\82l\82ments des listes *)\r
+(***************************************************************************)\r
+ \r
+ Unit Elmt : class(id : integer);\r
+ End Elmt;\r
+ \r
+ Unit elm : Elmt class(x1,y1,x2,y2 :integer);\r
+ End elm;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Bottons : Elmt class(touche,x1,y1,x2,y2 : integer); \r
+ (* x2-x1 et y2-y1 doit au mini etre de 8*)\r
+ (* x1,y1 : integer coordonn\82es du point haut gauche *)\r
+ (* x2,y2 : integer coordonn\82es du point bas droit *)\r
+ Var etat : boolean; (* true si bouton enable *)\r
+ \r
+ Unit affiche : procedure;\r
+ Begin\r
+ call Line(x1,y1,x2,y1,Blanc); (* Lignes en blanc *) \r
+ call Line(x1,y1+1,x2-1,y1+1,Blanc);\r
+ call Line(x1,y1,x1,y2,Blanc);\r
+ call Line(x1+1,y1+2,x1+1,y2-1,Blanc);\r
+ call Line(x1+1,y2,x2,y2,GrisFonce); (* Lignes en gris fonce *)\r
+ call Line(x1+2,y2-1,x2,y2-1,GrisFonce);\r
+ call Line(x2,y2,x2,y1+1,GrisFonce);\r
+ call Line(x2-1,y2-1,x2-1,y1+2,GrisFonce);\r
+ call Rectanglef(x1+2,y1+2,x2-2,y2-2,GrisClair); (* centre en gris *)\r
+ call AfficheSuite;\r
+ End affiche;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ End;\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ End;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ End;\r
+ \r
+ End Bottons;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Menu derivant de Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Menu : Bottons class;\r
+ Var cnom : integer, (* couleur du nom du bouton *) \r
+ nom : string; (* nom du bouton *)\r
+ \r
+ Unit affiche_nom : procedure;\r
+ Begin \r
+ call move(x1+5,y1+(y2-y1)/4);\r
+ call color(cnom);\r
+ call outstring(nom);\r
+ End affiche_nom;\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ var e : elm;\r
+ Begin\r
+ cnom:=RougeClair;\r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Insert(e);\r
+ if (touche<>-1)\r
+ then call Keys.Insert(new elmt(touche));\r
+ fi;\r
+ call affiche_nom;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ var e : elm;\r
+ Begin\r
+ cnom:=Rouge;\r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Delete(e);\r
+ if (touche<>-1)\r
+ then call Keys.delete(new elmt(touche));\r
+ fi;\r
+ call affiche_nom;\r
+ End bot_disable;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ Begin\r
+ if (etat) \r
+ then call bot_enable;\r
+ else call bot_disable;\r
+ fi;\r
+ End AfficheSuite;\r
+\r
+ End Menu;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Racc derivant de Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Racc : Bottons class (procedure sprite(x1,y1,x2,y2,col :integer));\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ var e : elm;\r
+ Begin \r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Insert(e);\r
+ if (touche<>-1)\r
+ then call Keys.Insert(new elmt(touche));\r
+ fi;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ var e : elm;\r
+ Begin \r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Delete(e);\r
+ if (touche<>-1)\r
+ then call Keys.delete(new elmt(touche));\r
+ fi;\r
+ End bot_disable;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ Begin\r
+ if etat\r
+ then call bot_enable;\r
+ call sprite(x1,y1,x2,y2,Noir);\r
+ else call bot_disable;\r
+ call sprite(x1,y1,x2,y2,GrisFonce);\r
+ fi;\r
+ End AfficheSuite;\r
+\r
+ End Racc;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Windows *)\r
+(***************************************************************************)\r
+ \r
+ Unit Windows : class(numero,x1,y1,x2,y2,lborder : integer; \r
+ r1,r2,r3 : boolean); \r
+ hidden x,y,xp,yp; \r
+ (* x2-x1 et y2-y1 doit au mini etre 33 *)\r
+ Var cborder : integer, (* couleur du pourtour *)\r
+ cnom : integer, (* couleur du nom de la fenetre *)\r
+ nom : string,\r
+ Bout : ListBot, (* liste des boutons rattaches *)\r
+ Hauteur : integer, (* hauteur de la bande *)\r
+ Largeur : integer, (* largeur des raccourcis *)\r
+ cbande : integer, (* couleur de la bande *)\r
+ WhereXd : integer, (* position en x de depart dans la fenetre *)\r
+ WhereX : integer, (* position courante en X dans la fenetre *)\r
+ WhereYd : integer, (* position en y de depart dans la fenetre *)\r
+ WhereY : integer; (* position courante en Y dans la fenetre *)\r
+ var B : arrayof Racc, (* variables locales *)\r
+ x,y : integer,\r
+ xp,yp : integer;\r
+ \r
+ Unit affiche : procedure;\r
+ var i : integer; \r
+ Begin\r
+ call rectanglef(x1,y1,x2,y2,Noir);\r
+ for i:=0 to lborder\r
+ do\r
+ call rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
+ od;\r
+ call Line(x1+16,y1,x1+16,y1+lborder,Noir); (* Lignes noires *)\r
+ call Line(x2-16,y1,x2-16,y1+lborder,Noir);\r
+ call Line(x1+16,y2,x1+16,y2-lborder,Noir);\r
+ call Line(x2-16,y2,x2-16,y2-lborder,Noir);\r
+ call Line(x1,y1+16,x1+lborder,y1+16,Noir);\r
+ call Line(x1,y2-16,x1+lborder,y2-16,Noir);\r
+ call Line(x2,y1+16,x2-lborder,y1+16,Noir);\r
+ call Line(x2,y2-16,x2-lborder,y2-16,Noir);\r
+ call Rectanglef(x1+lborder+1,y1+lborder+1,x2-lborder-1,\r
+ y1+lborder+hauteur+1,cbande);\r
+ call move(x1+(x2-x1)/3,y1+lborder+hauteur/4);\r
+ call color(cnom);\r
+ call outstring(nom);\r
+ call AffSuite;\r
+ End affiche;\r
+ \r
+ Unit virtual AffSuite : procedure;\r
+ End AffSuite;\r
+ \r
+ Unit virtual clear : procedure;\r
+ End clear;\r
+ \r
+ Unit gestionnaire : function : integer;\r
+ Var l,r,c : boolean,\r
+ x,y : integer,\r
+ rep : integer,\r
+ nbbot : integer;\r
+ Begin\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if (l) and (clics<>none)\r
+ then result:=clics.Appartient(x,y); exit;\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep>=97 and rep<=122) (* passe les lettres en majuscule *)\r
+ then rep:=rep-32;\r
+ fi;\r
+ if keys.Appartient(rep)\r
+ then result:=rep; exit;\r
+ fi;\r
+ od;\r
+ End gestionnaire;\r
+\r
+ Unit moveto : function (x,y :integer) : boolean;\r
+ Begin\r
+ if (x>0 and x<(x2-x1)) and (y>0 and y<y2-y1)\r
+ then WhereX:=WhereXd+x;\r
+ WhereY:=WhereYd+y;\r
+ call move(WhereX,WhereY);\r
+ result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End moveto;\r
+\r
+ Unit outgtext : function (chaine : string; long : integer) : boolean;\r
+ Begin\r
+ if (long*8+WhereX)<(x2-lborder-5)\r
+ then call move(WhereX,WhereY);\r
+ call outstring(chaine);\r
+ WhereX:=WhereX+long*8;\r
+ if WhereX>= x2-lborder-16\r
+ then WhereX:=WhereXd;\r
+ WhereY:=WhereY+16;\r
+ fi;\r
+ result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End outgtext;\r
+\r
+ Unit outchar : function (tmp : char) : boolean;\r
+ Begin\r
+ if (10+WhereX)<(x2-lborder-5-largeur)\r
+ then call move(WhereX,WhereY);\r
+ call hascii(ord(tmp));\r
+ WhereX:=WhereX+10;\r
+ if WhereX>= x2-lborder-16-largeur\r
+ then WhereX:=WhereXd;\r
+ WhereY:=WhereY+16;\r
+ fi;\r
+ result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End outchar;\r
+\r
+ Begin\r
+ \r
+ Bout:=new ListBot;\r
+ Keys:=new ListKey;\r
+ \r
+ array B dim (0:2);\r
+\r
+ x:=x2-Larg_bot-lborder-1;\r
+ y:=y1+lborder+1;\r
+ xp:=x2-lborder-1;\r
+ yp:=y+Haut_bot;\r
+ B(2):=new Racc(numero+3,-1,x,y,xp,yp,spr_upper);\r
+ B(2).etat:=r3;\r
+ call Bout.Insert(B(2));\r
+ \r
+ xp:=x-1;\r
+ x:=xp-Larg_bot;\r
+ B(1):=new Racc(numero+2,-1,x,y,xp,yp,spr_lower);\r
+ B(1).etat:=r2;\r
+ call Bout.Insert(B(1));\r
+ \r
+ x:=x1+lborder+1;\r
+ xp:=x+Larg_bot;\r
+ B(0):=new Racc(numero+1,-1,x,y,xp,yp,spr_close);\r
+ B(0).etat:=r1;\r
+ call Bout.Insert(B(0));\r
+\r
+ End Windows;\r
+\r
+(***************************************************************************)\r
+(* definition de main d\82rivant de la classe Windows *)\r
+(***************************************************************************)\r
+ \r
+ Unit Maine : Windows class;\r
+ var icname : string, (* nom une fois iconise *)\r
+ Lwind : ListW, (* liste des fenetres filles *)\r
+ Horiz : AccelerateH, (* accelerateur horizontal *)\r
+ Verti : AccelerateV; (* accelerateur vertical *)\r
+\r
+ Unit virtual AffSuite : procedure;\r
+ Begin\r
+ call Rectanglef(x1+lborder+1,y1+lborder+hauteur+3,\r
+ x2-lborder-1,y1+lborder+2*(hauteur+2),cbande);\r
+ if (Horiz<>none)\r
+ then call Horiz.affiche;\r
+ fi;\r
+ if (Verti<>none)\r
+ then call Verti.affiche;\r
+ fi;\r
+ Bout.Courant:=Bout.head;\r
+ while(Bout.Courant<>none)\r
+ do\r
+ call Bout.Courant.data qua Bottons.affiche;\r
+ Bout.Courant:=Bout.Courant.next;\r
+ od;\r
+ call Keys.Insert(new elmt(T_ALTF4)); (* alt/f4 pour quitter *)\r
+ End AffSuite;\r
+\r
+ Unit virtual clear : procedure;\r
+ Var xf,yf : integer;\r
+ Begin\r
+ if Verti<>none then xf:=Verti.x1-1;\r
+ else xf:=x2-lborder-1;\r
+ fi;\r
+ if Horiz<>none then yf:=Horiz.y1-1;\r
+ else yf:=y2-lborder-1;\r
+ fi;\r
+ call Rectanglef(x1+lborder+1,y1+lborder+2*(hauteur+2)+1,xf,yf,Noir);\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ end;\r
+\r
+ Unit iconify : procedure;\r
+ var i : integer,\r
+ l,r,c : boolean,\r
+ x,y : integer,\r
+ nboot : integer,\r
+ rep : integer;\r
+\r
+ Begin\r
+ call cls;\r
+ kill(clics);\r
+ call rectangle(1,SIZEY-40,40,SIZEY,BleuClair);\r
+ call rectangle(2,SIZEY-39,39,SIZEY-1,BleuClair);\r
+ call move(5,SIZEY-20);\r
+ call outstring(icname);\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,nboot,l,r,c);\r
+ if l \r
+ then if(x>=1 and x<=40 and y<=SIZEY and y>=SIZEY-40)\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep=13) (* validation *)\r
+ then exit;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ call cls;\r
+ clics:=new cliquer;\r
+ call W.affiche;\r
+ End iconify;\r
+\r
+ Begin\r
+ WhereXd:=x1+lborder+5;\r
+ WhereYd:=y1+lborder+2*(Haut_Bot+2)+5+8;\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ End Maine;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Son d\82rivant des classes Windows et elmt *)\r
+(***************************************************************************)\r
+ \r
+ Unit Son : Windows coroutine;\r
+ Var aa : Elmt,\r
+ Horiz : AccelerateH, (* accelerateur horizontal *)\r
+ Verti : AccelerateV; (* accelerateur vertical *)\r
+ \r
+ Unit virtual AffSuite : procedure;\r
+ Begin\r
+ if Horiz<>none\r
+ then call Horiz.affiche;\r
+ fi;\r
+ if Verti<>none\r
+ then call Verti.affiche;\r
+ fi;\r
+ Bout.Courant:=Bout.Head;\r
+ while(Bout.Courant<>none)\r
+ do\r
+ call Bout.Courant.data qua Bottons.affiche;\r
+ Bout.Courant:=bout.Courant.next;\r
+ od;\r
+ End AffSuite;\r
+\r
+ Unit virtual clear : procedure;\r
+ Var xf,yf : integer;\r
+ Begin\r
+ if Verti<>none then xf:=Verti.x1-1;\r
+ else xf:=x2-lborder-1;\r
+ fi;\r
+ if Horiz<>none then yf:=Horiz.y1-1;\r
+ else yf:=y2-lborder-1;\r
+ fi;\r
+ call Rectanglef(x1+lborder+1,y1+lborder+(hauteur+1)+1,xf,yf,Noir);\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ end;\r
+ \r
+ Begin\r
+ return;\r
+ pref Elmt(0) block\r
+ begin\r
+ aa:=this Elmt;\r
+ WhereXd:=x1+lborder+5;\r
+ WhereYd:=y1+lborder+(Haut_Bot+1)+5+8;\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ detach;\r
+ end\r
+ End Son;\r
+\r
+\r
+(***************************************************************************)\r
+(* definition de Accelerate d\82rivant des classes Windows et Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Accelerate : Bottons class(mother : Windows);\r
+ Var Bs : arrayof Racc,\r
+ PosX : integer,\r
+ PosY : integer,\r
+ LX,LY: integer,\r
+ C : integer; (* valeur du pas d'affichage *)\r
+ \r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ End AfficheSuite;\r
+ \r
+ Unit virtual bot_enable : procedure;\r
+ Begin\r
+ call mother.Bout.Insert(Bs(1));\r
+ call mother.Bout.Insert(Bs(2));\r
+ Call mother.Bout.Insert(Bs(3));\r
+ etat:=True;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ Begin\r
+ call mother.Bout.Delete(Bs(1));\r
+ call mother.Bout.Delete(Bs(2));\r
+ call mother.Bout.Delete(Bs(3));\r
+ etat:=False;\r
+ End bot_disable;\r
+\r
+\r
+ Unit virtual Deplacer : procedure( i :integer);\r
+ End Deplacer;\r
+ \r
+ Unit virtual Reset_Bot : procedure;\r
+ End Reset_Bot;\r
+\r
+ Begin \r
+ C:=5; (* valeur par defaut *)\r
+ inner;\r
+ call bot_enable;\r
+ End Accelerate;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateH d\82rivant de Accelerate *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateH : Accelerate class;\r
+ Var x : integer, \r
+ MaxX : integer,\r
+ MinX : integer;\r
+ \r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ Begin\r
+ call Rectanglef(x1+18,y1+3,x2-18,y2-3,Noir);\r
+ MaxX:=x2-18-LX;\r
+ MinX:=x1+18;\r
+ End AfficheSuite;\r
+\r
+ Unit DeplacerLeft : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=PosX-C;\r
+ if PosX<MinX\r
+ then PosX:=MinX;\r
+ Bs(1).etat:=False;\r
+ call Bs(1).bot_disable;\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ call Bs(3).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerLeft;\r
+ \r
+ Unit virtual Deplacer : procedure (x : integer);\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=x;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Deplacer;\r
+\r
+ Unit DeplacerRight : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=PosX+C;\r
+ if PosX>MaxX\r
+ then PosX:=MaxX;\r
+ Bs(3).etat:=False;\r
+ call Bs(3).bot_disable;\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ call Bs(1).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerRight;\r
+\r
+ Unit virtual Reset_Bot : procedure;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ x:=(x2-x1)/2;\r
+ PosX:=x-5;\r
+ PosY:=y1+3;\r
+ LX:=11;\r
+ LY:=y2-y1-6;\r
+ Bs(2).x1:=PosX;\r
+ Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX;\r
+ Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Reset_Bot;\r
+\r
+ Begin \r
+ array Bs dim (1:3);\r
+ Bs(1):=new Racc(id+1,T_FLDTE,x1+2,y1+2,x1+15,y1+15,spr_right);\r
+ Bs(1).etat:=True;\r
+ x:=(x2-x1)/2;\r
+ PosX:=x-5;\r
+ PosY:=y1+3;\r
+ LX:=11;\r
+ LY:=y2-y1-6;\r
+ Bs(2):=new Racc(id+2,-1,PosX,PosY,PosX+LX,PosY+LY,spr_point);\r
+ Bs(2).etat:=True;\r
+ Bs(3):=new Racc(id+3,T_FLGCH,x2-15,y2-16,x2-2,y2-3,spr_left);\r
+ Bs(3).etat:=True;\r
+ End AccelerateH;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateV d\82rivant de Accelerate *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateV : Accelerate class;\r
+ Var y : integer,\r
+ MaxY : integer,\r
+ MinY : integer; \r
+\r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ Begin\r
+ call Rectanglef(x1+3,y1+18,x2-3,y2-18,Noir);\r
+ MaxY:=y2-18-LY;\r
+ MinY:=y1+18;\r
+ End AfficheSuite;\r
+ \r
+ Unit DeplacerUp : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=PosY-C;\r
+ if PosY<MinY\r
+ then PosY:=MinY;\r
+ Bs(1).etat:=False;\r
+ call Bs(1).bot_disable;\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ call Bs(3).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerUp;\r
+\r
+ Unit virtual Deplacer : procedure (y : integer);\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=y;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Deplacer;\r
+ \r
+ Unit DeplacerDown : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=PosY+C;\r
+ if PosY>MaxY\r
+ then PosY:=MaxY;\r
+ Bs(3).etat:=False;\r
+ call Bs(3).bot_disable;\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ call Bs(1).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerDown;\r
+\r
+ Unit virtual Reset_Bot : procedure;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ y:=(y2-y1)/2;\r
+ PosX:=x1+3;\r
+ PosY:=y-5;\r
+ LX:=x2-x1-6;\r
+ LY:=11;\r
+ Bs(2).x1:=PosX;\r
+ Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX;\r
+ Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Reset_Bot;\r
+\r
+ Begin\r
+ array Bs dim (1:3);\r
+ Bs(1):=new Racc(id+1,T_FLHAU,x1+2,y1+2,x1+15,y1+15,spr_upper);\r
+ Bs(1).etat:=True;\r
+ y:=(y2-y1)/2;\r
+ PosX:=x1+3;\r
+ PosY:=y-5;\r
+ LX:=x2-x1-6;\r
+ LY:=11;\r
+ Bs(2):=new Racc(id+2,-1,PosX,PosY,PosX+LX,PosY+LY,spr_point);\r
+ Bs(2).etat:=True;\r
+ Bs(3):=new Racc(id+3,T_FLBAS,x2-15,y2-16,x2-2,y2-3,spr_lower);\r
+ Bs(3).etat:=True;\r
+ End AccelerateV;\r
+\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Ensemble (c'est une liste) *)\r
+(***************************************************************************)\r
+\r
+ Unit Ensemble : class;\r
+ Var Head : Node,\r
+ Courant : Node,\r
+ Last : Node;\r
+\r
+ Unit Node : class(data : elmt);\r
+ Var next : Node;\r
+ End Node;\r
+ \r
+ Unit virtual egalite : function (x,y : elmt) :boolean;\r
+ End egalite;\r
+\r
+ Unit Empty : function : boolean; \r
+ Begin\r
+ if Head=none\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End;\r
+\r
+ Unit Member : function (n : elmt) : boolean;\r
+ Var bl : boolean,\r
+ saveCou : Node;\r
+ Begin\r
+ Courant:=Head;\r
+ saveCou:=Courant;\r
+ bl:=False;\r
+ While (Courant<>none)\r
+ do\r
+ if not egalite(Courant.data,n)\r
+ then saveCou:=Courant; Courant:=Courant.next;\r
+ else bl:=True; exit;\r
+ fi;\r
+ od;\r
+ Courant:=SaveCou;\r
+ result:=bl;\r
+ End Member;\r
+\r
+ Unit Insert : procedure (n : elmt);\r
+ Var bl : boolean;\r
+ Begin\r
+ bl:=Member(n);\r
+ if not bl\r
+ then if Empty\r
+ then Head:=new Node(n); Last:=Head;\r
+ else Last.next:=new Node(n);\r
+ Last:=Last.next;\r
+ fi;\r
+ fi;\r
+ End Insert;\r
+\r
+ Unit Delete : procedure (n : elmt);\r
+ Var bl : boolean,\r
+ flag : Node;\r
+ Begin \r
+ bl:=Member(n);\r
+ if bl\r
+ then flag:=Courant.next; \r
+ if flag=Last\r
+ then Last:=Courant; courant.next:=none; kill(flag);\r
+ else if Courant.next<>none \r
+ then Courant.next:=Courant.next.next; kill(flag);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ End Delete;\r
+\r
+ End Ensemble;\r
+ \r
+(***************************************************************************)\r
+(* definition de la classe cliquer derivant de la classe ensemble *) \r
+(***************************************************************************)\r
+ \r
+ Unit cliquer : Ensemble class; \r
+ \r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id)=(y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+ \r
+ Unit Appartient : function(x,y : integer) : integer;\r
+ var bl : boolean;\r
+ Begin\r
+ bl:=False;\r
+ Courant:=Head;\r
+ while (Courant<>none)\r
+ do\r
+ if(x<(Courant.data qua elm.x2) and x>(Courant.data qua elm.x1) and \r
+ y<(Courant.data qua elm.y2) and y>(Courant.data qua elm.y1))\r
+ then bl:=True; exit;\r
+ else Courant:=Courant.next;\r
+ fi;\r
+ od;\r
+ if bl\r
+ then result:=Courant.data qua elm.id;\r
+ else result:=-1;\r
+ fi;\r
+ End Appartient;\r
+\r
+ End cliquer;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Listbot d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit Listbot : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id) = (y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+\r
+ End Listbot;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe ListKey d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit ListKey : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id) = (y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+\r
+ Unit Appartient : function(x : integer) : boolean;\r
+ var bl : boolean;\r
+ Begin\r
+ bl:=False;\r
+ Courant:=Head;\r
+ while (Courant<>none)\r
+ do\r
+ if(Courant.data.id = x)\r
+ then bl:=True; exit;\r
+ else Courant:=Courant.next;\r
+ fi;\r
+ od;\r
+ result:=bl;\r
+ End Appartient;\r
+\r
+ End ListKey;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe ListW d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit ListW : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ (* if (x qua Son.numero) = (y qua Son.numero)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi; *)\r
+ End egalite;\r
+\r
+ End ListW;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage des sprites des boutons *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit spr_upper : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call Line(x1+x-i/2,y1+y/2+i,x1+x+i/2,y1+y/2+i,couleur);\r
+ od\r
+ End spr_upper;\r
+\r
+(***************************************************************************)\r
+ Unit spr_lower : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call Line(x1+x-i/2,y2-y/2-i,x1+x+i/2,y2-y/2-i,couleur);\r
+ od\r
+ End spr_lower;\r
+\r
+(***************************************************************************)\r
+ Unit spr_left : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call Line(x2-x/2-i,y1+y-i/2,x2-x/2-i,y1+y+i/2,couleur);\r
+ od\r
+ End spr_left;\r
+\r
+(***************************************************************************)\r
+ Unit spr_right : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call Line(x1+x/2+i,y1+y-i/2,x1+x/2+i,y1+y+i/2,couleur);\r
+ od\r
+ End spr_right;\r
+\r
+(***************************************************************************)\r
+ Unit spr_close : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ call Rectanglef(x1+3,y1+y-1,x2-3,y1+y+1,couleur);\r
+ End spr_close;\r
+\r
+(***************************************************************************)\r
+ Unit spr_point : procedure(x1,y1,x2,y2,couleur : integer);;\r
+ var x,y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ x:=(x2-x1)/2;\r
+ call Rectanglef(x1+x-1,y1+y-1,x1+x+1,y1+y+1,couleur);\r
+ End spr_point;\r
+\r
+(***************************************************************************)\r
+(* procedure de gestion des boutons *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Load : procedure;\r
+ Const Largeur=300,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call fenet.affiche;\r
+ flagbool:=fenet.moveto(10,10);\r
+ call color(BleuClair);\r
+ flagbool:=fenet.outgtext("Chargement de Ville.dat en cours",32);\r
+ flagbool:=fenet.moveto(10,25);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext(".",1);\r
+ call Lit_Ville(fenet);\r
+ flagbool:=fenet.moveto(10,40);\r
+ call color(BleuClair);\r
+ flagbool:=fenet.outgtext("Chargement termine : 'Enter'",28);\r
+ fenet.B(0).etat:=True;\r
+ call fenet.bout.insert(fenet.B(0));\r
+ call fenet.B(0).affiche;\r
+ call keys.insert(new elmt(Tou_Ent));\r
+ call showcursor;\r
+ do\r
+ code:=fenet.gestionnaire;\r
+ if code=Tou_Ent or code=11 then exit fi;\r
+ od;\r
+ call hidecursor;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call cls;\r
+ call Etat_Menu(True,True,False,False,True);\r
+ call W.affiche;\r
+ COEF_X:=Larg_Aff/Larg_Vil;\r
+ COEF_Y:=Haut_Aff/Haut_Vil;\r
+ boolaf:=True;\r
+ call Ville_aff(1);\r
+ call showcursor;\r
+ End Bot_Load;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Run : procedure;\r
+ Const Largeur=330,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ nbcar : integer;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(10,10);\r
+ flagbool:=fenet.outgtext("Entrez le nombre de voitures (1-50)",32);\r
+ flagbool:=fenet.moveto(145,30);\r
+ nbcar:=gscanf(1,50);\r
+ call prg.generator(nbcar);\r
+ attach(fenet);\r
+ kill(fenet);\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call cls;\r
+ call Etat_Menu(False,False,True,False,False);\r
+ call W.affiche;\r
+ call Ville_aff(1);\r
+ End Bot_Run;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Stop : procedure;\r
+ Const Largeur=280,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(60,10);\r
+ flagbool:=fenet.outgtext("Simulation stopp\82e",18);\r
+ flagbool:=fenet.moveto(40,30);\r
+ flagbool:=fenet.outgtext("Appuyez sur une touche",22);\r
+ do\r
+ code:=inkey;\r
+ if code<>0 then exit; fi;\r
+ od;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call cls;\r
+ call Etat_Menu(True,False,False,True,True);\r
+ call W.affiche;\r
+ call Ville_aff(1);\r
+ End Bot_Stop;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_continue : procedure;\r
+ Const Largeur=300,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call fenet.affiche;\r
+ do\r
+ code:=inkey;\r
+ if code=13 then exit fi;\r
+ od;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call cls;\r
+ call Etat_Menu(False,False,True,False,False);\r
+ call W.affiche;\r
+ call Ville_aff(1);\r
+ End Bot_Continue;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Quit : function : boolean;\r
+ Const Largeur=300,\r
+ Hauteur=90;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ fin : boolean,\r
+ code : integer,\r
+ Yes,No : Menu;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ fenet:=new Son(10,Posx,Posy,Posx+Largeur,Posy+hauteur,2,True,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.nom:="Q U I T";\r
+ fenet.cnom:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ Yes:=new Menu(1,T_Y,Posx+60,Posy+61,Posx+100,Posy+61+Haut_bot);\r
+ Yes.nom:="Yes";\r
+ Yes.etat:=True;\r
+ call fenet.Bout.Insert(Yes);\r
+ No:=new Menu(2,T_N,Posx+190,Posy+61,Posx+220,Posy+61+Haut_bot);\r
+ No.nom:="No";\r
+ No.etat:=True;\r
+ call fenet.Bout.Insert(No);\r
+ call fenet.affiche;\r
+ call move(Posx+10,Posy+35);\r
+ call color(BleuClair);\r
+ call outstring("Do you want to quit the application");\r
+ call Keys.Insert(new elmt(T_ESC));\r
+ call showcursor;\r
+ do\r
+ code:=fenet.gestionnaire;\r
+ case code\r
+ when T_ESC : fin:=False; exit; (* touche racc exit *)\r
+ when T_Y : fin:=True; exit; (* touche Y *)\r
+ when T_N : fin:=False; exit; (* touche N *)\r
+ when 1 : fin:=True; exit; (* bouton yes *)\r
+ when 2 : fin:=False; exit; (* bouton no *) \r
+ when 11 : fin:=False; exit; (* racc exit *)\r
+ esac;\r
+ od; \r
+ call hidecursor;\r
+ if not fin\r
+ then attach(fenet);\r
+ kill(fenet);\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call cls;\r
+ call W.affiche;\r
+ call Ville_aff(1);\r
+ result:=False;\r
+ else result:=True;\r
+ fi;\r
+ call showcursor;\r
+ End Bot_Quit;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Help : procedure;\r
+ Const Largeur=410,\r
+ Hauteur=350;\r
+ Var fen : Son,\r
+ x,y,i,j : integer,\r
+ code : integer,\r
+ COORD_Y : integer,\r
+ fp : file,\r
+ tmp : char,\r
+ boolaff : boolean,\r
+ help : arrayof arrayof char,\r
+ nb_lign_hlp : integer;\r
+\r
+ \r
+ Unit affiche_hlp : procedure;\r
+ Begin\r
+ call fen.clear;\r
+ call color(BleuClair);\r
+ for i:=COORD_Y to imin(COORD_Y+18,nb_lign_hlp)\r
+ do\r
+ for j:=1 to 37\r
+ do\r
+ if (ord(help(i,j))>=28 and ord(help(i,j))<=255)\r
+ then boolaff:=fen.outchar(help(i,j));\r
+ fi;\r
+ od; \r
+ od;\r
+ End affiche_hlp;\r
+ \r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ fen:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,2,\r
+ True,False,False);\r
+ attach(fen);\r
+ fen.cnom:=RougeClair;\r
+ fen.nom:="H E L P";\r
+ fen.hauteur:=Haut_Bot;\r
+ fen.largeur:=Larg_Bot;\r
+ fen.cborder:=RougeClair;\r
+ fen.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ kill(Keys);\r
+ Keys:=new ListKey;\r
+ x:=fen.x2-fen.lborder-1-fen.hauteur;\r
+ y:=fen.y1+fen.hauteur+fen.lborder+1;\r
+ fen.Verti:=new AccelerateV(20,-1,x,y,x+fen.largeur,fen.y2-fen.lborder-1,fen);\r
+ call fen.affiche;\r
+ call fen.Verti.deplacer(fen.Verti.MinY);\r
+ call Keys.Insert(new elmt(T_ESC)); (* pour sortir de la fenetre *)\r
+ call Keys.Insert(new elmt(T_PGUP)); (* page up *)\r
+ call Keys.Insert(new elmt(T_PGDOWN)); (* page dow *)\r
+ COORD_Y:=1;\r
+ open(fp,text,unpack("simula.hlp"));\r
+ call reset(fp);\r
+ readln(fp,nb_lign_hlp);\r
+ array help dim (1:nb_lign_hlp);\r
+ for i:=1 to nb_lign_hlp\r
+ do \r
+ array help(i) dim (1:38);\r
+ od;\r
+ call color(BleuClair);\r
+ i:=1;\r
+ j:=1;\r
+ while not eof(fp)\r
+ do\r
+ read(fp,help(i,j));\r
+ j:=j+1;\r
+ if j=39 then j:=1;\r
+ i:=i+1;\r
+ fi;\r
+ od;\r
+ call affiche_hlp;\r
+ call setposition(fen.x1,fen.y1);\r
+ call showcursor;\r
+ do\r
+ code:=fen.gestionnaire;\r
+ call hidecursor;\r
+ if (code=T_ESC) or (code=11) then exit;\r
+ else\r
+ if (code=21) or (code=T_FLHAU) then COORD_Y:=COORD_Y-5;\r
+ if COORD_Y<=0 then COORD_Y:=1; fi;\r
+ call fen.Verti.DeplacerUp;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=22) then COORD_Y:=1;\r
+ call fen.Verti.Reset_Bot;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=23) or (code=T_FLBAS) then COORD_Y:=COORD_Y+5;\r
+ if COORD_Y>(nb_lign_hlp-5)\r
+ then COORD_Y:=nb_lign_hlp-5;\r
+ fi;\r
+ call fen.Verti.DeplacerDown;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=T_PGUP) then COORD_Y:=COORD_Y-19;\r
+ if COORD_Y<=0\r
+ then COORD_Y:=1;\r
+ call fen.Verti.Deplacer(fen.Verti.MinY);\r
+ else call fen.Verti.DeplacerDown;\r
+ fi;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=T_PGDOWN) then COORD_Y:=COORD_Y+19;\r
+ if COORD_Y>(nb_lign_hlp-5)\r
+ then COORD_Y:=nb_lign_hlp-5;\r
+ call fen.Verti.Deplacer(fen.Verti.MaxY);\r
+ else call fen.Verti.DeplacerDown;\r
+ fi;\r
+ call affiche_hlp;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call showcursor;\r
+ od;\r
+ attach(fen); (* correspond a la 1ere etape kill *)\r
+ kill(fen);\r
+ kill(clics);\r
+ clics:=new cliquer; (* on prepare pour la 'resurection' *)\r
+ kill(Keys);\r
+ Keys:=new ListKey;\r
+ call cls;\r
+ call W.affiche;\r
+ call Ville_aff(1);\r
+ End Bot_Help;\r
+\r
+(***************************************************************************)\r
+ Unit Etat_Menu : procedure (ml,mr,ms,mc,mq : boolean);\r
+ Begin\r
+ if (ml and not M(1).etat) (* load devient enable *)\r
+ then M(1).etat:=True;\r
+ M(1).Touche:=T_F1;\r
+ call M(1).bot_enable;\r
+ fi;\r
+ if (not ml and M(1).etat) (* load devient disable *)\r
+ then M(1).etat:=False;\r
+ M(1).Touche:=-1;\r
+ call M(1).bot_disable;\r
+ fi;\r
+ if (mr and not M(2).etat) (* run devient enable *)\r
+ then M(2).etat:=True;\r
+ M(2).Touche:=T_F2;\r
+ call M(2).bot_enable;\r
+ fi;\r
+ if (not mr and M(2).etat) (* run devient disable *)\r
+ then M(2).etat:=False;\r
+ M(2).Touche:=-1;\r
+ call M(2).bot_disable;\r
+ fi;\r
+ if (ms and not M(3).etat) (* stop devient enable *)\r
+ then M(3).etat:=True;\r
+ M(3).Touche:=T_F3;\r
+ call M(3).bot_enable;\r
+ fi;\r
+ if (not ms and M(3).etat) (* stop devient disable *)\r
+ then M(3).etat:=False;\r
+ M(3).Touche:=-1;\r
+ call M(3).bot_disable;\r
+ fi;\r
+ if (mc and not M(4).etat) (* continue devient enable *)\r
+ then M(4).etat:=True;\r
+ M(4).Touche:=T_F4;\r
+ call M(4).bot_enable;\r
+ fi;\r
+ if (not mc and M(4).etat) (* continue devient disable *)\r
+ then M(4).etat:=False;\r
+ M(4).Touche:=-1;\r
+ call M(4).bot_disable;\r
+ fi;\r
+ if (mq and not M(5).etat) (* quit devient enable *)\r
+ then M(5).etat:=True;\r
+ M(5).Touche:=T_F5;\r
+ call M(5).bot_enable;\r
+ fi;\r
+ if (not mq and M(5).etat) (* quit devient disable *)\r
+ then M(5).etat:=False;\r
+ M(5).Touche:=-1;\r
+ call M(5).bot_disable;\r
+ fi;\r
+ End;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage de la ville - on deborde de l'ecran *)\r
+(* tracer d'une ligne verticale qui peut depasser le cadre *)\r
+(***************************************************************************)\r
+ \r
+ Unit Trace_Vil1 : procedure (x1,y1,x2,y2 : real ; zoom : integer);\r
+ Var C : integer,\r
+ min_x : integer,\r
+ max_x : integer,\r
+ min_y : integer,\r
+ max_y : integer;\r
+ Begin\r
+ C:=5*zoom;\r
+ min_x:=imin(x1,x2);\r
+ max_x:=imax(x1,x2);\r
+ min_y:=imin(y1,y2);\r
+ max_y:=imax(y1,y2);\r
+ if (min_y>=Ydep_Aff and max_y<=(Ydep_Aff+Haut_Aff))\r
+ then (* on est en plein dans le cadre, on peut tracer normalement *)\r
+ call line(x1-C,imin(y1,y2)+C,x2-C,imax(y1,y2)-C,GrisClair);\r
+ call linep(x1,imin(y1,y2)+C,x2,imax(y1,y2)-C,Blanc,C);\r
+ call line(x1+C,imin(y1,y2)+C,x2+C,imax(y1,y2)-C,GrisClair);\r
+ else if (min_y<Ydep_Aff) (* c'est le minimum qui pose pb *)\r
+ then call line(x1-C,Ydep_Aff+C,x2-C,imax(y1,y2)-C,GrisClair);\r
+ call linep(x1,Ydep_Aff+C,x2,imax(y1,y2)-C,Blanc,C);\r
+ call line(x1+C,Ydep_Aff+C,x2+C,imax(y1,y2)-C,GrisClair);\r
+ else call line(x1-C,imin(y1,y2)+C,x2-C,Ydep_Aff+Haut_Aff-C,GrisClair);\r
+ call linep(x1,imin(y1,y2)+C,x2,Ydep_Aff+Haut_Aff-C,Blanc,C);\r
+ call line(x1+C,imin(y1,y2)+C,x2+C,Ydep_Aff+Haut_Aff-C,GrisClair);\r
+ fi;\r
+ fi;\r
+ End Trace_Vil1;\r
+\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage de la ville - on deborde de l'ecran *)\r
+(* tracer d'une ligne horizontale qui peut depasser le cadre *)\r
+(***************************************************************************)\r
+ \r
+ Unit Trace_Vil2 : procedure (x1,y1,x2,y2 : real ; zoom : integer);\r
+ Var C : integer,\r
+ min_x : integer,\r
+ max_x : integer,\r
+ min_y : integer,\r
+ max_y : integer;\r
+ Begin\r
+ C:=5*zoom;\r
+ min_x:=imin(x1,x2);\r
+ max_x:=imax(x1,x2);\r
+ min_y:=imin(y1,y2);\r
+ max_y:=imax(y1,y2);\r
+ if (min_x>=Xdep_Aff and max_x<=(Xdep_Aff+Larg_Aff))\r
+ then (* on est en plein dans le cadre, on peut tracer normalement *)\r
+ call line(imin(x1,x2)+C,y1-C,imax(x2,x1)-C,y2-C,GrisClair);\r
+ call linep(imin(x1,x2)+C,y1,imax(x2,x1)-C,y2,Blanc,C);\r
+ call line(imin(x1,x2)+C,y1+C,imax(x1,x2)-C,y2+C,GrisClair);\r
+ else if (min_x<Xdep_Aff) (* c'est le minimum qui pose pb *)\r
+ then call line(Xdep_Aff+C,y1-C,imax(x1,x2)-C,y2-C,GrisClair);\r
+ call linep(Xdep_Aff+C,y1,imax(x1,x2)-C,y2,Blanc,C);\r
+ call line(Xdep_Aff+C,y1+C,imax(x1,x2)-C,y2+C,GrisClair);\r
+ else call line(imin(x1,x2)+C,y1-C,Xdep_Aff+Larg_Aff-C,y2-C,GrisClair);\r
+ call linep(imin(x1,x2)+C,y1,Xdep_Aff+Larg_Aff-C,y2,Blanc,C);\r
+ call line(imin(x1,x2)+C,y1+C,Xdep_Aff+Larg_Aff-C,y2+C,GrisClair);\r
+ fi;\r
+ fi;\r
+ End Trace_Vil2;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage de la ville *)\r
+(***************************************************************************)\r
+ Unit Ville_Aff : procedure(zoom : integer);\r
+ var r : arcs,\r
+ s : sommets,\r
+ l : Liste,\r
+ C : integer,\r
+ x1,y1 : integer,\r
+ x2,y2 : integer,\r
+ min_x : integer,\r
+ max_x : integer,\r
+ min_y : integer,\r
+ max_y : integer;\r
+ Begin\r
+ if boolaf\r
+ then\r
+ call W.clear;\r
+ r:=RaciArcs;\r
+ while (r<> none)\r
+ do \r
+ x1:=Xdep_Aff+COORD_X+(r.initial.colonne*COEF_X*zoom);\r
+ y1:=Ydep_Aff+COORD_Y+(r.initial.Ligne*COEF_Y*zoom);\r
+ x2:=Xdep_Aff+COORD_X+(r.final.colonne*COEF_X*zoom);\r
+ y2:=Ydep_Aff+COORD_Y+(r.final.Ligne*COEF_Y*zoom);\r
+ min_x:=imin(x1,x2);\r
+ max_x:=imax(x1,x2);\r
+ min_y:=imin(y1,y2);\r
+ max_y:=imax(y1,y2);\r
+ if(x1=x2) (* c'est une ligne verticale *)\r
+ then \r
+ if (x1<Xdep_Aff or x2>(Xdep_Aff+Larg_Aff)) (* on est hors de l'ecran*)\r
+ then (* on ne fait rien *) \r
+ else (* on va peut etre afficher qqch *)\r
+ if (max_y<Ydep_Aff or min_y>(Ydep_Aff+Haut_Aff))\r
+ then (* on ne doit rien afficher *) \r
+ else (* on va afficher qqch *)\r
+ call trace_vil1(x1,y1,x2,y2,zoom);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ if(y1=y2) (* c'est une ligne horizontale *)\r
+ then \r
+ if (y1<Ydep_Aff or y2>(Ydep_Aff+Haut_Aff)) (* on est hors de l'ecran*)\r
+ then (*on ne fait rien *)\r
+ else (*on va peut etre afficher qqch *)\r
+ if (max_x<Xdep_Aff or min_x>(Xdep_Aff+Larg_Aff))\r
+ then (* on ne doit rien afficher *) \r
+ else (* on va afficher qqch *)\r
+ call trace_vil2(x1,y1,x2,y2,zoom);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ r:=r.suivants;\r
+ od;\r
+ s:=RaciSomm;\r
+ C:=5*zoom;\r
+ while(s<>none)\r
+ do\r
+ x1:=Xdep_Aff+COORD_X+(s.colonne*COEF_X*zoom);\r
+ y1:=Ydep_Aff+COORD_Y+(s.Ligne*COEF_Y*zoom);\r
+ if (x1>=Xdep_Aff and x1<=(Xdep_Aff+Larg_Aff) \r
+ and y1>=Ydep_Aff and y1<=(Ydep_Aff+Haut_Aff))\r
+ then case s.afftype\r
+ when 1 : call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ call line(x1+C,y1-C,x1+C,y1+C,GrisClair);\r
+ when 2 : call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ call line(x1+C,y1+C,x1+C,y1-C,GrisClair);\r
+ when 3 : call line(x1-C,y1+C,x1-C,y1-C,GrisClair);\r
+ call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ when 4 : call line(x1-C,y1-C,x1-C,y1+C,GrisClair);\r
+ call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ when 5 : call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ when 6 : call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ when 7 : call line(x1+C,y1-C,x1+C,y1+C,GrisClair);\r
+ when 8 : call line(x1-C,y1-C,x1-C,y1+C,GrisClair);\r
+ when 9 :\r
+ when 10 : call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ when 11 : call line(x1-C,y1-C,x1-C,y1+C,GrisClair);\r
+ call line(x1+C,y1-C,x1+C,y1+C,GrisClair);\r
+ esac;\r
+ fi;\r
+ s:=s.suivant;\r
+ od;\r
+ fi;\r
+ End Ville_Aff;\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(***************************************************************************)\r
+Unit prog : Lists class;\r
+\r
+(***************************************************************************)\r
+(* procedure de mise en route du generateur de voitures *)\r
+(***************************************************************************)\r
+ Unit generator : procedure (nbcar : integer);\r
+ Begin\r
+ call schedule(new Generate(nbcar),time);\r
+ call hold(10);\r
+ End generator;\r
+\r
+(***************************************************************************)\r
+(* simprocess de generation des voitures *)\r
+(***************************************************************************)\r
+ Unit Generate : Simprocess class(nbcar : integer);\r
+ Begin\r
+ do\r
+ if NbCarActiv<=nbcar\r
+ then call schedule(new car,time);\r
+ NbCarActiv:=NbCarActiv+1;\r
+ fi;\r
+ call hold(10);\r
+ od;\r
+ End Generate;\r
+\r
+(***************************************************************************)\r
+(* simprocess des voitures *)\r
+(* on se limite au cas o\97 toutes les voies sont \85 double sens *)\r
+(***************************************************************************)\r
+ Unit Car : Simprocess class;\r
+ \r
+ (* procedure d'affichage de la voiture dans la ville *)\r
+ Unit affiche_car : procedure;\r
+ Begin\r
+\r
+ End affiche_car;\r
+ \r
+ (* fonction se deplacant dans l'arc courant *)\r
+ Unit avance : function : boolean;\r
+ Begin\r
+ if sens=1\r
+ then arccour.occpsens(km):=none;\r
+ km:=km+1;\r
+ if km<=arccour.distance\r
+ then arccour.occpsens(km):=this car;\r
+ result:=True; (* on n'a pas encore fini *)\r
+ else result:=False; (* on est arrive au sommet final *)\r
+ fi;\r
+ else arccour.occpinve(km):=none;\r
+ km:=km+1;\r
+ if km<=arccour.distance\r
+ then arccour.occpinve(km):=this car;\r
+ result:=True; (* on n'a pas encore fini *)\r
+ else result:=False; (* on est arrive au sommet final *)\r
+ fi;\r
+ fi;\r
+ call affiche_car; \r
+ End avance;\r
+ \r
+ (* fonction choisissant le sommet de depart *)\r
+ Unit choix_sommet : function : sommets;\r
+ var som : sommets,\r
+ ch : integer,\r
+ i : integer;\r
+ Begin\r
+ som:=RaciSomm;\r
+ ch:=RANDOM*NBSOMMETS+1; (* on choisit le numero du sommet *)\r
+ for i:=1 to ch-1\r
+ do\r
+ som:=som.suivant;\r
+ od;\r
+ result:=som;\r
+ End choix_sommet;\r
+\r
+ (* fonction choisissant l'arc suivant que l'on va prendre *) \r
+ Unit choix_arc : function : arcs;\r
+ Var i : integer,\r
+ nbarcs : integer,\r
+ numarcdep : integer,\r
+ lst : liste;\r
+ Begin\r
+ nbarcs:=2;\r
+ if (dep.afftype<=8 and dep.afftype>=5)\r
+ then nbarcs:=nbarcs+1;\r
+ else if dep.afftype=9\r
+ then nbarcs:=nbarcs+2;\r
+ fi;\r
+ fi;\r
+ numarcdep:=RANDOM*nbarcs+1;\r
+ lst:=dep.ptrarc;\r
+ for i:=1 to numarcdep-1 (* on recherche cet arc dans la liste *)\r
+ do\r
+ lst:=lst.suivante;\r
+ od;\r
+ km:=1; (* kilometrage dans l'arc *)\r
+ result:=lst.pointeur; (* on poss\8ade l'arc *)\r
+ if result.initial=dep\r
+ then sens:=1;\r
+ else sens:=-1;\r
+ fi;\r
+ End choix_arc;\r
+\r
+ Var dep : sommets, (* sommet de depart du voyage *)\r
+ arccour : arcs, (* arc de depart du voyage *)\r
+ boo : boolean,\r
+ sens : integer, (* 1 si ini-fin , -1 si fin-ini *)\r
+ km : integer; (* distance ds l'arc courant depuis sommet initial*)\r
+ Begin\r
+ dep:=choix_sommet;\r
+ arccour:=choix_arc;\r
+ do\r
+ boo:=avance; (* on avance d'un pas *)\r
+ if boo (* on est \85 la fin de l'arc, il faut savoir si on va en *)\r
+ (* prendre un autre *)\r
+ then km:=RANDOM*100;\r
+ if km>60 \r
+ then arccour:=choix_arc; (* on a 60% de chance de continuer *)\r
+ boo:=True; (* on doit donc continuer *)\r
+ else boo:=False; (* on s'arrete *)\r
+ fi;\r
+ fi;\r
+ if boo (* si boo alors on n'est pas encore au point d'arrivee *)\r
+ then call hold(100);\r
+ else exit;\r
+ fi;\r
+ od;\r
+ NbCarActiv:=NbCarActiv-1;\r
+ call passivate;\r
+ End Car;\r
+\r
+\r
+(***************************************************************************)\r
+(* simprocess de gestion de l'affichage *)\r
+(***************************************************************************)\r
+ Unit affichage : simprocess class;\r
+ Begin\r
+ do \r
+ code:=W.Gestionnaire;\r
+ call hidecursor;\r
+ if (code=T_F1) or (code=1) then call Bot_Load; \r
+ else \r
+ if (code=T_F5) or (code=5) then if Bot_Quit then fin:=True; exit; fi; \r
+ else \r
+ if (code=T_F8) or (code=8) then call Bot_help; \r
+ else \r
+ if (code=T_ALTF4) then if Bot_Quit then fin:=True; exit; fi;\r
+ else \r
+ if (code=T_F2) or (code=2) then call Bot_Run;\r
+ else \r
+ if (code=T_F3) or (code=3) then call Bot_Stop;\r
+ else \r
+ if (code=T_f4) or (code=4) then call Bot_Continue;\r
+ else \r
+ if (code=T_FLGCH) or (code=51) then call W.Horiz.DeplacerLeft;\r
+ COORD_X:=COORD_X+30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=T_FLDTE) or (code=53) then call W.Horiz.DeplacerRight;\r
+ COORD_X:=COORD_X-30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=T_FLHAU) or (code=61) then call W.Verti.DeplacerUp;\r
+ COORD_Y:=COORD_Y+30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=T_FLBAS) or (code=63) then call W.verti.DeplacerDown;\r
+ COORD_Y:=COORD_Y-30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=101) then if Bot_Quit then fin:=True; exit fi;\r
+ else\r
+ if (code=102) then call W.iconify;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=52) then COORD_X:=0; \r
+ call W.Horiz.Reset_Bot;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=62) then COORD_Y:=0;\r
+ call W.Verti.Reset_Bot;\r
+ call Ville_Aff(ZOOM);\r
+ else \r
+ if (code=6) or (code=T_F6) \r
+ then Zoom:=Zoom+1;\r
+ if zoom=5 then M(6).etat:=False;\r
+ call M(6).bot_disable;\r
+ fi;\r
+ if not M(7).etat then M(7).etat:=True;\r
+ call M(7).bot_enable;\r
+ fi;\r
+ C:=5*Zoom;\r
+ Larg_Aff:=W.Horiz.x2-W.Horiz.x1-20-2*C;\r
+ Haut_Aff:=W.Verti.y2-W.Verti.y1-20-2*C;\r
+ Xdep_Aff:=W.Horiz.x1+10+C;\r
+ Ydep_Aff:=W.Verti.y1+10+C;\r
+ call Ville_Aff(Zoom);\r
+ else\r
+ if (code=7) or (code=T_F7)\r
+ then Zoom:=Zoom-1;\r
+ if zoom=1 then M(7).etat:=False;\r
+ call M(7).bot_disable;\r
+ fi;\r
+ if not M(6).etat then M(6).etat:=True;\r
+ call M(6).bot_Enable;\r
+ fi;\r
+ C:=5*Zoom;\r
+ Larg_Aff:=W.Horiz.x2-W.Horiz.x1-20-2*C;\r
+ Haut_Aff:=W.Verti.y2-W.Verti.y1-20-2*C;\r
+ Xdep_Aff:=W.Horiz.x1+10+C;\r
+ Ydep_Aff:=W.Verti.y1+10+C;\r
+ call Ville_Aff(Zoom);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call showcursor;\r
+ od;\r
+ End affichage;\r
+\r
+Var sim_aff : affichage;\r
+Begin\r
+ sim_aff:=new affichage;\r
+ call schedule(sim_aff,time);\r
+ call hold(1);\r
+End prog;\r
+\r
+(***************************************************************************)\r
+(* P R O G R A M M E P R I N C I P A L *)\r
+(***************************************************************************)\r
+Const Larg_bot=18,\r
+ Haut_bot=18;\r
+\r
+var prg : prog,\r
+ fin : boolean,\r
+ x1,y1 : integer,\r
+ x2,y2 : integer,\r
+ ZOOM : integer, (*coeficient de zoom *)\r
+ C : integer, (* largeur des voies *)\r
+ boolAf : boolean; (* vrai si il faut afficher la ville *)\r
+\r
+Begin\r
+ \r
+ call gron(1); (* mode 640x480x256 avec driver stealth.grn*)\r
+ SIZEX:=640; \r
+ SIZEY:=480;\r
+\r
+ clics:=new cliquer; (* ensemble des zones de clic possible *)\r
+\r
+ W:=new Maine(100,1,1,SIZEX,SIZEY,3,True,True,False);\r
+ W.hauteur:=Haut_bot;\r
+ W.cborder:=BleuClair;\r
+ W.cbande:=GrisClair;\r
+ W.cnom:=BleuClair;\r
+ W.nom:="Simulation de r\82seau routier";\r
+ W.icname:="Root";\r
+ \r
+ array M dim (1:8);\r
+\r
+ y1:=W.y1+W.lborder+1+W.hauteur+2;\r
+ y2:=y1+Haut_bot;\r
+ M(1):=new Menu(1,T_F1,W.x1+8,y1,W.x1+50,y2);\r
+ M(1).nom:="Load";\r
+ M(1).etat:=True;\r
+ call W.Bout.Insert(M(1));\r
+\r
+ M(2):=new Menu(2,-1,W.x1+55,y1,W.x1+89,y2);\r
+ M(2).nom:="Run";\r
+ M(2).etat:=False;\r
+ call W.Bout.Insert(M(2));\r
+\r
+ M(3):=new Menu(3,-1,W.x1+94,y1,W.x1+136,y2);\r
+ M(3).nom:="Stop";\r
+ M(3).etat:=False;\r
+ call W.Bout.Insert(M(3)); \r
+ \r
+ M(4):=new Menu(4,-1,W.x1+141,y1,W.x1+215,y2);\r
+ M(4).nom:="Continue";\r
+ M(4).etat:=False;\r
+ call W.Bout.Insert(M(4));\r
+\r
+ M(5):=new Menu(5,T_F5,W.x1+220,y1,W.x1+262,y2);\r
+ M(5).nom:="Quit";\r
+ M(5).etat:=True;\r
+ call W.Bout.Insert(M(5));\r
+ \r
+ M(6):=new Menu(6,T_F6,W.x2-94,y1,W.x2-77,y2);\r
+ M(6).nom:="+";\r
+ M(6).etat:=True;\r
+ call W.Bout.Insert(M(6));\r
+\r
+ M(7):=new Menu(7,T_F7,W.x2-72,y1,W.x2-55,y2);\r
+ M(7).nom:="-";\r
+ M(7).etat:=False;\r
+ call W.Bout.Insert(M(7));\r
+ \r
+ M(8):=new Menu(8,T_F8,W.x2-30,y1,W.x2-13,y2);\r
+ M(8).nom:="?";\r
+ M(8).etat:=True;\r
+ call W.Bout.Insert(M(8)); \r
+\r
+ x1:=W.x1+W.lborder+1;\r
+ y1:=W.y2-W.lborder-Haut_bot-1;\r
+ x2:=W.x2-W.lborder-Larg_bot-1;\r
+ y2:=W.y2-W.lborder-1;\r
+ W.Horiz:=new AccelerateH(50,-1,x1,y1,x2,y2,W);\r
+\r
+ x1:=W.x2-W.lborder-Larg_bot-1; \r
+ y1:=W.y1+W.lborder+2*(Haut_bot+2);\r
+ x2:=W.x2-W.lborder-1;\r
+ y2:=W.y2-W.lborder-Haut_bot;\r
+ W.Verti:=new AccelerateV(60,-1,x1,y1,x2,y2,W);\r
+ \r
+ Larg_Aff:=W.Horiz.x2-W.Horiz.x1-20;\r
+ Haut_Aff:=W.Verti.y2-W.Verti.y1-20;\r
+ Xdep_Aff:=W.Horiz.x1+10;\r
+ Ydep_Aff:=W.Verti.y1+10;\r
+ COEF_X:=1;\r
+ COEF_Y:=1;\r
+ COORD_X:=0;\r
+ COORD_Y:=0;\r
+ ZOOM:=1;\r
+ C:=5*ZOOM;\r
+ call W.affiche;\r
+ \r
+ call showcursor;\r
+ \r
+ prg:=new prog; (* on met la simulation en route *)\r
+ (* NB: elle commence par l'affichage et sa gestion *)\r
+ call hidecursor;\r
+ \r
+ call cls;\r
+ \r
+ call groff;\r
+\r
+ end\r
+ end\r
+end.\r
--- /dev/null
+Program simulation;\r
+\r
+(***************************************************************************)\r
+(* Programme de syst\8ame de fenetrage avec boutons et gestion de la souris *)\r
+(* ainsi que de simulation d'un r\82seau routier en ville. *)\r
+(* BARETS Olivier & PATAUD Fr\82d\82ric & PEYRAT Fran\87ois 1993/1994 *)\r
+(* plateforme : PC-DOS_386 avec clavier 102 touches / mode VGA / souris *)\r
+(* PC 486DX33 16Mo Ram *)\r
+(* ligne de commande de lancement : 'svgaint simula' *)\r
+(***************************************************************************)\r
+\r
+Begin\r
+Pref iiuwgraph block\r
+ \r
+ Begin\r
+ Pref mouse block\r
+\r
+\r
+ Const Noir = 0, Bleu = 1, Vert = 2, Cyan = 3,\r
+ Rouge = 4, Magenta = 5, Marron = 6, GrisClair = 7,\r
+ GrisFonce = 8, BleuClair = 9, VertClair =10, CyanClair =11,\r
+ RougeClair =12, MagentaClair=13, Jaune =14, Blanc =15;\r
+ \r
+ Const T_F1 =315, T_F2 =316, T_F3 =317, T_F4 =318,\r
+ T_F5 =319, T_F6 =320, T_F7 =321, T_F8 =322,\r
+ T_F9 =323, T_F10 =324, T_SHFTF1 =340, T_SHFTF2 =341,\r
+ T_SHFTF3 =342, T_SHFTF4 =343, T_SHFTF5 =344, T_SHFTF6 =345,\r
+ T_SHFTF7 =346, T_SHFTF8 =347, T_SHFTF9 =348, T_SHFTF10=349,\r
+ T_CTRLF1 =350, T_CTRLF2 =351, T_CTRLF3 =352, T_CTRLF4 =353, \r
+ T_CTRLF5 =354, T_CTRLF6 =355, T_CTRLF7 =356, T_CTRLF8 =357, \r
+ T_CTRLF9 =358, T_CTRLF10=359, T_ALTF1 =360, T_ALTF2 =361, \r
+ T_ALTF3 =362, T_ALTF4 =363, T_ALTF5 =364, T_ALTF6 =365, \r
+ T_ALTF7 =366, T_ALTF8 =367, T_ALTF9 =368, T_ALTF10 =369,\r
+ Tou_Ent =013, T_ESC =027, T_N =078, T_Y =089,\r
+ T_FLGCH =331, T_FLDTE =333, T_FLHAU =328, T_FLBAS =336,\r
+ T_ALT1 =376, T_ALT2 =377, T_PGUP =329, T_PGDOWN =337,\r
+ T_Back =008, T_ESPACE =032, T_CTRLENT=010;\r
+\r
+Const Larg_bot=18, (* largeur des boutons *)\r
+ Haut_bot=18; (* hauteur des boutons *)\r
+\r
+ Var SIZEX : integer,\r
+ SIZEY : integer;\r
+\r
+\r
+(* les variables du syst\8ame de fenetrage *)\r
+\r
+ Var code : integer,\r
+ Larg_Vil : integer, (* largeur de la ville *)\r
+ Haut_Vil : integer, (* Hauteur de la ville *)\r
+ Larg_Aff : integer, (* largeur de l'interieur de la fenetre maine *)\r
+ Haut_Aff : integer, (* hauteur de l'interieur de la fenetre maine *)\r
+ Xdep_Aff : integer, (* Point de depart de l'affichage en X ds maine *)\r
+ Ydep_Aff : integer, (* point de depart de l'affichage en Y ds maine *)\r
+ COEF_X : real, (* coeficient de zoom en x *)\r
+ COEF_Y : real, (* coeficient de zoom en y *)\r
+ COORD_X : integer, (* coordonn\82e en X de Xdep_Aff en relatif *)\r
+ COORD_Y : integer, (* coordonn\82e en Y de Ydep_Aff en relatif *)\r
+ Keys : ListKey,\r
+ SLKEYS : arrayof listkey,\r
+ SLCLICS : arrayof cliquer,\r
+ clics : cliquer,\r
+ EDIT : editor,\r
+ edit_bool: boolean,\r
+ SIMULA : simulateur,\r
+ DOS : MS_DOS;\r
+ \r
+\r
+(* les variables de la simulation *)\r
+\r
+ Var RaciSomm : Sommets,\r
+ RaciArcs : Arcs,\r
+ Activ : arrayof Pointeur, (* liste des vehicules en activite *)\r
+ NbCarActiv : integer,\r
+ NbMaxCar : integer,\r
+ NBSOMMETS : integer,\r
+ SimStop : boolean;\r
+\r
+(***************************************************************************)\r
+(* Permet de cr\82er un pointeur en loglan *)\r
+(***************************************************************************)\r
+ Unit Pointeur : class;\r
+ End Pointeur;\r
+\r
+\r
+(***************************************************************************)\r
+(* definition des classes et procedures de simprocess *)\r
+(***************************************************************************)\r
+\r
+\r
+UNIT PRIORITYQUEUE: CLASS;\r
+\r
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+\r
+\r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+\r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+\r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+\r
+END QUEUEHEAD;\r
+\r
+\r
+ UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+\r
+\r
+ UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+\r
+\r
+END PRIORITYQUEUE;\r
+\r
+\r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS: pointeur COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ BEGIN\r
+ \r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+ \r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ \r
+UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+\r
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)\r
+ (* WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+END SCHEDULE;\r
+ \r
+UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE; \r
+END SIMULATION;\r
+ \r
+ \r
+ \r
+UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+ \r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE FI;\r
+ END;\r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+ \r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT:PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+ \r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI FI;\r
+ END INTO;\r
+ END LINK;\r
+\r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+\r
+ END LISTS;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* definition des procedures de lecture des fichiers de donn\82es et mise en *)\r
+(* m\82moire des structures de la ville. *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+(* Structure d une place de parking *)\r
+(***************************************************************************)\r
+\r
+Unit Place : class (N : integer );\r
+var P1 : arrayof boolean;\r
+Begin\r
+ array P1 dim (1:N);\r
+End Place;\r
+\r
+(***************************************************************************)\r
+(* Structure de la liste des arc qui peuvent etre atteind *)\r
+(***************************************************************************)\r
+\r
+Unit Liste : class;\r
+var pointeur: Arcs,\r
+ suivante: Liste;\r
+end Liste;\r
+\r
+(***************************************************************************)\r
+(* Structure des arcs *)\r
+(***************************************************************************)\r
+Unit Arcs : class;\r
+Var Numero : integer, (* Identification de l'arc *)\r
+ Initial : Sommets, (* Sommet initial *)\r
+ Final : Sommets, (* Sommet final *)\r
+ Sens : integer, (* Sens de circulation *)\r
+ Distance : integer, (* Distance de initial a final*)\r
+ NbvoieIF : integer, (* Nombre de voie dans le sens 1 *)\r
+ NbvoieFI : integer, (* Nombre de voie dans le sens -1 *)\r
+ Suivants : Arcs, (* pointeur sur l'arc suivant dans la liste *)\r
+ (* pointeur sera de type car lors des affectations *)\r
+ occpsens : arrayof pointeur, (*si <>none alors il y a une voiture cette place*)\r
+ occpinve : arrayof pointeur; (*en sens inverse de initial final *)\r
+End Arcs;\r
+\r
+(***************************************************************************)\r
+(* Structure des sommets *)\r
+(***************************************************************************)\r
+\r
+Unit Sommets : class;\r
+var Nom : char, (* Nom du sommet *) \r
+ typecar : integer, (* Type carrefour 0:feu , 1:priorite , 2:stop *)\r
+ afftype : integer, (* type carrefour 1..9 pour affichage *)\r
+ Ligne : integer, (* Correspond a la position en Y sur ecran *)\r
+ Colonne : integer, (* Correspond a la position en X sur ecran *)\r
+ etat : integer, (* Etat du carrefour *)\r
+ ptrarc : Liste, (* Pointeur sur la liste pointant sur les arcs *)\r
+ suivant : Sommets; (* Pointeur sur les suivants *)\r
+End Sommets;\r
+\r
+(***************************************************************************)\r
+(* Procedure creant la liste des Sommets *)\r
+(* Ici il y a juste creation d un liste simple de sommet en mode pile *)\r
+(***************************************************************************)\r
+\r
+Unit CreeSomm : procedure( f: file);\r
+var Noeud : Sommets,\r
+ tampon: char,\r
+ arret : boolean;\r
+\r
+Begin\r
+ readln(f);\r
+ arret := false;\r
+ while not arret \r
+ do\r
+ read(f,tampon);\r
+ if ( tampon <> '.') then\r
+ Noeud := new Sommets;\r
+ NBSOMMETS:=NBSOMMETS+1; (* on comptabilise le nombre de sommets*)\r
+ Noeud.Nom := tampon;\r
+ read(f,Noeud.typecar);\r
+ read(f,Noeud.afftype);\r
+ read(f,Noeud.colonne);\r
+ (* on met en place les variables permettant de d\82finir les coef*)\r
+ (* de l'affichage en vectoriel *)\r
+ if(Noeud.colonne>Larg_Vil) then Larg_Vil:=Noeud.colonne; fi;\r
+ readln(f,Noeud.ligne);\r
+ if(Noeud.ligne>Haut_Vil) then Haut_Vil:=Noeud.ligne; fi;\r
+ Noeud.etat := 0; (* servira pour les \82volutions futures *)\r
+ Noeud.ptrarc := none;\r
+ Noeud.Suivant := RaciSomm;\r
+ RaciSomm := Noeud;\r
+ else arret := true;\r
+ fi\r
+ od;\r
+End CreeSomm;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure affichant chaque sommet ainsi que les arcs que l'on peut *)\r
+(* prendre depuis ce sommet en considerant les sens de circulation etc... *)\r
+(***************************************************************************)\r
+Unit ParcSomm : procedure;\r
+var Noeud : Sommets;\r
+var parcours : Liste;\r
+Begin\r
+ Noeud := RaciSomm;\r
+ while (Noeud <> none)\r
+ do\r
+ write("Nom: ");\r
+ writeln(Noeud.Nom);\r
+ writeln("X : ",Noeud.Colonne);\r
+ writeln("Y : ",Noeud.ligne);\r
+ parcours := Noeud.ptrarc;\r
+ while (parcours <> none )\r
+ do\r
+ writeln("Arc: ",parcours.pointeur.Numero);\r
+ parcours := parcours.suivante;\r
+ od;\r
+ Noeud := Noeud.suivant;\r
+ od;\r
+End ParcSomm;\r
+\r
+(***************************************************************************)\r
+(* Procedure affichant chaque arc *)\r
+(***************************************************************************)\r
+Unit ParcArc : procedure;\r
+var Noeud : arcs;\r
+var parcours : Liste;\r
+Begin\r
+ Noeud := RaciArcs;\r
+ while (Noeud <> none)\r
+ do\r
+ write("Numero: ");\r
+ write(Noeud.Numero);\r
+ write(" Sommet initial: ");\r
+ write(Noeud.initial.nom);\r
+ write(" Sommet final: ");\r
+ write(Noeud.final.nom);\r
+ write(" Distance: ");\r
+ writeln(Noeud.Distance);\r
+ Noeud := Noeud.suivants;\r
+ od;\r
+End ParcArc;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure creant la liste des Arc *)\r
+(* Ici on cree la liste des Arc sur la base d'une pile, puis il y a *)\r
+(* rattachement des pointeurs final et initial avec la liste des sommets *)\r
+(* et ce grace a la procedure rattache. *) \r
+(***************************************************************************)\r
+\r
+Unit CreeArcs : procedure( f: file);\r
+var Noeud : Arcs;\r
+var aux1 : char,\r
+ aux2 : char,\r
+ aux3 : char;\r
+Begin\r
+ readln(f);\r
+ readln(f);\r
+ while ( not(eof(f)))\r
+ do\r
+ Noeud := new Arcs;\r
+ read(f,Noeud.Numero);\r
+ read(f,aux3);\r
+ read(f,aux1);\r
+ read(f,aux3);\r
+ read(f,aux2);\r
+ read(f,aux3);\r
+ read(f,Noeud.Sens);\r
+ read(f,Noeud.distance);\r
+ (* on va supposer qu'il y a toujours 2 voies, une dans chaque sens *)\r
+ array Noeud.occpsens dim (1:Noeud.distance); (* on met la voie en place*)\r
+ array Noeud.occpinve dim (1:Noeud.distance);\r
+ read(f,Noeud.NbvoieIF);\r
+ readln(f,Noeud.NbvoieFI);\r
+ Noeud.Initial := none;\r
+ Noeud.Final := none;\r
+ Noeud.Suivants:= RaciArcs;\r
+ RaciArcs := Noeud;\r
+ Call rattache(Noeud,aux1,aux2);\r
+ od;\r
+End CreeArcs;\r
+\r
+(***************************************************************************)\r
+(* Rattachement du pointeur arc avec le sommet *)\r
+(* Cette procedure rattache les pointeurs final et initial des arcs avec *)\r
+(* un sommet de la liste des sommets. *)\r
+(* Puis il y a la procedure creant la liste des arcs que l'on peut *)\r
+(* emprunter depuis ce sommet. Cette procedure est appele ici. *) \r
+(* Pour l appelle de cette procedure RattaListe nous verifions le sens de *)\r
+(* circulation dans les arcs, en effet des arcs ne peuvent pas etre pris a *)\r
+(* partir de certain sommets, donc il ne doivent pas figurer dans cette *)\r
+(* liste( Sens interdits ). *)\r
+(***************************************************************************)\r
+Unit Rattache : procedure ( inout Noeud : Arcs ; aux1,aux2:char);\r
+var Parcours : Sommets;\r
+\r
+begin\r
+ Parcours := RaciSomm;\r
+ while((Parcours<>none) and (Parcours.Nom<>aux1) and (Parcours.Nom<>aux2))\r
+ do\r
+ Parcours := Parcours.suivant;\r
+ od;\r
+ if Parcours.Nom = aux1\r
+ then\r
+ Noeud.Initial := Parcours;\r
+ if Noeud.Sens <> -1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else if Parcours.Nom = aux2 \r
+ then\r
+ Noeud.Final := Parcours; \r
+ if Noeud.Sens <> 1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi\r
+ else\r
+ write("ERREUR de rattachement initial");\r
+ exit;\r
+ fi;\r
+ fi;\r
+ Parcours := Parcours.suivant;\r
+ while((Parcours<>none) and (Parcours.Nom<>aux1) and (Parcours.Nom<>aux2))\r
+ do\r
+ Parcours := Parcours.suivant;\r
+ od;\r
+ if Parcours.Nom = aux1\r
+ then\r
+ Noeud.Initial := Parcours; \r
+ if Noeud.Sens <> -1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else if Parcours.Nom = aux2 \r
+ then\r
+ Noeud.final := parcours;\r
+ if Noeud.Sens <> 1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else\r
+ write("ERREUR de rattachement du final");\r
+ fi;\r
+ fi;\r
+end rattache;\r
+\r
+(***************************************************************************)\r
+(* Rattachement des sommets a la liste des arc qui peuvent etres atteinds *)\r
+(***************************************************************************)\r
+Unit RattaListe : procedure (inout NoeudSom : sommets; NoeudArc : Arcs);\r
+var Noeud : Liste;\r
+\r
+begin\r
+ Noeud := new Liste;\r
+ Noeud.suivante := NoeudSom.ptrarc;\r
+ Noeud.pointeur := NoeudArc;\r
+ NoeudSom.ptrarc := Noeud;\r
+End RattaListe;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure de lecture de la ville appell\82e par bo_load *)\r
+(***************************************************************************)\r
+\r
+Unit Lit_Ville : procedure( fenet : Windows; a : arrayof char);\r
+var fichier : file,\r
+ flagbool : boolean;\r
+begin\r
+ Larg_Vil:=0;\r
+ Haut_Vil:=0;\r
+ NBSOMMETS:=0;\r
+ open (fichier,text,a);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext(".",1);\r
+ call reset (fichier);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("..",2);\r
+ Call CreeSomm(fichier);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("..",2);\r
+ Call CreeArcs(fichier);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("..",2);\r
+end Lit_Ville;\r
+\r
+(***************************************************************************)\r
+(* definition des procedures d'utilitaires graphiques *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+(* trace une ligne entre 2 points, change la position courante *)\r
+(***************************************************************************)\r
+ Unit Line : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ End Line;\r
+\r
+(***************************************************************************)\r
+(* tracer d'une ligne de pointill\82s, ne fonctionne qu'en horiz ou en verti *)\r
+(***************************************************************************)\r
+ Unit Linep : procedure (x1,y1,x2,y2,c,s :integer);\r
+ Var i :integer;\r
+ Begin (* ne fonctionne que pour des horizontales ou des verticales *)\r
+ if (x1=x2)\r
+ then for i:=y1 step s*2 to y2 \r
+ do\r
+ call line(x1,i,x1,i+s,c);\r
+ od;\r
+ else if (y1=y2)\r
+ then for i:=x1 step s*2 to x2 \r
+ do\r
+ call line(i,y1,i+s,y1,c);\r
+ od;\r
+ fi;\r
+ fi;\r
+ End linep;\r
+\r
+(***************************************************************************)\r
+ Unit Rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1);\r
+ End Rectangle;\r
+\r
+(***************************************************************************)\r
+(* tracer d'un rectangle plein *)\r
+(***************************************************************************)\r
+ Unit Rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ var i : integer;\r
+ Begin\r
+ for i:=imin(y1,y2) to imax(y1,y2)\r
+ do\r
+ call Line(x1,i,x2,i,c);\r
+ od\r
+ End Rectanglef;\r
+\r
+(****************************************************************************)\r
+(* Lecture d'une touche (bloquant) en affichant un curseur clignotant *)\r
+(***************************************************************************)\r
+ Unit Readcara : function (x,y,col_f,col_e : integer) : integer;\r
+ Var i : integer,\r
+ sx,sy : integer;\r
+ Begin\r
+ sx:=x;\r
+ sy:=y;\r
+ i:=inkey;\r
+ while i=0\r
+ do\r
+ call color(col_f);\r
+ call move(x,y);\r
+ call outstring("_");\r
+ for i:=1 to 300 do od;\r
+ call color(col_e);\r
+ call move(x,y);\r
+ call outstring("_");\r
+ for i:=1 to 100 do od;\r
+ i:=inkey;\r
+ od;\r
+ call color(col_f);\r
+ call move(x,y);\r
+ call outstring("_");\r
+ call move(sx,sy);\r
+ call color(col_e);\r
+ result:=i;\r
+ End Readcara;\r
+\r
+(****************************************************************************)\r
+(* lecture d'un entier en mode graphique, esc revient au debut de saisie *)\r
+(* l'entier doit se trouver dans une plage d\82finie par rangmin et rangmax *)\r
+(****************************************************************************)\r
+ Unit gscanf_num : function (rangmin,rangmax : integer) : integer;\r
+ Var valeur : integer,\r
+ sauvx : integer,\r
+ sauvy : integer,\r
+ flag : integer;\r
+ Begin\r
+ sauvx:=inxpos;\r
+ sauvy:=inypos;\r
+ do\r
+ valeur:=0;\r
+ do\r
+ flag:=readcara(inxpos,inypos,Noir,BleuClair);\r
+ if (flag>=48 and flag<=57)\r
+ then valeur:=valeur*10+flag-48;\r
+ call move(inxpos,inypos);\r
+ call hascii(flag);\r
+ fi;\r
+ if (flag=13) then exit; fi;\r
+ if (flag=27) (* on a demand\82 annulation *)\r
+ then valeur:=0;\r
+ call rectanglef(sauvx-1,sauvy-1,inxpos,sauvy+13,Noir);\r
+ call color(BleuClair);\r
+ call move(sauvx,sauvy);\r
+ fi;\r
+ od;\r
+ if (valeur>=rangmin and valeur<=rangmax)\r
+ then exit;\r
+ else call rectanglef(sauvx-1,sauvy-1,inxpos,sauvy+13,Noir);\r
+ call color(BleuClair);\r
+ call move(sauvx,sauvy);\r
+ fi;\r
+ od;\r
+ result:=valeur;\r
+ End gscanf_num;\r
+\r
+(****************************************************************************)\r
+(* lecture d'une chaine en mode graphique, esc revient au debut de saisie *)\r
+(****************************************************************************)\r
+ Unit gscanf_char : function (x,y,larg : integer;inout nbmax : integer) : arrayof char;\r
+ Var depx,posx : integer,\r
+ rep : integer,\r
+ col_e,col_f : integer,\r
+ resultat : arrayof char; \r
+\r
+ Unit affiche : procedure;\r
+ Var i :integer;\r
+ Begin\r
+ call Rectanglef(x-1,y-1,x+larg*8,y+14,col_f);\r
+ for i:=depx to posx\r
+ do\r
+ call move(x+(i-depx)*8,y);\r
+ call hascii(ord(resultat(i)));\r
+ od;\r
+ End;\r
+\r
+ Begin\r
+ call hidecursor;\r
+ array resultat dim (0:nbmax);\r
+ resultat(0):=chr(0);\r
+ col_f:=BleuClair;\r
+ col_e:=Noir;\r
+ depx:=0;\r
+ posx:=0;\r
+ call affiche;\r
+ do\r
+ do\r
+ if depx=0\r
+ then rep:=readcara(x+posx*8,y,col_f,col_e);\r
+ else rep:=readcara(x+(larg-1)*8,y,col_f,col_e);\r
+ fi;\r
+ if ((rep>=32 and rep<=122) or rep=T_Back or rep=Tou_Ent)\r
+ then exit;\r
+ fi;\r
+ od;\r
+ if (rep>=32 and rep<=122)\r
+ then resultat(posx):=chr(rep);\r
+ posx:=posx+1;\r
+ if posx>=nbmax\r
+ then posx:=posx-1;\r
+ else if posx>=larg\r
+ then depx:=depx+1;\r
+ fi;\r
+ fi;\r
+ call affiche;\r
+ else if rep=Tou_ent\r
+ then exit;\r
+ else posx:=posx-1;\r
+ if posx<0 then posx:=0; fi;\r
+ resultat(posx):=chr(0);\r
+ depx:=depx-1;\r
+ if depx<0 then depx:=0; fi;\r
+ call affiche;\r
+ fi;\r
+ fi;\r
+ od;\r
+ nbmax:=posx;\r
+ call showcursor;\r
+ result:=resultat;\r
+ End gscanf_char;\r
+\r
+\r
+(****************************************************************************)\r
+(* affiche un entier en mode graphique, maximum 10 chiffres *)\r
+(****************************************************************************)\r
+unit writint : procedure( valeur : integer);\r
+var flag,i : integer;\r
+var tbl : arrayof integer;\r
+begin\r
+ array tbl dim (1:10);\r
+ flag:=1; (* on 'empile' en ordre reverse *)\r
+ while valeur<>0\r
+ do\r
+ tbl(flag):=valeur mod 10;\r
+ valeur:=valeur div 10;\r
+ flag:=flag+1\r
+ od;\r
+ for i:=flag-1 downto 1 (* on affiche dans le bon ordre *)\r
+ do\r
+ call hascii(48+tbl(i))\r
+ od\r
+end writint;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+(* definition des classes d'\82l\82ments des listes *)\r
+(***************************************************************************)\r
+ \r
+ Unit Elmt : class(id : integer);\r
+ End Elmt;\r
+ \r
+ Unit elm : Elmt class(x1,y1,x2,y2 :integer);\r
+ End elm;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Bottons : Elmt class(touche,x1,y1,x2,y2 : integer); \r
+ (* x2-x1 et y2-y1 doit au mini etre de 8*)\r
+ (* x1,y1 : integer coordonn\82es du point haut gauche *)\r
+ (* x2,y2 : integer coordonn\82es du point bas droit *)\r
+ Var etat : boolean; (* true si bouton enable *)\r
+ \r
+ Unit affiche : procedure;\r
+ Begin\r
+ call Line(x1,y1,x2,y1,Blanc); (* Lignes en blanc *) \r
+ call Line(x1,y1+1,x2-1,y1+1,Blanc);\r
+ call Line(x1,y1,x1,y2,Blanc);\r
+ call Line(x1+1,y1+2,x1+1,y2-1,Blanc);\r
+ call Line(x1+1,y2,x2,y2,GrisFonce); (* Lignes en gris fonce *)\r
+ call Line(x1+2,y2-1,x2,y2-1,GrisFonce);\r
+ call Line(x2,y2,x2,y1+1,GrisFonce);\r
+ call Line(x2-1,y2-1,x2-1,y1+2,GrisFonce);\r
+ call Rectanglef(x1+2,y1+2,x2-2,y2-2,GrisClair); (* centre en gris *)\r
+ call AfficheSuite;\r
+ End affiche;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ End;\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ End;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ End;\r
+ \r
+ End Bottons;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Menu derivant de Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Menu : Bottons class;\r
+ Var cnom : integer, (* couleur du nom du bouton *) \r
+ nom : string; (* nom du bouton *)\r
+ \r
+ Unit affiche_nom : procedure;\r
+ Begin \r
+ call move(x1+5,y1+(y2-y1)/4-1);\r
+ call color(cnom);\r
+ call outstring(nom);\r
+ End affiche_nom;\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ var e : elm;\r
+ Begin\r
+ cnom:=RougeClair;\r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Insert(e);\r
+ if (touche<>-1)\r
+ then call Keys.Insert(new elmt(touche));\r
+ fi;\r
+ call affiche_nom;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ var e : elm;\r
+ Begin\r
+ cnom:=Rouge;\r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Delete(e);\r
+ if (touche<>-1)\r
+ then call Keys.delete(new elmt(touche));\r
+ fi;\r
+ call affiche_nom;\r
+ End bot_disable;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ Begin\r
+ if (etat) \r
+ then call bot_enable;\r
+ else call bot_disable;\r
+ fi;\r
+ End AfficheSuite;\r
+\r
+ End Menu;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Racc derivant de Bottons *)\r
+(* la procedure sprite permet d'afficher le sprite correspondant au bouton *)\r
+(***************************************************************************)\r
+ Unit Racc : Bottons class (procedure sprite(x1,y1,x2,y2,col :integer));\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ var e : elm;\r
+ Begin \r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Insert(e);\r
+ if (touche<>-1) (* si une touche a \82t\82 d\82finie pour ce bouton *)\r
+ then call Keys.Insert(new elmt(touche));\r
+ fi;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ var e : elm;\r
+ Begin \r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Delete(e);\r
+ if (touche<>-1) (* si une touche a \82t\82 d\82finie pour ce bouton *)\r
+ then call Keys.delete(new elmt(touche));\r
+ fi;\r
+ End bot_disable;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ Begin\r
+ if etat\r
+ then call bot_enable;\r
+ call sprite(x1,y1,x2,y2,Noir);\r
+ else call bot_disable;\r
+ call sprite(x1,y1,x2,y2,GrisFonce);\r
+ fi;\r
+ End AfficheSuite;\r
+\r
+ End Racc;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Windows *)\r
+(***************************************************************************)\r
+ \r
+ Unit Windows : class(numero,x1,y1,x2,y2,lborder : integer; \r
+ r1,r2,r3 : boolean); \r
+ hidden x,y,xp,yp; \r
+ (* x2-x1 et y2-y1 doit au mini etre 33 *)\r
+ Var cborder : integer, (* couleur du pourtour *)\r
+ cnom : integer, (* couleur du nom de la fenetre *)\r
+ nom : string, (* nom de la fenetre, sera affich\82 en haut *)\r
+ Bout : ListBot, (* liste des boutons rattaches *)\r
+ Hauteur : integer, (* hauteur de la bande *)\r
+ Largeur : integer, (* largeur des raccourcis *)\r
+ cbande : integer, (* couleur de la bande *)\r
+ WhereXd : integer, (* position en x de depart dans la fenetre *)\r
+ WhereX : integer, (* position courante en X dans la fenetre *)\r
+ WhereYd : integer, (* position en y de depart dans la fenetre *)\r
+ WhereY : integer; (* position courante en Y dans la fenetre *)\r
+ var B : arrayof Racc, (* variables locales *)\r
+ x,y : integer,\r
+ xp,yp : integer,\r
+ map : arrayof integer, (* pour le getmap du dessous *)\r
+ savmap : arrayof integer; (* pour le getmap du dessus *)\r
+ \r
+ Unit affiche : procedure;\r
+ var i : integer; \r
+ Begin\r
+ call move(x1,y1);\r
+ map:=getmap(x2,y2);\r
+ call rectanglef(x1,y1,x2,y2,Noir);\r
+ for i:=0 to lborder\r
+ do\r
+ call rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
+ od;\r
+ call Line(x1+16,y1,x1+16,y1+lborder,Noir); (* Lignes noires *)\r
+ call Line(x2-16,y1,x2-16,y1+lborder,Noir);\r
+ call Line(x1+16,y2,x1+16,y2-lborder,Noir);\r
+ call Line(x2-16,y2,x2-16,y2-lborder,Noir);\r
+ call Line(x1,y1+16,x1+lborder,y1+16,Noir);\r
+ call Line(x1,y2-16,x1+lborder,y2-16,Noir);\r
+ call Line(x2,y1+16,x2-lborder,y1+16,Noir);\r
+ call Line(x2,y2-16,x2-lborder,y2-16,Noir);\r
+ call Rectanglef(x1+lborder+1,y1+lborder+1,x2-lborder-1,\r
+ y1+lborder+hauteur+1,cbande);\r
+ call move(x1+(x2-x1)/3,y1+lborder+hauteur/4);\r
+ call color(cnom);\r
+ call outstring(nom);\r
+ call AffSuite;\r
+ call move(x1,y1);\r
+ savmap:=getmap(x2,y2);\r
+ End affiche;\r
+ \r
+ Unit virtual AffSuite : procedure;\r
+ End AffSuite;\r
+\r
+ Unit restore : procedure;\r
+ Begin\r
+ call move(x1,y1);\r
+ call putmap(map);\r
+ kill(map);\r
+ End restore;\r
+\r
+ Unit virtual clear : procedure;\r
+ End clear;\r
+ \r
+ (* gestionnaire d'\82v\82nement de la fenetre *)\r
+ Unit gestionnaire : function : integer;\r
+ Var l,r,c : boolean,\r
+ x,y : integer,\r
+ rep : integer,\r
+ nbbot : integer;\r
+ Begin\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if (l) and (clics<>none)\r
+ then result:=clics.Appartient(x,y); exit;\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep>=97 and rep<=122) (* passe les lettres en majuscule *)\r
+ then rep:=rep-32;\r
+ fi;\r
+ if keys.Appartient(rep)\r
+ then result:=rep; exit;\r
+ fi;\r
+ (* ligne rajoutee pour que cela ne soit pas bloquant pdt la simulation *)\r
+ if not SimStop then exit fi;\r
+ od;\r
+ End gestionnaire;\r
+\r
+ (* permet de se deplacer dans la fenetre *)\r
+ Unit moveto : function (x,y :integer) : boolean;\r
+ Begin\r
+ if (x>0 and x<(x2-x1)) and (y>0 and y<y2-y1)\r
+ then WhereX:=WhereXd+x;\r
+ WhereY:=WhereYd+y;\r
+ call move(WhereX,WhereY);\r
+ result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End moveto;\r
+\r
+ (* affichage d'une chaine de longueur connue 'long' *)\r
+ Unit outgtext : function (chaine : string; long : integer) : boolean;\r
+ Begin\r
+ if (long*8+WhereX)<(x2-lborder-5)\r
+ then call move(WhereX,WhereY);\r
+ call outstring(chaine);\r
+ WhereX:=WhereX+long*8;\r
+ if WhereX>= x2-lborder-16\r
+ then WhereX:=WhereXd;\r
+ WhereY:=WhereY+16;\r
+ fi;\r
+ result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End outgtext;\r
+\r
+ (* affichage d'un caract\8are *)\r
+ Unit outchar : function (tmp : char) : boolean;\r
+ Begin\r
+ if (10+WhereX)<(x2-lborder-5-largeur)\r
+ then call move(WhereX,WhereY);\r
+ call hascii(ord(tmp));\r
+ WhereX:=WhereX+10;\r
+ if WhereX>= x2-lborder-16-largeur\r
+ then WhereX:=WhereXd;\r
+ WhereY:=WhereY+16;\r
+ fi;\r
+ result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End outchar;\r
+\r
+ Begin\r
+ \r
+ Bout:=new ListBot; (* liste des boutons rattach\82s *)\r
+ \r
+ array B dim (0:2);\r
+\r
+ x:=x2-Larg_bot-lborder-1;\r
+ y:=y1+lborder+1;\r
+ xp:=x2-lborder-1;\r
+ yp:=y+Haut_bot;\r
+ B(2):=new Racc(numero+3,-1,x,y,xp,yp,spr_upper);\r
+ B(2).etat:=r3;\r
+ call Bout.Insert(B(2));\r
+ \r
+ xp:=x-1;\r
+ x:=xp-Larg_bot;\r
+ B(1):=new Racc(numero+2,-1,x,y,xp,yp,spr_lower);\r
+ B(1).etat:=r2;\r
+ call Bout.Insert(B(1));\r
+ \r
+ x:=x1+lborder+1;\r
+ xp:=x+Larg_bot;\r
+ B(0):=new Racc(numero+1,-1,x,y,xp,yp,spr_close);\r
+ B(0).etat:=r1;\r
+ call Bout.Insert(B(0));\r
+\r
+ End Windows;\r
+\r
+(***************************************************************************)\r
+(* definition de main d\82rivant de la classe Windows *)\r
+(***************************************************************************)\r
+ \r
+ Unit Maine : Windows class;\r
+ var icname : string, (* nom une fois iconise *)\r
+ Lwind : ListW, (* liste des fenetres filles *)\r
+ Horiz : AccelerateH, (* accelerateur horizontal *)\r
+ Verti : AccelerateV1; (* accelerateur vertical *)\r
+\r
+ Unit virtual AffSuite : procedure;\r
+ Begin\r
+ call Rectanglef(x1+lborder+1,y1+lborder+hauteur+3,\r
+ x2-lborder-1,y1+lborder+2*(hauteur+2),cbande);\r
+ if (Horiz<>none)\r
+ then call Horiz.affiche;\r
+ fi;\r
+ if (Verti<>none)\r
+ then call Verti.affiche;\r
+ fi;\r
+ Bout.Courant:=Bout.head;\r
+ while(Bout.Courant<>none)\r
+ do\r
+ call Bout.Courant.data qua Bottons.affiche;\r
+ Bout.Courant:=Bout.Courant.next;\r
+ od;\r
+ call Keys.Insert(new elmt(T_ALTF4)); (* alt/f4 pour quitter *)\r
+ call Keys.Insert(new elmt(T_SHFTF4)); (* shift/f4 pour about *)\r
+ call Keys.Insert(new elmt(T_CTRLF4)); (* ctrl/f4 pour iconify *)\r
+ End AffSuite;\r
+\r
+ Unit virtual clear : procedure;\r
+ Var xf,yf : integer;\r
+ Begin\r
+ if Verti<>none then xf:=Verti.x1-1;\r
+ else xf:=x2-lborder-1;\r
+ fi;\r
+ if Horiz<>none then yf:=Horiz.y1-1;\r
+ else yf:=y2-lborder-1;\r
+ fi;\r
+ call Rectanglef(x1+lborder+1,y1+lborder+2*(hauteur+2)+1,xf,yf,Noir);\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ end;\r
+\r
+ Unit iconify : procedure;\r
+ var i : integer,\r
+ l,r,c : boolean,\r
+ x,y : integer,\r
+ nboot : integer,\r
+ rep : integer,\r
+ sclic : cliquer,\r
+ mmap : arrayof integer;\r
+\r
+ Begin\r
+ call move(x1,y1);\r
+ mmap:=getmap(x2,y2);\r
+ call move(1,1);\r
+ call putmap(this maine qua windows.map);\r
+ sclic:=clics;\r
+ clics:=none;\r
+ call rectangle(1,SIZEY-40,40,SIZEY,BleuClair);\r
+ call rectangle(2,SIZEY-39,39,SIZEY-1,BleuClair);\r
+ call move(5,SIZEY-20);\r
+ call outstring(icname);\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,nboot,l,r,c);\r
+ if l \r
+ then if(x>=1 and x<=40 and y<=SIZEY and y>=SIZEY-40)\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep=13) (* validation *)\r
+ then exit;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ call move(1,1);\r
+ call putmap(mmap);\r
+ kill(mmap);\r
+ End iconify;\r
+\r
+ Begin\r
+ WhereXd:=x1+lborder+5;\r
+ WhereYd:=y1+lborder+2*(Haut_Bot+2)+5+8;\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ End Maine;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Son d\82rivant des classes Windows et elmt *)\r
+(***************************************************************************)\r
+ \r
+ Unit Son : Windows coroutine;\r
+ Var aa : Elmt,\r
+ Horiz : AccelerateH, (* accelerateur horizontal *)\r
+ Verti : AccelerateV1; (* accelerateur vertical *)\r
+ \r
+ Unit virtual AffSuite : procedure;\r
+ Begin\r
+ if Horiz<>none\r
+ then call Horiz.affiche;\r
+ fi;\r
+ if Verti<>none\r
+ then call Verti.affiche;\r
+ fi;\r
+ Bout.Courant:=Bout.Head;\r
+ while(Bout.Courant<>none)\r
+ do\r
+ call Bout.Courant.data qua Bottons.affiche;\r
+ Bout.Courant:=bout.Courant.next;\r
+ od;\r
+ call AffSuite1;\r
+ End AffSuite;\r
+\r
+ Unit virtual AffSuite1 : procedure;\r
+ End AffSuite1;\r
+\r
+ Unit virtual clear : procedure;\r
+ Var xf,yf : integer;\r
+ Begin\r
+ if Verti<>none then xf:=Verti.x1-1;\r
+ else xf:=x2-lborder-1;\r
+ fi;\r
+ if Horiz<>none then yf:=Horiz.y1-1;\r
+ else yf:=y2-lborder-1;\r
+ fi;\r
+ call Rectanglef(x1+lborder+1,y1+lborder+(hauteur+1)+1,xf,yf,Noir);\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ end;\r
+ \r
+ Begin\r
+ return;\r
+ pref Elmt(0) block\r
+ begin\r
+ aa:=this Elmt;\r
+ WhereXd:=x1+lborder+5;\r
+ WhereYd:=y1+lborder+(Haut_Bot+1)+5+8;\r
+ WhereX:=WhereXd;\r
+ WhereY:=WhereYd;\r
+ detach;\r
+ end\r
+ End Son;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe dialogue d\82rivant de la classe Son *)\r
+(***************************************************************************)\r
+ \r
+ Unit Dialogue : Son coroutine;\r
+ Var ok, cancel : Menu,\r
+ nomfic : arrayof char,\r
+ lgnomfic : integer,\r
+ flagbool : boolean,\r
+ temp : file,\r
+ pwd : arrayof char,\r
+ rep,i,j : integer,\r
+ lgpwd : integer,\r
+ fichiers : liste_chaine,\r
+ nbfichiers : integer,\r
+ tampon : arrayof arrayof char,\r
+ creation : boolean; (* true si le fichier doit \88tre cr\82\82 *)\r
+\r
+ \r
+ Unit virtual AffSuite1 : procedure;\r
+ var j : integer;\r
+ Begin \r
+ call color(RougeClair);\r
+ flagbool:=moveto(5,1);\r
+ flagbool:=outgtext("Nom du fichier:",15);\r
+ flagbool:=moveto(175,1);\r
+ flagbool:=outgtext("Repertoires:",12);\r
+ flagbool:=moveto(175,18);\r
+ if lgpwd<13\r
+ then for j:=0 to lgpwd \r
+ do\r
+ flagbool:=outchar(pwd(j));\r
+ od;\r
+ else for j:=0 to 2\r
+ do\r
+ flagbool:=outchar(pwd(j));\r
+ od;\r
+ flagbool:=outchar('.');\r
+ flagbool:=outchar('.');\r
+ flagbool:=outchar('.');\r
+ for j:=lgpwd-8 to lgpwd\r
+ do\r
+ flagbool:=outchar(pwd(j));\r
+ od;\r
+ fi;\r
+ call rectanglef(x1+9,y1+51,x1+147,y1+66,BleuClair);\r
+ call clics.insert(new elm(512,x1+9,y1+52,x1+147,y1+66));\r
+ call rectangle(x1+18,y1+70,x1+147,y1+150,BleuClair);\r
+ call affiche_fic(0);\r
+ if nbfichiers>5\r
+ then verti:=new accelerateV1(520,-1,x1+148,y1+70,x1+164,y1+150,this windows);\r
+ call verti.affiche;\r
+ Bout.courant:=Bout.head;\r
+ while(Bout.Courant<>none)\r
+ do\r
+ call Bout.courant.data qua Bottons.affiche;\r
+ Bout.courant:=Bout.courant.next;\r
+ od;\r
+ fi;\r
+ End AffSuite1;\r
+\r
+ Unit affiche_fic : procedure (depuis : integer);\r
+ Var i,j : integer;\r
+ Begin\r
+ call rectanglef(x1+19,y1+71,x1+146,y1+149,Noir);\r
+ call color(BleuClair);\r
+ fichiers.depl:=fichiers.root;\r
+ for i:=1 to depuis\r
+ do\r
+ fichiers.depl:=fichiers.depl.ptr;\r
+ od;\r
+ (* on est positionn\82 sur le premier *)\r
+ for j:=0 to imin(4,nbfichiers-depuis-1)\r
+ do\r
+ flagbool:=moveto(15,39+j*15);\r
+ call clics.insert(new elm(j+1,x1+20,y1+72+j*15,x1+147,y1+72+(j+1)*15));\r
+ tampon(j):=copy(fichiers.depl.data);\r
+ for i:=0 to 11\r
+ do\r
+ if fichiers.depl.data(i)=chr(0) then exit fi;\r
+ flagbool:=outchar(fichiers.depl.data(i));\r
+ od;\r
+ fichiers.depl:=fichiers.depl.ptr;\r
+ od;\r
+ End affiche_fic;\r
+\r
+ Unit Lecture : function : boolean;\r
+ Var rep : integer, \r
+ depuis : integer;\r
+ \r
+ Unit Aff_nom : procedure;\r
+ Var i : integer;\r
+ Begin\r
+ call rectanglef(x1+9,y1+51,x1+147,y1+66,BleuClair);\r
+ nomfic:=copy(tampon(rep-1));\r
+ for i:=0 to upper(tampon(rep-1))\r
+ do\r
+ if tampon(rep-1,i)=chr(0) then exit fi;\r
+ flagbool:=moveto(3+i*8,18);\r
+ flagbool:=outchar(tampon(rep-1,i));\r
+ od;\r
+ End Aff_nom;\r
+\r
+ Unit Veux_creation : function : boolean;\r
+ Const Largeur=320,\r
+ Hauteur=100;\r
+ Var x,y,code : integer,\r
+ Posx,Posy : integer,\r
+ fille : son,\r
+ fille_yes : Menu,\r
+ fille_no : Menu,\r
+ skey : listkey,\r
+ sclic : cliquer,\r
+ flagbool : boolean;\r
+ \r
+ Begin\r
+ x:=(x2-x1-largeur)/2;\r
+ y:=(y2-y1-hauteur)/2;\r
+ Posx:=x1+x;\r
+ Posy:=y1+y;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fille:=new Son(20,Posx,Posy,Posx+Largeur,Posy+hauteur,2,\r
+ True,False,False);\r
+ attach(fille);\r
+ fille.hauteur:=Haut_Bot;\r
+ fille.cborder:=RougeClair;\r
+ fille.cbande:=Rouge;\r
+ call color(RougeClair);\r
+ fille_Yes:=new Menu(1,T_Y,Posx+60,Posy+61,Posx+100,Posy+61+Haut_bot);\r
+ fille_Yes.nom:="Yes";\r
+ fille_Yes.etat:=True;\r
+ call fille.Bout.Insert(fille_Yes);\r
+ fille_No:=new Menu(2,T_N,Posx+190,Posy+61,Posx+220,Posy+61+Haut_bot);\r
+ fille_No.nom:="No";\r
+ fille_No.etat:=True;\r
+ call fille.Bout.Insert(fille_No);\r
+ call keys.insert(new elmt(T_ESC));\r
+ call hidecursor;\r
+ call fille.affiche; \r
+ flagbool:=fille.outgtext(" File not found : Do you want to creat",30);\r
+ call showcursor;\r
+ do\r
+ code:=fille.gestionnaire;\r
+ case code\r
+ when T_ESC : result:=false; exit;\r
+ when T_N : result:=false; exit;\r
+ when T_Y : result:=true; exit;\r
+ when 1 : result:=true; exit; (* menu yes *)\r
+ when 2 : result:=false; exit; (* menu no *)\r
+ when 11 : result:=false; exit; (*racc exit *)\r
+ esac; \r
+ od;\r
+ call hidecursor;\r
+ call fille.restore;\r
+ attach(fille);\r
+ kill(fille);\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ call showcursor;\r
+ End Veux_creation;\r
+\r
+ Begin\r
+ do\r
+ rep:=gestionnaire;\r
+ if rep=512 or rep=T_ESPACE (* zone clics pr entr\82e clavier nomfichier *)\r
+ then lgnomfic:=80;\r
+ nomfic:=gscanf_char(x1+10,y1+52,17,lgnomfic);\r
+ if nomfic(0)=chr(0)\r
+ then call hidecursor;\r
+ call rectanglef(x1+9,y1+51,x1+147,y1+66,BleuClair);\r
+ call showcursor;\r
+ call ok.bot_disable;\r
+ else if not fichiers.appartient(nomfic)\r
+ then if Veux_creation\r
+ then result:=true;\r
+ creation:=true;\r
+ exit;\r
+ else call hidecursor;\r
+ call rectanglef(x1+9,y1+51,x1+147,y1+66,BleuClair);\r
+ call showcursor;\r
+ nomfic(0):=chr(0);\r
+ call ok.bot_disable;\r
+ fi;\r
+ else call ok.bot_enable;\r
+ fi;\r
+ fi;\r
+ else if rep>=1 and rep<=5\r
+ then call aff_nom;\r
+ call ok.bot_enable;\r
+ else if rep=510 or rep=Tou_Ent\r
+ then result:=true; exit;\r
+ else if rep=511 or rep=T_ESC\r
+ then result:=false; exit;\r
+ else if rep=521 or rep=T_FLHAU (* il y a plus de 5 fichiers : up *)\r
+ then depuis:=depuis-1;\r
+ if depuis<0 then depuis:=0; fi;\r
+ call affiche_fic(depuis);\r
+ else if rep=523 or rep=T_FLBAS(* down *)\r
+ then depuis:=depuis+1; \r
+ if depuis>(nbfichiers-4)\r
+ then depuis:=nbfichiers-4;\r
+ fi;\r
+ call affiche_fic(depuis);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ End Lecture;\r
+\r
+ Unit liste_chaine : class;\r
+ Var root : node,\r
+ depl : node, (* pour les parcours *)\r
+ cour : node;\r
+\r
+ Unit node : class;\r
+ Var data : arrayof char,\r
+ ptr : node;\r
+ End node;\r
+\r
+ Unit appartient : function (a : arrayof char) : boolean;\r
+ Var fl :boolean; \r
+ \r
+ Unit egalite : function (a,b : arrayof char) :boolean;\r
+ Var i,j : integer;\r
+\r
+ Unit toupper : function (a : char) : char;\r
+ Begin\r
+ if (ord(a)>=97 and ord(a)<=122)\r
+ then result:=chr(ord(a)-32);\r
+ else result:=a;\r
+ fi;\r
+ End toupper;\r
+\r
+ Begin\r
+ result:=true;\r
+ i:=0;\r
+ while i<=upper(a)\r
+ do\r
+ if toupper(a(i))<>toupper(b(i))\r
+ then result:=false;\r
+ exit;\r
+ fi;\r
+ i:=i+1;\r
+ if a(i)=chr(0) then exit; fi;\r
+ od\r
+ End egalite;\r
+\r
+ Begin\r
+ depl:=root;\r
+ fl:=false;\r
+ call move(10,400);\r
+ while (not(fl) and depl<>none)\r
+ do\r
+ fl:=egalite(a,depl.data);\r
+ depl:=depl.ptr;\r
+ od;\r
+ result:=fl; \r
+ End appartient;\r
+\r
+ Unit insert : procedure (a : arrayof char);\r
+ Var nouveau : node;\r
+ Begin\r
+ nouveau:=new node;\r
+ nouveau.data:=copy(a);\r
+ if root=none\r
+ then root:=nouveau;\r
+ cour:=root;\r
+ else cour.ptr:=nouveau;\r
+ cour:=nouveau;\r
+ fi;\r
+ End insert;\r
+ \r
+ End liste_chaine;\r
+\r
+ Begin\r
+ return;\r
+ (* on va maintenant lire le pwd et le mettre dans la variable pwd *)\r
+ rep:=exec(unpack("cd > simula.tmp"));\r
+ open(temp,text,unpack("simula.tmp"));\r
+ call reset(temp);\r
+ i:=0;\r
+ array pwd dim (0:256);\r
+ lgnomfic:=256;\r
+ array nomfic dim (0:lgnomfic);\r
+ while (not(eof(temp)) and i<=256)\r
+ do\r
+ read(temp,pwd(i));\r
+ i:=i+1;\r
+ od;\r
+ lgpwd:=i-2; (* -1 pour le i:=i+1 en trop + -1 pour le RC *)\r
+ call unlink(temp);\r
+ rep:=exec(unpack("dir *.dat /a /b > simula.tmp")); \r
+ open(temp,text,unpack("simula.tmp"));\r
+ call reset(temp);\r
+ fichiers:=new liste_chaine;\r
+ while not(eof(temp))\r
+ do\r
+ i:=0;\r
+ do\r
+ read(temp,nomfic(i));\r
+ if nomfic(i)=' ' then nomfic(i):=chr(0); fi;\r
+ if nomfic(i)=chr(10) or eof(temp)\r
+ then nomfic(i):=chr(0);\r
+ exit\r
+ else i:=i+1;\r
+ fi;\r
+ od;\r
+ call fichiers.insert(nomfic);\r
+ nbfichiers:=nbfichiers+1;\r
+ od;\r
+ call unlink(temp);\r
+ array tampon dim (0:5);\r
+ for i:=0 to 5\r
+ do\r
+ array tampon(i) dim (0:15);\r
+ od;\r
+ ok:=new menu(510,Tou_Ent,x2-56,y1+30,x2-16,y1+30+Haut_Bot);\r
+ ok.nom:=" Ok ";\r
+ ok.etat:=False;\r
+ call Bout.insert(ok);\r
+ cancel:=new menu(511,T_ESC,x2-66,y1+60,x2-8,y1+60+Haut_Bot);\r
+ cancel.nom:="Cancel";\r
+ cancel.etat:=True;\r
+ call Bout.insert(cancel);\r
+ call Keys.insert(new elmt(T_ESPACE));\r
+ detach;\r
+ End Dialogue;\r
+\r
+\r
+(***************************************************************************)\r
+(* definition de Accelerate d\82rivant des classes Windows et Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Accelerate : Bottons class(mother : Windows);\r
+ Var Bs : arrayof Racc,\r
+ PosX : integer,\r
+ PosY : integer,\r
+ LX,LY: integer,\r
+ C : integer; (* valeur du pas d'affichage *)\r
+ \r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ End AfficheSuite;\r
+ \r
+ Unit virtual bot_enable : procedure;\r
+ Begin\r
+ call mother.Bout.Insert(Bs(1));\r
+ call mother.Bout.Insert(Bs(3));\r
+ call bot_enable_suite;\r
+ etat:=True;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_enable_suite : procedure;\r
+ End bot_enable_suite;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ Begin\r
+ call mother.Bout.Delete(Bs(1));\r
+ call mother.Bout.Delete(Bs(3));\r
+ call bot_disable_suite;\r
+ etat:=False;\r
+ End bot_disable;\r
+\r
+ Unit virtual bot_disable_suite : procedure;\r
+ End bot_disable_suite;\r
+\r
+ Unit virtual Deplacer : procedure( i :integer);\r
+ End Deplacer;\r
+ \r
+ Unit virtual Reset_Bot : procedure;\r
+ End Reset_Bot;\r
+\r
+ Begin \r
+ C:=5; (* valeur par defaut *)\r
+ inner;\r
+ call bot_enable;\r
+ End Accelerate;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateH d\82rivant de Accelerate *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateH : Accelerate class;\r
+ Var x : integer, \r
+ MaxX : integer,\r
+ MinX : integer;\r
+ \r
+ Unit virtual bot_enable_suite : procedure;\r
+ Begin\r
+ call mother.bout.insert(Bs(2));\r
+ End bot_enable_suite;\r
+ \r
+ Unit virtual bot_disable_suite : procedure;\r
+ Begin\r
+ call mother.bout.delete(Bs(2));\r
+ End bot_disable_suite;\r
+ \r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ Begin\r
+ call Rectanglef(x1+18,y1+3,x2-18,y2-3,Noir);\r
+ MaxX:=x2-18-LX;\r
+ MinX:=x1+18;\r
+ End AfficheSuite;\r
+\r
+ Unit DeplacerLeft : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=PosX-C;\r
+ if PosX<MinX\r
+ then PosX:=MinX;\r
+ Bs(1).etat:=False;\r
+ call Bs(1).bot_disable;\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ call Bs(3).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerLeft;\r
+ \r
+ Unit virtual Deplacer : procedure (x : integer);\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=x;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Deplacer;\r
+\r
+ Unit DeplacerRight : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=PosX+C;\r
+ if PosX>MaxX\r
+ then PosX:=MaxX;\r
+ Bs(3).etat:=False;\r
+ call Bs(3).bot_disable;\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ call Bs(1).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerRight;\r
+\r
+ Unit virtual Reset_Bot : procedure;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ x:=(x2-x1)/2;\r
+ PosX:=x-5;\r
+ PosY:=y1+3;\r
+ LX:=11;\r
+ LY:=y2-y1-6;\r
+ Bs(2).x1:=PosX;\r
+ Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX;\r
+ Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Reset_Bot;\r
+\r
+ Begin \r
+ array Bs dim (1:3);\r
+ Bs(1):=new Racc(id+1,T_FLDTE,x1+2,y1+2,x1+15,y1+15,spr_right);\r
+ Bs(1).etat:=True;\r
+ x:=(x2-x1)/2;\r
+ PosX:=x-5;\r
+ PosY:=y1+3;\r
+ LX:=11;\r
+ LY:=y2-y1-6;\r
+ Bs(2):=new Racc(id+2,-1,PosX,PosY,PosX+LX,PosY+LY,spr_point);\r
+ Bs(2).etat:=True;\r
+ Bs(3):=new Racc(id+3,T_FLGCH,x2-15,y2-16,x2-2,y2-3,spr_left);\r
+ Bs(3).etat:=True;\r
+ End AccelerateH;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateV1 d\82rivant de Accelerate *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateV1 : Accelerate class;\r
+ Var y : integer,\r
+ MaxY : integer,\r
+ MinY : integer; \r
+\r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ Begin\r
+ call Rectanglef(x1+3,y1+18,x2-3,y2-18,Noir);\r
+ MaxY:=y2-18-LY;\r
+ MinY:=y1+18;\r
+ End AfficheSuite;\r
+ \r
+ Unit virtual bot_enable_suite : procedure;\r
+ End bot_enable_suite;\r
+ \r
+ Unit virtual bot_disable_suite : procedure;\r
+ End bot_disable_suite;\r
+\r
+ Unit virtual DeplacerUp : procedure;\r
+ var e : elm;\r
+ Begin\r
+ PosY:=PosY-C;\r
+ if PosY<MinY\r
+ then PosY:=MinY;\r
+ Bs(1).etat:=False;\r
+ call Bs(1).bot_disable;\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ call Bs(3).bot_enable;\r
+ fi; \r
+ End DeplacerUp;\r
+\r
+ Unit virtual Deplacer : procedure (y : integer);\r
+ End Deplacer;\r
+ \r
+ Unit virtual DeplacerDown : procedure;\r
+ var e : elm;\r
+ Begin\r
+ PosY:=PosY+C;\r
+ if PosY>MaxY\r
+ then PosY:=MaxY;\r
+ Bs(3).etat:=False;\r
+ call Bs(3).bot_disable;\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ call Bs(1).bot_enable;\r
+ fi; \r
+ End DeplacerDown;\r
+\r
+ Unit virtual Reset_Bot : procedure;\r
+ End Reset_Bot;\r
+\r
+ Begin\r
+ array Bs dim (1:3);\r
+ Bs(1):=new Racc(id+1,T_FLHAU,x1+2,y1+2,x1+15,y1+15,spr_upper);\r
+ Bs(1).etat:=True;\r
+ y:=(y2-y1)/2;\r
+ PosX:=x1+3;\r
+ PosY:=y-5;\r
+ LX:=x2-x1-6;\r
+ LY:=11;\r
+ inner;\r
+ Bs(3):=new Racc(id+3,T_FLBAS,x2-15,y2-16,x2-2,y2-3,spr_lower);\r
+ Bs(3).etat:=True;\r
+ End AccelerateV1;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateV2 d\82rivant de AccelerateV1 *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateV2 : AccelerateV1 class;\r
+\r
+ Unit virtual bot_enable_suite : procedure;\r
+ Begin\r
+ call mother.bout.insert(Bs(2));\r
+ End bot_enable_suite;\r
+ \r
+ Unit virtual bot_disable_suite : procedure;\r
+ Begin\r
+ call mother.bout.delete(Bs(2));\r
+ End bot_disable_suite;\r
+ \r
+ Unit virtual DeplacerUp : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=PosY-C;\r
+ if PosY<MinY\r
+ then PosY:=MinY;\r
+ Bs(1).etat:=False;\r
+ call Bs(1).bot_disable;\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ call Bs(3).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerUp;\r
+\r
+ Unit virtual Deplacer : procedure (y : integer);\r
+ Begin\r
+ if y>=MinY and y<=MaxY\r
+ then call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=y;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ fi;\r
+ End Deplacer;\r
+ \r
+ Unit virtual DeplacerDown : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=PosY+C;\r
+ if PosY>MaxY\r
+ then PosY:=MaxY;\r
+ Bs(3).etat:=False;\r
+ call Bs(3).bot_disable;\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ call Bs(1).bot_enable;\r
+ fi; \r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerDown;\r
+\r
+ Unit virtual Reset_Bot : procedure;\r
+ Begin\r
+ call Bs(2).bot_disable;\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ y:=(y2-y1)/2;\r
+ PosX:=x1+3;\r
+ PosY:=y-5;\r
+ LX:=x2-x1-6;\r
+ LY:=11;\r
+ Bs(2).x1:=PosX;\r
+ Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX;\r
+ Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End Reset_Bot;\r
+\r
+ Begin\r
+ Bs(2):=new Racc(id+2,-1,PosX,PosY,PosX+LX,PosY+LY,spr_point);\r
+ Bs(2).etat:=True;\r
+ End AccelerateV2;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Ensemble (c'est une liste) *)\r
+(***************************************************************************)\r
+\r
+ Unit Ensemble : class;\r
+ Var Head : Node,\r
+ Courant : Node,\r
+ Last : Node;\r
+\r
+ Unit Node : class(data : elmt);\r
+ Var next : Node;\r
+ End Node;\r
+ \r
+ Unit virtual egalite : function (x,y : elmt) :boolean;\r
+ End egalite;\r
+\r
+ Unit Empty : function : boolean; \r
+ Begin\r
+ if Head=none\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End;\r
+\r
+ Unit Member : function (n : elmt) : boolean;\r
+ Var bl : boolean,\r
+ saveCou : Node;\r
+ Begin\r
+ Courant:=Head;\r
+ saveCou:=Courant;\r
+ bl:=False;\r
+ While (Courant<>none)\r
+ do\r
+ if not egalite(Courant.data,n)\r
+ then saveCou:=Courant; Courant:=Courant.next;\r
+ else bl:=True; exit;\r
+ fi;\r
+ od;\r
+ Courant:=SaveCou;\r
+ result:=bl;\r
+ End Member;\r
+\r
+ Unit Insert : procedure (n : elmt);\r
+ Var bl : boolean;\r
+ Begin\r
+ bl:=Member(n);\r
+ if not bl\r
+ then if Empty\r
+ then Head:=new Node(n); Last:=Head;\r
+ else Last.next:=new Node(n);\r
+ Last:=Last.next;\r
+ fi;\r
+ fi;\r
+ End Insert;\r
+\r
+ Unit Delete : procedure (n : elmt);\r
+ Var bl : boolean,\r
+ flag : Node;\r
+ Begin \r
+ bl:=Member(n);\r
+ if bl\r
+ then flag:=Courant.next; \r
+ if flag=Last\r
+ then Last:=Courant; courant.next:=none; kill(flag);\r
+ else if Courant.next<>none \r
+ then Courant.next:=Courant.next.next; kill(flag);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ End Delete;\r
+\r
+ End Ensemble;\r
+ \r
+(***************************************************************************)\r
+(* definition de la classe cliquer derivant de la classe ensemble *) \r
+(***************************************************************************)\r
+ \r
+ Unit cliquer : Ensemble class; \r
+ \r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id)=(y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+ \r
+ Unit Appartient : function(x,y : integer) : integer;\r
+ var bl : boolean;\r
+ Begin\r
+ bl:=False;\r
+ Courant:=Head;\r
+ while (Courant<>none)\r
+ do\r
+ if(x<(Courant.data qua elm.x2) and x>(Courant.data qua elm.x1) and \r
+ y<(Courant.data qua elm.y2) and y>(Courant.data qua elm.y1))\r
+ then bl:=True; exit;\r
+ else Courant:=Courant.next;\r
+ fi;\r
+ od;\r
+ if bl\r
+ then result:=Courant.data qua elm.id;\r
+ else result:=-1;\r
+ fi;\r
+ End Appartient;\r
+\r
+ End cliquer;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Listbot d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit Listbot : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id) = (y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+\r
+ End Listbot;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe ListKey d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit ListKey : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id) = (y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+\r
+ Unit Appartient : function(x : integer) : boolean;\r
+ var bl : boolean;\r
+ Begin\r
+ bl:=False;\r
+ Courant:=Head;\r
+ while (Courant<>none)\r
+ do\r
+ if(Courant.data.id = x)\r
+ then bl:=True; exit;\r
+ else Courant:=Courant.next;\r
+ fi;\r
+ od;\r
+ result:=bl;\r
+ End Appartient;\r
+\r
+ End ListKey;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe ListW d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit ListW : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ (* if (x qua Son.numero) = (y qua Son.numero)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi; *)\r
+ End egalite;\r
+\r
+ End ListW;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage des sprites des boutons *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit spr_upper : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call Line(x1+x-i/2,y1+y/2+i,x1+x+i/2,y1+y/2+i,couleur);\r
+ od\r
+ End spr_upper;\r
+\r
+(***************************************************************************)\r
+ Unit spr_lower : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call Line(x1+x-i/2,y2-y/2-i,x1+x+i/2,y2-y/2-i,couleur);\r
+ od\r
+ End spr_lower;\r
+\r
+(***************************************************************************)\r
+ Unit spr_left : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call Line(x2-x/2-i,y1+y-i/2,x2-x/2-i,y1+y+i/2,couleur);\r
+ od\r
+ End spr_left;\r
+\r
+(***************************************************************************)\r
+ Unit spr_right : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call Line(x1+x/2+i,y1+y-i/2,x1+x/2+i,y1+y+i/2,couleur);\r
+ od\r
+ End spr_right;\r
+\r
+(***************************************************************************)\r
+ Unit spr_close : procedure(x1,y1,x2,y2,couleur : integer);\r
+ var y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ call Rectanglef(x1+3,y1+y-1,x2-3,y1+y+1,couleur);\r
+ End spr_close;\r
+\r
+(***************************************************************************)\r
+ Unit spr_point : procedure(x1,y1,x2,y2,couleur : integer);;\r
+ var x,y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ x:=(x2-x1)/2;\r
+ call Rectanglef(x1+x-1,y1+y-1,x1+x+1,y1+y+1,couleur);\r
+ End spr_point;\r
+\r
+\r
+(***************************************************************************)\r
+(***************************************************************************)\r
+(* PROGRAMME NUMERO 1 : SIMULATEUR *)\r
+(***************************************************************************)\r
+(***************************************************************************)\r
+Unit simulateur : Logiciel coroutine;\r
+\r
+var prg : prog, (* programme principal, g\82r\82 par des simprocess *)\r
+ fin : boolean,\r
+ x1,y1 : integer,\r
+ x2,y2 : integer,\r
+ ZOOM : integer, (* coeficient de zoom *)\r
+ C : integer, (* largeur des voies *)\r
+ M : arrayof Menu,\r
+ boolAf : boolean; (* vrai si il faut afficher la ville *)\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Load : procedure;\r
+ Const Largeur1=400,\r
+ Hauteur1=180,\r
+ Largeur2=340,\r
+ Hauteur2=100;\r
+ Var fenet1 : Dialogue,\r
+ fenet2 : Son,\r
+ x,y,i : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ sclic : cliquer,\r
+ skey : listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet1:=new dialogue(10,x-Largeur1/2,y-Hauteur1/2,x+Largeur1/2,y+Hauteur1/2,\r
+ 2,False,False,False);\r
+ attach(fenet1);\r
+ attach(fenet1);\r
+ fenet1.hauteur:=Haut_Bot;\r
+ fenet1.cborder:=RougeClair;\r
+ fenet1.cbande:=Rouge;\r
+ call fenet1.affiche;\r
+ call showcursor;\r
+ flagbool:=fenet1.lecture;\r
+ if flagbool and not fenet1.creation\r
+ then call hidecursor;\r
+ kill(keys);\r
+ keys:=new listkey;\r
+ kill(clics);\r
+ clics:=new cliquer; \r
+ fenet2:=new Son(20,x-Largeur2/2,y-Hauteur2/2,x+Largeur2/2,y+hauteur2/2,2,\r
+ False,False,False);\r
+ attach(fenet2);\r
+ fenet2.hauteur:=Haut_Bot;\r
+ fenet2.cborder:=RougeClair;\r
+ fenet2.cbande:=Rouge;\r
+ call fenet2.affiche;\r
+ flagbool:=fenet2.moveto(10,10);\r
+ call color(BleuClair);\r
+ flagbool:=fenet2.outgtext("Chargement de",14); \r
+ for i:=0 to 12\r
+ do\r
+ if fenet1.nomfic(i)=chr(0) then exit fi;\r
+ flagbool:=fenet2.outchar(fenet1.nomfic(i));\r
+ od;\r
+ flagbool:=fenet2.outgtext(" en cours",8);\r
+ flagbool:=fenet2.moveto(10,25);\r
+ call color(VertClair);\r
+ flagbool:=fenet2.outgtext(".",1);\r
+ if RaciSomm<>none then RaciSomm:=none; fi;\r
+ if RaciArcs<>none then RaciArcs:=none; fi;\r
+ call W.verti.reset_bot;\r
+ call W.horiz.reset_bot;\r
+ call Lit_Ville(fenet2,fenet1.nomfic);\r
+ flagbool:=fenet2.moveto(10,40);\r
+ call color(BleuClair);\r
+ flagbool:=fenet2.outgtext("Chargement termin\82 : 'Enter'",28);\r
+ fenet2.B(0).etat:=True;\r
+ call fenet2.bout.insert(fenet2.B(0));\r
+ call fenet2.B(0).affiche;\r
+ call keys.insert(new elmt(Tou_Ent));\r
+ call showcursor;\r
+ do\r
+ code:=fenet2.gestionnaire;\r
+ if (code=Tou_Ent or code=21) then exit; fi;\r
+ od;\r
+ call hidecursor;\r
+ call fenet2.restore;\r
+ else if flagbool and fenet1.creation\r
+ then EDIT.nomfic:=fenet1.nomfic;\r
+ attach(EDIT);\r
+ if edit_bool (* on a cr\82\82 un fichier coherant *)\r
+ then\r
+ call Etat_Menu(True,True,False,False,False,True);\r
+ COEF_X:=Larg_Aff/Larg_Vil;\r
+ COEF_Y:=Haut_Aff/Haut_Vil;\r
+ boolaf:=True;\r
+ Zoom:=1;\r
+ COORD_X:=0;\r
+ COORD_Y:=0;\r
+ call ville_aff(zoom);\r
+ fi;\r
+ call hidecursor;\r
+ else call hidecursor;\r
+ fi;\r
+ fi;\r
+ call fenet1.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ if flagbool and not fenet1.creation\r
+ then attach(fenet2);\r
+ kill(fenet2);\r
+ call Etat_Menu(True,True,False,False,False,True);\r
+ COEF_X:=Larg_Aff/Larg_Vil;\r
+ COEF_Y:=Haut_Aff/Haut_Vil;\r
+ boolaf:=True;\r
+ Zoom:=1;\r
+ COORD_X:=0;\r
+ COORD_Y:=0;\r
+ call ville_aff(zoom);\r
+ fi;\r
+ attach(fenet1);\r
+ kill(fenet1);\r
+ call showcursor;\r
+ End Bot_Load;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Run : procedure;\r
+ Const Largeur=330,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ sclic : cliquer,\r
+ skey : listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(10,10);\r
+ flagbool:=fenet.outgtext("Entrez le nombre de voitures (1-50)",32);\r
+ flagbool:=fenet.moveto(145,30);\r
+ NbMaxCar:=gscanf_num(1,50);\r
+ array Activ dim (0:NbMaxCar); (* on genere le tableau des car actives *)\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ call Etat_Menu(False,False,True,False,False,False);\r
+ SimStop:=False;\r
+ End Bot_Run;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Stop : procedure;\r
+ Const Largeur=280,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ skey : listkey,\r
+ sclic : cliquer;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ kill(clics);\r
+ clics:=new cliquer;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(60,10);\r
+ flagbool:=fenet.outgtext("Simulation stopp\82e",18);\r
+ flagbool:=fenet.moveto(40,30);\r
+ flagbool:=fenet.outgtext("Appuyez sur une touche",22);\r
+ call showcursor;\r
+ do\r
+ code:=inkey;\r
+ if code<>0 then exit; fi;\r
+ od;\r
+ call hidecursor;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ call Etat_Menu(True,False,False,True,True,True);\r
+ SimStop:=True;\r
+ End Bot_Stop;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_continue : procedure;\r
+ Const Largeur=290,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ sclic : cliquer,\r
+ skey : listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(20,10);\r
+ flagbool:=fenet.outgtext("La simulation va reprendre...",29);\r
+ flagbool:=fenet.moveto(50,30);\r
+ flagbool:=fenet.outgtext("Appuyez sur une touche",22);\r
+ call showcursor;\r
+ code:=0;\r
+ do\r
+ code:=inkey;\r
+ if code<>0 then exit fi;\r
+ od;\r
+ call hidecursor;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ call Etat_Menu(False,False,True,False,False,False);\r
+ SimStop:=False;\r
+ End Bot_Continue;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Quit : function : boolean;\r
+ Const Largeur=300,\r
+ Hauteur=90;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ fin : boolean,\r
+ code : integer,\r
+ Yes,No : Menu,\r
+ sclic : cliquer,\r
+ skey : listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,Posx,Posy,Posx+Largeur,Posy+hauteur,2,True,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.nom:="Q U I T";\r
+ fenet.cnom:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ Yes:=new Menu(1,T_Y,Posx+60,Posy+61,Posx+100,Posy+61+Haut_bot);\r
+ Yes.nom:="Yes";\r
+ Yes.etat:=True;\r
+ call fenet.Bout.Insert(Yes);\r
+ No:=new Menu(2,T_N,Posx+190,Posy+61,Posx+220,Posy+61+Haut_bot);\r
+ No.nom:="No";\r
+ No.etat:=True;\r
+ call fenet.Bout.Insert(No);\r
+ call fenet.affiche;\r
+ call move(Posx+10,Posy+35);\r
+ call color(BleuClair);\r
+ call outstring("Do you want to quit the simulation");\r
+ call Keys.Insert(new elmt(T_ESC));\r
+ call showcursor;\r
+ do\r
+ code:=fenet.gestionnaire;\r
+ case code\r
+ when T_ESC : fin:=False; exit; (* touche racc exit *)\r
+ when T_Y : fin:=True; exit; (* touche Y *)\r
+ when T_N : fin:=False; exit; (* touche N *)\r
+ when 1 : fin:=True; exit; (* bouton yes *)\r
+ when 2 : fin:=False; exit; (* bouton no *) \r
+ when 11 : fin:=False; exit; (* racc exit *)\r
+ esac;\r
+ od; \r
+ call hidecursor;\r
+ if not fin\r
+ then result:=False;\r
+ else result:=True;\r
+ fi;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ call showcursor;\r
+ End Bot_Quit;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Help : procedure;\r
+ Const Largeur=410,\r
+ Hauteur=350;\r
+ Var fen : Son,\r
+ x,y,i,j : integer,\r
+ code : integer,\r
+ COORD_Y : integer,\r
+ fp : file,\r
+ tmp : char,\r
+ boolaff : boolean,\r
+ help : arrayof arrayof char,\r
+ nb_lign_hlp : integer,\r
+ skey : ListKey,\r
+ sclic : cliquer;\r
+\r
+ \r
+ Unit affiche_hlp : procedure;\r
+ Begin\r
+ call fen.clear;\r
+ call color(BleuClair);\r
+ for i:=COORD_Y to imin(COORD_Y+18,nb_lign_hlp)\r
+ do\r
+ for j:=1 to 37\r
+ do\r
+ if (ord(help(i,j))>=28 and ord(help(i,j))<=255)\r
+ then boolaff:=fen.outchar(help(i,j));\r
+ fi;\r
+ od; \r
+ od;\r
+ End affiche_hlp;\r
+ \r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fen:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,2,\r
+ True,False,False);\r
+ attach(fen);\r
+ fen.cnom:=RougeClair;\r
+ fen.nom:="H E L P";\r
+ fen.hauteur:=Haut_Bot;\r
+ fen.largeur:=Larg_Bot;\r
+ fen.cborder:=RougeClair;\r
+ fen.cbande:=Rouge;\r
+ x:=fen.x2-fen.lborder-1-fen.hauteur;\r
+ y:=fen.y1+fen.hauteur+fen.lborder+1;\r
+ fen.Verti:=new AccelerateV2(20,-1,x,y,x+fen.largeur,fen.y2-fen.lborder-1,fen);\r
+ call fen.affiche;\r
+ call fen.Verti.deplacer(fen.Verti.MinY);\r
+ call Keys.Insert(new elmt(T_ESC)); (* pour sortir de la fenetre *)\r
+ call Keys.Insert(new elmt(T_PGUP)); (* page up *)\r
+ call Keys.Insert(new elmt(T_PGDOWN)); (* page dow *)\r
+ COORD_Y:=1;\r
+ open(fp,text,unpack("simula.hlp"));\r
+ call reset(fp);\r
+ readln(fp,nb_lign_hlp);\r
+ array help dim (1:nb_lign_hlp);\r
+ for i:=1 to nb_lign_hlp\r
+ do \r
+ array help(i) dim (1:38);\r
+ od;\r
+ call color(BleuClair);\r
+ i:=1;\r
+ j:=1;\r
+ while not eof(fp)\r
+ do\r
+ read(fp,help(i,j));\r
+ j:=j+1;\r
+ if j=39 then j:=1;\r
+ i:=i+1;\r
+ fi;\r
+ od;\r
+ call affiche_hlp;\r
+ call setposition(fen.x1,fen.y1);\r
+ call showcursor;\r
+ do\r
+ code:=fen.gestionnaire;\r
+ call hidecursor;\r
+ if (code=T_ESC) or (code=11) then exit;\r
+ else\r
+ if (code=21) or (code=T_FLHAU) then COORD_Y:=COORD_Y-5;\r
+ if COORD_Y<=0 then COORD_Y:=1; fi;\r
+ call fen.Verti.DeplacerUp;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=22) then COORD_Y:=1;\r
+ call fen.Verti.Reset_Bot;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=23) or (code=T_FLBAS) then COORD_Y:=COORD_Y+5;\r
+ if COORD_Y>(nb_lign_hlp-5)\r
+ then COORD_Y:=nb_lign_hlp-5;\r
+ fi;\r
+ call fen.Verti.DeplacerDown;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=T_PGUP) then COORD_Y:=COORD_Y-19;\r
+ if COORD_Y<=0\r
+ then COORD_Y:=1;\r
+ call fen.Verti.Deplacer(fen.Verti.MinY);\r
+ else call fen.Verti.DeplacerDown;\r
+ fi;\r
+ call affiche_hlp;\r
+ else\r
+ if (code=T_PGDOWN) then COORD_Y:=COORD_Y+19;\r
+ if COORD_Y>(nb_lign_hlp-5)\r
+ then COORD_Y:=nb_lign_hlp-5;\r
+ call fen.Verti.Deplacer(fen.Verti.MaxY);\r
+ else call fen.Verti.DeplacerDown;\r
+ fi;\r
+ call affiche_hlp;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call showcursor;\r
+ od;\r
+ call fen.restore; (* restore le getmap et free de la ram *)\r
+ kill(keys);\r
+ Keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fen); (* correspond a la 1ere etape kill *)\r
+ kill(fen);\r
+ End Bot_Help;\r
+\r
+(***************************************************************************)\r
+ Unit About : procedure;\r
+ Const Largeur=400,\r
+ Hauteur=195;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ sclic : cliquer,\r
+ skey : Listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,2,\r
+ True,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(18,10);\r
+ flagbool:=fenet.outgtext("Logiciel r\82alis\82 dans le cadre d'un projet",43);\r
+ flagbool:=fenet.moveto(18,40);\r
+ flagbool:=fenet.outgtext("de Licence Informatique - Univertit\82 de PAU",43);\r
+ flagbool:=fenet.moveto(10,70);\r
+ flagbool:=fenet.outgtext("BARETS Olivier/PATAUD Fr\82d\82ric/PEYRAT Fran\87ois",43);\r
+ flagbool:=fenet.moveto(10,100);\r
+ flagbool:=fenet.outgtext("LI1 1993/1994",43);\r
+ flagbool:=fenet.moveto(10,130);\r
+ flagbool:=fenet.outgtext("M\82moire disponible : ",25);\r
+ call writint(memavail*4); (* sizeof (word) = 32 *)\r
+ flagbool:=fenet.moveto(230,130);\r
+ flagbool:=fenet.outgtext("Ko",2);\r
+ call Keys.Insert(new elmt(Tou_Ent));\r
+ call Keys.Insert(new elmt(T_ESC));\r
+ call showcursor;\r
+ do\r
+ code:=fenet.gestionnaire;\r
+ if (code=11 or code=Tou_Ent or code=T_ESC) then exit; fi;\r
+ od;\r
+ call hidecursor;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ Keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ End About;\r
+\r
+\r
+\r
+(***************************************************************************)\r
+ Unit Etat_Menu : procedure (ml,mr,msto,mc,msta,mq : boolean);\r
+ Begin\r
+ if (ml and not M(1).etat) (* load devient enable *)\r
+ then M(1).etat:=True;\r
+ M(1).Touche:=T_F1;\r
+ call M(1).bot_enable;\r
+ fi;\r
+ if (not ml and M(1).etat) (* load devient disable *)\r
+ then M(1).etat:=False;\r
+ M(1).Touche:=-1;\r
+ call M(1).bot_disable;\r
+ fi;\r
+ if (mr and not M(2).etat) (* run devient enable *)\r
+ then M(2).etat:=True;\r
+ M(2).Touche:=T_F2;\r
+ call M(2).bot_enable;\r
+ fi;\r
+ if (not mr and M(2).etat) (* run devient disable *)\r
+ then M(2).etat:=False;\r
+ M(2).Touche:=-1;\r
+ call M(2).bot_disable;\r
+ fi;\r
+ if (msto and not M(3).etat) (* stop devient enable *)\r
+ then M(3).etat:=True;\r
+ M(3).Touche:=T_F3;\r
+ call M(3).bot_enable;\r
+ fi;\r
+ if (not msto and M(3).etat) (* stop devient disable *)\r
+ then M(3).etat:=False;\r
+ M(3).Touche:=-1;\r
+ call M(3).bot_disable;\r
+ fi;\r
+ if (mc and not M(4).etat) (* continue devient enable *)\r
+ then M(4).etat:=True;\r
+ M(4).Touche:=T_F4;\r
+ call M(4).bot_enable;\r
+ fi;\r
+ if (not mc and M(4).etat) (* continue devient disable *)\r
+ then M(4).etat:=False;\r
+ M(4).Touche:=-1;\r
+ call M(4).bot_disable;\r
+ fi;\r
+ if (msta and not M(5).etat) (* stats devient enable *)\r
+ then M(5).etat:=True;\r
+ M(5).Touche:=T_F5;\r
+ call M(5).bot_enable;\r
+ fi;\r
+ if (not msta and M(5).etat) (* stats devient disable *)\r
+ then M(5).etat:=False;\r
+ M(5).Touche:=-1;\r
+ call M(5).bot_disable;\r
+ fi;\r
+ if (mq and not M(6).etat) (* quit devient enable *)\r
+ then M(6).etat:=True;\r
+ M(6).Touche:=T_F6;\r
+ call M(6).bot_enable;\r
+ fi;\r
+ if (not mq and M(6).etat) (* quit devient disable *)\r
+ then M(6).etat:=False;\r
+ M(6).Touche:=-1;\r
+ call M(6).bot_disable;\r
+ fi;\r
+ End;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage de la ville - on deborde de l'ecran *)\r
+(* tracer d'une ligne verticale qui peut depasser le cadre *)\r
+(***************************************************************************)\r
+ \r
+ Unit Trace_Vil1 : procedure (x1,y1,x2,y2 : real ; zoom : integer);\r
+ Var C : integer,\r
+ min_x : integer,\r
+ max_x : integer,\r
+ min_y : integer,\r
+ max_y : integer;\r
+ Begin\r
+ C:=5*zoom;\r
+ min_x:=imin(x1,x2);\r
+ max_x:=imax(x1,x2);\r
+ min_y:=imin(y1,y2);\r
+ max_y:=imax(y1,y2);\r
+ if (min_y>=Ydep_Aff and max_y<=(Ydep_Aff+Haut_Aff))\r
+ then (* on est en plein dans le cadre, on peut tracer normalement *)\r
+ call line(x1-C,imin(y1,y2)+C,x2-C,imax(y1,y2)-C,GrisClair);\r
+ call linep(x1,imin(y1,y2)+C,x2,imax(y1,y2)-C,Blanc,C);\r
+ call line(x1+C,imin(y1,y2)+C,x2+C,imax(y1,y2)-C,GrisClair);\r
+ else if (min_y<Ydep_Aff) (* c'est le minimum qui pose pb *)\r
+ then call line(x1-C,Ydep_Aff+C,x2-C,imax(y1,y2)-C,GrisClair);\r
+ call linep(x1,Ydep_Aff+C,x2,imax(y1,y2)-C,Blanc,C);\r
+ call line(x1+C,Ydep_Aff+C,x2+C,imax(y1,y2)-C,GrisClair);\r
+ else call line(x1-C,imin(y1,y2)+C,x2-C,Ydep_Aff+Haut_Aff-C,GrisClair);\r
+ call linep(x1,imin(y1,y2)+C,x2,Ydep_Aff+Haut_Aff-C,Blanc,C);\r
+ call line(x1+C,imin(y1,y2)+C,x2+C,Ydep_Aff+Haut_Aff-C,GrisClair);\r
+ fi;\r
+ fi;\r
+ End Trace_Vil1;\r
+\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage de la ville - on deborde de l'ecran *)\r
+(* tracer d'une ligne horizontale qui peut depasser le cadre *)\r
+(***************************************************************************)\r
+ \r
+ Unit Trace_Vil2 : procedure (x1,y1,x2,y2 : real ; zoom : integer);\r
+ Var C : integer,\r
+ min_x : integer,\r
+ max_x : integer,\r
+ min_y : integer,\r
+ max_y : integer;\r
+ Begin\r
+ C:=5*zoom;\r
+ min_x:=imin(x1,x2);\r
+ max_x:=imax(x1,x2);\r
+ min_y:=imin(y1,y2);\r
+ max_y:=imax(y1,y2);\r
+ if (min_x>=Xdep_Aff and max_x<=(Xdep_Aff+Larg_Aff))\r
+ then (* on est en plein dans le cadre, on peut tracer normalement *)\r
+ call line(imin(x1,x2)+C,y1-C,imax(x2,x1)-C,y2-C,GrisClair);\r
+ call linep(imin(x1,x2)+C,y1,imax(x2,x1)-C,y2,Blanc,C);\r
+ call line(imin(x1,x2)+C,y1+C,imax(x1,x2)-C,y2+C,GrisClair);\r
+ else if (min_x<Xdep_Aff) (* c'est le minimum qui pose pb *)\r
+ then call line(Xdep_Aff+C,y1-C,imax(x1,x2)-C,y2-C,GrisClair);\r
+ call linep(Xdep_Aff+C,y1,imax(x1,x2)-C,y2,Blanc,C);\r
+ call line(Xdep_Aff+C,y1+C,imax(x1,x2)-C,y2+C,GrisClair);\r
+ else call line(imin(x1,x2)+C,y1-C,Xdep_Aff+Larg_Aff-C,y2-C,GrisClair);\r
+ call linep(imin(x1,x2)+C,y1,Xdep_Aff+Larg_Aff-C,y2,Blanc,C);\r
+ call line(imin(x1,x2)+C,y1+C,Xdep_Aff+Larg_Aff-C,y2+C,GrisClair);\r
+ fi;\r
+ fi;\r
+ End Trace_Vil2;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage de la ville *)\r
+(***************************************************************************)\r
+ Unit Ville_Aff : procedure(zoom : integer);\r
+ var r : arcs,\r
+ s : sommets,\r
+ l : Liste,\r
+ C : integer,\r
+ x1,y1 : integer,\r
+ x2,y2 : integer,\r
+ min_x : integer,\r
+ max_x : integer,\r
+ min_y : integer,\r
+ max_y : integer;\r
+ Begin\r
+ if boolaf\r
+ then\r
+ call W.clear;\r
+ r:=RaciArcs;\r
+ while (r<> none)\r
+ do \r
+ x1:=Xdep_Aff+COORD_X+(r.initial.colonne*COEF_X*zoom);\r
+ y1:=Ydep_Aff+COORD_Y+(r.initial.Ligne*COEF_Y*zoom);\r
+ x2:=Xdep_Aff+COORD_X+(r.final.colonne*COEF_X*zoom);\r
+ y2:=Ydep_Aff+COORD_Y+(r.final.Ligne*COEF_Y*zoom);\r
+ min_x:=imin(x1,x2);\r
+ max_x:=imax(x1,x2);\r
+ min_y:=imin(y1,y2);\r
+ max_y:=imax(y1,y2);\r
+ if(x1=x2) (* c'est une ligne verticale *)\r
+ then \r
+ if (x1<Xdep_Aff or x2>(Xdep_Aff+Larg_Aff)) (* on est hors de l'ecran*)\r
+ then (* on ne fait rien *) \r
+ else (* on va peut etre afficher qqch *)\r
+ if (max_y<Ydep_Aff or min_y>(Ydep_Aff+Haut_Aff))\r
+ then (* on ne doit rien afficher *) \r
+ else (* on va afficher qqch *)\r
+ call trace_vil1(x1,y1,x2,y2,zoom);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ if(y1=y2) (* c'est une ligne horizontale *)\r
+ then \r
+ if (y1<Ydep_Aff or y2>(Ydep_Aff+Haut_Aff)) (* on est hors de l'ecran*)\r
+ then (*on ne fait rien *)\r
+ else (*on va peut etre afficher qqch *)\r
+ if (max_x<Xdep_Aff or min_x>(Xdep_Aff+Larg_Aff))\r
+ then (* on ne doit rien afficher *) \r
+ else (* on va afficher qqch *)\r
+ call trace_vil2(x1,y1,x2,y2,zoom);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ r:=r.suivants;\r
+ od;\r
+ s:=RaciSomm;\r
+ C:=5*zoom;\r
+ while(s<>none)\r
+ do\r
+ x1:=Xdep_Aff+COORD_X+(s.colonne*COEF_X*zoom);\r
+ y1:=Ydep_Aff+COORD_Y+(s.Ligne*COEF_Y*zoom);\r
+ if (x1>=Xdep_Aff and x1<=(Xdep_Aff+Larg_Aff) \r
+ and y1>=Ydep_Aff and y1<=(Ydep_Aff+Haut_Aff))\r
+ then case s.afftype\r
+ when 1 : call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ call line(x1+C,y1-C,x1+C,y1+C,GrisClair);\r
+ when 2 : call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ call line(x1+C,y1+C,x1+C,y1-C,GrisClair);\r
+ when 3 : call line(x1-C,y1+C,x1-C,y1-C,GrisClair);\r
+ call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ when 4 : call line(x1-C,y1-C,x1-C,y1+C,GrisClair);\r
+ call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ when 5 : call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ when 6 : call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ when 7 : call line(x1+C,y1-C,x1+C,y1+C,GrisClair);\r
+ when 8 : call line(x1-C,y1-C,x1-C,y1+C,GrisClair);\r
+ when 9 :\r
+ when 10 : call line(x1-C,y1-C,x1+C,y1-C,GrisClair);\r
+ call line(x1-C,y1+C,x1+C,y1+C,GrisClair);\r
+ when 11 : call line(x1-C,y1-C,x1-C,y1+C,GrisClair);\r
+ call line(x1+C,y1-C,x1+C,y1+C,GrisClair);\r
+ esac;\r
+ fi;\r
+ s:=s.suivant;\r
+ od;\r
+ fi;\r
+ End Ville_Aff;\r
+\r
+(***************************************************************************)\r
+(* *)\r
+(***************************************************************************)\r
+Unit prog : Lists class;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Stats : procedure;\r
+ Const Largeur=450,\r
+ Hauteur=350;\r
+ Var fenet : Son,\r
+ x,y,i : integer,\r
+ Posx,Posy : integer,\r
+ code : integer,\r
+ flagbool : boolean,\r
+ c : integer,\r
+ skey : listkey,\r
+ sclic : cliquer;\r
+ \r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,x-Largeur/2,y-Hauteur/2,x+Largeur/2,y+Hauteur/2,\r
+ 2,False,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ call fenet.affiche;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(60,5);\r
+ flagbool:=fenet.outgtext("Appuyez sur une touche pour continuer",38);\r
+ call color(RougeClair);\r
+ if NbCarActiv>0\r
+ then for c:=0 to imax((NbCarActiv div 18)-1,0)\r
+ do\r
+ for i:=c*18 to imin(NbCarActiv-1-c*18,18*(c+1)) (*maxi 18 car \85 la fois *)\r
+ do\r
+ flagbool:=fenet.moveto(10,25+(i-c*18)*15);\r
+ call color(RougeClair);\r
+ call writint(i+1+c);\r
+ flagbool:=fenet.moveto(40,25+(i-c*18)*15);\r
+ call color(VertClair);\r
+ flagbool:=fenet.outgtext("En partance de ",15);\r
+ flagbool:=fenet.outchar(Activ(i) qua car.dep.nom);\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(170,25+(i-c*18)*15);\r
+ if Activ(i) qua car.km<>0\r
+ then flagbool:=fenet.outgtext(" position ",10);\r
+ call writint(Activ(i) qua car.km);\r
+ else flagbool:=fenet.outgtext(" position 0",11);\r
+ fi;\r
+ call color(VertClair);\r
+ flagbool:=fenet.moveto(266,25+(i-c*18)*15);\r
+ flagbool:=fenet.outgtext(" vers ",6);\r
+ if (Activ(i) qua car.arccour.initial.nom)=(Activ(i) qua car.dep.nom)\r
+ then flagbool:=fenet.outchar(Activ(i) qua car.arccour.final.nom);\r
+ else flagbool:=fenet.outchar(Activ(i) qua car.arccour.initial.nom);\r
+ fi;\r
+ od;\r
+ code:=0;\r
+ do\r
+ code:=inkey;\r
+ if code<>0 then exit fi;\r
+ od;\r
+ call fenet.clear;\r
+ call color(BleuClair);\r
+ flagbool:=fenet.moveto(60,5);\r
+ flagbool:=fenet.outgtext("Appuyez sur une touche pour continuer",38);\r
+ od;\r
+ else flagbool:=fenet.moveto(10,25);\r
+ flagbool:=fenet.outgtext("NbCarActiv = 0",14);\r
+ code:=0;\r
+ do\r
+ code:=inkey;\r
+ if code<>0 then exit fi;\r
+ od;\r
+ fi;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ End Bot_Stats;\r
+\r
+\r
+(***************************************************************************)\r
+(* simprocess de generation des voitures *)\r
+(***************************************************************************)\r
+ Unit Generate : Simprocess class;\r
+ Begin\r
+ do\r
+ if NbCarActiv<NbMaxCar\r
+ then Activ(NbCarActiv):=new car;\r
+ call schedule(Activ(NbCarActiv),time);\r
+ NbCarActiv:=NbCarActiv+1;\r
+ call hold(5);\r
+ else call hold(70);\r
+ fi;\r
+ od;\r
+ End Generate;\r
+\r
+(***************************************************************************)\r
+(* simprocess des voitures *)\r
+(* on se limite au cas o\97 toutes les voies sont \85 double sens *)\r
+(***************************************************************************)\r
+ Unit Car : Simprocess class;\r
+ \r
+ (* procedure d'affichage de la voiture dans la ville *)\r
+ Unit affiche_car : procedure;\r
+ Var flagbool : boolean;\r
+ \r
+ Unit dessine_car : procedure (x1,y1,x2,y2 : integer);\r
+ Begin\r
+ call color(col);\r
+ x1:=COORD_X+x1*COEF_X*Zoom;\r
+ y1:=COORD_Y+y1*COEF_Y*Zoom;\r
+ x2:=COORD_X+x2*COEF_X*Zoom;\r
+ y2:=COORD_Y+y2*COEF_Y*Zoom;\r
+ if (x1>=0 and y1>=0 and x2<=Larg_Aff and y2<=Haut_Aff)\r
+ then call rectanglef(Xdep_Aff+x1,Ydep_Aff+y1,Xdep_Aff+x2,Ydep_Aff+y2,col);\r
+ fi;\r
+ End dessine_car;\r
+\r
+ Begin\r
+ if arccour.Initial.colonne=arccour.final.colonne\r
+ then (* on est vertical *)\r
+ if sens=1 \r
+ then (* on va de initial \85 final *)\r
+ if arccour.initial.ligne<arccour.final.ligne\r
+ then (* l'initial est plus 'haut' que le final *)\r
+ call dessine_car(arccour.initial.colonne+1,\r
+ arccour.initial.ligne+(km-1),\r
+ arccour.initial.colonne+(1+Zoom),\r
+ arccour.initial.ligne+(km));\r
+ else (* l'initial est plus 'bas' que le final *)\r
+ call dessine_car(arccour.initial.colonne+1,\r
+ arccour.initial.ligne-(km-1),\r
+ arccour.initial.colonne+(1+Zoom),\r
+ arccour.initial.ligne-(km));\r
+ fi;\r
+ else (* on va de final \85 initial *)\r
+ if arccour.initial.ligne<arccour.final.ligne\r
+ then (* l'initial est plus 'haut' que le final *)\r
+ call dessine_car(arccour.final.colonne-1,\r
+ arccour.final.ligne-(km-1),\r
+ arccour.final.colonne-(1+Zoom),\r
+ arccour.final.ligne-(km));\r
+ else (* l'initial est plus 'bas' que le final *)\r
+ call dessine_car(arccour.final.colonne-1,\r
+ arccour.final.ligne+(km-1),\r
+ arccour.final.colonne-(1+Zoom),\r
+ arccour.final.ligne+(km));\r
+ fi;\r
+ fi;\r
+ else (* on est horizontal *)\r
+ if sens=1\r
+ then (* on va de initial \85 final *)\r
+ if arccour.initial.colonne<arccour.final.colonne\r
+ then (* l'initial est plus 'gche' que le final *)\r
+ call dessine_car(arccour.initial.colonne+(km-1),\r
+ arccour.initial.ligne+1,\r
+ arccour.initial.colonne+(km),\r
+ arccour.initial.ligne+(1+Zoom));\r
+ else (* l'initial est plus 'dte' que le final *)\r
+ call dessine_car(arccour.initial.colonne-(km-1),\r
+ arccour.initial.ligne+1,\r
+ arccour.initial.colonne-(km),\r
+ arccour.initial.ligne+(1+Zoom));\r
+ fi;\r
+ else (* on va de final \85 initial *)\r
+ if arccour.initial.colonne<arccour.final.colonne\r
+ then (* l'initial est plus 'gche' que le final *)\r
+ call dessine_car(arccour.final.colonne-(km-1),\r
+ arccour.final.ligne-1,\r
+ arccour.final.colonne-(km),\r
+ arccour.final.ligne-(1+Zoom));\r
+ else (* l'initial est plus 'dte' que le final *)\r
+ call dessine_car(arccour.final.colonne+(km-1),\r
+ arccour.final.ligne-1,\r
+ arccour.final.colonne+(km),\r
+ arccour.final.ligne-(1+Zoom));\r
+ fi;\r
+ fi;\r
+ fi;\r
+ End affiche_car;\r
+ \r
+ (* fonction se deplacant dans l'arc courant *)\r
+ Unit avance : function : boolean;\r
+ Begin\r
+ if sens=1\r
+ then arccour.occpsens(km):=none;\r
+ km:=km+1;\r
+ if km<arccour.distance\r
+ then if arccour.occpsens(km)=none (* si il n'y a personne devant*)\r
+ then arccour.occpsens(km):=this car;\r
+ else km:=km-1;\r
+ fi;\r
+ result:=True; (* on n'a pas encore fini *)\r
+ else result:=False; (* on est arrive au sommet final *)\r
+ fi;\r
+ else arccour.occpinve(km):=none;\r
+ km:=km+1;\r
+ if km<=arccour.distance\r
+ then if arccour.occpinve(km)=none (* s'il n'y a personne devant *)\r
+ then arccour.occpinve(km):=this car; (* on avance *)\r
+ else km:=km-1; (* sinon on reste en place *)\r
+ fi;\r
+ result:=True; (* on n'a pas encore fini *)\r
+ else result:=False; (* on est arrive au sommet final *)\r
+ fi;\r
+ fi;\r
+ call affiche_car; \r
+ End avance;\r
+ \r
+ (* fonction choisissant le sommet de depart *)\r
+ Unit choix_sommet : function : sommets;\r
+ var som : sommets,\r
+ ch : integer,\r
+ i : integer;\r
+ Begin\r
+ som:=RaciSomm;\r
+ ch:=RANDOM*NBSOMMETS+1; (* on choisit le numero du sommet *)\r
+ for i:=1 to ch-1\r
+ do\r
+ som:=som.suivant;\r
+ od;\r
+ result:=som;\r
+ End choix_sommet;\r
+\r
+ (* fonction choisissant l'arc suivant que l'on va prendre *) \r
+ Unit choix_arc : function : arcs;\r
+ Var i : integer,\r
+ nbarcs : integer,\r
+ numarcdep : integer,\r
+ lst : liste,\r
+ sl : liste; (* sauvegarde du precedent *)\r
+ Begin\r
+ nbarcs:=2;\r
+ if (dep.afftype<=8 and dep.afftype>=5)\r
+ then nbarcs:=nbarcs+1;\r
+ else if dep.afftype=9\r
+ then nbarcs:=nbarcs+2;\r
+ fi;\r
+ fi;\r
+ numarcdep:=RANDOM*nbarcs+1;\r
+ lst:=dep.ptrarc;\r
+ sl:=lst;\r
+ for i:=1 to numarcdep-1 (* on recherche cet arc dans la liste *)\r
+ do\r
+ sl:=lst;\r
+ lst:=lst.suivante;\r
+ od;\r
+ km:=1; (* kilometrage dans l'arc *)\r
+ if lst.pointeur=arccour (* on a repris le meme arc *)\r
+ then if sl<>lst\r
+ then result:=sl.pointeur; (* on prend le precedent *)\r
+ else result:=lst.suivante.pointeur; (* sinon le suivant *)\r
+ fi;\r
+ else result:=lst.pointeur; (* on poss\8ade l'arc *)\r
+ fi;\r
+ if result.initial=dep\r
+ then sens:=1;\r
+ else sens:=-1;\r
+ fi;\r
+ End choix_arc;\r
+\r
+ Var dep : sommets, (* sommet de depart du voyage *)\r
+ arccour : arcs, (* arc de depart du voyage *)\r
+ boo : boolean,\r
+ sens : integer, (* 1 si ini-fin , -1 si fin-ini *)\r
+ km : integer, (* distance ds l'arc courant depuis sommet initial*)\r
+ pourcent : integer,\r
+ col : integer; (* couleur de la voiture *)\r
+ Begin\r
+ dep:=choix_sommet;\r
+ arccour:=dep.ptrarc.pointeur;\r
+ if dep=arccour.initial\r
+ then sens:=1;\r
+ else sens:=-1;\r
+ fi;\r
+ col:=RANDOM*15+1; (* tout sauf noir *)\r
+ km:=1;\r
+ do\r
+ boo:=avance; (* on avance d'un pas *)\r
+ if not boo (* on est \85 la fin de l'arc, il faut savoir si on va en *)\r
+ (* prendre un autre *)\r
+ then pourcent:=RANDOM*100;\r
+ if pourcent>20 \r
+ then if dep=arccour.initial\r
+ then dep:=arccour.final;\r
+ else dep:=arccour.initial;\r
+ fi;\r
+ arccour:=choix_arc; (* on a 80% de chance de continuer *)\r
+ boo:=True; (* on doit donc continuer *)\r
+ else boo:=False; (* on s'arrete *)\r
+ fi;\r
+ fi;\r
+ if boo (* si boo alors on n'est pas encore au point d'arrivee *)\r
+ then call hold(90);\r
+ else exit;\r
+ fi;\r
+ od;\r
+ NbCarActiv:=NbCarActiv-1;\r
+ call passivate;\r
+ End Car;\r
+\r
+\r
+(***************************************************************************)\r
+(* simprocess de gestion de l'affichage *)\r
+(***************************************************************************)\r
+ Unit affichage : simprocess class;\r
+ Begin\r
+ do \r
+ code:=W.Gestionnaire;\r
+ call hidecursor;\r
+ if (code=T_F1) or (code=1) then call Bot_Load; \r
+ else \r
+ if (code=T_F6) or (code=6) then if Bot_Quit then fin:=True; exit; fi; \r
+ else \r
+ if (code=T_F9) or (code=9) then call Bot_help; \r
+ else \r
+ if (code=T_ALTF4) then if Bot_Quit then fin:=True; exit; fi;\r
+ else \r
+ if (code=T_F2) or (code=2) then call Bot_Run;\r
+ else \r
+ if (code=T_F3) or (code=3) then call Bot_Stop;\r
+ else \r
+ if (code=T_f4) or (code=4) then call Bot_Continue;\r
+ else \r
+ if (code=T_FLGCH) or (code=51) then call W.Horiz.DeplacerLeft;\r
+ COORD_X:=COORD_X+30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=T_FLDTE) or (code=53) then call W.Horiz.DeplacerRight;\r
+ COORD_X:=COORD_X-30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=T_FLHAU) or (code=61) then call W.Verti.DeplacerUp;\r
+ COORD_Y:=COORD_Y+30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=T_FLBAS) or (code=63) then call W.verti.DeplacerDown;\r
+ COORD_Y:=COORD_Y-30;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=101) then if Bot_Quit then fin:=True; exit fi;\r
+ else\r
+ if (code=102) then call W.iconify;\r
+ else\r
+ if (code=52) then COORD_X:=0; \r
+ call W.Horiz.Reset_Bot;\r
+ call Ville_Aff(ZOOM);\r
+ else\r
+ if (code=62) then COORD_Y:=0;\r
+ call W.Verti.Reset_Bot;\r
+ call Ville_Aff(ZOOM);\r
+ else \r
+ if (code=7) or (code=T_F7) \r
+ then Zoom:=Zoom+1;\r
+ if zoom=5 then M(7).etat:=False;\r
+ call M(7).bot_disable;\r
+ fi;\r
+ if not M(8).etat then M(8).etat:=True;\r
+ call M(8).bot_enable;\r
+ fi;\r
+ C:=5*Zoom;\r
+ Larg_Aff:=W.Horiz.x2-W.Horiz.x1-20-2*C;\r
+ Haut_Aff:=W.Verti.y2-W.Verti.y1-20-2*C;\r
+ Xdep_Aff:=W.Horiz.x1+10+C;\r
+ Ydep_Aff:=W.Verti.y1+10+C;\r
+ call Ville_Aff(Zoom);\r
+ else\r
+ if (code=8) or (code=T_F8)\r
+ then Zoom:=Zoom-1;\r
+ if zoom=1 then M(8).etat:=False;\r
+ call M(8).bot_disable;\r
+ fi;\r
+ if not M(7).etat then M(7).etat:=True;\r
+ call M(7).bot_Enable;\r
+ fi;\r
+ C:=5*Zoom;\r
+ Larg_Aff:=W.Horiz.x2-W.Horiz.x1-20-2*C;\r
+ Haut_Aff:=W.Verti.y2-W.Verti.y1-20-2*C;\r
+ Xdep_Aff:=W.Horiz.x1+10+C;\r
+ Ydep_Aff:=W.Verti.y1+10+C;\r
+ call Ville_Aff(Zoom);\r
+ else\r
+ if (code=5) or (code=T_F5) then call Bot_Stats; \r
+ else\r
+ if (code=T_SHFTF4) then call About;\r
+ else\r
+ if (code=T_CTRLF4) then call W.iconify;\r
+ else\r
+ if code=T_CTRLENT then call rattacher(SIMULA,EDIT);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ call showcursor;\r
+ (* si on n'est pas en pause dans la simulation, on doit faire un hold *)\r
+ (* pour pouvoir passer la 'main' au generateur et aux voitures *)\r
+ if not SimStop then call hold(120); fi;\r
+ od;\r
+ End affichage;\r
+\r
+Var sim_aff : affichage;\r
+Begin\r
+ sim_aff:=new affichage;\r
+ call schedule(new generate,time); (* mise dans la file du generateur de car *)\r
+ call hold(10);\r
+ call schedule(sim_aff,time); (* mise dans la file du syst\8ame d'affichage *)\r
+ do \r
+ call hold(150);\r
+ if fin then exit; fi;\r
+ od;\r
+End prog;\r
+\r
+\r
+\r
+Begin\r
+\r
+ W:=new Maine(100,1,1,SIZEX,SIZEY,3,True,True,False);\r
+ W.hauteur:=Haut_bot;\r
+ W.cborder:=BleuClair;\r
+ W.cbande:=GrisClair;\r
+ W.cnom:=BleuClair;\r
+ W.nom:="Simulation de r\82seau routier";\r
+ W.icname:="Root";\r
+ \r
+ array M dim (1:9);\r
+\r
+ y1:=W.y1+W.lborder+1+W.hauteur+2;\r
+ y2:=y1+Haut_bot;\r
+ M(1):=new Menu(1,T_F1,W.x1+8,y1,W.x1+50,y2);\r
+ M(1).nom:="Load";\r
+ M(1).etat:=True;\r
+ call W.Bout.Insert(M(1));\r
+\r
+ M(2):=new Menu(2,-1,W.x1+55,y1,W.x1+89,y2);\r
+ M(2).nom:="Run";\r
+ M(2).etat:=False;\r
+ call W.Bout.Insert(M(2));\r
+\r
+ M(3):=new Menu(3,-1,W.x1+94,y1,W.x1+136,y2);\r
+ M(3).nom:="Stop";\r
+ M(3).etat:=False;\r
+ call W.Bout.Insert(M(3)); \r
+ \r
+ M(4):=new Menu(4,-1,W.x1+141,y1,W.x1+215,y2);\r
+ M(4).nom:="Continue";\r
+ M(4).etat:=False;\r
+ call W.Bout.Insert(M(4));\r
+ \r
+ M(5):=new Menu(5,-1,W.x1+220,y1,W.x1+270,y2);\r
+ M(5).nom:="Stats";\r
+ M(5).etat:=False;\r
+ call W.Bout.Insert(M(5));\r
+\r
+ M(6):=new Menu(6,T_F6,W.x1+275,y1,W.x1+317,y2);\r
+ M(6).nom:="Quit";\r
+ M(6).etat:=True;\r
+ call W.Bout.Insert(M(6));\r
+ \r
+ M(7):=new Menu(7,T_F7,W.x2-94,y1,W.x2-77,y2);\r
+ M(7).nom:="+";\r
+ M(7).etat:=True;\r
+ call W.Bout.Insert(M(7));\r
+\r
+ M(8):=new Menu(8,T_F8,W.x2-72,y1,W.x2-55,y2);\r
+ M(8).nom:="-";\r
+ M(8).etat:=False;\r
+ call W.Bout.Insert(M(8));\r
+ \r
+ M(9):=new Menu(9,T_F9,W.x2-30,y1,W.x2-13,y2);\r
+ M(9).nom:="?";\r
+ M(9).etat:=True;\r
+ call W.Bout.Insert(M(9)); \r
+\r
+ x1:=W.x1+W.lborder+1;\r
+ y1:=W.y2-W.lborder-Haut_bot-1;\r
+ x2:=W.x2-W.lborder-Larg_bot-1;\r
+ y2:=W.y2-W.lborder-1;\r
+ W.Horiz:=new AccelerateH(50,-1,x1,y1,x2,y2,W);\r
+\r
+ x1:=W.x2-W.lborder-Larg_bot-1; \r
+ y1:=W.y1+W.lborder+2*(Haut_bot+2);\r
+ x2:=W.x2-W.lborder-1;\r
+ y2:=W.y2-W.lborder-Haut_bot;\r
+ W.Verti:=new AccelerateV2(60,-1,x1,y1,x2,y2,W);\r
+ \r
+ Larg_Aff:=W.Horiz.x2-W.Horiz.x1-20;\r
+ Haut_Aff:=W.Verti.y2-W.Verti.y1-20;\r
+ Xdep_Aff:=W.Horiz.x1+10;\r
+ Ydep_Aff:=W.Verti.y1+10;\r
+ COEF_X:=1;\r
+ COEF_Y:=1;\r
+ COORD_X:=0;\r
+ COORD_Y:=0;\r
+ ZOOM:=1;\r
+ C:=5*ZOOM;\r
+ \r
+ return;\r
+\r
+ call keys.insert(new elmt(T_CTRLENT)); (* pour le chgt de programme *)\r
+\r
+ call W.affiche;\r
+ notfirst:=true; (* on a deja fait un affichage de la fenetre *)\r
+\r
+ call About; (* about en presentation *)\r
+ \r
+ call showcursor;\r
+\r
+ prg:=new prog; (* on met la simulation en route *)\r
+ (* NB: elle commence par l'affichage et sa gestion *)\r
+ call hidecursor;\r
+ \r
+ call W.restore;\r
+ \r
+end simulateur;\r
+ \r
+(***************************************************************************)\r
+(***************************************************************************)\r
+(* PROGRAMME NUMERO 2 : EDITEUR DE VILLES *)\r
+(***************************************************************************)\r
+(***************************************************************************)\r
+ Unit editor : Logiciel coroutine (nomfic : arrayof char;output resultat : boolean);\r
+ Var largeur : integer,\r
+ hauteur : integer,\r
+ y1,y2 : integer,\r
+ M : arrayof menu;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Quit : function : boolean;\r
+ Const Largeur=300,\r
+ Hauteur=90;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ fin : boolean,\r
+ code : integer,\r
+ Yes,No : Menu,\r
+ sclic : cliquer,\r
+ skey : listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,Posx,Posy,Posx+Largeur,Posy+hauteur,2,True,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.nom:="Q U I T";\r
+ fenet.cnom:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ Yes:=new Menu(1,T_Y,Posx+60,Posy+61,Posx+100,Posy+61+Haut_bot);\r
+ Yes.nom:="Yes";\r
+ Yes.etat:=True;\r
+ call fenet.Bout.Insert(Yes);\r
+ No:=new Menu(2,T_N,Posx+190,Posy+61,Posx+220,Posy+61+Haut_bot);\r
+ No.nom:="No";\r
+ No.etat:=True;\r
+ call fenet.Bout.Insert(No);\r
+ call fenet.affiche;\r
+ call move(Posx+10,Posy+35);\r
+ call color(BleuClair);\r
+ call outstring("Do you want to quit the editor");\r
+ call Keys.Insert(new elmt(T_ESC));\r
+ call showcursor;\r
+ do\r
+ code:=fenet.gestionnaire;\r
+ case code\r
+ when T_ESC : fin:=False; exit; (* touche racc exit *)\r
+ when T_Y : fin:=True; exit; (* touche Y *)\r
+ when T_N : fin:=False; exit; (* touche N *)\r
+ when 1 : fin:=True; exit; (* bouton yes *)\r
+ when 2 : fin:=False; exit; (* bouton no *) \r
+ when 11 : fin:=False; exit; (* racc exit *)\r
+ esac;\r
+ od; \r
+ call hidecursor;\r
+ if not fin\r
+ then result:=False;\r
+ else result:=True;\r
+ fi;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ call showcursor;\r
+ End Bot_Quit;\r
+ \r
+ \r
+ \r
+ \r
+ Begin\r
+ largeur:=SIZEX;\r
+ hauteur:=SIZEY;\r
+ W:=new Maine(100,1,1,largeur,hauteur,3,True,True,False);\r
+ W.hauteur:=Haut_bot;\r
+ W.cborder:=BleuClair;\r
+ W.cbande:=GrisClair;\r
+ W.cnom:=BleuClair;\r
+ W.nom:="Editeur de r\82seau routier";\r
+ W.icname:="Edit";\r
+ \r
+ array M dim (1:6);\r
+\r
+ y1:=W.y1+W.lborder+1+W.hauteur+2;\r
+ y2:=y1+Haut_bot;\r
+ M(1):=new Menu(1,T_F1,W.x1+8,y1,W.x1+50,y2);\r
+ M(1).nom:="Load";\r
+ M(1).etat:=True;\r
+ call W.Bout.Insert(M(1));\r
+ \r
+ M(2):=new Menu(2,T_F2,W.x1+55,y1,W.x1+99,y2);\r
+ M(2).nom:="Save";\r
+ M(2).etat:=False;\r
+ call W.Bout.Insert(M(2));\r
+ \r
+ M(3):=new Menu(3,T_F3,W.x1+104,y1,W.x1+146,y2);\r
+ M(3).nom:="Quit";\r
+ M(3).etat:=True;\r
+ call W.Bout.Insert(M(3)); \r
+\r
+ M(4):=new Menu(4,T_F4,W.x2-94,y1,W.x2-77,y2);\r
+ M(4).nom:="+";\r
+ M(4).etat:=True;\r
+ call W.Bout.Insert(M(4));\r
+ \r
+ M(5):=new Menu(5,-1,W.x2-72,y1,W.x2-55,y2);\r
+ M(5).nom:="-";\r
+ M(5).etat:=False;\r
+ call W.Bout.Insert(M(5));\r
+ \r
+ M(6):=new Menu(6,T_F6,W.x2-30,y1,W.x2-13,y2);\r
+ M(6).nom:="?";\r
+ M(6).etat:=True;\r
+ call W.Bout.Insert(M(6)); \r
+ \r
+ return; (* fin de l'initialisation de la coroutine *)\r
+\r
+ call keys.insert(new elmt(T_CTRLENT)); (* pour le chgt de programme *)\r
+\r
+ call W.affiche;\r
+ notfirst:=true; (* on a deja fait un affichage de la fenetre *)\r
+\r
+ do\r
+ code:=W.gestionnaire;\r
+ if code=T_F3 or code=3 then if bot_quit then exit; fi;\r
+ else \r
+ if code=T_F1 or code=1 then \r
+ else \r
+ if code=T_F2 or code=2 then\r
+ else \r
+ if code=T_CTRLF4 then call W.iconify;\r
+ else \r
+ if code=T_F4 or code=4 then\r
+ else \r
+ if code=T_F5 or code=5 then\r
+ else\r
+ if code=T_F6 or code=6 then\r
+ else\r
+ if code=T_CTRLENT then call rattacher(EDIT,DOS);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ call W.restore;\r
+ call showcursor;\r
+ kill(W);\r
+ End editor;\r
+\r
+ \r
+(***************************************************************************)\r
+(***************************************************************************)\r
+(* PROGRAMME NUMERO 3 : FENETRE MS-DOS *)\r
+(***************************************************************************)\r
+(***************************************************************************)\r
+ Unit MS_DOS : Logiciel coroutine; \r
+ Var largeur : integer,\r
+ hauteur : integer,\r
+ y1,y2 : integer,\r
+ M : arrayof menu;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Quit : function : boolean;\r
+ Const Largeur=300,\r
+ Hauteur=90;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ Posx,Posy : integer,\r
+ fin : boolean,\r
+ code : integer,\r
+ Yes,No : Menu,\r
+ sclic : cliquer,\r
+ skey : listkey;\r
+\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ Posx:=x-Largeur/2;\r
+ Posy:=y-Hauteur/2;\r
+ sclic:=clics;\r
+ clics:=new cliquer;\r
+ skey:=keys;\r
+ keys:=new listkey;\r
+ fenet:=new Son(10,Posx,Posy,Posx+Largeur,Posy+hauteur,2,True,False,False);\r
+ attach(fenet);\r
+ fenet.hauteur:=Haut_Bot;\r
+ fenet.cborder:=RougeClair;\r
+ fenet.nom:="Q U I T";\r
+ fenet.cnom:=RougeClair;\r
+ fenet.cbande:=Rouge;\r
+ Yes:=new Menu(1,T_Y,Posx+60,Posy+61,Posx+100,Posy+61+Haut_bot);\r
+ Yes.nom:="Yes";\r
+ Yes.etat:=True;\r
+ call fenet.Bout.Insert(Yes);\r
+ No:=new Menu(2,T_N,Posx+190,Posy+61,Posx+220,Posy+61+Haut_bot);\r
+ No.nom:="No";\r
+ No.etat:=True;\r
+ call fenet.Bout.Insert(No);\r
+ call fenet.affiche;\r
+ call move(Posx+10,Posy+35);\r
+ call color(BleuClair);\r
+ call outstring("Do you want to quit the DOS session");\r
+ call Keys.Insert(new elmt(T_ESC));\r
+ call showcursor;\r
+ do\r
+ code:=fenet.gestionnaire;\r
+ case code\r
+ when T_ESC : fin:=False; exit; (* touche racc exit *)\r
+ when T_Y : fin:=True; exit; (* touche Y *)\r
+ when T_N : fin:=False; exit; (* touche N *)\r
+ when 1 : fin:=True; exit; (* bouton yes *)\r
+ when 2 : fin:=False; exit; (* bouton no *) \r
+ when 11 : fin:=False; exit; (* racc exit *)\r
+ esac;\r
+ od; \r
+ call hidecursor;\r
+ if not fin\r
+ then result:=False;\r
+ else result:=True;\r
+ fi;\r
+ call fenet.restore;\r
+ kill(keys);\r
+ keys:=skey;\r
+ kill(clics);\r
+ clics:=sclic;\r
+ attach(fenet);\r
+ kill(fenet);\r
+ call showcursor;\r
+ End Bot_Quit;\r
+ \r
+ \r
+ \r
+ \r
+ Begin\r
+ largeur:=SIZEX;\r
+ hauteur:=SIZEY;\r
+ W:=new Maine(100,1,1,largeur,hauteur,3,True,True,False);\r
+ W.hauteur:=Haut_bot;\r
+ W.cborder:=BleuClair;\r
+ W.cbande:=GrisClair;\r
+ W.cnom:=BleuClair;\r
+ W.nom:="Fenetre MS-DOS";\r
+ W.icname:="MS-DOS";\r
+ \r
+ array M dim (1:2);\r
+\r
+ y1:=W.y1+W.lborder+1+W.hauteur+2;\r
+ y2:=y1+Haut_bot;\r
+ M(1):=new Menu(1,T_F1,W.x1+8,y1,W.x1+50,y2);\r
+ M(1).nom:="Quit";\r
+ M(1).etat:=True;\r
+ call W.Bout.Insert(M(1));\r
+ \r
+ M(2):=new Menu(2,T_F2,W.x2-30,y1,W.x2-13,y2);\r
+ M(2).nom:="?";\r
+ M(2).etat:=True;\r
+ call W.Bout.Insert(M(2)); \r
+ \r
+ return; (* fin de l'initialisation de la coroutine *)\r
+\r
+ call keys.insert(new elmt(T_CTRLENT)); (* pour le chgt de programme *)\r
+\r
+ call W.affiche;\r
+ notfirst:=true; (* on a deja fait un affichage de la fenetre *)\r
+\r
+ do\r
+ code:=W.gestionnaire;\r
+ if code=T_F1 or code=1 then if bot_quit then exit; fi;\r
+ else \r
+ if code=T_CTRLF4 then call W.iconify;\r
+ else \r
+ if code=T_CTRLENT then call rattacher(DOS,SIMULA);\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ call W.restore;\r
+ call showcursor;\r
+ kill(W);\r
+ End MS_DOS;\r
+\r
+ \r
+ \r
+(***************************************************************************)\r
+(***************************************************************************)\r
+(* P R O G R A M M E P R IN C I P A L *)\r
+(***************************************************************************)\r
+(***************************************************************************)\r
+ \r
+ Unit Logiciel : coroutine(id : integer);\r
+ Var W : Maine,\r
+ notfirst : boolean; (* false si c'est la premi\8are fois *)\r
+ End logiciel;\r
+\r
+\r
+\r
+ Unit rattacher : procedure (co_prov,co_dest : Logiciel);\r
+ Begin\r
+ if co_dest<>none\r
+ then SLKEYS(co_prov.id):=Keys; (* on sauve les liste de l'ancien actif *)\r
+ SLCLICS(co_prov.id):=clics;\r
+ call move(co_prov.W.x1,co_prov.W.y1);\r
+ co_prov.W.savmap:=getmap(co_prov.W.x2,co_prov.W.y2);\r
+ \r
+ Keys:=SLKEYS(co_dest.id); (* on met les listes du prog actif en place *)\r
+ clics:=SLCLICS(co_dest.id);\r
+ if co_dest.notfirst\r
+ then call move(co_dest.W.x1,co_dest.W.y1);\r
+ call putmap(co_dest.W.savmap);\r
+ fi;\r
+ \r
+ attach(co_dest); (* on met actif le programme *)\r
+ fi;\r
+ End rattacher;\r
+\r
+ \r
+ Begin\r
+ call gron(1); (* mode 640x480x256 avec driver stealth.grn*)\r
+ SIZEX:=640; \r
+ SIZEY:=480;\r
+\r
+ array SLKEYS dim (1:3);\r
+ array SLCLICS dim (1:3);\r
+ \r
+ clics:=new cliquer; (* ensemble des zones de clic possible *)\r
+ Keys:=new ListKey; (* liste des touches rattach\82es *)\r
+ SIMULA:=new simulateur(1);\r
+ SLKEYS(1):=keys;\r
+ SLCLICS(1):=clics;\r
+ \r
+ clics:=new cliquer; (* ensemble des zones de clic possible *)\r
+ Keys:=new ListKey; (* liste des touches rattach\82es *)\r
+ EDIT:=new editor(2,none,edit_bool);\r
+ SLKEYS(2):=keys;\r
+ SLCLICS(2):=clics;\r
+ \r
+ clics:=new cliquer; (* ensemble des zones de clic possible *)\r
+ Keys:=new ListKey; (* liste des touches rattach\82es *)\r
+ DOS:=new MS_DOS(3);\r
+ SLKEYS(3):=keys;\r
+ SLCLICS(3):=clics;\r
+\r
+ Keys:=SLKEYS(1); (* on met les listes du prog actif en place *)\r
+ clics:=SLCLICS(1);\r
+ do\r
+ attach(SIMULA);\r
+ od;\r
+ \r
+ call groff;\r
+ End\r
+\r
+ end\r
+end.\r
--- /dev/null
+ -1\r
+ 1\r
--- /dev/null
+program VerifyingSpecification;\r
+ (* This is an example showing how to proceed in order to\r
+ make a dynamic verification of an implementation of \r
+ a specification of a data structure.\r
+\r
+ In our example we shall give three components:\r
+ 1) a specification of stacks,\r
+ 2) a class that ensures the dynamic verification of\r
+ correctness of an implementing module,\r
+ 3) an implementation of stacks as a class which inherits\r
+ from the previous class.\r
+ *)\r
+ (* Nowy problem powstaje:\r
+ jak rozpl\ata'c wzajemne odwo/lania operacji wymienionych\r
+ w specyfikacji?\r
+\r
+ Zrobilem tak: kazda operacja posiada dwie wersje np. Push i Ppush\r
+ 1sza wersja jest otoczona pre- i post- conditions\r
+ 2ga wersja nie zawiera takiego sprawdzania - druga wersja jest uzywana w pre- i post-conditions i wewnatrz equal ktore odwoluje sie do top i pop\r
+\r
+ Nie jestem tym zachwycony.\r
+ Po co dwa razy pisac te sama procedure??\r
+\r
+ *)\r
+\r
+ (* --------------- specification of STACKS ----------------------------\r
+\r
+ sorts Elem, Stack, Boolean;\r
+\r
+ predicates\r
+ empty: Stack {SYMBOL 174 \f "Symbol"} Boolean\r
+ eq: Elem {SYMBOL 180 \f "Symbol"} Elem {SYMBOL 174 \f "Symbol"} Boolean\r
+ equal: Stack {SYMBOL 180 \f "Symbol"} Stack {SYMBOL 174 \f "Symbol"} Boolean\r
+\r
+ operations\r
+ push: Elem {SYMBOL 180 \f "Symbol"} Stack {SYMBOL 174 \f "Symbol"} Stack\r
+ pop: Stack {SYMBOL 174 \f "Symbol"} Stack\r
+ top: Stack {SYMBOL 174 \f "Symbol"} Elem\r
+\r
+ axioms\r
+ for every e in Elem, for every s in Stack\r
+\r
+ A1) not empty(push(e,s))\r
+ A2) eq(e, top(push(e,s)))\r
+ A3) equal(s, pop(push(e,s)))\r
+ A4) not empty(s) ==> equal(s, push(top(s), pop(s)))\r
+ A5) while not empty(s) do s := pop(s) od true\r
+ A6) equal(s, s') <=> begin result := true; s1 := s; s2 := s';\r
+ while not empty(s1) and not empty(s2) and result\r
+ do\r
+ result := eq(top(s1), top(s2));\r
+ s1 := pop(s1);\r
+ s2 := pop(s2);\r
+ od (result and empty(s1) and empty(s2))\r
+\r
+\r
+ end of specification STACKS\r
+ *)\r
+\r
+\r
+(* -------------------------- Checking STACKS --------------------------- *)\r
+\r
+ unit STACKS_CHECKING: class;\r
+\r
+ unit Elem: class;\r
+ end Elem;\r
+\r
+ unit Stack: class;\r
+ end Stack;\r
+\r
+ unit check_Push: class(e: Elem, s: Stack);\r
+ var res, old_s: Stack;\r
+ begin\r
+ (* if full(s) then raise ERR_Full fi; *)\r
+ old_s := s;\r
+ inner;\r
+ if empty(res) then raise ERR_Axiom1 fi;\r
+ if not eq(e, Ttop(res)) then raise ERR_Axiom2 fi;\r
+ if not equal(old_s, Ppop(res)) then raise ERR_Axiom3 fi;\r
+ end check_Push;\r
+\r
+ unit virtual Push: check_Push function: Stack;\r
+ end Push;\r
+\r
+ unit virtual Ppop: function(s:Stack): Stack;\r
+ end Ppop;\r
+\r
+ unit virtual Pop: check_Pop function: Stack;\r
+ end Pop;\r
+\r
+ unit virtual Ttop: function(s: Stack): Elem;\r
+ end Ttop;\r
+\r
+ unit check_Pop: class(s: Stack);\r
+ var res: Stack, aux: Elem;\r
+ begin\r
+ if empty(s) then raise ERR_Empty fi;\r
+ inner;\r
+ aux := Ttop(s); \r
+ if not equal(s, Ppush(aux,res)) then raise ERR_Axiom4 fi; \r
+ end check_Pop;\r
+ \r
+ unit virtual Ppush: function(e: Elem, s: Stack): Stack; \r
+ end Ppush;\r
+\r
+ unit virtual Top: check_Top function: Elem;\r
+ end Top;\r
+\r
+ unit check_Top: class(s: Stack);\r
+ var res: Elem, aux: Stack;\r
+ begin\r
+ if empty(s) then raise ERR_Empty fi;\r
+ inner;\r
+ aux := Pop(s);\r
+ if not equal(s, Ppush(res,aux)) then raise ERR_Axiom4 fi; \r
+ end check_Top;\r
+ \r
+ unit virtual Empty: function(s: Stack): Boolean;\r
+ end Empty;\r
+\r
+ unit virtual Eq: function(e1, e2: Elem): Boolean;\r
+ end Eq;\r
+\r
+ unit check_Equal: class(s1, s2: Stack);\r
+ (* what to check and how? *)\r
+\r
+ end check_Equal;\r
+\r
+ unit virtual Equal: function(s1, s2: Stack): Boolean;\r
+ \r
+ end Equal;\r
+\r
+ signal ERR_Full, ERR_Empty, ERR_Axiom1, ERR_Axiom2, ERR_Axiom3,\r
+ ERR_Axiom4;\r
+\r
+ end STACKS_CHECKING;\r
+\r
+\r
+\r
+ (* ----------------------- STACKS generic ------------------------------- *)\r
+\r
+ unit STACKS_Generic: STACKS_Checking class;\r
+ hidden link;\r
+\r
+ unit link: class(e: Elem);\r
+ var next: link;\r
+ end link;\r
+\r
+ unit Stackl: Stack class;\r
+ var top: link\r
+ end Stackl;\r
+\r
+ unit virtual Push: check_Push function: Stackl;\r
+ var aux: link;\r
+ begin\r
+ aux := new Link(e);\r
+ aux.next := s qua Stackl.top;\r
+ result := new Stackl;\r
+ result.top := aux;\r
+ res := result\r
+ end Push;\r
+\r
+ unit virtual Ppush: function(e: Elem, s: Stackl): Stackl;\r
+ var aux: link;\r
+ begin\r
+ aux := new Link(e);\r
+ aux.next := s.top;\r
+ result := new Stackl;\r
+ result.top := aux;\r
+ end Ppush;\r
+\r
+ unit virtual Pop: check_Pop function: Stackl;\r
+ begin\r
+ result := new Stackl;\r
+ result.top := s qua Stackl.top.next;\r
+ res := result;\r
+ end Pop;\r
+\r
+ unit virtual Ppop: function(s: Stackl): Stackl;\r
+ begin\r
+ result := new Stackl;\r
+ result.top := s.top.next;\r
+ end Ppop;\r
+\r
+ unit virtual Top: check_Top function: Elem;\r
+ begin\r
+ result := s qua Stackl.top.e; \r
+ res := result\r
+ end Top;\r
+\r
+ unit virtual Ttop: function(s: Stackl): Elem;\r
+ begin\r
+ result := s.top.e\r
+ end Ttop;\r
+\r
+ unit virtual Empty: function(s: Stackl): Boolean;\r
+ begin\r
+ result := s.top = none\r
+ end empty;\r
+ \r
+ unit virtual Eq: function(e1, e2: Elem): Boolean;\r
+ end Eq;\r
+ \r
+ unit virtual Equal: function(s1, s2: Stackl): Boolean;\r
+ var s3, s4: Stack;\r
+ begin \r
+ result := true; s3 := s1; s4 := s2;\r
+ while not empty(s3) and not empty(s4) and result\r
+ do\r
+ result := eq(Ttop(s3), Ttop(s4));\r
+ s3 := Ppop(s3);\r
+ s4 := Ppop(s4);\r
+ od; \r
+ result := (result and empty(s3) and empty(s4))\r
+ end Equal;\r
+\r
+\r
+\r
+ end STACKS_Generic;\r
+\r
+\r
+\r
+(* ------------------------- MAIN ---------------------------------- *)\r
+\r
+begin\r
+ pref STACKS_Generic block\r
+\r
+ unit mElem: Elem class(i:integer);\r
+ end mElem;\r
+\r
+ unit virtual Eq: function(e1,e2: mElem): Boolean;\r
+ begin\r
+ result := e1.i = e2.i\r
+ end Eq;\r
+\r
+ var e1, e2: mElem,\r
+ i: integer,\r
+ s1, s2: Stackl;\r
+\r
+ handlers\r
+ when ERR_Empty: writeln("stack is empty");\r
+ when ERR_Full: writeln("stack is full");\r
+ when ERR_Axiom1: writeln("Axiom1");\r
+ when ERR_Axiom2: writeln("Axiom2");\r
+ when ERR_Axiom3: writeln("Axiom3");\r
+ when ERR_Axiom4: writeln("Axiom4");\r
+ end handlers;\r
+\r
+ begin\r
+ writeln("program testing stacks and its verification environment");\r
+ s1 := new Stackl;\r
+ writeln("give an integer, ZERO ends");\r
+ do\r
+ readln(i);\r
+ e1 := new mElem(i);\r
+ s1 := push(e1, s1);\r
+ if i=0 then exit fi;\r
+ od;\r
+ s2 := s1;\r
+ do\r
+ if empty(s2)\r
+ then \r
+ exit\r
+ else\r
+ e2 := top(s2);\r
+ s2 := pop(s2);\r
+ writeln(e2.i)\r
+ fi\r
+ od;\r
+ end (* prefixed block *)\r
+end (* of program *)\r
+\r
--- /dev/null
+SOMMET :\r
+a 1 3 10 10\r
+b 1 5 40 10\r
+c 1 5 70 10\r
+d 1 10 90 10\r
+e 1 5 180 10\r
+f 1 1 240 10\r
+g 1 8 10 30\r
+h 1 9 40 30\r
+i 1 9 70 30\r
+k 1 9 180 30\r
+l 1 7 240 30\r
+n 1 8 10 60\r
+o 1 6 40 60\r
+p 1 9 70 60\r
+r 1 5 140 60\r
+s 1 6 180 60\r
+t 1 2 240 60\r
+u 1 8 10 80\r
+v 1 5 20 80\r
+w 1 5 50 80\r
+x 1 7 70 80\r
+z 1 4 10 100\r
+( 1 6 20 100\r
+) 1 6 50 100\r
+< 1 6 70 100\r
+> 1 2 140 100\r
+.\r
+ARCS :\r
+1 a b 2 5 1 1\r
+2 b c 2 5 1 1\r
+3 c d 2 5 1 1\r
+4 d e 2 5 1 1\r
+5 e f 2 5 1 1\r
+6 a g 2 5 1 1\r
+7 b h 2 5 1 1\r
+8 c i 2 5 1 1\r
+10 e k 2 5 1 1\r
+11 f l 2 5 1 1\r
+12 g h 2 5 1 1\r
+13 h i 2 5 1 1\r
+14 i k 2 5 1 1\r
+16 k l 2 5 1 1\r
+17 g n 2 5 1 1\r
+19 h o 2 5 1 1\r
+21 i p 2 5 1 1\r
+23 k s 2 5 1 1\r
+24 l t 2 5 1 1\r
+28 n o 2 5 1 1\r
+29 o p 2 5 1 1\r
+30 p r 2 5 1 1\r
+32 r s 2 5 1 1\r
+33 s t 2 5 1 1\r
+34 n u 2 5 1 1\r
+35 p x 2 5 1 1\r
+37 r > 2 5 1 1\r
+38 u v 2 5 1 1\r
+39 v w 2 5 1 1\r
+40 w x 2 5 1 1\r
+41 u z 2 5 1 1\r
+42 v ( 2 5 1 1\r
+43 w ) 2 5 1 1\r
+44 x < 2 5 1 1\r
+47 z ( 2 5 1 1\r
+48 ( ) 2 5 1 1\r
+49 ) < 2 5 1 1\r
+50 < > 2 5 1 1\r
--- /dev/null
+program ville;\r
+\r
+(***************************************************************************)\r
+(* Structure d une place de parking *)\r
+(***************************************************************************)\r
+\r
+Unit Place : class (N : integer );\r
+var P1 : arrayof boolean;\r
+Begin\r
+ array P1 dim (1:N);\r
+End Place;\r
+\r
+(***************************************************************************)\r
+(* Structure de la liste des arc qui peuvent etre atteind *)\r
+(***************************************************************************)\r
+\r
+Unit Liste : class;\r
+var pointeur: Arcs,\r
+ suivante: Liste;\r
+end Liste;\r
+\r
+(***************************************************************************)\r
+(* Structure des arcs *)\r
+(***************************************************************************)\r
+\r
+Unit Arcs : class;\r
+var Numero : integer, (* Identification de l'arc *)\r
+ Initial : Sommets, (* Sommet initial *)\r
+ Final : Sommets, (* Sommet final *)\r
+ Sens : integer, (* Sens de circulation *)\r
+ Distance: integer, (* Distance de initial a final*)\r
+ NbvoieIF: integer, (* Nombre de voie dans le sens 1 *)\r
+ NbvoieFI: integer, (* Nombre de voie dans le sens -1 *)\r
+ Suivants: Arcs; (* Pointeur sur les suivants *)\r
+End Arcs;\r
+\r
+(***************************************************************************)\r
+(* Structure des sommets *)\r
+(***************************************************************************)\r
+\r
+Unit Sommets : class;\r
+var Nom : char, (* Nom du sommet *) \r
+ typecar : integer, (* Type carrefour 0:feu , 1:priorite , 2:stop *)\r
+ Ligne : integer, (* Correspond a la position en Y sur ecran *)\r
+ Colonne : integer, (* Correspond a la position en X sur ecran *)\r
+ etat : integer, (* Etat du carrefour *)\r
+ ptrarc : Liste, (* Pointeur sur la liste pointant sur les arcs *)\r
+ suivant : Sommets; (* Pointeur sur les suivants *)\r
+End Sommets;\r
+\r
+(***************************************************************************)\r
+(* Procedure creant la liste des Sommets *)\r
+(* Ici il y a juste creation d un liste simple de sommet en mode pile *)\r
+(***************************************************************************)\r
+\r
+Unit CreeSomm : procedure( f: file);\r
+var Noeud : Sommets,\r
+ tampon: char,\r
+ arret : boolean;\r
+\r
+Begin\r
+ readln(f);\r
+ arret := false;\r
+ while not arret \r
+ do\r
+ read(f,tampon);\r
+ if ( tampon <> '.') then\r
+ Noeud := new Sommets;\r
+ Noeud.Nom := tampon;\r
+ read(f,Noeud.typecar);\r
+ read(f,Noeud.colonne);\r
+ readln(f,Noeud.ligne);\r
+ Noeud.etat := 0;\r
+ Noeud.ptrarc := none;\r
+ Noeud.Suivant := RaciSomm;\r
+ RaciSomm := Noeud;\r
+ else arret := true;\r
+ fi\r
+ od;\r
+End CreeSomm;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure affichant chaque sommet ainsi que les arcs que l'on peut *)\r
+(* prendre depuis ce sommet en considerant les sens de circulation etc... *)\r
+(***************************************************************************)\r
+Unit ParcSomm : procedure;\r
+var Noeud : Sommets;\r
+var parcours : Liste;\r
+Begin\r
+ Noeud := RaciSomm;\r
+ while (Noeud <> none)\r
+ do\r
+ write("Nom: ");\r
+ writeln(Noeud.Nom);\r
+ writeln("X : ",Noeud.Colonne);\r
+ writeln("Y : ",Noeud.ligne);\r
+ parcours := Noeud.ptrarc;\r
+ while (parcours <> none )\r
+ do\r
+ writeln("Arc: ",parcours.pointeur.Numero);\r
+ parcours := parcours.suivante;\r
+ od;\r
+ Noeud := Noeud.suivant;\r
+ od;\r
+End ParcSomm;\r
+\r
+Unit ParcArc : procedure;\r
+var Noeud : Arcs;\r
+Begin\r
+ Noeud := RaciArcs;\r
+ while (Noeud <> none)\r
+ do\r
+ write("Arc: ");\r
+ writeln(Noeud.Numero);\r
+ writeln("Initial:",Noeud.Initial.Nom);\r
+ writeln("Coordonnees:",Noeud.Initial.Ligne,",",Noeud.Initial.Colonne);\r
+ writeln("Final:",Noeud.Final.Nom);\r
+ writeln("Coordonnees:",Noeud.Final.Ligne,",",Noeud.Final.Colonne);\r
+ Noeud := Noeud.suivants;\r
+ od;\r
+End ParcArc;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure creant la liste des Arc *)\r
+(* Ici on cree la liste des Arc sur la base d'une pile, puis il y a *)\r
+(* rattachement des pointeurs final et initial avec la liste des sommets *)\r
+(* et ce grace a la procedure rattache. *) \r
+(***************************************************************************)\r
+\r
+Unit CreeArcs : procedure( f: file);\r
+var Noeud : Arcs;\r
+var aux1 : char;\r
+var aux2 : char;\r
+var aux3 : char;\r
+Begin\r
+ readln(f);\r
+ readln(f);\r
+ while ( not(eof(f)))\r
+ do\r
+ Noeud := new Arcs;\r
+ read(f,Noeud.Numero);\r
+ read(f,aux3);\r
+ read(f,aux1);\r
+ read(f,aux3);\r
+ read(f,aux2);\r
+ read(f,aux3);\r
+ read(f,Noeud.Sens);\r
+ read(f,Noeud.distance);\r
+ read(f,Noeud.NbvoieIF);\r
+ readln(f,Noeud.NbvoieFI);\r
+ Noeud.Initial := none;\r
+ Noeud.Final := none;\r
+ Noeud.Suivants:= RaciArcs;\r
+ RaciArcs := Noeud;\r
+ Call rattache(Noeud,aux1,aux2);\r
+ od;\r
+End CreeArcs;\r
+\r
+(***************************************************************************)\r
+(* Rattachement du pointeur arc avec le sommet *)\r
+(* Cette procedure rattache les pointeurs final et initial des arcs avec *)\r
+(* un sommet de la liste des sommets. *)\r
+(* Puis il y a la procedure creant la liste des arcs que l'on peut *)\r
+(* emprunter depuis ce sommet. Cette procedure est appele ici. *) \r
+(* Pour l appelle de cette procedure RattaListe nous verifions le sens de *)\r
+(* circulation dans les arcs, en effet des arcs ne peuvent pas etre pris a *)\r
+(* partir de certain sommets, donc il ne doivent pas figurer dans cette *)\r
+(* liste( Sens interdits ). *)\r
+(***************************************************************************)\r
+Unit Rattache : procedure ( inout Noeud : Arcs ; aux1,aux2:char);\r
+var Parcours : Sommets;\r
+\r
+begin\r
+ Parcours := RaciSomm;\r
+ while((Parcours<>none) and (Parcours.Nom<>aux1) and (Parcours.Nom<>aux2))\r
+ do\r
+ Parcours := Parcours.suivant;\r
+ od;\r
+ if Parcours.Nom = aux1\r
+ then\r
+ Noeud.Initial := Parcours;\r
+ if Noeud.Sens <> -1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else if Parcours.Nom = aux2 \r
+ then\r
+ Noeud.Final := Parcours; \r
+ if Noeud.Sens <> 1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi\r
+ else\r
+ write("ERREUR de rattachement initial");\r
+ exit;\r
+ fi;\r
+ fi;\r
+ Parcours := Parcours.suivant;\r
+ while((Parcours<>none) and (Parcours.Nom<>aux1) and (Parcours.Nom<>aux2))\r
+ do\r
+ Parcours := Parcours.suivant;\r
+ od;\r
+ if Parcours.Nom = aux1\r
+ then\r
+ Noeud.Initial := Parcours; \r
+ if Noeud.Sens <> -1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else if Parcours.Nom = aux2 \r
+ then\r
+ Noeud.final := parcours;\r
+ if Noeud.Sens <> 1\r
+ then\r
+ Call rattaListe(Parcours,Noeud);\r
+ fi;\r
+ else\r
+ write("ERREUR de rattachement du final");\r
+ fi;\r
+ fi;\r
+end rattache;\r
+\r
+(***************************************************************************)\r
+(* Rattachement des sommets a la liste des arc qui peuvent etres atteinds *)\r
+(***************************************************************************)\r
+Unit RattaListe : procedure (inout NoeudSom : sommets; NoeudArc : Arcs);\r
+var Noeud : Liste;\r
+\r
+begin\r
+ Noeud := new Liste;\r
+ Noeud.suivante := NoeudSom.ptrarc;\r
+ Noeud.pointeur := NoeudArc;\r
+ NoeudSom.ptrarc := Noeud;\r
+End RattaListe;\r
+\r
+\r
+(***************************************************************************)\r
+(* Procedure de remplissage de la structure *)\r
+(***************************************************************************)\r
+\r
+Unit Remplie : procedure;\r
+var fichier : file;\r
+begin\r
+ open (fichier,text,unpack("Ville1.doc"));\r
+ call reset (fichier);\r
+ Call CreeSomm(fichier);\r
+ Call CreeArcs(fichier);\r
+ Call ParcSomm;\r
+end Remplie;\r
+\r
+(***************************************************************************)\r
+(* PROGRAMME PRINCIPAL *)\r
+(***************************************************************************)\r
+\r
+var RaciSomm : Sommets;\r
+var RaciArcs : Arcs;\r
+\r
+Begin\r
+ Call Remplie;\r
+End ville;\r
--- /dev/null
+Program systemefenetrage;\r
+\r
+(***************************************************************************)\r
+(* Programme de syst\8ame de fenetrage avec boutons et gestion de la souris *)\r
+(* PATAUD Fr\82d\82ric & PEYRAT Fran\87ois 1993/1994 *)\r
+(***************************************************************************)\r
+\r
+Begin\r
+Pref iiuwgraph block\r
+ \r
+ Begin\r
+ Pref mouse block\r
+\r
+ Const Noir = 0,\r
+ Bleu = 1,\r
+ Vert = 2,\r
+ Cyan = 3,\r
+ Rouge = 4,\r
+ Magenta = 5,\r
+ Marron = 6,\r
+ GrisClair = 7,\r
+ GrisFonce = 8,\r
+ BleuClair = 9,\r
+ VertClair =10,\r
+ CyanClair =11,\r
+ RougeClair =12,\r
+ MagentaClair=13,\r
+ Jaune =14,\r
+ Blanc =15;\r
+ \r
+ Const Touche_F1 =-59,\r
+ Touche_F2 =-60,\r
+ Touche_F3 =-61,\r
+ Touche_F4 =-62,\r
+ Touche_F5 =-63,\r
+ Touche_F6 =-64,\r
+ Touche_F7 =-65,\r
+ Touche_F8 =-66,\r
+ Touche_F9 =-67,\r
+ Touche_F10 =-68,\r
+ Touche_F11 =-69,\r
+ Touche_F12 =-70;\r
+\r
+ Const SIZEX = 639,\r
+ SIZEY = 348;\r
+\r
+ Var code : integer,\r
+ COOR_X : integer, (*coordonn\82e relative en X dans la fenetre maine*)\r
+ COOR_Y : integer, (*coordonn\82e relative en Y dans la fenetre maine*)\r
+ W : Maine,\r
+ B : arrayof Racc,\r
+ M : arrayof Menu,\r
+ clics : cliquer;\r
+\r
+ \r
+(***************************************************************************)\r
+(* definition des procedures d'utilitaires graphiques *)\r
+(***************************************************************************)\r
+ \r
+ Unit Line : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y2);\r
+ End Line;\r
+\r
+ Unit Rectangle : procedure (x1,y1,x2,y2,c : integer);\r
+ Begin\r
+ call color(c);\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1);\r
+ End Rectangle;\r
+ \r
+ Unit Rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
+ var i : integer;\r
+ Begin\r
+ for i:=y1 to y2\r
+ do\r
+ call Line(x1,i,x2,i,c);\r
+ od\r
+ End Rectanglef;\r
+\r
+(***************************************************************************)\r
+(* definition des classes d'\82l\82ments des listes *)\r
+(***************************************************************************)\r
+ \r
+ Unit Elmt : class(id : integer);\r
+ End Elmt;\r
+ \r
+ Unit elm : Elmt class(x1,y1,x2,y2 :integer);\r
+ End elm;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Bottons : Elmt class(x1,y1,x2,y2 : integer); \r
+ (* x2-x1 et y2-y1 doit au mini etre de 8*)\r
+ (* x1,y1 : integer coordonn\82es du point haut gauche *)\r
+ (* x2,y2 : integer coordonn\82es du point bas droit *)\r
+ Var etat : boolean; (* true si bouton enable *)\r
+ \r
+ Unit affiche : procedure;\r
+ Begin\r
+ call Line(x1,y1,x2,y1,Blanc); (* Lignes en blanc *) \r
+ call Line(x1,y1+1,x2-1,y1+1,Blanc);\r
+ call Line(x1,y1,x1,y2,Blanc);\r
+ call Line(x1+1,y1+2,x1+1,y2-1,Blanc);\r
+ call Line(x1+1,y2,x2,y2,GrisFonce); (* Lignes en gris fonce *)\r
+ call Line(x1+2,y2-1,x2,y2-1,GrisFonce);\r
+ call Line(x2,y2,x2,y1+1,GrisFonce);\r
+ call Line(x2-1,y2-1,x2-1,y1+2,GrisFonce);\r
+ call Rectanglef(x1+2,y1+2,x2-2,y2-2,GrisClair); (* centre en gris *)\r
+ call AfficheSuite;\r
+ End affiche;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ End;\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ End;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ End;\r
+ \r
+ End Bottons;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Menu derivant de Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Menu : Bottons class;\r
+ Var cnom : integer, (* couleur du nom du bouton *) \r
+ nom : string; (* nom du bouton *)\r
+ \r
+ Unit affiche_nom : procedure;\r
+ Begin \r
+ call move(x1+5,y1+(y2-y1)/4+1);\r
+ call color(cnom);\r
+ call outstring(nom);\r
+ End affiche_nom;\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ var e : elm;\r
+ Begin\r
+ cnom:=RougeClair;\r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Insert(e);\r
+ call affiche_nom;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ var e : elm;\r
+ Begin\r
+ cnom:=Rouge;\r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Delete(e);\r
+ call affiche_nom;\r
+ End bot_disable;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ Begin\r
+ if (etat) \r
+ then call bot_enable;\r
+ else call bot_disable;\r
+ fi;\r
+ End AfficheSuite;\r
+\r
+ End Menu;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Racc derivant de Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Racc : Bottons class (procedure sprite(x1,y1,x2,y2 :integer));\r
+\r
+ Unit virtual bot_enable : procedure;\r
+ var e : elm;\r
+ Begin \r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Insert(e);\r
+ call sprite(x1,y1,x2,y2);\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ var e : elm;\r
+ Begin \r
+ e:=new elm(id,x1,y1,x2,y2);\r
+ call clics.Delete(e);\r
+ call sprite(x1,y1,x2,y2);\r
+ End bot_disable;\r
+\r
+ Unit virtual AfficheSuite : procedure;\r
+ Begin\r
+ if etat\r
+ then call bot_enable;\r
+ else call bot_disable;\r
+ fi;\r
+ End AfficheSuite;\r
+\r
+ End Racc;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Windows *)\r
+(***************************************************************************)\r
+ \r
+ Unit Windows : class(x1,y1,x2,y2 : integer); \r
+ (* x2-x1 et y2-y1 doit au mini etre 33 *)\r
+ Var numero : integer, (* numero d'identification de la fenetre *)\r
+ cborder : integer; (* couleur du pourtour *)\r
+ \r
+ Unit affiche : procedure;\r
+ Begin\r
+ call Line(x1,y1,x2,y1,cborder); (* lignes haut *)\r
+ call Line(x1,y1+1,x2,y1+1,cborder);\r
+ call Line(x1,y1,x1,y2,cborder); (* lignes gauche *)\r
+ call Line(x1+1,y1,x1+1,y2,cborder);\r
+ call Line(x2,y1,x2,y2,cborder); (* Lignes droite *)\r
+ call Line(x2-1,y1,x2-1,y2,cborder);\r
+ call Line(x1,y2,x2,y2,cborder); (* Lignes bas *)\r
+ call Line(x1,y2-1,x2,y2-1,cborder);\r
+ call Line(x1+16,y1,x1+16,y1+1,Noir); (* Lignes noires *)\r
+ call Line(x2-16,y1,x2-16,y1+1,Noir);\r
+ call Line(x1+16,y2,x1+16,y2-1,Noir);\r
+ call Line(x2-16,y2,x2-16,y2-1,Noir);\r
+ call Line(x1,y1+16,x1+1,y1+16,Noir);\r
+ call Line(x1,y2-16,x1+1,y2-16,Noir);\r
+ call Line(x2,y1+16,x2-1,y1+16,Noir);\r
+ call Line(x2,y2-16,x2-1,y2-16,Noir);\r
+ call AffSuite;\r
+ End affiche;\r
+ \r
+ Unit virtual AffSuite : procedure;\r
+ End AffSuite;\r
+\r
+ Unit gestionnaire : function : integer;\r
+ Var l,r,c : boolean,\r
+ x,y : integer,\r
+ rep : integer,\r
+ nbbot : integer;\r
+ Begin\r
+ do\r
+ call getpress(0,x,y,nbbot,l,r,c);\r
+ if l\r
+ then result:=clics.Appartient(x,y); exit;\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep>=Touche_F5 and rep<=Touche_F1) \r
+ then result:=-rep-58; exit;\r
+ fi;\r
+ od;\r
+ End gestionnaire;\r
+\r
+\r
+ End Windows;\r
+\r
+(***************************************************************************)\r
+(* definition de main d\82rivant de la classe Windows *)\r
+(***************************************************************************)\r
+ \r
+ Unit Maine : Windows class;\r
+ var cnom : integer, (* couleur du nom de la fenetre *)\r
+ nom : string, (* nom de la fenetre *)\r
+ cbande : integer, (* couleur de la bande du nom de la fenetre *)\r
+ Bout : Listbot, (* liste des boutons rattach\82s \85 la fenetre *)\r
+ Lwind : ListW, (* liste des fenetres filles *)\r
+ Horiz : AccelerateH, (* accelerateur horizontal *)\r
+ Verti : AccelerateV; (* accelerateur vertical *)\r
+\r
+ var i :integer;\r
+\r
+ Unit virtual AffSuite : procedure;\r
+ Begin\r
+ call Rectanglef(x1+17,y1+2,x2-17,y1+15,cbande);\r
+ call Rectanglef(x1+3,y1+17,x2-3,y1+33,cbande);\r
+ call move(x1+(x2-x1)/3,y1+5);\r
+ call color(cnom);\r
+ call outstring(nom);\r
+ if (Horiz<>none)\r
+ then call Horiz.affiche;\r
+ fi;\r
+ if (Verti<>none)\r
+ then call Verti.affiche;\r
+ fi;\r
+ Bout.Courant:=Bout.head;\r
+ while(Bout.Courant<>none)\r
+ do\r
+ call Bout.Courant.data qua Bottons.affiche;\r
+ Bout.Courant:=Bout.Courant.next;\r
+ od;\r
+ End AffSuite;\r
+\r
+\r
+ Unit iconify : procedure;\r
+ var i : integer,\r
+ l,r,c : boolean,\r
+ x,y : integer,\r
+ nboot : integer,\r
+ rep : integer;\r
+\r
+ Begin\r
+ call cls;\r
+ kill(clics);\r
+ call rectangle(1,SIZEY-40,40,SIZEY,BleuClair);\r
+ call rectangle(2,SIZEY-39,39,SIZEY-1,BleuClair);\r
+ call move(5,SIZEY-20);\r
+ call outstring("Root");\r
+ call showcursor;\r
+ do\r
+ call getpress(0,x,y,nboot,l,r,c);\r
+ if l \r
+ then if(x>=1 and x<=40 and y<=SIZEY and y>=SIZEY-40)\r
+ then exit;\r
+ fi;\r
+ fi;\r
+ rep:=inkey;\r
+ if (rep=13) (* validation *)\r
+ then exit;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ call cls;\r
+ clics:=new cliquer;\r
+ call W.affiche;\r
+ End iconify;\r
+\r
+ End Maine;\r
+\r
+(***************************************************************************)\r
+(* definition de Accelerate d\82rivant des classes Windows et Bottons *)\r
+(***************************************************************************)\r
+ \r
+ Unit Accelerate : Bottons class;\r
+ Var Bs : arrayof Racc,\r
+ PosX : integer,\r
+ PosY : integer,\r
+ LX,LY: integer;\r
+ \r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ End AfficheSuite;\r
+ \r
+ Unit virtual bot_enable : procedure;\r
+ Begin\r
+ call W.Bout.Insert(Bs(1));\r
+ call W.Bout.Insert(Bs(2));\r
+ Call W.Bout.Insert(Bs(3));\r
+ etat:=True;\r
+ End bot_enable;\r
+\r
+ Unit virtual bot_disable : procedure;\r
+ Begin\r
+ call W.Bout.Delete(Bs(1));\r
+ call W.Bout.Delete(Bs(2));\r
+ call W.Bout.Delete(Bs(3));\r
+ etat:=False;\r
+ End bot_disable;\r
+\r
+ Unit virtual Deplace : procedure;\r
+ End Deplace;\r
+ \r
+ Begin \r
+ inner;\r
+ call bot_enable;\r
+ End Accelerate;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateH d\82rivant de Accelerate *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateH : Accelerate class;\r
+ Var x : integer, \r
+ MaxX : integer,\r
+ MinX : integer;\r
+ \r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ Begin\r
+ call Rectanglef(x1+18,y1+3,x2-18,y2-3,Noir);\r
+ MaxX:=x2-18-LX;\r
+ MinX:=x1+18;\r
+ End AfficheSuite;\r
+\r
+ Unit virtual DeplacerLeft : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=PosX-5;\r
+ if PosX<MinX\r
+ then PosX:=MinX;\r
+ Bs(1).etat:=False;\r
+ e:=new elm(Bs(1).id,Bs(1).x1,Bs(1).y1,Bs(1).x2,Bs(1).y2);\r
+ call clics.Delete(e);\r
+ kill(e);\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ e:=new elm(Bs(3).id,Bs(3).x1,Bs(3).y1,Bs(3).x2,Bs(3).y2);\r
+ call clics.Insert(e);\r
+ fi;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerLeft;\r
+\r
+ Unit virtual DeplacerRight : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosX:=PosX+5;\r
+ if PosX>MaxX\r
+ then PosX:=MaxX;\r
+ Bs(3).etat:=False;\r
+ e:=new elm(Bs(3).id,Bs(3).x1,Bs(3).y1,Bs(3).x2,Bs(3).y2);\r
+ call clics.Delete(e);\r
+ kill(e);\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ e:=new elm(Bs(1).id,Bs(1).x1,Bs(1).y1,Bs(1).x2,Bs(1).y2);\r
+ call clics.Insert(e);\r
+ fi;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerRight;\r
+\r
+ Begin \r
+ array Bs dim (1:3);\r
+ Bs(1):=new Racc(id+1,x1+2,y1+2,x1+15,y1+15,spr_right);\r
+ Bs(1).etat:=True;\r
+ x:=(x2-x1)/2;\r
+ PosX:=x-5;\r
+ PosY:=y1+3;\r
+ LX:=11;\r
+ LY:=y2-y1-6;\r
+ Bs(2):=new Racc(id+2,PosX,PosY,PosX+LX,PosY+LY,spr_point);\r
+ Bs(2).etat:=True;\r
+ Bs(3):=new Racc(id+3,x2-15,y2-15,x2-2,y2-2,spr_left);\r
+ Bs(3).etat:=True;\r
+ End AccelerateH;\r
+\r
+(***************************************************************************)\r
+(* definition de AccelerateV d\82rivant de Accelerate *)\r
+(***************************************************************************)\r
+\r
+ Unit AccelerateV : Accelerate class;\r
+ Var y : integer,\r
+ MaxY : integer,\r
+ MinY : integer; \r
+\r
+ Unit virtual AfficheSuite : procedure; (* descend de bottons *)\r
+ Begin\r
+ call Rectanglef(x1+3,y1+18,x2-3,y2-18,Noir);\r
+ MaxY:=y2-18-LY;\r
+ MinY:=y1+18;\r
+ End AfficheSuite;\r
+ \r
+ Unit virtual DeplacerUp : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=PosY-5;\r
+ if PosY<MinY\r
+ then PosY:=MinY;\r
+ Bs(1).etat:=False;\r
+ e:=new elm(Bs(1).id,Bs(1).x1,Bs(1).y1,Bs(1).x2,Bs(1).y2);\r
+ call clics.Delete(e);\r
+ kill(e);\r
+ fi;\r
+ if not (Bs(3).etat)\r
+ then Bs(3).etat:=True;\r
+ e:=new elm(Bs(3).id,Bs(3).x1,Bs(3).y1,Bs(3).x2,Bs(3).y2);\r
+ call clics.Insert(e);\r
+ fi;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerUp;\r
+\r
+ Unit virtual DeplacerDown : procedure;\r
+ var e : elm;\r
+ Begin\r
+ call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir);\r
+ PosY:=PosY+5;\r
+ if PosY>MaxY\r
+ then PosY:=MaxY;\r
+ Bs(3).etat:=False;\r
+ e:=new elm(Bs(3).id,Bs(3).x1,Bs(3).y1,Bs(3).x2,Bs(3).y2);\r
+ call clics.Delete(e);\r
+ kill(e);\r
+ fi;\r
+ if not (Bs(1).etat)\r
+ then Bs(1).etat:=True;\r
+ e:=new elm(Bs(1).id,Bs(1).x1,Bs(1).y1,Bs(1).x2,Bs(1).y2);\r
+ call clics.Insert(e);\r
+ fi;\r
+ Bs(2).x1:=PosX; Bs(2).y1:=PosY;\r
+ Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY;\r
+ call Bs(2).affiche;\r
+ End DeplacerDown;\r
+\r
+\r
+ Begin\r
+ array Bs dim (1:3);\r
+ Bs(1):=new Racc(id+1,x1+2,y1+2,x1+15,y1+15,spr_upper);\r
+ Bs(1).etat:=True;\r
+ y:=(y2-y1)/2;\r
+ PosX:=x1+3;\r
+ PosY:=y-5;\r
+ LX:=x2-x1-6;\r
+ LY:=11;\r
+ Bs(2):=new Racc(id+2,PosX,PosY,PosX+LX,PosY+LY,spr_point);\r
+ Bs(2).etat:=True;\r
+ Bs(3):=new Racc(id+3,x2-15,y2-15,x2-2,y2-2,spr_lower);\r
+ Bs(3).etat:=True;\r
+ End AccelerateV;\r
+\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Son d\82rivant des classes Windows et elmt *)\r
+(***************************************************************************)\r
+ \r
+ Unit Son : Elmt coroutine;\r
+ Var aa : Windows,\r
+ Horiz : AccelerateH, (* accelerateur horizontal *)\r
+ Verti : AccelerateV; (* accelerateur vertical *)\r
+ Begin\r
+ pref Windows(0,0,0,0) block\r
+ begin\r
+ aa:=this Windows;\r
+\r
+ (* instructions *)\r
+ detach;\r
+\r
+ end\r
+ End Son;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Ensemble (c'est une liste) *)\r
+(***************************************************************************)\r
+\r
+ Unit Ensemble : class;\r
+ Var Head : Node,\r
+ Courant : Node,\r
+ Last : Node;\r
+\r
+ Unit Node : class(data : elmt);\r
+ Var next : Node;\r
+ End Node;\r
+ \r
+ Unit virtual egalite : function (x,y : elmt) :boolean;\r
+ End egalite;\r
+\r
+ Unit Empty : function : boolean; \r
+ Begin\r
+ if Head=none\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End;\r
+\r
+ Unit Member : function (n : elmt) : boolean;\r
+ Var bl : boolean,\r
+ saveCou : Node;\r
+ Begin\r
+ Courant:=Head;\r
+ saveCou:=Courant;\r
+ bl:=False;\r
+ While (Courant<>none)\r
+ do\r
+ if not egalite(Courant.data,n)\r
+ then saveCou:=Courant; Courant:=Courant.next;\r
+ else bl:=True; exit;\r
+ fi;\r
+ od;\r
+ Courant:=SaveCou;\r
+ result:=bl;\r
+ End Member;\r
+\r
+ Unit Insert : procedure (n : elmt);\r
+ Var bl : boolean;\r
+ Begin\r
+ bl:=Member(n);\r
+ if not bl\r
+ then if Empty\r
+ then Head:=new Node(n); Last:=Head;\r
+ else Last.next:=new Node(n);\r
+ Last:=Last.next;\r
+ fi;\r
+ fi;\r
+ End Insert;\r
+\r
+ Unit Delete : procedure (n : elmt);\r
+ Var bl : boolean,\r
+ flag : Node;\r
+ Begin \r
+ bl:=Member(n);\r
+ if bl\r
+ then flag:=Courant.next; \r
+ if flag=Last\r
+ then Last:=Courant; courant.next:=none; kill(flag);\r
+ else courant.next:=Courant.next.next; kill(flag);\r
+ fi;\r
+ fi;\r
+ End Delete;\r
+\r
+ End Ensemble;\r
+ \r
+(***************************************************************************)\r
+(* definition de la classe cliquer derivant de la classe ensemble *) \r
+(***************************************************************************)\r
+ \r
+ Unit cliquer : Ensemble class; \r
+ \r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id)=(y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+ \r
+ Unit Appartient : function(x,y : integer) : integer;\r
+ var bl : boolean;\r
+ Begin\r
+ bl:=False;\r
+ Courant:=Head;\r
+ while (Courant<>none)\r
+ do\r
+ if(x<(Courant.data qua elm.x2) and x>(Courant.data qua elm.x1) and \r
+ y<(Courant.data qua elm.y2) and y>(Courant.data qua elm.y1))\r
+ then bl:=True; exit;\r
+ else Courant:=Courant.next;\r
+ fi;\r
+ od;\r
+ if bl\r
+ then result:=Courant.data qua elm.id;\r
+ else result:=-1;\r
+ fi;\r
+ End Appartient;\r
+\r
+ End cliquer;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe Listbot d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit Listbot : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x.id) = (y.id)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+\r
+ End Listbot;\r
+\r
+(***************************************************************************)\r
+(* definition de la classe ListW d\82rivant de ensemble *)\r
+(***************************************************************************)\r
+ \r
+ Unit ListW : Ensemble class;\r
+\r
+ Unit virtual egalite : function (x,y : elmt) : boolean;\r
+ Begin\r
+ if (x qua Son.aa qua Windows.numero) \r
+ = (y qua Son.aa qua Windows.numero)\r
+ then result:=True;\r
+ else result:=False;\r
+ fi;\r
+ End egalite;\r
+\r
+ End ListW;\r
+\r
+(***************************************************************************)\r
+(* procedure d'affichage des sprites des boutons *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit spr_upper : procedure(x1,y1,x2,y2 : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call Line(x1+x-i/2,y1+y/2+i,x1+x+i/2,y1+y/2+i,Noir);\r
+ od\r
+ End spr_upper;\r
+\r
+(***************************************************************************)\r
+ Unit spr_lower : procedure(x1,y1,x2,y2 : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to y\r
+ do\r
+ call Line(x1+x-i/2,y2-y/2-i,x1+x+i/2,y2-y/2-i,Noir);\r
+ od\r
+ End spr_lower;\r
+\r
+(***************************************************************************)\r
+ Unit spr_left : procedure(x1,y1,x2,y2 : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call Line(x2-x/2-i,y1+y-i/2,x2-x/2-i,y1+y+i/2,Noir);\r
+ od\r
+ End spr_left;\r
+\r
+(***************************************************************************)\r
+ Unit spr_right : procedure(x1,y1,x2,y2 : integer);\r
+ var i,x,y : integer;\r
+ Begin\r
+ x:=(x2-x1)/2;\r
+ y:=(y2-y1)/2;\r
+ for i:=1 to x\r
+ do\r
+ call Line(x1+x/2+i,y1+y-i/2,x1+x/2+i,y1+y+i/2,Noir);\r
+ od\r
+ End spr_right;\r
+\r
+(***************************************************************************)\r
+ Unit spr_close : procedure(x1,y1,x2,y2 : integer);;\r
+ var y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ call Rectanglef(x1+3,y1+y-1,x2-3,y1+y+1,Noir);\r
+ End spr_close;\r
+\r
+(***************************************************************************)\r
+ Unit spr_point : procedure(x1,y1,x2,y2 : integer);;\r
+ var x,y : integer;\r
+ Begin\r
+ y:=(y2-y1)/2;\r
+ x:=(x2-x1)/2;\r
+ call Rectanglef(x1+x-1,y1+y-1,x1+x+1,y1+y+1,Noir);\r
+ End spr_point;\r
+\r
+(***************************************************************************)\r
+(* procedure de gestion des boutons *)\r
+(***************************************************************************)\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Load : procedure;\r
+ Const Largeur=200,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ savcli : cliquer;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ fenet:=new Son(20); (* identite = 20 *)\r
+ fenet.aa.x1:=x-Largeur/2;\r
+ fenet.aa.y1:=y-Hauteur/2;\r
+ fenet.aa.x2:=x+Largeur/2;\r
+ fenet.aa.y2:=y+Hauteur/2;\r
+ fenet.aa.numero:=10;\r
+ savcli:=clics; (* on sauvegarde l'ensemble des zones de clics *)\r
+ clics:=none;\r
+ call fenet.aa.affiche;\r
+ End Bot_Load;\r
+\r
+(***************************************************************************)\r
+ Unit Bot_Quit : procedure;\r
+ Const Largeur=200,\r
+ Hauteur=100;\r
+ Var fenet : Son,\r
+ x,y : integer,\r
+ savcli : cliquer;\r
+ Begin\r
+ x:=(W.x2-W.x1)/2;\r
+ y:=(W.y2-W.y1)/2;\r
+ fenet:=new Son(30); (* identite = 30 *)\r
+ fenet.aa.x1:=x-Largeur/2;\r
+ fenet.aa.y1:=y-Hauteur/2;\r
+ fenet.aa.x2:=x+Largeur/2;\r
+ fenet.aa.y2:=y+Hauteur/2;\r
+ fenet.aa.numero:=10;\r
+ savcli:=clics; (* on sauvegarde l'ensemble des zones de clics *)\r
+ clics:=none;\r
+ call fenet.aa.affiche;\r
+ End Bot_Quit;\r
+\r
+(***************************************************************************)\r
+(* P R O G R A M M E P R I N C I P A L *)\r
+(***************************************************************************)\r
+ Begin\r
+ call gron(4);\r
+ \r
+ clics:=new cliquer; (* ensemble des zones de clic possible *)\r
+\r
+ W:=new Maine(1,1,SIZEX,SIZEY);\r
+ W.numero:=1;\r
+ W.cborder:=BleuClair;\r
+ W.cbande:=GrisClair;\r
+ W.cnom:=BleuClair;\r
+ W.nom:="Simulation de r\82seau routier";\r
+ \r
+ W.Bout:=new ListBot;\r
+ \r
+ array B dim (0:2);\r
+\r
+ B(2):=new Racc(102,W.x2-16,W.y1+2,W.x2-3,W.y1+15,spr_upper);\r
+ B(2).etat:=True;\r
+ call W.Bout.Insert(B(2));\r
+ \r
+ B(1):=new Racc(101,B(2).x1-14,B(2).y1,B(2).x1-1,B(2).y2,spr_lower);\r
+ B(1).etat:=True;\r
+ call W.Bout.Insert(B(1));\r
+ \r
+ B(0):=new Racc(100,W.x1+3,B(1).y1,W.x1+16,B(1).y2,spr_close);\r
+ B(0).etat:=True;\r
+ call W.Bout.Insert(B(0));\r
+\r
+ array M dim (0:4);\r
+\r
+ M(0):=new Menu(1,W.x1+8,W.y1+18,W.x1+50,W.y1+32);\r
+ M(0).nom:="Load";\r
+ M(0).etat:=True;\r
+ call W.Bout.Insert(M(0));\r
+\r
+ M(1):=new Menu(2,W.x1+55,W.y1+18,W.x1+89,W.y1+32);\r
+ M(1).nom:="Run";\r
+ M(1).etat:=False;\r
+ call W.Bout.Insert(M(1));\r
+\r
+ M(2):=new Menu(3,W.x1+94,W.y1+18,W.x1+136,W.y1+32);\r
+ M(2).nom:="Stop";\r
+ M(2).etat:=False;\r
+ call W.Bout.Insert(M(2));\r
+ \r
+ M(3):=new Menu(4,W.x1+141,W.y1+18,W.x1+215,W.y1+32);\r
+ M(3).nom:="Continue";\r
+ M(3).etat:=False;\r
+ call W.Bout.Insert(M(3));\r
+\r
+ M(4):=new Menu(5,W.x1+220,W.y1+18,W.x1+262,W.y1+32);\r
+ M(4).nom:="Quit";\r
+ M(4).etat:=True;\r
+ call W.Bout.Insert(M(4));\r
+ \r
+ W.Horiz:=new AccelerateH(50,W.x1+2,W.y2-18,W.x2-18,W.y2-2);\r
+\r
+ W.Verti:=new AccelerateV(60,W.x2-18,W.y1+34,W.x2-2,W.y2-18);\r
+ \r
+ call W.affiche;\r
+ \r
+ call showcursor;\r
+ do\r
+ code:=W.Gestionnaire;\r
+ call hidecursor;\r
+ case code\r
+ when 1 : call Bot_Load; (* f1 : Load *)\r
+ when 5 : exit; (* f5 : quit *)\r
+ when 51 : call W.Horiz.DeplacerLeft;\r
+ when 53 : call W.Horiz.DeplacerRight;\r
+ when 61 : call W.Verti.DeplacerUp;\r
+ when 63 : call W.verti.DeplacerDown;\r
+ when 100 : exit; (* racc fin *)\r
+ when 101 : call W.iconify;\r
+ esac;\r
+ call showcursor;\r
+ od;\r
+ call hidecursor;\r
+ \r
+ call groff;\r
+ \r
+ end\r
+ end\r
+end.\r
--- /dev/null
+ program philos5;\r
+ \r
+ (********************************************************)\r
+ (* procedure qui efface l'\82cran *)\r
+ (********************************************************)\r
+ UNIT NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J");\r
+ END Newpage;\r
+ \r
+ \r
+ (********************************************************)\r
+ (* Processus gerant l'\82cran pour chaque philosophe *)\r
+ (********************************************************)\r
+ UNIT ecran : iiuwgraph process (n : integer);\r
+ const PI = 3.14159;\r
+ var compteur : integer,\r
+ xf, yf, xa, ya, ra, r, i : integer,\r
+ angle : real;\r
+ \r
+ (********************************************************)\r
+ (* procedure qui dessine une fourchette \85 l'\82cran *)\r
+ (********************************************************)\r
+ UNIT fourchette : procedure(num_phi, o, couleur : integer);\r
+ var r1, r2, r3, r4, x, y : integer,\r
+ angle : real;\r
+ begin\r
+ call color(couleur);\r
+ r1 := 30;\r
+ r2 := 15;\r
+ r3 := 15;\r
+ r4 := 15;\r
+ angle := (num_phi * 2 + o) * PI/5;\r
+ x := round((rt-50) *cos(angle) + xt);\r
+ y := round((rt-50) *sin(angle) + yt);\r
+ call move(x,y);\r
+ call draw(round(r1*cos(angle)+x), round(r1*sin(angle)+y));\r
+ call move(x,y);\r
+ call draw(round(r2*cos(angle+3*PI/4)+x),round(r2*sin(angle+3*PI/4)+y));\r
+ call move(x,y);\r
+ call draw(round(r3*cos(angle-3*PI/4)+x),round(r3*sin(angle-3*PI/4)+y));\r
+ call move(x,y);\r
+ call draw(round(r4*cos(angle+PI)+x),round(r4*sin(angle+PI)+y));\r
+ call color(7);\r
+ END fourchette;\r
+ \r
+ \r
+ (********************************************************)\r
+ (* procedure qui dessine un guardien \85 l'\82cran *)\r
+ (********************************************************)\r
+ \r
+ UNIT Guard : procedure(x,y,c:integer);\r
+ begin\r
+ call color(c);\r
+ call cirb(x, y, 15, 1, 0, 1, 1, 1, 1);\r
+ call move(x,y+15);\r
+ call draw(x,y+50);\r
+ \r
+ call draw(x-25,y+100);\r
+ call move(x,y+50);\r
+ call draw(x+25,y+100);\r
+ call move(x-25,y+25); call draw(x+25,y+25);\r
+ call cirb(x+25,y+25,5,0,0,1,1,1,1);\r
+ call cirb(x-25,y+25,5,0,0,1,1,1,1);\r
+ call move(x+25,y-20); call draw(x+25,y+95);\r
+ end Guard;\r
+ \r
+ (********************************************************)\r
+ (* procedure affichant les bulles dans lesquelles les *)\r
+ (* philosophes pourront \82crire leurs actions *)\r
+ (********************************************************)\r
+ UNIT bulles : procedure(n : integer);\r
+ var x1, x2, x3, y1, y2, y3, num, r1, r2, r3 : integer,\r
+ angle : real;\r
+ begin\r
+ num := n - 1;\r
+ angle := (2*num+1)*PI/5;\r
+ r1 := rt + 5;\r
+ r2 := r1 + 15;\r
+ r3 := r1 + 55;\r
+ x1 := round(r1*cos(angle) + xt);\r
+ y1 := round(r1*sin(angle) + yt);\r
+ x2 := round(r2*cos(angle + PI/64) + xt);\r
+ y2 := round(r2*sin(angle + PI/64) + yt);\r
+ x3 := round(r3*cos(angle - PI/64) + xt);\r
+ y3 := round(r3*sin(angle - PI/64) + yt);\r
+ call cirb(x1, y1, 5, 0, 0, 1, 0, 1, 1);\r
+ call cirb(x2, y2, 10, 0, 0, 1, 0, 1, 1);\r
+ call cirb(x3, y3, 35, 0, 0, 1, 0, 1, 1);\r
+ END bulles;\r
+ \r
+ (********************************************************)\r
+ (* procedure qui affiche les actions des philosophes *)\r
+ (********************************************************)\r
+ UNIT actionp : procedure(n, action : integer);\r
+ var x1, x2, x3, y1, y2, y3, num, r1, r2, r3, i, j : integer,\r
+ angle : real;\r
+ begin\r
+ num := n - 1;\r
+ angle := (2*num+1)*PI/5;\r
+ r1 := rt + 5;\r
+ r3 := r1 + 55;\r
+ x3 := round(r3*cos(angle - PI/64) + xt);\r
+ y3 := round(r3*sin(angle - PI/64) + yt);\r
+ j := x3 - 32;\r
+ i := y3 - 5;\r
+ call move(j,i);\r
+ case action\r
+ when 1: call outstring(" PENSER ");\r
+ when 2: call outstring(" RENTRER");\r
+ when 3: call outstring(" MANGER ");\r
+ \r
+ when 4: call outstring(" SORTIR ");\r
+ when 5: call outstring(" ANORMAL");\r
+ when 6: call outstring("G RENDUE");\r
+ call fourchette(n,0,14);\r
+ \r
+ \r
+ when 7: call outstring("D RENDUE");\r
+ call fourchette(n-1,0,14);\r
+ \r
+ \r
+ when 8: call outstring(" PARTIR ");\r
+ when 9: call outstring("G PRISE ");\r
+ call fourchette(n ,0,0);\r
+ \r
+ \r
+ when 10: call outstring("D PRISE ");\r
+ call fourchette(n-1,0,0);\r
+ \r
+ \r
+ when 11: call outstring("G REFUS ");\r
+ when 12: call outstring("D REFUS ");\r
+ esac;\r
+ call color(7);\r
+ END actionp;\r
+ \r
+ (*******************************************************)\r
+ (* procedure affichant un cercle *)\r
+ (*******************************************************)\r
+ UNIT cercle : procedure (x,y,r : integer);\r
+ var xp, yp, xn, yn, i : integer,\r
+ Dangle, angle : real;\r
+ begin\r
+ Dangle := 2*PI/100;\r
+ xp := r + x;\r
+ yp := yt;\r
+ for i := 0 to 100\r
+ do\r
+ angle := Dangle * i;\r
+ xn := round((r*cos(angle)) + x);\r
+ yn := round((r*sin(angle)) + y);\r
+ call move(xp, yp);\r
+ call draw(xn, yn);\r
+ xp := xn;\r
+ yp := yn;\r
+ od;\r
+ END cercle;\r
+ \r
+ unit table: procedure(xt,yt,rt : integer);\r
+ begin\r
+ (* affichage de la table *)\r
+ call cercle(xt, yt, rt);\r
+ (* affichage des assiettes *)\r
+ for i := 0 to 4\r
+ do\r
+ angle := ( (i*2)+1 ) *PI/5;\r
+ r := rt - ra - 5;\r
+ xa := round ( (r*cos(angle)) + xt);\r
+ ya := round ( (r*sin(angle)) + yt);\r
+ call color(2);\r
+ call cirb(xa, ya, ra, 0, 0, 1, 1, 1, 1);\r
+ call move(xa, ya);\r
+ call color(0);\r
+ call hascii (48 + (i-1) div 10);\r
+ call Hascii (48 + (i+1) mod 10);\r
+ call color(7);\r
+ od;\r
+ end table;\r
+ \r
+ UNIT finir : procedure;\r
+ begin\r
+ compteur := compteur + 1;\r
+ if compteur = 5\r
+ then call groff;\r
+ call endrun;\r
+ fi;\r
+ END finir;\r
+ \r
+ begin\r
+ call gron(1);\r
+ ra :=30;\r
+ return;\r
+ do\r
+ accept bulles, fourchette, finir,guard, table,actionp, cercle;\r
+ od;\r
+ END ecran;\r
+ \r
+ (*******************************************************)\r
+ (* processus philosophe *)\r
+ (*******************************************************)\r
+ UNIT philosophe : iiuwgraph process( node, num_phi : integer,\r
+ gardien : doorman, fourch_g, fourch_d : fork, e : ecran);\r
+ var i, compt_m : integer,\r
+ Goccupee, Doccupee : boolean;\r
+ \r
+ unit waitt : procedure(n:integer);\r
+ var j : integer;\r
+ begin\r
+ for j := 1 to n do od;\r
+ end waitt;\r
+ begin\r
+ return;\r
+ compt_m := 1;\r
+ call e.bulles(num_phi);\r
+ call e.actionp(num_phi, 1);\r
+ call waitt(1500);\r
+ while (compt_m < 3)\r
+ do\r
+ call gardien.dem_entrer(num_phi);\r
+ call e.actionp(num_phi, 2);\r
+ call waitt(1500);\r
+ (* tant que le philosophe n'a pas les deux fourchettes *)\r
+ while ( (not Goccupee) or (not Doccupee) )\r
+ do\r
+ (* demander \85 avoir la fourchette de gauche *)\r
+ if (not Goccupee) then\r
+ call fourch_g.prendref(Goccupee,num_phi,0);\r
+ call waitt(1500);\r
+ fi;\r
+ \r
+ (* demander \85 avoir la fourchette de droite *)\r
+ if (not Doccupee) then\r
+ call fourch_d.prendref(Doccupee,num_phi,1);\r
+ call waitt(1500);\r
+ fi;\r
+ od;\r
+ (* le philosophe a obtenu les 2 fourchettes *)\r
+ (* il mange *)\r
+ call e.actionp(num_phi, 3);\r
+ call waitt(4000);\r
+ (* le philosophe a fini de manger *)\r
+ (* il rend la fourchette de gauche *)\r
+ call fourch_g.rendref(Goccupee,num_phi,0);\r
+ call waitt(1500);\r
+ \r
+ (* il rend la fourchette de droite *)\r
+ call fourch_d.rendref(Doccupee, num_phi,1);\r
+ call waitt(1500);\r
+ \r
+ (* le philosophe demande \85 sortir de table *)\r
+ call gardien.sortir(num_phi);\r
+ \r
+ call waitt(5000);\r
+ \r
+ compt_m := compt_m + 1;\r
+ od;\r
+ (* le philosophe a mange 5 fois *)\r
+ (* il part d\82finitivement *)\r
+ call e.actionp(num_phi, 8);\r
+ call waitt(1500);\r
+ call e.finir;\r
+ END philosophe;\r
+ \r
+ (*******************************************************)\r
+ (* processus qui gere les entrees et sorties des *)\r
+ (* philosophes *)\r
+ (*******************************************************)\r
+ UNIT doorman : iiuwgraph process(node, place_dispo : integer, e : ecran);\r
+ \r
+ UNIT dem_entrer : procedure(num : integer);\r
+ begin\r
+ if place_dispo > 0\r
+ then\r
+ (* il y a des places disponibles \85 table *)\r
+ (* le philosophe peut rentrer *)\r
+ place_dispo := place_dispo - 1;\r
+ call e.actionp(num, 2);\r
+ if place_dispo = 0 then\r
+ (* il n'y a plus de places disponibles *)\r
+ (* aucun philosophe ne peut entrer *)\r
+ return disable dem_entrer;\r
+ fi;\r
+ else\r
+ call e.actionp(num, 5);\r
+ return;\r
+ fi;\r
+ END dem_entrer;\r
+ \r
+ UNIT sortir : procedure(num : integer);\r
+ begin\r
+ (* un philosophe sort de la salle *)\r
+ (* une place est liberee *)\r
+ place_dispo := place_dispo + 1;\r
+ call e.actionp(num, 4);\r
+ return enable dem_entrer;\r
+ END sortir;\r
+ \r
+ begin\r
+ enable dem_entrer, sortir;\r
+ return;\r
+ do od;\r
+ END doorman;\r
+ \r
+ (*******************************************************)\r
+ (* processus permettant de prendre et rendre les *)\r
+ (* fourchettes *)\r
+ (*******************************************************)\r
+ UNIT fork : iiuwgraph process (node : integer,e:ecran);\r
+ var aux : boolean;\r
+ \r
+ UNIT prendref : procedure (output foccupee : boolean;\r
+ input num,i:integer);\r
+ begin\r
+ if aux\r
+ then foccupee := true;\r
+ aux := false;\r
+ \r
+ else foccupee := false;\r
+ fi;\r
+ if i=0 then\r
+ if foccupee\r
+ then\r
+ call e.actionp(num, 9);\r
+ else\r
+ call e.actionp(num, 11);\r
+ fi;\r
+ else\r
+ if foccupee\r
+ then\r
+ call e.actionp(num, 10);\r
+ else\r
+ call e.actionp(num, 12);\r
+ fi;\r
+ fi;\r
+ END prendref;\r
+ \r
+ UNIT rendref : procedure (output foccup : boolean;\r
+ input num:integer,i:integer);\r
+ begin\r
+ aux := true;\r
+ foccup := false;\r
+ if i=0 then call e.actionp(num, 6)\r
+ else call e.actionp(num,7 ) fi;\r
+ END rendref;\r
+ \r
+ begin\r
+ aux := true;\r
+ enable prendref, rendref;\r
+ return;\r
+ do\r
+ accept prendref, rendref;\r
+ od;\r
+ END fork;\r
+ \r
+ (*******************************************************)\r
+ (* PROGRAMME PRINCIPAL *)\r
+ (*******************************************************)\r
+ CONST\r
+ xt = 300,\r
+ yt = 170,\r
+ rt = 105;\r
+ \r
+ VAR i : integer,\r
+ gardien : doorman,\r
+ f : arrayof fork,\r
+ f0 : fork,\r
+ ph : arrayof philosophe,\r
+ ph0 : philosophe,\r
+ e : ecran;\r
+ \r
+ BEGIN (********* programme principale ***********)\r
+ \r
+ call newpage;\r
+ e := new ecran(0);\r
+ resume(e);\r
+ \r
+ call e.table(xt,yt,rt);\r
+ \r
+ (* affichage des fourchettes *)\r
+ for i := 0 to 4\r
+ do\r
+ call e.fourchette(i, 0, 14);\r
+ od;\r
+ (* affichage de gardien *)\r
+ call e.guard(50,250,14);\r
+ gardien := new doorman(0, 4, e);\r
+ array ph dim (1:5);\r
+ array f dim (0:4);\r
+ for i := 0 to 4\r
+ do\r
+ f0 := new fork(0,e);\r
+ f(i) := f0;\r
+ resume(f(i));\r
+ od;\r
+ resume (gardien);\r
+ for i:= 1 to 5\r
+ do\r
+ ph0 := new philosophe(0, i, gardien, f(i mod 5), f(i-1), e);\r
+ ph(i) :=ph0;\r
+ od;\r
+ for i := 1 to 5\r
+ do\r
+ resume(ph(i));\r
+ od;\r
+ \r
+ \r
+END philos5.\r
--- /dev/null
+Program tri;\r
+\r
+(*******************************************************************)\r
+\r
+Unit newpage:procedure;\r
+begin\r
+ write(chr(27),"[2J");\r
+end newpage;\r
+\r
+(*******************************************************************)\r
+\r
+Unit gotoxy : procedure (row, column : integer);\r
+ var c, d, e, f : char,\r
+ i, j : integer;\r
+begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr (48+i);\r
+ d := chr (48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr (48+i);\r
+ f := chr (48+j);\r
+ write (chr(27), "[", c, d, ";", e, f, "H");\r
+ end gotoxy;\r
+\r
+(*******************************************************************)\r
+\r
+Unit pause:procedure(input seconde:integer);\r
+ var temps:integer;\r
+begin\r
+ for temps:=1 to (9000*seconde) do od;\r
+end pause;\r
+\r
+(*******************************************************************)\r
+\r
+Unit affiche:procedure(input position:integer;\r
+ inout tableau:arrayof integer);\r
+var i:integer;\r
+begin\r
+for i:=1 to upper(tableau) do\r
+ if i=position then write(chr(27),"[33m");\r
+ write(" ",tableau(i):4," ");\r
+ write(chr(27),"[36m")\r
+ else\r
+ write(" ",tableau(i):4," ") fi;\r
+od;\r
+writeln;\r
+end affiche;\r
+\r
+(*******************************************************************)\r
+\r
+Unit A:process(n:integer;p:B);\r
+var tabA:arrayof integer,\r
+ max,position,nb,i,nombre,j:integer,\r
+ bo:boolean;\r
+\r
+ (********************)\r
+\r
+Unit rech_max:procedure(output max,position:integer);\r
+(* Recherche du plus grand \82l\82ment de tabA *)\r
+var i:integer;\r
+begin\r
+max:=tabA(1);\r
+position:=1;\r
+for i:=2 to nb do\r
+ if tabA(i)>max then max:=tabA(i);\r
+ position:=i;\r
+ fi;\r
+od;\r
+end rech_max;\r
+\r
+ (********************)\r
+\r
+begin\r
+ call gotoxy(2,20);\r
+ write(chr(27),"[33m");\r
+ writeln("- SAISIE DU TABLEAU A -");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(4,1);\r
+ write("Quelle est la dimension de tabA ? ");\r
+ read(nb);\r
+ array tabA dim (1:nb);\r
+ for i:=1 to nb do\r
+ write("Donnez tabA(",i:3,") : ");\r
+ readln(nombre);\r
+ tabA(i):=nombre;\r
+ od;\r
+ call newpage;\r
+ call gotoxy(2,15);\r
+ writeln("AFFICHAGE DES DIFFERENTES ETAPES DU TRI");\r
+ writeln;\r
+ return;\r
+ j:=0;\r
+ do\r
+\r
+ call rech_max(max,position);\r
+ writeln;\r
+ if j<>0 then writeln("Etape ",j:2," : ") fi;\r
+ call p.ec;\r
+ write("TabA = ");\r
+ call affiche(position,tabA);\r
+ call p.rire;\r
+ call p.echange(max,bo);\r
+ tabA(position):=max;\r
+ j:=j+1;\r
+ if bo then exit fi;\r
+ od;\r
+ position:=0;\r
+ write(chr(27),"[32m");\r
+ writeln("Resultat Final : ");\r
+ write(chr(27),"[36m");\r
+ call p.ec;\r
+ write("TabA = ");\r
+ call affiche(position,tabA);\r
+ call p.rire;\r
+end A;\r
+\r
+(*******************************************************************)\r
+\r
+Unit B:process(n:integer);\r
+var tabB:arrayof integer,\r
+ min,position,nb,i,nombre,j:integer,\r
+ bidon:char,\r
+ arret:boolean;\r
+\r
+ (********************)\r
+\r
+Unit rech_min:procedure(output min,position:integer);\r
+(* Recherche du plus petit \82l\82ment de tabB *)\r
+var i:integer;\r
+begin\r
+min:=tabB(1);\r
+position:=1;\r
+for i:=2 to nb do\r
+ if tabB(i)<min then min:=tabB(i);\r
+ position:=i;\r
+ fi;\r
+od;\r
+end rech_min;\r
+\r
+ (********************)\r
+\r
+Unit echange:procedure(inout max:integer;\r
+ output bo:boolean);\r
+begin\r
+ if min<max then tabB(position):=max;\r
+ max:=min;\r
+ bo:=false\r
+ else bo:=true;\r
+ arret:=true fi;\r
+end echange;\r
+\r
+Unit ec:procedure;\r
+end ec;\r
+\r
+Unit rire:procedure;\r
+end rire;\r
+\r
+ (********************)\r
+\r
+begin\r
+ call gotoxy(2,20);\r
+ write(chr(27),"[33m");\r
+ writeln("- SAISIE DU TABLEAU B -");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(4,1);\r
+ write("Quelle est la dimension de tabB ? ");\r
+ read(nb);\r
+ array tabB dim (1:nb);\r
+ for i:=1 to nb do\r
+ write("Donnez tabB(",i:3,") : ");\r
+ readln(nombre);\r
+ tabB(i):=nombre;\r
+ od;\r
+ call newpage;\r
+ return;\r
+ j:=0;\r
+ do\r
+\r
+ call rech_min(min,position);\r
+ accept ec;\r
+ accept rire;\r
+ write("TabB = ");\r
+ call affiche(position,tabB);\r
+ writeln;\r
+ j:=j+1;\r
+ if (j mod 4)=0 then write(chr(27),"[32m");\r
+ writeln("< Appuyez sur Retour >");\r
+ write(chr(27),"[36m");\r
+ read(bidon);\r
+ call newpage fi;\r
+\r
+ accept echange;\r
+ if arret then exit fi;\r
+ od;\r
+ accept ec;\r
+ accept rire;\r
+ position:=0;\r
+ write("TabB = ");\r
+ call affiche(position,tabB);\r
+end B;\r
+\r
+(*******************************************************************)\r
+\r
+Unit baniere:procedure;\r
+begin\r
+ call newpage;\r
+ write(chr(27),"[31m");\r
+ call gotoxy(7,22);\r
+ writeln("PARTITION DE DEUX ENSEMBLES :");\r
+ call gotoxy(9,31);\r
+ writeln("Min & Max");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(15,29);\r
+ writeln("Presented by");\r
+ call gotoxy(22,26);\r
+ write(chr(27),"[32m");\r
+ writeln("- Dupin Christophe -");\r
+ call pause(2);\r
+ write(chr(27),"[36m");\r
+ call newpage;\r
+end baniere;\r
+\r
+(************************* Programme principal *****************************)\r
+\r
+var arret:boolean,\r
+ processusA : A,\r
+ processusB : B;\r
+\r
+begin\r
+ call baniere;\r
+ processusB:=new B(0);\r
+ processusA:=new A(0,processusB);\r
+ resume(processusA);\r
+ resume(processusB);\r
+end tri;\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+Program tri;\r
+\r
+(*******************************************************************)\r
+\r
+Unit newpage:procedure;\r
+begin\r
+ write(chr(27),"[2J");\r
+end newpage;\r
+\r
+(*******************************************************************)\r
+\r
+Unit gotoxy : procedure (row, column : integer);\r
+ var c, d, e, f : char,\r
+ i, j : integer;\r
+begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr (48+i);\r
+ d := chr (48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr (48+i);\r
+ f := chr (48+j);\r
+ write (chr(27), "[", c, d, ";", e, f, "H");\r
+ end gotoxy;\r
+\r
+(*******************************************************************)\r
+\r
+Unit pause:procedure(input seconde:integer);\r
+ var temps:integer;\r
+begin\r
+ for temps:=1 to (9000*seconde) do od;\r
+end pause;\r
+\r
+(*******************************************************************)\r
+\r
+Unit affiche:procedure(input position:integer;\r
+ inout tableau:arrayof integer);\r
+var i:integer;\r
+begin\r
+for i:=1 to upper(tableau) do\r
+ if i=position then write(chr(27),"[33m");\r
+ write(" ",tableau(i):4," ");\r
+ write(chr(27),"[36m")\r
+ else\r
+ write(" ",tableau(i):4," ") fi;\r
+od;\r
+writeln;\r
+end affiche;\r
+\r
+(*******************************************************************)\r
+\r
+Unit A:process(n:integer;p:B);\r
+var tabA:arrayof integer,\r
+ max,position,nb,i,nombre,j:integer,\r
+ bo:boolean;\r
+\r
+ (********************)\r
+\r
+Unit rech_max:procedure(output max,position:integer);\r
+(* Recherche du plus grand \82l\82ment de tabA *)\r
+var i:integer;\r
+begin\r
+max:=tabA(1);\r
+position:=1;\r
+for i:=2 to nb do\r
+ if tabA(i)>max then max:=tabA(i);\r
+ position:=i;\r
+ fi;\r
+od;\r
+end rech_max;\r
+\r
+ (********************)\r
+\r
+begin\r
+ call gotoxy(2,20);\r
+ write(chr(27),"[33m");\r
+ writeln("- SAISIE DU TABLEAU A -");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(4,1);\r
+ write("Quelle est la dimension de tabA ? ");\r
+ read(nb);\r
+ array tabA dim (1:nb);\r
+ for i:=1 to nb do\r
+ write("Donnez tabA(",i:3,") : ");\r
+ readln(nombre);\r
+ tabA(i):=nombre;\r
+ od;\r
+ call newpage;\r
+ call gotoxy(2,15);\r
+ writeln("AFFICHAGE DES DIFFERENTES ETAPES DU TRI");\r
+ writeln;\r
+ return;\r
+ j:=0;\r
+ do\r
+\r
+ call rech_max(max,position);\r
+ writeln;\r
+ if j<>0 then writeln("Etape ",j:2," : ") fi;\r
+ call p.ec;\r
+ write("TabA = ");\r
+ call affiche(position,tabA);\r
+ call p.rire;\r
+ call p.echange(max,bo);\r
+ tabA(position):=max;\r
+ j:=j+1;\r
+ if bo then exit fi;\r
+ od;\r
+ position:=0;\r
+ write(chr(27),"[32m");\r
+ writeln("Resultat Final : ");\r
+ write(chr(27),"[36m");\r
+ call p.ec;\r
+ write("TabA = ");\r
+ call affiche(position,tabA);\r
+ call p.rire;\r
+end A;\r
+\r
+(*******************************************************************)\r
+\r
+Unit B:process(n:integer);\r
+var tabB:arrayof integer,\r
+ min,position,nb,i,nombre,j:integer,\r
+ bidon:char,\r
+ arret:boolean;\r
+\r
+ (********************)\r
+\r
+Unit rech_min:procedure(output min,position:integer);\r
+(* Recherche du plus petit \82l\82ment de tabB *)\r
+var i:integer;\r
+begin\r
+min:=tabB(1);\r
+position:=1;\r
+for i:=2 to nb do\r
+ if tabB(i)<min then min:=tabB(i);\r
+ position:=i;\r
+ fi;\r
+od;\r
+end rech_min;\r
+\r
+ (********************)\r
+\r
+Unit echange:procedure(inout max:integer;\r
+ output bo:boolean);\r
+begin\r
+ if min<max then tabB(position):=max;\r
+ max:=min;\r
+ bo:=false\r
+ else bo:=true;\r
+ arret:=true fi;\r
+end echange;\r
+\r
+Unit ec:procedure;\r
+end ec;\r
+\r
+Unit rire:procedure;\r
+end rire;\r
+\r
+ (********************)\r
+\r
+begin\r
+ call gotoxy(2,20);\r
+ write(chr(27),"[33m");\r
+ writeln("- SAISIE DU TABLEAU B -");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(4,1);\r
+ write("Quelle est la dimension de tabB ? ");\r
+ read(nb);\r
+ array tabB dim (1:nb);\r
+ for i:=1 to nb do\r
+ write("Donnez tabB(",i:3,") : ");\r
+ readln(nombre);\r
+ tabB(i):=nombre;\r
+ od;\r
+ call newpage;\r
+ return;\r
+ j:=0;\r
+ do\r
+\r
+ call rech_min(min,position);\r
+ accept ec;\r
+ accept rire;\r
+ write("TabB = ");\r
+ call affiche(position,tabB);\r
+ writeln;\r
+ j:=j+1;\r
+ if (j mod 4)=0 then write(chr(27),"[32m");\r
+ writeln("< Appuyez sur Retour >");\r
+ write(chr(27),"[36m");\r
+ read(bidon);\r
+ call newpage fi;\r
+\r
+ accept echange;\r
+ if arret then exit fi;\r
+ od;\r
+ accept ec;\r
+ accept rire;\r
+ position:=0;\r
+ write("TabB = ");\r
+ call affiche(position,tabB);\r
+end B;\r
+\r
+(*******************************************************************)\r
+\r
+Unit baniere:procedure;\r
+begin\r
+ call newpage;\r
+ write(chr(27),"[31m");\r
+ call gotoxy(7,22);\r
+ writeln("PARTITION DE DEUX ENSEMBLES :");\r
+ call gotoxy(9,31);\r
+ writeln("Min & Max");\r
+ write(chr(27),"[36m");\r
+ call gotoxy(15,29);\r
+ writeln("Presented by");\r
+ call gotoxy(22,26);\r
+ write(chr(27),"[32m");\r
+ writeln("- Dupin Christophe -");\r
+ call pause(2);\r
+ write(chr(27),"[36m");\r
+ call newpage;\r
+end baniere;\r
+\r
+(************************* Programme principal *****************************)\r
+\r
+var arret:boolean,\r
+ processusA : A,\r
+ processusB : B;\r
+\r
+begin\r
+ call baniere;\r
+ processusB:=new B(0);\r
+ processusA:=new A(0,processusB);\r
+ resume(processusA);\r
+ resume(processusB);\r
+end tri;\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+program PHILO;\r
+\r
+(*----------------------------------------------------------------*)\r
+(*----------------------------------------------------------------*)\r
+(* PROGRAMME SIMULANT LE PROBLEME *)\r
+(* DES PHILOSOPHES ET DES SPAGHETTIS *)\r
+(*----------------------------------------------------------------*)\r
+(*----------------------------------------------------------------*)\r
+\r
+\r
+ UNIT ecran : IIUWGRAPH PROCESS (n:integer);\r
+ (*--------------------------------------------*)\r
+ (* - - PROCESSUS SIMULANT L'ECRAN - - *)\r
+ (*--------------------------------------------*)\r
+ VAR k :integer;\r
+\r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant d'utiliser le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ UNIT initgraph : PROCEDURE;\r
+ BEGIN\r
+ CALL GRON(1);\r
+ END initgraph;\r
+\r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant de fermer le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ UNIT closegraph : PROCEDURE;\r
+ BEGIN\r
+ CALL GROFF;\r
+ END closegraph;\r
+\r
+ (*----------------------------------------------------------------*)\r
+ (* AFFICHAGE en (x,y) d'un RECTANGLE de longueur l et de hauteur h *)\r
+ (*-----------------------------------------------------------------*)\r
+ UNIT rectangle : PROCEDURE(x,y,l,h : INTEGER);\r
+ BEGIN\r
+ CALL MOVE (x,y);\r
+ CALL DRAW (x+l,y);\r
+ CALL DRAW(x+l,y+h);\r
+ CALL DRAW(x,y+h);\r
+ CALL DRAW(x,y);\r
+ END rectangle;\r
+\r
+\r
+ (*--------------------------------------------------------------------*)\r
+ (* ECRITURE d'une CHAINE de caracteres sur l'ecran graphique en (x,y) *)\r
+ (*--------------------------------------------------------------------*)\r
+ UNIT ecrit_text : PROCEDURE(xy,x,y : INTEGER;str : string);\r
+ VAR ch : ARRAYOF CHARACTER,\r
+ lg,i : INTEGER;\r
+ BEGIN\r
+ call color (xy);\r
+ CALL move (x,y);\r
+ ch := UNPACK(str);\r
+ lg := UPPER(ch) - LOWER(ch) + 1;\r
+ FOR i := 1 TO lg DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(ORD(ch(i)));\r
+ OD;\r
+ END;\r
+\r
+ (*---------------------------------*)\r
+ (* LECTURE d'une touche au clavier *)\r
+ (*---------------------------------*)\r
+ UNIT inchar : FUNCTION : INTEGER;\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ DO\r
+ i := INKEY;\r
+ IF i =/= 0 THEN EXIT;\r
+ FI;\r
+ OD;\r
+ result := i;\r
+ END inchar;\r
+\r
+\r
+\r
+ UNIT finir : PROCEDURE;\r
+ var car : integer;\r
+ BEGIN\r
+ k:=k+1;\r
+ IF k = 5\r
+ THEN call color(4);\r
+ CALL ecrit_text (12,500,320,"TOUCHE");\r
+ car:= inchar;\r
+ (* FERMETURE DU MODE GRAPHIQUE *)\r
+ CALL closegraph;\r
+ CALL endrun;\r
+ FI;\r
+ END finir;\r
+\r
+ BEGIN\r
+ RETURN;\r
+ DO\r
+ ACCEPT initgraph,closegraph,rectangle,ecrit_text,inchar,finir;\r
+ OD;\r
+ END ecran;\r
+\r
+(*-------------------------------------------------------------------------*)\r
+\r
+UNIT philosophe:PROCESS(node,nr,x,y:integer,gardien:garde,fourl,\r
+ fourr:fourchette,e:ecran);\r
+ (*-------------------------------------------------*)\r
+ (* - - PROCESSUS SIMULANT UN PHILOSOPHE - - *)\r
+ (*-------------------------------------------------*)\r
+\r
+ var i,fin,car : integer, bol,bor:boolean;\r
+\r
+ BEGIN\r
+ RETURN;\r
+ fin:=1;\r
+\r
+ (* TANT QUE LE PHILOSOPHE N'EST PAS RENTRE 4 FOIS DANS LA SALLE *)\r
+ WHILE (fin<=4)\r
+ DO\r
+\r
+ (* 1ER TEMPS IL PENSE *)\r
+ CALL e.ecrit_text (14,x,y,"PENS");\r
+ FOR i:=1 TO 80\r
+ DO\r
+ OD;\r
+\r
+ (* 2 EME TEMPS IL DEMANDE AU GARDIEN L'AUTORISATION POUR RENTRER *)\r
+ CALL gardien.entree;\r
+ CALL e.ecrit_text (10,x,y,"ENTR");\r
+\r
+ (* 3EME TEMPS IL PREND LA FOURCHETTE DE GAUCHE ET LA CELLE DE DROITE *)\r
+ WHILE ((NOT bol) OR (NOT bor))\r
+ DO\r
+ IF (not bol) THEN\r
+ CALL fourl.prendre(bol);\r
+ IF bol THEN CALL e.ecrit_text (11,x,y,"FGAU"); FI;\r
+ FI;\r
+ IF (not bor) THEN\r
+ CALL fourr.prendre(bor);\r
+ IF bor THEN CALL e.ecrit_text (11,x,y,"FDRO"); FI;\r
+ FI;\r
+ OD;\r
+\r
+ (* 4EME TEMPS IL MANGE PENDANT UN TEMPS FINI *)\r
+ CALL e.ecrit_text (12,x,y,"MANG");\r
+\r
+ FOR i:=1 TO 40\r
+ DO\r
+ OD;\r
+\r
+ (* 5EME TEMPS IL DEPOSE LES FOURCHETTES *)\r
+ CALL fourl.poser(bol);\r
+ CALL fourr.poser(bor);\r
+ CALL e.ecrit_text (13,x,y,"LIBE");\r
+\r
+ (* 6EME TEMPS IL SORT DE LA SALLE *)\r
+ CALL gardien.sortie;\r
+ CALL e.ecrit_text (14,x,y,"SORT");\r
+ fin:=fin+1;\r
+ OD;\r
+\r
+ (* ENFIN IL VA SE COUCHER *)\r
+ CALL e.ecrit_text (9,x,y,"DORT");\r
+ CALL e.finir;\r
+ END philosophe;\r
+\r
+(*-------------------------------------------------------------------------*)\r
+\r
+ UNIT garde : PROCESS(node : integer,level : integer);\r
+ (*-------------------------------------------------*)\r
+ (* - - PROCESSUS SIMULANT LE GARDIEN - - *)\r
+ (*-------------------------------------------------*)\r
+ UNIT entree : PROCEDURE;\r
+ (*-------------------------------------------*)\r
+ (* PROCEDURE permettant de gerer les entrees *)\r
+ (* dans la SALLE A MANGER *)\r
+ (*-------------------------------------------*)\r
+ BEGIN\r
+ IF level > 0 THEN\r
+ level := level - 1;\r
+ IF level = 0 THEN\r
+ return DISABLE entree;\r
+ FI;\r
+ FI;\r
+ END entree;\r
+\r
+ UNIT sortie : PROCEDURE;\r
+ (*-------------------------------------------*)\r
+ (* PROCEDURE permettant de gerer les sorties *)\r
+ (* de la SALLE A MANGER *)\r
+ (*-------------------------------------------*)\r
+ BEGIN\r
+ level:=level+1;\r
+ return ENABLE entree;\r
+ END sortie;\r
+\r
+ BEGIN\r
+ ENABLE entree,sortie;\r
+ RETURN;\r
+ DO\r
+\r
+ OD;\r
+ END garde;\r
+\r
+(*-------------------------------------------------------------------------*)\r
+\r
+ UNIT fourchette : PROCESS (node : integer);\r
+ (*-------------------------------------------------*)\r
+ (* - - PROCESSUS SIMULANT UNE FOURCHETTE - - *)\r
+ (*-------------------------------------------------*)\r
+\r
+ var aux : boolean;\r
+\r
+ UNIT prendre : PROCEDURE (output bo : boolean);\r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE retournant un booleen qui indique si la *)\r
+ (* fourchette qui est demandee est disponible *)\r
+ (*---------------------------------------------------*)\r
+ BEGIN\r
+ IF aux THEN\r
+ bo := true;\r
+ aux := false;\r
+ ELSE\r
+ bo:= false;\r
+ FI;\r
+ END prendre;\r
+\r
+ UNIT poser : PROCEDURE (output b : boolean);\r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant de rendre disponible la *)\r
+ (* fourchette *)\r
+ (*---------------------------------------------------*)\r
+ BEGIN\r
+ aux := true;\r
+ b:= false;\r
+ END poser;\r
+\r
+ BEGIN\r
+ aux := true;\r
+ ENABLE prendre,poser;\r
+ RETURN;\r
+ DO\r
+\r
+ OD;\r
+ END fourchette;\r
+\r
+\r
+(*-------------------------------------------------------------------------*)\r
+\r
+\r
+ var\r
+ i,j:integer, (* Variable de travail et Indice de tableau *)\r
+ gardien : garde, (* Gardien de la salle a manger *)\r
+ f : arrayof fourchette, (* Tableau des cinq processus fourchettes *)\r
+ f0:fourchette, (* Variable intermediaire permettant de *)\r
+ (* remplir le tableau precedent *)\r
+ ph : arrayof philosophe, (* Tableau des cinq processus philosophe *)\r
+ ph0:philosophe, (* Variable intermediaire permettant de *)\r
+ (* remplir le tableau precedent *)\r
+ e:ecran, (* Variable de type processus ECRAN *)\r
+ car:integer; (* Variable de travail pour une attente *)\r
+ (* avant la suite de deroulement du *)\r
+ (* programme *)\r
+\r
+\r
+(*-------------------------------------------------------------------------*)\r
+\r
+ BEGIN\r
+\r
+ (* CREATION DU PROCESSUS ECRAN *)\r
+ e:=NEW ecran(0);\r
+\r
+ (* PROCESSUS ECRAN RENDU ACTIF *)\r
+ RESUME (e);\r
+\r
+ (* OUVERTURE DE L'ENVIRONEMENT GRAPHIQUE *)\r
+ CALL e.initgraph;\r
+\r
+ (* EFFACEMENT DE L'ECRAN *)\r
+ CALL e.cls;\r
+\r
+ (* AFFICHAGE DE LA PRESENTATION *)\r
+ CALL e.rectangle (1,1,635,348);\r
+ CALL e.rectangle (100,50,435,100);\r
+ CALL e.ecrit_text (15,160,95,"LES 5 PHILOSOPHES ET LES SPAGHETTIS");\r
+ CALL e.ecrit_text (15,140,200,"PROGRAMME REALISE PAR CHASTANET STEPHANIE");\r
+ CALL e.ecrit_text (15,160,300, "<TAPER SUR UNE TOUCHE POUR CONTINUER>");\r
+ car:=e.inchar;\r
+\r
+ (* AFFICHAGE DE LA SALLE A MANGER ET DE LA DISPOSITION DES PHILOSOPHES *)\r
+ CALL e.cls;\r
+ CALL e.rectangle(1,1,600,348);\r
+ CALL e.ecrit_text(15,245,15,"LA SALLE A MANGER");\r
+ CALL e.CIRB(300,170,170,0,0,1,1,1,1);\r
+ CALL e.color(1);\r
+ CALL e.cirb(215,90,25,0,0,1,1,1,1);\r
+ CALL e.color(3);\r
+ CALL e.ecrit_text(15,160,70,"1");\r
+ CALL e.color(1);\r
+ CALL e.cirb(165,200,25,0,0,1,1,1,1);\r
+ CALL e.color(3);\r
+ CALL e.ecrit_text(15,110,200,"2");\r
+ CALL e.color(1);\r
+ CALL e.cirb(390,90,25,0,0,1,1,1,1);\r
+ CALL e.color(3);\r
+ CALL e.ecrit_text(15,430,70,"5");\r
+ CALL e.color(1);\r
+ CALL e.cirb(435,200,25,0,0,1,1,1,1);\r
+ CALL e.color(3);\r
+ CALL e.ecrit_text(15,470,200,"4");\r
+ CALL e.color(1);\r
+ CALL e.cirb(300,270,25,0,0,1,1,1,1);\r
+ CALL e.color(3);\r
+ CALL e.ecrit_text(15,295,300,"3");\r
+\r
+ (* AFFICHAGE DU GARDIEN *)\r
+ CALL e.color(15);\r
+ CALL e.cirb(615,92,5,0,0,1,1,1,1);\r
+ CALL e.move (615,100);\r
+ CALL e.draw (615,125);\r
+ CALL e.move (610,110);\r
+ CALL e.draw (620,110);\r
+\r
+ (* CREATION D'UN PROCESSUS GARDIEN *)\r
+ gardien := NEW garde(0,4);\r
+\r
+ (* DECLARATION ET CREATION DU TABLEAU DES PROCESSUS PHILOSOPHES *)\r
+ ARRAY ph DIM (1:5);\r
+\r
+ (* DECLARATION ET CREATION DU TABLEAU DES PROCESSUS FOURCHETTES *)\r
+ ARRAY f DIM (0:4);\r
+\r
+ (* INITIALISATION DU TABLEAU DES PROCESSUS FOURCHETTES *)\r
+ FOR i:= 0 TO 4\r
+ DO\r
+\r
+ (* CREATION D'UN PROCESSUS FOURCHETTE *)\r
+ f0 := NEW fourchette(0);\r
+ f(i) :=f0;\r
+\r
+ (* PROCESSUS FOURCHETTE RENDU ACTIF *)\r
+ RESUME (f(i));\r
+ OD;\r
+\r
+ (* PROCESSUS GARDIEN RENDU ACTIF *)\r
+ RESUME (gardien);\r
+\r
+ (* POUR LES 5 PROCESSUS PHILOSOPHES, CREATION DU PROCESSUS *)\r
+ i:=1;\r
+ ph0 := NEW philosophe (0,1,120,70,gardien,f(i-1),f(i mod 5),e);\r
+ ph(1) := ph0;\r
+ i:=2;\r
+ ph0 := NEW philosophe (0,2,70,200,gardien,f(i-1),f(i mod 5),e);\r
+ ph(2) := ph0;\r
+ i:=3;\r
+ ph0 := NEW philosophe (0,3,290,320,gardien,f(i-1),f(i mod 5),e);\r
+ ph(3) := ph0;\r
+ i:=4;\r
+ ph0 := NEW philosophe (0,4,500,200,gardien,f(i-1),f(i mod 5),e);\r
+ ph(4) := ph0;\r
+ i:=5;\r
+ ph0 := NEW philosophe (0,5,460,70,gardien,f(i-1),f(i mod 5),e);\r
+ ph(5) := ph0;\r
+\r
+ (* POUR CHAQUE PROCESSUS PHILOSOPHE DU TABLEAU *)\r
+ FOR i:=1 TO 5\r
+ DO\r
+ FOR j:=1 TO 700 DO OD;\r
+\r
+ (* PROCESSUS PHILOSOPHE RENDU ACTIF *)\r
+ RESUME (ph(i));\r
+ OD;\r
+\r
+ END PHILO.\r
+\1a
\ No newline at end of file
--- /dev/null
+program ring;\r
+(***************************************************************)\r
+unit ecran : process(node: integer);\r
+var fin : boolean;\r
+ unit koniec : procedure;\r
+ begin fin:= true;\r
+ end koniec;\r
+ unit Bold : procedure;\r
+ begin\r
+ write( chr(27), "[1m")\r
+ end Bold;\r
+ \r
+ unit Blink : procedure;\r
+ begin\r
+ write( chr(27), "[5m")\r
+ end Blink;\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+ \r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ unit Underscore : procedure;\r
+ begin\r
+ write( chr(27), "[4m")\r
+ end Underscore;\r
+ \r
+ \r
+ unit inchar : IIuwgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ unit pisz :procedure( co, li,kol, jak: integer);\r
+ var i: integer;\r
+ begin\r
+ for i := 1 to 9000 do i :=i od;\r
+ call SetCursor(li,kol);\r
+ case jak\r
+ when 1 : call Normal;\r
+ when 2 : call Bold;\r
+ when 3 : call Reverse;\r
+ when 4 : call Underscore;\r
+ esac;\r
+ write(co);\r
+ end pisz;\r
+ var x: integer;\r
+ begin (* ecran ************************)\r
+ fin := false;\r
+ call NewPage;\r
+ call SetCursor(2,30);call Bold;\r
+ write( "RING OF PROCESSES ");\r
+ return;\r
+ enable inchar;\r
+ do accept pisz, koniec;\r
+ if fin then\r
+ call SetCursor(22,30); call Normal;\r
+ write("KONIEC"); x := inchar;exit\r
+ fi;\r
+ od;\r
+ end ecran;\r
+ \r
+unit Pr : process(n,nr: integer, booo : boolean, next : Pr, E: ecran);\r
+var prive, number, x_pos,w_pos: integer;\r
+ unit info : procedure(pp:Pr);\r
+ begin\r
+ next := pp;\r
+ end info;\r
+ unit send : procedure( x,n: integer);\r
+ begin\r
+ call E.pisz(x,5+2*nr+1,x_pos,1);\r
+ \r
+ x_pos := x_pos+4;\r
+ prive := x;number :=n;\r
+ end send;\r
+ unit work : procedure(output x : integer);\r
+ begin\r
+ x := random * 10;\r
+ call E.pisz(x,5+2*nr,w_pos,3);\r
+ w_pos := w_pos+4;\r
+ end work;\r
+begin\r
+ \r
+ x_pos := 10;\r
+ w_pos := 10;\r
+ call E.pisz(nr,5+2*nr,2,2);\r
+(* number:= E.inchar; *)\r
+ return;\r
+ if booo then\r
+ accept info;\r
+ call work(prive);\r
+ call next.send(prive,nr);\r
+ fi;\r
+ do\r
+ accept send;\r
+ if prive = 0 then\r
+ if number<>nr then call next.send(0,number) fi;\r
+ call E.pisz(0,5+2*nr,x_pos,4);\r
+ if number=nr then call E.koniec fi;\r
+ exit\r
+ fi;\r
+ call work(prive);\r
+ call next.send(prive,nr);\r
+ \r
+ od;\r
+ \r
+end Pr;\r
+ \r
+var Ar_Pr: arrayof Pr, pp,q : Pr, nb_pr ,i: integer, Ek: ecran;\r
+ \r
+begin (* main program *******************************************)\r
+ call ranset(5);\r
+ writeln;\r
+ write("Nb process = ");\r
+ readln(nb_pr);\r
+ array Ar_Pr dim (1:nb_pr);\r
+ \r
+ Ek := new ecran(0);\r
+ resume(Ek);\r
+ pp := new Pr(0,nb_pr,true,none, Ek);\r
+ q:=pp;\r
+ resume(pp);\r
+ for i :=nb_pr-1 downto 1\r
+ do\r
+ pp := new Pr(0,i,false,pp,Ek);\r
+ resume(pp);\r
+ od;\r
+ \r
+ call q.info(pp);\r
+end ring;\r
--- /dev/null
+ program QMsort;\r
+ \r
+(*_____________________________________________________*)\r
+ \r
+(* Pawel Susicki 1988/89 *)\r
+(* Two sorting algorithms: quick-sort and merge-sort *)\r
+(* Warning : int /m8000 qsort *)\r
+(* The maximal number of elements < 46 *)\r
+(*_____________________________________________________*)\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
+ unit Initialization : procedure(output max , min : integer);\r
+ begin\r
+ call NewPage;\r
+ call SetCursor(5,20);\r
+ writeln("TWO SORTING ALGORITHMES");\r
+ call SetCursor(7, 20);\r
+ write("by Pawel Susicki 1988/1989");\r
+ call SetCursor(12,10);\r
+ write("This program presents the parralel realisation of the ");\r
+ call SetCursor(13,10);\r
+ write("Merge-sort and Quick-sort Algoriths.");\r
+ call SetCursor(14,10);\r
+ writeln("The Elements of the sequence are chosen randomly.");\r
+ Call SetCursor(20,5);\r
+ write("Number of elements : ");readln(max);\r
+ write(" min for a process :");readln(min);\r
+ write(" press CR to start"); readln;\r
+ end Initialization;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ unit ekran:IIUWGRAPH process(nr:integer,skip:integer);\r
+ \r
+ unit print:procedure(begin_line,index,val,kolor :integer);\r
+ begin\r
+ call color(kolor);\r
+ call move(1+index*skip,begin_line);\r
+ call draw(1+index*skip,begin_line-val);\r
+ call color(0);\r
+ call move(1+index*skip,begin_line-val-1);\r
+ call draw(1+index*skip,begin_line-150);\r
+ call move(index*skip,begin_line);\r
+ call draw(index*skip,begin_line-150);\r
+ call move(2+index*skip,begin_line);\r
+ call draw(2+index*skip,begin_line-150);\r
+ end print;\r
+ \r
+ unit lightprint:procedure(begin_line,index,val,kolor:integer);\r
+ begin\r
+ call color(kolor);\r
+ for i := 0 to 2 do\r
+ call move(i+index*skip,begin_line);\r
+ call draw(i+index*skip,begin_line-val);\r
+ od;\r
+ call color(0);\r
+ for i :=0 to 1 do\r
+ call move(i+index*skip,begin_line-val-1);\r
+ call draw(i+index*skip,begin_line-150);\r
+ od;\r
+ end lightprint;\r
+ \r
+ \r
+ unit printchr:procedure(x,y:integer,s:string);\r
+ var A : arrayof char,i : integer;\r
+ begin\r
+ A := unpack(s);\r
+ call move(x,y);\r
+ call color(14);\r
+ for i := lower(A) to upper(A)\r
+ do\r
+ call HASCII(0);\r
+ call hascii(ord(A(i)));\r
+ od;\r
+ end printchr;\r
+ \r
+ begin\r
+ call gron(0);\r
+ call cls;\r
+ return;\r
+ do\r
+ accept print,lightprint,printchr;\r
+ od;\r
+end ekran;\r
+ \r
+(*-------------------------------------------------------------------*)\r
+ \r
+ \r
+unit A: process(nr:integer,begin_line:integer,ile:integer,\r
+ E:ekran,kolor:integer);\r
+(* This process is used to keep the given sequence of elements *)\r
+(* and to do all necessary manipulations on it. *)\r
+ \r
+ var tab:arrayof integer;\r
+ \r
+ unit take:function(i:integer):integer;\r
+ begin\r
+ result:=tab(i);\r
+ end take;\r
+ \r
+ unit put_tab:procedure(i,val:integer);\r
+ begin\r
+ tab(i):=val;\r
+ call E.print(begin_line,i,val,kolor);\r
+ end put_tab;\r
+ \r
+ unit light:procedure(i:integer);\r
+ begin\r
+ call E.lightprint(begin_line,i,tab(i),kolor);\r
+ end light;\r
+ \r
+ unit normal:procedure(i:integer);\r
+ begin\r
+ call E.print(begin_line,i,tab(i),kolor);\r
+ end normal;\r
+ \r
+ unit swap:procedure(i,j:integer);\r
+ var aux:integer;\r
+ begin\r
+ aux:=tab(i);\r
+ tab(i):=tab(j);\r
+ tab(j):=aux;\r
+ call E.print(begin_line,i,tab(i),kolor);\r
+ call E.print(begin_line,j,tab(j),kolor);\r
+ end swap;\r
+ \r
+ unit comp:function(i,j:integer):integer;\r
+ begin\r
+ if tab(i)<tab(j)\r
+ then result:=-1;\r
+ else\r
+ if tab(i)>tab(j)\r
+ then result:=1;\r
+ else result:=0;\r
+ fi;\r
+ fi;\r
+ end comp;\r
+ \r
+ unit printchr:procedure(x,y:integer,s:string);\r
+ begin\r
+ call E.printchr(x,begin_line-y,s);\r
+ end printchr;\r
+ \r
+ handlers\r
+ when ACCERROR:call E.printchr(325,325,"ACCERROR");\r
+ call E.groff;call endrun;\r
+ when CONERROR:call E.printchr(325,325,"CONERROR");\r
+ call E.groff;call endrun;\r
+ when LOGERROR:call E.printchr(325,325,"LOGERROR");\r
+ call E.groff;call endrun;\r
+ when MEMERROR:call E.printchr(325,325,"MEMERROR");\r
+ call E.groff;call endrun;\r
+ when NUMERROR:call E.printchr(325,325,"NUMERROR");\r
+ call E.groff;call endrun;\r
+ when TYPERROR:call E.printchr(325,325,"TYPERROR");\r
+ call E.groff;call endrun;\r
+ when SYSERROR:call E.printchr(325,325,"SYSERROR");\r
+ call E.groff;call endrun;\r
+ end handlers;\r
+ \r
+ begin\r
+ array tab dim(1:ile);\r
+ return;\r
+ do\r
+ accept take,put_tab,swap,comp,light,normal,printchr;\r
+ od;\r
+ end A;\r
+ \r
+(*----------------------------------------------------------------*)\r
+unit sync:process(nr:integer);\r
+(*This process is used uniquely for the sake of synchronization*)\r
+ unit slock:procedure;\r
+ begin\r
+ accept sunlock;\r
+ end slock;\r
+ \r
+ unit sunlock:procedure;\r
+ begin\r
+ end sunlock;\r
+ \r
+ begin\r
+ return;\r
+ do\r
+ accept slock;\r
+ od;\r
+end sync;\r
+ \r
+(*--------------------------------------------------------------------*)\r
+ \r
+unit BS:process(nr:integer,from,until:integer,T:A,father:P);\r
+(* Bubbel-sort algorithm. Both main-processes PMS and PQS use *)\r
+(* this algorithm in the case the longeur of the table is<min *)\r
+ \r
+ var left:integer, l:boolean;\r
+ begin\r
+ return;\r
+ do\r
+ l:=true;\r
+ left:=from;\r
+ do\r
+ call T.normal(left);\r
+ if T.comp(left,left+1)>0 then\r
+ call T.swap(left,left+1);\r
+ l:=false;\r
+ fi;\r
+ if left=from then call T.light(left); fi;\r
+ left:=left+1;\r
+ if left >= until then exit; fi;\r
+ call T.normal(left);(*bylo reverse*)\r
+ od;\r
+ call T.normal(from);\r
+ if l then exit; fi;\r
+ od;\r
+ call father.sync;\r
+end BS;\r
+(*---------------------------------------------------------------*)\r
+ \r
+unit P: process(nr, from,until,min:integer, T:A, father:P,\r
+ b:boolean,S:sync);\r
+(* Process- prefix for both Quick and Merge sort *)\r
+ var kolega:P, bubble:BS, left,right:integer;\r
+ \r
+ unit sync:procedure;\r
+ end sync;\r
+ \r
+handlers\r
+ when ACCERROR:call T.E.GROFF;writeln("ACCERROR");call endrun;\r
+ when CONERROR:call T.E.GROFF;writeln("CONERROR");call endrun;\r
+ when LOGERROR:call T.E.GROFF;writeln("LOGERROR");call endrun;\r
+ when MEMERROR:call T.E.GROFF;writeln("MEMERROR");call endrun;\r
+ when NUMERROR:call T.E.GROFF;writeln("NUMERROR");call endrun;\r
+ when TYPERROR:call T.E.GROFF;writeln("TYPERROR");call endrun;\r
+ when SYSERROR:call T.E.GROFF;writeln("SYSERROR");call endrun;\r
+end handlers;\r
+ \r
+end P;\r
+ \r
+unit PMS:P process;\r
+(* Algorithm MERGE-SORT. *)\r
+ var ll,rr:integer;\r
+ var tab:arrayof integer;\r
+ var l,r:boolean;\r
+ \r
+ begin\r
+ return;\r
+ call T.light(from);\r
+ left:=from+(until-from)div 2;\r
+ right:=left+1;\r
+ l:=false;\r
+ r:=true;\r
+ if left > from\r
+ then\r
+ l:=true;\r
+ if right-from+1 > min\r
+ then\r
+ kolega:=new PMS(0,from,left,min,T,this PMS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,from,left,T,this PMS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ if until > right\r
+ then\r
+ r:=true;\r
+ if until-right+1 > min\r
+ then\r
+ kolega:=new PMS(0,right,until,min,T,this PMS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,right,until,T,this PMS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ if l then accept sync; fi;\r
+ if r then accept sync; fi;\r
+ array tab dim(from:until);\r
+ left:=from;\r
+ ll:=from;\r
+ rr:=right;\r
+ do\r
+ if left>=rr\r
+ then\r
+ tab(ll):=T.take(right);\r
+ right:=right+1;\r
+ else\r
+ if right>until\r
+ then\r
+ tab(ll):=T.take(left);\r
+ left:=left+1;\r
+ else\r
+ if T.comp(left,right)<0\r
+ then\r
+ tab(ll):=T.take(left);\r
+ left:=left+1;\r
+ else\r
+ tab(ll):=T.take(right);\r
+ right:=right+1;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ ll:=ll+1;\r
+ if ll>until then exit; fi;\r
+ od;\r
+ left:=from;\r
+ do\r
+ call T.put_tab(left,tab(left));\r
+ left:=left+1;\r
+ if left>until then exit; fi;\r
+ od;\r
+ if not b\r
+ then call father.sync;\r
+ else\r
+ call T.printchr(50,60,"MERGE - SORT" );\r
+ call S.sunlock;\r
+ fi;\r
+end PMS;\r
+ \r
+unit PQS:P process;\r
+ \r
+ var counter:integer;\r
+ \r
+ unit shuffle:procedure;\r
+ begin\r
+ call T.light(from);\r
+ left:=from+1;\r
+ right:=until;\r
+ do\r
+ while T.comp(from,left) >=0 do\r
+ call T.normal(left);\r
+ left:=left+1;\r
+ if left < right then call T.normal(left); fi;\r
+ if left > right then exit; fi;\r
+ od;\r
+ while T.comp(from,right)<=0 do\r
+ call T.normal(right);\r
+ right:=right-1;\r
+ if left < right then call T.normal(right); fi;\r
+ if left > right then exit; fi;\r
+ od;\r
+ if left<right then\r
+ call T.swap(left,right);\r
+ call T.normal(left);\r
+ call T.normal(right);\r
+ fi;\r
+ if left >= right then exit; fi;\r
+ od;\r
+ call T.swap(from,right);\r
+ end shuffle;\r
+ \r
+ unit gen:procedure(from,until:integer; inout c:integer);\r
+ begin\r
+ if from < until\r
+ then\r
+ c:=c+1;\r
+ if until-right > min\r
+ then\r
+ kolega:=new PQS(0,from,until,min,T,this PQS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,from,until,T,this PQS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ end gen;\r
+ \r
+ begin\r
+ counter:=0;\r
+ return;\r
+ call shuffle;\r
+ while imax(right-from,until-right) > min+1 do\r
+ if until-right < right-from\r
+ then\r
+ call gen(right+1,until,counter);\r
+ until:=right-1;\r
+ else\r
+ call gen(from,right-1,counter);\r
+ from:=right+1;\r
+ fi;\r
+ call shuffle;\r
+ od;\r
+ call gen(right+1,until,counter);\r
+ call gen(from,right-1,counter);\r
+ while counter > 0 do\r
+ accept sync;\r
+ counter:=counter-1;\r
+ od;\r
+ if not b\r
+ then call father.sync;\r
+ else\r
+ call T.printchr(50,60,"QUICK - SORT");\r
+ call S.sunlock;\r
+ fi;\r
+end PQS;\r
+(*--------------------------------------------------------------------*)\r
+ \r
+ \r
+var E:ekran,T0,T1:A, S:sync, P1:PMS, P2:PQS,\r
+ i,x,max,min:integer;\r
+ \r
+begin\r
+ call Initialization(max,min);\r
+ \r
+ E:=new ekran(0,600/max);\r
+ resume(E);\r
+ (* the processes TO and T1 are used to operate on the given sequence*)\r
+ T0:=new A(0,160,max,E,10);\r
+ T1:=new A(0,320,max,E,11);\r
+ resume(T0);\r
+ resume(T1);\r
+ \r
+ i:=1;\r
+ while i <= max do\r
+ x := random*150;\r
+ call T0.put_tab(i,x);\r
+ call T1.put_tab(i,x);\r
+ i:=i+1;\r
+ od;\r
+ \r
+ S:=new sync(0);\r
+ resume(S);\r
+ \r
+ P1:=new PMS(0,1,max,min,T0,none,true,S);\r
+ P2:=new PQS(0,1,max,min,T1,none,true,S);\r
+ resume(P1);\r
+ resume(P2);\r
+ call S.slock;(* main wait for all other processes *)\r
+ call S.slock;\r
+ \r
+ call E.printchr(450,325,"press CR"); readln;\r
+ call E.groff;\r
+ call endrun;\r
+end qsort.\r
--- /dev/null
+\r
+ LOGLAN-82 UNIX Compiler, Version 2.1\r
+ January 10, 1993\r
+ (C)Copyright Institute of Informatics, University of Warsaw (C)Copyleft LITA Universite de Pau\r
+\r
+ Pass One\r
+\r
+Error no 308 in file SORT.LOG at line 52 :\r
+ UNDECLARED PREFIX IDENTIFIER IWGRAPH \r
+Error no 600 in file SORT.LOG at line 56 :\r
+ UNDECLARED IDENTIFIER COLOR \r
+Error no 600 in file SORT.LOG at line 57 :\r
+ UNDECLARED IDENTIFIER MOVE \r
+Error no 600 in file SORT.LOG at line 58 :\r
+ UNDECLARED IDENTIFIER DRAW \r
+Error no 600 in file SORT.LOG at line 70 :\r
+ UNDECLARED IDENTIFIER COLOR \r
+Error no 600 in file SORT.LOG at line 72 :\r
+ UNDECLARED IDENTIFIER MOVE \r
+Error no 600 in file SORT.LOG at line 73 :\r
+ UNDECLARED IDENTIFIER DRAW \r
+Error no 600 in file SORT.LOG at line 87 :\r
+ UNDECLARED IDENTIFIER MOVE \r
+Error no 600 in file SORT.LOG at line 88 :\r
+ UNDECLARED IDENTIFIER COLOR \r
+Error no 600 in file SORT.LOG at line 91 :\r
+ UNDECLARED IDENTIFIER HASCII \r
+Error no 600 in file SORT.LOG at line 97 :\r
+ UNDECLARED IDENTIFIER GRON \r
+Error no 600 in file SORT.LOG at line 98 :\r
+ UNDECLARED IDENTIFIER CLS \r
+Error no 603 in file SORT.LOG at line 450 :\r
+ UNDECLARED IDENTIFIER AFTER "." GROFF \r
+\r
+ 13 error(s) detected\r
--- /dev/null
+ program QMsort;\r
+ \r
+(*_____________________________________________________*)\r
+ \r
+(* Pawel Susicki 1988/89 *)\r
+(* Two sorting algorithms: quick-sort and merge-sort *)\r
+(* Warning : int /m8000 qsort *)\r
+(* The maximal number of elements < 46 *)\r
+(*_____________________________________________________*)\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+ \r
+ unit Initialization : procedure(output max , min : integer);\r
+ begin\r
+ call NewPage;\r
+ call SetCursor(5,20);\r
+ writeln("TWO SORTING ALGORITHMES");\r
+ call SetCursor(7, 20);\r
+ write("by Pawel Susicki 1988/1989");\r
+ call SetCursor(12,10);\r
+ write("This program presents the parralel realisation of the ");\r
+ call SetCursor(13,10);\r
+ write("Merge-sort and Quick-sort Algoriths.");\r
+ call SetCursor(14,10);\r
+ writeln("The Elements of the sequence are chosen randomly.");\r
+ Call SetCursor(20,5);\r
+ write("Number of elements : ");readln(max);\r
+ write(" min for a process :");readln(min);\r
+ write(" press CR to start"); readln;\r
+ end Initialization;\r
+ \r
+(*------------------------------------------------------------------------*)\r
+ \r
+ unit ekran:IWGRAPH process(nr:integer,skip:integer);\r
+ \r
+ unit print:procedure(begin_line,index,val,kolor :integer);\r
+ begin\r
+ call color(kolor);\r
+ call move(1+index*skip,begin_line);\r
+ call draw(1+index*skip,begin_line-val);\r
+ call color(0);\r
+ call move(1+index*skip,begin_line-val-1);\r
+ call draw(1+index*skip,begin_line-150);\r
+ call move(index*skip,begin_line);\r
+ call draw(index*skip,begin_line-150);\r
+ call move(2+index*skip,begin_line);\r
+ call draw(2+index*skip,begin_line-150);\r
+ end print;\r
+ \r
+ unit lightprint:procedure(begin_line,index,val,kolor:integer);\r
+ begin\r
+ call color(kolor);\r
+ for i := 0 to 2 do\r
+ call move(i+index*skip,begin_line);\r
+ call draw(i+index*skip,begin_line-val);\r
+ od;\r
+ call color(0);\r
+ for i :=0 to 1 do\r
+ call move(i+index*skip,begin_line-val-1);\r
+ call draw(i+index*skip,begin_line-150);\r
+ od;\r
+ end lightprint;\r
+ \r
+ \r
+ unit printchr:procedure(x,y:integer,s:string);\r
+ var A : arrayof char,i : integer;\r
+ begin\r
+ A := unpack(s);\r
+ call move(x,y);\r
+ call color(14);\r
+ for i := lower(A) to upper(A)\r
+ do\r
+ call HASCII(0);\r
+ call hascii(ord(A(i)));\r
+ od;\r
+ end printchr;\r
+ \r
+ begin\r
+ call gron(0);\r
+ call cls;\r
+ return;\r
+ do\r
+ accept print,lightprint,printchr;\r
+ od;\r
+end ekran;\r
+ \r
+(*-------------------------------------------------------------------*)\r
+ \r
+ \r
+unit A: process(nr:integer,begin_line:integer,ile:integer,\r
+ E:ekran,kolor:integer);\r
+(* This process is used to keep the given sequence of elements *)\r
+(* and to do all necessary manipulations on it. *)\r
+ \r
+ var tab:arrayof integer;\r
+ \r
+ unit take:function(i:integer):integer;\r
+ begin\r
+ result:=tab(i);\r
+ end take;\r
+ \r
+ unit put_tab:procedure(i,val:integer);\r
+ begin\r
+ tab(i):=val;\r
+ call E.print(begin_line,i,val,kolor);\r
+ end put_tab;\r
+ \r
+ unit light:procedure(i:integer);\r
+ begin\r
+ call E.lightprint(begin_line,i,tab(i),kolor);\r
+ end light;\r
+ \r
+ unit normal:procedure(i:integer);\r
+ begin\r
+ call E.print(begin_line,i,tab(i),kolor);\r
+ end normal;\r
+ \r
+ unit swap:procedure(i,j:integer);\r
+ var aux:integer;\r
+ begin\r
+ aux:=tab(i);\r
+ tab(i):=tab(j);\r
+ tab(j):=aux;\r
+ call E.print(begin_line,i,tab(i),kolor);\r
+ call E.print(begin_line,j,tab(j),kolor);\r
+ end swap;\r
+ \r
+ unit comp:function(i,j:integer):integer;\r
+ begin\r
+ if tab(i)<tab(j)\r
+ then result:=-1;\r
+ else\r
+ if tab(i)>tab(j)\r
+ then result:=1;\r
+ else result:=0;\r
+ fi;\r
+ fi;\r
+ end comp;\r
+ \r
+ unit printchr:procedure(x,y:integer,s:string);\r
+ begin\r
+ call E.printchr(x,begin_line-y,s);\r
+ end printchr;\r
+ \r
+ handlers\r
+ when ACCERROR:call E.printchr(325,325,"ACCERROR");\r
+ call E.groff;call endrun;\r
+ when CONERROR:call E.printchr(325,325,"CONERROR");\r
+ call E.groff;call endrun;\r
+ when LOGERROR:call E.printchr(325,325,"LOGERROR");\r
+ call E.groff;call endrun;\r
+ when MEMERROR:call E.printchr(325,325,"MEMERROR");\r
+ call E.groff;call endrun;\r
+ when NUMERROR:call E.printchr(325,325,"NUMERROR");\r
+ call E.groff;call endrun;\r
+ when TYPERROR:call E.printchr(325,325,"TYPERROR");\r
+ call E.groff;call endrun;\r
+ when SYSERROR:call E.printchr(325,325,"SYSERROR");\r
+ call E.groff;call endrun;\r
+ end handlers;\r
+ \r
+ begin\r
+ array tab dim(1:ile);\r
+ return;\r
+ do\r
+ accept take,put_tab,swap,comp,light,normal,printchr;\r
+ od;\r
+ end A;\r
+ \r
+(*----------------------------------------------------------------*)\r
+unit sync:process(nr:integer);\r
+(*This process is used uniquely for the sake of synchronization*)\r
+ unit slock:procedure;\r
+ begin\r
+ accept sunlock;\r
+ end slock;\r
+ \r
+ unit sunlock:procedure;\r
+ begin\r
+ end sunlock;\r
+ \r
+ begin\r
+ return;\r
+ do\r
+ accept slock;\r
+ od;\r
+end sync;\r
+ \r
+(*--------------------------------------------------------------------*)\r
+ \r
+unit BS:process(nr:integer,from,until:integer,T:A,father:P);\r
+(* Bubbel-sort algorithm. Both main-processes PMS and PQS use *)\r
+(* this algorithm in the case the longeur of the table is<min *)\r
+ \r
+ var left:integer, l:boolean;\r
+ begin\r
+ return;\r
+ do\r
+ l:=true;\r
+ left:=from;\r
+ do\r
+ call T.normal(left);\r
+ if T.comp(left,left+1)>0 then\r
+ call T.swap(left,left+1);\r
+ l:=false;\r
+ fi;\r
+ if left=from then call T.light(left); fi;\r
+ left:=left+1;\r
+ if left >= until then exit; fi;\r
+ call T.normal(left);(*bylo reverse*)\r
+ od;\r
+ call T.normal(from);\r
+ if l then exit; fi;\r
+ od;\r
+ call father.sync;\r
+end BS;\r
+(*---------------------------------------------------------------*)\r
+ \r
+unit P: process(nr, from,until,min:integer, T:A, father:P,\r
+ b:boolean,S:sync);\r
+(* Process- prefix for both Quick and Merge sort *)\r
+ var kolega:P, bubble:BS, left,right:integer;\r
+ \r
+ unit sync:procedure;\r
+ end sync;\r
+ \r
+handlers\r
+ when ACCERROR:call T.E.GROFF;writeln("ACCERROR");call endrun;\r
+ when CONERROR:call T.E.GROFF;writeln("CONERROR");call endrun;\r
+ when LOGERROR:call T.E.GROFF;writeln("LOGERROR");call endrun;\r
+ when MEMERROR:call T.E.GROFF;writeln("MEMERROR");call endrun;\r
+ when NUMERROR:call T.E.GROFF;writeln("NUMERROR");call endrun;\r
+ when TYPERROR:call T.E.GROFF;writeln("TYPERROR");call endrun;\r
+ when SYSERROR:call T.E.GROFF;writeln("SYSERROR");call endrun;\r
+end handlers;\r
+ \r
+end P;\r
+ \r
+unit PMS:P process;\r
+(* Algorithm MERGE-SORT. *)\r
+ var ll,rr:integer;\r
+ var tab:arrayof integer;\r
+ var l,r:boolean;\r
+ \r
+ begin\r
+ return;\r
+ call T.light(from);\r
+ left:=from+(until-from)div 2;\r
+ right:=left+1;\r
+ l:=false;\r
+ r:=true;\r
+ if left > from\r
+ then\r
+ l:=true;\r
+ if right-from+1 > min\r
+ then\r
+ kolega:=new PMS(0,from,left,min,T,this PMS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,from,left,T,this PMS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ if until > right\r
+ then\r
+ r:=true;\r
+ if until-right+1 > min\r
+ then\r
+ kolega:=new PMS(0,right,until,min,T,this PMS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,right,until,T,this PMS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ if l then accept sync; fi;\r
+ if r then accept sync; fi;\r
+ array tab dim(from:until);\r
+ left:=from;\r
+ ll:=from;\r
+ rr:=right;\r
+ do\r
+ if left>=rr\r
+ then\r
+ tab(ll):=T.take(right);\r
+ right:=right+1;\r
+ else\r
+ if right>until\r
+ then\r
+ tab(ll):=T.take(left);\r
+ left:=left+1;\r
+ else\r
+ if T.comp(left,right)<0\r
+ then\r
+ tab(ll):=T.take(left);\r
+ left:=left+1;\r
+ else\r
+ tab(ll):=T.take(right);\r
+ right:=right+1;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ ll:=ll+1;\r
+ if ll>until then exit; fi;\r
+ od;\r
+ left:=from;\r
+ do\r
+ call T.put_tab(left,tab(left));\r
+ left:=left+1;\r
+ if left>until then exit; fi;\r
+ od;\r
+ if not b\r
+ then call father.sync;\r
+ else\r
+ call T.printchr(50,60,"MERGE - SORT" );\r
+ call S.sunlock;\r
+ fi;\r
+end PMS;\r
+ \r
+unit PQS:P process;\r
+ \r
+ var counter:integer;\r
+ \r
+ unit shuffle:procedure;\r
+ begin\r
+ call T.light(from);\r
+ left:=from+1;\r
+ right:=until;\r
+ do\r
+ while T.comp(from,left) >=0 do\r
+ call T.normal(left);\r
+ left:=left+1;\r
+ if left < right then call T.normal(left); fi;\r
+ if left > right then exit; fi;\r
+ od;\r
+ while T.comp(from,right)<=0 do\r
+ call T.normal(right);\r
+ right:=right-1;\r
+ if left < right then call T.normal(right); fi;\r
+ if left > right then exit; fi;\r
+ od;\r
+ if left<right then\r
+ call T.swap(left,right);\r
+ call T.normal(left);\r
+ call T.normal(right);\r
+ fi;\r
+ if left >= right then exit; fi;\r
+ od;\r
+ call T.swap(from,right);\r
+ end shuffle;\r
+ \r
+ unit gen:procedure(from,until:integer; inout c:integer);\r
+ begin\r
+ if from < until\r
+ then\r
+ c:=c+1;\r
+ if until-right > min\r
+ then\r
+ kolega:=new PQS(0,from,until,min,T,this PQS,false,S);\r
+ resume(kolega);\r
+ else\r
+ bubble:=new BS(0,from,until,T,this PQS);\r
+ resume(bubble);\r
+ fi;\r
+ fi;\r
+ end gen;\r
+ \r
+ begin\r
+ counter:=0;\r
+ return;\r
+ call shuffle;\r
+ while imax(right-from,until-right) > min+1 do\r
+ if until-right < right-from\r
+ then\r
+ call gen(right+1,until,counter);\r
+ until:=right-1;\r
+ else\r
+ call gen(from,right-1,counter);\r
+ from:=right+1;\r
+ fi;\r
+ call shuffle;\r
+ od;\r
+ call gen(right+1,until,counter);\r
+ call gen(from,right-1,counter);\r
+ while counter > 0 do\r
+ accept sync;\r
+ counter:=counter-1;\r
+ od;\r
+ if not b\r
+ then call father.sync;\r
+ else\r
+ call T.printchr(50,60,"QUICK - SORT");\r
+ call S.sunlock;\r
+ fi;\r
+end PQS;\r
+(*--------------------------------------------------------------------*)\r
+ \r
+ \r
+var E:ekran,T0,T1:A, S:sync, P1:PMS, P2:PQS,\r
+ i,x,max,min:integer;\r
+ \r
+begin\r
+ call Initialization(max,min);\r
+ \r
+ E:=new ekran(0,600/max);\r
+ resume(E);\r
+ (* the processes TO and T1 are used to operate on the given sequence*)\r
+ T0:=new A(0,160,max,E,10);\r
+ T1:=new A(0,320,max,E,11);\r
+ resume(T0);\r
+ resume(T1);\r
+ \r
+ i:=1;\r
+ while i <= max do\r
+ x := random*150;\r
+ call T0.put_tab(i,x);\r
+ call T1.put_tab(i,x);\r
+ i:=i+1;\r
+ od;\r
+ \r
+ S:=new sync(0);\r
+ resume(S);\r
+ \r
+ P1:=new PMS(0,1,max,min,T0,none,true,S);\r
+ P2:=new PQS(0,1,max,min,T1,none,true,S);\r
+ resume(P1);\r
+ resume(P2);\r
+ call S.slock;(* main wait for all other processes *)\r
+ call S.slock;\r
+ \r
+ call E.printchr(450,325,"press CR"); readln;\r
+ call E.groff;\r
+ call endrun;\r
+end qsort.\r
--- /dev/null
+BLOCK
+(* BANK DEPARTMENT SERVICE SIMULATION *)
+
+
+
+UNIT PRIORITYQUEUE: CLASS;
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)
+
+
+
+ UNIT QUEUEHEAD: CLASS;
+ (* HEAP ACCESING MODULE *)
+ VAR LAST,ROOT:NODE;
+
+ UNIT MIN: FUNCTION: ELEM;
+ BEGIN
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;
+ END MIN;
+
+ UNIT INSERT: PROCEDURE(R:ELEM);
+ (* INSERTION INTO HEAP *)
+ VAR X,Z:NODE;
+ BEGIN
+ X:= R.LAB;
+ IF LAST=NONE THEN
+ ROOT:=X;
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT
+ ELSE
+ IF LAST.NS=0 THEN
+ LAST.NS:=1;
+ Z:=LAST.LEFT;
+ LAST.LEFT:=X;
+ X.UP:=LAST;
+ X.LEFT:=Z;
+ Z.RIGHT:=X;
+ ELSE
+ LAST.NS:=2;
+ Z:=LAST.RIGHT;
+ LAST.RIGHT:=X;
+ X.RIGHT:=Z;
+ X.UP:=LAST;
+ Z.LEFT:=X;
+ LAST.LEFT.RIGHT:=X;
+ X.LEFT:=LAST.LEFT;
+ LAST:=Z;
+ FI
+ FI;
+ CALL CORRECT(R,FALSE)
+ END INSERT;
+
+UNIT DELETE: PROCEDURE(R: ELEM);
+ VAR X,Y,Z:NODE;
+ BEGIN
+ X:=R.LAB;
+ Z:=LAST.LEFT;
+ IF LAST.NS =0 THEN
+ Y:= Z.UP;
+ Y.RIGHT:= LAST;
+ LAST.LEFT:=Y;
+ LAST:=Y;
+ ELSE
+ Y:= Z.LEFT;
+ Y.RIGHT:= LAST;
+ LAST.LEFT:= Y;
+ FI;
+ Z.EL.LAB:=X;
+ X.EL:= Z.EL;
+ LAST.NS:= LAST.NS-1;
+ R.LAB:=Z;
+ Z.EL:=R;
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)
+ ELSE CALL CORRECT(X.EL,TRUE) FI;
+ END DELETE;
+
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;
+ BEGIN
+ Z:=R.LAB;
+ IF DOWN THEN
+ WHILE NOT FIN DO
+ IF Z.NS =0 THEN FIN:=TRUE ELSE
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT
+ FI; FI;
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE
+ T:=X.EL;
+ X.EL:=Z.EL;
+ Z.EL:=T;
+ Z.EL.LAB:=Z;
+ X.EL.LAB:=X
+ FI; FI;
+ Z:=X;
+ OD
+ ELSE
+ X:=Z.UP;
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;
+ WHILE NOT LOG DO
+ T:=Z.EL;
+ Z.EL:=X.EL;
+ X.EL:=T;
+ X.EL.LAB:=X;
+ Z.EL.LAB:=Z;
+ Z:=X;
+ X:=Z.UP;
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);
+ FI;
+ OD
+ FI;
+ END CORRECT;
+
+END QUEUEHEAD;
+
+
+UNIT NODE: CLASS (EL:ELEM);
+ (* ELEMENT OF THE HEAP *)
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;
+ BEGIN
+ IF X= NONE THEN RESULT:=FALSE
+ ELSE RESULT:=EL.LESS(X.EL) FI;
+ END LESS;
+ END NODE;
+
+
+UNIT ELEM: CLASS(PRIOR:REAL);
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)
+ VAR LAB: NODE;
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;
+ BEGIN
+ IF X=NONE THEN RESULT:= FALSE ELSE
+ RESULT:= PRIOR< X.PRIOR FI;
+ END LESS;
+ BEGIN
+ LAB:= NEW NODE(THIS ELEM);
+ END ELEM;
+
+
+END PRIORITYQUEUE;
+
+
+
+UNIT SIMULATION: PRIORITYQUEUE CLASS;
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)
+
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)
+ MAINPR: MAINPROGRAM;
+
+
+ UNIT SIMPROCESS: COROUTINE;
+ (* USER PROCESS PREFIX *)
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)
+ EVENTAUX: EVENTNOTICE,
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)
+ FINISH: BOOLEAN;
+
+ UNIT IDLE: FUNCTION: BOOLEAN;
+ BEGIN
+ RESULT:= EVENT= NONE;
+ END IDLE;
+
+ UNIT TERMINATED: FUNCTION :BOOLEAN;
+ BEGIN
+ RESULT:= FINISH;
+ END TERMINATED;
+
+ UNIT EVTIME: FUNCTION: REAL;
+ (* TIME OF ACTIVATION *)
+ BEGIN
+ IF IDLE THEN CALL ERROR1;
+ FI;
+ RESULT:= EVENT.EVENTTIME;
+ END EVTIME;
+
+ UNIT ERROR1:PROCEDURE;
+ BEGIN
+ ATTACH(MAIN);
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");
+ END ERROR1;
+
+ UNIT ERROR2:PROCEDURE;
+ BEGIN
+ ATTACH(MAIN);
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");
+ END ERROR2;
+ BEGIN
+
+ RETURN;
+ INNER;
+ FINISH:=TRUE;
+ CALL PASSIVATE;
+ CALL ERROR2;
+ END SIMPROCESS;
+
+
+UNIT EVENTNOTICE: ELEM CLASS;
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;
+
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)
+ BEGIN
+ IF X=NONE THEN RESULT:= FALSE ELSE
+ RESULT:= EVENTTIME< X.EVENTTIME OR
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;
+
+ END LESS;
+ END EVENTNOTICE;
+
+
+UNIT MAINPROGRAM: SIMPROCESS CLASS;
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)
+ BEGIN
+ DO ATTACH(MAIN) OD;
+ END MAINPROGRAM;
+
+UNIT TIME:FUNCTION:REAL;
+ (* CURRENT VALUE OF SIMULATION TIME *)
+ BEGIN
+ RESULT:=CURRENT.EVTIME
+ END TIME;
+
+UNIT CURRENT: FUNCTION: SIMPROCESS;
+ (* THE FIRST PROCESS ON THE TIME AXIS *)
+ BEGIN
+ RESULT:=CURR;
+ END CURRENT;
+
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)
+ (* WITHIN TIME MOMENT T *)
+ BEGIN
+ IF T<TIME THEN T:= TIME FI;
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);
+ P.EVENT.PROC:= P;
+ ELSE
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN
+ P.EVENT:= P.EVENTAUX;
+ P.EVENT.PRIOR:=RANDOM;
+ ELSE
+ (* NEW SCHEDULING *)
+ P.EVENT.PRIOR:=RANDOM;
+ CALL PQ.DELETE(P.EVENT)
+ FI; FI;
+ P.EVENT.EVENTTIME:= T;
+ CALL PQ.INSERT(P.EVENT) FI;
+END SCHEDULE;
+
+UNIT HOLD:PROCEDURE(T:REAL);
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)
+ (* REDEFINE PRIOR *)
+ BEGIN
+ CALL PQ.DELETE(CURRENT.EVENT);
+ CURRENT.EVENT.PRIOR:=RANDOM;
+ IF T<0 THEN T:=0; FI;
+ CURRENT.EVENT.EVENTTIME:=TIME+T;
+ CALL PQ.INSERT(CURRENT.EVENT);
+ CALL CHOICEPROCESS;
+ END HOLD;
+
+UNIT PASSIVATE: PROCEDURE;
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)
+ BEGIN
+ CALL PQ.DELETE(CURRENT.EVENT);
+ CURRENT.EVENT:=NONE;
+ CALL CHOICEPROCESS
+ END PASSIVATE;
+
+UNIT RUN: PROCEDURE(P:SIMPROCESS);
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)
+ (* PRIOR *)
+ BEGIN
+ CURRENT.EVENT.PRIOR:=RANDOM;
+ IF NOT P.IDLE THEN
+ P.EVENT.PRIOR:=0;
+ P.EVENT.EVENTTIME:=TIME;
+ CALL PQ.CORRECT(P.EVENT,FALSE)
+ ELSE
+ IF P.EVENTAUX=NONE THEN
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);
+ P.EVENT.EVENTTIME:=TIME;
+ P.EVENT.PROC:=P;
+ CALL PQ.INSERT(P.EVENT)
+ ELSE
+ P.EVENT:=P.EVENTAUX;
+ P.EVENT.PRIOR:=0;
+ P.EVENT.EVENTTIME:=TIME;
+ P.EVENT.PROC:=P;
+ CALL PQ.INSERT(P.EVENT);
+ FI;FI;
+ CALL CHOICEPROCESS;
+END RUN;
+
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)
+ BEGIN
+ IF P= CURRENT THEN CALL PASSIVATE ELSE
+ CALL PQ.DELETE(P.EVENT);
+ P.EVENT:=NONE; FI;
+ END CANCEL;
+
+UNIT CHOICEPROCESS:PROCEDURE;
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)
+ VAR P:SIMPROCESS;
+ BEGIN
+ P:=CURR;
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;
+ ATTACH(MAIN);
+ ELSE ATTACH(CURR); FI;
+END CHOICEPROCESS;
+
+BEGIN
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)
+ CURR,MAINPR:=NEW MAINPROGRAM;
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);
+ MAINPR.EVENT.EVENTTIME:=0;
+ MAINPR.EVENT.PROC:=MAINPR;
+ CALL PQ.INSERT(MAINPR.EVENT);
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)
+ INNER;
+ PQ:=NONE;
+END SIMULATION;
+
+
+
+UNIT LISTS:SIMULATION CLASS;
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)
+
+ UNIT LINKAGE:CLASS;
+ (*WE WILL USE TWO WAY LISTS *)
+ VAR SUC1,PRED1:LINKAGE;
+ END LINKAGE;
+ UNIT HEAD:LINKAGE CLASS;
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)
+ UNIT FIRST:FUNCTION:LINK;
+ BEGIN
+ IF SUC1 IN LINK THEN RESULT:=SUC1
+ ELSE RESULT:=NONE FI;
+ END;
+ UNIT EMPTY:FUNCTION:BOOLEAN;
+ BEGIN
+ RESULT:=SUC1=THIS LINKAGE;
+ END EMPTY;
+ BEGIN
+ SUC1,PRED1:=THIS LINKAGE;
+ END HEAD;
+
+ UNIT LINK:LINKAGE CLASS;
+ (* ORDINARY LIST ELEMENT PREFIX *)
+ UNIT OUT:PROCEDURE;
+ BEGIN
+ IF SUC1=/=NONE THEN
+ SUC1.PRED1:=PRED1;
+ PRED1.SUC1:=SUC1;
+ SUC1,PRED1:=NONE FI;
+ END OUT;
+ UNIT INTO:PROCEDURE(S:HEAD);
+ BEGIN
+
+ CALL OUT;
+ IF S=/= NONE THEN
+ IF S.SUC1=/=NONE THEN
+ SUC1:=S;
+ PRED1:=S.PRED1;
+ PRED1.SUC1:=THIS LINKAGE;
+ S.PRED1:=THIS LINKAGE;
+ FI FI;
+ END INTO;
+ END LINK;
+
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)
+ END ELEM;
+
+ END LISTS;
+
+
+
+
+
+ (*BEGIN OF BANK DEPARTMENT SIMULATION*)
+
+
+ UNIT OFFICE:LISTS CLASS; (*AN OFFICE*)
+
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);
+ (* TELLER WITH CUSTOMERS QUEUEING UP *)
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ (* SERVICE OF THIS TELLER WILL BE PRECISED LATER *)
+ END SERVICE;
+ VAR CSTM:CUSTOMER, (*THE CUSTOMER BEING SERVED*)
+ REST,PAUSE:REAL;
+
+ BEGIN
+ PAUSE:=TIME;
+ DO
+ REST:=REST+TIME-PAUSE;
+ WHILE NOT QUEUE.EMPTY DO
+ (* SERVE ALL QUEUE *)
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;
+ CALL SERVICE;
+ CALL SCHEDULE(CSTM,TIME);
+ OD;
+ PAUSE:=TIME;
+ CALL PASSIVATE
+ OD;
+ END TILL;
+
+ UNIT CUSTOMER:SIMPROCESS CLASS;
+
+ VAR ELLIST:ELEM, K:INTEGER;
+ UNIT ARRIVAL:PROCEDURE(S:TILL);
+ (* ATTACHING TELLER S *)
+ BEGIN
+ IF S=/=NONE THEN
+ ELLIST:=NEW ELEM(THIS CUSTOMER);
+ CALL ELLIST.INTO(S.QUEUE);
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME) FI;
+ CALL PASSIVATE; FI;
+ END ARRIVAL;
+ END CUSTOMER;
+
+ END OFFICE;
+
+
+
+UNIT BANKDEPARTMENT:OFFICE CLASS;
+
+
+ UNIT COUNTER:TILL CLASS;
+ VAR PAYTIME:REAL; (*RANDOM SERVICE TIME*)
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ BEGIN
+ WRITELN(" THE PAY DESK SERVES CUSTOMER NO",CSTM.K,
+ " AT",TIME:10:4);
+ CALL CSTM.ELLIST.OUT;
+ PAYTIME:=RANDOM*2+2;
+ CALL HOLD(PAYTIME);
+ END SERVICE;
+ END COUNTER;
+
+
+ UNIT TELLER:TILL CLASS(NUMBER:INTEGER);
+ VAR SERVICETIME:REAL;
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ VAR N:INTEGER;
+ BEGIN
+ WRITELN(" THE TELLER NO",NUMBER," WAS IDLE FOR",REST:10:4,
+ " SEC");
+ CALL CSTM.ELLIST.OUT;
+ N:=CSTM QUA BANKCUSTOMER.NO;
+ WRITELN(" THE CUSTOMER NO",CSTM.K,
+ " BEGINS TO BE SERVED BY THE TELLER NO",NUMBER,
+ " AT",TIME:10:4);
+ ACCOUNT(N):=ACCOUNT(N)+CSTM QUA BANKCUSTOMER.AMOUNT;
+ IF ACCOUNT(N)<0 THEN CALL CSTM.ARRIVAL(CONTROL);FI;
+ SERVICETIME:=RANDOM*7+3;
+ CALL HOLD(SERVICETIME);
+
+ END SERVICE;
+ END TELLER;
+
+
+ UNIT BANKCUSTOMER:CUSTOMER CLASS(NO:INTEGER,AMOUNT:REAL);
+ (* BANK CUSTOMER. AMOUNT- THE MONEY TO BE PAID AT THE BANK *)
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOOSETELLER:INTEGER;
+ BEGIN
+ I:=I+1;
+ K:=I;
+ ARRIVALTIME:=TIME;
+ WRITELN(" THE CUSTOMER NO",K," ARRIVED AT",TIME:10:4);
+ CHOOSETELLER:=RANDOM*5+1;
+ CALL ARRIVAL(TELLERS(CHOOSETELLER));
+ IF AMOUNT<0 THEN CALL ARRIVAL(CTR); FI;
+ STAYTIME:=TIME-ARRIVALTIME;
+ WRITELN(" THE CUSTOMER NO",K," STAYED AT THE BANK FOR",
+ STAYTIME:10:4," SEC; STATE OF ACCOUNT",ACCOUNT(NO):10:4);
+ END BANKCUSTOMER;
+
+ VAR TELLERS:ARRAYOF TELLER,ACCOUNT:ARRAYOF REAL;
+ VAR CTR:COUNTER, CONTROL:TILL,I:INTEGER;
+
+ BEGIN (* NEW BANK DEPARTMENT GENERATION *)
+ CTR:=NEW COUNTER(NEW HEAD);
+ ARRAY TELLERS DIM(1:5); (* WE DEAL WITH 5 TELLES *)
+ FOR I:=1 TO 5 DO TELLERS(I):=NEW TELLER(NEW HEAD,I); OD;
+ ARRAY ACCOUNT DIM(1:100);
+ (* WE DEAL WITH 100 ACOUNTS IN THIS BANK DEPARTMENT *)
+ FOR I:=1 TO 100 DO ACCOUNT(I):=RANDOM*901+100; OD;
+ (* AN ACCOUNT VALUE CAN FLUCTUATE FROM 100 TO 1000$ *)
+ I:=0;
+ END BANKDEPARTMENT;
+
+
+
+ BEGIN (* OF PROGRAM *)
+ PREF BANKDEPARTMENT BLOCK
+ UNIT GENERATOR:SIMPROCESS CLASS;
+ (* CUSTOMERS GENERATION *)
+ BEGIN
+ DO
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,
+ RANDOM*9996+5),TIME);
+ CALL HOLD(RANDOM*10);
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,
+ -(RANDOM*900+5)),TIME);
+ CALL HOLD(RANDOM*10);
+ OD
+ END GENERATOR;
+ BEGIN
+ WRITELN(" BANK DEPARTMENT SERVICE SIMULATION");
+ WRITELN;
+ CALL SCHEDULE(NEW GENERATOR,TIME);
+ CALL HOLD (40);
+ END
+END
--- /dev/null
+program bank22;
+begin
+pref IIUWGraph BLOCK
+(* SYMULACJA PRACY BANKU *)
+(* dolaczone funkcje graficzne *)
+
+(****************************************************************************)
+
+unit kasa:procedure(nr:integer);
+var i:integer;
+begin
+i:=71+(nr-1)*56;
+call move(10,i);
+call draw(10,i+36);
+call draw(56,i+36);
+call draw(56,i);
+call draw(10,i);
+(*call vfill(i+36);
+call hfill(46);
+call move(10,i+36);
+call hfill(46);
+call move(46,i);
+call vfill(i+36);*)
+call move(13,i+7);
+call outstring("Desk");
+call move(13,i+21);
+call outstring("No");
+call move(38,i+18);
+(* call hascii(0); *)
+ call hascii(nr+48);
+end kasa;
+
+(****************************************************************************)
+
+unit klient:procedure(nr,kasa:integer;inout kl:integer);
+var i,j,k,p:integer;
+begin
+kl:=kl+1;
+j:=85+(kasa-1)*56;
+i:=54+(nr-1)*26;
+call move(i,j-4);
+call hfill(i+24);
+call vfill(j+12);
+call move(i,j+12);
+call hfill(i+24);
+call move(i+24,j-4);
+call vfill(j+12);
+call move(i+4,j);
+k:=kl div 10; p:=kl mod 10;
+if k>0 then
+(* call hascii(0); *)
+ call hascii(k+48);
+call move(i+12,j);
+(* call hascii(0); *)
+call hascii(p+48);
+else
+call move(i+8,j);
+(* call hascii(0); *)
+call hascii(p+48);
+fi;
+end klient;
+
+(****************************************************************************)
+
+unit obsluzony:procedure(nr,kasa:integer);
+var j:integer,pom:arrayof integer;
+begin
+j:=85+(kasa-1)*56;
+call move(80,j-5);
+pom:=getmap(199,j+14);
+call xormap(pom);
+call move(54,j-5);
+call putmap(pom);
+kill(pom);
+end obsluzony;
+
+
+(****************************************************************************)
+
+unit ramka:procedure;
+var i:integer;
+begin
+call move(0,0);
+call vfill(347);
+call hfill(719);
+call move(719,0);
+call vfill(347);
+call move(0,347);
+call hfill(719);
+call move(0,63);
+call hfill(719);
+call move(200,63);
+call vfill(347);
+call move(200,337);
+call hfill(719);
+call move(195,4);
+call outstring(" SIMULATION PROGRAM - BANK ");
+call move(0,14);
+call hfill(719);
+for i:=1 to 5 do
+ call kasa(i) od ;
+call move(5,19);
+call outstring("This program simulates a bank department with 5 desks ");
+ call outstring("served by 5 cashiers ");
+call move(5,29);
+
+call outstring("Customers arrive at random. The service time is also random ");
+
+call move(5,39);
+call outstring("as well as its account and the sum to be paid ");
+call move(5,49);
+end ramka;
+
+(****************************************************************************)
+
+unit zwieksz:procedure(inout linia:integer);
+var pom:arrayof integer;
+begin
+linia:=linia+10;
+if linia>=326 then
+call move(205,65);
+pom:=getmap(718,325);
+call xormap(pom);
+linia:=66;
+fi;
+kill(pom);
+end zwieksz;
+
+(****************************************************************************)
+
+unit piszczas:procedure(t:real);
+var d,p,i:integer,r,x:real;
+begin
+x:=inxpos+16;
+p:=entier(t);
+for i:=1 to 3 do
+d:=p mod 10;
+call move(x,inypos);
+call hascii(0);call hascii(d+48);
+x:=x-8;
+p:=p div 10;
+if p=0 then exit fi;
+od;
+x:=x+(i+1)*8;
+call move(x,inypos);
+call hascii(0);call hascii(ord('.'));
+r:=t*1000;
+r:=r-(p*1000);
+p:=entier(r);
+x:=x+24;
+call move(x,inypos);
+for i:=1 to 3 do
+d:=p mod 10;
+call move(x,inypos);
+call hascii(0); call hascii(d+48);
+x:=x-8;
+p:=p div 10;
+od;
+call move(x+32,inypos);
+end piszczas;
+
+(****************************************************************************)
+
+
+UNIT PRIORITYQUEUE: CLASS;
+ (* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)
+
+
+
+ UNIT QUEUEHEAD: CLASS;
+ (* HEAP ACCESING MODULE *)
+ VAR LAST,ROOT:NODE;
+
+ UNIT MIN: FUNCTION: ELEM;
+ BEGIN
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;
+ END MIN;
+
+ UNIT INSERT: PROCEDURE(R:ELEM);
+ (* INSERTION INTO HEAP *)
+ VAR X,Z:NODE;
+ BEGIN
+ X:= R.LAB;
+ IF LAST=NONE THEN
+ ROOT:=X;
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT
+ ELSE
+ IF LAST.NS=0 THEN
+ LAST.NS:=1;
+ Z:=LAST.LEFT;
+ LAST.LEFT:=X;
+ X.UP:=LAST;
+ X.LEFT:=Z;
+ Z.RIGHT:=X;
+ ELSE
+ LAST.NS:=2;
+ Z:=LAST.RIGHT;
+ LAST.RIGHT:=X;
+ X.RIGHT:=Z;
+ X.UP:=LAST;
+ Z.LEFT:=X;
+ LAST.LEFT.RIGHT:=X;
+ X.LEFT:=LAST.LEFT;
+ LAST:=Z;
+ FI
+ FI;
+ CALL CORRECT(R,FALSE)
+ END INSERT;
+
+UNIT DELETE: PROCEDURE(R: ELEM);
+ VAR X,Y,Z:NODE;
+ BEGIN
+ X:=R.LAB;
+ Z:=LAST.LEFT;
+ IF LAST.NS =0 THEN
+ Y:= Z.UP;
+ Y.RIGHT:= LAST;
+ LAST.LEFT:=Y;
+ LAST:=Y;
+ ELSE
+ Y:= Z.LEFT;
+ Y.RIGHT:= LAST;
+ LAST.LEFT:= Y;
+ FI;
+ Z.EL.LAB:=X;
+ X.EL:= Z.EL;
+ LAST.NS:= LAST.NS-1;
+ R.LAB:=Z;
+ Z.EL:=R;
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)
+ ELSE CALL CORRECT(X.EL,TRUE) FI;
+ END DELETE;
+
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;
+ BEGIN
+ Z:=R.LAB;
+ IF DOWN THEN
+ WHILE NOT FIN DO
+ IF Z.NS =0 THEN FIN:=TRUE ELSE
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT
+ FI; FI;
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE
+ T:=X.EL;
+ X.EL:=Z.EL;
+ Z.EL:=T;
+ Z.EL.LAB:=Z;
+ X.EL.LAB:=X
+ FI; FI;
+ Z:=X;
+ OD
+ ELSE
+ X:=Z.UP;
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;
+ WHILE NOT LOG DO
+ T:=Z.EL;
+ Z.EL:=X.EL;
+ X.EL:=T;
+ X.EL.LAB:=X;
+ Z.EL.LAB:=Z;
+ Z:=X;
+ X:=Z.UP;
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);
+ FI;
+ OD
+ FI;
+ END CORRECT;
+
+END QUEUEHEAD;
+
+
+UNIT NODE: CLASS (EL:ELEM);
+ (* ELEMENT OF THE HEAP *)
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;
+ BEGIN
+ IF X= NONE THEN RESULT:=FALSE
+ ELSE RESULT:=EL.LESS(X.EL) FI;
+ END LESS;
+ END NODE;
+
+
+UNIT ELEM: CLASS(PRIOR:REAL);
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)
+ VAR LAB: NODE;
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;
+ BEGIN
+ IF X=NONE THEN RESULT:= FALSE ELSE
+ RESULT:= PRIOR< X.PRIOR FI;
+ END LESS;
+ BEGIN
+ LAB:= NEW NODE(THIS ELEM);
+ END ELEM;
+
+
+END PRIORITYQUEUE;
+
+
+
+UNIT SIMULATION: PRIORITYQUEUE CLASS;
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)
+
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)
+ MAINPR: MAINPROGRAM;
+
+
+ UNIT SIMPROCESS: COROUTINE;
+ (* USER PROCESS PREFIX *)
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)
+ EVENTAUX: EVENTNOTICE,
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)
+ FINISH: BOOLEAN;
+
+ UNIT IDLE: FUNCTION: BOOLEAN;
+ BEGIN
+ RESULT:= EVENT= NONE;
+ END IDLE;
+
+ UNIT TERMINATED: FUNCTION :BOOLEAN;
+ BEGIN
+ RESULT:= FINISH;
+ END TERMINATED;
+
+ UNIT EVTIME: FUNCTION: REAL;
+ (* TIME OF ACTIVATION *)
+ BEGIN
+ IF IDLE THEN CALL ERROR1;
+ FI;
+ RESULT:= EVENT.EVENTTIME;
+ END EVTIME;
+
+ UNIT ERROR1:PROCEDURE;
+ BEGIN
+ ATTACH(MAIN);
+ call groff;
+ WRITELN(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");
+ END ERROR1;
+
+ UNIT ERROR2:PROCEDURE;
+ BEGIN
+ ATTACH(MAIN);
+ call groff;
+ WRITELN(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");
+ END ERROR2;
+ BEGIN
+
+ RETURN;
+ INNER;
+ FINISH:=TRUE;
+ CALL PASSIVATE;
+ CALL ERROR2;
+ END SIMPROCESS;
+
+
+UNIT EVENTNOTICE: ELEM CLASS;
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;
+
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)
+ BEGIN
+ IF X=NONE THEN RESULT:= FALSE ELSE
+ RESULT:= EVENTTIME< X.EVENTTIME OR
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;
+
+ END LESS;
+ END EVENTNOTICE;
+
+
+UNIT MAINPROGRAM: SIMPROCESS CLASS;
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)
+ BEGIN
+ DO ATTACH(MAIN) OD;
+ END MAINPROGRAM;
+
+UNIT TIME:FUNCTION:REAL;
+ (* CURRENT VALUE OF SIMULATION TIME *)
+ BEGIN
+ RESULT:=CURRENT.EVTIME
+ END TIME;
+
+UNIT CURRENT: FUNCTION: SIMPROCESS;
+ (* THE FIRST PROCESS ON THE TIME AXIS *)
+ BEGIN
+ RESULT:=CURR;
+ END CURRENT;
+
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)
+ (* WITHIN TIME MOMENT T *)
+ BEGIN
+ IF T<TIME THEN T:= TIME FI;
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);
+ P.EVENT.PROC:= P;
+ ELSE
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN
+ P.EVENT:= P.EVENTAUX;
+ P.EVENT.PRIOR:=RANDOM;
+ ELSE
+ (* NEW SCHEDULING *)
+ P.EVENT.PRIOR:=RANDOM;
+ CALL PQ.DELETE(P.EVENT)
+ FI; FI;
+ P.EVENT.EVENTTIME:= T;
+ CALL PQ.INSERT(P.EVENT) FI;
+END SCHEDULE;
+
+UNIT HOLD:PROCEDURE(T:REAL);
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)
+ (* REDEFINE PRIOR *)
+ BEGIN
+ CALL PQ.DELETE(CURRENT.EVENT);
+ CURRENT.EVENT.PRIOR:=RANDOM;
+ IF T<0 THEN T:=0; FI;
+ CURRENT.EVENT.EVENTTIME:=TIME+T;
+ CALL PQ.INSERT(CURRENT.EVENT);
+ CALL CHOICEPROCESS;
+ END HOLD;
+
+UNIT PASSIVATE: PROCEDURE;
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)
+ BEGIN
+ CALL PQ.DELETE(CURRENT.EVENT);
+ CURRENT.EVENT:=NONE;
+ CALL CHOICEPROCESS
+ END PASSIVATE;
+
+UNIT RUN: PROCEDURE(P:SIMPROCESS);
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)
+ (* PRIOR *)
+ BEGIN
+ CURRENT.EVENT.PRIOR:=RANDOM;
+ IF NOT P.IDLE THEN
+ P.EVENT.PRIOR:=0;
+ P.EVENT.EVENTTIME:=TIME;
+ CALL PQ.CORRECT(P.EVENT,FALSE)
+ ELSE
+ IF P.EVENTAUX=NONE THEN
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);
+ P.EVENT.EVENTTIME:=TIME;
+ P.EVENT.PROC:=P;
+ CALL PQ.INSERT(P.EVENT)
+ ELSE
+ P.EVENT:=P.EVENTAUX;
+ P.EVENT.PRIOR:=0;
+ P.EVENT.EVENTTIME:=TIME;
+ P.EVENT.PROC:=P;
+ CALL PQ.INSERT(P.EVENT);
+ FI;FI;
+ CALL CHOICEPROCESS;
+END RUN;
+
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)
+ BEGIN
+ IF P= CURRENT THEN CALL PASSIVATE ELSE
+ CALL PQ.DELETE(P.EVENT);
+ P.EVENT:=NONE; FI;
+ END CANCEL;
+
+UNIT CHOICEPROCESS:PROCEDURE;
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)
+ VAR P:SIMPROCESS;
+ BEGIN
+ P:=CURR;
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;
+ IF CURR=NONE THEN
+ call groff;
+ WRITE(" ERROR IN THE HEAP"); WRITELN;
+ ATTACH(MAIN);
+ ELSE ATTACH(CURR); FI;
+END CHOICEPROCESS;
+
+BEGIN
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)
+ CURR,MAINPR:=NEW MAINPROGRAM;
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);
+ MAINPR.EVENT.EVENTTIME:=0;
+ MAINPR.EVENT.PROC:=MAINPR;
+ CALL PQ.INSERT(MAINPR.EVENT);
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)
+ INNER;
+ PQ:=NONE;
+END SIMULATION;
+
+
+
+UNIT LISTS:SIMULATION CLASS;
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)
+
+ UNIT LINKAGE:CLASS;
+ (*WE WILL USE TWO WAY LISTS *)
+ VAR SUC1,PRED1:LINKAGE;
+ END LINKAGE;
+ UNIT HEAD:LINKAGE CLASS;
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)
+ UNIT FIRST:FUNCTION:LINK;
+ BEGIN
+ IF SUC1 IN LINK THEN RESULT:=SUC1
+ ELSE RESULT:=NONE FI;
+ END;
+ UNIT EMPTY:FUNCTION:BOOLEAN;
+ BEGIN
+ RESULT:=SUC1=THIS LINKAGE;
+ END EMPTY;
+ BEGIN
+ SUC1,PRED1:=THIS LINKAGE;
+ END HEAD;
+
+ UNIT LINK:LINKAGE CLASS;
+ (* ORDINARY LIST ELEMENT PREFIX *)
+ UNIT OUT:PROCEDURE;
+ BEGIN
+ IF SUC1=/=NONE THEN
+ SUC1.PRED1:=PRED1;
+ PRED1.SUC1:=SUC1;
+ SUC1,PRED1:=NONE FI;
+ END OUT;
+ UNIT INTO:PROCEDURE(S:HEAD);
+ BEGIN
+
+ CALL OUT;
+ IF S=/= NONE THEN
+ IF S.SUC1=/=NONE THEN
+ SUC1:=S;
+ PRED1:=S.PRED1;
+ PRED1.SUC1:=THIS LINKAGE;
+ S.PRED1:=THIS LINKAGE;
+ FI FI;
+ END INTO;
+ END LINK;
+
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)
+ END ELEM;
+
+ END LISTS;
+
+
+
+
+
+ (*poczatek symulacji pracy banku*)
+
+
+ UNIT OFFICE:LISTS CLASS; (*AN OFFICE*)
+
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);
+ (* TELLER WITH CUSTOMERS QUEUEING UP *)
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ (* SERVICE OF THIS TELLER WILL BE PRECISED LATER *)
+ END SERVICE;
+ VAR CSTM:CUSTOMER, (*THE CUSTOMER BEING SERVED*)
+ REST,PAUSE:REAL;
+
+ BEGIN
+ PAUSE:=TIME;
+ DO
+ REST:=REST+TIME-PAUSE;
+ WHILE NOT QUEUE.EMPTY DO
+ (* SERVE ALL QUEUE *)
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;
+ CALL SERVICE;
+ CALL SCHEDULE(CSTM,TIME);
+ OD;
+ PAUSE:=TIME;
+ CALL PASSIVATE
+ OD;
+ END TILL;
+
+ UNIT CUSTOMER:SIMPROCESS CLASS;
+
+ VAR ELLIST:ELEM, K:INTEGER;
+ UNIT ARRIVAL:PROCEDURE(S:TILL);
+ (* ATTACHING TELLER S *)
+ BEGIN
+ IF S=/=NONE THEN
+ ELLIST:=NEW ELEM(THIS CUSTOMER);
+ CALL ELLIST.INTO(S.QUEUE);
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME) FI;
+ CALL PASSIVATE; FI;
+ END ARRIVAL;
+ END CUSTOMER;
+
+ END OFFICE;
+
+
+
+UNIT BANKDEPARTMENT:OFFICE CLASS;
+
+
+ UNIT COUNTER:TILL CLASS;
+ VAR PAYTIME:REAL; (*RANDOM SERVICE TIME*)
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ BEGIN
+ call move(205,linia);
+ call outstring(" Customer No");
+ p1:=cstm.k div 10; p2:=cstm.k mod 10;
+ if p1>0 then
+ call hascii(0); call hascii(p1+48);
+ call hascii(0);call hascii(p2+48);
+ else
+ call hascii(0);call hascii(p2+48);
+ fi;
+ call outstring(" has payed at the desk at time: ");
+ call piszczas(time);
+ call zwieksz(linia);
+ CALL CSTM.ELLIST.OUT;
+ PAYTIME:=RANDOM*2+2;
+ CALL HOLD(PAYTIME);
+ END SERVICE;
+ END COUNTER;
+
+
+ UNIT TELLER:TILL CLASS(NUMBER:INTEGER);
+ VAR SERVICETIME:REAL;
+ UNIT VIRTUAL SERVICE:PROCEDURE;
+ VAR N:INTEGER;
+ BEGIN
+ call move(205,linia);
+ call outstring(" Cashier No ");
+ call hascii(0); call hascii(number+48);
+ call outstring(" was waiting a customer during ");
+ call piszczas(REST);
+ call zwieksz(linia);
+ CALL CSTM.ELLIST.OUT;
+ N:=CSTM QUA BANKCUSTOMER.NO;
+ call move(205,linia);
+ call outstring(" Customer No ");
+ p1:=cstm.k div 10; p2:=cstm.k mod 10;
+ if p1>0 then
+ call hascii(0); call hascii(p1+48);
+ call hascii(0);call hascii(p2+48);
+ else
+ call hascii(0);call hascii(p2+48);
+ fi;
+ call outstring(" becomes to be served by cashier No ");
+ call hascii(0); call hascii(number+48);
+ call zwieksz(linia);
+ call move(205,linia);
+ call outstring(" at time ");
+ call piszczas(TIME);
+ call zwieksz(linia);
+ ACCOUNT(N):=ACCOUNT(N)+CSTM QUA BANKCUSTOMER.AMOUNT;
+ IF ACCOUNT(N)<0 THEN CALL CSTM.ARRIVAL(CONTROL);FI;
+ SERVICETIME:=RANDOM*7+3;
+ CALL HOLD(SERVICETIME);
+
+ END SERVICE;
+ END TELLER;
+
+
+ UNIT BANKCUSTOMER:CUSTOMER CLASS(NO:INTEGER,AMOUNT:REAL);
+ (* BANK CUSTOMER. AMOUNT- THE MONEY TO BE PAID AT THE BANK *)
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOOSETELLER:INTEGER;
+ BEGIN
+ I:=I+1;
+ K:=I;
+ ARRIVALTIME:=TIME;
+ call move(205,linia);
+ call outstring(" Customer No ");
+ p1:=k div 10; p2:=k mod 10;
+ if p1>0 then
+ call hascii(0); call hascii(p1+48);
+ call hascii(0);call hascii(p2+48);
+ else
+ call hascii(0);call hascii(p2+48);
+ fi;
+ call outstring(" arrived at time ");
+ call piszczas(TIME);
+ call zwieksz(linia);
+ CHOOSETELLER:=RANDOM*5+1;
+ kasa(chooseteller):=kasa(chooseteller)+1;
+ call klient(kasa(chooseteller),chooseteller,kl);
+ CALL ARRIVAL(TELLERS(CHOOSETELLER));
+ IF AMOUNT<0 THEN CALL ARRIVAL(CTR); FI;
+ STAYTIME:=TIME-ARRIVALTIME;
+ call move(205,linia);
+ call outstring(" Customer No ");
+ p1:=k div 10; p2:=k mod 10;
+ if p1>0 then
+ call hascii(0); call hascii(p1+48);
+ call hascii(0);call hascii(p2+48);
+ else
+ call hascii(0);call hascii(p2+48);
+ fi;
+ call outstring(" left bank after ");
+ call piszczas(STAYTIME); (*STAN KONTA ",ACCOUNT(NO):10:4); *)
+ call zwieksz(linia);
+ call obsluzony(kasa(chooseteller),chooseteller);
+ kasa(chooseteller):=kasa(chooseteller)-1
+ END BANKCUSTOMER;
+
+ VAR TELLERS:ARRAYOF TELLER,ACCOUNT:ARRAYOF REAL;
+ VAR CTR:COUNTER, CONTROL:TILL,I:INTEGER;
+ var linia,p1,p2,kl:integer;
+ var kasa:arrayof integer;
+
+ BEGIN (* NEW BANK DEPARTMENT GENERATION *)
+ linia:=66;
+ array kasa dim(1:5);
+ CTR:=NEW COUNTER(NEW HEAD);
+ ARRAY TELLERS DIM(1:5); (* WE DEAL WITH 5 TELLES *)
+ FOR I:=1 TO 5 DO TELLERS(I):=NEW TELLER(NEW HEAD,I); OD;
+ ARRAY ACCOUNT DIM(1:100);
+ (* WE DEAL WITH 100 ACOUNTS IN THIS BANK DEPARTMENT *)
+ FOR I:=1 TO 100 DO ACCOUNT(I):=RANDOM*901+100; OD;
+ (* AN ACCOUNT VALUE CAN FLUCTUATE FROM 100 TO 1000$ *)
+ I:=0;
+ END BANKDEPARTMENT;
+
+
+
+ BEGIN (* OF PROGRAM *)
+ PREF BANKDEPARTMENT BLOCK
+ UNIT GENERATOR:SIMPROCESS CLASS;
+ (* CUSTOMERS GENERATION *)
+ BEGIN
+ DO
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,
+ RANDOM*9996+5),TIME);
+ CALL HOLD(RANDOM*3);
+ CALL SCHEDULE(NEW BANKCUSTOMER(RANDOM*100+1,
+ -(RANDOM*900+5)),TIME);
+ CALL HOLD(RANDOM*2);
+ OD
+ END GENERATOR;
+ BEGIN
+ call hpage(1,0,0);
+ call hpage(1,720,347);
+
+ call gron(1);
+ call ramka;
+ call move(300,339);
+ call outstring("Click the mouse in order to start simulation");
+ (* call track(719,349); *)
+ CALL SCHEDULE(NEW GENERATOR,TIME);
+ CALL HOLD (135);
+ call move(300,339);
+ call outstring(" Click the mouse in order to finish ");
+ (* call track(719,349); *)
+ call groff
+ END
+END
+end
+(****************************************************************************)
--- /dev/null
+BLOCK\r
+ \r
+(*****************************************************************************)\r
+(********************************** F I F O **********************************)\r
+(*****************************************************************************)\r
+ \r
+unit FIFO : class ( type T);\r
+ \r
+ var HEAD,LAST : ELEM;\r
+ \r
+ unit ELEM : class ( INFO : T);\r
+ var NEXT : ELEM;\r
+ begin\r
+ end ELEM;\r
+ \r
+ unit EMPTY : function : boolean;\r
+ begin\r
+ result := (HEAD=NONE)\r
+ end\r
+ \r
+ unit INTO : procedure ( INFO : T );\r
+ begin\r
+ if EMPTY then\r
+ HEAD := new ELEM(INFO);\r
+ LAST := HEAD\r
+ else\r
+ LAST.NEXT := new ELEM(INFO);\r
+ LAST := LAST.NEXT\r
+ (* fi *)\r
+ end INTO;\r
+ \r
+ unit FIRST : function : T;\r
+ begin\r
+ result.a := HEAD.INFO (*!!!!!!!!*)\r
+ end FIRST;\r
+ \r
+ unit OUT_FIRST : procedure;\r
+ var HLP : ELEM;\r
+ begin\r
+ if not EMPTY then\r
+ HLP := HEAD;\r
+ HEAD := HEAD.NEXT\r
+ fi\r
+ end OUT_FIRST;\r
+ \r
+ unit CARDINAL : function : integer;\r
+ var HLP : ELEM;\r
+ begin\r
+ HLP := HEAD;\r
+ while HLP <> NONE do\r
+ result :=result + 1;\r
+ HLP := HLP.NEXT\r
+ od\r
+ end CARDINAL;\r
+ \r
+ end FIFO;\r
+ \r
+ \r
+(*****************************************************************************)\r
+(************************** E N D F I F O *******************************)\r
+(*****************************************************************************)\r
+ \r
+(* * * * * * * * *)\r
+ \r
+(*****************************************************************************)\r
+(************************* S I M U L A T I O N *******************************)\r
+(*****************************************************************************)\r
+ \r
+UNIT PRIORITYQUEUE: IIUWGRAPH CLASS;\r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+(* root,right usunieto*) ROOT.LEFT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+ \r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ if y<>none then Y.RIGHT:= LAST else root :=none fi; (**10-93***)\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ (**** poprawka 10-93 ******)\r
+ z.left.right := none;\r
+ z.ns := 0;\r
+ z.left, z.right, z.up := none;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+END QUEUEHEAD;\r
+ \r
+ \r
+UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ \r
+UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+ \r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+(**** poprawka 10-93 *********)\r
+hidden Mmainpr, curr, pq;\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ unit\r
+ SIMPROCESS: COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ (***** poprawka 10-93 **********)\r
+ hidden event, eventaux, finish;\r
+ \r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN raise ERROR1; FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ handlers\r
+ when ERROR1 :\r
+ WRITELN(" AN ATTEMPT TO ACTIVATE AN IDLE PROCESS TIME");\r
+ attach(main);\r
+ when ERROR2 :\r
+ WRITELN(" AN ATTEMPT TO ACTIVATE A TERMINATED PROCESS TIME");\r
+ attach(MAIN);\r
+ end handlers;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ raise ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR<= X.PRIOR); FI;\r
+ \r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ \r
+UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF "PRIOR"- PRIORITY *)\r
+ (* WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ (*** poprawka 10-93 *****)\r
+ if p.terminated then raise ERROR2 fi;\r
+ \r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+END SCHEDULE;\r
+ \r
+UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE current PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ fi;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ BEGIN\r
+ (**** poprawka 10-93 ****)\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+ \r
+(*****************************************************************************)\r
+(************************ E N D S I M U L A T I O N *********************)\r
+(*****************************************************************************)\r
+ \r
+ \r
+ \r
+begin\r
+ pref iiuwgraph block\r
+ \r
+ BEGIN\r
+ PREF SIMULATION BLOCK\r
+ const pojemnosc=30;\r
+ var\r
+ autobusy:arrayof bus,\r
+ przystan:arrayof przystanek,\r
+ inf:info,cl:zegar,\r
+ ws:integer,\r
+ c:char,\r
+ praz:boolean,\r
+ i,j,p,czas_sym,czas,ilosc_przystankow,\r
+ ilosc_auto,czestosc,odstep1,odstep2,podst1,podst2:integer;\r
+ \r
+ unit wsp:class(x,y,i:integer);\r
+ begin\r
+ end wsp;\r
+ \r
+ unit nast:function(w:wsp):wsp;\r
+ var pom:wsp;\r
+ begin\r
+ if w.i <= ilosc_przystankow div 2\r
+ then\r
+ pom:=new wsp(w.x,w.y - odstep1,i mod ilosc_przystankow +1)\r
+ else\r
+ if w.x>550\r
+ then\r
+ pom:=new wsp(600-w.x,20,i mod ilosc_przystankow+1)\r
+ else\r
+ pom:=new wsp(w.x,w.y+odstep1,i mod ilosc_przystankow+1)\r
+ fi\r
+ fi;\r
+ result:=pom\r
+ end nast;\r
+ \r
+ unit bus:simprocess class;\r
+ var i,j,kier,wolnych_miejsc:integer,\r
+ ws:wsp,\r
+ wsiadajacy:pasazer;\r
+ begin\r
+ wolnych_miejsc:=pojemnosc;\r
+ praz:=true;\r
+ i:=1;\r
+ ws:=new wsp(480,320-odstep1,1);\r
+ do\r
+ if przystan(i).ws.x=510\r
+ then ws.x:=480\r
+ else ws.x:=420\r
+ fi;\r
+ ws.y:=przystan(i).ws.y;\r
+ ws.i:=i;\r
+ call ruch(ws,true) ;\r
+ praz:=false;\r
+ wolnych_miejsc:=wolnych_miejsc +\r
+ entier(random*(pojemnosc-wolnych_miejsc)*exp(i / pojemnosc));\r
+ if wolnych_miejsc>pojemnosc then wolnych_miejsc:=pojemnosc fi;\r
+ while (wolnych_miejsc > 0) and (not przystan(i).kolejka.empty)\r
+ do\r
+ wsiadajacy:=przystan(i).kolejka.first;\r
+ if (ilosc_przystankow div 2-i)>=0 then kier:=1\r
+ else kier:=-1\r
+ fi;\r
+ call usun(przystan(i).ws.x,przystan(i).ws.y,\r
+ kier*przystan(i).kolejka.cardinal);\r
+ call przystan(i).kolejka.out_first;\r
+ wolnych_miejsc:=wolnych_miejsc - 1;\r
+ call run(wsiadajacy);\r
+ call run(inf);\r
+ kill(wsiadajacy)\r
+ od;\r
+ call ruch(ws,false);\r
+ call hold(przystan(i).czas_do_nast);\r
+ i:=i mod ilosc_przystankow + 1;\r
+ od\r
+ end bus;\r
+ \r
+ unit pasazer:simprocess class(nr:integer);\r
+ var czas_przyjscia,czas_oczekiwania:integer;\r
+ begin\r
+ czas_przyjscia:=time;\r
+ call passivate;\r
+ czas_oczekiwania:=time-czas_przyjscia;\r
+ przystan(nr).laczny_czas:=przystan(nr).laczny_czas +\r
+ czas_oczekiwania;\r
+ przystan(nr).sredniczas:=przystan(nr).laczny_czas /\r
+ przystan(nr).total\r
+ end pasazer;\r
+ \r
+ \r
+ unit przystanek:simprocess class(nr:integer);\r
+ var\r
+ kolejka:FIFO,\r
+ new_pas:pasazer,\r
+ ws:wsp,\r
+ kier,ilosc_pas,total,laczny_czas,czas_do_nast:integer,\r
+ sredniczas:real;\r
+ begin\r
+ kolejka:=new FIFO(pasazer);\r
+ czas_do_nast:=3;\r
+ if nr<=ilosc_przystankow div 2 then\r
+ \r
+ ws:=new wsp(510,290-podst1-(nr-1)*odstep1,nr)\r
+ else\r
+ \r
+ ws:=new wsp(390,podst2+(nr-ilosc_przystankow div 2-1)*odstep2,nr)\r
+ fi;\r
+ if ws.x>450 then call move(ws.x-15,ws.y+10)\r
+ else call move(ws.x,ws.y+10) fi;\r
+ call wypisz(ws.i);\r
+ call hold(3*ilosc_przystankow);\r
+ do\r
+ call hold(2*abs(nr-ilosc_przystankow div 2)+1);\r
+ new_pas:=new pasazer(nr);\r
+ total:=total+1;\r
+ call kolejka.into(new_pas);\r
+ if (ilosc_przystankow div 2-nr)>=0 then kier:=1\r
+ else kier:=-1\r
+ fi;\r
+ call kol(ws.x,ws.y,kier*kolejka.cardinal);\r
+ call schedule(new_pas,time);\r
+ od;\r
+ end przystanek;\r
+ \r
+ \r
+ (*------------------------------------------------------------------------*)\r
+ (*-------------------- PROCEDURY POMOCNICZE ----------------------------*)\r
+ (*------------------------------------------------------------------------*)\r
+ \r
+ unit ludzik:procedure(x,y:integer);\r
+ begin\r
+ call move(x,y);\r
+ call draw(x,y+6);\r
+ call draw(x-2,y+10);\r
+ call move(x,y+6);\r
+ call draw(x+2,y+10);\r
+ call move(x-2,y+2);\r
+ call draw(x+2,y+2);\r
+ call move(x-2,y+2);\r
+ call draw(x-4,y+4);\r
+ call move(x+2,y+2);\r
+ call draw(x+4,y+4)\r
+ end;\r
+ \r
+ \r
+ unit usun:procedure(x,y,m:integer);\r
+ var i:integer;\r
+ begin\r
+ if m<=15\r
+ then\r
+ call color(0);\r
+ call ludzik(x+8*m,y);\r
+ call color(1)\r
+ fi\r
+ end;\r
+ \r
+ unit kol:procedure(x,y,m:integer);\r
+ var i:integer;\r
+ begin\r
+ if m<=15\r
+ then\r
+ call ludzik(x+8*m,y)\r
+ fi\r
+ end;\r
+ \r
+ \r
+ unit wypisz:iiuwgraph procedure(x:integer);\r
+ unit CHRTYP :function ( x:integer):string;\r
+ (* zamiana liczby na tekst *)\r
+ begin\r
+ case x\r
+ when 1 : result:="1";\r
+ when 2 : result:="2";\r
+ when 3 : result:="3";\r
+ when 4 : result:="4";\r
+ when 5 : result:="5";\r
+ when 6 : result:="6";\r
+ when 7 : result:="7";\r
+ when 8 : result:="8";\r
+ when 9 : result:="9";\r
+ when 0 : result:="0"\r
+ esac\r
+ end;\r
+ begin\r
+ if x<0 then call outstring("ujemna liczba")\r
+ else\r
+ call outstring(chrtyp(x div 10));\r
+ call outstring(chrtyp(x mod 10))\r
+ fi\r
+ end wypisz;\r
+ \r
+ \r
+ unit zegar:simprocess class;\r
+ var i,j:integer;\r
+ begin\r
+ do\r
+ call ramka(420,310,480,335);\r
+ call ramka(422,312,478,333);\r
+ call ramka(421,311,479,334);\r
+ call move(433,320);\r
+ call wypisz(i);\r
+ call outstring(":");\r
+ call wypisz(j);\r
+ j:=j+1;\r
+ if j=60 then j:=0;i:=i+1 fi;\r
+ call hold(1)\r
+ od\r
+ end zegar;\r
+ \r
+ \r
+ unit info:simprocess class;\r
+ var i:integer;\r
+ begin\r
+ call ramka(0,0,280,140+10*ilosc_przystankow);\r
+ call ramka(1,1,281,141+10*ilosc_przystankow);\r
+ call move(10,50);\r
+ call outstring("Pojemnosc wozu:");\r
+ call outstring("30 os.");\r
+ call move(10,70);\r
+ call outstring("Czas przejazdu miedzy");\r
+ call move(10,80);\r
+ call outstring("przystankami:");\r
+ call outstring(" 3 min.");\r
+ call move(10,10);\r
+ call outstring("Czas symulacji:");\r
+ if czas_sym div 60=/=0\r
+ then\r
+ call wypisz(czas_sym div 60);\r
+ call outstring(" godz. ")\r
+ fi;\r
+ call wypisz(czas_sym mod 60);\r
+ call outstring(" min.");\r
+ call move(10,30);\r
+ call outstring("Czestotliwosc kursowania:");\r
+ call wypisz(czestosc);\r
+ call outstring(" min.");\r
+ call move(140,100);\r
+ call outstring("Sr. czas ");\r
+ call move(140,110);\r
+ call outstring("oczekiwania:");\r
+ call move(30,100);\r
+ call outstring("Przys.");\r
+ call move(30,110);\r
+ call outstring("nr");\r
+ call outstring(" ");\r
+ call move(90,100);\r
+ call outstring("Ilosc");\r
+ call move(90,110);\r
+ call outstring("ludzi");\r
+ call ramka(490,5,610,20);\r
+ call move(500,10);\r
+ call outstring("Esc - koniec.");\r
+ do\r
+ if inkey=27 then call run(mainpr) fi;\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ call move(30,120+i*10);\r
+ call wypisz(i);\r
+ call outstring(" ");\r
+ call wypisz(przystan(i).kolejka.cardinal);\r
+ call outstring(" ");\r
+ call wypisz(entier(przystan(i).sredniczas));\r
+ call outstring(".");\r
+ call wypisz(entier(przystan(i).sredniczas*10) mod 10);\r
+ call outstring(" min. ")\r
+ od;\r
+ call hold(0.5)\r
+ od\r
+ end;\r
+ \r
+ \r
+ \r
+ unit ramka:iiuwgraph procedure(x1,y1,x2,y2:integer);\r
+ begin\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1)\r
+ end ramka;\r
+ \r
+ \r
+ unit pr:procedure(x,y,dx,dy:integer);\r
+ begin\r
+ call ramka(x-dx div 2,y-dy div 2,x+dx div 2,y+dy div 2)\r
+ end pr;\r
+ \r
+ unit auto:procedure(x,y:integer);\r
+ begin\r
+ call pr(x,y,8,18);\r
+ call pr(x,y,10,20);\r
+ call pr(x,y,10,2)\r
+ end auto;\r
+ \r
+ \r
+ unit ruch:procedure(ws:wsp,jak:boolean);\r
+ var j:integer;\r
+ begin\r
+ if jak\r
+ then\r
+ if praz andif ws.i=1 then call auto(ws.x+10,ws.y) fi;\r
+ if ws.i>1 andif ws.i<=ilosc_przystankow div 2\r
+ then\r
+ call color(0);\r
+ call auto(ws.x,ws.y+odstep1-odstep1 div 2);\r
+ for j:=0 to odstep1-odstep1 div 2\r
+ do\r
+ call color(1);\r
+ call auto(ws.x,ws.y+odstep1-odstep1 div 2-j);\r
+ call color(0);\r
+ call auto(ws.x,ws.y+odstep1-odstep1 div 2-j);\r
+ od;\r
+ call color(1);\r
+ call auto(ws.x+10,ws.y);\r
+ else\r
+ if ws.i=ilosc_przystankow div 2 +1\r
+ then\r
+ call color(0);\r
+ call auto(480,290-podst1-(ws.i-2)*odstep1-odstep1 div 2);\r
+ call color(1);\r
+ call auto(ws.x-10,ws.y);\r
+ else\r
+ if ws.i=1 andif (not praz)\r
+ then\r
+ call color(0);\r
+ call auto(420,(ilosc_przystankow-ilosc_przystankow div 2-1)*\r
+ odstep2 + podst2 + odstep2 div 2);\r
+ call color(1);\r
+ call auto(ws.x+10,ws.y);\r
+ else\r
+ if ws.i>ilosc_przystankow div 2\r
+ then\r
+ call color(0);\r
+ call auto(420,ws.y+odstep2 div 2-odstep2);\r
+ for j:=1 to odstep2-odstep2 div 2\r
+ do\r
+ call color(1);\r
+ call auto(ws.x,ws.y+j-odstep2+odstep2 div 2);\r
+ call color(0);\r
+ call auto(ws.x,ws.y+j-odstep2+odstep2 div 2);\r
+ od;\r
+ call color(1);\r
+ call auto(ws.x-10,ws.y);\r
+ fi\r
+ fi\r
+ fi\r
+ fi;\r
+ (*call color(1);\r
+ call auto(ws.x,ws.y);*)\r
+ write(chr(7))\r
+ else\r
+ write(chr(7));\r
+ call color(0);\r
+ if ws.i<=ilosc_przystankow div 2\r
+ then\r
+ call auto(ws.x+10,ws.y)\r
+ else\r
+ call auto(ws.x-10,ws.y)\r
+ fi;\r
+ if ws.i<= ilosc_przystankow div 2\r
+ then\r
+ for j:=0 to odstep1 div 2\r
+ do\r
+ call color(1);\r
+ call auto(ws.x,ws.y-j);\r
+ call color(0);\r
+ call auto(ws.x,ws.y-j);\r
+ od;\r
+ call color(1);\r
+ call auto(ws.x,ws.y-odstep1 div 2);\r
+ else\r
+ for j:=0 to odstep2 div 2\r
+ do\r
+ call color(1);\r
+ call auto(ws.x,ws.y+j);\r
+ call color(0);\r
+ call auto(ws.x,ws.y+j)\r
+ od;\r
+ call color(1);\r
+ call auto(ws.x,ws.y+odstep2 div 2);\r
+ fi\r
+ fi;\r
+ call color(1)\r
+ end ruch;\r
+ \r
+ unit zabij_pas:procedure(i:integer);\r
+ var p:pasazer;\r
+ begin\r
+ while przystan(i).kolejka.cardinal>0\r
+ do\r
+ p:=przystan(i).kolejka.first;\r
+ call przystan(i).kolejka.out_first;\r
+ if p.event=/=none then call cancel(p) fi;\r
+ kill(p)\r
+ od\r
+ end zabij_pas;\r
+ \r
+ unit wstep:procedure;\r
+ begin\r
+ call gron(0);\r
+ call ramka(230,120,480,220);\r
+ call ramka(228,118,482,222);\r
+ call ramka(226,116,484,224);\r
+ call move(250,140);\r
+ call outstring("Program zaliczeniowy nr 6 ");\r
+ call move(250,160);\r
+ call outstring(" Symulacja autobusowa ");\r
+ call move(250,180);\r
+ call outstring("Autor: Nguyen Tuan Trung");\r
+ call move(250,200);\r
+ call outstring(" Warszawa 24 - 05 - 1990r.");\r
+ WHILE INKEY=0 DO OD;\r
+ call groff\r
+ end wstep;\r
+ \r
+ (*----------- PROGRAM GLOWNY---------------------------------------------*)\r
+ \r
+ \r
+ begin\r
+ call wstep;\r
+ do\r
+ do\r
+ write("czas symulacji=");\r
+ readln(czas_sym);\r
+ if czas_sym > 0\r
+ then exit\r
+ else writeln("Musi byc dodatni !")\r
+ fi\r
+ od;\r
+ do\r
+ write("ilosc przystankow=");\r
+ readln(ilosc_przystankow);\r
+ if ilosc_przystankow>1 and ilosc_przystankow < 21 then exit\r
+ else writeln("Musi byc wieksza niz 1 i mniejsza niz 20!")\r
+ fi\r
+ od;\r
+ (*do\r
+ write("ilosc autobusow=");\r
+ readln(ilosc_auto);\r
+ if ilosc_auto>0 then exit\r
+ else writeln("Musi byc dodatnia !")\r
+ fi\r
+ od;*)\r
+ do\r
+ write("czestotliwosc=");\r
+ readln(czestosc);\r
+ if czestosc>=10 then exit\r
+ else writeln("Musi byc niemniejsza niz 10 min. !")\r
+ fi;\r
+ od;\r
+ ilosc_auto:=entier((3*ilosc_przystankow) / czestosc +0.5) ;\r
+ if ilosc_auto=0 then ilosc_auto:=1 fi;\r
+ call gron(0);\r
+ call ramka(400,3,500,300);\r
+ call ramka(395,0,505,305);\r
+ odstep1:=290 div (ilosc_przystankow div 2 + 1);\r
+ podst1:=(290- (ilosc_przystankow div 2-1)*odstep1) div 2;\r
+ odstep2:=290 div (ilosc_przystankow -\r
+ ilosc_przystankow div 2 + 1);\r
+ podst2:=(290- (ilosc_przystankow-\r
+ ilosc_przystankow div 2-1)*odstep2) div 2;\r
+ for i:=1 to 7\r
+ do\r
+ call ramka(448,300-i*40,452,320-i*40);\r
+ call ramka(449,300-i*40,451,320-i*40);\r
+ call ramka(450,300-i*40,450,320-i*40);\r
+ od;\r
+ \r
+ array autobusy dim(1:ilosc_auto);\r
+ for i:=1 to ilosc_auto\r
+ do\r
+ autobusy(i):=new bus ;\r
+ call schedule(autobusy(i),time+(i-1)*czestosc+0.6)\r
+ od;\r
+ array przystan dim(1:ilosc_przystankow);\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ przystan(i):=new przystanek(i);\r
+ call schedule(przystan(i),time)\r
+ od;\r
+ cl:=new zegar;\r
+ call schedule(cl,time);\r
+ inf:=new info;\r
+ call schedule(inf,time+0.5);\r
+ call hold(czas_sym+0.7);\r
+ do\r
+ call ramka(420,290,615,345);\r
+ call ramka(421,291,614,344);\r
+ call move(430,300);\r
+ call outstring("SYMULACJA ZAKONCZONA");\r
+ call move(430,320);\r
+ call outstring("Przedluzac?(t/n)");\r
+ i:=inkey;\r
+ while i=0 do i:=inkey od;\r
+ if i=/=ord('t') then exit fi;\r
+ call move(430,300);\r
+ call outstring("Przedluzac symulacje");\r
+ call move(430,320);\r
+ call outstring(" o: ");\r
+ call move(460,320);\r
+ for p:=1 downto 0 do\r
+ do\r
+ i:=inkey;\r
+ while i=0 do i:=inkey od;\r
+ if i>=ord('0') andif i<=ord('9') then exit fi\r
+ od;\r
+ if p=0 then\r
+ czas:=czas+(i-ord('0'))\r
+ else\r
+ czas:=10*(i-ord('0'))\r
+ fi;\r
+ call hascii(i);\r
+ (*call hascii(32);*)\r
+ od;\r
+ call outstring(" min.");\r
+ for j:=1 to 2000 do od;\r
+ call color(0);\r
+ call ramka(420,290,615,345);\r
+ call ramka(421,291,614,344);\r
+ call color(1);\r
+ call move(430,300);\r
+ call outstring(" ");\r
+ call move(430,320);\r
+ call outstring(" ");\r
+ czas_sym:=czas_sym+czas;\r
+ call move(10,10);\r
+ call outstring("Czas symulacji:");\r
+ if czas_sym div 60=/=0\r
+ then\r
+ call wypisz(czas_sym div 60);\r
+ call outstring(" godz. ")\r
+ fi;\r
+ if czas_sym mod 60 =/= 0 then\r
+ call wypisz(czas_sym mod 60);\r
+ call outstring(" min.");\r
+ else call outstring(" ")\r
+ fi;\r
+ call hold(czas)\r
+ od;\r
+ \r
+ for i:=1 to ilosc_auto\r
+ do\r
+ call cancel(autobusy(i));\r
+ kill (autobusy(i))\r
+ od;\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ call zabij_pas(i);\r
+ call cancel(przystan(i));\r
+ kill (przystan(i))\r
+ od;\r
+ kill (autobusy);\r
+ kill (przystan);\r
+ call cancel(cl);\r
+ kill (cl);\r
+ call cancel(inf);\r
+ kill (inf);\r
+ call groff;\r
+ write("Symulowac dalej ?(T/N)");\r
+ read(c);\r
+ if c=/='t' then exit fi\r
+ od\r
+ end\r
+ end\r
+end.\r
--- /dev/null
+BLOCK\r
+ \r
+(*****************************************************************************)\r
+(********************************** F I F O **********************************)\r
+(*****************************************************************************)\r
+ \r
+unit FIFO : class ( type T);\r
+ \r
+ var HEAD,LAST : ELEM;\r
+ \r
+ unit ELEM : class ( INFO : T);\r
+ var NEXT : ELEM;\r
+ begin\r
+ end ELEM;\r
+ \r
+ unit EMPTY : function : boolean;\r
+ begin\r
+ result := (HEAD=NONE)\r
+ end EMPTY;\r
+ \r
+ unit INTO : procedure ( INFO : T );\r
+ begin\r
+ if EMPTY then\r
+ HEAD := new ELEM(INFO);\r
+ LAST := HEAD\r
+ else\r
+ LAST.NEXT := new ELEM(INFO);\r
+ LAST := LAST.NEXT\r
+ fi\r
+ end INTO;\r
+ \r
+ unit FIRST : function : T;\r
+ begin\r
+ result := HEAD.INFO\r
+ end FIRST;\r
+ \r
+ unit OUT_FIRST : procedure;\r
+ begin\r
+ if not EMPTY\r
+ then\r
+ HEAD := HEAD.NEXT\r
+ fi\r
+ end OUT_FIRST;\r
+ \r
+ unit CARDINAL : function : integer;\r
+ var HLP : ELEM;\r
+ begin\r
+ HLP := HEAD;\r
+ while HLP <> NONE\r
+ do\r
+ result :=result + 1;\r
+ HLP := HLP.NEXT\r
+ od\r
+ end CARDINAL;\r
+ \r
+ end FIFO;\r
+ \r
+ \r
+(*****************************************************************************)\r
+(************************** E N D F I F O *******************************)\r
+(*****************************************************************************)\r
+ \r
+(* * * * * * * * *)\r
+ \r
+(*****************************************************************************)\r
+(************************* S I M U L A T I O N *******************************)\r
+(*****************************************************************************)\r
+ \r
+UNIT PRIORITYQUEUE: IIUWGRAPH CLASS;\r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(E:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= E.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ \r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ \r
+ CALL CORRECT(E,FALSE)\r
+ END INSERT;\r
+ \r
+UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ if y<>none then Y.RIGHT:= LAST else root :=none fi;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ \r
+ z.left.right := none;\r
+ z.ns := 0;\r
+ z.left, z.right, z.up := none;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+END QUEUEHEAD;\r
+ \r
+ \r
+UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ \r
+UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ hidden curr, pq;\r
+ signal ERROR1, ERROR2;\r
+ VAR CURR : SIMPROCESS, (* ACTIVE PROCESS *)\r
+ PQ : QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR : MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS: COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ \r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN raise ERROR1; FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ handlers\r
+ when ERROR1 :\r
+ WRITELN(" AN ATTEMPT TO ACTIVATE AN IDLE PROCESS TIME");\r
+ attach(main);\r
+ when ERROR2 :\r
+ WRITELN(" AN ATTEMPT TO ACTIVATE A TERMINATED PROCESS TIME");\r
+ attach(MAIN);\r
+ end handlers;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ raise ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+ UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE\r
+ THEN\r
+ RESULT:= FALSE\r
+ ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR<= X.PRIOR);\r
+ FI;\r
+ END LESS;\r
+ \r
+ END EVENTNOTICE;\r
+ \r
+ \r
+ UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+ UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+ UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+ UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ (* ACTIVATION OF PROCESS P AT TIME T AND DEFINITION OF *)\r
+ (* "PRIOR"- PRIORITY WITHIN TIME MOMENT T *)\r
+ BEGIN\r
+ \r
+ if p.terminated then raise ERROR2 fi;\r
+ \r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI;\r
+ FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+ END SCHEDULE;\r
+ \r
+ UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE current PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ fi;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;\r
+ CALL CHOICEPROCESS;\r
+END RUN;\r
+ \r
+UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOOSE THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ BEGIN\r
+ (**** poprawka 10-93 ****)\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+ \r
+(*****************************************************************************)\r
+(************************ E N D S I M U L A T I O N *********************)\r
+(*****************************************************************************)\r
+ \r
+ \r
+(* B U S S I M U L A T I O N *)\r
+begin\r
+ pref iiuwgraph block\r
+ \r
+ BEGIN\r
+ PREF SIMULATION BLOCK\r
+ const pojemnosc=30;\r
+ var\r
+ zaj : zajezdnia,\r
+ przystan:arrayof przystanek,\r
+ inf:info,cl:zegar,\r
+ ws:integer,\r
+ c:char,\r
+ praz, booo:boolean,\r
+ i,j,jj,p,czas_sym,czas,ilosc_przystankow,\r
+ ilosc_auto,czestosc,odstep1,odstep2,podst1,podst2:integer;\r
+ \r
+ unit wsp:class(x,y,i:integer);\r
+ begin\r
+ end wsp;\r
+ \r
+ unit nast:function(w:wsp):wsp;\r
+ var pom:wsp;\r
+ begin\r
+ if w.i <= ilosc_przystankow div 2\r
+ then\r
+ pom:=new wsp(w.x,w.y - odstep1,i mod ilosc_przystankow +1)\r
+ else\r
+ if w.x>550\r
+ then\r
+ pom:=new wsp(600-w.x,20,i mod ilosc_przystankow+1)\r
+ else\r
+ pom:=new wsp(w.x,w.y+odstep1,i mod ilosc_przystankow+1)\r
+ fi\r
+ fi;\r
+ result:=pom\r
+ end nast;\r
+ \r
+ unit bus:simprocess class(nr,kolor:integer);\r
+ (* nr = numer autobusu *)\r
+ var i,j,kier,\r
+ wolnych_miejsc : integer,\r
+ dokad : arrayof integer,\r
+ ws : wsp,\r
+ wsiadajacy:pasazer;\r
+ begin\r
+ array dokad dim (1: ilosc_przystankow);\r
+ wolnych_miejsc := pojemnosc;\r
+ praz := true;\r
+ \r
+ ws := new wsp(480,282,1);\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ write(chr(7));\r
+ write(chr(7));\r
+ i:= entier(random*10);\r
+ call hold(10+i);\r
+ i:=1;\r
+ (* dojazd do pierwszego przystanku *)\r
+ \r
+ while ws.y>przystan(i).ws.y\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ if nr<> 1 then call hold(nr*2) fi;\r
+ call auto(0 ,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-2;\r
+ od;\r
+ \r
+ do (* petla w ktorej pracuje autobus *)\r
+ \r
+ ws.y:=przystan(i).ws.y;\r
+ ws.i:=i;\r
+ if i <= ilosc_przystankow div 2\r
+ then\r
+ kier:=1; ws.x := 480 else kier := -1; ws.x :=420;\r
+ fi;\r
+ \r
+ call auto(kolor,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ \r
+ (* autobus jest na przystanku *)\r
+ praz:=false;\r
+ wolnych_miejsc:=wolnych_miejsc + dokad(i);\r
+ (* z autobusu wysiadlo dokad(i) pasazerow *)\r
+ call auto(kolor,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ \r
+ call hold(2);\r
+ \r
+ (*** teraz pasazerowie wsiadaja ***)\r
+ while (wolnych_miejsc > 0) and (not przystan(i).kolejka.empty)\r
+ do\r
+ wsiadajacy:=przystan(i).kolejka.first;\r
+ dokad(wsiadajacy.dokad) := dokad(wsiadajacy.dokad) +1;\r
+ call usun(przystan(i).ws.x,przystan(i).ws.y,\r
+ kier*przystan(i).kolejka.cardinal);\r
+ call przystan(i).kolejka.out_first;\r
+ wolnych_miejsc:=wolnych_miejsc - 1;\r
+ \r
+ call auto(0,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ call auto(kolor,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ \r
+ call run(wsiadajacy);\r
+ call run(inf);\r
+ kill(wsiadajacy)\r
+ od;\r
+ \r
+ (* autobus rusza z przystanku *)\r
+ call auto(0,ws.x+kier*10,ws.y,wolnych_miejsc);\r
+ if i= ilosc_przystankow div 2\r
+ then\r
+ while ws.y> 26\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-2;\r
+ od;\r
+ ws.x := 420; (*autobus przeskakuje na druga strone ulicy*)\r
+ kier := -1;\r
+ fi;\r
+ \r
+ if i=ilosc_przystankow then\r
+ while ws.y< 282\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y+2;\r
+ od;\r
+ ws.x := 480; (*autobus przeskakuje na druga strone ulicy*)\r
+ kier := 1;\r
+ i :=0;\r
+ fi;\r
+ \r
+ if i<ilosc_przystankow div 2\r
+ then\r
+ while ws.y>przystan(i+1).ws.y\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-kier*2;\r
+ od;\r
+ else\r
+ while ws.y< przystan(i+1).ws.y\r
+ do\r
+ call auto(kolor,ws.x,ws.y,wolnych_miejsc);\r
+ call hold(2);\r
+ call auto(0,ws.x,ws.y,wolnych_miejsc);\r
+ ws.y := ws.y-kier*2;\r
+ od;\r
+ fi;\r
+ \r
+ i:=i mod ilosc_przystankow + 1;\r
+ od\r
+ end bus;\r
+ \r
+ unit pasazer:simprocess class(nr,kolor:integer);\r
+ var czas_przyjscia,czas_oczekiwania:integer,\r
+ dokad : integer;\r
+ begin\r
+ dokad := 1+entier(random*(ilosc_przystankow-1));\r
+ czas_przyjscia:=time;\r
+ call passivate;\r
+ czas_oczekiwania:=time-czas_przyjscia;\r
+ przystan(nr).laczny_czas:=przystan(nr).laczny_czas +\r
+ czas_oczekiwania;\r
+ przystan(nr).sredniczas:=przystan(nr).laczny_czas /\r
+ przystan(nr).total\r
+ end pasazer;\r
+ \r
+ unit zajezdnia : simprocess class(ilosc,czestosc : integer) ;\r
+ var autobus : bus, i,j : integer;\r
+ begin\r
+ for i:=1 to ilosc\r
+ do\r
+ j:= entier(random*5)+2; (*kolor autobusu i= numer autobusu*)\r
+ autobus := new bus(i,j) ;\r
+ call schedule(autobus,time+2);\r
+ call HOLD(czestosc*i);\r
+ od;\r
+ end zajezdnia;\r
+ \r
+ unit przystanek : simprocess class(nr:integer);\r
+ var k, jak_czesto : integer,\r
+ kolejka : FIFO,\r
+ new_pas : pasazer,\r
+ ws:wsp,\r
+ kier,ilosc_pas,total,laczny_czas,czas_do_nast:integer,\r
+ sredniczas : real;\r
+ begin\r
+ kolejka := new FIFO(pasazer);\r
+ czas_do_nast:=3;\r
+ (*to powinno byc zalezne od szybkosci autobusu*)\r
+ (* i odleglosci miedzy przystankami*)\r
+ \r
+ if nr<=ilosc_przystankow div 2 then\r
+ ws := new wsp(510,290-podst1-(nr-1)*odstep1,nr)\r
+ else\r
+ ws := new wsp(390,podst2+(nr-ilosc_przystankow div 2-1)*odstep2,nr)\r
+ fi;\r
+ \r
+ if ws.x>450 then\r
+ call move(ws.x-15,ws.y+10)\r
+ else\r
+ call move(ws.x,ws.y+10)\r
+ fi;\r
+ call color(15);\r
+ call wypisz(ws.i);\r
+ call hold(2);\r
+ (* generowanie pasazerow *)\r
+ do\r
+ (* jak_czesto sa losowani pasazerowie *)\r
+ if nr<= (ilosc_przystankow div 2)\r
+ then\r
+ kier := 1 else kier := -1\r
+ fi;\r
+ k:= entier(random*12)+2; (*kolor pasazera*)\r
+ new_pas:=new pasazer(nr,k);\r
+ total:=total+1;\r
+ call kolejka.into(new_pas);\r
+ call kol(ws.x,ws.y,kier*kolejka.cardinal,k);\r
+ call schedule(new_pas,time);\r
+ call hold(entier(random*10)+10);\r
+ od;\r
+ end przystanek;\r
+ \r
+ \r
+ (*------------------------------------------------------------------------*)\r
+ (*-------------------- PROCEDURY POMOCNICZE ----------------------------*)\r
+ (*------------------------------------------------------------------------*)\r
+ \r
+ unit ludzik:procedure(x,y,k :integer);\r
+ begin\r
+ call color(k);\r
+ call move(x,y);\r
+ call draw(x,y+6);\r
+ call draw(x-2,y+10);\r
+ call move(x,y+6);\r
+ call draw(x+2,y+10);\r
+ call move(x-2,y+2);\r
+ call draw(x+2,y+2);\r
+ call move(x-2,y+2);\r
+ call draw(x-4,y+4);\r
+ call move(x+2,y+2);\r
+ call draw(x+4,y+4);\r
+ call color(15);\r
+ end;\r
+ \r
+ \r
+ unit usun:procedure(x,y,m:integer);\r
+ var i:integer;\r
+ begin\r
+ if m<=15\r
+ then\r
+ call color(0);\r
+ call ludzik(x+8*m,y,0);\r
+ call color(15)\r
+ fi\r
+ end;\r
+ \r
+ unit kol:procedure(x,y,m,k:integer);\r
+ var i:integer;\r
+ begin\r
+ if m<=15\r
+ then\r
+ call ludzik(x+8*m,y,k)\r
+ fi\r
+ end;\r
+ \r
+ \r
+ unit wypisz : procedure(x:integer);\r
+ unit CHRTYP :function ( x:integer):string;\r
+ (* zamiana liczby na tekst *)\r
+ begin\r
+ case x\r
+ when 1 : result:="1";\r
+ when 2 : result:="2";\r
+ when 3 : result:="3";\r
+ when 4 : result:="4";\r
+ when 5 : result:="5";\r
+ when 6 : result:="6";\r
+ when 7 : result:="7";\r
+ when 8 : result:="8";\r
+ when 9 : result:="9";\r
+ when 0 : result:="0"\r
+ esac\r
+ end;\r
+ begin\r
+ \r
+ if x<0 then call outstring("ujemna liczba")\r
+ else\r
+ call outstring(chrtyp(x div 10));\r
+ call outstring(chrtyp(x mod 10))\r
+ fi\r
+ end wypisz;\r
+ \r
+ \r
+ unit zegar:simprocess class;\r
+ var i,j:integer;\r
+ begin\r
+ call color(4);\r
+ call ramka(420,310,480,335);\r
+ call ramka(422,312,478,333);\r
+ call ramka(421,311,479,334);\r
+ call color(15);\r
+ do\r
+ call color(1);\r
+ call move(433,320);\r
+ call wypisz(i);\r
+ call outstring(":");\r
+ call wypisz(j);\r
+ j:=j+1;\r
+ if j=60 then j:=0;i:=i+1 fi;\r
+ call hold(1);\r
+ od\r
+ end zegar;\r
+ \r
+ \r
+ unit info:simprocess class;\r
+ var i:integer;\r
+ begin\r
+ call color(4);\r
+ call ramka(0,0,324,140+10*ilosc_przystankow);\r
+ call ramka(1,1,326,141+10*ilosc_przystankow);\r
+ call color(15);\r
+ call move(10,50);\r
+ call outstring("Max. nb. of persons in the bus:");\r
+ call outstring("30 os.");\r
+ call move(10,70);\r
+ call outstring("Time przejazdu miedzy");\r
+ call move(10,80);\r
+ call outstring("przystankami:");\r
+ call outstring(" 3 min.");\r
+ call move(10,10);\r
+ call outstring("The time of Simulation:");\r
+ if czas_sym div 60=/=0\r
+ then\r
+ call wypisz(czas_sym div 60);\r
+ call outstring(" h. ")\r
+ fi;\r
+ call wypisz(czas_sym mod 60);\r
+ call outstring(" min.");\r
+ call move(10,30);\r
+ call outstring("Frequency :");\r
+ call wypisz(czestosc);\r
+ call outstring(" min.");\r
+ call move(200,100);\r
+ call outstring("Avrage ");\r
+ call move(200,110);\r
+ call outstring("waiting-time:");\r
+ call move(30,100);\r
+ call outstring("BUS");\r
+ call move(30,110);\r
+ call outstring("STOP");\r
+ call outstring(" ");\r
+ call move(90,100);\r
+ call outstring("Number");\r
+ call move(90,110);\r
+ call outstring("of persons");\r
+ call color(4);\r
+ call ramka(530,5,610,20);\r
+ call move(535,10);\r
+ call outstring("Esc - END");\r
+ call color(15);\r
+ do\r
+ if inkey=27 then call run(mainpr) fi;\r
+ call color(15);\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ call move(30,120+i*10);\r
+ call wypisz(i);\r
+ call outstring(" ");\r
+ call move(90,120+i*10);\r
+ call wypisz(przystan(i).kolejka.cardinal);\r
+ call outstring(" ");\r
+ call move(200,120+i*10);\r
+ call wypisz(entier(przystan(i).sredniczas));\r
+ call outstring(".");\r
+ call wypisz(entier(przystan(i).sredniczas*10) mod 10);\r
+ call outstring(" min. ")\r
+ od;\r
+ call hold(0.5)\r
+ od\r
+ end info;\r
+ \r
+ \r
+ \r
+ unit ramka : procedure(x1,y1,x2,y2:integer);\r
+ begin\r
+ call move(x1,y1);\r
+ call draw(x2,y1);\r
+ call draw(x2,y2);\r
+ call draw(x1,y2);\r
+ call draw(x1,y1)\r
+ end ramka;\r
+ \r
+ \r
+ unit pr:procedure(x,y,dx,dy:integer);\r
+ begin\r
+ call ramka(x-dx div 2,y-dy div 2,x+dx div 2,y+dy div 2)\r
+ end pr;\r
+ \r
+ unit auto:procedure(k,x,y,n:integer);\r
+ begin (* ilosc miejsc wolnych w aucie *)\r
+ call color(k);\r
+ call pr(x,y,8,18);\r
+ call pr(x,y,10,20);\r
+ call pr(x,y,10,2);\r
+ call wypisz(n); (* ilosc pasazerow w autobusie *)\r
+ end auto;\r
+ \r
+ \r
+ \r
+ unit zabij_pas:procedure(i:integer);\r
+ var p:pasazer;\r
+ begin\r
+ while przystan(i).kolejka.cardinal>0\r
+ do\r
+ p:=przystan(i).kolejka.first;\r
+ call przystan(i).kolejka.out_first;\r
+ if p.event=/=none then call cancel(p) fi;\r
+ kill(p)\r
+ od\r
+ end zabij_pas;\r
+ \r
+ unit wstep:procedure;\r
+ begin\r
+ call gron(0);\r
+ call ramka(230,120,480,220);\r
+ call ramka(228,118,482,222);\r
+ call ramka(226,116,484,224);\r
+ call move(250,140);\r
+ call outstring(" PROJET 6 ");\r
+ call move(250,160);\r
+ call outstring(" BUS SIMULATION ");\r
+ call move(250,180);\r
+ call outstring("Author: Nguyen Tuan Trung");\r
+ call move(250,200);\r
+ call outstring(" Warsaw 24 - 05 - 1990");\r
+ WHILE INKEY=0 DO OD;\r
+ call groff\r
+ end wstep;\r
+ \r
+ unit Jezdnia : procedure;\r
+ var i : integer;\r
+ begin\r
+ for i:=1 to 7\r
+ do\r
+ (* rysowanie pasa srodkowego jezdni *)\r
+ call color(14);\r
+ call ramka(448,300-i*40,452,320-i*40);\r
+ call ramka(449,300-i*40,451,320-i*40);\r
+ call ramka(450,300-i*40,450,320-i*40);\r
+ call color(15);\r
+ od;\r
+ end Jezdnia;\r
+ \r
+ (*----------- PROGRAM GLOWNY---------------------------------------------*)\r
+ \r
+ \r
+ begin\r
+ call wstep; booo:= true;\r
+ DO (* to repeat simulation *)\r
+ \r
+ do\r
+ write("Simulation time = ");\r
+ readln(czas_sym);\r
+ if czas_sym > 0\r
+ then exit\r
+ else writeln(" The simulation time must be >0 ")\r
+ fi\r
+ od;\r
+ do\r
+ write("Number of bus-stops (1-10) = ");\r
+ readln(ilosc_przystankow);\r
+ if ilosc_przystankow>1 and ilosc_przystankow < 11 then exit\r
+ else writeln("It must be not bigger than 10!")\r
+ fi\r
+ od;\r
+ do\r
+ write("Number of buses (>0) = ");\r
+ readln(ilosc_auto);\r
+ if ilosc_auto>0 then\r
+ exit\r
+ else\r
+ writeln("Must be bigger than 0 !")\r
+ fi\r
+ od;\r
+ do\r
+ write("Frequency of buses (>10) = ");\r
+ readln(czestosc);\r
+ if czestosc>=10 then exit\r
+ else\r
+ writeln("Must be bigger than 9 !")\r
+ fi;\r
+ od;\r
+ \r
+ call gron(0);\r
+ call color(2); (* ta ramka odpowiada jezdni *)\r
+ call ramka(400,3,502,300);\r
+ call ramka(399,2,503,301);\r
+ call ramka(398,1,504,302);\r
+ call ramka(395,0,507,305);\r
+ call color(15);\r
+ odstep1:=290 div (ilosc_przystankow div 2 + 1);\r
+ podst1:=(290- (ilosc_przystankow div 2-1)*odstep1) div 2;\r
+ odstep2:=290 div (ilosc_przystankow -\r
+ ilosc_przystankow div 2 + 1);\r
+ podst2:=(290- (ilosc_przystankow-\r
+ ilosc_przystankow div 2-1)*odstep2) div 2;\r
+ call jezdnia;\r
+ \r
+(*_____________________________________________________________*)\r
+ \r
+ array przystan dim(1:ilosc_przystankow);\r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ przystan(i):=new przystanek(i);\r
+ call schedule(przystan(i),time)\r
+ od;\r
+ \r
+ cl:=new zegar;\r
+ call schedule(cl,time);\r
+ inf:=new info;\r
+ call schedule(inf,time+0.5);\r
+ \r
+ zaj := new zajezdnia(ilosc_auto,czestosc);\r
+ call schedule(zaj, time);\r
+ \r
+ WHILE BOOO DO\r
+ call hold(czas_sym+0.7);\r
+ (* program glowny czeka az sie skonczy czas symulacji *)\r
+ \r
+ call ramka(520,290,620,345);\r
+ call ramka(521,291,619,344);\r
+ call move(530,300);\r
+ \r
+ call outstring("TIME IS OUT");\r
+ call move(530,320);\r
+ call outstring("GO ON(y/n)?");\r
+ i:=inkey;\r
+ while i=0 do i:=inkey od;\r
+ if (i=ord('y'))\r
+ then\r
+ booo := true;\r
+ call move(530,320);\r
+ call outstring("add: ");\r
+ call move(565,320);\r
+ jj:=0;\r
+ for p:=1 to 2\r
+ do\r
+ i:=inkey;\r
+ while ( not( i>=ord('0') and i<=ord('9')) and i=0)\r
+ do i:= inkey od;\r
+ call hascii(i);\r
+ jj := 10*jj+ (i-ord('0'));\r
+ od;\r
+ czas := czas+jj;\r
+ call outstring(" min");\r
+ \r
+ for j:=1 to 2000 do od;\r
+ call color(0);\r
+ call ramka(520,290,620,345);\r
+ call ramka(521,291,619,344);\r
+ \r
+ call move(530,300);\r
+ call outstring(" ");\r
+ call move(530,320);\r
+ call outstring(" ");\r
+ \r
+ czas_sym:=czas_sym+czas;\r
+ call color(15);\r
+ call move(10,10);\r
+ call outstring(" ");\r
+ call move(10,10);\r
+ call outstring("Czas symulacji:");\r
+ if czas_sym div 60<>0\r
+ then\r
+ call wypisz(czas_sym div 60);\r
+ call outstring(" godz. ")\r
+ fi;\r
+ if czas_sym mod 60 <>0 then\r
+ call wypisz(czas_sym mod 60);\r
+ call outstring(" min.");\r
+ fi;\r
+ else\r
+ booo := false; (* nie przedluzam *)\r
+ fi; (*******************************)\r
+ \r
+ OD (* WHILE BOOO *);\r
+ \r
+(*___________________________________________________________________*)\r
+(* usuwanie obiektow stworzonych przez symulacje *)\r
+(*___________________________________________________________________*)\r
+ \r
+ for i:=1 to ilosc_przystankow\r
+ do\r
+ call zabij_pas(i);\r
+ call cancel(przystan(i));\r
+ kill (przystan(i))\r
+ od;\r
+ \r
+ kill (zaj);\r
+ kill (przystan);\r
+ call cancel(cl);\r
+ kill (cl);\r
+ call cancel(inf);\r
+ kill (inf);\r
+ call groff;\r
+ \r
+ write("Do you like to repeat the simulation process (y/n) ?");\r
+ (* uwaga!! autobusy nie zostaly usuniete !! *)\r
+ \r
+ read(c);\r
+ if c<> 'y' then exit fi ;\r
+ OD;\r
+ end\r
+ end\r
+end.\r
--- /dev/null
+program gar;\r
+ \r
+(* DEFINITION DE LA PAGE GRAPHIQUE GENERALE *)\r
+ \r
+BEGIN\r
+ \r
+PREF iiuwgraph BLOCK\r
+ \r
+(* PROCEDURE PAUSE POUR ATTENTE AU CLAVIER *)\r
+ \r
+UNIT PAUSE:procedure;\r
+ VAR touche:char;\r
+BEGIN\r
+ call color(12);\r
+ call move(100,320);\r
+ call outstring(" Appuyer sur ENTREE pour passer a la suite");\r
+ read(touche);\r
+END PAUSE;\r
+ \r
+(* PROCEDURE D ATTENTE PAR BOUCLE ACTIVE *)\r
+ \r
+UNIT attend:procedure(tmp:integer);\r
+ VAR i:integer;\r
+BEGIN\r
+ for i:=0 to tmp * 10 do od;\r
+END attend;\r
+ \r
+(* PROCEDURE D ATTENTE AVEC COMPTEUR POUR LA SORTIE DE L APPLICATION *)\r
+ \r
+UNIT attend_sortie:procedure;\r
+ VAR x,y,i,k,j:integer;\r
+BEGIN\r
+ j:=9;\r
+ x:=300;\r
+ y:=200;\r
+ for k:=1 to 10 do\r
+ call color(11);\r
+ call move(300,200);\r
+ call HASCII(j+48);\r
+ for i:=0 to 4000 do od;\r
+ call color(0);\r
+ call rectangle_double(x,y-1,x+25,y+9);\r
+ call rectangle_double(x+1,y,x+24,y+8);\r
+ call rectangle_double(x+4,y+2,x+22,y+6);\r
+ call rectangle_double(x+5,y+3,x+21,y+5);\r
+ j:=j-1;\r
+ od;\r
+END attend_sortie;\r
+ \r
+(* PAGE DE PRESENTATION GENERALE DE DEBUT *)\r
+ \r
+UNIT presentation:iiuwgraph procedure;\r
+BEGIN\r
+ (* creation d'une bordure*)\r
+ call border(13);\r
+ \r
+ (*creation d'un cadre pour la fenetre*)\r
+ call move(10,10);\r
+ call draw(10,340);\r
+ call draw( 628,340);\r
+ call draw(628,10);\r
+ call draw(10,10);\r
+ call color(2);\r
+ \r
+ (*contenu du titre*)\r
+ call move(180,80);\r
+ call outstring("IMPLEMENTATION D'UNE SIMULATION");\r
+ call move(260,100);\r
+ call outstring("DE GARE SNCF");\r
+ call color(12);\r
+ call move(250,180);\r
+ call outstring("PROJET NUMERO 2");\r
+ call color(14);\r
+ call move(130,280);\r
+ call outstring("PAR : Mr AC'H Fabrice et CLAVERIE Jean-Fran\87ois");\r
+ call move(130,300);\r
+ call outstring(" Mr GOUGEON Jean-Yves et Mr RICHARD Jerome");\r
+ \r
+ (*appel de la procedure pause pour passer a la suite*)\r
+ call PAUSE;\r
+ \r
+ (*appel de l'effacage de l'ecran*)\r
+ call cls;\r
+END presentation;\r
+ \r
+(* FONCTION DEFINISSANT UNE MESSAGE-BOX *)\r
+(* ARGUMENTS : Text_message, Longueur_message, Couleur_text, Coordonnees *)\r
+ \r
+UNIT msgbox : function(message:string,long,couleur,x,y:integer):boolean;\r
+ VAR centrage:integer,reponse:boolean,\r
+ h,v,b,i:integer;\r
+BEGIN\r
+ PREF mouse BLOCK\r
+ BEGIN\r
+ \r
+ (* si texte petit met longueur a 6 par defaut *)\r
+ if(long<6) then long:=6; fi;\r
+ \r
+ call move(x,y);\r
+ call color(couleur);\r
+ call rectangle_double(x,y,x+(long * 9 + 20)+2,y + 52);\r
+ \r
+ (* centrage du texte dans le rectangle *)\r
+ centrage:=((long * 9+20) div 2) - ((long div 2)*8);\r
+ \r
+ for i:=(y + 3) to (y+49) do\r
+ call color(7);\r
+ call move(x+3,i);\r
+ call draw(x+(long * 9) +19 ,i);\r
+ od;\r
+ call color(couleur);\r
+ call move(x+centrage,y+5);\r
+ call outstring(message);\r
+ call color(14);\r
+ \r
+ (* definition des boutons OUI et NON *)\r
+ \r
+ call rectangle(x+centrage+1,y+29,x+centrage+26,y+41);\r
+ call move(x+centrage+2,y+32);\r
+ call outstring("OUI");\r
+ call rectangle(x+(long * 9) -centrage +1,y+29,x+(long * 9) -centrage +26,y+41);\r
+ call move(x+(long * 9) - centrage +2,y+32);\r
+ call outstring("NON");\r
+ call showcursor;\r
+ do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ if(gauche) then\r
+ if((v> y + 29)and(v> y + 32)) then\r
+ if((h>(x+centrage+1))and(h<(x+centrage+26)))\r
+ then reponse:=true; gauche:=false; exit;\r
+ else\r
+ if((h>(x+(long * 9)-centrage +1))and(h<(x+(long * 9)-centrage +26)))\r
+ then reponse:=false;gauche:=false; exit;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ call hidecursor;\r
+ result:=reponse;\r
+ END;\r
+END msgbox;\r
+ \r
+(* PROCEDURE DE TRACAGE DE RECTANGLE SIMPLE *)\r
+ \r
+UNIT rectangle:iiuwgraph procedure(x_h,y_h,x_b,y_b:integer);\r
+BEGIN\r
+ call move(x_h,y_h);\r
+ call draw(x_b,y_h);\r
+ call draw(x_b,y_b);\r
+ call draw(x_h,y_b);\r
+ call draw(x_h,y_h);\r
+END rectangle;\r
+ \r
+(* PROCEDURE DE TRACAGE DE RECTANGLE DOUBLE AVEC RECTANGLE SIMPLE *)\r
+ \r
+UNIT rectangle_double : iiuwgraph procedure(x_h,y_h,x_b,y_b:integer);\r
+BEGIN\r
+ call rectangle(x_h,y_h,x_b,y_b);\r
+ call rectangle(x_h+2,y_h+2,x_b-2,y_b-2);\r
+END rectangle_double;\r
+ \r
+(* PROCEDURE DE CHOIX DES PARAMETRES DE LA SIMULATION *)\r
+(* RENVOIE LA DUREE ET LE TYPE DE SIMULATION *)\r
+ \r
+UNIT param : iiuwgraph procedure(inout duree,typ :integer);\r
+ VAR haut,bas:boolean,h,v,b:integer;\r
+BEGIN\r
+ PREF mouse BLOCK\r
+ BEGIN\r
+ \r
+ (*initialisation *)\r
+ haut:=true;\r
+ typ:=0;\r
+ duree:=0;\r
+ h:=0;v:=0;b:=0;\r
+ bas:=true;\r
+ call color(14);\r
+ call move(100,40);\r
+ call outstring(" CHER UTILISATEUR CHOISISSEZ UNE DUREE PARMI :");\r
+ call rectangle_double(100,60,550,100);\r
+ \r
+ (* fait les bares verticales *)\r
+ call move(150,62);\r
+ call draw(150,98);\r
+ call move(200,62);\r
+ call draw(200,98);\r
+ call move(250,62);\r
+ call draw(250,98);\r
+ call move(300,62);\r
+ call draw(300,98);\r
+ call move(350,62);\r
+ call draw(350,98);\r
+ call move(400,62);\r
+ call draw(400,98);\r
+ call move(450,62);\r
+ call draw(450,98);\r
+ call move(500,62);\r
+ call draw(500,98);\r
+ \r
+ (* fin bare verticales *)\r
+ (*texte*)\r
+ call color(15);\r
+ call move(105,78);call outstring("1 min");\r
+ call move(155,78);call outstring("2 min");\r
+ call move(205,78);call outstring("3 min");\r
+ call move(255,78);call outstring("4 min");\r
+ call move(305,78);call outstring("5 min");\r
+ call move(355,78);call outstring("6 min");\r
+ call move(405,78);call outstring("7 min");\r
+ call move(455,78);call outstring("8 min");\r
+ call move(505,78);call outstring("9 min");\r
+ (*fin texte*)\r
+ \r
+ call color(14);\r
+ call move(100,150);\r
+ call outstring(" ET UN TYPE DE SIMULATION ( densite des VOYAGEURs ) :");\r
+ call rectangle_double(100,170,550,210);\r
+ \r
+ (* bares verticales *)\r
+ call move(250,172);\r
+ call draw(250,208);\r
+ call move(400,172);\r
+ call draw(400,208);\r
+ (* fin bare verticales *)\r
+ \r
+ (*texte*)\r
+ call color(15);\r
+ call move(121,184);call outstring(" Nuit");\r
+ call move(275,184);call outstring(" Jour");\r
+ call move(425,184);call outstring(" Dense");\r
+ (*fin texte*)\r
+ \r
+ (* definition de la souris *)\r
+ call showcursor;\r
+ while(haut or bas) do\r
+ call getpress(0,h,v,b,gauche,droit,centre);\r
+ if (gauche) then\r
+ if(h>100 and h<550) then\r
+ call HIDECURSOR;\r
+ if(haut) then\r
+ if(v>60 and v<100) then\r
+ if(h>100 and h<150) then duree:=10;\r
+ \r
+ call color(0);\r
+ call move(105,78);\r
+ call outstring("1 min");\r
+ \r
+ call color(12);\r
+ call move(105,78);\r
+ call outstring("1 min");\r
+ else\r
+ if(h>150 and h<200) then duree:=20;\r
+ \r
+ call color(0);\r
+ call move(155,78);\r
+ call outstring("2 min");\r
+ \r
+ call color(12);\r
+ call move(155,78);\r
+ call outstring("2 min");\r
+ \r
+ else\r
+ if(h>200 and h<250) then duree:=30;\r
+ \r
+ call color(0);\r
+ call move(205,78);\r
+ call outstring("3 min");\r
+ \r
+ call color(12);\r
+ call move(205,78);\r
+ call outstring("3 min");\r
+ \r
+ else\r
+ if(h>250 and h<300) then duree:=40;\r
+ \r
+ call color(0);\r
+ call move(255,78);\r
+ call outstring("4 min");\r
+ \r
+ call color(12);\r
+ call move(255,78);\r
+ call outstring("4 min");\r
+ \r
+ else\r
+ if(h>300 and h<350) then duree:=50;\r
+ \r
+ call color(0);\r
+ call move(305,78);\r
+ call outstring("5 min");\r
+ \r
+ call color(12);\r
+ call move(305,78);\r
+ call outstring("5 min");\r
+ \r
+ else\r
+ if(h>350 and h<400) then duree:=60;\r
+ \r
+ call color(0);\r
+ call move(355,78);\r
+ call outstring("6 min");\r
+ \r
+ call color(12);\r
+ call move(355,78);\r
+ call outstring("6 min");\r
+ \r
+ else\r
+ if(h>400 and h<450) then duree:=70;\r
+ \r
+ call color(0);\r
+ call move(405,78);\r
+ call outstring("7 min");\r
+ \r
+ call color(12);\r
+ call move(405,78);\r
+ call outstring("7 min");\r
+ \r
+ else\r
+ if(h>450 and h<500) then duree:=80;\r
+ \r
+ call color(0);\r
+ call move(455,78);\r
+ call outstring("8 min");\r
+ \r
+ call color(12);\r
+ call move(455,78);\r
+ call outstring("8 min");\r
+ \r
+ else\r
+ if (h>500 and h<550) then duree:=90;\r
+ \r
+ call color(0);\r
+ call move(505,78);\r
+ call outstring("9 min");\r
+ \r
+ call color(12);\r
+ call move(505,78);\r
+ call outstring("9 min");\r
+ \r
+ fi;fi;fi;fi;fi;fi;fi;fi;fi;\r
+ haut:=false;\r
+ fi;\r
+ fi;\r
+ if (bas) then\r
+ if(v>170 and v<210) then\r
+ if (h>100 and h<250) then typ:=1;\r
+ \r
+ call color(0);\r
+ call move(121,184);\r
+ call outstring(" Nuit");\r
+ \r
+ call color(12);\r
+ call move(121,184);\r
+ call outstring(" Nuit");\r
+ \r
+ else\r
+ if (h>250 and h<400) then typ:=2;\r
+ \r
+ call color(0);\r
+ call move(275,184);\r
+ call outstring(" Jour");\r
+ \r
+ call color(12);\r
+ call move(275,184);\r
+ call outstring(" Jour");\r
+ else\r
+ if (h>400 and h<550) then typ:=3;\r
+ \r
+ call color(0);\r
+ call move(425,184);\r
+ call outstring(" Dense");\r
+ \r
+ call color(12);\r
+ call move(425,184);\r
+ call outstring(" Dense");\r
+ fi;fi;fi;\r
+ bas:=false;\r
+ fi;\r
+ fi;\r
+ call SHOWCURSOR;\r
+ fi;\r
+ gauche:=false;\r
+ fi;\r
+ od;\r
+ call color(10);\r
+ call move(100,300);\r
+ call outstring(" La duree sera de : ");call color(15);\r
+ case duree\r
+ when 10:call outstring("1 min");\r
+ when 20:call outstring("2 min");\r
+ when 30:call outstring("3 min");\r
+ when 40:call outstring("4 min");\r
+ when 50:call outstring("5 min");\r
+ when 60:call outstring("6 min");\r
+ when 70:call outstring("7 min");\r
+ when 80:call outstring("8 min");\r
+ when 90:call outstring("9 min");\r
+ esac;\r
+ call color(10);\r
+ call outstring(" et le type sera : ");call color(15);\r
+ case typ\r
+ when 1:call outstring("Nuit");\r
+ when 2:call outstring("Jour");\r
+ when 3:call outstring("Dense");\r
+ esac;\r
+ call PAUSE;\r
+ call hidecursor;\r
+ call cls;\r
+ END;\r
+END param;\r
+ \r
+(* PROCEDURE D ECRITURE D UN ENTIER A L ECRAN *)\r
+(* PARAMETRES TEMPS:REAL et COORDONNEES *)\r
+ \r
+UNIT ecrit_chiffre : procedure(TIME:real,x,y:integer);\r
+ VAR wtime :integer;\r
+BEGIN\r
+ call move(x,y);\r
+ call HASCII(0);\r
+ wtime:=entier(TIME);\r
+ (* temps <1000 *);\r
+ if(wtime>=100) then\r
+ call HASCII(wtime div 100+48);\r
+ wtime:=wtime mod 100;\r
+ else call HASCII(0);\r
+ fi;\r
+ call HASCII(wtime div 10 + 48);\r
+ call HASCII(wtime mod 10 + 48);\r
+END ecrit_chiffre;\r
+ \r
+(* PROCEDURE D EFFACEMENT DU CHIFFRE ECRIT *)\r
+ \r
+UNIT EFFACE_chiffre : procedure(x,y:integer);\r
+BEGIN\r
+ call color(0);\r
+ call rectangle_double(x,y-1,x+25,y+9);\r
+ call rectangle_double(x+1,y,x+24,y+8);\r
+ call rectangle_double(x+4,y+2,x+22,y+6);\r
+ call rectangle_double(x+5,y+3,x+21,y+5);\r
+END EFFACE_chiffre;\r
+ \r
+(* PROCEDURE DE TRACAGE DES VOIES *)\r
+ \r
+UNIT voie:iiuwgraph procedure;\r
+BEGIN\r
+ call color(9);\r
+ call rectangle_double(4,170,635,176);\r
+ call rectangle_double(5,171,634,175);\r
+ call move(5,171);\r
+ call color(14);\r
+ call outstring("QUAI 1");\r
+ call color(9);\r
+ call rectangle(4,177,635,195);\r
+ call color(10);\r
+ call rectangle_double(4,220,635,226);\r
+ call rectangle_double(5,221,634,225);\r
+ call move(5,221);\r
+ call color(14);\r
+ call outstring("QUAI 2");\r
+ call color(10);\r
+ call rectangle(4,227,635,245);\r
+ call color(11);\r
+ call rectangle_double(4,270,635,276);\r
+ call rectangle_double(5,271,634,275);\r
+ call move(5,271);\r
+ call color(14);\r
+ call outstring("QUAI 3");\r
+ call color(11);\r
+ call rectangle(4,277,635,295);\r
+ call color(12);\r
+ call rectangle_double(4,320,635,326);\r
+ call rectangle_double(5,321,634,325);\r
+ call move(5,321);\r
+ call color(14);\r
+ call outstring("QUAI 4");\r
+ call color(12);\r
+ call rectangle(4,327,635,345);\r
+END voie;\r
+ \r
+(* PROCEDURE DE TRACAGE DES CAISSES *)\r
+ \r
+UNIT caisse : iiuwgraph procedure;\r
+BEGIN\r
+ call color(15);\r
+ \r
+ (*caisse1*)\r
+ call rectangle_double(10,3,80,23);\r
+ \r
+ (*caisse2*)\r
+ call rectangle_double(10,26,80,43);\r
+ \r
+ (*caisse3*)\r
+ call rectangle_double(10,47,80,65);\r
+ \r
+ (*caisse4*)\r
+ call rectangle_double(10,68,80,86);\r
+ \r
+ (*texte caisse*)\r
+ call color(9);\r
+ call move(14,9);\r
+ call outstring("Caisse 1");\r
+ call move(14,31);\r
+ call color(10);\r
+ call outstring("Caisse 2");\r
+ call move(14,52);\r
+ call color(11);\r
+ call outstring("Caisse 3");\r
+ call move(14,73);\r
+ call color(12);\r
+ call outstring("Caisse 4");\r
+END caisse;\r
+ \r
+(* PROCEDURE D ECRITURE DES MESSAGES D ARRIVEE DES TRAIN DANS TABLEAU *)\r
+ \r
+UNIT mes_train :procedure(num:integer);\r
+BEGIN\r
+ case num\r
+ when 1:\r
+ call color(9);\r
+ call move(435,9);\r
+ call outstring("le train quai 1 arrive");\r
+ when 2:\r
+ call color(10);\r
+ call move(435,31);\r
+ call outstring("le train quai 2 arrive");\r
+ when 3:\r
+ call color(11);\r
+ call move(435,52);\r
+ call outstring("le train quai 3 arrive");\r
+ when 4:\r
+ call color(12);\r
+ call move(435,73);\r
+ call outstring("le train quai 4 arrive");\r
+ \r
+ esac;\r
+END mes_train;\r
+ \r
+UNIT mes_train_rep :procedure(num:integer);\r
+BEGIN\r
+ case num\r
+ when 1:\r
+ call color(9);\r
+ call move(435,9);\r
+ call outstring("le train quai 1 REPART");\r
+ when 2:\r
+ call color(10);\r
+ call move(435,31);\r
+ call outstring("le train quai 2 REPART");\r
+ when 3:\r
+ call color(11);\r
+ call move(435,52);\r
+ call outstring("le train quai 3 REPART");\r
+ when 4:\r
+ call color(12);\r
+ call move(435,73);\r
+ call outstring("le train quai 4 REPART");\r
+ \r
+ esac;\r
+END mes_train_rep;\r
+ \r
+UNIT eff_mestrn:procedure(num:integer);\r
+BEGIN\r
+ call color(0);\r
+ case num\r
+ when 1:\r
+ call move(435,9);\r
+ call outstring("le train quai 1 arrive");\r
+ when 2:\r
+ call move(435,31);\r
+ call outstring("le train quai 2 arrive");\r
+ when 3:\r
+ call move(435,52);\r
+ call outstring("le train quai 3 arrive");\r
+ when 4:\r
+ call move(435,73);\r
+ call outstring("le train quai 4 arrive");\r
+ \r
+ esac;\r
+END eff_mestrn;\r
+ \r
+UNIT eff_mestrn_rep:procedure(num:integer);\r
+BEGIN\r
+ call color(0);\r
+ case num\r
+ when 1:\r
+ call move(435,9);\r
+ call outstring("le train quai 1 REPART");\r
+ when 2:\r
+ call move(435,31);\r
+ call outstring("le train quai 2 REPART");\r
+ when 3:\r
+ call move(435,52);\r
+ call outstring("le train quai 3 REPART");\r
+ when 4:\r
+ call move(435,73);\r
+ call outstring("le train quai 4 REPART");\r
+ \r
+ esac;\r
+END eff_mestrn_rep;\r
+ \r
+(* PROCEDURE DE TRACAGE DES TRAINS *)\r
+ \r
+ UNIT DESSINE_TRAIN : procedure(num,deplacement :integer);\r
+ VAR wdepl,wbdepl:integer;\r
+ BEGIN\r
+ wdepl:=deplacement+5;\r
+ wbdepl:=deplacement+100;\r
+ if wdepl >=632 then wdepl:=632; fi;\r
+ if wbdepl>=632 then wbdepl:=632; fi;\r
+ \r
+ case num\r
+ when 1:\r
+ call color(9);\r
+ call rectangle_double(wdepl,179,wbdepl,193);\r
+ when 2:\r
+ call color(10);\r
+ call rectangle_double(wdepl,229,wbdepl,243);\r
+ when 3:\r
+ call color(11);\r
+ call rectangle_double(wdepl,279,wbdepl,293);\r
+ when 4:\r
+ call color(12);\r
+ call rectangle_double(wdepl,329,wbdepl,343);\r
+ esac;\r
+ END DESSINE_TRAIN;\r
+ \r
+ \r
+UNIT EFFACE_TRAIN : iiuwgraph procedure(num,deplacement :integer);\r
+ VAR wdepl,wbdepl :integer;\r
+BEGIN\r
+ wdepl:=deplacement+5;\r
+ wbdepl:=deplacement+100;\r
+ if wdepl >=632 then wdepl:=632; fi;\r
+ if wbdepl>=632 then wbdepl:=632 fi;\r
+ call color(0);\r
+ case num\r
+ when 1:\r
+ call rectangle_double(wdepl,179,wbdepl,193);\r
+ when 2:\r
+ call rectangle_double(wdepl,229,wbdepl,243);\r
+ when 3:\r
+ call rectangle_double(wdepl,279,wbdepl,293);\r
+ when 4:\r
+ call rectangle_double(wdepl,329,wbdepl,343);\r
+ esac;\r
+END EFFACE_TRAIN;\r
+ \r
+UNIT arrive_TRAIN:procedure(num:integer);\r
+ VAR indice,temp:integer;\r
+BEGIN\r
+ call mes_train(num);\r
+ for indice:=0 to 100 do\r
+ call DESSINE_TRAIN(num,indice);\r
+ call EFFACE_TRAIN(num,indice);\r
+ od;\r
+ call DESSINE_TRAIN(num,indice);\r
+END arrive_TRAIN;\r
+ \r
+UNIT REPART_TRAIN:procedure(num:integer);\r
+ VAR indice,temp:integer;\r
+BEGIN\r
+ call eff_mestrn(num);\r
+ call mes_train_rep(num);\r
+ for indice:=100 to 636 do\r
+ call DESSINE_TRAIN(num,indice);\r
+ call EFFACE_TRAIN(num,indice);\r
+ od;\r
+ call eff_mestrn_rep(num);\r
+END REPART_TRAIN;\r
+ \r
+(* PROCEDURE DE TRACAGE DU TABLEAU DES ARRIVEES *)\r
+ \r
+UNIT tableau : iiuwgraph procedure;\r
+BEGIN\r
+ call color(15);\r
+ call rectangle(350,3,635,86);\r
+ call rectangle(410,5,633,19);\r
+ call rectangle(410,28,633,42);\r
+ call rectangle(410,49,633,63);\r
+ call rectangle(410,70,633,84);\r
+ \r
+ (*texte tableau*)\r
+ call color(9);\r
+ call move(354,9);\r
+ call outstring("Quai 1");\r
+ call move(354,31);\r
+ call color(10);\r
+ call outstring("Quai 2");\r
+ call move(354,52);\r
+ call color(11);\r
+ call outstring("Quai 3");\r
+ call move(354,73);\r
+ call color(12);\r
+ call outstring("Quai 4");\r
+ \r
+END tableau;\r
+ \r
+(* PROCEDURE DE TRACAGE DES VOYAGEURS *)\r
+ \r
+UNIT VOYAGEUR:iiuwgraph procedure(x,y:integer);\r
+BEGIN\r
+ call move(x,y);\r
+ call draw(x,y+6);\r
+ call draw(x-2,y+10);\r
+ call move(x,y+6);\r
+ call draw(x+2,y+10);\r
+ call move(x-2,y+2);\r
+ call draw(x+2,y+2);\r
+ call move(x-2,y+2);\r
+ call draw(x-4,y+4);\r
+ call move(x+2,y+2);\r
+ call draw(x+4,y+4)\r
+END;\r
+ \r
+UNIT affiche_VOYAGEUR:iiuwgraph procedure(x,y:integer);\r
+BEGIN\r
+ call color(14);\r
+ call VOYAGEUR(x,y);\r
+END affiche_VOYAGEUR;\r
+ \r
+UNIT EFFACE_VOYAGEUR:iiuwgraph procedure(x,y:integer);\r
+BEGIN\r
+ call color(0);\r
+ call VOYAGEUR(x,y);\r
+END EFFACE_VOYAGEUR;\r
+ \r
+(* PROCEDURE D AFFICHAGE DE LA GARE *)\r
+ \r
+UNIT gar:iiuwgraph procedure;\r
+BEGIN\r
+ call color(15);\r
+ call attend(400);\r
+ call rectangle_double(0,0,639,349);\r
+ call caisse;\r
+ call voie;\r
+ call tableau;\r
+ call composteuse;\r
+END gar;\r
+ \r
+(* PROCEDURE DE TRACAGE DU COMPOSTEUR *)\r
+ \r
+UNIT composteuse : iiuwgraph procedure;\r
+BEGIN\r
+ call color(7);\r
+ call move(3,125);\r
+ call draw(460,125);\r
+ call move(3,126);\r
+ call draw(460,126);\r
+ call rectangle(500,125,633,150);\r
+ call move(528,135);\r
+ call outstring("COMPOSTEUR");\r
+END composteuse;\r
+ \r
+UNIT PRIORITYQUEUE: CLASS;\r
+(* HEAP AS BINARY LINKED TREE WITH FATHER LINK*)\r
+ \r
+ UNIT QUEUEHEAD: CLASS;\r
+ (* HEAP ACCESING MODULE *)\r
+ VAR LAST,ROOT:NODE;\r
+ \r
+ UNIT MIN: FUNCTION: ELEM;\r
+ BEGIN\r
+ IF ROOT=/= NONE THEN RESULT:=ROOT.EL FI;\r
+ END MIN;\r
+ \r
+ UNIT INSERT: PROCEDURE(R:ELEM);\r
+ (* INSERTION INTO HEAP *)\r
+ VAR X,Z:NODE;\r
+ BEGIN\r
+ X:= R.LAB;\r
+ IF LAST=NONE THEN\r
+ ROOT:=X;\r
+ ROOT.LEFT,ROOT.RIGHT,LAST:=ROOT\r
+ ELSE\r
+ IF LAST.NS=0 THEN\r
+ LAST.NS:=1;\r
+ Z:=LAST.LEFT;\r
+ LAST.LEFT:=X;\r
+ X.UP:=LAST;\r
+ X.LEFT:=Z;\r
+ Z.RIGHT:=X;\r
+ ELSE\r
+ LAST.NS:=2;\r
+ Z:=LAST.RIGHT;\r
+ LAST.RIGHT:=X;\r
+ X.RIGHT:=Z;\r
+ X.UP:=LAST;\r
+ Z.LEFT:=X;\r
+ LAST.LEFT.RIGHT:=X;\r
+ X.LEFT:=LAST.LEFT;\r
+ LAST:=Z;\r
+ FI\r
+ FI;\r
+ CALL CORRECT(R,FALSE)\r
+ END INSERT;\r
+ \r
+ UNIT DELETE: PROCEDURE(R: ELEM);\r
+ VAR X,Y,Z:NODE;\r
+ BEGIN\r
+ X:=R.LAB;\r
+ Z:=LAST.LEFT;\r
+ IF LAST.NS =0 THEN\r
+ Y:= Z.UP;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:=Y;\r
+ LAST:=Y;\r
+ ELSE\r
+ Y:= Z.LEFT;\r
+ Y.RIGHT:= LAST;\r
+ LAST.LEFT:= Y;\r
+ FI;\r
+ Z.EL.LAB:=X;\r
+ X.EL:= Z.EL;\r
+ LAST.NS:= LAST.NS-1;\r
+ R.LAB:=Z;\r
+ Z.EL:=R;\r
+ IF X.LESS(X.UP) THEN CALL CORRECT(X.EL,FALSE)\r
+ ELSE CALL CORRECT(X.EL,TRUE) FI;\r
+ END DELETE;\r
+ \r
+ UNIT CORRECT: PROCEDURE(R:ELEM,DOWN:BOOLEAN);\r
+ (* CORRECTION OF THE HEAP WITH STRUCTURE BROKEN BY R *)\r
+ VAR X,Z:NODE,T:ELEM,FIN,LOG:BOOLEAN;\r
+ BEGIN\r
+ Z:=R.LAB;\r
+ IF DOWN THEN\r
+ WHILE NOT FIN DO\r
+ IF Z.NS =0 THEN FIN:=TRUE ELSE\r
+ IF Z.NS=1 THEN X:=Z.LEFT ELSE\r
+ IF Z.LEFT.LESS(Z.RIGHT) THEN X:=Z.LEFT ELSE X:=Z.RIGHT\r
+ FI; FI;\r
+ IF Z.LESS(X) THEN FIN:=TRUE ELSE\r
+ T:=X.EL;\r
+ X.EL:=Z.EL;\r
+ Z.EL:=T;\r
+ Z.EL.LAB:=Z;\r
+ X.EL.LAB:=X\r
+ FI; FI;\r
+ Z:=X;\r
+ OD\r
+ ELSE\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z); FI;\r
+ WHILE NOT LOG DO\r
+ T:=Z.EL;\r
+ Z.EL:=X.EL;\r
+ X.EL:=T;\r
+ X.EL.LAB:=X;\r
+ Z.EL.LAB:=Z;\r
+ Z:=X;\r
+ X:=Z.UP;\r
+ IF X=NONE THEN LOG:=TRUE ELSE LOG:=X.LESS(Z);\r
+ FI;\r
+ OD\r
+ FI;\r
+ END CORRECT;\r
+ \r
+ END QUEUEHEAD;\r
+ \r
+ UNIT NODE: CLASS (EL:ELEM);\r
+ (* ELEMENT OF THE HEAP *)\r
+ VAR LEFT,RIGHT,UP: NODE, NS:INTEGER;\r
+ UNIT LESS: FUNCTION(X:NODE): BOOLEAN;\r
+ BEGIN\r
+ IF X= NONE THEN RESULT:=FALSE\r
+ ELSE RESULT:=EL.LESS(X.EL) FI;\r
+ END LESS;\r
+ END NODE;\r
+ \r
+ UNIT ELEM: CLASS(PRIOR:REAL);\r
+ (* PREFIX OF INFORMATION TO BE STORED IN NODE *)\r
+ VAR LAB: NODE;\r
+ UNIT VIRTUAL LESS: FUNCTION(X:ELEM):BOOLEAN;\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= PRIOR< X.PRIOR FI;\r
+ END LESS;\r
+ BEGIN\r
+ LAB:= NEW NODE(THIS ELEM);\r
+ END ELEM;\r
+ \r
+END PRIORITYQUEUE;\r
+ \r
+UNIT SIMULATION: PRIORITYQUEUE CLASS;\r
+(* THE LANGUAGE FOR SIMULATION PURPOSES *)\r
+ \r
+ VAR CURR: SIMPROCESS, (*ACTIVE PROCESS *)\r
+ PQ:QUEUEHEAD, (* THE TIME AXIS *)\r
+ MAINPR: MAINPROGRAM;\r
+ \r
+ \r
+ UNIT SIMPROCESS: COROUTINE;\r
+ (* USER PROCESS PREFIX *)\r
+ VAR EVENT, (* ACTIVATION MOMENT NOTICE *)\r
+ EVENTAUX: EVENTNOTICE,\r
+ (* THIS IS FOR AVOIDING MANY NEW CALLS AS AN RESULT OF *)\r
+ (* SUBSEQUENT PASSIVATIONS AND ACTIVATIONS *)\r
+ FINISH: BOOLEAN;\r
+ \r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= FINISH;\r
+ END TERMINATED;\r
+ \r
+ UNIT EVTIME: FUNCTION: REAL;\r
+ (* TIME OF ACTIVATION *)\r
+ BEGIN\r
+ IF IDLE THEN CALL ERROR1;\r
+ FI;\r
+ RESULT:= EVENT.EVENTTIME;\r
+ END EVTIME;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ call outstring(" AN ATTEMPT TO ACCESS AN IDLE PROCESS TIME");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(MAIN);\r
+ call outstring(" AN ATTEMPT TO ACCESS A TERMINATED PROCESS TIME");\r
+ END ERROR2;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ FINISH:=TRUE;\r
+ CALL PASSIVATE;\r
+ CALL ERROR2;\r
+ END SIMPROCESS;\r
+ \r
+ \r
+ UNIT EVENTNOTICE: ELEM CLASS;\r
+ (* A PROCESS ACTIVATION NOTICE TO BE PLACED ONTO THE TIME AXIS PQ *)\r
+ VAR EVENTTIME: REAL, PROC: SIMPROCESS;\r
+ \r
+ UNIT VIRTUAL LESS: FUNCTION(X: EVENTNOTICE):BOOLEAN;\r
+ (* OVERWRITE THE FORMER VERSION CONSIDERING EVENTTIME *)\r
+ BEGIN\r
+ IF X=NONE THEN RESULT:= FALSE ELSE\r
+ RESULT:= EVENTTIME< X.EVENTTIME OR\r
+ (EVENTTIME=X.EVENTTIME AND PRIOR< X.PRIOR); FI;\r
+ END LESS;\r
+ END EVENTNOTICE;\r
+ \r
+ UNIT MAINPROGRAM: SIMPROCESS CLASS;\r
+ (* IMPLEMENTING MASTER PROGRAM AS A PROCESS *)\r
+ BEGIN\r
+ DO ATTACH(MAIN) OD;\r
+ END MAINPROGRAM;\r
+ \r
+ UNIT TIME:FUNCTION:REAL;\r
+ (* CURRENT VALUE OF SIMULATION TIME *)\r
+ BEGIN\r
+ RESULT:=CURRENT.EVTIME\r
+ END TIME;\r
+ \r
+ UNIT CURRENT: FUNCTION: SIMPROCESS;\r
+ (* THE FIRST PROCESS ON THE TIME AXIS *)\r
+ BEGIN\r
+ RESULT:=CURR;\r
+ END CURRENT;\r
+ \r
+ UNIT SCHEDULE: PROCEDURE(P:SIMPROCESS,T:REAL);\r
+ BEGIN\r
+ IF T<TIME THEN T:= TIME FI;\r
+ IF P=CURRENT THEN CALL HOLD(T-TIME) ELSE\r
+ IF P.IDLE AND P.EVENTAUX=NONE THEN (* HAS NOT BEEN SCHEDULED YET*)\r
+ P.EVENT,P.EVENTAUX:= NEW EVENTNOTICE(RANDOM);\r
+ P.EVENT.PROC:= P;\r
+ ELSE\r
+ IF P.IDLE (* P HAS ALREADY BEEN SCHEDULED *) THEN\r
+ P.EVENT:= P.EVENTAUX;\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ ELSE\r
+ (* NEW SCHEDULING *)\r
+ P.EVENT.PRIOR:=RANDOM;\r
+ CALL PQ.DELETE(P.EVENT)\r
+ FI; FI;\r
+ P.EVENT.EVENTTIME:= T;\r
+ CALL PQ.INSERT(P.EVENT) FI;\r
+ END SCHEDULE;\r
+ \r
+ UNIT HOLD:PROCEDURE(T:REAL);\r
+ (* MOVE THE ACTIVE PROCESS T MINUTES BACK ALONG PQ *)\r
+ (* REDEFINE PRIOR *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF T<0 THEN T:=0; FI;\r
+ CURRENT.EVENT.EVENTTIME:=TIME+T;\r
+ CALL PQ.INSERT(CURRENT.EVENT);\r
+ CALL CHOICEPROCESS;\r
+ END HOLD;\r
+ \r
+ UNIT PASSIVATE: PROCEDURE;\r
+ (* REMOVE THE ACTVE PROCESS FROM PQ AND ACTIVATE THE NEXT ONE *)\r
+ BEGIN\r
+ CALL PQ.DELETE(CURRENT.EVENT);\r
+ CURRENT.EVENT:=NONE;\r
+ CALL CHOICEPROCESS\r
+ END PASSIVATE;\r
+ \r
+ UNIT RUN: PROCEDURE(P:SIMPROCESS);\r
+ (* ACTIVATE P IMMEDIATELY AND DELAY THE FORMER FIRST PROCESS BY REDEFINING*)\r
+ (* PRIOR *)\r
+ BEGIN\r
+ CURRENT.EVENT.PRIOR:=RANDOM;\r
+ IF NOT P.IDLE THEN\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ CALL PQ.CORRECT(P.EVENT,FALSE)\r
+ ELSE\r
+ IF P.EVENTAUX=NONE THEN\r
+ P.EVENT,P.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT)\r
+ ELSE\r
+ P.EVENT:=P.EVENTAUX;\r
+ P.EVENT.PRIOR:=0;\r
+ P.EVENT.EVENTTIME:=TIME;\r
+ P.EVENT.PROC:=P;\r
+ CALL PQ.INSERT(P.EVENT);\r
+ FI;FI;\r
+ CALL CHOICEPROCESS;\r
+ END RUN;\r
+ \r
+ UNIT CANCEL:PROCEDURE(P: SIMPROCESS);\r
+ (* REMOVE PROCESS P FROM PQ AND CONTINUE SIMULATION *)\r
+ BEGIN\r
+ IF P= CURRENT THEN CALL PASSIVATE ELSE\r
+ CALL PQ.DELETE(P.EVENT);\r
+ P.EVENT:=NONE; FI;\r
+ END CANCEL;\r
+ \r
+ UNIT CHOICEPROCESS:PROCEDURE;\r
+ (* CHOISIR THE FIRST PROCESS FROM PQ TO BE ACTIVATED *)\r
+ VAR P:SIMPROCESS;\r
+ BEGIN\r
+ P:=CURR;\r
+ CURR:= PQ.MIN QUA EVENTNOTICE.PROC;\r
+ IF CURR=NONE THEN\r
+ WRITE(" ERROR IN THE HEAP"); WRITELN;\r
+ ATTACH(MAIN);\r
+ ELSE ATTACH(CURR); FI;\r
+ END CHOICEPROCESS;\r
+ \r
+BEGIN\r
+ PQ:=NEW QUEUEHEAD; (* SIMULATION TIME AXIS*)\r
+ CURR,MAINPR:=NEW MAINPROGRAM;\r
+ MAINPR.EVENT,MAINPR.EVENTAUX:=NEW EVENTNOTICE(0);\r
+ MAINPR.EVENT.EVENTTIME:=0;\r
+ MAINPR.EVENT.PROC:=MAINPR;\r
+ CALL PQ.INSERT(MAINPR.EVENT);\r
+ (* THE FIRST PROCESS TO BE ACTIVATED IS MAIN PROGRAM *)\r
+ INNER;\r
+ PQ:=NONE;\r
+END SIMULATION;\r
+ \r
+UNIT LISTS:SIMULATION CLASS;\r
+ (* WE WISH TO USE LISTS FOR QUEUEING PROCESSES DURING SIMULATION*)\r
+ \r
+ UNIT LINKAGE:CLASS;\r
+ (*WE WILL USE TWO WAY LISTS *)\r
+ VAR SUC1,PRED1:LINKAGE;\r
+ END LINKAGE;\r
+ \r
+ UNIT HEAD:LINKAGE CLASS;\r
+ (* EACH LIST WILL HAVE ONE ELEMENT ESTABLISHED *)\r
+ UNIT FIRST:FUNCTION:LINK;\r
+ BEGIN\r
+ IF SUC1 IN LINK THEN RESULT:=SUC1\r
+ ELSE RESULT:=NONE\r
+ FI;\r
+ END FIRST;\r
+ \r
+ UNIT EMPTY:FUNCTION:BOOLEAN;\r
+ BEGIN\r
+ RESULT:=SUC1=THIS LINKAGE;\r
+ END EMPTY;\r
+ BEGIN\r
+ SUC1,PRED1:=THIS LINKAGE;\r
+ END HEAD;\r
+ \r
+ UNIT LINK:LINKAGE CLASS;\r
+ (* ORDINARY LIST ELEMENT PREFIX *)\r
+ UNIT OUT:PROCEDURE;\r
+ BEGIN\r
+ IF SUC1=/=NONE THEN\r
+ SUC1.PRED1:=PRED1;\r
+ PRED1.SUC1:=SUC1;\r
+ SUC1,PRED1:=NONE;\r
+ FI;\r
+ END OUT;\r
+ UNIT INTO:PROCEDURE(S:HEAD);\r
+ BEGIN\r
+ CALL OUT;\r
+ IF S=/= NONE THEN\r
+ IF S.SUC1=/=NONE THEN\r
+ SUC1:=S;\r
+ PRED1:=S.PRED1;\r
+ PRED1.SUC1:=THIS LINKAGE;\r
+ S.PRED1:=THIS LINKAGE;\r
+ FI;\r
+ FI;\r
+ END INTO;\r
+ END LINK;\r
+ \r
+ UNIT ELEM:LINK CLASS(SPROCESS:SIMPROCESS);\r
+ (* USER DEFINED PROCESS WILL BE JOINED INTO LISTS *)\r
+ END ELEM;\r
+ \r
+END LISTS;\r
+ \r
+UNIT GARE:LISTS CLASS; (*AN GARE*)\r
+ \r
+ UNIT TILL:SIMPROCESS CLASS(QUEUE:HEAD);\r
+ (* GUICHET WITH VOYAGEURS QUEUEING UP *)\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* SERVICE OF THIS GUICHET WILL BE PRECISED LATER *)\r
+ END SERVICE;\r
+ \r
+ VAR CSTM:VOYAGEUR, (*THE VOYAGEUR BEING SERVED*)\r
+ REST,PAUSE:REAL,\r
+ COMPTEUR : INTEGER;\r
+ \r
+ BEGIN\r
+ PAUSE:=TIME;\r
+ DO\r
+ REST:=REST+TIME-PAUSE;\r
+ WHILE NOT QUEUE.EMPTY DO\r
+ CSTM:=QUEUE.FIRST QUA ELEM.SPROCESS;\r
+ CALL SERVICE;\r
+ OD;\r
+ PAUSE:=TIME;\r
+ CALL PASSIVATE;\r
+ OD;\r
+ END TILL;\r
+ \r
+ UNIT VOYAGEUR:SIMPROCESS CLASS;\r
+ \r
+ VAR ELLIST:ELEM, K:INTEGER,NUMGUICHET:INTEGER;\r
+ UNIT ARRIVAL:PROCEDURE(S:TILL);\r
+ (* le VOYAGEUR va a un guichet ou au composteur *)\r
+ BEGIN\r
+ IF S=/=NONE THEN\r
+ ELLIST:=NEW ELEM(THIS VOYAGEUR);\r
+ call ELLIST.INTO(S.QUEUE); (* mit dans la file d'attente*)\r
+ case NUMGUICHET\r
+ when 1: call affiche_VOYAGEUR(90+S.COMPTEUR*10,10);\r
+ when 2: call affiche_VOYAGEUR(90+S.COMPTEUR*10,33);\r
+ when 3: call affiche_VOYAGEUR(90+S.COMPTEUR*10,54);\r
+ when 4: call affiche_VOYAGEUR(90+S.COMPTEUR*10,75);\r
+ when 5: call affiche_VOYAGEUR(500-S.COMPTEUR*10,110);\r
+ esac;\r
+ S.COMPTEUR:=S.COMPTEUR+1;\r
+ IF S.IDLE THEN CALL SCHEDULE(S,TIME); FI;\r
+ call PASSIVATE;\r
+ FI;\r
+ END ARRIVAL;\r
+ END VOYAGEUR;\r
+ \r
+ UNIT TRAIN:SIMPROCESS CLASS;\r
+ \r
+ UNIT ARRIVAL:PROCEDURE(inout QUAI:integer);\r
+ (* le train arrive en gare, prend les voyageurs et REPART*)\r
+ VAR CLI : VOYAGEUR,TEMP:INTEGER;\r
+ BEGIN\r
+ IF (NOT TAB_STOPQ(QUAI)) THEN\r
+ TAB_STOPQ(QUAI):=TRUE; \r
+ TEMP:=RANDOM*10;\r
+ call HOLD(TEMP); \r
+ call arrive_TRAIN(QUAI);\r
+ if(TEMP>0) THEN\r
+ (* DEPLACER TRAIN JUSQU'A DEBUT FILE *)\r
+ (* CHARGER VOYAGEUR*)\r
+ call attend(20);\r
+ write(chr(07));\r
+ \r
+ CASE QUAI\r
+ WHEN 1 :(* QUAI 1 *)\r
+ while(CPTQU1>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU1*20,155);\r
+ CPTQU1:=CPTQU1-1;\r
+ call HOLD(RANDOM * 10);\r
+ od;\r
+ CPTQU1:=0;\r
+ WHEN 2 :(* QUAI 2 *)\r
+ while(CPTQU2>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU2*20,205);\r
+ CPTQU2:=CPTQU2-1;\r
+ call HOLD(RANDOM * 11);\r
+ od;\r
+ CPTQU2:=0;\r
+ WHEN 3 :(* QUAI 3 *)\r
+ while(CPTQU3>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU3*20,255);\r
+ CPTQU3:=CPTQU3-1;\r
+ call HOLD(RANDOM * 12);\r
+ od;\r
+ CPTQU3:=0;\r
+ WHEN 4 :(* QUAI 4 *)\r
+ while(CPTQU4>=0) do\r
+ call EFFACE_VOYAGEUR(100+CPTQU4*20,305);\r
+ CPTQU4:=CPTQU4-1;\r
+ call HOLD(RANDOM * 13);\r
+ od;\r
+ CPTQU4:=0;\r
+ ESAC;\r
+ write(chr(07));\r
+ write(chr(07)); \r
+ fi;\r
+ call REPART_TRAIN(QUAI);\r
+ TAB_STOPQ(QUAI) := FALSE;\r
+ call HOLD(10); \r
+ (* le train sort de la gare *)\r
+ fi;\r
+ END ARRIVAL;\r
+ END TRAIN;\r
+ \r
+END GARE;\r
+ \r
+UNIT GAREDEPARTMENT:GARE CLASS;\r
+ \r
+ UNIT COMPOSTEUR:TILL CLASS;\r
+ VAR SERVICETIME:REAL;\r
+ VAR nbvoyageurQ1,nbvoyageurQ2,nbvoyageurQ3,nbvoyageurQ4 : integer;\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* represente le service dispense par le composteur *)\r
+ BEGIN\r
+ CALL CSTM.ELLIST.OUT; (* un voyageur a composte son billet\r
+ et sort de la file du composteur*)\r
+ call EFFACE_VOYAGEUR(500-COMPTEUR*10,110);\r
+ COMPTEUR:= COMPTEUR-1;\r
+ SERVICETIME:=RANDOM*4+nb4;\r
+ CALL HOLD(SERVICETIME);\r
+ (* on attends le temps passe pour composter le billet *)\r
+ CSTM.NUMGUICHET := RANDOM * 4 + 1; (* 4 = nombre de quais *)\r
+ while (TAB_STOPQ(CSTM.NUMGUICHET) ) do\r
+ call HOLD(1);\r
+ CSTM.NUMGUICHET := RANDOM *4 +1;\r
+ od;\r
+ (* le voyageur va sur le bon quai *)\r
+ CASE CSTM.NUMGUICHET\r
+ when 1 : (* QUAI 1 *)\r
+ nbvoyageurQ1 := nbvoyageurQ1 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU1*20,155);\r
+ CPTQU1:=CPTQU1+1;\r
+ when 2 : (* QUAI 2 *)\r
+ nbvoyageurQ2 := nbvoyageurQ2 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU2*20,205);\r
+ CPTQU2:=CPTQU2+1;\r
+ when 3 :(* QUAI 3 *)\r
+ nbvoyageurQ3 := nbvoyageurQ3 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU3*20,255);\r
+ CPTQU3:=CPTQU3+1;\r
+ when 4 :(* QUAI 4*)\r
+ nbvoyageurQ4 := nbvoyageurQ4 + 1;\r
+ call affiche_VOYAGEUR(100+CPTQU4*20,305);\r
+ CPTQU4:=CPTQU4+1;\r
+ ESAC;\r
+ END SERVICE;\r
+ END COMPOSTEUR;\r
+ \r
+\r
+ UNIT GUICHET:TILL CLASS(NUMBER:INTEGER);\r
+ VAR SERVICETIME:REAL;\r
+ UNIT VIRTUAL SERVICE:PROCEDURE;\r
+ (* service dispense au guichet de la gare*)\r
+ BEGIN\r
+ case CSTM.NUMGUICHET\r
+ when 1: call EFFACE_VOYAGEUR(90+COMPTEUR*10,10);\r
+ when 2: call EFFACE_VOYAGEUR(90+COMPTEUR*10,33);\r
+ when 3: call EFFACE_VOYAGEUR(90+COMPTEUR*10,54);\r
+ when 4: call EFFACE_VOYAGEUR(90+COMPTEUR*10,75);\r
+ esac;\r
+ CALL CSTM.ELLIST.OUT; (* sort de la file du guichet *)\r
+ COMPTEUR := COMPTEUR -1;\r
+ SERVICETIME:=RANDOM*4+10; (*augmente temps du guichet*)\r
+ CALL HOLD(SERVICETIME); \r
+ (* attend le temp du service au guichet *)\r
+ CSTM.NUMGUICHET:=5; (* 5 = COMPOSTEUR *)\r
+ CALL CSTM.ARRIVAL(COMPOSTBOX);\r
+ (* le voyageur va au composteur *)\r
+ END SERVICE;\r
+ END GUICHET;\r
+ UNIT GENERATORVOYAGEUR:SIMPROCESS CLASS(nb1,nb2 : integer);\r
+ (* VOYAGEURS GENERATION *)\r
+ VAR nbvoyageurs,wtime : integer;\r
+ BEGIN\r
+ DO\r
+ call move(500,100);\r
+ call color(12);\r
+ call outstring("TEMPS:");\r
+ call EFFACE_chiffre(550,100);\r
+ call color(12);\r
+ call ecrit_chiffre(TIME,550,100);\r
+ \r
+ call SCHEDULE(NEW GAREVOYAGEUR(RANDOM*100+1),TIME);\r
+ nbvoyageurs := nbvoyageurs+1;\r
+ (* temps d'attente entre la generation deux voyageurs *)\r
+ call HOLD(RANDOM * nb1);\r
+ \r
+ call move(500,100);\r
+ call color(12);\r
+ call outstring("TEMPS:");\r
+ call EFFACE_chiffre(550,100);\r
+ call color(12);\r
+ call ecrit_chiffre(TIME,550,100);\r
+ \r
+ call SCHEDULE(NEW GAREVOYAGEUR(RANDOM*100+1),TIME);\r
+ nbvoyageurs := nbvoyageurs+1;\r
+ (* temps d'attente entre la generation de deux voyageurs *)\r
+ call HOLD(RANDOM * nb2);\r
+ OD\r
+ END GENERATORVOYAGEUR;\r
+ \r
+ UNIT GENERATORTRAIN:SIMPROCESS CLASS(nb3 : integer,numquai :integer);\r
+ (* TRAIN GENERATION *)\r
+ VAR nbtrains,wtime: integer;\r
+ BEGIN\r
+ DO\r
+ call move(500,100);\r
+ call color(12);\r
+ call outstring("TEMPS:");\r
+ call EFFACE_chiffre(550,100);\r
+ call color(12);\r
+ call ecrit_chiffre(TIME,550,100);\r
+ \r
+ call SCHEDULE(NEW GARETRAIN(numquai),TIME);\r
+ nbtrains := nbtrains + 1;\r
+ (* temps d'attente entre la generation de deux trains*)\r
+ call HOLD(RANDOM * nb3);\r
+ OD\r
+ END GENERATORTRAIN;\r
+ \r
+\r
+ UNIT GAREVOYAGEUR:VOYAGEUR CLASS(NO:INTEGER);\r
+ VAR ARRIVALTIME,STAYTIME:REAL,CHOISIRGUICHET:INTEGER;\r
+ BEGIN\r
+ I:=I+1;\r
+ K:=I;\r
+ ARRIVALTIME:=TIME;\r
+ CHOISIRGUICHET:=RANDOM*nombreguichets +1;\r
+ NUMGUICHET := CHOISIRGUICHET;\r
+ (* un voyageur va a un guichet de la gare *)\r
+ CALL ARRIVAL(GUICHETS(CHOISIRGUICHET));\r
+ STAYTIME:=TIME-ARRIVALTIME;\r
+ END GAREVOYAGEUR;\r
+ \r
+ UNIT GARETRAIN:TRAIN CLASS(numquai : integer);\r
+ VAR ARRIVALTIME,STAYTIME:REAL;\r
+ BEGIN\r
+ ARRIVALTIME:=TIME;\r
+ (* un train arrive en gare sur un quai *)\r
+ CALL ARRIVAL(numquai);\r
+ STAYTIME:=TIME-ARRIVALTIME;\r
+ END GARETRAIN;\r
+ \r
+ VAR COMPOSTBOX:COMPOSTEUR,I:INTEGER,dur : integer;\r
+ VAR nombreguichets, nbvoyageurs, nbtrains :integer;\r
+ VAR GUICHETS:ARRAYOF GUICHET;\r
+ var nb1,nb2,nb3,nb4,billcomp1,billcomp2,billcomp3,pourcent : integer; \r
+ \r
+\r
+BEGIN (* NEW GARE DEPARTMENT GENERATION *)\r
+ call param(dur,affluence);\r
+ call color(14);\r
+ call move(3,130);\r
+ call outstring(" La duree est de : ");call color(15);\r
+ case dur\r
+ when 10:call outstring("1 min");\r
+ when 20:call outstring("2 min");\r
+ when 30:call outstring("3 min");\r
+ when 40:call outstring("4 min");\r
+ when 50:call outstring("5 min");\r
+ when 60:call outstring("6 min");\r
+ when 70:call outstring("7 min");\r
+ when 80:call outstring("8 min");\r
+ when 90:call outstring("9 min");\r
+ esac;\r
+ call color(14);\r
+ call outstring(" et le type est : ");call color(15);\r
+ case affluence\r
+ when 1:call outstring("Nuit");\r
+ when 2:call outstring("Jour");\r
+ when 3:call outstring("Dense");\r
+ esac;\r
+\r
+ case affluence\r
+ when 1 :nb1:=40; nb2:=35;\r
+ nb3:= 1200;nb4:=2;nombreguichets := 2;\r
+ call move(100,52);\r
+ call color(11);\r
+ call outstring("FERMEE");\r
+ call move(100,73);\r
+ call color(12);\r
+ call outstring("FERMEE");\r
+ \r
+ when 2 :nb1:=26; nb2:=27; nb3:= 400;nb4:=5;\r
+ nombreguichets := 3;\r
+ call move(100,73);\r
+ call color(12);\r
+ call outstring("FERMEE");\r
+ \r
+ when 3 :nb1:=10; nb2:=12; nb3:= 400;nb4:=5;\r
+ nombreguichets := 4;\r
+ esac;\r
+ COMPOSTBOX:=NEW COMPOSTEUR(NEW HEAD); (* creation du composteur *)\r
+ ARRAY GUICHETS DIM(1:nombreguichets); (* WE DEAL WITH 5 TELLES *)\r
+ (* creation des guichets *)\r
+ FOR I:=1 TO nombreguichets DO\r
+ GUICHETS(I):=NEW GUICHET(NEW HEAD,I);\r
+ OD;\r
+ I:=0;\r
+\r
+END GAREDEPARTMENT;\r
+\r
+ var gauche,droit,centre,rep,rep1,choix:boolean,\r
+ affluence,i : integer;\r
+ VAR CPTQU1,CPTQU2,CPTQU3,CPTQU4 : integer;\r
+ VAR TAB_STOPQ : ARRAYOF boolean;\r
+ \r
+ \r
+ \r
+ BEGIN (* OF PROGRAM *)\r
+ ARRAY TAB_STOPQ DIM(1:4);\r
+ TAB_STOPQ(1):= false;\r
+ TAB_STOPQ(2):= false;\r
+ TAB_STOPQ(3):= false;\r
+ TAB_STOPQ(4):= false;\r
+ i:= exec(unpack("new-1.exe"));\r
+ droit:=FALSE;\r
+ centre:=FALSE;\r
+ gauche:=FALSE;\r
+ call HPAGE(0,0,0);\r
+ call HPAGE(0,639,639);\r
+ call GRON(0);\r
+ choix:=TRUE;\r
+ call presentation;\r
+ while (choix) do \r
+ PREF GAREDEPARTMENT BLOCK\r
+ VAR generatecli : GENERATORVOYAGEUR; \r
+ VAR generatetr1, generatetr2, generatetr3,generatetr4: GENERATORTRAIN; \r
+ BEGIN\r
+ call gar;\r
+ (* creation du generateur de voyageurs *)\r
+ generatecli := NEW GENERATORVOYAGEUR(nb1,nb2);\r
+ call SCHEDULE(generatecli,TIME);\r
+ (* creation du generateur de trains pour le quai 1*)\r
+ generatetr1 := NEW GENERATORTRAIN(nb3,1);\r
+ call SCHEDULE(generatetr1,TIME);\r
+ (* creation du generateur de trains pour le quai 2 *)\r
+ generatetr2 := NEW GENERATORTRAIN(nb3,2);\r
+ call SCHEDULE(generatetr2,TIME);\r
+ (* creation du generateur de trains pour le quai 3 *)\r
+ generatetr3 := NEW GENERATORTRAIN(nb3,3);\r
+ call SCHEDULE(generatetr3,TIME);\r
+ (* creation du generateur de trains pour le quai 4 *)\r
+ generatetr4 := NEW GENERATORTRAIN(nb3,4);\r
+ call SCHEDULE(generatetr4,TIME);\r
+ \r
+ call HOLD (dur * 10);\r
+ \r
+ rep1:=msgbox("Voulez-vous les statistiques sur la simulation ?",48,14,100,200);\r
+ if (rep1) then\r
+ call cls;\r
+ call move(150,10);\r
+ call color(13);\r
+ call outstring("CHER UTILISATEUR VOICI LES STATISTIQUES !!!");\r
+ call move(120,40);\r
+ call color(3);\r
+ call outstring("le nombre total de voyageurs est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(generatecli.nbvoyageurs,420,40);\r
+ call move(20,70);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 1 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr1.nbtrains,420,70);\r
+ call move(20,90);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 2 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr2.nbtrains,420,90);\r
+ call move(20,110);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 3 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr3.nbtrains,420,110);\r
+ call move(20,130);\r
+ call color(3);\r
+ call outstring("le nombre total de trains sur le quai 4 est de");\r
+ call color(11);\r
+ call ecrit_chiffre(generatetr4.nbtrains,420,130);\r
+ call move(120,170);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai1 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ1,420,170);\r
+ call move(120,190);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai2 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ2,420,190);\r
+ call move(120,210);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai3 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ3,420,210);\r
+ call move(120,230);\r
+ call color(3);\r
+ call outstring("total voyageurs du quai4 est de ");\r
+ call color(11);\r
+ call ecrit_chiffre(COMPOSTBOX.nbvoyageurQ4,420,230);\r
+ call move(60,280);\r
+ call color(3);\r
+ call outstring("total voyageurs ayant compost\82s leur billet : ");\r
+ call color(11);\r
+ billcomp1 := COMPOSTBOX.nbvoyageurQ1+COMPOSTBOX.nbvoyageurQ2;\r
+ billcomp2 := COMPOSTBOX.nbvoyageurQ3+COMPOSTBOX.nbvoyageurQ4;\r
+ billcomp3:=billcomp1+billcomp2;\r
+ \r
+ call ecrit_chiffre(billcomp3,420,280);\r
+ pourcent:=100-((100*billcomp3)DIV generatecli.nbvoyageurs);\r
+ IF (pourcent >= 30) THEN\r
+ call move(70,300);\r
+ call color(10);\r
+ call outstring(" REMARQUE : Il serait utile de rajouter un composteur");\r
+ FI;\r
+ call PAUSE;\r
+ \r
+ fi;\r
+ choix:=msgbox("VOULEZ-VOUS CONTINUER (O/N)?",30,14,200,175);\r
+ call cls;\r
+ TAB_STOPQ(1):= false;\r
+ TAB_STOPQ(2):= false;\r
+ TAB_STOPQ(3):= false;\r
+ TAB_STOPQ(4):= false;\r
+ \r
+ END;\r
+ od;\r
+ call color(14);\r
+ call move(65,150);\r
+ call outstring(" MERCI POUR L'UTILISATION DE CETTE SUPERBE APPLICATION");\r
+ call move(250,320);\r
+ call outstring("VEUILLEZ PATIENTER");\r
+ call attend_sortie;\r
+ call GROFF;\r
+ END;\r
+END gar;\r
+(****************************\r
+************************************************)\r
+ \r
--- /dev/null
+PROGRAM station;\r
+(*_________________________________________________________*)\r
+(* loglan station h+ *)\r
+(* hgen station *)\r
+(* egahint /m50000 station *)\r
+(*---------------------------------------------------------*)\r
+ \r
+(*----------------------------------------------------------*)\r
+(* CALSSE DEFINISSANT LES PROCEDURES DE GRAPHISME UTILISEES *)\r
+(*----------------------------------------------------------*)\r
+ UNIT graph : IIUWGRAPH CLASS;\r
+ CONST MAXx = 635,\r
+ MAXy = 348,\r
+ LETDIMY = 08, (* Hauteur lettre *)\r
+ LETDIMX = 8, (* Largeur lettre *)\r
+ Fgauche = -75, (* Fleche gauche *)\r
+ Fdroite = -77, (* Fleche droite *)\r
+ ESC = 27, (* Touche escape *)\r
+ RETOUR = 13, (* Touche return *)\r
+ BKSPACE = 8, (* Touche Backspace *)\r
+ MOINS = 45; (* Touche signe moins *)\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant d'utiliser le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ UNIT initgraph : PROCEDURE;\r
+ BEGIN CALL GRON(1); END initgraph;\r
+ \r
+ (*---------------------------------------------------*)\r
+ (* PROCEDURE permettant de fermer le mode GRAPHIQUE *)\r
+ (*---------------------------------------------------*)\r
+ UNIT closegraph : PROCEDURE;\r
+ BEGIN CALL GROFF; END closegraph;\r
+ \r
+ \r
+ (*-----------------------------------------------------------------*)\r
+ (* AFFICHAGE en (x,y) d'un RECTANGLE de longueur l et de hauteur h *)\r
+ (*-----------------------------------------------------------------*)\r
+ UNIT rectangle : PROCEDURE(x,y,l,h : INTEGER);\r
+ BEGIN\r
+ CALL MOVE (x,y);\r
+ CALL DRAW (x+l,y);\r
+ CALL DRAW(x+l,y+h);\r
+ CALL DRAW(x,y+h);\r
+ CALL DRAW(x,y);\r
+ END rectangle;\r
+ \r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* ECRITURE d'une CHAINE de caracteres sur l'ecran graphique en (x,y) *)\r
+ (*--------------------------------------------------------------------*)\r
+ UNIT ecrit_text : PROCEDURE(x,y : INTEGER;str : string);\r
+ VAR ch : ARRAYOF CHARACTER,\r
+ lg,i : INTEGER;\r
+ BEGIN\r
+ call color(14);\r
+ CALL move (x,y);\r
+ ch := UNPACK(str);\r
+ lg := UPPER(ch) - LOWER(ch) + 1;\r
+ FOR i := 1 TO lg DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(ORD(ch(i)));\r
+ OD;\r
+ call color(15);\r
+ END;\r
+ \r
+ (*---------------------------------*)\r
+ (* LECTURE d'une touche au clavier *)\r
+ (*---------------------------------*)\r
+ UNIT inchar : FUNCTION : INTEGER;\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ DO\r
+ i := INKEY;\r
+ IF i =/= 0 THEN EXIT;\r
+ FI;\r
+ OD;\r
+ result := i;\r
+ END inchar;\r
+ \r
+ (*-------------------------------------------------------------------*)\r
+ (* LECTURE d'un ENTIER au clavier et AFFICHAGE sur l'ecran graphique *)\r
+ (*-------------------------------------------------------------------*)\r
+ UNIT lire_entier: FUNCTION(x,y:INTEGER;OUTPUT valeur :INTEGER): BOOLEAN;\r
+ VAR nbchiffre,key,i,cas : INTEGER,\r
+ negatif : BOOLEAN;\r
+ BEGIN\r
+ CALL MOVE(x,y);\r
+ FOR i := 1 TO 6 DO\r
+ CALL HASCII(0);\r
+ CALL MOVE(INXPOS+8,INYPOS);\r
+ OD;\r
+ CALL MOVE(x,y);\r
+ DO\r
+ DO (* Lecture de la touche *)\r
+ key := inchar;\r
+ cas := key;\r
+ IF (key >= 48 AND key <= 57)\r
+ THEN cas := 1;\r
+ EXIT;\r
+ FI;\r
+ IF (key = RETOUR) OR (key = ESC) OR (key = MOINS) OR (key = BKSPACE)\r
+ THEN EXIT;\r
+ FI;\r
+ OD;\r
+ CASE cas\r
+ WHEN 1 : (* Saisie d'un chiffre *)\r
+ IF (nbchiffre < 5 )\r
+ THEN valeur := valeur*10 + key - 48;\r
+ IF x = INXPOS\r
+ THEN negatif := FALSE;\r
+ FI;\r
+ CALL HASCII(0);\r
+ CALL HASCII(key);\r
+ nbchiffre := nbchiffre + 1;\r
+ ELSE valeur :=(valeur DIV 10)*10 + key - 48;\r
+ CALL MOVE(inxpos-8,y);\r
+ CALL HASCII(0);\r
+ CALL HASCII(key);\r
+ FI;\r
+ WHEN MOINS : (* Saisie du signe moins *)\r
+ IF x = INXPOS\r
+ THEN negatif := TRUE;\r
+ CALL HASCII(0);\r
+ CALL HASCII(MOINS);\r
+ FI;\r
+ WHEN RETOUR : (* Validation du chiffre eventuellement entre *)\r
+ IF negatif\r
+ THEN valeur := 0 - valeur;\r
+ FI;\r
+ IF nbchiffre > 0\r
+ THEN result := true;\r
+ FI;\r
+ RETURN;\r
+ WHEN ESC : (* Abandon de la saisie *)\r
+ RETURN;\r
+ WHEN BKSPACE : (* Saisie de la touche Backspace *)\r
+ IF nbchiffre > 0\r
+ THEN valeur := valeur DIV 10;\r
+ CALL MOVE(INXPOS-8,y);\r
+ CALL HASCII(0);\r
+ nbchiffre := nbchiffre -1\r
+ ELSE IF negatif\r
+ THEN negatif := FALSE;\r
+ CALL MOVE(inxpos-8,y);\r
+ CALL HASCII(0);\r
+ FI;\r
+ FI;\r
+ ESAC;\r
+ OD;\r
+ END lire_entier;\r
+ \r
+ (*---------------------------------------------------------------------*)\r
+ (* ECRITURE d'un ENTIER sur l'\82cran graphique au coordonn\82es courantes *)\r
+ (*---------------------------------------------------------------------*)\r
+ UNIT ecrit_entier : PROCEDURE (x : INTEGER);\r
+ VAR val,i : INTEGER,\r
+ strx : ARRAYOF CHARACTER;\r
+ BEGIN\r
+ ARRAY strx DIM(1:7);\r
+ i := 7;\r
+ val := ABS(x);\r
+ DO\r
+ strx(i) := chr(48+(val MOD 10));\r
+ val := val DIV 10;\r
+ IF (val = 0) THEN EXIT; FI;\r
+ i := i - 1;\r
+ OD;\r
+ IF x < 0\r
+ THEN i := i - 1;\r
+ strx(i) := chr(MOINS);\r
+ FI;\r
+ WHILE i <= 7 DO\r
+ CALL HASCII(0);\r
+ CALL HASCII(ORD(strx(i)));\r
+ i := i + 1;\r
+ OD;\r
+ END ecrit_entier;\r
+ \r
+ (*-------------------------------------------------------*)\r
+ (* PROCEDURE d'ECRITURE de l'HEURE sur l'\82cran graphique *)\r
+ (*-------------------------------------------------------*)\r
+ UNIT ecrit_heure : PROCEDURE(posx,posy : INTEGER,time : REAL);\r
+ VAR h,m,s : INTEGER;\r
+ BEGIN\r
+ h := ENTIER(time / 3600.0);\r
+ m := ENTIER(time - ENTIER(time/3600)*3600) DIV 60;\r
+ s := ENTIER(time - ENTIER(time/3600)*3600) MOD 60;\r
+ IF ( h < 10)\r
+ THEN CALL ecrit_text(posx,posy,"0");\r
+ ELSE CALL MOVE(posx,posy);\r
+ FI;\r
+ CALL ecrit_entier(h);\r
+ CALL ecrit_text(INXPOS,INYPOS,":");\r
+ IF ( m < 10) THEN CALL ecrit_text(INXPOS,INYPOS,"0"); FI;\r
+ CALL ecrit_entier(m);\r
+ CALL ecrit_text(INXPOS,INYPOS,":");\r
+ IF ( s < 10) THEN CALL ecrit_text(INXPOS,INYPOS,"0"); FI;\r
+ CALL ecrit_entier(s);\r
+ END ecrit_heure;\r
+ \r
+ END graph;\r
+ \r
+ \r
+(*----------------------------------------------------------*)\r
+(* IMPLEMENTATION d'une QUEUE DE PRIORITE sous forme de TAS *)\r
+(*----------------------------------------------------------*)\r
+UNIT priorityqueue : graph CLASS;\r
+ \r
+ (*----------------------------*)\r
+ (* CLASSE repr\82sentant le TAS *)\r
+ (*----------------------------*)\r
+ UNIT queuehead: CLASS;\r
+ VAR last,root:node;\r
+ \r
+ (*---------------------------------------------*)\r
+ (* FONCTION renvoyant l'ELEMENT MINIMUM du TAS *)\r
+ (*---------------------------------------------*)\r
+ UNIT min: FUNCTION: elem;\r
+ BEGIN\r
+ IF root=/= NONE THEN RESULT:=root.el FI;\r
+ END MIN;\r
+ \r
+ (*------------------------------------*)\r
+ (* INSERTION d'un element dans le TAS *)\r
+ (*------------------------------------*)\r
+ UNIT insert: PROCEDURE(r:elem);\r
+ VAR x,z:node;\r
+ BEGIN\r
+ x:= r.lab;\r
+ IF last=NONE\r
+ THEN root:=x;\r
+ root.left,root.right,last:=root\r
+ ELSE IF last.ns=0\r
+ THEN last.ns:=1;\r
+ z:=last.left;\r
+ last.left:=x;\r
+ x.up:=last;\r
+ x.left:=z;\r
+ z.right:=x;\r
+ ELSE last.ns:=2;\r
+ z:=last.right;\r
+ last.right:=x;\r
+ x.right:=z;\r
+ x.up:=last;\r
+ z.left:=x;\r
+ last.left.right:=x;\r
+ x.left:=last.left;\r
+ last:=z;\r
+ FI;\r
+ FI;\r
+ CALL correct(R,FALSE)\r
+ END insert;\r
+ \r
+ (*---------------------------------*)\r
+ (* SUPPRESSION d'un ELEMENT du TAS *)\r
+ (*---------------------------------*)\r
+ UNIT delete: PROCEDURE(r: elem);\r
+ VAR x,Y,z:node;\r
+ BEGIN\r
+ x:=r.lab;\r
+ z:=last.left;\r
+ IF last.ns =0\r
+ THEN Y:= z.up;\r
+ if y<>none then (*!!!!!!!!dopisalam !!!!!*)\r
+ Y.right:= last else root :=none fi;\r
+ last.left:=Y;\r
+ last:=Y;\r
+ ELSE Y:= z.left;\r
+ Y.right:= last;\r
+ last.left:= Y;\r
+ FI;\r
+ z.el.lab:=x;\r
+ x.el:= z.el;\r
+ last.ns:= last.ns-1;\r
+ r.lab:=z;\r
+ z.el:=R;\r
+ IF x.less(x.up)\r
+ THEN CALL correct(x.el,FALSE)\r
+ ELSE CALL correct(x.el,TRUE)\r
+ FI;\r
+ END delete;\r
+ \r
+ (*------------------------------------------------------------------------*)\r
+ (* CORRECTION-REEQUILIBRAGE du TAS apr\8as une insertion ou une suppression *)\r
+ (*------------------------------------------------------------------------*)\r
+ UNIT correct: PROCEDURE(r:elem,down:BOOLEAN);\r
+ VAR x,z:node,\r
+ t:elem,\r
+ fin,log:BOOLEAN;\r
+ BEGIN\r
+ z:=r.lab;\r
+ IF down\r
+ THEN WHILE NOT fin DO\r
+ IF z.ns =0\r
+ THEN fin:=TRUE;\r
+ ELSE IF z.ns=1\r
+ THEN x:=z.left;\r
+ ELSE IF z.left.less(z.right)\r
+ THEN x:=z.left;\r
+ ELSE x:=z.right;\r
+ FI;\r
+ FI;\r
+ IF z.less(x)\r
+ THEN fin:=TRUE;\r
+ ELSE t:=x.el;\r
+ x.el:=z.el;\r
+ z.el:=t;\r
+ z.el.lab:=z;\r
+ x.el.lab:=x\r
+ FI;\r
+ FI;\r
+ z:=x;\r
+ OD;\r
+ ELSE x:=z.up; (* !!!!!!!!!!refference to none **********)\r
+ IF x=NONE\r
+ THEN log:=TRUE;\r
+ ELSE log:=x.less(z);\r
+ FI;\r
+ WHILE NOT log DO\r
+ t:=z.el;\r
+ z.el:=x.el;\r
+ x.el:=t;\r
+ x.el.lab:=x;\r
+ z.el.lab:=z;\r
+ z:=x;\r
+ x:=z.up;\r
+ IF x=NONE\r
+ THEN log:=TRUE\r
+ ELSE log:=x.less(z);\r
+ FI;\r
+ OD;\r
+ FI;\r
+ END correct;\r
+ \r
+END queuehead;\r
+ \r
+(*-----------------------------------*)\r
+(* NOEUD du TAS contenant un element *)\r
+(*-----------------------------------*)\r
+UNIT node: CLASS (el:elem);\r
+VAR left,right,up: node, ns:INTEGER;\r
+ \r
+ (*-----------------------------------*)\r
+ (* COMPARAISON de deux NOEUDS du TAS *)\r
+ (*-----------------------------------*)\r
+ UNIT less: FUNCTION(x:node): BOOLEAN;\r
+ BEGIN\r
+ IF x= NONE\r
+ THEN RESULT:=FALSE\r
+ ELSE RESULT:=el.less(x.el)\r
+ FI;\r
+ END less;\r
+END node;\r
+ \r
+(*-----------------------------------*)\r
+(* TYPE generique des element du TAS *)\r
+(*-----------------------------------*)\r
+UNIT elem: CLASS(prior:REAL);\r
+VAR lab: node;\r
+ \r
+ (*----------------------------------------------------*)\r
+ (* FONCTION generique de comparaison de deux elements *)\r
+ (*----------------------------------------------------*)\r
+ UNIT VIRTUAL less: FUNCTION(x:elem):BOOLEAN;\r
+ BEGIN\r
+ IF x=NONE\r
+ THEN RESULT:= FALSE\r
+ ELSE RESULT:= prior< x.prior\r
+ FI;\r
+ END less;\r
+ \r
+ BEGIN\r
+ lab:= NEW node(THIS elem);\r
+ END elem;\r
+ \r
+END priorityqueue;\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+ \r
+(*--------------------------------*)\r
+(* MODULE GENERIQUE de SIMULATION *)\r
+(*--------------------------------*)\r
+UNIT simulation: priorityqueue CLASS;\r
+ \r
+VAR curr: simprocess, (* Processus actif *)\r
+ pq:queuehead, (* L'axe des temps *)\r
+ mainpr: mainprogram;\r
+ \r
+ UNIT simprocess: COROUTINE;\r
+ VAR event,\r
+ eventaux: eventnotice,\r
+ finish: BOOLEAN;\r
+ \r
+ (*---------------------------------------------------------*)\r
+ (* FONCTION permettant de savoir si le processus est actif *)\r
+ (*---------------------------------------------------------*)\r
+ UNIT IDLE: FUNCTION: BOOLEAN;\r
+ BEGIN\r
+ RESULT:= EVENT= NONE;\r
+ END IDLE;\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* FONCTION permettant de savoir si le processus est termin\82 *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT TERMINATED: FUNCTION :BOOLEAN;\r
+ BEGIN\r
+ RESULT:= finish;\r
+ END TERMINATED;\r
+ \r
+ UNIT evtime: FUNCTION: REAL;\r
+ BEGIN\r
+ IF IDLE\r
+ THEN CALL ERROR1;\r
+ FI;\r
+ RESULT := event.eventtime;\r
+ END evtime;\r
+ \r
+ UNIT ERROR1:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(main);\r
+ WRITELN(" Erreur tentative d'acces a un processus endormi");\r
+ END ERROR1;\r
+ \r
+ UNIT ERROR2:PROCEDURE;\r
+ BEGIN\r
+ ATTACH(main);\r
+ WRITELN(" Erreur : tentative d'acces a un processus deja termine");\r
+ END ERROR2;\r
+ \r
+ BEGIN\r
+ RETURN;\r
+ INNER;\r
+ finish:=TRUE;\r
+ CALL passivate;\r
+ CALL ERROR2;\r
+ END simprocess;\r
+ \r
+ (*-------------------------------------------------*)\r
+ (* PLACEMENT du processus actif sur l'axe du temps *)\r
+ (*-------------------------------------------------*)\r
+ UNIT eventnotice: elem CLASS;\r
+ VAR eventtime: REAL, proc: simprocess;\r
+ \r
+ UNIT VIRTUAL less: FUNCTION(x: eventnotice):BOOLEAN;\r
+ BEGIN\r
+ IF x=NONE\r
+ THEN RESULT:= FALSE;\r
+ ELSE RESULT:= eventtime< x.eventtime OR\r
+ (eventtime=x.eventtime AND prior< x.prior);\r
+ FI;\r
+ END less;\r
+ \r
+ END eventnotice;\r
+ \r
+ UNIT mainprogram: simprocess CLASS;\r
+ BEGIN\r
+ DO\r
+ ATTACH(main);\r
+ OD;\r
+ END mainprogram;\r
+ (*-----------------------------------------------------------*)\r
+ (* FONCTION permettant de savoir quel est le processus actif *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT time:FUNCTION:REAL;\r
+ BEGIN\r
+ RESULT:=current.evtime;\r
+ END time;\r
+ \r
+ (*--------------------------------------------------------------------*)\r
+ (* FONCTION retournant le premier processus place sur l'axe des temps *)\r
+ (*--------------------------------------------------------------------*)\r
+ UNIT current: FUNCTION: simprocess;\r
+ BEGIN\r
+ RESULT:=curr;\r
+ END current;\r
+ \r
+ (*-----------------------------------------------------------*)\r
+ (* PROCEDURE permettant d'activer le processus p \85 l'heure t *)\r
+ (*-----------------------------------------------------------*)\r
+ UNIT schedule: PROCEDURE(p:simprocess,t:REAL);\r
+ BEGIN\r
+ IF t<time\r
+ THEN t:= time\r
+ FI;\r
+ IF p=current\r
+ THEN CALL hold(T-time)\r
+ ELSE IF p.IDLE AND p.eventaux=NONE\r
+ THEN p.event,p.eventaux:= NEW eventnotice(RANDOM);\r
+ p.event.proc:=p ;\r
+ ELSE IF p.IDLE\r
+ THEN p.event:= p.eventaux;\r
+ p.event.prior:=RANDOM;\r
+ ELSE p.event.prior:=RANDOM;\r
+ CALL pq.delete(p.event);\r
+ \r
+ FI;\r
+ FI;\r
+ p.event.eventtime:= T;\r
+ CALL pq.insert(p.event);\r
+ FI;\r
+ END schedule;\r
+ \r
+ UNIT hold:PROCEDURE(t:REAL);\r
+ BEGIN\r
+ CALL pq.delete(current.event);\r
+ current.event.prior:=RANDOM;\r
+ IF t<0 THEN t:=0; FI;\r
+ current.event.eventtime:=time+T;\r
+ CALL pq.insert(current.event);\r
+ CALL choiceprocess;\r
+ END hold;\r
+ \r
+ (*----------------------------------------------------------*)\r
+ (* PROCEDURE permettant de desactiver le processus p et *)\r
+ (* d'activer le suivant processus situ\82 sur l'axe des temps *)\r
+ (*----------------------------------------------------------*)\r
+ UNIT passivate: PROCEDURE;\r
+ BEGIN\r
+ CALL pq.delete(current.event);\r
+ current.event:=NONE;\r
+ (* Choix du processus suivant \85 activer *)\r
+ CALL choiceprocess\r
+ END passivate;\r
+ \r
+ UNIT run: PROCEDURE(P:simprocess);\r
+ BEGIN\r
+ current.event.prior:=RANDOM;\r
+ IF NOT p.IDLE (* !!! SL-chain cut off !!!!!!*)\r
+ THEN p.event.prior:=0;\r
+ p.event.eventtime:=time;\r
+ CALL pq.correct(p.event,FALSE);\r
+ ELSE IF p.eventaux=NONE\r
+ THEN p.event,p.eventaux:=NEW eventnotice(0);\r
+ p.event.eventtime:=time;\r
+ p.event.proc:=p;\r
+ CALL pq.insert(p.event);\r
+ ELSE p.event:=p.eventaux;\r
+ p.event.prior:=0;\r
+ p.event.eventtime:=time;\r
+ p.event.proc:=p;\r
+ CALL pq.insert(p.event);\r
+ FI;\r
+ FI;\r
+ CALL choiceprocess;\r
+ END run;\r
+ \r
+ UNIT cancel:PROCEDURE(P: simprocess);\r
+ BEGIN\r
+ IF p= current\r
+ THEN CALL passivate;\r
+ ELSE CALL pq.delete(p.EVENT);\r
+ p.EVENT:=NONE;\r
+ FI;\r
+ END cancel;\r
+ \r
+ (*---------------------------------------------------------------------*)\r
+ (* PROCEDURE permettant de choisir le prochain processus qui va etre *)\r
+ (* activer , c'est \85 dir le premier de l'axe des temps *)\r
+ (*---------------------------------------------------------------------*)\r
+ UNIT choiceprocess:PROCEDURE;\r
+ VAR p:simprocess;\r
+ BEGIN\r
+ p:=curr;\r
+ curr:= pq.MIN QUA eventnotice.proc;\r
+ IF curr=NONE\r
+ THEN WRITE(" ERREUR DANS LE TAS"); WRITELN;\r
+ ATTACH(main);\r
+ ELSE ATTACH(curr);\r
+ FI;\r
+ END choiceprocess;\r
+ \r
+BEGIN\r
+ (* Simulation de l'axe des temps *)\r
+ pq:=NEW queuehead;\r
+ curr,mainpr:=NEW mainprogram;\r
+ mainpr.event,mainpr.eventaux:=NEW eventnotice(0);\r
+ mainpr.event.eventtime:=0;\r
+ mainpr.event.proc:=mainpr;\r
+ (* Insertion du processus sur l'axe des temps *)\r
+ CALL pq.insert(mainpr.event);\r
+ INNER;\r
+ PQ:=NONE;\r
+END simulation;\r
+ \r
+(*----------------------------------------------------------------------------*)\r
+ \r
+ \r
+(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)\r
+(* * SIMULATION D'UNE STATION SERVICE DE 4 POMPES * *)\r
+(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)\r
+ \r
+UNIT stationservice : simulation CLASS;\r
+ \r
+(* DECLARATION DE CONSTANTES PERMETTANT DE DEFINIR LA HAUTEUR ET LA *)\r
+(* LONGUEUR D'UNE POMPE, DE LA CAISSE ET D'UNE VOITURE *)\r
+const lhpompe =90,\r
+ hhpompe = 40,\r
+ lbpompe = 20,\r
+ hbpompe = 20,\r
+ lcaisse = 90,\r
+ hcaisse = 40,\r
+ lvoiture = 25,\r
+ hvoiture = 15;\r
+ \r
+ (*-----------------------------------------------------------------*)\r
+ (* Processus permettant l'affichage du temps courant de simulation *)\r
+ (*-----------------------------------------------------------------*)\r
+ UNIT clock : simprocess CLASS;\r
+ BEGIN\r
+ CALL rectangle (1,330,150,18);\r
+ CALL ecrit_text (3,334,"TIME");\r
+ \r
+ (* BOUCLE INFINIE : AFFICHAGE de l'HEURE \85 CHAQUE FOIS que la *)\r
+ (* proc\82dure est REVEILLE *)\r
+ DO\r
+ CALL ecrit_heure (55,334,time);\r
+ CALL HOLD(60);\r
+ OD;\r
+ END clock;\r
+ \r
+ \r
+ (*----------------------------------------*)\r
+ (* Processus simulant une POMPE *)\r
+ (*----------------------------------------*)\r
+ (* tip : Style de carburant de la pompe *)\r
+ (* tipe : Numero de la pompe *)\r
+ (* lig : Coordonn\82es Y de l'\82cran *)\r
+ (* col : Coordonn\82es X de l'\82cran *)\r
+ (*----------------------------------------*)\r
+ UNIT pompe : simprocess CLASS(tip : string,tipe,lig,col : INTEGER);\r
+ \r
+ VAR nbcli : integer, (* Nbre de clients a la pompe *)\r
+ libre: boolean,(* Booleen indiquant si la pompe est libre *)\r
+ cli : client,\r
+ i,li :INTEGER;\r
+ BEGIN\r
+ \r
+ i := pos_carb+(tipe-1)*80;\r
+ (* TANT QUE la pompe est en attente *)\r
+ \r
+ (* BOUCLE INFINIE : FONCTIONNEMENT DES POMPES *)\r
+ DO\r
+ \r
+ (* Si des clients attendent pour etre servis *)\r
+ IF (file_pompe(tipe).tete =/= NONE and libre)\r
+ THEN\r
+ \r
+ cli := file_pompe(tipe).tete.el;\r
+ \r
+ (* Mise en marche de la pompe libre *)\r
+ CALL ecrit_text (205,i,"MARCHE ");\r
+ \r
+ (* Affichage du numero du client qui est actuellement servi *)\r
+ call move (265,i);\r
+ call ecrit_entier(cli.num);\r
+ \r
+ \r
+ (* CHOIX al\82atoire du nombre de litres de carburant *)\r
+ li:=irandom (1,30);\r
+ libre := false; (* la pompe est occupe par le client *)\r
+ (* D\82roulement du service de li litres de carburant *)\r
+ CALL HOLD(60*li);\r
+ \r
+ (* Mise en attente de la pompe et decrementation du *)\r
+ (* nombre de clients souhaitant etre servi \85 cette m\88me pompe *)\r
+ \r
+ nbcli := nbcli - 1;\r
+ call move(253,i+25 );\r
+ call ecrit_entier(nbcli);\r
+ \r
+ (* Affichage \85 l'\82cran des differents clients d\82sirant prendre *)\r
+ (* du carburant \85 cette pompe *)\r
+ call file_pompe(tipe).supprimer;\r
+ call aff_queue_pompe(file_pompe(tipe), tipe);\r
+ \r
+ (* AFFICHAGE sur la pompe signalant qu'elle est bloque *)\r
+ CALL ecrit_text (205,i,"BLOQUE ");\r
+ \r
+ call schedule(cli, time);\r
+ call hold(60);\r
+ \r
+ ELSE (* S'il n'y a pas de client : DESACTIVATION du processus *)\r
+ CALL PASSIVATE;\r
+ FI;\r
+ \r
+ OD;\r
+ \r
+ END pompe;\r
+ \r
+ \r
+ (*-----------------------------------------------*)\r
+ (* AFFICHAGE \85 l'\82cran d'une POMPE et du TYPE de *)\r
+ (* carburant qu'elle distribue *)\r
+ (*-----------------------------------------------*)\r
+ UNIT aff_pompe : PROCEDURE(x : pompe);\r
+ VAR i,ligne : INTEGER;\r
+ BEGIN\r
+ CALL rectangle (x.col,x.lig,lhpompe,hhpompe);\r
+ CALL rectangle (x.col-2,x.lig-2,lhpompe+4,hhpompe+4);\r
+ CALL rectangle (x.col+20,x.lig +hhpompe,lbpompe,hbpompe);\r
+ CALL ecrit_text (x.col + 3, x.lig +10,x.tip);\r
+ END aff_pompe;\r
+ \r
+ \r
+ (*--------------------------------------------------*)\r
+ (* Processus simulant la caisse *)\r
+ (*--------------------------------------------------*)\r
+ UNIT caisse : simprocess CLASS;\r
+ VAR cli : client,\r
+ i,num, nbcli : INTEGER,\r
+ libre : boolean;\r
+ BEGIN\r
+ (* BOUCLE INFINIE : FONCTIONNEMENT DE LA CAISSE *)\r
+ \r
+ DO\r
+ call move (45,180);\r
+ call ecrit_entier(nbcli);\r
+ \r
+ (* SI la FILE de la caisse n'est pas vide *)\r
+ (* ALORS traitement du client *)\r
+ (* SINON desactivation du processus caisse *)\r
+ IF (file_caisse.tete =/= NONE and libre)\r
+ THEN\r
+ cli := file_caisse.tete.el;\r
+ nbc:=nbc +1;\r
+ \r
+ (* MISE en marche de la caisse *)\r
+ CALL ecrit_text (35,170,"MARCHE ");\r
+ libre := false;\r
+ (* SUPPRESSION du client de la file d'attente de la caisse *)\r
+ CALL file_caisse.supprimer;\r
+ \r
+ (* AFFICHAGE des clients se trouvant la la FILE de la caisse *)\r
+ (* apr\8as le passage de ce client *)\r
+ CALL affiche_queue(file_caisse);\r
+ \r
+ (* AFFICHAGE du numero du client se trouvant \85 la caisse *)\r
+ call move (90,170);\r
+ call ecrit_entier(cli.num);\r
+ call color(cli.col);\r
+ \r
+ (* AFFICHAGE le client qui paye?? a la caisse *)\r
+ call aff_voiture(70,200,cli.num);\r
+ call color(15);\r
+ \r
+ (* La dur\82e du PAIEMENT est de 10x60 *)\r
+ CALL HOLD(300*random);\r
+ \r
+ (* MISE A L'ARRET de la caisee *)\r
+ (* AFFICHAGE du nombre de client se trouvant dans la file *)\r
+ nbcli := nbcli-1;\r
+ CALL move (45,180);\r
+ CALL ecrit_entier(nbcli);\r
+ \r
+ CALL ecrit_text (35,170,"STOP ");\r
+ call ecrit_text (90,170," ");\r
+ \r
+ (* CALCUL du temps total n\82c\82ssaire pour se servir et payer *)\r
+ cli.temps_attente := time - cli.temps_arrive;\r
+ \r
+ (* CUMUL des differents temps d'attente *)\r
+ temps := temps + cli.temps_attente;\r
+ \r
+ (* effacement de client qui deja paye *)\r
+ call color(0);\r
+ call aff_voiture(70,200,cli.num);\r
+ \r
+ call color(15);\r
+ i := cli.val;\r
+ KILL (cli);\r
+ libre := true;\r
+ (* ACTIVATION de la pompe qui viend d'\88tre liberer apr\8as *)\r
+ (* paiement \85 la caisse *)\r
+ mach_pompe(i).libre := true;\r
+ call schedule(mach_pompe(i), time);\r
+ i := pos_carb+(i-1)*80;\r
+ CALL ecrit_text (205,i,"PRET ");\r
+ call hold(120);\r
+ ELSE CALL passivate;\r
+ FI;\r
+ OD;\r
+ CALL passivate;\r
+ END caisse;\r
+ \r
+ (*-------------------------------------------------*)\r
+ (* AFFICHAGE de la caisse *)\r
+ (*-------------------------------------------------*)\r
+ UNIT aff_caisse : PROCEDURE( x : caisse);\r
+ VAR i : INTEGER;\r
+ BEGIN\r
+ CALL rectangle (30,150,90,40);\r
+ CALL ecrit_text (33,160,"CAISSE");\r
+ END aff_caisse;\r
+ \r
+ (*------------------------------------------------*)\r
+ (* AFFICHAGE DE LA FILE D'ATTENTE DES POMPES *)\r
+ (*------------------------------------------------*)\r
+ \r
+ \r
+ UNIT aff_queue_pompe : PROCEDURE ( q:file_attente, tip : integer);\r
+ VAR val:client;\r
+ BEGIN\r
+ posx(tip):=300;\r
+ \r
+ (* POUR CHAQUE element du tas *)\r
+ WHILE (q.prem <> NONE) DO\r
+ (* AFFICHAGE eventuel de la voiture \85 l'\82cran, c'est *)\r
+ (* \85 dire s'il y a assez de place sur l'\82cran *)\r
+ IF ((posx(tip) >= 635) OR ((posx(tip) +25) >=635)) THEN EXIT; FI;\r
+ call color(q.prem.el.col);\r
+ CALL aff_voiture(posx(tip),posy(tip),q.prem.el.num);\r
+ \r
+ q.prem:=q.prem.succ;\r
+ posx(tip):=posx(tip)+30;\r
+ OD;\r
+ \r
+ (* EFFACEMENT de la derniere voiture qui vient d'avancer *)\r
+ IF ((posx(tip) < 635) AND ((posx(tip) +25) <635)) THEN\r
+ FOR i := posy(tip) TO (posy(tip)+25)\r
+ DO\r
+ CALL ecrit_text(posx(tip),i," ");\r
+ OD;\r
+ FI;\r
+ \r
+ END aff_queue_pompe;\r
+ \r
+ \r
+ \r
+ \r
+ (*--------------------------------------------------*)\r
+ (* AFFICHAGE DE LA FILE D'ATTENTE DE LA CAISSE *)\r
+ (*--------------------------------------------------*)\r
+ \r
+ UNIT affiche_queue : PROCEDURE( q:file_attente ) ;\r
+ BEGIN\r
+ poscay:= 150;\r
+ \r
+ (* POUR CHAQUE element du tas *)\r
+ WHILE (q.prem <> NONE) DO\r
+ call ecrit_text(poscax+5,poscay+2," ");\r
+ call color(q.prem.el.col);\r
+ (* AFFICHAGE de la voiture \85 l'\82cran *)\r
+ CALL aff_voiture(poscax,poscay,q.prem.el.num);\r
+ q.prem:=q.prem.succ;\r
+ poscay:=poscay-30;\r
+ if poscay<50 then exit fi;\r
+ OD;\r
+ \r
+ (* EFFACEMENT de la derniere voiture qui vient d'avancer *)\r
+ FOR i := poscay TO (poscay+20) DO\r
+ CALL ecrit_text(poscax,i," ");\r
+ OD;\r
+ \r
+ END affiche_queue;\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ (*----------------------------------------------*)\r
+ (* AFFICHAGE d'une voiture \85 l'\82cran *)\r
+ (*----------------------------------------------*)\r
+ (* posx : position X de la voiture *)\r
+ (* posy : position Y de la voiture *)\r
+ (* x : Numero \85 afficher sur la voiture, *)\r
+ (* c'est \85 dire le num\82ro du client *)\r
+ (*----------------------------------------------*)\r
+ UNIT aff_voiture : PROCEDURE(posx,posy,x:INTEGER);\r
+ BEGIN\r
+ CALL rectangle(posx,posy,25,15);\r
+ CALL move (posx+5,posy+2);\r
+ CALL ecrit_entier(x);\r
+ END aff_voiture;\r
+ \r
+ (*----------------------------------------------------*)\r
+ (* FONCTION RETOURNANT UN NOMBRE COMPRIS ENTRE a ET b *)\r
+ (*----------------------------------------------------*)\r
+ UNIT irandom : FUNCTION(a,b:INTEGER):INTEGER;\r
+ begin\r
+ result := entier((b-a)*random +a)\r
+ end irandom;\r
+ \r
+ \r
+ (*--------------------------------------------------------*)\r
+ (* Processus simulant UN CLIENT de la station *)\r
+ (*--------------------------------------------------------*)\r
+ UNIT client : simprocess CLASS(num : INTEGER);\r
+ VAR val, col : integer, (* numero de pompe et couleur de voiture choisit*)\r
+ bb : boolean, (* bb= true si le client est premier*)\r
+ temps_attente,temps_arrive : REAL; (* Temps d'attente dans la file *)\r
+ \r
+ (* On DETERMINE a l'ARRIVEE du client quel type de carburant il *)\r
+ (* souhaite *)\r
+ UNIT arrive : PROCEDURE;\r
+ VAR i,j : INTEGER;\r
+ BEGIN\r
+ \r
+ (* CHOIX ALEATOIRE du numero de pompe P que le client choisit *)\r
+ val := irandom(1,5);\r
+ col := irandom(1,14);\r
+ \r
+ (* SELON le numero de pompe : *)\r
+ (* - INSERTION du client dans la file d'attente de la pompe P *)\r
+ (* - INCREMENTATION et AFFICHAGE du nombre de client se *)\r
+ (* trouvant \85 la pompe *)\r
+ \r
+ call file_pompe(val).inserer(this client);\r
+ \r
+ j:= mach_pompe(val).nbcli + 1;\r
+ call move(253,75+(val-1)*80);\r
+ call ecrit_entier(j);\r
+ mach_pompe(val).nbcli :=j;\r
+ \r
+ \r
+ (* AFFICHAGE de la voiture du nouveau client *)\r
+ call color(col);\r
+ CALL aff_queue_pompe(file_pompe(val),val);\r
+ call color(15);\r
+ END arrive;\r
+ \r
+ BEGIN\r
+ \r
+ CALL arrive;\r
+ temps_arrive := time;\r
+ if (mach_pompe(val).libre and mach_pompe(val).idle )\r
+ then\r
+ call run(mach_pompe(val))\r
+ fi;\r
+ \r
+ call passivate;\r
+ \r
+ (* INSERTION du client dans la liste d'attente de la caisse *)\r
+ CALL file_caisse.inserer(this client);\r
+ \r
+ (* AFFICHAGE de l'ensemble des voitures qui se trouvent dans la *)\r
+ (* file d'attente de la caisse et du nombre decrement\82 du *)\r
+ (* de clients se trouvant dans la caisse *)\r
+ CALL affiche_queue(file_caisse);\r
+ caissiere.nbcli:= caissiere.nbcli +1;\r
+ if (caissiere.libre and caissiere.idle )\r
+ then\r
+ CALL run(caissiere) else call passivate;\r
+ fi;\r
+ \r
+ END client;\r
+ \r
+ (*-------------------------------------------*)\r
+ (* GENERATEUR de client *)\r
+ (*-------------------------------------------*)\r
+ UNIT gen_client : simprocess CLASS;\r
+ BEGIN\r
+ noclient := 0;\r
+ nombre := 1;\r
+ (* BOUCLE INFINIE : GENERATION D'UN CLIENT *)\r
+ DO\r
+ IF (noclient = 100)\r
+ THEN noclient := 1;\r
+ FI;\r
+ \r
+ (* GENERATION des clients plus ou moins rapide *)\r
+ (* selon la m\82t\82o qu'il fait *)\r
+ CALL schedule(NEW client(nombre),time);\r
+ CASE (weather)\r
+ WHEN 1 : CALL hold(RANDOM*300 +50);\r
+ WHEN 2 : CALL hold(RANDOM*300 +100);\r
+ WHEN 3 : CALL hold(RANDOM*300 +500);\r
+ ESAC;\r
+ noclient := noclient +1;\r
+ nombre := nombre + 1;\r
+ OD;\r
+ END gen_client;\r
+ \r
+(*---------------------------------------------*)\r
+(* TYPE des elements mis dans la file *)\r
+(*---------------------------------------------*)\r
+ UNIT link : CLASS(el : client);\r
+ VAR succ : link;\r
+ END;\r
+ \r
+ UNIT file_attente : CLASS;\r
+ VAR tete, queue,prem : link;\r
+ \r
+ (* INSERTION d'un CLIENT dans la FILE D'ATTENTE *)\r
+ UNIT inserer : PROCEDURE(x : client);\r
+ VAR inter : INTEGER;\r
+ BEGIN\r
+ IF tete = NONE\r
+ THEN tete := NEW LINK(x);\r
+ queue := tete;\r
+ ELSE queue.succ := NEW link(x);\r
+ queue := queue.succ;\r
+ FI;\r
+ prem:=tete;\r
+ END inserer;\r
+ \r
+ (* SUPPRESSION d'un client de la file d'attente *)\r
+ UNIT supprimer: PROCEDURE;\r
+ BEGIN\r
+ IF (tete =/= NONE)\r
+ THEN\r
+ tete := tete.succ;\r
+ FI;\r
+ prem:=tete;\r
+ END supprimer;\r
+END file_attente;\r
+ \r
+ \r
+(*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*)\r
+(*/*/*/*/*/* P R O G R A M M E P R I N C I P A L */*/*/*/*/*)\r
+(*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*)\r
+ CONST poscax = 150,\r
+ pos_carb = 50;\r
+ VAR\r
+ posx,posy : ARRAYOF INTEGER,(* Indice pour l'affichage *)\r
+ caissiere :caisse, (* Caisse *)\r
+ mach_pompe : ARRAYOF pompe, (* TABLEAU d'\82l\82ments de type pompe *)\r
+ poscay, (* Indice de positionnement de la caisse *)\r
+ nombre, (* Nombre de clients g\82n\82r\82s *)\r
+ nbc, (* Nombre de clients servis de carburant *)\r
+ (* et ayant pay\82 *)\r
+ i, (* Variable de boucle *)\r
+ noclient, (* Nbre totale des clients *)\r
+ y, (* *)\r
+ car, (* Variable permettant la saisie d'une touche *)\r
+ time_simulation,\r
+ weather : INTEGER, (* Variable signalant le temps qu'il fait *)\r
+ horloge : clock, (* Compteur de l'heure *)\r
+ cli : client, (* UN client *)\r
+ file_pompe : ARRAYOF file_attente, (* TABLEAU de FILES D'ATTENTE *)\r
+ (* pour les pompes *)\r
+ file_caisse : file_attente, (* FILE D'ATTENTE de la caisse *)\r
+ temps :real, (* TEMPS MOYEN d'attente de chaque client *)\r
+ bol: boolean;(* booleen retourn\82 par une fonction de la class GRAPH *)\r
+ \r
+ \r
+ BEGIN\r
+ \r
+ (* CREATION et INITIALISATION DES DIFFERENTS TABLEAUX *)\r
+ (* d'indice pour les affichages graphiques *)\r
+ \r
+ ARRAY posy DIM(1:4);\r
+ ARRAY posx DIM(1:4);\r
+ FOR i:=1 TO 4 DO\r
+ posx(i):=300;\r
+ OD;\r
+ posy(1):=45;\r
+ posy(2):=125;\r
+ posy(3):=205;\r
+ posy(4):=285;\r
+ \r
+ (* OUVERTURE DU MODE GRAPHIQUE *)\r
+ CALL initgraph;\r
+ \r
+ (* AFFICHAGE sommaire du sujet de la simulation et de la presentation *)\r
+ CALL cls;\r
+ CALL rectangle (1,1,635,348);\r
+ CALL move (15,174);\r
+ CALL ecrit_text (15,174,\r
+ " SIMULATION D'UNE STATION SERVICE COMPRENANT 4 POMPES\r
+ ET D'UNE CAISSE ");\r
+ \r
+ (* LECTURE ET CONTROLE d'une hypothese n\82c\82ssaire *)\r
+ (* au d\82roulement de la simulation *)\r
+ (* (temps qu'il fait) *)\r
+ CALL ecrit_text (50,190," 1 - BEAU TEMPS");\r
+ CALL ecrit_text (50,210," 2 - TEMPS COUVERT");\r
+ CALL ecrit_text (50,230," 3 - NUIT");\r
+ CALL ecrit_text (50,250," VOTRE CHOIX :");\r
+ DO\r
+ bol:= lire_entier(250,250,weather);\r
+ IF (weather>0 and weather<4) then\r
+ exit\r
+ ELSE\r
+ CALL ecrit_text (50,250,"REDONNER VOTRE CHOIX :");\r
+ FI;\r
+ OD;\r
+ call ecrit_text (50, 270," simulation time en minutes: ");\r
+ bol := lire_entier(270,270,time_simulation);\r
+ CALL ecrit_text (200,300,"< TAPER SUR UNE TOUCHE POUR CONTINUER >");\r
+ \r
+ (* CREATION de la file d'attente de clients pour chaque pompe *)\r
+ ARRAY file_pompe DIM(1:4);\r
+ FOR i:= 1 TO 4\r
+ DO\r
+ file_pompe(i) := new file_attente;\r
+ OD;\r
+ \r
+ (* CREATION de la file d'attente de clients pour la caisse *)\r
+ file_caisse := NEW file_attente;\r
+ \r
+ (* CREATION de l'HORLOGE de la simulation *)\r
+ horloge := NEW clock;\r
+ CALL schedule(horloge,time);\r
+ \r
+ (* CREATION de 4 POMPES *)\r
+ ARRAY mach_pompe DIM(1:4);\r
+ mach_pompe(1) := new pompe ("ESSENCE",1,25,200);\r
+ mach_pompe(2) := new pompe ("SUPER",2,105,200);\r
+ mach_pompe(3) := new pompe ("S PLOMB",3,185,200);\r
+ mach_pompe(4) := new pompe ("GAZOIL",4,265,200);\r
+ \r
+ \r
+ (* AFFICHAGE d'une page vierge *)\r
+ CALL cls;\r
+ CALL rectangle (1,1,635,348);\r
+ \r
+ (* AFFICHAGE des 4 pompes de la STATION *)\r
+ y := pos_carb;\r
+ FOR i := 1 TO 4 DO\r
+ CALL color(i+1);\r
+ CALL aff_pompe(mach_pompe(i));\r
+ CALL ecrit_text(205,y,"LIBRE ");\r
+ mach_pompe(i).libre := true;\r
+ y := y +80;\r
+ OD;\r
+ CALL color(15);\r
+ \r
+ (* CREATION de la caisse *)\r
+ caissiere := NEW caisse;\r
+ CALL aff_caisse(caissiere);\r
+ Call ecrit_text(35,170,"LIBRE ");\r
+ caissiere.libre := true;\r
+ \r
+ CALL ecrit_text (60,10,"FILE DE LA CAISSE ");\r
+ CALL ecrit_text (360,10, "FILES D'ATTENTE DES POMPES");\r
+END;\r
+ \r
+BEGIN\r
+ PREF stationservice BLOCK\r
+ VAR car,sauv : INTEGER;\r
+ \r
+ (* Procedure permettant la recherche du type de pompe qu'il faut rajouter *)\r
+ (* \85 la station service *)\r
+ UNIT recherche :PROCEDURE(i,j:integer);\r
+ var n : integer;\r
+ BEGIN\r
+ for n :=1 to 4 do\r
+ IF mach_pompe(n).nbcli>=j THEN\r
+ case n\r
+ when 1 : CALL ecrit_text(300,i,"- ESSENCE");\r
+ when 2 : CALL ecrit_text(300,i,"- SUPER");\r
+ when 3 : CALL ecrit_text(300,i,"- S PLOMB");\r
+ when 4 : CALL ecrit_text(300,i,"- GAZOIL ");\r
+ esac;\r
+ i:=i+10;\r
+ FI;\r
+ od;\r
+ \r
+ END recherche;\r
+ \r
+ BEGIN\r
+ CALL schedule(NEW gen_client,TIME);\r
+ CALL hold(Time_simulation*60);\r
+ CALL ecrit_text (400,324,"FIN DE LA SIMULATION");\r
+ CALL ecrit_text (200,335,"< TAPER SUR UNE TOUCHE POUR CONTINUER >");\r
+ car := inchar;\r
+ CALL cls;\r
+ CALL ecrit_text(100,10,\r
+ " OBSERVATION FINALE DE LA SIMULATION DE LA STATION");\r
+ \r
+ (* SI le nombre de client ayant pay\82 est diff\82rent de z\82ro *)\r
+ IF (nbc <> 0) THEN\r
+ \r
+ (* AFFICHAGE DES OBSERVATIONS FINALES SELON LA METEO *)\r
+ temps := (temps/nbc);\r
+ CALL ecrit_text (100,100,"PENDANT LE TEMPS DE LA SIMILATION, SEULEMENT ");\r
+ CALL move (460,100);\r
+ CALL ecrit_entier(nbc);\r
+ CALL ecrit_text (100,125,"PERSONNES ONT ETE TOTALEMENT SATISFAITES");\r
+ CALL ecrit_text (100,150,"LE TEMPS MOYEN PASSE A LA STATION EST : ");\r
+ CALL ecrit_heure (450,150,temps);\r
+ \r
+ \r
+ \r
+ sauv := 0;\r
+ for i :=1 to 4 do\r
+ y := mach_pompe(i).nbcli;\r
+ if sauv< y then sauv := y fi;\r
+ od;\r
+ \r
+ \r
+ case weather\r
+ when 1 : If ((sauv <=6) and (temps <=3000)) then\r
+ CALL ecrit_text (50,200,"LA STATION FONCTIONNE BIEN ");\r
+ fi;\r
+ If ((sauv <=6) and (temps >3000)) then\r
+ CALL ecrit_text (50,200,\r
+ "LES POMPES NE SONT PAS ASSEZ PUISSANTES");\r
+ fi;\r
+ If ((sauv >6) and (temps <=3000)) then\r
+ CALL ecrit_text (50,200,\r
+ "LES POMPES NE SONT PAS ASEZ PUISSANTES\r
+VEILLEZ A AJOUTER DES POMPES : ");\r
+ CALL RECHERCHE (225,6)\r
+ fi;\r
+ If ((sauv >6) and (temps >3000)) then\r
+ CALL ecrit_text (50,200,"LA CONSTRUCTION D'UNE AUTRE STATION");\r
+ CALL ecrit_text (50,225," PARAIT NECESSAIRE ");\r
+ fi;\r
+ when 2 : If ((sauv <=5) and (temps <=2400)) then\r
+ CALL ecrit_text (50,200,"LA STATION FONCTIONNE BIEN ");\r
+ fi;\r
+ If ((sauv <=5) and (temps >2400)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASSEZ PUISSANTES");\r
+ fi;\r
+ If ((sauv >5) and (temps <=2400)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASEZ PUISSANTES\r
+VEILLEZ A AJOUTER DES POMPES : ");\r
+ CALL RECHERCHE (225,5)\r
+ fi;\r
+ If ((sauv >5) and (temps >2400)) then\r
+ CALL ecrit_text (50,200,"LA CONSTRUCTION D'UNE AUTRE STATION");\r
+ CALL ecrit_text (50,225," PARAIT NECESSAIRE ");\r
+ fi;\r
+ when 3 : If ((sauv <=2) and (temps <=1800)) then\r
+ CALL ecrit_text (50,200,"LA STATION FONCTIONNE BIEN COMPTE\r
+TENUE QUE C'EST LA NUIT ");\r
+ fi;\r
+ If ((sauv <=2) and (temps >1800)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASSEZ PUISSANTES");\r
+ fi;\r
+ If ((sauv >2) and (temps <=1800)) then\r
+ CALL ecrit_text (50,200,"LES POMPES NE SONT PAS ASEZ PUISSANTES\r
+VEILLEZ A AJOUTER DES POMPES : ");\r
+ CALL RECHERCHE (225,2)\r
+ fi;\r
+ If ((sauv >2) and (temps >1800)) then\r
+ CALL ecrit_text (50,200,"LA CONSTRUCTION D'UNE AUTRE STATION");\r
+ CALL ecrit_text (50,225," PARAIT NECESSAIRE ");\r
+ fi;\r
+ \r
+ esac;\r
+ \r
+ (* SINON AFFICHAGE D'UN MESSAGE SIGNALANT QU'AUCUN CLIENT N'A PAYE *)\r
+ ELSE CALL ecrit_text (100,150,"AUCUN CLIENT N'A EU LE TEMPS DE SE SERVIR\r
+ET DE PAYER");\r
+ FI;\r
+ CALL rectangle (1,1,635,348);\r
+ CALL rectangle (10,30,612,300);\r
+ car:=inchar;\r
+ \r
+ (* FERMETURE DU MODE GRAPHIQUE *)\r
+ CALL closegraph;\r
+ \r
+ END;\r
+END station;\r
+ \r
--- /dev/null
+s'elever\r
+to arise\r
+etre\r
+to be\r
+battre\r
+to beat\r
+devenir\r
+to become\r
+commencer\r
+to begin\r
+plier\r
+to bend\r
+parier\r
+to bet\r
+lier\r
+to bind\r
+mordre\r
+to bite\r
+saigner\r
+to bleed\r
+souffler\r
+to blow\r
+casser\r
+to break\r
+apporter\r
+to bring\r
+construire\r
+to build\r
+bruler\r
+to burn\r
+eclater\r
+to burst\r
+acheter\r
+to buy\r
+jeter\r
+to cast\r
+attraper\r
+to catch\r
+choisir\r
+to choose\r
+s'accrocher\r
+to cling\r
+venir\r
+to come\r
+couter\r
+to cost\r
+ramper\r
+to creep\r
+couper\r
+to cut\r
+s'occuper de\r
+to deal\r
+creuser\r
+to dig\r
+faire\r
+to do\r
+dessiner\r
+to draw\r
+rever\r
+to dream\r
+boire\r
+to drink\r
+conduire\r
+to drive\r
+manger\r
+to eat\r
+tomber\r
+to fall\r
+se nourrir\r
+to feed\r
+ressentir\r
+to feel\r
+se battre\r
+to fight\r
+trouver\r
+to find\r
+lancer violemment\r
+to fling\r
+voler\r
+to fly\r
+interdire\r
+to forbid\r
+oublier\r
+to forget\r
+pardonner\r
+to forgive\r
+geler\r
+to freeze\r
+obtenir\r
+to get\r
+donner\r
+to give\r
+aller\r
+to go\r
+moudre\r
+to grind\r
+grandir\r
+to grow\r
+suspendre\r
+to hang\r
+avoir\r
+to have\r
+entendre\r
+to hear\r
+se cacher\r
+to hide\r
+frapper\r
+to hit\r
+tenir\r
+to hold\r
+faire mal\r
+to hurt\r
+garder\r
+to keep\r
+s'agenouiller\r
+to kneel\r
+savoir\r
+to know\r
+mettre\r
+to lay\r
+mener\r
+to lead\r
+apprendre\r
+to learn\r
+quitter\r
+to leave\r
+preter\r
+to lend\r
+permettre\r
+to let\r
+etre etendu\r
+to lie\r
+allumer\r
+to light\r
+perdre\r
+to loose\r
+fabriquer\r
+to make\r
+vouloir dire\r
+to mean\r
+rencontrer\r
+to meet\r
+payer\r
+to pay\r
+poser\r
+to put\r
+lire\r
+to read\r
+faire du velo\r
+to ride\r
+sonner\r
+to ring\r
+s'elever\r
+to rise\r
+courrir\r
+to run\r
+dire\r
+to say\r
+voir\r
+to see\r
+chercher\r
+to seek\r
+vendre\r
+to sell\r
+envoyer\r
+to send\r
+fixer\r
+to set\r
+coudre\r
+to sew\r
+secouer\r
+to shake\r
+briller\r
+to shine\r
+tirer\r
+to shoot\r
+montrer\r
+to show\r
+se retrecir\r
+to shrink\r
+fermer\r
+to shut\r
+chanter\r
+to sing\r
+sombrer\r
+to sink\r
+etre assis\r
+to sit\r
+tuer\r
+to slay\r
+dormir\r
+to sleep\r
+glisser\r
+to slide\r
+sentir\r
+to smell\r
+parler\r
+to speak\r
+epeler\r
+to spell\r
+depenser\r
+to spend\r
+repandre\r
+to spill\r
+touner\r
+to spin\r
+cracher\r
+to spit\r
+se fendre\r
+to split\r
+etaler\r
+to spread\r
+bondir\r
+to spring\r
+etre debout\r
+to stand\r
+derober\r
+to steal\r
+coller\r
+to stick\r
+piquer\r
+to sting\r
+puer\r
+to stink\r
+frapper\r
+to strike\r
+jurer\r
+to swear\r
+balayer\r
+to sweep\r
+nager\r
+to swim\r
+se balancer\r
+to swing\r
+prendre\r
+to take\r
+enseigner\r
+to teach\r
+dechirer\r
+to tear\r
+raconter\r
+to tell\r
+croire\r
+to think\r
+jeter\r
+to throw\r
+fouler\r
+to tread\r
+subir\r
+to undergo\r
+comprendre\r
+to understand\r
+se reveiller\r
+to wake\r
+porter\r
+to wear\r
+tisser\r
+to weave\r
+pleurer\r
+to weep\r
+gagner\r
+to win\r
+serpenter\r
+to wind\r
+se retirer\r
+to withdraw\r
+tordre\r
+to wring\r
+ecrire\r
+to write\r
+\r
+\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+program test19;\r
+(* 19 lipiec 1988\r
+\r
+ ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» \r
+ º m o d u l o b s l u g i º \r
+ º r e l a c j i º\r
+ º º\r
+ ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ\r
+\r
+ zadaniem modulu jest zrealizowanie systemu wspolpracy z\r
+ relacjami i krotkami: modul opisuje te pojecia i definiuje\r
+ operacje na nich: insert, delete, make etc.*)\r
+\r
+\r
+ (***************************************************)\r
+ (* *)\r
+ (* Assumptions on file system *)\r
+ (* *)\r
+ (* The module handling relations assumes a file *)\r
+ (* system of random access files. The signature *)\r
+ (* of file system consists of four sorts: *)\r
+ (* P - files, *)\r
+ (* R - records, *)\r
+ (* S - file's names, *)\r
+ (* N - nonnegative integers *)\r
+ (* and several operations and predicates, *)\r
+ (* makefile : S x N -> P *)\r
+ (* openfile : S x N -> P *)\r
+ (* closefile : P -> P *)\r
+ (* isopen? : P -> B0 *)\r
+ (* frewind : P -> P *)\r
+ (* feof : P -> B0 *)\r
+ (* fput : P x R -> P *)\r
+ (* fget : P -> R *)\r
+ (* fseek : P x N -> P *)\r
+ (* position : P -> N *)\r
+ (* filelen : P -> N *)\r
+ (* *)\r
+ (* which satisfy the following properties *)\r
+ (* *)\r
+ (* isopen?(makefile(s,n)) *)\r
+ (* position(makefile(s,n)) = 1 *)\r
+ (* feof(p) <=> (position(p) = filelen(p)) *)\r
+ (* ªisopen?(closefile(p)) *)\r
+ (* position(frewind(p)) = 1 *)\r
+ (* k<filelen(p) => position(fseek(p,k)) = k *)\r
+ (* *)\r
+ (* isopen?(p) => (p':=fput(p,r))(k:=position(p')) *)\r
+ (* (p":=fseek(p',k-1)) (r':=fget(p")) (r =r') *)\r
+ (* *)\r
+ (* isopen?(p) => (p':=frewind(p)) *)\r
+ (* (while ªfeof(p') do r:= fget(p') od) true *)\r
+ (* *)\r
+ (* position(p) ó filelen(p) *)\r
+ (* *)\r
+ (*** * * * * * * * * * * * * * * * * * * * * * * ***)\r
+\r
+unit FileSystem: class;\r
+ (* system plikow bezposredniego dostepu *)\r
+\r
+\r
+ (************************************************************)\r
+ (* T Y P Y D A N Y C H *)\r
+ (************************************************************)\r
+ \r
+ unit Rfile: class;\r
+ (* plik jest ciagiem ponumerowanych rekordow\r
+ jednakowej dlugosci *)\r
+ \r
+ var name: arrayof char (* nazwa zewnetrzna *),\r
+ opened: boolean (* czy otwarty *),\r
+ reclen (* dlugosc rekordu - w slowach *),\r
+ (* rozmiar slowa odpowiada rozmiarowi\r
+ liczby typu integer *)\r
+ position (* numer biezacego rekordu *),\r
+ length: integer (* dlugosc pliku -\r
+ numer pozycji nastepnej po \r
+ ostatniej zajetej *),\r
+ plik: file (* plik bezposredniego dostepu *),\r
+ next, prev: Rfile (* wszystkie pliki w systemie\r
+ sa powiazane w liste\r
+ dwukierunkowa *)\r
+ end Rfile;\r
+ \r
+ \r
+ var system: Rfile; (* dowiazanie do straznika listy plikow *)\r
+\r
+\r
+ \r
+ \r
+\r
+(******************************************************************)\r
+(******************************************************************) \r
+\r
+ \r
+ \r
+ (*****************************************************************)\r
+ (* P R O C E D U R Y I F U N K C J E *)\r
+ (* S Y S T E M U P L I K O W *)\r
+ (*****************************************************************)\r
+\r
+\r
+\r
+ (******************************)\r
+ (* A U X I L I A R Y *)\r
+ (******************************)\r
+\r
+\r
+ \r
+ unit FindInSystem: function\r
+ ( name:arrayof char): Rfile ; \r
+ \r
+ unit equalstring: function\r
+ (s1, s2: arrayof char): boolean;\r
+ var i1, i2, len, i: integer;\r
+ begin\r
+ if s1 = none then \r
+ writeln(" 1st parameter in equalstring=none");\r
+ call endrun fi;\r
+ if s2 = none then\r
+ writeln(" 2nd parameter in equalstring=none");\r
+ call endrun fi;\r
+ i1 := lower(s1); i2 := lower(s2);\r
+ len := upper(s1) - i1 + 1;\r
+ if len =/= upper(s2) - i2 + 1\r
+ then return fi;\r
+ for i := 1 to len \r
+ do if s1(i1) =/= s2(i2)\r
+ then return fi;\r
+ i1 := i1 + 1;\r
+ i2 := i2 + 1;\r
+ od;\r
+ result := true\r
+ end equalstring;\r
+ \r
+ var p: Rfile;\r
+ begin system.name := name;\r
+ p := system.next;\r
+ while not equalstring( name, p.name )\r
+ do p := p.next od;\r
+ if (p = system) then result := none \r
+ else result := p fi;\r
+ end FindInSystem;\r
+ \r
+ (*********************************)\r
+ \r
+ unit AddToSystem: function\r
+ (name: arrayof char): Rfile;\r
+ begin\r
+ result := new Rfile;\r
+ result.name := name;\r
+ result.next := system.next;\r
+ result.prev := system;\r
+ system.next.prev := result;\r
+ system.next := result;\r
+ end AddToSystem;\r
+ \r
+ (*********************************)\r
+ \r
+ unit DeleteFromSystem: procedure\r
+ (p:Rfile);\r
+ begin\r
+ if p = system then return fi;\r
+ p.next.prev := p.prev;\r
+ p.prev.next := p.next\r
+ end DeleteFromSystem;\r
+ \r
+ (********************************)\r
+ \r
+ unit FindFileLength: function\r
+ (p: file, recl:integer): integer;\r
+ \r
+ (* odtwarza dlugosc istniejacego pliku,\r
+ recl - dlugosc rekord w slowach *)\r
+ \r
+ var record: arrayof integer, i:integer;\r
+ begin\r
+ if p = none then \r
+ write(" FS - FindFileLength - ");\r
+ writeln("file object does not exist");\r
+ return;\r
+ fi; \r
+ result := 1;\r
+ call reset(p);\r
+ array record dim (1:recl);\r
+ i := recl*intsize;\r
+ do\r
+ getrec(p,record,i);\r
+ if i =/= recl*intsize then exit fi;\r
+ result := result + 1;\r
+ od;\r
+ end FindFileLength; \r
+\r
+\r
+ \r
+ \r
+\r
+ \r
+(*****************************************************************) \r
+ \r
+(* M A K E F I L E *)\r
+ \r
+ (* utworzenie i dolaczenie do systemu nowego pliku\r
+ o zadanej nazwie i dlugosci rekordu *)\r
+\r
+\r
+ \r
+ unit makefile: function \r
+ ( name: arrayof char (* nazwa zewnetrzna pliku *),\r
+ reclen: integer (* dlugosc rekordu pliku *) ): Rfile;\r
+ \r
+ begin\r
+ if FindInSystem(name) =/= none\r
+ (* istnieje w systemie plik o tej nazwie *)\r
+ then\r
+ writeln(" FS - makefile - file name duplicated"); \r
+ fi;\r
+ if reclen <= 0 \r
+ then \r
+ writeln(" FS - makefile - record length should be possitive"); \r
+ fi;\r
+ result := AddToSystem(name); \r
+ result.opened := true;\r
+ result .reclen := reclen;\r
+ result.position := 1;\r
+ result.length := 1;\r
+ open (result.plik, direct, name);\r
+ call rewrite(result.plik);\r
+ end makefile; \r
+ \r
+ \r
+(***************************************************************)\r
+\r
+(* O P E N F I L E *)\r
+\r
+ (* otwarcie i ewentualne dolaczenie do systemu \r
+ pliku o zadanej nazwie zewnetrznej i rozmiarze\r
+ rekordu *)\r
+\r
+\r
+\r
+ unit openfile: function\r
+ (name: arrayof char (* nazwa zewnetrzna pliku *),\r
+ reclen: integer (* dlugosc rekordu pliku *) ): Rfile;\r
+ \r
+ begin\r
+ if reclen <= 0 \r
+ then\r
+ writeln(" FS - openfile - record length should be possitive"); \r
+ fi;\r
+ result := FindInSystem(name);\r
+ if result = none then result := AddToSystem(name) fi;\r
+ result.opened := true;\r
+ result.reclen := reclen;\r
+ result.position := 1;\r
+ open(result.plik, direct, name);\r
+ result.length := FindFileLength(result.plik,reclen);\r
+ if result.length = 1 then call rewrite(result.plik)\r
+ else call reset(result.plik) fi;\r
+ end openfile;\r
+ \r
+ \r
+(***************************************************************)\r
+\r
+(* C L O S E F I L E *)\r
+\r
+ (* zamkniecie pliku z usunieciem obiektu pliku ;\r
+ obiekt typu Rfile pozostaje w systemie z odpowiednia\r
+ adnotacja *)\r
+ \r
+\r
+ unit closefile: procedure (p:Rfile);\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - closefile - closing nonexisting file"); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - closefile - closing not opened file"); \r
+ fi;\r
+ p. opened := false;\r
+ kill(p.plik)\r
+ end closefile;\r
+ \r
+\r
+\r
+(****************************************************************) \r
+ \r
+(* I S O P E N *)\r
+\r
+ (* sprawdzenie, czy plik jest otwarty *)\r
+ \r
+ \r
+ unit isopen: function( p:Rfile): boolean;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - isopen - testing nonexisting file"); \r
+ fi;\r
+ result := p.opened\r
+ end isopen;\r
+ \r
+ \r
+(****************************************************************)\r
+\r
+(* F R E W I N D *)\r
+\r
+ (* przewiniecie pliku do poczatku *)\r
+ \r
+\r
+ unit frewind: procedure( p:Rfile);\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - frewind - rewinding nonexisting file"); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - frewind - rewinding net opened file"); \r
+ fi;\r
+ p.position := 1;\r
+ call reset(p.plik)\r
+ end frewind;\r
+ \r
+ \r
+(**************************************************************) \r
+\r
+(* F E O F *)\r
+\r
+ (* test, czy koniec pliku *)\r
+ \r
+\r
+ unit feof: function(p: Rfile): boolean;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - feof - testing nonexisting file"); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - feof - testing not opened file"); \r
+ fi;\r
+ result := ( p.position >= p.length )\r
+ end feof;\r
+ \r
+ \r
+(**************************************************************)\r
+\r
+(* F P U T *)\r
+\r
+ (* wlozenie rekordu na plik w miejsce wskazane przez\r
+ atrybut position *)\r
+ \r
+ \r
+\r
+ unit fput: procedure( p: Rfile, Record: arrayof integer);\r
+ \r
+ var ile, i : integer;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - fput - file does not exist"); i:= inchar;\r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - fput - file not opened"); \r
+ fi;\r
+ if p.position > p.length \r
+ then\r
+ writeln(" FS - fput - try to access after file length"); \r
+ fi;\r
+ if Record = none \r
+ then\r
+ writeln(" FS - fput - record does not exist");\r
+ fi;\r
+ ile := upper(Record) - lower(Record) + 1;\r
+ if ile =/= p.reclen \r
+ then\r
+ writeln(" FS - fput - wrong record length"); \r
+ fi;\r
+ i := ile * intsize;\r
+ putrec(p.plik, Record, i);\r
+ if i =/= ile * intsize \r
+ then\r
+ writeln(" FS - fput - error during writing "); \r
+ fi;\r
+ p.position := p.position + 1;\r
+ if p.position > p.length then p.length := p.position fi;\r
+ end fput;\r
+ \r
+ \r
+(**************************************************************)\r
+\r
+(* F G E T *)\r
+\r
+ (* odczytanie rekordu z pliku z miejsca wskazywanego\r
+ przez atrybut position *)\r
+ \r
+ \r
+ unit fget: function( p: Rfile): arrayof integer;\r
+ var Record: arrayof integer, \r
+ ile, i : integer;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - fget - file does not exist "); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - fget - file not opened"); \r
+ fi;\r
+ if p.position >= p.length \r
+ then\r
+ writeln(" FS - fget - try to read past eof"); \r
+ fi;\r
+ ile := p.reclen;\r
+ array Record dim (1:ile);\r
+ i := ile * intsize;\r
+ getrec(p.plik, Record, i);\r
+ if i =/= ile * intsize \r
+ then\r
+ writeln(" FS - fget - error during reading"); \r
+ fi;\r
+ p.position := p.position + 1;\r
+ result := Record;\r
+ end fget;\r
+ \r
+ \r
+ \r
+(*************************************************************)\r
+\r
+(* F S E E K *)\r
+\r
+ (* wyszukanie w pliku rekordu o zadanym numerze -\r
+ ustawienie atrybutu position *)\r
+ \r
+\r
+\r
+ unit fseek: procedure( p: Rfile, nrrec: integer);\r
+ \r
+ var offset: integer;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - fseek - file does not exist"); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - fseek - file not opened"); \r
+ fi;\r
+ if nrrec <= 0 \r
+ then\r
+ writeln(" FS - fseek - record number should be positive"); \r
+ fi;\r
+ if nrrec > p.length \r
+ then\r
+ writeln(" FS - fseek - try to access after file length"); \r
+ fi;\r
+ p.position := nrrec;\r
+ offset := (nrrec - 1) * p.reclen * intsize;\r
+ call seek(p.plik, offset, 0)\r
+ end fseek;\r
+ \r
+ \r
+ \r
+(************************************************************)\r
+\r
+(* P O S I T I O N *)\r
+\r
+ (* answeres the current position of file pointer *)\r
+ \r
+\r
+ unit position: function( p: Rfile): integer;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - position - checking nonexisting file"); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - position - checking not opened file"); \r
+ fi;\r
+ result := p.position\r
+ end position;\r
+ \r
+ \r
+(************************************************************)\r
+\r
+(* F I L E L E N *)\r
+\r
+ (* gives the file length - the number of position\r
+ immediately after the last one *)\r
+ \r
+\r
+ unit filelen: function( p: Rfile): integer;\r
+ begin\r
+ if p = none \r
+ then\r
+ writeln(" FS - filelen - checking nonexisting file"); \r
+ fi;\r
+ if not p.opened \r
+ then\r
+ writeln(" FS - filelen - checking not opened file"); \r
+ fi;\r
+ result := p.length\r
+ end filelen;\r
+ \r
+ \r
+(**************************************************************)\r
+(**************************************************************)\r
+ \r
+ \r
+\r
+\r
+ \r
+ \r
+ \r
+ \r
+ begin (* of FileSystem *)\r
+ system := new Rfile;\r
+ system.next, system.prev := system;\r
+ end FileSystem;\r
+\r
+(***************************************************************)\r
+(* Pakiet Grafiki Blokowej *)\r
+(* *)\r
+(* *)\r
+(* *)\r
+(* *)\r
+(***************************************************************)\r
+ unit Bold : procedure;\r
+ begin\r
+ write( chr(27), "[1m")\r
+ end Bold;\r
+ \r
+ unit Blink : procedure;\r
+ begin\r
+ write( chr(27), "[5m")\r
+ end Blink;\r
+ \r
+ unit Reverse : procedure;\r
+ begin\r
+ write( chr(27), "[7m")\r
+ end Reverse;\r
+\r
+ unit Normal : procedure;\r
+ begin\r
+ write( chr(27), "[0m")\r
+ end Normal;\r
+ \r
+ unit Underscore : procedure;\r
+ begin\r
+ write( chr(27), "[4m")\r
+ end Underscore;\r
+\r
+ \r
+\r
+ unit inchar : IIuwgraph function : integer;\r
+ (*podaj nr znaku przeslanego z klawiatury *)\r
+ var i : integer;\r
+ begin\r
+ do\r
+ i := inkey;\r
+ if i <> 0 then exit fi;\r
+ od;\r
+ result := i;\r
+ end inchar;\r
+ \r
+ unit NewPage : procedure;\r
+ begin\r
+ write( chr(27), "[2J")\r
+ end NewPage;\r
+ \r
+ unit SetCursor : procedure(row, column : integer);\r
+ var c,d,e,f : char,\r
+ i,j : integer;\r
+ begin\r
+ i := row div 10;\r
+ j := row mod 10;\r
+ c := chr(48+i);\r
+ d := chr(48+j);\r
+ i := column div 10;\r
+ j := column mod 10;\r
+ e := chr(48+i);\r
+ f := chr(48+j);\r
+ write( chr(27), "[", c, d, ";", e, f, "H")\r
+ end SetCursor;\r
+(***************************************************************)\r
+(* koniec Grafiki *) \r
+(***************************************************************)\r
+\r
+unit HandlerOfRelations : FileSystem class(PageSize: integer,\r
+ TreeHeight: integer,\r
+ HalfPageSize : integer) ;\r
+ signal signal8, (*przekroczono wysokosc TreeHeight *)\r
+ signal14, (*dwa identyczne klucze o jednakowych ref*)\r
+ Signal13; (*sygnal usuwania nieobecnego rekordu*)\r
+ signal Signal11, (*nie ma poprzednika w PrevKey*)\r
+ Signal12; (*nie ma nastepnika w NextKey*)\r
+\r
+ \r
+ unit Node : class;\r
+ (*klasa prefiksujaca wszystkie klasy wykorzystywane w\r
+ interpreterze*)\r
+ var Gender:integer \r
+ begin\r
+ end Node;\r
+\r
+(* unit ObjectToRec : function (n : Node) : arrayof integer;\r
+ end ObjectToRec;\r
+\r
+ unit RecToObject : function(a: arrayof integer) : Node;\r
+ end RecToObject;*)\r
+\r
+(*struktura logiczna\r
+\r
+ DataFile\r
+ / | \\r
+ Atrybut \ . \r
+ | Relation \ | \r
+ | \ |\r
+ | |\r
+ | |IndexFile | |\r
+ | | | |\r
+ | _______________________ | *)\r
+\r
+\r
+\r
+ (********************************************\r
+ * * \r
+ * DataFile * \r
+ * * \r
+ * Reset * \r
+ * AddRec * \r
+ * DelRec * \r
+ * FindRec * \r
+ * FreePlace * \r
+ * * \r
+ * * \r
+ ********************************************)\r
+\r
+ unit DataFile : Node class;\r
+ (*typ DataFile jest wspolnym prefiksem dla Atrybut i\r
+Relation i IndexFile. Ten typ umo*liwia operacje\r
+ Wstaw Rekord, UsunRekord etc. *)\r
+ var plik : Rfile;\r
+ var FreePlace : integer; (* pozycja wolnego miejsca \r
+ w pliku*)\r
+\r
+\r
+ unit Reset : procedure ;\r
+ begin\r
+ call fseek(plik,1);\r
+ end Reset;\r
+\r
+ unit AddRec : procedure (input Record:arrayof integer; \r
+ output RefRec:integer);\r
+ (*Procedura wstawia rekord Record do DataFile i zwraca\r
+jego pozycje w pliku wykorzystujac przy tym informacje o\r
+wolnych miejscach zapamietana na stosie FreePlace*)\r
+\r
+ var AuxRec: arrayof integer;\r
+ begin\r
+ array AuxRec dim(lower(Record):upper(Record));\r
+ if FreePlace=0 \r
+ then\r
+ RefRec:=FileLen(plik);\r
+ (*jesli nie bylo usunietych rekordow, to Record\r
+ zapiszemy na koncu pliku*)\r
+ else\r
+ RefRec:=FreePlace;\r
+ call fseek(plik,RefRec);\r
+ AuxRec:=fget(plik);(*odczytanie pozycji poprzed\r
+ niego wolnego miejsca, ktore \r
+ bedzie teraz aktualnym wolnym miejscem*)\r
+ FreePlace:=AuxRec(1);\r
+ fi; \r
+ call fseek(plik,RefRec);\r
+ call fput(plik,Record)\r
+ end AddRec;\r
+\r
+ unit DelRec: procedure(input DataRef: integer);\r
+ (*Procedura usuwa rekord wskazany przez DataRef i wpisuje\r
+na jego miejsce referencje do ostatniego wolnego miejsca.\r
+Pozycja usunietego rekordu jest zapamietana na stosie \r
+FreePlace *)\r
+\r
+ var AuxRec: arrayof integer;\r
+ begin\r
+ call fseek(plik,DataRef);\r
+ array AuxRec dim (1 : plik.reclen);\r
+ AuxRec(1):=FreePlace;\r
+ call fput(plik,AuxRec);\r
+ FreePlace:=DataRef;\r
+ end DelRec;\r
+ \r
+ unit FindRec:procedure(input Record:arrayof integer;\r
+ output RefRec : integer);\r
+(*Procedura FindRec odszukuje rekord wskazany przez Record\r
+i zwraca jego pozycje w pliku*)\r
+ var equal :boolean,\r
+ i, Place: integer, \r
+ AuxRec: arrayof integer;\r
+ begin\r
+ array AuxRec dim(lower(Record): upper(Record));\r
+ call Reset;\r
+ equal:=false;\r
+ while (not feof(plik) and not equal)\r
+ do\r
+ RefRec := position(plik);\r
+ AuxRec:= fget(plik);\r
+ for i:=lower(AuxRec) to upper(AuxRec)\r
+ do\r
+ equal:= AuxRec(i)=Record(i);\r
+ if not equal then exit fi\r
+ od (*koniec porownywania rekordow*);\r
+ (* czy znaleziony jest usunietym wczesniej rekordem? *) \r
+ if (equal and FreePlace <> 0)\r
+ then\r
+ Place:=FreePlace;\r
+ while not Place=0 \r
+ do\r
+ if RefRec = Place \r
+ then\r
+ equal:=false;\r
+ exit (*if equal*)\r
+ else\r
+ call fseek(plik,Place);\r
+ AuxRec:=fget(plik);\r
+ Place:=AuxRec(1)\r
+ fi;\r
+ od;\r
+ call fseek(plik,RefRec+plik.reclen);\r
+ fi (*if equal*);\r
+ od (*eof plik*);\r
+ if not equal\r
+ then \r
+ RefRec:=-1(*nie znalezlismy rekordu*)\r
+ fi; \r
+ end FindRec;\r
+\r
+ begin (*DataFile*)\r
+\r
+ FreePlace:=0\r
+ end DataFile;\r
+\r
+(*\r
+ ********************************************\r
+ * Relation *\r
+ * *\r
+ * insert *\r
+ * delete *\r
+ * retrieve *\r
+ * member *\r
+ * close *\r
+ * open *\r
+ * allocate *\r
+ * deallocate *\r
+ * *\r
+ ********************************************\r
+*)\r
+unit Relation : DataFile class ;\r
+ var Index :arrayof IndexFile;\r
+\r
+ unit Tuple : Node class;\r
+ (*element relacji*)\r
+ end Tuple;\r
+ \r
+ unit virtual TupleToRec : function (t : Tuple): arrayof\r
+ integer;\r
+ end TupleToRec ;\r
+\r
+ unit virtual RecToTuple : function(a : arrayof integer):\r
+ Tuple;\r
+ end RecToTuple;\r
+\r
+\r
+\r
+ unit Insert: procedure (t: Tuple);\r
+ var i,PageRef,DataRef:integer;\r
+ var AuxRec : arrayof integer; \r
+ begin\r
+ AuxRec:=TupleToRec(t);\r
+ call AddRec(AuxRec, DataRef);\r
+ if Index <> none\r
+ then\r
+ for i:=1 to upper(Index) \r
+ do\r
+ if Index(i)<>none \r
+ then\r
+ call Index(i).AddKey(Index(i).KeyOf(t),DataRef)\r
+ fi\r
+ od;\r
+ fi;\r
+ end Insert;\r
+\r
+ unit Delete : procedure (t: Tuple);\r
+ var i,DataRef :integer,\r
+ AuxRec : arrayof integer;\r
+ begin\r
+ if Index =/= none\r
+ then (*najpierw szukamy w indeksach i usuwamy tam*)\r
+ for i:=1 to upper(Index) \r
+ do\r
+ if none <> Index(i) \r
+ then\r
+ DataRef := Index(i).FindKey(Index(i).KeyOf(t));\r
+ call Index(i).DelKey(Index(i).KeyOf(t),DataRef);\r
+ (* \r
+DelKey dziala? *)\r
+ fi;\r
+ od\r
+ else (*brak indeksu*)\r
+ AuxRec := TupleToRec(t);\r
+ call FindRec(AuxRec, DataRef); \r
+ fi;\r
+ if DataRef = -1\r
+ then\r
+ raise Signal13 (*proba usuniecia rekordu ktorego nie ma*)\r
+ else\r
+ call DelRec(DataRef) ; (*wstawic na liste usuniec*)\r
+ fi\r
+ end Delete;\r
+\r
+\r
+ (* ********************************************\r
+ * IndexFile *\r
+ * *\r
+ * Key *\r
+ * Order *\r
+ * Item *\r
+ * Page *\r
+ * Addkey *\r
+ * DelKey *\r
+ * NextKey *\r
+ * FindKey *\r
+ * SearchKey *\r
+ * PrevKey *\r
+ * MinKey *\r
+ * MaxKey *\r
+ * Path *\r
+ * CloseIndex *\r
+ ********************************************\r
+*)\r
+\r
+unit IndexFile : DataFile coroutine;\r
+\r
+\r
+ unit SearchStep: class;\r
+ var PageRef,RefOnPage : integer,\r
+ updated : boolean;\r
+ end SearchStep;\r
+ \r
+ unit Item : class ;\r
+ var ky: key, PageRef: integer, DataRef: integer;\r
+ (* item jest jednostka ( rekordem) przechowywana w\r
+ indeksie na stronie tzn.Page\r
+ zawiera:\r
+ ky - klucz,\r
+ PageRef - informacje o stronie na ktorej znajduje sie\r
+ korzen poddrzewa z kluczami wiekszymi od klucza kl,\r
+ a mniejszymi od kluczy podporzadkowanych sasiadowi z\r
+ lewej,\r
+ DataRef - informacja w ktorym rekordzie zapisano\r
+ krotke odpowiadajaca naszemu kluczowi ky*)\r
+ end Item;\r
+\r
+ unit Page: class;\r
+ var ItemsOnPage, (*ilu synow ma ta strona +1*)\r
+ LessPageRef: integer; (*wskaznik do poddrzewa elementow\r
+mniejszych od pierwszego klucza na tej stronie*)\r
+ var ItemsArray: arrayof Item;\r
+ begin\r
+ array ItemsArray dim (1:PageSize)\r
+ end Page;\r
+ \r
+ var KeySize: integer;\r
+ \r
+ unit key : Node class ;\r
+ (*definicja klucza zgodnie z zyczeniem uzytkownika*)\r
+ end key;\r
+\r
+\r
+ var StackOfPages: arrayof Page;\r
+ var Finger: integer; (*zmienne StackOfPages i Finger \r
+ implementuja stos stron*)\r
+ var Path: arrayof SearchStep; (*zmienne Path i Finger\r
+ implementuja sciezke*)\r
+\r
+(* axiom: nr strony wskazanej przez Finger w StackOfPages jest\r
+ identyczny z numerem strony wskazanym przez Finger w Path*)\r
+\r
+ unit virtual KeyOf : function (t : Tuple) : key;\r
+ (*KeyOf tworzy z dowolnej krotki klucz zaleznie od\r
+ rozwazanego indeksu*)\r
+ end KeyOf;\r
+\r
+ unit virtual Leq: function (k1,k2 : key):Boolean;\r
+ (* Leq sprawdza czy krotki k1,k2 sa w relacji\r
+ obowiazujacej w rozwazanym indeksie\r
+ zakladamy, ze jest to relacja antysymetryczna*)\r
+ end Leq;\r
+\r
+\r
+ unit AddKey : procedure (input ky:key,DataRef:integer);\r
+ (*wstawienie klucza ky i referencji DataRef do indexu w odpowiednie \r
+ miejsce w B-drzewie\r
+ DataRef jest adresem rekordu ktory odpowiada kluczowi \r
+ w pliku relacji*)\r
+ var depth, (*aktualna glebokosc stosu stron*)\r
+ PageRef,\r
+ i : integer,\r
+ AddItem, AuxItem, itm2 : Item,\r
+ IncreaseHeight : boolean,\r
+ NewRoot : Page,\r
+ AuxRec : arrayof integer;\r
+ \r
+ unit Search : procedure (input itm1 : Item, PageRef :\r
+ integer;\r
+ output include : boolean, itm2 :\r
+ Item);\r
+ (*szukaj poczawszy od strony PageRef, miejsca dla itm1;\r
+ jezeli nie znajdzie miejsca na tej stronie to\r
+rekurencyjnie szuka na nastepnej odpowiedniej az do\r
+liscia;\r
+ jezeli include to WSTAWIA obiekt itm2*)\r
+ \r
+ var NextPageRef, \r
+ ItemRef : integer,\r
+ inclde : boolean,\r
+ item2 : Item,\r
+ AuxPage : Page;\r
+ \r
+ unit Insert : procedure;\r
+ (*wstawia obiekt itm2 na strone PageRef w miejscu ItemRef*)\r
+ var OldPage, RightPage : Page,\r
+ AuxRec : arrayof integer,\r
+ AuxItmArr ,\r
+ AuxItmArr2 : arrayof Item,\r
+ RightPageRef, \r
+ i : integer;\r
+ begin (*Insert*)\r
+ OldPage := StackOfPages(Finger);\r
+ if OldPage.ItemsOnPage < PageSize\r
+ then (*jest miejsce na tej stronie *)\r
+ call UpdatePage (item2, ItemRef, OldPage);\r
+ Path(Finger).RefOnPage := ItemRef + 1;\r
+ include := false;\r
+ else (*strona jest pelna dokonujemy podzialu *)\r
+ include := true;\r
+ OldPage.ItemsOnPage := HalfPageSize;\r
+ Path(Finger).updated := true;\r
+ RightPage := new Page;\r
+ RightPage.ItemsOnPage := HalfPageSize;\r
+ array RightPage.ItemsArray dim (1:PageSize);\r
+ AuxItmArr := OldPage.ItemsArray;\r
+ AuxItmArr2 := RightPage.ItemsArray;\r
+ if ItemRef = HalfPageSize \r
+ then (*obiekt itm2=item2 idzie do gory*)\r
+ for i := 1 to HalfPageSize\r
+ do \r
+ AuxItmArr2(i):=AuxItmArr(i+HalfPageSize) \r
+ od;\r
+ itm2:= item2;\r
+ else (*to nie item2 idzie do gory *)\r
+ if ItemRef < HalfPageSize\r
+ then (*wstawiamy do lewej strony*)\r
+ for i := 1 to HalfPageSize\r
+ do \r
+ AuxItmArr2(i) :=\r
+ AuxItmArr(i+HalfPageSize)\r
+ od;\r
+ itm2 := AuxItmArr(HalfPageSize);\r
+ for i := HalfPageSize-1 downto ItemRef+1 \r
+ do \r
+ AuxItmArr(i+1) := \r
+ AuxItmArr(i)\r
+ od;\r
+ AuxItmArr(ItemRef+1) := item2;\r
+ else (*ItemRef>HalfPageSize *)\r
+ itm2 := AuxItmArr(HalfPageSize+1);\r
+ for i := HalfPageSize+2 to ItemRef\r
+ do \r
+ AuxItmArr2(i-HalfPageSize-1) :=\r
+ AuxItmArr(i)\r
+ od;\r
+ AuxItmArr2(ItemRef-HalfPageSize)\r
+ := item2;\r
+\r
+ for i := ItemRef+1 to PageSize\r
+ do \r
+ AuxItmArr2(i-HalfPageSize) := \r
+ AuxItmArr(i)\r
+ od;\r
+ fi (*ItemRef < HalfPageSize *)\r
+ fi (*ItemRef = HalfPagSize *);\r
+(*****) (* StackOfPages(finger) := OldPage; *)\r
+ call fseek(plik,Path(Finger).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(Finger))); \r
+ RightPage.LessPageRef := itm2.PageRef;\r
+ AuxRec :=PageToRec(RightPage);\r
+ call AddRec(AuxRec,RightPageRef);\r
+ itm2.PageRef :=RightPageRef;\r
+ fi (* *)\r
+ end Insert;\r
+\r
+ \r
+ begin (*Search*)\r
+\r
+ if PageRef = -1\r
+ then (*poprzednia strona jest lisciem, nalezy do niej\r
+ wstawic itm1 ale z PageRef = -1*) \r
+ include := true;\r
+ itm2 := itm1;\r
+ itm2.PageRef := -1;\r
+ else (*przeszukaj te strone*)\r
+ Finger, depth := Finger+1;\r
+ call GetPage (PageRef);\r
+ AuxPage := StackOfPages (Finger);\r
+ call SearchPage (AuxPage, itm1, NextPageRef, ItemRef);\r
+ call Search(itm1, NextPageRef, include, item2);\r
+ if include\r
+ then (*wstawic obiekt item2 na strone PageRef w miejsce\r
+ ItemRef; jezeli na tej stronie wystarczy miejsca\r
+ na nowy obiekt to wstawic go i zgasic include;\r
+ jezeli brakuje miejsca to strone dzielimy i\r
+ include pozostawiamy zapalone, nowy item itm2 ma\r
+ byc wstawiony na wyzszej stronie *)\r
+ call Insert; \r
+ fi (*include*);\r
+ Finger := Finger -1;\r
+ fi (*PageRef=-1*);\r
+ end Search;\r
+\r
+ \r
+ begin (*AddKey*)\r
+ (*szukaj w korzeniu i powtarzaj rekurencyjnie w odp.\r
+ poddrzewach, gdy znajdziesz to sygnal blad\r
+ w przeciwnym przypadku*)\r
+ Path(1).updated := true; \r
+ AuxItem := new Item;\r
+ AuxItem.ky := ky;\r
+ AuxItem.DataRef := DataRef;\r
+ AuxItem.PageRef := -1;\r
+ Finger := 0;\r
+ call Search(AuxItem, Path(1).PageRef,\r
+ IncreaseHeight, AddItem);\r
+ if IncreaseHeight\r
+ then (*korzen podzielony, dodajemy nowy korzen*)\r
+ NewRoot := new Page;\r
+ NewRoot.ItemsOnPage := 1;\r
+ NewRoot.LessPageRef := Path(1).PageRef;\r
+ (*adres prawej czesci starego korzenia*)\r
+ array NewRoot.ItemsArray dim (1:PageSize);\r
+ NewRoot.ItemsArray(1) := AddItem;\r
+ if depth+1 > TreeHeight\r
+ then (*przekroczono dopuszczalna wysokosc drzewa*)\r
+ raise Signal8 \r
+ fi;\r
+ for i := 1 to depth\r
+ do \r
+ StackOfPages(i+1) := StackOfPages(i);\r
+ Path(i+1) := Path(i);\r
+ od;\r
+ StackOfPages(1) := NewRoot;\r
+ Path(1) := new SearchStep;\r
+ Path(1).RefOnPage := 1;\r
+ Path(1).updated := true;\r
+ AuxRec :=PageToRec(NewRoot);\r
+ call AddRec(AuxRec, PageRef);\r
+ Path(1).PageRef := PageRef (*adres nowego korzenia*) ;\r
+ Finger := depth+1;\r
+ else\r
+ Finger := depth;\r
+ fi (*IncreaseHeight*); \r
+\r
+ end AddKey;\r
+ \r
+\r
+\r
+\r
+(*AXIOM po wykonaniu dowolnej operacji zmieniajacej Finger\r
+ Finger i Path pokazuja na sciezce jakis item w ktorym jest\r
+ klucz tzn. item dla ktorego RefOnPage =/= 0*)\r
+\r
+ unit PrevKey : procedure (output ky:key, DataRef:integer);\r
+ (*ky jest bezposrednim poprzednikiem klucza biezacego\r
+wskazanego przez Path. DataRef wskazuje referencje do\r
+krotki odpowiadajacej ky w pliku danych*)\r
+ var AuxPage : Page,\r
+ AuxRec : arrayof integer,\r
+ PageRef, nextPageRef,\r
+ RefOnPage : integer;\r
+ begin (*Zakladamy, ze biezacy klucz jest wskazany przez \r
+ Path(Finger)*) \r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ PageRef:=Path(Finger).PageRef;\r
+ AuxPage:=StackOfPages(Finger);\r
+ if AuxPage.LessPageRef = -1\r
+ then (*jestesmy w lisciu*)\r
+ if RefOnPage <> 1\r
+ then (*poprzednikiem jest sasiad z lewej*)\r
+ RefOnPage := RefOnPage -1;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ else (*RefOnPage = 1*)\r
+ if Finger =1\r
+ then (*to jest korzen*)\r
+ ky:=AuxPage.ItemsArray(RefOnPage).ky;\r
+ DataRef:=AuxPage.ItemsArray(RefOnPage).DataRef;\r
+ raise signal11; (*nie ma poprzednika*)\r
+ return;\r
+ else\r
+ RefOnPage := 0;\r
+ while Finger <> 1 and RefOnPage = 0 \r
+ do\r
+ Finger := Finger-1;\r
+ Auxpage := StackOfPages(Finger);\r
+ RefOnPage := Path(Finger).RefOnPage\r
+ od;\r
+ if Finger = 1 and RefOnPage = 0\r
+ then\r
+ ky:=AuxPage.ItemsArray(1).ky;\r
+ DataRef:=AuxPage.ItemsArray(1).DataRef;\r
+ raise signal11; (*nie ma poprzednika*)\r
+ return;\r
+ fi;\r
+ fi (* Finger = 1 *);\r
+ fi (* RefOnPage <> 1 *);\r
+ else (*to nie jest lisc*)\r
+ if RefOnPage = 1\r
+ then\r
+ nextPageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0 \r
+ else\r
+ RefOnPage := RefOnPage -1;\r
+ nextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ fi;\r
+ while nextPageRef <> -1 (*szukamy najwiekszego syna*) \r
+ do\r
+ Finger := Finger +1;\r
+ PageRef := nextPageRef;\r
+ call GetPage(PageRef);\r
+ AuxPage := StackOfPages(Finger);\r
+ RefOnPage, Path(Finger).RefOnPage :=\r
+ Auxpage.ItemsOnPage;\r
+ nextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef\r
+ od;\r
+ fi;\r
+ ky:=AuxPage.ItemsArray(RefOnPage).ky;\r
+ DataRef:=AuxPage.ItemsArray(RefOnPage).DataRef\r
+ end PrevKey;\r
+\r
+\r
+ unit MinKey : procedure (output k:Key, DataRef : integer);\r
+ (*ustawia Pointer do indexu i Path tak by pokazywaly\r
+najmniejszy klucz. k - jest najmniejszym kluczem w\r
+rozwazanym indeksie, DataRef jest odpowiadajaca mu\r
+referencja do rekordu w pliku glownym relacji*)\r
+\r
+ var PageRef : integer,\r
+ AuxPage : Page,\r
+ AuxItem : Item;\r
+\r
+ begin\r
+ Finger :=1;\r
+ do\r
+ AuxPage := StackOfPages(Finger);\r
+ PageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0;\r
+ if PageRef = -1 then exit fi;\r
+ Finger := Finger +1;\r
+ call GetPage(PageRef);\r
+ od;\r
+ AuxItem := AuxPage.ItemsArray(1);\r
+ k := AuxItem.ky;\r
+ DataRef := AuxItem.DataRef;\r
+ Path(Finger).RefOnPage := 1;\r
+\r
+ end MinKey;\r
+\r
+ unit MaxKey : procedure( output k:Key, DataRef: integer);\r
+(*ustawia Pointer do indexu i Path tak by pokazywaly\r
+najwiekszy klucz*)\r
+ var PageRef, n : integer,\r
+ AuxPage : Page;\r
+\r
+ begin\r
+ Finger :=1;\r
+ do \r
+ AuxPage := StackOfPages(Finger);\r
+ Path(Finger).RefOnPage, n :=\r
+ AuxPage.ItemsOnPage ;\r
+ PageRef := AuxPage.ItemsArray(n).PageRef;\r
+ if PageRef = -1 then exit fi;\r
+ Finger := Finger+1;\r
+ call GetPage(PageRef);\r
+ od;\r
+ k := AuxPage.ItemsArray(n).Ky;\r
+ DataRef := AuxPage.ItemsArray(n).DataRef;\r
+\r
+ end MaxKey;\r
+\r
+\r
+\r
+(*************************************************************************)\r
+\r
+ \r
+ unit NextKey: procedure (output ky:key,DataRef:integer);\r
+(*referencja DataRef do bezposredniego nastepnika biezacej\r
+ pozycji\r
+ ky jest bezposrednim nastepnikiem klucza biezacego\r
+ wskazanego przez Path. DataRef wskazuje referencje do\r
+ krotki odpowiadajacej ky w pliku danych*)\r
+ var AuxPage : Page,\r
+ AuxItem : Item,\r
+ PageRef,nextPageRef,\r
+ RefOnPage : integer;\r
+ begin (*Zakladamy, ze biezacy klucz jest wskazany przez\r
+ Path(Finger) *)\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ PageRef := Path(Finger).PageRef;\r
+ AuxPage:=StackOfPages(Finger);\r
+\r
+ if AuxPage.LessPageRef = -1\r
+ then (*jestesmy w lisciu*)\r
+ while Finger <> 1 and RefOnPage = AuxPage.ItemsOnPage \r
+ do\r
+ Finger := Finger - 1;\r
+ AuxPage := StackOfPages(Finger);\r
+ RefOnPage := Path(Finger).refOnPage\r
+ od;\r
+ if RefOnPage = AuxPage.ItemsOnPage\r
+ then\r
+ AuxItem := AuxPage.ItemsArray(RefOnPage); \r
+ DataRef := AuxItem.DataRef;\r
+ ky := AuxItem.ky;\r
+ raise signal12; (*nie ma nastepnika*)\r
+ return;\r
+ else\r
+ RefOnPage := RefOnPage+1;\r
+ Path(Finger).RefOnPage := RefOnPage\r
+ fi;\r
+ else (*to nie jest lisc*)\r
+ nextPageRef := AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ while nextPageRef <> -1 \r
+ do\r
+ Finger := Finger+1;\r
+ PageRef := NextPageRef;\r
+ call GetPage(PageRef);\r
+ AuxPage := StackOfPages(Finger);\r
+ Path(Finger).refOnPage := 0;\r
+ NextPageRef := AuxPage.LesspageRef\r
+ od;\r
+ RefOnPage := 1;\r
+ Path(Finger).RefOnPage := 1\r
+ fi;\r
+ AuxItem := AuxPage.ItemsArray(RefOnPage); \r
+ DataRef := AuxItem.DataRef;\r
+ ky := AuxItem.ky\r
+ end NextKey;\r
+\r
+ \r
+ unit DelKey : procedure (input ky:key,DataRef:integer);\r
+ (*usuwanie klucza ky, o referencji do pliku glownego\r
+ dataref, z indeksu, jezeli takiego klucza nie ma to\r
+ sygnal*)\r
+ var DataRef1: integer,\r
+ k: key,\r
+ underflw:boolean; (*true if underflow occurred*)\r
+\r
+ unit remove : procedure(output underflw:boolean);\r
+ var AuxPage,AuxPage1 :Page,\r
+ i,ItemsOnPage,RefOnPage,nextPageRef :integer;\r
+ begin\r
+ AuxPage:=StackOfPages(Finger);\r
+ i:=Finger;\r
+ Path(Finger).updated:=true;\r
+ RefOnPage := Path(Finger).RefOnPage;\r
+ \r
+ if AuxPage.LessPageRef <> -1\r
+ then (*to nie jest lisc*)\r
+ NextPageRef :=\r
+ AuxPage.ItemsArray(RefOnPage).PageRef;\r
+ while NextPageRef <> -1 \r
+ do\r
+ Finger := Finger+1;\r
+ call GetPage(NextPageRef);\r
+ AuxPage1 := StackOfPages(Finger);\r
+ Path(Finger).RefOnPage := 0;\r
+ NextPageRef := AuxPage1.LessPageRef\r
+ od;\r
+ Path(Finger).updated:=true;\r
+ Path(Finger).RefOnPage := 1;\r
+ AuxPage.ItemsArray(RefOnPage).ky:=\r
+ AuxPage1.ItemsArray(1).ky;\r
+ AuxPage.ItemsArray(RefOnPage).DataRef:=\r
+ AuxPage1.ItemsArray(1).DataRef;\r
+ StackOfPages(i):=AuxPage;(*wymienilam usuniety element*)\r
+ AuxPage:= AuxPage1;\r
+ RefOnPage:=1;\r
+ fi;(*jestesmy w lisciu*)\r
+\r
+ ItemsOnPage:= AuxPage.ItemsOnPage -1;\r
+ \r
+ for i:=RefOnPage to ItemsOnPage\r
+ do\r
+ AuxPage.ItemsArray(i):=AuxPage.ItemsArray(i+1)\r
+ od;\r
+ AuxPage.ItemsOnPage:= ItemsOnPage;\r
+ StackOfPages(Finger):=AuxPage;\r
+ if ItemsOnPage<HalfPageSize\r
+ then (*trzeba wywolac underflow*)\r
+ underflw:=true\r
+ fi\r
+ end remove;\r
+\r
+unit underflow: procedure(inout underflw:boolean);\r
+ (* Finger wskazuje strone A na ktorej jest niedomiar *)\r
+ var Itm:Item,\r
+ AuxPage,AuxPage1, AuxPage2:Page,\r
+ i,k,n,pb,lb,PageRef,RefOnPage: integer,\r
+ AuxRec: arrayof integer;\r
+ begin\r
+ call SetCursor(7,1); (*****************************)\r
+ writeln("underflow",Finger); \r
+ underflw:=false;\r
+ if Finger<>1 then\r
+ AuxPage:=StackOfPages(Finger);(*strona z niedomiarem*)\r
+ \r
+ Path(Finger).updated:=true ;\r
+ Path(Finger-1).updated:=true ; \r
+ AuxPage1:=StackOfPages(Finger-1); (*strona ojca*) \r
+ RefOnPage:=Path(Finger-1).RefOnPage; \r
+ if RefOnPage< AuxPage1.ItemsOnPage\r
+ then (*istnieje prawy stryj*)\r
+ k:=RefOnPage+1;\r
+ Itm:=AuxPage1.ItemsArray(k);\r
+ PageRef:=Itm.PageRef;\r
+ (*wczytanie strony-brata prawego na AuxPage2*)\r
+ call fseek(plik,PageRef);\r
+ AuxRec:=fget(plik);\r
+ AuxPage2:=RecToPage(AuxRec); \r
+ \r
+ Itm.PageRef:=AuxPage2.LessPageRef;\r
+ AuxPage.ItemsArray(AuxPage.ItemsOnPage+1):=Itm;\r
+ (*stryj schodzi do AuxPage*)\r
+ n:=AuxPage2.ItemsOnPage-HalfPageSize;\r
+\r
+ if n>0\r
+ then\r
+ n:=entier((n-1)/2);(* przelewamy n elementow *)\r
+ Itm:=AuxPage2.ItemsArray(n+1); \r
+ Itm.PageRef:=PageRef;\r
+ AuxPage1.ItemsArray(k):=Itm;\r
+ for i:=1 to n\r
+ do\r
+ AuxPage.ItemsArray(HalfPageSize+i):=\r
+ AuxPage2.ItemsArray(i) \r
+ od;\r
+ AuxPage.ItemsOnPage:=HalfPageSize+n;\r
+ StackOfPages(Finger):=AuxPage;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ k:=AuxPage2.ItemsOnPage-(n+1);\r
+\r
+ for i:=1 to k\r
+ do\r
+ AuxPage2.ItemsArray(i):=\r
+ AuxPage2.ItemsArray(n+1+i)\r
+ od;\r
+ AuxPage2.ItemsOnPage:=k; \r
+ AuxRec:=PageToRec(AuxPage2);(*zapamiet. AuxPage2*)\r
+ call fseek(plik,PageRef);\r
+ call fput(plik,AuxRec);\r
+ else\r
+ (*AuxPage2.ItemsOnPage=HalfPageSize tzn. n=0*)\r
+ for i:=1 to HalfPageSize\r
+ do\r
+ AuxPage.ItemsArray(HalfPageSize+i):=\r
+ AuxPage2.ItemsArray(i)\r
+ od;\r
+ AuxPage.ItemsOnPage:=PageSize;\r
+ for i:=RefOnPage+2 to AuxPage1.ItemsOnPage\r
+ do\r
+ AuxPage1.ItemsArray(i-1):=\r
+ AuxPage1.ItemsArray(i)\r
+ od;\r
+\r
+ AuxPage1.ItemsOnPage:=AuxPage1.ItemsOnPage-1;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage;\r
+ call DelRec(PageRef);\r
+ if AuxPage1.ItemsOnPage<HalfPageSize \r
+ then\r
+ Finger:=Finger-1;\r
+ underflw:=true;\r
+ (*niedomiar na stronie ojca*)\r
+ fi ;\r
+ fi (*n>0*)\r
+ \r
+ else (*nie ma prawego stryja, wez z lewej*)\r
+ if RefOnPage>1 \r
+ then\r
+ Itm:=AuxPage1.ItemsArray(RefOnPage-1);\r
+ PageRef:=Itm.PageRef;\r
+ else\r
+ PageRef:=AuxPage1.LessPageRef;\r
+ fi;\r
+ (*wczytanie strony-brata lewego na AuxPage2*)\r
+ call fseek(plik,PageRef);\r
+ AuxRec:=fget(plik);\r
+ AuxPage2:=RecToPage(AuxRec); (*str-brat lewy*)\r
+ \r
+ Itm:=AuxPage1.ItemsArray(RefOnPage);\r
+ Itm.PageRef:=AuxPage.LessPageRef;\r
+ n:=AuxPage2.ItemsOnPage-HalfPageSize;\r
+ if n>0\r
+ then\r
+ n:=entier((n-1)/2);\r
+ (*przesun o n+1 w prawo elem na str.AuxPage*)\r
+ k:=AuxPage.ItemsOnPage;\r
+ for i:=1 to n+1\r
+ do\r
+ AuxPage.ItemsArray(k+n+2-i):=\r
+ AuxPage.ItemsArray(k+1-i)\r
+ od;\r
+\r
+ AuxPage.ItemsArray(n+1):=Itm;\r
+ (*ojciec do AuxPage*)\r
+ AuxPage.ItemsOnPage:=k+n+1;\r
+ Itm:=AuxPage2.ItemsArray(HalfPageSize+n+1); \r
+ Itm.PageRef:=PageRef; (*referencja do AuxPage*)\r
+ AuxPage1.ItemsArray(RefOnPage):=Itm;\r
+ for i:=1 to n\r
+ do\r
+ AuxPage.ItemsArray(i):=\r
+ AuxPage2.ItemsArray(HalfPageSize+1+i+n) \r
+ od;\r
+ AuxPage.ItemsOnPage:=HalfPageSize+n;\r
+ AuxPage2.ItemsOnPage:= HalfPageSize+n;\r
+ \r
+ (*wyslac strony i zapisac sciezke i stos*)\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage;\r
+ (*zapamietanie strony AuxPage2*)\r
+ AuxRec:=PageToRec(AuxPage2);\r
+ call fseek(plik,PageRef);\r
+ call fput(plik,AuxRec);\r
+\r
+ else \r
+ (*n=o tzn.AuxPage2.ItemsOnPage=HalfPageSize*)\r
+ \r
+ AuxPage2.ItemsArray(HalfPageSize+1):=Itm;\r
+ for i:=1 to HalfPageSize-1\r
+ do\r
+ AuxPage2.ItemsArray(HalfPageSize+1+i):=\r
+ AuxPage.ItemsArray(i)\r
+ od;\r
+ AuxPage1.ItemsOnPage:=AuxPage1.ItemsOnPage-1;\r
+ AuxPage2.ItemsOnPage:=PageSize;\r
+ StackOfPages(Finger-1):=AuxPage1;\r
+ StackOfPages(Finger):=AuxPage2;\r
+ Path(Finger-1).RefOnPage:=RefOnPage-1;\r
+ call DelRec(Path(Finger).PageRef);\r
+ (*wyrzucono str AuxPage*)\r
+ Path(Finger).PageRef:=PageRef;\r
+ \r
+ if AuxPage1.ItemsOnPage<HalfPageSize\r
+ then\r
+ Finger:=Finger-1;\r
+ underflw:=true (*niedomiar na stronie ojca*)\r
+ fi;\r
+ fi (*n>0*)\r
+\r
+ fi(*lewy istnieje*) \r
+\r
+\r
+ else (*niedomiar jest w korzeniu*) \r
+ AuxPage:=StackOfPages(1);\r
+ if AuxPage.ItemsOnPage=0\r
+ then \r
+ call DelRec(Path(1).PageRef);\r
+ if AuxPage.LessPageRef<>-1\r
+ then\r
+ i:=2;\r
+ while Path(i)<>none\r
+ do\r
+ Path(i-1):=Path(i);\r
+ StackOfPages(i-1):=StackOfPages(i);\r
+ i:=i+1\r
+ od\r
+ else\r
+ writeln("drzewo znika ");\r
+ fi; \r
+ fi\r
+ fi (*Finger<>1*); \r
+ end underflow;\r
+\r
+ begin (*DelKey*)\r
+ k:=ky;\r
+ DataRef1:=FindKey(k);\r
+ do\r
+ if k=ky and DataRef=DataRef1\r
+ then\r
+ (*znalezlismy wlasciwy klucz *)\r
+ call remove(underflw);\r
+ while underflw \r
+ do \r
+ call underflow(underflw) \r
+ od;\r
+ return\r
+ else\r
+ if k<>ky or DataRef1= -1\r
+ then\r
+ writeln("* nie ma takiego klucza *")\r
+ else\r
+ call NextKey(k,DataRef1)\r
+ fi\r
+ fi\r
+ od \r
+ end DelKey;\r
+\r
+ \r
+ unit FindKey:function (k : key): integer;\r
+ (*wynikiem poszukiwania klucza k jest referencja do\r
+ datafile wskazujaca na krotke o danym kluczu. Gdy \r
+ nie znaleziono, wartoscia funkcji jest -1 *)\r
+ var PageRef,\r
+ i : integer,\r
+ AuxPage : Page,\r
+ Itms : arrayof Item,\r
+ k1 : Key;\r
+ begin\r
+ Finger := 1;\r
+ PageRef := Path(Finger).PageRef;\r
+ do\r
+ call GetPage( PageRef );\r
+ (*przeszukujemy strone o adresie Pageref*)\r
+ AuxPage := StackOfPages(Finger);\r
+ Itms := AuxPage.ItemsArray; \r
+ for i := AuxPage.ItemsOnPage downto 1\r
+ do\r
+ k1 := Itms(i).ky;\r
+ if leq(k1, k)\r
+ then\r
+ Path(Finger).RefOnPage := i;\r
+ if leq(k, k1)\r
+ then (*znaleziony*)\r
+ result := Itms(i).DataRef;\r
+ return\r
+ fi;\r
+ PageRef := Itms(i).PageRef;\r
+ exit;\r
+ else\r
+ if i =1\r
+ then (*klucz k jest mniejszy od wszystkich kluczy\r
+ na rozwazanej stronie*)\r
+ PageRef := AuxPage.LessPageRef;\r
+ Path(Finger).RefOnPage := 0;\r
+ fi;\r
+ fi;\r
+ od;\r
+ \r
+ if PageRef = -1\r
+ then (*jestesmy w lisciu, nie ma poszukiwanego klucza*)\r
+ if Path(Finger).RefOnPage = 0\r
+ then\r
+ Path(Finger).RefOnPage :=1\r
+ fi;\r
+ result := -1;\r
+ exit (*FindKey*)\r
+ else\r
+ Finger := Finger+1\r
+ fi;\r
+ od;\r
+ end FindKey;\r
+\r
+unit SearchKey: procedure(input k:key;\r
+ output DataRef : integer);\r
+(*referencja do klucza, ktory jest >=k *)\r
+begin\r
+ DataRef:=FindKey(k);\r
+ if DataRef=-1\r
+ then\r
+ call NextKey(k,DataRef)\r
+ fi\r
+end SearchKey;\r
+\r
+\r
+\r
+ unit GetPage : procedure(PageRef : integer);\r
+ (* wczytanie do stosu stron strony o adresie PageRef, \r
+ chyba, ze strona o tej referencji jest juz w stosie.\r
+ Poprawienie sciezki i ew. przeslanie do pliku strony\r
+ wskazanej przez Path(Finger).PageRef o ile byla zmieniana jej tresc *)\r
+\r
+ var AuxRec : arrayof integer;\r
+ begin \r
+ \r
+ if Path(Finger) = none\r
+ then\r
+ Path(Finger) := new SearchStep;\r
+ Path(Finger).Updated := false;\r
+ Path(Finger).PageRef := PageRef-1; (*chce by byla roznica ponizej *)\r
+ fi; \r
+(*! if Path(Finger).PageRef <> PageRef\r
+ then *) (*zmiana strony *)\r
+ if Path(Finger).Updated\r
+ then (*wyslanie strony na plik, poniewaz byla zmieniana *)\r
+ AuxRec := PageToRec(StackOfPages(Finger));\r
+ call fseek(plik, Path(Finger).PageRef);\r
+ call fput(plik,AuxRec);\r
+ fi (*updated*);\r
+ (*wczytanie potrzebnej strony*)\r
+ call fseek(plik, PageRef);\r
+ AuxRec := fget(plik);\r
+ StackOfPages(Finger) := RecToPage(AuxRec);\r
+ Path(Finger) := new SearchStep;\r
+ Path(Finger).PageRef := PageRef;\r
+ Path(Finger).updated := false; \r
+(*! fi *)\r
+\r
+ end GetPage ;\r
+\r
+ unit UpdatePage : procedure (input AuxItem : Item,\r
+ ItemRef : integer,\r
+ AuxPage : Page);\r
+ (* wstaw AuxItem na wskazanej stronie, w miejscu ItemRef +1 *)\r
+ var AuxItmArr : arrayof Item,\r
+ n,i: integer;\r
+ begin \r
+ AuxPage.ItemsOnPage, n := AuxPage.ItemsOnPage +1;\r
+ for i := n downto ItemRef +2 \r
+ do \r
+ AuxItmArr := AuxPage.ItemsArray; \r
+ AuxItmArr(i) := AuxItmArr(i-1)\r
+ od;\r
+ AuxPage.ItemsArray(ItemRef+1) := AuxItem;\r
+ Path(Finger).Updated := true;\r
+ end UpdatePage ;\r
+\r
+ unit order : function (i1, i2 : Item) : boolean;\r
+ (*ropzszerzenie porzadku LessOrEqual Leq o badanie DataRef w\r
+przypadku gdy klucze sa rowne *)\r
+ \r
+ var k1,k2 :key,\r
+ n : integer;\r
+\r
+ begin \r
+ k1 := i1.ky;\r
+ k2 := i2.ky;\r
+ if Leq(k2,k1)\r
+ then (* k2ók1 *)\r
+ if Leq(k1, k2)\r
+ then (* k1=k2 *)\r
+ \r
+ (* DORADZAMY zbadaj czy k1 = k2? *************************)\r
+ (* potrzebna inna funkcja EQ? booleowska *****************)\r
+ (* o odp. wlasnosciach: zwrotnsc,przechodniosc, symetria *)\r
+ \r
+ n := i1.DataRef - i2.DataRef;\r
+ if n=0 \r
+ then (*dwa identyczne klucze o jednakowych referencjach*)\r
+ raise Signal14\r
+ fi;\r
+ result := n<0;\r
+ else (* k1>k2 *)\r
+ result := false\r
+ fi\r
+ else (*k1<k2 ?*)\r
+ if not Leq(k1, k2)\r
+ then\r
+(* 16.08.87 ********************************************) \r
+ (* raise RelacjaNieSpojna *) \r
+ else \r
+ result := true \r
+ fi \r
+ fi\r
+ end order;\r
+\r
+ unit SearchPage : procedure (input P : Page, it : Item;\r
+ output NextPageRef, ItemRef : integer);\r
+ (* szukamy miejsca dla obiektu it na stronie P, NextPageRef\r
+jest adresem strony na ktorej mozemy kontynuowac\r
+poszukiwania; ItemRef jest numerem obiektu mniejszego od it\r
+lub jest rowne 0 gdy nasz obiekt it jest mniejszy\r
+od wszystkich obiektow na stronie*)\r
+ \r
+ var Itms : arrayof Item,\r
+ it1 : Item;\r
+\r
+ begin \r
+ Itms :=P.ItemsArray;\r
+ for ItemRef := P.ItemsOnPage downto 1\r
+ do \r
+ it1 := Itms(ItemRef);\r
+ if order (it1, it) \r
+ then (*it1<it *)\r
+ NextPageRef := it1.PageRef;\r
+ return \r
+ fi\r
+ od;\r
+ (*obiekt it jest mniejszy od wszystkich obiektow na tej\r
+stronie*)\r
+ ItemRef := 0;\r
+ NextPageRef := P.LessPageRef;\r
+ end SearchPage ;\r
+\r
+\r
+\r
+ unit RecToPage : function(A: arrayof integer): Page;\r
+ (*Ta funkcja odczytuje tablice liczb calkowitych i zmienia\r
+ja w strone Page. Wykorzystuje sie virtualna funkcje\r
+RecToKey. *)\r
+ var P: Page,\r
+ i,j : integer,\r
+ It : Item;\r
+ begin \r
+ P:=new Page;\r
+ P.ItemsOnPage,j := A(1);\r
+ P.LessPageRef := A(2);\r
+ array P.ItemsArray dim (1:PageSize);\r
+ for i := 1 to j (*P.ItemsOnPage*)\r
+ do\r
+ It := new Item;\r
+ It.ky := RecToKey(A, 3+(i-1)*(KeySize+2) ) ;\r
+ It.PageRef := A(i*(KeySize+2)+1);\r
+ It.DataRef := A(i*(KeySize+2)+2);\r
+ P.ItemsArray(i) := It;\r
+ od(*itemsOnPage*);\r
+ result :=P\r
+ end RecToPage ;\r
+\r
+ unit PageToRec : function (P: Page): arrayof integer;\r
+ (*Funkcja odwrotna do poprzedniej*)\r
+ var A : arrayof integer,\r
+ It: Item,\r
+ i : integer;\r
+ begin \r
+ array A dim(1:(2+PageSize*(KeySize+2)));\r
+ A(1) :=P.ItemsOnPage;\r
+ A(2) := P.LessPageRef;\r
+ for i := 1 to P.ItemsOnPage \r
+ do \r
+ It:=P.ItemsArray(i);\r
+ (* if It = none then writeln(" It w PageToRec jest none"); \r
+ writeln("ItemsOnPage= ",P.ItemsOnPage,"i= ",i) \r
+ fi; *)\r
+ call KeyToRec(It.ky, A, 3+(i-1)*(KeySize+2) );\r
+ (*O KeyToRec zakladam, ze jest to procedura virtualna,\r
+ktora przepisuje klucz ky do tablicy A poczynajac od\r
+danego miejsca A(j) do kolejnych KeySize komorek tej\r
+tablicy. *)\r
+ A(i*(KeySize+2)+1) := It.PageRef;\r
+ A(i*(KeySize+2)+2) := It.DataRef;\r
+ od;\r
+ result := A\r
+ end PageToRec ;\r
+\r
+ unit virtual KeyToRec : procedure(ky:Key, A: arrayof integer, j: integer);\r
+ (*procedura virtualna, ktora przepisuje klucz ky do tablicy\r
+A poczynajac od danego miejsca A(j) do kolejnych KeySize\r
+komorek tej tablicy. *)\r
+ \r
+ begin \r
+ \r
+ end KeyToRec ;\r
+\r
+ unit virtual RecToKey : function(A: arrayof integer, \r
+ j:integer): Key;\r
+ (*Funkcja odczytuje KeySize kolejnych komorek z tablicy A\r
+poczynajac od A(j) i tworzy z nich klucz *)\r
+ \r
+ begin \r
+ \r
+ end RecToKey ;\r
+ \r
+ var AuxRec : arrayof integer,\r
+ akey : Key,\r
+ PageRef : integer;\r
+\r
+begin (*IndexFile*)\r
+ (*ustawic wskazowke do IndexFile *)\r
+ (*zainicjowac Path i StackOfPages*)\r
+ Finger :=1;\r
+ array StackOfPages dim(1:TreeHeight);\r
+ array Path dim (1:TreeHeight);\r
+ StackOfPages(1) := new Page;\r
+ StackOfPages(1).ItemsOnPage := 0;\r
+ StackOfPages(1).LessPageRef := -1;\r
+ array StackOfPages(1).ItemsArray dim (1: PageSize);\r
+ Path(1):= new SearchStep;\r
+ Path(1).PageRef := 1;\r
+ Path(1).RefOnPage := 0;\r
+ \r
+ \r
+end IndexFile;\r
+\r
+\r
+\r
+ \r
+begin (*Relation*)\r
+\r
+ end Relation;\r
+\r
+ \r
+\r
+\r
+begin (*obsluga relacji*)\r
+\r
+end HandlerOfRelations;\r
+\r
+\r
+begin (*to begin odpowiada zewnetrznym : program i end*)\r
+\r
+pref HandlerOfRelations(4,8,2) block\r
+\r
+unit Bibliografia : Relation class;\r
+ (*nasza przykladowa relacja *)\r
+ const autleng=25, tytleng=50, wydleng=15;\r
+\r
+ unit Krotka : Tuple class ;\r
+ var autor,\r
+ tytul, \r
+ wydawca : arrayof char,\r
+ rok,\r
+ pozycja : integer;\r
+ begin \r
+ array autor dim(1 : autleng);\r
+ array tytul dim (1 : tytleng);\r
+ array wydawca dim (1 :wydleng); \r
+ end Krotka;\r
+\r
+ var ak : Krotka; (*aktualna krotka*)\r
+ \r
+ unit virtual TupleToRec : function (k : Krotka): arrayof\r
+ integer;\r
+ var Aux : arrayof integer,\r
+ AIC : arrayof char,\r
+ i : integer;\r
+\r
+ begin\r
+ array Aux dim (1:95);\r
+ AIC := k.autor;\r
+ for i := 1 to autleng \r
+ do \r
+ Aux(i) := ord(AIC(i));\r
+ if ord(AIC(i)) = 13\r
+ then (*Enter *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i := 1 to tytleng\r
+ do \r
+ Aux(autleng+i) := ord(k.tytul(i));\r
+ if ord(k.tytul(i)) = 13\r
+ then (*Enter *)\r
+ exit \r
+ fi;\r
+ od; \r
+ for i := 1 to wydleng\r
+ do \r
+ Aux(75+i) := ord(k.wydawca(i));\r
+ if ord(k.wydawca(i)) = 13\r
+ then (*Enter *)\r
+ exit \r
+ fi;\r
+ od;\r
+ Aux(91) := k.rok;\r
+ Aux(92) := k.pozycja;\r
+ result := Aux;\r
+ end TupleToRec;\r
+\r
+unit virtual RecToTuple : function (a: arrayof integer)\r
+ :Krotka;\r
+ (* *)\r
+ var k:krotka,\r
+ i:integer;\r
+begin \r
+ k:=new krotka;\r
+ for i:=1 to autleng \r
+ do\r
+ k.autor(i):=chr(a(i));\r
+ if a(i) = 13\r
+ then (*koniec tekstu *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i:=1 to tytleng\r
+ do\r
+ k.tytul(i):=chr(a(autleng+i));\r
+ if a(autleng+i) = 13\r
+ then (*koniec tekstu *)\r
+ exit\r
+ fi;\r
+ od;\r
+ for i := 1 to wydleng \r
+ do \r
+ k.wydawca(i):=chr(a(75+i));\r
+ if a(75+i) = 13\r
+ then (*koniec tekstu *)\r
+ exit\r
+ fi;\r
+ od;\r
+ k.rok:=a(91);\r
+ k.pozycja:=a(92);\r
+ result := k\r
+end RecToTuple ;\r
+\r
+unit DrukujKrotke : procedure;\r
+ (*drukuj aktualna krotke *)\r
+begin \r
+ call SetCursor(4,1);\r
+ writeln(" ");\r
+ writeln(" ");\r
+ writeln(" ");\r
+ writeln(" ");\r
+ call SetCursor(10,1);\r
+ write(" autor: ");\r
+ call SetCursor(10,14);\r
+ call Drukuj(ak.autor); writeln;\r
+ write(" tytul: ");\r
+ call SetCursor(11,14);\r
+ call Drukuj(ak.tytul); writeln;\r
+ write(" wydawca: ");\r
+ call SetCursor(12,14);\r
+ call Drukuj(ak.wydawca); writeln;\r
+ writeln("rok wydania: ",ak.rok);\r
+ writeln(" pozycja nr: ",ak.pozycja);\r
+end DrukujKrotke ;\r
+\r
+unit WczytajKrotke : procedure;\r
+ (*Czytaj aktualna krotke *)\r
+begin \r
+ call SetCursor(25,1);\r
+ write("edit tuple, pressing PgDn finishes ");\r
+ \r
+ do\r
+ call SetCursor(4,1);\r
+ writeln; call Reverse;\r
+ write(" autor: "); call Normal;\r
+ call Czytaj(ak.autor); call Reverse;\r
+ write(" tytul: "); call Normal;\r
+ call Czytaj(ak.tytul); call Reverse;\r
+ write(" wydawca: "); call Normal;\r
+ call Czytaj(ak.wydawca); call Reverse;\r
+ write("rok wydania: "); call Normal;\r
+ read(ak.rok); call Reverse;\r
+ write(" pozycja nr: "); call Normal;\r
+ readln(ak.pozycja); \r
+ if inchar = -81 then exit fi;\r
+ od;\r
+end WczytajKrotke ;\r
+\r
+unit IndeksAutorow : IndexFile class ;\r
+ (* *)\r
+ unit klucz : Key class ;\r
+ var autor : arrayof char;\r
+ begin\r
+ array autor dim (1: autleng );\r
+ \r
+ end klucz;\r
+\r
+ unit virtual KeyOf : function (k :Krotka) : klucz;\r
+ (*tworzenie klucza z krotki *)\r
+ begin \r
+ result := new klucz;\r
+ result.autor := copy (k.autor)\r
+ end KeyOf ;\r
+\r
+ unit virtual Leq : function (k1,k2 : klucz) : boolean;\r
+ (*porownanie dwu kluczy *)\r
+ var i: integer;\r
+ begin\r
+ result := true;\r
+ \r
+\r
+\r
+ for i := 1 to autleng\r
+ do \r
+ if ord(k1.autor(i)) =13 \r
+ then\r
+ exit\r
+ else\r
+ if ord(k2.autor(i)) = 13 \r
+ then\r
+ result := false;\r
+ exit\r
+ else\r
+ \r
+ fi;\r
+ fi;\r
+ if ord(k1.autor(i)) = ord(k2.autor(i))\r
+ then (*rowne*)\r
+ else\r
+ if ord(k1.autor(i)) < ord(k2.autor(i))\r
+ then\r
+ result := true ;\r
+ else\r
+ result := false;\r
+ fi;\r
+ exit;\r
+ fi;\r
+ od;\r
+ end Leq ;\r
+\r
+ unit virtual KeyToRec : procedure(ky:klucz, A: arrayof integer,\r
+ j: integer);\r
+ (*procedura virtualna, ktora przepisuje klucz ky do tablicy\r
+ A poczynajac od danego miejsca A(j) do kolejnych KeySize\r
+ komorek tej tablicy. *)\r
+\r
+ var i : integer;\r
+ begin \r
+ for i := 1 to autleng\r
+ do \r
+ A(j+i-1) := ord(ky.autor(i))\r
+ od;\r
+ end KeyToRec ;\r
+\r
+ unit virtual RecToKey : function(A: arrayof integer, \r
+ j:integer): klucz;\r
+ (*Funkcja odczytuje KeySize kolejnych komorek z tablicy A\r
+ poczynajac od A(j) i tworzy z nich klucz *)\r
+\r
+ var k : klucz;\r
+ begin \r
+ k := new klucz;\r
+ for i := 1 to autleng\r
+ do \r
+ k.autor(i) := chr(A(j+i-1))\r
+ od;\r
+ result := k \r
+ end RecToKey ;\r
+\r
+ unit DrukujStrone : procedure (PageRef: integer);\r
+ var P : Page,\r
+ j,\r
+ i : integer,\r
+ l : klucz,\r
+ c : char,\r
+ AuxRec : arrayof integer;\r
+ begin\r
+ if PageRef = -1 then return fi;\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od; \r
+ (*wczytaj strone*)\r
+ call fseek(plik, PageRef);\r
+ AuxRec := fget(plik);\r
+ P := RecToPage(AuxRec);\r
+ (*drukuj*)\r
+\r
+ writeln("stronaRefNr=",PageRef:4," itemow =", P.ItemsOnPage:3);\r
+ write(" klucze ");\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ l := P.ItemsArray(i).ky;\r
+ for j := 1 to 12\r
+ do\r
+ c := l.autor(j);\r
+ if ord(c) = 13 \r
+ then\r
+ write(' ') \r
+ else\r
+ write(c)\r
+ fi;\r
+ od; \r
+ od; \r
+ writeln;\r
+ write(" PgRfs",P.LessPageRef:5);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ write(P.ItemsArray(i).PageRef:12);\r
+ od;\r
+ writeln;\r
+ call DrukujStrone(P.LessPageRef);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ call DrukujStrone(P.ItemsArray(i).PageRef);\r
+ od;\r
+ kill(AuxRec);\r
+ end DrukujStrone;\r
+\r
+ var akl : klucz;\r
+\r
+ begin (*indeksAutorow*) \r
+ KeySize := autleng;\r
+ akl, akey := new klucz;\r
+ (* dlugosc rekordu-klucza = 2+(PageSize * (KeySize + 2)); *)\r
+ if otworz\r
+ then\r
+ plik := openfile(unpack("autor.idx"),2+(PageSize * (KeySize + 2)) );\r
+ (* odczytac strony do StackOfPages *)\r
+ Path(1).PageRef := INFO(1);\r
+ Path(1).RefOnPage := 1;\r
+ call fseek(plik,Path(1).PageRef);\r
+ AuxRec := fget(plik);\r
+ StackOfPages(1) := RecToPage(AuxRec);\r
+ kill(AuxRec);\r
+ else\r
+ plik := makefile(unpack("autor.idx"),2+(PageSize * (KeySize + 2)) );\r
+ fi; \r
+ return;\r
+ (* ZAMYKANIE indeksu *)\r
+ (* strony zmienione ze sciezki sa zapisywane na pliku *)\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od; \r
+ (* ZAPISAC nr rekordu - korzenia *) \r
+ INFO(1) := Path(1).PageRef;\r
+ call closefile(plik);\r
+ end IndeksAutorow ;\r
+\r
+ var IA :IndeksAutorow ; \r
+\r
+ unit IndeksPoz : IndexFile class ;\r
+ (* *)\r
+ unit klucz : Key class ;\r
+ var poz : integer; \r
+ begin\r
+\r
+ end klucz;\r
+\r
+ unit virtual KeyOf : function (k :Krotka) : klucz;\r
+ (*tworzenie klucza z krotki *)\r
+ begin \r
+ result := new klucz;\r
+ result.poz := k.pozycja\r
+ end KeyOf ;\r
+\r
+ unit virtual Leq : function (k1,k2 : klucz) : boolean;\r
+ (*porownanie dwu kluczy *)\r
+ begin\r
+ result := not (k1.poz > k2.poz)\r
+ end Leq ;\r
+\r
+ unit virtual KeyToRec : procedure(ky:klucz, A: arrayof integer,\r
+ j: integer);\r
+ (*procedura virtualna, ktora przepisuje klucz ky do tablicy\r
+ A poczynajac od danego miejsca A(j) do kolejnych KeySize\r
+ komorek tej tablicy. *)\r
+\r
+ (* *)\r
+ var i : integer;\r
+ begin \r
+ A(j) := ky.poz;\r
+ end KeyToRec ;\r
+\r
+ unit virtual RecToKey : function(A: arrayof integer, \r
+ j:integer): klucz;\r
+ (*Funkcja odczytuje KeySize kolejnych komorek z tablicy A\r
+ poczynajac od A(j) i tworzy z nich klucz *)\r
+ (* *)\r
+ var k : klucz;\r
+ begin \r
+ k := new klucz;\r
+ k.poz := A(j);\r
+ result := k \r
+ end RecToKey ;\r
+\r
+ unit DrukujStrone : procedure (PageRef: integer);\r
+ var P : Page,\r
+ i : integer,\r
+ AuxRec : arrayof integer;\r
+ begin\r
+ if PageRef = -1 then return fi;\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od; \r
+ (*wczytaj strone*)\r
+ call fseek(plik, PageRef);\r
+ AuxRec := fget(plik);\r
+ P := RecToPage(AuxRec);\r
+ (*drukuj*)\r
+\r
+ writeln("stronaRefNr=",PageRef:4," itemow =", P.ItemsOnPage:3);\r
+ write(" klucze ");\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ write(P.ItemsArray(i).ky qua klucz.poz:12);\r
+ od; \r
+(* 16.08.87 *******************************************************)\r
+ writeln;\r
+ write(" PgRfs",P.LessPageRef:5);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ write(P.ItemsArray(i).PageRef:12);\r
+ od; \r
+ writeln;\r
+ call DrukujStrone(P.LessPageRef);\r
+ for i := 1 to P.ItemsOnPage\r
+ do\r
+ call DrukujStrone(P.ItemsArray(i).PageRef);\r
+ od;\r
+ kill(AuxRec);\r
+ end DrukujStrone;\r
+ \r
+\r
+ var akl : klucz;\r
+\r
+ begin (*indeksPozycji*) \r
+ KeySize := 1;\r
+ akl, akey := new klucz;\r
+ (* plik.reclength := 2+(PageSize * (KeySize + 2)); *)\r
+ if otworz\r
+ then\r
+ plik := openfile(unpack("nrpzycji.idx"),2+(PageSize * (KeySize + 2))); \r
+ (* odczytac strone-korzen do StackOfPages *)\r
+ \r
+ Path(1).PageRef := INFO(2);\r
+ Path(1).RefOnPage := 1;\r
+ call fseek(plik,Path(1).PageRef);\r
+ AuxRec := fget(plik);\r
+ StackOfPages(1) := RecToPage(AuxRec);\r
+ kill(AuxRec);\r
+ else \r
+ plik := makefile(unpack("nrpzycji.idx"),2+(PageSize * (KeySize + 2)) );\r
+ fi; \r
+ return;\r
+ (* ZAMYKANIE indexu *)\r
+ for i := 1 to TreeHeight\r
+ do\r
+ if Path(i) = none then exit fi;\r
+ if Path(i).updated\r
+ then\r
+ call fseek(plik,Path(i).PageRef);\r
+ call fput(plik,PageToRec(StackOfPages(i)));\r
+ Path(i).updated := false;\r
+ fi;\r
+ od; \r
+ (* ZAPISAC nr rekordu - korzenia *) \r
+ INFO(2) := Path(1).PageRef;\r
+ call closefile(plik); \r
+end IndeksPoz ;\r
+\r
+var IB :IndeksPoz ; \r
+\r
+begin (*bibliografia*)\r
+\r
+if otworz\r
+then\r
+ plik:= openfile(unpack("bibliog.dta"), 95);\r
+else \r
+ plik:= makefile(unpack("bibliog.dta"), 95);\r
+fi; \r
+ ak := new Krotka;\r
+ (* call IncreaseIndex( new IndeksAutorow); *)\r
+ array Index dim(1 : 2);\r
+ Index(1), IA := new IndeksAutorow; \r
+ Index(2), IB := new IndeksPoz;\r
+end Bibliografia ;\r
+\r
+\r
+ (*deklaracje pomocnicze programu glownego*)\r
+ var cha : char,\r
+ otworz, (* otwieramy *)\r
+ otwarta : boolean, (*czy baza bibliograficzna juz jest otwarta?*)\r
+ R : Bibliografia,\r
+ i,j : integer,\r
+ Rec : arrayof integer;\r
+\r
+ unit Czytaj : procedure(a: arrayof char);\r
+ (*czytaj tablice znakow *)\r
+ var i,j : integer,\r
+ cha1: char;\r
+ begin \r
+ for i := 1 to upper(a) \r
+ do \r
+ j := inchar;\r
+ a(i) := chr(j);\r
+ write(a(i));\r
+ if j = 13\r
+ then (*wczytano Enter *)\r
+ writeln;\r
+ exit\r
+ fi;\r
+ od;\r
+ if i < upper(a)\r
+ then\r
+ a(i+1) := chr(13)\r
+ else\r
+ a(upper(a)) := chr(13)\r
+ fi\r
+ end Czytaj ;\r
+\r
+ unit Drukuj : procedure (a : arrayof char);\r
+ (*drukuj tablice znakow jako linijke tekstu *)\r
+ var i : integer;\r
+ begin \r
+ for i := 1 to upper(a) \r
+ do \r
+ write(a(i));\r
+ if ord(a(i)) =13\r
+ then (*wydrukowano Enter *)\r
+ exit\r
+ fi\r
+ od;\r
+ end Drukuj ;\r
+\r
+var INFO : arrayof integer,\r
+ j1,j2: integer,\r
+ extrem : boolean,\r
+ infoplik : Rfile;\r
+\r
+ handlers\r
+\r
+ when Signal13 : \r
+ call SetCursor(5,1);\r
+ writeln("Trying to delete an already absent record");\r
+ return;\r
+ \r
+ when Signal11 :\r
+ call SetCursor(5,1);\r
+ writeln("osiagnieto element minimalny");\r
+ extrem := true;\r
+ return;\r
+ \r
+ when Signal12 :\r
+ call SetCursor(5,1);\r
+ writeln("osiagnieto element maksymalny");\r
+ extrem := true;\r
+ return; \r
+ end handlers;\r
+\r
+\r
+begin (*program glowny prefiksowany przez HandlerOfRelations*)\r
+ (*dane bibliograficzne*)\r
+ (*wyswietl powitanie*)\r
+\r
+ array INFO dim (1:3); \r
+ call Reverse; \r
+ call NewPage;\r
+ call SetCursor(13,10);\r
+ (*call Normal;*)\r
+ (*call Bold;*)\r
+ write("TOOLBOX dla baz danych");\r
+ call SetCursor(15,10);\r
+ write("test 19v.4");\r
+ call SetCursor(21,10);\r
+ (*call Normal;*)\r
+ write("G.Mirkowska, A.Salwicki - Lipiec 1988");\r
+ call SetCursor(22,10);\r
+ write("klase FileSystem napisala J.Warpechowska");\r
+ call SetCursor(23,68);\r
+ write("press a key");\r
+ i := inchar;\r
+ call Normal;\r
+ call NewPage;\r
+ writeln; writeln; writeln;\r
+ write(\r
+ "Do you wish to use the previously prepared bibliography files?(y/n)?");\r
+ i := inchar;\r
+ call Bold;\r
+ write(chr(i));\r
+ if i =121\r
+ then\r
+ otworz := true;\r
+ infoplik := openfile(unpack("bibliog.bas"),3);\r
+ INFO := fget(infoplik);\r
+ else\r
+ otworz := false;\r
+ infoplik := makefile(unpack("bibliog.bas"),3);\r
+ fi; \r
+\r
+ R :=new Bibliografia;\r
+ R.FreePlace := Info(3);\r
+ call NewPage;\r
+ call Reverse;\r
+ writeln(\r
+ "i-INSERT d-DELETE s-SEARCH m-MINMAX t-TYPE n-NEXT p-PREVIOUS q-QUIT");\r
+ \r
+ writeln(\r
+ "ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ");\r
+ writeln;\r
+ call SetCursor(23,1);\r
+ call Normal;\r
+ writeln(\r
+ "ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ");\r
+ writeln(\r
+ " ");\r
+ call Blink;\r
+ write(\r
+ " make a choice ");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(1,76); \r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call SetCursor(25,1);\r
+ write(\r
+ " ");\r
+ call SetCursor(5,1);\r
+ do\r
+ case cha \r
+\r
+ when 'q' : (* quit*)\r
+ call Blink;\r
+ call SetCursor(24,7);\r
+ writeln("end of program test19-4, CLOSING FILES");\r
+ call Normal;\r
+ call SetCursor(5,1);\r
+ call closefile(R.plik); \r
+ attach(R.IA);\r
+ attach(R.IB);\r
+ INFO(3) := R.FreePlace; \r
+ call frewind(infoplik);\r
+ call fput(infoplik,INFO);\r
+ call closefile(infoplik);\r
+ call NewPage;\r
+ call endrun;\r
+ (* end quit *)\r
+ \r
+ when 'i': (*read a tuple and INSERT*)\r
+ call R.WczytajKrotke;\r
+ call SetCursor(24,7);\r
+ call Blink;\r
+ call Reverse;\r
+ write("inserting the tuple");\r
+ call R.Insert(R.ak);\r
+ j1,j2 := 1;\r
+ call Normal;\r
+ call SetCursor(24,7);\r
+ write(" ");\r
+ \r
+ when 't' : (*type*)\r
+ call Normal;\r
+ call Reverse;\r
+ call SetCursor(3,38);\r
+ write("print: r-RELATION or b-BTREE ");\r
+ cha := chr(inchar); \r
+ call Normal;\r
+ writeln(cha);\r
+ if cha = 'r'\r
+ then (*printing relation*)\r
+ call SetCursor(24,4);\r
+ write(" press SPACEBAR for next record");\r
+ call SetCursor(5,1);\r
+ call fseek(R.plik,1);\r
+ while not feof(R.plik)\r
+ do \r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call R.DrukujKrotke;\r
+ call SetCursor(24,19);\r
+ i:=inchar;\r
+ od;\r
+ else (*printing Btree*)\r
+ call SetCursor(4,30);\r
+ call Reverse;\r
+ write("select index: a-AUTHORS or p-POSITIONS ");\r
+ call Normal;\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call SetCursor(5,1);\r
+ if cha = 'p'\r
+ then\r
+ call R.IB.DrukujStrone(R.IB.Path(1).PageRef);\r
+ else\r
+ call R.IA.DrukujStrone(R.IA.Path(1).PageRef);\r
+ fi;\r
+\r
+ fi (*koniec drukuj*);\r
+\r
+ when 's': (*search for a tuple*)\r
+ call SetCursor(3,19);\r
+ call Reverse;\r
+ write(" searching tuple (t)? or key (k)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal;\r
+ if cha = 't'\r
+ then (*give a tuple *)\r
+ call SetCursor(5,1);\r
+ call R.WczytajKrotke;\r
+ Rec := R.TupleToRec(R.ak);\r
+ call SetCursor(24,7);\r
+ call Blink;\r
+ call Reverse;\r
+ write("searching the tuple");\r
+ \r
+ call R.FindRec(Rec, i);\r
+ \r
+ call Normal;\r
+ call SetCursor(24,7);\r
+ write(" ");\r
+ if i = -1\r
+ then (* *)\r
+ writeln(" the tuple not found");\r
+ else (* *)\r
+ writeln(" position of the tuple in the datafile = ",i); \r
+ (* call fseek(R.plik, i);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(rec);\r
+ call R.DrukujKrotke; *)\r
+ fi;\r
+ else (*'k' *)\r
+ if cha ='k'\r
+ then (*searching in the authors or position index*)\r
+ call SetCursor(4,19);\r
+ call Reverse;\r
+ write("which index: authors(a)? or positions(p)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal; \r
+ if cha = 'a'\r
+ then\r
+ i := 1;\r
+ call SetCursor(5,1);\r
+ write(" autor: ");\r
+ call Czytaj(R.IA.akl.autor); \r
+ \r
+ j1 := R.IA.Findkey(R.IA.akl);\r
+ if j1<> -1\r
+ then (*znaleziono *)\r
+ call SetCursor(24,7);\r
+ writeln("tuple found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call R.DrukujKrotke;\r
+ else (*nie znaleziono *)\r
+ call SetCursor(24,7);\r
+ writeln(" tuple not found");\r
+ fi\r
+ else (*zakladamy cha ='p'*)\r
+ i := 2;\r
+ call SetCursor(5,1);\r
+ write(" position nr: ");\r
+ read(R.IB.akl.poz); \r
+ j2 := R.Index(i).Findkey(R.IB.akl);\r
+ if j2<> -1\r
+ then (*znaleziono *)\r
+ call SetCursor(24,7);\r
+ write("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ else (*nie znaleziono *)\r
+ call SetCursor(24,7);\r
+ writeln(" tuple not found");\r
+ fi ;\r
+ fi (*wyboru klucza*);\r
+ fi (*cha ='c'*) \r
+ fi (*when 's'*);\r
+ \r
+ \r
+\r
+ when 'p': (*show the previous tuple*)\r
+ \r
+ call SetCursor(4,19);\r
+ call Reverse;\r
+ write("which index: authors(a)? or positions(p)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal; \r
+ if cha = 'a'\r
+ then\r
+ if j1>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(1).PrevKey(R.IA.akl,j1);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ j1 :=0;\r
+ R.IA.akl := R.IA.new klucz;\r
+ else\r
+ call SetCursor(24,7);\r
+ write("tuple found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ call SetCursor(24,7);\r
+ write("no key has been located yet");\r
+ fi; \r
+ else\r
+ if j2>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(2).PrevKey(R.IB.akl,j2);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ else\r
+ call SetCursor(24,7);\r
+ write("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ call SetCursor(24,7);\r
+ writeln("no key has been located yet");\r
+ fi;\r
+ fi (* prev *);\r
+ \r
+ \r
+ when 'm': (*min or max*)\r
+ call Reverse;\r
+ call SetCursor(3,25);\r
+ write("searching index of: authors(a)? or positions(p)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ if cha ='a'\r
+ then\r
+ call Reverse;\r
+ call SetCursor(4,25);\r
+ write("searching index of authors: min(i)? or max(x)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ call SetCursor(5,1);\r
+ if cha = 'i'\r
+ then\r
+ call R.IA.MinKey(R.IA.akl, j1);\r
+ call SetCursor(24,7);\r
+ writeln(" min key found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke; \r
+ else\r
+ call R.IA.MaxKey(R.IA.akl, j1);\r
+ call SetCursor(24,7);\r
+ writeln("max key found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke; \r
+ fi;\r
+ else (*wg pozycji*)\r
+ call Reverse;\r
+ call SetCursor(4,25);\r
+ write("searching index of positions: min(i)? or max(x)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ call SetCursor(24,7);\r
+ if cha = 'i'\r
+ then\r
+ call R.IB.MinKey(R.IB.akl, j2);\r
+ writeln("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke; \r
+ else\r
+ call R.IB.MaxKey(R.IB.akl, j2);\r
+ writeln("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke; \r
+ fi;\r
+ fi; (* end of minmax utility *)\r
+\r
+ \r
+ when 'n': (*show the next tuple*)\r
+ call SetCursor(4,19);\r
+ call Reverse;\r
+ write("which index: authors(a)? or positions(p)? ");\r
+ cha := chr(inchar);\r
+ writeln(cha);\r
+ call Normal; \r
+ call SetCursor(24,7);\r
+ if cha = 'a'\r
+ then\r
+ if j1>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(1).NextKey(R.IA.akl,j1);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ else\r
+ writeln("tuple found on position = ",j1);\r
+ call fseek(R.plik, j1);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ writeln("no key has been located yet");\r
+ fi; \r
+ else\r
+ if j2>0\r
+ then (*aktualna krotka jest okreslona *)\r
+ call R.Index(2).NextKey(R.IB.akl,j2);\r
+ if extrem\r
+ then\r
+ extrem := false;\r
+ else\r
+ writeln("tuple found on position = ",j2);\r
+ call fseek(R.plik, j2);\r
+ Rec := fget(R.plik);\r
+ R.ak := R.RecToTuple(Rec);\r
+ call SetCursor(6,1);\r
+ call R.DrukujKrotke;\r
+ fi;\r
+ else (* *)\r
+ writeln("no key has been located yet");\r
+ fi;\r
+ fi (*Next*);\r
+\r
+ when 'd': (*delete the actual tuple*)\r
+ call Reverse;\r
+ call SetCursor(3,25);\r
+ write("from index of: authors(a)? or positions(p)?");\r
+ cha := chr(inchar);\r
+ call Normal;\r
+ writeln(cha);\r
+ \r
+ if cha ='a'\r
+ then (* ustawic aktualna krotke*) \r
+ \r
+ else\r
+ \r
+ fi;\r
+ \r
+ call SetCursor(25,4);\r
+ call Blink;\r
+ call Reverse;\r
+ write("DELETING the actual tuple");\r
+ call R.Delete(R.ak);\r
+\r
+\r
+ otherwise\r
+ call SetCursor(25,4);\r
+ write("REPEAT")\r
+ esac;\r
+ \r
+ call Normal;\r
+ call SetCursor(25,1);\r
+ write(" ");\r
+ call Blink;\r
+ call Reverse; \r
+ call SetCursor(25,60);\r
+ write("press a key");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(1,76);\r
+ write(chr(32));\r
+ i:=inchar;\r
+ call Normal; \r
+ call SetCursor(3,1);\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ writeln(\r
+ " ");\r
+ call SetCursor(24,1);\r
+ writeln(\r
+ " ");\r
+ write(\r
+ " ");\r
+\r
+ call Normal;\r
+ call Blink;\r
+ call Reverse;\r
+ call SetCursor(25,60);\r
+ write("make your choice");\r
+ call Normal;\r
+ call Bold;\r
+ call SetCursor(1,76);\r
+ write(chr(32));\r
+ i := inchar;\r
+ cha := chr(i);\r
+ call SetCursor(1,76); \r
+ writeln(chr(i));\r
+ call SetCursor(25,60);\r
+ write(" ");\r
+ call SetCursor(5,1);\r
+ od\r
+ end\r
+end Test19;\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+block\r
+(*_______________________________________________________*)\r
+(* SYMULACJA RUCHU ULICZNEGO *)\r
+(*_______________________________________________________*)\r
+ \r
+(* simulation class *)\r
+ \r
+ unit fifo:class;\r
+ (* the type implementing fifo - queues *)\r
+ hidden front, rear;\r
+ signal fifoempty;\r
+ var front, rear:fifoel;\r
+ \r
+ \r
+ unit fifoel : class;\r
+ var succ:fifoel;\r
+ \r
+ unit into:procedure(q:fifo);\r
+ begin\r
+ if q.front = none then\r
+ q.front,q.rear := this fifoel\r
+ else q.rear.succ, q.rear :=this fifoel\r
+ fi\r
+ end into;\r
+ \r
+ end fifoel;\r
+ \r
+ \r
+ \r
+ unit outfirst:procedure;\r
+ begin\r
+ if front = none then raise fifoempty\r
+ else\r
+ if rear = front then rear,front := none\r
+ else front:=front.succ\r
+ fi\r
+ fi\r
+ end outfirst;\r
+ \r
+ \r
+ \r
+ unit empty:function:boolean;\r
+ begin\r
+ result := front=none\r
+ end empty;\r
+ \r
+ \r
+ \r
+ unit first:function:fifoel;\r
+ begin\r
+ result := front\r
+ end first;\r
+ \r
+ \r
+ \r
+ unit cardinal:function:integer;\r
+ var i:integer,\r
+ aux:fifoel;\r
+ begin\r
+ aux := front;\r
+ while aux =/= none do\r
+ i:=i+1;\r
+ aux:=aux.succ\r
+ od;\r
+ result := i\r
+ end cardinal;\r
+ \r
+ end fifo;\r
+ \r
+ \r
+ \r
+ unit priorityqueue: fifo class;\r
+ (* heap as binary linked tree with father link*)\r
+ hidden node;\r
+ \r
+ unit queuehead: class;\r
+ (* heap accessing module *)\r
+ hidden last, root;\r
+ var last,root:node;\r
+ \r
+ unit min: function: elem;\r
+ begin\r
+ if root=/= none then result:=root.el fi;\r
+ end min;\r
+ \r
+ unit insert: procedure(r:elem);\r
+ (* insertion into heap *)\r
+ var x,z:node;\r
+ begin\r
+ x:= r.lab;\r
+ if last = none then\r
+ root:=x;\r
+ root.left,root.right,last:=root\r
+ else\r
+ if last.ns = 0 then\r
+ last.ns:=1;\r
+ z:= last.left;\r
+ last.left:=x;\r
+ x.up:= last;\r
+ x.left:= z; z.right:=x\r
+ else\r
+ last.ns:=2;\r
+ z:= last.right;\r
+ last.right:=x;\r
+ x.right:=z;\r
+ x.up:= last;\r
+ z.left:=x;\r
+ last.left.right:=x;\r
+ x.left:=last.left;\r
+ last:= z;\r
+ fi;\r
+ fi;\r
+ call correct(r,false);\r
+ end insert;\r
+ \r
+ \r
+ \r
+ unit delete: procedure(r: elem);\r
+ var x,y,z:node;\r
+ begin\r
+ x:=r.lab;\r
+ if x=root and root.ns=0 then\r
+ root,last:= none\r
+ else\r
+ z:=last.left;\r
+ if last.ns =0 then\r
+ y:= z.up;\r
+ y.right:= last;\r
+ last.left:=y;\r
+ last:=y;\r
+ else\r
+ y:= z.left;\r
+ y.right:= last;\r
+ last.left:= y;\r
+ fi;\r
+ z.el.lab:=x;\r
+ x.el:= z.el;\r
+ last.ns:= last.ns-1;\r
+ r.lab:=z;\r
+ z.el:=r;\r
+ if x.less(x.up) then\r
+ call correct(x.el,false)\r
+ else\r
+ call correct(x.el,true)\r
+ fi;\r
+ fi;\r
+ end delete;\r
+ \r
+ \r
+ unit correct: procedure(r:elem,down:boolean);\r
+ (* correction of the heap with structure broken by r *)\r
+ var x,z:node,t:elem,fin,log:boolean;\r
+ begin\r
+ z:=r.lab;\r
+ if down then\r
+ while not fin do\r
+ if z.ns =0 then\r
+ fin:=true\r
+ else\r
+ if z.ns=1 then\r
+ x:=z.left\r
+ else\r
+ if z.left.less(z.right) then\r
+ x:=z.left\r
+ else x:=z.right\r
+ fi\r
+ fi;\r
+ if z.less(x) then\r
+ fin:=true\r
+ else\r
+ t:=x.el;\r
+ x.el:=z.el;\r
+ z.el:=t;\r
+ z.el.lab:=z;\r
+ x.el.lab:=x\r
+ fi\r
+ fi;\r
+ z:=x;\r
+ od\r
+ else\r
+ x:=z.up;\r
+ if x=none then log:=true else log:=x.less(z); fi;\r
+ while not log do\r
+ t:=z.el;\r
+ z.el:=x.el;\r
+ x.el:=t;\r
+ x.el.lab:=x;\r
+ z.el.lab:=z;\r
+ z:=x;\r
+ x:=z.up;\r
+ if x=none then log:=true else log:=x.less(z);fi;\r
+ od;\r
+ fi;\r
+ end correct;\r
+ \r
+ end queuehead;\r
+ \r
+ \r
+ \r
+ unit node: class (el:elem);\r
+ (* element of the heap *)\r
+ var left,right,up: node, ns:integer;\r
+ unit less: function(x:node): boolean;\r
+ begin\r
+ if x= none then result:=false\r
+ else result:=el.less(x.el)\r
+ fi;\r
+ end less;\r
+ end node;\r
+ \r
+ unit elem: class(prior:real);\r
+ (* prefix of information to be stored in node *)\r
+ var lab: node;\r
+ unit virtual less: function(x:elem):boolean;\r
+ begin\r
+ if x=none then result:= false\r
+ else\r
+ result:= prior< x.prior\r
+ fi;\r
+ end less;\r
+ begin\r
+ lab:= new node(this elem);\r
+ end elem;\r
+ \r
+ \r
+ end priorityqueue;\r
+(*______________________________________________________________*)\r
+ \r
+ \r
+ \r
+ \r
+ unit simulation: priorityqueue class;\r
+ (* the language for simulation purposes *)\r
+ taken queuehead, elem, fifoel;\r
+ hidden pq, curr, eventnotice, mainprogram, choiceprocess;\r
+ var curr : simprocess, (*active process *)\r
+ pq :queuehead, (* the time axis *)\r
+ mainpr: mainprogram;\r
+ \r
+ unit simprocess:fifoel coroutine;\r
+ (* user process prefix *)\r
+ var event, (* activation moment notice *)\r
+ eventpom: eventnotice,\r
+ (* this is for avoiding many new calls as an result *)\r
+ (* of subsequent passivations and activations *)\r
+ finish: boolean;\r
+ signal termproc, idleproc;\r
+ unit idle: function: boolean;\r
+ begin\r
+ result:= event= none;\r
+ end idle;\r
+ \r
+ \r
+ unit terminated: function :boolean;\r
+ begin\r
+ result:= finish;\r
+ end terminated;\r
+ \r
+ \r
+ unit evtime: function: real;\r
+ (* time of activation *)\r
+ begin\r
+ if idle then raise idleproc fi;\r
+ result:= event.eventtime;\r
+ end evtime;\r
+ handlers\r
+ (* default handlers for signals termproc and idleproc *)\r
+ when termproc: writeln(" simprocess is terminated ");\r
+ attach(mainpr);\r
+ when idleproc: writeln(" simprocess is idle ");\r
+ attach(mainpr);\r
+ end handlers;\r
+ begin\r
+ return;\r
+ inner;\r
+ finish:=true;\r
+ call passivate;\r
+ raise termproc\r
+ end simprocess;\r
+ \r
+ \r
+ \r
+ unit eventnotice: elem class;\r
+ (* a process activation notice to be placed onto the time axis pq *)\r
+ var eventtime: real, proc: simprocess;\r
+ unit virtual less: function(x: eventnotice):boolean;\r
+ (* overwrite the former version considering eventtime *)\r
+ begin\r
+ if x=none then result:= false\r
+ else\r
+ result:=eventtime < x.eventtime or\r
+ (eventtime=x.eventtime and prior < x.prior);\r
+ fi;\r
+ end less;\r
+ end eventnotice;\r
+ \r
+ \r
+ unit mainprogram: simprocess class;\r
+ (* implementing master programm as a process *)\r
+ begin\r
+ do attach(main) od;\r
+ end mainprogram;\r
+ \r
+ \r
+ unit time:function:real;\r
+ (* current value of simulation time *)\r
+ begin\r
+ result:=current.evtime\r
+ end time;\r
+ \r
+ \r
+ unit current: function: simprocess;\r
+ (* the first process on the time axis *)\r
+ begin\r
+ result:=curr;\r
+ end current;\r
+ \r
+ unit schedule: procedure(p:simprocess,t:real);\r
+ (* activation of process p at time t *)\r
+ begin\r
+ if t<time then t:= time fi;\r
+ if p=current then\r
+ call hold(t-time)\r
+ else\r
+ if p.idle and p.eventpom=none then\r
+ (* has not been scheduled yet *)\r
+ p.event,p.eventpom:= new eventnotice(random);\r
+ p.event.proc:= p;\r
+ else\r
+ if p.idle (* p has been scheduled yet *) then\r
+ p.event:= p.eventpom;\r
+ p.event.prior:=random;\r
+ else\r
+ (* new scheduling *)\r
+ p.event.prior:=random;\r
+ call pq.delete(p.event)\r
+ fi\r
+ fi;\r
+ p.event.eventtime:= t;\r
+ call pq.insert(p.event);\r
+ fi;\r
+ end schedule;\r
+ \r
+ \r
+ unit hold:procedure(t:real);\r
+ (* move the active process t minutes back along pq *)\r
+ (* redefine prior *)\r
+ begin\r
+ call pq.delete(current.event);\r
+ current.event.prior:=random;\r
+ if t<0 then t:=0; fi;\r
+ current.event.eventtime:=time+t;\r
+ call pq.insert(current.event);\r
+ call choiceprocess;\r
+ end hold;\r
+ \r
+ \r
+ unit passivate: procedure;\r
+ (* remove the actve process from pq and activate the next one *)\r
+ begin\r
+ call pq.delete(current.event);\r
+ current.event:=none;\r
+ call choiceprocess\r
+ end passivate;\r
+ \r
+ \r
+ unit run: procedure(p:simprocess);\r
+ (* activate p immediately and delay former first process *)\r
+ (* by redefining prior *)\r
+ begin\r
+ current.event.prior:=random;\r
+ if not p.idle then\r
+ p.event.prior:=0;\r
+ p.event.eventtime:=time;\r
+ call pq.correct(p.event,false)\r
+ else\r
+ if p.eventpom=none then\r
+ p.event,p.eventpom:=new eventnotice(0);\r
+ p.event.eventtime:=time;\r
+ p.event.proc:=p;\r
+ call pq.insert(p.event)\r
+ else\r
+ p.event:=p.eventpom;\r
+ p.event.prior:=0;\r
+ p.event.eventtime:=time;\r
+ p.event.proc:=p;\r
+ call pq.insert(p.event);\r
+ fi\r
+ fi;\r
+ call choiceprocess;\r
+ end run;\r
+ \r
+ \r
+ \r
+ unit cancel:procedure(p: simprocess);\r
+ (* remove process p from pq and continue simulation *)\r
+ begin\r
+ if p= current then call passivate\r
+ else\r
+ call pq.delete(p.event);\r
+ p.event:=none;\r
+ fi;\r
+ end cancel;\r
+ \r
+ \r
+ \r
+ unit choiceprocess:procedure;\r
+ (* choose the first process from pq to be activated *)\r
+ var p:simprocess;\r
+ begin\r
+ p:=curr;\r
+ if pq.min= none then\r
+ writeln(" empty queue");\r
+ mainpr.event:=mainpr.eventpom;\r
+ mainpr.event.prior:=0;\r
+ mainpr.event.eventtime:=time;\r
+ call pq.insert(mainpr.event);\r
+ curr:=mainpr;\r
+ attach(mainpr)\r
+ else\r
+ curr:=pq.min qua eventnotice.proc;\r
+ attach(curr)\r
+ fi;\r
+ end choiceprocess;\r
+ \r
+ \r
+ \r
+ begin\r
+ pq:=new queuehead; (* simulation time axis*)\r
+ curr,mainpr:=new mainprogram;\r
+ mainpr.event,mainpr.eventpom:=new eventnotice(0);\r
+ mainpr.event.eventtime:=0;\r
+ mainpr.event.proc:=mainpr;\r
+ call pq.insert(mainpr.event);\r
+ (* the first process to be activated is main program *)\r
+ inner;\r
+ pq:=none;\r
+ \r
+ end simulation;\r
+ \r
+(*______________________________________________________________________*)\r
+(* grafika do symulacji *)\r
+(*______________________________________________________________________*)\r
+ \r
+ \r
+unit graf:iiuwgraph class; (* clasa graficzna *)\r
+var c:arrayof arrayof integer;\r
+var ile :arrayof integer;\r
+ \r
+ unit inchar:function:integer;\r
+ begin\r
+ while result=0 do\r
+ result:=inkey;\r
+ od;\r
+ end inchar;\r
+ \r
+ \r
+ unit outhline: procedure(a:arrayof char);\r
+ (* wypisanie w trybie graficznym*)\r
+ var i,j:integer;\r
+ begin\r
+ i:=upper(a);\r
+ for j:=1 to i do\r
+ call hascii(0);\r
+ call hascii(ord(a(j)));\r
+ od;\r
+ kill (a);\r
+ end outhline;\r
+ \r
+ \r
+ \r
+ unit inhline:function(xc:integer;yc,il:integer):arrayof char;\r
+ var i,count,ik:integer;\r
+ var ar:arrayof char;\r
+ begin\r
+ call move(xc,yc);\r
+ count:=0;\r
+ array ar dim(1:il);\r
+ while ik=/=13 and count<il do\r
+ ik:=inchar;\r
+ if ik=8 and count>0 then\r
+ ar(count):=' ';\r
+ count:=count-1;\r
+ call move(xc+(count)*8,yc);\r
+ call hascii(0);\r
+ else\r
+ if ik=/=13 then\r
+ count:=count+1;\r
+ ar(count):=chr(ik);\r
+ call hascii(0);\r
+ call hascii(ik);\r
+ fi;\r
+ fi;\r
+ od;\r
+ if count=/=0 then\r
+ array result dim(1:count);\r
+ for i:=1 to count do\r
+ result(i):=ar(i);\r
+ od;\r
+ fi;\r
+ end inhline;\r
+ \r
+ \r
+ \r
+(* funkcja zamiany na liczbe liczby zapisanej znakowo *);\r
+ unit cyfra:function(at:arrayof char):integer;\r
+ var id,i,j,k:integer;\r
+ begin\r
+ j:=1;\r
+ k:=0;\r
+ id:=upper(at);\r
+ for i:=id downto 1 do\r
+ k:=k+((ord(at(i))-48)*j);\r
+ j:=j*10;\r
+ od;\r
+ result:=k;\r
+ end cyfra;\r
+ \r
+ \r
+ unit daj:function(a:integer):arrayof char;\r
+ var ta:arrayof char;\r
+ var i,j,k,l,m:integer;\r
+ begin\r
+ if a>9 then\r
+ if a>99 then\r
+ if a>999 then\r
+ if a>9999 then i:=5;\r
+ else i:=4; fi;\r
+ else i:=3; fi;\r
+ else i:=2; fi;\r
+ else i:=1; fi;\r
+ k:=10;\r
+ l:=1;\r
+ m:=1;\r
+ array ta dim(1:i);\r
+ if i=5 then m:=2;ta(1):=chr((a div 10000)+48); fi;\r
+ for j:=i downto m do\r
+ ta(j):=chr(((a mod k) div l)+48);\r
+ k:=k*10;\r
+ l:=l*10;\r
+ od;\r
+ result:=ta;\r
+ end daj;\r
+ \r
+ unit mapa:procedure; (* rysowanie fragmentu miasta *)\r
+ begin\r
+ call cls; (* czyszczenie ekranu *)\r
+ call move(9,5); (* rameczka *)\r
+ call draw(719,5);\r
+ call draw(719,333);\r
+ call draw(9,333);\r
+ call draw(9,5);\r
+ call move(590,5);\r
+ call draw(590,333);\r
+ call move(589,5);\r
+ call draw(589,333);\r
+ call move(9,70); (* tu juz skrzyzowanie *)\r
+ call draw(102,70);\r
+ call draw(102,5);\r
+ call move(9,69);\r
+ call draw(103,69);\r
+ call draw(103,5);\r
+ call move(124,5);\r
+ call draw(124,69);\r
+ call draw(590,69);\r
+ call move(125,5);\r
+ call draw(125,70);\r
+ call draw(590,70);\r
+ call move(9,107);\r
+ call draw(103,107);\r
+ call draw(103,333);\r
+ call move(9,108);\r
+ call draw(102,108);\r
+ call draw(102,333);\r
+ call move(124,107);\r
+ call draw(124,204);\r
+ call draw(331,204);\r
+ call draw(331,107);\r
+ call draw(124,107);\r
+ call move(125,108);\r
+ call draw(125,203);\r
+ call draw(330,203);\r
+ call draw(330,108);\r
+ call draw(125,108);\r
+ \r
+ call move(124,333); (* "dolny" parking *)\r
+ call draw(124,226);\r
+ call draw(221,226);\r
+ call draw(221,242);\r
+ call draw(161,242);\r
+ call draw(161,297);\r
+ call draw(290,297);\r
+ call draw(290,242);\r
+ call draw(230,242);\r
+ call draw(230,226);\r
+ call draw(331,226);\r
+ call draw(331,333);\r
+ \r
+ call move(125,333);\r
+ call draw(125,227);\r
+ call draw(220,227);\r
+ call draw(220,241);\r
+ call draw(160,241);\r
+ call draw(160,298);\r
+ call draw(291,298);\r
+ call draw(291,241);\r
+ call draw(231,241);\r
+ call draw(231,227);\r
+ call draw(330,227);\r
+ call draw(330,333);\r
+ \r
+ call move(353,333); (* "gorny" parking *)\r
+ call draw(353,107);\r
+ call draw(488,107);\r
+ call draw(488,123);\r
+ call draw(463,123);\r
+ call draw(463,143);\r
+ call draw(522,143);\r
+ call draw(522,123);\r
+ call draw(497,123);\r
+ call draw(497,107);\r
+ call draw(590,107);\r
+ \r
+ call move(354,333);\r
+ call draw(354,108);\r
+ call draw(487,108);\r
+ call draw(487,122);\r
+ call draw(464,122);\r
+ call draw(464,144);\r
+ call draw(523,144);\r
+ call draw(523,122);\r
+ call draw(498,122);\r
+ call draw(498,108);\r
+ call draw(590,108);\r
+ \r
+ call move(9,84); (* tory tramwajowe *);\r
+ call draw(590,84);\r
+ call move(9,86);\r
+ call draw(590,86);\r
+ call move(9,91);\r
+ call draw(590,91);\r
+ call move(9,93);\r
+ call draw(590,93);\r
+ \r
+ call move(134,81); (* przystanki *)\r
+ call draw(174,81);\r
+ call move(134,82);\r
+ call draw(174,82);\r
+ call move(288,95);\r
+ call draw(328,95);\r
+ call move(288,96);\r
+ call draw(328,96);\r
+ \r
+ call move(600,20); (* poglodowka *)\r
+ call draw(715,20);\r
+ call move(620,10);\r
+ call draw(620,62);\r
+ call move(680,20);\r
+ call draw(680,62);\r
+ call move(620,40);\r
+ call draw(680,40);\r
+ call move(617,16);\r
+ call outhline(unpack("1"));\r
+ call move(677,16);\r
+ call outhline(unpack("2"));\r
+ call move(617,36);\r
+ call outhline(unpack("3"));\r
+ call move(677,36);\r
+ call outhline(unpack("4"));\r
+ call move(595,80);\r
+ call outhline(unpack("przejechalo"));\r
+ call move(595,90);\r
+ call outhline(unpack("pojazdow"));\r
+ call ilep;\r
+ call move(595,300);\r
+ call outhline(unpack("SPACJA-menu"));\r
+ call move(595,310);\r
+ call outhline(unpack("Q exit"));\r
+ call move(595,320);\r
+ call outhline(unpack("Z zmiany"));\r
+ end mapa;\r
+ \r
+ \r
+ unit ilep:procedure;\r
+ var i:integer;\r
+ begin\r
+ for i:=1 to 4 do\r
+ call move(595,90+i*10);\r
+ call outhline(daj(i));\r
+ call move(640,90+i*10);\r
+ call outhline(daj(ile(i)));\r
+ od;\r
+ end ilep;\r
+ \r
+ \r
+ unit start:procedure;(* strona tytulowa oraz zapamietanie *)\r
+ var i:integer; (* wygladu samochodow *)\r
+ begin\r
+ call cirb(100,100,20,1,1,1,1,1,1);\r
+ call cirb(100,120,20,1,1,1,1,1,1);\r
+ call cirb(150,100,20,1,1,1,1,1,1);\r
+ call cirb(150,120,20,3.8,1.6,1,1,1,1);\r
+ call move(101,101);\r
+ c(1):= getmap(111,104); (* samochod poziomy *)\r
+ call move(101,101);\r
+ c(2):= getmap(106,108); (* samochod pionowy *)\r
+ call move(1,1);\r
+ c(3):=getmap(11,4);\r
+ call move(1,1);\r
+ c(4):=getmap(6,8);\r
+ call move(2,110);\r
+ call outhline(unpack("Symulacja"));\r
+ i:=inchar;\r
+ end start;\r
+ \r
+ \r
+ \r
+ unit grtram:procedure; (* rysowanie i zapamietanie tramwaju *)\r
+ begin\r
+ call move(9,0);\r
+ call draw(26,0);\r
+ call move(0,1);\r
+ call draw(27,1);\r
+ call move(8,2);\r
+ call draw(48,2);\r
+ call move(0,3);\r
+ call draw(27,3);\r
+ call move(9,4);\r
+ call draw(26,4);\r
+ call move(30,0);\r
+ call draw(47,0);\r
+ call move(29,1);\r
+ call draw(56,1);\r
+ call move(29,3);\r
+ call draw(56,3);\r
+ call move(30,4);\r
+ call draw(47,4);\r
+ end grtram;\r
+ \r
+ \r
+ unit semafv:procedure(x,y:integer,upp:boolean);\r
+ begin (* rysowanie pionowych sygnalizatorow "swiatel" *)\r
+ if upp then y:=y+3 fi;\r
+ call move(x,y);\r
+ call draw(x+9,y);\r
+ call draw(x+9,y+27);\r
+ call draw(x,y+27);\r
+ call draw(x,y);\r
+ call move(x,y+9);\r
+ call draw(x+9,y+9);\r
+ call move(x,y+18);\r
+ call draw(x+9,y+18);\r
+ if upp then\r
+ y:=y-30;\r
+ call move(x,y+27);\r
+ call draw(x+9,y+27);\r
+ else\r
+ call move(x,y+30);\r
+ call draw(x+9,y+30);\r
+ fi;\r
+ call move(x+4,y+27);\r
+ call draw(x+4,y+30);\r
+ call move(x+5,y+27);\r
+ call draw(x+5,y+30);\r
+ end semafv;\r
+ \r
+ \r
+ unit semafh:procedure(x,y:integer,upp:boolean);\r
+ begin (* rysowanie poziomych sygnalizatorow "swiatel" *)\r
+ if upp then x:=x+3 fi;\r
+ call move(x,y);\r
+ call draw(x,y+9);\r
+ call draw(x+27,y+9);\r
+ call draw(x+27,y);\r
+ call draw(x,y);\r
+ call move(x+9,y);\r
+ call draw(x+9,y+9);\r
+ call move(x+18,y);\r
+ call draw(x+18,y+9);\r
+ if upp then\r
+ x:=x-30;\r
+ call move(x+27,y);\r
+ call draw(x+27,y+9);\r
+ else\r
+ call move(x+30,y);\r
+ call draw(x+30,y+9);\r
+ fi;\r
+ call move(x+27,y+4);\r
+ call draw(x+30,y+4);\r
+ call move(x+27,y+5);\r
+ call draw(x+30,y+5);\r
+ end semafh;\r
+ \r
+ unit ser:class(og:boolean,x,y:integer);\r
+ (* klasa sygnalizator swietlny*)\r
+ end ser;\r
+ \r
+(* 3 kolejne procedury to graficzne zapalanie swiatel na skrzyzowaniach *)\r
+ \r
+ unit semh:procedure(a:arrayof integer,s:integer);\r
+ var x,y,i:integer;\r
+ begin\r
+ for i:=lower(a) to upper(a) do\r
+ x:=sem(a(i)).x;\r
+ y:=sem(a(i)).y;\r
+ if not sem(a(i)).og then\r
+ call seml(x,x+9,x+18,y,y,y,s);\r
+ else\r
+ call seml(x,x-9,x-18,y,y,y,s);\r
+ fi;\r
+ od;\r
+ end semh;\r
+ \r
+ \r
+ unit semv:procedure(a:arrayof integer,s:integer);\r
+ var x,y,i:integer;\r
+ begin\r
+ for i:=lower(a) to upper(a) do\r
+ x:=sem(a(i)).x;\r
+ y:=sem(a(i)).y;\r
+ if not sem(a(i)).og then\r
+ call seml(x,x,x,y,y+9,y+18,s);\r
+ else\r
+ call seml(x,x,x,y,y-9,y-18,s);\r
+ fi;\r
+ od;\r
+ end semv;\r
+ \r
+ \r
+ unit seml :procedure(x1,x2,x3,y1,y2,y3,s:integer);\r
+ begin\r
+ case s\r
+ when 0:call move(x1,y1);\r
+ call hascii(0);\r
+ call move(x2,y2);\r
+ call hascii(0);\r
+ call move(x3,y3);\r
+ call hascii(42);\r
+ when 1:call move(x3,y3);\r
+ call hascii(0);\r
+ call move(x2,y2);\r
+ call hascii(42);\r
+ when 2:call move(x2,y2);\r
+ call hascii(0);\r
+ call move(x1,y1);\r
+ call hascii(42);\r
+ when 3:call move(x2,y2);\r
+ call hascii(42);\r
+ esac;\r
+end seml;\r
+ \r
+ \r
+unit parking:procedure(ni:integer,bol:boolean);\r
+ var i,j,k,b,x,y:integer;\r
+ begin\r
+ if ni=11 then x:=457;y:=127;\r
+ else x:=162;y:=286;\r
+ fi;\r
+ k:=1;\r
+ if bol then\r
+ while park(ni,k) do k:=k+1 od;\r
+ b:=2;\r
+ park(ni,k):=true;\r
+ else\r
+ while not park(ni,k) do k:=k+1 od;\r
+ b:=4;\r
+ park(ni,k):=false;\r
+ fi;\r
+ j:=k div 15;\r
+ i:=k mod 15;\r
+ x:=x+9*i;\r
+ y:=y-14*j;\r
+ call move(x,y);\r
+ call putmap(c(b));\r
+end parking;\r
+ \r
+ \r
+unit intoq:procedure(d,i:integer,bol:boolean);\r
+ (* rysowanie samochodu *);\r
+ var a,b,x,y:integer;\r
+ unit los:procedure;\r
+ begin\r
+ case d\r
+ when 1:y:=76;x:=-2+i*12;\r
+ when 2:y:=99;x:=102-i*12;\r
+ when 3:y:=76;x:=110+i*12;\r
+ when 4:y:=99;x:=330-i*12;\r
+ when 5:y:=76;x:=341+i*12;\r
+ when 6:y:=99;x:=590-i*12;\r
+ when 7:y:=208;x:=110+i*12;\r
+ when 8:y:=218;x:=330-i*12;\r
+ when 9:x:=105;y:=204-i*12;\r
+ when 10:x:=117;y:=95+i*12;\r
+ when 11:x:=105;y:=333-i*12;\r
+ when 12:x:=117;y:=214+i*12;\r
+ when 13:x:=333;y:=204-i*12;\r
+ when 14:x:=343;y:=95+i*12;\r
+ when 15:x:=333;y:=333-i*12;\r
+ when 16:x:=343;y:=214+i*12;\r
+ when 17:x:=105;y:=70-i*12;\r
+ when 18:x:=117;y:=-6+i*12;\r
+ when 19:y:=76;x:=485+i*12;\r
+ when 20:y:=99;x:=488-i*12;\r
+ when 21:y:=76;x:=341+i*12;\r
+ when 22:y:=99;x:=590-i*12;\r
+ when 23:y:=208;x:=218+i*12;\r
+ when 24:y:=218;x:=221-i*12;\r
+ when 25:y:=208;x:=110+i*12;\r
+ when 26:y:=218;x:=330-i*12;\r
+ esac;\r
+ \r
+ end los;\r
+ \r
+ begin\r
+ if i=/=0 then\r
+ call los;\r
+ call move(x,y);\r
+ if d>8 and d<19 then b:=2 else b:=1 fi;\r
+ if bol then\r
+ call putmap(c(b));\r
+ else\r
+ call putmap(c(b+2));\r
+ fi;\r
+ fi;\r
+ end intoq;\r
+ \r
+ var drogi,park:arrayof arrayof boolean;\r
+ var i,j:integer;\r
+ var sem:arrayof ser;\r
+ \r
+ begin\r
+ array drogi dim (1:26);\r
+ for i:=23 to 26 do\r
+ array drogi(i) dim(1:8);\r
+ od;\r
+ for i:=11 to 16 do\r
+ array drogi(i) dim(1:10);\r
+ od;\r
+ array drogi(1) dim(1:8);\r
+ array drogi(2) dim(1:8);\r
+ array drogi(3) dim(1:17);\r
+ array drogi(4) dim(1:17);\r
+ array drogi(5) dim(1:20);\r
+ array drogi(6) dim(1:20);\r
+ array drogi(7) dim(1:17);\r
+ array drogi(8) dim(1:17);\r
+ array drogi(9) dim(1:9);\r
+ array drogi(10) dim(1:9);\r
+ array drogi(13) dim(1:9);\r
+ array drogi(14) dim(1:9);\r
+ array drogi(17) dim(1:6);\r
+ array drogi(18) dim(1:6);\r
+ array drogi(19) dim(1:9);\r
+ array drogi(20) dim(1:11);\r
+ array drogi(21) dim(1:11);\r
+ array drogi(22) dim(1:9);\r
+ array c dim(1:6);\r
+ array sem dim(1:13);\r
+ array ile dim(1:4);\r
+ for i:=1 to 4 do\r
+ array c(i) dim(1:10);\r
+ od;\r
+ array c(5) dim(1:15);\r
+ array c(6) dim(1:15);\r
+ array park dim(10:11);\r
+ array park(10) dim(1:60);\r
+ array park(11) dim(1:6);\r
+ call gron(1); (* rysowanie planu skrzyzowan oraz sygnalizatorow *)\r
+ call start;\r
+ call grtram;\r
+ call move(0,0);\r
+ c(5):=getmap(56,4);\r
+ call mapa;\r
+ call move(100,83);\r
+ c(6):=getmap(140,87);\r
+ call semafv(90,35,true);\r
+ sem(1):=new ser(true,91,57);\r
+ call semafv(90,170,true);\r
+ sem(2):=new ser(true,91,192);\r
+ call semafv(127,229,false);\r
+ sem(3):=new ser(false,128,230);\r
+ call semafv(127,110,false);\r
+ sem(4):=new ser(false,128,111);\r
+ call semafv(318,170,true);\r
+ sem(5):=new ser(true,319,192);\r
+ call semafv(356,229,false);\r
+ sem(6):=new ser(false,357,230);\r
+ call semafv(356,110,false);\r
+ sem(7):=new ser(false,357,111);\r
+ call semafh(127,56,false);\r
+ sem(8):=new ser(false,128,57);\r
+ \r
+ call semafh(356,56,false);\r
+ sem(9):=new ser(false,357,57);\r
+ call semafh(70,110,true);\r
+ sem(10):=new ser(true,92,111);\r
+ call semafh(298,110,true);\r
+ sem(11):=new ser(true,320,111);\r
+ call semafh(127,191,false);\r
+ sem(12):=new ser(false,128,192);\r
+ call semafh(298,229,true);\r
+ sem(13):=new ser(true,320,230);\r
+ end graf;\r
+ \r
+ \r
+ \r
+unit droga:simulation class;\r
+ unit zmiany:procedure;\r
+ const qord=113;\r
+ const zord=122;\r
+ const sord=115;\r
+ const oord=111;\r
+ const bord=98;\r
+ var k,l:integer;\r
+ var t:real;\r
+ begin\r
+ t:=time;\r
+ k:=1;\r
+ while k=/=0 do\r
+ k:=gr.inkey;\r
+ od;\r
+ while k=0 do\r
+ k:=gr.inkey;\r
+ od;\r
+ case k\r
+ when qord:call gr.groff;\r
+ call endrun;\r
+ when zord:call change;\r
+ esac;\r
+ end zmiany;\r
+ \r
+ unit change:procedure;\r
+ var x,y,i:integer;\r
+ begin\r
+ call gr.move(595,150);\r
+ call gr.outhline(unpack("ktore skrzyz."));\r
+ i:=gr.cyfra(gr.inhline(600,160,1));\r
+ if i>0 and i<5 then\r
+ call gr.move(595,170);\r
+ call gr.outhline(unpack("zielone ?"));\r
+ cros(i) qua cross.htim:=gr.cyfra(gr.inhline(600,180,2));\r
+ call gr.move(595,190);\r
+ call gr.outhline(unpack("zolte ?"));\r
+ cros(i) qua cross.otim:=gr.cyfra(gr.inhline(600,200,2));\r
+ call gr.move(595,210);\r
+ call gr.outhline(unpack("czerwone ?"));\r
+ cros(i) qua cross.vtim:=gr.cyfra(gr.inhline(600,220,2));\r
+ fi;\r
+ for i:=1 to 8 do\r
+ call gr.move(594,140+i*10);\r
+ call gr.outhline(unpack(" "));\r
+ od;\r
+ end change;\r
+ \r
+ \r
+ unit cross:simprocess class;(* skrzyzowanie *);\r
+ var co,ro,sh,sv:arrayof integer;\r
+ var qu :arrayof kolej;\r
+ var openz,tr :arrayof boolean;\r
+ var vtim,htim,otim,sctim :integer;(* czas swiecenia sygnalizatora *);\r
+ var sigsta :integer;(* stan sygnalizatorow na skrzyzowaniu *);\r
+ var ver,hor :integer;(* liczba kolejek pionowych i poziomych *);\r
+ var bzi :integer;\r
+ unit outfrom:procedure(a,b:integer);(* wypychanie samochodow z kolejek *);\r
+ var i:integer;\r
+ var ok :boolean;\r
+ begin\r
+ ok:=true;\r
+ while time<=sctim and ok do\r
+ ok:=false;\r
+ for i:=a to b do\r
+ if not qu(i).endc then call run (qu(i).firstq);ok:=true; fi;\r
+ od;\r
+ od;\r
+ end outfrom;\r
+ \r
+ begin\r
+ otim:=5;\r
+ array tr dim (1:2);\r
+ array openz dim(1:2);\r
+ do\r
+ bzi:=gr.inkey;\r
+ if bzi=32 then call zmiany fi;;\r
+ sigsta:=(sigsta + 1) mod 4;(* zmiana swiatel*);\r
+ call gr.semh(sh,sigsta);\r
+ call gr.semv(sv,(sigsta+2)mod 4);\r
+ call gr.ilep;\r
+ case sigsta\r
+ when 0:openz(1):=true;\r
+ if tr(1) then tr(1):=false;call run(tramm(1)) fi;\r
+ if tr(2) then tr(2):=false;call run(tramm(2)) fi;\r
+ sctim:=time+htim;\r
+ call outfrom(1,hor);\r
+ when 1: openz(1):=false;\r
+ sctim:=time+otim;\r
+ when 2: openz(2):=true;\r
+ sctim:=time+vtim;\r
+ call outfrom(hor+1,ver+hor);\r
+ when 3: openz(2):=false;\r
+ sctim:=time+otim;\r
+ esac;\r
+ call schedule(this cross,sctim);\r
+ od;\r
+ end cross;\r
+ \r
+ \r
+ unit wolno:function(a,b:integer):integer;(* obliczenie miejsca *)\r
+ var bol:boolean; (* stania na skrzyzowaniu *)\r
+ begin\r
+ if a>0 and a<5 then\r
+ case a\r
+ when 1,2 :if b>8 and b<19 then\r
+ bol:=cros(a) qua cross.openz(2);\r
+ result:=b mod 2 +3\r
+ else\r
+ bol:=cros(a) qua cross.openz(1);\r
+ result:=b mod 2 +1;\r
+ fi;\r
+ when 3,4 :if (b<9 or b>18) and b=/=0 then\r
+ result:=1;\r
+ bol:=cros(a) qua cross.openz(1);\r
+ else\r
+ result:=b mod 2 +2;\r
+ bol:=cros(a) qua cross.openz(2);\r
+ fi;\r
+ esac;\r
+ if bol then (*and cros(a) qua cross.qu(result).endc*)\r
+ result:=0;\r
+ fi;\r
+ else result:=0;\r
+ fi;\r
+ end wolno;\r
+ \r
+ \r
+ unit wyjazd:simprocess class;\r
+ var co,ro:arrayof integer;\r
+ end wyjazd;\r
+ \r
+ unit parking:simprocess class(poj:integer);\r
+ var co,ro:arrayof integer;\r
+ var cars:integer;\r
+ unit park :procedure(a:car);\r
+ var i:integer;\r
+ begin\r
+ if cars<poj then\r
+ cars:=cars+1;\r
+ a.bol:=true;\r
+ a.stp:=a.nr;\r
+ while a.finp=a.stp do\r
+ a.finp:=random*7+5; (* losowanie wyjazdu *)\r
+ od;\r
+ call gr.parking(a.nr,true);\r
+ i:=150+random*360;\r
+ call schedule(a,time+i);\r
+ else\r
+ a.bol:=false;\r
+ if a.nr=10 then a.finp:=11 else a.finp:=10 fi;\r
+ call schedule(a,time+2);\r
+ fi;\r
+ end park;\r
+ end parking;\r
+ \r
+ unit kolej:class(nr:integer);\r
+ var il:integer;\r
+ unit elcar:class(p:car);\r
+ var next:elcar;\r
+ end elcar;\r
+ var first,last:elcar;\r
+ \r
+ unit insert :procedure(p:car);\r
+ begin\r
+ if first=none then\r
+ first,last:=new elcar(p);\r
+ else\r
+ last.next:=new elcar(p);\r
+ last:=last.next;\r
+ fi;\r
+ il:=il+1;\r
+ end insert;\r
+ \r
+ unit firstq:function:car;\r
+ begin\r
+ if first=/=none then\r
+ result:=first.p;\r
+ if first.next=/=none then\r
+ first:=first.next;\r
+ else first:=none;last:=none;\r
+ fi;\r
+ if il>0 then\r
+ il:=il-1;\r
+ fi;\r
+ fi;\r
+ end firstq;\r
+ \r
+ unit endc:function:boolean;\r
+ begin\r
+ result:=(first=none);\r
+ end endc;\r
+ \r
+ begin (* kolej *)\r
+ il:=0;\r
+ end kolej;\r
+ \r
+ \r
+ unit road:class(distance,line,speed:integer);(* droga *)\r
+ var cars :integer;\r
+ end road;\r
+ \r
+ \r
+ unit rotime: function (d,s:integer):integer;(* czas pokonania danej drogi *);\r
+ var min:integer;\r
+ begin\r
+ if s < roads(d).speed then min := s\r
+ else min:=roads(d).speed;\r
+ fi;\r
+(*result:=roads(d).distance*3.6*((1+.1*roads(d).cars)/10*roads(d).line)/min;*)\r
+ result:=30;\r
+ end rotime;\r
+ \r
+ unit car:simprocess class(max:integer);\r
+ var stp,finp,old,where,nr,nero,wol:integer;\r
+ var tim,bla,ble,zw:integer;\r
+ var bol:boolean;\r
+ \r
+ unit jedziecar:procedure(d,t:integer);\r
+ var j,k,tim:integer;\r
+ begin\r
+ case d\r
+ when 1,2:j:=7;\r
+ when 3,4,7,8:j:=16;\r
+ when 5,6:j:=19;\r
+ when 9,10,13,14,19,22:j:=8;\r
+ when 17,18:j:=5;\r
+ when 11,12,15,16:j:=9;\r
+ \r
+ when 20,21:j:=10;\r
+ when 23,24,25,26:j:=7;\r
+ esac ;\r
+ tim:=t/j;\r
+ for k:=j downto 1 do\r
+ if not gr.drogi(d,k) then\r
+ gr.drogi(d,k):=true;\r
+ gr.drogi(d,k+1):=false;\r
+ call gr.intoq(d,k+1,false);\r
+ call gr.intoq(d,k,true);\r
+ zw:=k;\r
+ fi;\r
+ call hold(tim);\r
+ od;\r
+ end jedziecar;\r
+ \r
+ begin (* algorytm car *)\r
+ do\r
+ finp,stp:=random*5+5; (*losowanie wjazdu *)\r
+ while finp=stp do\r
+ finp:=random*7+5; (* losowanie wyjazdu *)\r
+ od;\r
+ tim:=360+random*360; (* czas pierwszego pojawienia sie *)\r
+ call schedule(this car,time+tim);\r
+ old:=0;\r
+ bol:=false;\r
+ nr:=stp;\r
+ where:=nr; (* gdzie jest *)\r
+ do\r
+ nr:=where;\r
+ if nr=finp then (* czy dojechal do wyjazdu *)\r
+ if old=/=0 then\r
+ call gr.intoq(old,zw,false);\r
+ gr.drogi(old,zw):=false;\r
+ fi;\r
+ if nr>9 then call cros(nr) qua parking.park(this car);\r
+ if bol then call gr.parking(nr,false);\r
+ cros(nr) qua parking.cars:=cros(nr) qua parking.cars-1;\r
+ fi;\r
+ else exit\r
+ fi;\r
+ fi;\r
+ case nr (* co robic w zaleznosci od miejsca pobytu *)\r
+ when 1,2,3,4 : where:=cros(nr) qua cross.co(finp);\r
+ (*skrzyzowanie *)\r
+ nero:=cros(nr) qua cross.ro(where);\r
+ gr.ile(nr):=gr.ile(nr)+1;\r
+ when 5,6,7,8,9: where:=cros(nr) qua wyjazd.co(finp);\r
+ (*wyjazd-wjazd *)\r
+ nero:=cros(nr) qua wyjazd.ro(where);\r
+ when 10,11 : where:=cros(nr) qua parking.co(finp);\r
+ (*parking *)\r
+ nero:=cros(nr) qua parking.ro(where);\r
+ esac;\r
+ wol:=wolno(nr,old);\r
+ if wol=/=0 then\r
+ call cros(nr) qua cross.qu(wol).insert(this car);\r
+ call passivate;\r
+ fi;\r
+ tim:=rotime(nero,max);\r
+ roads(nero).cars:=roads(nero).cars+1;\r
+ if old=/=0 and nr=/=10 and nr=/=11 then\r
+ call gr.intoq(old,zw,false);\r
+ gr.drogi(old,zw):=false;\r
+ fi;\r
+ \r
+ call jedziecar(nero,tim);\r
+ old:=nero;\r
+ roads(nero).cars:=roads(nero).cars-1;\r
+ od;\r
+ od;\r
+ end car;\r
+ \r
+ unit tram:simprocess class(a:integer);\r
+ var b,i,y,x1,x2:integer;\r
+ var t:arrayof integer;\r
+ unit jazda:procedure(d:integer);\r
+ var x,p,i:integer;\r
+ var bol:boolean;\r
+ begin\r
+ p:=8;\r
+ if a=1 then\r
+ bol:=true;\r
+ else\r
+ p:=-8;\r
+ fi;\r
+ case d\r
+ when 1:d:=15;x:=125;\r
+ when 2:d:=7;x:=10;\r
+ when 3:d:=29;x:=349;\r
+ when 4:d:=29;x:=58;\r
+ when 5:d:=24;x:=533;\r
+ when 6:d:=32;x:=282;\r
+ esac;\r
+ for i:=1 to d do\r
+ call gr.move(x,y);\r
+ call gr.putmap(gr.c(5));\r
+ x:=x+p;\r
+ call hold(2);\r
+ od;\r
+ end jazda;\r
+ begin\r
+ array t dim(1:5);\r
+ if a=1 then\r
+ t(1),t(4):=2;\r
+ t(2):=1;\r
+ t(3):=4;\r
+ t(5):=6;\r
+ else\r
+ t(1):=5;\r
+ t(2):=2;\r
+ t(3):=3;\r
+ t(4),t(5):=1;\r
+ fi;\r
+ if a=1 then y:=90;x2:=538\r
+ else y:=83;x2:=21; fi;\r
+ do\r
+ b:=random*60+60;\r
+ call schedule(this tram,time+b);\r
+ call jazda(t(1));\r
+ if wolno(t(2),t(1))=/=0 then\r
+ cros(t(2)) qua cross.tr(a):=true;\r
+ call passivate;\r
+ fi;\r
+ call jazda(t(3));\r
+ call hold(30);\r
+ if not cros(t(4)) qua cross.openz(1) then\r
+ cros(t(4)) qua cross.tr(a):=true;\r
+ call passivate;\r
+ fi;\r
+ call jazda(t(5));\r
+ call gr.move(x2,y);\r
+ call gr.putmap(gr.c(6));\r
+ call hold(60);\r
+ od;\r
+ end tram;\r
+ \r
+ \r
+ unit gencar:simprocess class;(* generator samochodow *);\r
+ var t,i,b:integer;\r
+ var p:car;\r
+ begin\r
+ for i:=1 to 10 do (******?????bylo 20 ????*****)\r
+ t:=random*36;\r
+ b:=random*(41)+60;\r
+ p:=new car(b);\r
+ call schedule(p,t);\r
+ readln ; (* to ja ???????????*)\r
+ od;\r
+ readln ; (* to ja ???????????*)\r
+ \r
+ for i:=1 to 4 do\r
+ call schedule(cros(i),time+i);\r
+ od;\r
+ call schedule(tramm(1),time+3);\r
+ call schedule(tramm(2),time+4);\r
+ call hold(6000);\r
+ call run(mainpr)\r
+ end gencar;\r
+ \r
+ var i,j:integer,\r
+ g:gencar,\r
+ cros :arrayof simprocess,\r
+ roads :arrayof road,\r
+ tramm:arrayof tram,\r
+ gr:graf;\r
+ \r
+ unit prepkol:procedure;\r
+ begin\r
+ array cros(1) qua cross.qu dim(1:4);\r
+ array cros(2) qua cross.qu dim(1:3);\r
+ array cros(3) qua cross.qu dim(1:3);\r
+ array cros(4) qua cross.qu dim(1:3);\r
+ cros(1) qua cross.qu(1):=new kolej(2);\r
+ cros(1) qua cross.qu(2):=new kolej(3);\r
+ cros(1) qua cross.qu(3):=new kolej(10);\r
+ cros(1) qua cross.qu(4):=new kolej(17);\r
+ cros(2) qua cross.qu(1):=new kolej(4);\r
+ cros(2) qua cross.qu(2):=new kolej(5);\r
+ cros(2) qua cross.qu(3):=new kolej(14);\r
+ cros(3) qua cross.qu(1):=new kolej(7);\r
+ cros(3) qua cross.qu(2):=new kolej(12);\r
+ cros(3) qua cross.qu(3):=new kolej(9);\r
+ cros(4) qua cross.qu(1):=new kolej(8);\r
+ cros(4) qua cross.qu(2):=new kolej(16);\r
+ cros(4) qua cross.qu(3):=new kolej(13);\r
+ end prepkol;\r
+ \r
+ \r
+ unit preproad:procedure;\r
+ begin\r
+ array roads dim(1:26);\r
+ roads(1):=new road(90,1,90);\r
+ roads(2):=new road(90,1,90);\r
+ roads(3):=new road(400,1,80);\r
+ roads(4):=new road(400,1,80);\r
+ roads(5):=new road(400,1,90);\r
+ roads(6):=new road(400,1,90);\r
+ roads(7):=new road(400,1,70);\r
+ roads(8):=new road(400,1,70);\r
+ roads(9):=new road(200,1,70);\r
+ \r
+ roads(10):=new road(200,1,70);\r
+ roads(11):=new road(220,1,70);\r
+ roads(12):=new road(220,1,70);\r
+ roads(13):=new road(200,1,70);\r
+ roads(14):=new road(200,1,70);\r
+ roads(15):=new road(220,1,70);\r
+ roads(16):=new road(220,1,70);\r
+ roads(17):=new road(100,1,70);\r
+ roads(18):=new road(100,1,70);\r
+ roads(19):=new road(160,1,90);\r
+ roads(20):=new road(240,1,90);\r
+ roads(21):=new road(240,1,90);\r
+ roads(22):=new road(160,1,90);\r
+ roads(23):=new road(200,1,70);\r
+ roads(24):=new road(200,1,70);\r
+ roads(25):=new road(200,1,70);\r
+ roads(26):=new road(200,1,70);\r
+ end preproad;\r
+ \r
+ begin\r
+ gr:=new graf;\r
+ array cros dim(1:11);\r
+ for i:=1 to 4 do\r
+ cros(i):=new cross;\r
+ od;\r
+ for i:=5 to 9 do\r
+ cros(i):=new wyjazd;\r
+ od;\r
+ cros(10):=new parking(60);\r
+ cros(11):=new parking(6);\r
+ array tramm dim(1:2);\r
+ tramm(1):=new tram(1);\r
+ tramm(2):=new tram(2);\r
+ \r
+ call preproad;\r
+ array cros(1) qua cross.sh dim(1:2);\r
+ array cros(2) qua cross.sh dim(1:2);\r
+ array cros(3) qua cross.sh dim(1:1);\r
+ array cros(4) qua cross.sh dim(1:1);\r
+ array cros(1) qua cross.sv dim(1:2);\r
+ array cros(2) qua cross.sv dim(1:1);\r
+ array cros(3) qua cross.sv dim(1:2);\r
+ array cros(4) qua cross.sv dim(1:2);\r
+ for i:=1 to 4 do\r
+ cros(i) qua cross.hor:=1;\r
+ cros(i) qua cross.ver:=2;\r
+ od;\r
+ cros(1) qua cross.hor:=2;\r
+ cros(2) qua cross.hor:=2;\r
+ cros(2) qua cross.ver:=1;\r
+ cros(1) qua cross.sh(1):=8;\r
+ \r
+ cros(1) qua cross.sh(2):=10;\r
+ cros(2) qua cross.sh(1):=9;\r
+ cros(2) qua cross.sh(2):=11;\r
+ cros(3) qua cross.sh(1):=12;\r
+ cros(4) qua cross.sh(1):=13;\r
+ cros(1) qua cross.sv(1):=1;\r
+ cros(1) qua cross.sv(2):=4;\r
+ cros(2) qua cross.sv(1):=7;\r
+ cros(3) qua cross.sv(1):=2;\r
+ cros(3) qua cross.sv(2):=3;\r
+ cros(4) qua cross.sv(1):=5;\r
+ cros(4) qua cross.sv(2):=6;\r
+ for i:=1 to 4 do\r
+ array cros(i) qua cross.co dim (5:11);\r
+ od;\r
+ for i:=5 to 9 do\r
+ array cros(i) qua wyjazd.co dim (5:11);\r
+ od;\r
+ array cros(10) qua parking.co dim (5:11);\r
+ array cros(11) qua parking.co dim (5:11);\r
+ for i:=5 to 11 do\r
+ cros(1) qua cross.co(i):=2;\r
+ cros(2) qua cross.co(i):=1;\r
+ cros(3) qua cross.co(i):=1;\r
+ cros(4) qua cross.co(i):=2;\r
+ cros(5) qua wyjazd.co(i):=3;\r
+ cros(6) qua wyjazd.co(i):=4;\r
+ cros(7) qua wyjazd.co(i):=2;\r
+ cros(8) qua wyjazd.co(i):=1;\r
+ cros(9) qua wyjazd.co(i):=1;\r
+ cros(10) qua parking.co(i):=3;\r
+ cros(11) qua parking.co(i):=2;\r
+ od;\r
+ cros(1) qua cross.co(5):=3;\r
+ cros(1) qua cross.co(8):=8;\r
+ cros(1) qua cross.co(9):=9;\r
+ cros(1) qua cross.co(10):=3;\r
+ cros(2) qua cross.co(6):=4;\r
+ cros(2) qua cross.co(7):=7;\r
+ cros(2) qua cross.co(10):=4;\r
+ cros(2) qua cross.co(11):=11;\r
+ cros(3) qua cross.co(5):=5;\r
+ cros(3) qua cross.co(6):=4;\r
+ cros(3) qua cross.co(10):=10;\r
+ cros(4) qua cross.co(5):=3;\r
+ cros(4) qua cross.co(6):=6;\r
+ cros(4) qua cross.co(10):=10;\r
+ cros(7) qua wyjazd.co(11):=11;\r
+ cros(10) qua parking.co(6):=4;\r
+ cros(10) qua parking.co(7):=4;\r
+ cros(10) qua parking.co(11):=4;\r
+ cros(11) qua parking.co(7):=7;\r
+ array cros(1) qua cross.ro dim(2:9);\r
+ array cros(2) qua cross.ro dim(1:11);\r
+ array cros(3) qua cross.ro dim(1:10);\r
+ array cros(4) qua cross.ro dim(2:10);\r
+ array cros(5) qua wyjazd.ro dim(3:3);\r
+ \r
+ array cros(6) qua wyjazd.ro dim(4:4);\r
+ array cros(7) qua wyjazd.ro dim(2:11);\r
+ array cros(8) qua wyjazd.ro dim(1:1);\r
+ array cros(9) qua wyjazd.ro dim(1:1);\r
+ array cros(10) qua parking.ro dim(3:4);\r
+ array cros(11) qua parking.ro dim(2:7);\r
+ cros(1) qua cross.ro(2):=4;\r
+ cros(1) qua cross.ro(3):=9;\r
+ cros(1) qua cross.ro(8):=18;\r
+ cros(1) qua cross.ro(9):=1;\r
+ cros(2) qua cross.ro(1):=3;\r
+ cros(2) qua cross.ro(4):=13;\r
+ cros(2) qua cross.ro(7):=6;\r
+ cros(2) qua cross.ro(11):=20;\r
+ cros(3) qua cross.ro(1):=10;\r
+ cros(3) qua cross.ro(4):=8;\r
+ cros(3) qua cross.ro(5):=11;\r
+ cros(3) qua cross.ro(10):=24;\r
+ cros(4) qua cross.ro(2):=14;\r
+ cros(4) qua cross.ro(3):=7;\r
+ cros(4) qua cross.ro(6):=15;\r
+ cros(4) qua cross.ro(10):=23;\r
+ \r
+ cros(5) qua wyjazd.ro(3):=12;\r
+ cros(6) qua wyjazd.ro(4):=16;\r
+ cros(7) qua wyjazd.ro(2):=5;\r
+ cros(7) qua wyjazd.ro(11):=19;\r
+ cros(8) qua wyjazd.ro(1):=17;\r
+ cros(9) qua wyjazd.ro(1):=2;\r
+ cros(10) qua parking.ro(3):=25;\r
+ cros(10) qua parking.ro(4):=26;\r
+ cros(11) qua parking.ro(2):=21;\r
+ cros(11) qua parking.ro(7):=22;\r
+ cros(1) qua cross.htim:=60;\r
+ cros(1) qua cross.vtim:=30;\r
+ cros(2) qua cross.htim:=60;\r
+ cros(2) qua cross.vtim:=30;\r
+ cros(3) qua cross.htim:=40;\r
+ cros(3) qua cross.vtim:=50;\r
+ cros(4) qua cross.htim:=40;\r
+ cros(4) qua cross.vtim:=50;\r
+ cros(1) qua cross.sigsta:=0;\r
+ cros(2) qua cross.sigsta:=0;\r
+ cros(3) qua cross.sigsta:=0;\r
+ cros(4) qua cross.sigsta:=0;\r
+ call prepkol;\r
+ readln;\r
+ g:=new gencar;\r
+ readln; (*??????? to ja ????? *)\r
+ call run(g);\r
+ end droga;\r
+ \r
+begin\r
+ pref droga block\r
+ begin\r
+ call hold(6000);\r
+ end;\r
+ end;\r
+ call gr.groff;\r
+end;\r
+ \r
--- /dev/null
+\r
+ OPCODES USED FOR FOURS GENERETED BY THE PART\r
+ OF SEMANTICAL ANALYZER OF CODE GENERATOR\r
+\r
+ Opcodes were divided in relation to number of arguments, to which\r
+they assign values (2,1,0) and then in each group in relation to\r
+number of arguments being addresses in symbol table.\r
+ The rest of not mentioned arguments are: \r
+-- values of canstants represented by INTEGER,\r
+-- numbers of REAL constants,\r
+-- addresses of atributes after dot in IPMEM,\r
+-- addresses of prototypes in IPMEM.\r
+\r
+ Short forms:\r
+-- AF - phisical address,\r
+-- AV - virtual address.\r
+\r
+ \r
+\r
+--------------returning two arguments\r
+----2 ARG.\r
+1 OPENRC A:=AV of new record B:=AF C=PROTOTYP(address in IPMEM)\r
+2 BACK A:=AV B:=AF of record from which follow return\r
+3 RAISE open record of handler A:=AH B:=AF C=number of signal\r
+\r
+----3 ARG.\r
+\r
+4 OPEN A:=AH B:=AF of new record C=prototype of genereted record\r
+5 SLOPEN A:=AH B:=AF of new record C=AV of father synthetizing prototype\r
+\r
+\r
+---------- returning one argument\r
+---- 1 ARG.\r
+\r
+11 CLEAR 1,2 words A:=0\r
+12\r
+13 take the value A from register B B>0 means number of register A:=reg\r
+ B<0 means offset (negative) in relation to (R6)\r
+15 THIS A:=contents of DISPLAY (AV) for B B=address in IPMEM\r
+16 insert prototype A:=number of prototype B B=address in IPMEM\r
+20 VIRT.DISPLAY A:=prototype of virtual of number C from DISPLAY for B\r
+21 insert static type A:=(B,C) B:=constant<64 C=number of prototype\r
+22 read formal type through DISPLAY A:=formal type B=number in DISPLAY\r
+ (address of prototype in IPMEM) C=address of description of type in IPMEM\r
+23 PARAMETR OUTPUT A:=value of parameter( C=number of paremeter)\r
+ for standard procedure B (it reads parameter.output or\r
+ value of function for standard procedure)\r
+\r
+---- 2 ARG.\r
+\r
+29 address of variable using "." operator A:=address(B.C) (B-A0,C-offset)\r
+30 address of visible variable A:=address(B)\r
+31 SIGN A:=SIGN(B) (B - INTEGER or REAL)\r
+32 add 1 to atribute A:=B+1\r
+33 lower from MEMBER A:=LOWER(B) B=AV\r
+34 lower without MEMBER A:=LOWER(B) B=AV\r
+35 upper from MEMBER A:=UPPER(B) B=AV\r
+36 upper without MEMBER A:=UPPER(B) B=AV\r
+37 add constant A:=B+C C - constant INTEGER\r
+38 MOVE & SAVE substitute A:=B and store in working variable \r
+39 add short const. A:=B+C C-short const.\r
+40 read type of formal parameter A:=type of parameter of number C \r
+ B=AF of data record\r
+41 COPY A:=COPY B\r
+42 NOT A:=NOT B\r
+43 take AV A:=AV reconstracted from B=AH\r
+44 VIRT.DOT from MEMBER A:=prototype of virtual B=AV\r
+45 VIRT.DOT bez MEMBER A:=prototype of virtual without MEMBER\r
+46 take AF from MEMBER A:=AF from virtual B from MEMBER\r
+47 take AF without MEMBER A:=AF without MEMBER\r
+48 ABS INTEGER A:=ABS(B)\r
+49 MINUS UNARNY INTEGER A:=-B\r
+50 ABS REAL\r
+51 MINUS UNARNY REAL\r
+52 take AF of parameter A:=AF C=number of paramteter B=AF of record\r
+53 cyclic SHIFT towards left of constant A:=ISHIFT(B,CONST.C)\r
+54 find using SL-link formal type A:=formal type B=AV or AH\r
+ C=address of type description in IPMEM\r
+55 IS A:=B IS C B=AV C=address of prototype in IPMEM\r
+56 IN\r
+57 QUA A:=AF from AV B with control QUA C C=addresd in IPMEM\r
+58 IFIX A:=IFIX(B)\r
+59 FLOAT A:=FLOAT(B)\r
+60 MOVE A:=B\r
+61 read 1,2,3 words from AF A:=(B)\r
+62 read 1,2,3 words from AF A:=(B) \r
+63 read 1,2,3 words from AF A:=(B)\r
+64 multiplication by 2 A:=2*B\r
+65 multiplication by 3 A:=3*B\r
+66 multiplication by 4\r
+67 multiplication by 5\r
+68 multiplication by 6\r
+69 multiplication by 7\r
+70 multiplication by 8\r
+71 multiplication by 9\r
+72 multiplication by 10\r
+73 division by 8 A:=B/8\r
+74 division by 4\r
+75 division by 2\r
+76 EQ 0 comparision with zero A:=B .EQ. 0 B-INTEGER or REAL\r
+77 NE 0\r
+78 LT 0\r
+79 LE 0\r
+80 GT 0\r
+81 GE 0\r
+82 NOT MEMBER A:=B .EQ. NONE B=AV\r
+83 MEMBER A:=B .NE. NONE\r
+84 read 1,2,3 words from record AF=B offset=C A:=B.C\r
+85 ""\r
+86 ""\r
+87 modify type A:=B+C A,B - formal type (2 words) C=short constant\r
+88 EQ CONST comparision with constant INTEGER A:=B .EQ. C C=constant\r
+89 NE CONST ""\r
+90 LT CONST ""\r
+91 LE CONST ""\r
+92 GT CONST ""\r
+93 GE CONST ""\r
+94 EQ SHORT comparision with short constant A:=B .EQ. C C=short constant\r
+95 NE SHORT\r
+96 LT SHORT\r
+97 LE SHORT\r
+98 GT SHORT\r
+99 GE SHORT\r
+\r
+----- 3 ARG.\r
+\r
+100 OR A:=B OR C\r
+101 AND\r
+102 ARRAY with control of indexes, with MEMBER A:=AF of element of array\r
+ B=AV of array C=ATS of index\r
+103 ARRAY with control of indexes, without MEMBER "" ""\r
+104 ARRAY without control of indexes, with MEMBER\r
+105 ARRAY without control of indexes, without MEMBER\r
+106 EQ comparision INTEGER A:=B .EQ. C B,C= ATS values of INTEGER\r
+107 NE "" ""\r
+108 LT "" ""\r
+109 LE "" ""\r
+110 GT "" ""\r
+111 GE "" ""\r
+112 begin in 1 ARG A:=B C B=AV C=number of prototype (insert to R1,R2,R3)\r
+113 + INTEGER A:=B+C\r
+114 - INTEGER A:=B-C\r
+115 * INTEGER A:=B*C\r
+116 cyclic SHIFT towards left A:=ISHIFT(B,C)\r
+117 DIVE INTEGER A:=B DIVE C\r
+118 MODE INTEGER A:=B MODE C\r
+119 + REAL\r
+120 - REAL\r
+121 * REAL\r
+122 / REAL A:=B/C\r
+123 EQ REF A:=B .EQ. C B,C- virtual addresses\r
+124 NE REF A:=B .NE. C\r
+125 EQ REAL A:=B .EQ. C B,C- arguments REAL (can be constant)\r
+126 NE REAL " " "\r
+127 LT REAL " " "\r
+128 LE REAL " " "\r
+129 GT REAL " " "\r
+130 GE REAL " " "\r
+131 XOR A:=B XOR C\r
+\r
+\r
+----------returning zero arguments\r
+---- 0 ARG.\r
+132 CALL standard procedure A=number of standard procedure/function\r
+NOT IMPL - 133 return control to code written in asembler \r
+\r
+---- 1 ARG.\r
+\r
+137 CLEAR 1 word from record which AF=A A.B:=0\r
+138 CLEAR 2 word from record which AF=A A.B:=0\r
+139 insert value of A to register B B>0 means number of register\r
+ B<0 means offset(negative) regard to (R6)\r
+140 NOP null instruction with argument A\r
+141 RELEASE relase variable used for atrybute A (for FOR)\r
+ (delete "alive" working variable)\r
+143 KILL A for blocks,procedures,functions,records,arrays \r
+144 dynamic control of headers A=AV of calling module\r
+ B=number of parameter (function,procedure)\r
+145 parameter INPUT write value of A as a parameter of number C of\r
+ standard procedure B\r
+146 GKILL A universal, with full control\r
+147 CLEAR 1 word from AF=A (A):=0\r
+148 CLEAR 2 words from AF=A (A):=0\r
+149 QUA TEST check correctness A QUA B A=AV B=address in IPMEM\r
+150 STYPE check correctness of substitution L:=A B=type of L (address in IPMEM)\r
+151 IF-FALSE conditional jump A=ATS B=number of label\r
+152 IF-TRUE " " "\r
+153 KILL AFTER RAISE A=AV\r
+158 CANCEL cancel informations : value of atribute A in register\r
+\r
+---- 2 ARG\r
+159 GO transmit control to record: A=AF B=AH\r
+160 GOLOCAL " " " for local without prefix\r
+161 write 1 word into AF (A):=B\r
+162 write 2 words into AF (A):=B\r
+163 write 3 words into AF (A):=B\r
+164 write 1 word into record for which AF=A offset=C A.C:=B\r
+165 write 2 words into record for which AF=A offset=C A.C:=B\r
+166 write 3 words into record for which AF=A offset=C A.C:=B\r
+\r
+----- 3 ARG.\r
+\r
+170 DTYPE check correctness of substitution L:=B A=type of L C=type ofB\r
+\r
+--------requesting special service (172-176,178-194 end segment)\r
+---opcodes which end base block (exeptcion 177)\r
+\r
+172 TERMINATE\r
+173 WIND \r
+174 LAST WILL LABEL\r
+175 JUMP AT LAST WILL A=number of prototype\r
+176 forced end of base block (of segment for existing["alive"] variables)\r
+177 beginig of instruction of number A\r
+178 INNER A=level in prefix sequence\r
+179 FIRST LABEL = enter point to module\r
+180 BACKHD - return through RETURN from HANDLER\r
+181 LABEL A=number of label (for each module labels are numbered starting from 1)\r
+182 JUMP " " "\r
+183 JUMP behind INNER A=address of prefix in IPMEM\r
+184 BEGIN begining of module (A=address in IPMEM)\r
+185 END end of module\r
+186 BLOCK A open record for A (address in IPMEM),transfer control,kill\r
+187 DETACH\r
+188 ATTACH A=current ATS\r
+189 CASE A=ATS of expression B=number label C=SUM of opction C,F\r
+190 ESAC A=number of labels B=base label C=minimal label \r
+ and below A+1 numbers : range of labels and their descriptions\r
+\r
+----- procedures R.S. (return from module)\r
+\r
+191 BACKBL\r
+192 BACKPR\r
+193 BACK\r
+194 FIN\r
+\r
+-------- services of symbol table and ending mark\r
+\r
+195 MOVE & SAVE A:=B enter working atrybute of number A and apetyte like for\r
+ atrybute B and store in working variable\r
+ (create A with apetyte like B and generate A:=B)\r
+197 REAL CONST rezervation of working atrubute contaning REAL constant\r
+ A=number B=index of constant\r
+198 SHORT INT rezervation of working atrubute contaning short constant\r
+ A=number B=value of constant\r
+199 LONG INT normal constant\r
+200 ending mark of code\r
+201 TSTEMP1 rezervation of working atrybute and apetyte 1\r
+ A=address in symbol table\r
+202 TSTEMP2\r
+203 TSTEMP3\r
+204 TSTEMP4\r
+205 TSINSE GLOBALY enter description of declared atrybute in main block\r
+ A=address in symbol table B=address of atrybute\r
+206 TSINSE POREDNI atrybute from indirect module\r
+207 TSINSE LOKALNY local atrybute \r
+208 TSTEMP LIVE rezervation of working atrybute which address is A \r
+ and apetyte 1.This atrybute is "alive" after quiting\r
+ base block (for loop FOR) together with copying \r
+ value of B (A:=B)\r
+--------------------------------------------------------------------------\r
+\ 1\ 1\ 1\ 1\r
--- /dev/null
+The file Lcode contains some information on lcode used by the Loglan system.\r
+\r
+It is not a full list of opcodes.\r
+If you have patience you can look into INT.\r
+Regarder les fichiers \int\execute.c pour les opcodes des processus\r
+\r
+ Andrzej Salwicki\r
+\r
+\r
+Pau, le 26 Septembre 1994
\ No newline at end of file
--- /dev/null
+From: MX%"antek@mimuw.edu.pl" 1-MAR-1993 15:38:21.16\r
+To: SALWICKI\r
+CC: \r
+Subj: \r
+\r
+Date: Mon, 1 Mar 93 14:59:27 GMT\r
+From: antek@mimuw.edu.pl\r
+To: salwicki@pauvx1.univ-pau.fr\r
+\r
+\1cw\r
+\U1STANDARD\r
+\U2POLISH\r
+\U3ITALIC\r
+\U4BOLD\r
+\U"ORATOR\r
+\U(PLORATOR\r
+\+\r
+\+\r
+\ \ \ \ \\r
+\-\r
+\+\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \"PRZENASZALNY RUNNING SYSTEM NOWEGO LOGLANU\ \ \ \ \ \ \ \ \ \ \^\r
+\-\r
+\+\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ NAPISANY W J\(E\"ZYKU C\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \1Antoni Kreczmar\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\r
+\-\r
+\+\r
+\ \\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+1. Wst\2e\1p\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Poni\2x\1szy kr\2o\1tki opis Running Systemu dla \ nowego \ Loglanu \ opiera\r
+\-\r
+\+\r
+si\2e \ \1w \ du\2x\1ym \ stopniu \ na \ poprzednich \ dokumentacjach. \ \ Przede\r
+\-\r
+\+\r
+wszystkim na opisie Running \ Systemu \ Loglanu-82 \ oraz \ na \ dw\2o\1ch\r
+\-\r
+\+\r
+pracach opublikowanych, \ tj. \ G.Cioni, \ "Programmed \ deallocation\r
+\-\r
+\+\r
+without \ dangling \ reference" \ IPL \ 18(1984) \ pp.179-187, \ \ oraz\r
+\-\r
+\+\r
+M.Krause, \ A.Kreczmar, \ H.Langmaack, \ A.Salwicki, \ M.Warpechowski\r
+\-\r
+\+\r
+"Algebraic approach to ...." w Lecture Notes in Computer \ Science\r
+\-\r
+\+\r
+Springer 208, pp.134-156. W pierwszej z tych prac \ opisano \ system\r
+\-\r
+\+\r
+adresowania \ po\2s\1redniego \ dla \ Loglanu, \ \ a \ \ w \ \ drugiej \ \ dosy\2c\r
+\-\r
+\+\r
+\1skomplikowane \ algorytmy \ poprawiania \ \ tablicy \ \ Display \ \ oraz\r
+\-\r
+\+\r
+adresowania nielokalnego dla j\2e\1zyk\2o\1w z metodami dziedziczenia \ na\r
+\-\r
+\+\r
+r\2ox\1nych poziomach. Bez znajomo\2s\1ci \ tych \ dw\2o\1ch \ prac \ zrozumienie\r
+\-\r
+\+\r
+poni\2x\1szego kr\2o\1tkiego raportu jest niezwykle trudne. Radzimy \ wi\2e\1c\r
+\-\r
+\+\r
+przed przyst\2a\1pienie do czytania niniejszego tekstu zapozna\2c \ \1si\2e\r
+\-\r
+\+\r
+\1z tymi dwiema pracami, \ jak \ r\2o\1wnie\2x \ \1z \ dokumentacj\2a \ \1w \ dw\2o\1ch\r
+\-\r
+\+\r
+poprzednich jej postaciach (dla Loglanu-82 w \ pe\2l\1ni \ uruchominego\r
+\-\r
+\+\r
+i dla Loglanu-84 w pr\2o\1bnej wersji loglanowej). \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Nowy RS system dla nowego Loglanu \ zosta\2l \ \1napisany \ najpierw \ w\r
+\-\r
+\+\r
+Loglanie-82, \ a \ nast\2e\1pnie \ w \ j\2e\1zyku \ C. \ Wyb\2o\1r \ j\2e\1zyka \ C \ by\2l\r
+\-\r
+\+\r
+\1nieprzypadkowy. Ot\2ox \1w j\2e\1zyku tym mo\2x\1na wyrazi\2c \ \1wiele \ w\2l\1asno\2s\1ci\r
+\-\r
+\+\r
+niskopoziomowych, a posiada \ on \ tak\2x\1e \ wszystkie \ zalety \ j\2e\1zyka\r
+\-\r
+\+\r
+wysokopoziomowego. Przet\2l\1umaczenie wersji loglanowej na j\2e\1zyk C\r
+\-\r
+\+\r
+nie \ przedstawia\2l\1o \ wi\2e\1kszych \ trudno\2s\1ci, \ umo\2x\1liwi\2l\1o \ natomiast\r
+\-\r
+\+\r
+stworzenie bardzo efektywnego systemu \2l\1atwego do przenoszenia. \,\r
+\-\/\f\r
+\+\r
+RS system napisany \ w \ C \ daje \ mo\2x\1liwo\2sc \ \1wykonywania \ programu\r
+\-\r
+\+\r
+loglanowego przet\2l\1umaczonego na j\2e\1zyk C. Taki \ spos\2o\1b \ realizacji\r
+\-\r
+\+\r
+Loglanu \ wydaje \ mi \ si\2e \ \1najprostszy. \ Napisanie \ kompilatora \ z\r
+\-\r
+\+\r
+Loglanu na C jest \ znacznie \ \2l\1atwiejsze \ ni\2x \ \1napisanie \ pe\2l\1nego\r
+\-\r
+\+\r
+kompilatora \ na \ docelow\2a \ \1maszyn\2e\1. \ Problem \ przenoszenia \ jest\r
+\-\r
+\+\r
+rozwi\2a\1zany w spos\2o\1b natychmiastowy. Ponadto kompilator taki mo\2x\1e\r
+\-\r
+\+\r
+korzysta\2c \1z bogactwa konstrukcji j\2e\1zyka C. Nie b\2e\1dzie problemu ze\r
+\-\r
+\+\r
+sta\2l\1ymi, \ \ instrukcjami \ \ \ steruj\2a\1cymi \ \ \ w \ \ \ obr\2e\1bie \ \ \ modu\2l\1u,\r
+\-\r
+\+\r
+wej\2s\1ciem-wyj\2s\1ciem, \2l\1a\2n\1cuchami itp. \ Niezwykle \ upro\2s\1ci \ si\2e \ \1sam\r
+\-\r
+\+\r
+proces translacji. Wyra\2x\1enia mog\2a \1pozosta\2c \1w prawie niezmienionej\r
+\-\r
+\+\r
+postaci - jedynie dost\2e\1p do zmiennych loglanowych b\2e\1dzie wymaga\2l\r
+\-\r
+\+\r
+\1wywo\2l\1ywania specjalnych makro - ale proces \2l\1adowania \ rejestr\2o\1w,\r
+\-\r
+\+\r
+optymalizacji lokalnej itd. przerzucony zostanie na system \ C.\r
+\-\r
+\+\r
+A \ przecie\2x \ \1jest \ to \ system \ niezwykle \ \ efektywny. \ \ Wi\2e\1kszo\2sc\r
+\-\r
+\+\r
+\1kompilator\2o\1w C daje kod \ dobrze \ zoptymalizowany. \ W \ ten \ prosty\r
+\-\r
+\+\r
+spos\2o\1b mo\2x\1emy wykorzysta\2c \1si\2le \1tego j\2e\1zyka \ zostawiaj\2a\1c \ troski\r
+\-\r
+\+\r
+techniczne \ \ \ (rejestry, \ \ \ arytmetyka \ \ \ maszyny, \ \ \ \ etykiety,\r
+\-\r
+\+\r
+optymalizacja) systemowi C. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Opisany poni\2x\1ej system sk\2l\1ada si\2e \1z dwu \ plik\2o\1w \ : \ Rs.c \ oraz\r
+\-\r
+\+\r
+Rsdata.h. Plik Rsdata.h jest \ tzw. \ plikiem \ nag\2lo\1wkowym \ (header\r
+\-\r
+\+\r
+file). W nim wyra\2x\1ono wszystkie wsp\2o\1lne struktury \ danych \ oraz\r
+\-\r
+\+\r
+podstawowe zmienne. Na pliku Rs.c znajduje \ si\2e \ \1natomiast \ pe\2l\1na\r
+\-\r
+\+\r
+biblioteka \ \ Running \ \ Systemu. \ \ Tekst \ \ programu \ \ \ loglanowego\r
+\-\r
+\+\r
+przet\2l\1umaczony na C musi w\2la\1cza\2c \1za pomoc\2a \1instrukcji \ include\r
+\-\r
+\+\r
+plik Rsdata.h. W taki sam spos\2o\1b w\2la\1czany \ jest \ ten \ plik \ przez\r
+\-\r
+\+\r
+Rs.c. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\+\r
+ Edmonton, Maj 1988\r
+\-\r
+\+\r
+\+\r
+ Warszawa, Sierpie\2n \11988\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+2. Opis struktur danych na pliku Rsdata.h\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Na pliku \ tym \ znajduj\2a \ \1si\2e \ \1deklaracje \ struktury \ prototyp\2o\1w \ i\r
+\-\r
+\+\r
+offset\2o\1w. Zajmiemy \ si\2e \ \1najpierw \ struktur\2a \ \ \1prototypu. \ \ Ma \ \ on\r
+\-\r
+\+\r
+nast\2e\1puj\2a\1c\2a \1posta\2c\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\4struct \3Prototype\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3kind\1;\r
+\-\r
+\+\r
+\ \4int \3num\1;\r
+\-\r
+\+\r
+\ \4int \3lspan\1, \3rspan\1;\r
+\-\r
+\+\r
+\ \4int \3references\1;\r
+\-\r
+\+\r
+\ \4int \3decl\1, \3level\1;\r
+\-\r
+\+\r
+\ \4int \3lastwill\1;\r
+\-\r
+\+\r
+\ \4int \3permadd\1;\r
+\-\r
+\+\r
+\ \4int \3Sloffset\1, \3Dloffset\1;\r
+\-\r
+\+\r
+\ \4int \3Statoffset\1, \3Lscoffset\1;\r
+\-\r
+\+\r
+\ \4int \3handlist\1;\r
+\-\r
+\+\r
+\ \4int \3pref\1, \3pslength\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3kind \1definiuje rodzaj \ prototypu. \ Mamy \ nast\2e\1puj\2a\1ce \ ich\r
+\-\r
+\+\r
+rodzaje: CLASS, SUBROUTINE, PROCESS, COROUTINE, HANDLER, \ RECORD,\r
+\-\r
+\+\r
+PRIMITARRAY, REFARRAY, SUBARRAY, STRUCTARRAY, POINTARRAY. \ Pi\2ec\r
+\-\r
+\+\r
+\1pierwszych nie wymaga wyja\2s\1nie\2n\1. RECORD jest klas\2a \1bez kodu i bez\r
+\-\r
+\+\r
+innych modu\2lo\1w zadeklarowanych \ wewn\2a\1trz. \ Ten \ rodzaj \ prototypu\r
+\-\r
+\+\r
+istnia\2l \1ju\2x \1w poprzedniej wersji Running Systemu. Ostanich pi\2ec\r
+\-\r
+\+\r
+\1rodzaj\2o\1w dotyczy tablic. PRIMITARRAY jest tablic\2a \ \1o \ elementach\r
+\-\r
+\+\r
+typu pierwotnego, \ REFARRAY \ jest \ tablic\2a \ \1typu \ referencyjnego,\r
+\-\r
+\+\r
+SUBARRAY jest tablic\2a\1, kt\2o\1rej elementami s\2a \1domkni\2e\1cia \ procedur,\r
+\-\r
+\+\r
+STRUCTARRAY jest tablic\2a \1o elementach typu z\2l\1o\2x\1onego \ i \ wreszcie\r
+\-\r
+\+\r
+POINTARRAY \ jest \ tablic\2a \ \1typu \ \ referencyjnego, \ \ jednak\2x\1e \ \ o\r
+\-\r
+\+\r
+elementach daj\2a\1cych adresy po\2s\1rednie bez licznik\2o\1w. \ Taki \ typ\r
+\-\r
+\+\r
+dodatkowy wprowadzili\2s\1my w nowej wersji \ RS \ w \ celu \ osi\2a\1gni\2e\1cia\r
+\-\r
+\+\r
+wi\2e\1kszej efektywno\2s\1ci kodu. Zamiast \ pe\2l\1nego \ adresu \ wirtualnego\r
+\-\r
+\+\r
+[adres po\2s\1redni, licznik] niekt\2o\1re referencje s\2a \ \1postaci \ [adres\r
+\-\r
+\+\r
+po\2s\1redni]. \ Nie \ daj\2a \ \1one \ oczywi\2s\1cie \ gwarancji \ \ poprawno\2s\1ci\r
+\-\r
+\+\r
+adresowania \ (mo\2x\1e \ wyst\2a\1pi\2c \ \1tzw. \ nieokre\2s\1lona \ \ referencja),\r
+\-\/\f\r
+\+\r
+nimniej, \ je\2s\1li \ u\2x\1ytkownik \ jest \ pewny \ \ poprawno\2s\1ci \ \ swoich\r
+\-\r
+\+\r
+adresowa\2n\1, mo\2x\1e cz\2esc \1lub \ wszystkie \ referencje \ zaznaczy\2c \ \1jako\r
+\-\r
+\+\r
+proste. Poniewa\2x \1typy \ tablicowe \ s\2a \ \1rozr\2ox\1niane \ przez \ atrybut\r
+\-\r
+\+\r
+\3kind, \1w\2s\1r\2o\1d rodzaj\2o\1w typ\2o\1w pojawi\2l \1si\2e \1tak\2x\1e typ POINTERARRAY. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Drugim atrybutem prototypu jest \3num\1. Wskazuje on \ pozycj\2e \ \1danego\r
+\-\r
+\+\r
+prototypu w tablicy PROT [] definiuj\2a\1cej wszystkie prototypy. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybuty \3lspan \1i \3rspan \1definiuj\2a \ \1rozmiar \ obiektu \ danego \ typu.\r
+\-\r
+\+\r
+Wszystkie obiekty alokowane \ s\2a \ \1w \ tablicy \ M[ \ ]. \ Maj\2a\1c \ adres\r
+\-\r
+\+\r
+obiektu \3am \1na lewo mamy rozmiar \ \3lspan\1, \ na \ prawo \ \3rspan\1, \ czyli\r
+\-\r
+\+\r
+obiekt \ zajmuje \ elementy \ tablicy \ M[\3am-lspan\1..\3am\1+\3rspan\1]. \ Adres\r
+\-\r
+\+\r
+prototypu usytuowany jest zawsze w s\2l\1owie M[\3am\1], tzn. maj\2a\1c adres\r
+\-\r
+\+\r
+obiektu na zmiennej \3am\1, w\2l\1a\2s\1nie M[\3am\1] = \ \3num \ \1, \ gdzie \ \3num \ \1jest\r
+\-\r
+\+\r
+adresem prototypu tego \ obiektu \ w \ tablicy \ PROT. \ Tablice \ maj\2a\r
+\-\r
+\+\r
+\1rozmiar definiowany dynamicznie. W s\2l\1owie \ M[\3am\1] \ jest \ zapisany\r
+\-\r
+\+\r
+stosowny \ numer \ prototypu, \ natomiast \ \ dwa \ \ kolejne \ \ s\2l\1owa\r
+\-\r
+\+\r
+definiuj\2a \1doln\2a \ \1i \ g\2o\1rn\2a \ \1granice \ wska\2z\1nika. \ Rozmiar \ elementu\r
+\-\r
+\+\r
+tablicy w przypadku PRIMITARRAY podawany jest za pomoc\2a \ \1atrybutu\r
+\-\r
+\+\r
+\3lspan\1. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Pozosta\2l\1e atrybuty nie s\2a \1konieczne w przypadku tablic.\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrubut \3references \1definiuje struktur\2e \1referencji prototypu. \ Jest\r
+\-\r
+\+\r
+to po prostu indeks w tablicy OFF[], kt\2o\1ra \ definiuje \ wszystkie\r
+\-\r
+\+\r
+rodzaje struktur referencji (patrz definicja OFF poni\2x\1ej). \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Atrybuty \3decl \1i \ \3level \ \1odnosz\2a \ \1si\2e \ \1do \ struktury \ zagnie\2x\1d\2x\1e\2n\r
+\-\r
+\+\r
+\1programu. Mianowicie \3decl \1jest indeksem w PROT \ ojca \ statycznego\r
+\-\r
+\+\r
+danego modu\2l\1u, natomiast \3level \1jest g\2le\1boko\2s\1ci\2a \1zagnie\2x\1d\2x\1enia. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3lastwill \1okre\2s\1la miejsce w module, od kt\2o\1rego rozpoczynaj\2a\r
+\-\r
+\+\r
+\1si\2e \1instrukcje lastwill. \ W \ jaki \ spos\2o\1b \ modeluje \ si\2e \ \1kontrol\2e\r
+\-\r
+\+\r
+\1sterowania podamy w punktach 4 i 10. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Nast\2e\1pny atrybut \3permadd \1jest wsp\2o\1lnym adresem dla \ permutacji \ i\r
+\-\r
+\+\r
+inwersji permutacji numer\2o\1w displaya. Mianowicie plik \ loglanowy\r
+\-\r
+\+\r
+definiuje dwie tablice \3perm\1[] i \3perminv\1[], kt\2o\1re \ musz\2a \ \1zawiera\2c\r
+\-\r
+\+\r
+\1te permutacji. \ Przyk\2l\1adowo, \ dla \ \3perm\1[] \ = \ {0,1,2,0,2,1} \ oraz\r
+\-\/\f\r
+\+\r
+\3perminv\1[] = {0,1,2,0,2,1}, indeks \3permadd\1=0 dla warto\2s\1ci \ \3level\1=2\r
+\-\r
+\+\r
+okre\2s\1la permutacj\2e \1{0,1,2} \ (i \ te \ sam\2a \ \1odwrotn\2a\1), \ natomiast\r
+\-\r
+\+\r
+\3permadd\1=2 dla \3level \1te\2x \1r\2o\1wnym 2 daje perm={0,2,1} \ (i \ podobnie\r
+\-\r
+\+\r
+te sam\2a \1odwrotn\2a\1}. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Cztery \ kolejne \ atrybuty \ \ (\3Sloffset\1, \ \ \3Dloffset\1, \ \ \3Statoffset\1,\r
+\-\r
+\+\r
+\3Lscoffset\1) definiuj\2a \1adresy wzgl\2e\1dne (offsety) czterech zmiennych\r
+\-\r
+\+\r
+systemowych Sl, Dl, Statsl i Lsc. Ka\2x\1dy \ modu\2l \ \1posiadaj\2a\1cy \ kod\r
+\-\r
+\+\r
+musi \ mie\2c \ \1okre\2s\1lon\2a \ \1pozycj\2e \ \1Sl \ ojca, \ Dl \ \ ojca, \ \ lokalnego\r
+\-\r
+\+\r
+sterowania Lsc i licznika Sl syn\2o\1w (Statsl). \ O \ tych \ zmiennych\r
+\-\r
+\+\r
+systemowych b\2e\1dziemy m\2o\1wi\2c \1za chwil\2e\1. Tutaj natomiast \ chcieli\2s\1my\r
+\-\r
+\+\r
+zwr\2o\1ci\2c \1uwag\2e \1na to, \2x\1e w poprzedniej \ wersji \ RS \ offsety \ tych\r
+\-\r
+\+\r
+zmiennych by\2l\1y podawane w prototypie (ich pozycja \ by\2l\1a \ ustalona\r
+\-\r
+\+\r
+na ko\2n\1cu obiektu). Wprowadzenie offset\2o\1w zmiennych systemowych do\r
+\-\r
+\+\r
+prototyp\2o\1w skomplikuje kompilacj\2e\1, ale przyspieszy i ujednorodni\r
+\-\r
+\+\r
+RS. Dost\2e\1p do tych zmiennych \ b\2e\1dzie \ bowiem \ taki \ sam \ jak \ do\r
+\-\r
+\+\r
+innych \ zmiennych \ wprowadzonych \ przez \ \ u\2x\1ytkownika \ \ czy \ \ te\2x\r
+\-\r
+\+\r
+\1kompilator. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3handlist \1definiuje list\2e \1handler\2o\1w zadeklarowanych w danym\r
+\-\r
+\+\r
+module. Jest to indeks w \ tablicy \ HL[], \ gdzie \ zdefiniowane \ s\2a\r
+\-\r
+\+\r
+\1wszystkie takie listy. \ Tablica \ HL \ jest \ typu \ Hlstelem \ postaci\r
+\-\r
+\+\r
+nast\2e\1puj\2a\1cej: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\4struct \3Hlstelem\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3hand\1;\r
+\-\r
+\+\r
+\ \4int \3signlist\1;\r
+\-\r
+\+\r
+\ \4int \3next\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3hand \1jest indeksem w tablicy \ PROT \ w\2l\1a\2s\1ciwego \ handlera.\r
+\-\r
+\+\r
+Natomiast atrybut \3signlist \ \1jest \ indeksem \ w \ tablicy \ SL[] \ typu\r
+\-\r
+\+\r
+\3Sgelem\1, \ gdzie \ okre\2s\1lone \ s\2a \ \1numery \ sygna\2lo\1w \ zwi\2a\1zane \ z \ \ tym\r
+\-\r
+\+\r
+handlerem. Typ \3Sgelem \1ma posta\2c \1nast\2e\1puj\2a\1c\2a\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\4struct \3Sgelem\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3signalnum\1;\r
+\-\r
+\+\r
+\ \4int \3next\r
+\-\r
+\+\r
+\1};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W ka\2x\1dym elemencie tablicy \ SL[] \ mamy \ numer \ sygna\2l\1u \ \3signalnum\1,\r
+\-\r
+\+\r
+kt\2o\1ry jest warto\2s\1ci\2a \1absolutn\2a \1budowan\2a \1przez kompilator. \ Atrybut\r
+\-\r
+\+\r
+\3next \1pokazuje na kolejny element takiej \ listy \ w \ SL[]. \ Podobnie\r
+\-\r
+\+\r
+zreszt\2a \1atrybut \3next \1w HL[] wskazuje na nast\2e\1pny handler \ zwi\2a\1zany\r
+\-\r
+\+\r
+z danym modu\2l\1em. Koniec ka\2x\1dej takiej listy \ (w \ obu \ przypadkach)\r
+\-\r
+\+\r
+okre\2s\1la warto\2sc \3next\1=-1 (tak wybrano z uwagi na \ adresowanie \ w \ C\r
+\-\r
+\+\r
+tablic od 0). \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3handlist \1wyst\2e\1puje tak\2x\1e w prototypie handlera. \ Okre\2s\1la\r
+\-\r
+\+\r
+on jedynie, \ czy \ handler \ ten \ odpowiada \ na \ wszystkie \ sygna\2l\1y\r
+\-\r
+\+\r
+(others), \ czy \ \ te\2x \ \ \1jest \ \ deklarowany \ \ jako \ \ handler \ \ dla\r
+\-\r
+\+\r
+wyspecyfikowanych \ numer\2o\1w \ sygna\2lo\1w. \ W \ \ pierwszym \ \ przypadku\r
+\-\r
+\+\r
+warto\2sc \ \1tego \ atrybutu \ jest \ 1 \ (hanlder \ dla \ \ others), \ \ w\r
+\-\r
+\+\r
+pozosta\2l\1ych przypadkach warto\2sc \1tego atrybutu jest 0. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Dwa ostatnie atrybuty w prototypie ( \ \3pref\1, \ \3pslength\1) \ okre\2s\1laj\2a\r
+\-\r
+\+\r
+\1struktur\2e \1prefiksowania. Nie musz\2a \1one \ wyst\2e\1powa\2c \ \1w \ przypadku\r
+\-\r
+\+\r
+prototyp\2o\1w dla handler\2o\1w, gdy\2x \1handler nie mo\2x\1e by\2c \1prefiksowany.\r
+\-\r
+\+\r
+Atrybut \3pref \1jest indeksem w tablicy PROT modu\2l\1u \ prefiksuj\2a\1cego\r
+\-\r
+\+\r
+(-1 gdy nie istnieje), \ atrybut \ \3pslength \ \1jest \ d\2l\1ugo\2s\1ci\2a \ \1ci\2a\1gu\r
+\-\r
+\+\r
+prefiksuj\2a\1cego. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Pozosta\2l\1a do \ om\2o\1wienia \ struktura \ referencji. \ Ot\2ox \ \1z \ powodu\r
+\-\r
+\+\r
+wprowadzenia bogactwa typ\2o\1w z\2l\1o\2x\1onych w nowym Loglanie, struktura\r
+\-\r
+\+\r
+referencji \ w \ obiektach \ jest \ stosunkowo \ skomplikowana. \ Takie\r
+\-\r
+\+\r
+struktury opisuje tablica OFF[] typu \3Offsets\1. \,\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\4struct \3Offsets\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3kind\1;\r
+\-\r
+\+\r
+\ \4int \3size\1, \3num\1;\r
+\-\r
+\+\r
+\ \4int \3length\1, \3finish\1;\r
+\-\r
+\+\r
+\ \4int \3head\1;\r
+\-\r
+\+\r
+\ \4int \3references\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3kind \1jest nast\2e\1puj\2a\1cych \ rodzaj\2o\1w: \ SIMPLELIST, \ SEGMENT,\r
+\-\r
+\+\r
+REPEATED \ oraz \ COMBINEDLIST. \ SIMPLELIST \ jest \ list\2a \ \ \1zwyk\2l\1ych\r
+\-\r
+\+\r
+offset\2o\1w \ zmiennych \ referencyjnych \ w \ obiekcie. \ SEGMENT \ jest\r
+\-\r
+\+\r
+szczeg\2o\1ln\2a \1postaci\2a \ \1takiej \ listy, \ gdy \ te \ offsety \ zajmuj\2a\r
+\-\r
+\+\r
+\1kolejne miejsca w pami\2e\1ci (ten typ wprowadzili\2s\1my \ ze \ wzgl\2e\1du\r
+\-\r
+\+\r
+na tablice referencyjne, jakkolwiek jest \ on \ sprowadzalny \ do\r
+\-\r
+\+\r
+przypadku poprzedniego). REPEATED jest \ n-krotn\2a \ \1iteracj\2a \ \1danej\r
+\-\r
+\+\r
+struktury referencyjnej. COMBINEDLIST jest list\2a \1by\2c \1mo\2x\1e r\2ox\1nych\r
+\-\r
+\+\r
+struktur referencji. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Atrybut \3size \1okre\2s\1la ca\2l\1kowit\2a \1d\2l\1ugo\2sc \1opisywanej \ struktury \ Dla\r
+\-\r
+\+\r
+SIMPLELIST musi to \ by\2c \ \1d\2l\1ugo\2sc \ \1ca\2l\1ego \ obiektu, \ dla \ SEGMENT\r
+\-\r
+\+\r
+r\2o\1wnie\2x \1d\2l\1ugo\2sc \1ca\2l\1ego obiektu, dla REPEATED musi to by\2c \ \1d\2l\1ugo\2sc\r
+\-\r
+\+\r
+\1powtarzanej struktury, i ostatecznie dla COMBINEDLIST ma to \ by\2c\r
+\-\r
+\+\r
+\1d\2l\1ugo\2sc \ \1struktury \ wewn\2a\1trz \ kt\2o\1rej \ podawane \ s\2a \ \1wska\2z\1niki \ \ do\r
+\-\r
+\+\r
+podstruktur. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Kolejny \ atrybut \ \3num \ \1definiuje \ indeks \ w \ tablicy \ \ OFF \ \ danej\r
+\-\r
+\+\r
+struktury.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Znaczenie atrybutu \3length \1jest \ wieloznaczne. \ Dla \ SIMPLELIST\r
+\-\r
+\+\r
+\3length \1jest d\2l\1ugo\2s\1ci\2a \1listy offset\2o\1w. Dla SEGMENT \ \3length \ \1jest\r
+\-\r
+\+\r
+pozycj\2a \1pierwszego,a \3finish \1ostatniego elementu \ segmentu. \ Dla\r
+\-\r
+\+\r
+REPEATED \3length \1jest \ krotno\2s\1ci\2a \ \1powt\2o\1rzenia \ podstruktury. \ Dla\r
+\-\r
+\+\r
+COMBINEDLIST \3length \1jest d\2l\1ugo\2s\1ci\2a \1listy. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Atrybut \3head \1jest indeksem w tablicy EL[], gdzie \ zakodowane \ s\2a\r
+\-\r
+\+\r
+\1listy struktur referencji. Typem tej tablicy jest \3Elem\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\/\f\r
+\+\r
+\4struct \3Elem\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3offset\1;\r
+\-\r
+\+\r
+\ \4int \3next\1;\r
+\-\r
+\+\r
+\ \4int \3references\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W tablicy tej atrybut \3offset \1definiuje odpowiedni offset a \ \3next\r
+\-\r
+\+\r
+\1jest jak zwykle wska\2z\1nikiem do \ nast\2e\1pnego \ elementu \ listy. \ Dla\r
+\-\r
+\+\r
+typu SIMPLELIST ka\2x\1dy taki \ offset \ mo\2x\1e \ by\2c \ \1offsetem \ zmiennej\r
+\-\r
+\+\r
+referencyjnej pe\2l\1nej lub tylko adresem po\2s\1rednim, ale tak\2x\1e \ mo\2x\1e\r
+\-\r
+\+\r
+by\2c \1offsetem domkni\2e\1cia procedury (czyli pary <SL, adres kodu> ).\r
+\-\r
+\+\r
+Gdy atrybut \3references \1jest 0, mamy referencje pe\2l\1n\2a\1, gdy jest \ 1\r
+\-\r
+\+\r
+jest to adres po\2s\1redni, wreszcie gdy jest 2 \ jest \ to \ domkni\2e\1cie\r
+\-\r
+\+\r
+procedury. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dla typu COMBINEDLIST atrybut \3references \1okre\2s\1la indeks w tablicy\r
+\-\r
+\+\r
+OFF wskazywanej podstruktury referencji. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+W przypadku typu SEGMENT atrybut \ \3head \ \1mo\2x\1e \ jeszcze \ okre\2s\1la\2c\r
+\-\r
+\+\r
+\1rodzaj referencji. Gdy \3head \1= 0, mamy segment pe\2l\1nych referencji,\r
+\-\r
+\+\r
+gdy jest 1 jest to segment adres\2o\1w po\2s\1rednich, gdy jest 2 jest to\r
+\-\r
+\+\r
+segment domkni\2ec \1procedur.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dla ostatniego atrybutu \3references \1w \ typie \ \3Offsets \ \1mamy \ jedno\r
+\-\r
+\+\r
+zadanie. Powinien on okre\2s\1la\2c \1dla typu REPEATED indeks w \ tablicy\r
+\-\r
+\+\r
+OFF powtarzanej struktury. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Powy\2x\1szy system wprowadzania \ struktury \ prototyp\2o\1w \ jest \ dosy\2c\r
+\-\r
+\+\r
+\1niezr\2e\1czny, je\2s\1li musi by\2c \1wykonany r\2e\1cznie. Troch\2e \1w \ tym \ wina\r
+\-\r
+\+\r
+j\2e\1zyka C. Mo\2x\1na by\2l\1o \ wprowadzi\2c \ \1typ \ union, \ kt\2o\1ry \ przypomina\r
+\-\r
+\+\r
+rekordy z \ wariantami, \ ale \ w\2o\1wczas \ nie \ mo\2x\1naby \ podawa\2c \ \1tych\r
+\-\r
+\+\r
+struktur przez definicje w deklaracji (odp. DATA \ w \ Fortranie).\r
+\-\r
+\+\r
+Zatem przyj\2al\1em \ takie \ rozwi\2a\1zanie \ przez \ zwyk\2la \ \1struktur\2e\1. \ Z\r
+\-\r
+\+\r
+drugiej strony translator z Loglanu na C mo\2x\1e bez k\2l\1opotu budowa\2c\r
+\-\r
+\+\r
+\1tak\2a \1struktur\2e\1. \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+3. Struktury Dl i Sl\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Struktura Dl zachowana jest taka \ jak \ w \ Simuli \ i \ Loglanie-82.\r
+\-\r
+\+\r
+Aktywny wsp\2ol\1program jest \2l\1a\2n\1cuchem Dl, zawieszony jest \ cyklem\r
+\-\r
+\+\r
+Dl. \ Nowy \ Loglan \ usun\2al \ \ \1Detach, \ \ gdy\2x \ \ \1wprowadzi\2l \ \ \1zmienn\2a\r
+\-\r
+\+\r
+\1LAST_ATTACH - \ wskazuj\2a\1c\2a \ \1na \ ostatni \ wsp\2ol\1program \ wykonuj\2a\1cy\r
+\-\r
+\+\r
+Attach(X). Zako\2n\1czenie wsp\2ol\1programu \ jest \ sygnalizowane \ b\2le\1dem\r
+\-\r
+\+\r
+(propozycja \ \ \ \ Marka \ \ \ \ Warpechowskiego). \ \ \ \ Wykonuje \ \ \ \ \ si\2e\r
+\-\r
+\+\r
+\1Attach(LAST_ATTACH) with Cor_Term (coroutine terminated), \ o \ ile\r
+\-\r
+\+\r
+LAST_ATTACH \ =/= \ \4none\1, \ w \ \ przeciwnym \ \ razie \ \ wykonuje \ \ si\2e\r
+\-\r
+\+\r
+\1Attach(My_Process) \ \ with \ \ Cor_Term. \ \ To \ \ \ rozwi\2a\1zanie \ \ \ jest\r
+\-\r
+\+\r
+metodologicznie uzasadnione i najprostsze. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dla \ wsp\2ol\1programu \ aktywnego \ warto\2sc \ \1Dl \ jest \ \ \4none\1. \ \ Pr\2o\1ba\r
+\-\r
+\+\r
+reaktywacji wsp\2ol\1programu aktywnego \ powoduje \ wys\2l\1anie \ sygna\2l\1u\r
+\-\r
+\+\r
+alarmowego. \ Wsp\2ol\1program \ \ zako\2n\1czony \ \ ma \ \ ustawion\2a \ \ \1warto\2sc\r
+\-\r
+\+\r
+\1lokalnego sterowania Lsc na 0. \ Pr\2o\1ba \ reaktywacji \ zako\2n\1czonego\r
+\-\r
+\+\r
+wsp\2ol\1programu powoduje wys\2l\1anie sygna\2l\1u. Zauwa\2x\1my na \ zako\2n\1czenie\r
+\-\r
+\+\r
+omawiania struktury Dl, \ \2x\1e \ Dl-link \ mo\2x\1e \ by\2c \ \1w \ tym \ systemie\r
+\-\r
+\+\r
+referencj\2a \1niepe\2l\1n\2a \1(tzn. tylko adresem po\2s\1rednim). \ Zyskujemy\r
+\-\r
+\+\r
+w ten spos\2o\1b na pami\2e\1ci i na czasie wykonania programu. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Struktura Sl link\2o\1w \ tworzy \ drzewo. Problemem s\2a \ \1tylko \ usuwane\r
+\-\r
+\+\r
+obiekty procedur, \ funkcji \ i \ blok\2o\1w, \ po \ ich \ terminacji. \ W\r
+\-\r
+\+\r
+poprzedniej \ wersji \ przyj\2e\1li\2s\1my \ \ strategi\2e \ \ \1usuwania \ \ takich\r
+\-\r
+\+\r
+obiekt\2o\1w bez wzgl\2e\1du na konsekwencje. Mog\2l\1o si\2e \ \1zdarzy\2c\1, \ \2x\1e \ po\r
+\-\r
+\+\r
+pewnym \ czasie \ wznawiany \ dobrze \ \ okre\2s\1lony \ \ obiekt \ \ nie \ \ ma\r
+\-\r
+\+\r
+okre\2s\1lonego otoczenia statycznego (Sl link przeci\2e\1ty). \ Umieli\2s\1my\r
+\-\r
+\+\r
+wykry\2c \1takie przypadki, ale nie by\2l\1o to \ rozwi\2a\1zanie \ eleganckie.\r
+\-\r
+\+\r
+Marek Lao \ zauwa\2x\1y\2l\1, \ \2x\1e \ lepiej \ by\2l\1oby \ u\2x\1y\2c \ \1zwyk\2l\1ej \ techniki\r
+\-\r
+\+\r
+licznik\2o\1w referencji tylko \ dla \ tego \ przypadku. \ Mamy \ przecie\2x\r
+\-\r
+\+\r
+\1licznik Statsl (poprzednio inaczej okre\2s\1lony), nale\2x\1y zastosowa\2c\r
+\-\r
+\+\r
+\1go w spos\2o\1b nast\2e\1puj\2a\1cy. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Ka\2x\1de otwarcie nowego obiektu zwi\2e\1ksza o 1 \ licznik \ Statsl \ jego\r
+\-\r
+\+\r
+statycznego ojca. Ka\2x\1de zako\2n\1czenie obiektu \ procedury \ (funkcji,\r
+\-\r
+\+\r
+bloku) sprawdza, czy jego Statsl jest 0. Je\2s\1li tak, obiekt \ mo\2x\1na\r
+\-\r
+\+\r
+usun\2ac\1, zmniejszy\2c \1Statsl o \ 1 \ dla \ jego \ ojca \ i \ powt\2o\1rzy\2c \ \1te\r
+\-\/\f\r
+\+\r
+operacje dla takiego \ ojca \ (o \ ile \ jest \ to \ obiekt \ procedury,\r
+\-\r
+\+\r
+funkcji lub bloku). Dla usuwanego za pomoc\2a \1kill \ obiektu \ klasy,\r
+\-\r
+\+\r
+sprawdzamy \ najpierw \ jego \ Statsl, \ \ i \ \ post\2e\1pujemy \ \ podobnie.\r
+\-\r
+\+\r
+Pozostaje rozwi\2a\1za\2c \1poprawnie problem usuwania wsp\2ol\1program\2o\1w. \,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Zabicie zawieszonego wsp\2ol\1programu polega na \ zabiciu \ stosownego\r
+\-\r
+\+\r
+cyklu Dl. Najpierw przegl\2a\1damy taki cykl i sprawdzamy, \ czy \ jego\r
+\-\r
+\+\r
+wszystkie obiekty maj\2a \1Statsl \ r\2o\1wny \ 0. \ Je\2s\1li \ nie, \ wywo\2l\1ujemy\r
+\-\r
+\+\r
+sygna\2l \1alarmowy. Je\2s\1li natomiast wszystkie \ s\2a \ \1usuwalne, \ mo\2x\1emy\r
+\-\r
+\+\r
+przyst\2a\1pi\2c \1do kolejnego ich usuwania. Aby \ to \ zrobi\2c \ \1poprawnie,\r
+\-\r
+\+\r
+nale\2x\1a\2l\1oby stosowa\2c \1operacj\2e \1przej\2s\1cia po Sl-\2l\1a\2n\1cuchu dla ka\2x\1dego\r
+\-\r
+\+\r
+obiektu usuni\2e\1tego (tak jak \ dla \ obiektu \ klasy). \ Ale \ przecie\2x\r
+\-\r
+\+\r
+\1mogliby\2s\1my usun\2ac \1jaki\2s \1obiekt jeszcze \ nieusuni\2e\1ty \ z \ usuwanego\r
+\-\r
+\+\r
+w\2l\1a\2s\1nie cyklu wsp\2ol\1programu. Aby unikn\2ac \1tej sytuacji, \ odwracamy\r
+\-\r
+\+\r
+najpierw \ cykl \ wsp\2ol\1programu. \ Zabijaj\2a\1c \ obiekty \ w \ kolejno\2s\1ci\r
+\-\r
+\+\r
+odwrotnej (od g\2l\1owy wsp\2ol\1programu, nast\2e\1pnie syn dynamiczny itd),\r
+\-\r
+\+\r
+mamy pewno\2sc\1, \ \2x\1e \ nie \ usuniemy \ przy \ czyszczeniu \ kolejnych\r
+\-\r
+\+\r
+\2l\1a\2n\1cuch\2o\1w Sl \2x\1adnego pozosta\2l\1ego elementu \ cyklu. \ Wynika \ to \ z\r
+\-\r
+\+\r
+w\2l\1asno\2s\1ci Sl \ i \ Dl \ \2l\1a\2n\1cuch\2o\1w \ - \ nie \ mog\2a \ \1i\2sc \ \1w \ przeciwnych\r
+\-\r
+\+\r
+kierunkach, tzn. je\2s\1li jest Dl droga od A do B to nie ma Sl drogi\r
+\-\r
+\+\r
+od B do A. \ W \ drugiej \ fazie \ usuwania \ wsp\2ol\1programu \ zmieniamy\r
+\-\r
+\+\r
+orientacj\2e \1cyklu. resach \ odpowiednio \ (2,3) \ i \ (1,4),\r
--- /dev/null
+From: MX%"antek@mimuw.edu.pl" 1-MAR-1993 15:47:20.56\r
+To: SALWICKI\r
+CC: \r
+Subj: \r
+\r
+Date: Mon, 1 Mar 93 14:59:41 GMT\r
+From: antek@mimuw.edu.pl\r
+To: salwicki@pauvx1.univ-pau.fr\r
+\r
+/*\r
+\r
+program mergecor;\r
+ unit node: class;\r
+ var left,right : node,\r
+ val : integer;\r
+\r
+ unit ins: procedure( value: integer) ;\r
+ begin\r
+ if val > value\r
+ then\r
+ if left=none\r
+ then\r
+ left:=new node;\r
+ left.val:=value;\r
+ else\r
+ call left.ins(value);\r
+ fi;\r
+ else\r
+ if right = none\r
+ then\r
+ right:=new node;\r
+ right.val:=value;\r
+ else\r
+ call right.ins(value)\r
+ fi;\r
+ fi;\r
+ end ins;\r
+\r
+ end node;\r
+\r
+ unit traverse : coroutine (i:integer);\r
+ var val: integer,\r
+ x: node;\r
+\r
+ unit t: procedure(y:node);\r
+ begin\r
+ if y=/=none\r
+ then\r
+ call t(y.left);\r
+ val:=y.val;\r
+ detach;\r
+ call t(y.right);\r
+ fi;\r
+ end t;\r
+ begin\r
+ x:=d(i);\r
+ return;\r
+ call t(x);\r
+ detach with endtree(i);\r
+ end traverse;\r
+ signal endtree(t:integer),fin ;\r
+\r
+ var n,i,j,min,m,k: integer,\r
+ d: arrayof node,\r
+ tr: arrayof traverse,\r
+ bb: integer;\r
+ exceptions\r
+ when endtree:\r
+ if bb=1\r
+ then\r
+ raise fin\r
+ fi;\r
+ bb:=1;\r
+ if t=1\r
+ then\r
+ j:=2\r
+ else\r
+ j:=1\r
+ fi;\r
+ do\r
+ write(tr(j).val); writeln;\r
+ attach(tr(j))\r
+ od;\r
+ when fin : terminate;\r
+ begin\r
+ read(n);\r
+ array d dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(j); write(j); if j>m then m:=j fi;\r
+ d(i):=new node;\r
+ d(i).val:=j;\r
+ do\r
+ read(j);\r
+ if j=-1 then writeln; exit fi;\r
+ write(j);\r
+ if j>m then m:=j fi;\r
+ call d(i).ins(j)\r
+ od;\r
+ od;\r
+ array tr dim (1:n);\r
+ min:=0;\r
+ for i:=1 to n\r
+ do\r
+ tr(i):=new traverse(i);\r
+ attach(tr(i));\r
+ od;\r
+ k:=0;\r
+ do\r
+ min:=tr(1).val;\r
+ j:=1;\r
+ for i:=2 to n\r
+ do\r
+ if min > tr(i).val then min:=tr(i).val; j:=i fi;\r
+ od;\r
+ write(min); attach(tr(j));\r
+ k:=k+1; if k=10 then writeln; k:=0 fi;\r
+ od;\r
+ writeln;\r
+ end mergecor\r
+\r
+*/\r
+\r
+\r
+\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 8\r
+\r
+\r
+ int displ= -6;\r
+ int displdir = -15;\r
+ int curr= -8;\r
+ int lstcor= -10;\r
+ int chead = -12;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspn ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 7, 0, 27, 26, 25, 24, 0, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 2, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 6, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{3, 3, 1, 9, 3, 0, 1, 4, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 4, 0, 9, 4, 3, 2, 5, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 5},\r
+{4, 6, 0, 9, 1, 0, 1, 4, 0, 9, 8, 7, 6, 0},\r
+{4, 7, 0, 9, 1, 0, 1, 2, 0, 9, 8, 7, 6, 0}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -6, 4, 0,\r
+ -4, 5, 0,\r
+ -2, 6, 0,\r
+ -8, 7, 0,\r
+ -10, 8, 0,\r
+ -12, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 1, 12, 0,\r
+ 3, -1, 0,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+\r
+\r
+ struct Hlstelem HL[]= { 6,0,1,\r
+ 7,1,-1 };\r
+ struct Sgelem SL[]= { 101,-1,\r
+ 102, -1 };\r
+\r
+\r
+\r
+node()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+L1: Endclass();\r
+L2: Killafter();\r
+ Endclass();\r
+}\r
+\r
+\r
+ins()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ };\r
+\r
+L1:\r
+ if (*Address(1,5) > *Local(1))\r
+ {\r
+ if (Notmember(Address(1,1)))\r
+ {\r
+ Dopen(1,0,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2:\r
+ *(Physical(Address(1,1))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,1));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=3; Go(Local(2));\r
+L3: Killafter() ;\r
+ };\r
+ }\r
+ else\r
+ {\r
+ if (Notmember(Address(1,3)))\r
+ {\r
+ Dopen(1,0,Address(1,3));\r
+ IC=4; Go(Address(1,3));\r
+L4: *(Physical(Address(1,3))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,3));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=5; Go(Local(2));\r
+L5: Killafter();\r
+ };\r
+ };\r
+ Back();\r
+L6: Killafter();\r
+ Back();\r
+}\r
+\r
+\r
+\r
+\r
+trav()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1: Refmove(Local(1),Arrayelem(Global(7),*Local(-1)));\r
+ IC=2; Back();\r
+L2: Dopen(4,3,Local(4));\r
+ Refmove(Physical(Local(4))+1,Local(1));\r
+ IC=3; Go(Local(4));\r
+L3: Killafter();\r
+ Attachwith(lastcor,101,Local(4));\r
+ *(Physical(Local(4))+5)= *Local(-1);\r
+ Attach(lastcor);\r
+ Endcor();\r
+L4: Killafter();\r
+ Endcor();\r
+}\r
+\r
+t()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ };\r
+L1:\r
+ if (Member(Local(1)))\r
+ { Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ *Address(1,3)= *(Physical(Local(1))+5);\r
+ IC=3; Attach(lastcor);\r
+L3: Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=4; Go(Local(3));\r
+L4: Killafter();\r
+ };\r
+ Back();\r
+L5: Killafter();\r
+ Back();\r
+}\r
+\r
+\r
+\r
+merge()\r
+\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ case 7: goto L7; break;\r
+ };\r
+\r
+L1:\r
+ printf("Number of trees n=2\n"); *Global(1)=2;\r
+ Openarray(5,1,*Global(1),Global(7));\r
+ printf("Give the values of nodes. End each tree with -1\n");\r
+ *Global(2)=1;\r
+ while (1)\r
+ {\r
+ if (*Global(2)> *Global(1)) break;\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Dopen(1,0,Arrayelem(Global(7),*Global(2)));\r
+ IC=2; Go(Arrayelem(Global(7),*Global(2)));\r
+L2: *(Physical(Arrayelem(Global(7),*Global(2)))+5)= *Global(3);\r
+ while(1)\r
+ {\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) == -1) break;\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Slopen(2,Global(16),Arrayelem(Global(7),*Global(2)));\r
+ *(Physical(Global(16))+1)= *Global(3);\r
+ IC=3; Go(Global(16));\r
+L3: Killafter();\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ (*Global(5))++;\r
+ Openarray(5,1,*Global(1),Global(9));\r
+ *Global(4)=0;\r
+ *Global(2)=1;\r
+ while(1)\r
+ { if (*Global(2) > *Global(1)) break;\r
+ Dopen(3,0,Arrayelem(Global(9),*Global(2)));\r
+ *(Physical(Arrayelem(Global(9),*Global(2)))-1)=\r
+ *Global(2);\r
+ IC=4; Go(Arrayelem(Global(9),*Global(2)));\r
+L4: IC=5; Attach(Arrayelem(Global(9),*Global(2)));\r
+L5: (*Global(2))++;\r
+ };\r
+ *Global(6)=0;\r
+ while(1)\r
+ {\r
+ if (*Global(4) == *Global(5) ) break;\r
+ *Global(4)= *(Physical(Arrayelem(Global(9),1))+3);\r
+ *Global(3)=1;\r
+ *Global(2)=2;\r
+ while (1)\r
+ {\r
+ if (*Global(2) > *Global(1)) break;\r
+ if (*Global(4) > *(Physical(Arrayelem(Global(9),*Global(2)))+3))\r
+ { *Global(4) = *(Physical(Arrayelem(Global(9),*Global(2)))+3);\r
+ *Global(3)= *Global(2);\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ if (*Global(4) < *Global(5))\r
+ {\r
+ printf("%d ",*Global(4));\r
+ IC=6; Attach(Arrayelem(Global(9),*Global(3)));\r
+L6: (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ };\r
+ };\r
+ Endrun();\r
+\r
+L7: Killafter();\r
+ Endrun();\r
+ }\r
+\r
+\r
+endtree()\r
+{\r
+ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ if (*Global(18))\r
+ { Raising(102,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2: ;\r
+ };\r
+ *Global(18)= 1;\r
+ if (*Address(1,5)==1) *Global(3)=2; else *Global(3)=1;\r
+ while(1)\r
+ { if (IC==0) break; /* dummy */\r
+ printf("%d ",*(Physical(Arrayelem(Global(9),*Global(3)))+3));\r
+ (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ IC=3; Attach(Arrayelem(Global(9),*Global(3)));\r
+L3: ;\r
+ };\r
+ Back();\r
+L4: Killafter();\r
+ Back();\r
+}\r
+\r
+fin()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+L1:\r
+ Termination();\r
+ Back();\r
+L2: Killafter();\r
+ Back();\r
+}\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=merge;\r
+ module[1]=node;\r
+ module[2]=ins;\r
+ module[3]=trav;\r
+ module[4]=t;\r
+ module[6]=endtree;\r
+ module[7]=fin;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\r
+\1a/*\r
+\r
+program pawel;\r
+ var n,m;\r
+\r
+ unit F: procedure;\r
+ var i: integer;\r
+ begin\r
+ if m=n+1\r
+ then\r
+ for i:=1 to n do write(A[i]," "); od;\r
+ writeln;\r
+ else\r
+ for i:=1 to n\r
+ do\r
+ if A[i]=0\r
+ then\r
+ A[i]:=m; m:=m+1;\r
+ F;\r
+ m:=m-1; A[i]:=0;\r
+ fi;\r
+ od;\r
+ fi;\r
+ end F;\r
+\r
+begin\r
+ write("Generation of all permutations. Give n=");\r
+ read(n); writeln;\r
+ A:=array[1..n] of integer;\r
+ m:=1;\r
+ F;\r
+end\r
+\r
+*/\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+\r
+#define numprot 3\r
+\r
+\r
+ int displ= 5;\r
+ int displdir = 9;\r
+ int curr= 11;\r
+ int lstcor= 13;\r
+ int chead =15;\r
+ int offnum = 1;\r
+ int protnum= numprot;\r
+\r
+\r
+ int perm [] = { 0,0,1};\r
+ int perminv [] = { 0,0,1};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen*/\r
+{\r
+{2, 0, 0, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{1, 1, 0, 9, 1, 0, 1, 0, 1, 9, 8, 7, 6, -1, -1, 1},\r
+{6, 2, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot]) ();\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 28, 0, 9, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 9, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 3, 1, 0,\r
+ 5, 2, 0,\r
+ 7, 3, 0,\r
+ 11, 4, 0,\r
+ 13, 5, 0,\r
+ 15, 6, 0,\r
+ 17, 7, 0,\r
+ 26, 8, 1,\r
+ 27, -1,2,\r
+ 8, 10, 1,\r
+ 9, -1, 2 };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+int pawel()\r
+{\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+\r
+ L1: printf("Generation of all permutations. Give n=");\r
+ scanf("%d",Global(1));\r
+ printf(" \n");\r
+ Openarray(2,1,*Global(1),Global(3));\r
+ { int i;\r
+ for (i=1; i<= *Global(1); i++)\r
+ *Arrayelem(Global(3),i)=0;\r
+ };\r
+ *Global(2)=1;\r
+ Dopen(1,0,Global(17)); IC=2;\r
+ Go(Global(17));\r
+ L2: Killafter();\r
+ Endrun();\r
+}\r
+\r
+int F()\r
+{\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+\r
+L1:\r
+ if (*Global(2)== *Global(1)+1)\r
+ { int i;\r
+ for (i=1; i<= *Global(1); i++)\r
+ printf("%d ",*(Arrayelem(Global(3),i)));\r
+ printf(" \n");\r
+ }\r
+ else\r
+\r
+ {int i;\r
+ for (i=1; i<= *Global(1);i++)\r
+ {\r
+ if (*(Arrayelem(Global(3),i))==0)\r
+ {\r
+ *(Arrayelem(Global(3),i))= *Global(2);\r
+ (*Global(2))++;\r
+ Dopen(1,0,Global(17)); *Local(1)=i;\r
+ IC=2; Go(Global(17));\r
+ L2: Killafter();\r
+ (*Global(2))--; i= *Local(1);\r
+ *(Arrayelem(Global(3),i))=0;\r
+ };\r
+ };\r
+ };\r
+ Back();\r
+ }\r
+\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=pawel;\r
+ module[1]=F;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer) !=-2) module[modulenumber]();\r
+}\r
+\r
+\1a/*\r
+\r
+program square;\r
+ var a,b,c,delta,x1,x2:real;\r
+begin\r
+ writeln(" solution of square equation a*x**2 b*x +c=0");\r
+ write(" give a= "); read(a);\r
+ write(" give b= "); read(b);\r
+ write(" give c= "); read(c);\r
+ delta:=b**2 - 4*a*c;\r
+ if delta < 0\r
+ then\r
+ writeln(" no solutions"); endrun;\r
+ fi;\r
+ delta:=sqrt(delta);\r
+ x1:=(-b-delta)/2/a;\r
+ x2:=(-b+delta)/2/a;\r
+ writeln("x1=",x1,"x2=",x2);\r
+end\r
+ */\r
+\r
+#include <math.h>\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+\r
+#define numprot 1\r
+\r
+#define rlh sizeof(float)/sizeof(int)\r
+\r
+#define aoff 1\r
+#define boff 1+rlh\r
+#define coff 1+2*rlh\r
+#define deloff 1+3*rlh\r
+#define x1off 1+4*rlh\r
+#define x2off 1+5*rlh\r
+\r
+\r
+ int displ=15;\r
+ int displdir =17;\r
+ int curr= 18;\r
+ int lstcor= 20;\r
+ int chead =22;\r
+ int offnum = 1;\r
+ int protnum= numprot;\r
+\r
+\r
+ int perm [] = { 0,0,1};\r
+ int perminv [] = { 0,0,1};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen*/\r
+{\r
+{2, 0, 0, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot+1]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 28, 0, 6, 0, 0, 0 };\r
+\r
+ struct Elem EL[]=\r
+ {\r
+ 15, 1, 0,\r
+ 18, 2, 0,\r
+ 20, 3, 0,\r
+ 22, 4, 0,\r
+ 26, 5, 1,\r
+ 27, -1,2,\r
+ };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+int square()\r
+{\r
+\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+ L1: printf(" solution of square equation a*x**2 + b*x +c=0\n");\r
+ printf(" \ngive a=");\r
+ scanf("%f", Flglobal(aoff));\r
+ printf(" \ngive b=");\r
+ scanf("%f", Flglobal(boff));\r
+ printf(" \ngive c=");\r
+ scanf("%f", Flglobal(coff));\r
+ * Flglobal(deloff) =\r
+ (* Flglobal(boff))*(* Flglobal(boff))-\r
+ 4*(* Flglobal(aoff))*(* Flglobal(coff));\r
+ if ( * Flglobal(deloff) < 0 )\r
+ {\r
+ printf(" no solutions\n");\r
+ Endrun();\r
+ };\r
+ * Flglobal(deloff) = sqrt( (double) * Flglobal(deloff) );\r
+ * Flglobal(x1off) = (- * Flglobal(boff) -\r
+ * Flglobal(deloff))/2/ * Flglobal(aoff);\r
+\r
+ * Flglobal(x2off) = (- * Flglobal(boff) +\r
+ * Flglobal(deloff))/2/ * Flglobal(aoff);\r
+ printf(" \n x1=%f\n",* Flglobal(x1off));\r
+ printf(" \n x2=%f\n",* Flglobal(x2off));\r
+ L2: Endrun();\r
+}\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=square;\r
+ IC=1;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer) !=-2) module[modulenumber]();\r
+}\r
+\r
+\1a/*\r
+\r
+program functest;\r
+ type F: function(n:integer): integer;\r
+\r
+ unit f : function(n:integer):F;\r
+\r
+ unit h:F;\r
+ begin\r
+ result:=n*2;\r
+ end h;\r
+\r
+ unit g:F;\r
+ begin\r
+ result:=n+2;\r
+ end g;\r
+\r
+ begin\r
+ if n=0 then result=h else result:=g fi;\r
+ end f;\r
+\r
+ var x,y :F; n:integer;\r
+\r
+begin\r
+ x:=f(0); y:=f(1);\r
+ write("n="); readln(n); writeln(x(n));\r
+ write("m="); readln(n); writeln(y(n));\r
+end\r
+\r
+*/\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPLAY,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 4\r
+\r
+\r
+ int displ= -9;\r
+ int displdir = 20;\r
+ int curr= -11;\r
+ int lstcor= -13;\r
+ int chead = -15;\r
+ int protnum=numprot;\r
+ int offnum=3;\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{1, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 3, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 3, 0, 11, 0,\r
+ 0, 10, 2, 2, 0, 14, 0,\r
+ };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 2,\r
+ 9, 2, 2,\r
+ 16, 3, 0,\r
+ -9, 4, 0,\r
+ -7, 5, 0,\r
+ -5, 6, 0,\r
+ -11, 7, 0,\r
+ -13, 8, 0,\r
+ -15, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 2, 12, 2,\r
+ 8, 13, 1,\r
+ 9, -1, 2,\r
+ 8, 15, 1,\r
+ 9, -1, 2\r
+ };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+procclostest()\r
+ {\r
+ switch(IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+\r
+ };\r
+L1: Dopen(1,0,Global(16));\r
+ *(Physical(Global(16))+1)= 0;\r
+ IC=2;Go(Global(16));\r
+L2: Procclosmove(Global(7), Physical(Global(16))+2);\r
+ Killafter();\r
+ Dopen(1,0,Global(16));\r
+ *(Physical(Global(16))+1)= 1;\r
+ IC=3;Go(Global(16));\r
+L3: Procclosmove(Global(9), Physical(Global(16))+2);\r
+ Killafter();\r
+ printf("n=");\r
+ scanf("%d",Global(6));\r
+ Slopen(*Global(8),Global(16),Global(7));\r
+ *(Physical(Global(16))+1)= *Global(6);\r
+ IC=4;Go(Global(16));\r
+L4: printf("%d\n",*(Physical(Global(16))+2));\r
+ Killafter();\r
+ printf("m=");\r
+ scanf("%d",Global(6));\r
+ Slopen(*Global(10),Global(16),Global(9));\r
+ *(Physical(Global(16))+1)= *Global(6);\r
+ IC=5;Go(Global(16));\r
+L5: printf("%d\n",*(Physical(Global(16))+2));\r
+ Killafter();\r
+ Endrun();\r
+}\r
+\r
+\r
+f()\r
+{\r
+ if ( *Local(1) == 0)\r
+ {\r
+ *Local(2) = *current;\r
+ *Local(3) = 2;\r
+ }\r
+ else\r
+ {\r
+ *Local(2) = *current;\r
+ *Local(3) = 3;\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+h()\r
+{\r
+ *Local(2) = *Local(1) * 2;\r
+ Back();\r
+}\r
+\r
+g()\r
+{\r
+ *Local(2) = *Local(1) +2;\r
+ Back();\r
+}\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=procclostest;\r
+ module[1]=f;\r
+ module[2]=h;\r
+ module[3]=g;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+ }\r
+\1a/*\r
+\r
+program MEMORYTEST;\r
+var i,j,k,n: integer,\r
+ X,Y: A,\r
+ Z: arrayof A;\r
+ unit A: class;\r
+ var P: arrayof A;\r
+ begin\r
+ array P dim(1:j);\r
+ end A;\r
+begin\r
+ i:=0;\r
+ read(n); read(k);\r
+ for j:=1 to n\r
+ do\r
+ X:=new A; i:=i+1;\r
+ if i=k\r
+ then\r
+ Z:=Y.P;\r
+ kill(Y); kill(Z);\r
+ i:=0;\r
+ fi;\r
+ Y:=X;\r
+ od;\r
+end\r
+\r
+*/\r
+\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+\r
+#define numprot 3\r
+\r
+\r
+\r
+ int displdir = 15;\r
+ int displ= 11;\r
+ int curr= 17;\r
+ int lstcor= 19;\r
+ int chead =21;\r
+ int protnum=numprot;\r
+ int offnum=1;\r
+\r
+ int perm [] = { 0,0,1};\r
+ int perminv [] = { 0,0,1};\r
+\r
+ struct Prototype PROT[]=\r
+\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 0, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 1, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 2}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 30, 0, 8, 0, 0, 0,\r
+ 0, 12, 1, 3, 0, 8, 0 };\r
+\r
+ struct Elem EL[]=\r
+ {\r
+ 5, 1, 0,\r
+ 7, 2, 0,\r
+ 11, 3, 0,\r
+ 13, 4, 0,\r
+ 21, 5, 0,\r
+ 17, 6, 0,\r
+ 26, 7, 1,\r
+ 27, -1,2,\r
+ 1, 9, 0,\r
+ 8, 10, 1,\r
+ 9, -1, 2 };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+int memor()\r
+{\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+ L1: *Global(1)=0;\r
+ printf("\n n="); scanf("%d",Global(4));\r
+ printf("\n k="); scanf("%d",Global(3));\r
+ *Global(2)=1;\r
+ while (1)\r
+ { if (*Global(2) > *Global(4)) break;\r
+ Dopen(1,0,Global(5)); IC=2;\r
+ Go(Global(5));\r
+ L2: (*Global(1))++;\r
+ if (*Global(1)== *Global(3))\r
+ {\r
+ Refmove(Global(9),Physical(Global(7))+1);\r
+ Gkill(Global(7));\r
+ Gkill(Global(9));\r
+ *Global(1)=0;\r
+ };\r
+ Refmove(Global(7),Global(5));\r
+ (*Global(2))++;\r
+ };\r
+ Endrun ();\r
+ }\r
+\r
+int A()\r
+{\r
+ Openarray(2,1,*Global(2),Local(1));\r
+ Endclass ();\r
+}\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=memor;\r
+ module[1]=A;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\r
+\1a\r
+/*\r
+\r
+program merge;\r
+ unit node: class;\r
+ var left,right : node,\r
+ val : integer;\r
+\r
+ unit ins: procedure( value: integer) ;\r
+ begin\r
+ if val > value\r
+ then\r
+ if left=none\r
+ then\r
+ left:=new node;\r
+ left.val:=value;\r
+ else\r
+ call left.ins(value);\r
+ fi;\r
+ else\r
+ if right = none\r
+ then\r
+ right:=new node;\r
+ right.val:=value;\r
+ else\r
+ call right.ins(value)\r
+ fi;\r
+ fi;\r
+ end ins;\r
+\r
+ end node;\r
+\r
+ unit traverse : coroutine (x:node);\r
+ var val: integer;\r
+\r
+ unit t: procedure(y:node);\r
+ begin\r
+ if y=/=none\r
+ then\r
+ call t(y.left);\r
+ val:=y.val;\r
+ detach;\r
+ call t(y.right);\r
+ fi;\r
+ end t;\r
+ begin\r
+ return;\r
+ call t(x);\r
+ val:=m;\r
+ end traverse;\r
+\r
+ var n,i,j,min,m,k: integer,\r
+ d: arrayof node,\r
+ tr: arrayof traverse;\r
+ begin\r
+ read(n);\r
+ array d dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(j); write(j); if j>m then m:=j fi;\r
+ d(i):=new node;\r
+ d(i).val:=j;\r
+ do\r
+ read(j);\r
+ if j=-1 then writeln; exit fi;\r
+ write(j);\r
+ if j>m then m:=j fi;\r
+ call d(i).ins(j)\r
+ od;\r
+ od;\r
+ m:=m+1;\r
+ array tr dim (1:n);\r
+ min:=0;\r
+ for i:=1 to n\r
+ do\r
+ tr(i):=new traverse(d(i));\r
+ attach(tr(i));\r
+ od;\r
+ k:=0;\r
+ do\r
+ if min=m then exit fi;\r
+ min:=tr(1).val;\r
+ j:=1;\r
+ for i:=2 to n\r
+ do\r
+ if min > tr(i).val then min:=tr(i).val; j:=i fi;\r
+ od;\r
+ if min<m\r
+ then\r
+ write(min); attach(tr(j));\r
+ k:=k+1; if k=10 then writeln; k:=0 fi;\r
+ fi;\r
+ od;\r
+ writeln;\r
+ attach(tr(j));\r
+ end merge\r
+\r
+*/\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 6\r
+\r
+ int displ= -6;\r
+ int displdir = -15;\r
+ int curr= -8;\r
+ int lstcor= -10;\r
+ int chead = -12;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref psleng*/\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{3, 3, 0, 9, 3, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 4, 0, 9, 4, 3, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 5 }\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -6, 4, 0,\r
+ -4, 5, 0,\r
+ -2, 6, 0,\r
+ -8, 7, 0,\r
+ -10, 8, 0,\r
+ -12, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 1, 12, 0,\r
+ 3, -1, 0,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+node()\r
+{\r
+ Endclass();\r
+}\r
+\r
+\r
+ins()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ };\r
+\r
+L1:\r
+ if (*Address(1,5) > *Local(1))\r
+ {\r
+ if (Notmember(Address(1,1)))\r
+ {\r
+ Dopen(1,0,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2:\r
+ *(Physical(Address(1,1))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,1));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=3; Go(Local(2));\r
+L3: Killafter() ;\r
+ };\r
+ }\r
+ else\r
+ {\r
+ if (Notmember(Address(1,3)))\r
+ {\r
+ Dopen(1,0,Address(1,3));\r
+ IC=4; Go(Address(1,3));\r
+L4: *(Physical(Address(1,3))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,3));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=5; Go(Local(2));\r
+L5: Killafter();\r
+ };\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+\r
+traverse()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ IC=2; Back();\r
+L2: Dopen(4,3,Local(4));\r
+ Refmove(Physical(Local(4))+1,Local(1));\r
+ IC=3; Go(Local(4));\r
+L3: Killafter();\r
+ *Local(3)= *Global(5);\r
+ IC=4; Attach(lastcor);\r
+L4: Endcor();\r
+}\r
+\r
+t()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ if (Member(Local(1)))\r
+ { Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ *Address(1,3)= *(Physical(Local(1))+5);\r
+ IC=3; Attach(lastcor);\r
+L3: Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=4; Go(Local(3));\r
+L4: Killafter();\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+ merge()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ };\r
+L1:\r
+ printf("Number of trees n="); scanf("%d",Global(1));\r
+ Openarray(5,1,*Global(1),Global(7));\r
+ printf("Give the values of nodes. End each tree with -1\n");\r
+ *Global(2)=1;\r
+ while (1)\r
+ {\r
+ if (*Global(2)> *Global(1)) break;\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Dopen(1,0,Arrayelem(Global(7),*Global(2)));\r
+ IC=2; Go(Arrayelem(Global(7),*Global(2)));\r
+L2: *(Physical(Arrayelem(Global(7),*Global(2)))+5)= *Global(3);\r
+ while(1)\r
+ {\r
+ scanf("%d",Global(3));\r
+ if (*Global(3\r
--- /dev/null
+From: MX%"antek@mimuw.edu.pl" 1-MAR-1993 16:00:42.56\r
+To: SALWICKI\r
+CC: \r
+Subj: \r
+\r
+Date: Mon, 1 Mar 93 14:59:41 GMT\r
+From: antek@mimuw.edu.pl\r
+To: salwicki@pauvx1.univ-pau.fr\r
+\r
+/*\r
+\r
+program mergecor;\r
+ unit node: class;\r
+ var left,right : node,\r
+ val : integer;\r
+\r
+ unit ins: procedure( value: integer) ;\r
+ begin\r
+ if val > value\r
+ then\r
+ if left=none\r
+ then\r
+ left:=new node;\r
+ left.val:=value;\r
+ else\r
+ call left.ins(value);\r
+ fi;\r
+ else\r
+ if right = none\r
+ then\r
+ right:=new node;\r
+ right.val:=value;\r
+ else\r
+ call right.ins(value)\r
+ fi;\r
+ fi;\r
+ end ins;\r
+\r
+ end node;\r
+\r
+ unit traverse : coroutine (i:integer);\r
+ var val: integer,\r
+ x: node;\r
+\r
+ unit t: procedure(y:node);\r
+ begin\r
+ if y=/=none\r
+ then\r
+ call t(y.left);\r
+ val:=y.val;\r
+ detach;\r
+ call t(y.right);\r
+ fi;\r
+ end t;\r
+ begin\r
+ x:=d(i);\r
+ return;\r
+ call t(x);\r
+ detach with endtree(i);\r
+ end traverse;\r
+ signal endtree(t:integer),fin ;\r
+\r
+ var n,i,j,min,m,k: integer,\r
+ d: arrayof node,\r
+ tr: arrayof traverse,\r
+ bb: integer;\r
+ exceptions\r
+ when endtree:\r
+ if bb=1\r
+ then\r
+ raise fin\r
+ fi;\r
+ bb:=1;\r
+ if t=1\r
+ then\r
+ j:=2\r
+ else\r
+ j:=1\r
+ fi;\r
+ do\r
+ write(tr(j).val); writeln;\r
+ attach(tr(j))\r
+ od;\r
+ when fin : terminate;\r
+ begin\r
+ read(n);\r
+ array d dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(j); write(j); if j>m then m:=j fi;\r
+ d(i):=new node;\r
+ d(i).val:=j;\r
+ do\r
+ read(j);\r
+ if j=-1 then writeln; exit fi;\r
+ write(j);\r
+ if j>m then m:=j fi;\r
+ call d(i).ins(j)\r
+ od;\r
+ od;\r
+ array tr dim (1:n);\r
+ min:=0;\r
+ for i:=1 to n\r
+ do\r
+ tr(i):=new traverse(i);\r
+ attach(tr(i));\r
+ od;\r
+ k:=0;\r
+ do\r
+ min:=tr(1).val;\r
+ j:=1;\r
+ for i:=2 to n\r
+ do\r
+ if min > tr(i).val then min:=tr(i).val; j:=i fi;\r
+ od;\r
+ write(min); attach(tr(j));\r
+ k:=k+1; if k=10 then writeln; k:=0 fi;\r
+ od;\r
+ writeln;\r
+ end mergecor\r
+\r
+*/\r
+\r
+\r
+\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 8\r
+\r
+\r
+ int displ= -6;\r
+ int displdir = -15;\r
+ int curr= -8;\r
+ int lstcor= -10;\r
+ int chead = -12;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspn ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 7, 0, 27, 26, 25, 24, 0, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 2, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 6, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{3, 3, 1, 9, 3, 0, 1, 4, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 4, 0, 9, 4, 3, 2, 5, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 5},\r
+{4, 6, 0, 9, 1, 0, 1, 4, 0, 9, 8, 7, 6, 0},\r
+{4, 7, 0, 9, 1, 0, 1, 2, 0, 9, 8, 7, 6, 0}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -6, 4, 0,\r
+ -4, 5, 0,\r
+ -2, 6, 0,\r
+ -8, 7, 0,\r
+ -10, 8, 0,\r
+ -12, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 1, 12, 0,\r
+ 3, -1, 0,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+\r
+\r
+ struct Hlstelem HL[]= { 6,0,1,\r
+ 7,1,-1 };\r
+ struct Sgelem SL[]= { 101,-1,\r
+ 102, -1 };\r
+\r
+\r
+\r
+node()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+L1: Endclass();\r
+L2: Killafter();\r
+ Endclass();\r
+}\r
+\r
+\r
+ins()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ };\r
+\r
+L1:\r
+ if (*Address(1,5) > *Local(1))\r
+ {\r
+ if (Notmember(Address(1,1)))\r
+ {\r
+ Dopen(1,0,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2:\r
+ *(Physical(Address(1,1))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,1));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=3; Go(Local(2));\r
+L3: Killafter() ;\r
+ };\r
+ }\r
+ else\r
+ {\r
+ if (Notmember(Address(1,3)))\r
+ {\r
+ Dopen(1,0,Address(1,3));\r
+ IC=4; Go(Address(1,3));\r
+L4: *(Physical(Address(1,3))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,3));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=5; Go(Local(2));\r
+L5: Killafter();\r
+ };\r
+ };\r
+ Back();\r
+L6: Killafter();\r
+ Back();\r
+}\r
+\r
+\r
+\r
+\r
+trav()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1: Refmove(Local(1),Arrayelem(Global(7),*Local(-1)));\r
+ IC=2; Back();\r
+L2: Dopen(4,3,Local(4));\r
+ Refmove(Physical(Local(4))+1,Local(1));\r
+ IC=3; Go(Local(4));\r
+L3: Killafter();\r
+ Attachwith(lastcor,101,Local(4));\r
+ *(Physical(Local(4))+5)= *Local(-1);\r
+ Attach(lastcor);\r
+ Endcor();\r
+L4: Killafter();\r
+ Endcor();\r
+}\r
+\r
+t()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ };\r
+L1:\r
+ if (Member(Local(1)))\r
+ { Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ *Address(1,3)= *(Physical(Local(1))+5);\r
+ IC=3; Attach(lastcor);\r
+L3: Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=4; Go(Local(3));\r
+L4: Killafter();\r
+ };\r
+ Back();\r
+L5: Killafter();\r
+ Back();\r
+}\r
+\r
+\r
+\r
+merge()\r
+\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ case 7: goto L7; break;\r
+ };\r
+\r
+L1:\r
+ printf("Number of trees n=2\n"); *Global(1)=2;\r
+ Openarray(5,1,*Global(1),Global(7));\r
+ printf("Give the values of nodes. End each tree with -1\n");\r
+ *Global(2)=1;\r
+ while (1)\r
+ {\r
+ if (*Global(2)> *Global(1)) break;\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Dopen(1,0,Arrayelem(Global(7),*Global(2)));\r
+ IC=2; Go(Arrayelem(Global(7),*Global(2)));\r
+L2: *(Physical(Arrayelem(Global(7),*Global(2)))+5)= *Global(3);\r
+ while(1)\r
+ {\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) == -1) break;\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Slopen(2,Global(16),Arrayelem(Global(7),*Global(2)));\r
+ *(Physical(Global(16))+1)= *Global(3);\r
+ IC=3; Go(Global(16));\r
+L3: Killafter();\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ (*Global(5))++;\r
+ Openarray(5,1,*Global(1),Global(9));\r
+ *Global(4)=0;\r
+ *Global(2)=1;\r
+ while(1)\r
+ { if (*Global(2) > *Global(1)) break;\r
+ Dopen(3,0,Arrayelem(Global(9),*Global(2)));\r
+ *(Physical(Arrayelem(Global(9),*Global(2)))-1)=\r
+ *Global(2);\r
+ IC=4; Go(Arrayelem(Global(9),*Global(2)));\r
+L4: IC=5; Attach(Arrayelem(Global(9),*Global(2)));\r
+L5: (*Global(2))++;\r
+ };\r
+ *Global(6)=0;\r
+ while(1)\r
+ {\r
+ if (*Global(4) == *Global(5) ) break;\r
+ *Global(4)= *(Physical(Arrayelem(Global(9),1))+3);\r
+ *Global(3)=1;\r
+ *Global(2)=2;\r
+ while (1)\r
+ {\r
+ if (*Global(2) > *Global(1)) break;\r
+ if (*Global(4) > *(Physical(Arrayelem(Global(9),*Global(2)))+3))\r
+ { *Global(4) = *(Physical(Arrayelem(Global(9),*Global(2)))+3);\r
+ *Global(3)= *Global(2);\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ if (*Global(4) < *Global(5))\r
+ {\r
+ printf("%d ",*Global(4));\r
+ IC=6; Attach(Arrayelem(Global(9),*Global(3)));\r
+L6: (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ };\r
+ };\r
+ Endrun();\r
+\r
+L7: Killafter();\r
+ Endrun();\r
+ }\r
+\r
+\r
+endtree()\r
+{\r
+ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ if (*Global(18))\r
+ { Raising(102,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2: ;\r
+ };\r
+ *Global(18)= 1;\r
+ if (*Address(1,5)==1) *Global(3)=2; else *Global(3)=1;\r
+ while(1)\r
+ { if (IC==0) break; /* dummy */\r
+ printf("%d ",*(Physical(Arrayelem(Global(9),*Global(3)))+3));\r
+ (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ IC=3; Attach(Arrayelem(Global(9),*Global(3)));\r
+L3: ;\r
+ };\r
+ Back();\r
+L4: Killafter();\r
+ Back();\r
+}\r
+\r
+fin()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+L1:\r
+ Termination();\r
+ Back();\r
+L2: Killafter();\r
+ Back();\r
+}\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=merge;\r
+ module[1]=node;\r
+ module[2]=ins;\r
+ module[3]=trav;\r
+ module[4]=t;\r
+ module[6]=endtree;\r
+ module[7]=fin;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\r
+\1a/*\r
+\r
+program pawel;\r
+ var n,m;\r
+\r
+ unit F: procedure;\r
+ var i: integer;\r
+ begin\r
+ if m=n+1\r
+ then\r
+ for i:=1 to n do write(A[i]," "); od;\r
+ writeln;\r
+ else\r
+ for i:=1 to n\r
+ do\r
+ if A[i]=0\r
+ then\r
+ A[i]:=m; m:=m+1;\r
+ F;\r
+ m:=m-1; A[i]:=0;\r
+ fi;\r
+ od;\r
+ fi;\r
+ end F;\r
+\r
+begin\r
+ write("Generation of all permutations. Give n=");\r
+ read(n); writeln;\r
+ A:=array[1..n] of integer;\r
+ m:=1;\r
+ F;\r
+end\r
+\r
+*/\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+\r
+#define numprot 3\r
+\r
+\r
+ int displ= 5;\r
+ int displdir = 9;\r
+ int curr= 11;\r
+ int lstcor= 13;\r
+ int chead =15;\r
+ int offnum = 1;\r
+ int protnum= numprot;\r
+\r
+\r
+ int perm [] = { 0,0,1};\r
+ int perminv [] = { 0,0,1};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen*/\r
+{\r
+{2, 0, 0, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{1, 1, 0, 9, 1, 0, 1, 0, 1, 9, 8, 7, 6, -1, -1, 1},\r
+{6, 2, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot]) ();\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 28, 0, 9, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 9, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 3, 1, 0,\r
+ 5, 2, 0,\r
+ 7, 3, 0,\r
+ 11, 4, 0,\r
+ 13, 5, 0,\r
+ 15, 6, 0,\r
+ 17, 7, 0,\r
+ 26, 8, 1,\r
+ 27, -1,2,\r
+ 8, 10, 1,\r
+ 9, -1, 2 };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+int pawel()\r
+{\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+\r
+ L1: printf("Generation of all permutations. Give n=");\r
+ scanf("%d",Global(1));\r
+ printf(" \n");\r
+ Openarray(2,1,*Global(1),Global(3));\r
+ { int i;\r
+ for (i=1; i<= *Global(1); i++)\r
+ *Arrayelem(Global(3),i)=0;\r
+ };\r
+ *Global(2)=1;\r
+ Dopen(1,0,Global(17)); IC=2;\r
+ Go(Global(17));\r
+ L2: Killafter();\r
+ Endrun();\r
+}\r
+\r
+int F()\r
+{\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+\r
+L1:\r
+ if (*Global(2)== *Global(1)+1)\r
+ { int i;\r
+ for (i=1; i<= *Global(1); i++)\r
+ printf("%d ",*(Arrayelem(Global(3),i)));\r
+ printf(" \n");\r
+ }\r
+ else\r
+\r
+ {int i;\r
+ for (i=1; i<= *Global(1);i++)\r
+ {\r
+ if (*(Arrayelem(Global(3),i))==0)\r
+ {\r
+ *(Arrayelem(Global(3),i))= *Global(2);\r
+ (*Global(2))++;\r
+ Dopen(1,0,Global(17)); *Local(1)=i;\r
+ IC=2; Go(Global(17));\r
+ L2: Killafter();\r
+ (*Global(2))--; i= *Local(1);\r
+ *(Arrayelem(Global(3),i))=0;\r
+ };\r
+ };\r
+ };\r
+ Back();\r
+ }\r
+\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=pawel;\r
+ module[1]=F;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer) !=-2) module[modulenumber]();\r
+}\r
+\r
+\1a/*\r
+\r
+program square;\r
+ var a,b,c,delta,x1,x2:real;\r
+begin\r
+ writeln(" solution of square equation a*x**2 b*x +c=0");\r
+ write(" give a= "); read(a);\r
+ write(" give b= "); read(b);\r
+ write(" give c= "); read(c);\r
+ delta:=b**2 - 4*a*c;\r
+ if delta < 0\r
+ then\r
+ writeln(" no solutions"); endrun;\r
+ fi;\r
+ delta:=sqrt(delta);\r
+ x1:=(-b-delta)/2/a;\r
+ x2:=(-b+delta)/2/a;\r
+ writeln("x1=",x1,"x2=",x2);\r
+end\r
+ */\r
+\r
+#include <math.h>\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+\r
+#define numprot 1\r
+\r
+#define rlh sizeof(float)/sizeof(int)\r
+\r
+#define aoff 1\r
+#define boff 1+rlh\r
+#define coff 1+2*rlh\r
+#define deloff 1+3*rlh\r
+#define x1off 1+4*rlh\r
+#define x2off 1+5*rlh\r
+\r
+\r
+ int displ=15;\r
+ int displdir =17;\r
+ int curr= 18;\r
+ int lstcor= 20;\r
+ int chead =22;\r
+ int offnum = 1;\r
+ int protnum= numprot;\r
+\r
+\r
+ int perm [] = { 0,0,1};\r
+ int perminv [] = { 0,0,1};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen*/\r
+{\r
+{2, 0, 0, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot+1]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 28, 0, 6, 0, 0, 0 };\r
+\r
+ struct Elem EL[]=\r
+ {\r
+ 15, 1, 0,\r
+ 18, 2, 0,\r
+ 20, 3, 0,\r
+ 22, 4, 0,\r
+ 26, 5, 1,\r
+ 27, -1,2,\r
+ };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+int square()\r
+{\r
+\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+ L1: printf(" solution of square equation a*x**2 + b*x +c=0\n");\r
+ printf(" \ngive a=");\r
+ scanf("%f", Flglobal(aoff));\r
+ printf(" \ngive b=");\r
+ scanf("%f", Flglobal(boff));\r
+ printf(" \ngive c=");\r
+ scanf("%f", Flglobal(coff));\r
+ * Flglobal(deloff) =\r
+ (* Flglobal(boff))*(* Flglobal(boff))-\r
+ 4*(* Flglobal(aoff))*(* Flglobal(coff));\r
+ if ( * Flglobal(deloff) < 0 )\r
+ {\r
+ printf(" no solutions\n");\r
+ Endrun();\r
+ };\r
+ * Flglobal(deloff) = sqrt( (double) * Flglobal(deloff) );\r
+ * Flglobal(x1off) = (- * Flglobal(boff) -\r
+ * Flglobal(deloff))/2/ * Flglobal(aoff);\r
+\r
+ * Flglobal(x2off) = (- * Flglobal(boff) +\r
+ * Flglobal(deloff))/2/ * Flglobal(aoff);\r
+ printf(" \n x1=%f\n",* Flglobal(x1off));\r
+ printf(" \n x2=%f\n",* Flglobal(x2off));\r
+ L2: Endrun();\r
+}\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=square;\r
+ IC=1;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer) !=-2) module[modulenumber]();\r
+}\r
+\r
+\1a/*\r
+\r
+program functest;\r
+ type F: function(n:integer): integer;\r
+\r
+ unit f : function(n:integer):F;\r
+\r
+ unit h:F;\r
+ begin\r
+ result:=n*2;\r
+ end h;\r
+\r
+ unit g:F;\r
+ begin\r
+ result:=n+2;\r
+ end g;\r
+\r
+ begin\r
+ if n=0 then result=h else result:=g fi;\r
+ end f;\r
+\r
+ var x,y :F; n:integer;\r
+\r
+begin\r
+ x:=f(0); y:=f(1);\r
+ write("n="); readln(n); writeln(x(n));\r
+ write("m="); readln(n); writeln(y(n));\r
+end\r
+\r
+*/\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPLAY,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 4\r
+\r
+\r
+ int displ= -9;\r
+ int displdir = 20;\r
+ int curr= -11;\r
+ int lstcor= -13;\r
+ int chead = -15;\r
+ int protnum=numprot;\r
+ int offnum=3;\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{1, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 3, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 3, 0, 11, 0,\r
+ 0, 10, 2, 2, 0, 14, 0,\r
+ };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 2,\r
+ 9, 2, 2,\r
+ 16, 3, 0,\r
+ -9, 4, 0,\r
+ -7, 5, 0,\r
+ -5, 6, 0,\r
+ -11, 7, 0,\r
+ -13, 8, 0,\r
+ -15, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 2, 12, 2,\r
+ 8, 13, 1,\r
+ 9, -1, 2,\r
+ 8, 15, 1,\r
+ 9, -1, 2\r
+ };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+procclostest()\r
+ {\r
+ switch(IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+\r
+ };\r
+L1: Dopen(1,0,Global(16));\r
+ *(Physical(Global(16))+1)= 0;\r
+ IC=2;Go(Global(16));\r
+L2: Procclosmove(Global(7), Physical(Global(16))+2);\r
+ Killafter();\r
+ Dopen(1,0,Global(16));\r
+ *(Physical(Global(16))+1)= 1;\r
+ IC=3;Go(Global(16));\r
+L3: Procclosmove(Global(9), Physical(Global(16))+2);\r
+ Killafter();\r
+ printf("n=");\r
+ scanf("%d",Global(6));\r
+ Slopen(*Global(8),Global(16),Global(7));\r
+ *(Physical(Global(16))+1)= *Global(6);\r
+ IC=4;Go(Global(16));\r
+L4: printf("%d\n",*(Physical(Global(16))+2));\r
+ Killafter();\r
+ printf("m=");\r
+ scanf("%d",Global(6));\r
+ Slopen(*Global(10),Global(16),Global(9));\r
+ *(Physical(Global(16))+1)= *Global(6);\r
+ IC=5;Go(Global(16));\r
+L5: printf("%d\n",*(Physical(Global(16))+2));\r
+ Killafter();\r
+ Endrun();\r
+}\r
+\r
+\r
+f()\r
+{\r
+ if ( *Local(1) == 0)\r
+ {\r
+ *Local(2) = *current;\r
+ *Local(3) = 2;\r
+ }\r
+ else\r
+ {\r
+ *Local(2) = *current;\r
+ *Local(3) = 3;\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+h()\r
+{\r
+ *Local(2) = *Local(1) * 2;\r
+ Back();\r
+}\r
+\r
+g()\r
+{\r
+ *Local(2) = *Local(1) +2;\r
+ Back();\r
+}\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=procclostest;\r
+ module[1]=f;\r
+ module[2]=h;\r
+ module[3]=g;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+ }\r
+\1a/*\r
+\r
+program MEMORYTEST;\r
+var i,j,k,n: integer,\r
+ X,Y: A,\r
+ Z: arrayof A;\r
+ unit A: class;\r
+ var P: arrayof A;\r
+ begin\r
+ array P dim(1:j);\r
+ end A;\r
+begin\r
+ i:=0;\r
+ read(n); read(k);\r
+ for j:=1 to n\r
+ do\r
+ X:=new A; i:=i+1;\r
+ if i=k\r
+ then\r
+ Z:=Y.P;\r
+ kill(Y); kill(Z);\r
+ i:=0;\r
+ fi;\r
+ Y:=X;\r
+ od;\r
+end\r
+\r
+*/\r
+\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+\r
+#define numprot 3\r
+\r
+\r
+\r
+ int displdir = 15;\r
+ int displ= 11;\r
+ int curr= 17;\r
+ int lstcor= 19;\r
+ int chead =21;\r
+ int protnum=numprot;\r
+ int offnum=1;\r
+\r
+ int perm [] = { 0,0,1};\r
+ int perminv [] = { 0,0,1};\r
+\r
+ struct Prototype PROT[]=\r
+\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 0, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 1, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 2}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 30, 0, 8, 0, 0, 0,\r
+ 0, 12, 1, 3, 0, 8, 0 };\r
+\r
+ struct Elem EL[]=\r
+ {\r
+ 5, 1, 0,\r
+ 7, 2, 0,\r
+ 11, 3, 0,\r
+ 13, 4, 0,\r
+ 21, 5, 0,\r
+ 17, 6, 0,\r
+ 26, 7, 1,\r
+ 27, -1,2,\r
+ 1, 9, 0,\r
+ 8, 10, 1,\r
+ 9, -1, 2 };\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+int memor()\r
+{\r
+ switch (IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+ L1: *Global(1)=0;\r
+ printf("\n n="); scanf("%d",Global(4));\r
+ printf("\n k="); scanf("%d",Global(3));\r
+ *Global(2)=1;\r
+ while (1)\r
+ { if (*Global(2) > *Global(4)) break;\r
+ Dopen(1,0,Global(5)); IC=2;\r
+ Go(Global(5));\r
+ L2: (*Global(1))++;\r
+ if (*Global(1)== *Global(3))\r
+ {\r
+ Refmove(Global(9),Physical(Global(7))+1);\r
+ Gkill(Global(7));\r
+ Gkill(Global(9));\r
+ *Global(1)=0;\r
+ };\r
+ Refmove(Global(7),Global(5));\r
+ (*Global(2))++;\r
+ };\r
+ Endrun ();\r
+ }\r
+\r
+int A()\r
+{\r
+ Openarray(2,1,*Global(2),Local(1));\r
+ Endclass ();\r
+}\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=memor;\r
+ module[1]=A;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\r
+\1a\r
+/*\r
+\r
+program merge;\r
+ unit node: class;\r
+ var left,right : node,\r
+ val : integer;\r
+\r
+ unit ins: procedure( value: integer) ;\r
+ begin\r
+ if val > value\r
+ then\r
+ if left=none\r
+ then\r
+ left:=new node;\r
+ left.val:=value;\r
+ else\r
+ call left.ins(value);\r
+ fi;\r
+ else\r
+ if right = none\r
+ then\r
+ right:=new node;\r
+ right.val:=value;\r
+ else\r
+ call right.ins(value)\r
+ fi;\r
+ fi;\r
+ end ins;\r
+\r
+ end node;\r
+\r
+ unit traverse : coroutine (x:node);\r
+ var val: integer;\r
+\r
+ unit t: procedure(y:node);\r
+ begin\r
+ if y=/=none\r
+ then\r
+ call t(y.left);\r
+ val:=y.val;\r
+ detach;\r
+ call t(y.right);\r
+ fi;\r
+ end t;\r
+ begin\r
+ return;\r
+ call t(x);\r
+ val:=m;\r
+ end traverse;\r
+\r
+ var n,i,j,min,m,k: integer,\r
+ d: arrayof node,\r
+ tr: arrayof traverse;\r
+ begin\r
+ read(n);\r
+ array d dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(j); write(j); if j>m then m:=j fi;\r
+ d(i):=new node;\r
+ d(i).val:=j;\r
+ do\r
+ read(j);\r
+ if j=-1 then writeln; exit fi;\r
+ write(j);\r
+ if j>m then m:=j fi;\r
+ call d(i).ins(j)\r
+ od;\r
+ od;\r
+ m:=m+1;\r
+ array tr dim (1:n);\r
+ min:=0;\r
+ for i:=1 to n\r
+ do\r
+ tr(i):=new traverse(d(i));\r
+ attach(tr(i));\r
+ od;\r
+ k:=0;\r
+ do\r
+ if min=m then exit fi;\r
+ min:=tr(1).val;\r
+ j:=1;\r
+ for i:=2 to n\r
+ do\r
+ if min > tr(i).val then min:=tr(i).val; j:=i fi;\r
+ od;\r
+ if min<m\r
+ then\r
+ write(min); attach(tr(j));\r
+ k:=k+1; if k=10 then writeln; k:=0 fi;\r
+ fi;\r
+ od;\r
+ writeln;\r
+ attach(tr(j));\r
+ end merge\r
+\r
+*/\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 6\r
+\r
+ int displ= -6;\r
+ int displdir = -15;\r
+ int curr= -8;\r
+ int lstcor= -10;\r
+ int chead = -12;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref psleng*/\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{3, 3, 0, 9, 3, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 4, 0, 9, 4, 3, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 5 }\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -6, 4, 0,\r
+ -4, 5, 0,\r
+ -2, 6, 0,\r
+ -8, 7, 0,\r
+ -10, 8, 0,\r
+ -12, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 1, 12, 0,\r
+ 3, -1, 0,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+node()\r
+{\r
+ Endclass();\r
+}\r
+\r
+\r
+ins()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ };\r
+\r
+L1:\r
+ if (*Address(1,5) > *Local(1))\r
+ {\r
+ if (Notmember(Address(1,1)))\r
+ {\r
+ Dopen(1,0,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2:\r
+ *(Physical(Address(1,1))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,1));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=3; Go(Local(2));\r
+L3: Killafter() ;\r
+ };\r
+ }\r
+ else\r
+ {\r
+ if (Notmember(Address(1,3)))\r
+ {\r
+ Dopen(1,0,Address(1,3));\r
+ IC=4; Go(Address(1,3));\r
+L4: *(Physical(Address(1,3))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,3));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=5; Go(Local(2));\r
+L5: Killafter();\r
+ };\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+\r
+traverse()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ IC=2; Back();\r
+L2: Dopen(4,3,Local(4));\r
+ Refmove(Physical(Local(4))+1,Local(1));\r
+ IC=3; Go(Local(4));\r
+L3: Killafter();\r
+ *Local(3)= *Global(5);\r
+ IC=4; Attach(lastcor);\r
+L4: Endcor();\r
+}\r
+\r
+t()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ if (Member(Local(1)))\r
+ { Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ *Address(1,3)= *(Physical(Local(1))+5);\r
+ IC=3; Attach(lastcor);\r
+L3: Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=4; Go(Local(3));\r
+L4: Killafter();\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+ merge()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ };\r
+L1:\r
+ printf("Number of trees n="); scanf("%d",Global(1));\r
+ Openarray(5,1,*Global(1),Global(7));\r
+ printf("Give the values of nodes. End each tree with -1\n");\r
+ *Global(2)=1;\r
+ while (1)\r
+ {\r
+ if (*Global(2)> *Global(1)) break;\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Dopen(1,0,Arrayelem(Global(7),*Global(2)));\r
+ IC=2; Go(Arrayelem(Global(7),*Global(2)));\r
+L2: *(Physical(Arrayelem(Global(7),*Global(2)))+5)= *Global(3);\r
+ while(1)\r
+ {\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) == -1) break;\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Slopen(2,Global(16),Arrayelem(Global(7),*Global(2)));\r
+ *(Physical(Global(16))+1)= *Global(3);\r
+ IC=3; Go(Global(16));\r
+L3: Killafter();\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ (*Global(5))++;\r
+ Openarray(5,1,*Global(1),Global(9));\r
+ *Global(4)=0;\r
+ *Global(2)=1;\r
+ while(1)\r
+ { if (*Global(2) > *Global(1)) break;\r
+ Dopen(3,0,Arrayelem(Global(9),*Global(2)));\r
+ Refmove(Physical(Arrayelem(Global(9),*Global(2)))+1,\r
+ Arrayelem(Global(7),*Global(2)));\r
+ IC=4; Go(Arrayelem(Global(9),*Global(2)));\r
+L4: IC=5; Attach(Arrayelem(Global(9),*Global(2)));\r
+L5: (*Global(2))++;\r
+ };\r
+ *Global(6)=0;\r
+ while(1)\r
+ {\r
+ if (*Global(4) == *Global(5) ) break;\r
+ *Global(4)= *(Physical(Arrayelem(Global(9),1))+3);\r
+ *Global(3)=1;\r
+ *Global(2)=2;\r
+ while (1)\r
+ {\r
+ if (*Global(2) > *Global(1)) break;\r
+ if (*Global(4) > *(Physical(Arrayelem(Global(9),*Global(2)))+3))\r
+ { *Global(4) = *(Physical(Arrayelem(Global(9),*Global(2)))+3);\r
+ *Global(3)= *Global(2);\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ if (*Global(4) < *Global(5))\r
+ {\r
+ printf("%d ",*Global(4));\r
+ IC=6; Attach(Arrayelem(Global(9),*Global(3)));\r
+L6: (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ };\r
+ };\r
+\r
+ Attach(Arrayelem(Global(9),*Global(3)));\r
+ Endrun();\r
+ }\r
+\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=merge;\r
+ module[1]=node;\r
+ module[2]=ins;\r
+ module[3]=traverse;\r
+ module[4]=t;\r
+ IC=1;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\1a\r
+/*\r
+\r
+program merge;\r
+ unit node: class;\r
+ var left,right : node,\r
+ val : integer;\r
+\r
+ unit ins: procedure( value: integer) ;\r
+ begin\r
+ if val > value\r
+ then\r
+ if left=none\r
+ then\r
+ left:=new node;\r
+ left.val:=value;\r
+ else\r
+ call left.ins(value);\r
+ fi;\r
+ else\r
+ if right = none\r
+ then\r
+ right:=new node;\r
+ right.val:=value;\r
+ else\r
+ call right.ins(value)\r
+ fi;\r
+ fi;\r
+ end ins;\r
+\r
+ end node;\r
+\r
+ unit traverse : coroutine (x:node);\r
+ var val: integer;\r
+\r
+ unit t: procedure(y:node);\r
+ begin\r
+ if y=/=none\r
+ then\r
+ call t(y.left);\r
+ val:=y.val;\r
+ detach;\r
+ call t(y.right);\r
+ fi;\r
+ end t;\r
+ begin\r
+ return;\r
+ call t(x);\r
+ val:=m;\r
+ end traverse;\r
+\r
+\r
+ unit killtree: procedure (x:node);\r
+ begin\r
+ if x=/= none\r
+ then\r
+ killtree(x.left);\r
+ killtree(x.right);\r
+ kill(x);\r
+ fi;\r
+ end killtree;\r
+\r
+ unit clear:procedure ;\r
+ var i:integer;\r
+ begin\r
+ for i:=1 to n do call killtree(d(i)); od;\r
+ for i:=1 to n do kill(tr(i)); od;\r
+ kill(d);\r
+ kill(tr);\r
+ end clear;\r
+\r
+ var n,i,j,min,m,k: integer,\r
+ d: arrayof node,\r
+ tr: arrayof traverse;\r
+ begin\r
+ read(n);\r
+ array d dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(j); write(j); if j>m then m:=j fi;\r
+ d(i):=new node;\r
+ d(i).val:=j;\r
+ do\r
+ read(j);\r
+ if j=-1 then writeln; exit fi;\r
+ write(j);\r
+ if j>m then m:=j fi;\r
+ call d(i).ins(j)\r
+ od;\r
+ od;\r
+ m:=m+1;\r
+ array tr dim (1:n);\r
+ min:=0;\r
+ for i:=1 to n\r
+ do\r
+ tr(i):=new traverse(d(i));\r
+ attach(tr(i));\r
+ od;\r
+ k:=0;\r
+ do\r
+ if min=m then exit fi;\r
+ min:=tr(1).val;\r
+ j:=1;\r
+ for i:=2 to n\r
+ do\r
+ if min > tr(i).val then min:=tr(i).val; j:=i fi;\r
+ od;\r
+ if min<m\r
+ then\r
+ write(min); attach(tr(j));\r
+ k:=k+1; if k=10 then writeln; k:=0 fi;\r
+ fi;\r
+ od;\r
+ writeln;\r
+ call clear;\r
+ end merge\r
+\r
+*/\r
+\r
+\r
+\r
+#include "rsdata.h"\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 9\r
+\r
+ int displ= -6;\r
+ int displdir = -15;\r
+ int curr= -8;\r
+ int lstcor= -10;\r
+ int chead = -12;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref psleng*/\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{3, 3, 0, 9, 3, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 4, 0, 9, 4, 3, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 5 },\r
+{1, 6, 0, 9, 2, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 7, 0, 9, 4, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -6, 4, 0,\r
+ -4, 5, 0,\r
+ -2, 6, 0,\r
+ -8, 7, 0,\r
+ -10, 8, 0,\r
+ -12, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 1, 12, 0,\r
+ 3, -1, 0,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+node()\r
+{\r
+ Endclass();\r
+}\r
+\r
+\r
+ins()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ };\r
+\r
+L1:\r
+ if (*Address(1,5) > *Local(1))\r
+ {\r
+ if (Notmember(Address(1,1)))\r
+ {\r
+ Dopen(1,0,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2:\r
+ *(Physical(Address(1,1))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,1));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=3; Go(Local(2));\r
+L3: Killafter() ;\r
+ };\r
+ }\r
+ else\r
+ {\r
+ if (Notmember(Address(1,3)))\r
+ {\r
+ Dopen(1,0,Address(1,3));\r
+ IC=4; Go(Address(1,3));\r
+L4: *(Physical(Address(1,3))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,3));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=5; Go(Local(2));\r
+L5: Killafter();\r
+ };\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+\r
+traverse()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ IC=2; Back();\r
+L2: Dopen(4,3,Local(4));\r
+ Refmove(Physical(Local(4))+1,Local(1));\r
+ IC=3; Go(Local(4));\r
+L3: Killafter();\r
+ *Local(3)= *Global(5);\r
+ IC=4; Attach(lastcor);\r
+L4: Endcor();\r
+}\r
+\r
+t()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ if (Member(Local(1)))\r
+ { Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ *Address(1,3)= *(Physical(Local(1))+5);\r
+ IC=3; Attach(lastcor);\r
+L3: Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=4; Go(Local(3));\r
+L4: Killafter();\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+clear()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+L1:*Local(1)=1;\r
+ while (1)\r
+ {\r
+ if (*Local(1)> *Global(1)) break;\r
+ Dopen(7,0,Local(2));\r
+ Refmove(Physical(Local(2))+1,Arrayelem(Global(7),*Local(1)));\r
+ IC=2; Go(Local(2));\r
+L2: Killafter();\r
+ (*Local(1))++;\r
+ };\r
+ Memorydump();\r
+ *Local(1)=1;\r
+ while (1)\r
+ {\r
+ if (*Local(1)> *Global(1)) break;\r
+ Gkill(Arrayelem(Global(9),*Local(1)));\r
+ (*Local(1))++;\r
+ };\r
+ Memorydump();\r
+ Gkill(Global(7));\r
+ Gkill(Global(9));\r
+ Back();\r
+}\r
+\r
+\r
+killtree()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ };\r
+L1:if (Member(Local(1)))\r
+ {\r
+ Dopen(7,0,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ Dopen(7,0,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=3; Go(Local(3));\r
+L3: Killafter();\r
+ Gkill(Local(1));\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+ merge()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ case 7: goto L7; break;\r
+ };\r
+L1:\r
+ printf("Number of trees n="); scanf("%d",Global(1));\r
+ Openarray(5,1,*Global(1),Global(7));\r
+ printf("Give the values of nodes. End each tree with -1\n");\r
+ *Global(2)=1;\r
+ while (1)\r
+ {\r
+ if (*Global(2)> *Global(1)) break;\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Dopen(1,0,Arrayelem(Global(7),*Global(2)));\r
+ IC=2; Go(Arrayelem(Global(7),*Global(2)));\r
+L2: *(Physical(Arrayelem(Global(7),*Global(2)))+5)= *Global(3);\r
+ while(1)\r
+ {\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) == -1) break;\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Slopen(2,Global(16),Arrayelem(Global(7),*Global(2)));\r
+ *(Physical(Global(16))+1)= *Global(3);\r
+ IC=3; Go(Global(16));\r
+L3: Killafter();\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ (*Global(5))++;\r
+ Openarray(5,1,*Global(1),Global(9));\r
+ *Global(4)=0;\r
+ *Global(2)=1;\r
+ while(1)\r
+ { if (*Global(2) > *Global(1)) break;\r
+ Dopen(3,0,Arrayelem(Global(9),*Global(2)));\r
+ Refmove(Physical(Arrayelem(Global(9),*Global(2)))+1,\r
+ Arrayelem(Global(7),*Global(2)));\r
+ IC=4; Go(Arrayelem(Global(9),*Global(2)));\r
+L4: IC=5; Attach(Arrayelem(Global(9),*Global(2)));\r
+L5: (*Global(2))++;\r
+ };\r
+ *Global(6)=0;\r
+ while(1)\r
+ {\r
+ if (*Global(4) == *Global(5) ) break;\r
+ *Global(4)= *(Physical(Arrayelem(Global(9),1))+3);\r
+ *Global(3)=1;\r
+ *Global(2)=2;\r
+ while (1)\r
+ {\r
+ if (*Global(2) > *Global(1)) break;\r
+ if (*Global(4) > *(Physical(Arrayelem(Global(9),*Global(2)))+3))\r
+ { *Global(4) = *(Physical(Arrayelem(Global(9),*Global(2)))+3);\r
+ *Global(3)= *Global(2);\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ if (*Global(4) < *Global(5))\r
+ {\r
+ printf("%d ",*Global(4));\r
+ IC=6; Attach(Arrayelem(Global(9),*Global(3)));\r
+L6: (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ };\r
+ };\r
+ Memorydump();\r
+ Dopen(6,0,Global(16));\r
+ IC=7; Go(Global(16));\r
+L7: Killafter();\r
+ Memorydump();\r
+ Endrun();\r
+ }\r
+\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=merge;\r
+ module[1]=node;\r
+ module[2]=ins;\r
+ module[3]=traverse;\r
+ module[4]=t;\r
+ module[6]=clear;\r
+ module[7]=killtree;\r
+ IC=1;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\1a/*\r
+\r
+program merge;\r
+ unit node: class;\r
+ var left,right : node,\r
+ val : integer;\r
+\r
+ unit ins: procedure( value: integer) ;\r
+ begin\r
+ if val > value\r
+ then\r
+ if left=none\r
+ then\r
+ left:=new node;\r
+ left.val:=value;\r
+ else\r
+ call left.ins(value);\r
+ fi;\r
+ else\r
+ if right = none\r
+ then\r
+ right:=new node;\r
+ right.val:=value;\r
+ else\r
+ call right.ins(value)\r
+ fi;\r
+ fi;\r
+ end ins;\r
+\r
+ end node;\r
+\r
+ unit traverse : coroutine (x:node);\r
+ var val: integer;\r
+\r
+ unit t: procedure(y:node);\r
+ begin\r
+ if y=/=none\r
+ then\r
+ call t(y.left);\r
+ val:=y.val;\r
+ detach;\r
+ call t(y.right);\r
+ fi;\r
+ end t;\r
+ begin\r
+ return;\r
+ call t(x);\r
+ val:=m;\r
+ end traverse;\r
+\r
+ var n,i,j,min,m,k: integer,\r
+ d: arrayof node,\r
+ tr: arrayof traverse;\r
+ begin\r
+ read(n);\r
+ array d dim(1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(j); write(j); if j>m then m:=j fi;\r
+ d(i):=new node;\r
+ d(i).val:=j;\r
+ do\r
+ read(j);\r
+ if j=-1 then writeln; exit fi;\r
+ write(j);\r
+ if j>m then m:=j fi;\r
+ call d(i).ins(j)\r
+ od;\r
+ od;\r
+ m:=m+1;\r
+ array tr dim (1:n);\r
+ min:=0;\r
+ for i:=1 to n\r
+ do\r
+ tr(i):=new traverse(d(i));\r
+ attach(tr(i));\r
+ od;\r
+ k:=0;\r
+ do\r
+ if min=m then exit fi;\r
+ min:=tr(1).val;\r
+ j:=1;\r
+ for i:=2 to n\r
+ do\r
+ if min > tr(i).val then min:=tr(i).val; j:=i fi;\r
+ od;\r
+ if min<m\r
+ then\r
+ write(min); attach(tr(j));\r
+ k:=k+1; if k=10 then writeln; k:=0 fi;\r
+ fi;\r
+ od;\r
+ writeln;\r
+ end merge\r
+\r
+*/\r
+\r
+\r
+\r
+#include "rsdata.h"\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISVIRT,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 6\r
+\r
+ int displ= -6;\r
+ int displdir = -15;\r
+ int curr= -8;\r
+ int lstcor= -10;\r
+ int chead = -12;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+\r
+ int perm [] = { 0,1,2};\r
+ int perminv [] = { 0,1,2};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref psleng*/\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 2, 1, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{3, 3, 0, 9, 3, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 4, 0, 9, 4, 3, 2, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{7, 5 }\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -6, 4, 0,\r
+ -4, 5, 0,\r
+ -2, 6, 0,\r
+ -8, 7, 0,\r
+ -10, 8, 0,\r
+ -12, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 1, 12, 0,\r
+ 3, -1, 0,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+\r
+node()\r
+{\r
+ Endclass();\r
+}\r
+\r
+\r
+ins()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ };\r
+\r
+L1:\r
+ if (*Address(1,5) > *Local(1))\r
+ {\r
+ if (Notmember(Address(1,1)))\r
+ {\r
+ Dopen(1,0,Address(1,1));\r
+ IC=2; Go(Address(1,1));\r
+L2:\r
+ *(Physical(Address(1,1))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,1));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=3; Go(Local(2));\r
+L3: Killafter() ;\r
+ };\r
+ }\r
+ else\r
+ {\r
+ if (Notmember(Address(1,3)))\r
+ {\r
+ Dopen(1,0,Address(1,3));\r
+ IC=4; Go(Address(1,3));\r
+L4: *(Physical(Address(1,3))+5)= *Local(1);\r
+ }\r
+ else\r
+ {\r
+ Slopen(2,Local(2),Address(1,3));\r
+ *(Physical(Local(2))+1)= *Local(1);\r
+ IC=5; Go(Local(2));\r
+L5: Killafter();\r
+ };\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+\r
+\r
+traverse()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ IC=2; Back();\r
+L2: Dopen(4,3,Local(4));\r
+ Refmove(Physical(Local(4))+1,Local(1));\r
+ IC=3; Go(Local(4));\r
+L3: Killafter();\r
+ *Local(3)= *Global(5);\r
+ IC=4; Attach(lastcor);\r
+L4: Endcor();\r
+}\r
+\r
+t()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ };\r
+L1:\r
+ if (Member(Local(1)))\r
+ { Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+1);\r
+ IC=2; Go(Local(3));\r
+L2: Killafter();\r
+ *Address(1,3)= *(Physical(Local(1))+5);\r
+ IC=3; Attach(lastcor);\r
+L3: Dopen(4,3,Local(3));\r
+ Refmove(Physical(Local(3))+1,Physical(Local(1))+3);\r
+ IC=4; Go(Local(3));\r
+L4: Killafter();\r
+ };\r
+ Back();\r
+}\r
+\r
+\r
+ merge()\r
+{ switch(IC)\r
+ {\r
+ case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ case 4: goto L4; break;\r
+ case 5: goto L5; break;\r
+ case 6: goto L6; break;\r
+ };\r
+L1:\r
+ printf("Number of trees n="); scanf("%d",Global(1));\r
+ Openarray(5,1,*Global(1),Global(7));\r
+ printf("Give the values of nodes. End each tree with -1\n");\r
+ *Global(2)=1;\r
+ while (1)\r
+ {\r
+ if (*Global(2)> *Global(1)) break;\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Dopen(1,0,Arrayelem(Global(7),*Global(2)));\r
+ IC=2; Go(Arrayelem(Global(7),*Global(2)));\r
+L2: *(Physical(Arrayelem(Global(7),*Global(2)))+5)= *Global(3);\r
+ while(1)\r
+ {\r
+ scanf("%d",Global(3));\r
+ if (*Global(3) == -1) break;\r
+ if (*Global(3) > *Global(5)) *Global(5)= *Global(3);\r
+ Slopen(2,Global(16),Arrayelem(Global(7),*Global(2)));\r
+ *(Physical(Global(16))+1)= *Global(3);\r
+ IC=3; Go(Global(16));\r
+L3: Killafter();\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ (*Global(5))++;\r
+ Openarray(5,1,*Global(1),Global(9));\r
+ *Global(4)=0;\r
+ *Global(2)=1;\r
+ while(1)\r
+ { if (*Global(2) > *Global(1)) break;\r
+ Dopen(3,0,Arrayelem(Global(9),*Global(2)));\r
+ Refmove(Physical(Arrayelem(Global(9),*Global(2)))+1,\r
+ Arrayelem(Global(7),*Global(2)));\r
+ IC=4; Go(Arrayelem(Global(9),*Global(2)));\r
+L4: IC=5; Attach(Arrayelem(Global(9),*Global(2)));\r
+L5: (*Global(2))++;\r
+ };\r
+ *Global(6)=0;\r
+ while(1)\r
+ {\r
+ if (*Global(4) == *Global(5) ) break;\r
+ *Global(4)= *(Physical(Arrayelem(Global(9),1))+3);\r
+ *Global(3)=1;\r
+ *Global(2)=2;\r
+ while (1)\r
+ {\r
+ if (*Global(2) > *Global(1)) break;\r
+ if (*Global(4) > *(Physical(Arrayelem(Global(9),*Global(2)))+3))\r
+ { *Global(4) = *(Physical(Arrayelem(Global(9),*Global(2)))+3);\r
+ *Global(3)= *Global(2);\r
+ };\r
+ (*Global(2))++;\r
+ };\r
+ if (*Global(4) < *Global(5))\r
+ {\r
+ printf("%d ",*Global(4));\r
+ IC=6; Attach(Arrayelem(Global(9),*Global(3)));\r
+L6: (*Global(6))++;\r
+ if (*Global(6)==10) { printf(" \n"); *Global(6)=0; };\r
+ };\r
+ };\r
+ Endrun();\r
+ }\r
+\r
+\r
+main ()\r
+{ Init();\r
+ module[0]=merge;\r
+ module[1]=node;\r
+ module[2]=ins;\r
+ module[3]=traverse;\r
+ module[4]=t;\r
+ modulenumber=0;\r
+ IC=1;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+}\r
+\r
+\1a\r
+#include "rsdata.h"\r
+\r
+\r
+\r
+extern int IC; /* global control */\r
+extern int modulenumber; /* module number */\r
+extern unsigned int *DISPLAY,*DISPDIR; /* displays' addresses */\r
+extern unsigned int *lastcor,*mycoroutine,*myprocess;\r
+extern unsigned int *current,*local,*global;\r
+\r
+#define numprot 5\r
+\r
+\r
+ int displ= -9;\r
+ int displdir = 20;\r
+ int curr= -11;\r
+ int lstcor= -13;\r
+ int chead = -15;\r
+ int protnum=numprot;\r
+ int offnum=4;\r
+\r
+ int perm [] = { 0,1,0,2,1,3};\r
+ int perminv [] = { 0,1,0,2,1,3};\r
+\r
+ struct Prototype PROT [] =\r
+/*\r
+kind num lspn rspan ref dcl lev lst pmdd Sl DL Lsc Stat hand pref pslen */\r
+{\r
+{2, 0, 15, 27, 0, -1, 0, 0, 0, 27, 26, 25, 24, -1, -1, 1},\r
+{0, 1, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{1, 2, 0, 9, 1, 0, 1, 0, 0, 9, 8, 7, 6, -1, -1, 1},\r
+{0, 3, 0, 9, 1, 2, 2, 0, 2, 9, 8, 7, 6, -1, 1, 2},\r
+{1, 4, 0, 9, 1, 3, 3, 0, 2, 9, 8, 7, 6, -1, -1, 1}\r
+};\r
+\r
+\r
+ int (* module [numprot]) () ;\r
+ jmp_buf buffer;\r
+\r
+ struct Offsets OFF[]=\r
+ { 0, 43, 0, 11, 0, 0, 0,\r
+ 0, 10, 1, 2, 0, 11, 0,\r
+ 0, 10, 2, 3, 0, 13, 0,\r
+ 0, 10, 3, 4, 0, 16, 0,\r
+ 0, 10, 4, 4, 0, 20, 0 };\r
+\r
+ struct Elem EL[]=\r
+ { 7, 1, 0,\r
+ 9, 2, 0,\r
+ 16, 3, 0,\r
+ -9, 4, 0,\r
+ -7, 5, 0,\r
+ -5, 6, 0,\r
+ -11, 7, 0,\r
+ -13, 8, 0,\r
+ -15, 9, 0,\r
+ 26, 10, 1,\r
+ 27, -1, 2,\r
+ 8, 12, 1,\r
+ 9, -1, 2,\r
+ 2, 14, 0,\r
+ 8, 15, 1,\r
+ 9, -1, 2,\r
+ 1, 17, 0,\r
+ 4, 18, 0,\r
+ 8, 19, 1,\r
+ 9, -1, 2,\r
+ 1, 21, 0,\r
+ 3, 22, 0,\r
+ 8, 23, 1,\r
+ 9, -1, 2};\r
+\r
+ struct Hlstelem HL[]= { 0 };\r
+ struct Sgelem SL[]= { 0 };\r
+\r
+\r
+sltest()\r
+ {\r
+ switch(IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ case 3: goto L3; break;\r
+ };\r
+L1: Dopen(2,0,Global(16));\r
+ IC=2;Go(Global(16));\r
+L2: Killafter();\r
+ Slopen(4,Global(16),Global(7));\r
+ IC=3;\r
+ Go(Global(16));\r
+L3: Killafter();\r
+ Endrun();\r
+}\r
+\r
+\r
+A()\r
+{\r
+ switch(IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+L1: Inn(1);\r
+L2: Endclass();\r
+}\r
+\r
+Bk()\r
+{\r
+ switch(IC)\r
+ { case 1: goto L1; break;\r
+ case 2: goto L2; break;\r
+ };\r
+\r
+L1: Dopen(3,2,Global(7));\r
+ IC=2; Go(Global(7));\r
+L2:\r
+ Back();\r
+}\r
+\r
+B()\r
+{ IC=2;\r
+ modulenumber=1;\r
+ longjmp(buffer,-1);\r
+}\r
+\r
+P()\r
+{ (* Address(2,1))++;\r
+ printf("i=%d\n", *Address(2,1));\r
+ Back();\r
+}\r
+\r
+\r
+\r
+main ()\r
+{\r
+ Init();\r
+ module[0]=sltest;\r
+ module[1]=A;\r
+ module[2]=Bk;\r
+ module[3]=B;\r
+ module[4]=P;\r
+ IC=1;\r
+ modulenumber=0;\r
+ if (setjmp(buffer)!=-2) module[modulenumber]();\r
+ }\r
+\1a\r
--- /dev/null
+From: MX%"antek@mimuw.edu.pl" 1-MAR-1993 17:47:52.39\r
+To: SALWICKI\r
+CC: \r
+Subj: \r
+\r
+Date: Mon, 1 Mar 93 14:59:27 GMT\r
+From: antek@mimuw.edu.pl\r
+To: salwicki@pauvx1.univ-pau.fr\r
+\r
+\1cw\r
+\U1STANDARD\r
+\U2POLISH\r
+\U3ITALIC\r
+\U4BOLD\r
+\U"ORATOR\r
+\U(PLORATOR\r
+\+\r
+\+\r
+\ \ \ \ \\r
+\-\r
+\+\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \"PRZENASZALNY RUNNING SYSTEM NOWEGO LOGLANU\ \ \ \ \ \ \ \ \ \ \^\r
+\-\r
+\+\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ NAPISANY W J\(E\"ZYKU C\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \1Antoni Kreczmar\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\r
+\-\r
+\+\r
+\ \\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+1. Wst\2e\1p\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Poni\2x\1szy kr\2o\1tki opis Running Systemu dla \ nowego \ Loglanu \ opiera\r
+\-\r
+\+\r
+si\2e \ \1w \ du\2x\1ym \ stopniu \ na \ poprzednich \ dokumentacjach. \ \ Przede\r
+\-\r
+\+\r
+wszystkim na opisie Running \ Systemu \ Loglanu-82 \ oraz \ na \ dw\2o\1ch\r
+\-\r
+\+\r
+pracach opublikowanych, \ tj. \ G.Cioni, \ "Programmed \ deallocation\r
+\-\r
+\+\r
+without \ dangling \ reference" \ IPL \ 18(1984) \ pp.179-187, \ \ oraz\r
+\-\r
+\+\r
+M.Krause, \ A.Kreczmar, \ H.Langmaack, \ A.Salwicki, \ M.Warpechowski\r
+\-\r
+\+\r
+"Algebraic approach to ...." w Lecture Notes in Computer \ Science\r
+\-\r
+\+\r
+Springer 208, pp.134-156. W pierwszej z tych prac \ opisano \ system\r
+\-\r
+\+\r
+adresowania \ po\2s\1redniego \ dla \ Loglanu, \ \ a \ \ w \ \ drugiej \ \ dosy\2c\r
+\-\r
+\+\r
+\1skomplikowane \ algorytmy \ poprawiania \ \ tablicy \ \ Display \ \ oraz\r
+\-\r
+\+\r
+adresowania nielokalnego dla j\2e\1zyk\2o\1w z metodami dziedziczenia \ na\r
+\-\r
+\+\r
+r\2ox\1nych poziomach. Bez znajomo\2s\1ci \ tych \ dw\2o\1ch \ prac \ zrozumienie\r
+\-\r
+\+\r
+poni\2x\1szego kr\2o\1tkiego raportu jest niezwykle trudne. Radzimy \ wi\2e\1c\r
+\-\r
+\+\r
+przed przyst\2a\1pienie do czytania niniejszego tekstu zapozna\2c \ \1si\2e\r
+\-\r
+\+\r
+\1z tymi dwiema pracami, \ jak \ r\2o\1wnie\2x \ \1z \ dokumentacj\2a \ \1w \ dw\2o\1ch\r
+\-\r
+\+\r
+poprzednich jej postaciach (dla Loglanu-82 w \ pe\2l\1ni \ uruchominego\r
+\-\r
+\+\r
+i dla Loglanu-84 w pr\2o\1bnej wersji loglanowej). \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Nowy RS system dla nowego Loglanu \ zosta\2l \ \1napisany \ najpierw \ w\r
+\-\r
+\+\r
+Loglanie-82, \ a \ nast\2e\1pnie \ w \ j\2e\1zyku \ C. \ Wyb\2o\1r \ j\2e\1zyka \ C \ by\2l\r
+\-\r
+\+\r
+\1nieprzypadkowy. Ot\2ox \1w j\2e\1zyku tym mo\2x\1na wyrazi\2c \ \1wiele \ w\2l\1asno\2s\1ci\r
+\-\r
+\+\r
+niskopoziomowych, a posiada \ on \ tak\2x\1e \ wszystkie \ zalety \ j\2e\1zyka\r
+\-\r
+\+\r
+wysokopoziomowego. Przet\2l\1umaczenie wersji loglanowej na j\2e\1zyk C\r
+\-\r
+\+\r
+nie \ przedstawia\2l\1o \ wi\2e\1kszych \ trudno\2s\1ci, \ umo\2x\1liwi\2l\1o \ natomiast\r
+\-\r
+\+\r
+stworzenie bardzo efektywnego systemu \2l\1atwego do przenoszenia. \,\r
+\-\/\f\r
+\+\r
+RS system napisany \ w \ C \ daje \ mo\2x\1liwo\2sc \ \1wykonywania \ programu\r
+\-\r
+\+\r
+loglanowego przet\2l\1umaczonego na j\2e\1zyk C. Taki \ spos\2o\1b \ realizacji\r
+\-\r
+\+\r
+Loglanu \ wydaje \ mi \ si\2e \ \1najprostszy. \ Napisanie \ kompilatora \ z\r
+\-\r
+\+\r
+Loglanu na C jest \ znacznie \ \2l\1atwiejsze \ ni\2x \ \1napisanie \ pe\2l\1nego\r
+\-\r
+\+\r
+kompilatora \ na \ docelow\2a \ \1maszyn\2e\1. \ Problem \ przenoszenia \ jest\r
+\-\r
+\+\r
+rozwi\2a\1zany w spos\2o\1b natychmiastowy. Ponadto kompilator taki mo\2x\1e\r
+\-\r
+\+\r
+korzysta\2c \1z bogactwa konstrukcji j\2e\1zyka C. Nie b\2e\1dzie problemu ze\r
+\-\r
+\+\r
+sta\2l\1ymi, \ \ instrukcjami \ \ \ steruj\2a\1cymi \ \ \ w \ \ \ obr\2e\1bie \ \ \ modu\2l\1u,\r
+\-\r
+\+\r
+wej\2s\1ciem-wyj\2s\1ciem, \2l\1a\2n\1cuchami itp. \ Niezwykle \ upro\2s\1ci \ si\2e \ \1sam\r
+\-\r
+\+\r
+proces translacji. Wyra\2x\1enia mog\2a \1pozosta\2c \1w prawie niezmienionej\r
+\-\r
+\+\r
+postaci - jedynie dost\2e\1p do zmiennych loglanowych b\2e\1dzie wymaga\2l\r
+\-\r
+\+\r
+\1wywo\2l\1ywania specjalnych makro - ale proces \2l\1adowania \ rejestr\2o\1w,\r
+\-\r
+\+\r
+optymalizacji lokalnej itd. przerzucony zostanie na system \ C.\r
+\-\r
+\+\r
+A \ przecie\2x \ \1jest \ to \ system \ niezwykle \ \ efektywny. \ \ Wi\2e\1kszo\2sc\r
+\-\r
+\+\r
+\1kompilator\2o\1w C daje kod \ dobrze \ zoptymalizowany. \ W \ ten \ prosty\r
+\-\r
+\+\r
+spos\2o\1b mo\2x\1emy wykorzysta\2c \1si\2le \1tego j\2e\1zyka \ zostawiaj\2a\1c \ troski\r
+\-\r
+\+\r
+techniczne \ \ \ (rejestry, \ \ \ arytmetyka \ \ \ maszyny, \ \ \ \ etykiety,\r
+\-\r
+\+\r
+optymalizacja) systemowi C. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Opisany poni\2x\1ej system sk\2l\1ada si\2e \1z dwu \ plik\2o\1w \ : \ Rs.c \ oraz\r
+\-\r
+\+\r
+Rsdata.h. Plik Rsdata.h jest \ tzw. \ plikiem \ nag\2lo\1wkowym \ (header\r
+\-\r
+\+\r
+file). W nim wyra\2x\1ono wszystkie wsp\2o\1lne struktury \ danych \ oraz\r
+\-\r
+\+\r
+podstawowe zmienne. Na pliku Rs.c znajduje \ si\2e \ \1natomiast \ pe\2l\1na\r
+\-\r
+\+\r
+biblioteka \ \ Running \ \ Systemu. \ \ Tekst \ \ programu \ \ \ loglanowego\r
+\-\r
+\+\r
+przet\2l\1umaczony na C musi w\2la\1cza\2c \1za pomoc\2a \1instrukcji \ include\r
+\-\r
+\+\r
+plik Rsdata.h. W taki sam spos\2o\1b w\2la\1czany \ jest \ ten \ plik \ przez\r
+\-\r
+\+\r
+Rs.c. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\+\r
+ Edmonton, Maj 1988\r
+\-\r
+\+\r
+\+\r
+ Warszawa, Sierpie\2n \11988\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+2. Opis struktur danych na pliku Rsdata.h\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Na pliku \ tym \ znajduj\2a \ \1si\2e \ \1deklaracje \ struktury \ prototyp\2o\1w \ i\r
+\-\r
+\+\r
+offset\2o\1w. Zajmiemy \ si\2e \ \1najpierw \ struktur\2a \ \ \1prototypu. \ \ Ma \ \ on\r
+\-\r
+\+\r
+nast\2e\1puj\2a\1c\2a \1posta\2c\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\4struct \3Prototype\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3kind\1;\r
+\-\r
+\+\r
+\ \4int \3num\1;\r
+\-\r
+\+\r
+\ \4int \3lspan\1, \3rspan\1;\r
+\-\r
+\+\r
+\ \4int \3references\1;\r
+\-\r
+\+\r
+\ \4int \3decl\1, \3level\1;\r
+\-\r
+\+\r
+\ \4int \3lastwill\1;\r
+\-\r
+\+\r
+\ \4int \3permadd\1;\r
+\-\r
+\+\r
+\ \4int \3Sloffset\1, \3Dloffset\1;\r
+\-\r
+\+\r
+\ \4int \3Statoffset\1, \3Lscoffset\1;\r
+\-\r
+\+\r
+\ \4int \3handlist\1;\r
+\-\r
+\+\r
+\ \4int \3pref\1, \3pslength\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3kind \1definiuje rodzaj \ prototypu. \ Mamy \ nast\2e\1puj\2a\1ce \ ich\r
+\-\r
+\+\r
+rodzaje: CLASS, SUBROUTINE, PROCESS, COROUTINE, HANDLER, \ RECORD,\r
+\-\r
+\+\r
+PRIMITARRAY, REFARRAY, SUBARRAY, STRUCTARRAY, POINTARRAY. \ Pi\2ec\r
+\-\r
+\+\r
+\1pierwszych nie wymaga wyja\2s\1nie\2n\1. RECORD jest klas\2a \1bez kodu i bez\r
+\-\r
+\+\r
+innych modu\2lo\1w zadeklarowanych \ wewn\2a\1trz. \ Ten \ rodzaj \ prototypu\r
+\-\r
+\+\r
+istnia\2l \1ju\2x \1w poprzedniej wersji Running Systemu. Ostanich pi\2ec\r
+\-\r
+\+\r
+\1rodzaj\2o\1w dotyczy tablic. PRIMITARRAY jest tablic\2a \ \1o \ elementach\r
+\-\r
+\+\r
+typu pierwotnego, \ REFARRAY \ jest \ tablic\2a \ \1typu \ referencyjnego,\r
+\-\r
+\+\r
+SUBARRAY jest tablic\2a\1, kt\2o\1rej elementami s\2a \1domkni\2e\1cia \ procedur,\r
+\-\r
+\+\r
+STRUCTARRAY jest tablic\2a \1o elementach typu z\2l\1o\2x\1onego \ i \ wreszcie\r
+\-\r
+\+\r
+POINTARRAY \ jest \ tablic\2a \ \1typu \ \ referencyjnego, \ \ jednak\2x\1e \ \ o\r
+\-\r
+\+\r
+elementach daj\2a\1cych adresy po\2s\1rednie bez licznik\2o\1w. \ Taki \ typ\r
+\-\r
+\+\r
+dodatkowy wprowadzili\2s\1my w nowej wersji \ RS \ w \ celu \ osi\2a\1gni\2e\1cia\r
+\-\r
+\+\r
+wi\2e\1kszej efektywno\2s\1ci kodu. Zamiast \ pe\2l\1nego \ adresu \ wirtualnego\r
+\-\r
+\+\r
+[adres po\2s\1redni, licznik] niekt\2o\1re referencje s\2a \ \1postaci \ [adres\r
+\-\r
+\+\r
+po\2s\1redni]. \ Nie \ daj\2a \ \1one \ oczywi\2s\1cie \ gwarancji \ \ poprawno\2s\1ci\r
+\-\r
+\+\r
+adresowania \ (mo\2x\1e \ wyst\2a\1pi\2c \ \1tzw. \ nieokre\2s\1lona \ \ referencja),\r
+\-\/\f\r
+\+\r
+nimniej, \ je\2s\1li \ u\2x\1ytkownik \ jest \ pewny \ \ poprawno\2s\1ci \ \ swoich\r
+\-\r
+\+\r
+adresowa\2n\1, mo\2x\1e cz\2esc \1lub \ wszystkie \ referencje \ zaznaczy\2c \ \1jako\r
+\-\r
+\+\r
+proste. Poniewa\2x \1typy \ tablicowe \ s\2a \ \1rozr\2ox\1niane \ przez \ atrybut\r
+\-\r
+\+\r
+\3kind, \1w\2s\1r\2o\1d rodzaj\2o\1w typ\2o\1w pojawi\2l \1si\2e \1tak\2x\1e typ POINTERARRAY. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Drugim atrybutem prototypu jest \3num\1. Wskazuje on \ pozycj\2e \ \1danego\r
+\-\r
+\+\r
+prototypu w tablicy PROT [] definiuj\2a\1cej wszystkie prototypy. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybuty \3lspan \1i \3rspan \1definiuj\2a \ \1rozmiar \ obiektu \ danego \ typu.\r
+\-\r
+\+\r
+Wszystkie obiekty alokowane \ s\2a \ \1w \ tablicy \ M[ \ ]. \ Maj\2a\1c \ adres\r
+\-\r
+\+\r
+obiektu \3am \1na lewo mamy rozmiar \ \3lspan\1, \ na \ prawo \ \3rspan\1, \ czyli\r
+\-\r
+\+\r
+obiekt \ zajmuje \ elementy \ tablicy \ M[\3am-lspan\1..\3am\1+\3rspan\1]. \ Adres\r
+\-\r
+\+\r
+prototypu usytuowany jest zawsze w s\2l\1owie M[\3am\1], tzn. maj\2a\1c adres\r
+\-\r
+\+\r
+obiektu na zmiennej \3am\1, w\2l\1a\2s\1nie M[\3am\1] = \ \3num \ \1, \ gdzie \ \3num \ \1jest\r
+\-\r
+\+\r
+adresem prototypu tego \ obiektu \ w \ tablicy \ PROT. \ Tablice \ maj\2a\r
+\-\r
+\+\r
+\1rozmiar definiowany dynamicznie. W s\2l\1owie \ M[\3am\1] \ jest \ zapisany\r
+\-\r
+\+\r
+stosowny \ numer \ prototypu, \ natomiast \ \ dwa \ \ kolejne \ \ s\2l\1owa\r
+\-\r
+\+\r
+definiuj\2a \1doln\2a \ \1i \ g\2o\1rn\2a \ \1granice \ wska\2z\1nika. \ Rozmiar \ elementu\r
+\-\r
+\+\r
+tablicy w przypadku PRIMITARRAY podawany jest za pomoc\2a \ \1atrybutu\r
+\-\r
+\+\r
+\3lspan\1. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Pozosta\2l\1e atrybuty nie s\2a \1konieczne w przypadku tablic.\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrubut \3references \1definiuje struktur\2e \1referencji prototypu. \ Jest\r
+\-\r
+\+\r
+to po prostu indeks w tablicy OFF[], kt\2o\1ra \ definiuje \ wszystkie\r
+\-\r
+\+\r
+rodzaje struktur referencji (patrz definicja OFF poni\2x\1ej). \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Atrybuty \3decl \1i \ \3level \ \1odnosz\2a \ \1si\2e \ \1do \ struktury \ zagnie\2x\1d\2x\1e\2n\r
+\-\r
+\+\r
+\1programu. Mianowicie \3decl \1jest indeksem w PROT \ ojca \ statycznego\r
+\-\r
+\+\r
+danego modu\2l\1u, natomiast \3level \1jest g\2le\1boko\2s\1ci\2a \1zagnie\2x\1d\2x\1enia. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3lastwill \1okre\2s\1la miejsce w module, od kt\2o\1rego rozpoczynaj\2a\r
+\-\r
+\+\r
+\1si\2e \1instrukcje lastwill. \ W \ jaki \ spos\2o\1b \ modeluje \ si\2e \ \1kontrol\2e\r
+\-\r
+\+\r
+\1sterowania podamy w punktach 4 i 10. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Nast\2e\1pny atrybut \3permadd \1jest wsp\2o\1lnym adresem dla \ permutacji \ i\r
+\-\r
+\+\r
+inwersji permutacji numer\2o\1w displaya. Mianowicie plik \ loglanowy\r
+\-\r
+\+\r
+definiuje dwie tablice \3perm\1[] i \3perminv\1[], kt\2o\1re \ musz\2a \ \1zawiera\2c\r
+\-\r
+\+\r
+\1te permutacji. \ Przyk\2l\1adowo, \ dla \ \3perm\1[] \ = \ {0,1,2,0,2,1} \ oraz\r
+\-\/\f\r
+\+\r
+\3perminv\1[] = {0,1,2,0,2,1}, indeks \3permadd\1=0 dla warto\2s\1ci \ \3level\1=2\r
+\-\r
+\+\r
+okre\2s\1la permutacj\2e \1{0,1,2} \ (i \ te \ sam\2a \ \1odwrotn\2a\1), \ natomiast\r
+\-\r
+\+\r
+\3permadd\1=2 dla \3level \1te\2x \1r\2o\1wnym 2 daje perm={0,2,1} \ (i \ podobnie\r
+\-\r
+\+\r
+te sam\2a \1odwrotn\2a\1}. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Cztery \ kolejne \ atrybuty \ \ (\3Sloffset\1, \ \ \3Dloffset\1, \ \ \3Statoffset\1,\r
+\-\r
+\+\r
+\3Lscoffset\1) definiuj\2a \1adresy wzgl\2e\1dne (offsety) czterech zmiennych\r
+\-\r
+\+\r
+systemowych Sl, Dl, Statsl i Lsc. Ka\2x\1dy \ modu\2l \ \1posiadaj\2a\1cy \ kod\r
+\-\r
+\+\r
+musi \ mie\2c \ \1okre\2s\1lon\2a \ \1pozycj\2e \ \1Sl \ ojca, \ Dl \ \ ojca, \ \ lokalnego\r
+\-\r
+\+\r
+sterowania Lsc i licznika Sl syn\2o\1w (Statsl). \ O \ tych \ zmiennych\r
+\-\r
+\+\r
+systemowych b\2e\1dziemy m\2o\1wi\2c \1za chwil\2e\1. Tutaj natomiast \ chcieli\2s\1my\r
+\-\r
+\+\r
+zwr\2o\1ci\2c \1uwag\2e \1na to, \2x\1e w poprzedniej \ wersji \ RS \ offsety \ tych\r
+\-\r
+\+\r
+zmiennych by\2l\1y podawane w prototypie (ich pozycja \ by\2l\1a \ ustalona\r
+\-\r
+\+\r
+na ko\2n\1cu obiektu). Wprowadzenie offset\2o\1w zmiennych systemowych do\r
+\-\r
+\+\r
+prototyp\2o\1w skomplikuje kompilacj\2e\1, ale przyspieszy i ujednorodni\r
+\-\r
+\+\r
+RS. Dost\2e\1p do tych zmiennych \ b\2e\1dzie \ bowiem \ taki \ sam \ jak \ do\r
+\-\r
+\+\r
+innych \ zmiennych \ wprowadzonych \ przez \ \ u\2x\1ytkownika \ \ czy \ \ te\2x\r
+\-\r
+\+\r
+\1kompilator. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3handlist \1definiuje list\2e \1handler\2o\1w zadeklarowanych w danym\r
+\-\r
+\+\r
+module. Jest to indeks w \ tablicy \ HL[], \ gdzie \ zdefiniowane \ s\2a\r
+\-\r
+\+\r
+\1wszystkie takie listy. \ Tablica \ HL \ jest \ typu \ Hlstelem \ postaci\r
+\-\r
+\+\r
+nast\2e\1puj\2a\1cej: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\4struct \3Hlstelem\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3hand\1;\r
+\-\r
+\+\r
+\ \4int \3signlist\1;\r
+\-\r
+\+\r
+\ \4int \3next\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3hand \1jest indeksem w tablicy \ PROT \ w\2l\1a\2s\1ciwego \ handlera.\r
+\-\r
+\+\r
+Natomiast atrybut \3signlist \ \1jest \ indeksem \ w \ tablicy \ SL[] \ typu\r
+\-\r
+\+\r
+\3Sgelem\1, \ gdzie \ okre\2s\1lone \ s\2a \ \1numery \ sygna\2lo\1w \ zwi\2a\1zane \ z \ \ tym\r
+\-\r
+\+\r
+handlerem. Typ \3Sgelem \1ma posta\2c \1nast\2e\1puj\2a\1c\2a\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\4struct \3Sgelem\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3signalnum\1;\r
+\-\r
+\+\r
+\ \4int \3next\r
+\-\r
+\+\r
+\1};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W ka\2x\1dym elemencie tablicy \ SL[] \ mamy \ numer \ sygna\2l\1u \ \3signalnum\1,\r
+\-\r
+\+\r
+kt\2o\1ry jest warto\2s\1ci\2a \1absolutn\2a \1budowan\2a \1przez kompilator. \ Atrybut\r
+\-\r
+\+\r
+\3next \1pokazuje na kolejny element takiej \ listy \ w \ SL[]. \ Podobnie\r
+\-\r
+\+\r
+zreszt\2a \1atrybut \3next \1w HL[] wskazuje na nast\2e\1pny handler \ zwi\2a\1zany\r
+\-\r
+\+\r
+z danym modu\2l\1em. Koniec ka\2x\1dej takiej listy \ (w \ obu \ przypadkach)\r
+\-\r
+\+\r
+okre\2s\1la warto\2sc \3next\1=-1 (tak wybrano z uwagi na \ adresowanie \ w \ C\r
+\-\r
+\+\r
+tablic od 0). \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3handlist \1wyst\2e\1puje tak\2x\1e w prototypie handlera. \ Okre\2s\1la\r
+\-\r
+\+\r
+on jedynie, \ czy \ handler \ ten \ odpowiada \ na \ wszystkie \ sygna\2l\1y\r
+\-\r
+\+\r
+(others), \ czy \ \ te\2x \ \ \1jest \ \ deklarowany \ \ jako \ \ handler \ \ dla\r
+\-\r
+\+\r
+wyspecyfikowanych \ numer\2o\1w \ sygna\2lo\1w. \ W \ \ pierwszym \ \ przypadku\r
+\-\r
+\+\r
+warto\2sc \ \1tego \ atrybutu \ jest \ 1 \ (hanlder \ dla \ \ others), \ \ w\r
+\-\r
+\+\r
+pozosta\2l\1ych przypadkach warto\2sc \1tego atrybutu jest 0. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Dwa ostatnie atrybuty w prototypie ( \ \3pref\1, \ \3pslength\1) \ okre\2s\1laj\2a\r
+\-\r
+\+\r
+\1struktur\2e \1prefiksowania. Nie musz\2a \1one \ wyst\2e\1powa\2c \ \1w \ przypadku\r
+\-\r
+\+\r
+prototyp\2o\1w dla handler\2o\1w, gdy\2x \1handler nie mo\2x\1e by\2c \1prefiksowany.\r
+\-\r
+\+\r
+Atrybut \3pref \1jest indeksem w tablicy PROT modu\2l\1u \ prefiksuj\2a\1cego\r
+\-\r
+\+\r
+(-1 gdy nie istnieje), \ atrybut \ \3pslength \ \1jest \ d\2l\1ugo\2s\1ci\2a \ \1ci\2a\1gu\r
+\-\r
+\+\r
+prefiksuj\2a\1cego. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Pozosta\2l\1a do \ om\2o\1wienia \ struktura \ referencji. \ Ot\2ox \ \1z \ powodu\r
+\-\r
+\+\r
+wprowadzenia bogactwa typ\2o\1w z\2l\1o\2x\1onych w nowym Loglanie, struktura\r
+\-\r
+\+\r
+referencji \ w \ obiektach \ jest \ stosunkowo \ skomplikowana. \ Takie\r
+\-\r
+\+\r
+struktury opisuje tablica OFF[] typu \3Offsets\1. \,\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\4struct \3Offsets\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3kind\1;\r
+\-\r
+\+\r
+\ \4int \3size\1, \3num\1;\r
+\-\r
+\+\r
+\ \4int \3length\1, \3finish\1;\r
+\-\r
+\+\r
+\ \4int \3head\1;\r
+\-\r
+\+\r
+\ \4int \3references\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Atrybut \3kind \1jest nast\2e\1puj\2a\1cych \ rodzaj\2o\1w: \ SIMPLELIST, \ SEGMENT,\r
+\-\r
+\+\r
+REPEATED \ oraz \ COMBINEDLIST. \ SIMPLELIST \ jest \ list\2a \ \ \1zwyk\2l\1ych\r
+\-\r
+\+\r
+offset\2o\1w \ zmiennych \ referencyjnych \ w \ obiekcie. \ SEGMENT \ jest\r
+\-\r
+\+\r
+szczeg\2o\1ln\2a \1postaci\2a \ \1takiej \ listy, \ gdy \ te \ offsety \ zajmuj\2a\r
+\-\r
+\+\r
+\1kolejne miejsca w pami\2e\1ci (ten typ wprowadzili\2s\1my \ ze \ wzgl\2e\1du\r
+\-\r
+\+\r
+na tablice referencyjne, jakkolwiek jest \ on \ sprowadzalny \ do\r
+\-\r
+\+\r
+przypadku poprzedniego). REPEATED jest \ n-krotn\2a \ \1iteracj\2a \ \1danej\r
+\-\r
+\+\r
+struktury referencyjnej. COMBINEDLIST jest list\2a \1by\2c \1mo\2x\1e r\2ox\1nych\r
+\-\r
+\+\r
+struktur referencji. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Atrybut \3size \1okre\2s\1la ca\2l\1kowit\2a \1d\2l\1ugo\2sc \1opisywanej \ struktury \ Dla\r
+\-\r
+\+\r
+SIMPLELIST musi to \ by\2c \ \1d\2l\1ugo\2sc \ \1ca\2l\1ego \ obiektu, \ dla \ SEGMENT\r
+\-\r
+\+\r
+r\2o\1wnie\2x \1d\2l\1ugo\2sc \1ca\2l\1ego obiektu, dla REPEATED musi to by\2c \ \1d\2l\1ugo\2sc\r
+\-\r
+\+\r
+\1powtarzanej struktury, i ostatecznie dla COMBINEDLIST ma to \ by\2c\r
+\-\r
+\+\r
+\1d\2l\1ugo\2sc \ \1struktury \ wewn\2a\1trz \ kt\2o\1rej \ podawane \ s\2a \ \1wska\2z\1niki \ \ do\r
+\-\r
+\+\r
+podstruktur. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Kolejny \ atrybut \ \3num \ \1definiuje \ indeks \ w \ tablicy \ \ OFF \ \ danej\r
+\-\r
+\+\r
+struktury.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Znaczenie atrybutu \3length \1jest \ wieloznaczne. \ Dla \ SIMPLELIST\r
+\-\r
+\+\r
+\3length \1jest d\2l\1ugo\2s\1ci\2a \1listy offset\2o\1w. Dla SEGMENT \ \3length \ \1jest\r
+\-\r
+\+\r
+pozycj\2a \1pierwszego,a \3finish \1ostatniego elementu \ segmentu. \ Dla\r
+\-\r
+\+\r
+REPEATED \3length \1jest \ krotno\2s\1ci\2a \ \1powt\2o\1rzenia \ podstruktury. \ Dla\r
+\-\r
+\+\r
+COMBINEDLIST \3length \1jest d\2l\1ugo\2s\1ci\2a \1listy. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Atrybut \3head \1jest indeksem w tablicy EL[], gdzie \ zakodowane \ s\2a\r
+\-\r
+\+\r
+\1listy struktur referencji. Typem tej tablicy jest \3Elem\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\/\f\r
+\+\r
+\4struct \3Elem\r
+\-\r
+\+\r
+\1{\r
+\-\r
+\+\r
+\ \4int \3offset\1;\r
+\-\r
+\+\r
+\ \4int \3next\1;\r
+\-\r
+\+\r
+\ \4int \3references\1;\r
+\-\r
+\+\r
+};\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W tablicy tej atrybut \3offset \1definiuje odpowiedni offset a \ \3next\r
+\-\r
+\+\r
+\1jest jak zwykle wska\2z\1nikiem do \ nast\2e\1pnego \ elementu \ listy. \ Dla\r
+\-\r
+\+\r
+typu SIMPLELIST ka\2x\1dy taki \ offset \ mo\2x\1e \ by\2c \ \1offsetem \ zmiennej\r
+\-\r
+\+\r
+referencyjnej pe\2l\1nej lub tylko adresem po\2s\1rednim, ale tak\2x\1e \ mo\2x\1e\r
+\-\r
+\+\r
+by\2c \1offsetem domkni\2e\1cia procedury (czyli pary <SL, adres kodu> ).\r
+\-\r
+\+\r
+Gdy atrybut \3references \1jest 0, mamy referencje pe\2l\1n\2a\1, gdy jest \ 1\r
+\-\r
+\+\r
+jest to adres po\2s\1redni, wreszcie gdy jest 2 \ jest \ to \ domkni\2e\1cie\r
+\-\r
+\+\r
+procedury. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dla typu COMBINEDLIST atrybut \3references \1okre\2s\1la indeks w tablicy\r
+\-\r
+\+\r
+OFF wskazywanej podstruktury referencji. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+W przypadku typu SEGMENT atrybut \ \3head \ \1mo\2x\1e \ jeszcze \ okre\2s\1la\2c\r
+\-\r
+\+\r
+\1rodzaj referencji. Gdy \3head \1= 0, mamy segment pe\2l\1nych referencji,\r
+\-\r
+\+\r
+gdy jest 1 jest to segment adres\2o\1w po\2s\1rednich, gdy jest 2 jest to\r
+\-\r
+\+\r
+segment domkni\2ec \1procedur.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dla ostatniego atrybutu \3references \1w \ typie \ \3Offsets \ \1mamy \ jedno\r
+\-\r
+\+\r
+zadanie. Powinien on okre\2s\1la\2c \1dla typu REPEATED indeks w \ tablicy\r
+\-\r
+\+\r
+OFF powtarzanej struktury. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Powy\2x\1szy system wprowadzania \ struktury \ prototyp\2o\1w \ jest \ dosy\2c\r
+\-\r
+\+\r
+\1niezr\2e\1czny, je\2s\1li musi by\2c \1wykonany r\2e\1cznie. Troch\2e \1w \ tym \ wina\r
+\-\r
+\+\r
+j\2e\1zyka C. Mo\2x\1na by\2l\1o \ wprowadzi\2c \ \1typ \ union, \ kt\2o\1ry \ przypomina\r
+\-\r
+\+\r
+rekordy z \ wariantami, \ ale \ w\2o\1wczas \ nie \ mo\2x\1naby \ podawa\2c \ \1tych\r
+\-\r
+\+\r
+struktur przez definicje w deklaracji (odp. DATA \ w \ Fortranie).\r
+\-\r
+\+\r
+Zatem przyj\2al\1em \ takie \ rozwi\2a\1zanie \ przez \ zwyk\2la \ \1struktur\2e\1. \ Z\r
+\-\r
+\+\r
+drugiej strony translator z Loglanu na C mo\2x\1e bez k\2l\1opotu budowa\2c\r
+\-\r
+\+\r
+\1tak\2a \1struktur\2e\1. \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+3. Struktury Dl i Sl\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Struktura Dl zachowana jest taka \ jak \ w \ Simuli \ i \ Loglanie-82.\r
+\-\r
+\+\r
+Aktywny wsp\2ol\1program jest \2l\1a\2n\1cuchem Dl, zawieszony jest \ cyklem\r
+\-\r
+\+\r
+Dl. \ Nowy \ Loglan \ usun\2al \ \ \1Detach, \ \ gdy\2x \ \ \1wprowadzi\2l \ \ \1zmienn\2a\r
+\-\r
+\+\r
+\1LAST_ATTACH - \ wskazuj\2a\1c\2a \ \1na \ ostatni \ wsp\2ol\1program \ wykonuj\2a\1cy\r
+\-\r
+\+\r
+Attach(X). Zako\2n\1czenie wsp\2ol\1programu \ jest \ sygnalizowane \ b\2le\1dem\r
+\-\r
+\+\r
+(propozycja \ \ \ \ Marka \ \ \ \ Warpechowskiego). \ \ \ \ Wykonuje \ \ \ \ \ si\2e\r
+\-\r
+\+\r
+\1Attach(LAST_ATTACH) with Cor_Term (coroutine terminated), \ o \ ile\r
+\-\r
+\+\r
+LAST_ATTACH \ =/= \ \4none\1, \ w \ \ przeciwnym \ \ razie \ \ wykonuje \ \ si\2e\r
+\-\r
+\+\r
+\1Attach(My_Process) \ \ with \ \ Cor_Term. \ \ To \ \ \ rozwi\2a\1zanie \ \ \ jest\r
+\-\r
+\+\r
+metodologicznie uzasadnione i najprostsze. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dla \ wsp\2ol\1programu \ aktywnego \ warto\2sc \ \1Dl \ jest \ \ \4none\1. \ \ Pr\2o\1ba\r
+\-\r
+\+\r
+reaktywacji wsp\2ol\1programu aktywnego \ powoduje \ wys\2l\1anie \ sygna\2l\1u\r
+\-\r
+\+\r
+alarmowego. \ Wsp\2ol\1program \ \ zako\2n\1czony \ \ ma \ \ ustawion\2a \ \ \1warto\2sc\r
+\-\r
+\+\r
+\1lokalnego sterowania Lsc na 0. \ Pr\2o\1ba \ reaktywacji \ zako\2n\1czonego\r
+\-\r
+\+\r
+wsp\2ol\1programu powoduje wys\2l\1anie sygna\2l\1u. Zauwa\2x\1my na \ zako\2n\1czenie\r
+\-\r
+\+\r
+omawiania struktury Dl, \ \2x\1e \ Dl-link \ mo\2x\1e \ by\2c \ \1w \ tym \ systemie\r
+\-\r
+\+\r
+referencj\2a \1niepe\2l\1n\2a \1(tzn. tylko adresem po\2s\1rednim). \ Zyskujemy\r
+\-\r
+\+\r
+w ten spos\2o\1b na pami\2e\1ci i na czasie wykonania programu. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Struktura Sl link\2o\1w \ tworzy \ drzewo. Problemem s\2a \ \1tylko \ usuwane\r
+\-\r
+\+\r
+obiekty procedur, \ funkcji \ i \ blok\2o\1w, \ po \ ich \ terminacji. \ W\r
+\-\r
+\+\r
+poprzedniej \ wersji \ przyj\2e\1li\2s\1my \ \ strategi\2e \ \ \1usuwania \ \ takich\r
+\-\r
+\+\r
+obiekt\2o\1w bez wzgl\2e\1du na konsekwencje. Mog\2l\1o si\2e \ \1zdarzy\2c\1, \ \2x\1e \ po\r
+\-\r
+\+\r
+pewnym \ czasie \ wznawiany \ dobrze \ \ okre\2s\1lony \ \ obiekt \ \ nie \ \ ma\r
+\-\r
+\+\r
+okre\2s\1lonego otoczenia statycznego (Sl link przeci\2e\1ty). \ Umieli\2s\1my\r
+\-\r
+\+\r
+wykry\2c \1takie przypadki, ale nie by\2l\1o to \ rozwi\2a\1zanie \ eleganckie.\r
+\-\r
+\+\r
+Marek Lao \ zauwa\2x\1y\2l\1, \ \2x\1e \ lepiej \ by\2l\1oby \ u\2x\1y\2c \ \1zwyk\2l\1ej \ techniki\r
+\-\r
+\+\r
+licznik\2o\1w referencji tylko \ dla \ tego \ przypadku. \ Mamy \ przecie\2x\r
+\-\r
+\+\r
+\1licznik Statsl (poprzednio inaczej okre\2s\1lony), nale\2x\1y zastosowa\2c\r
+\-\r
+\+\r
+\1go w spos\2o\1b nast\2e\1puj\2a\1cy. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Ka\2x\1de otwarcie nowego obiektu zwi\2e\1ksza o 1 \ licznik \ Statsl \ jego\r
+\-\r
+\+\r
+statycznego ojca. Ka\2x\1de zako\2n\1czenie obiektu \ procedury \ (funkcji,\r
+\-\r
+\+\r
+bloku) sprawdza, czy jego Statsl jest 0. Je\2s\1li tak, obiekt \ mo\2x\1na\r
+\-\r
+\+\r
+usun\2ac\1, zmniejszy\2c \1Statsl o \ 1 \ dla \ jego \ ojca \ i \ powt\2o\1rzy\2c \ \1te\r
+\-\/\f\r
+\+\r
+operacje dla takiego \ ojca \ (o \ ile \ jest \ to \ obiekt \ procedury,\r
+\-\r
+\+\r
+funkcji lub bloku). Dla usuwanego za pomoc\2a \1kill \ obiektu \ klasy,\r
+\-\r
+\+\r
+sprawdzamy \ najpierw \ jego \ Statsl, \ \ i \ \ post\2e\1pujemy \ \ podobnie.\r
+\-\r
+\+\r
+Pozostaje rozwi\2a\1za\2c \1poprawnie problem usuwania wsp\2ol\1program\2o\1w. \,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Zabicie zawieszonego wsp\2ol\1programu polega na \ zabiciu \ stosownego\r
+\-\r
+\+\r
+cyklu Dl. Najpierw przegl\2a\1damy taki cykl i sprawdzamy, \ czy \ jego\r
+\-\r
+\+\r
+wszystkie obiekty maj\2a \1Statsl \ r\2o\1wny \ 0. \ Je\2s\1li \ nie, \ wywo\2l\1ujemy\r
+\-\r
+\+\r
+sygna\2l \1alarmowy. Je\2s\1li natomiast wszystkie \ s\2a \ \1usuwalne, \ mo\2x\1emy\r
+\-\r
+\+\r
+przyst\2a\1pi\2c \1do kolejnego ich usuwania. Aby \ to \ zrobi\2c \ \1poprawnie,\r
+\-\r
+\+\r
+nale\2x\1a\2l\1oby stosowa\2c \1operacj\2e \1przej\2s\1cia po Sl-\2l\1a\2n\1cuchu dla ka\2x\1dego\r
+\-\r
+\+\r
+obiektu usuni\2e\1tego (tak jak \ dla \ obiektu \ klasy). \ Ale \ przecie\2x\r
+\-\r
+\+\r
+\1mogliby\2s\1my usun\2ac \1jaki\2s \1obiekt jeszcze \ nieusuni\2e\1ty \ z \ usuwanego\r
+\-\r
+\+\r
+w\2l\1a\2s\1nie cyklu wsp\2ol\1programu. Aby unikn\2ac \1tej sytuacji, \ odwracamy\r
+\-\r
+\+\r
+najpierw \ cykl \ wsp\2ol\1programu. \ Zabijaj\2a\1c \ obiekty \ w \ kolejno\2s\1ci\r
+\-\r
+\+\r
+odwrotnej (od g\2l\1owy wsp\2ol\1programu, nast\2e\1pnie syn dynamiczny itd),\r
+\-\r
+\+\r
+mamy pewno\2sc\1, \ \2x\1e \ nie \ usuniemy \ przy \ czyszczeniu \ kolejnych\r
+\-\r
+\+\r
+\2l\1a\2n\1cuch\2o\1w Sl \2x\1adnego pozosta\2l\1ego elementu \ cyklu. \ Wynika \ to \ z\r
+\-\r
+\+\r
+w\2l\1asno\2s\1ci Sl \ i \ Dl \ \2l\1a\2n\1cuch\2o\1w \ - \ nie \ mog\2a \ \1i\2sc \ \1w \ przeciwnych\r
+\-\r
+\+\r
+kierunkach, tzn. je\2s\1li jest Dl droga od A do B to nie ma Sl drogi\r
+\-\r
+\+\r
+od B do A. \ W \ drugiej \ fazie \ usuwania \ wsp\2ol\1programu \ zmieniamy\r
+\-\r
+\+\r
+orientacj\2e \1cyklu. W trzeciej, ju\2x \1bezpiecznie mo\2x\1emy usun\2ac \ \1ca\2l\1y\r
+\-\r
+\+\r
+cykl \ czyszcz\2a\1c \ po \ \ drodze \ \ \2l\1a\2n\1cuchy \ \ Sl. \ \ W \ \ ten \ \ spos\2o\1b\r
+\-\r
+\+\r
+rozwi\2a\1zali\2s\1my, \ chyba \ dostatecznie \ \ poprawnie \ \ i \ \ elegancko,\r
+\-\r
+\+\r
+problemy czyszczenia pami\2e\1ci w Loglanie. Ponadto taka \ struktura\r
+\-\r
+\+\r
+Sl pozwala \ na \ zast\2a\1pi\2e\1nie \ pe\2l\1nych \ referencji \ dla \ Sl \ link\2o\1w\r
+\-\r
+\+\r
+adresami po\2s\1rednimi (tak jak to \ mia\2l\1o \ miejsce \ w \ przypadku \ Dl\r
+\-\r
+\+\r
+link\2o\1w). Zawsze bowiem warto\2sc \1Sl jest \ dobrze \ okre\2s\1lona \ i \ nie\r
+\-\r
+\+\r
+wymaga sprawdzenia, tak jak to mia\2l\1o miejsce w \ starym \ Loglanie,\r
+\-\r
+\+\r
+tzn. czy okre\2s\1la jeszcze istniej\2a\1cy obiekt. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Zmiana warto\2s\1ci atrybutu Statsl dotyczy \ tak\2x\1e \ u\2x\1ycia \ zmiennych\r
+\-\r
+\+\r
+podprogramowych. Warto\2s\1ci\2a \1takiej \ zmiennej \ podprogramowej \ jest\r
+\-\r
+\+\r
+domkni\2e\1cie procedury (<SL,adres kodu>). Poniewa\2x \1j\2e\1zyk w \ obecnej\r
+\-\r
+\+\r
+postaci dopuszcza operowanie na zmiennych podprogramowych, system\r
+\-\r
+\+\r
+musi dba\2c \1o to, by nieopatrznie nie usuwa\2c \1otoczenia \ statycznego\r
+\-\r
+\+\r
+dla dost\2e\1pnego domkni\2e\1cia procedury, \ albowiem \ takie \ domkni\2e\1cie\r
+\-\r
+\+\r
+mo\2x\1e by\2c \1w ka\2x\1dej chwili u\2x\1yte. Jak wi\2e\1c post\2e\1pujemy. Traktujemy\r
+\-\r
+\+\r
+domkni\2e\1cia \ \ procedur \ \ jako \ \ specjalne \ \ zmienne \ \ referencyjne\r
+\-\r
+\+\r
+(przypominam, \ \2x\1e \ odpowiednie \ SL \ linki \ \ mog\2a \ \ \1by\2c \ \ \1adresami\r
+\-\r
+\+\r
+kr\2o\1tkimi). Dla tych specjalnych \ referencji \ stosujemy \ strategi\2e\r
+\-\r
+\+\r
+\1reference counter, czyli ka\2x\1de \ podstawienie \ wymaga \ poprawienia\r
+\-\r
+\+\r
+odpowiednich \ Statsl. \ Przy \ usuwaniu \ \ obiektu \ \ nale\2x\1y \ \ jednak\r
+\-\/\f\r
+\+\r
+wszystkie takie zmienne przejrze\2c \1i \ tak\2x\1e \ poprawi\2c \ \1odpowiednie\r
+\-\r
+\+\r
+Statsl. Ca\2l\1o\2sc \1jest bardzo prosta, wymaga jednak wyr\2ox\1nienia tych\r
+\-\r
+\+\r
+referencji, co zosta\2l\1o zrobione w\2l\1a\2s\1nie w strukturze OFF.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+4. Struktura sterowania lokalnego\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Sterowanie lokalne w j\2e\1zyku C jest bardzo podobne \ do \ sterowania\r
+\-\r
+\+\r
+lokalnego w Loglanie. Wszystkie p\2e\1tle \ loglanowe \ mo\2x\1na \ zast\2a\1pi\2c\r
+\-\r
+\+\r
+\1przez ich \ odpowiedniki \ w \ j\2e\1zyku \ C. \ Podobnie \ z \ instrukcjami\r
+\-\r
+\+\r
+warunkowymi i instrukcjami wyboru. Problem techniczny powstaje w\r
+\-\r
+\+\r
+momencie przekazywanie sterowania pomi\2e\1dzy modu\2l\1ami \ Loglanowymi,\r
+\-\r
+\+\r
+poniewa\2x \1ka\2x\1de takie przekazanie sterowania zawiesza \ wykonywanie\r
+\-\r
+\+\r
+instrukcji modu\2l\1u aktywnego. Jak z tym \ problemem \ upora\2c \ \1si\2e \ \1w\r
+\-\r
+\+\r
+j\2e\1zyku C. Modu\2l \1loglanowy przet\2l\1umaczony na odpowiedni modu\2l \1C ma\r
+\-\r
+\+\r
+jako pierwsz\2a \1instrukcj\2e \1wygenerowan\2a \1przez kompilator instrukcj\2e\r
+\-\r
+\+\r
+\1wyboru: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ \4switch \1(IC)\r
+\-\r
+\+\r
+ {\r
+\-\r
+\+\r
+ \4case \11: \4goto \1L1; \4break\1;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ ...\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ \4case \1n: \4goto \1Ln; \4break\1;\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+gdzie IC jest wsp\2o\1ln\2a \ \1zmienn\2a \ \1globaln\2a \ \1zadeklarowan\2a \ \1w \ pliku\r
+\-\r
+\+\r
+Rsdata.h oraz etykiety L1,...,Ln definiuj\2a \1r\2ox\1ne \ punkty \ wej\2s\1cia\r
+\-\r
+\+\r
+do modu\2l\1u. Ka\2x\1de \ przekazanie \ sterowania \ do \ innego \ modu\2l\1u \ za\r
+\-\r
+\+\r
+pomoc\2a \1procedur systemowych RS \ (np. \ Go, \ Attach, \ itp.) \ wymaga\r
+\-\r
+\+\r
+prawid\2l\1owego okre\2s\1lenia warto\2s\1ci \ IC, \ kt\2o\1ra \ jest \ zapami\2e\1tywana\r
+\-\r
+\+\r
+przez RS w \ odpowiedniej \ lokacji \ obiektu \ (Lsc). \ Na \ przyk\2l\1ad,\r
+\-\r
+\+\r
+wywo\2l\1anie procedury loglanowej ma posta\2c\1: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ IC=m; Go(..);\r
+\-\r
+\+\r
+Lm: ...;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Przy ponownym wywo\2l\1aniu tego modu\2l\1u, na \ przyk\2l\1ad \ po \ powrocie \ z\r
+\-\r
+\+\r
+wywo\2l\1anej \ procedury, \ odtworzona \ warto\2sc \ \1IC \ \ pozwala \ \ Running\r
+\-\/\f\r
+\+\r
+Systemowi trafi\2c \1w poprawne miejsce modu\2l\1u, a wi\2e\1c w instrukcje po\r
+\-\r
+\+\r
+wywo\2l\1aniu Go(...). \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Pierwsze wej\2s\1cie do modu\2l\1u okre\2s\1la warto\2sc \1IC=1, zatem etykieta L1\r
+\-\r
+\+\r
+musi \ wyst\2a\1pi\2c \ \1przed \ pierwsz\2a \ \1przet\2l\1umaczon\2a \ \1na \ C \ instrukcj\2a\r
+\-\r
+\+\r
+\1loglanow\2a\1. \,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Jak ju\2x \1powiedzieli\2s\1my, ka\2x\1dy modu\2l \1loglanowy ma sw\2o\1j \ odpowiedni\r
+\-\r
+\+\r
+modu\2l \1w j\2e\1zyku C. Poniewa\2x \1chcemy przekazywa\2c \1sterowanie pomi\2e\1dzy\r
+\-\r
+\+\r
+takimi modu\2l\1ami w C, wraz z tekstami modu\2lo\1w przet\2l\1umaczony tekst\r
+\-\r
+\+\r
+musi mie\2c \1zdefiniowan\2a \1tablic\2e\1: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ \4int \1(* module []) () ;\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Ka\2x\1da pozycja \ w \ tej \ tablicy \ musi \ okre\2s\1la\2c \ \1modu\2l\1, \ zgodnie \ z\r
+\-\r
+\+\r
+porz\2a\1dkiem zadanym przez tablic\2e \1PROT. Ca\2l\1y program \ ko\2n\1czy \ modu\2l\r
+\-\r
+\+\r
+\1main(), gdzie warto\2s\1ci tej tablicy musz\2a \1by\2c \1tak w\2l\1a\2s\1nie okre\2s\1lone\r
+\-\r
+\+\r
+i \ gdzie \ przekazuje \ si\2e \ \1sterowanie \ do \ \ loglanowego \ \ programu\r
+\-\r
+\+\r
+g\2lo\1wnego: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+main ()\r
+\-\r
+\+\r
+{\r
+\-\r
+\+\r
+ module[0]=A1;\r
+\-\r
+\+\r
+ ...\r
+\-\r
+\+\r
+ module[k]=Ak;\r
+\-\r
+\+\r
+ Init();\r
+\-\r
+\+\r
+ IC=1;\r
+\-\r
+\+\r
+ ...\,\r
+\-\r
+\+\r
+}\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W \ powy\2x\1szym \ tek\2s\1cie \ A1,...,Ak \ s\2a \ \ \1nazwami \ \ modu\2lo\1w, \ \ kt\2o\1re\r
+\-\r
+\+\r
+wprowadzi\2l \1translator i okre\2s\1laj\2a \1one \ odpowiednie \ modu\2l\1y \ w \ C.\r
+\-\r
+\+\r
+Instrukcja Init() inicjalizuje struktury danych Running \ Systemu.\r
+\-\r
+\+\r
+Potem IC okre\2s\1lamy na 1 i \ przekazujemy \ sterowanie \ do \ programu\r
+\-\r
+\+\r
+loglanowego \ ( \ przekazywanie \ \ sterowania \ \ pomi\2e\1dzy \ \ modu\2l\1ami\r
+\-\r
+\+\r
+zostanie porzedstawione w rozdziale 7). \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W podobny spos\2o\1b definiuje si\2e \1etykiet\2e \3lastwill \1w module. Atrybut\r
+\-\r
+\+\r
+\3lastwill \1w prototypie musi \ okre\2s\1la\2c \ \1tak\2a \ \1warto\2sc \ \1zmiennej \ IC,\r
+\-\r
+\+\r
+kt\2o\1ra przeka\2x\1e sterowanie w odpowiednie miejsce modu\2l\1u. \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+5. Adresowanie\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Plik \ Rsdata.h \ dostarcza \ \ odpowiednich \ \ macro \ \ s\2l\1u\2xa\1cych \ \ do\r
+\-\r
+\+\r
+adresowania zmiennych loglanowych. \ Macro \ Address(\3dnum\1,\3off\1) \ daje\r
+\-\r
+\+\r
+adres zmiennej o numerze displaya \3dnum \1i offsecie \ \3off\1. \ Wykonanie\r
+\-\r
+\+\r
+zatem instrukcji podstawienia: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ i:=j+k\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+dla \ zmiennych \ integer \ \ o \ \ adresach \ \ (\3dnum\1,\3off\1) \ \ odpowiednio\r
+\-\r
+\+\r
+(1,2),(2,3) oraz (1,4) t\2l\1umaczymy nast\2e\1puj\2a\1co: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ *Address(1,2)= *Address(2,3) + *Address(1,4);\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Plik Rsdata.h daje \ tak\2x\1e \ dwa \ dodatkowe \ macra \ dla \ adresowania\r
+\-\r
+\+\r
+lokalnego i globalnego. Local(\3off\1) daje adres w obiekcie \ aktywnym\r
+\-\r
+\+\r
+o \ offsecie \ \3off\1, \ Global(\3off\1) \ daje \ adres \ w \ obiekcie \ programu\r
+\-\r
+\+\r
+g\2lo\1wnego o offsecie \3off\1. Instrukcj\2e\1:\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ i:=i-j\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+gdzie i jest zmienn\2a \1globaln\2a \1o offsecie \ 5, \ a \ j \ jest \ zmienn\2a\r
+\-\r
+\+\r
+\1lokaln\2a \1o offsecie 2 t\2l\1umaczymy nast\2e\1puj\2a\1co: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ *Global(5) -= *Local(2);\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Wykonywanie operacji arytmetycznych na innym \ typie \ ni\2x \ \1integer\r
+\-\r
+\+\r
+wymaga \ zastosowania \ zmiany \ typu \ (cast). \ Nie \ wiem \ \ jak \ \ w\r
+\-\r
+\+\r
+przysz\2l\1o\2s\1ci post\2a\1pi kompilator z typami pierwotnymi \ r\2ox\1nymi \ od\r
+\-\r
+\+\r
+typu integer, niemniej dla typu real mo\2x\1emy \ w \ spos\2o\1b \ naturalny\r
+\-\r
+\+\r
+dokona\2c \1zmiany kwalifikacji. Plik Rsdata.h zawiera \ odpowiednie\r
+\-\r
+\+\r
+makra \ Fladdress, \ Fllocal \ i \ Flglobal, \ \ kt\2o\1re \ \ automatycznie\r
+\-\r
+\+\r
+dokonuj\2a \1konwersji typu integer na real. Zatem instrukcj\2e\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ x:=x+y\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+dla zmiennych typu real o \ adresach \ odpowiednio \ (2,3) \ i \ (1,4),\r
+\-\r
+\+\r
+t\2l\1umaczymy nast\2e\1puj\2a\1co: \,\r
+\-\/\f\r
+\+\r
+\r
+\-\r
+\+\r
+ *Fladdress(2,3) += *Fladdress(1,4);\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Poza \ optymalizacj\2a \ \1adresowania \ \ polegaj\2a\1c\2a \ \ \1na \ \ wywo\2l\1ywaniu\r
+\-\r
+\+\r
+uproszczonych macro (Global i \ Local), \ kompilator \ Loglanu \ mo\2x\1e\r
+\-\r
+\+\r
+stosowa\2c \1zmienne lokalne j\2e\1zyka C. \ Dotyczy \ to \ w \ szczeg\2o\1lno\2s\1ci\r
+\-\r
+\+\r
+zmiennych steruj\2a\1cych p\2e\1tlami, ale tak\2x\1e wielu \ innych \ sytuacji.\r
+\-\r
+\+\r
+(Poniewa\2x \ \1zaproponowana \ tutaj \ wersja \ kompilatora \ nie \ wymaga\r
+\-\r
+\+\r
+generowania \ \ zmiennych \ \ roboczych, \ \ nie \ \ \ widz\2e \ \ \ \1mo\2x\1liwo\2s\1ci\r
+\-\r
+\+\r
+wykorzystania takiej techniki w obliczaniu wyra\2x\1e\2n\1.) \ Przyk\2l\1adowo\r
+\-\r
+\+\r
+w Loglanie p\2e\1tle: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ k:=0;\r
+\-\r
+\+\r
+ \4for \1i:=3 \4to \1n\r
+\-\r
+\+\r
+ \4do\r
+\-\r
+\+\r
+ if \1(p \4mod \1i)=0 \4then \1k:=1; \4exit fi\1;\r
+\-\r
+\+\r
+ \4od\1;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+mo\2x\1emy przet\2l\1umaczy\2c \1nast\2e\1puj\2a\1co (wiedz\2a\1c, \2x\1e k \ jest \ zmienn\2a\r
+\-\r
+\+\r
+\1o adresie (3,4), n jest zmienn\2a \1o adresie (0,1) i wreszcie p\r
+\-\r
+\+\r
+jest zmienn\2a \1o adresie (1,2)): \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ *Address(3,4)=0;\r
+\-\r
+\+\r
+ { \4int \1i;\r
+\-\r
+\+\r
+ \4for \1(i=3; i<= *Global(1); i++)\r
+\-\r
+\+\r
+ {\r
+\-\r
+\+\r
+ \4if \1( *Address(1,2) % i ==0) { *Address(3,4)=1; \4break\1;};\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+co oczywi\2s\1cie da znacznie lepszy kod ko\2n\1cowy, ni\2x \ \1wersja \ "czysto\r
+\-\r
+\+\r
+loglanowa": \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ *Address(3,4)=0;\r
+\-\r
+\+\r
+ *Local(2)=3; /* za\2lox\1my, \2x\1e i ma lokalny offset 2 */\r
+\-\r
+\+\r
+ \4while\1(1)\r
+\-\r
+\+\r
+ {\r
+\-\r
+\+\r
+ \4if \1( *Local(2) > *Global(1) ) \4break\1;\r
+\-\r
+\+\r
+ \4if \1( *Address(1,2) % *Local(2) ==0)\r
+\-\r
+\+\r
+ { *Address(3,4)=1; \4break\1; };\r
+\-\r
+\+\r
+ (*Local(2))++;\r
+\-\/\f\r
+\+\r
+ };\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Dost\2e\1p \ do \ \ element\2o\1w \ \ tablic \ \ dynamicznych \ \ daje \ \ procedura\r
+\-\r
+\+\r
+Arrayelem(X,i). \ \ Pierwszy \ \ parametr \ \ musi \ \ okre\2s\1la\2c \ \ \1zmienn\2a\r
+\-\r
+\+\r
+\1referencyjn\2a \1wskazuj\2a\1c\2a \1obiekt tablicy natomiast \ drugi \ parametr\r
+\-\r
+\+\r
+musi okre\2s\1la\2c \ \1indeks \ tablicy. \ Przyk\2l\1adowo, \ wczytanie \ tablicy\r
+\-\r
+\+\r
+ca\2l\1kowitej wyznaczonej przez adres (1,2) o zakresie wska\2z\1nika \ od\r
+\-\r
+\+\r
+1 do n, gdzie n ma adres (0,8), mo\2x\1e wygl\2a\1da\2c \1nast\2e\1puj\2a\1co: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ {\4int \1i;\r
+\-\r
+\+\r
+ \4for \1(i=1; i<= *Global(8); i++)\r
+\-\r
+\+\r
+ scanf("%d", Arrayelem(*Address(1,2),i));\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Natomiast wypisanie takiej tablicy b\2e\1dzie \ r\2o\1wnie \ proste, \ i \ ma\r
+\-\r
+\+\r
+posta\2c \1nast\2e\1puj\2a\1c\2a\1: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ {\4int \1i;\r
+\-\r
+\+\r
+ \4for \1(i=1; i<= *Global(8); i++)\r
+\-\r
+\+\r
+ printf("%d", *Arrayelem(*Address(1,2),i));\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+W celu wykonywania adresowania zdalnego nale\2x\1y wywo\2l\1a\2c \ \1procedur\2e\r
+\-\r
+\+\r
+\1RS o nazwie Physical(X). Parametrem tej procedury jest referencja\r
+\-\r
+\+\r
+do \ obiektu. \ Adres \ wzgl\2e\1dny \ w \ obiekcie \ wyznacza \ translator.\r
+\-\r
+\+\r
+Przyk\2l\1adowo rozwa\2x\1my instrukcj\2e \1i:=X.k, gdzie i ma adres (1,1), X\r
+\-\r
+\+\r
+ma adres (2,3) i wreszcie k ma offset 4. Odpowiednia instrukcja w\r
+\-\r
+\+\r
+j\2e\1zyku C powinna mie\2c \1posta\2c\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ *Address(1,1)= *(Physical(Address(2,3)+4);\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+RS \ dostarcza \ tak\2x\1e \ wielu \ pomocnych \ \ operacji \ \ na \ \ adresach\r
+\-\r
+\+\r
+wirtualnych. Poza Physical(X) mamy Physimple(X), kt\2o\1ra \ realizuje\r
+\-\r
+\+\r
+wyznaczenie adresu bez sprawdzania zgodno\2s\1ci licznik\2o\1w (mo\2x\1e \ by\2c\r
+\-\r
+\+\r
+\1u\2x\1ywana \ w \ zoptymalizowanych \ wersjach). \ \ Mamy \ \ te\2x \ \ \1operacje\r
+\-\r
+\+\r
+podstawienia referencyjnego Refmove(X<Y) co odpowiada X:=Y. \ Dwie\r
+\-\r
+\+\r
+funkcje \ Member(X) \ i \ Notmember(X) \ daj\2a \ \1odpowiednie \ testy \ na\r
+\-\r
+\+\r
+istnienie \ obiektu. \ Wreszcie \ Equal(X,Y) \ i \ Notequal(X,Y) \ daj\2a\r
+\-\r
+\+\r
+\1por\2o\1wnania \ zmiennych \ referencyjnych, \ co \ odpowiada \ warto\2s\1ciom\r
+\-\/\f\r
+\+\r
+wyra\2x\1e\2n \1X=Y i \ X=/=Y. \ Instrukcj\2e \ \1X:=\4none \ \1realizuje \ none(X).\r
+\-\r
+\+\r
+Ponadto wszystkie zmienne referencyjne (nie dotyczy \ to \ adres\2o\1w\r
+\-\r
+\+\r
+po\2s\1rednich) s\2a \1inicjalizowane na \4none\1. Inne zmienne maj\2a \ \1warto\2sc\r
+\-\r
+\+\r
+\1pocz\2a\1tkowa nieokre\2s\1lona. \,\r
+\-\f\r
+\+\r
+\r
+\-\r
+\+\r
+6. Operacje otwierania obiekt\2o\1w\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Mamy cztery operacje otwierania obiekt\2o\1w: Openrc, Slopen, Dopen \ i\r
+\-\r
+\+\r
+Open array. Ich nag\2lo\1wki s\2a \1nast\2e\1puj\2a\1ce: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Openrc (\3a\1,X)\r
+\-\r
+\+\r
+ \4int \3a\1;\r
+\-\r
+\+\r
+ \4unsigned int \1*X;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Slopen (\3a\1,X,Y)\r
+\-\r
+\+\r
+ \4unsigned int \1*X,*Y;\r
+\-\r
+\+\r
+ \4int \3a\1;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Dopen(\3a\1,\3b\1,X)\r
+\-\r
+\+\r
+ \4int \3a\1,\3b\1;\r
+\-\r
+\+\r
+ \4unsigned int \1*X;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Openarray (\3a\1,\3l\1,\3u\1,X)\r
+\-\r
+\+\r
+ \4int \3l\1,\3u\1;\r
+\-\r
+\+\r
+ \4int \3a\1;\r
+\-\r
+\+\r
+ \4unsigned int \1*X;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Procedura Openrc otwiera obiekt klasy, \ kt\2o\1ra \ nie \ ma \ kodu \ ani\r
+\-\r
+\+\r
+modu\2lo\1w wewn\2e\1trznych. Slopen otwiera \ obiekt \ ze \ znanym \ ojcem\r
+\-\r
+\+\r
+syntaktycznym \ (dost\2e\1p \ zdalny \ do \ procedury). \ Procedura \ Dopen\r
+\-\r
+\+\r
+otwiera obiekt modu\2l\1u widocznego i wreszcie \ procedura \ Openarray\r
+\-\r
+\+\r
+otwiera \ obiekt \ tablicy. \ Parametr \ X \ jest \ \ adresem \ \ zmiennej\r
+\-\r
+\+\r
+referencyjnej, kt\2o\1ra po wykonaniu odpowiedniej \ procedury \ b\2e\1dzie\r
+\-\r
+\+\r
+wskazywa\2c \1na otwarty \ obiekt. \ Parametr \ \3a \ \1wskazuje \ zawsze \ na\r
+\-\r
+\+\r
+indeks prototypu otwieranego obiektu w tablicy PROT. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+W procedurze Slopen parametr Y wskazuje na obiekt, kt\2o\1ry \ ma \ by\2c\r
+\-\r
+\+\r
+\1ojcem syntaktycznym otwieranego obiektu. \ W \ procedurze \ Dopen \ \3b\r
+\-\r
+\+\r
+\1jest \ numerem \ prototypu \ w \ kt\2o\1rym \ jest \ zadeklarowany \ \ modu\2l\r
+\-\/\f\r
+\+\r
+\1otwierany. W procedurze Openarray parametry \3l\1, \3u \1okre\2s\1laj\2a \1dolny\r
+\-\r
+\+\r
+i g\2o\1rny wska\2z\1nik indeksu. \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+7. Operacje przekazywania sterowania\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Wywo\2l\1anie modu\2l\1u loglanowego mo\2x\1e odbywa\2c \ \1si\2e \ \1tylko \ za \ pomoc\2a\r
+\-\r
+\+\r
+\1wywo\2l\1ania odpowiedniego modu\2l\1u w C. Takie wywo\2l\1ania odk\2l\1adane \ na\r
+\-\r
+\+\r
+stos \ powodowa\2l\1yby \ szybkie \ jego \ przepe\2l\1nienie. \ \ Aby \ \ unikn\2ac\r
+\-\r
+\+\r
+\1odk\2l\1adania kopii modu\2lo\1w j\2e\1zyka C na stos mo\2x\1na za \ ka\2x\1dym \ razem\r
+\-\r
+\+\r
+przekazywania sterowania pomi\2e\1dzy \ modu\2l\1ami \ wraca\2c \ \1do \ programu\r
+\-\r
+\+\r
+g\2lo\1wnego main(), czyszcz\2a\1c w ten spos\2o\1b stos. \ Ka\2x\1da \ z \ procedur\r
+\-\r
+\+\r
+przekazywania sterowania pomi\2e\1dzy modu\2l\1ami wyznacza \ tylko \ numer\r
+\-\r
+\+\r
+kolejnego \ modu\2l\1u, \ kt\2o\1ry \ nale\2x\1y \ wywo\2l\1a\2c\1. \ Taki \ numer \ \ modu\2l\1u\r
+\-\r
+\+\r
+b\2e\1dziemy trzyma\2c \1na zmiennej globalnej \3modulenumber\1. W \ programie\r
+\-\r
+\+\r
+main() nale\2x\1y tylko wywo\2l\1a\2c \1odpowiedni modu\2l \1za pomoc\2a \1instrukcji\r
+\-\r
+\+\r
+module[\3modulenumber\1]().\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Aby powr\2o\1t do programu main() czy\2s\1ci\2l \1stos, \ kt\2o\1ry \ mo\2x\1e \ zawiera\2c\r
+\-\r
+\+\r
+\1poza kolejnym wykonywanym modu\2l\1em wywo\2l\1ania \ r\2ox\1nych \ pomocniczych\r
+\-\r
+\+\r
+procedur, nale\2x\1y skorzysta\2c \1z procedur standardowych \ setjmp \ oraz\r
+\-\r
+\+\r
+longjmp dostarczanych przez system C. Ustawiaj\2a\1c setjmp(buffer) \ w\r
+\-\r
+\+\r
+programie \ g\2lo\1wnym, \ ka\2x\1de \ zako\2n\1czenie \ przekazywania \ sterowania\r
+\-\r
+\+\r
+pomi\2e\1dzy modu\2l\1ami ko\2n\1czy wykonanie longjmp(buffer,-1). \ Sterowanie\r
+\-\r
+\+\r
+wraca do setjmp(buffer) czyszcz\2a\1c \ stos. \ Zako\2n\1czenie \ wykonywania\r
+\-\r
+\+\r
+programu \ mo\2x\1na \ zrealizowa\2c \ \1wywo\2l\1aniem \ \ longjmp(buffer,-2). \ \ W\r
+\-\r
+\+\r
+zale\2x\1no\2s\1ci \ od \ warto\2s\1ci \ setjmp(buffer) \ otrzymanej \ w \ programie\r
+\-\r
+\+\r
+main() mo\2x\1emy albo przekaza\2c \1sterowanie do kolejnego modu\2l\1u, \ albo\r
+\-\r
+\+\r
+zako\2n\1czy\2c \1wykonywanie programu. Przy \ takich \ za\2l\1o\2x\1eniach \ program\r
+\-\r
+\+\r
+g\2lo\1wny ma nast\2e\1puj\2a\1c\2a \1posta\2c\1:\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+main ()\r
+\-\r
+\+\r
+{\r
+\-\r
+\+\r
+ module[0]=A1;\r
+\-\r
+\+\r
+ ...\r
+\-\r
+\+\r
+ module[k]=Ak;\r
+\-\r
+\+\r
+ Init();\r
+\-\r
+\+\r
+ IC=1;\r
+\-\r
+\+\r
+ \3modulenumber\1=0;\,\r
+\-\r
+\+\r
+ \4if \1(setjmp(buffer)!=-2) module[\3modulenumber\1]();\,\r
+\-\r
+\+\r
+}\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+W RS mamy \ pi\2ec \ \1operacji \ zwi\2a\1zanych \ z \ prostym \ przekazywaniem\r
+\-\r
+\+\r
+sterowania: \ Go, \ Back, \ Endclass, \ Inn \ oraz \ Endrun. \ Oto \ \ ich\r
+\-\r
+\+\r
+nag\2lo\1wki: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Go (X)\r
+\-\r
+\+\r
+ \4unsigned int \1*X;\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Back ()\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Endclass()\,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Inn(k)\r
+\-\r
+\+\r
+ \4int \1k;\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Endrun ()\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Procedura \ Go(X) \ przekazuje \ sterowania \ do \ obiektu \ X. \ \ Typowa\r
+\-\r
+\+\r
+kolejno\2sc \ \ \1operacji \ \ przy \ \ przekazywaniu \ \ \ sterowania \ \ \ jest\r
+\-\r
+\+\r
+nast\2e\1puj\2a\1ca: \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Dopen(a,b,X);\r
+\-\r
+\+\r
+ /* przekazanie parametr\2o\1w do X */\r
+\-\r
+\+\r
+ IC=m; Go(X);\r
+\-\r
+\+\r
+Lm:/* po powrocie z X */\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Procedura Back() zwraca sterowanie po Dl. Nie \ ma \ parametr\2o\1w. \ W\r
+\-\r
+\+\r
+przypadku wsp\2ol\1program\2o\1w \ musi \ by\2c \ \1po \ niej \ wej\2s\1cie \ opatrzone\r
+\-\r
+\+\r
+etykiet\2a\1: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ IC=m; Back();\r
+\-\r
+\+\r
+Lm:/* ponowna reaktywacja modu\2l\1u */\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Procedura \ Endclass() \ realizuje \ operacj\2e \ \ \1zako\2n\1czenia \ \ klasy.\r
+\-\r
+\+\r
+Wywo\2l\1ujemy j\2a \1w miejscu wyst\2a\1pienia ko\2n\1ca klasy (\4return \1w \ klasie\r
+\-\r
+\+\r
+t\2l\1umaczone \ jest \ zawsze \ na \ Back \ ). \ Procedura \ \ ta \ \ sprawdza\r
+\-\r
+\+\r
+dynamicznie w jakiego typu obiekcie jest sterowanie. Je\2x\1eli \ jest\r
+\-\r
+\+\r
+to obiekt wsp\2ol\1programu, wywo\2l\1ywana \ jest \ operacja \ Endcor(). \ W\r
+\-\r
+\+\r
+przeciwnym przypadku \ wywo\2l\1ywana \ jest \ zwyk\2l\1a \ operacja \ Back().\r
+\-\r
+\+\r
+Zako\2n\1czenie \ nieprefiksowanego \ podprogramu \ \ lub \ \ bloku \ \ mo\2x\1na\r
+\-\r
+\+\r
+zrealizowa\2c \1za pomoc\2a \1procedury \ Back(), \ natomiast \ w \ przypadku\r
+\-\r
+\+\r
+klasy \ niemo\2x\1liwe \ jest \ statyczne \ sprawdzenie \ czy \ b\2e\1dzie \ \ to\r
+\-\r
+\+\r
+instrukcja ko\2n\1cz\2a\1ca wsp\2ol\1program, czy te\2x \1nie. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Procedura Inn(k) przekazuje sterowanie \ przez \ \4inner\1. \ Warto\2sc \ \1k\r
+\-\r
+\+\r
+okre\2s\1la d\2l\1ugo\2sc l\1a\2n\1cucha prefiksowego danego \ modu\2l\1u. \ Instrukcja\r
+\-\r
+\+\r
+po Inn(k) musi by\2c \1tak\2x\1e w stosowny \ spos\2o\1b \ opatrzona \ etykiet\2a\1.\r
+\-\r
+\+\r
+Powr\2o\1t za \4inner \1wykonuje si\2e \1bezpo\2s\1rednio, bez \ uczestnictwa \ RS.\r
+\-\r
+\+\r
+Na przyk\2l\1ad, maj\2a\1c \ modu\2l\1y \ A \ i \ B \ (B \ prefiksowany \ przez \ A),\r
+\-\r
+\+\r
+operacja \4inner \1w A oraz powr\2o\1t w B powinny wygl\2a\1da\2c \1nast\2e\1puj\2a\1co: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ A()\r
+\-\r
+\+\r
+ {\r
+\-\r
+\+\r
+ ...\r
+\-\r
+\+\r
+ Inn(1);\,\r
+\-\r
+\+\r
+Lm: ...\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ B()\r
+\-\r
+\+\r
+ {\r
+\-\r
+\+\r
+ ...\r
+\-\r
+\+\r
+ IC=m; \,\r
+\-\r
+\+\r
+ \3modulenumber\1=n; /* gdzie n jest numerem modu\2l\1u A */\,\r
+\-\r
+\+\r
+ longjmp(buffer,-1); /* skok do programu g\2lo\1wnego */\,\r
+\-\/\f\r
+\+\r
+\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ /* gdzie wywo\2l\1any zostanie modu\2l \1A */\,\r
+\-\r
+\+\r
+ };\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Procedura Endrun ko\2n\1czy wykonanie programu.\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+8. Operacje usuwania obiekt\2o\1w\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Mamy \ dwie \ procedury \ do \ usuwania \ obiekt\2o\1w \ : \ Killafter() \ i\r
+\-\r
+\+\r
+Gkill(X). Pierwsza z nich wywo\2l\1ywana jest po powrocie z procedury,\r
+\-\r
+\+\r
+funkcji lub \ bloku \ loglanowego. \ Jej \ zadaniem \ jest \ czyszczenie\r
+\-\r
+\+\r
+\2l\1a\2n\1cucha Sl (patrz \ punkt \ 3). \ Zatem \ typowa \ kolejno\2sc \ \1operacji\r
+\-\r
+\+\r
+wywo\2l\1ania takiego modu\2l\1u loglanowego b\2e\1dzie nast\2e\1puj\2a\1ca :\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Dopen(a,b,X);\r
+\-\r
+\+\r
+ /* przekazanie parametr\2o\1w wej\2s\1ciowych */\r
+\-\r
+\+\r
+ IC=m; Go(X);\r
+\-\r
+\+\r
+Lm: /* przekazanie parametr\2o\1w wyj\2s\1ciowych */\r
+\-\r
+\+\r
+ Killafter();\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Jakkolwiek nowy RS jest wyposa\2x\1ony w \ automatyczny \ od\2s\1miecacz \ i\r
+\-\r
+\+\r
+zb\2e\1dne obiekty funkcji, procedur i blok\2o\1w \ i \ tak \ b\2e\1da \ usuwane,\r
+\-\r
+\+\r
+jednak\2x\1e wywo\2l\1anie Killafter() w przypadku \ ka\2x\1dego \ modu\2l\1u \ typu\r
+\-\r
+\+\r
+procedura, funkcja lub blok usprawni dzia\2l\1anie pami\2e\1ci \ RS, \ gdy\2x\r
+\-\r
+\+\r
+\1najcz\2es\1ciej jest to ostatni obiekt w pami\2e\1ci, \ kt\2o\1rego \ usuni\2e\1cie\r
+\-\r
+\+\r
+odbywa si\2e \1jak na stosie. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Operacja Gkill(X) jest star\2a \1operacj\2a \1z modyfikacjami opisanymi \ w\r
+\-\r
+\+\r
+punkcie 3. Parametrem tej operacji jest adres usuwanego obiektu. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+9. Operacje na wsp\2ol\1programach\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+RS dostarcza trzech procedur operuj\2a\1cych na wsp\2ol\1programach. S\2a \1to\r
+\-\r
+\+\r
+operacje \ Endcor(), \ Attach(X) \ \ oraz \ \ Attachwith(X,\3signalnum\1,Y).\r
+\-\r
+\+\r
+Operacja Endcor jest wywo\2l\1ywana na zako\2n\1czenie wsp\2ol\1programu. \ Jej\r
+\-\r
+\+\r
+dzia\2l\1anie zosta\2l\1o om\2o\1wione przy okazji \ opisywania \ struktury \ Dl.\r
+\-\r
+\+\r
+Operacja \ Attach(X) \ \ przekazuje \ \ sterowanie \ \ do \ \ wsp\2ol\1programu\r
+\-\r
+\+\r
+wyznaczonego przez parametr X. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Wi\2e\1kszego om\2o\1wienia \ wymaga \ natomiast \ operacja \ Attachwith. \ Jej\r
+\-\r
+\+\r
+pierwszym parametrem jest referencja do wsp\2ol\1programu gdzie ma by\2c\r
+\-\r
+\+\r
+\1wywo\2l\1any alarm. Drugi parametr to numer \ sygna\2l\1u. \ Wreszcie \ trzeci\r
+\-\r
+\+\r
+parametr jest referencj\2a \1do obiektu utworzonego \ handlera \ (o \ ile\r
+\-\r
+\+\r
+taki zostanie znaleziony). Po wywo\2l\1aniu mo\2x\1na b\2e\1dzie przekaza\2c \ \1do\r
+\-\r
+\+\r
+handlera parametry wej\2s\1ciowe i dopiero wtedy przekaza\2c \ \1sterowanie\r
+\-\r
+\+\r
+do wsp\2ol\1programu X za \ pomoc\2a \ \1zwyk\2l\1ego \ Attach. \ Ciag \ instrukcji\r
+\-\r
+\+\r
+realizuj\2a\1cych \ wywo\2l\1anie \ sygna\2l\1u \ w \ innym \ wsp\2ol\1programie \ \ mo\2x\1e\r
+\-\r
+\+\r
+wygl\2a\1da\2c \1na przyk\2l\1ad tak: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Attachwith(X,s,Y);\r
+\-\r
+\+\r
+ /* przekazujemy do Y parametry wej\2s\1ciowe */\r
+\-\r
+\+\r
+ IC=m; Attach(X);\r
+\-\r
+\+\r
+Lm: /* dalsze instrukcje w module */\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\r
+\-\r
+\+\r
+10. Wyj\2a\1tki\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Z \ wyj\2a\1tkami \ \ zwi\2a\1zane \ \ s\2a \ \ \1operacje \ \ Raising(\3signalnum\1,X) \ \ i\r
+\-\r
+\+\r
+Termination() oraz etykiety \3lastwill\1. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Operacja Raising(\3signalnum\1,X) powoduje \ poszukiwanie \ w \ aktywnym\r
+\-\r
+\+\r
+\2l\1a\2n\1cuchu Dl handlera dla sygna\2l\1u o numerze \3signalnum\1. Je\2x\1eli taki\r
+\-\r
+\+\r
+handler \ zostanie \ znaleziony, \ otwarty \ zostanie \ jego \ \ obiekt,\r
+\-\r
+\+\r
+kt\2o\1rego referencja przekazana zostanie \ na \ parametr \ X. \ Po \ tej\r
+\-\r
+\+\r
+instrukcji \ mo\2x\1na \ przekaza\2c \ \1do \ \ obiektu \ \ handlera \ \ parametry\r
+\-\r
+\+\r
+wej\2s\1ciowe i wreszcie przekaza\2c \ \1sterowanie \ do \ handlera \ zwyk\2l\1ym\r
+\-\r
+\+\r
+Go(X). Czyli odpowiedni ci\2a\1g instrukcji jest \ taki \ sam \ jak \ dla\r
+\-\r
+\+\r
+wywo\2l\1ania procedury. \ Zamiast \ operacji \ Dopen \ czy \ Slopen \ mamy\r
+\-\r
+\+\r
+operacj\2e \1Raising. Oczywi\2s\1cie po powrocie obiekt \ handlera \ chcemy\r
+\-\r
+\+\r
+usun\2ac\1, musi zatem wyst\2a\1pi\2c \1Killafter(). \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Je\2x\1eli w handlerze wyst\2e\1puje \ na \ zako\2n\1czenie \ instrukcja \ \4return\1,\r
+\-\r
+\+\r
+wykonuje \ si\2e \ \1zwyk\2l\1e \ Back() \ z \ jego \ konsekwencjami. \ Mamy \ \ do\r
+\-\r
+\+\r
+czynienia ze zwyk\2l\1a procedur\2a \1tylko wo\2l\1an\2a \1dynamicznie. Je\2x\1eli \ na\r
+\-\r
+\+\r
+zako\2n\1czenie \ handlera \ wyst\2e\1puje \ terminate, \ wywo\2l\1ujemy \ operacj\2e\r
+\-\r
+\+\r
+\1Termination(). Jak teraz powinny wygl\2a\1da\2c \ \1odpowiednie \ instrukcj\2e\r
+\-\r
+\+\r
+\1lastwill. Ot\2ox \1Termination ustawia w ka\2x\1dym obiekcie \ \2l\1a\2n\1cucha \ Dl\r
+\-\r
+\+\r
+(od obiektu gdzie wywo\2l\1ano \ alarm \ do \ obiektu \ gdzie \ znaleziono\r
+\-\r
+\+\r
+handler) lokalne sterowanie \ na \ etykiet\2e \ \3lastwill\1. \ Nast\2e\1pnie \ w\r
+\-\r
+\+\r
+handlerze nale\2x\1y wykona\2c \1zwyk\2l\1e \ Back() \ - \ powr\2o\1t \ po \ Dl \ linku.\r
+\-\r
+\+\r
+Pierwsza \ instrukcja \ lastwill \ \ powinna \ \ by\2c \ \ \1zatem \ \ operacj\2a\r
+\-\r
+\+\r
+\1Killafter(). Czyli w handlerze terminate t\2l\1umaczymy na: \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Termination();\r
+\-\r
+\+\r
+ Back();\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+natomiast ci\2a\1g instrukcji lastwill powinien wygl\2a\1da\2c \1nast\2e\1puj\2a\1co:\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Lk: Killafter(); /* Lk etykieta dla IC=k dla lastwill */\r
+\-\r
+\+\r
+ .... /* instrukcje lastwill */\r
+\-\r
+\+\r
+ Back(); /* lub IC=...; \3modulenumber\1= ...;\,\r
+\-\r
+\+\r
+ longjmp(buffer,-1); \,\r
+\-\/\f\r
+\+\r
+ w przypadku modu\2l\1u prefiksowanego */\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+11. Za\2la\1czone przyk\2l\1ady\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+System RS testowa\2l\1em na przyk\2l\1adach napisanych r\2e\1cznie. \ Stara\2l\1em\r
+\-\r
+\+\r
+si\2e \ \1przetestowa\2c \ \1wszystkie \ wa\2x\1ne \ konstrukcje \ \ RS, \ \ a \ \ wi\2e\1c\r
+\-\r
+\+\r
+otwieranie \ obiekt\2o\1w, \ przekazywanie \ sterowania, \ wsp\2ol\1programy,\r
+\-\r
+\+\r
+wyj\2a\1tki, \ tablice \ dynamiczne, \ no \ i \ oczywi\2s\1cie \ od\2s\1miecacz \ \ z\r
+\-\r
+\+\r
+kompaktyfikatorem. Nie \ mog\2l\1em \ przetestowa\2c \ \1tego \ systemu \ zbyt\r
+\-\r
+\+\r
+szczeg\2ol\1owo, gdy\2x \ \1zawiera \ on \ za \ wiele \ elemnt\2o\1w \ trudnych \ do\r
+\-\r
+\+\r
+wychwycenia w r\2e\1cznym tworzeniu kodu. \ Nie \ przetestowa\2l\1em \ wielu\r
+\-\r
+\+\r
+fragment\2o\1w \ zwi\2a\1zanych \ z \ definicj\2a \ \ \1struktur \ \ referencyjnych.\r
+\-\r
+\+\r
+Oczywi\2s\1cie, wydaje \ mi \ si\2e\1, \ \2x\1e \ przetestowanie \ ca\2l\1o\2s\1ci \ nale\2x\1y\r
+\-\r
+\+\r
+od\2l\1o\2x\1y\2c \1do czasu powstania kompilatora. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Przyk\2l\1ad perm.c odpowiada znanej nam procedurze \ rekurencyjnej \ na\r
+\-\r
+\+\r
+generowanie wszystkich permutacji. Przyk\2l\1ad ten testuje \ dzia\2l\1anie\r
+\-\r
+\+\r
+otwierania \ obiektu \ widocznego, \ tablice, \ rekursj\2e\1, \ adresowanie\r
+\-\r
+\+\r
+nielokalne i u\2x\1ycie zmiennych sterowania p\2e\1tla. \,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+Przyk\2l\1ad merge.c jest stosunkowo du\2x\1ym programem do testowania\r
+\-\r
+\+\r
+operacji na wsp\2ol\1programach. Jest to znany \ program \ na \ scalanie\r
+\-\r
+\+\r
+drzew binarnych poszukiwa\2n\1. \ Program \ testuje \ tak\2x\1e \ wywo\2l\1ywanie\r
+\-\r
+\+\r
+zdalne procedur, przekazywanie parametr\2o\1w referencyjnych, tablice\r
+\-\r
+\+\r
+wsp\2ol\1program\2o\1w, operacje Attach, itp. Napisa\2l\1em przy okazji \ trzy\r
+\-\r
+\+\r
+warianty tego przyk\2l\1adu pozwalaj\2a\1ce \ testowa\2c \ \1inne \ operacje \ na\r
+\-\r
+\+\r
+wsp\2ol\1programach. Ot\2ox \1mergecor.c jest tym samym algorytmem, z tym\r
+\-\r
+\+\r
+\2x\1e \ zako\2n\1czenie \ sygnalizuje \ operacja \ Attachwith \ do \ drugiego\r
+\-\r
+\+\r
+wsp\2ol\1programu. Przyk\2l\1ad testcor.c testuje poprawno\2sc \ \1reakcji \ na\r
+\-\r
+\+\r
+pr\2o\1b\2e \1reaktywacji wsp\2ol\1programu zako\2n\1czonego. Wreszcie \ kmerge.c\r
+\-\r
+\+\r
+jest wariantem tego przyk\2l\1adu gdzie usuwane s\2a \ \1za \ pomoc\2a \ \1Gkill\r
+\-\r
+\+\r
+zb\2e\1dne obiekty. Przyk\2l\1ad ten \ s\2l\1u\2x\1y\2l \ \1przetestowaniu \ poprawno\2s\1ci\r
+\-\r
+\+\r
+dzia\2l\1ania \ \ w\2l\1a\2s\1nie \ \ operacji \ \ Gkill, \ \ tak\2x\1e \ \ w \ \ \ przypadku\r
+\-\r
+\+\r
+wsp\2ol\1program\2o\1w (a to jest przypadek trudniejszy). \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+Program memor.c by\2l \1dla mnie najtrudniejszy w uruchamianiu. Jest\r
+\-\r
+\+\r
+to kr\2o\1tki program na testowanie od\2s\1miecacza i kompaktyfikatora.\r
+\-\r
+\+\r
+Poniewa\2x \1kompaktyfikator musia\2l \ \1by\2c \ \1nieznacznie \ rozszerzony \ z\r
+\-\r
+\+\r
+uwagi na nowa koncepcje Statsl, wprowadzi\2l\1em \ dodatkowy \ przebieg\r
+\-\r
+\+\r
+poprawiaj\2a\1cy to pole dla obiekt\2o\1w, kt\2o\1re po od\2s\1mieceniu pozostan\2a\r
+\-\r
+\+\r
+x\1ywe. Testowa\2l\1em kompaktyfikator dla r\2ox\1nych \ parametr\2o\1w \ w \ tym\r
+\-\r
+\+\r
+przyk\2l\1adzie (n=liczba obiekt\2o\1w wygenerowanych, \ k= \ cz\2e\1stotliwo\2sc\r
+\-\r
+\+\r
+\1usuwania poprzednik\2o\1w). Poniewa\2x \1j\2e\1zyk C \ umo\2x\1liwia \ profilowanie\r
+\-\r
+\+\r
+programu, by\2l\1em \ w \ stanie \ oszacowa\2c \ \1koszt \ wzgl\2e\1dny \ dzia\2l\1ania\r
+\-\r
+\+\r
+kompaktyfikatora. Ot\2ox \1kompaktyfikator zabiera\2l \1nie wi\2e\1cej ni\2x \16\r
+\-\r
+\+\r
+procent czasu dzia\2l\1ania programu , kt\2o\1ry sam nic \ w\2l\1a\2s\1ciwie \ nie\r
+\-\r
+\+\r
+robi. \ Du\2x\1a \ cz\2esc \ \1czasu \ (ponad \ 4 \ procent) \ \ zajmuje \ \ jednak\r
+\-\r
+\+\r
+inicjalizowanie zmiennych referencyjnych. \ Wydaje \ si\2e\1, \ \2x\1e \ taka\r
+\-\r
+\+\r
+inicjalizacja mog\2l\1aby by\2c \ \1czasem \ pomijana \ (programista \ bardzo\r
+\-\r
+\+\r
+rzadko zapomina o podstawieniu \ na \ zmienn\2a \ \1referencyjn\2a\1). \ Przy\r
+\-\r
+\+\r
+okazji tego \ testu \ musz\2e \ \1zwr\2o\1ci\2c \ \1uwag\2e \ \1na \ to, \ \2x\1e \ w \ wersji\r
+\-\r
+\+\r
+loglanowej nowego RS inicjalizacja zmiennych by\2l\1a wykonywana wraz\r
+\-\r
+\+\r
+z zerowanie obiektu (\4none \1=[0,0]). Niestety w wersji napisanej \ w\r
+\-\r
+\+\r
+C chcia\2l\1em, aby zmienne loglanowe \ by\2l\1y \ adresowane \ nie \ poprzez\r
+\-\r
+\+\r
+indeks w tablicy M, ale przez adres w pami\2e\1ci. Takie \ rozwi\2a\1zanie\r
+\-\r
+\+\r
+jest oczywi\2s\1cie bardziej efektywne, ale wymaga innego \ okre\2s\1lenia\r
+\-\r
+\+\r
+\4none\1. Mianowicie \4none\1=[M0,0], gdzie M0= &M[0], oraz M[1]=1. \ Ale\r
+\-\r
+\+\r
+w\2o\1wczas inicjalizacj\2e \1obiektu trzeba wykonywa\2c \1przegl\2a\1daj\2a\1c list\2e\r
+\-\r
+\+\r
+\1referencji \ - \ a \ to \ jak \ widzimy \ kosztuje \ bardzo. \ Co \ prawda\r
+\-\r
+\+\r
+przyk\2l\1adowy \ program \ nie \ zawiera\2l \ x\1adnych \ oblicze\2n\1, \ a \ \ wi\2e\1c\r
+\-\r
+\+\r
+inicjalizacja mog\2l\1a kosztowa\2c \1gros czasu dzia\2l\1ania. \,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Napisa\2l\1em jeden przyk\2l\1ad testuj\2a\1cy \ arytmetyk\2e \ \1zmiennopozycyjn\2a\1.\r
+\-\r
+\+\r
+Jest to program square.c gdzie rozwi\2a\1zujemy r\2o\1wnanie kwadratowe.\r
+\-\r
+\+\r
+Wykorzystuj\2a\1c macra dla arytmetyki \ zmiennopozycyjnej \ bez \ trudu\r
+\-\r
+\+\r
+uda\2l\1o si\2e \1wyrazi\2c \1opracje na typie real. Wida\2c\1, \2x\1e wyra\2x\1enia mog\2a\r
+\-\r
+\+\r
+\1pozosta\2c \1bez zmiany, ewentualne zmienne \ robocze \ wygeneruje \ sam\r
+\-\r
+\+\r
+kompilator j\2e\1zyka C. Ich \ typ \ b\2e\1dzie \ dobrany \ zgodnie \ z \ typem\r
+\-\r
+\+\r
+argument\2o\1w. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Przyk\2l\1ad sltest.c s\2l\1u\2x\1y\2l \1do sprawdzenia dzia\2l\1ania nowej struktury\r
+\-\r
+\+\r
+Sl. \ Prosty \ program \ o \ znanej \ strukturze, \ gdzie \ \ wywo\2l\1ywana\r
+\-\r
+\+\r
+procedura ma zniszczone otoczenie \ statyczne, \ pozwala\2l \ \1sprawdzi\2c\r
+\-\r
+\+\r
+\1poprawno\2sc \ \1dzia\2l\1ania \ tej \ techniki. \ Wydaje \ si\2e\1, \ \2x\1e \ \ ma \ \ ona\r
+\-\r
+\+\r
+metodologicznie znaczna przewag\2e \1nad starym rozwi\2a\1zaniem \ (nie \ ma\r
+\-\r
+\+\r
+efekt\2o\1w dziwnych i niezrozumia\2l\1ych \ dla \ programisty), \ a \ ponadto\r
+\-\r
+\+\r
+jest stosunkowo \2l\1atwo implementowalna. Troch\2e \1tracimy \ na \ czasie,\r
+\-\r
+\+\r
+poniewa\2x \1sprawdzenie i czyszczenie \2l\1a\2n\1cuch\2o\1w Sl jest \ dro\2x\1sze \ ni\2x\r
+\-\r
+\+\r
+\1usuwanie na \2s\1lepo obiekt\2o\1w funkcji \ i \ blok\2o\1w. \ Z \ drugiej \ strony\r
+\-\r
+\+\r
+zyskuje si\2e \1troch\2e \1na pami\2e\1ci gdy\2x \1Sl link mo\2x\1e by\2c \1referencj\2a \1bez\r
+\-\r
+\+\r
+licznika. \,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Ostatni przyk\2l\1ad functest.c s\2l\1u\2x\1y sprawdzeniu poprawno\2s\1ci u\2x\1ywania\r
+\-\r
+\+\r
+zmiennych podprogramowych. W bloku g\2lo\1wnym zadeklarowany jest \ typ\r
+\-\r
+\+\r
+funkcyjny F oraz funkcja f z parametrem integer oraz typem wyniku\r
+\-\r
+\+\r
+F. W funkcji tej zadeklarowano dwie inne funkcje \ h, \ g, \ kt\2o\1re \ w\r
+\-\r
+\+\r
+tre\2s\1ci funkcji f podstawiane s\2a \1jako jej wynik (typ f jest zgodny\r
+\-\r
+\+\r
+z F). W programie g\2lo\1wnym na zmienne x,y podstawiana jest \ warto\2sc\r
+\-\r
+\+\r
+\1wyniku wywo\2l\1ania funkcji f, dla argumentu 0 tym wynikiem \ jest \ h,\r
+\-\r
+\+\r
+dla argumentu 1 tym wynikiem jest g. Wreszcie \ na \ ko\2n\1cu \ programu\r
+\-\r
+\+\r
+wywo\2l\1ujemy x(n), oraz y(n) jako odpowiednie funkcje zapami\2e\1tane na\r
+\-\r
+\+\r
+zmiennych x,y.\r
+\-\r
+\=\r
+\1a#include "rsdata.h"\r
+\r
+\r
+\r
+\r
+ int IC; /* global control */\r
+ int modulenumber; /* module number */\r
+ unsigned int *DISPLAY,*DISPDIR; /* displays' addresses */\r
+ unsigned int *lastcor,*mycoroutine,*myprocess;\r
+ unsigned int *current,*local,*global;\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Running System basic constants */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+#define maxint 65535\r
+#define maxapp maxint /* to be defined for each system */\r
+#define maxcounter (-1) /* maximal value of counter */\r
+#define reflength 2 /* reference variable length */\r
+#define memorylength 16000 /* to be defined for each system */\r
+#define upr (memorylength-1) /* memory upper index */\r
+#define minsize 2 /* minimal object size */\r
+#define virt1 reflength /* auxiliary virtual addresses */\r
+#define virt2 2*reflength\r
+#define virt3 3*reflength\r
+#define virt4 4*reflength\r
+#define virtn virt4\r
+#define lwr (virtn+reflength) /* memory lower index */\r
+\r
+\r
+\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Functions defining system offsets */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+#define Sl(a,am) (am+PROT[a].Sloffset) /* Sl link offset */\r
+#define Dl(a,am) (am+PROT[a].Dloffset) /* Dl link offset */\r
+#define Statsl(a,am) (am+PROT[a].Statoffset) /* Statussl offset */\r
+#define Lsc(a,am) (am+PROT[a].Lscoffset) /* Lsc offset */\r
+\r
+/************************************************************************/\r
+/* */\r
+/* Sl - defines the static father of an object, where is declared */\r
+/* Dl - defines the dynamic father of an object, where to return */\r
+/* Statussl - defines the number of syntactic sons */\r
+/* Lsc - defines the local sequence control */\r
+/************************************************************************/\r
+\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Running System basic offsets */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* for arrays */\r
+/*----------------------------------------------------------------------*/\r
+\r
+#define lboffset 1 /* array lower bound offset */\r
+#define uboffset 2 /* array upper bound offset */\r
+#define elmoffset 3 /* array first element offset */\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* for killed objects */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+#define shortlink 1 /* offset of next shortlist element */\r
+#define longlink 2 /* offset of next longlist element */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Entities imported from a program */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+extern int displ,curr,lstcor,chead,displdir; /* basic offsets in main */\r
+extern struct Prototype PROT[]; /* Prototypes */\r
+extern struct Offsets OFF[]; /* Reference structures */\r
+extern struct Elem EL[]; /* Lists of references */\r
+extern struct Hlstelem HL[]; /* Lists of handlers */\r
+extern struct Sgelem SL[]; /* Lists of signals */\r
+extern int perm[],perminv[]; /* Langmaack's permutations */\r
+extern int (*module []) (); /* Modules addresses */\r
+extern int protnum,offnum; /* Length of PROT and OFF */\r
+extern jmp_buf buffer; /* buffer for jumps */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* Loglan memory structure */\r
+/* */\r
+/* M[lwr],...,M[lastused],.....,M[lastitem],...,M[upr] */\r
+/* where: */\r
+/* M[lwr],...,M[lastused] memory for objects */\r
+/* M[lastitem],...,M[upr] memory for indirect addresses */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Every reference X = [ah,counter] */\r
+/* where: */\r
+/* ah = address in indirect addresses table */\r
+/* counter = a consecutive positive integer */\r
+/* */\r
+/* Every indirect addresses table item= [am,guard_counter] */\r
+/* where: */\r
+/* am = address of an object */\r
+/* guard_counter = a consecutive positive integer */\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* X=none iff counter <> guard_counter i.e. iff */\r
+/* M[X+1]<> M[M[X]+1] */\r
+/************************************************************************/\r
+\r
+\r
+\r
+unsigned int M[memorylength]; /* Loglan memory */\r
+unsigned int * M0; /* address of M[0],[M0,0]=none */\r
+\r
+unsigned int *lastitem,*freeitem;\r
+\r
+ /* M[lastitem..upr] - indirect addresses table;\r
+ M[freeitem] - head of free indirect addresses */\r
+\r
+unsigned int *lastused;\r
+\r
+ /* M[lwr..lastused] - memory for objects */\r
+\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Basic runnning system structures: */\r
+/* */\r
+/* class object: */\r
+/* M[lspan],...,M[am],...,M[rspan] */\r
+/* where M[am]=prototype number */\r
+/* */\r
+/* array object: */\r
+/* M[am],M[am+1],M[am+2],...,M[am+l-1] */\r
+/* where M[am]=prototype number */\r
+/* M[am+1]= lowr bound */\r
+/* M[am+2]= upper bound */\r
+/* l = total length */\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* killed object: */\r
+/* M[am],M[am+1],M[am+2],...,M[am+l-1] */\r
+/* where M[am]=l, total length */\r
+/* M[am+1]= address of next killed */\r
+/* with equal length */\r
+/* M[am+2]= address of next killed */\r
+/* with next greater length */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+\r
+\r
+\r
+unsigned int *headk,*headkmin;\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* headk - head of killed objects list */\r
+/* the list ends with M[lwr]=maximal appetite */\r
+/* headkmin - head of killed objects list of minimal length */\r
+/* each list element has only address of next killed with */\r
+/* equal length, so no need for M[am+2] */\r
+/* */\r
+/************************************************************************/\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Global variables */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+\r
+\r
+unsigned int *vipt1,*vipt2,*vipt3,*vipt4,*viptn;\r
+\r
+ /* vipti = address of M[virti] */\r
+\r
+unsigned int *Mlwr,*Mupr; /* addresses of M[lwr] and M[upr] */\r
+\r
+int protnum1; /* =protnum+1, used in marking */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Object size */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+static unsigned int Size (a,am)\r
+int a;\r
+unsigned int *am;\r
+{\r
+ switch (PROT[a].kind)\r
+ {\r
+ case PRIMITARRAY:\r
+ return((*(am+uboffset)- *(am+lboffset)+1)*PROT[a].elsize+\r
+ elmoffset);\r
+ case REFARRAY :\r
+ case SUBARRAY:\r
+ return((*(am+uboffset)- *(am+lboffset)+1)*reflength+elmoffset);\r
+ case STRUCTARRAY:\r
+ return((*(am+uboffset)- *(am+lboffset)+1)*\r
+ (OFF[PROT[a].references].size)+elmoffset);\r
+ case POINTARRAY:\r
+ return(*(am+uboffset)- *(am+lboffset)+1+elmoffset);\r
+ default:\r
+ return(PROT[a].rspan+PROT[a].lspan+1);\r
+ }\r
+}\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Position of protnum in object */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+static unsigned int Ptposition(a)\r
+int a;\r
+{\r
+ switch (PROT[a].kind)\r
+ {\r
+ case PRIMITARRAY:\r
+ case REFARRAY:\r
+ case SUBARRAY:\r
+ case STRUCTARRAY:\r
+ case POINTARRAY:\r
+ return(0);\r
+ default:\r
+ return(PROT[a].lspan);\r
+ }\r
+}\r
+\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Auxiliary function for dumping the whole memory */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+\r
+Memorydump ()\r
+{\r
+ unsigned int *i,*l,*u;\r
+ int j;\r
+\r
+ printf("\n SYSTEM VARIABLES\n");\r
+ printf(\r
+ "freeitem lastused lastitem headk headkmin Mlwr Mupr\n");\r
+ printf("%3d %3d %3d %3d %3d %3d %3d\n",\r
+ freeitem,lastused,lastitem,headk,headkmin,Mlwr,Mupr);\r
+ printf(" VIRTUAL ADDRESSES\n");\r
+ l= Mupr-1;\r
+ do\r
+ {\r
+ if (l-18>lastitem) u=l-18;\r
+ else u=lastitem;\r
+ printf(" ah ");\r
+ for (i=l; i>=u; i=i-reflength) printf(" %5d",i);\r
+ printf("\n M[ah] ");\r
+ for (i=l; i>=u; i=i-reflength) printf(" %5d", *i);\r
+ printf("\nM[ah+1]");\r
+ for (i=l; i>=u; i=i-reflength) printf(" %5d",*(i+1));\r
+ printf("\n");\r
+ l=u-reflength;\r
+ }\r
+ while (u!=lastitem);\r
+\r
+ printf(" OBJECTS\n");\r
+ j=0;\r
+ for (i=M0; i<=lastused; ++i)\r
+ {\r
+ printf(" %6d",*i);\r
+ ++j;\r
+ if (j==10){\r
+ printf("\n");\r
+ j=0;\r
+ };\r
+ };\r
+ printf( "\n");\r
+} /* end Memorydump */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Auxiliary function for dumping prototype structures */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+Writedata()\r
+\r
+{\r
+ int i,j;\r
+\r
+ struct Prototype a;\r
+ struct Offsets L;\r
+ int p;\r
+ int q;\r
+ int working;\r
+\r
+ printf("\n PROTOTYPE STRUCTURE\n");\r
+ printf(\r
+ "Nr Kind Lspan Rspan Ref Decl Lev Lstw Sl Dl Lsc Stat Pref Psl \n");\r
+ for (i=0; i<=protnum-1; ++i)\r
+ {\r
+ printf("\n%2d ",i);\r
+ a=PROT[i];\r
+ switch (a.kind)\r
+ {\r
+ case PROCESS:\r
+ printf("proc ");\r
+ break;\r
+ case SUBROUTINE:\r
+ printf("sub ");\r
+ break;\r
+ case COROUTINE:\r
+ printf("cor ");\r
+ break;\r
+ case CLASS:\r
+ printf("class");\r
+ break;\r
+ case HANDLER:\r
+ printf("hand ");\r
+ break;\r
+ default:\r
+ printf("array");\r
+ };\r
+\r
+ printf("%2d ",a.lspan);\r
+ switch(a.kind)\r
+ {\r
+ case CLASS:\r
+ case SUBROUTINE:\r
+ case PROCESS:\r
+ case HANDLER:\r
+ case COROUTINE:\r
+ break;\r
+ default:\r
+ continue;\r
+ };\r
+ printf(" %2d ",a.rspan);\r
+ if (a.references!=-1) printf("%2d ",OFF[a.references].num);\r
+ else printf(" ");\r
+ if (a.decl!=-1) printf("%2d ",PROT[a.decl].num) ;\r
+ else printf(" ");\r
+ printf("%2d ",a.level);\r
+ printf("%2d ",a.lastwill);\r
+ printf("%2d %2d %2d %2d ",\r
+ a.Sloffset,a.Dloffset,a.Statoffset,a.Lscoffset);\r
+ switch (a.kind)\r
+ {\r
+ case HANDLER:\r
+ continue;\r
+ };\r
+ if (a.pref!=-1) printf("%2d ",PROT[a.pref].num) ;\r
+ else printf(" ");\r
+ printf("%2d",a.pslength);\r
+\r
+ };\r
+ printf("\n HANDLERS\n\n handler signals\n");\r
+ for (i=0; i<=protnum-1; ++i)\r
+ {\r
+ a=PROT[i];\r
+ printf("\n%2d ",i);\r
+ switch (a.kind)\r
+ {\r
+ case CLASS:\r
+ case SUBROUTINE:\r
+ case PROCESS:\r
+ case COROUTINE:\r
+ break;\r
+ default:\r
+ continue;\r
+ };\r
+ p=a.handlist;\r
+ while (p>=0)\r
+ {\r
+ printf("%2d ",HL[p].hand);\r
+ q=HL[p].signlist;\r
+ while (q>=0)\r
+ {\r
+ printf("%2d ",SL[q].signalnum);\r
+ q=SL[q].next;\r
+ };\r
+ p=HL[p].next;\r
+ };\r
+ printf("\n");\r
+ };\r
+ printf("\n\n OFFSETS\n");\r
+ for (i=0; i<=offnum-1; ++i)\r
+ {\r
+ L=OFF[i];\r
+ printf(" %2d size %d ",i,L.size);\r
+ switch(L.kind)\r
+ {\r
+ case SIMPLELIST:\r
+ printf(" Listref ");\r
+ working=L.head;\r
+ for (j=1; j<=L.length; ++j)\r
+ {\r
+ printf("%2d ",EL[working].offset);\r
+ if (EL[working].references==1) printf("s ");\r
+ if (EL[working].references==2) printf("p ");\r
+ working=EL[working].next;\r
+ };\r
+ break;\r
+ case SEGMENT:\r
+ printf("Segment ");\r
+ printf("%2d %2d ",L.start,L.finish);\r
+ if (L.head==1) printf(" s ");\r
+ if (L.head==2) printf(" p ");\r
+ break;\r
+ case REPEATED:\r
+ printf("Repeated ");\r
+ printf("%2d %2d ",L.ntimes,OFF[L.references].num);\r
+ break;\r
+ case COMBINEDLIST:\r
+ printf(" List ");\r
+ working=L.head;\r
+ for (j=1; j<=L.length; ++j)\r
+ {\r
+ printf("%2d %2d ",EL[working].offset,\r
+ OFF[EL[working].references].num);\r
+ working=EL[working].next;\r
+ };\r
+ break;\r
+ };\r
+ printf(" \n");\r
+ };\r
+ printf(" \n PERMUTATIONS ");\r
+ printf("\n Prot \tPerm ");\r
+ for (i=0; i<=protnum-1; ++i)\r
+ {\r
+ a=PROT[i];\r
+ switch(a.kind)\r
+ {\r
+ case CLASS:\r
+ case SUBROUTINE:\r
+ case PROCESS:\r
+ case HANDLER:\r
+ case COROUTINE:\r
+ break;\r
+ default:\r
+ continue;\r
+ };\r
+ printf("\n%2d ",i);\r
+ for (j=0; j<=PROT[i].level; ++j)\r
+ printf("%2d ",perm[PROT[i].permadd+j]);\r
+ };\r
+ printf("\n Prot \tPerminv ");\r
+ for (i=0; i<=protnum-1; ++i)\r
+ {\r
+ a=PROT[i];\r
+ switch(a.kind)\r
+ {\r
+ case CLASS:\r
+ case SUBROUTINE:\r
+ case PROCESS:\r
+ case HANDLER:\r
+ case COROUTINE:\r
+ break;\r
+ default:\r
+ continue;\r
+ };\r
+ printf("\n%2d ",i);\r
+ for (j=0; j<=PROT[i].level; ++j)\r
+ printf("%2d ",perminv[PROT[i].permadd+j]);\r
+ };\r
+ printf(" \n");\r
+} /* end writedata */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* The final address of object referenced by X */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+\r
+unsigned int *Physical(X)\r
+unsigned int *X;\r
+{\r
+ if( Notmember(X) )\r
+ Raising(reftonone,vipt2);\r
+ else\r
+ return(Physimple(X));\r
+}\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* Request for a new object: */\r
+/* */\r
+/* (a) Search for a free indirect address item */\r
+/* */\r
+/* (i) if freeitem <>0, then take from list of free addresses */\r
+/* (ii) if freeitem=0, then expand indirect addresses table */\r
+/* (iii)if no space, then compactify the whole memory */\r
+/* (iv) if still no space, then fatal error */\r
+/* */\r
+/* (b) Search for a frame of size defined by length: */\r
+/* */\r
+/* (i) if lastused+length<lastitem, then like in stack */\r
+/* (ii) if no space, then search on the list of killed objects */\r
+/* (iii)if not found, then compactify the whole memory */\r
+/* (iv) if still no space, then fatal error */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+static Request(a,length,X)\r
+int a;\r
+unsigned int *X,length;\r
+\r
+{\r
+ unsigned int *t1,*t2,*t3,*ah,*am,l;\r
+ char wascomp,nfound;\r
+\r
+ if (length >= maxapp)\r
+ Error(8);\r
+\r
+ if (length <= minsize)\r
+ length=minsize;\r
+\r
+ wascomp=0;\r
+\r
+ /* search for a free indirect address */\r
+\r
+ if (freeitem)\r
+ {\r
+ ah=freeitem;\r
+ freeitem= (unsigned int *)*ah;\r
+ }\r
+ else /* extend the indirect address table */\r
+ {\r
+ ah=lastitem-reflength;\r
+ if (ah<=lastused)\r
+ {\r
+ Compactify();\r
+ wascomp=1;\r
+ ah=lastitem-reflength;\r
+ if (ah<=lastused)\r
+ Error(8);\r
+ };\r
+ lastitem=ah;\r
+ *(ah+1)=0;\r
+ };\r
+\r
+ /* search for free frame */\r
+\r
+ t1=lastused+length;\r
+ if (t1<lastused || t1>= lastitem)\r
+ {\r
+ if(length==minsize && headkmin)\r
+ {\r
+ am=headkmin;\r
+ headkmin=(unsigned int *) *(am+shortlink);\r
+ }\r
+ else\r
+ {\r
+ t1=headk;\r
+ nfound=1;\r
+ t2=0;\r
+ while (t1!= Mlwr)\r
+ {\r
+ if (*(t1)==length ||\r
+ *(t1)>(length+minsize) )\r
+ {\r
+ l= *(t1)-length;\r
+ nfound=0;\r
+ break;\r
+ }\r
+ else\r
+ {\r
+ t2=t1;\r
+ t1= (unsigned int *)*(t1+longlink);\r
+ };\r
+ };\r
+ if (nfound)\r
+ {\r
+ if (wascomp) Error(8);\r
+ *ah=(unsigned int) freeitem;\r
+ freeitem=ah;\r
+ Compactify();\r
+ ah=lastitem-reflength;\r
+ lastitem=ah;\r
+ *(ah+1)=0;\r
+ t1=lastused+length;\r
+ if (t1<lastused || t1>=lastitem) Error(8);\r
+ am=lastused+1;\r
+ lastused=t1;\r
+ }\r
+ else\r
+ {\r
+ t3= (unsigned int *) *(t1+shortlink);\r
+ am=t1;\r
+ if (t3)\r
+ *(t3+longlink)= *(t1+longlink);\r
+ else\r
+ t3= (unsigned int *)*(t1+longlink);\r
+ if (t2)\r
+ *(t2+longlink)= (unsigned int) t3;\r
+ else\r
+ headk=t3;\r
+ if (l)\r
+ {\r
+ t3=t1+length;\r
+ *t3=l;\r
+ Insert(t3);\r
+ }\r
+ };\r
+ };\r
+ }\r
+ else\r
+ {\r
+ am=lastused+1;\r
+ lastused=t1;\r
+ };\r
+ *X= (unsigned int)ah;\r
+ *(X+1)= *(ah+1);\r
+ am+=Ptposition(a);\r
+ *am=a;\r
+ *ah= (unsigned int )am;\r
+\r
+} /* end Request */\r
+\r
+\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Dispose the object referenced by X=[ah,counter] */\r
+/* */\r
+/* (a) dispose the indirect address: */\r
+/* (i) advance M[ah+1], i.e. guard_counter */\r
+/* (ii) if guard_counter=-1, then leave it */\r
+/* for compactification of the whole memory */\r
+/* (iii) otherwise put on the list of free addresses */\r
+/* */\r
+/* (b) dispose the frame: */\r
+/* (i) if the frame is bordering free space, increase lastused */\r
+/* (ii) otherwise put it on the list of killed objects */\r
+/* (iii) correct Statussl for procedure closures */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+static Disp (X)\r
+\r
+unsigned int *X;\r
+{\r
+ int a;\r
+ unsigned int *am,*ah;\r
+ unsigned int length;\r
+\r
+ if (Notmember(X)) return;\r
+\r
+ ah= (unsigned int *) *X;\r
+ am= (unsigned int *) *ah;\r
+ if (++(*(ah+1))!=maxcounter)\r
+ {\r
+ *ah=(unsigned int)freeitem;\r
+ freeitem=ah;\r
+ };\r
+ traverse(am,5);\r
+ a= *am;\r
+ length=Size(a,am);\r
+ if (am+length-Ptposition(a)-1==lastused)\r
+ lastused-=length;\r
+ else\r
+ {\r
+ am-=Ptposition(a);\r
+ *am=length;\r
+ Insert(am);\r
+ };\r
+} /* end Disp */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Move virtual address Y on X */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+Refmove(X,Y)\r
+unsigned int *X,*Y;\r
+\r
+{\r
+ *X++ = *Y++;\r
+ *X= *Y;\r
+}\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Move procedure closure address Y on X */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+Procclosmove(X,Y)\r
+unsigned int *X,*Y;\r
+\r
+{ unsigned int *am;\r
+ int a;\r
+\r
+ if ( *X!=0)\r
+ {\r
+ am=Physimple(X);\r
+ a= *am;\r
+ (*Statsl(a,am))--;\r
+ };\r
+ if ( *Y!=0)\r
+ {\r
+ am=Physimple(Y);\r
+ a= *am;\r
+ (*Statsl(a,am))++;\r
+ };\r
+ *X++ = *Y++;\r
+ *X= *Y;\r
+}\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* For Y shortaddress, reconstruct reference on X */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+Refset(X,Y)\r
+unsigned int *X,*Y;\r
+{\r
+ *X= *Y;\r
+ *(X+1)= *((unsigned int *)*X+1);\r
+}\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* X:=none */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+Setnone(X)\r
+unsigned int *X;\r
+\r
+{\r
+ *X++ = (unsigned int)M0;\r
+ *X= 0;\r
+}\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* X=/=Y */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+int Notequal(X,Y)\r
+unsigned int *X,*Y;\r
+\r
+{\r
+ if (Notmember(X)) return(Member(Y));\r
+ else\r
+ if (Notmember(Y))\r
+ return(1);\r
+ else\r
+ return((int)(Physimple(X)-Physimple(Y)));\r
+}\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* X=Y */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+int Equal(X,Y)\r
+unsigned int *X,*Y;\r
+\r
+{\r
+ return(! Notequal(X,Y));\r
+}\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Insert the frame pointed by am on the list of killed objects */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+static Insert(am)\r
+unsigned int *am;\r
+{\r
+ unsigned int *t1,*t2;\r
+ unsigned int l,k;\r
+\r
+ l= *am;\r
+ if (l==minsize)\r
+ {\r
+ *(am+shortlink)=(unsigned int)headkmin;\r
+ headkmin=am;\r
+ }\r
+ else\r
+ {\r
+ t1=headk;\r
+ t2=0;\r
+ while (1)\r
+ {\r
+ k= *t1;\r
+ if (l==k)\r
+ {\r
+ *(am+shortlink)= *(t1+shortlink);\r
+ *(t1+shortlink)= (unsigned int)am;\r
+ break;\r
+ }\r
+ else\r
+ if (l<k)\r
+ {\r
+ *(am+longlink)= (unsigned int)t1;\r
+ *(am+shortlink)=0;\r
+ if(t2) *(t2+longlink)=(unsigned int)am;\r
+ else headk=am;\r
+ break;\r
+ }\r
+ else\r
+ {\r
+ t2=t1;\r
+ t1=(unsigned int *) *(t1+longlink);\r
+ };\r
+ };\r
+ };\r
+} /* end Insert */\r
+\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Purge the Sl-chain of an object referenced by vipt3 */\r
+/* */\r
+/* (i) if Statussl=0 and it is procedure instance, dispose it */\r
+/* (ii) otherwise goto end */\r
+/* (iv) put vipt3 = Sl father of vipt3, and goto (i) */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+\r
+static Killer ()\r
+{\r
+ unsigned int *am;\r
+ int a;\r
+\r
+ while (1)\r
+ {\r
+ am=Physimple(vipt3);\r
+ a= *am;\r
+ if ( *Statsl(a,am)) return;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case SUBROUTINE:\r
+ break;\r
+ default:\r
+ return;\r
+ };\r
+ if ( Physimple(vipt3)!=Physimple(Dl(a,am))) return;\r
+ Refset(vipt2,Sl(a,am));\r
+ Disp(vipt3);\r
+ Refmove(vipt3,vipt2);\r
+ };\r
+} /* end of killer */\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Purge memory after procedure instance termination */\r
+/* */\r
+/* (i) if Statussl<>0, nothing can be deallocated */\r
+/* (ii) otherwise dispose the object, put on vipt3 its Sl father */\r
+/* and call Killer, which purges Sl-chain */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+\r
+Killafter()\r
+{\r
+ unsigned int *am;\r
+ int a;\r
+\r
+ am=Physimple(vipt2);\r
+ a= *am;\r
+ if ( *Statsl(a,am)) return;\r
+ Refset(vipt3,Sl(a,am));\r
+ Disp(vipt2);\r
+ Killer();\r
+}\r
+\r
+\r
+\r
+/************************************************************************/\r
+/* */\r
+/* */\r
+/* Compactifier - the play in 9 acts (Oh My God!!!) */\r
+/* */\r
+/* It's like an ancient tragedy with prolog, epilogue, */\r
+/* chorus singing in some entr'acts, deus ex machina etc. */\r
+/* */\r
+/* */\r
+/************************************************************************/\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* Procedure traverse is a Deus ex machina */\r
+/* (helps to solve dramatic problems in many moments): */\r
+/* */\r
+/* short trip through the object pointed by am with action */\r
+/* performed for each reference */\r
+/* (uses procedures pointed and correct) */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static traverse (am,action)\r
+unsigned int *am;\r
+char action;\r
+{\r
+ int a, L;\r
+ unsigned int *t;\r
+\r
+ if ((int) *am >= 0) a= *am;\r
+ else a= *am+protnum1;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case PRIMITARRAY :\r
+ return;\r
+ case REFARRAY :\r
+ for (t= am+elmoffset;t<=am+Size(a,am)-1;t+=reflength)\r
+ correct(t,action,0);\r
+ return;\r
+ case SUBARRAY :\r
+ for (t= am+elmoffset;t<=am+Size(a,am)-1;t+=reflength)\r
+ correct(t,action,2);\r
+ return;\r
+ case STRUCTARRAY :\r
+ L=PROT[a].references;\r
+ for (t= am+elmoffset;t<=am+Size(a,am)-1;t+=OFF[L].size)\r
+ pointed(t,L,action);\r
+ return;\r
+ case POINTARRAY :\r
+ for (t= am+elmoffset;t<=am+Size(a,am)-1; t++)\r
+ correct(t,action,1);\r
+ return;\r
+ default :\r
+ L=PROT[a].references;\r
+ pointed(am,L,action);\r
+ };\r
+} /* end traverse */\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* correct all references defined by the structure of offsets L */\r
+/* according to action, in the subframe starting with acron */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static pointed (acron,L,action)\r
+unsigned int *acron;\r
+char L;\r
+char action; /* 1 nonefy,2 relocate,3 mark,4 Setnone,5 decstatussl */\r
+{\r
+ int i,k,working,ref;\r
+\r
+ if (L==-1) return;\r
+ switch (OFF[L].kind)\r
+ {\r
+ case SIMPLELIST:\r
+ working=OFF[L].head;\r
+ for (i=1; i<=OFF[L].length; ++i)\r
+ {\r
+ k=EL[working].offset;\r
+ correct(acron+k,action,EL[working].references);\r
+ working=EL[working].next;\r
+ };\r
+ return;\r
+ case SEGMENT:\r
+ switch(OFF[L].head)\r
+ {case 0:\r
+ for (k=OFF[L].start;k<=OFF[L].finish;k+=reflength)\r
+ correct(acron+k,action,0);\r
+ break;\r
+ case 1:\r
+ for (k=OFF[L].start;k<=OFF[L].finish;++k)\r
+ correct(acron+k,action,1);\r
+ break;\r
+ case 2:\r
+ for (k=OFF[L].start;k<=OFF[L].finish;k+=reflength)\r
+ correct(acron+k,action,2);\r
+ break;\r
+ };\r
+\r
+ return;\r
+ case REPEATED:\r
+ for (i=1;i<=OFF[L].ntimes;++i)\r
+ {\r
+ pointed(acron,OFF[L].references,action);\r
+ acron+=OFF[L].size;\r
+ };\r
+ return;\r
+ case COMBINEDLIST:\r
+ working=OFF[L].head;\r
+ for (i=1;i<=OFF[L].length;++i)\r
+ {\r
+ k=EL[working].offset;\r
+ ref=EL[working].references;\r
+ pointed(acron+k,ref,action);\r
+ working=EL[working].next;\r
+ };\r
+ return;\r
+ };\r
+} /* end pointed */\r
+\r
+\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* correct one reference pointed by am according to action */\r
+/* (for long references it is different than for the short ones) */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static correct (am,action,reftype)\r
+unsigned int *am;\r
+char reftype; /* 0-fulladdress, 1-shortaddress, 2-procedure closure */\r
+char action;\r
+{ int a;\r
+\r
+ switch (action)\r
+ {\r
+ case 1:\r
+ if (reftype==0) nonefy(am); return;\r
+ case 2:\r
+ if (reftype==0) relocate(am); else relocs(am);\r
+ return;\r
+ case 3:\r
+ if (reftype==0) mark(am); else marks(am);\r
+ return;\r
+ case 4:\r
+ if (reftype==0) Setnone(am); else *am=0;\r
+ return;\r
+ case 5:\r
+ if (reftype==2)\r
+ {\r
+ if ( *am==0) return;\r
+ am=Physimple(am);\r
+ a= *am;\r
+ if (a < 0) a+=protnum1;\r
+ (*Statsl(a,am))--;\r
+ };\r
+ return;\r
+ };\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Two auxiliary procedures mark and marks are called by traverse */\r
+/* in prologue. They help to visit all accessible objects from an */\r
+/* active one. Each accessible object is marked by changing its */\r
+/* basic item M[am](=prototype number) on a negative value. Mark */\r
+/* passes through full references [ah,counter],while marks passes */\r
+/* through simplified references [ah]. */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+\r
+static mark (am)\r
+unsigned int *am;\r
+{\r
+ if (Notmember(am)) return;\r
+ am=Physimple(am);\r
+ if ((int) *am >=0)\r
+ {\r
+ *am -= protnum1 ;\r
+ traverse(am,3);\r
+ };\r
+}\r
+\r
+\r
+\r
+static marks (am)\r
+unsigned int *am;\r
+{\r
+\r
+ if (*am==0) return;\r
+ am=Physimple(am);\r
+ if ((int)*am >=0)\r
+ {\r
+ *am -= protnum1;\r
+ traverse(am,3);\r
+ };\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Prologue: */\r
+/* marking of all accessible objects */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+static prologue ()\r
+{\r
+ unsigned int *am;\r
+\r
+ am=Physimple(current);\r
+ *am -= protnum1;\r
+ traverse(am,3);\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Chorus song No 1: */\r
+/* for each free address change its guard counter on max */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+static chorus_song_1 ()\r
+{\r
+ unsigned int *t;\r
+\r
+ t=freeitem;\r
+ while (t) {\r
+ *(t+1)=maxcounter;\r
+ t= (unsigned int *) *t;\r
+ };\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Act No 1: */\r
+/* for each not-killed object recognize those which */\r
+/* will be deallocated because are not accessible; */\r
+/* knowing that these objects will be deallocated */\r
+/* correct the corresponding Statussl items. */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+static act1 ()\r
+{\r
+ unsigned int *t1,*t2;\r
+ int a;\r
+\r
+ for (t2= lastitem;t2<= Mupr;t2+=reflength)\r
+ {\r
+ if(*(t2+1)==maxcounter) continue;\r
+ t1= (unsigned int *) *t2;\r
+ if ((int) *t1 >=0) traverse(t1,5);\r
+ };\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Act No 2: */\r
+/* each non-accesible object put on the list of killed */\r
+/* objects; for each accessible object put on M[am] ah */\r
+/* in order to be able in act4 to compute on M[ah] */\r
+/* updated am (Attention! for Ptposition=0,special case) */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+\r
+static act2 ()\r
+{\r
+ unsigned int *t1,*t2,*t3,l;\r
+ int a;\r
+\r
+ for (t1=lastitem;t1<= Mupr;t1+=reflength)\r
+ {\r
+ if (*(t1+1)==maxcounter) continue;\r
+ t2= (unsigned int *) *t1;\r
+ if ((int) *t2<0) *t2 += protnum1;\r
+ else\r
+ {\r
+ *(t1+1)=maxcounter;\r
+ a= *t2;\r
+ l=Size(a,t2);\r
+ t2-=Ptposition(a);\r
+ *t2=l;\r
+ Insert(t2);\r
+ continue;\r
+ };\r
+ a= *t2;\r
+ if (Ptposition(a))\r
+ {\r
+ t3=t2-Ptposition(a);\r
+ *t1= *t3;\r
+ *t3= *t2;\r
+ *t2= (unsigned int)t1;\r
+ }\r
+ else\r
+ {\r
+ *t1= *(t2+1);\r
+ *(t2+1)= (unsigned int) t1;\r
+ };\r
+ };\r
+} /* end act2 */\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Chorus song No 2: */\r
+/* marking of all killed objects */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+#define skilled (-1) /* marking for killed object */\r
+\r
+static chorus_song_2 ()\r
+{\r
+ unsigned int *t1,*t2,*t3;\r
+\r
+ t1=headkmin;\r
+ while (t1)\r
+ {\r
+ t2=(unsigned int *) *(t1+shortlink);\r
+ *(t1+shortlink)=minsize;\r
+ *t1=skilled;\r
+ t1=t2;\r
+ };\r
+ t1=headk;\r
+ while (t1!= Mlwr)\r
+ {\r
+ t2=t1;\r
+ while (t2)\r
+ {\r
+ t3= (unsigned int *)*(t2+shortlink);\r
+ *(t2+shortlink)= *t2;\r
+ *t2=skilled;\r
+ t2=t3;\r
+ };\r
+ t1= (unsigned int *) *(t1+longlink);\r
+ };\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Auxiliary procedure nonefy called by traverse. It sets to none */\r
+/* [M0,0] each reference which points no object. */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static nonefy (am)\r
+unsigned int *am;\r
+{\r
+ if ( Notmember(am)) Setnone(am);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Act No 3: */\r
+/* traverse memory and for all alive objects set to [M0,0] */\r
+/* each reference pointing no object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static act3 ()\r
+{\r
+ unsigned int *t1,*t2,*t3,l;\r
+ int a;\r
+\r
+ t1= Mlwr+1;\r
+ while (t1<=lastused)\r
+ {\r
+ if ( *t1!=skilled)\r
+ {\r
+ a= *t1;\r
+ if (Ptposition(a))\r
+ {\r
+ t2=t1+Ptposition(a);\r
+ t3= (unsigned int *)*t2;\r
+ *t1= *t3;\r
+ *t2= a;\r
+ }\r
+ else\r
+ {\r
+ t3= (unsigned int *) *(t1+1);\r
+ *(t1+1)= *t3;\r
+ t2=t1;\r
+ };\r
+ l=Size(a,t2);\r
+ traverse(t2,1);\r
+ if (Ptposition(a))\r
+ {\r
+ *t2= (unsigned int) t3;\r
+ *t1= a;\r
+ }\r
+ else\r
+ *(t1+1)= (unsigned int)t3;\r
+ t1+=l;\r
+ }\r
+ else\r
+ t1+= *(t1+shortlink);\r
+ };\r
+ for (t1=vipt1; t1<=viptn; t1+=reflength) nonefy(t1);\r
+} /* end act3 */\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Chorus song No 3: */\r
+/* compute new values of indirect addresses and put them */\r
+/* on guard counters; this enables to update references */\r
+/* during memory squeezing; now M[ah+1]= future ah */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static chorus_song_3()\r
+{\r
+ unsigned int *t1,*t2;\r
+\r
+ t1= Mupr-1;\r
+ for ( t2= Mupr; t2>= lastitem; t2-=reflength)\r
+ {\r
+ if (*t2==maxcounter) *t2= (unsigned int)M0;\r
+ else\r
+ {\r
+ *t2= (unsigned int)t1;\r
+ t1-=reflength;\r
+ };\r
+ };\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Two auxiliary procedures relocate and relocs are used in act4. */\r
+/* They update for each reference its ah taking a new one from */\r
+/* M[ah+1] computed in chorus song No 3. Procedure relocates is */\r
+/* applied for full references, procedure relocs for simplified. */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static relocate(am)\r
+unsigned int *am;\r
+{\r
+ *am= *( (unsigned int *)*am+1);\r
+ *(am+1)=0;\r
+}\r
+\r
+static relocs(am)\r
+unsigned int *am;\r
+{\r
+ if (*am==0) return;\r
+ *am= *( (unsigned int *)*am+1);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Act No 4: */\r
+/* squeeze memory; for all alive objects update all */\r
+/* references using traverse with relocate and relocs; */\r
+/* simultaneously update M[ah] with a new value of am */\r
+/* obtained after squeezing memory; reconstruct also */\r
+/* the value of M[am] changed in act2. */\r
+/* */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+static act4()\r
+{\r
+ unsigned int *t1,*t2,*t3,*t4,*t5,l,k;\r
+ int a;\r
+\r
+ t1= Mlwr+1;\r
+ t2=t1;\r
+ while (t1<=lastused)\r
+ {\r
+ if (*t1==skilled) t1+= *(t1+shortlink);\r
+ else\r
+ {\r
+ t5=(unsigned int *) *t1;\r
+ a=(int)t5;\r
+ t3=t1+Ptposition(a);\r
+ if (Ptposition(a))\r
+ {\r
+ t4= (unsigned int *)*t3;\r
+ *t3=(unsigned int)t5;\r
+ *t1= *t4;\r
+ }\r
+ else\r
+ {\r
+ t4= (unsigned int *)*(t1+1);\r
+ *(t1+1)= *t4;\r
+ };\r
+ l=Size(a,t3);\r
+ t3=t2;\r
+ for (k=1;k<=l;++k)\r
+ *t3++= *t1++;\r
+ t5=t2+Ptposition(a);\r
+ *t4= (unsigned int)t5;\r
+ traverse(t5,2);\r
+ t2+=l;\r
+ };\r
+ };\r
+ for (t1=vipt1;t1<=viptn; t1+=reflength) relocate(t1);\r
+ lastused=t2-1;\r
+ headkmin=0;\r
+ headk= Mlwr;\r
+} /* end act4 */\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Epilogue: */\r
+/* squeeze the indirect address table;update also some */\r
+/* Running System variables. */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+static epilogue () /* update virtual addresses */\r
+{\r
+ unsigned int *t1,*t2,*t3;\r
+\r
+ t1= Mupr+1;\r
+ for ( t3= Mupr-1; t3>=lastitem; t3-=reflength)\r
+ {\r
+ t2= (unsigned int *)*(t3+1);\r
+ if (t2!=M0)\r
+ {\r
+ *t2= *t3;\r
+ *(t2+1)=0;\r
+ t1=t2;\r
+ };\r
+ };\r
+ lastitem=t1;\r
+ freeitem=0;\r
+ Update(current); /* update DISPDIR */\r
+ local=Physimple(current); /* update local register */\r
+}\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Compactify (call prepared procedures) */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+Compactify ()\r
+{\r
+ int nlength;\r
+ nlength=lastitem-lastused;\r
+ prologue();\r
+ chorus_song_1();\r
+ act1();\r
+ act2();\r
+ chorus_song_2();\r
+ act3();\r
+ chorus_song_3();\r
+ act4();\r
+ epilogue();\r
+ printf("\n Compactifier used; released space=%d\n",\r
+ lastitem-lastused-nlength);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Errors at run-time are handled by Error(n), where n is */\r
+/* the error number. */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+static Error(n)\r
+char n;\r
+\r
+{\r
+ switch (n)\r
+ {\r
+\r
+ case 1:\r
+ printf("\nReference to none\n");\r
+ longjmp(buffer,-2);\r
+ case 2:\r
+ printf("\nIllegal attach\n");\r
+ longjmp(buffer,-2);\r
+ case 3:\r
+ printf("\nCoroutine terminated\n");\r
+ longjmp(buffer,-2);\r
+ case 4:\r
+ printf("\nImproper coroutine end\n");\r
+ longjmp(buffer,-2);\r
+ case 5:\r
+ printf("\nIncorrect kill\n");\r
+ longjmp(buffer,-2);\r
+ case 6:\r
+ printf("\nArray index error\n");\r
+ longjmp(buffer,-2);\r
+ case 7:\r
+ printf("\nIllegal array generation\n");\r
+ longjmp(buffer,-2);\r
+ case 8:\r
+ printf("\nMemory overflow\n");\r
+ longjmp(buffer,-2);\r
+ case 9:\r
+ printf("\nend of a program execution\n");\r
+ longjmp(buffer,-2);\r
+ case 10:\r
+ printf("\nhandler not found\n");\r
+ longjmp(buffer,-2);\r
+ };\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Openrc: */\r
+/* opens a new object of a class without system attributes */\r
+/* a - prototype number, */\r
+/* X - reference to the opened object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Openrc (a,X)\r
+int a;\r
+unsigned int *X;\r
+\r
+{\r
+ unsigned int *am;\r
+\r
+ Request(a,Size(a,0),X);\r
+ am=Physimple(X);\r
+ traverse(am,4);\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Slopen: */\r
+/* opens a new object of with explicitly given Sl-father */\r
+/* a - prototype number, */\r
+/* X - reference to the opened object */\r
+/* Y - reference to its Sl-father */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+\r
+Slopen (a,X,Y)\r
+\r
+unsigned int *X,*Y;\r
+int a;\r
+\r
+{\r
+ unsigned int *am,*Slr,*Dlr;\r
+\r
+ Request(a,Size(a,0),X);\r
+ am=Physimple(X);\r
+ traverse(am,4);\r
+ *Statsl(a,am)=0;\r
+ Slr=Sl(a,am);\r
+ *Slr= *Y;\r
+ Dlr=Dl(a,am);\r
+ *Dlr= *current;\r
+ am=Physimple(Y);\r
+ a= *am;\r
+ (*Statsl(a,am))++;\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Dopen: */\r
+/* opens a new object of a visible module */\r
+/* a - prototype number, */\r
+/* b - prototype number of a's static father */\r
+/* X - reference to the opened object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Dopen(a,b,X)\r
+\r
+int a,b;\r
+unsigned int *X;\r
+\r
+{\r
+ int c;\r
+\r
+ c=PROT[a].decl;\r
+ Slopen(a,X,DISPLAY+reflength*perm[PROT[b].permadd+PROT[c].level]);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Openarray: */\r
+/* opens a new array */\r
+/* a - prototype number, */\r
+/* l - lower bound */\r
+/* u - upper bound */\r
+/* X - reference to the opened object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Openarray (a,l,u,X)\r
+\r
+int l,u;\r
+int a;\r
+unsigned int *X;\r
+\r
+{\r
+ unsigned int length;\r
+ unsigned int *am;\r
+\r
+ if (u<l) Raising(illarray,vipt2);\r
+ length=u-l+1;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case PRIMITARRAY :\r
+ length=length*PROT[a].elsize ;\r
+ break;\r
+ case REFARRAY :\r
+ case SUBARRAY :\r
+ length=length*reflength;\r
+ break;\r
+ case STRUCTARRAY :\r
+ length=length*(OFF[PROT[a].references].size);\r
+ break;\r
+ case POINTARRAY :\r
+ break;\r
+ };\r
+ length+=elmoffset;\r
+ Request(a,length,X);\r
+ am=Physimple(X);\r
+ *(am+lboffset)=l;\r
+ *(am+uboffset)=u;\r
+ traverse(am,4);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Go: */\r
+/* calls an object X */\r
+/* X - reference to the object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Go (X)\r
+unsigned int *X;\r
+\r
+{\r
+ int a,b;\r
+\r
+ a= *local;\r
+ *(Lsc(a,local))=IC*protnum1+modulenumber;\r
+ Update(X);\r
+ Refmove(current,X);\r
+ local=Physimple(X);\r
+ a= *local;\r
+ b=a;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case HANDLER:\r
+ break;\r
+ default:\r
+ while (a >=0)\r
+ {\r
+ switch (PROT[a].kind)\r
+ {\r
+ case RECORD:\r
+ break;\r
+ default:\r
+ b=a;\r
+ };\r
+ a=PROT[a].pref;\r
+ };\r
+ };\r
+ IC=1;\r
+ modulenumber=b;\r
+ longjmp(buffer,-1);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Back: */\r
+/* explicit return statement */\r
+/* used also in end of unprefixed subprogram or block */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+Back ()\r
+{\r
+ unsigned int *Dlr;\r
+ int a;\r
+\r
+ a= *local;\r
+ Dlr=Dl(a,local);\r
+ if (*Dlr==0) Endcor();\r
+ Refmove(vipt2,current);\r
+ *Lsc(a,local)=IC*protnum1+modulenumber;\r
+ Refset(current,Dlr);\r
+ *Dlr= *vipt2;\r
+ Update(current);\r
+ local=Physimple(current);\r
+ a= *local;\r
+ IC= *Lsc(a,local);\r
+ modulenumber=IC%protnum1;\r
+ IC=IC/protnum1;\r
+ longjmp(buffer,-1);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Endclass: */\r
+/* end of class statement */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Endclass ()\r
+{\r
+ int a;\r
+\r
+ a= *local;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case CLASS:\r
+ case SUBROUTINE: Back(); break;\r
+ case COROUTINE: Endcor(); break;\r
+ };\r
+}\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Inner: */\r
+/* passes control to a subclass */\r
+/* k - class level in the inheritance sequence */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Inn(k)\r
+int k;\r
+{\r
+ int t,a;\r
+\r
+ a= *local;\r
+ if (PROT[a].pslength==k) return;\r
+ for (t=2; t<=PROT[a].pslength-k; ++t) a=PROT[a].pref;\r
+ IC=1;\r
+ modulenumber=a;\r
+ longjmp(buffer,-1);\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Endrun: */\r
+/* end of computations */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+Endrun ()\r
+{\r
+ Error(9);\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Update: */\r
+/* update display algorithm; no way to explain how it */\r
+/* works without a special theoretical background. */\r
+/* X - reference to an object which will be active */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+static Update (X)\r
+unsigned int *X;\r
+\r
+{\r
+ int a,c,d,j,k,permadd,l;\r
+ unsigned int *am;\r
+\r
+ am=Physimple(X);\r
+ a= *am;\r
+ k=PROT[a].level;\r
+ d=a;\r
+ permadd=PROT[a].permadd;\r
+ while(1)\r
+ {\r
+ l=perm[permadd+k];\r
+ Refset(DISPLAY+reflength*l,X);\r
+ *(DISPDIR+l)= (unsigned int )am;\r
+ if (k--==0) return;\r
+ j=perminv[PROT[a].permadd+perm[PROT[d].permadd+k]];\r
+ d=PROT[d].decl;\r
+ do\r
+ {\r
+ c=PROT[a].decl;\r
+ X=Sl(a,am);\r
+ am=Physimple(X);\r
+ a= *am;\r
+ j=perminv[PROT[a].permadd+perm[PROT[c].permadd+j]];\r
+ }\r
+ while (PROT[a].level-j);\r
+ };\r
+} /* end of update */\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Gkill: */\r
+/* deallocates a class, an array or a coroutine object */\r
+/* for coroutines deallocates the whole cycle */\r
+/* X - reference to the object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Gkill(X)\r
+unsigned int *X;\r
+{\r
+ unsigned int *am,*Dlr;\r
+ int a;\r
+\r
+ if (Notmember(X) ) return;\r
+ am=Physimple(X);\r
+ a= *am;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case PRIMITARRAY:\r
+ case REFARRAY:\r
+ case SUBARRAY:\r
+ case STRUCTARRAY:\r
+ case POINTARRAY:\r
+ case RECORD:\r
+ Disp(X);\r
+ return;\r
+ case CLASS:\r
+ if ( *Statsl(a,am)) Raising(incorkill,vipt2);\r
+ Refset(vipt3,Sl(a,am));\r
+ Disp(X);\r
+ Killer();\r
+ return;\r
+ case COROUTINE:\r
+ case PROCESS:\r
+ Dlr=X;\r
+ while (1)\r
+ {\r
+ Refset(vipt4,Dlr);\r
+ if ( *Statsl(a,am)) Raising(incorkill,vipt2);\r
+ Dlr=Dl(a,am);\r
+ if (Physimple(X)==Physimple(Dlr)) break;\r
+ am=Physimple(Dlr);\r
+ a= *am;\r
+ };\r
+\r
+ Refmove(vipt2,X);\r
+ do\r
+ {\r
+ am=Physimple(vipt2);\r
+ a= *am;\r
+ Dlr=Dl(a,am);\r
+ Refset(vipt3,Dlr);\r
+ *Dlr= *vipt4;\r
+ Refmove(vipt4,vipt2);\r
+ Refmove(vipt2,vipt3);\r
+ }\r
+ while (Notequal(vipt2,X));\r
+ do\r
+ {\r
+ am=Physimple(X);\r
+ a= *am;\r
+ Refset(vipt3,Sl(a,am));\r
+ Refset(vipt4,Dl(a,am));\r
+ Disp(X);\r
+ Killer ();\r
+ Refmove(X,vipt4);\r
+ }\r
+ while (Member(X));\r
+ return;\r
+ default:\r
+ Raising(incorkill,vipt2);\r
+ };\r
+} /* end Gkill */\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Endcor: */\r
+/* end of coroutine; it is different than return; */\r
+/* treated as an error */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+\r
+Endcor ()\r
+{\r
+\r
+ if (Member(lastcor))\r
+ {\r
+ Attachwith(lastcor,imprterm,vipt2);\r
+ IC=0;\r
+ Attach(lastcor);\r
+ }\r
+ else\r
+ {\r
+ Attachwith(myprocess,imprterm,vipt2);\r
+ IC=0;\r
+ Attach(myprocess);\r
+ };\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Atthelp: */\r
+/* auxiliary for Attach and Attachwith */\r
+/* X - reference to a coroutine */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+static Atthelp(X)\r
+unsigned int *X;\r
+{\r
+ unsigned int *amnew,*amold,*Dlr;\r
+ int a,b;\r
+\r
+ if ( Notmember(X)) Raising(ilattach,vipt2);\r
+ amnew=Physimple(X);\r
+ a= *amnew;\r
+ switch(PROT[a].kind)\r
+ {\r
+ case COROUTINE:\r
+ case PROCESS :\r
+ break;\r
+ default:\r
+ Raising(ilattach,vipt2);\r
+ };\r
+ if ( *Lsc(a,amnew)<protnum1) Raising(corterm,vipt2);\r
+ if (Equal(mycoroutine,X)) return;\r
+ Refmove(vipt2,mycoroutine);\r
+ amold=Physimple(mycoroutine);\r
+ b= *amold;\r
+ Dlr=Dl(b,amold);\r
+ Refmove(mycoroutine,X);\r
+ *Dlr= *current;\r
+ Refmove(lastcor,vipt2);\r
+ b=a;\r
+ Dlr=Dl(b,amnew);\r
+ a= *local;\r
+ *Lsc(a,local)=IC*protnum1+modulenumber;\r
+ Update(Dlr);\r
+ Refset(current,Dlr);\r
+ *Dlr=0;\r
+ local=Physimple(current);\r
+ a= *local;\r
+ IC= *Lsc(a,local);\r
+} /*end Atthhelp */\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Attach: */\r
+/* attaches coroutine X */\r
+/* X - reference to a coroutine */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+Attach(X)\r
+unsigned int *X;\r
+{\r
+ Atthelp(X);\r
+ modulenumber=IC%protnum1;\r
+ IC=IC/protnum1;\r
+ longjmp(buffer,-1);\r
+}\r
+\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Raising: */\r
+/* raises a signal */\r
+/* signalnum- signal number, */\r
+/* X - reference to the opened object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+Raising(signalnum,X)\r
+int signalnum;\r
+unsigned int *X;\r
+{\r
+ unsigned int *am,*Y;\r
+ int a,b,h,s;\r
+\r
+ Y=current;\r
+ while (*Y!=0)\r
+ {\r
+ am=Physimple(Y);\r
+ a= *am;\r
+ switch (PROT[a].kind)\r
+ {\r
+ case HANDLER:\r
+ Y=Sl(a,am);\r
+ continue;\r
+ };\r
+ b=a;\r
+ while (b>=0)\r
+ {\r
+ h=PROT[b].handlist;\r
+ while (h>=0)\r
+ {\r
+ if (PROT[HL[h].hand].others &&\r
+ signalnum<=syssigl)\r
+ {\r
+ Slopen(HL[h].hand,X,Y);\r
+ return;\r
+ };\r
+ s=HL[h].signlist;\r
+ while (s>=0)\r
+ {\r
+ if (SL[s].signalnum==signalnum)\r
+ {\r
+ Slopen(HL[h].hand,X,Y);\r
+ return;\r
+ };\r
+ s=SL[s].next;\r
+ };\r
+ h=HL[h].next;\r
+ };\r
+ b=PROT[b].pref;\r
+ };\r
+ Y=Dl(a,am);\r
+ };\r
+ if (signalnum<=syssigl)\r
+ Error(signalnum);\r
+ else Error(10); /* handler not found */\r
+} /* end Raising */\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Attachwith: */\r
+/* raises a signal in another coroutine */\r
+/* signalnum - signal number, */\r
+/* X - reference to the coroutine */\r
+/* Y - reference to the opened object */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+Attachwith(X,signalnum,Y)\r
+unsigned int *X,*Y;\r
+int signalnum;\r
+\r
+{\r
+\r
+ Refmove(vipt3,mycoroutine);\r
+ Atthelp(X);\r
+ Raising(signalnum,Y);\r
+ IC=1;\r
+ Refmove(current,Y);\r
+ local=Physimple(current);\r
+ Atthelp(vipt3);\r
+}\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Termination: */\r
+/* terminates an active dynamic chain */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+Termination ()\r
+{\r
+ unsigned int *X,*Y,*am;\r
+ int a,b;\r
+\r
+ a= *local;\r
+ X=Sl(a,local);\r
+ Y=Dl(a,local);\r
+ am=Physimple(X);\r
+ while (1)\r
+ {\r
+ Y=Physimple(Y);\r
+ b= *Y;\r
+ *Lsc(b,Y)=PROT[b].lastwill*protnum1+b;\r
+ if (Y==am) return;\r
+ Y=Dl(b,Y);\r
+ };\r
+}\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Init: */\r
+/* initialize all RS data */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+\r
+Init ()\r
+{\r
+\r
+ protnum1=protnum+1;\r
+ M0= &M[0];\r
+ M[0]=0;\r
+ M[1]= (unsigned int) M0;\r
+ vipt1= &M[virt1];\r
+ vipt2= &M[virt2];\r
+ vipt3= &M[virt3];\r
+ viptn=vipt4= &M[virt4];\r
+ myprocess= vipt1;\r
+ freeitem= 0;\r
+ Mlwr= &M[lwr];\r
+ Mupr= &M[upr];\r
+ lastused=Mlwr;\r
+ headk=Mlwr;\r
+ headkmin=0;\r
+ lastitem= Mupr+1;\r
+ M[lwr]=maxapp;\r
+ Request(0,Size(0,0),vipt1);\r
+ global=local=Physimple(vipt1);\r
+ *Statsl(0,local)=0;\r
+ traverse(local,4);\r
+ DISPLAY= local+displ;\r
+ current= local+curr;\r
+ Refmove(current,vipt1);\r
+ Refmove(DISPLAY,current);\r
+ DISPDIR= local +displdir;\r
+ *DISPDIR = (unsigned int) local;\r
+ lastcor= local+lstcor;\r
+ mycoroutine= local+chead;\r
+ Refmove(mycoroutine,current);\r
+}\r
+\r
+\r
+\r
+\r
+\r
+/*----------------------------------------------------------------------*/\r
+/* */\r
+/* Arrayelem: */\r
+/* compute final address of an array element */\r
+/* X - reference to the array object */\r
+/* i - element index */\r
+/* */\r
+/*----------------------------------------------------------------------*/\r
+\r
+\r
+unsigned int *Arrayelem (X,i)\r
+unsigned int *X;\r
+int i;\r
+{\r
+ int a;\r
+ unsigned int *am,length;\r
+\r
+ am=Physical(X);\r
+ a= *am;\r
+ if (i> (int) *(am+uboffset)) Raising(arrayind,vipt2);\r
+ i-= (int) *(am+lboffset);\r
+ if (i<0) Raising(arrayind,vipt2);\r
+ switch (PROT[a].kind)\r
+ {\r
+ case PRIMITARRAY:\r
+ length=PROT[a].elsize;\r
+ break;\r
+ case REFARRAY:\r
+ case SUBARRAY:\r
+ length=reflength;\r
+ break;\r
+ case STRUCTARRAY:\r
+ length=OFF[PROT[a].references].size;\r
+ break;\r
+ case POINTARRAY:\r
+ length=1;\r
+ break;\r
+ };\r
+ am+=elmoffset+length*i;\r
+ return(am);\r
+}\r
+\r
+\r
+\1a\r
+#include <setjmp.h>\r
+ /* on-line functions */\r
+\r
+\r
+#define Physimple(X) (unsigned int *)(* ((unsigned int *) *X))\r
+#define Notmember(X) ( *(X+1)!= *((unsigned int *)*X+1) )\r
+#define Member(X) ( *(X+1)== *((unsigned int *)*X+1) )\r
+\r
+#define Address(dnum,off) ((unsigned int *)*(DISPDIR+dnum)+off)\r
+#define Local(off) (local+off)\r
+#define Global(off) (global+off)\r
+#define Fladdress(dnum,off) (float *) ((unsigned int *)*(DISPDIR+dnum)+off)\r
+#define Fllocal(off) (float *)(local+off)\r
+#define Flglobal(off) (float *)(global+off)\r
+\r
+\r
+ /* repeated headings */\r
+\r
+unsigned int * Arrayelem();\r
+unsigned int * Physical();\r
+\r
+\r
+ /* global common variables */\r
+\r
+\r
+ /* constants for standard signals */\r
+\r
+\r
+#define syssigl 100\r
+#define reftonone 1\r
+#define ilattach 2\r
+#define corterm 3\r
+#define imprterm 4\r
+#define incorkill 5\r
+#define arrayind 6\r
+#define illarray 7\r
+\r
+\r
+ /* common structures */\r
+\r
+ enum { CLASS,SUBROUTINE,PROCESS,COROUTINE,HANDLER,RECORD,\r
+ PRIMITARRAY,REFARRAY,SUBARRAY,STRUCTARRAY,POINTARRAY};\r
+\r
+struct Prototype\r
+\r
+{\r
+ int kind; /* prototype kind */\r
+ int num; /* numer of prototype */\r
+ int lspan,rspan; /* lspan for arrays = elsize */\r
+ int references; /* address of reference structure */\r
+ int decl,level; /* sl-father and depth in sl-tree */\r
+ int lastwill; /* label for lastwill statements */\r
+ int permadd; /* address of permutations */\r
+ int Sloffset,Dloffset; /* offsets of */\r
+ int Statoffset,Lscoffset; /* system attributes */\r
+ int handlist; /* handlerlist for handlers=others */\r
+ int pref,pslength; /* address of pref father, prefix */\r
+ /* sequence length, both */\r
+ /* for handlers not existant */\r
+\r
+};\r
+\r
+#define elsize lspan\r
+#define others handlist\r
+\r
+\r
+/* Structure for handlers */\r
+\r
+struct Hlstelem\r
+{\r
+ int hand; /* handler prototype */\r
+ int signlist; /* address of signals */\r
+ int next;\r
+};\r
+\r
+struct Sgelem\r
+{\r
+ int signalnum; /* signal number */\r
+ int next;\r
+};\r
+\r
+\r
+\r
+\r
+\r
+\r
+/* Structure for offsets of reference variables in objects */\r
+\r
+\r
+\r
+struct Elem\r
+{\r
+ int offset; /* offset in a structure */\r
+ int next; /* next list element */\r
+ int references; /* for COMBINEDLIST points */\r
+ /* the corresponding substructure */\r
+ /* for SIMPLELIST */\r
+ /* 0 when it is fulladdress */\r
+ /* 1 when it is shortaddress */\r
+ /* 2 when it is procedure closure */\r
+};\r
+\r
+\r
+\r
+ enum { SIMPLELIST,SEGMENT,REPEATED,COMBINEDLIST}; /* kind of structure */\r
+\r
+struct Offsets\r
+{\r
+ int kind; /* kind as above */\r
+ int size; /* size of characterized object */\r
+ int num; /* reference structure number */\r
+ int length,finish; /* for SIMPLELIST and COMBINEDLIST */\r
+ /* length is a list length, finish not used */\r
+ /* for SEGMENT length (start) and finish */\r
+ /* define a segment span */\r
+ /* for REPEATED length=ntimes */\r
+ /* finish not used */\r
+ int head; /* for LISTS it is a list head */\r
+ /* for SEGMENT */\r
+ /* 0 when they are fulladdresses */\r
+ /* 1 when they are shortaddresses */\r
+ /* 2 when they are procedure closures */\r
+ /* for REPEATED not used */\r
+ int references; /* address of reference structure */\r
+ /* used only for REPEATED */\r
+};\r
+\r
+#define start length\r
+#define ntimes length\r
+\r
+\1a\r
--- /dev/null
+From: MX%"antek@mimuw.edu.pl" 1-MAR-1993 16:29:48.71\r
+To: SALWICKI\r
+CC: \r
+Subj: \r
+\r
+Date: Mon, 1 Mar 93 15:01:30 GMT\r
+From: antek@mimuw.edu.pl\r
+To: salwicki@pauvx1.univ-pau.fr\r
+\r
+ CAEN, October, 1987\r
+\r
+ A SHORT INTRODUCTION TO THE NEW RUNNING SYSTEM\r
+ WRITTEN IN LOGLAN-82\r
+\r
+ by\r
+\r
+ Antoni Kreczmar\r
+\r
+1. Preface\r
+\r
+This short introduction describes the main differences between the Loglan-82\r
+and Loglan-84 Running Systems (RS) as well as the user guide for RS program.\r
+This program was entierly written in Loglan-82, so it gives a good high level\r
+point of view on the chosen algorithms. In future a library of modules written\r
+in programming language C will replace that program. It seems that this way we\r
+shall obtain a strict, abstract definition of Loglan RS, as well as a perfect\r
+mean to produce a professional portable system.\r
+\r
+The present text may be read only by fellows who know the theory of Loglan RS\r
+virtual addressing and Loglan RS Display structure. For the first problem we\r
+refer the reader to the paper by G.Cioni, A.Kreczmar "Programmed deallocation\r
+without dangling reference" IPL 18(1984) pp.179-187, for the latter one we re-\r
+fer the reader to the paper by M.Krause, A.Kreczmar, H.Langmaack, A.Salwicki,\r
+M.Warpechowski "Algebraic approach to ...." published in Lecture Notes in Com-\r
+puter Science Springer serie number 208, pp. 134-156. In what follows we do\r
+not explain the details of these solutions, in the contrary, all the details\r
+are just put in our program (we hope the program is self explanatory for our\r
+fellows who understand the published solutions).\r
+\r
+2. Structure of RS.LOG\r
+\r
+Program RS is written as the sequence of classes. The most outer one is the\r
+class defining Loglan prototypes (class PROTOTYPES). Going down we have the\r
+following classes: MEMORY (defining the structure of memory management),\r
+OBJECTS (defining the basic operations on Loglan objects), COROUTINES (de-\r
+fining the operations on coroutines), HANDLING (defining operations on exc-\r
+eptions), and finally we have a prefixed block which allows to interpret the\r
+tentative intermediate code designed only for testing aims.\r
+\r
+Class PROTOTYPE defines all prototypes, like in Loglan-82 RS, but it profits\r
+from the possibility of building up hierarchies. So, the outermost prototype\r
+Prtp has only the common attributes, then we can inherit this class to define\r
+prototypes of simple classes and arrays, etc. The full picture of this hie-\r
+rarchy is given at the beginning of class PROTOTYPES. What is interesting and\r
+new with respect to Loglan-82 RS is that we define system attributes as\r
+virtual operations (Sl, Dl, Lsc etc.), so their offsets may be changed later.\r
+Pay attention also on attributes "perm" and "perminv" which are necessary\r
+to update Display correctly. In the program RS we gave the full algorithm for\r
+computing these permutations (procedure Cmptperm) which is not executed in\r
+our program. It is written as a comment, however it was tested on large\r
+examples. In future this procedure must be executed during a program com-\r
+pilation. Everything what is needed to perform this procedure is a program\r
+structure with decl and pref functions.\r
+\r
+The last but not least thing which we must stress in this short introduction\r
+is the structure of offsets for reference values. In fact, Loglan-84 differs\r
+from Loglan-82 also because of more complicated world of structured types.\r
+In fact, we can define in this new version of language a record or array of\r
+elements which contain references. This implies that the structure of offsets\r
+of references ressembles regular expressions. We can have a list of offsets,\r
+a segment of offsets, a list of such expressions and finally a repetition of\r
+such an expression. A list of offsets (Listref) is the following stucture:\r
+\r
+ head ---> (i1,next1) ---> ... ---> (in,none)\r
+\r
+where i1,...,in are offsets of references inside an object.\r
+\r
+A segment of offsets (Segment) is only a pair (start,finish), and all ele-\r
+ments between offsets start and finish are references. A list of structures\r
+defining offsets (List) is the following:\r
+\r
+ head ---> (Offset1,next1) ---> ... ---> (Offsetn,none)\r
+\r
+where Offset is the type of offsets structure. Finally a repetition n times\r
+such a structure is defined by class Repeated. It is a pair (ntimes,Offsets)\r
+where ntimes defines the number of repetitions and Offsets defines the re-\r
+peted structure. Recalling Loglan-84 types we see that Listref is a normal\r
+list of offsets in an object, like in Loglan-82, Segment appears when a sta-\r
+tic array of references is declared, List appears when a record with selec-\r
+tors having references is declared, and finally Repeated appears when a sta-\r
+tic array with element having references is declared.\r
+\r
+The structure of Offsets is read by procedure Takeoffsets, the structure of\r
+Prototypes is read by procedure Takeprototype. For the syntax of input look\r
+inside these procedures.\r
+\r
+3. Object structure\r
+\r
+The new Running System has a new object structure. In fact, it is not diffi-\r
+cult to observe that an object may be uniquely defined if we have an access\r
+to its prototype. Moreover during the work on Loglan-82 we realized that the\r
+structure of object growing only in one direction is cumbersome for many re-\r
+asons (formal parameters had to be numbered, auxiliary variables changed the\r
+already computed offsets etc.). Thus it would be nicer if object could grow\r
+both directions. Such a solution was accepted as an axiom, so objects in new\r
+RS are identified by one value placed not necessarily at one of its ends.\r
+\r
+Prototypes of objects are defined by classes (Prtp). Such a class has two\r
+attributes defining object size : lspan , rspan. For adjustable arrays an\r
+object size is settled on run time. Thus the first value of such an object\r
+defines array prototype while the next two (lower bound & upper bound) fixed\r
+on run time define the object size. Because of adjustable arrays virtual\r
+function Size, giving an object length, has formal parameter am. This para-\r
+meter is not used in the case of normal modules, it is used only in the case\r
+of adjustable arrays. Then it points an object address from which we can\r
+calculate object size using lower and upper bound.\r
+\r
+4. Compactifier\r
+\r
+New compactifier is based in the structure of the old one. However we added\r
+one important feature, namely automatic garbage collection. This garbage co-\r
+llection is based on the known technique which traverses the whole graph of\r
+objects accessible from the active one and marks them. The traversing proce-\r
+dure starts from marking a visited object. Then using the information about\r
+the relocation of references inside the object it goes recursively to visit\r
+other objects.\r
+\r
+Garbage collection (act1) is the first phase of compactifying procedure.\r
+Then we do the same as in the old compactification process. In act2 we walk\r
+through the list of free items on address table. Act3 again analyzes this\r
+table however by scanning it entierly and marking non-used addresses. In the\r
+act4 the lists of killed objects are traversed and killed objects are marked.\r
+In act5 the whole memory is scanned and references to nonexisting objects\r
+are set to none (this phase is necessary; originally it was not executed but\r
+P.Gburzynski found that error). In act6 the table of indirect addresses is\r
+scanned. It computes the future values of indirect addresses and prepares\r
+the these addresses to the next phase. It is the most important phase, act7.\r
+It scans the whole memory updating all references. Finally the table of ind-\r
+irect addresses is squeezed (act8).\r
+\r
+5. Coroutines\r
+\r
+The system of coroutines differs a little bit from the old one. Dl link is\r
+fixed at the moment of coroutine generation as for all the other modules.\r
+Every coroutine has additional reference Cl. When return is encountered that\r
+reference points coroutine object itself. Each attach, detach updates this\r
+reference on the last object belonging to the coroutine chain (coroutine\r
+chain is defined as in the old Running System). Termination of a coroutine\r
+returns the control via Dl which does not change during a program execution.\r
+In order to mark coroutine termination, Cl is set to none. This way any\r
+attempt to activate a terminated coroutine will be recognized by Running\r
+System. To obtain, as previously, the possibility of nonsymetric coroutine\r
+sequencing each process contains a system reference pointing the last atta-\r
+ched coroutine. Thus detach makes the control transfer from an active to\r
+this pointed coroutine.\r
+\r
+6. Handlers\r
+\r
+System of handlers is also a little bit changed. According to Szczepanska's\r
+observation it is methodologically improper to perform recursive call of a\r
+handler. Thus procedure Raise searches a handler going via Dl, but ommitting\r
+handler objects and its Sl fathers. So when a handler is declared in a modu-\r
+le neither a handler object nor its dynamic father are taken into considera-\r
+tion in searching process.\r
+\r
+7. Examples\r
+\r
+There are some examples of programs written in an intermediate code to test\r
+new RS. The full description of an intermediate code is given at the end of\r
+RS program (in the last prefixed block). Each example is prepared so that it\r
+is possible to understand its sense. We give first the full text of program\r
+written in Loglan (with some comments concerning the offsets values), then\r
+the system of offsets, the system of prototypes and finally a code is given.\r
+The syntax of these input data is precisely described in the corresponding\r
+modules. In order to have the possibility of testing our product, some uti-\r
+lities were provided. Each code statement possesses as a final data an inf-\r
+ormation concerning the output. We can output for each code statement just\r
+such a code or a memory dump. If this final value is 1 we print a statement\r
+(trace). If this final value is 2 we dump memory. If this final value is\r
+greater than 2 we print trace as well as memory dump.\r
+\r
+The list of examples contain program Pawel (recursive generation of permuta-\r
+tions), program Merge (coroutine merging of many BST), program Knapsack (the\r
+use of handlers to obtain the solution of simple knapsack problem), and fi-\r
+nally program Mergecor which implements the merging process of two Bst but\r
+using handlers instead of maximal integer to end a tree.\r
+\r
+There is a macro called tr.bat which transforms commented examples into a\r
+form which can be read by RS.LOG. To do it you simply call tr with a parame-\r
+ter denoting an example, for instance:\r
+\r
+ tr pawel.log\r
+\r
+Then you obtain a file code.txt which is ready to be read by RS. In examples\r
+we must put sign # at the end of Loglan version, and we must avoid to use\r
+later all the signs appearing in numbers ( so digits and -). The given exam-\r
+ples keep to this syntax.\r
+\r
+When RS program starts to be executed, it asks you whether you want to print\r
+prototypes, offsets or memory, just at the beginning of a program execution.\r
+You can answer 0 or 1 , corresponding to the needed output. After that phase\r
+your example will be executed. Good luck.\r
+\r
+ Antek Kreczmar\r
+ \1aprogram RS;\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* *)\r
+(* THIS IS LOGLAN-84 RUNNING SYSTEM WRITTEN IN LOGLAN-82 *)\r
+(* *)\r
+(* by Antoni Kreczmar *)\r
+(* *)\r
+(* Institute of Informatics, Warsaw University *)\r
+(* *)\r
+(* June, 1987 *)\r
+(* *)\r
+(* *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* GLOBAL CONSTANTS *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+ const maxint = 32000, (* defines maximal integer *)\r
+ reflength=2, (* reference value length *)\r
+ memorylength = 200, (* defines the length of M *)\r
+ syssigl=100; (* defines system signals bound *)\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* GLOBAL VARIABLES *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+ var M : arrayof integer, (* M[0..memorylength-1] is RS memory *)\r
+ f: file; (* file with datas *)\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* SIGNALS FOR RS ERRORS *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+ signal Error(t:string);\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* *)\r
+(* *)\r
+(* PROTOTYPES *)\r
+(* *)\r
+(* Prototype defines the skeleton of an object *)\r
+(* *)\r
+(* In this part the structure of prototypes is read. *)\r
+(* Levels and Langmaack's permutations may be computed *)\r
+(* ( however this will be done at compilation phase ) *)\r
+(*****************************************************************************)\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* HIERARCHY OF PROTOTYPES *)\r
+(* *)\r
+(* Prtp any prototype *)\r
+(* | *)\r
+(* ------------------------ *)\r
+(* | | *)\r
+(* | | *)\r
+(* Simple class Prtpsimpl Prtparr adjustable array *)\r
+(* without Dl,Sl | | *)\r
+(* | | *)\r
+(* Prtpmod | *)\r
+(* | | *)\r
+(* ------------- | *)\r
+(* | | | *)\r
+(* Block Prtpsub | --------------- *)\r
+(* subroutine | Handler Prtphand | | *)\r
+(* | Prtparnst | *)\r
+(* Class Prtplass | | *)\r
+(* | | | *)\r
+(* | | Prtparstr structured *)\r
+(* | -------------- elements *)\r
+(* Coroutine Prtpcor | | *)\r
+(* | | | *)\r
+(* | | Prtparrf reference *)\r
+(* | | elements *)\r
+(* Process Prtpproc Prtparpr primitive *)\r
+(* elements *)\r
+(*****************************************************************************)\r
+\r
+\r
+\r
+ unit PROTOTYPES: class;\r
+\r
+\r
+ (*****************************************************************)\r
+ (* *)\r
+ (* Every object is patterned upon its prototype *)\r
+ (* *)\r
+ (* *)\r
+ (* object = M[am-lspan..am+rspan] where *)\r
+ (* ----------------- *)\r
+ (* | M[am-lspan] | = *)\r
+ (* | | = *)\r
+ (* | . | = } attributes *)\r
+ (* | . | = *)\r
+ (* | . | = *)\r
+ (* | M[am-1] | = *)\r
+ (* | M[am] | = <-- pt - Prototype number *)\r
+ (* | M[am+1] | = *)\r
+ (* | . | = *)\r
+ (* | . | = } attributes *)\r
+ (* | . | = *)\r
+ (* | M[am+rspan] | = *)\r
+ (* ----------------- *)\r
+ (*****************************************************************)\r
+\r
+ unit Prtp: class;\r
+\r
+ var num: integer; (* prototype number - only for identifiction *)\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ unit virtual Size: function(am:integer) : integer;\r
+\r
+ (* size of the object of this prototype allocated in M[...am...] *)\r
+ (* formal parameter am appears only because of adjustable arrays *)\r
+\r
+ end Size;\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+\r
+ unit virtual Ptposition: function: integer;\r
+\r
+ (* position of pt in an object with respect to its beginning *)\r
+\r
+ end Ptposition;\r
+\r
+ (*------------------------------------------------------------------*)\r
+\r
+ end Prtp;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Prtpsimpl : Prtp class;\r
+\r
+ (* prototype of a simple class, i.e. without Lsc, Dl and Sl *)\r
+\r
+ var lspan,rspan: integer,\r
+ references: Offsets; (* structure of references in object *)\r
+ (* cf. declaration of Offsets *)\r
+\r
+ (*------------------------------------------------------------------*)\r
+\r
+ unit virtual Size: function(am:integer) : integer;\r
+\r
+ begin\r
+ result:=lspan+rspan+1;\r
+ end Size;\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ unit virtual Ptposition: function: integer;\r
+\r
+ begin\r
+ result:=lspan;\r
+ end Ptposition;\r
+\r
+\r
+ end Prtpsimpl;\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ (* Prtpmod is a prototype of any module. It has static attributes *)\r
+ (* like decl,pref and its objects have Dl, Sl, Statsl and Lsc *)\r
+ (* Blocks and subroutines belong exactley to this class, while *)\r
+ (* classes (coroutines,processes) are elements of Prtpmod subclass *)\r
+\r
+\r
+ (*****************************************************************)\r
+ (* *)\r
+ (* ----------------- *)\r
+ (* | M[am-lspan] | = *)\r
+ (* | | = *)\r
+ (* | . | = } attributes *)\r
+ (* | . | = *)\r
+ (* | . | = *)\r
+ (* | M[am-1] | = *)\r
+ (* | M[am] | = <-- pt - Prototype number *)\r
+ (* | . | = *)\r
+ (* | M[am+1] | = } attributes *)\r
+ (* | . | = *)\r
+ (* | . | = Lsc local sequence control *)\r
+ (* | . | = Statsl number of synt. sons *)\r
+ (* | . | = Dl dynamic link *)\r
+ (* | M[am+rspan] | = Sl static link *)\r
+ (* ----------------- *)\r
+ (*****************************************************************)\r
+\r
+\r
+ (* Offsets of system attributes are defined by virtual functions *)\r
+ (* they may be changed later on; here system attributes are *)\r
+ (* allocated at the right end of an object *)\r
+\r
+\r
+ const Sloffset=1-reflength, (* roffset of Sl *)\r
+ Dloffset=Sloffset-reflength, (* roffset of Dl *)\r
+ Statoffset=Dloffset-1, (* roffset of Statsl *)\r
+ Lscoffset=Statoffset-1; (* roffset of Lsc *)\r
+\r
+ unit Prtpmod : Prtpsimpl class;\r
+\r
+\r
+\r
+ var declto, prefto: Prtpmod, (* decl and pref links *)\r
+ level: integer, (* level of node in decl tree *)\r
+ codeadd: integer, (* address of first statement *)\r
+ lstwill: integer, (* address of lastwill *)\r
+ perm: arrayof integer, (* Langmaack's permutation *)\r
+ perminv: arrayof integer; (* inverse of perm *)\r
+\r
+ unit virtual Sl : function(am : integer):integer;\r
+ begin\r
+ result:=am+rspan+Sloffset\r
+ end Sl;\r
+\r
+ unit virtual Dl : function(am : integer) : integer;\r
+ begin\r
+ result:=am+rspan+Dloffset\r
+ end Dl;\r
+\r
+ unit virtual Statsl : function(am : integer) : integer;\r
+ begin\r
+ result:=am+rspan+Statoffset\r
+ end Statsl;\r
+\r
+ unit virtual Lsc: function(am : integer) : integer;\r
+ begin\r
+ result:=am+rspan+Lscoffset\r
+ end Lsc;\r
+\r
+ end Prtpmod;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit Prtpsub : Prtpmod class;\r
+\r
+ (* Prtpsub is a prototype of block, procedure or function *)\r
+\r
+ var pslength: integer, (* prefix sequence length *)\r
+ handlist: hlstelem; (* list of handlers,see down *)\r
+\r
+ end Prtpsub;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+ unit Prtpclass : Prtpsub class;\r
+\r
+ (* Prtpclass is a prototype of class *)\r
+\r
+ end Prtpclass;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit Prtpcor : Prtpclass class;\r
+\r
+ (* Prtpcor is a prototype of coroutine *)\r
+\r
+ end Prtpcor;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit Prtphand: Prtpmod class;\r
+\r
+ (* Prtphand is a prototype of handler *)\r
+ var oth: boolean; (* for others oth=true *)\r
+\r
+ end Prtphand;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+\r
+ unit Prtpproc: Prtpcor class;\r
+\r
+ var displ: integer, (* offset of DISPLAY[1] in object *)\r
+ curr: integer, (* offset of current in object *)\r
+ lstcr: integer, (* offset of lastcor in object *)\r
+ chead: integer; (* offset of corhead in object *)\r
+\r
+ (* DISPLAY, current,lastcor and corhead must be in Offsets *)\r
+ (* lastcor and corhead are used in class COROUTINES *)\r
+ end Prtpproc;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ (*********************************************************)\r
+ (* adjustable array object has the form *)\r
+ (* M[am]=pt *)\r
+ (* M[am+1]= lower bound *)\r
+ (* M[am+2]= upper bound *)\r
+ (* M[am+3] = *)\r
+ (* M[am+4] = } elements *)\r
+ (* ... = *)\r
+ (* M[am+i] = *)\r
+ (*********************************************************)\r
+\r
+ const lboffset= 1, (* offset of lower bound *)\r
+ uboffset= 2, (* offset of upper bound *)\r
+ elmoffset=3; (* offset of first element *)\r
+\r
+ (*--------------------------------------------------------------------*)\r
+ unit Prtparr: Prtp class;\r
+\r
+\r
+ unit virtual Size: function(am:integer) : integer;\r
+ (* dummy *)\r
+ end Size;\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ unit virtual Ptposition: function: integer;\r
+\r
+ begin\r
+ result:=0;\r
+ end Ptposition;\r
+\r
+ end Prtparr;\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Prtparnst: Prtparr class;\r
+ (* adjustable array of non-structured elements *)\r
+\r
+ var elsize:integer; (* element size *)\r
+\r
+ unit virtual Size: function(am:integer): integer;\r
+ begin\r
+ result:=(M(am+uboffset)-M(am+lboffset)+1)*elsize+3;\r
+ end Size;\r
+ end Prtparnst;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Prtparpr: Prtparnst class;\r
+ (* adjustable array of primitive elements, elsize is read *)\r
+ end Prtparpr;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Prtparrf:Prtparnst class;\r
+ (* adjustable array of references *)\r
+\r
+ begin\r
+ elsize:=reflength; (* define element size *)\r
+ end Prtparrf;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Prtparstr:Prtparr class;\r
+ (* array of structured elements *)\r
+ var references:Offsets;\r
+\r
+ unit virtual Size: function(am:integer): integer;\r
+ begin\r
+ result:=(M(am+uboffset)-M(am+lboffset)+1)*references.size+3;\r
+ end Size;\r
+\r
+\r
+ end Prtparstr;\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+ var maxlevel: integer; (* length of Display *)\r
+\r
+\r
+ (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)\r
+ (* *)\r
+ (* END OF SPECIFICATION PART *)\r
+ (* *)\r
+ (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)\r
+\r
+\r
+\r
+\r
+\r
+\r
+ (*------------------------------------------------------------------*)\r
+ (* *)\r
+ (* STRUCTURES FOR *)\r
+ (* *)\r
+ (* HANDLERS *)\r
+ (* *)\r
+ (*------------------------------------------------------------------*)\r
+\r
+\r
+ (*------------------------------------------------------------------*)\r
+ (* *)\r
+ (* Each module can have the list of handlers. This list is the list *)\r
+ (* of lists i.e. for each handler we have the list of joint signal *)\r
+ (* numbers. So, the main list has as elements the triples: *)\r
+ (* (handler prototype,signal list,next list element) *)\r
+ (* The corresponding signal list has as elements the pairs: *)\r
+ (* (signal number,next list element) *)\r
+ (* If else part appears, then all visible signals in a module are *)\r
+ (* on the list joint with such a handler and its oth=true. *)\r
+ (* System signals have signal number <= syssigl. For these signals *)\r
+ (* return in a handler is not allowed. They not appear on the list *)\r
+ (* of signals for handler for others. *)\r
+ (* *)\r
+ (*------------------------------------------------------------------*)\r
+\r
+\r
+ (*------------------------------------------------------------------*)\r
+ (* *)\r
+ (* System signals numbers *)\r
+ (* *)\r
+ (*------------------------------------------------------------------*)\r
+\r
+\r
+ const\r
+ reftonone = 1, (* reference to none *)\r
+ memover = 2, (* memory overflow *)\r
+ incorqua = 3, (* incorrect qua *)\r
+ incorassg = 4, (* incorrect assignment *)\r
+ ilattach = 5, (* illegal attach *)\r
+ corterm = 6, (* coroutine terminated *)\r
+ handnfond = 7, (* handler not found *)\r
+ imprterm = 8, (* improper terminate *)\r
+ incorkill = 9, (* incorrect kill *)\r
+ arrayind = 10; (* array index error *)\r
+\r
+\r
+\r
+ unit hlstelem: class;\r
+ var hand: integer, (* prototype number of handler *)\r
+ signlist: sglelem, (* signal list *)\r
+ next: hlstelem; (* next list element *)\r
+ end hlstelem;\r
+\r
+ unit sglelem: class;\r
+ var signalnum: integer, (* signal number *)\r
+ next: sglelem; (* next list element *)\r
+ end sglelem;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ (*------------------------------------------------------------------*)\r
+ (* *)\r
+ (* STRUCTURES FOR *)\r
+ (* *)\r
+ (* OFFSETS OF REFERENCES *)\r
+ (* *)\r
+ (*------------------------------------------------------------------*)\r
+\r
+\r
+ (*------------------------------------------------------------------*)\r
+\r
+\r
+ (* auxiliary classes for defining lists of offsets *)\r
+\r
+ unit Elem:class(offset:integer,next:Elem);\r
+ end Elem;\r
+\r
+ unit Elemex:Elem class;\r
+ var references :Offsets;\r
+ end Elemex;\r
+\r
+ (*----------------------------------------------------------------*)\r
+\r
+ unit Offsets: class;\r
+ (* any substructure defining references *)\r
+\r
+ var size: integer, (* defines the size of considered *)\r
+ (* memory subframe *)\r
+ num: integer; (* offsets number - only to write *)\r
+ end Offsets;\r
+\r
+ (*----------------------------------------------------------------*)\r
+\r
+\r
+\r
+ unit Listref: Offsets class;\r
+ (* each list element is an offset of a reference *)\r
+\r
+ var head: Elem,\r
+ length: integer;\r
+ end Listref;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit Segment: Offsets class;\r
+ (* contiguous segment of memory *)\r
+\r
+ var start,finish: integer;\r
+ end Segment;\r
+\r
+ (*---------------------------------------------------------------*)\r
+\r
+ unit Repeated : Offsets class;\r
+ (* repetition n times *)\r
+\r
+ var ntimes: integer,\r
+ references: Offsets;\r
+ end Repeated;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit List: Offsets class;\r
+ (* each list element is an offset of substructure *)\r
+\r
+ var head: Elemex,\r
+ length: integer;\r
+\r
+ end List;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ var STRUC :arrayof Offsets; (* array for offsets structures *)\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ signal SS;\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ var PROT: arrayof Prtp,\r
+ n: integer;\r
+\r
+\r
+\r
+ (* PROT[1..n] is defined by the compiler *)\r
+ (* RS reads it from file CODE.TXT by Takeprot procedure *)\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Takeoffsets : procedure;\r
+\r
+ (* reads offsets to STRUC from CODE.TXT file *)\r
+\r
+ (* Input format: *)\r
+ (* n - number of offsets *)\r
+ (* { offsetnumber size *)\r
+ (* kind (1,2,3,4) *)\r
+ (* =(Listref,Segment,Repeated,List) *)\r
+ (* if kind=1 then *)\r
+ (* n,offset1,offset2,...,offsetn *)\r
+ (* if kind=2 then *)\r
+ (* start finish *)\r
+ (* if kind=3 then *)\r
+ (* ntimes offsetnumber *)\r
+ (* if kind=4 then *)\r
+ (* n,offset1,offset2,...,offsetn *)\r
+ (* offsets of substructures }+ *)\r
+ (* *)\r
+ (* ATTENTION!!! *)\r
+ (* must be called before Takeprot *)\r
+\r
+\r
+ var n,m,i,j,k,t,p: integer,\r
+ L: List,\r
+ Lr: Listref,\r
+ S: Segment,\r
+ R: Repeated,\r
+ ref: Offsets;\r
+\r
+ begin\r
+ open(f,text,unpack("CODE.TXT"));\r
+ call RESET(f);\r
+ read(f,n);\r
+ if n<1 then raise SS fi;\r
+ array STRUC dim (1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(f,t); (* offsets number *)\r
+ if i=/=t\r
+ then\r
+ raise Error("Incorrect prototype");\r
+ fi;\r
+ read(f,k); (* read size *)\r
+ read(f,j); (* read kind *)\r
+ case j\r
+ when 1: (* Listref *)\r
+ Lr:=new Listref;\r
+ read(f,m); (* m = length *)\r
+ for t:=1 to m\r
+ do\r
+ read(f,p); (* p=offset *)\r
+ Lr.head:=new Elem(p,Lr.head);\r
+ od;\r
+ Lr.length:=m;\r
+ ref:=Lr;\r
+ when 2: (* Segment *)\r
+ S:=new Segment;\r
+ read(f,m); read(f,p);\r
+ S.start:=m; S.finish:=p;\r
+ ref:=S;\r
+ when 3: (* Repeated *)\r
+ R:=new Repeated;\r
+ read(f,m); read(f,p);\r
+ R.ntimes:=m; R.references:=STRUC(p);\r
+ ref:=R\r
+ when 4: (* List *)\r
+ L:=new List;\r
+ read(f,m); (* m = length *)\r
+ for t:=1 to m\r
+ do\r
+ read(f,p); (* p=offset *)\r
+ L.head:=new Elemex(p,L.head);\r
+ read(f,p);\r
+ L.head.references:=STRUC(p);\r
+ od;\r
+ L.length:=m;\r
+ ref:=L;\r
+ otherwise\r
+ raise Error(" Incorrect prototype kind");\r
+ esac;\r
+ ref.num:=i; ref.size:=k;\r
+ STRUC(i):=ref;\r
+ readln(f);\r
+ od;\r
+ end Takeoffsets;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+\r
+ unit Takeprot : procedure;\r
+\r
+ (* reads PROT structure from CODE.TXT file *)\r
+\r
+ (* Input format: *)\r
+ (* n - number of prototypes *)\r
+ (* { prototypenumber *)\r
+ (* kind = (1,2,3,4,5,6,7,8,9) *)\r
+ (* (for kind = 1 simple class like record) *)\r
+ (* lspan rspan offestsnum *)\r
+ (* (for kind = 2,9 class,block,subprogram) *)\r
+ (* (2 is for block, subprogram, 9 for class) *)\r
+ (* lspan rspan offsetsnum decl pref codeadd *)\r
+ (* level pslength *)\r
+ (* perm[1..level] perminv[1..level] *)\r
+ (* lstwill *)\r
+ (* { handlerprot, { signalnumber}+,0 }+,0 *)\r
+ (* (for kind = 3 process-main block additionally) *)\r
+ (* displ curr lstcr chead *)\r
+ (* (for kind = 4 adjustable primitive array ) *)\r
+ (* elsize *)\r
+ (* (for kind = 5 adjustable structured array) *)\r
+ (* offsetsnum *)\r
+ (* (for kind = 6 adjustable reference array) *)\r
+ (* (no data) *)\r
+ (* (for kind = 7 coroutine, no additional datas) *)\r
+ (* (for kind = 8 handler like in kind 2 but *)\r
+ (* instead of pslength oth =0,1 is given *)\r
+ (* }+ *)\r
+ (* maxlevel *)\r
+\r
+ var i,j,k,l: integer,\r
+ a: Prtp,\r
+ b: Prtpmod,\r
+ t: Prtpsimpl,\r
+ c: Prtpsub,\r
+ d: Prtparpr,\r
+ e: Prtparstr,\r
+ h: Prtphand,\r
+ r: Prtpproc,\r
+ p: hlstelem,\r
+ q: sglelem;\r
+\r
+\r
+ begin\r
+ read(f,n);\r
+ if n<1 then raise SS fi;\r
+ array PROT dim (1:n);\r
+ for i:=1 to n\r
+ do\r
+ read(f,l);\r
+ if i=/=l\r
+ then\r
+ raise Error("Incorrect prototype");\r
+ fi;\r
+ read(f,j); (* read kind *)\r
+ case j\r
+ when 1: (* simple class *)\r
+ a:=new Prtpsimpl; t:=a;\r
+ read(f,l); t.lspan:=l; (* read lspan *)\r
+ read(f,l); t.rspan:=l; (* read rspan *)\r
+ read(f,l); (* read offsetnum *)\r
+ if l=/=0 then t.references:=STRUC(l); fi;\r
+ when 2,3,7,8,9: (* module *)\r
+ case j\r
+ when 2:\r
+ a:=new Prtpsub; b:=a; c:=a;\r
+ when 3:\r
+ a:=new Prtpproc; b:=a; c:=a; r:=a;\r
+ when 7:\r
+ a:=new Prtpcor; b:=a; c:=a;\r
+ when 8:\r
+ a:=new Prtphand; b:=a; h:=a;\r
+ when 9:\r
+ a:=new Prtpclass; b:=a; c:=a;\r
+ esac;\r
+ read(f,l); b.lspan:=l;\r
+ read(f,l); b.rspan:=l;\r
+ read(f,l); (* read offsetnum *)\r
+ if l=/=0 then b.references:=STRUC(l); fi;\r
+ read(f,l);\r
+ if l=/=0 then b.declto:=PROT(l); fi; (* set decl *)\r
+ read(f,l);\r
+ if l=/=0 then b.prefto:=PROT(l); fi; (* set prefto *)\r
+ read(f,l); b.codeadd:=l; (* read codeadd. *)\r
+ read(f,l); b.level:=l; (* read level *)\r
+ if j=/=8\r
+ then\r
+ read(f,l); c.pslength:=l; (* read pslength *)\r
+ fi;\r
+ array b.perm dim(1:b.level);\r
+ array b.perminv dim(1:b.level);\r
+ for k:=1 to b.level do read(f,b.perm(k)) od;\r
+ for k:=1 to b.level do read(f,b.perminv(k)) od;\r
+ read(f,l); b.lstwill:=l; (* read lstwill *)\r
+ if j=/=8\r
+ then\r
+ c.handlist:=none;\r
+ do\r
+ read(f,l);\r
+ if l=0 then exit fi; (* end of list *)\r
+ p:=new hlstelem; (* generate element *)\r
+ p.hand:=l;\r
+ p.next:=c.handlist; c.handlist:=p;\r
+ read(f,k); (* read signalnum *)\r
+ q:=new sglelem;\r
+ p.signlist:=q; q.signalnum:=k;\r
+ do\r
+ read(f,k);\r
+ if k=0 then exit fi; (* end of list *)\r
+ q:=new sglelem; q.signalnum:=k;\r
+ q.next:=p.signlist; p.signlist:=q;\r
+ od;\r
+ od;\r
+ if j=3\r
+ then\r
+ read(f,l); r.displ:=l;\r
+ read(f,l); r.curr:=l;\r
+ read(f,l); r.lstcr:=l;\r
+ read(f,l); r.chead:=l;\r
+ fi;\r
+ else\r
+ read(f,l);\r
+ if l=0 then h.oth:=false else h.oth:=true fi;\r
+ fi;\r
+ when 4: (* prim.adjus.arr.*)\r
+ a:=new Prtparpr; d:=a;\r
+ read(f,l);\r
+ d.elsize:=l; (* read elem.size *)\r
+ when 5: (* str.adjus.arr. *)\r
+ a:=new Prtparstr; e:=a;\r
+ read(f,l);\r
+ e.references:=STRUC(l); (* set offsets *)\r
+ when 6: (* ref.adj.array *)\r
+ a:=new Prtparrf;\r
+ otherwise\r
+ raise Error(" Incorrect prototype kind");\r
+ esac;\r
+ a.num:=i;\r
+ PROT(i):=a;\r
+ od;\r
+ read(f,maxlevel);\r
+ end Takeprot;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ (* Cmptperm computes perm and perminv for all PROT[i] *)\r
+ (* see LNCS 208, pp.134*156 *)\r
+ (*\r
+ unit Cmptperm: procedure;\r
+\r
+\r
+ var i,j,k,l,m,s,t: integer,\r
+ a,b,c,d: Prtpmod,\r
+ perm,perminv,perm1,perminv1: arrayof integer;\r
+\r
+\r
+ unit Cmptcmpl: function (a:Prtpmod) :Prtpmod;\r
+\r
+\r
+ var b,c,e: Prtpmod;\r
+\r
+ begin\r
+\r
+ result:=a.declto; b:=a.prefto; c:=b.declto;\r
+ do\r
+ e:=result;\r
+ do\r
+ if e=c then return fi;\r
+ if e=none then exit fi;\r
+ e:=e.prefto;\r
+ od;\r
+ result:=result.declto;\r
+ od\r
+\r
+ end Cmptcmpl;\r
+\r
+ begin\r
+\r
+ array perm dim (1:1); perm(1):=1;\r
+ array perminv dim(1:1); perminv(1):=1;\r
+ PROT(1) qua Prtpmod.perm:=perm;\r
+ PROT(1) qua Prtpmod.perminv:=perminv;\r
+\r
+ for m:=2 to n\r
+ do\r
+ if not PROT(m) in Prtpmod\r
+ then\r
+ repeat\r
+ fi;\r
+ a:=PROT(m);\r
+ if a.prefto=none\r
+ then\r
+ b:=a.declto;\r
+ perm1:=b.perm; perminv1:=b.perminv;\r
+ l:=b.level; k:=a.level;\r
+ array perm dim(1:k); array perminv dim(1:k);\r
+ for i:=1 to l\r
+ do\r
+ perm(i):=perm1(i); perminv(i):=perminv1(i)\r
+ od;\r
+ perm(k):=k; perminv(k):=k;\r
+ else\r
+ b:=a.prefto; perm1:=b.perm;\r
+ l:=b.level; k:=a.level;\r
+ array perm dim(1:k); array perminv dim(1:k);\r
+ perm(k):=perm1(l); perminv(perm1(l)):=k;\r
+ d:=b.declto;\r
+ c:= Cmptcmpl(a);\r
+ j:=c.level; i:=l-1;\r
+ do\r
+ perm(j):=perm1(i); perminv(perm1(i)):=j;\r
+ if i=1 then exit fi;\r
+ i:=i-1; t:=j;\r
+ j:=c.perminv(d.perm(i));\r
+ d:=d.declto;\r
+ for s:=1 to t-j\r
+ do\r
+ c:=c.declto;\r
+ od;\r
+ od;\r
+ j:=l;\r
+ for i:=1 to k\r
+ do\r
+ if perm(i) = 0\r
+ then\r
+ j:=j+1; perm(i):=j;\r
+ perminv(j):=i\r
+ fi\r
+ od;\r
+ fi;\r
+ a.perm:=perm; a.perminv:=perminv;\r
+\r
+ od;\r
+\r
+ end Cmptperm;\r
+\r
+ *)\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Protwrite :procedure;\r
+\r
+\r
+\r
+\r
+ var i,j,k: integer,\r
+ a: Prtp,\r
+ b,c: Prtpsimpl,\r
+ d: Prtpmod,\r
+ g: Prtpclass,\r
+ e: Prtparpr,\r
+ f: Prtparstr,\r
+ L: List,\r
+ Lr: Listref,\r
+ S: Segment,\r
+ R: Repeated,\r
+ working: Elem,\r
+ workinge: Elemex,\r
+ p: hlstelem,\r
+ q: sglelem;\r
+\r
+ begin\r
+ writeln;\r
+ writeln(" PROTOTYPE STRUCTURE ");\r
+ writeln;\r
+ write("Nr Offsets Lspan Rspan Decl Pref Code Level Pslength");\r
+ writeln(" Lstwill Kind");\r
+ for i:=1 to n\r
+ do\r
+ a:=PROT(i);\r
+ write(i:2); write(" ");\r
+ if a in Prtpsimpl\r
+ then\r
+ b:=a;\r
+ if b.references =/=none\r
+ then\r
+ write(b.references.num:3);\r
+ else\r
+ write(0:3);\r
+ fi;\r
+ write(" ",b.lspan:4," ",b.rspan:4," ");\r
+ if a in Prtpmod\r
+ then\r
+ d:=a;\r
+ b:=d.declto;\r
+ c:=d.prefto;\r
+ if b=/=none then write(b.num:2) else write(" ") fi;\r
+ write(" ");\r
+ if c=/=none then write(c.num:2) else write(" ") fi;\r
+ write(" ");\r
+ write(d.codeadd:4," ");\r
+ write(d.level:4);write(" ");\r
+ if a in Prtpsub\r
+ then\r
+ write(d qua Prtpsub.pslength:4);\r
+ write(d qua Prtpsub.lstwill:4);\r
+ if a is Prtpsub then write(" subroutine");\r
+ else\r
+ if a is Prtpclass then write(" class")\r
+ else\r
+ if a is Prtpcor then write(" coroutine");\r
+ else write(" process");\r
+ fi;\r
+ fi;\r
+ fi;\r
+ else\r
+ write(" ",d qua Prtphand.lstwill:4);\r
+ if a qua Prtphand.oth\r
+ then\r
+ write("others")\r
+ else\r
+ write(" ")\r
+ fi;\r
+ write(" handler");\r
+ fi;\r
+ else\r
+ write(" simple")\r
+ fi;\r
+ else\r
+ if a is Prtparpr\r
+ then\r
+ e:=a; write(e.elsize:3);\r
+ else\r
+ if a is Prtparstr\r
+ then\r
+ f:=a; write(f.references.num:3);\r
+ fi;\r
+ fi;\r
+ write(" array");\r
+ fi;\r
+ writeln;\r
+ od;\r
+\r
+ writeln; writeln; writeln(" HANDLERS");\r
+ writeln; writeln; writeln(" handler signals ");\r
+ for i:=1 to n\r
+ do\r
+ a:=PROT(i);\r
+ write(i);\r
+ if a in Prtpclass\r
+ then\r
+ g:=a; p:=g.handlist;\r
+ do\r
+ if p=none then exit fi;\r
+ write(p.hand);\r
+ q:=p.signlist;\r
+ do\r
+ if q=none then exit fi;\r
+ write(q.signalnum); q:=q.next;\r
+ od;\r
+ p:=p.next\r
+ od;\r
+ fi;\r
+ writeln;\r
+ od;\r
+ writeln;writeln;\r
+ write(" MAXIMAL LEVEL="); writeln(maxlevel);\r
+ writeln;\r
+ writeln(" OFFSETS");\r
+ for i:=1 to upper(STRUC)\r
+ do\r
+ writeln;\r
+ write(i:2); write(" size=",STRUC(i).size);\r
+ if STRUC(i)=none then repeat fi;\r
+ if STRUC(i) is Listref\r
+ then\r
+ write(" Listref=");\r
+ Lr:=STRUC(i); working:=Lr.head;\r
+ for j:=1 to Lr.length\r
+ do\r
+ write(working.offset);\r
+ working:=working.next;\r
+ od;\r
+ repeat;\r
+ fi;\r
+ if STRUC(i) is Segment\r
+ then\r
+ write(" Segment=");\r
+ S:=STRUC(i); write(S.start,S.finish);\r
+ repeat;\r
+ fi;\r
+ if STRUC(i) is Repeated\r
+ then\r
+ write(" Repeated=");\r
+ R:=STRUC(i); write(R.ntimes,R.references.num);\r
+ repeat;\r
+ fi;\r
+ if STRUC(i) is List\r
+ then\r
+ write(" List=");\r
+ L:=STRUC(i); workinge:=L.head;\r
+ for j:=1 to L.length\r
+ do\r
+ write(workinge.offset);\r
+ write(workinge.references.num);\r
+ workinge:=workinge.next;\r
+ od;\r
+ repeat;\r
+ fi;\r
+ od;\r
+ if PROT=none then return fi;\r
+ if PROT(1) qua Prtpclass.perm=none then return fi;\r
+ writeln;\r
+ writeln(" PERMUTATIONS ");\r
+ writeln;\r
+ writeln("Prot Perm Perminv");\r
+ for i:=1 to n\r
+ do\r
+ a:=PROT(i); write(i:2); write(" ");\r
+ if a in Prtpmod\r
+ then\r
+ d:=a;\r
+ for j:=1 to maxlevel\r
+ do\r
+ if j<=d.level\r
+ then\r
+ write(d.perm(j):2); write(' ');\r
+ else\r
+ write(" ");\r
+ fi\r
+ od;\r
+ write(" ");\r
+ for j:=1 to maxlevel\r
+ do\r
+ if j<=d.level\r
+ then\r
+ write(d.perminv(j):2); write(' ');\r
+ else\r
+ write(" ");\r
+ fi\r
+ od;\r
+ fi;\r
+\r
+ writeln;\r
+ od;\r
+\r
+ end Protwrite;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit virtual Raising : procedure (signum,X: integer);\r
+ (* virtual procedure defining raise statement *)\r
+ (* used in memory management and other systems *)\r
+ end Raising;\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ handlers\r
+ when SS: writeln(" Incorrect prototype structure ");\r
+ terminate;\r
+ end handlers;\r
+\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ (* PROTOTYPES body *)\r
+ begin\r
+ call Takeoffsets;\r
+ call Takeprot;\r
+(* call Cmptperm; *)\r
+ end PROTOTYPES;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* MEMORY AND ADDRESSING *)\r
+(* *)\r
+(* inherits PROTOTYPES *)\r
+(* *)\r
+(* For structure of addressing see IPL 18(1984) pp.179-187 *)\r
+(* *)\r
+(* Every address in this solution is a pair <ah,counter> *)\r
+(* where ah points to M[lastitem..upr] and counter is *)\r
+(* an integer treated as a guard. *)\r
+(* *)\r
+(* Operations Member,Physical,Request and Disp are *)\r
+(* virtual, so this solution can be eventually exchanged *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+ unit MEMORY: PROTOTYPES class;\r
+\r
+ var current : integer; (* reference to the current object *)\r
+ (* allocated in main block *)\r
+\r
+ const minsize=2, (* defines minimal object size *)\r
+ upr = memorylength-1, (* M[lwr+1..upr] is memory for *)\r
+ (* objects and virtual addresses *)\r
+\r
+ (* Now some auxiliary RS references are allocated *)\r
+\r
+ virt1 = reflength, (* address of main program *)\r
+ virt2 = virt1+reflength, (* address of recently open object *)\r
+ virt3 = virt2+reflength, (* address of auxiliary reference *)\r
+ virt4 = virt3+reflength, (* address of auxiliary reference *)\r
+ virtn = virt4, (* address of last auxiliary ref. *)\r
+ lwr = virtn+reflength; (* M[lwr]=sentinel for killed list *)\r
+ (* lwr+1 first normal memory word *)\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit virtual Physical:function (X:integer): integer;\r
+\r
+ (* computes effective address for a given reference at M[X] *)\r
+\r
+ begin\r
+ if Member(X)\r
+ then\r
+ result:=M(M(X))\r
+ else\r
+ call Raising(reftonone,virt2); (* reference to none *)\r
+ fi;\r
+ end Physical;\r
+\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit virtual Member: function (X: integer):boolean;\r
+\r
+ (* test for none , X points a reference at M[X] *)\r
+\r
+ begin\r
+ result := M(X+1)=M(M(X)+1)\r
+ end Member;\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+\r
+ unit virtual Request: procedure (pt,length,X:integer);\r
+\r
+ (* takes a new frame for object of type defined by pt *)\r
+ (* parameter length is necessary because of arrays *)\r
+ (* reference to a frame is returned at address M[X] *)\r
+\r
+ var t1,t2,t3,t4,t5: integer,\r
+ ah,am: integer,\r
+ a: Prtp,\r
+ wascomp, found: boolean;\r
+\r
+ begin\r
+ if length >= maxapp\r
+ then\r
+ raise Error (" memory overflow");\r
+ fi;\r
+ if length <= minsize\r
+ then\r
+ length:=minsize;\r
+ fi;\r
+ wascomp:=false;\r
+ (* take new dictionary item *)\r
+ if freeitem =/=0\r
+ then\r
+ ah:=freeitem; freeitem:=M(ah)\r
+ else\r
+ ah:=lastitem-reflength;\r
+ if ah <= lastused\r
+ then\r
+ call Compactify; wascomp:=true;\r
+ ah:=lastitem-reflength;\r
+ if ah <= lastused\r
+ then\r
+ raise Error (" memory overflow");\r
+ fi;\r
+ fi;\r
+ lastitem:=ah; M(ah+1):=0\r
+ fi;\r
+ (* take new frame *)\r
+ t1:=lastused+length;\r
+ if t1<lastused orif t1>=lastitem\r
+ then\r
+ if length=2 and headk2=/=0\r
+ then\r
+ am:=headk2; headk2:=M(am+shortlink);\r
+ else\r
+ t1:=headk; found:=false;\r
+ t4:=0;\r
+ while t1=/=lwr and not found\r
+ do\r
+ t2:=M(t1);\r
+ if t2=length\r
+ then\r
+ found :=true\r
+ else\r
+ if t2-length >=2\r
+ then\r
+ found:=true\r
+ else\r
+ t4:=t1; t1:=M(t1+longlink);\r
+ fi\r
+ fi;\r
+ od;\r
+ if not found\r
+ then\r
+ if wascomp then raise Error (" memory overflow"); fi;\r
+ M(ah):=freeitem; freeitem:=ah; (* release ah *)\r
+ call Compactify; ah:=lastitem-2;\r
+ lastitem:=ah; M(ah+1):=0;\r
+ t1:=lastused+length;\r
+ if t1<lastused orif t1>=lastitem\r
+ then\r
+ raise Error (" memory overflow");\r
+ fi;\r
+ am:=lastused+1; lastused:=t1;\r
+ else\r
+ t5:=M(t1+shortlink); am:=t1;\r
+ if t5=/=0\r
+ then\r
+ M(t5+longlink):=M(t1+longlink)\r
+ else\r
+ t5:=M(t1+longlink);\r
+ fi;\r
+ if t4=0 then headk:=t5 else M(t4+longlink):=t5 fi;\r
+ if t2>length\r
+ then\r
+ t5:=t1+length; M(t5):=t2-length;\r
+ call Sinsert(t5)\r
+ fi\r
+ fi;\r
+ fi;\r
+ else\r
+ am:=lastused+1; lastused:=t1\r
+ fi;\r
+ (* clear object *)\r
+ for t2:=am to am+length-1 do M(t2):=0 od;\r
+ (* set reference *)\r
+ M(X):=ah; M(X+1):=M(ah+1);\r
+ a:=PROT(pt); am:=am+a.Ptposition;\r
+ M(am):=pt; M(ah):=am;\r
+ end Request;\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit virtual Disp: procedure (X:integer);\r
+\r
+ (* simple kill of object referenced at M[X] *)\r
+\r
+ var counter: integer,\r
+ length: integer,\r
+ am,ah: integer,\r
+ a: Prtp;\r
+\r
+ begin\r
+\r
+ if not Member(X) then return fi;\r
+ ah:=M(X); am:=M(ah); (* compute ah and am *)\r
+ counter:=M(ah+1);\r
+ counter:=counter+1; (* advance guard counter *)\r
+ M(ah+1):=counter;\r
+ if counter=/=maxcounter (* if counter not exhausted *)\r
+ then\r
+ M(ah):=freeitem; freeitem:=ah (* release virtual address *)\r
+ fi;\r
+ a:=PROT(M(am)); (* a is a prototype of object *)\r
+ if am+a.Size(am)-a.Ptposition-1 = lastused\r
+ then (* bordering free space *)\r
+ lastused:=lastused-a.Size(am) (* am because of arrays *)\r
+ else\r
+ length:=a.Size(am); (* length is object size *)\r
+ am:=am-a.Ptposition; (* change am to the beginning *)\r
+ M(am):=length;\r
+ call Sinsert(am);\r
+ fi\r
+\r
+ end Disp;\r
+\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit virtual Refmove : procedure(X,Y:integer);\r
+\r
+ (* this procedure is used for moving references *)\r
+ begin\r
+ M(X):=M(Y); M(X+1):=M(Y+1);\r
+ end Refmove;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit virtual Setnone : procedure(X:integer);\r
+\r
+ (* this procedure is used for setting to none *)\r
+ begin\r
+ M(X):=0; M(X+1):=0;\r
+ end Setnone;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit virtual Notequal: function(X,Y:integer): boolean;\r
+\r
+ (* this procedure tests whether references are not equal *)\r
+\r
+ begin\r
+ if Member(X)\r
+ then\r
+ if Member(Y)\r
+ then\r
+ result:=Physical(X)=/=Physical(Y)\r
+ else\r
+ result:=true\r
+ fi\r
+ else\r
+ result:=Member(Y)\r
+ fi\r
+ end Notequal;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit virtual Equal: function(X,Y:integer): boolean;\r
+\r
+ (* this procedure tests whether references are equal *)\r
+\r
+ begin\r
+ result:=not Notequal(X,Y)\r
+ end Equal;\r
+\r
+\r
+ (*######################################################################*)\r
+ (* *)\r
+ (* END OF SPECIFICATION PART *)\r
+ (* *)\r
+ (*######################################################################*)\r
+\r
+\r
+\r
+ const maxapp = maxint, (* maximal appetite *)\r
+ shortlink = 1, (* pointer to next killed of equal size *)\r
+ longlink = 2, (* pointer to next killed of greater size *)\r
+ maxcounter = maxint; (* maximal counter value *)\r
+\r
+ var\r
+ freeitem: integer, (* address of first free ah *)\r
+ headk: integer, (* address of first killed *)\r
+ headk2: integer, (* address of first killed length 2 *)\r
+ lastused: integer, (* M[lastused..maxint] for objects *)\r
+ lastitem: integer; (* M[1..lastitem] for virtual addresses *)\r
+\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+ unit Sinsert :procedure (am:integer);\r
+\r
+ (* dispose of a memory piece from M[am] to M[am+app-1] *)\r
+ (* where app = M[am] *)\r
+\r
+ var t1,t2,t3,t4: integer;\r
+\r
+ begin\r
+ t1:=M(am);\r
+ if t1=2\r
+ then\r
+ M(am+shortlink):=headk2; headk2:=am\r
+ else\r
+ t2:=headk; t4:=0;\r
+ do\r
+ t3:=M(t2);\r
+ if t1=t3\r
+ then\r
+ M(am+shortlink):=M(t2+shortlink);\r
+ M(t2+shortlink):=am\r
+ else\r
+ if t1<t3\r
+ then\r
+ M(am+longlink):=t2; t1:=t3;\r
+ M(am+shortlink):=0;\r
+ if t4=0 then headk:=am else M(t4+longlink):=am fi;\r
+ else\r
+ t4:=t2; t2:=M(t2+longlink)\r
+ fi\r
+ fi;\r
+ if t1=t3 then exit fi;\r
+ od;\r
+ fi;\r
+ end Sinsert;\r
+\r
+\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit Compactify : procedure ;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+ (* Compactify squeezes the memory of objects and virtual addresses *)\r
+ (* collecting first garbage *)\r
+ (* *)\r
+ (* - a play in nine acts - *)\r
+ (* *)\r
+ (*-----------------------------------------------------------------*)\r
+\r
+\r
+ const skilled = -1; (* dummy prototype for killed objects *)\r
+ var nlength: integer; (* variable for keeping free space length *)\r
+\r
+ (*----------------------------------------------------------------*)\r
+ unit nonefy :procedure (am:integer);\r
+ (* one of the actions for Traverse, converts none to <0,0> *)\r
+ begin\r
+ if M(am+1) =/= M(M(am)+1)\r
+ then\r
+ M(am):=0; M(am+1):=0\r
+ fi;\r
+ end nonefy;\r
+\r
+ (*----------------------------------------------------------------*)\r
+\r
+ unit relocate: procedure(am:integer);\r
+\r
+ (* one of the actions for Traverse, updates virtual address *)\r
+ (* for none=<0,0> a proper updating requires M[1]=0 *)\r
+ begin\r
+ M(am):=M(M(am)+1); M(am+1):=0;\r
+ end relocate;\r
+\r
+\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit Traverse :procedure(am:integer; procedure action(i:integer));\r
+\r
+ (* this procedure is used for compactification of memory and it *)\r
+ (* traverses all references in an object pointed by am and *)\r
+ (* performs action(i) on each of them *)\r
+\r
+\r
+ (*---------------------------------------------------------------*)\r
+\r
+ unit Pointed : procedure (acron:integer,references:Offsets);\r
+\r
+ (* this recursive procedure performs action(i) on references *)\r
+ (* defined by the compiler and encoded in the structure Offsets *)\r
+ (* in a subframe starting from acron *)\r
+\r
+ var i,k: integer,\r
+ b: boolean,\r
+ L: List,\r
+ Lr: Listref,\r
+ S: Segment,\r
+ R: Repeated,\r
+ working: Elem,\r
+ workinge: Elemex,\r
+ ref: Offsets;\r
+ begin\r
+ if references=none then return fi; (* no references *)\r
+ if references is Listref\r
+ then\r
+ Lr:=references;\r
+ working:=Lr.head; (* initialize list scan *)\r
+ for i:=1 to Lr.length\r
+ do\r
+ k:=working.offset;\r
+ call action(acron+k);\r
+ working:=working.next;\r
+ od;\r
+ return;\r
+ fi;\r
+ if references is Segment\r
+ then\r
+ S:=references;\r
+ for i:=S.start step reflength to S.finish\r
+ do (* for a reference value *)\r
+ call action(acron+i)\r
+ od;\r
+ return;\r
+ fi;\r
+ if references is Repeated\r
+ then\r
+ R:=references;\r
+ k:=acron;\r
+ for i:=1 to R.ntimes\r
+ do\r
+ call Pointed(k,R.references);\r
+ k:=k+R.size;\r
+ od;\r
+ return;\r
+ fi;\r
+ if references is List\r
+ then\r
+ L:=references;\r
+ workinge:=L.head; (* initialize list scan *)\r
+ for i:=1 to L.length\r
+ do\r
+ k:=workinge.offset;\r
+ ref:=workinge.references;\r
+ call Pointed(acron+k,ref);\r
+ workinge:=workinge.next;\r
+ od;\r
+ return;\r
+ fi;\r
+\r
+ end Pointed;\r
+\r
+ (*---------------------------------------------------------------*)\r
+\r
+ var a: Prtp,\r
+ references: Offsets,\r
+ pt: integer,\r
+ kind,i: integer;\r
+\r
+ (* body of Traverse *)\r
+ begin\r
+ pt:=M(am);\r
+ if pt<0 then pt:=-pt fi; (* if object marked pt<0 *)\r
+ a:=PROT(pt); (* a is object prototype *)\r
+ if a in Prtpsimpl\r
+ then\r
+ references:=a qua Prtpsimpl.references;\r
+ call Pointed(am,references);\r
+ if a in Prtpmod\r
+ then\r
+ call action(a qua Prtpmod.Dl(am));\r
+ call action(a qua Prtpmod.Sl(am));\r
+ fi;\r
+ else (* adjustable array *)\r
+ if a is Prtparpr (* primitive elements *)\r
+ then\r
+ return; (* do nothing *)\r
+ fi;\r
+ if a is Prtparrf (* reference elements *)\r
+ then (* for array elements *)\r
+ for i:=am+elmoffset step reflength to am+a.Size(am)-1\r
+ do\r
+ call action(i); (* do action *)\r
+ od;\r
+ else (* for structured *)\r
+ references:=a qua Prtparstr.references;\r
+ call Pointed(am+elmoffset,references);\r
+ fi;\r
+ fi;\r
+ end Traverse;\r
+\r
+\r
+ (*-------------------------------------------------------------------*)\r
+ unit act1: procedure;\r
+\r
+ (* garbage collection is performed in the following way : *)\r
+ (* all objects reachable from the current one are visited and *)\r
+ (* marked; the way of marking uses M[am]=pt and changes it to *)\r
+ (* the negative value M[am]=-pt; when dictionary of virtual *)\r
+ (* addresses is scaned in act4, then non-marked objects are *)\r
+ (* killed and marked objects are corrected, i.e. M[am]:=pt *)\r
+\r
+ (*---------------------------------------------------------------*)\r
+ unit mark: procedure (i:integer);\r
+\r
+ (* procedure analyzes reference <M[i],M[i+1]>; if it denotes *)\r
+ (* an alive object, then for such an object marking is done *)\r
+ (* and for all which are pointed from it *)\r
+ var am:integer;\r
+ begin\r
+ if Member(i)\r
+ then\r
+ am:=Physical(i);\r
+ if M(am)>0 (* object not yet marked *)\r
+ then\r
+ M(am):=-M(am); (* mark this object *)\r
+ call Traverse(am,mark); (* mark reachable from am *)\r
+ fi;\r
+ fi;\r
+ end mark;\r
+\r
+ (*---------------------------------------------------------------*)\r
+ var am: integer;\r
+\r
+ begin\r
+ am:=Physical(current);\r
+ M(am):=-M(am); (* mark current object *)\r
+ call Traverse(am,mark); (* visit all reachable *)\r
+ end act1;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+ unit act2: procedure;\r
+\r
+ (* scans freeitem list and puts counter = maxcounter so that *)\r
+ (* each unusable entry M[ah],M[ah+1] has the form x,maxcounter *)\r
+\r
+ var t1: integer;\r
+\r
+ begin\r
+\r
+ t1:=freeitem;\r
+ while t1=/=0\r
+ do\r
+ M(t1+1):=maxcounter; t1:=M(t1)\r
+ od;\r
+\r
+ end act2;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit act3: procedure;\r
+\r
+ (* scans thru dictionary table and for alive addresses *)\r
+ (* a corrects the value of Statsl in Sl fathers *)\r
+\r
+ var t1,t2,t3: integer,\r
+ b: Prtpmod,\r
+ a: Prtp;\r
+ begin\r
+ for t1:=lastitem step reflength to upr\r
+ do\r
+ if M(t1+1)=/=maxcounter (* alive object *)\r
+ then\r
+ t2:=M(t1); (* t2 = am of object *)\r
+ if M(t2)>0 (* object to be killed *)\r
+ then\r
+ a:=PROT(M(t2));\r
+ if a in Prtpmod\r
+ then\r
+ b:=a; t2:=b.Sl(t2);\r
+ t2:=Physical(t2);\r
+ b:=PROT(abs(M(t2)));\r
+ t3:=b.Statsl(t2); M(t3):=M(t3)-1;\r
+ fi;\r
+ fi;\r
+ fi;\r
+ od;\r
+ end act3;\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit act4: procedure;\r
+\r
+ (* scans thru dictionary table and for alive addresses *)\r
+ (* exchanges M[am-lspan],M[am],M[ah] with M[am],ah,M[am-lspan]; *)\r
+ (* objects marked by procedure prologue are put to killed list *)\r
+ (* ATTENTION!!! *)\r
+ (* when lspan=0 we have a special case, cf. act4,act5 and act7 *)\r
+\r
+\r
+ var t1,t2,t3: integer,\r
+ a: Prtp;\r
+ begin\r
+ for t1:=lastitem step reflength to upr\r
+ do\r
+ if M(t1+1)=/=maxcounter (* alive object *)\r
+ then\r
+ t2:=M(t1); (* t2 = am of object *)\r
+ if M(t2)<0 (* marked object *)\r
+ then\r
+ M(t2):=-M(t2) (* reconstruct pt *)\r
+ else\r
+ M(t1+1):=maxcounter; (* kill address *)\r
+ a:=PROT(M(t2)); (* a is object prot. *)\r
+ t3:=a.Size(t2); (* t3 is object size *)\r
+ t2:=t2-a.Ptposition; (* move t2 to begin. *)\r
+ M(t2):=t3;\r
+ call Sinsert(t2); (* kill this object *)\r
+ repeat; (* skip the rest *)\r
+ fi;\r
+ a:=PROT(M(t2));\r
+ if a.Ptposition=/=0 (* prot.numb.not first *)\r
+ then\r
+ t3:=t2-a.Ptposition; M(t1):=M(t3);\r
+ M(t3):=M(t2); M(t2):=t1;\r
+ else (* prot. num. first *)\r
+ M(t1):=M(t2+1); M(t2+1):=t1\r
+ fi;\r
+ fi;\r
+ od;\r
+ end act4;\r
+\r
+ (*----------------------------------------------------------------*)\r
+\r
+ unit act5: procedure;\r
+\r
+ (* marks the killed objects substituting prototype number to *)\r
+ (* a special value, so that during scanning memory we will be *)\r
+ (* able to tell apart the killed objects just by such a number; *)\r
+ (* the length of a killed object is put on the M[i+shortlink] *)\r
+\r
+ var t1,t2,t3: integer;\r
+\r
+ begin\r
+ t1:=headk2;\r
+ while t1 =/= 0\r
+ do\r
+ t2:=M(t1+shortlink); M(t1+shortlink):=2;\r
+ M(t1):=skilled; t1:=t2;\r
+ od;\r
+ t1:=headk;\r
+ while t1 =/= lwr\r
+ do\r
+ t2:=t1;\r
+ while t2 =/=0\r
+ do\r
+ t3:=M(t2+shortlink); M(t2+shortlink):=M(t2);\r
+ M(t2):=skilled; t2:=t3\r
+ od;\r
+ t1:=M(t1+longlink);\r
+ od;\r
+\r
+ end act5;\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ (* Now we can scan the memory without looking at dictionary *)\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ unit act6: procedure;\r
+\r
+ (* scans thru the memory and for alive objects call traverse *)\r
+ (* in order to set virtual addresses equal none identical to <0,0> *)\r
+ (* RS auxiliary references are also corrected *)\r
+\r
+ var t1,t2,t3,t4,t5: integer,\r
+ a: Prtp;\r
+\r
+ begin\r
+ t1:=lwr+1;\r
+ while t1 <= lastused\r
+ do\r
+ if M(t1)=/=skilled (* alive object *)\r
+ then\r
+ t3:=M(t1); a:=PROT(t3); (* a - prototype *)\r
+ if a.Ptposition =/=0\r
+ then\r
+ t2:=t1+a.Ptposition; t4:=M(t2);\r
+ M(t1):=M(t4); (* reconstruct M[t1] *)\r
+ M(t2):=t3; (* reconstruct M[t2] *)\r
+ else\r
+ t4:=M(t1+1); M(t1+1):=M(t4); (* reconstruct M[t1+1] *)\r
+ t2:=t1;\r
+ fi;\r
+ t5:=a.Size(t2); (* object size *)\r
+ call Traverse(t2,nonefy); (* set none to <0,0> *)\r
+ if a.Ptposition =/=0\r
+ then\r
+ M(t2):=t4; M(t1):=t3;\r
+ else\r
+ M(t1+1):=t4\r
+ fi;\r
+ t1:=t1+t5\r
+ else\r
+ t1:=t1+M(t1+shortlink) (* M[t1+shortlink]=size *)\r
+ fi\r
+ od;\r
+ for t1:=virt1 step reflength to virtn\r
+ do\r
+ call nonefy(t1);\r
+ od;\r
+ end act6;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit act7: procedure;\r
+\r
+ (* squeezes dictionary putting on counters new values of ah *)\r
+\r
+ var t1,t2,t3: integer;\r
+\r
+ begin\r
+\r
+ t1:=upr-1; t2:=t1;\r
+ while t1>= lastitem\r
+ do\r
+ if M(t1+1)=maxcounter (* entry killed *)\r
+ then\r
+ M(t1+1):=0\r
+ else\r
+ M(t1+1):=t2; t2:=t2-reflength;\r
+ fi;\r
+ t1:=t1-reflength;\r
+ od;\r
+ end act7;\r
+\r
+ (*-------------------------------------------------------------------*)\r
+\r
+ unit act8: procedure;\r
+\r
+ (* squeezes the memory, killed objects are removed, remaining pushed *)\r
+ (* for alive objects references are relocated .i.e. new ah and new *)\r
+ (* counters are computed;M[am-lspan], M[am], M[ah] are reconstructed *)\r
+ (* finally all auxiliary RS references are also relocated *)\r
+\r
+ var t1,t2,t3,t4,t5,t6: integer,\r
+ a: Prtp;\r
+\r
+ begin\r
+ M(1):=0; (* M[1]=0 for relocate *)\r
+ t1:=lwr+1; t2:=t1;\r
+ while t1 <= lastused\r
+ do\r
+ if M(t1)=skilled (* ignore this object *)\r
+ then\r
+ t1:=t1+M(t1+shortlink) (* M[t1+shortlink]=size *)\r
+ else\r
+ t6:=M(t1); (* prototype number *)\r
+ a:=PROT(t6); (* object prototype *)\r
+ t4:=t1+a.Ptposition; (* t4 is amold *)\r
+ if a.Ptposition=/=0\r
+ then\r
+ t5:=M(t4); (* t5 is old ah *)\r
+ M(t4):=t6; (* reconstruct M[t4] *)\r
+ M(t1):=M(t5); (* reconstruct M[t1] *)\r
+ else\r
+ t5:=M(t1+1); (* t5 is old ah *)\r
+ M(t1+1):=M(t5); (* reconstruct M[t1+1] *)\r
+ fi;\r
+ t3:=a.Size(t4);\r
+ for t6:=0 to t3-1 (* copy object *)\r
+ do\r
+ M(t2+t6):=M(t1+t6);\r
+ od;\r
+ t6:=t2+a.Ptposition; (* t6 is amnew *)\r
+ M(t5):=t6; (* set proper M[ah] *)\r
+ call Traverse(t6,relocate);\r
+ t1:=t1+t3;\r
+ t2:=t2+t3;\r
+ fi;\r
+ od;\r
+ (* relocate RS auxiliary references *)\r
+ for t1:=virt1 step reflength to virtn\r
+ do\r
+ call relocate(t1);\r
+ od;\r
+ (* initialize working variables *)\r
+ M(1):=1; (* reconstruct M[1] *)\r
+ lastused:=t2-1; headk2:=0;\r
+ headk:=lwr;\r
+ end act8;\r
+\r
+ (*------------------------------------------------------------------*)\r
+\r
+ unit act9: procedure;\r
+\r
+ (* squeezes dictionary *)\r
+\r
+ var t1,t2,t3: integer;\r
+\r
+ begin\r
+ t1:=upr+1; t2:=t1-reflength;\r
+ while t2 >=lastitem\r
+ do\r
+ t3:=M(t2+1);\r
+ if t3 =/=0\r
+ then\r
+ M(t3):=M(t2); M(t3+1):=0;\r
+ t1:=t3;\r
+ fi;\r
+ t2:=t2-reflength;\r
+ od;\r
+ lastitem:=t1; freeitem:=0;\r
+\r
+ end act9;\r
+\r
+\r
+ (*----------------------------------------------------------------*)\r
+ var i: integer;\r
+ (* Compactify body *)\r
+ begin\r
+ nlength:=lastitem-lastused;\r
+ call act1; call Memorydump;\r
+ call act2; call Memorydump;\r
+ call act3; call Memorydump;\r
+ call act4; call Memorydump;\r
+ call act5; call Memorydump;\r
+ call act6; call Memorydump;\r
+ call act7; call Memorydump;\r
+ call act8; call Memorydump;\r
+ call act9; call Memorydump;\r
+ writeln(" compactifier used;released space=", lastitem-lastused-nlength);\r
+ end Compactify;\r
+\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit Memorydump : procedure;\r
+\r
+\r
+ var i,j,k,l,u: integer;\r
+\r
+\r
+ begin\r
+ writeln;\r
+ writeln(" SYSTEM VARIABLES");\r
+ writeln("freeitem lastused lastitem headk headk2 lwr upr");\r
+ write(freeitem:8); write(lastused:8); write(lastitem:8);\r
+ write(headk:6);write(" "); write(headk2:6);write(" ");\r
+ write(lwr:4);write(" "); writeln(upr:4);\r
+ writeln(" VIRTUAL ADDRESSES");\r
+ l:=upr-1;\r
+ do\r
+ if l-18 > lastitem then u:=l-18 else u:=lastitem fi;\r
+ write(" ah ");\r
+ for i:=l step reflength downto u do write(' ',i:5) od;\r
+ writeln;\r
+ write(" M[ah] ");\r
+ for i:=l step reflength downto u do write(' ',M(i):5) od;\r
+ writeln;\r
+ write(" M[ah+1]");\r
+ for i:=l step reflength downto u do write(' ',M(i+1):5) od;\r
+ writeln;\r
+ if u=lastitem then exit else l:=u-reflength fi;\r
+ od;\r
+ writeln(" OBJECTS");\r
+ j:=0;\r
+ for i:=0 to lastused\r
+ do\r
+ write(' ',M(i):5); j:=j+1;\r
+ if j=10\r
+ then\r
+ writeln; j:=0;\r
+ fi;\r
+ od;\r
+ writeln;\r
+ end Memorydump;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+\r
+ (* MEMORY body *)\r
+ begin\r
+ array M dim (0:upr); (* main memory *)\r
+ M(0):=0; M(1):=1; (* <0,0> = none *)\r
+ freeitem:=0; lastused:=lwr;\r
+ headk:=lwr; headk2:=0;\r
+ lastitem:=upr+1; M(lwr):=maxapp; (* sentinel of killed *)\r
+ end MEMORY;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+(****************************************************************************)\r
+(* *)\r
+(* OBJECTS *)\r
+(* inherits MEMORY *)\r
+(* *)\r
+(* *)\r
+(* used to open a new object and pass *)\r
+(* the control to and back *)\r
+(* *)\r
+(* Sl links are used to keep the syntactic environment of an object. *)\r
+(* Dl links inform where to pass the control back from an object. *)\r
+(* *)\r
+(* Sl links create a tree structure on the set of objects; this tree *)\r
+(* is embedable into the decl syntactic tree. *)\r
+(* Dl links create a structure formed from the active chain and *)\r
+(* and a number of cycles corresponding to suspended coroutines *)\r
+(* or terminated objects. *)\r
+(* New statement adds a new object with Sl,Dl defined as usually. *)\r
+(* Return statement in any object sets Dl to itself. *)\r
+(* End statement in coroutines sets LSC to zero. *)\r
+(* End statement in the other objects is equivalent to return. *)\r
+(* *)\r
+(****************************************************************************)\r
+\r
+unit OBJECTS: MEMORY class;\r
+\r
+\r
+ var IC: integer, (* global control indicator *)\r
+ DISPLAY: integer; (* pointer to Display array allocated *)\r
+ (* in main block *)\r
+\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit Openrc: procedure (pt,X:integer);\r
+\r
+ (* opens a new frame for a simple class whose prototype *)\r
+ (* defined by pt;reference to an object is returned at M[X] *)\r
+\r
+ var a: Prtpsimpl,\r
+ length: integer;\r
+\r
+ begin\r
+ a:=PROT(pt); length:=a.Size(0); (* dummy parameter *)\r
+ call Request(pt,length,X);\r
+ end Openrc;\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit Slopen :procedure(pt,X,Y:integer);\r
+\r
+ (* opens a new frame for an object with given Sl at M[Y] *)\r
+ (* returns reference at M[X] *)\r
+\r
+ var am: integer,\r
+ length: integer,\r
+ a,b: Prtpmod,\r
+ Stat: integer,\r
+ Sl,Dl: integer;\r
+\r
+ begin\r
+ a:=PROT(pt); length:=a.Size(0); (* dummy parameter *)\r
+ call Request(pt,length,X);\r
+ am:=Physical(X);\r
+ Sl:=a.Sl(am);\r
+ call Refmove(Sl,Y); (* define Sl link *)\r
+ Dl:=a.Dl(am);\r
+ call Refmove(Dl,current); (* define Dl link *)\r
+ am:=Physical(Y);\r
+ a:=PROT(M(am));\r
+ Stat:=a.Statsl(am);\r
+ M(Stat):=M(Stat)+1; (* advance Statusl *)\r
+ end Slopen;\r
+\r
+ (*------------------------------------------------------------------------*)\r
+\r
+ unit Dopen :procedure (pt1,pt2,X: integer);\r
+\r
+ (* opens a new frame for a visible object, so Sl is taken from Display *)\r
+ (* it corresponds to a statement "new C" executed in a module "B" *)\r
+ (* where C is defined by pt1 and B by pt2 *)\r
+\r
+\r
+ var a,b: Prtpmod;\r
+\r
+ begin\r
+ a:=PROT(pt1) qua Prtpmod.declto; (* prototype of father C *)\r
+ b:=PROT(pt2); (* prototype of B *)\r
+ call Slopen(pt1,X,DISPL(b.perm(a.level)));\r
+ end Dopen;\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit Openarray: procedure (pt,l,u,X:integer);\r
+\r
+ (* performs generation newarray[l..u] of type defined by pt *)\r
+\r
+ var length: integer,\r
+ am: integer,\r
+ a: Prtparr,\r
+ references: Offsets;\r
+ begin\r
+ length:=u-l+1; a:=PROT(pt);\r
+ if a in Prtparnst\r
+ then\r
+ length:=length*a qua Prtparnst.elsize;\r
+ else\r
+ length:=length*a qua Prtparstr.references.size\r
+ fi;\r
+ length:=length+elmoffset; (* add system attributes *)\r
+ call Request(pt,length,X); am:=Physical(X);\r
+ M(am+lboffset):=l; M(am+uboffset):=u;\r
+ end Openarray;\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit Go : procedure(X:integer);\r
+\r
+ (* transfers control to the newly created object defined by X *)\r
+\r
+ var a,b: Prtpmod,\r
+ am: integer;\r
+\r
+ begin\r
+ am:=Physical(current);\r
+ a:=PROT(M(am));\r
+ M(a.Lsc(am)):=IC; (* save local control *)\r
+ call Update(X);\r
+ call Refmove(current,X); (* new current *)\r
+ am:=Physical(X);\r
+ a:=PROT(M(am));\r
+ b:=a;\r
+ while a=/=none (* search in prefix seq. *)\r
+ do (* first non-simple class *)\r
+ if not a is Prtpsimpl\r
+ then\r
+ b:=a;\r
+ fi;\r
+ a:=a.prefto;\r
+ od;\r
+ IC:=b.codeadd;\r
+ end Go;\r
+\r
+ (*------------------------------------------------------------------------*)\r
+\r
+ unit Back: procedure;\r
+\r
+ (* return from a module is Back *)\r
+ (* end in non-coroutine is equivalent to Back *)\r
+ (* end in coroutine is equivalent to Endcor, cf. COROUTINES *)\r
+\r
+ var Dl: integer,\r
+ am: integer,\r
+ a: Prtpmod;\r
+\r
+ begin\r
+ am:=Physical(current);\r
+ a:=PROT(M(am));\r
+ Dl:=a.Dl(am);\r
+ if not Member(Dl) (* return in main or in *)\r
+ then (* attached coroutine is *)\r
+ return (* equivalent to empty *)\r
+ fi;\r
+ call Refmove(virt2,current); (* set proper output *)\r
+ M(a.Lsc(am)):=IC; (* update local seq. cont. *)\r
+ call Refmove(current,Dl); (* current becomes Dl *)\r
+ call Refmove(Dl,virt2); (* set Dl in old to itself *)\r
+ call Update(current);\r
+ am:=Physical(current);\r
+ a:=PROT(M(am)); (* prototype of new object *)\r
+ IC:=M(a.Lsc(am)); (* IC is local seq. contr. *)\r
+ end Back;\r
+\r
+ (*------------------------------------------------------------------------*)\r
+\r
+\r
+ unit Inn: procedure (k:integer);\r
+\r
+ (* simulates the execution of inner in a class, k is pslength *)\r
+ (* of a class where inner is executed *)\r
+\r
+\r
+ var t: integer,\r
+ am: integer,\r
+ a: Prtpsub;\r
+\r
+ begin\r
+ am:=Physical(current);\r
+ a:=PROT(M(am)); (* prototype of current *)\r
+ if a.pslength=/=k (* if inner=/= empty *)\r
+ then\r
+ for t:=2 to a.pslength-k (* search for a layer *)\r
+ do\r
+ a:=a.prefto;\r
+ od;\r
+ IC:=a.codeadd;\r
+ fi;\r
+ end Inn;\r
+\r
+ (*------------------------------------------------------------------------*)\r
+\r
+\r
+ unit Endrun: procedure;\r
+ var i: integer;\r
+ (* end or return in main block *)\r
+ begin\r
+ writeln(" Print memory? (0,1)");\r
+ read(i);\r
+ if i=1\r
+ then\r
+ call Compactify;\r
+ call Memorydump\r
+ fi;\r
+ raise Error("End of a program execution");\r
+ end Endrun;\r
+\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit prf: function (X:integer, a: Prtpmod): boolean;\r
+\r
+ (* determines whether prototype a belongs to a prefix sequence of X *)\r
+ var b: Prtpmod,\r
+ am: integer;\r
+ begin\r
+ result:=false;\r
+ am:=Physical(X);\r
+ b:=PROT(M(am));\r
+ while b =/= none\r
+ do\r
+ if a=b then result:=true; return; fi;\r
+ b:=b.prefto;\r
+ od;\r
+ end prf;\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit qual : procedure (X: integer , a: Prtpmod);\r
+\r
+ (* validate qualification of object X by class type a *)\r
+ begin\r
+ if not prf(X,a)\r
+ then\r
+ call Raising(incorqua,virt2);\r
+ fi;\r
+ end qual;\r
+\r
+ (*---------------------------------------------------------------------*)\r
+\r
+ unit inl: function (X:integer, a:Prtp): boolean;\r
+\r
+ (* validate X in a *)\r
+ begin\r
+ if not Member(X)\r
+ then (* none is in everything *)\r
+ result:=true;\r
+ else\r
+ result:=prf(X,a);\r
+ fi;\r
+ end inl;\r
+\r
+ (*------------------------------------------------------------------------*)\r
+\r
+ unit isl : function (X:integer, a:Prtp): boolean;\r
+ (* validate X is a *)\r
+ var am: integer;\r
+ begin\r
+ if not Member(X)\r
+ then (* none is not something *)\r
+ result:=false;\r
+ else\r
+ am:=Physical(X);\r
+ result:=PROT(M(am))=a;\r
+ fi\r
+ end isl;\r
+\r
+ (*-------------------------------------------------------------------------*)\r
+\r
+ unit typeref: procedure (X:integer, a: Prtp);\r
+\r
+ (* check correctness of assignment Y:=X where type of Y is a *)\r
+ begin\r
+ if Member(X) (* none allowed everywhere *)\r
+ then\r
+ if not prf(X,a)\r
+ then\r
+ call Raising(incorassg,virt2); (* incorrect assignment *)\r
+ fi;\r
+ fi;\r
+ end typeref;\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit typed :procedure (ldim,rdim,X:integer;a,b:Prtp);\r
+\r
+ (* check correctness of Y:=X where X and Y are adjustable arrays *)\r
+ (* type of Y is array ldim of a, type of X is array rdim of b *)\r
+ begin\r
+ if ldim=/=rdim\r
+ then\r
+ call Raising(incorassg,virt2); (* incorrect assignment *)\r
+ fi;\r
+ if ldim=0\r
+ then\r
+ call typeref(X,a)\r
+ else\r
+ if a=/=b\r
+ then\r
+ call Raising(incorassg,virt2); (* incorrect assignment *)\r
+ fi;\r
+ fi;\r
+ end typed;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit gkill : procedure (X:integer);\r
+\r
+\r
+ (* general killer of pointed objects *)\r
+ (* It can kill an object of array or simple class, as well as *)\r
+ (* a cycle of coroutine. In the latter case because of calls *)\r
+ (* to procedure killer which kills SL chain (if possible) one *)\r
+ (* must change the order of this cycle. Taking this cycle in *)\r
+ (* reverse order we can call killer with security that the *)\r
+ (* whole cycle will be properly deallocated. This method bases *)\r
+ (* strongly on the fact that if X Dl Y, then not Y Sl* X. *)\r
+\r
+ var a: Prtp,\r
+ b: Prtpmod,\r
+ Dl: integer,\r
+ am: integer;\r
+ begin\r
+ if not Member(X) then return fi; (* kill only alive object *)\r
+ am:=Physical(X);\r
+ a:=PROT(M(am));\r
+ if a in Prtparr orif a is Prtpsimpl (* no problems with arrays *)\r
+ then (* or with records *)\r
+ call Disp(X); return;\r
+ fi;\r
+ if a is Prtpclass (* kill class if possible *)\r
+ then\r
+ b:=a;\r
+ if M(b.Statsl(am))=/=0\r
+ then\r
+ call Raising(incorkill,virt2)\r
+ fi;\r
+ call Refmove(virt3,b.Sl(am));\r
+ call Disp(X);\r
+ call killer;\r
+ return;\r
+ fi;\r
+ if a is Prtpproc then call Raising(incorkill,virt2) fi;\r
+\r
+ (* kill coroutine - methods in three phases *)\r
+ b:=a;\r
+ Dl:=X;\r
+ do (* first loop, examine all Statussl *)\r
+ call Refmove(virt4,Dl);\r
+ if M(b.Statsl(am))=/=0\r
+ then\r
+ call Raising(incorkill,virt2)\r
+ fi;\r
+ Dl:=b.Dl(am);\r
+ if Equal(X,Dl) then exit fi;\r
+ am:=Physical(Dl); b:=PROT(M(am));\r
+ od;\r
+ call Refmove(virt2,X);\r
+ do (* second loop, change the order *)\r
+ am:=Physical(virt2);\r
+ b:=PROT(M(am));\r
+ Dl:=b.Dl(am);\r
+ call Refmove(virt3,Dl);\r
+ call Refmove(Dl,virt4);\r
+ call Refmove(virt4,virt2);\r
+ call Refmove(virt2,virt3);\r
+ if Equal(virt2,X) then exit fi;\r
+ od;\r
+ do (* third loop, kill all objects *)\r
+ am:=Physical(X); b:=PROT(M(am));\r
+ call Refmove(virt3,b.Sl(am));\r
+ call Refmove(virt4,b.Dl(am));\r
+ call Disp(X);\r
+ call killer;\r
+ call Refmove(X,virt4);\r
+ if not Member(X) then exit fi;\r
+ od;\r
+ end gkill;\r
+\r
+\r
+ (*######################################################################*)\r
+ (* *)\r
+ (* END OF SPECIFICATION PART *)\r
+ (* *)\r
+ (*######################################################################*)\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit DISPL: function(d:integer): integer;\r
+ (* auxiliary function returning an address of DISPLAY[d] in M *)\r
+ begin\r
+ result:=DISPLAY+(d-1)*reflength;\r
+ end DISPL;\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit Update: procedure (X:integer);\r
+\r
+\r
+ (* Update DISPLAY procedure, see LNCS 208, pp.134-156 *)\r
+\r
+ var a,c,d,e: Prtpmod,\r
+ am: integer,\r
+ j,k: integer;\r
+\r
+\r
+ begin\r
+ am:=Physical(X);\r
+ a:=PROT(M(am)); k:=a.level;\r
+ d:=a; e:=a;\r
+ do\r
+ call Refmove(DISPL(e.perm(k)),X);\r
+ if k=1 then return fi;\r
+ k:=k-1;\r
+ j:=a.perminv(d.perm(k));\r
+ d:=d.declto;\r
+ do\r
+ c:=a.declto; X:=a.Sl(am); (* compute address of Sl *)\r
+ am:=Physical(X); (* take next object *)\r
+ a:=PROT(M(am));\r
+ j:= a.perminv(c.perm(j));\r
+ if a.level=j then exit fi\r
+ od\r
+ od\r
+ end Update;\r
+\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit killer: procedure;\r
+\r
+ (* this procedure kills Sl chain of virt3 , if Statussl allows it *)\r
+\r
+ var am: integer,\r
+ Stat: integer,\r
+ a: Prtpmod;\r
+\r
+ begin\r
+ do\r
+ am:=Physical(virt3); a:=PROT(M(am));\r
+ Stat:=a.Statsl(am); M(Stat):=M(Stat)-1;\r
+ if M(Stat)=0 (* StatusSl = 0 *)\r
+ andif (not a in Prtpclass) (* it is not class *)\r
+ andif Equal(virt3,a.Dl(am)) (* object terminated *)\r
+ then\r
+ call Refmove(virt2,a.Sl(am));\r
+ call Disp(virt3);\r
+ call Refmove(virt3,virt2);\r
+ else\r
+ exit\r
+ fi;\r
+ od;\r
+ end killer;\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ unit killafter: procedure;\r
+\r
+ (* this procedure kills an object of non-class after return *)\r
+ (* the reference to returned object is kept on virt2 always *)\r
+\r
+ var am: integer,\r
+ Stat: integer,\r
+ a: Prtpmod;\r
+\r
+ begin\r
+ am:=Physical(virt2);\r
+ a:=PROT(M(am));\r
+ Stat:=a.Statsl(am);\r
+ if M(Stat)=0\r
+ then\r
+ call Refmove(virt3,a.Sl(am));\r
+ call Disp(virt2);\r
+ call killer;\r
+ fi;\r
+ end killafter;\r
+\r
+\r
+ (*-----------------------------------------------------------------------*)\r
+\r
+ var i: integer,\r
+ am: integer,\r
+ a: Prtpmod;\r
+\r
+\r
+ (* OBJECTS body *)\r
+ begin\r
+ a:=PROT(1); (* a is prototype of main *)\r
+ i:=a.Size(0); (* i = length of main object *)\r
+ call Request(1,i,virt1);\r
+ am:=Physical(virt1); (* am is physical of main *)\r
+ DISPLAY:=am+a qua Prtpproc.displ; (* define address of DISPLAY[1] *)\r
+ current:=am+a qua Prtpproc.curr; (* define current *)\r
+ call Refmove(current,virt1);\r
+ call Refmove(DISPL(1),current); (* define Display for main *)\r
+ end OBJECTS;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ (************************************************************************)\r
+ (* *)\r
+ (* COROUTINES *)\r
+ (* *)\r
+ (* inherits OBJECTS *)\r
+ (* *)\r
+ (* performs coroutine sequencing *)\r
+ (* *)\r
+ (************************************************************************)\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ unit COROUTINES : OBJECTS class;\r
+\r
+ var lastcor: integer, (* reference to the last attaching coroutine *)\r
+ corhead: integer; (* reference to the active coroutine *)\r
+\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit Endcor: procedure ;\r
+\r
+ (* - in Loglan 82 coroutine end was equivalent to detach - *)\r
+ (* here, if lastcor=/=none attach(lastcor) else attach(main) *)\r
+ var\r
+ am: integer,\r
+ a: Prtpmod;\r
+\r
+ begin\r
+ am:=Physical(current);\r
+ a:=PROT(M(am));\r
+ IC:=0; (* prepare M(a.Lsc(am))=0 *)\r
+ if Member(lastcor)\r
+ then\r
+ call Attch(lastcor)\r
+ else\r
+ call Attch(virt1)\r
+ fi;\r
+ end Endcor;\r
+\r
+ (*----------------------------------------------------------------------*)\r
+\r
+ unit Attchaux: class(X: integer);\r
+\r
+ (* auxiliary for Attach and Attach with *)\r
+\r
+\r
+ var amnew: integer,\r
+ amold: integer,\r
+ Dl: integer,\r
+ a: Prtpmod,\r
+ b: Prtpcor;\r
+ begin\r
+ if not Member(X)\r
+ then\r
+ call Raising(ilattach,virt2);\r
+ fi;\r
+ amnew:=Physical(X); (* take physical of X *)\r
+ a:=PROT(M(amnew)); (* a is prototype of X *)\r
+ if not (a in Prtpcor)\r
+ then\r
+ call Raising(ilattach,virt2);\r
+ fi;\r
+ if M(a.Lsc(amnew))=0\r
+ then\r
+ call Raising(corterm,virt2);\r
+ fi;\r
+ if Equal(corhead,X) then return fi; (* equivalent to empty *)\r
+ call Refmove(virt2,corhead); (* save lastcoroutine *)\r
+ amold:=Physical(corhead); (* physical of head *)\r
+ b:=PROT(M(amold)); (* b is prototype of old *)\r
+ Dl:=b.Dl(amold); (* compute Dl of old *)\r
+ call Refmove(corhead,X); (* set coroutinehead *)\r
+ call Refmove(Dl,current); (* set Dl in old corout. *)\r
+ call Refmove(lastcor,virt2); (* set lastcor *)\r
+ b:=a; (* b is prototype of new *)\r
+ Dl:=b.Dl(amnew); (* compute Dl of new *)\r
+ amold:=Physical(current); (* compute current *)\r
+ a:=PROT(M(amold)); (* a prototype of curr. *)\r
+ M(a.Lsc(amold)):=IC; (* remember IC *)\r
+ end Attchaux;\r
+\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ unit Attch : Attchaux procedure;\r
+\r
+ (* performs Attach(X) *)\r
+\r
+ begin\r
+ call Update(Dl); (* update DISPLAY *)\r
+ call Refmove(current,Dl); (* set new current *)\r
+ call Setnone(Dl); (* Dl of corhead is none *)\r
+ amnew:=Physical(current); (* compute physical add. *)\r
+ a:=PROT(M(amnew)); (* a is prototype of cur.*)\r
+ IC:=M(a.Lsc(amnew)); (* define new IC *)\r
+ end Attch;\r
+\r
+ (*--------------------------------------------------------------------*)\r
+\r
+ (* body of COROUTINES *)\r
+ begin\r
+ lastcor:=am+ a qua Prtpproc . lstcr;\r
+ corhead:=am+ a qua Prtpproc . chead;\r
+ call Setnone(lastcor); (* lastcor=none *)\r
+ call Refmove(corhead,current); (* corhead=main *)\r
+ end COROUTINES;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ (************************************************************************)\r
+ (* *)\r
+ (* HANDLING *)\r
+ (* *)\r
+ (* inherits COROUTINES *)\r
+ (* *)\r
+ (* performs exception handling *)\r
+ (* *)\r
+ (************************************************************************)\r
+\r
+\r
+\r
+ unit HANDLING : COROUTINES class;\r
+\r
+ unit virtual Raising : procedure (signalnum,X:integer);\r
+\r
+ (* Procedure Raising implements raise statement. Parameter signalnum *)\r
+ (* defines signal number, M[X] returns the address of opened handler *)\r
+\r
+ var a: Prtpmod,\r
+ b: Prtpsub,\r
+ h: hlstelem,\r
+ am: integer,\r
+ Y: integer,\r
+ s: sglelem;\r
+\r
+ begin\r
+ Y:=current; (* start of searching *)\r
+ do (* main loop *)\r
+ am:=Physical(Y);\r
+ a:=PROT(M(am)); (* take prototype *)\r
+ if a is Prtphand (* for handlers skip *)\r
+ then (* to avoid recursiv. *)\r
+ Y:=a.Sl(am); (* handling;go via Sl *)\r
+ repeat; (* continue searching *)\r
+ fi;\r
+ b:=a;\r
+ do (* search prefix seq. *)\r
+ h:=b.handlist;\r
+ do (* search in module *)\r
+ if h=none then exit fi; (* end of handlist *)\r
+ if PROT(h.hand) qua Prtphand.oth (* for handler others *)\r
+ andif signalnum <= syssigl (* and system signals *)\r
+ then\r
+ call Slopen(h.hand,X,Y); (* open handler object *)\r
+ return;\r
+ fi;\r
+ s:=h.signlist;\r
+ do (* search signal list *)\r
+ if s = none then exit fi; (* end of signal list *)\r
+ if s.signalnum=signalnum (* handler found *)\r
+ then\r
+ call Slopen(h.hand,X,Y); (* open handler object *)\r
+ return;\r
+ fi;\r
+ s:=s.next;\r
+ od;\r
+ h:=h.next;\r
+ od;\r
+ b:=b.prefto;\r
+ if b=none then exit fi; (* end of prefix seq. *)\r
+ od;\r
+ Y:=a.Dl(am); (* go via Dl *)\r
+ if not Member(Y) then exit fi;\r
+ od;\r
+ raise Error(" Handler not found");\r
+ end Raising;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit Attchwith: Attchaux procedure (signalnum,Y:integer);\r
+\r
+ (* this procedure performs attach(X) with signalnum *)\r
+ (* Y points an object of a found handler *)\r
+ begin\r
+ call Refmove(virt4,current); (* save current *)\r
+ call Refmove(current,Dl); (* set new current *)\r
+ call Setnone(Dl); (* Dl of corhead is none *)\r
+ call Raising(signalnum,Y);\r
+ call Refmove(current,virt4); (* restore current *)\r
+ end Attchwith;\r
+\r
+ (*-----------------------------------------------------------------*)\r
+\r
+ unit Termination : procedure;\r
+\r
+ (* Procedure Termination winds up the dynamic chain moving Lsc *)\r
+ (* of each object on its lastwill part. For prefixed modules *)\r
+ (* lastwill is performed from the innermost to the outermost; *)\r
+ (* so, it is sufficient to move Lsc for the innermost module *)\r
+ (* and for end statement in prefixed modules a jump to the *)\r
+ (* prefix father lastwill statement is statically executed. *)\r
+ (* Dummy lastwill part in this solution is always required. *)\r
+ (* The last statement before lastwill in such modules passes *)\r
+ (* control to the corresponding post inner part, as usually. *)\r
+\r
+ var X: integer,\r
+ Y: integer,\r
+ a: Prtphand,\r
+ b: Prtpmod,\r
+ am: integer;\r
+ begin\r
+ am:=Physical(current); (* take address of handler *)\r
+ a:=PROT(M(am)); (* prototype of handler *)\r
+ X:=a.Sl(am); (* find handler Sl father *)\r
+ Y:=a.Dl(am); (* find handler Dl father *)\r
+ am:=Physical(X); (* set am the last address *)\r
+ do\r
+ Y:=Physical(Y);\r
+ b:=PROT(M(Y)); (* prototype of module *)\r
+ M(b.Lsc(Y)):=b.lstwill; (* move Lsc on lastwill *)\r
+ if Y=am then exit fi; (* end of chain *)\r
+ Y:=b.Dl(Y); (* next chain element *)\r
+ od;\r
+ end Termination;\r
+\r
+\r
+ end HANDLING;\r
+\r
+\r
+\r
+(*****************************************************************************)\r
+(* *)\r
+(* BODY PART OF PROGRAM *)\r
+(* *)\r
+(*****************************************************************************)\r
+\r
+ begin\r
+\r
+ pref HANDLING block\r
+\r
+ (************************************************************************)\r
+ (* *)\r
+ (* EXECUTOR *)\r
+ (* *)\r
+ (* inherits COROUTINES *)\r
+ (* *)\r
+ (* written only for testing RS *)\r
+ (************************************************************************)\r
+\r
+\r
+ var CODES : arrayof integer; (* program code *)\r
+\r
+ (*----------------------------------------------------------------*)\r
+ (* opcode: *)\r
+ (* 1 pt dn off 0 0 = Openrc(pt,X) *)\r
+ (* 2 pt dn1 off1 dn2 off2 = Slopen(pt,X,Y) *)\r
+ (* 3 pt1 pt2 dn off 0 = Dopen(pt1,pt2,X) *)\r
+ (* 4 pt dn1 off1 dn2 off2 = Openarr(pt,1,u,X) *)\r
+ (* 5 dn off 0 0 0 = Go(X) *)\r
+ (* 6 0 0 0 0 0 = Back address on virt2 *)\r
+ (* 7 k 0 0 0 0 = Inn(k) *)\r
+ (* 8 dn1 off1 dn2 off2 0 = a:=a+b *)\r
+ (* 9 " = a:=a-b *)\r
+ (* 10 " = a:=a*b *)\r
+ (* 11 " = a:=a/b *)\r
+ (* 12 dn1 off1 dn2 off2 s = a:=A[i] for s=0 *)\r
+ (* 13 dn1 off1 0 0 0 = A[i]:=a for s=1 *)\r
+ (* 14 dn off 0 0 0 = write(a) *)\r
+ (* 15 dn off 0 0 0 = read(a) *)\r
+ (* 16 0 0 0 0 0 = writeln *)\r
+ (* 17 C 0 0 0 0 = goto C *)\r
+ (* 18 C dn off 0 0 = if a=0 goto C *)\r
+ (* 19 C dn off 0 0 = if a>0 goto C *)\r
+ (* 20 dn off 0 0 0 = kill(X) *)\r
+ (* 21 dn1 off1 dn2 off2 0 = X:=Y *)\r
+ (* 22 dn off 0 0 0 = a:=0 *)\r
+ (* 23 dn off s 0 0 = a:=a+s *)\r
+ (* 24 dn1 off1 dn2 off2 off = a:=X.b *)\r
+ (* 25 dn1 off1 off dn2 off2 = X.a:=b *)\r
+ (* 26 dn1 off1 dn2 off2 off = Y:=X.Z *)\r
+ (* 27 dn1 off1 off dn2 off2 = Y.Z:=X *)\r
+ (* 28 0 0 0 0 0 = endrun *)\r
+ (* 29 dn off 0 0 0 = attach(X) *)\r
+ (* 30 0 0 0 0 0 = attach(lastcor) *)\r
+ (* 31 C dn off 0 0 = if X=none goto C *)\r
+ (* 32 0 0 0 0 0 = Endcor *)\r
+ (* 33 dn off pt 0 0 = qual X by a *)\r
+ (* 34 dn off 0 0 0 = gkill(X) *)\r
+ (* 35 dn off pt C 0 = if X in a goto C *)\r
+ (* 36 dn off pt C 0 = if X is a goto C *)\r
+ (* 37 dn off pt 0 0 = typeref(X,a) *)\r
+ (* 38 dn off pt pt1 0 = typed(k,s, *)\r
+ (* 39 k s 0 0 0 = X,pt,pt1) *)\r
+ (* 40 s dn off 0 0 = raise(s,X) *)\r
+ (* 41 0 0 0 0 0 = terminate *)\r
+ (* 42 0 0 0 0 0 = kill procedure on Dl *)\r
+ (* 43 dn1 off1 s dn2 off2 = attach(X) with s *)\r
+ (* 44 s dn1 off1 0 0 = attach(lastcor) with *)\r
+ (* 45 0 0 0 0 0 = attach(main) *)\r
+ (* 46 s dn1 off1 0 0 = attach(main) with s *)\r
+ (*----------------------------------------------------------------*)\r
+\r
+\r
+ unit Address: function(dnum,offset:integer):integer;\r
+ (* gives physical address of a variable pointed by dnum,offset *)\r
+ begin\r
+ result:=Physical(DISPL(dnum))+offset\r
+ end Address;\r
+\r
+ unit Arrelem: procedure(X,i:integer; output am,length:integer);\r
+ (* X - reference to array and i - index value *)\r
+ (* am -physical address element , length - element length *)\r
+\r
+ var a: Prtp,\r
+ pt: integer;\r
+ begin\r
+ am:=Physical(X); pt:=M(am); a:=PROT(pt);\r
+ if i<M(am+lboffset) orif i>M(am+uboffset)\r
+ then\r
+ call Raising(arrayind,virt2);\r
+ fi;\r
+ i:=i-M(am+lboffset);\r
+ if a in Prtparnst\r
+ then\r
+ length:=a qua Prtparnst. elsize;\r
+ am:=am+elmoffset+length * i;\r
+ else\r
+ length:=a qua Prtparstr.references.size;\r
+ am:=am+elmoffset+length * i;\r
+ fi;\r
+ end Arrelem;\r
+\r
+ var n: integer,\r
+ dn,off: integer,\r
+ dn1,off1: integer,\r
+ dn2,off2: integer,\r
+ pt,pt1,pt2: integer,\r
+ l,u,k,i,C,s: integer;\r
+\r
+ handlers\r
+ when Error: writeln; writeln(t); terminate;\r
+ end handlers;\r
+\r
+\r
+ (* EXECUTOR body *)\r
+\r
+ begin\r
+ read(f,n); n:=n*8;\r
+ (* each code requires 8 words, the first is the code number *)\r
+ (* 6 define an operation and arguments, see the table above *)\r
+ (* last=0,1,2 and defines trace and dump, last=1 gives trace *)\r
+ (* last=2 gives dump and trace simultaneously *)\r
+ writeln(" Print prototypes? (0,1)");\r
+ read(i);\r
+ if i=1 then call Protwrite fi;\r
+ writeln(" Print memory? (0,1)");\r
+ read(i);\r
+ if i=1 then call Memorydump fi;\r
+ array CODES dim (1:n);\r
+ for i:=1 to n do read(f,CODES(i)) od;\r
+ writeln(" Print codes? (0,1)");\r
+ read(i);\r
+ if i=1\r
+ then\r
+ writeln(" OPCODES ");\r
+ k:=0;\r
+ for i:=1 to n\r
+ do\r
+ write(CODES(i)); k:=k+1;\r
+ if k=8 then k:=0 ; writeln; fi;\r
+ od;\r
+ fi;\r
+ IC:=1;\r
+ do\r
+ C:=(IC-1)*8+1;\r
+ if CODES(C+7) >= 1\r
+ then\r
+ writeln(" code ");\r
+ write(CODES(C),CODES(C+1),CODES(C+2),CODES(C+3),CODES(C+4));\r
+ writeln(CODES(C+5),CODES(C+6));\r
+ fi;\r
+ if CODES(C+7) >= 2\r
+ then\r
+ writeln("memory dump"); call Memorydump;\r
+ fi;\r
+ case CODES(C+1)\r
+ when 1:\r
+ pt:=CODES(C+2);dn:=CODES(C+3); off:=CODES(C+4);\r
+ IC:=IC+1;\r
+ call Openrc(pt,Address(dn,off));\r
+ when 2:\r
+ pt:=CODES(C+2);dn1:=CODES(C+3);off1:=CODES(C+4);\r
+ dn2:=CODES(C+5);off2:=CODES(C+6);\r
+ IC:=IC+1;\r
+ call Slopen(pt,Address(dn1,off1),Address(dn2,off2));\r
+ when 3:\r
+ pt1:=CODES(C+2);pt2:=CODES(C+3);dn:=CODES(C+4);off:=CODES(C+5);\r
+ IC:=IC+1;\r
+ call Dopen(pt1,pt2,Address(dn,off));\r
+ when 4:\r
+ pt:=CODES(C+2);dn1:=CODES(C+3);off1:=CODES(C+4);\r
+ dn2:=CODES(C+5);off2:=CODES(C+6);\r
+ k:=M(Address(dn1,off1));\r
+ IC:=IC+1;\r
+ call Openarray(pt,1,k,Address(dn2,off2));\r
+ when 5:\r
+ dn:=CODES(C+2);off:=CODES(C+3);\r
+ IC:=IC+1;\r
+ call Go(Address(dn,off));\r
+ when 6:\r
+ dn:=CODES(C+2);off:=CODES(C+3);\r
+ IC:=IC+1;\r
+ call Back;\r
+ when 7:\r
+ k:=CODES(C+2);\r
+ IC:=IC+1;\r
+ call Inn(k);\r
+ when 8:\r
+ dn1:=CODES(C+2);off1:=CODES(C+3);\r
+ dn2:=CODES(C+4);off2:=CODES(C+5);\r
+ i:=Address(dn1,off1); k:=Address(dn2,off2);\r
+ M(i):=M(i)+M(k);\r
+ IC:=IC+1;\r
+ when 9:\r
+ dn1:=CODES(C+2);off1:=CODES(C+3);\r
+ dn2:=CODES(C+4);off2:=CODES(C+5);\r
+ i:=Address(dn1,off1); k:=Address(dn2,off2);\r
+ M(i):=M(i)-M(k);\r
+ IC:=IC+1;\r
+ when 10:\r
+ dn1:=CODES(C+2);off1:=CODES(C+3);\r
+ dn2:=CODES(C+4);off2:=CODES(C+5);\r
+ i:=Address(dn1,off1); k:=Address(dn2,off2);\r
+ M(i):=M(i)*M(k);\r
+ IC:=IC+1;\r
+ when 11:\r
+ dn1:=CODES(C+2);off1:=CODES(C+3);\r
+ dn2:=CODES(C+4);off2:=CODES(C+5);\r
+ i:=Address(dn1,off1); k:=Address(dn2,off2);\r
+ M(i):=M(i)/M(k);\r
+ IC:=IC+1;\r
+ when 12:\r
+ dn1:=CODES(C+2);off1:=CODES(C+3);\r
+ dn2:=CODES(C+4);off2:=CODES(C+5);\r
+ s:=CODES(C+6);\r
+ call Arrelem(Address(dn1,off1),M(Address(dn2,off2)),k,l);\r
+ dn1:=CODES(C+10);off1:=CODES(C+11);\r
+ u:= Address(dn1,off1);\r
+ if s=0\r
+ then\r
+ for i:= 0 to l-1 do M(u+i):=M(k+i) od;\r
+ else\r
+ for i:= 0 to l-1 do M(k+i):=M(u+i) od;\r
+ fi;\r
+ IC:=IC+2;\r
+ when 14:\r
+ dn:=CODES(C+2);off:=CODES(C+3);\r
+ write(M(Address(dn,off)));\r
+ IC:=IC+1;\r
+ when 15:\r
+ dn:=CODES(C+2);off:=CODES(C+3);\r
+ read(M(Address(dn,off)));\r
+ IC:=IC+1;\r
+ when 16:\r
+ writeln;\r
+ IC:=IC+1;\r
+ when 17:\r
+ IC:=CODES(C+2);\r
+ when 18:\r
+ dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);\r
+ if M(Address(dn,off))=0\r
+ then\r
+ IC:=C\r
+ else\r
+ IC:=IC+1;\r
+ fi;\r
+ when 19:\r
+ dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);\r
+ if M(Address(dn,off))>0\r
+ then\r
+ IC:=C\r
+ else\r
+ IC:=IC+1;\r
+ fi;\r
+ when 20:\r
+ dn:=CODES(C+2); off:=CODES(C+3);\r
+ IC:=IC+1;\r
+ call Disp(Address(dn,off));\r
+ when 21:\r
+ dn1:=CODES(C+2); off1:=CODES(C+3);\r
+ dn2:=CODES(C+4); off2:=CODES(C+5);\r
+ IC:=IC+1;\r
+ call Refmove(Address(dn1,off1),Address(dn2,off2));\r
+ when 22:\r
+ dn:=CODES(C+2); off:=CODES(C+3);\r
+ M(Address(dn,off)):=0;\r
+ IC:=IC+1;\r
+ when 23:\r
+ dn:=CODES(C+2); off:=CODES(C+3);\r
+ s:=CODES(C+4);\r
+ k:=Address(dn,off); M(k):=M(k)+s;\r
+ IC:=IC+1;\r
+ when 24:\r
+ dn1:=CODES(C+2); off1:=CODES(C+3);\r
+ dn2:=CODES(C+4); off2:=CODES(C+5); off:=CODES(C+6);\r
+ k:=Address(dn2,off2);\r
+ k:=Physical(k); k:=k+off;\r
+ M(Address(dn1,off1)):=M(k);\r
+ IC:=IC+1;\r
+ when 25:\r
+ dn1:=CODES(C+2); off1:=CODES(C+3); off:=CODES(C+4);\r
+ dn2:=CODES(C+5); off2:=CODES(C+6);\r
+ k:=Address(dn1,off1);\r
+ k:=Physical(k); k:=k+off;\r
+ M(k):= M(Address(dn2,off2));\r
+ IC:=IC+1;\r
+ when 26:\r
+ dn1:=CODES(C+2); off1:=CODES(C+3);\r
+ dn2:=CODES(C+4); off2:=CODES(C+5); off:=CODES(C+6);\r
+ k:=Address(dn2,off2);\r
+ k:=Physical(k); k:=k+off;\r
+ call Refmove(Address(dn1,off1),k);\r
+ IC:=IC+1;\r
+ when 27:\r
+ dn1:=CODES(C+2); off1:=CODES(C+3); off:=CODES(C+4);\r
+ dn2:=CODES(C+5); off2:=CODES(C+6);\r
+ k:=Address(dn1,off1);\r
+ k:=Physical(k); k:=k+off;\r
+ call Refmove(k,Address(dn2,off2));\r
+ IC:=IC+1;\r
+ when 28:\r
+ call Endrun;\r
+ when 29:\r
+ dn:=CODES(C+2); off:=CODES(C+3);\r
+ IC:=IC+1;\r
+ call Attch(Address(dn,off));\r
+ when 30:\r
+ IC:=IC+1;\r
+ call Attch(lastcor);\r
+ when 31:\r
+ dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);\r
+ if not Member(Address(dn,off))\r
+ then\r
+ IC:=C\r
+ else\r
+ IC:=IC+1;\r
+ fi;\r
+ when 32:\r
+ IC:=IC+1;\r
+ call Endcor;\r
+ when 33:\r
+ dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);\r
+ call qual(Address(dn,off),PROT(pt));\r
+ IC:=IC+1;\r
+ when 34:\r
+ dn:=CODES(C+2); off:=CODES(C+3);\r
+ call gkill(Address(dn,off));\r
+ IC:=IC+1;\r
+ when 35:\r
+ dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);\r
+ C:=CODES(C+5);\r
+ if inl(Address(dn,off),PROT(pt))\r
+ then\r
+ IC:=C\r
+ else\r
+ IC:=IC+1;\r
+ fi;\r
+ when 36:\r
+ dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);\r
+ C:=CODES(C+5);\r
+ if isl(Address(dn,off),PROT(pt))\r
+ then\r
+ IC:=C\r
+ else\r
+ IC:=IC+1;\r
+ fi;\r
+ when 37:\r
+ dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);\r
+ IC:=IC+1;\r
+ call typeref(Address(dn,off),PROT(pt));\r
+ when 38:\r
+ dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);\r
+ pt1:=CODES(C+5);\r
+ k:=CODES(C+10); s:=CODES(C+11);\r
+ IC:=IC+2;\r
+ call typed(k,s,Address(dn,off),PROT(pt),PROT(pt1));\r
+ when 40:\r
+ s:=CODES(C+2); dn:=CODES(C+3); off:=CODES(C+4);\r
+ IC:=IC+1;\r
+ call Raising(s,Address(dn,off));\r
+ when 41:\r
+ IC:=IC+1;\r
+ call Termination;\r
+ when 42:\r
+ IC:=IC+1;\r
+ call killafter;\r
+ when 43:\r
+ dn1:=CODES(C+2); off1:=CODES(C+3); s:=CODES(C+4);\r
+ dn2:=CODES(C+5); off2:=CODES(C+6);\r
+ IC:=IC+1;\r
+ call Attchwith(Address(dn1,off1),s,Address(dn2,off2));\r
+ when 44:\r
+ s:=CODES(C+2);\r
+ dn1:=CODES(C+3); off1:=CODES(C+4);\r
+ IC:=IC+1;\r
+ call Attchwith(lastcor,s,Address(dn1,off1));\r
+ when 45:\r
+ IC:=IC+1;\r
+ call Attch(virt1);\r
+ when 46:\r
+ s:=CODES(C+2);\r
+ dn1:=CODES(C+3); off1:=CODES(C+4);\r
+ IC:=IC+1;\r
+ call Attchwith(virt1,s,Address(dn1,off1));\r
+ esac;\r
+ od;\r
+ end\r
+end\r
+\r
+\1a\r
--- /dev/null
+In this directory one finds several files concerning the \r
+running system of new Loglan'84.\r
+\r
+1. running system of Loglan'84 in Loglan'82\r
+2. running system of Loglan'84 in C language\r
+3. files for testing the running system\r
+ i.e. loglan sources translated manually to executable-interpretable code.\r
+\r
+Ad 1 rsloglan.doc\r
+ antek5.txt\r
+Ad 2 antek6.txt\r
+Ad 3 antek3.txt & antek4.txt\r
+\r
+Remark. The running system has no notion of processes! It came later.\r
+\r
+All work was done by prof. Antoni Kreczmar.\r
+\r
+ Andrzej Salwicki\r
+\r
+\r
+Pau, le 26 Septembre 1994
\ No newline at end of file
--- /dev/null
+#include <String.h>
+#include <iostream.h>
+#include "Objects.h"
+
+#include "Expr.h"
+
+//**************************************
+//** **
+//** Objects decribing an expression **
+//** inside an abstract tree. **
+//** **
+//**************************************
+
+ostream& operator <<( ostream& stream, ExprType type )
+{
+ switch(type)
+ {
+ case Ident:
+ return stream << "Identifier";
+ case IntegerConst:
+ return stream << "Integer Constant";
+ case IntegerExpr:
+ return stream << "Integer expression";
+ case RealConst:
+ return stream << "Real Constant";
+ case RealExpr:
+ return stream << "Real expression";
+ case BoolConst:
+ return stream << "Boolean Constant";
+ case BoolExpr:
+ return stream << "Boolean expression";
+ case ObjExpr:
+ return stream << "Object expression";
+ case ObjConst:
+ return stream << "Object Constant";
+ case Other:
+ return stream << "Other";
+ case ExprError:
+ return stream << "Error Type";
+ default:
+ return stream << "Unknown value";
+ }
+}
+
+ostream& operator <<( ostream& stream, ArithOpType type )
+{
+ switch(type)
+ {
+ case Plus:
+ return stream << " Plus ";
+ case Minus:
+ return stream << " Minus ";
+ case Multiply:
+ return stream << " Multiply ";
+ case Divide:
+ return stream << " Divide ";
+ case IntDivide:
+ return stream << " Integer Divide";
+ case Modulo:
+ return stream << " Modulo ";
+ default:
+ return stream << "Unknown value";
+ }
+}
+
+ostream& operator <<( ostream& stream, BoolOpType type )
+{
+ switch(type)
+ {
+ case Less:
+ return stream << " Less ";
+ case LessOrEqual:
+ return stream << " Less Or Equal ";
+ case Equal:
+ return stream << " Equal ";
+ case NotEqual:
+ return stream << " Not Equal ";
+ case Greater:
+ return stream << " Greater ";
+ case GreaterOrEqual:
+ return stream << " Greater Or Equal ";
+ case Or:
+ return stream << " Or ";
+ case And:
+ return stream << " And ";
+ case AndIf:
+ return stream << " AndIf ";
+ case OrIf:
+ return stream << " OrIf ";
+ default:
+ return stream << "Unknown value";
+ }
+}
+
+ostream& operator <<( ostream& stream, ObjOpType type )
+{
+ switch(type)
+ {
+ case Qua:
+ return stream << " Qua ";
+ case Is:
+ return stream << " Is ";
+ case In:
+ return stream << " In ";
+ default:
+ return stream << "Unknown value";
+ }
+}
+
+Expression::Expression( ExprType rettype , Location *objloc )
+{
+ kind = "NullObject";
+ returntype = rettype;
+ place = objloc;
+}
+
+ostream& operator << ( ostream& stream , Expression ThisExp )
+{
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\nExpression :";
+#endif
+ ThisExp.Print( stream );
+ return stream;
+}
+
+void Expression::Print( ostream& stream )
+{
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\nkind :" << kind << \
+ "\ntype :" << type << \
+ "\nlocation :" << *place << \
+ "\nReturnType :" << returntype;
+#endif
+}
+
+IntegerConstant::IntegerConstant( int value, Location *TheLoc ) :
+ Expression( IntegerConst,TheLoc ),rvalue(value)
+{
+ kind = "IntegerConstant";
+}
+
+void IntegerConstant::Print( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream = stream << "\nRValue :" << rvalue;
+#else
+ stream << rvalue;
+#endif
+}
+
+RealConstant::RealConstant( double value, Location *TheLoc ) :
+ Expression( RealConst,TheLoc ),rvalue(value)
+{
+ kind = "RealConstant";
+}
+
+void RealConstant::Print( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream = stream << "\nRValue :" << rvalue;
+#else
+ stream << rvalue;
+#endif
+}
+
+BoolConstant::BoolConstant( int value, Location *TheLoc ) :
+ Expression( BoolConst, TheLoc ),rvalue(value)
+{
+ kind = "RealConst";
+}
+
+void BoolConstant::Print( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\nRValue :" << rvalue;
+#else
+ stream << rvalue;
+#endif
+}
+
+StringConstant::StringConstant( String *value, Location *TheLoc ) :
+ Expression( StringConst,TheLoc ),rvalue(value)
+{
+ kind = "StringConstant";
+}
+
+void StringConstant::Print( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\nRValue :" << *rvalue;
+#else
+ stream << *rvalue;
+#endif
+}
+
+CharConstant::CharConstant( char value, Location *TheLoc ) :
+ Expression( CharConst, TheLoc ),rvalue(value)
+{
+ kind = "CharConstant";
+}
+
+void CharConstant::Print( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\nRValue :" << rvalue;
+#else
+ stream << rvalue;
+#endif
+}
+
+Identifier::Identifier( String * TheName, Location *TheLoc ) :
+ Expression( Ident, TheLoc )
+{
+ kind = "Identifier";
+ Title = TheName;
+}
+
+Identifier::Identifier( Entry ThisEntry, Location *TheLoc ) :
+ Expression( Ident, TheLoc )
+{
+ kind = "Identifier";
+ Title = NULL;
+ Where = ThisEntry;
+}
+
+void Identifier::Print( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\nTitle :" << *Title;
+#else
+ stream << *Title ;
+#endif
+}
+
+NoneObject::NoneObject( Location *TheLoc ) : Expression( ObjConst, TheLoc )
+{
+ kind = "None";
+}
+
+Result::Result( Location *TheLoc ) : Expression( ObjConst, TheLoc )
+{
+ kind = "Result";
+}
+
+UnaryOperator::UnaryOperator( Expression * ThisExp, ExprType ret, Location *TheLoc ) :
+ Expression( ret, TheLoc )
+{
+ kind = "UnaryOperator";
+ Argument = ThisExp;
+ place = new Location(*(ThisExp->place) + *TheLoc);
+}
+
+void UnaryOperator::Print ( ostream& stream )
+{
+ Expression::Print(stream);
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\n((";
+ Argument->Print(stream);
+ stream << "\n))";
+#else
+ stream << '(';
+ Argument->Print(stream);
+ stream << ')';
+#endif
+}
+
+BinaryOperator::BinaryOperator( Expression *LeftExpr, Expression *RightExpr,
+ ExprType ret , Location *TheLoc ) :
+ Expression( ret, TheLoc )
+{
+ kind = "BinaryOperator";
+ LeftMember = LeftExpr;
+ RightMember = RightExpr;
+ place = new Location(*(LeftMember->place) + *TheLoc + *(RightMember->place));
+}
+
+virtual void BinaryOperator::Print( ostream& stream )
+{
+ Expression::Print( stream );
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ stream << "\n(\nLeft Member :\n";
+ LeftMember->Print( stream );
+ stream << " , ";
+ RightMember->Print( stream );
+ stream << "\n)";
+#else
+ stream << " ( ";
+ LeftMember->Print(stream);
+ stream << ' ' << kind << ' ';
+ RightMember->Print(stream);
+ stream << " ) ";
+
+#endif
+}
+
+BoolOperator::BoolOperator( Expression *LeftExpr, Expression *RightExpr,
+ BoolOpType TheOp , Location *TheLoc ) :
+ BinaryOperator( LeftExpr, RightExpr, Other,TheLoc )
+{
+ kind = "Boolean Operator";
+ OpKind = TheOp;
+
+ if ( (TheOp == Or) || (TheOp == And) )
+ switch( LeftExpr->returntype)
+ {
+ case BoolExpr:
+ case BoolConst:
+ case Ident:
+ switch( RightExpr->returntype )
+ {
+ case BoolExpr:
+ case BoolConst:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not a boolean expression.\n";
+ break;
+ }
+ break;
+
+ default:
+ cout << "Operand 1 of Operator " << TheOp << " : \"";
+ LeftExpr->Print( cout );
+ cout << "\" is not a boolean expression.\n";
+ switch( RightExpr->returntype )
+ {
+ case BoolExpr:
+ case BoolConst:
+ case Ident:
+ break;
+
+ default:
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not a boolan expression.\n";
+ break;
+ }
+ returntype = ExprError;
+ }
+ else
+ switch( LeftExpr->returntype )
+ {
+ case IntegerConst:
+ case IntegerExpr:
+ switch( RightExpr->returntype )
+ {
+ case IntegerConst:
+ case IntegerExpr:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "As operand 1 of operator " << TheOp << " is "
+ << LeftExpr->returntype << ", operand 2 that is \"";
+ RightExpr->Print( cout );
+ cout << "\" is expected to be an Integer Expression too.\n";
+ }
+ break;
+
+ case RealConst:
+ case RealExpr:
+ switch( RightExpr->returntype )
+ {
+ case RealConst:
+ case RealExpr:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "As operand 1 of operator " << TheOp << " is "
+ << LeftExpr->returntype << ", operand 2 that is \"";
+ RightExpr->Print( cout );
+ cout << "\" is expected to be a Real Expression too.\n";
+ }
+ break;
+
+ case CharConst:
+ case CharExpr:
+ switch( RightExpr->returntype )
+ {
+ case CharConst:
+ case CharExpr:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "As operand 1 of operator " << TheOp << " is "
+ << LeftExpr->returntype << ", operand 2 that is \"";
+ RightExpr->Print( cout );
+ cout << "\" is expected to be a Character Expression too.\n";
+ }
+ break;
+
+ case StringConst:
+ case StringExpr:
+ switch( RightExpr->returntype )
+ {
+ case StringConst:
+ case StringExpr:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "As operand 1 of operator " << TheOp << " is "
+ << LeftExpr->returntype << ", operand 2 that is \"";
+ RightExpr->Print( cout );
+ cout << "\" is expected to be a String Expression too.\n";
+ }
+ break;
+
+ case ObjConst:
+ case ObjExpr:
+ if ( (TheOp == Equal) || (TheOp == NotEqual) )
+ switch( RightExpr->returntype )
+ {
+ case ObjConst:
+ case ObjExpr:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "As operand 1 of operator " << TheOp << " is "
+ << LeftExpr->returntype << ", operand 2 that is \"";
+ RightExpr->Print( cout );
+ cout << "\" is expected to be an Object Expression too.\n";
+ }
+ else
+ {
+ cout << " Only = and <> can be applied onto objects.\n";
+ returntype = ExprError;
+ }
+ break;
+
+ case BoolConst:
+ case BoolExpr:
+ if ( (TheOp == Equal) || (TheOp == NotEqual) )
+ switch( RightExpr->returntype )
+ {
+ case BoolConst:
+ case BoolExpr:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "As operand 1 of operator " << TheOp << " is "
+ << LeftExpr->returntype << ", operand 2 that is \"";
+ RightExpr->Print( cout );
+ cout << "\" is expected to be a Boolean Expression too.\n";
+ }
+ else
+ {
+ cout << " Only = and <> can be applied onto booleans.\n";
+ returntype = ExprError;
+ }
+ break;
+
+ case Ident:
+ switch( RightExpr->returntype )
+ {
+ case IntegerConst:
+ case IntegerExpr:
+ case RealConst:
+ case RealExpr:
+ case CharConst:
+ case CharExpr:
+ case StringConst:
+ case StringExpr:
+ returntype = BoolExpr;
+ break;
+
+ case ObjConst:
+ case ObjExpr:
+ if ( (TheOp == Equal) || (TheOp == NotEqual) )
+ returntype = BoolExpr;
+ else
+ {
+ cout << " You can only apply Equal and NotEqual onto objects.\n";
+ returntype = ExprError;
+ }
+ break;
+
+ case BoolConst:
+ case BoolExpr:
+ if ( (TheOp == Equal) || (TheOp == NotEqual) )
+ returntype = BoolExpr;
+ else
+ {
+ cout << " You can only apply Equal and NotEqual onto booleans.\n";
+ returntype = ExprError;
+ }
+ break;
+
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << " Type of Operand 2 \"";
+ RightExpr->Print( cout );
+ cout << "\" of operand " << TheOp << " is wrong.\n";
+ }
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << " The type of Operand 1 \"";
+ LeftExpr->Print( cout );
+ cout << "\" of operator " << TheOp << " is wrong.\n";
+ }
+}
+
+virtual void BoolOperator::Print( ostream& stream )
+{
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ BinaryOperator::Print( stream );
+ stream << "\nKind of Boolean Operator : " << OpKind;
+#else
+ stream << " ( ";
+ LeftMember->Print( stream );
+ stream << ' ' << OpKind << ' ';
+ RightMember->Print( stream );
+ stream << " ) ";
+#endif
+}
+
+ArithOperator::ArithOperator( Expression *LeftExpr, Expression *RightExpr,
+ ArithOpType TheOp , Location *TheLoc ) :
+ BinaryOperator( LeftExpr, RightExpr, Other, TheLoc )
+{
+ kind = "Arithmetic Operator";
+ OpKind = TheOp;
+
+ switch( LeftExpr->returntype)
+ {
+ case IntegerConst:
+ case IntegerExpr:
+
+ switch( RightExpr->returntype )
+ {
+ case IntegerConst:
+ case IntegerExpr:
+ returntype = IntegerExpr;
+ break;
+
+ case RealConst:
+ case RealExpr:
+ returntype = RealExpr;
+ break;
+
+ case Ident:
+ returntype = IntegerExpr;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not an arithmetic expression.\n";
+ break;
+ }
+ break;
+
+ case RealConst:
+ case RealExpr:
+ switch( RightExpr->returntype )
+ {
+
+ case IntegerConst:
+ case IntegerExpr:
+ case RealConst:
+ case RealExpr:
+ case Ident:
+ returntype = RealExpr;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not an arithmetic expression.\n";
+
+ }
+ break;
+
+ case Ident:
+ switch( RightExpr->returntype )
+ {
+ case IntegerConst:
+ case IntegerExpr:
+ returntype = IntegerExpr;
+ break;
+
+ case RealConst:
+ case RealExpr:
+ returntype = RealExpr;
+ break;
+
+ case Ident:
+ returntype = Ident;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not an arithmetic expression.\n";
+ }
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand 1 of Operator " << TheOp << " : \"";
+ LeftExpr->Print( cout );
+ cout << "\" is not an arithmetic expression.\n";
+ switch( RightExpr->returntype )
+ {
+ case IntegerConst:
+ case IntegerExpr:
+ case RealConst:
+ case RealExpr:
+ case Ident:
+ break;
+
+ default:
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not an arithmetic expression.\n";
+ }
+
+ }
+}
+
+virtual void ArithOperator::Print( ostream& stream)
+{
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ BinaryOperator::Print( stream );
+ stream << "\nKind of Arithmetic Operator : " << OpKind;
+#else
+ stream << " ( ";
+ LeftMember->Print( stream );
+ stream << ' ' << OpKind << ' ';
+ RightMember->Print( stream );
+ stream << " ) ";
+#endif
+}
+
+ObjOperator::ObjOperator( Expression *LeftExpr, Expression *RightExpr,
+ ObjOpType TheOp , Location *TheLoc ) :
+ BinaryOperator( LeftExpr, RightExpr, Other, TheLoc )
+{
+ kind = "Object Operator";
+ OpKind = TheOp;
+
+ switch(LeftExpr->returntype)
+ {
+ case Ident:
+ switch ( RightExpr->returntype )
+ {
+ case Ident:
+ if (TheOp == Qua)
+ returntype = ObjExpr;
+ else
+ returntype = BoolExpr;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand 2 of Operator " << TheOp << " : \"";
+ RightExpr->Print( cout );
+ cout << "\" is not an Identifier.\n";
+ }
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ cout << "Operand 1 of Operator " << TheOp << " : \"";
+ LeftExpr->Print( cout );
+ cout << "\" is not an Identifier.\n";
+
+ }
+}
+
+virtual void ObjOperator::Print( ostream& stream )
+{
+#ifdef VERBOSE_PRINT_EXPR_TREE
+ BinaryOperator::Print( stream );
+ stream << "\nKind of Object Operator : " << OpKind;
+#else
+ stream << " ( ";
+ LeftMember->Print( stream );
+ stream << ' ' << OpKind << ' ';
+ RightMember->Print( stream );
+ stream << " ) ";
+#endif
+}
+
+Not::Not( Expression *TheExpr, Location *TheLoc ) :
+ UnaryOperator( TheExpr , Other, TheLoc )
+{
+ kind = "Not";
+
+ switch( TheExpr->returntype )
+ {
+ case BoolExpr:
+ case BoolConst:
+ case Ident:
+ returntype = BoolExpr;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand of Operator Not : \"";
+ TheExpr->Print( cout );
+ cout << "\" is not a Boolean Expression.\n";
+ }
+}
+
+This::This( Expression *TheExpr, Location *TheLoc ) :
+ UnaryOperator( TheExpr, Other, TheLoc )
+{
+ kind = "This";
+
+ if ( TheExpr )
+ switch ( TheExpr->returntype )
+ {
+ case Ident:
+ returntype = ObjExpr;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand is of operator 'This' is not an Identifier.\n";
+ }
+ else
+ returntype = ObjExpr;
+}
+
+void This::Print( ostream& stream )
+{
+ cout << " This ";
+ if ( Argument )
+ UnaryOperator::Print( stream );
+}
+
+New::New( Expression *TheExpr, Location *TheLoc ) :
+ UnaryOperator( TheExpr , Other, TheLoc )
+{
+ kind = "New";
+
+ switch( TheExpr->returntype )
+ {
+ case Ident:
+ returntype = ObjExpr;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Operand \"";
+ TheExpr->Print(cout);
+ cout << "\"type of New operator is wrong.\n";
+ }
+}
+
+Copy::Copy( Expression *TheExpr, Location *TheLoc ) :
+ UnaryOperator( TheExpr, Other, TheLoc )
+{
+ kind = "Copy";
+ switch(TheExpr->returntype)
+ {
+ case Ident:
+ case ObjExpr:
+ returntype = ObjExpr;
+ break;
+
+ case ExprError:
+ returntype = ExprError;
+ break;
+
+ default:
+ returntype = ExprError;
+ cout << "Wrong operand type for operand \"";
+ TheExpr->Print(cout);
+ cout << "\" of Copy.\n";
+ break;
+ }
+}
+
+ArrayOf::ArrayOf( Expression *TheExpr, ExprType ret, Location *TheLoc ) :
+ UnaryOperator( TheExpr, ret, TheLoc )
+{
+ kind = "ArrayOf";
+}
+
+Error::Error( ) : Expression( ExprError, NULL )
+{
+ kind = "Error into Expression";
+}
--- /dev/null
+//****************************************************************
+//* *
+//* Expr.h : Header file of the Expression hierarchy classes *
+//* This file describes all the nodes contained into *
+//* an expression tree of the program. *
+//* *
+//* (c) LITA, university of PAU (France), summer 1993. *
+//****************************************************************
+
+//**************************************
+//** **
+//** Objects decribing an expression **
+//** inside an abstract tree. **
+//** **
+//**************************************
+
+// This is a global variable used for identify the location of a lexem.
+extern Location ThisPlace;
+
+//**
+//** Enumeration type used for calculating the return type
+//** of one expression node.
+//**
+
+typedef enum
+{
+ Ident, // Identifier node : could match any kind of expression
+ IntegerConst, // Integer constant node.
+ IntegerExpr, // Integer expression node.
+ RealConst, // Real constant node.
+ RealExpr, // Real expression node.
+ BoolConst, // Boolean constant node.
+ BoolExpr, // Boolean expression node.
+ ObjConst, // Object constant node (like NONE operator or
+ // predefined type ).
+ ObjExpr, // Object expression node.
+ StringExpr, // String expression node.
+ StringConst, // String constant node.
+ CharExpr, // Character expression node.
+ CharConst, // Character constant node.
+ Other, // Other Node (used for constructors, will be removed too ).
+ ExprError // This node and maybe its children is holding
+ // a wrong expression.
+} ExprType;
+
+// We overload this operator for let it print an ExprType object.
+ostream& operator << ( ostream& , ExprType );
+
+//**
+//** This class is a dummy class that is just for testing code.
+//** The code should be removed when joining to the symbol Table.
+//** This is supposed to described the type of one symbol table entry.
+//** The only node to use it is the Identifier Node for now.
+//**
+
+class Entry
+{
+ int dummy; //** Just to say the class is not empty.
+};
+
+//**
+//** This is the Expression class. This class is the root of all the tree
+//** of the expression classes. You find in it all the method and fields
+//** that every node uses.
+//**
+
+class Expression
+{
+
+ public:
+ String kind; // Verbose description of the type of the node.
+ Location *place; // Position of the object in the source text.
+ ExprType returntype; // Kind of result the node produces.
+
+ Expression( ExprType,Location* );// The constructor take just the kind
+ // of the node, and eventually its position.
+ virtual void Print( ostream& ); // Virtual procedure that prints the contents
+ // of the node. Of course there is a lot of
+ // different version of this procedure.
+
+// This overloading allow the programmer to write 'cout << TheExpression'
+// for printing the contents of all the nodes in the tree.
+ friend ostream& operator << ( ostream& , Expression );
+} ;
+
+//**
+//** This is the Identifier Operator Class that derives from Expression
+//** class. This nodes holds a string field to store temporaly the string that
+//** lex has parsed and an entry type for the variable in the symbol table.
+//**
+
+class Identifier : public Expression
+{
+ public:
+ String *Title; // The name of the operator.
+ Entry Where; // The entry if defined (else NULL).
+
+ Identifier( String *, Location * );
+ // Initialised with the name if it has not been
+ // declared (maybe further).
+ Identifier( Entry, Location *); // else initialised with its entry.
+ void Print( ostream& ); // This Print write down the name of the identifier.
+
+} ;
+
+//**
+//** This is the UnaryOperator class. This class derives from Expression
+//** from which it adds an Expression pointer for one argument of type
+//** Expression. This class in general should not be instantiated.
+//** Use derivation for creating new unary operator.
+//**
+
+class UnaryOperator : public Expression
+{
+ public:
+ Expression *Argument; // This holds the argument which is another
+ // expression.
+
+// We need to construct this the argument taken and what kind of result
+// this operator returns.
+
+ UnaryOperator( Expression *ThisExp, ExprType ret, Location * );
+
+ virtual void Print( ostream& ); // This print outputs the name of
+ // the operator and the argument into brackets.
+
+} ;
+
+//**
+//** This is the BinaryOperator class. This is the same as UnaryOperator
+//** except it takes two expression instead of one.
+//** This class is separate from the UnaryOperator because functions that
+//** takes one argument can't accept two arguments (which will surely happend
+//** if BinaryOperator derives from UnaryOperator ).
+//**
+
+class BinaryOperator : public Expression
+{
+public:
+ Expression *LeftMember,*RightMember;
+
+ BinaryOperator( Expression *LeftExpr, Expression *RightExpr,
+ ExprType ret, Location *TheLoc );
+ virtual void Print( ostream& ); // The two expression are printed into
+ // brackets and separated by a ','.
+
+} ;
+
+//**
+//** This is the BoolOperator class. This class describes all the boolean
+//** operators ( =, =/= or <>, <, <=, >, >=, OR, AND, ORIF and ANDIF ).
+//** The operators are discimined by the field OpKind.
+//** We use for this a new enumeration type called BoolOpType (BOOLean OPerator
+//** TYPE).
+//**
+
+typedef enum
+{
+ Less, // A < B
+ LessOrEqual, // A <= B
+ Equal, // A = B
+ NotEqual, // A =/= B or A <> B
+ Greater, // A > B
+ GreaterOrEqual, // A >= B
+ Or, // A OR B (inclusif OR)
+ And, // A AND B
+ AndIf, // A ANDIF B (same as AND)
+ OrIf // A ORIF B (same as OR)
+} BoolOpType;
+
+// We overload << for printing BoolOpType variable.
+
+ostream& operator << ( ostream& , BoolOpType );
+
+class BoolOperator : public BinaryOperator
+{
+public:
+ BoolOpType OpKind;
+
+// For creation, we need the two expression and the kind of boolean operator.
+// For example if a is an 'BoolOperator *'
+// then 'a = new BoolOperator( Expr1, Expr2, Or )' will describe the expression
+// '(Expr1) OR (Expr2)'.
+ BoolOperator( Expression *LeftExpr, Expression *RightExpr,
+ BoolOpType Operator, Location * );
+ void Print( ostream& );
+} ;
+
+//**
+//** This is the ArithOperator class. This class is designed on the same model
+//** as BoolOperator but for arithmetic Operator.
+//** The new enumerated type is calls ArithOpType (ARITHmetic OPerator TYPE).
+//**
+
+typedef enum
+{
+ Plus, // A + B
+ Minus, // A - B
+ Multiply, // A * B
+ Divide, // A / B
+ IntDivide, // A DIV B
+ Modulo // A MOD B
+} ArithOpType;
+
+ostream& operator << ( ostream& , ArithOpType );
+
+class ArithOperator : public BinaryOperator
+{
+public:
+ ArithOpType OpKind;
+ ArithOperator( Expression *LeftExpr, Expression *RightExpr,
+ ArithOpType Operator, Location * );
+ void Print( ostream& );
+} ;
+
+//**
+//** This is the ObjOperator class. This class derives from the class
+//** BinaryOperator. It describes the operators which need object expression
+//** as argument (essentially QUA, IS ,IN ).
+//**
+
+typedef enum
+{
+ Qua,
+ Is,
+ In
+} ObjOpType;
+
+ostream& operator << ( ostream& , ObjOpType );
+
+class ObjOperator : public BinaryOperator
+{
+public:
+ ObjOpType OpKind;
+ ObjOperator( Expression *LeftExpr, Expression *RightExpr,
+ ObjOpType Operator, Location * );
+ void Print( ostream& );
+} ;
+
+class Not : public UnaryOperator
+{
+public:
+ Not( Expression *TheExpr, Location * );
+} ;
+
+class This : public UnaryOperator
+{
+ public:
+ This( Expression *TheExpr, Location * );
+ void Print( ostream& );
+} ;
+
+class New : public UnaryOperator
+{
+ public:
+ New( Expression *TheExpr, Location * );
+} ;
+
+class Copy : public UnaryOperator
+{
+ public:
+ Copy( Expression *TheExpr, Location * );
+} ;
+
+class ArrayOf : public UnaryOperator
+{
+ public:
+ ArrayOf( Expression *TheExpr, ExprType ret, Location * );
+} ;
+
+class NoneObject : public Expression
+{
+ public:
+ NoneObject( Location * );
+} ;
+
+class Result : public Expression
+{
+ public:
+ Result( Location * );
+} ;
+
+class Error : public Expression
+{
+ public:
+ Error( void );
+} ;
+
+class IntegerConstant : public Expression
+{
+public:
+ int rvalue;
+ IntegerConstant( int value, Location * );
+ void Print( ostream& );
+
+} ;
+
+class RealConstant : public Expression
+{
+public:
+ double rvalue;
+ RealConstant( double value, Location * );
+ void Print( ostream& );
+
+} ;
+
+class BoolConstant : public Expression
+{
+ public:
+ int rvalue;
+
+ BoolConstant( int, Location * );
+ void Print( ostream& );
+} ;
+
+class StringConstant : public Expression
+{
+ public:
+ String *rvalue;
+
+ StringConstant( String *, Location * );
+ void Print( ostream& );
+} ;
+
+class CharConstant : public Expression
+{
+ public:
+ char rvalue;
+
+ CharConstant( char rvalue, Location * );
+ void Print( ostream& );
+} ;
--- /dev/null
+//****************************************************************
+//* *
+//* Instr.h : Header file for the object class hierarchy for *
+//* the instructions. *
+//* *
+//* (c) LITA, university of PAU (France), summer 1993. *
+//****************************************************************
+
+#include <String.h>
+#include <iostream.h>
+#include "Objects.h"
+#include "Expr.h"
+#include "Instr.h"
+
+//***************************************
+//** **
+//** Objects decribing an instruction **
+//** inside an abstract tree. **
+//** **
+//***************************************
+
+/*
+ Instruction
+
+ Single_Instruction Complex_Instruction
+
+
+ Single_Instruction
+
+*:= *job io signal control object
+
+ Attach Put Raise Return Wind
+ Resume Get Call Inner
+ Stop Read Exit Kill
+ Detach ReadLn Generator
+ Terminate Write
+ WriteLn
+
+
+ Complex_instructions
+
+ *Loop Block Condition
+
+ *For Pref Block *If
+ *While Case
+*/
+
+virtual void Instruction::Print( ostream& stream )
+{
+ stream << " \"" << kind << "\" ";
+}
+
+ostream& operator << ( ostream& stream , Instruction TheInstr )
+{
+ TheInstr.Print( stream );
+}
+
+OneArgInstr::OneArgInstr( Expression * TheExpr, String TheStr, Location *TheLoc ) :
+ Instruction( TheStr, TheLoc )
+{
+ argument = TheExpr;
+}
+
+void OneArgInstr::Print( ostream& stream )
+{
+ Instruction::Print( stream );
+ stream << "(" << *argument << ");\n";
+}
+
+TwoArgInstr::TwoArgInstr( Expression *TheExpr1, Expression *TheExpr2,
+ String TheStr , Location *TheLoc) :
+ Instruction( TheStr, TheLoc )
+{
+ arg1 = TheExpr1;
+ arg2 = TheExpr2;
+}
+
+void TwoArgInstr::Print( ostream& stream )
+{
+ Instruction::Print( stream );
+ stream << "(" << *arg1 << "," << *arg2 << ");";
+}
+
+Affectation::Affectation( Expression *L_Value, Expression *R_Value ) :
+ TwoArgInstr( L_Value , R_Value, String("Affectation"),
+ new Location(*L_Value->place + *R_Value->place) )
+{
+ switch( L_Value->returntype )
+ {
+ case Ident:
+ /* Here we should verify if the returntype of the Expression is coherent
+ with the type of the Identifier ( if it is declared ). */
+ break;
+ default:
+ L_Value->Print( cout );
+ cout << " is not an Identifier .\n" ;
+ break;
+ }
+}
+
+void Affectation::Print( ostream& stream )
+{
+ arg1->Print( stream );
+ cout << " := ";
+ arg2->Print( stream );
+}
+
+Attach::Attach( Expression *TheExpr, Location *TheLoc ) :
+ OneArgInstr( TheExpr, String("Attach"),
+ new Location( *TheLoc + *TheExpr->place ))
+{
+ switch( TheExpr->returntype )
+ {
+ case Ident:
+ case ObjExpr:
+ case ObjConst:
+ /* Here we should verify if the Expression
+ is coherent with a coroutine object. */
+ break;
+
+ case ExprError:
+ /* Here we test if the expression is correct or not.
+ If it is not correct, a report of the error has already been
+ emited and we have to go ahead without any comment for avoiding
+ errors provoked by the wrong expression. */
+ break;
+
+ default:
+ /* Here the Expression is correct according to the rules of building
+ an expression but the expression is not an object type so we emit
+ an error saying that there is a mismatched expression used with
+ the Attach instruction. */
+ cout << " Operand \"";
+ TheExpr->Print( cout );
+ cout << "\" for instruction Attach is wrong.\n";
+ break;
+ }
+}
+
+Resume::Resume( Expression *TheExpr, Location *TheLoc ) :
+ OneArgInstr( TheExpr, String("Resume"),
+ new Location( *TheLoc + *TheExpr->place ) )
+{
+ switch( TheExpr->returntype )
+ {
+ case Ident:
+ case ObjExpr:
+ case ObjConst:
+ /* Here we should verify if the Expression
+ is coherent with a process object. */
+ break;
+
+ case ExprError:
+ /* Here we test if the expression is correct or not.
+ If it is not correct, a report of the error has already been
+ emited and we have to go ahead without any comment for avoiding
+ errors provoked by the wrong expression. */
+ break;
+
+ default:
+ /* Here the Expression is correct according to the rules of building
+ an expression but the expression is not an object type so we emit
+ an error saying that there is a mismatched expression used with
+ the Resume instruction. */
+ cout << " Operand \"";
+ TheExpr->Print( cout );
+ cout << "\" for instruction Resume is wrong.\n";
+ break;
+ }
+}
+
+Stop::Stop( Expression *TheExpr, Location *TheLoc ) :
+ OneArgInstr( TheExpr, String("Stop"),
+ new Location( *TheLoc + *TheExpr->place) )
+{
+ switch( TheExpr->returntype )
+ {
+ case Ident:
+ case ObjExpr:
+ case ObjConst:
+ /* Here we should verify if the Expression
+ is coherent with a process object. */
+ break;
+
+ case ExprError:
+ /* Here we test if the expression is correct or not.
+ If it is not correct, a report of the error has already been
+ emited and we have to go ahead without any comment for avoiding
+ errors provoked by the wrong expression. */
+ break;
+
+ default:
+ /* Here the Expression is correct according to the rules of building
+ an expression but the expression is not an object type so we emit
+ an error saying that there is a mismatched expression used with
+ the instruction Stop. */
+ cout << " Operand \"";
+ TheExpr->Print( cout );
+ cout << "\" for instruction Stop is wrong.\n";
+ break;
+ }
+}
+
+Stop::Stop( Location *TheLoc ) : OneArgInstr( NULL, String("Stop"), TheLoc ) {}
+
+void Stop::Print( ostream& stream )
+{
+ if (argument)
+ OneArgInstr::Print( stream );
+ else
+ cout << "Stop;\n";
+}
+
+Get::Get( Expression *TheArg, Location *TheLoc) :
+ OneArgInstr( TheArg, String("Get"),
+ new Location(*TheArg->place + *TheLoc) )
+{
+ switch(TheArg->returntype)
+ {
+ case Ident:
+ case ExprError:
+ break;
+
+ default:
+ cout << " Operand \"";
+ TheArg->Print( cout );
+ cout << "\" for instruction Get is wrong.\n";
+ break;
+ }
+}
+
+Put::Put( Expression *TheArg, Location *TheLoc) :
+ OneArgInstr( TheArg, String("Put"),
+ new Location(*TheArg->place + *TheLoc) )
+{
+ switch(TheArg->returntype)
+ {
+ case Ident:
+ case ExprError:
+ break;
+
+ default:
+ cout << " Operand \"";
+ TheArg->Print( cout );
+ cout << "\" for instruction Put is wrong.\n";
+ break;
+ }
+}
+
+Block::Block( Instruction *FirstInstr, Location *TheLoc ) :
+ Instruction( String("Block"), TheLoc ), InstrList( FirstInstr )
+{
+
+// We have to test the pointer because a block of instruction could be empty.
+// i.e. : for i := 1 to 2 do od;
+// \___/-> empty block;
+ if (FirstInstr)
+ *place = *place + *FirstInstr->place;
+
+}
+
+Block& operator += ( Block& TheBlock, Instruction *TheInstr )
+{
+ TheBlock.InstrList += TheInstr;
+// The test is not worth here because the block is expanded only if there is
+// a new instruction who of course is not empty.
+ *TheBlock.place = *TheBlock.place + *TheInstr->place;
+ return TheBlock;
+}
+
+void Block::Print( ostream& stream )
+{
+ stream << "Block\n";
+ InstrList.Print( stream );
+ stream << "End of Block.\n";
+}
+
+ListOfInstr::ListOfInstr( Instruction *TheInstr )
+{
+ Instruct = TheInstr;
+ NextInst = NULL;
+}
+
+ListOfInstr& operator += ( ListOfInstr& TheList , Instruction *TheInstr )
+{
+ ListOfInstr *Current = &TheList;
+
+ while (Current->NextInst != NULL ) Current = Current->NextInst;
+ Current->NextInst = new ListOfInstr( TheInstr );
+ return TheList;
+}
+
+void ListOfInstr::Print( ostream& stream )
+{
+ ListOfInstr *Current;
+
+ Current = NextInst;
+ Instruct->Print( stream );
+ stream << "\n";
+
+ while (Current != NULL)
+ {
+ Current->Instruct->Print( stream );
+ stream << "\n";
+ Current = Current->NextInst;
+ }
+
+}
+
+ConditionIf::ConditionIf( Expression *TheCondition,
+ Block *Block1, Block *Block2, Location *TheLoc ) :
+ Instruction( String( " If " ),
+ new Location( *TheLoc + *Block1->place + *Block2->place ) ),
+ Condition( TheCondition ), BlockThen( Block1 ), BlockElse( Block2 )
+{
+ switch( TheCondition->returntype )
+ {
+ case BoolExpr:
+ case BoolConst:
+ case Ident:
+ case ExprError:
+ break;
+
+ default:
+ cout << " Bad Expression \"";
+ TheCondition->Print( cout );
+ cout << " for If condition.\n";
+ break;
+ }
+}
+
+void ConditionIf::Print( ostream& stream )
+{
+ cout << "If (";
+ Condition->Print( cout );
+ cout << ")\nThen \n";
+ BlockThen->Print( cout );
+ if (BlockElse)
+ {
+ cout <<"Else\n";
+ BlockElse->Print( cout );
+ }
+}
+
+void Loop::Print( ostream& stream )
+{
+ stream << " DO\n";
+ Body->Print( stream );
+ stream << "\nOD\n";
+}
+
+While::While( Expression *TheExpr, Block *TheBlock, Location *TheLoc ) :
+ Loop( TheBlock, String("While") ), Condition( TheExpr )
+{
+ if (TheExpr)
+ {
+ *place = *TheLoc + *TheBlock->place;
+ switch( TheExpr->returntype )
+ {
+ case Ident:
+ case BoolConst:
+ case BoolExpr:
+ case ExprError:
+ break;
+
+ default:
+ cout << "Wrong expression \"";
+ TheExpr->Print( cout );
+ cout << "\" for Instruction While.\n";
+ break;
+ }
+ }
+}
+
+void While::Print( ostream& stream )
+{
+ stream << "While ";
+ Condition->Print( stream );
+ Loop::Print( stream );
+}
+
+For::For( Expression *TheVar, Expression *Initial, Expression *Final,
+ Expression *Step, Block *TheBlock, Location *TheLoc ) :
+ Loop( TheBlock, String("For") ), Counter( TheVar ),
+ CounterInit( Initial ), CounterStop( Final ), CounterStep( Step )
+{
+ *place = *TheLoc + *TheVar->place + *Initial->place + *Final->place +
+ *Step->place + *TheBlock->place;
+ switch( CounterInit->returntype )
+ {
+ case Ident:
+ case IntegerConst:
+ case IntegerExpr:
+ case RealExpr:
+ case RealConst:
+ case ExprError:
+ break;
+
+ default:
+ cout << " Bad Expression type for Initial value \"";
+ CounterInit->Print( cout );
+ cout << "\" of variable ";
+ Counter->Print( cout );
+ cout << ".\n";
+ }
+
+ switch( CounterStop->returntype )
+ {
+ case Ident:
+ case IntegerConst:
+ case IntegerExpr:
+ case RealExpr:
+ case RealConst:
+ case ExprError:
+ break;
+
+ default:
+ cout << " Bad Expression type for Initial value \"";
+ CounterInit->Print( cout );
+ cout << "\" of variable ";
+ Counter->Print( cout );
+ cout << ".\n";
+ }
+
+ switch( CounterStep->returntype )
+ {
+ case Ident:
+ case IntegerConst:
+ case IntegerExpr:
+ case RealExpr:
+ case RealConst:
+ case ExprError:
+ break;
+
+ default:
+ cout << " Bad Expression type for Step value \"";
+ CounterStep->Print( cout );
+ cout << ".\n";
+ }
+
+}
+
+void For::Print( ostream& stream )
+{
+ stream << "For ";
+ Counter->Print( cout );
+ stream << " := ";
+ CounterInit->Print( cout );
+ stream << " TO ";
+ CounterStop->Print( cout );
+ stream << " Step ";
+ CounterStep->Print( cout );
+ Loop::Print( stream );
+}
--- /dev/null
+//****************************************************************
+//* *
+//* Instr.h : Header file for the object class hierarchy for *
+//* the instructions. *
+//* *
+//* (c) LITA, university of PAU (France), summer 1993. *
+//****************************************************************
+
+//***************************************
+//** **
+//** Objects decribing an instruction **
+//** inside an abstract tree. **
+//** **
+//***************************************
+
+/*
+ Instruction
+
+ Single_Instruction Complex_Instruction
+
+
+ Single_Instruction
+
+ := job io signal control object
+
+ Attach Put Raise Return Wind
+ Resume Get Call Inner
+ Stop Read Exit Kill
+ Detach ReadLn Generator
+ Terminate Write
+ WriteLn
+
+
+ Complex_instructions
+
+ Loop Block Condition
+
+ For Pref Block If
+ While Case
+*/
+
+class Instruction
+{
+ public:
+ String kind;
+ Location *place;
+
+ Instruction( String TheStr, Location *TheLoc ) :
+ kind( TheStr ), place( TheLoc )
+ {}
+
+ virtual void Print( ostream& );
+
+ friend ostream& operator << ( ostream& , Instruction );
+} ;
+
+class OneArgInstr : public Instruction
+{
+ public:
+ Expression *argument;
+
+ OneArgInstr( Expression * , String, Location * );
+ virtual void Print( ostream& );
+} ;
+
+class TwoArgInstr : public Instruction
+{
+ public:
+ Expression *arg1,*arg2;
+
+ TwoArgInstr( Expression *, Expression *, String, Location *);
+ virtual void Print( ostream& );
+} ;
+
+class Affectation : public TwoArgInstr
+{
+ public:
+ Affectation( Expression *, Expression * );
+ void Print( ostream& );
+} ;
+
+typedef enum
+{
+ AttachInstr,
+ ResumeInstr,
+ StopInstr
+} OneArgJob;
+
+class Attach : public OneArgInstr
+{
+ public:
+ Attach( Expression *, Location * );
+} ;
+
+class Resume : public OneArgInstr
+{
+ public:
+ Resume( Expression *, Location * );
+} ;
+
+class Detach : public Instruction
+{
+ public:
+ Detach( Location *TheLoc ) : Instruction( String( "Detach" ), TheLoc ) {}
+} ;
+
+class Terminate : public Instruction
+{
+ public:
+ Terminate( Location *TheLoc ) : Instruction( String( "Terminate" ), TheLoc ) {}
+} ;
+
+class Stop : public OneArgInstr
+{
+ public:
+ Stop( Expression *, Location * );
+ Stop( Location * );
+ void Print( ostream& );
+} ;
+
+//**
+//** These class describes the I/O instructions of LOGLAN
+//**
+//** Each Instruction taking a variable argument number
+//** for example "writeln( output,a,b )"
+//** is simplified into the following Instructions :
+//** write( output, a );
+//** write( output, b );
+//** writeln( output );
+//**
+
+class Read : public OneArgInstr
+{
+ public:
+ Read( Expression *, Location * );
+} ;
+
+class Readln : public Instruction
+{
+ public:
+ Readln( Location * );
+} ;
+
+class Write : public OneArgInstr
+{
+ public:
+ Write( Expression *, Location * );
+} ;
+
+class Writeln : public Instruction
+{
+ public:
+ Writeln( Location * );
+} ;
+
+class Get : public OneArgInstr
+{
+ public:
+ Expression *TheFile, *TheArg;
+ Get( Expression *, Location * );
+} ;
+
+class Put : public OneArgInstr
+{
+ public:
+ Expression *TheFile, *TheArg;
+ Put( Expression *, Location * );
+} ;
+
+//**
+//** This is the only Instruction concerning signals.
+//**
+
+class Raise : public OneArgInstr
+{
+ public:
+ Raise( Expression *TheExpr, Location *TheLoc ) :
+ OneArgInstr( TheExpr, String("Raise"), TheLoc ) {}
+} ;
+
+//**
+//** Class container for a set of Instructions. We call it a block.
+//** Tool class for containing several instructions and manipulate them.
+//**
+
+class ListOfInstr
+{
+ Instruction *Instruct;
+ ListOfInstr *NextInst;
+ public:
+ friend ListOfInstr& operator += ( ListOfInstr& , Instruction * );
+ ListOfInstr( Instruction *TheInstr );
+ void Print( ostream& );
+} ;
+
+class Block : public Instruction
+{
+ ListOfInstr InstrList;
+ public:
+ Block( Instruction *FirstInstr, Location *TheLoc );
+ friend Block& operator += ( Block& TheBlock, Instruction *TheInstr );
+ void Print( ostream& );
+} ;
+
+//**
+//** Class conditionnal If : A class with 2 Blocks conditionnaly executed.
+//**
+
+class ConditionIf : public Instruction
+{
+ Block *BlockThen, *BlockElse;
+ Expression *Condition;
+ public:
+ ConditionIf( Expression *, Block *, Block *, Location * );
+ void Print( ostream & );
+} ;
+
+//**
+//** Class Loop : A class for hanling loop construction
+//**
+
+class Loop : public Instruction
+{
+ Block *Body;
+ public:
+ Loop( Block *TheBlock, String TheName ) :
+ Instruction( TheName, TheBlock->place ), Body( TheBlock ) {};
+ void Print( ostream& );
+} ;
+
+class While : public Loop
+{
+ Expression *Condition;
+ public:
+ While( Expression *, Block *, Location * );
+ void Print( ostream& );
+} ;
+
+class For : public Loop
+{
+ Expression *Counter;
+ Expression *CounterInit;
+ Expression *CounterStop;
+ Expression *CounterStep;
+ public:
+ For( Expression *,Expression *, Expression *, Expression *, Block *,Location * );
+ void Print( ostream& );
+} ;
--- /dev/null
+%{
+
+//****************************************************************
+//* *
+//* Lex.l : Reg. Exp. for the LOGLAN-82 and the LOGLAN-93 *
+//* languages. *
+//* *
+//* (c) LITA, university of PAU (France), summer 1993. *
+//****************************************************************
+
+#ifdef TOKENS_DEBUG
+#define TOKENS_ERROR
+#define TOKENS_DEBUG_printf(a) fprintf(stderr,a)
+#define TOKENS_DEBUG_printf2(a,b) fprintf(stderr,a,b)
+#else
+#define TOKENS_DEBUG_printf(a)
+#define TOKENS_DEBUG_printf2(a,b)
+#endif
+
+#ifdef TOKENS_ERROR
+#define TOKENS_ERROR_printf(a) fprintf(stderr,a)
+#else
+#define TOKENS_ERROR_printf(a)
+#endif
+
+#ifdef SYNTAX_ONLY
+#define SEMANTIC(a)
+#else
+#define SEMANTIC(a) a
+#endif
+
+#ifndef SYNTAX_ONLY
+
+#include <String.h>
+#include <iostream.h>
+#include "Objects.h"
+#include "Expr.h"
+#include "Instr.h"
+
+#endif
+
+#include "syntax.h"
+
+int line_number=1;
+
+#ifndef SYNTAX_ONLY
+void LexAdvanceCursor( int length );
+
+Location ThisPlace;
+int BeginningOfLine;
+
+#endif
+
+%}
+
+%x CondComment CondLineComment
+%x CondString
+
+Letter [A-Za-z]
+IdLetter {Letter}|[_0-9]
+Digit [0-9]
+
+Identifier {Letter}({IdLetter}*)
+A [Aa]
+B [Bb]
+C [Cc]
+D [Dd]
+E [Ee]
+F [Ff]
+G [Gg]
+H [Hh]
+I [Ii]
+J [Jj]
+K [Kk]
+L [Ll]
+M [Mm]
+N [Nn]
+O [Oo]
+P [Pp]
+Q [Qq]
+R [Rr]
+S [Ss]
+T [Tt]
+U [Uu]
+V [Vv]
+W [Ww]
+X [Xx]
+Y [Yy]
+Z [Zz]
+
+%%
+
+{B}{E}{G}{I}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(Begin);
+ }
+
+{E}{N}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(END);
+ }
+
+{P}{R}{O}{G}{R}{A}{M} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PROGRAM);
+ }
+
+{U}{N}{I}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(UNIT);
+ }
+
+{C}{L}{A}{S}{S} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(CLASS);
+ }
+
+{P}{R}{O}{C}{E}{D}{U}{R}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PROCEDURE);
+ }
+
+{F}{U}{N}{C}{T}{I}{O}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(FUNCTION);
+ }
+
+{C}{O}{R}{O}{U}{T}{I}{N}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(COROUTINE);
+ }
+{P}{R}{O}{C}{E}{S}{S} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PROCESS);
+ }
+
+{B}{L}{O}{C}{K} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(BLOCK);
+ }
+
+{T}{Y}{P}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(TYPE);
+ }
+
+{H}{A}{N}{D}{L}{E}{R}{S} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(HANDLERS);
+ }
+
+{I}{N}{P}{U}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(INPUT);
+ }
+
+{O}{U}{T}{P}{U}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(OUTPUT);
+ }
+
+{I}{N}{O}{U}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(INOUT);
+ }
+
+{V}{I}{R}{T}{U}{A}{L} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(VIRTUAL);
+ }
+
+{W}{H}{E}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(WHEN);
+ }
+
+{O}{T}{H}{E}{R}{W}{I}{S}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(OTHERWISE);
+ }
+
+{C}{O}{N}{S}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(CONST);
+ }
+
+{V}{A}{R} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(VAR);
+ }
+
+{S}{I}{G}{N}{A}{L} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(SIGNAL);
+ }
+
+{O}{T}{H}{E}{R}{W}{I}{S}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(OTHERWISE);
+ }
+
+{I}{N}{T}{E}{G}{E}{R} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(INTEGER);
+ }
+
+{R}{E}{A}{L} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(REAL);
+ }
+
+{B}{O}{O}{L}{E}{A}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(BOOLEAN);
+ }
+
+{C}{H}{A}{R}{A}{C}{T}{E}{R} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(CHARACTER);
+ }
+
+{S}{T}{R}{I}{N}{G} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(STRING);
+ }
+
+{F}{I}{L}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(File);
+ }
+
+{P}{R}{O}{C}{E}{S}{S} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PROCESS);
+ }
+
+{C}{O}{R}{O}{U}{T}{I}{N}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(COROUTINE);
+ }
+
+{A}{R}{R}{A}{Y}{O}{F} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ARRAY_OF);
+ }
+
+{N}{O}{N}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(NONE);
+ }
+
+{T}{H}{I}{S} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(THIS);
+ }
+
+{D}{I}{V} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(DIV);
+ }
+
+{M}{O}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(MOD);
+ }
+
+{I}{S} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(IS);
+ }
+
+{I}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(IN);
+ }
+
+{O}{R} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(OR);
+ }
+
+{A}{N}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(AND);
+ }
+
+{N}{O}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(NOT);
+ }
+
+{Q}{U}{A} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(QUA);
+ }
+
+{R}{E}{S}{U}{L}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(RESULT);
+ }
+
+{N}{E}{W} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(NEW);
+ }
+
+{C}{O}{P}{Y} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(COPY);
+ }
+
+{A}{T}{T}{A}{C}{H} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ATTACH);
+ }
+
+{D}{E}{T}{A}{C}{H} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(DETACH);
+ }
+
+{S}{T}{O}{P} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(STOP);
+ }
+
+{R}{E}{S}{U}{M}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(RESUME);
+ }
+
+{T}{E}{R}{M}{I}{N}{A}{T}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(TERMINATE);
+ }
+
+{P}{U}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PUT);
+ }
+
+{G}{E}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(GET);
+ }
+
+{R}{E}{A}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(READ);
+ }
+
+{R}{E}{A}{D}{L}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(READLN);
+ }
+
+{W}{R}{I}{T}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(WRITE);
+ }
+
+{W}{R}{I}{T}{E}{L}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(WRITELN);
+ }
+
+{C}{A}{L}{L} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(CALL);
+ }
+
+{K}{I}{L}{L} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(KILL);
+ }
+
+{E}{X}{I}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(EXIT);
+ }
+
+{R}{E}{P}{E}{A}{T} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(REPEAT);
+ }
+
+{I}{N}{N}{E}{R} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(INNER);
+ }
+
+{W}{I}{N}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(WIND);
+ }
+
+{R}{A}{I}{S}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(RAISE);
+ }
+
+{A}{R}{R}{A}{Y} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ARRAY);
+ }
+
+{D}{I}{M} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(DIM);
+ }
+
+{D}{O} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(DO);
+ }
+
+{O}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(OD);
+ }
+
+{W}{H}{I}{L}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(WHILE);
+ }
+
+{F}{O}{R} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(FOR);
+ }
+
+{S}{T}{E}{P} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(STEP);
+ }
+
+{T}{O} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(TO);
+ }
+
+{D}{O}{W}{N}{T}{O} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(DOWNTO);
+ }
+
+{I}{F} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(IF);
+ }
+
+{T}{H}{E}{N} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(THEN);
+ }
+
+{E}{L}{S}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ELSE);
+ }
+
+{F}{I} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(FI);
+ }
+
+{A}{N}{D}{I}{F} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ANDIF);
+ }
+
+{O}{R}{I}{F} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ORIF);
+ }
+
+{C}{A}{S}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(CASE);
+ }
+
+{E}{S}{A}{C} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ESAC);
+ }
+
+{P}{R}{E}{F} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PREF);
+ }
+
+{S}{H}{A}{R}{E}{D} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(SHARED);
+ }
+
+{E}{N}{U}{M} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ENUM);
+ }
+
+{T}{R}{U}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisBool.Bool = 1 ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(BOOLCONST);
+ }
+
+{F}{A}{L}{S}{E} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisBool.Bool = 0 ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(BOOLCONST);
+ }
+
+\* {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(STAR);
+ }
+
+\/ {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(DIVIDE);
+ }
+
+\+ {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(PLUS);
+ }
+
+\- {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(MINUS);
+ }
+
+\= {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(EQUAL);
+ }
+
+("<>")|("=/=") {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(NEQUAL);
+ }
+
+"<" {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(LESS);
+ }
+
+">" {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(GREATER);
+ }
+
+(">=")|("=>") {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(GREATEROREQUAL);
+ }
+
+("<=")|("=<") {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(LESSOREQUAL);
+ }
+
+\( {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(OPENINGBRACKET);
+ }
+
+\) {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(CLOSINGBRACKET);
+ }
+
+\, {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(LIST_SEPARATOR);
+ }
+
+: {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(VARSEPARATOR);
+ }
+
+\; {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(ENDSENTENCE);
+ }
+
+\. {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(POINT);
+ }
+
+":=" {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisLoc = new Location( ThisPlace ) ));
+ return(AFFECTATION);
+ }
+
+" " {
+ SEMANTIC(( ThisPlace.Tab(1) ));
+ }
+
+\n {
+ SEMANTIC(( BeginningOfLine = 1 ));
+ SEMANTIC(( ThisPlace.Cr() ));
+ line_number++;
+ }
+
+{Identifier} {
+ TOKENS_DEBUG_printf2("%s.\n",yytext);
+ SEMANTIC(( yylval.ThisString.Str = new String ( yytext ) ));
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisString.Loc = new Location( ThisPlace ) ));
+ return(IDENTIFIER);
+ }
+
+{Digit}+ {
+ TOKENS_DEBUG_printf("DigitSequence.\n");
+ SEMANTIC(( yylval.ThisInt.Int = atoi(yytext) ));
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisInt.Loc = new Location( ThisPlace ) ));
+ return(DIGITSEQUENCE);
+ }
+
+\'.?\' {
+ TOKENS_DEBUG_printf("CharConst.\n");
+ SEMANTIC(( yylval.ThisChar.Char = yytext[1] ));
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisChar.Loc = new Location( ThisPlace ) ));
+ return(CHARCONST);
+ }
+
+\'[^\'\n]*\' {
+ TOKENS_ERROR_printf("Error : Multiple Character constant.\n");
+ SEMANTIC(( yylval.ThisChar.Char = yytext[1] ));
+ SEMANTIC(( LexAdvanceCursor( strlen(yytext) ) ));
+ SEMANTIC(( yylval.ThisChar.Loc = new Location( ThisPlace ) ));
+ return(CHARCONST);
+ }
+
+\" {
+ BEGIN(CondString);
+ SEMANTIC(( ThisPlace.Tab( 1 ) ));
+ yymore();
+ }
+
+"(*" {
+ BEGIN(CondComment);
+ SEMANTIC(( ThisPlace.Tab( 2 ) ));
+ yymore();
+ }
+
+. {
+ TOKENS_ERROR_printf("Erreur d'entree.\n");
+ SEMANTIC(( ThisPlace.Select( 1 ) ));
+ }
+
+"//" {
+ BEGIN(CondLineComment);
+ SEMANTIC(( ThisPlace.Tab( 2 ) ));
+ yymore();
+ }
+
+<CondLineComment>.*\n {
+ BEGIN(INITIAL);
+ SEMANTIC(( ThisPlace.Cr() ));
+ SEMANTIC(( BeginningOfLine = 1 ));
+ line_number++;
+ }
+
+<CondString>\" {
+ TOKENS_DEBUG_printf2("String :%s\n",yytext);
+ BEGIN(INITIAL);
+ SEMANTIC(
+ {
+ yylval.ThisString.Str = new String(yytext);
+ ThisPlace.Select( strlen(yytext) );
+ yylval.ThisString.Loc = new Location( ThisPlace );
+ });
+ return(TEXTCONST);
+ }
+
+<CondString>\\\" {
+ yymore();
+ }
+
+<CondString>\n {
+ TOKENS_ERROR_printf("Error : Unterminated String.\n");
+ line_number++;
+ BEGIN(INITIAL);
+ SEMANTIC(( ThisPlace.Cr() ));
+ SEMANTIC(( BeginningOfLine = 1 ));
+ return(TEXTCONST);
+ }
+
+<CondString>. {
+ yymore();
+ }
+
+<CondComment>"(*" {
+ SEMANTIC(( ThisPlace.Tab( 2 ) ));
+ }
+
+<CondComment>"*)" {
+ BEGIN(INITIAL);
+ SEMANTIC(( ThisPlace.Select( 2 ) ));
+ }
+
+<CondComment>. {
+ SEMANTIC(( ThisPlace.Tab( 1 ) ));
+ }
+
+%%
+#ifndef SYNTAX_ONLY
+void LexAdvanceCursor( int length )
+{
+
+ if ( !BeginningOfLine )
+ ThisPlace.Advance();
+ ThisPlace.Select( length );
+ BeginningOfLine = 0;
+ ThisPlace;
+}
+#endif /* SYNTAX_ONLY */
--- /dev/null
+# CDEFINE : Any symbols used for debugging\r
+# RULES_DEBUG : if defined prints the rules reduced\r
+# RULES_ERROR_DEBUG : if defined prints the error rules reduced\r
+# TOKENS_DEBUG : if defined prints the tokens read in the input\r
+#\r
+CXX=gcc\r
+\r
+LDFLAGS= -lm -lg++\r
+CDEFINE= \r
+YACC=bison -y\r
+YFLAGS=-d -v\r
+CXXFLAGS= $(CDEFINE) $(CFLAGS)\r
+\r
+DIST= syntax.y lex.l \\r
+ SymTable.cc SymTable.h \\r
+ Objects.cc Objects.h \\r
+ Expr.cc Expr.h \\r
+ Instr.cc Instr.h \\r
+ tstSymbt.cc tstObj.cc tstExpr.cc\\r
+ Makefile \\r
+ test.log test1.log test2.log test3.log test4.log\r
+\r
+SYNTAXOBJ=syntax.o lex.o Objects.o Expr.o Instr.o\r
+\r
+.l.cc:\r
+ $(LEX) -t $(LFLAGS) $< > $@\r
+\r
+all: syntax\r
+\r
+check: test\r
+\r
+test: all\r
+ ./syntax < test.log 2>&1 > result.out\r
+\r
+syntax: $(SYNTAXOBJ)\r
+ $(CXX) -o syntax $(CXXFLAGS) $(SYNTAXOBJ) $(LDFLAGS)\r
+\r
+lex.o: lex.cc syntax.h\r
+\r
+tstSyntax.o: syntax.cc\r
+ $(CXX) $(CXXFLAGS) -DSYNTAX_ONLY -DRULES_DEBUG -c syntax.cc -o tstSyntax.o\r
+\r
+tstLex.o: lex.cc\r
+ $(CXX) $(CXXFLAGS) -DSYNTAX_ONLY -DTOKENS_DEBUG -c lex.cc -o tstLex.o\r
+\r
+tstObj: tstObj.o Objects.o\r
+ $(CXX) -o tstOBJ $(CXXFLAGS) $(LDFLAGS) tstObj.o Objects.o\r
+\r
+tstSymbt: tstSymbt.o SymTable.o\r
+ $(CXX) -o tstSymbt tstSymbt.o SymTable.o $(CXXFLAGS) $(LDFLAGS)\r
+\r
+tstExpr: tstExpr.o Expr.o\r
+ $(CXX) -o tstExpr tstExpr.o Expr.o $(CXXFLAGS) $(LDFLAGS)\r
+\r
+tstInstr: tstInstr.o Instr.o Objects.o Expr.o\r
+ $(CXX) -o tstInstr tstInstr.o Instr.o Expr.o Objects.o $(CXXFLAGS) $(LDFLAGS)\r
+\r
+tstSyntax: tstSyntax.o tstLex.o\r
+ $(CXX) -o tstSyntax tstSyntax.o tstLex.o $(CXXFLAGS) $(LDFLAGS)\r
+\r
+syntax.cc syntax.h: syntax.y\r
+ $(YACC) $(YFLAGS) syntax.y\r
+ mv y.tab.c syntax.cc\r
+ mv y.tab.h syntax.h\r
+ mv y.output syntax.out\r
+\r
+clean:\r
+ rm -f syntax.[ch] lex.c *.o syntax.output\r
+ rm -f result.out tst*.o\r
+\r
+realclean: clean\r
+ rm -f syntax tst*\r
+\r
+dist:\r
+ tar cvf loglan.tar $(DIST)\r
--- /dev/null
+#include <stdlib.h>
+#include <String.h>
+#include "Objects.h"
+
+#define LINE_WIDTH 256 // set the line width to anything you want.
+ // The Only assumption is that a column number
+ // is lesser than LINE_WIDTH
+
+#define POSITION(line,column) ( (line) * LINE_WIDTH + (column) )
+
+//**************************************
+//* Class Location : *
+//* Class used for storing location *
+//* of an object *
+//**************************************
+
+// Constructor with two arguments : the markers are set equal each other
+// Start mark = End mark.
+
+Location::Location( void )
+{
+ LineStart = LineEnd = 1;
+ ColumnStart = ColumnEnd = 1;
+}
+
+Location::Location( int Line, int Column = 1 )
+{
+ if (Line < 0 || Column < 0 || Column > LINE_WIDTH)
+ error("Incoherent values for initialisation of Location object.");
+ LineStart = LineEnd = Line;
+ ColumnStart = ColumnEnd = Column;
+}
+
+// Constructor with four arguments : the two first are for Start mark
+// and the two last are for the End mark.
+
+Location::Location( int First_Line, int First_Column,
+ int Last_Line, int Last_Column )
+{
+ if ((First_Line <= 0) || (First_Column <= 0) ||
+ (Last_Line <= 0) || (Last_Column <= 0) ||
+ (First_Column > LINE_WIDTH) || (Last_Column > LINE_WIDTH))
+ error("Incoherent values for initialisation of Location object.");
+
+ if ( POSITION(First_Line,First_Column) < POSITION(Last_Line,Last_Column) )
+ {
+ LineStart = First_Line;
+ LineEnd = Last_Line;
+ ColumnStart = First_Column;
+ ColumnEnd = Last_Column;
+ }
+ else
+ {
+ LineStart = Last_Line;
+ LineEnd = First_Line;
+ ColumnStart = Last_Column;
+ ColumnEnd = First_Column;
+ }
+}
+
+Location::Location( const Location& TheLoc )
+{
+ LineStart = TheLoc.LineStart;
+ LineEnd = TheLoc.LineEnd;
+ ColumnStart = TheLoc.ColumnStart;
+ ColumnEnd = TheLoc.ColumnEnd;
+}
+
+// SetEnd method : Set the End mark to line number Line
+// and column number Column.
+
+void Location::SetEnd( int Line, int Column )
+{
+
+ if ( Line <= 0 || Column <= 0 || Column > LINE_WIDTH)
+ error("Incoherent values for initialisation of Location object.");
+
+ if ( POSITION(Line,Column) > POSITION(LineStart,ColumnStart) )
+// The new End Mark is after the Start Mark so we just adjust the End Mark.
+ {
+ LineEnd = Line;
+ ColumnEnd = Column;
+ }
+ else
+ {
+// The new End Mark is before the Start Mark so we have two swap the two marks.
+ LineEnd = LineStart;
+ ColumnEnd = ColumnStart;
+ LineStart = Line;
+ ColumnStart = Column;
+ }
+}
+
+// This function sets the beginning of the Location Object at
+// the line Line and the column Column
+
+void Location::Move( int Line , int Column )
+{
+ LineStart = Line;
+ ColumnStart = Column;
+ if ( POSITION(LineStart,ColumnStart) > POSITION(LineEnd,ColumnEnd) )
+ {
+ ColumnEnd = ColumnStart;
+ LineEnd = LineStart;
+ }
+}
+
+// This function simply advance the start position by 'distance' columns.
+void Location::Tab( int distance )
+{
+ ColumnStart += distance;
+ if (ColumnStart > LINE_WIDTH)
+ {
+ LineStart++;
+ ColumnStart = ((ColumnStart - 1) % LINE_WIDTH) + 1;
+ }
+ if (POSITION(LineStart,ColumnStart) > POSITION(LineEnd,ColumnEnd) )
+ {
+ LineEnd = LineStart;
+ ColumnEnd = ColumnStart;
+ }
+}
+
+// This function return the start position to the first column of the next line.
+void Location::Cr( void )
+{
+ LineStart++;
+ ColumnStart = 1;
+ if ( POSITION(LineStart,ColumnStart) > POSITION(LineEnd,ColumnEnd) )
+ {
+ LineEnd = LineStart;
+ ColumnEnd = ColumnStart;
+ }
+}
+
+void Location::Select( int length )
+{
+ LineStart = LineEnd;
+ ColumnStart = ColumnEnd;
+ ColumnEnd += length - 1;
+ if ( ColumnEnd >= LINE_WIDTH )
+ {
+ LineEnd++;
+ ColumnEnd = (ColumnEnd - 1 ) % LINE_WIDTH + 1;
+ }
+}
+
+void Location::Advance( void )
+{
+ LineStart = LineEnd;
+ ColumnStart = ++ColumnEnd;
+ if (ColumnStart == LINE_WIDTH)
+ {
+ ColumnStart = ColumnEnd = 1;
+ LineStart = ++LineEnd;
+ }
+}
+
+void Location::CrSelect( void )
+{
+ LineEnd++;
+ ColumnEnd = 1;
+}
+
+// Checking the properties of a location Object :
+// Line numbers and Column numbers must be greater than 0 and
+// Start Mark must be come before the End Mark.
+
+int Location::OK( void )
+{
+ if ( (LineStart < 0) || (LineEnd < 0) ||
+ (ColumnStart < 0) || (ColumnEnd < 0) ||
+// here we compute the number of characters from the begining
+// assuming the line is LINE_WIDTH characters wide .
+ ( POSITION( LineStart,ColumnStart ) > POSITION( LineEnd,ColumnEnd ) )
+ )
+ {
+ error(" This Location object is not in a coherent state.");
+ return -1;
+ }
+ else
+ return 0;
+}
+
+// Overloading semantic of + operator.
+// this return a Location Object that include both objects Location.
+Location operator + ( const Location& FirstLocation ,
+ const Location& SecondLocation )
+{
+ if (POSITION( FirstLocation .LineStart,FirstLocation .ColumnStart ) <
+ POSITION( SecondLocation.LineEnd ,SecondLocation.ColumnEnd ) )
+ {
+ return Location( FirstLocation .LineStart ,
+ FirstLocation .ColumnStart,
+ SecondLocation.LineEnd,
+ SecondLocation.ColumnEnd );
+ }
+ else
+ {
+ return Location( SecondLocation.LineStart ,
+ SecondLocation.ColumnStart,
+ FirstLocation.LineEnd,
+ FirstLocation.ColumnEnd );
+ }
+}
+
+// Well, this print out the contents of a Location object.
+
+ostream& operator << ( ostream& cout, Location there )
+{
+ cout << '(' << there.LineStart << ':' << there.ColumnStart << ',';
+ return cout << there.LineEnd << ':' << there.ColumnEnd << ')';
+}
+
+// General fonction that force the program to abort.
+void error( char * TheString )
+{
+ cout << TheString;
+ exit(-1);
+}
--- /dev/null
+//**************************************
+//* Class Location : *
+//* Class used for storing location *
+//* of an object *
+//**************************************
+
+void error(char *); // outputs an error message then exits.
+
+class Location
+{
+ int LineStart, // Line number where the entity starts
+ LineEnd, // Line number where the entity ends.
+ ColumnStart, // Column number of the beginning of the entity.
+ ColumnEnd; // Column number of the end of the entity.
+
+ int OK( void ); // Checks some properties of the object.
+
+ public:
+
+ // Several Constructors for initialisation of Location Object.
+ // The entity for the two first constructors is set to end at the same
+ // point than its beginnning.
+
+ // First constructor sets the Location to the beginning of the Text.
+ Location( void );
+
+ // Second constructor sets the Location to line Line and column Column.
+ // If Column is ommited, it is assumed that you are talking about the
+ // column 1.
+
+ Location( int Line , int Column = 1 );
+
+ // Last constructor for the ones who knows about the beginning and the
+ // end of the entity referenced.
+ Location( int First_Line, int First_Column,
+ int Last_Line, int Last_Column);
+
+ Location( const Location& );
+
+ // Set the point in the text where the entity ends.
+ void SetEnd( int Line, int Column );
+
+ // Move the beginning of the Location to the place indicated.
+ void Move( int Line , int Column );
+
+ // Advance the start position to n columns.
+ void Tab( int distance );
+
+ // Return the start position to next line.
+ void Cr( void );
+
+ void Select( int length );
+
+ void Advance( void );
+
+ void CrSelect( void );
+
+ // Overloading of the operator + for computing new Location
+ // The Location Object resulting begins at the first Location
+ // ( The most little position in the text) and ends at the
+ // last location (The furthest position).
+ friend Location operator + ( const Location& , const Location& );
+
+ // friend operation that allows to write the Location of the entity on
+ // the output stream.
+ friend ostream& operator << ( ostream& cout, Location there );
+} ;
+
+//**
+//** Several structure used inside the lex and yacc structure
+//**
+
+//** LocInt : concatenation of a integer and a location Object.
+typedef struct
+{
+ int Int;
+ Location *Loc;
+} LocInt;
+
+//** LocBool : concatenation of a boolean and a location Object.
+typedef struct
+{
+ int Bool;
+ Location *Loc;
+} LocBool;
+
+//** LocInt : concatenation of a integer and a location Object.
+typedef struct
+{
+ double Real;
+ Location *Loc;
+} LocDouble;
+
+//** LocStr : concatenation of a String and a location Object.
+typedef struct
+{
+ String *Str;
+ Location *Loc;
+} LocStr;
+
+//** LocChar : concatenation of a character and a location Object.
+typedef struct
+{
+ char Char;
+ Location *Loc;
+} LocChar;
+
+//*******************************************
+//* Class ErrorEntry *
+//* This Class describes an error emited *
+//* during the analysis of the text. *
+//*******************************************
+
+enum ErrorKind {Warning, // This entry is a warning.
+ Error, // This entry is a real error.
+ Fatal, // This entry is a spurious error.
+ Internal, // This error is because of the compiler.
+ Operating_system, // This error is because of the operating system.
+ Unknown}; // We don't know why an error has been generated.
+
+class ErrorEntry
+{
+ Location place; // Where it has happened.
+ int number; // The number of error encountered.
+ ErrorKind kind; // The type of error (see upper).
+ char *comment; // A precision about the error.
+
+ public:
+ // Two constructors to initialize an ErrorEntry object.
+
+ // First constructor, give the location of the error and its identification
+ ErrorEntry( Location, int, ErrorKind );
+
+ // Second constructor, just add a commend to the error.
+ ErrorEntry( Location, int, ErrorKind, char * );
+
+ // the friend operator << that allows to output the content of an
+ // ErrorEntry object into an output stream.
+ friend ostream operator << ( ostream& cout, ErrorEntry TheError);
+} ;
+
+//*******************************************
+//* Class ErrorStorage *
+//* This class describes the object that *
+//* holds all of the errors and warning *
+//* produced by the analysis phase. *
+//*******************************************
+
+class ErrorStorage
+{
+
+} ;
--- /dev/null
+#include <std.h>\r
+#include <String.h>\r
+#include <iostream.h>\r
+#include "SymTable.h"\r
+\r
+int init_offset(type kind) {\r
+\r
+ switch (kind) {\r
+ case CLASS_S : \r
+ case PROCESS_S :\r
+ case COROUTINE_S :\r
+ case SIGNAL_S :\r
+ case FUNCTION_S :\r
+ case PROCEDURE_S :\r
+ case BLOCK_S :\r
+ case HANDLERS_S : break; \r
+ };\r
+\r
+ return 1; \r
+\r
+};\r
+\r
+int update_offset(type kind) {\r
+\r
+ switch (kind) {\r
+ case CLASS_S : \r
+ case PROCESS_S :\r
+ case COROUTINE_S :\r
+ case SIGNAL_S :\r
+ case FUNCTION_S :\r
+ case PROCEDURE_S :\r
+ case HANDLERS_S : \r
+ case VARIABLE_S :\r
+ case CONSTANT_S : break; \r
+ };\r
+\r
+ return 1; \r
+\r
+};\r
+\r
+void list::add_elem(entry* e) {\r
+\r
+ list_elem* ThisElement;\r
+\r
+ ThisElement = new list_elem(e);\r
+ ThisElement->next = end_ptr;\r
+ end_ptr = ThisElement;\r
+\r
+};\r
+\r
+\r
+entry* list::find_virt(String id)\r
+{\r
+ list_elem* ThisElement;\r
+\r
+ for( ThisElement = end_ptr;\r
+ (ThisElement != NULL) && ( ThisElement->info_ptr->id != id);\r
+ ThisElement = ThisElement->next\r
+ );\r
+\r
+ if ( ThisElement )\r
+ return ThisElement->info_ptr;\r
+ else\r
+ return NULL;\r
+};\r
+\r
+\r
+void spec_list::add(String id)\r
+{\r
+\r
+ end_ptr=new spec_elem(id,end_ptr);\r
+\r
+};\r
+\r
+bool spec_list::present(String id) {\r
+\r
+ spec_elem* temp;\r
+\r
+ temp=end_ptr;\r
+ while ( temp != NULL && temp->info != id ) \r
+ temp=temp->next;\r
+ if (temp != NULL) \r
+ return TRUE;\r
+ else\r
+ return FALSE;\r
+\r
+};\r
+\r
+\r
+void pref_list::add_pref(entry* e,sharing sh)\r
+{\r
+ list* temp;\r
+\r
+ end_ptr = new pref_list_elem(e,sh,end_ptr);\r
+\r
+ if ((temp=((c_class*)(e->rest))->my_symtab->formal_param_list) != NULL) {\r
+ if (symtab->last->formal_param_list == NULL)\r
+ symtab->last->formal_param_list=new list;\r
+ symtab->last->formal_param_list->end_ptr=temp->end_ptr;\r
+ };\r
+\r
+};\r
+\r
+\r
+entry::entry(String ii,type kk,int oo,spec ss,packet* pp)\r
+{\r
+ id = ii;\r
+ kind = kk;\r
+ offset = oo;\r
+ visible = ss;\r
+ rest = pp;\r
+};\r
+\r
+node::node(int ll)\r
+{ \r
+ level=ll;\r
+ current_offset=OFFSET;\r
+ if (symtab == NULL)\r
+ end_ptr = begin_ptr \r
+ = new entry(NO_IDENT,FATHER,NO_OFFSET,NORMAL,\r
+ new f_father(NULL,level)\r
+ );\r
+ else\r
+ end_ptr = begin_ptr\r
+ = new entry(NO_IDENT,FATHER,NO_OFFSET,NORMAL,\r
+ new f_father(symtab->last,level)\r
+ );\r
+\r
+ virtual_list = NULL;\r
+ begin_ptr->prev = NULL;\r
+ close=taken=hidden = NULL;\r
+\r
+};\r
+\r
+void node::close_unit()\r
+{\r
+ symtab->last=((f_father*)(begin_ptr->rest))->father_ptr;\r
+};\r
+\r
+\r
+node* node::open_unit()\r
+{\r
+ node* temp;\r
+ \r
+ temp = new node(level+1);\r
+\r
+ ((c_class*)(symtab->last->end_ptr->rest))->my_symtab=temp;\r
+\r
+ temp->current_offset=init_offset(end_ptr->kind);\r
+ symtab->last=temp;\r
+\r
+ return temp;\r
+ \r
+};\r
+\r
+void node::add_spec(spec kind,String id)\r
+{\r
+ \r
+ switch (kind) {\r
+\r
+ case CLOSE :\r
+ if (close==NULL) close=new spec_list;\r
+ close->add(id);\r
+ break;\r
+ \r
+ case HIDDEN :\r
+ if (hidden==NULL) hidden=new spec_list;\r
+ hidden->add(id);\r
+ break;\r
+\r
+ case TAKEN :\r
+ if (taken==NULL) taken=new spec_list;\r
+ taken->add(id);\r
+ break;\r
+\r
+ };\r
+\r
+};\r
+\r
+void node::add_virt(entry* v) {\r
+\r
+ if (virtual_list == NULL) virtual_list=new list;\r
+ virtual_list->add_elem(v);\r
+\r
+};\r
+\r
+void node::add_form_param(entry* fp) {\r
+\r
+ if (formal_param_list == NULL) formal_param_list=new list;\r
+ formal_param_list->add_elem(fp);\r
+\r
+};\r
+\r
+\r
+struct find_result* node::local_find(String id,visible vis) {\r
+\r
+ entry* temp;\r
+ bool stop=FALSE;\r
+\r
+ \r
+ temp=end_ptr;\r
+\r
+ while ( !stop && temp->kind != FATHER) {\r
+ if (temp->id != id)\r
+ temp=temp->prev; \r
+ else\r
+ switch (temp->visible)\r
+ {\r
+ case HIDDEN :\r
+ if (vis == NOT_HIDDEN)\r
+ temp=temp->prev;\r
+ else\r
+ stop=TRUE;\r
+ break;\r
+\r
+ case NORMAL :\r
+ case CLOSE :\r
+ stop=TRUE;\r
+ break;\r
+ };\r
+ };\r
+\r
+ \r
+ if ( !stop ) \r
+ return new find_result(level,NULL);\r
+ else \r
+ return new find_result(level,temp);\r
+};\r
+\r
+struct find_result* symboltable::find_in_module(node* start,String id,bool dot=DOT,visible vis=ALL) {\r
+\r
+ struct find_result* temp1;\r
+ node* temp2;\r
+ pref_list_elem* temp3;\r
+ bool stop=FALSE;\r
+\r
+ temp1=start->local_find(id,vis);\r
+ if (temp1->found != NULL && !dot) \r
+ return temp1;\r
+ else if (start->prefix != NULL) {\r
+ \r
+ temp3=start->prefix->end_ptr;\r
+ while ((temp3 != NULL) && !stop) {\r
+ temp1=((c_class*)(temp3->where->rest))->my_symtab->local_find(id,NOT_HIDDEN);\r
+ if (temp1->found != NULL) stop = TRUE;\r
+ temp3=temp3->next;\r
+ };\r
+ if (temp3 != NULL && !dot) return temp1;\r
+ };\r
+\r
+return new find_result(temp1->level,NULL);\r
+\r
+ \r
+}; \r
+\r
+struct find_result* symboltable::find(String id) {\r
+\r
+ struct find_result* temp1;\r
+ entry* temp2;\r
+ node* temp3;\r
+\r
+ temp1=symtab->find_in_module(symtab->last,id,FALSE,ALL);\r
+ if (temp1->found != NULL && temp1->found->id == id) return temp1; \r
+ temp3=((f_father*)(symtab->last->begin_ptr->rest))->father_ptr;\r
+ while (temp3 != NULL && temp1->level != MAIN_LEVEL ) { \r
+ temp1=symtab->find_in_module(temp3,id,FALSE,NOT_HIDDEN); \r
+ temp3=((f_father*)(temp3->begin_ptr->rest))->father_ptr;\r
+ };\r
+\r
+ if (temp1->found != NULL && temp1->found->id == id)\r
+\r
+ return temp1;\r
+\r
+ else\r
+\r
+ return new find_result(MAIN_LEVEL,NULL);\r
+ \r
+};\r
+\r
+entry* symboltable::inherit(String id,sharing sh=NOT_SHARED) {\r
+\r
+ entry* temp;\r
+\r
+ pref_list_elem* temp1;\r
+\r
+\r
+ temp=symtab->find(id)->found;\r
+\r
+ if (temp != NULL && ( temp->kind ==CLASS_S || temp->kind == PROCESS_S || temp->kind == COROUTINE_S) ) {\r
+\r
+ if (last->prefix == NULL) last->prefix = new pref_list;\r
+ \r
+ if (((c_class*)(temp->rest))->prefix != NULL) {\r
+\r
+ temp1=((c_class*)(temp->rest))->prefix->end_ptr;\r
+ while (temp1 != NULL) {\r
+ last->prefix->add_pref(temp1->where,temp1->shared);\r
+ temp1=temp1->next;\r
+ };\r
+ }; \r
+ last->prefix->add_pref(temp,sh);\r
+ return temp;\r
+ }\r
+\r
+ else\r
+ \r
+ return NULL;\r
+\r
+};\r
+\r
+entry* symboltable::insert(String id,type kind,packet* p) {\r
+\r
+ entry* temp;\r
+\r
+ spec temp1;\r
+\r
+ if ( ((symtab->last->local_find(id,ALL))->found == NULL) )\r
+ {\r
+\r
+ temp1=NORMAL;\r
+ if (symtab->last->close != NULL) \r
+ if (symtab->last->close->present(id) ) temp1=CLOSE;\r
+ if (symtab->last->hidden != NULL) \r
+ if (symtab->last->hidden->present(id) ) temp1=HIDDEN;\r
+ temp=new entry(id,kind,symtab->last->current_offset,temp1,p);\r
+ symtab->last->current_offset += update_offset(kind);\r
+ temp->prev=symtab->last->end_ptr;\r
+ symtab->last->end_ptr=temp;\r
+ if (kind == VARIABLE_S && (((v_variable*)p)->type == POINTER)) {\r
+ if (symtab->last->ref_var_list == NULL) \r
+ symtab->last->ref_var_list=new list;\r
+ symtab->last->ref_var_list->add_elem(temp);\r
+ };\r
+ return temp;\r
+\r
+ }\r
+\r
+ else return NULL;\r
+\r
+};\r
--- /dev/null
+typedef int bool;
+
+typedef enum { FATHER,PREFIX,CLASS_S,PROCESS_S,COROUTINE_S,VARIABLE_S,SIGNAL_S,
+ CONSTANT_S,FUNCTION_S,PROCEDURE_S,BLOCK_S,HANDLERS_S } type;
+
+typedef enum { CLOSE,HIDDEN,TAKEN,NORMAL } spec;
+
+typedef enum { INTEGER,REAL,BOOLEAN,CHARACTER,STRING,FILE,SEMAPHORE,POINTER } var_type;
+
+typedef enum { ALL,NOT_HIDDEN } visible;
+
+typedef enum { SHARED,NOT_SHARED } sharing;
+
+
+
+
+#define NO_OFFSET -2
+#define NO_IDENT NULL
+#define OFFSET 150
+#define TRUE 1
+#define FALSE 0
+#define MAIN_LEVEL 0
+#define DOT TRUE
+#define NOT_DOT FALSE
+
+class packet {public : };
+
+class entry
+{
+public :
+ String id;
+ type kind;
+ int offset;
+ spec visible;
+ packet* rest;
+ entry* prev;
+
+ entry(String,type,int,spec,packet*);
+};
+
+struct find_result
+{
+ int level;
+ entry* found;
+
+ find_result(int l,entry* e) { level=l;found=e;}
+};
+
+
+class list_elem
+{
+public :
+ entry* info_ptr;
+ list_elem* next;
+ list_elem(entry* e) { info_ptr=e; };
+};
+
+class list
+{
+public :
+ list_elem* end_ptr;
+ void add_elem(entry*);
+
+ entry* find_virt(String);
+
+ list() { end_ptr=NULL; };
+};
+
+class spec_elem
+{
+public :
+ String info;
+ spec_elem* next;
+
+ spec_elem(String e,spec_elem* n) { info=e;next=n; };
+};
+
+class spec_list
+{
+public :
+ spec_elem* end_ptr;
+
+ void add ( String );
+ bool present( String );
+
+ spec_list() { end_ptr=NULL; };
+};
+
+class pref_list_elem
+{
+ public :
+ entry* where;
+ int base;
+ sharing shared;
+ pref_list_elem* next;
+
+ pref_list_elem(entry* e,sharing sh,pref_list_elem* c)
+ {
+ where = e;
+ shared = sh;
+ next = c;
+ };
+
+};
+
+
+class pref_list
+{
+public :
+ pref_list_elem* end_ptr;
+ void add_pref(entry*,sharing);
+ pref_list() {end_ptr=NULL;};
+};
+
+class node
+{
+public :
+ int level;
+ int current_offset;
+ entry* end_ptr;
+ entry* begin_ptr;
+ list* virtual_list;
+ list* formal_param_list;
+ list* ref_var_list;
+ pref_list* prefix;
+ spec_list* close;
+ spec_list* hidden;
+ spec_list* taken;
+
+ void add_spec(spec,String);
+ void add_virt(entry*);
+ void add_form_param(entry*);
+ void close_unit();
+ node* open_unit();
+ struct find_result* local_find(String,visible);
+ node(int);
+
+};
+
+class c_class : public packet
+{
+public :
+ pref_list* prefix;
+ bool f_param;
+ bool virt; // or shared
+ node* my_symtab;
+
+};
+
+class f_father : public packet
+{
+public :
+ node* father_ptr;
+ int level;
+ int base;
+ f_father(node* ff,int ll) { father_ptr=ff;level=ll; };
+};
+
+class symboltable
+{
+public :
+ node* last;
+ node* root;
+ entry* inherit(String,sharing sh = NOT_SHARED);
+ entry* insert(String,type,packet*);
+
+ struct find_result* find_in_module(node*,String,bool,visible vis = ALL);
+
+ struct find_result* find(String);
+ symboltable() {root=last=new node(MAIN_LEVEL);};
+};
+
+class v_variable : public packet
+{
+public :
+ var_type type;
+ bool f_param;
+};
+
+class s_signal : public c_class {};
+
+class h_handler : public c_class {};
+
+class c_coroutine : public c_class { };
+
+class p_process : public c_class {};
+
+class b_block : public c_class {};
+
+class p_procedure : public c_class { public: } ;
+
+class f_function : public c_class {
+
+public :
+ type result_type;
+};
+
+class c_constant : public packet
+{
+public :
+ int ptr; //here will be link to constant value
+};
--- /dev/null
+//****************************************************************
+//* *
+//* Syntax.y : Grammar for the LOGLAN-82 and the LOGLAN-93 *
+//* languages. *
+//* *
+//* (c) LITA, university of PAU (France), summer 1993. *
+//****************************************************************
+
+%{
+
+#ifdef RULES_DEBUG
+
+#define RULES_DEBUG_printf(a) fprintf(stderr,a)
+#define RULES_ERROR_DEBUG
+
+#else
+
+#define RULES_DEBUG_printf(a)
+
+#endif
+
+#ifdef RULES_ERROR_DEBUG
+
+#define RULES_ERROR_printf(a) fprintf(stderr,a)
+
+#else
+
+#define RULES_ERROR_printf(a)
+
+#endif
+
+#ifndef SYNTAX_ONLY
+
+#define SEMANTIC(a) a
+
+#include <math.h>
+#include <String.h>
+#include <iostream.h>
+#include "Objects.h"
+#include "Expr.h"
+#include "Instr.h"
+
+extern int BeginningOfLine;
+
+#else
+
+#define SEMANTIC(a)
+
+#endif
+
+void initialize( void );
+int yylex( void );
+int line_number;
+int yyerror( void );
+int yyerror( char * );
+
+%}
+
+%union {
+ Expression *Expr;
+ Instruction *Instr;
+ Block *ThisBlock;
+ Location *ThisLoc;
+ BoolOpType bool;
+ ArithOpType arith;
+ ObjOpType object;
+ OneArgJob ThisArgJob;
+ LocInt ThisInt;
+ LocDouble ThisReal;
+ LocChar ThisChar;
+ LocStr ThisString;
+ LocBool ThisBool;
+}
+
+%type <bool> binary_operator
+%type <arith> arith_operator arith_operator2
+%type <ThisReal> opt_Num_const
+%type <ThisInt> opt_prefix_sign
+%type <Expr> factor expression expression_in_bracket
+%type <Expr> NumberConst object_factor composed_expr2
+%type <Expr> composed_expr logic_expr variable
+%type <Expr> object generator r_value
+%type <Expr> one_or_more_logic_factor one_or_more_logic_term
+%type <Expr> one_or_more_factor one_or_more_term
+%type <Expr> non_prefixed_variable non_prefixed_generator
+%type <Expr> short_or_and_list
+%type <object> object_operator
+%type <Instr> affectation_instruction instruction
+%type <Instr> single_instruction complex_instruction
+%type <Instr> condition_instruction loop_instruction
+%type <ThisArgJob> parameter_job_instruction
+%type <ThisBlock> instructions opt_instructions opt_else loop_body
+
+// Main
+
+%token <ThisLoc> PROGRAM BLOCK PREF
+
+// Module definition
+
+%token <ThisLoc> UNIT CLASS PROCEDURE FUNCTION
+%token <ThisLoc> COROUTINE PROCESS VIRTUAL SHARED ENUM
+
+// Parameters transmission mode
+
+%token <ThisLoc> INPUT OUTPUT INOUT TAKEN CLOSE HIDDEN
+
+// Sub-parts of module
+
+%token <ThisLoc> HANDLERS SIGNAL Begin END
+
+// Variable and constants declarations
+
+%token <ThisLoc> VAR CONST
+%token <ThisString> IDENTIFIER
+%token <ThisLoc> INTEGER TYPE REAL BOOLEAN CHARACTER
+%token <ThisLoc> STRING File ARRAY
+
+//Punctuation
+
+%token <ThisLoc> LIST_SEPARATOR VARSEPARATOR OPENINGBRACKET
+%token <ThisLoc> CLOSINGBRACKET ENDSENTENCE POINT
+
+//Operators
+
+%token <ThisLoc> STAR DIVIDE DIV MOD PLUS MINUS
+%token <ThisLoc> LESS LESSOREQUAL EQUAL NEQUAL
+%token <ThisLoc> GREATER GREATEROREQUAL
+%token <ThisLoc> OR AND NOT ANDIF ORIF
+%token <ThisLoc> AFFECTATION
+%token <ThisLoc> QUA THIS IS IN NEW COPY ARRAY_OF
+%token <ThisLoc> NONE
+
+// Constants
+
+%token <ThisString> TEXTCONST
+%token <ThisChar> CHARCONST
+%token <ThisInt> DIGITSEQUENCE
+%token <ThisBool> BOOLCONST
+
+//Keywords for Instructions
+
+%token <ThisLoc> IF THEN ELSE FI
+%token <ThisLoc> CASE WHEN OTHERWISE ESAC
+%token <ThisLoc> WHILE FOR STEP TO DOWNTO DO OD
+%token <ThisLoc> ATTACH DETACH RESUME STOP TERMINATE
+%token <ThisLoc> RESULT
+%token <ThisLoc> GET PUT READ READLN WRITE WRITELN
+%token <ThisLoc> DIM
+%token <ThisLoc> RAISE KILL
+%token <ThisLoc> CALL RETURN
+%token <ThisLoc> EXIT REPEAT
+%token <ThisLoc> INNER WIND
+
+%%
+
+// We begin with the main rule that initialize the variables analyse the
+// program and then go on is compilation.
+
+but: initloglan program endprogram analyse
+ { RULES_DEBUG_printf(" but -> initloglan program analyse \n");} ;
+
+// This rule is empty. Is only use is for side-effect.
+
+initloglan: { initialize(); }
+ ;
+
+// This one too...
+
+analyse:
+ ;
+
+program: program_module
+ {RULES_DEBUG_printf("program -> program_module.\n"); }
+ | block_module
+ {RULES_DEBUG_printf("program -> block_module.\n"); }
+ | unit_module
+ {RULES_DEBUG_printf("program -> unit_module.\n"); }
+ ;
+
+program_module: PROGRAM IDENTIFIER endsentence module_body
+ { RULES_DEBUG_printf("program_module -> PROGRAM IDENTIFIER endsentence module_body.\n"); }
+ | PROGRAM error module_body
+ { RULES_ERROR_printf(" error: program name missing.\n"); }
+ ;
+
+block_module: BLOCK module_body
+ { RULES_DEBUG_printf("block_module -> BLOCK module_body.\n"); }
+ | error
+ { RULES_ERROR_printf(" error : BLOCK or PROGRAM expected.\n"); }
+ ;
+
+unit_module: module_header module_body
+ { RULES_DEBUG_printf("unit_module -> module_header module_body.\n"); }
+ ;
+
+module_body: opt_declarations module_code
+ { RULES_DEBUG_printf("module_body -> opt_declarations module_code.\n"); }
+ ;
+module_header: UNIT opt_virtual IDENTIFIER VARSEPARATOR prefix_list module_type parameters endsentence opt_visibility_declarations
+ { RULES_DEBUG_printf("module_header -> UNIT opt_virtual IDENTIFIER VARSEPARATOR prefix_list modul_type parameters endsentence opt_visibility_declarations.\n"); }
+ | UNIT opt_virtual IDENTIFIER VARSEPARATOR ENUM OPENINGBRACKET identifier_list CLOSINGBRACKET endsentence
+ { RULES_DEBUG_printf("module_header -> UNIT opt_virtual IDENTIFIER VARSEPARATOR ENUM OPENINGBRACKET identifier_list CLOSINGBRACKET endsentence.\n"); }
+ ;
+
+prefix_list:
+ { RULES_DEBUG_printf("prefix_list -> .\n"); }
+ | list_prefix
+ { RULES_DEBUG_printf("prefix_list -> list_prefix.\n"); };
+
+list_prefix: opt_shared identifier_path
+ { RULES_DEBUG_printf("list_prefix -> identifier_path .\n"); }
+ | opt_shared identifier_path LIST_SEPARATOR prefix_list
+ { RULES_DEBUG_printf("list_prefix -> identifier_path LIST_SEPARATOR prefix_list.\n"); }
+ ;
+
+opt_shared: SHARED
+ { RULES_DEBUG_printf("opt_shared -> SHARED.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_shared -> .\n"); }
+ ;
+
+opt_virtual: VIRTUAL
+ { RULES_DEBUG_printf("opt_virtual -> VIRTUAL.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_virtual -> .\n"); }
+ ;
+
+identifier_path:
+ IDENTIFIER
+ { RULES_DEBUG_printf("identifier_path -> IDENTIFIER.\n"); }
+ | IDENTIFIER VARSEPARATOR identifier_path
+ { RULES_DEBUG_printf("identifier_path -> IDENTIFIER VARSEPARATOR identifier_path.\n"); }
+ ;
+
+module_type: CLASS
+ { RULES_DEBUG_printf("module_type -> CLASS.\n"); }
+ | PROCEDURE
+ { RULES_DEBUG_printf("module_type -> PROCEDURE.\n"); }
+ | FUNCTION
+ { RULES_DEBUG_printf("module_type -> FUNCTION.\n"); }
+ | COROUTINE
+ { RULES_DEBUG_printf("module_type -> COROUTINE.\n"); }
+ | PROCESS
+ { RULES_DEBUG_printf("module_type -> PROCESS.\n"); }
+ ;
+
+parameters: OPENINGBRACKET formal_parameters_list opt_endsentence CLOSINGBRACKET end_parameters
+ { RULES_DEBUG_printf("parameters -> OPENINGBRACKET formal_parameters_list opt_endsentence CLOSINGBRACKET end_parameters.\n"); }
+ | end_parameters
+ { RULES_DEBUG_printf("parameters -> end_parameters.\n"); }
+ ;
+
+end_parameters: VARSEPARATOR typeident
+ { RULES_DEBUG_printf("end_parameters -> VARSEPARATOR IDENTIFIER.\n"); }
+ |
+ { RULES_DEBUG_printf("end_parameters -> .\n"); }
+ ;
+
+formal_parameters_list: formal_parameters_list endsentence formal_parameter
+ { RULES_DEBUG_printf("formal_parameters_list -> formal_parameters_list endsentence formal_parameter.\n"); }
+ | formal_parameter
+ { RULES_DEBUG_printf("formal_parameters_list -> formal_parameter.\n"); }
+ ;
+
+formal_parameter: parametertype var_param_list
+ { RULES_DEBUG_printf("formal_parameter -> parametertype var_param_list.\n"); }
+ | TYPE IDENTIFIER
+ { RULES_DEBUG_printf("formal_parameter -> TYPE IDENTIFIER.\n"); }
+ | callable_module
+ { RULES_DEBUG_printf("formal_parameter -> callable_module.\n"); }
+ ;
+
+parametertype: INPUT
+ { RULES_DEBUG_printf("parametertype -> INPUT.\n"); }
+ | OUTPUT
+ { RULES_DEBUG_printf("parametertype -> OUTPUT.\n"); }
+ | INOUT
+ { RULES_DEBUG_printf("parametertype -> INOUT.\n"); }
+ |
+ { RULES_DEBUG_printf("parametertype -> .\n"); }
+ ;
+
+var_param_list: var_param_list LIST_SEPARATOR var_declaration
+ { RULES_DEBUG_printf("var_param_list -> var_param_list LIST_SEPARATOR var_declaration.\n"); }
+ | var_declaration
+ { RULES_DEBUG_printf("var_param_list -> var_declaration.\n"); }
+ ;
+
+var_declaration: identifier_list VARSEPARATOR typeident
+ { RULES_DEBUG_printf("var_declaration -> identifier_list VARSEPARATOR typeident.\n"); }
+ ;
+
+identifier_list: identifier_list LIST_SEPARATOR IDENTIFIER
+ { RULES_DEBUG_printf("identifier_list -> identifier_list LIST_SEPARATOR IDENTIFIER.\n"); }
+ | IDENTIFIER
+ { RULES_DEBUG_printf("identifier_list -> IDENTIFIER.\n"); }
+ ;
+
+typeident: list_arrayof definedtype
+ { RULES_DEBUG_printf(" typeident -> list_arrayof definedtype .\n"); }
+ | definedtype
+ { RULES_DEBUG_printf(" typeident -> definedtype .\n"); }
+ ;
+
+list_arrayof: list_arrayof ARRAY_OF
+ { RULES_DEBUG_printf(" list_arrayof -> list_arrayof ARRAY_OF .\n"); }
+ | ARRAY_OF
+ { RULES_DEBUG_printf(" list_arrayof -> .\n"); }
+ ;
+
+definedtype: predefinedtype
+ | IDENTIFIER
+ ;
+
+predefinedtype: INTEGER
+ { RULES_DEBUG_printf(" predefinedtype -> INTEGER .\n"); }
+ | REAL
+ { RULES_DEBUG_printf(" predefinedtype -> REAL.\n"); }
+ | BOOLEAN
+ { RULES_DEBUG_printf(" predefinedtype -> BOOLEAN.\n"); }
+ | CHARACTER
+ { RULES_DEBUG_printf(" predefinedtype -> CHARACTER.\n"); }
+ | STRING
+ { RULES_DEBUG_printf(" predefinedtype -> STRING.\n"); }
+ | File
+ { RULES_DEBUG_printf(" predefinedtype -> FILE.\n"); }
+ | PROCESS
+ { RULES_DEBUG_printf(" predefinedtype -> PROCESS.\n"); }
+ | COROUTINE
+ { RULES_DEBUG_printf(" predefinedtype -> PROCESS.\n"); }
+ ;
+
+callable_module: function_callable
+ { RULES_DEBUG_printf("callable_module -> function_callable.\n"); }
+ | procedure_callable
+ { RULES_DEBUG_printf("callable_module -> procedure_callable.\n"); }
+ ;
+
+function_callable: FUNCTION IDENTIFIER parameters
+ { RULES_DEBUG_printf("function_callable -> FUNCTION IDENTIFIER parameters.\n"); }
+ ;
+
+procedure_callable: PROCEDURE IDENTIFIER parameters
+ { RULES_DEBUG_printf("procedure_callable -> PROCEDURE IDENTIFIER parameters.\n"); }
+ ;
+
+handlers_declaration: HANDLERS handlers_body END HANDLERS opt_endsentence
+ { RULES_DEBUG_printf("handlers_declaration -> HANDLERS handlers_body END HANDLERS opt_endsentence.\n"); }
+ ;
+
+opt_endsentence: ENDSENTENCE
+ { RULES_DEBUG_printf("opt_endsentence -> ENDSENTENCE.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_endsentence -> .\n"); }
+ ;
+
+endsentence: ENDSENTENCE
+ { RULES_DEBUG_printf("endsentence -> ENDSENTENCE.\n"); }
+ | error
+ { RULES_ERROR_printf("error : ';' expected.\n"); }
+
+handlers_body: when_list opt_others
+ { RULES_DEBUG_printf("handlers_body -> when_list opt_others.\n"); }
+ ;
+
+when_list: when_list when_unique
+ { RULES_DEBUG_printf("when_list -> when_list when_unique.\n"); }
+ | when_unique
+ { RULES_DEBUG_printf("when_list -> when_unique.\n"); }
+ ;
+
+when_unique: WHEN identifier_list VARSEPARATOR instructions
+ { RULES_DEBUG_printf("when_unique -> WHEN identifier_list VARSEPARATOR instructions.\n"); }
+ ;
+
+opt_others: OTHERWISE VARSEPARATOR instructions
+ { RULES_DEBUG_printf("opt_others -> OTHERWISE VARSEPARATOR instructions.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_others -> .\n"); }
+ ;
+
+module_code: Begin opt_instructions END module_code_end
+ {
+ RULES_DEBUG_printf("module_code -> BEGIN opt_instructions END module_code_end.\n");
+ SEMANTIC(
+ {
+ if ($<ThisBlock>2)
+ $<ThisBlock>2->Print( cout );
+ });
+ }
+ | END module_code_end
+ { RULES_DEBUG_printf("module_code -> END module_code_end.\n"); }
+ ;
+
+opt_instructions: instructions
+ {
+ RULES_DEBUG_printf("opt_instructions -> instructions opt_endsentence.\n");
+ SEMANTIC(( $<ThisBlock>$ = $<ThisBlock>1 ));
+ }
+ |
+ {
+ RULES_DEBUG_printf("opt_instructions ->.\n");
+ SEMANTIC(( $<ThisBlock>$ = NULL ));
+ }
+ ;
+
+module_code_end:
+ IDENTIFIER
+ { RULES_DEBUG_printf("module_code_end -> IDENTIFIER .\n"); }
+ |
+ { RULES_DEBUG_printf("module_code_end -> .\n"); }
+ ;
+
+opt_declarations:
+ { RULES_DEBUG_printf("opt_declarations -> .\n"); }
+ | declarations handlers_declaration
+ { RULES_DEBUG_printf("opt_declarations -> declarations handlers_declaration.\n"); }
+ | handlers_declaration
+ { RULES_DEBUG_printf("opt_declarations -> handlers_declaration.\n"); }
+ | declarations
+ { RULES_DEBUG_printf("opt_declarations -> declarations .\n"); }
+ ;
+
+declarations: declarations declaration endsentence
+ { RULES_DEBUG_printf("declarations -> declarations declaration endsentence.\n"); }
+ | declaration endsentence
+ { RULES_DEBUG_printf("declarations -> declaration endsentence. \n"); }
+ ;
+
+declaration: const_declaration
+ { RULES_DEBUG_printf("declaration -> const_declaration.\n"); }
+ | variables_declaration
+ { RULES_DEBUG_printf("declaration -> variables_declaration.\n"); }
+ | unit_module
+ { RULES_DEBUG_printf("declaration -> unit_module.\n"); }
+ | signal_declaration
+ { RULES_DEBUG_printf("declarations -> signal_declaration.\n"); }
+ ;
+
+opt_visibility_declarations:
+ visibility_declarations
+ { RULES_DEBUG_printf("opt_visibility_declarations -> visibility_declarations.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_visibility_declarations -> .\n"); }
+ ;
+
+visibility_declarations:
+ visibility_declarations visibility_declaration endsentence
+ { RULES_DEBUG_printf("visibility_declarations -> visibility_declarations visibility_declaration endsentence.\n"); }
+ | visibility_declaration endsentence
+ { RULES_DEBUG_printf("visibility_declarations ->visibility_declaration endsentence.\n"); }
+ ;
+
+visibility_declaration:
+ visibility_keyword identifier_list
+ { RULES_DEBUG_printf("visibility_declaration -> visibility_keyword identifier_list.\n"); }
+ ;
+
+visibility_keyword:
+ TAKEN
+ { RULES_DEBUG_printf("visibility_keyword -> TAKEN.\n"); }
+ | CLOSE
+ { RULES_DEBUG_printf("visibility_declarations -> CLOSE.\n"); }
+ | HIDDEN
+ { RULES_DEBUG_printf("visibility_declarations -> HIDDEN.\n"); }
+ ;
+
+variables_declaration: VAR vars_list
+ { RULES_DEBUG_printf("variables_declaration -> VAR vars_list.\n"); }
+ ;
+
+const_declaration: CONST const_list
+ { RULES_DEBUG_printf("variables_declaration -> CONST const_list.\n"); }
+ ;
+
+signal_declaration: SIGNAL IDENTIFIER parameters
+ { RULES_DEBUG_printf("signal_declaration -> SIGNAL IDENTIFIER parameters.\n");}
+ ;
+
+// instructions are composed of juxtaposition of several instruction.
+instructions: instruction
+ {
+ RULES_DEBUG_printf("instructions -> instruction.\n");
+ SEMANTIC(( $<ThisBlock>$ = new Block( $<Instr>1 ) ));
+ }
+ | instructions instruction
+ {
+ RULES_DEBUG_printf("instructions -> instructions instruction.\n");
+ SEMANTIC(( *$<ThisBlock>1 += $<Instr>2 ));
+ }
+ ;
+
+// An Instruction could be a single instruction (like WRITE or STOP)
+// or a complex instruction (i.e. composed ) (like IF FOR WHILE CASE ... )
+instruction: single_instruction endsentence
+ {
+ RULES_DEBUG_printf("instruction -> single_instruction endsentence.\n");
+ SEMANTIC(( $<Instr>$ = $<Instr>1 ));
+ }
+ | complex_instruction
+ {
+ RULES_DEBUG_printf("instruction -> complex_instruction.\n");
+ SEMANTIC(( $<Instr>$ = $<Instr>1 ));
+ }
+ ;
+
+// List of every single instruction available
+single_instruction:
+ affectation_instruction
+ {
+ RULES_DEBUG_printf("instruction -> affectation_instruction.\n");
+ SEMANTIC(( $<Instr>$ = $<Instr>1 ));
+ }
+ | job_instruction
+ {
+ RULES_DEBUG_printf("instruction -> job_instruction.\n");
+ SEMANTIC(( $<Instr>$ = $<Instr>1 ));
+ }
+ | io_instruction
+ { RULES_DEBUG_printf("instruction -> io_instruction.\n"); }
+ | signal_instruction
+ { RULES_DEBUG_printf("instruction -> signal_instruction.\n"); }
+ | array_instruction
+ { RULES_DEBUG_printf("instruction -> array_instruction.\n"); }
+ | object_instruction
+ { RULES_DEBUG_printf("instruction -> object_instruction.\n"); }
+ | CALL variable
+ { RULES_DEBUG_printf("instruction -> CALL variable.\n"); }
+ | RETURN
+ { RULES_DEBUG_printf("instruction -> RETURN.\n"); }
+ | exit_instruction
+ { RULES_DEBUG_printf("instruction -> exit_instruction.\n"); }
+ ;
+
+// Subdivision of complex instructions :
+// instruction declaring a loop
+// instruction declaring a condition
+// instruction declaring a sub-block
+complex_instruction:
+ loop_instruction
+ {
+ RULES_DEBUG_printf("complex_instruction -> loop_instruction.\n");
+ $<Instr>$ = $<Instr>1;
+ }
+ | condition_instruction
+ { RULES_DEBUG_printf("complex_instruction -> condition_instruction.\n"); }
+ | block_instruction
+ { RULES_DEBUG_printf("complex_instruction -> block_instruction.\n"); }
+ | case_instruction
+ { RULES_DEBUG_printf("complex_instruction -> case_instruction.\n"); }
+ ;
+
+vars_list: vars_list LIST_SEPARATOR var_declaration
+ { RULES_DEBUG_printf("vars_list -> vars_list LIST_SEPARATOR var_declaration .\n"); }
+ | var_declaration
+ { RULES_DEBUG_printf("vars_list -> var_declaration .\n"); }
+ ;
+
+const_list: const_list LIST_SEPARATOR one_const
+ { RULES_DEBUG_printf("const_list -> const_list LISTSEPARATOR one_const.\n");}
+ | one_const
+ { RULES_DEBUG_printf("const_list -> one_const.\n");}
+ ;
+
+one_const: IDENTIFIER EQUAL expression
+ {
+ RULES_DEBUG_printf("one_const -> IDENTIFIER EQUAL expression. \n");
+ }
+ ;
+
+expression: one_or_more_logic_term
+ {
+ RULES_DEBUG_printf("expression -> one_or_more_logic_term.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ ;
+
+one_or_more_logic_term:
+ one_or_more_logic_factor
+ {
+ RULES_DEBUG_printf("one_or_more_logic_term -> one_or_more_logic_term.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 )) ;
+ }
+ | one_or_more_logic_term OR one_or_more_logic_factor
+ {
+ RULES_DEBUG_printf("one_or_more_logic_term -> one_or_more_logic_term OR one_or_more_logic_factor.\n");
+ SEMANTIC(( $<Expr>$ = new BoolOperator( $<Expr>1, $<Expr>3 , Or, $<ThisLoc>2 ) ));
+ }
+ ;
+
+one_or_more_logic_factor:
+ composed_expr
+ {
+ RULES_DEBUG_printf("one_or_more_logic_factor -> composed_expr.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | one_or_more_logic_factor AND composed_expr
+ {
+ RULES_DEBUG_printf("one_or_more_logic_factor -> one_or_more_logic_factor AND composed_expr.\n");
+ SEMANTIC(( $<Expr>$ = new BoolOperator( $<Expr>1, $<Expr>3, And, $<ThisLoc>2 ) ));
+ }
+ ;
+
+composed_expr: NOT composed_expr2
+ {
+ RULES_DEBUG_printf("composed_expr -> NOT composed_expr2.\n");
+ SEMANTIC(( $<Expr>$ = new Not( $<Expr>2,$<ThisLoc>1 ) ));
+ }
+ | composed_expr2
+ {
+ RULES_DEBUG_printf("composed_expr -> composed_expr2.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ ;
+
+composed_expr2: logic_expr
+ {
+ RULES_DEBUG_printf("composed_expr2 -> logic_expr.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | logic_expr binary_operator logic_expr
+ {
+ RULES_DEBUG_printf("composed_expr2 -> logic_expr binary_operator logic_expr.\n");
+ SEMANTIC(( $<Expr>$ = new BoolOperator( $<Expr>1 , $<Expr>3 , $<bool>2 ) ));
+ }
+ | logic_expr object_operator object
+ {
+ RULES_DEBUG_printf("composed_expr2 -> logic_expr object_operator logic_expr.\n");
+ SEMANTIC(( $<Expr>$ = new ObjOperator( $<Expr>1 , $<Expr>3 , $<object>2 ) ));
+ }
+ ;
+
+binary_operator:
+ EQUAL
+ {
+ RULES_DEBUG_printf("binary_operator -> EQUAL.\n");
+ SEMANTIC(($<bool>$ = Equal));
+ }
+ | NEQUAL
+ {
+ RULES_DEBUG_printf("binary_operator -> NEQUAL.\n");
+ SEMANTIC(($<bool>$ = NotEqual));
+ }
+ | LESS
+ {
+ RULES_DEBUG_printf("binary_operator -> LESS.\n");
+ SEMANTIC(($<bool>$ = Less));
+ }
+ | LESSOREQUAL
+ {
+ RULES_DEBUG_printf("binary_operator -> LESSOREQUAL.\n");
+ SEMANTIC(($<bool>$ = LessOrEqual));
+ }
+ | GREATER
+ {
+ RULES_DEBUG_printf("binary_operator -> GREATER.\n");
+ SEMANTIC(($<bool>$ = Greater));
+ }
+ | GREATEROREQUAL
+ {
+ RULES_DEBUG_printf("binary_operator -> GREATEROREQUAL.\n");
+ SEMANTIC(($<bool>$ = GreaterOrEqual));
+ }
+ ;
+
+object_operator:
+ IS
+ {
+ RULES_DEBUG_printf("object_operator -> IS.\n");
+ SEMANTIC(( $<object>$ = Is ));
+ }
+ | IN
+ {
+ RULES_DEBUG_printf("object_operator -> IN.\n");
+ SEMANTIC(( $<object>$ = In ));
+ }
+ ;
+
+object: COROUTINE
+ { RULES_DEBUG_printf("object -> COROUTINE.\n"); }
+ | PROCESS
+ { RULES_DEBUG_printf("object -> PROCESS.\n"); }
+ | IDENTIFIER
+ {
+ RULES_DEBUG_printf("object -> IDENTIFIER.\n");
+ SEMANTIC(( $<Expr>$ = new Identifier( $<ThisString>1.Str, $<ThisString>1.Loc ) ));
+ }
+ | error
+ {
+ RULES_ERROR_printf("error : bad object.\n");
+ SEMANTIC(( $<Expr>$ = new Error( new Location( ThisPlace ) ));
+ }
+ ;
+
+logic_expr: opt_prefix_sign one_or_more_term
+ {
+ RULES_DEBUG_printf("expression -> opt_prefix_sign one_or_more_term.\n");
+// To be modified, must take care of the optionnal prefix sign.
+ SEMANTIC(( $<Expr>$ = $<Expr>2 ));
+ }
+ ;
+
+// The optionnal prefixing sign: +a, -a, a
+opt_prefix_sign:
+ PLUS
+ {
+ RULES_DEBUG_printf("opt_prefix_sign -> PLUS.\n");
+ SEMANTIC(( $<ThisInt>$.Int = 1 ));
+ SEMANTIC(( $<ThisInt>$.Loc = $<ThisLoc>1 ));
+ }
+ | MINUS
+ {
+ RULES_DEBUG_printf("opt_prefix_sign -> MINUS.\n");
+ SEMANTIC(( $<ThisInt>$.Int = -1 ));
+ SEMANTIC(( $<ThisInt>$.Loc = $<ThisLoc>1));
+ }
+ |
+ {
+ RULES_DEBUG_printf("opt_prefix_sign -> .\n");
+ SEMANTIC(( $<ThisInt>$.Int = 1 ));
+ SEMANTIC(( $<ThisInt>$.Loc = new Location(ThisPlace) ));
+ }
+ ;
+
+one_or_more_term:
+ one_or_more_factor
+ {
+ RULES_DEBUG_printf("one_or_more_term -> one_or_more_factor.\n");
+ SEMANTIC(($<Expr>$ = $<Expr>1));
+ }
+ | one_or_more_term arith_operator one_or_more_factor
+ {
+ RULES_DEBUG_printf("one_or_more_term -> one_or_more_term arith_operator one_or_more_factor.\n");
+ SEMANTIC(( $<Expr>$ = new ArithOperator( $<Expr>1 , $<Expr>3 , $<arith>2 ) ));
+ }
+ ;
+
+one_or_more_factor:
+ factor
+ {
+ RULES_DEBUG_printf("one_or_more_factor -> factor.\n");
+ SEMANTIC(($<Expr>$ = $<Expr>1));
+ }
+ | one_or_more_factor arith_operator2 factor
+ {
+ RULES_DEBUG_printf("one_or_more_factor -> one_or_more_factor arith_operator2 factor.\n");
+ SEMANTIC(( $<Expr>$ = new ArithOperator( $<Expr>1 , $<Expr>3 , $<arith>2 ) ));
+ }
+ ;
+
+arith_operator:
+ PLUS
+ {
+ RULES_DEBUG_printf("arith_operator -> PLUS.\n");
+ SEMANTIC(($<arith>$ = Plus));
+ }
+ | MINUS
+ {
+ RULES_DEBUG_printf("arith_operator -> MINUS.\n");
+ SEMANTIC(($<arith>$ = Minus));
+ }
+ ;
+
+arith_operator2:
+ STAR
+ {
+ RULES_DEBUG_printf("arith_operator2 -> STAR.\n");
+ SEMANTIC(($<arith>$ = Multiply));
+ }
+ | DIVIDE
+ {
+ RULES_DEBUG_printf("arith_operator2 -> DIVIDE.\n");
+ SEMANTIC(($<arith>$ = Divide));
+ }
+ | DIV
+ {
+ RULES_DEBUG_printf("arith_operator2 -> DIV.\n");
+ SEMANTIC(($<arith>$ = IntDivide));
+ }
+ | MOD
+ {
+ RULES_DEBUG_printf("arith_operator2 -> MOD.\n");
+ SEMANTIC(($<arith>$ = Modulo));
+ }
+ ;
+factor: NumberConst
+ {
+ RULES_DEBUG_printf("factor -> NumberConst.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | TEXTCONST
+ {
+ RULES_DEBUG_printf("factor -> TextConst.\n");
+ SEMANTIC(( $<Expr>$ = new StringConstant ( $<ThisString>1.Str,
+ $<ThisString>1.Loc ) ));
+ }
+ | CHARCONST
+ {
+ RULES_DEBUG_printf("factor -> CharConst.\n");
+ SEMANTIC(( $<Expr>$ = new CharConstant( $<ThisChar>1.Str,
+ $<ThisChar>1.Loc ) ));
+ }
+ | BOOLCONST
+ {
+ RULES_DEBUG_printf("factor -> BOOLCONST.\n");
+ SEMANTIC(( $<Expr>$ = new BoolConstant( $<ThisBool>1.Bool,
+ $<ThisBool>1.Loc ) ));
+ }
+ | variable
+ {
+ RULES_DEBUG_printf("factor -> variable.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | object_factor
+ {
+ RULES_DEBUG_printf("factor -> object_factor.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | generator
+ {
+ RULES_DEBUG_printf("factor -> generator.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | expression_in_bracket
+ {
+ RULES_DEBUG_printf("factor -> expression_in_bracket.\n");
+ SEMANTIC(($<Expr>$ = $<Expr>1));
+ }
+ | error
+ {
+ RULES_ERROR_printf(" error : bad factor.\n");
+ SEMANTIC(($<Expr>$ = new Error ));
+ }
+ ;
+
+// Two results possible : an Integer constant if syntaxic string looks like
+// 1000 or 1E3.
+// or a Real constant if it looks like
+// 1.3 1E-3, etc...
+NumberConst: DIGITSEQUENCE opt_Num_const
+ {
+ RULES_DEBUG_printf("NumberConst -> DIGITSEQUENCE opt_Num_const.\n");
+ SEMANTIC(
+ {
+ if ($<ThisReal>2 >= 1)
+ {
+ $<Expr>$ = new IntegerConstant((int)($<ThisInt>1.Int * $<ThisReal>2.Real),
+ new Location(*$<ThisInt>1.Loc + *$<ThisReal>2.Loc));
+ }
+ else
+ {
+ $<Expr>$ = new RealConstant( $<ThisInt>1 * $<ThisReal>2,
+ new Location(*$<ThisInt>1.Loc + *$<ThisReal>2.Loc));
+ }
+ })
+ }
+ | DIGITSEQUENCE POINT DIGITSEQUENCE opt_Num_const
+ {
+ RULES_DEBUG_printf("NumberConst -> DIGITSEQUENCE POINT DIGITSEQUENCE opt_Num_const.\n");
+ SEMANTIC(
+ {
+ double dec = $<ThisInt>3.Int;
+
+ while (dec > 1) dec /= 10;
+ dec += $<ThisInt>1;
+
+ $<Expr>$ = new RealConstant( dec * $<ThisReal>4 );
+ })
+ }
+ | DIGITSEQUENCE POINT opt_Num_const
+ {
+ RULES_DEBUG_printf("NumberConst -> DIGITSEQUENCE POINT opt_Num_const.\n");
+ SEMANTIC(
+ {
+ printf("Valeur numerique : ");
+ $<Expr>$ = new RealConstant( $<ThisInt>1 * $<ThisReal>3 );
+ })
+ }
+ | POINT DIGITSEQUENCE opt_Num_const
+ {
+ RULES_DEBUG_printf("NumberConst -> POINT DIGITSEQUENCE opt_Num_const.\n");
+ SEMANTIC(
+ {
+ double dec = $<ThisInt>2;
+
+ while (dec > 1) dec /= 10;
+
+ $<Expr>$ = new RealConstant( dec * $<ThisReal>3 );
+ })
+ }
+ ;
+
+// The IDENTIFIER must be the E letter for the analyse of an sci notated value
+// ( for example 1E-2 ).
+
+opt_Num_const: IDENTIFIER opt_prefix_sign DIGITSEQUENCE
+ {
+ RULES_DEBUG_printf("opt_Num_const -> IDENTIFIER opt_prefix_sign DIGITSEQUENCE.\n");
+ SEMANTIC(
+ {
+ if ( *$<ThisString>1 == "E" )
+ $<ThisReal>$ = pow( 10 , (double) $<ThisInt>3 * $<ThisInt>2 );
+ else
+ printf("Error : E was expected.\n");
+ })
+ }
+ |
+ {
+ RULES_DEBUG_printf("opt_Num_const -> .\n");
+ SEMANTIC(( $<ThisReal>$ = 1 ));
+ }
+ | IDENTIFIER error
+ {
+ RULES_DEBUG_printf(" error : exponant value expected.\n");
+ SEMANTIC(( $<ThisReal>$ = 1 ));
+ }
+ ;
+
+object_factor: NONE
+ {
+ RULES_DEBUG_printf("object_factor -> NONE.\n");
+ SEMANTIC(( $<Expr>$ = new NoneObject ));
+ }
+ | THIS IDENTIFIER
+ {
+ RULES_DEBUG_printf("object_factor -> THIS IDENTIFIER.\n");
+ SEMANTIC(( $<Expr>$ = new This( new Identifier ($<ThisString>2 ) ) ));
+ }
+ | THIS error
+ { RULES_ERROR_printf(" error : IDENTIFIER expected.\n"); }
+ ;
+
+qualifier_expr: non_prefixed_variable
+ { RULES_DEBUG_printf("qualifier_expr -> non_prefixed_variable.\n"); }
+ | non_prefixed_generator
+ { RULES_DEBUG_printf("qualifier_expr -> non_prefixed_generator.\n"); }
+ ;
+
+opt_qualifier: qualifier_expr opt_qua_list POINT
+ { RULES_DEBUG_printf("opt_qualifier -> qualifier_expr opt_qua_list POINT.\n"); }
+ | THIS IDENTIFIER opt_qua_list POINT
+ { RULES_DEBUG_printf("opt_qualifier -> THIS IDENTIFIER opt_qua_list POINT.\n"); }
+ | THIS error
+ { RULES_DEBUG_printf(" error : IDENTIFIER expected.\n"); }
+ ;
+
+opt_qua_list: opt_qua_list QUA IDENTIFIER
+ { RULES_DEBUG_printf("opt_qua_list -> QUA IDENTIFIER.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_qua_list -> .\n"); }
+ | opt_qua_list QUA error
+ { RULES_ERROR_printf(" error : bad qua list (IDENTIFIER is missing).\n"); }
+ ;
+
+opt_list_qualifier:
+ opt_list_qualifier opt_qualifier
+ { RULES_DEBUG_printf("opt_list_qualifier -> opt_list_qualifier opt_qualifier.\n"); }
+ | opt_qualifier
+ { RULES_DEBUG_printf("opt_list_qualifier -> opt_qualifier.\n"); }
+ ;
+
+variable: opt_list_qualifier non_prefixed_variable
+ {
+ RULES_DEBUG_printf("variable -> opt_list_qualifier non_prefixed_variable.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>2 ));
+ }
+ | non_prefixed_variable
+ {
+ RULES_DEBUG_printf("variable -> non_prefixed_variable.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ ;
+
+non_prefixed_variable: RESULT
+ {
+ RULES_DEBUG_printf("non_prefixed_variable -> RESULT.\n");
+ SEMANTIC(( $<Expr>$ = new Result ));
+ }
+ | identifier_path
+ {
+ RULES_DEBUG_printf("non_prefixed_variable -> identifier_path.\n");
+ SEMANTIC(( $<Expr>$ = new Identifier( $<ThisString>1 ) ));
+ }
+ | identifier_path OPENINGBRACKET one_or_more_expression CLOSINGBRACKET
+ {
+ RULES_DEBUG_printf("non_prefixed_variable -> identifier_path OPENINGBRACKET one_or_more_expression CLOSINGBRACKET.\n");
+ SEMANTIC(( $<Expr>$ = new Identifier( $<ThisString>1 ) ));
+ }
+ ;
+
+one_or_more_expression:
+ expression
+ { RULES_DEBUG_printf("one_or_more_expression -> expression.\n"); }
+ | one_or_more_expression LIST_SEPARATOR expression
+ { RULES_DEBUG_printf("one_or_more_expression -> one_or_more_expression LIST_SEPARATOR expression.\n"); }
+ ;
+
+generator: opt_list_qualifier non_prefixed_generator
+ {
+ RULES_DEBUG_printf("generator -> opt_list_qualifier non_prefixed_generator.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>2 ));
+ }
+ | non_prefixed_generator
+ {
+ RULES_DEBUG_printf("generator -> non_prefixed_generator.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ ;
+
+non_prefixed_generator: NEW identifier_path actual_parameters
+ {
+ RULES_DEBUG_printf(" non_prefixed_generator -> NEW identifier_path actual_paramters.\n");
+ SEMANTIC(( $<Expr>$ = new New( new Identifier( $<ThisString>2 ) ) ));
+ }
+ | NEW ARRAY OPENINGBRACKET expression LIST_SEPARATOR expression CLOSINGBRACKET
+ {
+ RULES_DEBUG_printf("non_prefixed_generator -> NEW ARRAY OPENINGBRACKET expression VARSEPARATOR expression CLOSINGBRACKET");
+ SEMANTIC(( $<Expr>$ = new Error ));
+ }
+ | NEW error
+ { RULES_DEBUG_printf(" error : IDENTIFIER or ARRAY expected.\n"); }
+ | NEW ARRAY error
+ { RULES_DEBUG_printf(" error : syntax error in array definition.\n"); }
+ ;
+
+actual_parameters:
+ | OPENINGBRACKET actual_parameters_list CLOSINGBRACKET
+ { RULES_DEBUG_printf(" actual_parameters -> OPENINGBRACKET actual_parameters_list CLOSINGBRACKET.\n"); }
+ ;
+
+actual_parameters_list:
+ actual_parameter
+ { RULES_DEBUG_printf("actual_paramters_list -> actual_parameter.\n"); }
+ | actual_parameters_list LIST_SEPARATOR actual_parameter
+ { RULES_DEBUG_printf("actual_parameters_list -> actual_parameters_list LIST_SEPARATOR actual_parameter.\n"); }
+ ;
+
+actual_parameter:
+ expression
+ { RULES_DEBUG_printf("actual_parameter -> expression.\n"); }
+ | predefinedtype
+ { RULES_DEBUG_printf("actual_parameter -> predefinedtype.\n"); }
+ ;
+
+affectation_instruction:
+ l_identifiers_list AFFECTATION r_value
+ {
+ RULES_DEBUG_printf("affectation_instruction -> l_identifiers_list AFFECTATION r_value.\n");
+ SEMANTIC(( $<Instr>$ = new Affectation( $<Expr>1 , $<Expr>3 ) ));
+ }
+ | l_identifiers_list error r_value
+ {
+ RULES_ERROR_printf("error : ':=' expected.\n");
+ SEMANTIC(( $<Instr>$ = new Affectation( $<Expr>1 , $<Expr>3 ) ));
+ }
+ ;
+
+//** Warning !!! Theses actions are to be replaced by something right
+//** It's just Test Code .
+
+l_identifiers_list: variable
+ {
+ RULES_DEBUG_printf("l_identifiers_list -> variable.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | l_identifiers_list LIST_SEPARATOR variable
+ {
+ RULES_DEBUG_printf("l_identifiers_list -> l_identifiers_list LIST_SEPARATOR variable.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>3 ));
+ }
+ ;
+
+r_value: expression
+ {
+ RULES_DEBUG_printf("r_value -> expression .\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+ | COPY expression_in_bracket
+ {
+ RULES_DEBUG_printf("r_value -> COPY expression_in_bracket .\n");
+ SEMANTIC(( $<Expr>$ = new Copy( $<Expr>2 ) ));
+ }
+ ;
+
+job_instruction:
+ parameter_job_instruction OPENINGBRACKET expression CLOSINGBRACKET
+ {
+ RULES_DEBUG_printf("job_instruction -> parameter_job_instruction ( expression ).\n");
+ SEMANTIC(
+ {
+ switch($<ThisArgJob>1)
+ {
+ case AttachInstr:
+ $<Instr>$ = new Attach( $<Expr>3 );
+ break;
+ case ResumeInstr:
+ $<Instr>$ = new Resume( $<Expr>3 );
+ break;
+ case StopInstr:
+ $<Instr>$ = new Stop( $<Expr>3 );
+ break;
+ }
+ });
+ }
+ | DETACH
+ {
+ RULES_DEBUG_printf("job_instruction -> DETACH.\n");
+ SEMANTIC(( $<Instr>$ = new Detach ));
+ }
+ | STOP
+ {
+ RULES_DEBUG_printf("job_instruction -> STOP.\n");
+ SEMANTIC(( $<Instr>$ = new Stop ));
+ }
+ | TERMINATE
+ {
+ RULES_DEBUG_printf("job_instruction -> TERMINATE.\n");
+ SEMANTIC(( $<Instr>$ = new Terminate ));
+ }
+ ;
+
+parameter_job_instruction:
+ ATTACH
+ {
+ RULES_DEBUG_printf("parameter_job_instruction -> ATTACH.\n");
+ SEMANTIC(( $<ThisArgJob>$ = AttachInstr ));
+ }
+ | RESUME
+ {
+ RULES_DEBUG_printf("parameter_job_instruction -> RESUME.\n");
+ SEMANTIC(( $<ThisArgJob>$ = ResumeInstr ));
+ }
+ | STOP
+ {
+ RULES_DEBUG_printf("parameter_job_instruction -> STOP.\n");
+ SEMANTIC(( $<ThisArgJob>$ = StopInstr ));
+ }
+ ;
+
+io_instruction:
+ file_io_instruction
+ { RULES_DEBUG_printf("io_instruction -> file_io_instruction .\n"); }
+ | input_instruction
+ { RULES_DEBUG_printf("io_instruction -> input_instruction .\n"); }
+ | output_instruction
+ { RULES_DEBUG_printf("io_instruction -> output_instruction .\n"); }
+ ;
+
+file_io_instruction:
+ file_io_keyword OPENINGBRACKET expression LIST_SEPARATOR one_or_more_expression CLOSINGBRACKET
+ { RULES_DEBUG_printf("file_io_instruction -> file_io_keyword ( expression LIST_SEPARATOR one_or_more_expression ).\n"); }
+ ;
+
+file_io_keyword:
+ PUT
+ { RULES_DEBUG_printf("file_io_keyword -> PUT.\n"); }
+ | GET
+ { RULES_DEBUG_printf("file_io_keyword -> GET.\n"); }
+ ;
+
+input_instruction:
+ input_keyword OPENINGBRACKET l_identifiers_list CLOSINGBRACKET
+ { RULES_DEBUG_printf("input_instruction -> input_keyword ( l_identifiers_list ).\n"); }
+ | READLN
+ { RULES_DEBUG_printf("input_instruction -> READLN.\n"); }
+ ;
+
+input_keyword:
+ READ
+ { RULES_DEBUG_printf("input_keyword -> READ.\n"); }
+ | READLN
+ { RULES_DEBUG_printf("input_keyword -> READLN.\n"); }
+ ;
+
+output_instruction:
+ output_keyword OPENINGBRACKET l_formated_identifiers_list CLOSINGBRACKET
+ { RULES_DEBUG_printf("output_instructions -> output_keyword ( l_formated_identifiers_list ).\n"); }
+ | WRITELN
+ { RULES_DEBUG_printf("output_instructions -> WRITELN.\n"); }
+ ;
+
+output_keyword:
+ WRITE
+ { RULES_DEBUG_printf("output_keyword -> WRITE.\n"); }
+ | WRITELN
+ { RULES_DEBUG_printf("output_keyword -> WRITELN.\n"); }
+ ;
+
+l_formated_identifiers_list:
+ expression opt_modifiers
+ { RULES_DEBUG_printf("l_formatted_identifiers_list -> expression opt_modifiers.\n"); }
+ | l_formated_identifiers_list LIST_SEPARATOR expression opt_modifiers
+ { RULES_DEBUG_printf("l_formatted_identifiers_list -> l_formated_identifiers_list LIST_SEPARATOR expression opt_modifiers.\n"); }
+ ;
+
+opt_modifiers: VARSEPARATOR NumberConst opt_modifiers2
+ { RULES_DEBUG_printf(" opt_modifiers -> VARSEPARATOR NumberConst opt_modifiers2.\n");}
+ |
+ { RULES_DEBUG_printf(" opt_modifiers -> .\n");}
+ ;
+opt_modifiers2: VARSEPARATOR NumberConst
+ { RULES_DEBUG_printf(" opt_modifiers2 -> VARSEPARATOR NumberConst.\n");}
+ |
+ { RULES_DEBUG_printf(" opt_modifiers2 -> .\n");}
+ ;
+
+signal_instruction:
+ RAISE IDENTIFIER actual_parameters
+ { RULES_DEBUG_printf("signal_instruction -> RAISE IDENTIFIER actual_parameters.\n"); }
+ ;
+
+array_instruction:
+ ARRAY variable DIM OPENINGBRACKET expression VARSEPARATOR expression CLOSINGBRACKET
+ { RULES_DEBUG_printf("array_instruction -> ARRAY variable DIM OPENINGBRACKET expression VARSEPARATOR expression CLOSINGBRACKET.\n"); }
+ ;
+
+exit_instruction:
+ exit_list opt_repeat
+ { RULES_DEBUG_printf("exit_instruction -> opt_exit_list opt_repeat.\n");}
+ | REPEAT
+ { RULES_DEBUG_printf("exit_instruction -> REPEAT.\n");}
+ ;
+exit_list: exit_list EXIT
+ { RULES_DEBUG_printf("opt_exit_list -> opt_exit_list EXIT.\n");}
+ | EXIT
+ { RULES_DEBUG_printf("opt_exit_list -> EXIT .\n");}
+ ;
+
+opt_repeat: REPEAT
+ { RULES_DEBUG_printf("opt_repeat -> REPEAT.\n");}
+ |
+ { RULES_DEBUG_printf("opt_repeat -> .\n");}
+ ;
+
+loop_instruction:
+ WHILE expression loop_body
+ {
+ RULES_DEBUG_printf("loop_header -> WHILE expression loop_body.\n");
+ SEMANTIC(( $<Instr>$ = new While( $<Expr>2, $<ThisBlock>3 ) ));
+ }
+ | FOR variable AFFECTATION expression DOWNTO expression loop_body
+ {
+ RULES_DEBUG_printf("loop_header -> FOR variable AFFECTATION expression DOWNTO expression loop_body.\n");
+ SEMANTIC(( $<Instr>$ = new For( $<Expr>2,
+ $<Expr>4, $<Expr>6,
+ new IntegerConstant( -1 ),
+ $<ThisBlock>7 ) ));
+ }
+ | FOR variable AFFECTATION expression TO expression loop_body
+ {
+ RULES_DEBUG_printf("loop_header -> FOR variable AFFECTATION expression TO expression loop_body.\n");
+ SEMANTIC(( $<Instr>$ = new For( $<Expr>2,
+ $<Expr>4, $<Expr>6,
+ new IntegerConstant( 1 ),
+ $<ThisBlock>7 ) ));
+ }
+ | FOR variable AFFECTATION expression TO expression STEP expression loop_body
+ {
+ RULES_DEBUG_printf("loop_header -> FOR variable AFFECTATION expression TO expression STEP expression loop_body.\n");
+ SEMANTIC(( $<Instr>$ = new For( $<Expr>2,
+ $<Expr>4, $<Expr>6,
+ $<Expr>8,
+ $<ThisBlock>9 ) ));
+ }
+ ;
+
+loop_body:
+ DO opt_instructions OD
+ {
+ RULES_DEBUG_printf("loop_body -> DO opt_instructions OD.\n");
+ SEMANTIC(( $<ThisBlock>$ = $<ThisBlock>2 ));
+ }
+ | DO opt_instructions error
+ {
+ RULES_ERROR_printf("error OD expected.\n");
+ SEMANTIC(( $<ThisBlock>$ = NULL ));
+ }
+ ;
+
+condition_instruction:
+ IF short_or_and_list THEN opt_instructions opt_else FI
+ {
+ RULES_DEBUG_printf("condition_instruction -> IF short_or_and_list THEN opt_instructions opt_else FI.\n");
+ SEMANTIC(( $<Instr>$ = new ConditionIf( $<Expr>2, $<ThisBlock>4, $<ThisBlock>5 ) ));
+ }
+ | IF short_or_and_list error
+ { RULES_ERROR_printf("error : THEN expected.\n"); }
+ | IF short_or_and_list THEN opt_instructions opt_else error
+ { RULES_ERROR_printf("error : FI or ELSE expected.\n"); }
+ ;
+
+short_or_and_list: expression
+ {
+ RULES_DEBUG_printf("short_or_and_list -> expression.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>1 ));
+ }
+// The two next rules are wrong because ORIF and ANDIF are supposed to have
+// the same priority. This has to be fixed.
+ | short_or_and_list ORIF expression
+ {
+ RULES_DEBUG_printf("short_or_and_list -> short_or_and_list ORIF expression.\n");
+ SEMANTIC(( $<Expr>$ = new BoolOperator( $<Expr>1, $<Expr>3, Or ) ));
+ }
+ | short_or_and_list ANDIF expression
+ {
+ RULES_DEBUG_printf("short_or_and_list -> short_or_and_list ANDIF expression.\n");
+ SEMANTIC(( $<Expr>$ = new BoolOperator( $<Expr>1, $<Expr>3, And ) ));
+ }
+ ;
+
+opt_else: ELSE opt_instructions
+ {
+ RULES_DEBUG_printf("opt_else -> ELSE opt_instructions. \n");
+ SEMANTIC(( $<ThisBlock>$ = $<ThisBlock>2 ));
+ }
+ |
+ {
+ RULES_DEBUG_printf("opt_else -> . \n");
+ SEMANTIC(( $<ThisBlock>$ = NULL ));
+ }
+ ;
+
+case_instruction:
+ CASE expression case_when_list opt_case_otherwise ESAC
+ { RULES_DEBUG_printf("case_instruction -> CASE expression case_when_list opt_case_otherwise ESAC.\n"); }
+ ;
+
+opt_case_otherwise:
+ OTHERWISE opt_instructions
+ { RULES_DEBUG_printf("opt_case_otherwise -> OTHERWISE opt_instructions.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_case_otherwise -> .\n"); }
+ ;
+
+case_when_list:
+ one_when_case
+ { RULES_DEBUG_printf("case_when_list -> one_when_case.\n"); }
+ | case_when_list one_when_case
+ { RULES_DEBUG_printf("case_when_list -> case_when_list one_when_case.\n"); }
+ ;
+
+one_when_case: WHEN expression VARSEPARATOR opt_instructions
+ { RULES_DEBUG_printf("one_when_case -> WHEN expression VARSEPARATOR opt_instructions.\n"); }
+ ;
+
+object_instruction:
+ WIND
+ { RULES_DEBUG_printf("object_instruction -> WIND.\n"); }
+ | INNER
+ { RULES_DEBUG_printf("object_instruction -> INNER.\n"); }
+ | KILL expression_in_bracket
+ { RULES_DEBUG_printf("object_instruction -> KILL expression_in_bracket.\n"); }
+ | generator
+ { RULES_DEBUG_printf("object_instruction -> generator.\n"); }
+ ;
+
+block_instruction:
+ PREF IDENTIFIER actual_parameters BLOCK opt_block_taken module_body endsentence
+ { RULES_DEBUG_printf("block_instruction -> PREF IDENTIFIER actual_parameters BLOCK opt_block_taken module_body endsentence.\n"); }
+ ;
+
+opt_block_taken:
+ TAKEN identifier_list endsentence
+ { RULES_DEBUG_printf("opt_block_taken -> TAKEN identifier_list endsentence.\n"); }
+ |
+ { RULES_DEBUG_printf("opt_block_taken -> .\n"); }
+ ;
+expression_in_bracket:
+ OPENINGBRACKET expression CLOSINGBRACKET
+ {
+ RULES_DEBUG_printf("expression_in_bracket -> OPENINGBRACKET expression CLOSINGBRACKET.\n");
+ SEMANTIC(( $<Expr>$ = $<Expr>2 ));
+ }
+ | OPENINGBRACKET expression error
+ { RULES_ERROR_printf("error : unbalanced bracket. \n"); }
+ ;
+
+endprogram: ENDSENTENCE
+ { RULES_DEBUG_printf("endprogram -> ENDSENTENCE.\n"); }
+ | POINT
+ { RULES_DEBUG_printf("endprogram -> POINT.\n"); }
+ | error
+ { RULES_ERROR_printf("error : ';' or '.' expected.\n"); }
+ ;
+%%
+void initialize( void )
+{
+ BeginningOfLine = 1;
+}
+
+main()
+{
+ yyparse();
+}
+
+int yyerror( void )
+{
+ printf("Syntax error at line %d.\n",line_number);
+ return 0;
+}
+
+int yyerror( char *s )
+{
+ printf("%s",s);
+ return 0;
+}
--- /dev/null
+PROGRAM TEST;
+
+(* This is only a test program *)
+
+UNIT VIRTUAL A: SHARED C, SHARED D : K : Z ,E CLASS;
+
+ UNIT K: D PROCEDURE(INPUT H : CHAR; INOUT P : PROC ) ;
+ END K;
+
+ UNIT L : D FUNCTION( A,B: INTEGER; OUTPUT P : RESULTAT ):INTEGER;
+ END L;
+
+ UNIT WEEK : ENUM(Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday);
+ END WEEK;
+
+END;
+
+CONST A=A QUA B . D + C / A * ( B AND (K+C = KAN)) OR (123 + 234.34 + 256E-5 < 1);
+VAR H,K,L,LIOP : INET,
+ A,C,E : INTEGER,
+ BRK,RCS : OBJ;
+
+SIGNAL SIG(A:K; FUNCTION B : RESULTAT;);
+
+HANDLERS
+ WHEN I : A := B;
+ WHEN N : K QUA C QUA G. C := F;
+ OTHERWISE : Q := COPY(A);
+END HANDLERS;
+BEGIN
+ A := R QUA C .A QUA B .D;
+ A := "ABCD";
+ STOP;
+ WHILE A
+ DO
+ IF B <> 6 THEN
+ IF K =/= 5 THEN
+ ARRAY A DIM (1:6);
+ ELSE
+ A := NEW ARRAY(1,6);
+ FI
+ FI
+ OD
+END;
--- /dev/null
+PROGRAM A;
+ UNIT B:PROCEDURE;
+ END B;
+
+CONST I = A QUA;
+BEGIN
+END A;
--- /dev/null
+PROGRAM ID;
+BEGIN
+FOR I := 1 TO 2
+DO
+A := A + 1;
+OD
+END A;
--- /dev/null
+PROGRAM Test3;
+BEGIN
+ A := A AND 1 + 4 = 5;
+END;
--- /dev/null
+program test4;
+
+Begin
+ Read(A);
+eND;
--- /dev/null
+#include <String.h>
+#include <iostream.h>
+#include "Objects.h"
+#include "Expr.h"
+
+Location ThisPlace(1,2,4,5);
+
+main()
+{
+
+// Test : building the expression 'A := B + ( 1 * 4 );'
+
+ Expression *TheExpr;
+
+ TheExpr = new Affectation( new Identifier( new String("A")),
+ new ArithOperator( new Identifier( new String("B")),
+ new ArithOperator( new IntegerConstant(1), new IntegerConstant(4), IntegerExpr, Multiply ),
+ IntegerExpr, Plus ),
+ Instruction );
+
+ cout << "The Expr is : \n";
+ TheExpr->Print( cout );
+ cout << '\n';
+
+}
--- /dev/null
+/**********************************
+ * test of the location class *
+ **********************************/
+
+#include <iostream.h>
+#include "Objects.h"
+
+Location a,*b,c(4,4,6,8);
+
+main()
+{
+ cout << "Location of a " << a << ".\n" << "Location of c " << c << ".\n";
+ b = new Location ( 5,5 );
+ cout << "After creation, Location of b is " << *b << ".\n";
+ b->SetEnd(9,2);
+ cout << "After modification, Location of b is " << *b << ".\n";
+ a.Move(15,3);
+ a.Tab( 40 );
+ cout << "After modification of A , and tabbing, Location of a is " << a << ".\n";
+ a.Cr();
+ cout << "Then Location of a is after Cr :"<< a << ".\n";
+ a.Select( 15 );
+ cout << "Location of a after Select(15) is " << a << ".\n";
+ a.Select( 2 );
+ cout << "Location of a after Select(15) is " << a << ".\n";
+ cout << "After all of this the location of a + c is " << (a + c) << ".\n";
+}
--- /dev/null
+#include <iostream.h>
+#include <String.h>
+#include "SymTable.h"
+
+symboltable *table = new symboltable;
+
+main()
+{
+
+ node* temp1;
+ entry* temp;
+ entry* temp0;
+ node* temp2;
+ struct find_result* temp3;
+ String t = "t", a = "a",
+ x = "x", y = "y",
+ u = "u", v = "v",
+ z = "z", b = "b",
+ o = "o";
+
+//temp=table->insert(t,VARIABLE_S,new v_variable);
+temp0=table->insert(a,CLASS_S,new c_class);
+temp3=table->find(a);
+cout << "test 1 " << temp3->found->id << '\n';
+
+temp1=table->last->open_unit();
+table->last->add_spec(CLOSE,x);
+table->last->add_spec(CLOSE,y);
+table->last->add_spec(HIDDEN,t);
+table->last->add_spec(HIDDEN,u);
+table->last->add_spec(CLOSE,t);
+table->last->add_virt(temp0);
+
+temp=table->insert(x,VARIABLE_S,new v_variable);
+temp=table->insert(t,VARIABLE_S,new v_variable);
+temp=table->insert(u,VARIABLE_S,new v_variable);
+temp=table->insert(z,VARIABLE_S,new v_variable);
+temp=table->insert(y,VARIABLE_S,new v_variable);
+
+
+temp3=table->find_in_module(temp1,y,NOT_DOT);
+cout << "test " << temp3->found->id << '\n';
+temp3=temp1->local_find(x,ALL);
+cout << "test " << temp3->found->id << '\n';
+temp3=table->find(u);
+cout << "test " << temp3->found->id << '\n';
+table->last->close_unit();
+
+temp3=table->find(a);
+cout << "test " << temp3->found->id << '\n';
+
+temp0=table->insert(b,CLASS_S,new c_class);
+temp1=table->last->open_unit();
+
+temp3=table->find(a);
+cout << "test 2 " << temp3->found->id << 'n';
+
+temp0=table->inherit(a);
+
+temp3=table->find(o);
+if (temp3->found == NULL) cout << "o nie jest widoczy \n";
+
+temp3=table->find_in_module(temp1,t,NOT_DOT);
+if (temp3->found == NULL) cout << "t nie jest widoczy z zewnatrz\n";
+
+temp3=table->find_in_module(temp1,t,TRUE);
+if (temp3->found == NULL) cout << "t nie jest widoczy przez kropke\n";
+
+temp3=table->find_in_module(temp1,x,TRUE);
+if (temp3->found == NULL) cout << "x nie jest widoczy \n";
+
+temp3=table->find(a);
+cout << "test " << temp3->found->id << '\n';
+
+
+}
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Put strings representing decimal floating-point numbers
+ * into canonical form: always have a decimal point or
+ * exponent field; if using an exponent field, have the
+ * number before it start with a digit and decimal point
+ * (if the number has more than one digit); only have an
+ * exponent field if it saves space.
+ *
+ * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' .
+ */
+
+#include <stdio.h>
+
+ extern char *Alloc(), *mem(), *strcpy();
+
+ char *
+cds(s, z0)
+ char *s, *z0;
+{
+ int ea, esign, et, i, k, nd = 0, sign = 0, tz;
+ char c, *z;
+ char ebuf[24];
+ long ex = 0;
+ static char etype[256], *db;
+ static int dblen = 64;
+
+ if (!db) {
+ etype['E'] = 1;
+ etype['e'] = 1;
+ etype['D'] = 1;
+ etype['d'] = 1;
+ etype['+'] = 2;
+ etype['-'] = 3;
+ db = Alloc(dblen);
+ }
+
+ while((c = *s++) == '0');
+ if (c == '-')
+ { sign = 1; c = *s++; }
+ else if (c == '+')
+ c = *s++;
+ k = strlen(s) + 2;
+ if (k >= dblen) {
+ do dblen <<= 1;
+ while(k >= dblen);
+ free(db);
+ db = Alloc(dblen);
+ }
+ if (etype[(unsigned char)c] >= 2)
+ while(c == '0') c = *s++;
+ tz = 0;
+ while(c >= '0' && c <= '9') {
+ if (c == '0')
+ tz++;
+ else {
+ if (nd)
+ for(; tz; --tz)
+ db[nd++] = '0';
+ else
+ tz = 0;
+ db[nd++] = c;
+ }
+ c = *s++;
+ }
+ ea = -tz;
+ if (c == '.') {
+ while((c = *s++) >= '0' && c <= '9') {
+ if (c == '0')
+ tz++;
+ else {
+ if (tz) {
+ ea += tz;
+ if (nd)
+ for(; tz; --tz)
+ db[nd++] = '0';
+ else
+ tz = 0;
+ }
+ db[nd++] = c;
+ ea++;
+ }
+ }
+ }
+ if (et = etype[(unsigned char)c]) {
+ esign = et == 3;
+ c = *s++;
+ if (et == 1) {
+ if(etype[(unsigned char)c] > 1) {
+ if (c == '-')
+ esign = 1;
+ c = *s++;
+ }
+ }
+ while(c >= '0' && c <= '9') {
+ ex = 10*ex + (c - '0');
+ c = *s++;
+ }
+ if (esign)
+ ex = -ex;
+ }
+ /* debug */ if (c)
+ /* debug*/ Fatal("unexpected character in cds");
+ ex -= ea;
+ if (!nd) {
+ if (!z0)
+ z0 = mem(4,0);
+ strcpy(z0, "-0.");
+ sign = 0;
+ }
+ else if (ex > 2 || ex + nd < -2) {
+ sprintf(ebuf, "%ld", ex + nd - 1);
+ k = strlen(ebuf) + nd + 3;
+ if (nd > 1)
+ k++;
+ if (!z0)
+ z0 = mem(k,0);
+ z = z0;
+ *z++ = '-';
+ *z++ = *db;
+ if (nd > 1) {
+ *z++ = '.';
+ for(k = 1; k < nd; k++)
+ *z++ = db[k];
+ }
+ *z++ = 'e';
+ strcpy(z, ebuf);
+ }
+ else {
+ k = (int)(ex + nd);
+ i = nd + 3;
+ if (k < 0)
+ i -= k;
+ else if (ex > 0)
+ i += ex;
+ if (!z0)
+ z0 = mem(i,0);
+ z = z0;
+ *z++ = '-';
+ if (ex >= 0) {
+ for(k = 0; k < nd; k++)
+ *z++ = db[k];
+ while(--ex >= 0)
+ *z++ = '0';
+ *z++ = '.';
+ }
+ else {
+ for(i = 0; i < k;)
+ *z++ = db[i++];
+ *z++ = '.';
+ while(++k <= 0)
+ *z++ = '0';
+ while(i < nd)
+ *z++ = db[i++];
+ }
+ *z = 0;
+ }
+ return sign ? z0 : z0+1;
+ }
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
+
+static char datafmt[] = "%s\t%09ld\t%d" ;
+
+/* another initializer, called from parser */
+dataval(repp, valp)
+register expptr repp, valp;
+{
+ int i, nrep;
+ ftnint elen;
+ register Addrp p;
+ Addrp nextdata();
+
+ if (parstate < INDATA) {
+ frexpr(repp);
+ goto ret;
+ }
+ if(repp == NULL)
+ nrep = 1;
+ else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
+ nrep = repp->constblock.Const.ci;
+ else
+ {
+ err("invalid repetition count in DATA statement");
+ frexpr(repp);
+ goto ret;
+ }
+ frexpr(repp);
+
+ if( ! ISCONST(valp) )
+ {
+ err("non-constant initializer");
+ goto ret;
+ }
+
+ if(toomanyinit) goto ret;
+ for(i = 0 ; i < nrep ; ++i)
+ {
+ p = nextdata(&elen);
+ if(p == NULL)
+ {
+ err("too many initializers");
+ toomanyinit = YES;
+ goto ret;
+ }
+ setdata((Addrp)p, (Constp)valp, elen);
+ frexpr((expptr)p);
+ }
+
+ret:
+ frexpr(valp);
+}
+
+
+Addrp nextdata(elenp)
+ftnint *elenp;
+{
+ register struct Impldoblock *ip;
+ struct Primblock *pp;
+ register Namep np;
+ register struct Rplblock *rp;
+ tagptr p;
+ expptr neltp;
+ register expptr q;
+ int skip;
+ ftnint off, vlen;
+
+ while(curdtp)
+ {
+ p = (tagptr)curdtp->datap;
+ if(p->tag == TIMPLDO)
+ {
+ ip = &(p->impldoblock);
+ if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
+ fatali("bad impldoblock 0%o", (int) ip);
+ if(ip->isactive)
+ ip->varvp->Const.ci += ip->impdiff;
+ else
+ {
+ q = fixtype(cpexpr(ip->implb));
+ if( ! ISICON(q) )
+ goto doerr;
+ ip->varvp = (Constp) q;
+
+ if(ip->impstep)
+ {
+ q = fixtype(cpexpr(ip->impstep));
+ if( ! ISICON(q) )
+ goto doerr;
+ ip->impdiff = q->constblock.Const.ci;
+ frexpr(q);
+ }
+ else
+ ip->impdiff = 1;
+
+ q = fixtype(cpexpr(ip->impub));
+ if(! ISICON(q))
+ goto doerr;
+ ip->implim = q->constblock.Const.ci;
+ frexpr(q);
+
+ ip->isactive = YES;
+ rp = ALLOC(Rplblock);
+ rp->rplnextp = rpllist;
+ rpllist = rp;
+ rp->rplnp = ip->varnp;
+ rp->rplvp = (expptr) (ip->varvp);
+ rp->rpltag = TCONST;
+ }
+
+ if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
+ || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
+ { /* start new loop */
+ curdtp = ip->datalist;
+ goto next;
+ }
+
+ /* clean up loop */
+
+ if(rpllist)
+ {
+ rp = rpllist;
+ rpllist = rpllist->rplnextp;
+ free( (charptr) rp);
+ }
+ else
+ Fatal("rpllist empty");
+
+ frexpr((expptr)ip->varvp);
+ ip->isactive = NO;
+ curdtp = curdtp->nextp;
+ goto next;
+ }
+
+ pp = (struct Primblock *) p;
+ np = pp->namep;
+ skip = YES;
+
+ if(p->primblock.argsp==NULL && np->vdim!=NULL)
+ { /* array initialization */
+ q = (expptr) mkaddr(np);
+ off = typesize[np->vtype] * curdtelt;
+ if(np->vtype == TYCHAR)
+ off *= np->vleng->constblock.Const.ci;
+ q->addrblock.memoffset =
+ mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
+ if( (neltp = np->vdim->nelt) && ISCONST(neltp))
+ {
+ if(++curdtelt < neltp->constblock.Const.ci)
+ skip = NO;
+ }
+ else
+ err("attempt to initialize adjustable array");
+ }
+ else
+ q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
+ if(skip)
+ {
+ curdtp = curdtp->nextp;
+ curdtelt = 0;
+ }
+ if(q->headblock.vtype == TYCHAR)
+ if(ISICON(q->headblock.vleng))
+ *elenp = q->headblock.vleng->constblock.Const.ci;
+ else {
+ err("initialization of string of nonconstant length");
+ continue;
+ }
+ else *elenp = typesize[q->headblock.vtype];
+
+ if (np->vstg == STGBSS) {
+ vlen = np->vtype==TYCHAR
+ ? np->vleng->constblock.Const.ci
+ : typesize[np->vtype];
+ if(vlen > 0)
+ np->vstg = STGINIT;
+ }
+ return( (Addrp) q );
+
+doerr:
+ err("nonconstant implied DO parameter");
+ frexpr(q);
+ curdtp = curdtp->nextp;
+
+next:
+ curdtelt = 0;
+ }
+
+ return(NULL);
+}
+
+
+
+LOCAL FILEP dfile;
+
+
+setdata(varp, valp, elen)
+register Addrp varp;
+ftnint elen;
+register Constp valp;
+{
+ struct Constblock con;
+ register int type;
+ int i, k, valtype;
+ ftnint offset;
+ char *dataname(), *varname;
+ static Addrp badvar;
+
+ if (varp->vstg == STGCOMMON) {
+ if (!(dfile = blkdfile))
+ dfile = blkdfile = opf(blkdfname, textwrite);
+ }
+ else {
+ if (procclass == CLBLOCK) {
+ if (varp != badvar) {
+ badvar = varp;
+ warn1("%s is not in a COMMON block",
+ varp->uname_tag == UNAM_NAME
+ ? varp->user.name->fvarname
+ : "???");
+ }
+ return;
+ }
+ if (!(dfile = initfile))
+ dfile = initfile = opf(initfname, textwrite);
+ }
+ varname = dataname(varp->vstg, varp->memno);
+ offset = varp->memoffset->constblock.Const.ci;
+ type = varp->vtype;
+ valtype = valp->vtype;
+ if(type!=TYCHAR && valtype==TYCHAR)
+ {
+ if(! ftn66flag)
+ warn("non-character datum initialized with character string");
+ varp->vleng = ICON(typesize[type]);
+ varp->vtype = type = TYCHAR;
+ }
+ else if( (type==TYCHAR && valtype!=TYCHAR) ||
+ (cktype(OPASSIGN,type,valtype) == TYERROR) )
+ {
+ err("incompatible types in initialization");
+ return;
+ }
+ if(type == TYADDR)
+ con.Const.ci = valp->Const.ci;
+ else if(type != TYCHAR)
+ {
+ if(valtype == TYUNKNOWN)
+ con.Const.ci = valp->Const.ci;
+ else consconv(type, &con, valp);
+ }
+
+ k = 1;
+
+ switch(type)
+ {
+ case TYLOGICAL:
+ if (tylogical != TYLONG)
+ type = tylogical;
+ case TYSHORT:
+ case TYLONG:
+ dataline(varname, offset, type);
+ prconi(dfile, con.Const.ci);
+ break;
+
+ case TYADDR:
+ dataline(varname, offset, type);
+ prcona(dfile, con.Const.ci);
+ break;
+
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ k = 2;
+ case TYREAL:
+ case TYDREAL:
+ dataline(varname, offset, type);
+ prconr(dfile, &con, k);
+ break;
+
+ case TYCHAR:
+ k = valp -> vleng -> constblock.Const.ci;
+ if (elen < k)
+ k = elen;
+ for(i = 0 ; i < k ; ++i) {
+ dataline(varname, offset++, TYCHAR);
+ fprintf(dfile, "\t%d\n",
+ valp->Const.ccp[i]);
+ }
+ k = elen - valp->vleng->constblock.Const.ci;
+ if(k > 0) {
+ dataline(varname, offset, TYBLANK);
+ fprintf(dfile, "\t%d\n", k);
+ }
+ break;
+
+ default:
+ badtype("setdata", type);
+ }
+
+}
+
+
+
+/*
+ output form of name is padded with blanks and preceded
+ with a storage class digit
+*/
+char *dataname(stg,memno)
+ int stg;
+ long memno;
+{
+ static char varname[64];
+ register char *s, *t;
+ char buf[16], *memname();
+
+ if (stg == STGCOMMON) {
+ varname[0] = '2';
+ sprintf(s = buf, "Q.%ld", memno);
+ }
+ else {
+ varname[0] = stg==STGEQUIV ? '1' : '0';
+ s = memname(stg, memno);
+ }
+ t = varname + 1;
+ while(*t++ = *s++);
+ *t = 0;
+ return(varname);
+}
+
+
+
+
+
+frdata(p0)
+chainp p0;
+{
+ register struct Chain *p;
+ register tagptr q;
+
+ for(p = p0 ; p ; p = p->nextp)
+ {
+ q = (tagptr)p->datap;
+ if(q->tag == TIMPLDO)
+ {
+ if(q->impldoblock.isbusy)
+ return; /* circular chain completed */
+ q->impldoblock.isbusy = YES;
+ frdata(q->impldoblock.datalist);
+ free( (charptr) q);
+ }
+ else
+ frexpr(q);
+ }
+
+ frchain( &p0);
+}
+
+
+
+dataline(varname, offset, type)
+char *varname;
+ftnint offset;
+int type;
+{
+ fprintf(dfile, datafmt, varname, offset, type);
+}
+
+ void
+make_param(p, e)
+ register struct Paramblock *p;
+ expptr e;
+{
+ p->vclass = CLPARAM;
+ impldcl((Namep)p);
+ p->paramval = mkconv(p->vtype, e);
+ }
--- /dev/null
+#define PDP11 4
+
+#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */
+#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */
+
+#define M(x) (1<<x) /* Mask (x) returns 2^x */
+
+#define ALLOC(x) (struct x *) ckalloc(sizeof(struct x))
+#define ALLEXPR (expptr) ckalloc( sizeof(union Expression) )
+typedef int *ptr;
+typedef char *charptr;
+typedef FILE *FILEP;
+typedef int flag;
+typedef char field; /* actually need only 4 bits */
+typedef long int ftnint;
+#define LOCAL static
+
+#define NO 0
+#define YES 1
+
+#define CNULL (char *) 0 /* Character string null */
+#define PNULL (ptr) 0
+#define CHNULL (chainp) 0 /* Chain null */
+#define ENULL (expptr) 0
+
+
+/* BAD_MEMNO - used to distinguish between long string constants and other
+ constants in the table */
+
+#define BAD_MEMNO -32768
+
+
+/* block tag values -- syntactic stuff */
+
+#define TNAME 1
+#define TCONST 2
+#define TEXPR 3
+#define TADDR 4
+#define TPRIM 5 /* Primitive datum - should not appear in an
+ expptr variable, it should have already been
+ identified */
+#define TLIST 6
+#define TIMPLDO 7
+#define TERROR 8
+
+
+/* parser states - order is important, since there are several tests for
+ state < INDATA */
+
+#define OUTSIDE 0
+#define INSIDE 1
+#define INDCL 2
+#define INDATA 3
+#define INEXEC 4
+
+/* procedure classes */
+
+#define PROCMAIN 1
+#define PROCBLOCK 2
+#define PROCSUBR 3
+#define PROCFUNCT 4
+
+
+/* storage classes -- vstg values. BSS and INIT are used in the later
+ merge pass over identifiers; and they are entered differently into the
+ symbol table */
+
+#define STGUNKNOWN 0
+#define STGARG 1 /* adjustable dimensions */
+#define STGAUTO 2 /* for stack references */
+#define STGBSS 3 /* uninitialized storage (normal variables) */
+#define STGINIT 4 /* initialized storage */
+#define STGCONST 5
+#define STGEXT 6 /* external storage */
+#define STGINTR 7 /* intrinsic (late decision) reference. See
+ chapter 5 of the Fortran 77 standard */
+#define STGSTFUNCT 8
+#define STGCOMMON 9
+#define STGEQUIV 10
+#define STGREG 11 /* register - the outermost DO loop index will be
+ in a register (because the compiler is one
+ pass, it can't know where the innermost loop is
+ */
+#define STGLENG 12
+#define STGNULL 13
+#define STGMEMNO 14 /* interemediate-file pointer to constant table */
+
+/* name classes -- vclass values, also procclass values */
+
+#define CLUNKNOWN 0
+#define CLPARAM 1 /* Parameter - macro definition */
+#define CLVAR 2 /* variable */
+#define CLENTRY 3
+#define CLMAIN 4
+#define CLBLOCK 5
+#define CLPROC 6
+#define CLNAMELIST 7 /* in data with this tag, the vdcldone flag should
+ be ignored (according to vardcl()) */
+
+
+/* vprocclass values -- there is some overlap with the vclass values given
+ above */
+
+#define PUNKNOWN 0
+#define PEXTERNAL 1
+#define PINTRINSIC 2
+#define PSTFUNCT 3
+#define PTHISPROC 4 /* here to allow recursion - further distinction
+ is given in the CL tag (those just above).
+ This applies to the presence of the name of a
+ function used within itself. The function name
+ means either call the function again, or assign
+ some value to the storage allocated to the
+ function's return value. */
+
+/* control stack codes - these are part of a state machine which handles
+ the nesting of blocks (i.e. what to do about the ELSE statement) */
+
+#define CTLDO 1
+#define CTLIF 2
+#define CTLELSE 3
+
+
+/* operators for both Fortran input and C output. They are common because
+ so many are shared between the trees */
+
+#define OPPLUS 1
+#define OPMINUS 2
+#define OPSTAR 3
+#define OPSLASH 4
+#define OPPOWER 5
+#define OPNEG 6
+#define OPOR 7
+#define OPAND 8
+#define OPEQV 9
+#define OPNEQV 10
+#define OPNOT 11
+#define OPCONCAT 12
+#define OPLT 13
+#define OPEQ 14
+#define OPGT 15
+#define OPLE 16
+#define OPNE 17
+#define OPGE 18
+#define OPCALL 19
+#define OPCCALL 20
+#define OPASSIGN 21
+#define OPPLUSEQ 22
+#define OPSTAREQ 23
+#define OPCONV 24
+#define OPLSHIFT 25
+#define OPMOD 26
+#define OPCOMMA 27
+#define OPQUEST 28
+#define OPCOLON 29
+#define OPABS 30
+#define OPMIN 31
+#define OPMAX 32
+#define OPADDR 33
+#define OPCOMMA_ARG 34
+#define OPBITOR 35
+#define OPBITAND 36
+#define OPBITXOR 37
+#define OPBITNOT 38
+#define OPRSHIFT 39
+#define OPWHATSIN 40 /* dereferencing operator */
+#define OPMINUSEQ 41 /* assignment operators */
+#define OPSLASHEQ 42
+#define OPMODEQ 43
+#define OPLSHIFTEQ 44
+#define OPRSHIFTEQ 45
+#define OPBITANDEQ 46
+#define OPBITXOREQ 47
+#define OPBITOREQ 48
+#define OPPREINC 49 /* Preincrement (++x) operator */
+#define OPPREDEC 50 /* Predecrement (--x) operator */
+#define OPDOT 51 /* structure field reference */
+#define OPARROW 52 /* structure pointer field reference */
+#define OPNEG1 53 /* simple negation under forcedouble */
+#define OPDMIN 54 /* min(a,b) macro under forcedouble */
+#define OPDMAX 55 /* max(a,b) macro under forcedouble */
+#define OPASSIGNI 56 /* assignment for inquire stmt */
+#define OPIDENTITY 57 /* for turning TADDR into TEXPR */
+#define OPCHARCAST 58 /* for casting to char * (in I/O stmts) */
+#define OPDABS 59 /* abs macro under forcedouble */
+#define OPMIN2 60 /* min(a,b) macro */
+#define OPMAX2 61 /* max(a,b) macro */
+
+/* label type codes -- used with the ASSIGN statement */
+
+#define LABUNKNOWN 0
+#define LABEXEC 1
+#define LABFORMAT 2
+#define LABOTHER 3
+
+
+/* INTRINSIC function codes*/
+
+#define INTREND 0
+#define INTRCONV 1
+#define INTRMIN 2
+#define INTRMAX 3
+#define INTRGEN 4 /* General intrinsic, e.g. cos v. dcos, zcos, ccos */
+#define INTRSPEC 5
+#define INTRBOOL 6
+#define INTRCNST 7 /* constants, e.g. bigint(1.0) v. bigint (1d0) */
+
+
+/* I/O statement codes - these all form Integer Constants, and are always
+ reevaluated */
+
+#define IOSTDIN ICON(5)
+#define IOSTDOUT ICON(6)
+#define IOSTDERR ICON(0)
+
+#define IOSBAD (-1)
+#define IOSPOSITIONAL 0
+#define IOSUNIT 1
+#define IOSFMT 2
+
+#define IOINQUIRE 1
+#define IOOPEN 2
+#define IOCLOSE 3
+#define IOREWIND 4
+#define IOBACKSPACE 5
+#define IOENDFILE 6
+#define IOREAD 7
+#define IOWRITE 8
+
+
+/* User name tags -- these identify the form of the original identifier
+ stored in a struct Addrblock structure (in the user field). */
+
+#define UNAM_UNKNOWN 0 /* Not specified */
+#define UNAM_NAME 1 /* Local symbol, store in the hash table */
+#define UNAM_IDENT 2 /* Character string not stored elsewhere */
+#define UNAM_EXTERN 3 /* External reference; check symbol table
+ using memno as index */
+#define UNAM_CONST 4 /* Constant value */
+#define UNAM_CHARP 5 /* pointer to string */
+
+
+#define IDENT_LEN 31 /* Maximum length user.ident */
+
+/* type masks - TYLOGICAL defined in ftypes */
+
+#define MSKLOGICAL M(TYLOGICAL)
+#define MSKADDR M(TYADDR)
+#define MSKCHAR M(TYCHAR)
+#define MSKINT M(TYSHORT)|M(TYLONG)
+#define MSKREAL M(TYREAL)|M(TYDREAL) /* DREAL means Double Real */
+#define MSKCOMPLEX M(TYCOMPLEX)|M(TYDCOMPLEX)
+#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST))
+
+/* miscellaneous macros */
+
+/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is
+ the log of one of the OR'ed masks in y) */
+
+#define ONEOF(x,y) (M(x) & (y))
+#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX)
+#define ISREAL(z) ONEOF(z, MSKREAL)
+#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX)
+#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype))
+
+/* ISCHAR assumes that z has some kind of structure, i.e. is not null */
+
+#define ISCHAR(z) (z->headblock.vtype==TYCHAR)
+#define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */
+#define ISCONST(z) (z->tag==TCONST)
+#define ISERROR(z) (z->tag==TERROR)
+#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS)
+#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR)
+#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1)
+#define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */
+#define ICON(z) mkintcon( (ftnint)(z) )
+
+/* NO66 -- F77 feature is being used
+ NOEXT -- F77 extension is being used */
+
+#define NO66(s) if(no66flag) err66(s)
+#define NOEXT(s) if(noextflag) errext(s)
+
+/* round a up to the nearest multiple of b:
+
+ a = b * floor ( (a + (b - 1)) / b )*/
+
+#define roundup(a,b) ( b * ( (a+b-1)/b) )
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include <stdio.h>
+#ifndef NULL
+/* ANSI C */
+#include <stddef.h>
+#endif
+
+#include "ctype.h"
+
+#include "ftypes.h"
+#include "defines.h"
+#include "machdefs.h"
+
+#define MAXDIM 20
+#define MAXINCLUDES 10
+#define MAXLITERALS 200 /* Max number of constants in the literal
+ pool */
+#define MAXTOKENLEN 302 /* length of longest token */
+#define MAXCTL 20
+#define MAXHASH 401
+#define MAXSTNO 801
+#define MAXEXT 200
+#define MAXEQUIV 150
+#define MAXLABLIST 125 /* Max number of labels in an alternate
+ return CALL */
+
+/* These are the primary pointer types used in the compiler */
+
+typedef union Expression *expptr, *tagptr;
+typedef struct Chain *chainp;
+typedef struct Addrblock *Addrp;
+typedef struct Constblock *Constp;
+typedef struct Exprblock *Exprp;
+typedef struct Nameblock *Namep;
+
+extern FILEP opf();
+extern FILEP infile;
+extern FILEP diagfile;
+extern FILEP textfile;
+extern FILEP asmfile;
+extern FILEP c_file; /* output file for all functions; extern
+ declarations will have to be prepended */
+extern FILEP pass1_file; /* Temp file to hold the function bodies
+ read on pass 1 */
+extern FILEP expr_file; /* Debugging file */
+extern FILEP initfile; /* Intermediate data file pointer */
+extern FILEP blkdfile; /* BLOCK DATA file */
+
+extern int current_ftn_file;
+
+extern char *blkdfname, *initfname, *sortfname;
+extern long int headoffset; /* Since the header block requires data we
+ don't know about until AFTER each
+ function has been processed, we keep a
+ pointer to the current (dummy) header
+ block (at the top of the assembly file)
+ here */
+
+extern char main_alias[]; /* name given to PROGRAM psuedo-op */
+extern char token [ ];
+extern int toklen;
+extern long lineno;
+extern char *infname;
+extern int needkwd;
+extern struct Labelblock *thislabel;
+
+/* Used to allow runtime expansion of internal tables. In particular,
+ these values can exceed their associated constants */
+
+extern int maxctl;
+extern int maxequiv;
+extern int maxstno;
+extern int maxhash;
+extern int maxext;
+
+extern flag nowarnflag;
+extern flag ftn66flag; /* Generate warnings when weird f77
+ features are used (undeclared dummy
+ procedure, non-char initialized with
+ string, 1-dim subscript in EQUIV) */
+extern flag no66flag; /* Generate an error when a generic
+ function (f77 feature) is used */
+extern flag noextflag; /* Generate an error when an extension to
+ Fortran 77 is used (hex/oct/bin
+ constants, automatic, static, double
+ complex types) */
+extern flag zflag; /* enable double complex intrinsics */
+extern flag shiftcase;
+extern flag undeftype;
+extern flag shortsubs; /* Use short subscripts on arrays? */
+extern flag onetripflag; /* if true, always execute DO loop body */
+extern flag checksubs;
+extern flag debugflag;
+extern int nerr;
+extern int nwarn;
+
+extern int parstate;
+extern flag headerdone; /* True iff the current procedure's header
+ data has been written */
+extern int blklevel;
+extern flag saveall;
+extern flag substars; /* True iff some formal parameter is an
+ asterisk */
+extern int impltype[ ];
+extern ftnint implleng[ ];
+extern int implstg[ ];
+
+extern int tyint, tyioint, tyreal;
+extern int tylogical; /* TY____ of the implementation of logical.
+ This will be LONG unless '-2' is given
+ on the command line */
+extern int type_choice[];
+extern char *typename[];
+
+extern int typesize[]; /* size (in bytes) of an object of each
+ type. Indexed by TY___ macros */
+extern int typealign[];
+extern int proctype; /* Type of return value in this procedure */
+extern char * procname; /* External name of the procedure, or last ENTRY name */
+extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */
+extern Addrp retslot;
+extern Addrp xretslot[];
+extern int cxslot; /* Complex return argument slot (frame pointer offset)*/
+extern int chslot; /* Character return argument slot (fp offset) */
+extern int chlgslot; /* Argument slot for length of character buffer */
+extern int procclass; /* Class of the current procedure: either CLPROC,
+ CLMAIN, CLBLOCK or CLUNKNOWN */
+extern ftnint procleng; /* Length of function return value (e.g. char
+ string length). If this is -1, then the length is
+ not known at compile time */
+extern int nentry; /* Number of entry points (other than the original
+ function call) into this procedure */
+extern flag multitype; /* YES iff there is more than one return value
+ possible */
+extern int blklevel;
+extern long lastiolabno;
+extern int lastlabno;
+extern int lastvarno;
+extern int lastargslot; /* integer offset pointing to the next free
+ location for an argument to the current routine */
+extern int argloc;
+extern int autonum[]; /* for numbering
+ automatic variables, e.g. temporaries */
+extern int retlabel;
+extern int ret0label;
+extern int dorange; /* Number of the label which terminates
+ the innermost DO loop */
+extern int regnum[ ]; /* Numbers of DO indicies named in
+ regnamep (below) */
+extern Namep regnamep[ ]; /* List of DO indicies in registers */
+extern int maxregvar; /* number of elts in regnamep */
+extern int highregvar; /* keeps track of the highest register
+ number used by DO index allocator */
+extern int nregvar; /* count of DO indicies in registers */
+
+extern chainp templist[];
+extern int maxdim;
+extern chainp earlylabs;
+extern chainp holdtemps;
+extern struct Entrypoint *entries;
+extern struct Rplblock *rpllist;
+extern struct Chain *curdtp;
+extern ftnint curdtelt;
+extern chainp allargs; /* union of args in entries */
+extern int nallargs; /* total number of args */
+extern int nallchargs; /* total number of character args */
+extern flag toomanyinit; /* True iff too many initializers in a
+ DATA statement */
+
+extern flag inioctl;
+extern int iostmt;
+extern Addrp ioblkp;
+extern int nioctl;
+extern int nequiv;
+extern int eqvstart; /* offset to eqv number to guarantee uniqueness
+ and prevent <something> from going negative */
+extern int nintnames;
+
+/* Chain of tagged blocks */
+
+struct Chain
+ {
+ chainp nextp;
+ char * datap; /* Tagged block */
+ };
+
+extern chainp chains;
+
+/* Recall that field is intended to hold four-bit characters */
+
+/* This structure exists only to defeat the type checking */
+
+struct Headblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg;
+ expptr vleng; /* Expression for length of char string -
+ this may be a constant, or an argument
+ generated by mkarg() */
+ } ;
+
+/* Control construct info (for do loops, else, etc) */
+
+struct Ctlframe
+ {
+ unsigned ctltype:8;
+ unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */
+ unsigned dowhile:1;
+ int ctlabels[4]; /* Control labels, defined below */
+ int dolabel; /* label marking end of this DO loop */
+ Namep donamep; /* DO index variable */
+ expptr domax; /* constant or temp variable holding MAX
+ loop value; or expr of while(expr) */
+ expptr dostep; /* expression */
+ Namep loopname;
+ };
+#define endlabel ctlabels[0]
+#define elselabel ctlabels[1]
+#define dobodylabel ctlabels[1]
+#define doposlabel ctlabels[2]
+#define doneglabel ctlabels[3]
+extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF
+ structures - this is the stack
+ bottom */
+extern struct Ctlframe *ctlstack; /* Pointer to current nesting
+ level */
+extern struct Ctlframe *lastctl; /* Point to end of
+ dynamically-allocated array */
+
+typedef struct {
+ int type;
+ chainp cp;
+ } Atype;
+
+typedef struct {
+ int nargs, changes;
+ Atype atypes[1];
+ } Argtypes;
+
+/* External Symbols */
+
+struct Extsym
+ {
+ char *fextname; /* Fortran version of external name */
+ char *cextname; /* C version of external name */
+ field extstg; /* STG -- should be COMMON, UNKNOWN or EXT
+ */
+ unsigned extype:4; /* for transmitting type to output routines */
+ unsigned used_here:1; /* Boolean - true on the second pass
+ through a function if the block has
+ been referenced */
+ unsigned exused:1; /* Has been used (for help with error msgs
+ about externals typed differently in
+ different modules) */
+ unsigned exproto:1; /* type specified in a .P file */
+ unsigned extinit:1; /* Procedure has been defined,
+ or COMMON has DATA */
+ unsigned extseen:1; /* True if previously referenced */
+ chainp extp; /* List of identifiers in the common
+ block for this function, stored as
+ Namep (hash table pointers) */
+ chainp allextp; /* List of lists of identifiers; we keep one
+ list for each layout of this common block */
+ int curno; /* current number for this common block,
+ used for constructing appending _nnn
+ to the common block name */
+ int maxno; /* highest curno value for this common block */
+ ftnint extleng;
+ ftnint maxleng;
+ Argtypes *arginfo;
+ };
+typedef struct Extsym Extsym;
+
+extern Extsym *extsymtab; /* External symbol table */
+extern Extsym *nextext;
+extern Extsym *lastext;
+extern int complex_seen, dcomplex_seen;
+
+/* Statement labels */
+
+struct Labelblock
+ {
+ int labelno; /* Internal label */
+ unsigned blklevel:8; /* level of nesting , for branch-in-loop
+ checking */
+ unsigned labused:1;
+ unsigned fmtlabused:1;
+ unsigned labinacc:1; /* inaccessible? (i.e. has its scope
+ vanished) */
+ unsigned labdefined:1; /* YES or NO */
+ unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */
+ ftnint stateno; /* Original label */
+ char *fmtstring; /* format string */
+ };
+
+extern struct Labelblock *labeltab; /* Label table - keeps track of
+ all labels, including undefined */
+extern struct Labelblock *labtabend;
+extern struct Labelblock *highlabtab;
+
+/* Entry point list */
+
+struct Entrypoint
+ {
+ struct Entrypoint *entnextp;
+ Extsym *entryname; /* Name of this ENTRY */
+ chainp arglist;
+ int typelabel; /* Label for function exit; this
+ will return the proper type of
+ object */
+ Namep enamep; /* External name */
+ };
+
+/* Primitive block, or Primary block. This is a general template returned
+ by the parser, which will be interpreted in context. It is a template
+ for an identifier (variable name, function name), parenthesized
+ arguments (array subscripts, function parameters) and substring
+ specifications. */
+
+struct Primblock
+ {
+ field tag;
+ field vtype;
+ Namep namep; /* Pointer to structure Nameblock */
+ struct Listblock *argsp;
+ expptr fcharp; /* first-char-index-pointer (in
+ substring) */
+ expptr lcharp; /* last-char-index-pointer (in
+ substring) */
+ };
+
+
+struct Hashentry
+ {
+ int hashval;
+ Namep varp;
+ };
+extern struct Hashentry *hashtab; /* Hash table */
+extern struct Hashentry *lasthash;
+
+struct Intrpacked /* bits for intrinsic function description */
+ {
+ unsigned f1:3;
+ unsigned f2:4;
+ unsigned f3:7;
+ unsigned f4:1;
+ };
+
+struct Nameblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg;
+ expptr vleng; /* length of character string, if applicable */
+ char *fvarname; /* name in the Fortran source */
+ char *cvarname; /* name in the resulting C */
+ chainp vlastdim; /* datap points to new_vars entry for the */
+ /* system variable, if any, storing the final */
+ /* dimension; we zero the datap if this */
+ /* variable is needed */
+ unsigned vprocclass:3; /* P____ macros - selects the varxptr
+ field below */
+ unsigned vdovar:1; /* "is it a DO variable?" for register
+ and multi-level loop checking */
+ unsigned vdcldone:1; /* "do I think I'm done?" - set when the
+ context is sufficient to determine its
+ status */
+ unsigned vadjdim:1; /* "adjustable dimension?" - needed for
+ information about copies */
+ unsigned vsave:1;
+ unsigned vimpldovar:1; /* used to prevent erroneous error messages
+ for variables used only in DATA stmt
+ implicit DOs */
+ unsigned vis_assigned:1;/* True if this variable has had some
+ label ASSIGNED to it; hence
+ varxptr.assigned_values is valid */
+ unsigned vimplstg:1; /* True if storage type is assigned implicitly;
+ this allows a COMMON variable to participate
+ in a DIMENSION before the COMMON declaration.
+ */
+ unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */
+ unsigned vfmt_asg:1; /* True if char *var_fmt needed */
+ unsigned vpassed:1; /* True if passed as a character-variable arg */
+ unsigned vknownarg:1; /* True if seen in a previous entry point */
+ unsigned visused:1; /* True if variable is referenced -- so we */
+ /* can omit variables that only appear in DATA */
+ unsigned vnamelist:1; /* Appears in a NAMELIST */
+ unsigned vimpltype:1; /* True if implicitly typed and not
+ invoked as a function or subroutine
+ (so we can consistently type procedures
+ declared external and passed as args
+ but never invoked).
+ */
+ unsigned vtypewarned:1; /* so we complain just once about
+ changed types of external procedures */
+ unsigned vinftype:1; /* so we can restore implicit type to a
+ procedure if it is invoked as a function
+ after being given a different type by -it */
+ unsigned vinfproc:1; /* True if -it infers this to be a procedure */
+ unsigned vcalled:1; /* has been invoked */
+ unsigned vdimfinish:1; /* need to invoke dim_finish() */
+
+/* The vardesc union below is used to store the number of an intrinsic
+ function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to
+ store the index of this external symbol in extsymtab (when vstg ==
+ STGEXT and vprocclass == PEXTERNAL) */
+
+ union {
+ int varno; /* Return variable for a function.
+ This is used when a function is
+ assigned a return value. Also
+ used to point to the COMMON
+ block, when this is a field of
+ that block. Also points to
+ EQUIV block when STGEQUIV */
+ struct Intrpacked intrdesc; /* bits for intrinsic function*/
+ } vardesc;
+ struct Dimblock *vdim; /* points to the dimensions if they exist */
+ ftnint voffset; /* offset in a storage block (the variable
+ name will be "v.%d", voffset in a
+ common blck on the vax). Also holds
+ pointers for automatic variables. When
+ STGEQUIV, this is -(offset from array
+ base) */
+ union {
+ chainp namelist; /* points to names in the NAMELIST,
+ if this is a NAMELIST name */
+ chainp vstfdesc; /* points to (formals, expr) pair */
+ chainp assigned_values; /* list of integers, each being a
+ statement label assigned to
+ this variable in the current function */
+ } varxptr;
+ int argno; /* for multiple entries */
+ Argtypes *arginfo;
+ };
+
+
+/* PARAMETER statements */
+
+struct Paramblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg;
+ expptr vleng;
+ char *fvarname;
+ char *cvarname;
+ expptr paramval;
+ } ;
+
+
+/* Expression block */
+
+struct Exprblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg;
+ expptr vleng; /* in the case of a character expression, this
+ value is inherited from the children */
+ unsigned opcode;
+ expptr leftp;
+ expptr rightp;
+ };
+
+
+union Constant
+ {
+ struct {
+ char *ccp0;
+ ftnint blanks;
+ } ccp1;
+ ftnint ci; /* Constant long integer */
+ double cd[2];
+ char *cds[2];
+ };
+#define ccp ccp1.ccp0
+
+struct Constblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg; /* vstg = 1 when using Const.cds */
+ expptr vleng;
+ union Constant Const;
+ };
+
+
+struct Listblock
+ {
+ field tag;
+ field vtype;
+ chainp listp;
+ };
+
+
+
+/* Address block - this is the FINAL form of identifiers before being
+ sent to pass 2. We'll want to add the original identifier here so that it can
+ be preserved in the translation.
+
+ An example identifier is q.7. The "q" refers to the storage class
+ (field vstg), the 7 to the variable number (int memno). */
+
+struct Addrblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg;
+ expptr vleng;
+ /* put union...user here so the beginning of an Addrblock
+ * is the same as a Constblock.
+ */
+ union {
+ Namep name; /* contains a pointer into the hash table */
+ char ident[IDENT_LEN + 1]; /* C string form of identifier */
+ char *Charp;
+ union Constant Const; /* Constant value */
+ struct {
+ double dfill[2];
+ field vstg1;
+ } kludge; /* so we can distinguish string vs binary
+ * floating-point constants */
+ } user;
+ long memno; /* when vstg == STGCONST, this is the
+ numeric part of the assembler label
+ where the constant value is stored */
+ expptr memoffset; /* used in subscript computations, usually */
+ unsigned istemp:1; /* used in stack management of temporary
+ variables */
+ unsigned isarray:1; /* used to show that memoffset is
+ meaningful, even if zero */
+ unsigned ntempelt:10; /* for representing temporary arrays, as
+ in concatenation */
+ unsigned dbl_builtin:1; /* builtin to be declared double */
+ unsigned charleng:1; /* so saveargtypes can get i/o calls right */
+ ftnint varleng; /* holds a copy of a constant length which
+ is stored in the vleng field (e.g.
+ a double is 8 bytes) */
+ int uname_tag; /* Tag describing which of the unions()
+ below to use */
+ char *Field; /* field name when dereferencing a struct */
+}; /* struct Addrblock */
+
+
+/* Errorbock - placeholder for errors, to allow the compilation to
+ continue */
+
+struct Errorblock
+ {
+ field tag;
+ field vtype;
+ };
+
+
+/* Implicit DO block, especially related to DATA statements. This block
+ keeps track of the compiler's location in the implicit DO while it's
+ running. In particular, the isactive and isbusy flags tell where
+ it is */
+
+struct Impldoblock
+ {
+ field tag;
+ unsigned isactive:1;
+ unsigned isbusy:1;
+ Namep varnp;
+ Constp varvp;
+ chainp impdospec;
+ expptr implb;
+ expptr impub;
+ expptr impstep;
+ ftnint impdiff;
+ ftnint implim;
+ struct Chain *datalist;
+ };
+
+
+/* Each of these components has a first field called tag. This union
+ exists just for allocation simplicity */
+
+union Expression
+ {
+ field tag;
+ struct Addrblock addrblock;
+ struct Constblock constblock;
+ struct Errorblock errorblock;
+ struct Exprblock exprblock;
+ struct Headblock headblock;
+ struct Impldoblock impldoblock;
+ struct Listblock listblock;
+ struct Nameblock nameblock;
+ struct Paramblock paramblock;
+ struct Primblock primblock;
+ } ;
+
+
+
+struct Dimblock
+ {
+ int ndim;
+ expptr nelt; /* This is NULL if the array is unbounded */
+ expptr baseoffset; /* a constant or local variable holding
+ the offset in this procedure */
+ expptr basexpr; /* expression for comuting the offset, if
+ it's not constant. If this is
+ non-null, the register named in
+ baseoffset will get initialized to this
+ value in the procedure's prolog */
+ struct
+ {
+ expptr dimsize; /* constant or register holding the size
+ of this dimension */
+ expptr dimexpr; /* as above in basexpr, this is an
+ expression for computing a variable
+ dimension */
+ } dims[1]; /* Dimblocks are allocated with enough
+ space for this to become dims[ndim] */
+ };
+
+
+/* Statement function identifier stack - this holds the name and value of
+ the parameters in a statement function invocation. For example,
+
+ f(x,y,z)=x+y+z
+ .
+ .
+ y = f(1,2,3)
+
+ generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
+ at the definition */
+
+struct Rplblock /* name replacement block */
+ {
+ struct Rplblock *rplnextp;
+ Namep rplnp; /* Name of the formal parameter */
+ expptr rplvp; /* Value of the actual parameter */
+ expptr rplxp; /* Initialization of temporary variable,
+ if required; else null */
+ int rpltag; /* Tag on the value of the actual param */
+ };
+
+
+
+/* Equivalence block */
+
+struct Equivblock
+ {
+ struct Eqvchain *equivs; /* List (Eqvchain) of primblocks
+ holding variable identifiers */
+ flag eqvinit;
+ long int eqvtop;
+ long int eqvbottom;
+ int eqvtype;
+ } ;
+#define eqvleng eqvtop
+
+extern struct Equivblock *eqvclass;
+
+
+struct Eqvchain
+ {
+ struct Eqvchain *eqvnextp;
+ union
+ {
+ struct Primblock *eqvlhs;
+ Namep eqvname;
+ } eqvitem;
+ long int eqvoffset;
+ } ;
+
+
+
+/* For allocation purposes only, and to keep lint quiet. In particular,
+ don't count on the tag being able to tell you which structure is used */
+
+
+/* There is a tradition in Fortran that the compiler not generate the same
+ bit pattern more than is necessary. This structure is used to do just
+ that; if two integer constants have the same bit pattern, just generate
+ it once. This could be expanded to optimize without regard to type, by
+ removing the type check in putconst() */
+
+struct Literal
+ {
+ short littype;
+ short litnum; /* numeric part of the assembler
+ label for this constant value */
+ int lituse; /* usage count */
+ union {
+ ftnint litival;
+ double litdval[2];
+ } litval;
+ char *cds[2];
+ };
+
+extern struct Literal litpool[ ];
+extern int nliterals;
+extern char Letters[];
+#define letter(x) Letters[x]
+
+
+/* popular functions with non integer return values */
+
+
+int *ckalloc();
+char *varstr(), *nounder(), *addunder();
+char *copyn(), *copys();
+chainp hookup(), mkchain(), revchain();
+ftnint convci();
+char *convic();
+char *setdoto();
+double convcd();
+Namep mkname();
+struct Labelblock *mklabel(), *execlab();
+Extsym *mkext(), *newentry();
+expptr addrof(), call1(), call2(), call3(), call4();
+Addrp builtin(), Mktemp(), mktmp0(), mktmpn(), autovar();
+Addrp mkplace(), mkaddr(), putconst(), memversion();
+expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype();
+expptr errnode(), mkaddcon(), mkintcon(), putcxop();
+tagptr cpexpr();
+ftnint lmin(), lmax(), iarrlen();
+void *memcpy(), *memset();
+char *strcat(), *strcpy(), *strncpy();
+char *dbconst(), *flconst();
+
+void puteq (), putex1 ();
+expptr putx (), putsteq (), putassign ();
+
+extern int forcedouble; /* force real functions to double */
+extern int doin_setbound; /* special handling for array bounds */
+extern int Ansi;
+extern double atof();
+extern char *cds(), *cpstring(), *dtos(), *gmem(), *mem(), *string_num();
+extern char *c_type_decl();
+extern char hextoi_tab[];
+#define hextoi(x) hextoi_tab[(x) & 0xff]
+extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[];
+extern int Castargs, infertypes;
+extern FILE *protofile;
+extern void exit(), inferdcl(), protowrite(), save_argtypes();
+extern char binread[], binwrite[], textread[], textwrite[];
+extern char *wh_first, *wh_last, *wh_next;
+extern void putwhile();
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+LOCAL eqvcommon(), eqveqv(), nsubs();
+
+/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
+
+/* called at end of declarations section to process chains
+ created by EQUIVALENCE statements
+ */
+doequiv()
+{
+ register int i;
+ int inequiv; /* True if one namep occurs in
+ several EQUIV declarations */
+ int comno; /* Index into Extsym table of the last
+ COMMON block seen (implicitly assuming
+ that only one will be given) */
+ int ovarno;
+ ftnint comoffset; /* Index into the COMMON block */
+ ftnint offset; /* Offset from array base */
+ ftnint leng;
+ register struct Equivblock *equivdecl;
+ register struct Eqvchain *q;
+ struct Primblock *primp;
+ register Namep np;
+ int k, k1, ns, pref, t;
+ chainp cp;
+ extern int type_pref[];
+
+ for(i = 0 ; i < nequiv ; ++i)
+ {
+
+/* Handle each equivalence declaration */
+
+ equivdecl = &eqvclass[i];
+ equivdecl->eqvbottom = equivdecl->eqvtop = 0;
+ comno = -1;
+
+
+
+ for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
+ {
+ offset = 0;
+ primp = q->eqvitem.eqvlhs;
+ vardcl(np = primp->namep);
+ if(primp->argsp || primp->fcharp)
+ {
+ expptr offp, suboffset();
+
+/* Pad ones onto the end of an array declaration when needed */
+
+ if(np->vdim!=NULL && np->vdim->ndim>1 &&
+ nsubs(primp->argsp)==1 )
+ {
+ if(! ftn66flag)
+ warni
+ ("1-dim subscript in EQUIVALENCE, %d-dim declared",
+ np -> vdim -> ndim);
+ cp = NULL;
+ ns = np->vdim->ndim;
+ while(--ns > 0)
+ cp = mkchain((char *)ICON(1), cp);
+ primp->argsp->listp->nextp = cp;
+ }
+
+ offp = suboffset(primp);
+ if(ISICON(offp))
+ offset = offp->constblock.Const.ci;
+ else {
+ dclerr
+ ("nonconstant subscript in equivalence ",
+ np);
+ np = NULL;
+ }
+ frexpr(offp);
+ }
+
+/* Free up the primblock, since we now have a hash table (Namep) entry */
+
+ frexpr((expptr)primp);
+
+ if(np && (leng = iarrlen(np))<0)
+ {
+ dclerr("adjustable in equivalence", np);
+ np = NULL;
+ }
+
+ if(np) switch(np->vstg)
+ {
+ case STGUNKNOWN:
+ case STGBSS:
+ case STGEQUIV:
+ break;
+
+ case STGCOMMON:
+
+/* The code assumes that all COMMON references in a given EQUIVALENCE will
+ be to the same COMMON block, and will all be consistent */
+
+ comno = np->vardesc.varno;
+ comoffset = np->voffset + offset;
+ break;
+
+ default:
+ dclerr("bad storage class in equivalence", np);
+ np = NULL;
+ break;
+ }
+
+ if(np)
+ {
+ q->eqvoffset = offset;
+
+/* eqvbottom gets the largest difference between the array base address
+ and the address specified in the EQUIV declaration */
+
+ equivdecl->eqvbottom =
+ lmin(equivdecl->eqvbottom, -offset);
+
+/* eqvtop gets the largest difference between the end of the array and
+ the address given in the EQUIVALENCE */
+
+ equivdecl->eqvtop =
+ lmax(equivdecl->eqvtop, leng-offset);
+ }
+ q->eqvitem.eqvname = np;
+ }
+
+/* Now all equivalenced variables are in the hash table with the proper
+ offset, and eqvtop and eqvbottom are set. */
+
+ if(comno >= 0)
+
+/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
+ */
+
+ eqvcommon(equivdecl, comno, comoffset);
+ else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
+ {
+ if(np = q->eqvitem.eqvname)
+ {
+ inequiv = NO;
+ if(np->vstg==STGEQUIV)
+ if( (ovarno = np->vardesc.varno) == i)
+ {
+
+/* Can't EQUIV different elements of the same array */
+
+ if(np->voffset + q->eqvoffset != 0)
+ dclerr
+ ("inconsistent equivalence", np);
+ }
+ else {
+ offset = np->voffset;
+ inequiv = YES;
+ }
+
+ np->vstg = STGEQUIV;
+ np->vardesc.varno = i;
+ np->voffset = - q->eqvoffset;
+
+ if(inequiv)
+
+/* Combine 2 equivalence declarations */
+
+ eqveqv(i, ovarno, q->eqvoffset + offset);
+ }
+ }
+ }
+
+/* Now each equivalence declaration is distinct (all connections have been
+ merged in eqveqv()), and some may be empty. */
+
+ for(i = 0 ; i < nequiv ; ++i)
+ {
+ equivdecl = & eqvclass[i];
+ if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
+
+/* a live chain */
+
+ k = TYCHAR;
+ pref = 1;
+ for(q = equivdecl->equivs ; q; q = q->eqvnextp)
+ {
+ np = q->eqvitem.eqvname;
+ np->voffset -= equivdecl->eqvbottom;
+ t = typealign[k1 = np->vtype];
+ if (pref < type_pref[k1]) {
+ k = k1;
+ pref = type_pref[k1];
+ }
+ if(np->voffset % t != 0)
+ dclerr("bad alignment forced by equivalence", np);
+ }
+ equivdecl->eqvtype = k;
+ }
+ freqchain(equivdecl);
+ }
+}
+
+
+
+
+
+/* put equivalence chain p at common block comno + comoffset */
+
+LOCAL eqvcommon(p, comno, comoffset)
+struct Equivblock *p;
+int comno;
+ftnint comoffset;
+{
+ int ovarno;
+ ftnint k, offq;
+ register Namep np;
+ register struct Eqvchain *q;
+
+ if(comoffset + p->eqvbottom < 0)
+ {
+ errstr("attempt to extend common %s backward",
+ extsymtab[comno].fextname);
+ freqchain(p);
+ return;
+ }
+
+ if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
+ extsymtab[comno].extleng = k;
+
+
+ for(q = p->equivs ; q ; q = q->eqvnextp)
+ if(np = q->eqvitem.eqvname)
+ {
+ switch(np->vstg)
+ {
+ case STGUNKNOWN:
+ case STGBSS:
+ np->vstg = STGCOMMON;
+ np->vcommequiv = 1;
+ np->vardesc.varno = comno;
+
+/* np -> voffset will point to the base of the array */
+
+ np->voffset = comoffset - q->eqvoffset;
+ break;
+
+ case STGEQUIV:
+ ovarno = np->vardesc.varno;
+
+/* offq will point to the current element, even if it's in an array */
+
+ offq = comoffset - q->eqvoffset - np->voffset;
+ np->vstg = STGCOMMON;
+ np->vcommequiv = 1;
+ np->vardesc.varno = comno;
+
+/* np -> voffset will point to the base of the array */
+
+ np->voffset = comoffset - q->eqvoffset;
+ if(ovarno != (p - eqvclass))
+ eqvcommon(&eqvclass[ovarno], comno, offq);
+ break;
+
+ case STGCOMMON:
+ if(comno != np->vardesc.varno ||
+ comoffset != np->voffset+q->eqvoffset)
+ dclerr("inconsistent common usage", np);
+ break;
+
+
+ default:
+ badstg("eqvcommon", np->vstg);
+ }
+ }
+
+ freqchain(p);
+ p->eqvbottom = p->eqvtop = 0;
+}
+
+
+/* Move all items on ovarno chain to the front of nvarno chain.
+ * adjust offsets of ovarno elements and top and bottom of nvarno chain
+ */
+
+LOCAL eqveqv(nvarno, ovarno, delta)
+int ovarno, nvarno;
+ftnint delta;
+{
+ register struct Equivblock *neweqv, *oldeqv;
+ register Namep np;
+ struct Eqvchain *q, *q1;
+
+ neweqv = eqvclass + nvarno;
+ oldeqv = eqvclass + ovarno;
+ neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
+ neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
+ oldeqv->eqvbottom = oldeqv->eqvtop = 0;
+
+ for(q = oldeqv->equivs ; q ; q = q1)
+ {
+ q1 = q->eqvnextp;
+ if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
+ {
+ q->eqvnextp = neweqv->equivs;
+ neweqv->equivs = q;
+ q->eqvoffset -= delta;
+ np->vardesc.varno = nvarno;
+ np->voffset -= delta;
+ }
+ else free( (charptr) q);
+ }
+ oldeqv->equivs = NULL;
+}
+
+
+
+
+freqchain(p)
+register struct Equivblock *p;
+{
+ register struct Eqvchain *q, *oq;
+
+ for(q = p->equivs ; q ; q = oq)
+ {
+ oq = q->eqvnextp;
+ free( (charptr) q);
+ }
+ p->equivs = NULL;
+}
+
+
+
+
+
+/* nsubs -- number of subscripts in this arglist (just the length of the
+ list) */
+
+LOCAL nsubs(p)
+register struct Listblock *p;
+{
+ register int n;
+ register chainp q;
+
+ n = 0;
+ if(p)
+ for(q = p->listp ; q ; q = q->nextp)
+ ++n;
+
+ return(n);
+}
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+warni(s,t)
+ char *s;
+ int t;
+{
+ char buf[100];
+ sprintf(buf,s,t);
+ warn(buf);
+ }
+
+warn1(s,t)
+char *s, *t;
+{
+ char buff[100];
+ sprintf(buff, s, t);
+ warn(buff);
+}
+
+
+warn(s)
+char *s;
+{
+ if(nowarnflag)
+ return;
+ if (infname && *infname)
+ fprintf(diagfile, "Warning on line %ld of %s: %s\n",
+ lineno, infname, s);
+ else
+ fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s);
+ fflush(diagfile);
+ ++nwarn;
+}
+
+
+errstr(s, t)
+char *s, *t;
+{
+ char buff[100];
+ sprintf(buff, s, t);
+ err(buff);
+}
+
+
+
+erri(s,t)
+char *s;
+int t;
+{
+ char buff[100];
+ sprintf(buff, s, t);
+ err(buff);
+}
+
+errl(s,t)
+char *s;
+long t;
+{
+ char buff[100];
+ sprintf(buff, s, t);
+ err(buff);
+}
+
+
+
+err(s)
+char *s;
+{
+ if (infname && *infname)
+ fprintf(diagfile, "Error on line %ld of %s: %s\n",
+ lineno, infname, s);
+ else
+ fprintf(diagfile, "Error on line %ld: %s\n", lineno, s);
+ fflush(diagfile);
+ ++nerr;
+}
+
+
+yyerror(s)
+char *s;
+{
+ err(s);
+}
+
+
+
+dclerr(s, v)
+char *s;
+Namep v;
+{
+ char buff[100];
+
+ if(v)
+ {
+ sprintf(buff, "Declaration error for %s: %s", v->fvarname, s);
+ err(buff);
+ }
+ else
+ errstr("Declaration error %s", s);
+}
+
+
+
+execerr(s, n)
+char *s, *n;
+{
+ char buf1[100], buf2[100];
+
+ sprintf(buf1, "Execution error %s", s);
+ sprintf(buf2, buf1, n);
+ err(buf2);
+}
+
+
+Fatal(t)
+char *t;
+{
+ fprintf(diagfile, "Compiler error line %ld of %s: %s\n", lineno, infname, t);
+ done(3);
+}
+
+
+
+
+fatalstr(t,s)
+char *t, *s;
+{
+ char buff[100];
+ sprintf(buff, t, s);
+ Fatal(buff);
+}
+
+
+
+fatali(t,d)
+char *t;
+int d;
+{
+ char buff[100];
+ sprintf(buff, t, d);
+ Fatal(buff);
+}
+
+
+
+badthing(thing, r, t)
+char *thing, *r;
+int t;
+{
+ char buff[50];
+ sprintf(buff, "Impossible %s %d in routine %s", thing, t, r);
+ Fatal(buff);
+}
+
+
+
+badop(r, t)
+char *r;
+int t;
+{
+ badthing("opcode", r, t);
+}
+
+
+
+badtag(r, t)
+char *r;
+int t;
+{
+ badthing("tag", r, t);
+}
+
+
+
+
+
+badstg(r, t)
+char *r;
+int t;
+{
+ badthing("storage class", r, t);
+}
+
+
+
+
+badtype(r, t)
+char *r;
+int t;
+{
+ badthing("type", r, t);
+}
+
+
+many(s, c, n)
+char *s, c;
+int n;
+{
+ char buff[250];
+
+ sprintf(buff,
+ "Too many %s.\nTable limit now %d.\nTry recompiling using the -N%c%d option\n",
+ s, n, c, 2*n);
+ Fatal(buff);
+}
+
+
+err66(s)
+char *s;
+{
+ errstr("Fortran 77 feature used: %s", s);
+ --nerr;
+}
+
+
+
+errext(s)
+char *s;
+{
+ errstr("F77 compiler extension used: %s", s);
+ --nerr;
+}
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "names.h"
+
+LOCAL void exar2(), popctl(), pushctl();
+
+/* Logical IF codes
+*/
+
+
+exif(p)
+expptr p;
+{
+ pushctl(CTLIF);
+ putif(p, 0); /* 0 => if, not elseif */
+}
+
+
+
+exelif(p)
+expptr p;
+{
+ if (ctlstack->ctltype == CTLIF)
+ putif(p, 1); /* 1 ==> elseif */
+ else
+ execerr("elseif out of place", CNULL);
+}
+
+
+
+
+
+exelse()
+{
+ if(ctlstack->ctltype==CTLIF) {
+ p1_else ();
+ ctlstack->ctltype = CTLELSE;
+ }
+ else
+ execerr("else out of place", CNULL);
+}
+
+
+exendif()
+{
+ if(ctlstack->ctltype == CTLIF) {
+ popctl();
+ p1_endif ();
+ } else if(ctlstack->ctltype == CTLELSE) {
+ popctl();
+ p1else_end ();
+ } else
+ execerr("endif out of place", CNULL);
+}
+
+
+
+/* pushctl -- Start a new control construct, initialize the labels (to
+ zero) */
+
+ LOCAL void
+pushctl(code)
+ int code;
+{
+ register int i;
+
+ if(++ctlstack >= lastctl)
+ many("loops or if-then-elses", 'c', maxctl);
+ ctlstack->ctltype = code;
+ for(i = 0 ; i < 4 ; ++i)
+ ctlstack->ctlabels[i] = 0;
+ ctlstack->dowhile = 0;
+ ++blklevel;
+}
+
+
+ LOCAL void
+popctl()
+{
+ if( ctlstack-- < ctls )
+ Fatal("control stack empty");
+ --blklevel;
+}
+
+
+
+/* poplab -- update the flags in labeltab */
+
+LOCAL poplab()
+{
+ register struct Labelblock *lp;
+
+ for(lp = labeltab ; lp < highlabtab ; ++lp)
+ if(lp->labdefined)
+ {
+ /* mark all labels in inner blocks unreachable */
+ if(lp->blklevel > blklevel)
+ lp->labinacc = YES;
+ }
+ else if(lp->blklevel > blklevel)
+ {
+ /* move all labels referred to in inner blocks out a level */
+ lp->blklevel = blklevel;
+ }
+}
+
+
+/* BRANCHING CODE
+*/
+
+exgoto(lab)
+struct Labelblock *lab;
+{
+ lab->labused = 1;
+ p1_goto (lab -> stateno);
+}
+
+
+
+
+
+
+
+exequals(lp, rp)
+register struct Primblock *lp;
+register expptr rp;
+{
+ if(lp->tag != TPRIM)
+ {
+ err("assignment to a non-variable");
+ frexpr((expptr)lp);
+ frexpr(rp);
+ }
+ else if(lp->namep->vclass!=CLVAR && lp->argsp)
+ {
+ if(parstate >= INEXEC)
+ err("statement function amid executables");
+ mkstfunct(lp, rp);
+ }
+ else
+ {
+ expptr new_lp, new_rp;
+
+ if(parstate < INDATA)
+ enddcl();
+ new_lp = mklhs (lp);
+ new_rp = fixtype (rp);
+ puteq(new_lp, new_rp);
+ }
+}
+
+
+
+/* Make Statement Function */
+
+long laststfcn = -1, thisstno;
+int doing_stmtfcn;
+
+mkstfunct(lp, rp)
+struct Primblock *lp;
+expptr rp;
+{
+ register struct Primblock *p;
+ register Namep np;
+ chainp args;
+
+ laststfcn = thisstno;
+ np = lp->namep;
+ if(np->vclass == CLUNKNOWN)
+ np->vclass = CLPROC;
+ else
+ {
+ dclerr("redeclaration of statement function", np);
+ return;
+ }
+ np->vprocclass = PSTFUNCT;
+ np->vstg = STGSTFUNCT;
+
+/* Set the type of the function */
+
+ impldcl(np);
+ args = (lp->argsp ? lp->argsp->listp : CHNULL);
+ np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
+
+ for(doing_stmtfcn = 1 ; args ; args = args->nextp)
+
+/* It is an error for the formal parameters to have arguments or
+ subscripts */
+
+ if( ((tagptr)(args->datap))->tag!=TPRIM ||
+ (p = (struct Primblock *)(args->datap) )->argsp ||
+ p->fcharp || p->lcharp )
+ err("non-variable argument in statement function definition");
+ else
+ {
+
+/* Replace the name on the left-hand side */
+
+ args->datap = (char *)p->namep;
+ vardcl(p -> namep);
+ free((char *)p);
+ }
+ doing_stmtfcn = 0;
+}
+
+ static void
+mixed_type(np)
+ Namep np;
+{
+ char buf[128];
+ sprintf(buf, "%s function %.90s invoked as subroutine",
+ ftn_types[np->vtype], np->fvarname);
+ warn(buf);
+ }
+
+
+excall(name, args, nstars, labels)
+Namep name;
+struct Listblock *args;
+int nstars;
+struct Labelblock *labels[ ];
+{
+ register expptr p;
+ extern void saveargtypes();
+
+ if (name->vtype != TYSUBR) {
+ if (name->vinfproc && !name->vcalled) {
+ name->vtype = TYSUBR;
+ frexpr(name->vleng);
+ name->vleng = 0;
+ }
+ else if (!name->vimpltype && name->vtype != TYUNKNOWN)
+ mixed_type(name);
+ else
+ settype(name, TYSUBR, (ftnint)0);
+ }
+ p = mkfunct( mkprim(name, args, CHNULL) );
+
+/* Subroutines and their identifiers acquire the type INT */
+
+ p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
+
+/* Handle the alternate return mechanism */
+
+ if(nstars > 0) {
+ saveargtypes((Exprp)p);
+ putcmgo(p, nstars, labels);
+ } else {
+ putexpr(p);
+ } /* else */
+}
+
+
+
+exstop(stop, p)
+int stop;
+register expptr p;
+{
+ char *str;
+ int n;
+ expptr mkstrcon();
+
+ if(p)
+ {
+ if( ! ISCONST(p) )
+ {
+ execerr("pause/stop argument must be constant", CNULL);
+ frexpr(p);
+ p = mkstrcon(0, CNULL);
+ }
+ else if( ISINT(p->constblock.vtype) )
+ {
+ str = convic(p->constblock.Const.ci);
+ n = strlen(str);
+ if(n > 0)
+ {
+ p->constblock.Const.ccp = copyn(n, str);
+ p->constblock.Const.ccp1.blanks = 0;
+ p->constblock.vtype = TYCHAR;
+ p->constblock.vleng = (expptr) ICON(n);
+ }
+ else
+ p = (expptr) mkstrcon(0, CNULL);
+ }
+ else if(p->constblock.vtype != TYCHAR)
+ {
+ execerr("pause/stop argument must be integer or string", CNULL);
+ p = (expptr) mkstrcon(0, CNULL);
+ }
+ }
+ else p = (expptr) mkstrcon(0, CNULL);
+
+ {
+ expptr subr_call;
+
+ subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
+ putexpr( subr_call );
+ }
+}
+
+/* DO LOOP CODE */
+
+#define DOINIT par[0]
+#define DOLIMIT par[1]
+#define DOINCR par[2]
+
+
+/* Macros for ctlstack -> dostepsign */
+
+#define VARSTEP 0
+#define POSSTEP 1
+#define NEGSTEP 2
+
+
+/* exdo -- generate DO loop code. In the case of a variable increment,
+ positive increment tests are placed above the body, negative increment
+ tests are placed below (see enddo() ) */
+
+exdo(range, loopname, spec)
+int range; /* end label */
+Namep loopname;
+chainp spec; /* input spec must have at least 2 exprs */
+{
+ register expptr p;
+ register Namep np;
+ chainp cp; /* loops over the fields in spec */
+ register int i;
+ int dotype; /* type of the index variable */
+ int incsign; /* sign of the increment, if it's constant
+ */
+ Addrp dovarp; /* loop index variable */
+ expptr doinit; /* constant or register for init param */
+ expptr par[3]; /* local specification parameters */
+
+ expptr init, test, inc; /* Expressions in the resulting FOR loop */
+
+
+ test = ENULL;
+
+ pushctl(CTLDO);
+ dorange = ctlstack->dolabel = range;
+ ctlstack->loopname = loopname;
+
+/* Declare the loop index */
+
+ np = (Namep)spec->datap;
+ ctlstack->donamep = NULL;
+ if (!np) { /* do while */
+ ctlstack->dowhile = 1;
+#if 0
+ if (loopname) {
+ if (loopname->vtype == TYUNKNOWN) {
+ loopname->vdcldone = 1;
+ loopname->vclass = CLLABEL;
+ loopname->vprocclass = PLABEL;
+ loopname->vtype = TYLABEL;
+ }
+ if (loopname->vtype == TYLABEL)
+ if (loopname->vdovar)
+ dclerr("already in use as a loop name",
+ loopname);
+ else
+ loopname->vdovar = 1;
+ else
+ dclerr("already declared; cannot be a loop name",
+ loopname);
+ }
+#endif
+ putwhile((expptr)spec->nextp);
+ NOEXT("do while");
+ spec->nextp = 0;
+ frchain(&spec);
+ return;
+ }
+ if(np->vdovar)
+ {
+ errstr("nested loops with variable %s", np->fvarname);
+ ctlstack->donamep = NULL;
+ return;
+ }
+
+/* Create a memory-resident version of the index variable */
+
+ dovarp = mkplace(np);
+ if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
+ {
+ err("bad type on do variable");
+ return;
+ }
+ ctlstack->donamep = np;
+
+ np->vdovar = YES;
+
+/* Now dovarp points to the index to be used within the loop, dostgp
+ points to the one which may need to be stored */
+
+ dotype = dovarp->vtype;
+
+/* Count the input specifications and type-check each one independently;
+ this just eliminates non-numeric values from the specification */
+
+ for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
+ {
+ p = par[i++] = fixtype((tagptr)cp->datap);
+ if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
+ {
+ err("bad type on DO parameter");
+ return;
+ }
+ }
+
+ frchain(&spec);
+ switch(i)
+ {
+ case 0:
+ case 1:
+ err("too few DO parameters");
+ return;
+
+ default:
+ err("too many DO parameters");
+ return;
+
+ case 2:
+ DOINCR = (expptr) ICON(1);
+
+ case 3:
+ break;
+ }
+
+
+/* Now all of the local specification fields are set, but their types are
+ not yet consistent */
+
+/* Declare the loop initialization value, casting it properly and declaring a
+ register if need be */
+
+ if (ISCONST (DOINIT) || !onetripflag)
+/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
+ since mkconv is called just before */
+ doinit = putx (mkconv (dotype, DOINIT));
+ else {
+ doinit = (expptr) Mktemp(dotype, ENULL);
+ puteq (cpexpr (doinit), DOINIT);
+ } /* else */
+
+/* Declare the loop ending value, casting it to the type of the index
+ variable */
+
+ if( ISCONST(DOLIMIT) )
+ ctlstack->domax = mkconv(dotype, DOLIMIT);
+ else {
+ ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
+ puteq (cpexpr (ctlstack -> domax), DOLIMIT);
+ } /* else */
+
+/* Declare the loop increment value, casting it to the type of the index
+ variable */
+
+ if( ISCONST(DOINCR) )
+ {
+ ctlstack->dostep = mkconv(dotype, DOINCR);
+ if( (incsign = conssgn(ctlstack->dostep)) == 0)
+ err("zero DO increment");
+ ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
+ }
+ else
+ {
+ ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
+ ctlstack->dostepsign = VARSTEP;
+ puteq (cpexpr (ctlstack -> dostep), DOINCR);
+ }
+
+/* All data is now properly typed and in the ctlstack, except for the
+ initial value. Assignments of temps have been generated already */
+
+ switch (ctlstack -> dostepsign) {
+ case VARSTEP:
+ test = mkexpr (OPQUEST, mkexpr (OPLT,
+ cpexpr (ctlstack -> dostep), ICON(0)),
+ mkexpr (OPCOLON,
+ mkexpr (OPGE, cpexpr((expptr)dovarp),
+ cpexpr (ctlstack -> domax)),
+ mkexpr (OPLE, cpexpr((expptr)dovarp),
+ cpexpr (ctlstack -> domax))));
+ break;
+ case POSSTEP:
+ test = mkexpr (OPLE, cpexpr((expptr)dovarp),
+ cpexpr (ctlstack -> domax));
+ break;
+ case NEGSTEP:
+ test = mkexpr (OPGE, cpexpr((expptr)dovarp),
+ cpexpr (ctlstack -> domax));
+ break;
+ default:
+ erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign);
+ break;
+ } /* switch (ctlstack -> dostepsign) */
+
+ if (onetripflag)
+ test = mkexpr (OPOR, test,
+ mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
+ init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
+ inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
+
+ if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
+ && ctlstack -> dostepsign != VARSTEP) {
+ expptr tester;
+
+ tester = mkexpr (OPMINUS, cpexpr (doinit),
+ cpexpr (ctlstack -> domax));
+ if (incsign == conssgn (tester))
+ warn ("DO range never executed");
+ frexpr (tester);
+ } /* if !onetripflag && */
+
+ p1_for (init, test, inc);
+}
+
+exenddo(np)
+ Namep np;
+{
+ Namep np1;
+ int here;
+ struct Ctlframe *cf;
+
+ if( ctlstack < ctls )
+ Fatal("control stack empty");
+ here = ctlstack->dolabel;
+ if (ctlstack->ctltype != CTLDO || here >= 0) {
+ err("misplaced ENDDO");
+ return;
+ }
+ if (np != ctlstack->loopname) {
+ if (np1 = ctlstack->loopname)
+ errstr("expected \"enddo %s\"", np1->fvarname);
+ else
+ err("expected unnamed ENDDO");
+ for(cf = ctls; cf < ctlstack; cf++)
+ if (cf->ctltype == CTLDO && cf->loopname == np) {
+ here = cf->dolabel;
+ break;
+ }
+ }
+ enddo(here);
+ }
+
+
+enddo(here)
+int here;
+{
+ register struct Ctlframe *q;
+ Namep np; /* name of the current DO index */
+ Addrp ap;
+ register int i;
+ register expptr e;
+
+/* Many DO's can end at the same statement, so keep looping over all
+ nested indicies */
+
+ while(here == dorange)
+ {
+ if(np = ctlstack->donamep)
+ {
+ p1for_end ();
+
+/* Now we're done with all of the tests, and the loop has terminated.
+ Store the index value back in long-term memory */
+
+ if(ap = memversion(np))
+ puteq((expptr)ap, (expptr)mkplace(np));
+ for(i = 0 ; i < 4 ; ++i)
+ ctlstack->ctlabels[i] = 0;
+ deregister(ctlstack->donamep);
+ ctlstack->donamep->vdovar = NO;
+ e = ctlstack->dostep;
+ if (e->tag == TADDR && e->addrblock.istemp)
+ frtemp((Addrp)e);
+ else
+ frexpr(e);
+ e = ctlstack->domax;
+ if (e->tag == TADDR && e->addrblock.istemp)
+ frtemp((Addrp)e);
+ else
+ frexpr(e);
+ }
+ else if (ctlstack->dowhile)
+ p1for_end ();
+
+/* Set dorange to the closing label of the next most enclosing DO loop
+ */
+
+ popctl();
+ poplab();
+ dorange = 0;
+ for(q = ctlstack ; q>=ctls ; --q)
+ if(q->ctltype == CTLDO)
+ {
+ dorange = q->dolabel;
+ break;
+ }
+ }
+}
+
+exassign(vname, labelval)
+ register Namep vname;
+struct Labelblock *labelval;
+{
+ Addrp p;
+ expptr mkaddcon();
+ register Addrp q;
+ static char nullstr[] = "";
+ char *fs;
+ register chainp cp, cpprev;
+ register ftnint k, stno;
+
+ p = mkplace(vname);
+ if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
+ err("noninteger assign variable");
+ return;
+ }
+
+ /* If the label hasn't been defined, then we do things twice:
+ * once for an executable stmt label, once for a format
+ */
+
+ /* code for executable label... */
+
+/* Now store the assigned value in a list associated with this variable.
+ This will be used later to generate a switch() statement in the C output */
+
+ if (!labelval->labdefined || !labelval->fmtstring) {
+
+ if (vname -> vis_assigned == 0) {
+ vname -> varxptr.assigned_values = CHNULL;
+ vname -> vis_assigned = 1;
+ }
+
+ /* don't duplicate labels... */
+
+ stno = labelval->stateno;
+ cpprev = 0;
+ for(k = 0, cp = vname->varxptr.assigned_values;
+ cp; cpprev = cp, cp = cp->nextp, k++)
+ if ((ftnint)cp->datap == stno)
+ break;
+ if (!cp) {
+ cp = mkchain((char *)stno, CHNULL);
+ if (cpprev)
+ cpprev->nextp = cp;
+ else
+ vname->varxptr.assigned_values = cp;
+ labelval->labused = 1;
+ }
+ putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
+ }
+
+ /* Code for FORMAT label... */
+
+ fs = labelval->fmtstring;
+ if (!labelval->labdefined || fs && fs != nullstr) {
+ extern void fmtname();
+
+ if (!fs)
+ labelval->fmtstring = nullstr;
+ labelval->fmtlabused = 1;
+ p = ALLOC(Addrblock);
+ p->tag = TADDR;
+ p->vtype = TYCHAR;
+ p->vstg = STGAUTO;
+ p->memoffset = ICON(0);
+ fmtname(vname, p);
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ q->vtype = TYCHAR;
+ q->vstg = STGAUTO;
+ q->ntempelt = 1;
+ q->memoffset = ICON(0);
+ q->uname_tag = UNAM_IDENT;
+ sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
+ putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
+ }
+
+} /* exassign */
+
+
+
+exarif(expr, neglab, zerlab, poslab)
+expptr expr;
+struct Labelblock *neglab, *zerlab, *poslab;
+{
+ register int lm, lz, lp;
+
+ lm = neglab->stateno;
+ lz = zerlab->stateno;
+ lp = poslab->stateno;
+ expr = fixtype(expr);
+
+ if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
+ {
+ err("invalid type of arithmetic if expression");
+ frexpr(expr);
+ }
+ else
+ {
+ if (lm == lz && lz == lp)
+ exgoto (neglab);
+ else if(lm == lz)
+ exar2(OPLE, expr, neglab, poslab);
+ else if(lm == lp)
+ exar2(OPNE, expr, neglab, zerlab);
+ else if(lz == lp)
+ exar2(OPGE, expr, zerlab, neglab);
+ else {
+ expptr t;
+
+ if (!addressable (expr)) {
+ t = (expptr) Mktemp(expr -> headblock.vtype, ENULL);
+ expr = mkexpr (OPASSIGN, cpexpr (t), expr);
+ } else
+ t = (expptr) cpexpr (expr);
+
+ p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
+ exgoto(neglab);
+ p1_elif (mkexpr (OPEQ, t, ICON (0)));
+ exgoto(zerlab);
+ p1_else ();
+ exgoto(poslab);
+ p1else_end ();
+ } /* else */
+ }
+}
+
+
+
+/* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0)
+ goto l2 else goto l1. If this seems backwards, that's because it is,
+ in order to make the 1 pass algorithm work. */
+
+ LOCAL void
+exar2(op, e, l1, l2)
+ int op;
+ expptr e;
+ struct Labelblock *l1, *l2;
+{
+ expptr comp;
+
+ comp = mkexpr (op, e, ICON (0));
+ p1_if(putx(fixtype(comp)));
+ exgoto(l1);
+ p1_else ();
+ exgoto(l2);
+ p1else_end ();
+}
+
+
+/* exreturn -- return the value in p from a SUBROUTINE call -- used to
+ implement the alternate return mechanism */
+
+exreturn(p)
+register expptr p;
+{
+ if(procclass != CLPROC)
+ warn("RETURN statement in main or block data");
+ if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
+ {
+ err("alternate return in nonsubroutine");
+ p = 0;
+ }
+
+ if (p || proctype == TYSUBR) {
+ if (p == ENULL) p = ICON (0);
+ p = mkconv (TYLONG, fixtype (p));
+ p1_subr_ret (p);
+ } /* if p || proctype == TYSUBR */
+ else
+ p1_subr_ret((expptr)retslot);
+}
+
+
+exasgoto(labvar)
+Namep labvar;
+{
+ register Addrp p;
+ void p1_asgoto();
+
+ p = mkplace(labvar);
+ if( ! ISINT(p->vtype) )
+ err("assigned goto variable must be integer");
+ else {
+ p1_asgoto (p);
+ } /* else */
+}
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+
+LOCAL void conspower(), consbinop(), zdiv();
+LOCAL expptr fold(), mkpower(), stfcall();
+
+typedef struct { double dreal, dimag; } dcomplex;
+
+extern char dflttype[26];
+
+/* little routines to create constant blocks */
+
+Constp mkconst(t)
+register int t;
+{
+ register Constp p;
+
+ p = ALLOC(Constblock);
+ p->tag = TCONST;
+ p->vtype = t;
+ return(p);
+}
+
+
+/* mklogcon -- Make Logical Constant */
+
+expptr mklogcon(l)
+register int l;
+{
+ register Constp p;
+
+ p = mkconst(TYLOGICAL);
+ p->Const.ci = l;
+ return( (expptr) p );
+}
+
+
+
+/* mkintcon -- Make Integer Constant */
+
+expptr mkintcon(l)
+ftnint l;
+{
+ register Constp p;
+
+ p = mkconst(tyint);
+ p->Const.ci = l;
+#ifdef MAXSHORT
+ if(l >= -MAXSHORT && l <= MAXSHORT)
+ p->vtype = TYSHORT;
+#endif
+ return( (expptr) p );
+}
+
+
+
+
+/* mkaddcon -- Make Address Constant, given integer value */
+
+expptr mkaddcon(l)
+register long l;
+{
+ register Constp p;
+
+ p = mkconst(TYADDR);
+ p->Const.ci = l;
+ return( (expptr) p );
+}
+
+
+
+/* mkrealcon -- Make Real Constant. The type t is assumed
+ to be TYREAL or TYDREAL */
+
+expptr mkrealcon(t, d)
+ register int t;
+ char *d;
+{
+ register Constp p;
+
+ p = mkconst(t);
+ p->Const.cds[0] = cds(d,CNULL);
+ p->vstg = 1;
+ return( (expptr) p );
+}
+
+
+/* mkbitcon -- Make bit constant. Reads the input string, which is
+ assumed to correctly specify a number in base 2^shift (where shift
+ is the input parameter). shift may not exceed 4, i.e. only binary,
+ quad, octal and hex bases may be input. Constants may not exceed 32
+ bits, or whatever the size of (struct Constblock).ci may be. */
+
+expptr mkbitcon(shift, leng, s)
+int shift;
+int leng;
+char *s;
+{
+ register Constp p;
+ register long x;
+
+ p = mkconst(TYLONG);
+ x = 0;
+ while(--leng >= 0)
+ if(*s != ' ')
+ x = (x << shift) | hextoi(*s++);
+ /* mwm wanted to change the type to short for short constants,
+ * but this is dangerous -- there is no syntax for long constants
+ * with small values.
+ */
+ p->Const.ci = x;
+ return( (expptr) p );
+}
+
+
+
+
+
+/* mkstrcon -- Make string constant. Allocates storage and initializes
+ the memory for a copy of the input Fortran-string. */
+
+expptr mkstrcon(l,v)
+int l;
+register char *v;
+{
+ register Constp p;
+ register char *s;
+
+ p = mkconst(TYCHAR);
+ p->vleng = ICON(l);
+ p->Const.ccp = s = (char *) ckalloc(l+1);
+ p->Const.ccp1.blanks = 0;
+ while(--l >= 0)
+ *s++ = *v++;
+ *s = '\0';
+ return( (expptr) p );
+}
+
+
+
+/* mkcxcon -- Make complex contsant. A complex number is a pair of
+ values, each of which may be integer, real or double. */
+
+expptr mkcxcon(realp,imagp)
+register expptr realp, imagp;
+{
+ int rtype, itype;
+ register Constp p;
+ expptr errnode();
+
+ rtype = realp->headblock.vtype;
+ itype = imagp->headblock.vtype;
+
+ if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
+ {
+ p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
+ ? TYDCOMPLEX : TYCOMPLEX);
+ if (realp->constblock.vstg || imagp->constblock.vstg) {
+ p->vstg = 1;
+ p->Const.cds[0] = ISINT(rtype)
+ ? string_num("", realp->constblock.Const.ci)
+ : realp->constblock.vstg
+ ? realp->constblock.Const.cds[0]
+ : dtos(realp->constblock.Const.cd[0]);
+ p->Const.cds[1] = ISINT(itype)
+ ? string_num("", imagp->constblock.Const.ci)
+ : imagp->constblock.vstg
+ ? imagp->constblock.Const.cds[0]
+ : dtos(imagp->constblock.Const.cd[0]);
+ }
+ else {
+ p->Const.cd[0] = ISINT(rtype)
+ ? realp->constblock.Const.ci
+ : realp->constblock.Const.cd[0];
+ p->Const.cd[1] = ISINT(itype)
+ ? imagp->constblock.Const.ci
+ : imagp->constblock.Const.cd[0];
+ }
+ }
+ else
+ {
+ err("invalid complex constant");
+ p = (Constp)errnode();
+ }
+
+ frexpr(realp);
+ frexpr(imagp);
+ return( (expptr) p );
+}
+
+
+/* errnode -- Allocate a new error block */
+
+expptr errnode()
+{
+ struct Errorblock *p;
+ p = ALLOC(Errorblock);
+ p->tag = TERROR;
+ p->vtype = TYERROR;
+ return( (expptr) p );
+}
+
+
+
+
+
+/* mkconv -- Make type conversion. Cast expression p into type t.
+ Note that casting to a character copies only the first sizeof(char)
+ bytes. */
+
+expptr mkconv(t, p)
+register int t;
+register expptr p;
+{
+ register expptr q;
+ register int pt;
+ expptr opconv();
+
+ if(t==TYUNKNOWN || t==TYERROR)
+ badtype("mkconv", t);
+ pt = p->headblock.vtype;
+
+/* Casting to the same type is a no-op */
+
+ if(t == pt)
+ return(p);
+
+/* If we're casting a constant which is not in the literal table ... */
+
+ else if( ISCONST(p) && pt!=TYADDR)
+ {
+ if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
+ /* avoid trouble with -i2 */
+ p->headblock.vtype = t;
+ return p;
+ }
+ q = (expptr) mkconst(t);
+ consconv(t, &q->constblock, &p->constblock );
+ frexpr(p);
+ }
+ else
+ q = opconv(p, t);
+
+ if(t == TYCHAR)
+ q->constblock.vleng = ICON(1);
+ return(q);
+}
+
+
+
+/* opconv -- Convert expression p to type t using the main
+ expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */
+
+expptr opconv(p, t)
+expptr p;
+int t;
+{
+ register expptr q;
+
+ q = mkexpr(OPCONV, p, ENULL);
+ q->headblock.vtype = t;
+ return(q);
+}
+
+
+
+/* addrof -- Create an ADDR expression operation */
+
+expptr addrof(p)
+expptr p;
+{
+ return( mkexpr(OPADDR, p, ENULL) );
+}
+
+
+
+/* cpexpr - Returns a new copy of input expression p */
+
+tagptr cpexpr(p)
+register tagptr p;
+{
+ register tagptr e;
+ int tag;
+ register chainp ep, pp;
+ tagptr cpblock();
+
+/* This table depends on the ordering of the TY macros, e.g. TYUNKNOWN */
+
+ static int blksize[ ] =
+ {
+ 0,
+ sizeof(struct Nameblock),
+ sizeof(struct Constblock),
+ sizeof(struct Exprblock),
+ sizeof(struct Addrblock),
+ sizeof(struct Primblock),
+ sizeof(struct Listblock),
+ sizeof(struct Errorblock)
+ };
+
+ if(p == NULL)
+ return(NULL);
+
+/* TNAMEs are special, and don't get copied. Each name in the current
+ symbol table has a unique TNAME structure. */
+
+ if( (tag = p->tag) == TNAME)
+ return(p);
+
+ e = cpblock(blksize[p->tag], (char *)p);
+
+ switch(tag)
+ {
+ case TCONST:
+ if(e->constblock.vtype == TYCHAR)
+ {
+ e->constblock.Const.ccp =
+ copyn((int)e->constblock.vleng->constblock.Const.ci+1,
+ e->constblock.Const.ccp);
+ e->constblock.vleng =
+ (expptr) cpexpr(e->constblock.vleng);
+ }
+ case TERROR:
+ break;
+
+ case TEXPR:
+ e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp);
+ e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
+ break;
+
+ case TLIST:
+ if(pp = p->listblock.listp)
+ {
+ ep = e->listblock.listp =
+ mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
+ for(pp = pp->nextp ; pp ; pp = pp->nextp)
+ ep = ep->nextp =
+ mkchain((char *)cpexpr((tagptr)pp->datap),
+ CHNULL);
+ }
+ break;
+
+ case TADDR:
+ e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng);
+ e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
+ e->addrblock.istemp = NO;
+ break;
+
+ case TPRIM:
+ e->primblock.argsp = (struct Listblock *)
+ cpexpr((expptr)e->primblock.argsp);
+ e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
+ e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
+ break;
+
+ default:
+ badtag("cpexpr", tag);
+ }
+
+ return(e);
+}
+
+/* frexpr -- Free expression -- frees up memory used by expression p */
+
+frexpr(p)
+register tagptr p;
+{
+ register chainp q;
+
+ if(p == NULL)
+ return;
+
+ switch(p->tag)
+ {
+ case TCONST:
+ if( ISCHAR(p) )
+ {
+ free( (charptr) (p->constblock.Const.ccp) );
+ frexpr(p->constblock.vleng);
+ }
+ break;
+
+ case TADDR:
+ if (p->addrblock.vtype > TYERROR) /* i/o block */
+ break;
+ frexpr(p->addrblock.vleng);
+ frexpr(p->addrblock.memoffset);
+ break;
+
+ case TERROR:
+ break;
+
+/* TNAME blocks don't get free'd - probably because they're pointed to in
+ the hash table. 14-Jun-88 -- mwm */
+
+ case TNAME:
+ return;
+
+ case TPRIM:
+ frexpr((expptr)p->primblock.argsp);
+ frexpr(p->primblock.fcharp);
+ frexpr(p->primblock.lcharp);
+ break;
+
+ case TEXPR:
+ frexpr(p->exprblock.leftp);
+ if(p->exprblock.rightp)
+ frexpr(p->exprblock.rightp);
+ break;
+
+ case TLIST:
+ for(q = p->listblock.listp ; q ; q = q->nextp)
+ frexpr((tagptr)q->datap);
+ frchain( &(p->listblock.listp) );
+ break;
+
+ default:
+ badtag("frexpr", p->tag);
+ }
+
+ free( (charptr) p );
+}
+
+ void
+wronginf(np)
+ Namep np;
+{
+ int c, k;
+ warn1("fixing wrong type inferred for %.65s", np->fvarname);
+ np->vinftype = 0;
+ c = letter(np->fvarname[0]);
+ if ((np->vtype = impltype[c]) == TYCHAR
+ && (k = implleng[c]))
+ np->vleng = ICON(k);
+ }
+
+/* fix up types in expression; replace subtrees and convert
+ names to address blocks */
+
+expptr fixtype(p)
+register tagptr p;
+{
+
+ if(p == 0)
+ return(0);
+
+ switch(p->tag)
+ {
+ case TCONST:
+ if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
+ MSKREAL) )
+ return( (expptr) p);
+
+ return( (expptr) putconst((Constp)p) );
+
+ case TADDR:
+ p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
+ return( (expptr) p);
+
+ case TERROR:
+ return( (expptr) p);
+
+ default:
+ badtag("fixtype", p->tag);
+
+/* This case means that fixexpr can't call fixtype with any expr,
+ only a subexpr of its parameter. */
+
+ case TEXPR:
+ return( fixexpr((Exprp)p) );
+
+ case TLIST:
+ return( (expptr) p );
+
+ case TPRIM:
+ if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
+ {
+ if(p->primblock.namep->vtype == TYSUBR)
+ {
+ err("function invocation of subroutine");
+ return( errnode() );
+ }
+ else {
+ if (p->primblock.namep->vinftype)
+ wronginf(p->primblock.namep);
+ return( mkfunct(p) );
+ }
+ }
+
+/* The lack of args makes p a function name, substring reference
+ or variable name. */
+
+ else return( mklhs((struct Primblock *) p) );
+ }
+}
+
+
+
+/* special case tree transformations and cleanups of expression trees.
+ Parameter p should have a TEXPR tag at its root, else an error is
+ returned */
+
+expptr fixexpr(p)
+register Exprp p;
+{
+ expptr lp;
+ register expptr rp;
+ register expptr q;
+ int opcode, ltype, rtype, ptype, mtype;
+
+ if( ISERROR(p) )
+ return( (expptr) p );
+ else if(p->tag != TEXPR)
+ badtag("fixexpr", p->tag);
+ opcode = p->opcode;
+
+/* First set the types of the left and right subexpressions */
+
+ lp = p->leftp = fixtype(p->leftp);
+ ltype = lp->headblock.vtype;
+
+ if(opcode==OPASSIGN && lp->tag!=TADDR)
+ {
+ err("left side of assignment must be variable");
+ frexpr((expptr)p);
+ return( errnode() );
+ }
+
+ if(p->rightp)
+ {
+ rp = p->rightp = fixtype(p->rightp);
+ rtype = rp->headblock.vtype;
+ }
+ else
+ {
+ rp = NULL;
+ rtype = 0;
+ }
+
+ if(ltype==TYERROR || rtype==TYERROR)
+ {
+ frexpr((expptr)p);
+ return( errnode() );
+ }
+
+/* Now work on the whole expression */
+
+ /* force folding if possible */
+
+ if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
+ {
+ q = mkexpr(opcode, lp, rp);
+
+/* mkexpr is expected to reduce constant expressions */
+
+ if( ISCONST(q) )
+ return(q);
+ free( (charptr) q ); /* constants did not fold */
+ }
+
+ if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
+ {
+ frexpr((expptr)p);
+ return( errnode() );
+ }
+
+ switch(opcode)
+ {
+ case OPCONCAT:
+ if(p->vleng == NULL)
+ p->vleng = mkexpr(OPPLUS,
+ cpexpr(lp->headblock.vleng),
+ cpexpr(rp->headblock.vleng) );
+ break;
+
+ case OPASSIGN:
+ if (rtype == TYREAL)
+ break;
+ case OPPLUSEQ:
+ case OPSTAREQ:
+ if(ltype == rtype)
+ break;
+ if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
+ break;
+ if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
+ break;
+ if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
+ && typesize[ltype]>=typesize[rtype] )
+ break;
+
+/* Cast the right hand side to match the type of the expression */
+
+ p->rightp = fixtype( mkconv(ptype, rp) );
+ break;
+
+ case OPSLASH:
+ if( ISCOMPLEX(rtype) )
+ {
+ p = (Exprp) call2(ptype,
+
+/* Handle double precision complex variables */
+
+ ptype == TYCOMPLEX ? "c_div" : "z_div",
+ mkconv(ptype, lp), mkconv(ptype, rp) );
+ break;
+ }
+ case OPPLUS:
+ case OPMINUS:
+ case OPSTAR:
+ case OPMOD:
+ if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
+ (rtype==TYREAL && ! ISCONST(rp) ) ))
+ break;
+ if( ISCOMPLEX(ptype) )
+ break;
+
+/* Cast both sides of the expression to match the type of the whole
+ expression. */
+
+ if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL))
+ p->leftp = fixtype(mkconv(ptype,lp));
+ if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL))
+ p->rightp = fixtype(mkconv(ptype,rp));
+ break;
+
+ case OPPOWER:
+ return( mkpower((expptr)p) );
+
+ case OPLT:
+ case OPLE:
+ case OPGT:
+ case OPGE:
+ case OPEQ:
+ case OPNE:
+ if(ltype == rtype)
+ break;
+ mtype = cktype(OPMINUS, ltype, rtype);
+ if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
+ (rtype==TYREAL && ! ISCONST(rp)) ))
+ break;
+ if( ISCOMPLEX(mtype) )
+ break;
+ if(ltype != mtype)
+ p->leftp = fixtype(mkconv(mtype,lp));
+ if(rtype != mtype)
+ p->rightp = fixtype(mkconv(mtype,rp));
+ break;
+
+ case OPCONV:
+ ptype = cktype(OPCONV, p->vtype, ltype);
+ if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
+ {
+ lp->exprblock.rightp =
+ fixtype( mkconv(ptype, lp->exprblock.rightp) );
+ free( (charptr) p );
+ p = (Exprp) lp;
+ }
+ break;
+
+ case OPADDR:
+ if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
+ Fatal("addr of addr");
+ break;
+
+ case OPCOMMA:
+ case OPQUEST:
+ case OPCOLON:
+ break;
+
+ case OPMIN:
+ case OPMAX:
+ case OPMIN2:
+ case OPMAX2:
+ case OPDMIN:
+ case OPDMAX:
+ case OPABS:
+ case OPDABS:
+ ptype = p->vtype;
+ break;
+
+ default:
+ break;
+ }
+
+ p->vtype = ptype;
+ return((expptr) p);
+}
+
+
+/* fix an argument list, taking due care for special first level cases */
+
+fixargs(doput, p0)
+int doput; /* doput is true if constants need to be passed by reference */
+struct Listblock *p0;
+{
+ register chainp p;
+ register tagptr q, t;
+ register int qtag;
+ int nargs;
+ Addrp mkscalar();
+
+ nargs = 0;
+ if(p0)
+ for(p = p0->listp ; p ; p = p->nextp)
+ {
+ ++nargs;
+ q = (tagptr)p->datap;
+ qtag = q->tag;
+ if(qtag == TCONST)
+ {
+ if(q->constblock.vtype == TYSHORT)
+ q = (tagptr) mkconv(tyint, q);
+/* leave constant arguments of intrinsics alone --
+ * the expression might still simplify.
+ */
+
+/* Call putconst() to store values in a constant table. Since even
+ constants must be passed by reference, this can optimize on the storage
+ required */
+
+ p->datap = doput ? (char *)putconst((Constp)q)
+ : (char *)q;
+ }
+
+/* Take a function name and turn it into an Addr. This only happens when
+ nothing else has figured out the function beforehand */
+
+ else if(qtag==TPRIM && q->primblock.argsp==0 &&
+ q->primblock.namep->vclass==CLPROC &&
+ q->primblock.namep->vprocclass != PTHISPROC)
+ p->datap = (char *)mkaddr(q->primblock.namep);
+
+ else if(qtag==TPRIM && q->primblock.argsp==0 &&
+ q->primblock.namep->vdim!=NULL)
+ p->datap = (char *)mkscalar(q->primblock.namep);
+
+ else if(qtag==TPRIM && q->primblock.argsp==0 &&
+ q->primblock.namep->vdovar &&
+ (t = (tagptr) memversion(q->primblock.namep)) )
+ p->datap = (char *)fixtype(t);
+ else
+ p->datap = (char *)fixtype(q);
+ }
+ return(nargs);
+}
+
+
+
+/* mkscalar -- only called by fixargs above, and by some routines in
+ io.c */
+
+Addrp mkscalar(np)
+register Namep np;
+{
+ register Addrp ap;
+
+ vardcl(np);
+ ap = mkaddr(np);
+
+ /* The prolog causes array arguments to point to the
+ * (0,...,0) element, unless subscript checking is on.
+ */
+ if( !checksubs && np->vstg==STGARG)
+ {
+ register struct Dimblock *dp;
+ dp = np->vdim;
+ frexpr(ap->memoffset);
+ ap->memoffset = mkexpr(OPSTAR,
+ (np->vtype==TYCHAR ?
+ cpexpr(np->vleng) :
+ (tagptr)ICON(typesize[np->vtype]) ),
+ cpexpr(dp->baseoffset) );
+ }
+ return(ap);
+}
+
+
+ static void
+adjust_arginfo(np) /* adjust arginfo to omit the length arg for the
+ arg that we now know to be a character-valued
+ function */
+ register Namep np;
+{
+ struct Entrypoint *ep;
+ register chainp args;
+ Argtypes *at;
+
+ for(ep = entries; ep; ep = ep->entnextp)
+ for(args = ep->arglist; args; args = args->nextp)
+ if (np == (Namep)args->datap
+ && (at = ep->entryname->arginfo))
+ --at->nargs;
+ }
+
+
+
+expptr mkfunct(p0)
+ expptr p0;
+{
+ register struct Primblock *p = (struct Primblock *)p0;
+ struct Entrypoint *ep;
+ Addrp ap;
+ Extsym *extp;
+ register Namep np;
+ register expptr q;
+ expptr intrcall();
+ extern chainp new_procs;
+ int k, nargs;
+ int class;
+
+ if(p->tag != TPRIM)
+ return( errnode() );
+
+ np = p->namep;
+ class = np->vclass;
+
+
+ if(class == CLUNKNOWN)
+ {
+ np->vclass = class = CLPROC;
+ if(np->vstg == STGUNKNOWN)
+ {
+ if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
+ && (zflag || !(*(struct Intrpacked *)&k).f4
+ || dcomplex_seen))
+ {
+ np->vstg = STGINTR;
+ np->vardesc.varno = k;
+ np->vprocclass = PINTRINSIC;
+ }
+ else
+ {
+ extp = mkext(np->fvarname,
+ addunder(np->cvarname));
+ extp->extstg = STGEXT;
+ np->vstg = STGEXT;
+ np->vardesc.varno = extp - extsymtab;
+ np->vprocclass = PEXTERNAL;
+ }
+ }
+ else if(np->vstg==STGARG)
+ {
+ if(np->vtype == TYCHAR) {
+ adjust_arginfo(np);
+ if (np->vpassed) {
+ char wbuf[160], *who;
+ who = np->fvarname;
+ sprintf(wbuf, "%s%s%s\n\t%s%s%s",
+ "Character-valued dummy procedure ",
+ who, " not declared EXTERNAL.",
+ "Code may be wrong for previous function calls having ",
+ who, " as a parameter.");
+ warn(wbuf);
+ }
+ }
+ np->vprocclass = PEXTERNAL;
+ }
+ }
+
+ if(class != CLPROC)
+ fatali("invalid class code %d for function", class);
+
+/* F77 doesn't allow subscripting of function calls */
+
+ if(p->fcharp || p->lcharp)
+ {
+ err("no substring of function call");
+ goto error;
+ }
+ impldcl(np);
+ np->vimpltype = 0; /* invoking as function ==> inferred type */
+ np->vcalled = 1;
+ nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp);
+
+ switch(np->vprocclass)
+ {
+ case PEXTERNAL:
+ if(np->vtype == TYUNKNOWN)
+ {
+ dclerr("attempt to use untyped function", np);
+ np->vtype = dflttype[letter(np->fvarname[0])];
+ }
+ ap = mkaddr(np);
+ if (!extsymtab[np->vardesc.varno].extseen) {
+ new_procs = mkchain((char *)np, new_procs);
+ extsymtab[np->vardesc.varno].extseen = 1;
+ }
+call:
+ q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
+ q->exprblock.vtype = np->vtype;
+ if(np->vleng)
+ q->exprblock.vleng = (expptr) cpexpr(np->vleng);
+ break;
+
+ case PINTRINSIC:
+ q = intrcall(np, p->argsp, nargs);
+ break;
+
+ case PSTFUNCT:
+ q = stfcall(np, p->argsp);
+ break;
+
+ case PTHISPROC:
+ warn("recursive call");
+
+/* entries is the list of multiple entry points */
+
+ for(ep = entries ; ep ; ep = ep->entnextp)
+ if(ep->enamep == np)
+ break;
+ if(ep == NULL)
+ Fatal("mkfunct: impossible recursion");
+
+ ap = builtin(np->vtype, ep->entryname->cextname, -2);
+ /* the negative last arg prevents adding */
+ /* this name to the list of used builtins */
+ goto call;
+
+ default:
+ fatali("mkfunct: impossible vprocclass %d",
+ (int) (np->vprocclass) );
+ }
+ free( (charptr) p );
+ return(q);
+
+error:
+ frexpr((expptr)p);
+ return( errnode() );
+}
+
+
+
+LOCAL expptr stfcall(np, actlist)
+Namep np;
+struct Listblock *actlist;
+{
+ register chainp actuals;
+ int nargs;
+ chainp oactp, formals;
+ int type;
+ expptr q, rhs, ap;
+ Namep tnp;
+ register struct Rplblock *rp;
+ struct Rplblock *tlist;
+
+ if(actlist)
+ {
+ actuals = actlist->listp;
+ free( (charptr) actlist);
+ }
+ else
+ actuals = NULL;
+ oactp = actuals;
+
+ nargs = 0;
+ tlist = NULL;
+ if( (type = np->vtype) == TYUNKNOWN)
+ {
+ dclerr("attempt to use untyped statement function", np);
+ type = np->vtype = dflttype[letter(np->fvarname[0])];
+ }
+ formals = (chainp) np->varxptr.vstfdesc->datap;
+ rhs = (expptr) (np->varxptr.vstfdesc->nextp);
+
+ /* copy actual arguments into temporaries */
+ while(actuals!=NULL && formals!=NULL)
+ {
+ rp = ALLOC(Rplblock);
+ rp->rplnp = tnp = (Namep) formals->datap;
+ ap = fixtype((tagptr)actuals->datap);
+ if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
+ && (ap->tag==TCONST || ap->tag==TADDR) )
+ {
+
+/* If actuals are constants or variable names, no temporaries are required */
+ rp->rplvp = (expptr) ap;
+ rp->rplxp = NULL;
+ rp->rpltag = ap->tag;
+ }
+ else {
+ rp->rplvp = (expptr) Mktemp(tnp->vtype, tnp->vleng);
+ rp -> rplxp = NULL;
+ putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
+ if((rp->rpltag = rp->rplvp->tag) == TERROR)
+ err("disagreement of argument types in statement function call");
+ }
+ rp->rplnextp = tlist;
+ tlist = rp;
+ actuals = actuals->nextp;
+ formals = formals->nextp;
+ ++nargs;
+ }
+
+ if(actuals!=NULL || formals!=NULL)
+ err("statement function definition and argument list differ");
+
+ /*
+ now push down names involved in formal argument list, then
+ evaluate rhs of statement function definition in this environment
+*/
+
+ if(tlist) /* put tlist in front of the rpllist */
+ {
+ for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
+ ;
+ rp->rplnextp = rpllist;
+ rpllist = tlist;
+ }
+
+/* So when the expression finally gets evaled, that evaluator must read
+ from the globl rpllist 14-jun-88 mwm */
+
+ q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
+
+ /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
+ while(--nargs >= 0)
+ {
+ if(rpllist->rplxp)
+ q = mkexpr(OPCOMMA, rpllist->rplxp, q);
+ rp = rpllist->rplnextp;
+ frexpr(rpllist->rplvp);
+ free((char *)rpllist);
+ rpllist = rp;
+ }
+ frchain( &oactp );
+ return(q);
+}
+
+
+static int replaced;
+
+/* mkplace -- Figure out the proper storage class for the input name and
+ return an addrp with the appropriate stuff */
+
+Addrp mkplace(np)
+register Namep np;
+{
+ register Addrp s;
+ register struct Rplblock *rp;
+ int regn;
+
+ /* is name on the replace list? */
+
+ for(rp = rpllist ; rp ; rp = rp->rplnextp)
+ {
+ if(np == rp->rplnp)
+ {
+ replaced = 1;
+ if(rp->rpltag == TNAME)
+ {
+ np = (Namep) (rp->rplvp);
+ break;
+ }
+ else return( (Addrp) cpexpr(rp->rplvp) );
+ }
+ }
+
+ /* is variable a DO index in a register ? */
+
+ if(np->vdovar && ( (regn = inregister(np)) >= 0) )
+ if(np->vtype == TYERROR)
+ return((Addrp) errnode() );
+ else
+ {
+ s = ALLOC(Addrblock);
+ s->tag = TADDR;
+ s->vstg = STGREG;
+ s->vtype = TYIREG;
+ s->memno = regn;
+ s->memoffset = ICON(0);
+ s -> uname_tag = UNAM_NAME;
+ s -> user.name = np;
+ return(s);
+ }
+
+ vardcl(np);
+ return(mkaddr(np));
+}
+
+
+ static int doing_vleng;
+
+/* mklhs -- Compute the actual address of the given expression; account
+ for array subscripts, stack offset, and substring offsets. The f -> C
+ translator will need this only to worry about the subscript stuff */
+
+expptr mklhs(p)
+register struct Primblock *p;
+{
+ expptr suboffset();
+ register Addrp s;
+ Namep np;
+
+ if(p->tag != TPRIM)
+ return( (expptr) p );
+ np = p->namep;
+
+ replaced = 0;
+ s = mkplace(np);
+ if(s->tag!=TADDR || s->vstg==STGREG)
+ {
+ free( (charptr) p );
+ return( (expptr) s );
+ }
+
+ /* compute the address modified by subscripts */
+
+ if (!replaced)
+ s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
+ frexpr((expptr)p->argsp);
+ p->argsp = NULL;
+
+ /* now do substring part */
+
+ if(p->fcharp || p->lcharp)
+ {
+ if(np->vtype != TYCHAR)
+ errstr("substring of noncharacter %s", np->fvarname);
+ else {
+ if(p->lcharp == NULL)
+ p->lcharp = (expptr) cpexpr(s->vleng);
+ if(p->fcharp) {
+ doing_vleng = 1;
+ s->vleng = fixtype(mkexpr(OPMINUS,
+ p->lcharp,
+ mkexpr(OPMINUS, p->fcharp, ICON(1) )));
+ doing_vleng = 0;
+ }
+ else {
+ frexpr(s->vleng);
+ s->vleng = p->lcharp;
+ }
+ }
+ }
+
+ s->vleng = fixtype( s->vleng );
+ s->memoffset = fixtype( s->memoffset );
+ free( (charptr) p );
+ return( (expptr) s );
+}
+
+
+
+
+
+/* deregister -- remove a register allocation from the list; assumes that
+ names are deregistered in stack order (LIFO order - Last In First Out) */
+
+deregister(np)
+Namep np;
+{
+ if(nregvar>0 && regnamep[nregvar-1]==np)
+ {
+ --nregvar;
+ }
+}
+
+
+
+
+/* memversion -- moves a DO index REGISTER into a memory location; other
+ objects are passed through untouched */
+
+Addrp memversion(np)
+register Namep np;
+{
+ register Addrp s;
+
+ if(np->vdovar==NO || (inregister(np)<0) )
+ return(NULL);
+ np->vdovar = NO;
+ s = mkplace(np);
+ np->vdovar = YES;
+ return(s);
+}
+
+
+
+/* inregister -- looks for the input name in the global list regnamep */
+
+inregister(np)
+register Namep np;
+{
+ register int i;
+
+ for(i = 0 ; i < nregvar ; ++i)
+ if(regnamep[i] == np)
+ return( regnum[i] );
+ return(-1);
+}
+
+
+
+/* suboffset -- Compute the offset from the start of the array, given the
+ subscripts as arguments */
+
+expptr suboffset(p)
+register struct Primblock *p;
+{
+ int n;
+ expptr si, size;
+ chainp cp;
+ expptr offp, prod;
+ expptr subcheck();
+ struct Dimblock *dimp;
+ expptr sub[MAXDIM+1];
+ register Namep np;
+
+ np = p->namep;
+ offp = ICON(0);
+ n = 0;
+ if(p->argsp)
+ for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
+ {
+ si = fixtype(cpexpr((tagptr)cp->datap));
+ if (!ISINT(si->headblock.vtype)) {
+ NOEXT("non-integer subscript");
+ si = mkconv(TYLONG, si);
+ }
+ sub[n++] = si;
+ if(n > maxdim)
+ {
+ erri("more than %d subscripts", maxdim);
+ break;
+ }
+ }
+
+ dimp = np->vdim;
+ if(n>0 && dimp==NULL)
+ err("subscripts on scalar variable");
+ else if(dimp && dimp->ndim!=n)
+ errstr("wrong number of subscripts on %s", np->fvarname);
+ else if(n > 0)
+ {
+ prod = sub[--n];
+ while( --n >= 0)
+ prod = mkexpr(OPPLUS, sub[n],
+ mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
+ if(checksubs || np->vstg!=STGARG)
+ prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
+
+/* Add in the run-time bounds check */
+
+ if(checksubs)
+ prod = subcheck(np, prod);
+ size = np->vtype == TYCHAR ?
+ (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
+ prod = mkexpr(OPSTAR, prod, size);
+ offp = mkexpr(OPPLUS, offp, prod);
+ }
+
+/* Check for substring indicator */
+
+ if(p->fcharp && np->vtype==TYCHAR)
+ offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
+
+ return(offp);
+}
+
+
+
+
+expptr subcheck(np, p)
+Namep np;
+register expptr p;
+{
+ struct Dimblock *dimp;
+ expptr t, checkvar, checkcond, badcall;
+
+ dimp = np->vdim;
+ if(dimp->nelt == NULL)
+ return(p); /* don't check arrays with * bounds */
+ np->vlastdim = 0;
+ if( ISICON(p) )
+ {
+
+/* check for negative (constant) offset */
+
+ if(p->constblock.Const.ci < 0)
+ goto badsub;
+ if( ISICON(dimp->nelt) )
+
+/* see if constant offset exceeds the array declaration */
+
+ if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
+ return(p);
+ else
+ goto badsub;
+ }
+
+/* We know that the subscript offset p or dimp -> nelt is not a constant.
+ Now find a register to use for run-time bounds checking */
+
+ if(p->tag==TADDR && p->addrblock.vstg==STGREG)
+ {
+ checkvar = (expptr) cpexpr(p);
+ t = p;
+ }
+ else {
+ checkvar = (expptr) Mktemp(p->headblock.vtype, ENULL);
+ t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
+ }
+ checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
+ if( ! ISICON(p) )
+ checkcond = mkexpr(OPAND, checkcond,
+ mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
+
+/* Construct the actual test */
+
+ badcall = call4(p->headblock.vtype, "s_rnge",
+ mkstrcon(strlen(np->fvarname), np->fvarname),
+ mkconv(TYLONG, cpexpr(checkvar)),
+ mkstrcon(strlen(procname), procname),
+ ICON(lineno) );
+ badcall->exprblock.opcode = OPCCALL;
+ p = mkexpr(OPQUEST, checkcond,
+ mkexpr(OPCOLON, checkvar, badcall));
+
+ return(p);
+
+badsub:
+ frexpr(p);
+ errstr("subscript on variable %s out of range", np->fvarname);
+ return ( ICON(0) );
+}
+
+
+
+
+Addrp mkaddr(p)
+register Namep p;
+{
+ Extsym *extp;
+ register Addrp t;
+ Addrp intraddr();
+ int k;
+
+ switch( p->vstg)
+ {
+ case STGAUTO:
+ if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
+ return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
+ goto other;
+
+ case STGUNKNOWN:
+ if(p->vclass != CLPROC)
+ break; /* Error */
+ extp = mkext(p->fvarname, addunder(p->cvarname));
+ extp->extstg = STGEXT;
+ p->vstg = STGEXT;
+ p->vardesc.varno = extp - extsymtab;
+ p->vprocclass = PEXTERNAL;
+ if ((extp->exproto || infertypes)
+ && (p->vtype == TYUNKNOWN || p->vimpltype)
+ && (k = extp->extype))
+ inferdcl(p, k);
+
+
+ case STGCOMMON:
+ case STGEXT:
+ case STGBSS:
+ case STGINIT:
+ case STGEQUIV:
+ case STGARG:
+ case STGLENG:
+ other:
+ t = ALLOC(Addrblock);
+ t->tag = TADDR;
+
+ t->vclass = p->vclass;
+ t->vtype = p->vtype;
+ t->vstg = p->vstg;
+ t->memno = p->vardesc.varno;
+ t->memoffset = ICON(p->voffset);
+ if (p->vdim)
+ t->isarray = 1;
+ if(p->vleng)
+ {
+ t->vleng = (expptr) cpexpr(p->vleng);
+ if( ISICON(t->vleng) )
+ t->varleng = t->vleng->constblock.Const.ci;
+ }
+
+/* Keep the original name around for the C code generation */
+
+ t -> uname_tag = UNAM_NAME;
+ t -> user.name = p;
+ return(t);
+
+ case STGINTR:
+
+ return ( intraddr (p));
+ }
+ badstg("mkaddr", p->vstg);
+ /* NOT REACHED */ return 0;
+}
+
+
+
+
+/* mkarg -- create storage for a new parameter. This is called when a
+ function returns a string (for the return value, which is the first
+ parameter), or when a variable-length string is passed to a function. */
+
+Addrp mkarg(type, argno)
+int type, argno;
+{
+ register Addrp p;
+
+ p = ALLOC(Addrblock);
+ p->tag = TADDR;
+ p->vtype = type;
+ p->vclass = CLVAR;
+
+/* TYLENG is the type of the field holding the length of a character string */
+
+ p->vstg = (type==TYLENG ? STGLENG : STGARG);
+ p->memno = argno;
+ return(p);
+}
+
+
+
+
+/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
+ Nameblock (or Paramblock), arguments (actual params or array
+ subscripts) and substring bounds. Requires that v have lots of
+ extra (uninitialized) storage, since it could be a paramblock or
+ nameblock */
+
+expptr mkprim(v0, args, substr)
+ Namep v0;
+ struct Listblock *args;
+ chainp substr;
+{
+ typedef union {
+ struct Paramblock paramblock;
+ struct Nameblock nameblock;
+ struct Headblock headblock;
+ } *Primu;
+ register Primu v = (Primu)v0;
+ register struct Primblock *p;
+
+ if(v->headblock.vclass == CLPARAM)
+ {
+
+/* v is to be a Paramblock */
+
+ if(args || substr)
+ {
+ errstr("no qualifiers on parameter name %s",
+ v->paramblock.fvarname);
+ frexpr((expptr)args);
+ if(substr)
+ {
+ frexpr((tagptr)substr->datap);
+ frexpr((tagptr)substr->nextp->datap);
+ frchain(&substr);
+ }
+ frexpr((expptr)v);
+ return( errnode() );
+ }
+ return( (expptr) cpexpr(v->paramblock.paramval) );
+ }
+
+ p = ALLOC(Primblock);
+ p->tag = TPRIM;
+ p->vtype = v->nameblock.vtype;
+
+/* v is to be a Nameblock */
+
+ p->namep = (Namep) v;
+ p->argsp = args;
+ if(substr)
+ {
+ p->fcharp = (expptr) substr->datap;
+ p->lcharp = (expptr) substr->nextp->datap;
+ frchain(&substr);
+ }
+ return( (expptr) p);
+}
+
+
+
+/* vardcl -- attempt to fill out the Name template for variable v.
+ This function is called on identifiers known to be variables or
+ recursive references to the same function */
+
+vardcl(v)
+register Namep v;
+{
+ struct Dimblock *t;
+ expptr neltp;
+ extern int doing_stmtfcn;
+
+ if(v->vclass == CLUNKNOWN)
+ v->vclass = CLVAR;
+ if(v->vdcldone)
+ return;
+ if(v->vclass == CLNAMELIST)
+ return;
+
+ if(v->vtype == TYUNKNOWN)
+ impldcl(v);
+ else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
+ {
+ dclerr("used as variable", v);
+ return;
+ }
+ if(v->vstg==STGUNKNOWN) {
+ if (doing_stmtfcn) {
+ /* neither declare this variable if its only use */
+ /* is in defining a stmt function, nor complain */
+ /* that it is never used */
+ v->vimpldovar = 1;
+ return;
+ }
+ v->vstg = implstg[ letter(v->fvarname[0]) ];
+ v->vimplstg = 1;
+ }
+
+/* Compute the actual storage location, i.e. offsets from base addresses,
+ possibly the stack pointer */
+
+ switch(v->vstg)
+ {
+ case STGBSS:
+ v->vardesc.varno = ++lastvarno;
+ break;
+ case STGAUTO:
+ if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
+ break;
+ if(t = v->vdim)
+ if( (neltp = t->nelt) && ISCONST(neltp) ) ;
+ else
+ dclerr("adjustable automatic array", v);
+ break;
+
+ default:
+ break;
+ }
+ v->vdcldone = YES;
+}
+
+
+
+/* Set the implicit type declaration of parameter p based on its first
+ letter */
+
+impldcl(p)
+register Namep p;
+{
+ register int k;
+ int type;
+ ftnint leng;
+
+ if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
+ return;
+ if(p->vtype == TYUNKNOWN)
+ {
+ k = letter(p->fvarname[0]);
+ type = impltype[ k ];
+ leng = implleng[ k ];
+ if(type == TYUNKNOWN)
+ {
+ if(p->vclass == CLPROC)
+ return;
+ dclerr("attempt to use undefined variable", p);
+ type = dflttype[k];
+ leng = 0;
+ }
+ settype(p, type, leng);
+ p->vimpltype = 1;
+ }
+}
+
+ void
+inferdcl(np,type)
+ Namep np;
+ int type;
+{
+ int k = impltype[letter(np->fvarname[0])];
+ if (k != type) {
+ np->vinftype = 1;
+ np->vtype = type;
+ frexpr(np->vleng);
+ np->vleng = 0;
+ }
+ np->vimpltype = 0;
+ np->vinfproc = 1;
+ }
+
+
+#define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c)
+#define COMMUTE { e = lp; lp = rp; rp = e; }
+
+
+
+/* mkexpr -- Make expression, and simplify constant subcomponents (tree
+ order is not preserved). Assumes that lp is nonempty, and uses
+ fold() to simplify adjacent constants */
+
+expptr mkexpr(opcode, lp, rp)
+int opcode;
+register expptr lp, rp;
+{
+ register expptr e, e1;
+ int etype;
+ int ltype, rtype;
+ int ltag, rtag;
+ long L;
+
+ ltype = lp->headblock.vtype;
+ ltag = lp->tag;
+ if(rp && opcode!=OPCALL && opcode!=OPCCALL)
+ {
+ rtype = rp->headblock.vtype;
+ rtag = rp->tag;
+ }
+ else rtype = 0;
+
+ etype = cktype(opcode, ltype, rtype);
+ if(etype == TYERROR)
+ goto error;
+
+ switch(opcode)
+ {
+ /* check for multiplication by 0 and 1 and addition to 0 */
+
+ case OPSTAR:
+ if( ISCONST(lp) )
+ COMMUTE
+
+ if( ISICON(rp) )
+ {
+ if(rp->constblock.Const.ci == 0)
+ goto retright;
+ goto mulop;
+ }
+ break;
+
+ case OPSLASH:
+ case OPMOD:
+ if( ICONEQ(rp, 0) )
+ {
+ err("attempted division by zero");
+ rp = ICON(1);
+ break;
+ }
+ if(opcode == OPMOD)
+ break;
+
+/* Handle multiplying or dividing by 1, -1 */
+
+mulop:
+ if( ISICON(rp) )
+ {
+ if(rp->constblock.Const.ci == 1)
+ goto retleft;
+
+ if(rp->constblock.Const.ci == -1)
+ {
+ frexpr(rp);
+ return( mkexpr(OPNEG, lp, ENULL) );
+ }
+ }
+
+/* Group all constants together. In particular,
+
+ (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
+ (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
+*/
+
+ if (lp->tag != TEXPR || !lp->exprblock.rightp
+ || !ISICON(lp->exprblock.rightp))
+ break;
+
+ if (lp->exprblock.opcode == OPLSHIFT) {
+ L = 1 << lp->exprblock.rightp->constblock.Const.ci;
+ if (opcode == OPSTAR || ISICON(rp) &&
+ !(L % rp->constblock.Const.ci)) {
+ lp->exprblock.opcode = OPSTAR;
+ lp->exprblock.rightp->constblock.Const.ci = L;
+ }
+ }
+
+ if (lp->exprblock.opcode == OPSTAR) {
+ if(opcode == OPSTAR)
+ e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
+ else if(ISICON(rp) &&
+ (lp->exprblock.rightp->constblock.Const.ci %
+ rp->constblock.Const.ci) == 0)
+ e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
+ else break;
+
+ e1 = lp->exprblock.leftp;
+ free( (charptr) lp );
+ return( mkexpr(OPSTAR, e1, e) );
+ }
+ break;
+
+
+ case OPPLUS:
+ if( ISCONST(lp) )
+ COMMUTE
+ goto addop;
+
+ case OPMINUS:
+ if( ICONEQ(lp, 0) )
+ {
+ frexpr(lp);
+ return( mkexpr(OPNEG, rp, ENULL) );
+ }
+
+ if( ISCONST(rp) && is_negatable((Constp)rp))
+ {
+ opcode = OPPLUS;
+ consnegop((Constp)rp);
+ }
+
+/* Group constants in an addition expression (also subtraction, since the
+ subtracted value was negated above). In particular,
+
+ (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
+*/
+
+addop:
+ if( ISICON(rp) )
+ {
+ if(rp->constblock.Const.ci == 0)
+ goto retleft;
+ if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
+ {
+ e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
+ e1 = lp->exprblock.leftp;
+ free( (charptr) lp );
+ return( mkexpr(OPPLUS, e1, e) );
+ }
+ }
+ if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
+ /* check for (i [+const]) - (i [+const]) */
+ if (lp->tag == TPRIM)
+ e = lp;
+ else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
+ && lp->exprblock.rightp->tag == TCONST) {
+ e = lp->exprblock.leftp;
+ if (e->tag != TPRIM)
+ break;
+ }
+ else
+ break;
+ if (e->primblock.argsp)
+ break;
+ if (rp->tag == TPRIM)
+ e1 = rp;
+ else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
+ && rp->exprblock.rightp->tag == TCONST) {
+ e1 = rp->exprblock.leftp;
+ if (e1->tag != TPRIM)
+ break;
+ }
+ else
+ break;
+ if (e->primblock.namep != e1->primblock.namep
+ || e1->primblock.argsp)
+ break;
+ L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
+ if (e1 != rp)
+ L -= rp->exprblock.rightp->constblock.Const.ci;
+ frexpr(lp);
+ frexpr(rp);
+ return ICON(L);
+ }
+
+ break;
+
+
+ case OPPOWER:
+ break;
+
+/* Eliminate outermost double negations */
+
+ case OPNEG:
+ case OPNEG1:
+ if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
+ {
+ e = lp->exprblock.leftp;
+ free( (charptr) lp );
+ return(e);
+ }
+ break;
+
+/* Eliminate outermost double NOTs */
+
+ case OPNOT:
+ if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
+ {
+ e = lp->exprblock.leftp;
+ free( (charptr) lp );
+ return(e);
+ }
+ break;
+
+ case OPCALL:
+ case OPCCALL:
+ etype = ltype;
+ if(rp!=NULL && rp->listblock.listp==NULL)
+ {
+ free( (charptr) rp );
+ rp = NULL;
+ }
+ break;
+
+ case OPAND:
+ case OPOR:
+ if( ISCONST(lp) )
+ COMMUTE
+
+ if( ISCONST(rp) )
+ {
+ if(rp->constblock.Const.ci == 0)
+ if(opcode == OPOR)
+ goto retleft;
+ else
+ goto retright;
+ else if(opcode == OPOR)
+ goto retright;
+ else
+ goto retleft;
+ }
+ case OPEQV:
+ case OPNEQV:
+
+ case OPBITAND:
+ case OPBITOR:
+ case OPBITXOR:
+ case OPBITNOT:
+ case OPLSHIFT:
+ case OPRSHIFT:
+
+ case OPLT:
+ case OPGT:
+ case OPLE:
+ case OPGE:
+ case OPEQ:
+ case OPNE:
+
+ case OPCONCAT:
+ break;
+ case OPMIN:
+ case OPMAX:
+ case OPMIN2:
+ case OPMAX2:
+ case OPDMIN:
+ case OPDMAX:
+
+ case OPASSIGN:
+ case OPASSIGNI:
+ case OPPLUSEQ:
+ case OPSTAREQ:
+ case OPMINUSEQ:
+ case OPSLASHEQ:
+ case OPMODEQ:
+ case OPLSHIFTEQ:
+ case OPRSHIFTEQ:
+ case OPBITANDEQ:
+ case OPBITXOREQ:
+ case OPBITOREQ:
+
+ case OPCONV:
+ case OPADDR:
+ case OPWHATSIN:
+
+ case OPCOMMA:
+ case OPCOMMA_ARG:
+ case OPQUEST:
+ case OPCOLON:
+ case OPDOT:
+ case OPARROW:
+ case OPIDENTITY:
+ case OPCHARCAST:
+ case OPABS:
+ case OPDABS:
+ break;
+
+ default:
+ badop("mkexpr", opcode);
+ }
+
+ e = (expptr) ALLOC(Exprblock);
+ e->exprblock.tag = TEXPR;
+ e->exprblock.opcode = opcode;
+ e->exprblock.vtype = etype;
+ e->exprblock.leftp = lp;
+ e->exprblock.rightp = rp;
+ if(ltag==TCONST && (rp==0 || rtag==TCONST) )
+ e = fold(e);
+ return(e);
+
+retleft:
+ frexpr(rp);
+ return(lp);
+
+retright:
+ frexpr(lp);
+ return(rp);
+
+error:
+ frexpr(lp);
+ if(rp && opcode!=OPCALL && opcode!=OPCCALL)
+ frexpr(rp);
+ return( errnode() );
+}
+
+#define ERR(s) { errs = s; goto error; }
+
+/* cktype -- Check and return the type of the expression */
+
+cktype(op, lt, rt)
+register int op, lt, rt;
+{
+ char *errs;
+
+ if(lt==TYERROR || rt==TYERROR)
+ goto error1;
+
+ if(lt==TYUNKNOWN)
+ return(TYUNKNOWN);
+ if(rt==TYUNKNOWN)
+
+/* If not unary operation, return UNKNOWN */
+
+ if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
+ return(TYUNKNOWN);
+
+ switch(op)
+ {
+ case OPPLUS:
+ case OPMINUS:
+ case OPSTAR:
+ case OPSLASH:
+ case OPPOWER:
+ case OPMOD:
+ if( ISNUMERIC(lt) && ISNUMERIC(rt) )
+ return( maxtype(lt, rt) );
+ ERR("nonarithmetic operand of arithmetic operator")
+
+ case OPNEG:
+ case OPNEG1:
+ if( ISNUMERIC(lt) )
+ return(lt);
+ ERR("nonarithmetic operand of negation")
+
+ case OPNOT:
+ if(lt == TYLOGICAL)
+ return(TYLOGICAL);
+ ERR("NOT of nonlogical")
+
+ case OPAND:
+ case OPOR:
+ case OPEQV:
+ case OPNEQV:
+ if(lt==TYLOGICAL && rt==TYLOGICAL)
+ return(TYLOGICAL);
+ ERR("nonlogical operand of logical operator")
+
+ case OPLT:
+ case OPGT:
+ case OPLE:
+ case OPGE:
+ case OPEQ:
+ case OPNE:
+ if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
+ {
+ if(lt != rt)
+ ERR("illegal comparison")
+ }
+
+ else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
+ {
+ if(op!=OPEQ && op!=OPNE)
+ ERR("order comparison of complex data")
+ }
+
+ else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
+ ERR("comparison of nonarithmetic data")
+ return(TYLOGICAL);
+
+ case OPCONCAT:
+ if(lt==TYCHAR && rt==TYCHAR)
+ return(TYCHAR);
+ ERR("concatenation of nonchar data")
+
+ case OPCALL:
+ case OPCCALL:
+ case OPIDENTITY:
+ return(lt);
+
+ case OPADDR:
+ case OPCHARCAST:
+ return(TYADDR);
+
+ case OPCONV:
+ if(rt == 0)
+ return(0);
+ if(lt==TYCHAR && ISINT(rt) )
+ return(TYCHAR);
+ case OPASSIGN:
+ case OPASSIGNI:
+ case OPMINUSEQ:
+ case OPPLUSEQ:
+ case OPSTAREQ:
+ case OPSLASHEQ:
+ case OPMODEQ:
+ case OPLSHIFTEQ:
+ case OPRSHIFTEQ:
+ case OPBITANDEQ:
+ case OPBITXOREQ:
+ case OPBITOREQ:
+ if( ISINT(lt) && rt==TYCHAR)
+ return(lt);
+ if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
+ if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
+ || (lt!=rt))
+ {
+ ERR("impossible conversion")
+ }
+ return(lt);
+
+ case OPMIN:
+ case OPMAX:
+ case OPDMIN:
+ case OPDMAX:
+ case OPMIN2:
+ case OPMAX2:
+ case OPBITOR:
+ case OPBITAND:
+ case OPBITXOR:
+ case OPBITNOT:
+ case OPLSHIFT:
+ case OPRSHIFT:
+ case OPWHATSIN:
+ case OPABS:
+ case OPDABS:
+ return(lt);
+
+ case OPCOMMA:
+ case OPCOMMA_ARG:
+ case OPQUEST:
+ case OPCOLON: /* Only checks the rightmost type because
+ of C language definition (rightmost
+ comma-expr is the value of the expr) */
+ return(rt);
+
+ case OPDOT:
+ case OPARROW:
+ return (lt);
+ break;
+ default:
+ badop("cktype", op);
+ }
+error:
+ err(errs);
+error1:
+ return(TYERROR);
+}
+
+/* fold -- simplifies constant expressions; it assumes that e -> leftp and
+ e -> rightp are TCONST or NULL */
+
+ LOCAL expptr
+fold(e)
+ register expptr e;
+{
+ Constp p;
+ register expptr lp, rp;
+ int etype, mtype, ltype, rtype, opcode;
+ int i, ll, lr;
+ char *q, *s;
+ struct Constblock lcon, rcon;
+ long L;
+ double d;
+
+ opcode = e->exprblock.opcode;
+ etype = e->exprblock.vtype;
+
+ lp = e->exprblock.leftp;
+ ltype = lp->headblock.vtype;
+ rp = e->exprblock.rightp;
+
+ if(rp == 0)
+ switch(opcode)
+ {
+ case OPNOT:
+ lp->constblock.Const.ci = ! lp->constblock.Const.ci;
+ retlp:
+ e->exprblock.leftp = 0;
+ frexpr(e);
+ return(lp);
+
+ case OPBITNOT:
+ lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
+ goto retlp;
+
+ case OPNEG:
+ case OPNEG1:
+ consnegop((Constp)lp);
+ goto retlp;
+
+ case OPCONV:
+ case OPADDR:
+ return(e);
+
+ case OPABS:
+ case OPDABS:
+ switch(ltype) {
+ case TYSHORT:
+ case TYLONG:
+ if ((L = lp->constblock.Const.ci) < 0)
+ lp->constblock.Const.ci = -L;
+ goto retlp;
+ case TYREAL:
+ case TYDREAL:
+ if (lp->constblock.vstg) {
+ s = lp->constblock.Const.cds[0];
+ if (*s == '-')
+ lp->constblock.Const.cds[0] = s + 1;
+ goto retlp;
+ }
+ if ((d = lp->constblock.Const.cd[0]) < 0.)
+ lp->constblock.Const.cd[0] = -d;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ return e; /* lazy way out */
+ }
+ default:
+ badop("fold", opcode);
+ }
+
+ rtype = rp->headblock.vtype;
+
+ p = ALLOC(Constblock);
+ p->tag = TCONST;
+ p->vtype = etype;
+ p->vleng = e->exprblock.vleng;
+
+ switch(opcode)
+ {
+ case OPCOMMA:
+ case OPCOMMA_ARG:
+ case OPQUEST:
+ case OPCOLON:
+ return(e);
+
+ case OPAND:
+ p->Const.ci = lp->constblock.Const.ci &&
+ rp->constblock.Const.ci;
+ break;
+
+ case OPOR:
+ p->Const.ci = lp->constblock.Const.ci ||
+ rp->constblock.Const.ci;
+ break;
+
+ case OPEQV:
+ p->Const.ci = lp->constblock.Const.ci ==
+ rp->constblock.Const.ci;
+ break;
+
+ case OPNEQV:
+ p->Const.ci = lp->constblock.Const.ci !=
+ rp->constblock.Const.ci;
+ break;
+
+ case OPBITAND:
+ p->Const.ci = lp->constblock.Const.ci &
+ rp->constblock.Const.ci;
+ break;
+
+ case OPBITOR:
+ p->Const.ci = lp->constblock.Const.ci |
+ rp->constblock.Const.ci;
+ break;
+
+ case OPBITXOR:
+ p->Const.ci = lp->constblock.Const.ci ^
+ rp->constblock.Const.ci;
+ break;
+
+ case OPLSHIFT:
+ p->Const.ci = lp->constblock.Const.ci <<
+ rp->constblock.Const.ci;
+ break;
+
+ case OPRSHIFT:
+ p->Const.ci = lp->constblock.Const.ci >>
+ rp->constblock.Const.ci;
+ break;
+
+ case OPCONCAT:
+ ll = lp->constblock.vleng->constblock.Const.ci;
+ lr = rp->constblock.vleng->constblock.Const.ci;
+ p->Const.ccp = q = (char *) ckalloc(ll+lr);
+ p->Const.ccp1.blanks = 0;
+ p->vleng = ICON(ll+lr);
+ s = lp->constblock.Const.ccp;
+ for(i = 0 ; i < ll ; ++i)
+ *q++ = *s++;
+ s = rp->constblock.Const.ccp;
+ for(i = 0; i < lr; ++i)
+ *q++ = *s++;
+ break;
+
+
+ case OPPOWER:
+ if( ! ISINT(rtype) )
+ return(e);
+ conspower(p, (Constp)lp, rp->constblock.Const.ci);
+ break;
+
+
+ default:
+ if(ltype == TYCHAR)
+ {
+ lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
+ rp->constblock.Const.ccp,
+ lp->constblock.vleng->constblock.Const.ci,
+ rp->constblock.vleng->constblock.Const.ci);
+ rcon.Const.ci = 0;
+ mtype = tyint;
+ }
+ else {
+ mtype = maxtype(ltype, rtype);
+ consconv(mtype, &lcon, &lp->constblock);
+ consconv(mtype, &rcon, &rp->constblock);
+ }
+ consbinop(opcode, mtype, p, &lcon, &rcon);
+ break;
+ }
+
+ frexpr(e);
+ return( (expptr) p );
+}
+
+
+
+/* assign constant l = r , doing coercion */
+
+consconv(lt, lc, rc)
+ int lt;
+ register Constp lc, rc;
+{
+ int rt = rc->vtype;
+ register union Constant *lv = &lc->Const, *rv = &rc->Const;
+
+ lc->vtype = lt;
+ if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
+ memcpy((char *)lv, (char *)rv, sizeof(union Constant));
+ lc->vstg = rc->vstg;
+ if (ISCOMPLEX(lt) && ISREAL(rt)) {
+ if (rc->vstg)
+ lv->cds[1] = cds("0",CNULL);
+ else
+ lv->cd[1] = 0.;
+ }
+ return;
+ }
+ lc->vstg = 0;
+
+ switch(lt)
+ {
+
+/* Casting to character means just copying the first sizeof (character)
+ bytes into a new 1 character string. This is weird. */
+
+ case TYCHAR:
+ *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
+ lv->ccp1.blanks = 0;
+ break;
+
+ case TYSHORT:
+ case TYLONG:
+ if(rt == TYCHAR)
+ lv->ci = rv->ccp[0];
+ else if( ISINT(rt) )
+ lv->ci = rv->ci;
+ else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
+
+ break;
+
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ lv->cd[1] = 0.;
+ lv->cd[0] = rv->ci;
+ break;
+
+ case TYREAL:
+ case TYDREAL:
+ lv->cd[0] = rv->ci;
+ break;
+
+ case TYLOGICAL:
+ lv->ci = rv->ci;
+ break;
+ }
+}
+
+
+
+/* Negate constant value -- changes the input node's value */
+
+consnegop(p)
+register Constp p;
+{
+ register char *s;
+
+ if (p->vstg) {
+ if (ISCOMPLEX(p->vtype)) {
+ s = p->Const.cds[1];
+ p->Const.cds[1] = *s == '-' ? s+1
+ : *s == '0' ? s : s-1;
+ }
+ s = p->Const.cds[0];
+ p->Const.cds[0] = *s == '-' ? s+1
+ : *s == '0' ? s : s-1;
+ return;
+ }
+ switch(p->vtype)
+ {
+ case TYSHORT:
+ case TYLONG:
+ p->Const.ci = - p->Const.ci;
+ break;
+
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ p->Const.cd[1] = - p->Const.cd[1];
+ /* fall through and do the real parts */
+ case TYREAL:
+ case TYDREAL:
+ p->Const.cd[0] = - p->Const.cd[0];
+ break;
+ default:
+ badtype("consnegop", p->vtype);
+ }
+}
+
+
+
+/* conspower -- Expand out an exponentiation */
+
+ LOCAL void
+conspower(p, ap, n)
+ Constp p, ap;
+ ftnint n;
+{
+ register union Constant *powp = &p->Const;
+ register int type;
+ struct Constblock x, x0;
+
+ if (n == 1) {
+ memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
+ return;
+ }
+
+ switch(type = ap->vtype) /* pow = 1 */
+ {
+ case TYSHORT:
+ case TYLONG:
+ powp->ci = 1;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ powp->cd[1] = 0;
+ case TYREAL:
+ case TYDREAL:
+ powp->cd[0] = 1;
+ break;
+ default:
+ badtype("conspower", type);
+ }
+
+ if(n == 0)
+ return;
+ switch(type) /* x0 = ap */
+ {
+ case TYSHORT:
+ case TYLONG:
+ x0.Const.ci = ap->Const.ci;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ x0.Const.cd[1] =
+ ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
+ case TYREAL:
+ case TYDREAL:
+ x0.Const.cd[0] =
+ ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
+ break;
+ }
+ x0.vtype = type;
+ x0.vstg = 0;
+ if(n < 0)
+ {
+ if( ISINT(type) )
+ {
+ err("integer ** negative number");
+ return;
+ }
+ else if (!x0.Const.cd[0]
+ && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
+ err("0.0 ** negative number");
+ return;
+ }
+ n = -n;
+ consbinop(OPSLASH, type, &x, p, &x0);
+ }
+ else
+ consbinop(OPSTAR, type, &x, p, &x0);
+
+ for( ; ; )
+ {
+ if(n & 01)
+ consbinop(OPSTAR, type, p, p, &x);
+ if(n >>= 1)
+ consbinop(OPSTAR, type, &x, &x, &x);
+ else
+ break;
+ }
+}
+
+
+
+/* do constant operation cp = a op b -- assumes that ap and bp have data
+ matching the input type */
+
+
+ LOCAL void
+consbinop(opcode, type, cpp, app, bpp)
+ int opcode, type;
+ Constp cpp, app, bpp;
+{
+ register union Constant *ap = &app->Const,
+ *bp = &bpp->Const,
+ *cp = &cpp->Const;
+ int k;
+ double ad[2], bd[2], temp;
+
+ cpp->vstg = 0;
+
+ if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
+ ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
+ bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
+ if (ISCOMPLEX(type)) {
+ ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
+ bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
+ }
+ }
+ switch(opcode)
+ {
+ case OPPLUS:
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ cp->ci = ap->ci + bp->ci;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ cp->cd[1] = ad[1] + bd[1];
+ case TYREAL:
+ case TYDREAL:
+ cp->cd[0] = ad[0] + bd[0];
+ break;
+ }
+ break;
+
+ case OPMINUS:
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ cp->ci = ap->ci - bp->ci;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ cp->cd[1] = ad[1] - bd[1];
+ case TYREAL:
+ case TYDREAL:
+ cp->cd[0] = ad[0] - bd[0];
+ break;
+ }
+ break;
+
+ case OPSTAR:
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ cp->ci = ap->ci * bp->ci;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ cp->cd[0] = ad[0] * bd[0];
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ temp = ad[0] * bd[0] - ad[1] * bd[1] ;
+ cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ;
+ cp->cd[0] = temp;
+ break;
+ }
+ break;
+ case OPSLASH:
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ cp->ci = ap->ci / bp->ci;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ cp->cd[0] = ad[0] / bd[0];
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
+ break;
+ }
+ break;
+
+ case OPMOD:
+ if( ISINT(type) )
+ {
+ cp->ci = ap->ci % bp->ci;
+ break;
+ }
+ else
+ Fatal("inline mod of noninteger");
+
+ case OPMIN2:
+ case OPDMIN:
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
+ break;
+ default:
+ Fatal("inline min of exected type");
+ }
+ break;
+
+ case OPMAX2:
+ case OPDMAX:
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
+ break;
+ default:
+ Fatal("inline max of exected type");
+ }
+ break;
+
+ default: /* relational ops */
+ switch(type)
+ {
+ case TYSHORT:
+ case TYLONG:
+ if(ap->ci < bp->ci)
+ k = -1;
+ else if(ap->ci == bp->ci)
+ k = 0;
+ else k = 1;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ if(ad[0] < bd[0])
+ k = -1;
+ else if(ad[0] == bd[0])
+ k = 0;
+ else k = 1;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ if(ad[0] == bd[0] &&
+ ad[1] == bd[1] )
+ k = 0;
+ else k = 1;
+ break;
+ }
+
+ switch(opcode)
+ {
+ case OPEQ:
+ cp->ci = (k == 0);
+ break;
+ case OPNE:
+ cp->ci = (k != 0);
+ break;
+ case OPGT:
+ cp->ci = (k == 1);
+ break;
+ case OPLT:
+ cp->ci = (k == -1);
+ break;
+ case OPGE:
+ cp->ci = (k >= 0);
+ break;
+ case OPLE:
+ cp->ci = (k <= 0);
+ break;
+ }
+ break;
+ }
+}
+
+
+
+/* conssgn - returns the sign of a Fortran constant */
+
+conssgn(p)
+register expptr p;
+{
+ register char *s;
+
+ if( ! ISCONST(p) )
+ Fatal( "sgn(nonconstant)" );
+
+ switch(p->headblock.vtype)
+ {
+ case TYSHORT:
+ case TYLONG:
+ if(p->constblock.Const.ci > 0) return(1);
+ if(p->constblock.Const.ci < 0) return(-1);
+ return(0);
+
+ case TYREAL:
+ case TYDREAL:
+ if (p->constblock.vstg) {
+ s = p->constblock.Const.cds[0];
+ if (*s == '-')
+ return -1;
+ if (*s == '0')
+ return 0;
+ return 1;
+ }
+ if(p->constblock.Const.cd[0] > 0) return(1);
+ if(p->constblock.Const.cd[0] < 0) return(-1);
+ return(0);
+
+
+/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
+
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ if (p->constblock.vstg)
+ return *p->constblock.Const.cds[0] != '0'
+ && *p->constblock.Const.cds[1] != '0';
+ return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
+
+ default:
+ badtype( "conssgn", p->constblock.vtype);
+ }
+ /* NOT REACHED */ return 0;
+}
+
+char *powint[ ] = {
+ "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
+
+LOCAL expptr mkpower(p)
+register expptr p;
+{
+ register expptr q, lp, rp;
+ int ltype, rtype, mtype, tyi;
+
+ lp = p->exprblock.leftp;
+ rp = p->exprblock.rightp;
+ ltype = lp->headblock.vtype;
+ rtype = rp->headblock.vtype;
+
+ if(ISICON(rp))
+ {
+ if(rp->constblock.Const.ci == 0)
+ {
+ frexpr(p);
+ if( ISINT(ltype) )
+ return( ICON(1) );
+ else if (ISREAL (ltype))
+ return mkconv (ltype, ICON (1));
+ else
+ return( (expptr) putconst((Constp)
+ mkconv(ltype, ICON(1))) );
+ }
+ if(rp->constblock.Const.ci < 0)
+ {
+ if( ISINT(ltype) )
+ {
+ frexpr(p);
+ err("integer**negative");
+ return( errnode() );
+ }
+ rp->constblock.Const.ci = - rp->constblock.Const.ci;
+ p->exprblock.leftp = lp
+ = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
+ }
+ if(rp->constblock.Const.ci == 1)
+ {
+ frexpr(rp);
+ free( (charptr) p );
+ return(lp);
+ }
+
+ if( ONEOF(ltype, MSKINT|MSKREAL) && !doin_setbound) {
+ p->exprblock.vtype = ltype;
+ return(p);
+ }
+ }
+ if( ISINT(rtype) )
+ {
+ if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
+ q = call2(TYSHORT, "pow_hh", lp, rp);
+ else {
+ if(ltype == TYSHORT)
+ {
+ ltype = TYLONG;
+ lp = mkconv(TYLONG,lp);
+ }
+ rp = mkconv(TYLONG,rp);
+ if (ISCONST(rp)) {
+ tyi = tyint;
+ tyint = TYLONG;
+ rp = (expptr)putconst((Constp)rp);
+ tyint = tyi;
+ }
+ q = call2(ltype, powint[ltype-TYLONG], lp, rp);
+ }
+ }
+ else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
+ extern int callk_kludge;
+ callk_kludge = TYDREAL;
+ q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
+ callk_kludge = 0;
+ }
+ else {
+ q = call2(TYDCOMPLEX, "pow_zz",
+ mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
+ if(mtype == TYCOMPLEX)
+ q = mkconv(TYCOMPLEX, q);
+ }
+ free( (charptr) p );
+ return(q);
+}
+
+
+/* Complex Division. Same code as in Runtime Library
+*/
+
+
+ LOCAL void
+zdiv(c, a, b)
+ register dcomplex *a, *b, *c;
+{
+ double ratio, den;
+ double abr, abi;
+
+ if( (abr = b->dreal) < 0.)
+ abr = - abr;
+ if( (abi = b->dimag) < 0.)
+ abi = - abi;
+ if( abr <= abi )
+ {
+ if(abi == 0)
+ Fatal("complex division by zero");
+ ratio = b->dreal / b->dimag ;
+ den = b->dimag * (1 + ratio*ratio);
+ c->dreal = (a->dreal*ratio + a->dimag) / den;
+ c->dimag = (a->dimag*ratio - a->dreal) / den;
+ }
+
+ else
+ {
+ ratio = b->dimag / b->dreal ;
+ den = b->dreal * (1 + ratio*ratio);
+ c->dreal = (a->dreal + a->dimag*ratio) / den;
+ c->dimag = (a->dimag - a->dreal*ratio) / den;
+ }
+}
--- /dev/null
+
+ F2C(1) F2C(1)
+
+ NAME
+ f2c - Convert Fortran 77 to C or C++
+
+ SYNOPSIS
+ f2c [ option ... ] file ...
+
+ DESCRIPTION
+ F2c converts Fortran 77 source code in files with names end-
+ ing in `.f' or `.F' to C (or C++) source files in the
+ current directory, with `.c' substituted for the final `.f'
+ or `.F'. If no Fortran files are named, f2c reads Fortran
+ from standard input and writes C on standard output. File
+ names that end with `.p' or `.P' are taken to be prototype
+ files, as produced by option `-P', and are read first.
+
+ The following options have the same meaning as in f77(1).
+
+ -C Compile code to check that subscripts are within
+ declared array bounds.
+
+ -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long
+ int. Assume the default libF77 and libI77: allow only
+ INTEGER*4 (and no LOGICAL) variables in INQUIREs.
+ Option `-I4' confirms the default rendering of INTEGER
+ as long int.
+
+ -onetrip
+ Compile DO loops that are performed at least once if
+ reached. (Fortran 77 DO loops are not performed at all
+ if the upper limit is smaller than the lower limit.)
+
+ -U Honor the case of variable and external names. Fortran
+ keywords must be in lower case.
+
+ -u Make the default type of a variable `undefined' rather
+ than using the default Fortran rules.
+
+ -w Suppress all warning messages. If the option is
+ `-w66', only Fortran 66 compatibility warnings are
+ suppressed.
+
+ The following options are peculiar to f2c.
+
+ -A Produce ANSI C. Default is old-style C.
+
+ -a Make local variables automatic rather than static
+ unless they appear in a DATA, EQUIVALENCE, NAMELIST, or
+ SAVE statement.
+
+ -C++ Output C++ code.
+
+ -c Include original Fortran source as comments.
+
+ Page 1 Tenth Edition (printed 1/28/90)
+
+ F2C(1) F2C(1)
+
+ -E Declare uninitialized COMMON to be Extern (overridably
+ defined in f2c.h as extern).
+
+ -ec Place uninitialized COMMON blocks in separate files:
+ COMMON /ABC/ appears in file abc_com.c. Option `-e1c'
+ bundles the separate files into the output file, with
+ comments that give an unbundling sed(1) script.
+
+ -ext Complain about f77(1) extensions.
+
+ -g Include original Fortran line numbers as comments.
+
+ -i2 Similar to -I2, but assume a modified libF77 and libI77
+ (compiled with -Df2c_i2), so INTEGER and LOGICAL vari-
+ ables may be assigned by INQUIRE.
+
+ -P Write a file.P of ANSI (or C++) prototypes for pro-
+ cedures defined in each input file.f or file.F. When
+ reading Fortran from standard input, write prototypes
+ at the beginning of standard output. Implies -A unless
+ option `-C++' is present. Option -Ps implies -P , and
+ gives exit status 4 if rerunning f2c may change proto-
+ types or declarations.
+
+ -p Supply preprocessor definitions to make common-block
+ members look like local variables.
+
+ -R Do not promote REAL functions and operations to DOUBLE
+ PRECISION. Option `-!R' confirms the default, which
+ imitates f77.
+
+ -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE
+ COMPLEX.
+
+ -Tdir
+ Put temporary files in directory dir.
+
+ -w8 Suppress warnings when COMMON or EQUIVALENCE forces
+ odd-word alignment of doubles.
+
+ -Wn Assume n characters/word (default 4) when initializing
+ numeric variables with character data.
+
+ -z Do not implicitly recognize DOUBLE COMPLEX.
+
+ -!c Inhibit C output, but produce -P output.
+
+ -!I Reject include statements.
+
+ -!it Don't infer types of untyped EXTERNAL procedures from
+ use as parameters to previously defined or prototyped
+ procedures.
+
+ Page 2 Tenth Edition (printed 1/28/90)
+
+ F2C(1) F2C(1)
+
+ -!P Do not attempt to infer ANSI or C++ prototypes from
+ usage.
+
+ The resulting C invokes the support routines of f77; object
+ code should be loaded by f77 or with ld(1) or cc(1) options
+ -lF77 -lI77 -lm. Calling conventions are those of f77: see
+ the reference below.
+
+ FILES
+ file.[fF]
+ input file
+
+ *.c output file
+
+ /usr/include/f2c.h
+ header file
+
+ /usr/lib/libF77.a
+ intrinsic function library
+
+ /usr/lib/libI77.a
+ Fortran I/O library
+
+ /lib/libc.a
+ C library, see section 3
+
+ SEE ALSO
+ S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77
+ Compiler', UNIX Time Sharing System Programmer's Manual,
+ Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
+
+ DIAGNOSTICS
+ The diagnostics produced by f2c are intended to be self-
+ explanatory.
+
+ BUGS
+ Floating-point constant expressions are simplified in the
+ floating-point arithmetic of the machine running f2c, so
+ they are typically accurate to at most 16 or 17 decimal
+ places.
+ Untypable EXTERNAL functions are declared int.
+
+ Page 3 Tenth Edition (printed 1/28/90)
+
--- /dev/null
+/* f2c.h -- Standard Fortran to C header file */
+
+/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
+
+ - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long flag;
+typedef long ftnlen;
+typedef long ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ shortint h;
+ integer i;
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+typedef long Long;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ Long *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f; /* complex function */
+typedef VOID H_f; /* character function */
+typedef VOID Z_f; /* double complex function */
+typedef doublereal E_f; /* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Format.c -- this file takes an intermediate file (generated by pass 1
+ of the translator) and some state information about the contents of that
+ file, and generates C program text. */
+
+#include "defs.h"
+#include "p1defs.h"
+#include "format.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+int c_output_line_length = DEF_C_LINE_LENGTH;
+
+int last_was_label; /* Boolean used to generate semicolons
+ when a label terminates a block */
+static char this_proc_name[52]; /* Name of the current procedure. This is
+ probably too simplistic to handle
+ multiple entry points */
+
+static int p1getd(), p1gets(), p1getf(), get_p1_token();
+static int p1get_const(), p1getn();
+static expptr do_format(), do_p1_name_pointer(), do_p1_const();
+static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
+static expptr do_p1_head(), do_p1_list(), do_p1_literal();
+static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
+static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
+static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
+static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
+static void do_p1_1while(), do_p1_2while();
+static void do_p1_comment(), do_p1_set_line();
+static expptr do_p1_addr(), expand_structure_refs();
+static void proto();
+void list_arg_types();
+chainp length_comp();
+void listargs();
+extern chainp assigned_fmts;
+static long old_lineno;
+static char filename[P1_FILENAME_MAX];
+extern int gflag;
+extern char *parens;
+
+#define is_end_token(x) ((x) == P1_ENDIF || (x) == P1_ENDELSE || (x) == P1_ENDFOR)
+
+start_formatting ()
+{
+ FILE *infile;
+ static int wrote_one = 0;
+ extern int usedefsforcommon;
+ extern char *p1_file, *p1_bakfile;
+
+ this_proc_name[0] = '\0';
+ last_was_label = 0;
+ old_lineno = lineno;
+ wh_next = wh_first;
+
+ (void) fclose (pass1_file);
+ if ((infile = fopen (p1_file, binread)) == NULL)
+ Fatal("start_formatting: couldn't open the intermediate file\n");
+
+ if (wrote_one)
+ nice_printf (c_file, "\n");
+
+ while (!feof (infile)) {
+ expptr this_expr;
+
+ this_expr = do_format (infile, c_file);
+ if (this_expr) {
+ out_and_free_statement (c_file, this_expr);
+ } /* if this_expr */
+ } /* while !feof infile */
+
+ (void) fclose (infile);
+
+ if (last_was_label)
+ nice_printf (c_file, ";\n");
+
+ prev_tab (c_file);
+ if (this_proc_name[0])
+ nice_printf (c_file, "} /* %s */\n", this_proc_name);
+
+
+/* Write the #undefs for common variable reference */
+
+ if (usedefsforcommon) {
+ Extsym *ext;
+ int did_one = 0;
+
+ for (ext = extsymtab; ext < nextext; ext++)
+ if (ext -> extstg == STGCOMMON && ext -> used_here) {
+ ext -> used_here = 0;
+ if (!did_one)
+ nice_printf (c_file, "\n");
+ wr_abbrevs(c_file, 0, ext->extp);
+ did_one = 1;
+ ext -> extp = CHNULL;
+ } /* if */
+
+ if (did_one)
+ nice_printf (c_file, "\n");
+ } /* if usedefsforcommon */
+
+ other_undefs(c_file);
+
+ wrote_one = 1;
+
+/* For debugging only */
+
+ if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
+ if (infile = fopen (p1_file, binread)) {
+ ffilecopy (infile, pass1_file);
+ fclose (infile);
+ fclose (pass1_file);
+ } /* if infile */
+
+/* End of "debugging only" */
+
+ if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
+ err ("start_formatting: couldn't reopen the pass1 file");
+
+} /* start_formatting */
+
+
+static expptr expand_structure_refs (e)
+expptr e;
+{
+ if (e == ENULL)
+ return ENULL;
+ else if (e -> tag == TADDR)
+ if (e -> addrblock.Field == NULL)
+ return e;
+ else {
+ Constp mkconst ();
+ Constp p = mkconst(TYCHAR);
+
+ p -> vleng = ICON (strlen (e -> addrblock.Field));
+ p -> Const.ccp = e -> addrblock.Field;
+ p -> Const.ccp1.blanks = 0;
+ e -> addrblock.Field = NULL;
+ return mkexpr(OPDOT, e, (expptr)p);
+ } /* else */
+ else if (e -> tag != TEXPR)
+ return e;
+ else {
+ e -> exprblock.leftp = expand_structure_refs (e -> exprblock.leftp);
+ e -> exprblock.rightp = expand_structure_refs (e -> exprblock.rightp);
+ return e;
+ } /* else */
+} /* expand_structure_refs */
+
+
+/* do_format -- takes an input stream (a file in pass1 format) and writes
+ the appropriate C code to outfile when possible. When reading an
+ expression, the expression tree is returned instead. */
+
+static expptr do_format (infile, outfile)
+FILE *infile, *outfile;
+{
+ int gsave, token_type, was_c_token;
+ expptr retval = ENULL;
+
+ token_type = get_p1_token (infile);
+ if (is_end_token (token_type) && last_was_label) {
+ nice_printf (outfile, ";");
+ last_was_label = 0;
+ }
+
+ was_c_token = 1;
+ switch (token_type) {
+ case P1_COMMENT:
+ do_p1_comment (infile, outfile);
+ was_c_token = 0;
+ break;
+ case P1_SET_LINE:
+ do_p1_set_line (infile);
+ was_c_token = 0;
+ break;
+ case P1_FILENAME:
+ p1gets(infile, filename, P1_FILENAME_MAX);
+ was_c_token = 0;
+ break;
+ case P1_NAME_POINTER:
+ retval = do_p1_name_pointer (infile);
+ break;
+ case P1_CONST:
+ retval = do_p1_const (infile);
+ break;
+ case P1_EXPR:
+ retval = do_p1_expr (infile, outfile);
+ break;
+ case P1_IDENT:
+ retval = do_p1_ident(infile);
+ break;
+ case P1_CHARP:
+ retval = do_p1_charp(infile);
+ break;
+ case P1_EXTERN:
+ retval = do_p1_extern (infile);
+ break;
+ case P1_HEAD:
+ gsave = gflag;
+ gflag = 0;
+ retval = do_p1_head (infile, outfile);
+ gflag = gsave;
+ break;
+ case P1_LIST:
+ retval = do_p1_list (infile, outfile);
+ break;
+ case P1_LITERAL:
+ retval = do_p1_literal (infile);
+ break;
+ case P1_LABEL:
+ do_p1_label (infile, outfile);
+ /* last_was_label = 1; -- now set in do_p1_label */
+ was_c_token = 0;
+ break;
+ case P1_ASGOTO:
+ do_p1_asgoto (infile, outfile);
+ break;
+ case P1_GOTO:
+ do_p1_goto (infile, outfile);
+ break;
+ case P1_IF:
+ do_p1_if (infile, outfile);
+ break;
+ case P1_ELSE:
+ do_p1_else (outfile);
+ break;
+ case P1_ELIF:
+ do_p1_elif (infile, outfile);
+ break;
+ case P1_ENDIF:
+ do_p1_endif (outfile);
+ break;
+ case P1_ENDELSE:
+ do_p1_endelse (outfile);
+ break;
+ case P1_ADDR:
+ retval = do_p1_addr (infile, outfile);
+ break;
+ case P1_SUBR_RET:
+ do_p1_subr_ret (infile, outfile);
+ break;
+ case P1_COMP_GOTO:
+ do_p1_comp_goto (infile, outfile);
+ break;
+ case P1_FOR:
+ do_p1_for (infile, outfile);
+ break;
+ case P1_ENDFOR:
+ do_p1_end_for (outfile);
+ break;
+ case P1_WHILE1START:
+ do_p1_1while(outfile);
+ break;
+ case P1_WHILE2START:
+ do_p1_2while(infile, outfile);
+ break;
+ case P1_PROCODE:
+ procode(outfile);
+ break;
+ case P1_FORTRAN:
+ do_p1_fortran(infile, outfile);
+ /* no break; */
+ case P1_EOF:
+ was_c_token = 0;
+ break;
+ case P1_UNKNOWN:
+ Fatal("do_format: Unknown token type in intermediate file");
+ break;
+ default:
+ Fatal("do_format: Bad token type in intermediate file");
+ break;
+ } /* switch */
+
+ if (was_c_token)
+ last_was_label = 0;
+ return retval;
+} /* do_format */
+
+
+ static void
+do_p1_comment (infile, outfile)
+FILE *infile, *outfile;
+{
+ extern int c_output_line_length, in_comment;
+
+ char storage[COMMENT_BUFFER_SIZE + 1];
+ int length;
+
+ if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
+ return;
+
+ length = strlen (storage);
+
+ in_comment = 1;
+ if (length > c_output_line_length - 6)
+ margin_printf (outfile, "/*%s*/\n", storage);
+ else
+ margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
+ in_comment = 0;
+} /* do_p1_comment */
+
+ static void
+do_p1_set_line (infile)
+FILE *infile;
+{
+ int status;
+ long new_line_number = -1;
+
+ status = p1getd (infile, &new_line_number);
+
+ if (status == EOF)
+ err ("do_p1_set_line: Missing line number at end of file\n");
+ else if (status == 0 || new_line_number == -1)
+ errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n",
+ new_line_number);
+ else {
+ lineno = new_line_number;
+ if (gflag)
+ fprintf(c_file, "/*# %ld \"%s\"*/\n", lineno, filename);
+ }
+} /* do_p1_set_line */
+
+
+static expptr do_p1_name_pointer (infile)
+FILE *infile;
+{
+ Namep namep = (Namep) NULL;
+ int status;
+
+ status = p1getd (infile, (long *) &namep);
+
+ if (status == EOF)
+ err ("do_p1_name_pointer: Missing pointer at end of file\n");
+ else if (status == 0 || namep == (Namep) NULL)
+ erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n",
+ (int) namep);
+
+ return (expptr) namep;
+} /* do_p1_name_pointer */
+
+
+
+static expptr do_p1_const (infile)
+FILE *infile;
+{
+ struct Constblock *c = (struct Constblock *) NULL;
+ long type = -1;
+ int status;
+
+ status = p1getd (infile, &type);
+
+ if (status == EOF)
+ err ("do_p1_const: Missing constant type at end of file\n");
+ else if (status == 0)
+ errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type);
+ else {
+ status = p1get_const (infile, (int)type, &c);
+
+ if (status == EOF) {
+ err ("do_p1_const: Missing constant value at end of file\n");
+ c = (struct Constblock *) NULL;
+ } else if (status == 0) {
+ err ("do_p1_const: Illegal constant value in p1 file\n");
+ c = (struct Constblock *) NULL;
+ } /* else */
+ } /* else */
+ return (expptr) c;
+} /* do_p1_const */
+
+
+static expptr do_p1_literal (infile)
+FILE *infile;
+{
+ int status;
+ long memno;
+ Addrp addrp;
+
+ status = p1getd (infile, &memno);
+
+ if (status == EOF)
+ err ("do_p1_literal: Missing memno at end of file");
+ else if (status == 0)
+ err ("do_p1_literal: Missing memno in p1 file");
+ else {
+ struct Literal *litp, *lastlit;
+ extern struct Literal litpool[];
+ extern int nliterals;
+
+ addrp = ALLOC (Addrblock);
+ addrp -> tag = TADDR;
+ addrp -> vtype = TYUNKNOWN;
+ addrp -> Field = NULL;
+
+ lastlit = litpool + nliterals;
+ for (litp = litpool; litp < lastlit; litp++)
+ if (litp -> litnum == memno) {
+ addrp -> vtype = litp -> littype;
+ *((union Constant *) &(addrp -> user)) =
+ *((union Constant *) &(litp -> litval));
+ break;
+ } /* if litp -> litnum == memno */
+
+ addrp -> memno = memno;
+ addrp -> vstg = STGMEMNO;
+ addrp -> uname_tag = UNAM_CONST;
+ } /* else */
+
+ return (expptr) addrp;
+} /* do_p1_literal */
+
+
+static void do_p1_label (infile, outfile)
+FILE *infile, *outfile;
+{
+ int status;
+ ftnint stateno;
+ char *user_label ();
+ struct Labelblock *L;
+ char *fmt;
+
+ status = p1getd (infile, &stateno);
+
+ if (status == EOF)
+ err ("do_p1_label: Missing label at end of file");
+ else if (status == 0)
+ err ("do_p1_label: Missing label in p1 file ");
+ else if (stateno < 0) { /* entry */
+ margin_printf(outfile, "\n%s:\n", user_label(stateno));
+ last_was_label = 1;
+ }
+ else {
+ L = labeltab + stateno;
+ if (L->labused) {
+ fmt = "%s:\n";
+ last_was_label = 1;
+ }
+ else
+ fmt = "/* %s: */\n";
+ margin_printf(outfile, fmt, user_label(L->stateno));
+ } /* else */
+} /* do_p1_label */
+
+
+
+static void do_p1_asgoto (infile, outfile)
+FILE *infile, *outfile;
+{
+ expptr expr;
+
+ expr = do_format (infile, outfile);
+ out_asgoto (outfile, expr);
+
+} /* do_p1_asgoto */
+
+
+static void do_p1_goto (infile, outfile)
+FILE *infile, *outfile;
+{
+ int status;
+ long stateno;
+ char *user_label ();
+
+ status = p1getd (infile, &stateno);
+
+ if (status == EOF)
+ err ("do_p1_goto: Missing goto label at end of file");
+ else if (status == 0)
+ err ("do_p1_goto: Missing goto label in p1 file");
+ else {
+ nice_printf (outfile, "goto %s;\n", user_label (stateno));
+ } /* else */
+} /* do_p1_goto */
+
+
+static void do_p1_if (infile, outfile)
+FILE *infile, *outfile;
+{
+ expptr cond;
+
+ do {
+ cond = do_format (infile, outfile);
+ } while (cond == ENULL);
+
+ out_if (outfile, cond);
+} /* do_p1_if */
+
+
+static void do_p1_else (outfile)
+FILE *outfile;
+{
+ out_else (outfile);
+} /* do_p1_else */
+
+
+static void do_p1_elif (infile, outfile)
+FILE *infile, *outfile;
+{
+ expptr cond;
+
+ do {
+ cond = do_format (infile, outfile);
+ } while (cond == ENULL);
+
+ elif_out (outfile, cond);
+} /* do_p1_elif */
+
+static void do_p1_endif (outfile)
+FILE *outfile;
+{
+ endif_out (outfile);
+} /* do_p1_endif */
+
+
+static void do_p1_endelse (outfile)
+FILE *outfile;
+{
+ end_else_out (outfile);
+} /* do_p1_endelse */
+
+
+static expptr do_p1_addr (infile, outfile)
+FILE *infile, *outfile;
+{
+ Addrp addrp = (Addrp) NULL;
+ int status;
+
+ status = p1getn (infile, sizeof (struct Addrblock), (char **) &addrp);
+
+ if (status == EOF)
+ err ("do_p1_addr: Missing Addrp at end of file");
+ else if (status == 0)
+ err ("do_p1_addr: Missing Addrp in p1 file");
+ else if (addrp == (Addrp) NULL)
+ err ("do_p1_addr: Null addrp in p1 file");
+ else if (addrp -> tag != TADDR)
+ erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
+ else {
+ addrp -> vleng = do_format (infile, outfile);
+ addrp -> memoffset = do_format (infile, outfile);
+ }
+
+ return (expptr) addrp;
+} /* do_p1_addr */
+
+
+
+static void do_p1_subr_ret (infile, outfile)
+FILE *infile, *outfile;
+{
+ expptr retval;
+
+ nice_printf (outfile, "return ");
+ retval = do_format (infile, outfile);
+ if (!multitype)
+ if (retval)
+ expr_out (outfile, retval);
+
+ nice_printf (outfile, ";\n");
+} /* do_p1_subr_ret */
+
+
+
+static void do_p1_comp_goto (infile, outfile)
+FILE *infile, *outfile;
+{
+ expptr index;
+ expptr labels;
+
+ index = do_format (infile, outfile);
+
+ if (index == ENULL) {
+ err ("do_p1_comp_goto: no expression for computed goto");
+ return;
+ } /* if index == ENULL */
+
+ labels = do_format (infile, outfile);
+
+ if (labels && labels -> tag != TLIST)
+ erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag);
+ else
+ compgoto_out (outfile, index, labels);
+} /* do_p1_comp_goto */
+
+
+static void do_p1_for (infile, outfile)
+FILE *infile, *outfile;
+{
+ expptr init, test, inc;
+
+ init = do_format (infile, outfile);
+ test = do_format (infile, outfile);
+ inc = do_format (infile, outfile);
+
+ out_for (outfile, init, test, inc);
+} /* do_p1_for */
+
+static void do_p1_end_for (outfile)
+FILE *outfile;
+{
+ out_end_for (outfile);
+} /* do_p1_end_for */
+
+
+ static void
+do_p1_fortran(infile, outfile)
+ FILE *infile, *outfile;
+{
+ char buf[P1_STMTBUFSIZE];
+ if (!p1gets(infile, buf, P1_STMTBUFSIZE))
+ return;
+ /* bypass nice_printf nonsense */
+ fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */
+ }
+
+
+static expptr do_p1_expr (infile, outfile)
+FILE *infile, *outfile;
+{
+ int status;
+ long opcode, type;
+ struct Exprblock *result = (struct Exprblock *) NULL;
+
+ status = p1getd (infile, &opcode);
+
+ if (status == EOF)
+ err ("do_p1_expr: Missing expr opcode at end of file");
+ else if (status == 0)
+ err ("do_p1_expr: Missing expr opcode in p1 file");
+ else {
+
+ status = p1getd (infile, &type);
+
+ if (status == EOF)
+ err ("do_p1_expr: Missing expr type at end of file");
+ else if (status == 0)
+ err ("do_p1_expr: Missing expr type in p1 file");
+ else if (opcode == 0)
+ return ENULL;
+ else {
+ result = ALLOC (Exprblock);
+
+ result -> tag = TEXPR;
+ result -> vtype = type;
+ result -> opcode = opcode;
+ result -> vleng = do_format (infile, outfile);
+
+ if (is_unary_op (opcode))
+ result -> leftp = do_format (infile, outfile);
+ else if (is_binary_op (opcode)) {
+ result -> leftp = do_format (infile, outfile);
+ result -> rightp = do_format (infile, outfile);
+ } else
+ errl("do_p1_expr: Illegal opcode %ld", opcode);
+ } /* else */
+ } /* else */
+
+ return (expptr) result;
+} /* do_p1_expr */
+
+
+static expptr do_p1_ident(infile)
+FILE *infile;
+{
+ Addrp addrp;
+ int status;
+ long vtype, vstg;
+
+ addrp = ALLOC (Addrblock);
+ addrp -> tag = TADDR;
+
+ status = p1getd (infile, &vtype);
+ if (status == EOF)
+ err ("do_p1_ident: Missing identifier type at end of file\n");
+ else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+ errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
+ else
+ addrp -> vtype = vtype;
+
+ status = p1getd (infile, &vstg);
+ if (status == EOF)
+ err ("do_p1_ident: Missing identifier storage at end of file\n");
+ else if (status == 0 || vstg < 0 || vstg > STGNULL)
+ errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
+ else
+ addrp -> vstg = vstg;
+
+ status = p1gets(infile, addrp->user.ident, IDENT_LEN);
+
+ if (status == EOF)
+ err ("do_p1_ident: Missing ident string at end of file");
+ else if (status == 0)
+ err ("do_p1_ident: Missing ident string in intermediate file");
+ addrp->uname_tag = UNAM_IDENT;
+ return (expptr) addrp;
+} /* do_p1_ident */
+
+static expptr do_p1_charp(infile)
+FILE *infile;
+{
+ Addrp addrp;
+ int status;
+ long vtype, vstg;
+ char buf[64];
+
+ addrp = ALLOC (Addrblock);
+ addrp -> tag = TADDR;
+
+ status = p1getd (infile, &vtype);
+ if (status == EOF)
+ err ("do_p1_ident: Missing identifier type at end of file\n");
+ else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+ errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
+ else
+ addrp -> vtype = vtype;
+
+ status = p1getd (infile, &vstg);
+ if (status == EOF)
+ err ("do_p1_ident: Missing identifier storage at end of file\n");
+ else if (status == 0 || vstg < 0 || vstg > STGNULL)
+ errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
+ else
+ addrp -> vstg = vstg;
+
+ status = p1gets(infile, buf, sizeof(buf));
+
+ if (status == EOF)
+ err ("do_p1_ident: Missing charp ident string at end of file");
+ else if (status == 0)
+ err ("do_p1_ident: Missing charp ident string in intermediate file");
+ addrp->uname_tag = UNAM_CHARP;
+ addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
+ return (expptr) addrp;
+}
+
+
+static expptr do_p1_extern (infile)
+FILE *infile;
+{
+ Addrp addrp;
+
+ addrp = ALLOC (Addrblock);
+ if (addrp) {
+ int status;
+
+ addrp->tag = TADDR;
+ addrp->vstg = STGEXT;
+ addrp->uname_tag = UNAM_EXTERN;
+ status = p1getd (infile, &(addrp -> memno));
+ if (status == EOF)
+ err ("do_p1_extern: Missing memno at end of file");
+ else if (status == 0)
+ err ("do_p1_extern: Missing memno in intermediate file");
+ if (addrp->vtype = extsymtab[addrp->memno].extype)
+ addrp->vclass = CLPROC;
+ } /* if addrp */
+
+ return (expptr) addrp;
+} /* do_p1_extern */
+
+
+
+static expptr do_p1_head (infile, outfile)
+FILE *infile, *outfile;
+{
+ int status;
+ int add_n_;
+ long class;
+ char storage[256];
+
+ status = p1getd (infile, &class);
+ if (status == EOF)
+ err ("do_p1_head: missing header class at end of file");
+ else if (status == 0)
+ err ("do_p1_head: missing header class in p1 file");
+ else {
+ status = p1gets (infile, storage, sizeof(storage));
+ if (status == EOF || status == 0)
+ storage[0] = '\0';
+ } /* else */
+
+ if (class == CLPROC || class == CLMAIN) {
+ chainp lengths;
+
+ add_n_ = nentry > 1;
+ lengths = length_comp(entries, add_n_);
+
+ if (!add_n_ && protofile && class != CLMAIN)
+ protowrite(protofile, proctype, storage, entries, lengths);
+
+ if (class == CLMAIN)
+ nice_printf (outfile, "/* Main program */ ");
+ else
+ nice_printf(outfile, "%s ", multitype ? "VOID"
+ : c_type_decl(proctype, 1));
+
+ nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
+ if (!Ansi) {
+ listargs(outfile, entries, add_n_, lengths);
+ nice_printf (outfile, "\n");
+ }
+ list_arg_types (outfile, entries, lengths, add_n_, "\n");
+ nice_printf (outfile, "{\n");
+ frchain(&lengths);
+ next_tab (outfile);
+ strcpy(this_proc_name, storage);
+ list_decls (outfile);
+
+ } else if (class == CLBLOCK)
+ next_tab (outfile);
+ else
+ errl("do_p1_head: got class %ld", class);
+
+ return NULL;
+} /* do_p1_head */
+
+
+static expptr do_p1_list (infile, outfile)
+FILE *infile, *outfile;
+{
+ long tag, type, count;
+ int status;
+ expptr result;
+
+ status = p1getd (infile, &tag);
+ if (status == EOF)
+ err ("do_p1_list: missing list tag at end of file");
+ else if (status == 0)
+ err ("do_p1_list: missing list tag in p1 file");
+ else {
+ status = p1getd (infile, &type);
+ if (status == EOF)
+ err ("do_p1_list: missing list type at end of file");
+ else if (status == 0)
+ err ("do_p1_list: missing list type in p1 file");
+ else {
+ status = p1getd (infile, &count);
+ if (status == EOF)
+ err ("do_p1_list: missing count at end of file");
+ else if (status == 0)
+ err ("do_p1_list: missing count in p1 file");
+ } /* else */
+ } /* else */
+
+ result = (expptr) ALLOC (Listblock);
+ if (result) {
+ chainp pointer;
+
+ result -> tag = tag;
+ result -> listblock.vtype = type;
+
+/* Assume there will be enough data */
+
+ if (count--) {
+ pointer = result->listblock.listp =
+ mkchain((char *)do_format(infile, outfile), CHNULL);
+ while (count--) {
+ pointer -> nextp =
+ mkchain((char *)do_format(infile, outfile), CHNULL);
+ pointer = pointer -> nextp;
+ } /* while (count--) */
+ } /* if (count) */
+ } /* if (result) */
+
+ return result;
+} /* do_p1_list */
+
+
+chainp length_comp(e, add_n) /* get lengths of characters args */
+ struct Entrypoint *e;
+ int add_n;
+{
+ chainp lengths;
+ chainp args, args1;
+ Namep arg, np;
+ int nchargs;
+ Argtypes *at;
+ Atype *a;
+
+ args = args1 = add_n ? allargs : e->arglist;
+ nchargs = 0;
+ for (lengths = NULL; args; args = args -> nextp)
+ if ((arg = (Namep)args->datap)
+ && arg->vtype == TYCHAR
+ && arg->vclass != CLPROC) {
+ lengths = mkchain((char *)arg, lengths);
+ nchargs++;
+ }
+ if (!add_n && (np = e->enamep)) {
+ /* one last check -- by now we know all we ever will
+ * about external args...
+ */
+ save_argtypes(e->arglist, &e->entryname->arginfo,
+ &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
+ np->vtype);
+ at = e->entryname->arginfo;
+ for(a = at->atypes; args1; a++, args1 = args1->nextp) {
+ frchain(&a->cp);
+ if (arg = (Namep)args1->datap)
+ switch(arg->vclass) {
+ case CLPROC:
+ if (arg->vimpltype
+ && a->type >= 300)
+ a->type = TYUNKNOWN + 200;
+ break;
+ case CLUNKNOWN:
+ a->type %= 100;
+ }
+ }
+ }
+ return revchain(lengths);
+ }
+
+void listargs(outfile, entryp, add_n_, lengths)
+ FILE *outfile;
+ struct Entrypoint *entryp;
+ int add_n_;
+ chainp lengths;
+{
+ chainp args;
+ char *s;
+ Namep arg;
+ int did_one = 0;
+
+ nice_printf (outfile, "(");
+
+ if (add_n_) {
+ nice_printf(outfile, "n__");
+ did_one = 1;
+ args = allargs;
+ }
+ else
+ args = entryp->arglist;
+
+ if (multitype)
+ {
+ nice_printf(outfile, ", ret_val");
+ did_one = 1;
+ args = allargs;
+ }
+ else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
+ {
+ s = xretslot[proctype]->user.ident;
+ nice_printf(outfile, did_one ? ", %s" : "%s",
+ *s == '(' /*)*/ ? "r_v" : s);
+ did_one = 1;
+ if (proctype == TYCHAR)
+ nice_printf (outfile, ", ret_val_len");
+ }
+ for (; args; args = args -> nextp)
+ if (arg = (Namep)args->datap) {
+ nice_printf (outfile, "%s", did_one ? ", " : "");
+ out_name (outfile, arg);
+ did_one = 1;
+ }
+
+ for (args = lengths; args; args = args -> nextp)
+ nice_printf(outfile, ", %s",
+ new_arg_length((Namep)args->datap));
+ nice_printf (outfile, ")");
+} /* listargs */
+
+
+void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
+FILE *outfile;
+struct Entrypoint *entryp;
+chainp lengths;
+int add_n_;
+char *finalnl;
+{
+ chainp args;
+ int last_type = -1, last_class = -1;
+ int did_one = 0, done_one;
+ char *s, *sep = "", *sep1;
+
+ if (outfile == (FILE *) NULL) {
+ err ("list_arg_types: null output file");
+ return;
+ } else if (entryp == (struct Entrypoint *) NULL) {
+ err ("list_arg_types: null procedure entry pointer");
+ return;
+ } /* else */
+
+ if (Ansi) {
+ done_one = 0;
+ sep1 = ", ";
+ nice_printf(outfile, "(" /*)*/);
+ }
+ else {
+ done_one = 1;
+ sep1 = ";\n";
+ }
+ args = entryp->arglist;
+ if (add_n_) {
+ nice_printf(outfile, "int n__");
+ did_one = done_one;
+ sep = sep1;
+ args = allargs;
+ }
+ if (multitype) {
+ nice_printf(outfile, "%sMultitype *ret_val", sep);
+ did_one = done_one;
+ sep = sep1;
+ }
+ else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
+ s = xretslot[proctype]->user.ident;
+ nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
+ *s == '(' /*)*/ ? "r_v" : s);
+ did_one = done_one;
+ sep = sep1;
+ if (proctype == TYCHAR)
+ nice_printf (outfile, "%sftnlen ret_val_len", sep);
+ } /* if ONEOF proctype */
+ for (; args; args = args -> nextp) {
+ Namep arg = (Namep) args->datap;
+
+/* Scalars are passed by reference, and arrays will have their lower bound
+ adjusted, so nearly everything is printed with a star in front. The
+ exception is character lengths, which are passed by value. */
+
+ if (arg) {
+ int type = arg -> vtype, class = arg -> vclass;
+
+ if (class == CLPROC)
+ if (arg->vimpltype)
+ type = Castargs ? TYUNKNOWN : TYSUBR;
+ else if (type == TYREAL && forcedouble && !Castargs)
+ type = TYDREAL;
+
+ if (type == last_type && class == last_class && did_one)
+ nice_printf (outfile, ", ");
+ else
+ if (class == CLPROC && Castargs)
+ nice_printf(outfile, "%s%s ", sep,
+ usedcasts[type] = casttypes[type]);
+ else
+ nice_printf(outfile, "%s%s ", sep,
+ c_type_decl(type, 0));
+ if (class == CLPROC)
+ if (Castargs)
+ out_name(outfile, arg);
+ else {
+ nice_printf(outfile, "(*");
+ out_name(outfile, arg);
+ nice_printf(outfile, ") %s", parens);
+ }
+ else {
+ nice_printf (outfile, "*");
+ out_name (outfile, arg);
+ }
+
+ last_type = type;
+ last_class = class;
+ did_one = done_one;
+ sep = sep1;
+ } /* if (arg) */
+ } /* for args = entryp -> arglist */
+
+ for (args = lengths; args; args = args -> nextp)
+ nice_printf(outfile, "%sftnlen %s", sep,
+ new_arg_length((Namep)args->datap));
+ if (did_one)
+ nice_printf (outfile, ";\n");
+ else if (Ansi)
+ nice_printf(outfile,
+ /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
+ finalnl);
+} /* list_arg_types */
+
+ static void
+write_formats(outfile)
+ FILE *outfile;
+{
+ register struct Labelblock *lp;
+ int first = 1;
+ extern int in_string;
+ char *fs;
+
+ for(lp = labeltab ; lp < highlabtab ; ++lp)
+ if (lp->fmtlabused) {
+ if (first) {
+ first = 0;
+ nice_printf(outfile, "/* Format strings */\n");
+ }
+ nice_printf(outfile, "static char fmt_%ld[] = \"",
+ lp->stateno);
+ in_string = 1;
+ if (!(fs = lp->fmtstring))
+ fs = "";
+ nice_printf(outfile, "%s\"", fs);
+ in_string = 0;
+ nice_printf(outfile, ";\n");
+ }
+ if (!first)
+ nice_printf(outfile, "\n");
+ }
+
+ static void
+write_ioblocks(outfile)
+ FILE *outfile;
+{
+ register iob_data *L;
+ register char *f, **s, *sep;
+
+ nice_printf(outfile, "/* Fortran I/O blocks */\n");
+ L = iob_list = (iob_data *)revchain((chainp)iob_list);
+ do {
+ nice_printf(outfile, "static %s %s = { ",
+ L->type, L->name);
+ sep = 0;
+ for(s = L->fields; f = *s; s++) {
+ if (sep)
+ nice_printf(outfile, sep);
+ sep = ", ";
+ if (*f == '"') { /* kludge */
+ nice_printf(outfile, "\"");
+ in_string = 1;
+ nice_printf(outfile, "%s\"", f+1);
+ in_string = 0;
+ }
+ else
+ nice_printf(outfile, "%s", f);
+ }
+ nice_printf(outfile, " };\n");
+ }
+ while(L = L->next);
+ nice_printf(outfile, "\n\n");
+ }
+
+ static void
+write_assigned_fmts(outfile)
+ FILE *outfile;
+{
+ register chainp cp;
+ Namep np;
+ int did_one = 0;
+
+ cp = assigned_fmts = revchain(assigned_fmts);
+ nice_printf(outfile, "/* Assigned format variables */\nchar ");
+ do {
+ np = (Namep)cp->datap;
+ if (did_one)
+ nice_printf(outfile, ", ");
+ did_one = 1;
+ nice_printf(outfile, "*%s_fmt", np->fvarname);
+ }
+ while(cp = cp->nextp);
+ nice_printf(outfile, ";\n\n");
+ }
+
+ static char *
+to_upper(s)
+ register char *s;
+{
+ static char buf[64];
+ register char *t = buf;
+ register int c;
+ while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
+ return buf;
+ }
+
+
+/* This routine creates static structures representing a namelist.
+ Declarations of the namelist and related structures are:
+
+ struct Vardesc {
+ char *name;
+ char *addr;
+ Long *dims; /* laid out as struct dimensions below *//*
+ int type;
+ };
+ typedef struct Vardesc Vardesc;
+
+ struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+
+ struct dimensions
+ {
+ long numberofdimensions;
+ long numberofelements
+ long baseoffset;
+ long span[numberofdimensions-1];
+ };
+
+ If dims is not null, then the corner element of the array is at
+ addr. However, the element with subscripts (i1,...,in) is at
+ addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
+*/
+
+ static void
+write_namelists(nmch, outfile)
+ chainp nmch;
+ FILE *outfile;
+{
+ Namep var;
+ struct Hashentry *entry;
+ struct Dimblock *dimp;
+ int i, nd, type;
+ char *comma, *name;
+ register chainp q;
+ register Namep v;
+
+ nice_printf(outfile, "/* Namelist stuff */\n\n");
+ for (entry = hashtab; entry < lasthash; ++entry) {
+ if (!(v = entry->varp) || !v->vnamelist)
+ continue;
+ type = v->vtype;
+ name = v->cvarname;
+ if (dimp = v->vdim) {
+ nd = dimp->ndim;
+ nice_printf(outfile,
+ "static Long %s_dims[] = { %d, %ld, %ld",
+ name, nd,
+ dimp->nelt->constblock.Const.ci,
+ dimp->baseoffset->constblock.Const.ci);
+ for(i = 0, --nd; i < nd; i++)
+ nice_printf(outfile, ", %ld",
+ dimp->dims[i].dimsize->constblock.Const.ci);
+ nice_printf(outfile, " };\n");
+ }
+ nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
+ name, to_upper(name),
+ type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&");
+ out_name(outfile, v);
+ nice_printf(outfile, dimp ? ", %s_dims" : ", (Long *)0", name);
+ nice_printf(outfile, ", %ld };\n",
+ type != TYCHAR ? (long)type
+ : -v->vleng->constblock.Const.ci);
+ }
+
+ do {
+ var = (Namep)nmch->datap;
+ name = var->cvarname;
+ nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
+ comma = "{";
+ i = 0;
+ for(q = var->varxptr.namelist ; q ; q = q->nextp) {
+ v = (Namep)q->datap;
+ if (!v->vnamelist)
+ continue;
+ i++;
+ nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
+ comma = ",";
+ }
+ nice_printf(outfile, " };\n");
+ nice_printf(outfile,
+ "static Namelist %s = { \"%s\", %s_vl, %d };\n",
+ name, to_upper(name), name, i);
+ }
+ while(nmch = nmch->nextp);
+ nice_printf(outfile, "\n");
+ }
+
+/* fixextype tries to infer from usage in previous procedures
+ the type of an external procedure declared
+ external and passed as an argument but never typed or invoked.
+ */
+
+ static int
+fixexttype(var)
+ Namep var;
+{
+ Extsym *e;
+ int type, type1;
+ extern void changedtype();
+
+ type = var->vtype;
+ e = &extsymtab[var->vardesc.varno];
+ if ((type1 = e->extype) && type == TYUNKNOWN)
+ return var->vtype = type1;
+ if (var->visused) {
+ if (e->exused && type != type1)
+ changedtype(var);
+ e->exused = 1;
+ e->extype = type;
+ }
+ return type;
+ }
+
+list_decls (outfile)
+FILE *outfile;
+{
+ extern chainp used_builtins;
+ extern struct Hashentry *hashtab;
+ extern void wr_char_len();
+ struct Hashentry *entry;
+ int write_header = 1;
+ int last_class = -1, last_stg = -1;
+ Namep var;
+ int Alias, Define, did_one, last_type, type;
+ extern int def_equivs, useauto;
+ extern chainp new_vars; /* Compiler-generated locals */
+ chainp namelists = 0;
+ char *ctype;
+ long lineno_save = lineno;
+ int useauto1 = useauto && !saveall;
+
+ lineno = old_lineno;
+
+/* First write out the statically initialized data */
+
+ if (initfile)
+ list_init_data(&initfile, initfname, outfile);
+
+/* Next come formats */
+ write_formats(outfile);
+
+/* Now write out the system-generated identifiers */
+
+ if (new_vars || nequiv) {
+ chainp args, next_var, this_var;
+ chainp nv[TYVOID], nv1[TYVOID];
+ int i, j;
+ Addrp Var;
+ Namep arg;
+
+ /* zap unused dimension variables */
+
+ for(args = allargs; args; args = args->nextp) {
+ arg = (Namep)args->datap;
+ if (this_var = arg->vlastdim) {
+ frexpr((tagptr)this_var->datap);
+ this_var->datap = 0;
+ }
+ }
+
+ /* sort new_vars by type, skipping entries just zapped */
+
+ for(i = TYADDR; i < TYVOID; i++)
+ nv[i] = 0;
+ for(this_var = new_vars; this_var; this_var = next_var) {
+ next_var = this_var->nextp;
+ if (Var = (Addrp)this_var->datap) {
+ if (!(this_var->nextp = nv[j = Var->vtype]))
+ nv1[j] = this_var;
+ nv[j] = this_var;
+ }
+ else {
+ this_var->nextp = 0;
+ frchain(&this_var);
+ }
+ }
+ new_vars = 0;
+ for(i = TYVOID; --i >= TYADDR;)
+ if (this_var = nv[i]) {
+ nv1[i]->nextp = new_vars;
+ new_vars = this_var;
+ }
+
+ /* write the declarations */
+
+ did_one = 0;
+ last_type = -1;
+
+ for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+ Var = (Addrp) this_var->datap;
+
+ if (Var == (Addrp) NULL)
+ err ("list_decls: null variable");
+ else if (Var -> tag != TADDR)
+ erri ("list_decls: bad tag on new variable '%d'",
+ Var -> tag);
+
+ type = nv_type (Var);
+ if (Var->vstg == STGINIT
+ || Var->uname_tag == UNAM_IDENT
+ && *Var->user.ident == ' '
+ && multitype)
+ continue;
+ if (!did_one)
+ nice_printf (outfile, "/* System generated locals */\n");
+
+ if (last_type == type && did_one)
+ nice_printf (outfile, ", ");
+ else {
+ if (did_one)
+ nice_printf (outfile, ";\n");
+ nice_printf (outfile, "%s ",
+ c_type_decl (type, Var -> vclass == CLPROC));
+ } /* else */
+
+/* Character type is really a string type. Put out a '*' for parameters
+ with unknown length and functions returning character */
+
+ if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
+ || Var -> vclass == CLPROC))
+ nice_printf (outfile, "*");
+
+ write_nv_ident(outfile, (Addrp)this_var->datap);
+ if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
+ ISICON((Var -> vleng))
+ && (i = Var->vleng->constblock.Const.ci) > 0)
+ nice_printf (outfile, "[%d]", i);
+
+ did_one = 1;
+ last_type = nv_type (Var);
+ } /* for this_var */
+
+/* Handle the uninitialized equivalences */
+
+ do_uninit_equivs (outfile, &did_one);
+
+ if (did_one)
+ nice_printf (outfile, ";\n\n");
+ } /* if new_vars */
+
+/* Write out builtin declarations */
+
+ if (used_builtins) {
+ chainp cp;
+ Extsym *es;
+
+ last_type = -1;
+ did_one = 0;
+
+ nice_printf (outfile, "/* Builtin functions */");
+
+ for (cp = used_builtins; cp; cp = cp -> nextp) {
+ Addrp e = (Addrp)cp->datap;
+
+ switch(type = e->vtype) {
+ case TYDREAL:
+ case TYREAL:
+ /* if (forcedouble || e->dbl_builtin) */
+ /* libF77 currently assumes everything double */
+ type = TYDREAL;
+ ctype = "double";
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ type = TYVOID;
+ /* no break */
+ default:
+ ctype = c_type_decl(type, 0);
+ }
+
+ if (did_one && last_type == type)
+ nice_printf(outfile, ", ");
+ else
+ nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
+
+ extern_out(outfile, es = &extsymtab[e -> memno]);
+ proto(outfile, es->arginfo, es->fextname);
+ last_type = type;
+ did_one = 1;
+ } /* for cp = used_builtins */
+
+ nice_printf (outfile, ";\n\n");
+ } /* if used_builtins */
+
+ last_type = -1;
+ for (entry = hashtab; entry < lasthash; ++entry) {
+ var = entry -> varp;
+
+ if (var) {
+ int procclass = var -> vprocclass;
+ char *comment = NULL;
+ int stg = var -> vstg;
+ int class = var -> vclass;
+ type = var -> vtype;
+
+ if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
+ continue;
+
+ if (useauto1 && stg == STGBSS && !var->vsave)
+ stg = STGAUTO;
+
+ switch (class) {
+ case CLVAR:
+ break;
+ case CLPROC:
+ switch(procclass) {
+ case PTHISPROC:
+ extsymtab[var->vardesc.varno].extype = type;
+ continue;
+ case PSTFUNCT:
+ case PINTRINSIC:
+ continue;
+ case PUNKNOWN:
+ err ("list_decls: unknown procedure class");
+ continue;
+ case PEXTERNAL:
+ if (stg == STGUNKNOWN) {
+ warn1(
+ "%.64s declared EXTERNAL but never used.",
+ var->fvarname);
+ /* to retain names declared EXTERNAL */
+ /* but not referenced, change
+ /* "continue" to "stg = STGEXT" */
+ continue;
+ }
+ else
+ type = fixexttype(var);
+ }
+ break;
+ case CLUNKNOWN:
+ /* declared but never used */
+ continue;
+ case CLPARAM:
+ continue;
+ case CLNAMELIST:
+ if (var->visused)
+ namelists = mkchain((char *)var, namelists);
+ continue;
+ default:
+ erri("list_decls: can't handle class '%d' yet",
+ class);
+ Fatal(var->fvarname);
+ continue;
+ } /* switch */
+
+ /* Might be equivalenced to a common. If not, don't process */
+ if (stg == STGCOMMON && !var->vcommequiv)
+ continue;
+
+/* Only write the header if system-generated locals, builtins, or
+ uninitialized equivs were already output */
+
+ if (write_header == 1 && (new_vars || nequiv || used_builtins)
+ && oneof_stg ( var, stg,
+ M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
+ nice_printf (outfile, "/* Local variables */\n");
+ write_header = 2;
+ }
+
+
+ Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
+ if (Define = Alias && def_equivs) {
+ if (!write_header)
+ nice_printf(outfile, ";\n");
+ def_start(outfile, var->cvarname, CNULL, "(");
+ goto Alias1;
+ }
+ else if (type == last_type && class == last_class &&
+ stg == last_stg && !write_header)
+ nice_printf (outfile, ", ");
+ else {
+ if (!write_header && ONEOF(stg, M(STGBSS)|
+ M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
+ nice_printf (outfile, ";\n");
+
+ switch (stg) {
+ case STGARG:
+ case STGLENG:
+ /* Part of the argument list, don't write them out
+ again */
+ continue; /* Go back to top of the loop */
+ case STGBSS:
+ case STGEQUIV:
+ case STGCOMMON:
+ nice_printf (outfile, "static ");
+ break;
+ case STGEXT:
+ nice_printf (outfile, "extern ");
+ break;
+ case STGAUTO:
+ break;
+ case STGINIT:
+ case STGUNKNOWN:
+ /* Don't want to touch the initialized data, that will
+ be handled elsewhere. Unknown data have
+ already been complained about, so skip them */
+ continue;
+ default:
+ erri("list_decls: can't handle storage class %d",
+ var->vstg);
+ continue;
+ } /* switch */
+
+ nice_printf (outfile, "%s ", c_type_decl (var -> vtype, var ->
+ vclass == CLPROC));
+ } /* else */
+
+/* Character type is really a string type. Put out a '*' for variable
+ length strings, and also for equivalences */
+
+ if (var -> vtype == TYCHAR && var -> vclass != CLPROC
+ && (!var->vleng || !ISICON (var -> vleng))
+ || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
+ nice_printf (outfile, "*%s", var->cvarname);
+ else {
+ nice_printf (outfile, "%s", var->cvarname);
+ if (var -> vclass == CLPROC)
+ proto(outfile, var->arginfo, var->fvarname);
+ else if (var -> vtype == TYCHAR && ISICON ((var -> vleng)))
+ wr_char_len(outfile, var->vdim,
+ (int)var->vleng->constblock.Const.ci, 0);
+ else if (var -> vdim &&
+ !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
+ comment = wr_ardecls(outfile, var->vdim, 1L);
+ }
+
+ if (comment)
+ nice_printf (outfile, "%s", comment);
+ Alias1:
+ if (Alias) {
+ char *amp, *lp, *name, *rp;
+ char *equiv_name ();
+ ftnint voff = var -> voffset;
+ int et0, expr_type, k;
+ Extsym *E;
+ struct Equivblock *eb;
+ char buf[16];
+
+/* We DON'T want to use oneof_stg here, because we need to distinguish
+ between them */
+
+ if (stg == STGEQUIV) {
+ name = equiv_name(k = var->vardesc.varno, CNULL);
+ eb = eqvclass + k;
+ if (eb->eqvinit) {
+ amp = "&";
+ et0 = TYERROR;
+ }
+ else {
+ amp = "";
+ et0 = eb->eqvtype;
+ }
+ expr_type = et0;
+ }
+ else {
+ E = &extsymtab[var->vardesc.varno];
+ sprintf(name = buf, "%s%d", E->cextname, E->curno);
+ expr_type = type;
+ et0 = -1;
+ amp = "&";
+ } /* else */
+
+ if (!Define)
+ nice_printf (outfile, " = ");
+ if (voff) {
+ k = typesize[type];
+ switch((int)(voff % k)) {
+ case 0:
+ voff /= k;
+ expr_type = type;
+ break;
+ case SZSHORT:
+ case SZSHORT+SZLONG:
+ expr_type = TYSHORT;
+ voff /= SZSHORT;
+ break;
+ case SZLONG:
+ expr_type = TYLONG;
+ voff /= SZLONG;
+ break;
+ default:
+ expr_type = TYCHAR;
+ }
+ }
+
+ if (expr_type == type) {
+ lp = rp = "";
+ if (et0 == -1 && !voff)
+ goto cast;
+ }
+ else {
+ lp = "(";
+ rp = ")";
+ cast:
+ nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
+ }
+
+/* Now worry about computing the offset */
+
+ if (voff) {
+ if (expr_type == et0)
+ nice_printf (outfile, "%s%s + %ld%s",
+ lp, name, voff, rp);
+ else
+ nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
+ c_type_decl (expr_type, 0), amp,
+ name, voff, rp);
+ } else
+ nice_printf(outfile, "%s%s", amp, name);
+/* Always put these at the end of the line */
+ last_type = last_class = last_stg = -1;
+ write_header = 0;
+ if (Define) {
+ ind_printf(0, outfile, ")\n");
+ write_header = 2;
+ }
+ continue;
+ } /* if oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)) */
+ write_header = 0;
+ last_type = type;
+ last_class = class;
+ last_stg = stg;
+ } /* if (var) */
+ } /* for (entry = hashtab */
+
+ if (!write_header)
+ nice_printf (outfile, ";\n\n");
+ else if (write_header == 2)
+ nice_printf(outfile, "\n");
+
+/* Next, namelists, which may reference equivs */
+
+ if (namelists) {
+ write_namelists(namelists = revchain(namelists), outfile);
+ frchain(&namelists);
+ }
+
+/* Finally, ioblocks (which may reference equivs and namelists) */
+ if (iob_list)
+ write_ioblocks(outfile);
+ if (assigned_fmts)
+ write_assigned_fmts(outfile);
+ lineno = lineno_save;
+} /* list_decls */
+
+do_uninit_equivs (outfile, did_one)
+FILE *outfile;
+int *did_one;
+{
+ extern int nequiv;
+ struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
+ int k, last_type = -1, t;
+
+ for (eqv = eqvclass; eqv < lasteqv; eqv++)
+ if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
+ if (!*did_one)
+ nice_printf (outfile, "/* System generated locals */\n");
+ t = eqv->eqvtype;
+ if (last_type == t)
+ nice_printf (outfile, ", ");
+ else {
+ if (*did_one)
+ nice_printf (outfile, ";\n");
+ nice_printf (outfile, "static %s ", c_type_decl(t, 0));
+ k = typesize[t];
+ } /* else */
+ nice_printf(outfile, "%s", equiv_name(eqv - eqvclass, CNULL));
+ nice_printf(outfile, "[%ld]",
+ (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
+ last_type = t;
+ *did_one = 1;
+ } /* if !eqv -> eqvinit */
+} /* do_uninit_equivs */
+
+
+/* wr_ardecls -- Writes the brackets and size for an array
+ declaration. Because of the inner workings of the compiler,
+ multi-dimensional arrays get mapped directly into a one-dimensional
+ array, so we have to compute the size of the array here. When the
+ dimension is greater than 1, a string comment about the original size
+ is returned */
+
+char *wr_ardecls(outfile, dimp, size)
+FILE *outfile;
+struct Dimblock *dimp;
+long size;
+{
+ int i, k;
+ static char buf[1000];
+
+ if (dimp == (struct Dimblock *) NULL)
+ return NULL;
+
+ sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */
+ k = strlen(buf); /* BSD doesn't return char transmitted count */
+
+ for (i = 0; i < dimp -> ndim; i++) {
+ expptr this_size = dimp -> dims[i].dimsize;
+
+ if (!ISICON (this_size))
+ err ("wr_ardecls: nonconstant array size");
+ else {
+ size *= this_size -> constblock.Const.ci;
+ sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
+ k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
+ } /* else */
+ } /* for i = 0 */
+
+ nice_printf (outfile, "[%ld]", size);
+ strcat(buf+k, " */");
+
+ return (i > 1) ? buf : NULL;
+} /* wr_ardecls */
+
+
+
+/* ----------------------------------------------------------------------
+
+ The following routines read from the p1 intermediate file. If
+ that format changes, only these routines need be changed
+
+ ---------------------------------------------------------------------- */
+
+static int get_p1_token (infile)
+FILE *infile;
+{
+ int token = P1_UNKNOWN;
+
+/* NOT PORTABLE!! */
+
+ if (fscanf (infile, "%d", &token) == EOF)
+ return P1_EOF;
+
+/* Skip over the ": " */
+
+ if (getc (infile) != '\n')
+ getc (infile);
+
+ return token;
+} /* get_p1_token */
+
+
+
+/* Returns a (null terminated) string from the input file */
+
+static int p1gets (fp, str, size)
+FILE *fp;
+char *str;
+int size;
+{
+ char *fgets ();
+ char c;
+
+ if (str == NULL)
+ return 0;
+
+ if ((c = getc (fp)) != ' ')
+ ungetc (c, fp);
+
+ if (fgets (str, size, fp)) {
+ int length;
+
+ str[size - 1] = '\0';
+ length = strlen (str);
+
+/* Get rid of the newline */
+
+ if (str[length - 1] == '\n')
+ str[length - 1] = '\0';
+ return 1;
+
+ } else if (feof (fp))
+ return EOF;
+ else
+ return 0;
+} /* p1gets */
+
+
+static int p1get_const (infile, type, resultp)
+FILE *infile;
+int type;
+struct Constblock **resultp;
+{
+ int status;
+ struct Constblock *result;
+
+ if (type != TYCHAR) {
+ *resultp = result = ALLOC(Constblock);
+ result -> tag = TCONST;
+ result -> vtype = type;
+ }
+
+ switch (type) {
+ case TYSHORT:
+ case TYLONG:
+ case TYLOGICAL:
+ status = p1getd (infile, &(result -> Const.ci));
+ break;
+ case TYREAL:
+ case TYDREAL:
+ status = p1getf(infile, &result->Const.cds[0]);
+ result->vstg = 1;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ status = p1getf(infile, &result->Const.cds[0]);
+ if (status && status != EOF)
+ status = p1getf(infile, &result->Const.cds[1]);
+ result->vstg = 1;
+ break;
+ case TYCHAR:
+ status = fscanf(infile, "%lx", resultp);
+ break;
+ default:
+ erri ("p1get_const: bad constant type '%d'", type);
+ status = 0;
+ break;
+ } /* switch */
+
+ return status;
+} /* p1get_const */
+
+static int p1getd (infile, result)
+FILE *infile;
+long *result;
+{
+ return fscanf (infile, "%ld", result);
+} /* p1getd */
+
+ static int
+p1getf(infile, result)
+ FILE *infile;
+ char **result;
+{
+
+ char buf[1324];
+ register int k;
+
+ k = fscanf (infile, "%s", buf);
+ if (k < 1)
+ k = EOF;
+ else
+ strcpy(*result = mem(strlen(buf)+1,0), buf);
+ return k;
+}
+
+static int p1getn (infile, count, result)
+FILE *infile;
+int count;
+char **result;
+{
+
+ char *bufptr;
+ extern ptr ckalloc ();
+
+ bufptr = (char *) ckalloc (count);
+
+ if (result)
+ *result = bufptr;
+
+ for (; !feof (infile) && count > 0; count--)
+ *bufptr++ = getc (infile);
+
+ return feof (infile) ? EOF : 1;
+} /* p1getn */
+
+ static void
+proto(outfile, at, fname)
+ FILE *outfile;
+ Argtypes *at;
+ char *fname;
+{
+ int i, j, k, n;
+ char *comma;
+ Atype *atypes;
+ Namep np;
+ chainp cp;
+ extern void bad_atypes();
+
+ if (at) {
+ /* Correct types that we learn on the fly, e.g.
+ subroutine gotcha(foo)
+ external foo
+ call zap(...,foo,...)
+ call foo(...)
+ */
+ atypes = at->atypes;
+ n = at->nargs;
+ for(i = 0; i++ < n; atypes++) {
+ if (!(cp = atypes->cp))
+ continue;
+ j = atypes->type;
+ do {
+ np = (Namep)cp->datap;
+ k = np->vtype;
+ if (np->vclass == CLPROC) {
+ if (!np->vimpltype && k)
+ k += 200;
+ else {
+ if (j >= 300)
+ j = TYUNKNOWN + 200;
+ continue;
+ }
+ }
+ if (j == k)
+ continue;
+ if (j >= 300
+ || j == 200 && k >= 200)
+ j = k;
+ else {
+ bad_atypes(at,fname,i,j,k,""," and");
+ goto break2;
+ }
+ }
+ while(cp = cp->nextp);
+ atypes->type = j;
+ frchain(&atypes->cp);
+ }
+ }
+ break2:
+ if (parens) {
+ nice_printf(outfile, parens);
+ return;
+ }
+
+ if (!at || (n = at->nargs) < 0) {
+ nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
+ return;
+ }
+
+ if (n == 0) {
+ nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
+ return;
+ }
+
+ atypes = at->atypes;
+ nice_printf(outfile, "(");
+ comma = "";
+ for(; --n >= 0; atypes++) {
+ k = atypes->type;
+ if (k == TYADDR)
+ nice_printf(outfile, "%schar **", comma);
+ else if (k >= 200) {
+ k -= 200;
+ nice_printf(outfile, "%s%s", comma,
+ usedcasts[k] = casttypes[k]);
+ }
+ else if (k >= 100)
+ nice_printf(outfile, "%s%s", comma,
+ c_type_decl(k-100, 0));
+ else
+ nice_printf(outfile, "%s%s *", comma,
+ c_type_decl(k, 0));
+ comma = ", ";
+ }
+ nice_printf(outfile, ")");
+ }
+
+ void
+protowrite(protofile, type, name, e, lengths)
+ FILE *protofile;
+ char *name;
+ struct Entrypoint *e;
+ chainp lengths;
+{
+ extern char used_rets[];
+
+ nice_printf(protofile, "extern %s %s", protorettypes[type], name);
+ list_arg_types(protofile, e, lengths, 0, ";\n");
+ used_rets[type] = 1;
+ }
+
+ static void
+do_p1_1while(outfile)
+ FILE *outfile;
+{
+ if (*wh_next) {
+ nice_printf(outfile,
+ "for(;;) { /* while(complicated condition) */\n" /*}*/ );
+ next_tab(outfile);
+ }
+ else
+ nice_printf(outfile, "while(" /*)*/ );
+ }
+
+ static void
+do_p1_2while(infile, outfile)
+ FILE *infile, *outfile;
+{
+ expptr test;
+
+ test = do_format(infile, outfile);
+ if (*wh_next)
+ nice_printf(outfile, "if (!(");
+ expr_out(outfile, test);
+ if (*wh_next++)
+ nice_printf(outfile, "))\n\tbreak;\n");
+ else {
+ nice_printf(outfile, /*(*/ ") {\n");
+ next_tab(outfile);
+ }
+ }
--- /dev/null
+#define DEF_C_LINE_LENGTH 77
+/* actual max will be 79 */
+
+extern int c_output_line_length; /* max # chars per line in C source
+ code */
+
+char *wr_ardecls (/* FILE *, struct Dimblock * */);
+void list_init_data (), wr_one_init (), wr_output_values ();
+int do_init_data ();
+chainp data_value ();
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+#include "format.h"
+
+#define MAX_INIT_LINE 100
+#define NAME_MAX 64
+
+static int memno2info();
+
+extern int in_string;
+extern char *str_fmt[], *initbname;
+extern void def_start();
+
+void list_init_data(Infile, Inname, outfile)
+ FILE **Infile, *outfile;
+ char *Inname;
+{
+ FILE *sortfp;
+ int status;
+
+ fclose(*Infile);
+ *Infile = 0;
+
+ if (status = dsort(Inname, sortfname))
+ fatali ("sort failed, status %d", status);
+
+ if ((sortfp = fopen(sortfname, textread)) == NULL)
+ Fatal("Couldn't open sorted initialization data");
+
+ do_init_data(outfile, sortfp);
+ fclose(sortfp);
+
+/* Insert a blank line after any initialized data */
+
+ nice_printf (outfile, "\n");
+
+ if (debugflag && infname)
+ /* don't back block data file up -- it won't be overwritten */
+ backup(initfname, initbname);
+} /* list_init_data */
+
+
+
+/* do_init_data -- returns YES when at least one declaration has been
+ written */
+
+int do_init_data(outfile, infile)
+FILE *outfile, *infile;
+{
+ char varname[NAME_MAX], ovarname[NAME_MAX];
+ ftnint offset;
+ ftnint type;
+ int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */
+ int did_one = 0; /* True when one has been output */
+ chainp values = CHNULL; /* Actual data values */
+ int keepit = 0;
+ Namep np;
+
+ ovarname[0] = '\0';
+
+ while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
+ && rdlong (infile, &type)) {
+ if (strcmp (varname, ovarname)) {
+
+ /* If this is a new variable name, the old initialization has been
+ completed */
+
+ wr_one_init(outfile, ovarname, &values, keepit);
+
+ strcpy (ovarname, varname);
+ values = CHNULL;
+ if (vargroup == 0) {
+ if (memno2info(atoi(varname+2), &np)) {
+ if (((Addrp)np)->uname_tag != UNAM_NAME) {
+ err("do_init_data: expected NAME");
+ goto Keep;
+ }
+ np = ((Addrp)np)->user.name;
+ }
+ if (!(keepit = np->visused) && !np->vimpldovar)
+ warn1("local variable %s never used",
+ np->fvarname);
+ }
+ else {
+ Keep:
+ keepit = 1;
+ }
+ if (keepit && !did_one) {
+ nice_printf (outfile, "/* Initialized data */\n\n");
+ did_one = YES;
+ }
+ } /* if strcmp */
+
+ values = mkchain((char *)data_value(infile, offset, (int)type), values);
+ } /* while */
+
+/* Write out the last declaration */
+
+ wr_one_init (outfile, ovarname, &values, keepit);
+
+ return did_one;
+} /* do_init_data */
+
+
+ void
+wr_char_len(outfile, dimp, n, extra1)
+ FILE *outfile;
+ int n;
+ struct Dimblock *dimp;
+ int extra1;
+{
+ int i, nd;
+ expptr e;
+
+ if (!dimp) {
+ nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
+ return;
+ }
+ nice_printf(outfile, "[%d", n);
+ nd = dimp->ndim;
+ for(i = 0; i < nd; i++) {
+ e = dimp->dims[i].dimsize;
+ if (!ISICON (e))
+ err ("wr_char_len: nonconstant array size");
+ else
+ nice_printf(outfile, "*%ld", e->constblock.Const.ci);
+ }
+ /* extra1 allows for stupid C compilers that complain about
+ * too many initializers in
+ * char x[2] = "ab";
+ */
+ nice_printf(outfile, extra1 ? "+1]" : "]");
+ }
+
+ static int ch_ar_dim = -1; /* length of each element of char string array */
+ static int eqvmemno; /* kludge */
+
+ static void
+write_char_init(outfile, Values, namep)
+ FILE *outfile;
+ chainp *Values;
+ Namep namep;
+{
+ struct Equivblock *eqv;
+ long size;
+ struct Dimblock *dimp;
+ int i, nd, type;
+ expptr ds;
+
+ if (!namep)
+ return;
+ if(nequiv >= maxequiv)
+ many("equivalences", 'q', maxequiv);
+ eqv = &eqvclass[nequiv];
+ eqv->eqvbottom = 0;
+ type = namep->vtype;
+ size = type == TYCHAR
+ ? namep->vleng->constblock.Const.ci
+ : typesize[type];
+ if (dimp = namep->vdim)
+ for(i = 0, nd = dimp->ndim; i < nd; i++) {
+ ds = dimp->dims[i].dimsize;
+ if (!ISICON(ds))
+ err("write_char_values: nonconstant array size");
+ else
+ size *= ds->constblock.Const.ci;
+ }
+ *Values = revchain(*Values);
+ eqv->eqvtop = size;
+ eqvmemno = ++lastvarno;
+ eqv->eqvtype = type;
+ wr_equiv_init(outfile, nequiv, Values, 0);
+ def_start(outfile, namep->cvarname, CNULL, "");
+ if (type == TYCHAR)
+ ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
+ else
+ ind_printf(0, outfile, dimp
+ ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
+ c_type_decl(type,0), eqvmemno);
+ }
+
+/* wr_one_init -- outputs the initialization of the variable pointed to
+ by info. When is_addr is true, info is an Addrp; otherwise,
+ treat it as a Namep */
+
+void wr_one_init (outfile, varname, Values, keepit)
+FILE *outfile;
+char *varname;
+chainp *Values;
+int keepit;
+{
+ static int memno;
+ static union {
+ Namep name;
+ Addrp addr;
+ } info;
+ Namep namep;
+ int is_addr, size;
+ ftnint last, loc;
+ int is_scalar = 0;
+ char *array_comment = NULL;
+ chainp cp, values;
+ extern char datachar[];
+ static int e1[3] = {1, 0, 1};
+
+ if (!keepit)
+ goto done;
+ if (varname == NULL || varname[1] != '.')
+ goto badvar;
+
+/* Get back to a meaningful representation; find the given memno in one
+ of the appropriate tables (user-generated variables in the hash table,
+ system-generated variables in a separate list */
+
+ memno = atoi(varname + 2);
+ switch(varname[0]) {
+ case 'q':
+ /* Must subtract eqvstart when the source file
+ * contains more than one procedure.
+ */
+ wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
+ goto done;
+ case 'Q':
+ /* COMMON initialization (BLOCK DATA) */
+ wr_equiv_init(outfile, memno, Values, 1);
+ goto done;
+ case 'v':
+ break;
+ default:
+ badvar:
+ errstr("wr_one_init: unknown variable name '%s'", varname);
+ goto done;
+ }
+
+ is_addr = memno2info (memno, &info.name);
+ if (info.name == (Namep) NULL) {
+ err ("wr_one_init -- unknown variable");
+ return;
+ }
+ if (is_addr) {
+ if (info.addr -> uname_tag != UNAM_NAME) {
+ erri ("wr_one_init -- couldn't get name pointer; tag is %d",
+ info.addr -> uname_tag);
+ namep = (Namep) NULL;
+ nice_printf (outfile, " /* bad init data */");
+ } else
+ namep = info.addr -> user.name;
+ } else
+ namep = info.name;
+
+ /* check for character initialization */
+
+ *Values = values = revchain(*Values);
+ if (info.name->vtype == TYCHAR) {
+ for(last = 1; values; values = values->nextp) {
+ cp = (chainp)values->datap;
+ loc = (ftnint)cp->datap;
+ if (loc > last) {
+ write_char_init(outfile, Values, namep);
+ goto done;
+ }
+ last = (int)cp->nextp->datap == TYBLANK
+ ? loc + (int)cp->nextp->nextp->datap
+ : loc + 1;
+ }
+ }
+ else {
+ size = typesize[info.name->vtype];
+ loc = 0;
+ for(; values; values = values->nextp) {
+ if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
+ write_char_init(outfile, Values, namep);
+ goto done;
+ }
+ last = ((long) ((chainp) values->datap)->datap) / size;
+ if (last - loc > 4) {
+ write_char_init(outfile, Values, namep);
+ goto done;
+ }
+ loc = last;
+ }
+ }
+ values = *Values;
+
+ nice_printf (outfile, "static %s ", c_type_decl (info.name -> vtype, 0));
+
+ if (is_addr)
+ write_nv_ident (outfile, info.addr);
+ else
+ out_name (outfile, info.name);
+
+ if (namep)
+ is_scalar = namep -> vdim == (struct Dimblock *) NULL;
+
+ if (namep && !is_scalar)
+ array_comment = info.name->vtype == TYCHAR
+ ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
+
+ if (info.name -> vtype == TYCHAR)
+ if (ISICON (info.name -> vleng))
+
+/* We'll make single strings one character longer, so that we can use the
+ standard C initialization. All this does is pad an extra zero onto the
+ end of the string */
+ wr_char_len(outfile, namep->vdim, ch_ar_dim =
+ info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
+ else
+ err ("variable length character initialization");
+
+ if (array_comment)
+ nice_printf (outfile, "%s", array_comment);
+
+ nice_printf (outfile, " = ");
+ wr_output_values (outfile, namep, values);
+ ch_ar_dim = -1;
+ nice_printf (outfile, ";\n");
+ done:
+ frchain(Values);
+} /* wr_one_init */
+
+
+
+
+chainp data_value (infile, offset, type)
+FILE *infile;
+ftnint offset;
+int type;
+{
+ char line[MAX_INIT_LINE + 1], *pointer;
+ chainp vals, prev_val;
+ long atol();
+ char *newval;
+
+ if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
+ err ("data_value: error reading from intermediate file");
+ return CHNULL;
+ } /* if fgets */
+
+/* Get rid of the trailing newline */
+
+ if (line[0])
+ line[strlen (line) - 1] = '\0';
+
+#define iswhite(x) (isspace (x) || (x) == ',')
+
+ pointer = line;
+ prev_val = vals = CHNULL;
+
+ while (*pointer) {
+ register char *end_ptr, old_val;
+
+/* Move pointer to the start of the next word */
+
+ while (*pointer && iswhite (*pointer))
+ pointer++;
+ if (*pointer == '\0')
+ break;
+
+/* Move end_ptr to the end of the current word */
+
+ for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
+ end_ptr++)
+ ;
+
+ old_val = *end_ptr;
+ *end_ptr = '\0';
+
+/* Add this value to the end of the list */
+
+ if (ONEOF(type, MSKREAL|MSKCOMPLEX))
+ newval = cpstring(pointer);
+ else
+ newval = (char *)atol(pointer);
+ if (vals) {
+ prev_val->nextp = mkchain(newval, CHNULL);
+ prev_val = prev_val -> nextp;
+ } else
+ prev_val = vals = mkchain(newval, CHNULL);
+ *end_ptr = old_val;
+ pointer = end_ptr;
+ } /* while *pointer */
+
+ return mkchain((char *)offset, mkchain((char *)type, vals));
+} /* data_value */
+
+ static void
+overlapping()
+{
+ extern char *filename0;
+ static int warned = 0;
+
+ if (warned)
+ return;
+ warned = 1;
+
+ fprintf(stderr, "Error");
+ if (filename0)
+ fprintf(stderr, " in file %s", filename0);
+ fprintf(stderr, ": overlapping initializations\n");
+ nerr++;
+ }
+
+ static void make_one_const();
+ static long charlen;
+
+void wr_output_values (outfile, namep, values)
+FILE *outfile;
+Namep namep;
+chainp values;
+{
+ int type = TYUNKNOWN;
+ struct Constblock Const;
+ static expptr Vlen;
+
+ if (namep)
+ type = namep -> vtype;
+
+/* Handle array initializations away from scalars */
+
+ if (namep && namep -> vdim)
+ wr_array_init (outfile, namep -> vtype, values);
+
+ else if (values->nextp && type != TYCHAR)
+ overlapping();
+
+ else {
+ make_one_const(type, &Const.Const, values);
+ Const.vtype = type;
+ Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
+ if (type== TYCHAR) {
+ if (!Vlen)
+ Vlen = ICON(0);
+ Const.vleng = Vlen;
+ Vlen->constblock.Const.ci = charlen;
+ out_const (outfile, &Const);
+ free (Const.Const.ccp);
+ }
+ else
+ out_const (outfile, &Const);
+ }
+ }
+
+
+wr_array_init (outfile, type, values)
+FILE *outfile;
+int type;
+chainp values;
+{
+ int size = typesize[type];
+ long index, main_index = 0;
+ int k;
+
+ if (type == TYCHAR) {
+ nice_printf(outfile, "\"");
+ in_string = 1;
+ k = 0;
+ if (Ansi != 1)
+ ch_ar_dim = -1;
+ }
+ else
+ nice_printf (outfile, "{ ");
+ while (values) {
+ struct Constblock Const;
+
+ index = ((long) ((chainp) values->datap)->datap) / size;
+ while (index > main_index) {
+
+/* Fill with zeros. The structure shorthand works because the compiler
+ will expand the "0" in braces to fill the size of the entire structure
+ */
+
+ switch (type) {
+ case TYREAL:
+ case TYDREAL:
+ nice_printf (outfile, "0.0,");
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ nice_printf (outfile, "{0},");
+ break;
+ case TYCHAR:
+ nice_printf(outfile, " ");
+ break;
+ default:
+ nice_printf (outfile, "0,");
+ break;
+ } /* switch */
+ main_index++;
+ } /* while index > main_index */
+
+ if (index < main_index)
+ overlapping();
+ else switch (type) {
+ case TYCHAR:
+ { int this_char;
+
+ if (k == ch_ar_dim) {
+ nice_printf(outfile, "\"");
+ in_string = 0;
+ nice_printf(outfile, " \"");
+ in_string = 1;
+ k = 0;
+ }
+ this_char = (int) ((chainp) values->datap)->
+ nextp->nextp->datap;
+ if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
+ main_index += this_char;
+ k += this_char;
+ while(--this_char >= 0)
+ nice_printf(outfile, " ");
+ values = values -> nextp;
+ continue;
+ }
+ nice_printf(outfile,
+ str_fmt[this_char & 0x7f],
+ this_char);
+ k++;
+ } /* case TYCHAR */
+ break;
+
+ case TYSHORT:
+ case TYLONG:
+ case TYREAL:
+ case TYDREAL:
+ case TYLOGICAL:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ make_one_const(type, &Const.Const, values);
+ Const.vtype = type;
+ Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
+ out_const(outfile, &Const);
+ break;
+ default:
+ erri("wr_array_init: bad type '%d'", type);
+ break;
+ } /* switch */
+ values = values->nextp;
+
+ main_index++;
+ if (values && type != TYCHAR)
+ nice_printf (outfile, ",");
+ } /* while values */
+
+ if (type == TYCHAR) {
+ nice_printf(outfile, "\"");
+ in_string = 0;
+ }
+ else
+ nice_printf (outfile, " }");
+} /* wr_array_init */
+
+
+ static void
+make_one_const(type, storage, values)
+ int type;
+ union Constant *storage;
+ chainp values;
+{
+ union Constant *Const;
+ register char **L;
+
+ if (type == TYCHAR) {
+ char *str, *str_ptr, *Alloc ();
+ chainp v, prev;
+ int b = 0, k, main_index = 0;
+
+/* Find the max length of init string, by finding the highest offset
+ value stored in the list of initial values */
+
+ for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
+ ;
+ if (prev != CHNULL)
+ k = ((int) (((chainp) prev->datap)->datap)) + 2;
+ /* + 2 above for null char at end */
+ str = Alloc (k);
+ for (str_ptr = str; values; str_ptr++) {
+ int index = (int) (((chainp) values->datap)->datap);
+
+ if (index < main_index)
+ overlapping();
+ while (index > main_index++)
+ *str_ptr++ = ' ';
+
+ k = (int) (((chainp) values->datap)->nextp->nextp->datap);
+ if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
+ b = k;
+ break;
+ }
+ *str_ptr = k;
+ values = values -> nextp;
+ } /* for str_ptr */
+ *str_ptr = '\0';
+ Const = storage;
+ Const -> ccp = str;
+ Const -> ccp1.blanks = b;
+ charlen = str_ptr - str;
+ } else {
+ int i = 0;
+ chainp vals;
+
+ vals = ((chainp)values->datap)->nextp->nextp;
+ if (vals) {
+ L = (char **)storage;
+ do L[i++] = vals->datap;
+ while(vals = vals->nextp);
+ }
+
+ } /* else */
+
+} /* make_one_const */
+
+
+
+rdname (infile, vargroupp, name)
+FILE *infile;
+int *vargroupp;
+char *name;
+{
+ register int i, c;
+
+ c = getc (infile);
+
+ if (feof (infile))
+ return NO;
+
+ *vargroupp = c - '0';
+ for (i = 1;; i++) {
+ if (i >= NAME_MAX)
+ Fatal("rdname: oversize name");
+ c = getc (infile);
+ if (feof (infile))
+ return NO;
+ if (c == '\t')
+ break;
+ *name++ = c;
+ }
+ *name = 0;
+ return YES;
+} /* rdname */
+
+rdlong (infile, n)
+FILE *infile;
+ftnint *n;
+{
+ register int c;
+
+ for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
+ ;
+
+ if (feof (infile))
+ return NO;
+
+ for (*n = 0; isdigit (c); c = getc (infile))
+ *n = 10 * (*n) + c - '0';
+ return YES;
+} /* rdlong */
+
+
+ static int
+memno2info (memno, info)
+ int memno;
+ Namep *info;
+{
+ chainp this_var;
+ extern chainp new_vars;
+ extern struct Hashentry *hashtab, *lasthash;
+ struct Hashentry *entry;
+
+ for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+ Addrp var = (Addrp) this_var->datap;
+
+ if (var == (Addrp) NULL)
+ Fatal("memno2info: null variable");
+ else if (var -> tag != TADDR)
+ Fatal("memno2info: bad tag");
+ if (memno == var -> memno) {
+ *info = (Namep) var;
+ return 1;
+ } /* if memno == var -> memno */
+ } /* for this_var = new_vars */
+
+ for (entry = hashtab; entry < lasthash; ++entry) {
+ Namep var = entry -> varp;
+
+ if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
+ *info = (Namep) var;
+ return 0;
+ } /* if entry -> vardesc.varno == memno */
+ } /* for entry = hashtab */
+
+ Fatal("memno2info: couldn't find memno");
+ return 0;
+} /* memno2info */
+
+ static chainp
+do_string(outfile, v, nloc)
+ FILEP outfile;
+ register chainp v;
+ ftnint *nloc;
+{
+ register chainp cp, v0;
+ ftnint dloc, k, loc;
+ extern char *chr_fmt[];
+ unsigned long uk;
+ char buf[8], *comma;
+
+ nice_printf(outfile, "{");
+ cp = (chainp)v->datap;
+ loc = (ftnint)cp->datap;
+ comma = "";
+ for(v0 = v;;) {
+ switch((int)cp->nextp->datap) {
+ case TYBLANK:
+ k = (ftnint)cp->nextp->nextp->datap;
+ loc += k;
+ while(--k >= 0) {
+ nice_printf(outfile, "%s' '", comma);
+ comma = ", ";
+ }
+ break;
+ case TYCHAR:
+ uk = (ftnint)cp->nextp->nextp->datap;
+ sprintf(buf, chr_fmt[uk < 0x7f ? uk : 0x7f], uk);
+ nice_printf(outfile, "%s'%s'", comma, buf);
+ comma = ", ";
+ loc++;
+ break;
+ default:
+ goto done;
+ }
+ v0 = v;
+ if (!(v = v->nextp))
+ break;
+ cp = (chainp)v->datap;
+ dloc = (ftnint)cp->datap;
+ if (loc != dloc)
+ break;
+ }
+ done:
+ nice_printf(outfile, "}");
+ *nloc = loc;
+ return v0;
+ }
+
+ static chainp
+Ado_string(outfile, v, nloc)
+ FILEP outfile;
+ register chainp v;
+ ftnint *nloc;
+{
+ register chainp cp, v0;
+ ftnint dloc, k, loc;
+
+ nice_printf(outfile, "\"");
+ in_string = 1;
+ cp = (chainp)v->datap;
+ loc = (ftnint)cp->datap;
+ for(v0 = v;;) {
+ switch((int)cp->nextp->datap) {
+ case TYBLANK:
+ k = (ftnint)cp->nextp->nextp->datap;
+ loc += k;
+ while(--k >= 0)
+ nice_printf(outfile, " ");
+ break;
+ case TYCHAR:
+ k = (ftnint)cp->nextp->nextp->datap;
+ nice_printf(outfile, str_fmt[k & 0x7f], k);
+ loc++;
+ break;
+ default:
+ goto done;
+ }
+ v0 = v;
+ if (!(v = v->nextp))
+ break;
+ cp = (chainp)v->datap;
+ dloc = (ftnint)cp->datap;
+ if (loc != dloc)
+ break;
+ }
+ done:
+ nice_printf(outfile, "\"");
+ in_string = 0;
+ *nloc = loc;
+ return v0;
+ }
+
+ static char *
+Len(L)
+ long L;
+{
+ static char buf[24];
+ if (L == 1)
+ return "";
+ sprintf(buf, "[%ld]", L);
+ return buf;
+ }
+
+wr_equiv_init(outfile, memno, Values, iscomm)
+ FILE *outfile;
+ int memno;
+ chainp *Values;
+ int iscomm;
+{
+ struct Equivblock *eqv;
+ char *equiv_name ();
+ int curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
+ static char Blank[] = "";
+ register char *comma = Blank;
+ register chainp cp, v;
+ chainp sentinel, values, v1;
+ ftnint L, L1, dL, dloc, loc, loc0;
+ union Constant Const;
+ char imag_buf[50], real_buf[50];
+ int szshort = typesize[TYSHORT];
+ static char typepref[] = {0, 0, TYSHORT, TYLONG, TYREAL, TYDREAL,
+ TYREAL, TYDREAL, TYLOGICAL, TYCHAR};
+ char *z;
+
+ /* add sentinel */
+ if (iscomm) {
+ L = extsymtab[memno].maxleng;
+ xtype = extsymtab[memno].extype;
+ }
+ else {
+ eqv = &eqvclass[memno];
+ L = eqv->eqvtop - eqv->eqvbottom;
+ xtype = eqv->eqvtype;
+ }
+
+ if (xtype != TYCHAR) {
+
+ /* unless the data include a value of the appropriate
+ * type, we add an extra element in an attempt
+ * to force correct alignment */
+
+ for(v = *Values;;v = v->nextp) {
+ if (!v) {
+ dtype = typepref[xtype];
+ z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
+ k = typesize[dtype];
+ if (j = L % k)
+ L += k - j;
+ v = mkchain((char *)L,
+ mkchain((char *)dtype,
+ mkchain(z, CHNULL)));
+ *Values = mkchain((char *)v, *Values);
+ L += k;
+ break;
+ }
+ if ((int)((chainp)v->datap)->nextp->datap == xtype)
+ break;
+ }
+ }
+
+ sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
+ *Values = values = revchain(mkchain((char *)sentinel, *Values));
+
+ /* use doublereal fillers only if there are doublereal values */
+
+ k = TYLONG;
+ for(v = values; v; v = v->nextp)
+ if (ONEOF((int)((chainp)v->datap)->nextp->datap,
+ M(TYDREAL)|M(TYDCOMPLEX))) {
+ k = TYDREAL;
+ break;
+ }
+ type_choice[0] = k;
+
+ nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
+ next_tab(outfile);
+ loc = loc0 = k = 0;
+ curtype = -1;
+ for(v = values; v; v = v->nextp) {
+ cp = (chainp)v->datap;
+ dloc = (ftnint)cp->datap;
+ L = dloc - loc;
+ if (L < 0) {
+ overlapping();
+ v1 = cp;
+ frchain(&v1);
+ v->datap = 0;
+ continue;
+ }
+ dtype = (int)cp->nextp->datap;
+ if (dtype == TYBLANK) {
+ dtype = TYCHAR;
+ wasblank = 1;
+ }
+ else
+ wasblank = 0;
+ if (curtype != dtype || L > 0) {
+ if (curtype != -1) {
+ L1 = (loc - loc0)/dL;
+ nice_printf(outfile, "%s e_%d%s;\n",
+ typename[curtype], ++k, Len(L1));
+ }
+ curtype = dtype;
+ loc0 = dloc;
+ }
+ if (L > 0) {
+ if (xtype == TYCHAR)
+ filltype = TYCHAR;
+ else {
+ filltype = L % szshort ? TYCHAR
+ : type_choice[L/szshort % 4];
+ filltype1 = loc % szshort ? TYCHAR
+ : type_choice[loc/szshort % 4];
+ if (typesize[filltype] > typesize[filltype1])
+ filltype = filltype1;
+ }
+ nice_printf(outfile, "struct { %s filler%s; } e_%d;\n",
+ typename[filltype],
+ Len(L/typesize[filltype]), ++k);
+ loc = dloc;
+ }
+ if (wasblank) {
+ loc += (ftnint)cp->nextp->nextp->datap;
+ dL = 1;
+ }
+ else {
+ dL = typesize[dtype];
+ loc += dL;
+ }
+ }
+ nice_printf(outfile, "} %s = { ", iscomm
+ ? extsymtab[memno].cextname
+ : equiv_name(eqvmemno, CNULL));
+ loc = 0;
+ for(v = values; ; v = v->nextp) {
+ cp = (chainp)v->datap;
+ if (!cp)
+ continue;
+ dtype = (int)cp->nextp->datap;
+ if (dtype == TYERROR)
+ break;
+ dloc = (ftnint)cp->datap;
+ if (dloc > loc) {
+ nice_printf(outfile, "%s{0}", comma);
+ comma = ", ";
+ loc = dloc;
+ }
+ if (comma != Blank)
+ nice_printf(outfile, ", ");
+ comma = ", ";
+ if (dtype == TYCHAR || dtype == TYBLANK) {
+ v = Ansi == 1 ? Ado_string(outfile, v, &loc)
+ : do_string(outfile, v, &loc);
+ continue;
+ }
+ make_one_const(dtype, &Const, v);
+ switch(dtype) {
+ case TYLOGICAL:
+ if (Const.ci < 0 || Const.ci > 1)
+ errl(
+ "wr_equiv_init: unexpected logical value %ld",
+ Const.ci);
+ nice_printf(outfile,
+ Const.ci ? "TRUE_" : "FALSE_");
+ break;
+ case TYSHORT:
+ case TYLONG:
+ nice_printf(outfile, "%ld", Const.ci);
+ break;
+ case TYREAL:
+ nice_printf(outfile, "%s",
+ flconst(real_buf, Const.cds[0]));
+ break;
+ case TYDREAL:
+ nice_printf(outfile, "%s", Const.cds[0]);
+ break;
+ case TYCOMPLEX:
+ nice_printf(outfile, "%s, %s",
+ flconst(real_buf, Const.cds[0]),
+ flconst(imag_buf, Const.cds[1]));
+ break;
+ case TYDCOMPLEX:
+ nice_printf(outfile, "%s, %s",
+ Const.cds[0], Const.cds[1]);
+ break;
+ default:
+ erri("unexpected type %d in wr_equiv_init",
+ dtype);
+ }
+ loc += typesize[dtype];
+ }
+ nice_printf(outfile, " };\n\n");
+ prev_tab(outfile);
+ frchain(&sentinel);
+ }
--- /dev/null
+
+/* variable types (stored in the vtype field of expptr)
+ * numeric assumptions:
+ * int < reals < complexes
+ * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYLOGICAL 8
+#define TYCHAR 9
+#define TYSUBR 10
+#define TYERROR 11
+#define TYCILIST 12
+#define TYICILIST 13
+#define TYOLIST 14
+#define TYCLLIST 15
+#define TYALIST 16
+#define TYINLIST 17
+#define TYVOID 18
+#define TYLABEL 19
+#define TYFTNLEN 20
+/* TYVOID is not in any tables. */
+
+/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by
+ type. Such tables can include the size (in bytes) of objects of a given
+ type, or labels for returning objects of different types from procedures
+ (see array rtvlabels) */
+
+#define NTYPES TYVOID
+#define NTYPES0 TYCILIST
+#define TYBLANK TYSUBR /* Huh? */
+
--- /dev/null
+# define SEOS 1
+# define SCOMMENT 2
+# define SLABEL 3
+# define SUNKNOWN 4
+# define SHOLLERITH 5
+# define SICON 6
+# define SRCON 7
+# define SDCON 8
+# define SBITCON 9
+# define SOCTCON 10
+# define SHEXCON 11
+# define STRUE 12
+# define SFALSE 13
+# define SNAME 14
+# define SNAMEEQ 15
+# define SFIELD 16
+# define SSCALE 17
+# define SINCLUDE 18
+# define SLET 19
+# define SASSIGN 20
+# define SAUTOMATIC 21
+# define SBACKSPACE 22
+# define SBLOCK 23
+# define SCALL 24
+# define SCHARACTER 25
+# define SCLOSE 26
+# define SCOMMON 27
+# define SCOMPLEX 28
+# define SCONTINUE 29
+# define SDATA 30
+# define SDCOMPLEX 31
+# define SDIMENSION 32
+# define SDO 33
+# define SDOUBLE 34
+# define SELSE 35
+# define SELSEIF 36
+# define SEND 37
+# define SENDFILE 38
+# define SENDIF 39
+# define SENTRY 40
+# define SEQUIV 41
+# define SEXTERNAL 42
+# define SFORMAT 43
+# define SFUNCTION 44
+# define SGOTO 45
+# define SASGOTO 46
+# define SCOMPGOTO 47
+# define SARITHIF 48
+# define SLOGIF 49
+# define SIMPLICIT 50
+# define SINQUIRE 51
+# define SINTEGER 52
+# define SINTRINSIC 53
+# define SLOGICAL 54
+# define SNAMELIST 55
+# define SOPEN 56
+# define SPARAM 57
+# define SPAUSE 58
+# define SPRINT 59
+# define SPROGRAM 60
+# define SPUNCH 61
+# define SREAD 62
+# define SREAL 63
+# define SRETURN 64
+# define SREWIND 65
+# define SSAVE 66
+# define SSTATIC 67
+# define SSTOP 68
+# define SSUBROUTINE 69
+# define STHEN 70
+# define STO 71
+# define SUNDEFINED 72
+# define SWRITE 73
+# define SLPAR 74
+# define SRPAR 75
+# define SEQUALS 76
+# define SCOLON 77
+# define SCOMMA 78
+# define SCURRENCY 79
+# define SPLUS 80
+# define SMINUS 81
+# define SSTAR 82
+# define SSLASH 83
+# define SPOWER 84
+# define SCONCAT 85
+# define SAND 86
+# define SOR 87
+# define SNEQV 88
+# define SEQV 89
+# define SNOT 90
+# define SEQ 91
+# define SLT 92
+# define SGT 93
+# define SLE 94
+# define SGE 95
+# define SNE 96
+# define SENDDO 97
+# define SWHILE 98
+# define SSLASHD 99
+
+/* # line 124 "gram.in" */
+# include "defs.h"
+# include "p1defs.h"
+
+static int nstars; /* Number of labels in an
+ alternate return CALL */
+static int ndim;
+static int vartype;
+int new_dcl;
+static ftnint varleng;
+static struct { expptr lb, ub; } dims[MAXDIM+1];
+static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate
+ return CALL */
+
+/* The next two variables are used to verify that each statement might be reached
+ during runtime. lastwasbranch is tested only in the defintion of the
+ stat: nonterminal. */
+
+int lastwasbranch = NO;
+static int thiswasbranch = NO;
+extern ftnint yystno;
+extern flag intonly;
+static chainp datastack;
+extern long laststfcn, thisstno;
+extern int can_include; /* for netlib */
+
+ftnint convci();
+Addrp nextdata();
+expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
+expptr mkcxcon();
+struct Listblock *mklist();
+struct Listblock *mklist();
+struct Impldoblock *mkiodo();
+Extsym *comblock();
+#define ESNULL (Extsym *)0
+#define NPNULL (Namep)0
+#define LBNULL (struct Listblock *)0
+extern void freetemps(), make_param();
+
+ static void
+pop_datastack() {
+ chainp d0 = datastack;
+ if (d0->datap)
+ curdtp = (chainp)d0->datap;
+ datastack = d0->nextp;
+ d0->nextp = 0;
+ frchain(&d0);
+ }
+
+
+/* # line 176 "gram.in" */
+typedef union {
+ int ival;
+ ftnint lval;
+ char *charpval;
+ chainp chval;
+ tagptr tagval;
+ expptr expval;
+ struct Labelblock *labval;
+ struct Nameblock *namval;
+ struct Eqvchain *eqvval;
+ Extsym *extval;
+ } YYSTYPE;
+#define yyclearin yychar = -1
+#define yyerrok yyerrflag = 0
+extern int yychar;
+extern int yyerrflag;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+YYSTYPE yylval, yyval;
+typedef int yytabelem;
+# define YYERRCODE 256
+yytabelem yyexca[] ={
+-1, 1,
+ 0, -1,
+ -2, 0,
+-1, 20,
+ 1, 38,
+ -2, 228,
+-1, 24,
+ 1, 42,
+ -2, 228,
+-1, 122,
+ 6, 240,
+ -2, 228,
+-1, 150,
+ 1, 244,
+ -2, 188,
+-1, 174,
+ 1, 265,
+ 78, 265,
+ -2, 188,
+-1, 223,
+ 77, 173,
+ -2, 139,
+-1, 245,
+ 74, 228,
+ -2, 225,
+-1, 271,
+ 1, 286,
+ -2, 143,
+-1, 275,
+ 1, 295,
+ 78, 295,
+ -2, 145,
+-1, 328,
+ 77, 174,
+ -2, 141,
+-1, 358,
+ 1, 267,
+ 14, 267,
+ 74, 267,
+ 78, 267,
+ -2, 189,
+-1, 436,
+ 91, 0,
+ 92, 0,
+ 93, 0,
+ 94, 0,
+ 95, 0,
+ 96, 0,
+ -2, 153,
+-1, 453,
+ 1, 289,
+ 78, 289,
+ -2, 143,
+-1, 455,
+ 1, 291,
+ 78, 291,
+ -2, 143,
+-1, 457,
+ 1, 293,
+ 78, 293,
+ -2, 143,
+-1, 459,
+ 1, 296,
+ 78, 296,
+ -2, 144,
+-1, 504,
+ 78, 289,
+ -2, 143,
+ };
+# define YYNPROD 301
+# define YYLAST 1346
+yytabelem yyact[]={
+
+ 237, 274, 471, 317, 316, 412, 420, 297, 470, 399,
+ 413, 397, 386, 357, 398, 266, 128, 356, 273, 252,
+ 292, 5, 116, 295, 326, 303, 222, 99, 184, 121,
+ 195, 229, 17, 203, 270, 304, 313, 199, 201, 118,
+ 94, 202, 396, 104, 210, 183, 236, 101, 106, 234,
+ 264, 103, 111, 336, 260, 95, 96, 97, 165, 166,
+ 334, 335, 336, 395, 105, 311, 309, 190, 130, 131,
+ 132, 133, 120, 135, 119, 114, 157, 129, 157, 475,
+ 103, 272, 334, 335, 336, 396, 521, 103, 278, 483,
+ 535, 165, 166, 334, 335, 336, 342, 341, 340, 339,
+ 338, 137, 343, 345, 344, 347, 346, 348, 450, 258,
+ 259, 260, 539, 165, 166, 258, 259, 260, 261, 525,
+ 102, 522, 155, 409, 155, 186, 187, 103, 408, 117,
+ 165, 166, 258, 259, 260, 318, 100, 527, 484, 188,
+ 446, 185, 480, 230, 240, 240, 194, 193, 290, 120,
+ 211, 119, 462, 481, 157, 294, 482, 257, 157, 243,
+ 468, 214, 463, 469, 461, 464, 460, 239, 241, 220,
+ 215, 218, 157, 219, 213, 165, 166, 334, 335, 336,
+ 342, 341, 340, 157, 371, 452, 343, 345, 344, 347,
+ 346, 348, 443, 428, 377, 294, 102, 102, 102, 102,
+ 155, 189, 447, 149, 155, 446, 192, 103, 98, 196,
+ 197, 198, 277, 376, 320, 321, 206, 288, 155, 289,
+ 300, 375, 299, 324, 315, 328, 275, 275, 330, 155,
+ 310, 333, 196, 216, 217, 350, 269, 207, 308, 352,
+ 353, 333, 100, 177, 354, 349, 323, 112, 245, 257,
+ 247, 110, 157, 417, 286, 287, 418, 362, 157, 157,
+ 157, 157, 157, 257, 257, 109, 108, 268, 279, 280,
+ 281, 265, 107, 355, 4, 333, 427, 465, 378, 370,
+ 170, 172, 176, 257, 165, 166, 258, 259, 260, 261,
+ 102, 406, 232, 293, 407, 381, 422, 390, 155, 400,
+ 391, 223, 419, 422, 155, 155, 155, 155, 155, 117,
+ 221, 314, 392, 319, 387, 359, 372, 196, 360, 373,
+ 374, 333, 333, 536, 350, 333, 275, 250, 424, 333,
+ 405, 333, 410, 532, 230, 432, 433, 434, 435, 436,
+ 437, 438, 439, 440, 441, 403, 331, 156, 401, 332,
+ 531, 333, 530, 333, 333, 333, 388, 526, 380, 529,
+ 524, 157, 257, 333, 431, 492, 257, 257, 257, 257,
+ 257, 382, 383, 235, 426, 384, 358, 494, 296, 333,
+ 448, 165, 166, 258, 259, 260, 261, 451, 165, 166,
+ 258, 259, 260, 261, 103, 445, 472, 400, 421, 191,
+ 402, 196, 103, 150, 307, 174, 285, 155, 474, 246,
+ 476, 416, 467, 466, 242, 226, 223, 200, 212, 136,
+ 209, 486, 171, 488, 490, 275, 275, 275, 141, 240,
+ 496, 429, 329, 333, 333, 333, 333, 333, 333, 333,
+ 333, 333, 333, 403, 497, 479, 401, 403, 487, 154,
+ 257, 154, 495, 493, 306, 485, 502, 454, 456, 458,
+ 500, 491, 268, 499, 505, 506, 507, 103, 451, 271,
+ 271, 472, 30, 333, 414, 501, 400, 508, 511, 509,
+ 387, 244, 208, 510, 516, 514, 515, 333, 517, 333,
+ 513, 333, 520, 293, 518, 225, 240, 333, 402, 523,
+ 92, 248, 402, 528, 6, 262, 123, 249, 81, 80,
+ 275, 275, 275, 79, 534, 533, 479, 78, 173, 263,
+ 314, 77, 403, 76, 537, 401, 351, 154, 75, 333,
+ 282, 154, 60, 49, 48, 333, 45, 33, 333, 538,
+ 113, 205, 454, 456, 458, 154, 267, 165, 166, 334,
+ 335, 336, 342, 540, 503, 411, 154, 204, 394, 393,
+ 298, 478, 503, 503, 503, 134, 389, 312, 115, 379,
+ 26, 25, 24, 23, 302, 22, 305, 402, 21, 385,
+ 284, 9, 503, 8, 7, 2, 519, 301, 20, 319,
+ 164, 51, 489, 291, 228, 327, 325, 415, 91, 361,
+ 255, 53, 337, 19, 55, 365, 366, 367, 368, 369,
+ 37, 224, 3, 1, 0, 351, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 154, 0, 0, 0, 0,
+ 0, 154, 154, 154, 154, 154, 0, 0, 0, 267,
+ 0, 512, 267, 267, 165, 166, 334, 335, 336, 342,
+ 341, 340, 339, 338, 0, 343, 345, 344, 347, 346,
+ 348, 165, 166, 334, 335, 336, 342, 341, 453, 455,
+ 457, 0, 343, 345, 344, 347, 346, 348, 0, 0,
+ 305, 0, 459, 0, 0, 0, 0, 165, 166, 334,
+ 335, 336, 342, 341, 340, 339, 338, 351, 343, 345,
+ 344, 347, 346, 348, 444, 0, 0, 0, 449, 165,
+ 166, 334, 335, 336, 342, 341, 340, 339, 338, 0,
+ 343, 345, 344, 347, 346, 348, 165, 166, 334, 335,
+ 336, 342, 0, 0, 154, 0, 498, 343, 345, 344,
+ 347, 346, 348, 0, 0, 267, 0, 0, 0, 0,
+ 0, 442, 0, 504, 455, 457, 165, 166, 334, 335,
+ 336, 342, 341, 340, 339, 338, 0, 343, 345, 344,
+ 347, 346, 348, 0, 0, 0, 0, 0, 0, 430,
+ 0, 477, 0, 305, 165, 166, 334, 335, 336, 342,
+ 341, 340, 339, 338, 0, 343, 345, 344, 347, 346,
+ 348, 423, 0, 0, 0, 0, 165, 166, 334, 335,
+ 336, 342, 341, 340, 339, 338, 0, 343, 345, 344,
+ 347, 346, 348, 0, 0, 0, 267, 0, 0, 0,
+ 0, 165, 166, 334, 335, 336, 342, 341, 340, 339,
+ 338, 12, 343, 345, 344, 347, 346, 348, 0, 0,
+ 0, 0, 0, 0, 305, 10, 56, 46, 73, 85,
+ 14, 61, 70, 90, 38, 66, 47, 42, 68, 72,
+ 31, 67, 35, 34, 11, 87, 36, 18, 41, 39,
+ 28, 16, 57, 58, 59, 50, 54, 43, 88, 64,
+ 40, 69, 44, 89, 29, 62, 84, 13, 0, 82,
+ 65, 52, 86, 27, 74, 63, 15, 0, 0, 71,
+ 83, 160, 161, 162, 163, 169, 168, 167, 158, 159,
+ 103, 0, 160, 161, 162, 163, 169, 168, 167, 158,
+ 159, 103, 0, 0, 32, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103, 0, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 0, 160, 161, 162,
+ 163, 169, 168, 167, 158, 159, 103, 0, 160, 161,
+ 162, 163, 169, 168, 167, 158, 159, 103, 0, 0,
+ 233, 0, 0, 0, 0, 0, 165, 166, 363, 0,
+ 364, 233, 227, 0, 0, 0, 238, 165, 166, 231,
+ 0, 0, 0, 0, 233, 0, 0, 238, 0, 0,
+ 165, 166, 473, 0, 0, 233, 0, 0, 0, 0,
+ 238, 165, 166, 231, 0, 0, 233, 0, 0, 0,
+ 0, 238, 165, 166, 425, 0, 0, 233, 0, 0,
+ 0, 0, 238, 165, 166, 0, 0, 0, 0, 0,
+ 0, 0, 0, 238, 160, 161, 162, 163, 169, 168,
+ 167, 158, 159, 103, 0, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103, 0, 0, 0, 160, 161,
+ 162, 163, 169, 168, 167, 158, 159, 103, 256, 0,
+ 93, 160, 161, 162, 163, 169, 168, 167, 158, 159,
+ 103, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 276, 0, 0, 0, 0, 0, 165,
+ 166, 0, 122, 0, 322, 125, 126, 127, 0, 238,
+ 165, 166, 0, 0, 0, 0, 0, 138, 139, 0,
+ 238, 140, 0, 142, 143, 144, 0, 251, 145, 146,
+ 147, 0, 148, 165, 166, 253, 0, 254, 0, 0,
+ 153, 0, 0, 0, 0, 0, 165, 166, 151, 0,
+ 152, 178, 179, 180, 181, 182, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 251, 0, 0, 0, 0,
+ 0, 165, 166, 283, 0, 153, 0, 0, 0, 0,
+ 0, 165, 166, 175, 0, 404, 0, 0, 0, 0,
+ 0, 165, 166, 56, 46, 251, 85, 0, 61, 0,
+ 90, 165, 166, 47, 73, 0, 0, 0, 70, 0,
+ 0, 66, 87, 0, 68, 72, 0, 67, 0, 57,
+ 58, 59, 50, 0, 0, 88, 0, 0, 0, 0,
+ 89, 0, 62, 84, 0, 64, 82, 69, 52, 86,
+ 0, 0, 63, 0, 124, 0, 65, 83, 0, 0,
+ 74, 0, 0, 0, 0, 71 };
+yytabelem yypact[]={
+
+ -1000, 18, 503, 837, -1000, -1000, -1000, -1000, -1000, -1000,
+ 495, -1000, -1000, -1000, -1000, -1000, -1000, 164, 453, -35,
+ 194, 188, 187, 173, 58, 169, -8, 66, -1000, -1000,
+ -1000, -1000, -1000, 1264, -1000, -1000, -1000, -5, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, 453, -1000, -1000, -1000, -1000,
+ -1000, 354, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, 1096, 348, 1191, 348, 165,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, 453, 453, 453, 453, -1000, 453,
+ -1000, 325, -1000, -1000, 453, -1000, -11, 453, 453, 453,
+ 343, -1000, -1000, -1000, 453, 159, -1000, -1000, -1000, -1000,
+ 468, 346, 58, -1000, -1000, 344, -1000, -1000, -1000, -1000,
+ 66, 453, 453, 343, -1000, -1000, 234, 342, 489, -1000,
+ 341, 917, 963, 963, 340, 475, 453, 335, 453, -1000,
+ -1000, -1000, -1000, 1083, -1000, -1000, 308, 1211, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, 1083, 193, 158, -1000, -1000, 1049, 1049, -1000, -1000,
+ -1000, -1000, 1181, 332, -1000, -1000, 325, 325, 453, -1000,
+ -1000, 73, 304, -1000, 58, -1000, 304, -1000, -1000, -1000,
+ 453, -1000, 380, -1000, 330, 1273, -17, 66, -18, 453,
+ 475, 37, 963, 1060, -1000, 453, -1000, -1000, -1000, -1000,
+ -1000, 963, -1000, 963, 361, -1000, 963, -1000, 271, -1000,
+ 751, 475, -1000, 963, -1000, -1000, -1000, 963, 963, -1000,
+ 751, -1000, 963, -1000, -1000, 58, 475, -1000, 301, 240,
+ -1000, 1211, -1000, -1000, -1000, 906, -1000, 1211, 1211, 1211,
+ 1211, 1211, -30, 204, 106, 388, -1000, -1000, 388, 388,
+ -1000, 143, 135, 116, 751, -1000, 1049, -1000, -1000, -1000,
+ -1000, -1000, 308, -1000, -1000, 300, -1000, -1000, 325, -1000,
+ -1000, 222, -1000, -1000, -1000, -5, -1000, -36, 1201, 453,
+ -1000, 216, -1000, 45, -1000, -1000, 380, 460, -1000, 453,
+ -1000, -1000, 178, -1000, 226, -1000, -1000, -1000, 324, 220,
+ 726, 751, 952, -1000, 751, 299, 199, 115, 751, 453,
+ 704, -1000, 941, 963, 963, 963, 963, 963, 963, 963,
+ 963, 963, 963, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ 676, 114, -31, 646, 629, 321, 127, -1000, -1000, -1000,
+ 1083, 33, 751, -1000, -1000, 27, -30, -30, -30, 50,
+ -1000, 388, 106, 107, 106, 1049, 1049, 1049, 607, 88,
+ 86, 74, -1000, -1000, -1000, 87, -1000, 201, -1000, 304,
+ -1000, 113, -1000, 85, 930, -1000, 1201, -1000, -1000, -3,
+ 1070, -1000, -1000, -1000, 963, -1000, -1000, 453, -1000, 380,
+ 64, 78, -1000, 8, -1000, 60, -1000, -1000, 453, 963,
+ 58, 963, 963, 391, -1000, 290, 303, 963, 963, -1000,
+ 475, -1000, 0, -31, -31, -31, 467, 95, 95, 581,
+ 646, -22, -1000, 963, -1000, 475, 475, 58, -1000, 308,
+ -1000, -1000, 388, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ 1049, 1049, 1049, -1000, 466, 465, -5, -1000, -1000, 930,
+ -1000, -1000, 564, -1000, -1000, 1201, -1000, -1000, -1000, -1000,
+ 380, -1000, 460, 460, 453, -1000, 751, 37, 11, 43,
+ 751, -1000, -1000, -1000, 963, 285, 751, 41, 282, 62,
+ -1000, 963, 284, 227, 282, 277, 275, 258, -1000, -1000,
+ -1000, -1000, 930, -1000, -1000, 7, 248, -1000, -1000, -1000,
+ -1000, -1000, 963, -1000, -1000, 475, -1000, -1000, 751, -1000,
+ -1000, -1000, -1000, -1000, 751, -1000, -1000, 751, 34, 475,
+ -1000 };
+yytabelem yypgo[]={
+
+ 0, 613, 612, 13, 611, 81, 15, 32, 610, 604,
+ 603, 10, 0, 602, 601, 600, 16, 598, 35, 25,
+ 597, 596, 595, 3, 4, 594, 67, 593, 592, 50,
+ 34, 18, 26, 101, 20, 591, 30, 373, 1, 292,
+ 24, 347, 327, 2, 9, 14, 31, 49, 46, 590,
+ 588, 39, 28, 45, 587, 585, 584, 583, 581, 1100,
+ 40, 580, 579, 12, 578, 575, 573, 572, 571, 570,
+ 568, 29, 567, 27, 566, 23, 41, 7, 44, 6,
+ 37, 565, 38, 561, 560, 11, 22, 36, 559, 558,
+ 8, 17, 33, 557, 555, 541, 5, 540, 472, 537,
+ 536, 534, 533, 532, 528, 203, 523, 521, 518, 517,
+ 513, 509, 88, 508, 507, 19 };
+yytabelem yyr1[]={
+
+ 0, 1, 1, 55, 55, 55, 55, 55, 55, 55,
+ 2, 56, 56, 56, 56, 56, 56, 56, 60, 52,
+ 33, 53, 53, 61, 61, 62, 62, 63, 63, 26,
+ 26, 26, 27, 27, 34, 34, 17, 57, 57, 57,
+ 57, 57, 57, 57, 57, 57, 57, 57, 57, 10,
+ 10, 10, 74, 7, 8, 9, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 16, 16, 16, 50,
+ 50, 50, 50, 51, 51, 64, 64, 65, 65, 66,
+ 66, 80, 54, 54, 67, 67, 81, 82, 76, 83,
+ 84, 77, 77, 85, 85, 45, 45, 45, 70, 70,
+ 86, 86, 72, 72, 87, 36, 18, 18, 19, 19,
+ 75, 75, 89, 88, 88, 90, 90, 43, 43, 91,
+ 91, 3, 68, 68, 92, 92, 95, 93, 94, 94,
+ 96, 96, 11, 69, 69, 97, 20, 20, 71, 21,
+ 21, 22, 22, 38, 38, 38, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 12, 12, 13, 13, 13, 13, 13, 13, 37, 37,
+ 37, 37, 32, 40, 40, 44, 44, 48, 48, 48,
+ 48, 48, 48, 48, 47, 49, 49, 49, 41, 41,
+ 42, 42, 42, 42, 42, 42, 42, 42, 58, 58,
+ 58, 58, 58, 58, 58, 58, 58, 99, 23, 24,
+ 24, 98, 98, 98, 98, 98, 98, 98, 98, 98,
+ 98, 98, 4, 100, 101, 101, 101, 101, 73, 73,
+ 35, 25, 25, 46, 46, 14, 14, 28, 28, 59,
+ 78, 79, 102, 103, 103, 103, 103, 103, 103, 103,
+ 103, 103, 103, 103, 103, 103, 103, 104, 111, 111,
+ 111, 106, 113, 113, 113, 108, 108, 105, 105, 114,
+ 114, 115, 115, 115, 115, 115, 115, 15, 107, 109,
+ 110, 110, 29, 29, 6, 6, 30, 30, 30, 31,
+ 31, 31, 31, 31, 31, 5, 5, 5, 5, 5,
+ 112 };
+yytabelem yyr2[]={
+
+ 0, 0, 6, 5, 4, 5, 7, 7, 5, 3,
+ 3, 7, 9, 7, 9, 9, 11, 7, 1, 3,
+ 3, 1, 2, 4, 6, 2, 6, 2, 6, 1,
+ 5, 7, 3, 7, 3, 3, 3, 2, 2, 2,
+ 2, 2, 2, 2, 2, 3, 5, 3, 11, 15,
+ 11, 11, 1, 5, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 1, 9, 13, 7,
+ 9, 11, 7, 3, 7, 7, 7, 7, 7, 6,
+ 6, 7, 3, 7, 6, 6, 1, 13, 1, 1,
+ 1, 4, 6, 3, 7, 2, 5, 2, 2, 6,
+ 3, 2, 2, 6, 7, 5, 3, 11, 3, 7,
+ 1, 6, 1, 4, 6, 3, 7, 3, 2, 3,
+ 7, 3, 7, 6, 8, 3, 1, 4, 2, 6,
+ 3, 7, 3, 2, 4, 9, 3, 7, 1, 1,
+ 2, 3, 7, 2, 7, 2, 2, 2, 7, 7,
+ 7, 7, 5, 7, 7, 7, 7, 7, 5, 7,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 5,
+ 9, 11, 11, 1, 2, 3, 2, 3, 3, 3,
+ 3, 3, 3, 2, 11, 3, 3, 3, 2, 7,
+ 2, 2, 7, 7, 7, 7, 5, 7, 2, 15,
+ 9, 3, 5, 4, 13, 5, 5, 11, 7, 2,
+ 9, 9, 11, 4, 2, 3, 21, 3, 7, 9,
+ 7, 7, 3, 3, 7, 7, 15, 15, 0, 2,
+ 7, 3, 7, 2, 5, 3, 3, 3, 7, 1,
+ 1, 1, 3, 4, 5, 5, 5, 4, 5, 5,
+ 7, 9, 9, 5, 7, 3, 7, 6, 3, 3,
+ 3, 6, 3, 3, 3, 3, 3, 7, 7, 2,
+ 6, 3, 3, 3, 5, 5, 5, 3, 7, 7,
+ 9, 9, 3, 7, 3, 11, 3, 3, 2, 7,
+ 7, 7, 7, 7, 7, 3, 7, 11, 11, 11,
+ 1 };
+yytabelem yychk[]={
+
+ -1000, -1, -55, -2, 256, 3, 1, -56, -57, -58,
+ 18, 37, 4, 60, 23, 69, 44, -7, 40, -10,
+ -50, -64, -65, -66, -67, -68, -69, 66, 43, 57,
+ -98, 33, 97, -99, 36, 35, 39, -8, 27, 42,
+ 53, 41, 30, 50, 55, -100, 20, 29, -101, -102,
+ 48, -35, 64, -14, 49, -9, 19, 45, 46, 47,
+ -103, 24, 58, 68, 52, 63, 28, 34, 31, 54,
+ 25, 72, 32, 21, 67, -104, -106, -107, -109, -110,
+ -111, -113, 62, 73, 59, 22, 65, 38, 51, 56,
+ 26, -17, 5, -59, -60, -60, -60, -60, 44, -73,
+ 78, -52, -33, 14, 78, 99, -73, 78, 78, 78,
+ 78, -73, 78, -97, 83, -70, -86, -33, -51, 85,
+ 83, -71, -59, -98, 70, -59, -59, -59, -16, 82,
+ -71, -71, -71, -71, -81, -71, -37, -33, -59, -59,
+ -59, 74, -59, -59, -59, -59, -59, -59, -59, -105,
+ -42, 82, 84, 74, -37, -48, -41, -12, 12, 13,
+ 5, 6, 7, 8, -49, 80, 81, 11, 10, 9,
+ -105, 74, -105, -108, -42, 82, -105, 78, -59, -59,
+ -59, -59, -59, -53, -52, -53, -52, -52, -60, -33,
+ -26, 74, -33, -76, -51, -36, -33, -33, -33, -80,
+ 74, -82, -76, -92, -93, -95, -33, 78, 14, 74,
+ -78, -73, 74, -78, -36, -51, -33, -33, -80, -82,
+ -92, 76, -32, 74, -4, 6, 74, 75, -25, -46,
+ -38, 82, -39, 74, -47, -37, -48, -12, 90, -40,
+ -38, -40, 74, -3, 6, -33, 74, -33, -41, -114,
+ -42, 74, -115, 82, 84, -15, 15, -12, 82, 83,
+ 84, 85, -41, -41, -29, 78, -6, -37, 74, 78,
+ -30, -39, -5, -31, -38, -47, 74, -30, -112, -112,
+ -112, -112, -41, 82, -61, 74, -26, -26, -52, -71,
+ 75, -27, -34, -33, 82, -75, 74, -77, -84, -73,
+ -75, -54, -37, -19, -18, -37, 74, 74, -7, 83,
+ -86, 83, -72, -87, -33, -3, -24, -23, 98, -33,
+ -38, -38, 74, -36, -38, -21, -40, -22, -38, 71,
+ -38, 75, 78, -12, 82, 83, 84, -13, 89, 88,
+ 87, 86, 85, 91, 93, 92, 95, 94, 96, -3,
+ -38, -39, -38, -38, -38, -73, -91, -3, 75, 75,
+ 78, -41, -38, 82, 84, -41, -41, -41, -41, -41,
+ 75, 78, -29, -29, -29, 78, 78, 78, -38, -39,
+ -5, -31, -112, -112, 75, -62, -63, 14, -26, -74,
+ 75, 78, -16, -88, -89, 99, 78, -85, -45, -44,
+ -12, -47, -33, -48, 74, -36, 75, 78, 83, 78,
+ -19, -94, -96, -11, 14, -20, -33, 75, 78, 76,
+ -79, 74, 76, 75, -79, 82, 75, 77, 78, -33,
+ 75, -46, -38, -38, -38, -38, -38, -38, -38, -38,
+ -38, -38, 75, 78, 75, 74, 78, 75, -115, -41,
+ 75, -6, 78, -39, -5, -39, -5, -39, -5, 75,
+ 78, 78, 78, 75, 78, 76, -75, -34, 75, 78,
+ -90, -43, -38, 82, -85, 82, -44, -37, -83, -18,
+ 78, 75, 78, 81, 78, -87, -38, -73, -38, -28,
+ -38, 70, 75, -32, 74, -40, -38, -3, -39, -91,
+ -3, -73, -23, -33, -39, -23, -23, -23, -63, 14,
+ -16, -90, 77, -45, -44, -77, -23, -96, -11, -33,
+ -24, 75, 78, -79, 75, 78, 75, 75, -38, 75,
+ 75, 75, 75, -43, -38, 83, 75, -38, -3, 78,
+ -3 };
+yytabelem yydef[]={
+
+ 1, -2, 0, 0, 9, 10, 2, 3, 4, 5,
+ 0, 239, 8, 18, 18, 18, 18, 228, 0, 37,
+ -2, 39, 40, 41, -2, 43, 44, 45, 47, 138,
+ 198, 239, 201, 0, 239, 239, 239, 66, 138, 138,
+ 138, 138, 86, 138, 133, 0, 239, 239, 214, 215,
+ 239, 217, 239, 239, 239, 54, 223, 239, 239, 239,
+ 242, 239, 235, 236, 55, 56, 57, 58, 59, 60,
+ 61, 62, 63, 64, 65, 0, 0, 0, 0, 255,
+ 239, 239, 239, 239, 239, 258, 259, 260, 262, 263,
+ 264, 6, 36, 7, 21, 21, 0, 0, 18, 0,
+ 229, 29, 19, 20, 0, 88, 0, 229, 0, 0,
+ 0, 88, 126, 134, 0, 46, 98, 100, 101, 73,
+ 0, 0, -2, 202, 203, 0, 205, 206, 53, 240,
+ 0, 0, 0, 0, 88, 126, 0, 168, 0, 213,
+ 0, 0, 173, 173, 0, 0, 0, 0, 0, 243,
+ -2, 245, 246, 0, 190, 191, 0, 0, 177, 178,
+ 179, 180, 181, 182, 183, 160, 161, 185, 186, 187,
+ 247, 0, 248, 249, -2, 266, 253, 0, 300, 300,
+ 300, 300, 0, 11, 22, 13, 29, 29, 0, 138,
+ 17, 0, 110, 90, 228, 72, 110, 76, 78, 80,
+ 0, 85, 0, 123, 125, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 69, 0, 75, 77, 79, 84,
+ 122, 0, 169, -2, 0, 222, 0, 218, 0, 231,
+ 233, 0, 143, 0, 145, 146, 147, 0, 0, 220,
+ 174, 221, 0, 224, 121, -2, 0, 230, 271, 0,
+ 188, 0, 269, 272, 273, 0, 277, 0, 0, 0,
+ 0, 0, 196, 271, 250, 0, 282, 284, 0, 0,
+ 254, -2, 287, 288, 0, -2, 0, 256, 257, 261,
+ 278, 279, 300, 300, 12, 0, 14, 15, 29, 52,
+ 30, 0, 32, 34, 35, 66, 112, 0, 0, 0,
+ 105, 0, 82, 0, 108, 106, 0, 0, 127, 0,
+ 99, 74, 0, 102, 0, 241, 200, 209, 0, 0,
+ 0, 241, 0, 70, 211, 0, 0, 140, -2, 0,
+ 0, 219, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 162, 163, 164, 165, 166, 167, 234,
+ 0, 143, 152, 158, 0, 0, 0, 119, -2, 268,
+ 0, 0, 274, 275, 276, 192, 193, 194, 195, 197,
+ 267, 0, 252, 0, 251, 0, 0, 0, 0, 143,
+ 0, 0, 280, 281, 23, 0, 25, 27, 16, 110,
+ 31, 0, 50, 0, 0, 51, 0, 91, 93, 95,
+ 0, 97, 175, 176, 0, 71, 81, 0, 89, 0,
+ 0, 0, 128, 130, 132, 135, 136, 48, 0, 0,
+ 228, 0, 0, 0, 67, 0, 170, 173, 0, 212,
+ 0, 232, 148, 149, 150, 151, -2, 154, 155, 156,
+ 157, 159, 144, 0, 207, 0, 0, 228, 270, 271,
+ 189, 283, 0, -2, 290, -2, 292, -2, 294, -2,
+ 0, 0, 0, 24, 0, 0, 66, 33, 111, 0,
+ 113, 115, 118, 117, 92, 0, 96, 83, 90, 109,
+ 0, 124, 0, 0, 0, 103, 104, 0, 0, 208,
+ 237, 204, 241, 171, 173, 0, 142, 0, 143, 0,
+ 120, 0, 0, 168, -2, 0, 0, 0, 26, 28,
+ 49, 114, 0, 94, 95, 0, 0, 129, 131, 137,
+ 199, 210, 0, 68, 172, 0, 184, 226, 227, 285,
+ 297, 298, 299, 116, 118, 87, 107, 238, 0, 0,
+ 216 };
+typedef struct { char *t_name; int t_val; } yytoktype;
+#ifndef YYDEBUG
+# define YYDEBUG 0 /* don't allow debugging */
+#endif
+
+#if YYDEBUG
+
+yytoktype yytoks[] =
+{
+ "SEOS", 1,
+ "SCOMMENT", 2,
+ "SLABEL", 3,
+ "SUNKNOWN", 4,
+ "SHOLLERITH", 5,
+ "SICON", 6,
+ "SRCON", 7,
+ "SDCON", 8,
+ "SBITCON", 9,
+ "SOCTCON", 10,
+ "SHEXCON", 11,
+ "STRUE", 12,
+ "SFALSE", 13,
+ "SNAME", 14,
+ "SNAMEEQ", 15,
+ "SFIELD", 16,
+ "SSCALE", 17,
+ "SINCLUDE", 18,
+ "SLET", 19,
+ "SASSIGN", 20,
+ "SAUTOMATIC", 21,
+ "SBACKSPACE", 22,
+ "SBLOCK", 23,
+ "SCALL", 24,
+ "SCHARACTER", 25,
+ "SCLOSE", 26,
+ "SCOMMON", 27,
+ "SCOMPLEX", 28,
+ "SCONTINUE", 29,
+ "SDATA", 30,
+ "SDCOMPLEX", 31,
+ "SDIMENSION", 32,
+ "SDO", 33,
+ "SDOUBLE", 34,
+ "SELSE", 35,
+ "SELSEIF", 36,
+ "SEND", 37,
+ "SENDFILE", 38,
+ "SENDIF", 39,
+ "SENTRY", 40,
+ "SEQUIV", 41,
+ "SEXTERNAL", 42,
+ "SFORMAT", 43,
+ "SFUNCTION", 44,
+ "SGOTO", 45,
+ "SASGOTO", 46,
+ "SCOMPGOTO", 47,
+ "SARITHIF", 48,
+ "SLOGIF", 49,
+ "SIMPLICIT", 50,
+ "SINQUIRE", 51,
+ "SINTEGER", 52,
+ "SINTRINSIC", 53,
+ "SLOGICAL", 54,
+ "SNAMELIST", 55,
+ "SOPEN", 56,
+ "SPARAM", 57,
+ "SPAUSE", 58,
+ "SPRINT", 59,
+ "SPROGRAM", 60,
+ "SPUNCH", 61,
+ "SREAD", 62,
+ "SREAL", 63,
+ "SRETURN", 64,
+ "SREWIND", 65,
+ "SSAVE", 66,
+ "SSTATIC", 67,
+ "SSTOP", 68,
+ "SSUBROUTINE", 69,
+ "STHEN", 70,
+ "STO", 71,
+ "SUNDEFINED", 72,
+ "SWRITE", 73,
+ "SLPAR", 74,
+ "SRPAR", 75,
+ "SEQUALS", 76,
+ "SCOLON", 77,
+ "SCOMMA", 78,
+ "SCURRENCY", 79,
+ "SPLUS", 80,
+ "SMINUS", 81,
+ "SSTAR", 82,
+ "SSLASH", 83,
+ "SPOWER", 84,
+ "SCONCAT", 85,
+ "SAND", 86,
+ "SOR", 87,
+ "SNEQV", 88,
+ "SEQV", 89,
+ "SNOT", 90,
+ "SEQ", 91,
+ "SLT", 92,
+ "SGT", 93,
+ "SLE", 94,
+ "SGE", 95,
+ "SNE", 96,
+ "SENDDO", 97,
+ "SWHILE", 98,
+ "SSLASHD", 99,
+ "-unknown-", -1 /* ends search */
+};
+
+char * yyreds[] =
+{
+ "-no such reduction-",
+ "program : /* empty */",
+ "program : program stat SEOS",
+ "stat : thislabel entry",
+ "stat : thislabel spec",
+ "stat : thislabel exec",
+ "stat : thislabel SINCLUDE filename",
+ "stat : thislabel SEND end_spec",
+ "stat : thislabel SUNKNOWN",
+ "stat : error",
+ "thislabel : SLABEL",
+ "entry : SPROGRAM new_proc progname",
+ "entry : SPROGRAM new_proc progname progarglist",
+ "entry : SBLOCK new_proc progname",
+ "entry : SSUBROUTINE new_proc entryname arglist",
+ "entry : SFUNCTION new_proc entryname arglist",
+ "entry : type SFUNCTION new_proc entryname arglist",
+ "entry : SENTRY entryname arglist",
+ "new_proc : /* empty */",
+ "entryname : name",
+ "name : SNAME",
+ "progname : /* empty */",
+ "progname : entryname",
+ "progarglist : SLPAR SRPAR",
+ "progarglist : SLPAR progargs SRPAR",
+ "progargs : progarg",
+ "progargs : progargs SCOMMA progarg",
+ "progarg : SNAME",
+ "progarg : SNAME SEQUALS SNAME",
+ "arglist : /* empty */",
+ "arglist : SLPAR SRPAR",
+ "arglist : SLPAR args SRPAR",
+ "args : arg",
+ "args : args SCOMMA arg",
+ "arg : name",
+ "arg : SSTAR",
+ "filename : SHOLLERITH",
+ "spec : dcl",
+ "spec : common",
+ "spec : external",
+ "spec : intrinsic",
+ "spec : equivalence",
+ "spec : data",
+ "spec : implicit",
+ "spec : namelist",
+ "spec : SSAVE",
+ "spec : SSAVE savelist",
+ "spec : SFORMAT",
+ "spec : SPARAM in_dcl SLPAR paramlist SRPAR",
+ "dcl : type opt_comma name in_dcl new_dcl dims lengspec",
+ "dcl : dcl SCOMMA name dims lengspec",
+ "dcl : dcl SSLASHD datainit vallist SSLASHD",
+ "new_dcl : /* empty */",
+ "type : typespec lengspec",
+ "typespec : typename",
+ "typename : SINTEGER",
+ "typename : SREAL",
+ "typename : SCOMPLEX",
+ "typename : SDOUBLE",
+ "typename : SDCOMPLEX",
+ "typename : SLOGICAL",
+ "typename : SCHARACTER",
+ "typename : SUNDEFINED",
+ "typename : SDIMENSION",
+ "typename : SAUTOMATIC",
+ "typename : SSTATIC",
+ "lengspec : /* empty */",
+ "lengspec : SSTAR intonlyon expr intonlyoff",
+ "lengspec : SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff",
+ "common : SCOMMON in_dcl var",
+ "common : SCOMMON in_dcl comblock var",
+ "common : common opt_comma comblock opt_comma var",
+ "common : common SCOMMA var",
+ "comblock : SCONCAT",
+ "comblock : SSLASH SNAME SSLASH",
+ "external : SEXTERNAL in_dcl name",
+ "external : external SCOMMA name",
+ "intrinsic : SINTRINSIC in_dcl name",
+ "intrinsic : intrinsic SCOMMA name",
+ "equivalence : SEQUIV in_dcl equivset",
+ "equivalence : equivalence SCOMMA equivset",
+ "equivset : SLPAR equivlist SRPAR",
+ "equivlist : lhs",
+ "equivlist : equivlist SCOMMA lhs",
+ "data : SDATA in_data datalist",
+ "data : data opt_comma datalist",
+ "in_data : /* empty */",
+ "datalist : datainit datavarlist SSLASH datapop vallist SSLASH",
+ "datainit : /* empty */",
+ "datapop : /* empty */",
+ "vallist : /* empty */",
+ "vallist : val",
+ "vallist : vallist SCOMMA val",
+ "val : value",
+ "val : simple SSTAR value",
+ "value : simple",
+ "value : addop simple",
+ "value : complex_const",
+ "savelist : saveitem",
+ "savelist : savelist SCOMMA saveitem",
+ "saveitem : name",
+ "saveitem : comblock",
+ "paramlist : paramitem",
+ "paramlist : paramlist SCOMMA paramitem",
+ "paramitem : name SEQUALS expr",
+ "var : name dims",
+ "datavar : lhs",
+ "datavar : SLPAR datavarlist SCOMMA dospec SRPAR",
+ "datavarlist : datavar",
+ "datavarlist : datavarlist SCOMMA datavar",
+ "dims : /* empty */",
+ "dims : SLPAR dimlist SRPAR",
+ "dimlist : /* empty */",
+ "dimlist : dim",
+ "dimlist : dimlist SCOMMA dim",
+ "dim : ubound",
+ "dim : expr SCOLON ubound",
+ "ubound : SSTAR",
+ "ubound : expr",
+ "labellist : label",
+ "labellist : labellist SCOMMA label",
+ "label : SICON",
+ "implicit : SIMPLICIT in_dcl implist",
+ "implicit : implicit SCOMMA implist",
+ "implist : imptype SLPAR letgroups SRPAR",
+ "implist : imptype",
+ "imptype : /* empty */",
+ "imptype : type",
+ "letgroups : letgroup",
+ "letgroups : letgroups SCOMMA letgroup",
+ "letgroup : letter",
+ "letgroup : letter SMINUS letter",
+ "letter : SNAME",
+ "namelist : SNAMELIST",
+ "namelist : namelist namelistentry",
+ "namelistentry : SSLASH name SSLASH namelistlist",
+ "namelistlist : name",
+ "namelistlist : namelistlist SCOMMA name",
+ "in_dcl : /* empty */",
+ "funarglist : /* empty */",
+ "funarglist : funargs",
+ "funargs : expr",
+ "funargs : funargs SCOMMA expr",
+ "expr : uexpr",
+ "expr : SLPAR expr SRPAR",
+ "expr : complex_const",
+ "uexpr : lhs",
+ "uexpr : simple_const",
+ "uexpr : expr addop expr",
+ "uexpr : expr SSTAR expr",
+ "uexpr : expr SSLASH expr",
+ "uexpr : expr SPOWER expr",
+ "uexpr : addop expr",
+ "uexpr : expr relop expr",
+ "uexpr : expr SEQV expr",
+ "uexpr : expr SNEQV expr",
+ "uexpr : expr SOR expr",
+ "uexpr : expr SAND expr",
+ "uexpr : SNOT expr",
+ "uexpr : expr SCONCAT expr",
+ "addop : SPLUS",
+ "addop : SMINUS",
+ "relop : SEQ",
+ "relop : SGT",
+ "relop : SLT",
+ "relop : SGE",
+ "relop : SLE",
+ "relop : SNE",
+ "lhs : name",
+ "lhs : name substring",
+ "lhs : name SLPAR funarglist SRPAR",
+ "lhs : name SLPAR funarglist SRPAR substring",
+ "substring : SLPAR opt_expr SCOLON opt_expr SRPAR",
+ "opt_expr : /* empty */",
+ "opt_expr : expr",
+ "simple : name",
+ "simple : simple_const",
+ "simple_const : STRUE",
+ "simple_const : SFALSE",
+ "simple_const : SHOLLERITH",
+ "simple_const : SICON",
+ "simple_const : SRCON",
+ "simple_const : SDCON",
+ "simple_const : bit_const",
+ "complex_const : SLPAR uexpr SCOMMA uexpr SRPAR",
+ "bit_const : SHEXCON",
+ "bit_const : SOCTCON",
+ "bit_const : SBITCON",
+ "fexpr : unpar_fexpr",
+ "fexpr : SLPAR fexpr SRPAR",
+ "unpar_fexpr : lhs",
+ "unpar_fexpr : simple_const",
+ "unpar_fexpr : fexpr addop fexpr",
+ "unpar_fexpr : fexpr SSTAR fexpr",
+ "unpar_fexpr : fexpr SSLASH fexpr",
+ "unpar_fexpr : fexpr SPOWER fexpr",
+ "unpar_fexpr : addop fexpr",
+ "unpar_fexpr : fexpr SCONCAT fexpr",
+ "exec : iffable",
+ "exec : SDO end_spec intonlyon label intonlyoff opt_comma dospecw",
+ "exec : SDO end_spec opt_comma dospecw",
+ "exec : SENDDO",
+ "exec : logif iffable",
+ "exec : logif STHEN",
+ "exec : SELSEIF end_spec SLPAR expr SRPAR STHEN",
+ "exec : SELSE end_spec",
+ "exec : SENDIF end_spec",
+ "logif : SLOGIF end_spec SLPAR expr SRPAR",
+ "dospec : name SEQUALS exprlist",
+ "dospecw : dospec",
+ "dospecw : SWHILE SLPAR expr SRPAR",
+ "iffable : let lhs SEQUALS expr",
+ "iffable : SASSIGN end_spec assignlabel STO name",
+ "iffable : SCONTINUE end_spec",
+ "iffable : goto",
+ "iffable : io",
+ "iffable : SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label",
+ "iffable : call",
+ "iffable : call SLPAR SRPAR",
+ "iffable : call SLPAR callarglist SRPAR",
+ "iffable : SRETURN end_spec opt_expr",
+ "iffable : stop end_spec opt_expr",
+ "assignlabel : SICON",
+ "let : SLET",
+ "goto : SGOTO end_spec label",
+ "goto : SASGOTO end_spec name",
+ "goto : SASGOTO end_spec name opt_comma SLPAR labellist SRPAR",
+ "goto : SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr",
+ "opt_comma : /* empty */",
+ "opt_comma : SCOMMA",
+ "call : SCALL end_spec name",
+ "callarglist : callarg",
+ "callarglist : callarglist SCOMMA callarg",
+ "callarg : expr",
+ "callarg : SSTAR label",
+ "stop : SPAUSE",
+ "stop : SSTOP",
+ "exprlist : expr",
+ "exprlist : exprlist SCOMMA expr",
+ "end_spec : /* empty */",
+ "intonlyon : /* empty */",
+ "intonlyoff : /* empty */",
+ "io : io1",
+ "io1 : iofmove ioctl",
+ "io1 : iofmove unpar_fexpr",
+ "io1 : iofmove SSTAR",
+ "io1 : iofmove SPOWER",
+ "io1 : iofctl ioctl",
+ "io1 : read ioctl",
+ "io1 : read infmt",
+ "io1 : read ioctl inlist",
+ "io1 : read infmt SCOMMA inlist",
+ "io1 : read ioctl SCOMMA inlist",
+ "io1 : write ioctl",
+ "io1 : write ioctl outlist",
+ "io1 : print",
+ "io1 : print SCOMMA outlist",
+ "iofmove : fmkwd end_spec in_ioctl",
+ "fmkwd : SBACKSPACE",
+ "fmkwd : SREWIND",
+ "fmkwd : SENDFILE",
+ "iofctl : ctlkwd end_spec in_ioctl",
+ "ctlkwd : SINQUIRE",
+ "ctlkwd : SOPEN",
+ "ctlkwd : SCLOSE",
+ "infmt : unpar_fexpr",
+ "infmt : SSTAR",
+ "ioctl : SLPAR fexpr SRPAR",
+ "ioctl : SLPAR ctllist SRPAR",
+ "ctllist : ioclause",
+ "ctllist : ctllist SCOMMA ioclause",
+ "ioclause : fexpr",
+ "ioclause : SSTAR",
+ "ioclause : SPOWER",
+ "ioclause : nameeq expr",
+ "ioclause : nameeq SSTAR",
+ "ioclause : nameeq SPOWER",
+ "nameeq : SNAMEEQ",
+ "read : SREAD end_spec in_ioctl",
+ "write : SWRITE end_spec in_ioctl",
+ "print : SPRINT end_spec fexpr in_ioctl",
+ "print : SPRINT end_spec SSTAR in_ioctl",
+ "inlist : inelt",
+ "inlist : inlist SCOMMA inelt",
+ "inelt : lhs",
+ "inelt : SLPAR inlist SCOMMA dospec SRPAR",
+ "outlist : uexpr",
+ "outlist : other",
+ "outlist : out2",
+ "out2 : uexpr SCOMMA uexpr",
+ "out2 : uexpr SCOMMA other",
+ "out2 : other SCOMMA uexpr",
+ "out2 : other SCOMMA other",
+ "out2 : out2 SCOMMA uexpr",
+ "out2 : out2 SCOMMA other",
+ "other : complex_const",
+ "other : SLPAR expr SRPAR",
+ "other : SLPAR uexpr SCOMMA dospec SRPAR",
+ "other : SLPAR other SCOMMA dospec SRPAR",
+ "other : SLPAR out2 SCOMMA dospec SRPAR",
+ "in_ioctl : /* empty */",
+};
+#endif /* YYDEBUG */
+/*
+ * @(#) yaccpar 1.4 88/11/11
+ *
+ * UNIX is a registered trademark of AT&T
+ * Portions Copyright 1976-1989 AT&T
+ * Portions Copyright 1980-1989 Microsoft Corporation
+ * Portions Copyright 1983-1989 The Santa Cruz Operation, Inc
+ * All Rights Reserved
+ */
+#ident "@(#)yacc:yaccpar 1.10"
+
+/*
+** Skeleton parser driver for yacc output
+*/
+
+/*
+** yacc user known macros and defines
+*/
+#define YYERROR goto yyerrlab
+#define YYACCEPT return(0)
+#define YYABORT return(1)
+#define YYBACKUP( newtoken, newvalue )\
+{\
+ if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\
+ {\
+ yyerror( "syntax error - cannot backup" );\
+ goto yyerrlab;\
+ }\
+ yychar = newtoken;\
+ yystate = *yyps;\
+ yylval = newvalue;\
+ goto yynewstate;\
+}
+#define YYRECOVERING() (!!yyerrflag)
+#ifndef YYDEBUG
+# define YYDEBUG 1 /* make debugging available */
+#endif
+
+/*
+** user known globals
+*/
+int yydebug; /* set to 1 to get debugging */
+
+/*
+** driver internal defines
+*/
+#define YYFLAG (-1000)
+
+/*
+** global variables used by the parser
+*/
+YYSTYPE yyv[ YYMAXDEPTH ]; /* value stack */
+int yys[ YYMAXDEPTH ]; /* state stack */
+
+YYSTYPE *yypv; /* top of value stack */
+int *yyps; /* top of state stack */
+
+int yystate; /* current state */
+int yytmp; /* extra var (lasts between blocks) */
+
+int yynerrs; /* number of errors */
+int yyerrflag; /* error recovery flag */
+int yychar; /* current input token number */
+
+
+
+/*
+** yyparse - return 0 if worked, 1 if syntax error not recovered from
+*/
+int
+yyparse()
+{
+ register YYSTYPE *yypvt; /* top of value stack for $vars */
+
+ /*
+ ** Initialize externals - yyparse may be called more than once
+ */
+ yypv = &yyv[-1];
+ yyps = &yys[-1];
+ yystate = 0;
+ yytmp = 0;
+ yynerrs = 0;
+ yyerrflag = 0;
+ yychar = -1;
+
+ goto yystack;
+ {
+ register YYSTYPE *yy_pv; /* top of value stack */
+ register int *yy_ps; /* top of state stack */
+ register int yy_state; /* current state */
+ register int yy_n; /* internal state number info */
+
+ /*
+ ** get globals into registers.
+ ** branch to here only if YYBACKUP was called.
+ */
+ yynewstate:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ goto yy_newstate;
+
+ /*
+ ** get globals into registers.
+ ** either we just started, or we just finished a reduction
+ */
+ yystack:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+
+ /*
+ ** top of for (;;) loop while no reductions done
+ */
+ yy_stack:
+ /*
+ ** put a state and value onto the stacks
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token value in list of value vs.
+ ** name pairs. 0 and negative (-1) are special values.
+ ** Note: linear search is used since time is not a real
+ ** consideration while debugging.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ printf( "State %d, token ", yy_state );
+ if ( yychar == 0 )
+ printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ++yy_ps >= &yys[ YYMAXDEPTH ] ) /* room on stack? */
+ {
+ yyerror( "yacc stack overflow" );
+ YYABORT;
+ }
+ *yy_ps = yy_state;
+ *++yy_pv = yyval;
+
+ /*
+ ** we have a new state - find out what to do
+ */
+ yy_newstate:
+ if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG )
+ goto yydefault; /* simple state */
+#if YYDEBUG
+ /*
+ ** if debugging, need to mark whether new token grabbed
+ */
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ printf( "Received token " );
+ if ( yychar == 0 )
+ printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) )
+ goto yydefault;
+ if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/
+ {
+ yychar = -1;
+ yyval = yylval;
+ yy_state = yy_n;
+ if ( yyerrflag > 0 )
+ yyerrflag--;
+ goto yy_stack;
+ }
+
+ yydefault:
+ if ( ( yy_n = yydef[ yy_state ] ) == -2 )
+ {
+#if YYDEBUG
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ printf( "Received token " );
+ if ( yychar == 0 )
+ printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ /*
+ ** look through exception table
+ */
+ {
+ register int *yyxi = yyexca;
+
+ while ( ( *yyxi != -1 ) ||
+ ( yyxi[1] != yy_state ) )
+ {
+ yyxi += 2;
+ }
+ while ( ( *(yyxi += 2) >= 0 ) &&
+ ( *yyxi != yychar ) )
+ ;
+ if ( ( yy_n = yyxi[1] ) < 0 )
+ YYACCEPT;
+ }
+ }
+
+ /*
+ ** check for syntax error
+ */
+ if ( yy_n == 0 ) /* have an error */
+ {
+ /* no worry about speed here! */
+ switch ( yyerrflag )
+ {
+ case 0: /* new error */
+ yyerror( "syntax error" );
+ goto skip_init;
+ yyerrlab:
+ /*
+ ** get globals into registers.
+ ** we have a user generated syntax type error
+ */
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ yynerrs++;
+ skip_init:
+ case 1:
+ case 2: /* incompletely recovered error */
+ /* try again... */
+ yyerrflag = 3;
+ /*
+ ** find state where "error" is a legal
+ ** shift action
+ */
+ while ( yy_ps >= yys )
+ {
+ yy_n = yypact[ *yy_ps ] + YYERRCODE;
+ if ( yy_n >= 0 && yy_n < YYLAST &&
+ yychk[yyact[yy_n]] == YYERRCODE) {
+ /*
+ ** simulate shift of "error"
+ */
+ yy_state = yyact[ yy_n ];
+ goto yy_stack;
+ }
+ /*
+ ** current state has no shift on
+ ** "error", pop stack
+ */
+#if YYDEBUG
+# define _POP_ "Error recovery pops state %d, uncovers state %d\n"
+ if ( yydebug )
+ printf( _POP_, *yy_ps,
+ yy_ps[-1] );
+# undef _POP_
+#endif
+ yy_ps--;
+ yy_pv--;
+ }
+ /*
+ ** there is no state on stack with "error" as
+ ** a valid shift. give up.
+ */
+ YYABORT;
+ case 3: /* no shift yet; eat a token */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token in list of
+ ** pairs. 0 and negative shouldn't occur,
+ ** but since timing doesn't matter when
+ ** debugging, it doesn't hurt to leave the
+ ** tests here.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ printf( "Error recovery discards " );
+ if ( yychar == 0 )
+ printf( "token end-of-file\n" );
+ else if ( yychar < 0 )
+ printf( "token -none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ printf( "token %s\n",
+ yytoks[yy_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( yychar == 0 ) /* reached EOF. quit */
+ YYABORT;
+ yychar = -1;
+ goto yy_newstate;
+ }
+ }/* end if ( yy_n == 0 ) */
+ /*
+ ** reduction by production yy_n
+ ** put stack tops, etc. so things right after switch
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, print the string that is the user's
+ ** specification of the reduction which is just about
+ ** to be done.
+ */
+ if ( yydebug )
+ printf( "Reduce by (%d) \"%s\"\n",
+ yy_n, yyreds[ yy_n ] );
+#endif
+ yytmp = yy_n; /* value to switch over */
+ yypvt = yy_pv; /* $vars top of value stack */
+ /*
+ ** Look in goto table for next state
+ ** Sorry about using yy_state here as temporary
+ ** register variable, but why not, if it works...
+ ** If yyr2[ yy_n ] doesn't have the low order bit
+ ** set, then there is no action to be done for
+ ** this reduction. So, no saving & unsaving of
+ ** registers done. The only difference between the
+ ** code just after the if and the body of the if is
+ ** the goto yy_stack in the body. This way the test
+ ** can be made before the choice of what to do is needed.
+ */
+ {
+ /* length of production doubled with extra bit */
+ register int yy_len = yyr2[ yy_n ];
+
+ if ( !( yy_len & 01 ) )
+ {
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state =
+ yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ goto yy_stack;
+ }
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state = yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ }
+ /* save until reenter driver code */
+ yystate = yy_state;
+ yyps = yy_ps;
+ yypv = yy_pv;
+ }
+ /*
+ ** code supplied by user is placed in this switch
+ */
+ switch( yytmp )
+ {
+
+case 3:
+/* # line 224 "gram.in" */
+{
+/* stat: is the nonterminal for Fortran statements */
+
+ lastwasbranch = NO; } break;
+case 5:
+/* # line 230 "gram.in" */
+{ /* forbid further statement function definitions... */
+ if (parstate == INDATA && laststfcn != thisstno)
+ parstate = INEXEC;
+ thisstno++;
+ if(yypvt[-1].labval && (yypvt[-1].labval->labelno==dorange))
+ enddo(yypvt[-1].labval->labelno);
+ if(lastwasbranch && thislabel==NULL)
+ warn("statement cannot be reached");
+ lastwasbranch = thiswasbranch;
+ thiswasbranch = NO;
+ if(yypvt[-1].labval)
+ {
+ if(yypvt[-1].labval->labtype == LABFORMAT)
+ err("label already that of a format");
+ else
+ yypvt[-1].labval->labtype = LABEXEC;
+ }
+ freetemps();
+ } break;
+case 6:
+/* # line 250 "gram.in" */
+{ if (can_include)
+ doinclude( yypvt[-0].charpval );
+ else {
+ fprintf(diagfile, "Cannot open file %s\n", yypvt[-0].charpval);
+ done(1);
+ }
+ } break;
+case 7:
+/* # line 258 "gram.in" */
+{ if (yypvt[-2].labval)
+ lastwasbranch = NO;
+ endproc(); /* lastwasbranch = NO; -- set in endproc() */
+ } break;
+case 8:
+/* # line 263 "gram.in" */
+{ extern void unclassifiable();
+ unclassifiable();
+
+/* flline flushes the current line, ignoring the rest of the text there */
+
+ flline(); } break;
+case 9:
+/* # line 270 "gram.in" */
+{ flline(); needkwd = NO; inioctl = NO;
+ yyerrok; yyclearin; } break;
+case 10:
+/* # line 275 "gram.in" */
+{
+ if(yystno != 0)
+ {
+ yyval.labval = thislabel = mklabel(yystno);
+ if( ! headerdone ) {
+ if (procclass == CLUNKNOWN)
+ procclass = CLMAIN;
+ puthead(CNULL, procclass);
+ }
+ if(thislabel->labdefined)
+ execerr("label %s already defined",
+ convic(thislabel->stateno) );
+ else {
+ if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
+ && thislabel->labtype!=LABFORMAT)
+ warn1("there is a branch to label %s from outside block",
+ convic( (ftnint) (thislabel->stateno) ) );
+ thislabel->blklevel = blklevel;
+ thislabel->labdefined = YES;
+ if(thislabel->labtype != LABFORMAT)
+ p1_label((long)(thislabel - labeltab));
+ }
+ }
+ else yyval.labval = thislabel = NULL;
+ } break;
+case 11:
+/* # line 303 "gram.in" */
+{startproc(yypvt[-0].extval, CLMAIN); } break;
+case 12:
+/* # line 305 "gram.in" */
+{ warn("ignoring arguments to main program");
+ /* hashclear(); */
+ startproc(yypvt[-1].extval, CLMAIN); } break;
+case 13:
+/* # line 309 "gram.in" */
+{ if(yypvt[-0].extval) NO66("named BLOCKDATA");
+ startproc(yypvt[-0].extval, CLBLOCK); } break;
+case 14:
+/* # line 312 "gram.in" */
+{ entrypt(CLPROC, TYSUBR, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 15:
+/* # line 314 "gram.in" */
+{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 16:
+/* # line 316 "gram.in" */
+{ entrypt(CLPROC, yypvt[-4].ival, varleng, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 17:
+/* # line 318 "gram.in" */
+{ if(parstate==OUTSIDE || procclass==CLMAIN
+ || procclass==CLBLOCK)
+ execerr("misplaced entry statement", CNULL);
+ entrypt(CLENTRY, 0, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval);
+ } break;
+case 18:
+/* # line 326 "gram.in" */
+{ newproc(); } break;
+case 19:
+/* # line 330 "gram.in" */
+{ yyval.extval = newentry(yypvt[-0].namval, 1); } break;
+case 20:
+/* # line 334 "gram.in" */
+{ yyval.namval = mkname(token); } break;
+case 21:
+/* # line 337 "gram.in" */
+{ yyval.extval = NULL; } break;
+case 29:
+/* # line 355 "gram.in" */
+{ yyval.chval = 0; } break;
+case 30:
+/* # line 357 "gram.in" */
+{ NO66(" () argument list");
+ yyval.chval = 0; } break;
+case 31:
+/* # line 360 "gram.in" */
+{yyval.chval = yypvt[-1].chval; } break;
+case 32:
+/* # line 364 "gram.in" */
+{ yyval.chval = (yypvt[-0].namval ? mkchain((char *)yypvt[-0].namval,CHNULL) : CHNULL ); } break;
+case 33:
+/* # line 366 "gram.in" */
+{ if(yypvt[-0].namval) yypvt[-2].chval = yyval.chval = mkchain((char *)yypvt[-0].namval, yypvt[-2].chval); } break;
+case 34:
+/* # line 370 "gram.in" */
+{ if(yypvt[-0].namval->vstg!=STGUNKNOWN && yypvt[-0].namval->vstg!=STGARG)
+ dclerr("name declared as argument after use", yypvt[-0].namval);
+ yypvt[-0].namval->vstg = STGARG;
+ } break;
+case 35:
+/* # line 375 "gram.in" */
+{ NO66("altenate return argument");
+
+/* substars means that '*'ed formal parameters should be replaced.
+ This is used to specify alternate return labels; in theory, only
+ parameter slots which have '*' should accept the statement labels.
+ This compiler chooses to ignore the '*'s in the formal declaration, and
+ always return the proper value anyway.
+
+ This variable is only referred to in proc.c */
+
+ yyval.namval = 0; substars = YES; } break;
+case 36:
+/* # line 391 "gram.in" */
+{
+ char *s;
+ s = copyn(toklen+1, token);
+ s[toklen] = '\0';
+ yyval.charpval = s;
+ } break;
+case 45:
+/* # line 407 "gram.in" */
+{ NO66("SAVE statement");
+ saveall = YES; } break;
+case 46:
+/* # line 410 "gram.in" */
+{ NO66("SAVE statement"); } break;
+case 47:
+/* # line 412 "gram.in" */
+{ fmtstmt(thislabel); setfmt(thislabel); } break;
+case 48:
+/* # line 414 "gram.in" */
+{ NO66("PARAMETER statement"); } break;
+case 49:
+/* # line 418 "gram.in" */
+{ settype(yypvt[-4].namval, yypvt[-6].ival, yypvt[-0].lval);
+ if(ndim>0) setbound(yypvt[-4].namval,ndim,dims);
+ } break;
+case 50:
+/* # line 422 "gram.in" */
+{ settype(yypvt[-2].namval, yypvt[-4].ival, yypvt[-0].lval);
+ if(ndim>0) setbound(yypvt[-2].namval,ndim,dims);
+ } break;
+case 51:
+/* # line 426 "gram.in" */
+{ if (new_dcl == 2) {
+ err("attempt to give DATA in type-declaration");
+ new_dcl = 1;
+ }
+ } break;
+case 52:
+/* # line 433 "gram.in" */
+{ new_dcl = 2; } break;
+case 53:
+/* # line 436 "gram.in" */
+{ varleng = yypvt[-0].lval;
+ if (vartype == TYLOGICAL && varleng == 1) {
+ varleng = 0;
+ err("treating LOGICAL*1 as LOGICAL");
+ --nerr; /* allow generation of .c file */
+ }
+ } break;
+case 54:
+/* # line 446 "gram.in" */
+{ varleng = (yypvt[-0].ival<0 || yypvt[-0].ival==TYLONG ? 0 : typesize[yypvt[-0].ival]);
+ vartype = yypvt[-0].ival; } break;
+case 55:
+/* # line 450 "gram.in" */
+{ yyval.ival = TYLONG; } break;
+case 56:
+/* # line 451 "gram.in" */
+{ yyval.ival = tyreal; } break;
+case 57:
+/* # line 452 "gram.in" */
+{ ++complex_seen; yyval.ival = TYCOMPLEX; } break;
+case 58:
+/* # line 453 "gram.in" */
+{ yyval.ival = TYDREAL; } break;
+case 59:
+/* # line 454 "gram.in" */
+{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); yyval.ival = TYDCOMPLEX; } break;
+case 60:
+/* # line 455 "gram.in" */
+{ yyval.ival = TYLOGICAL; } break;
+case 61:
+/* # line 456 "gram.in" */
+{ NO66("CHARACTER statement"); yyval.ival = TYCHAR; } break;
+case 62:
+/* # line 457 "gram.in" */
+{ yyval.ival = TYUNKNOWN; } break;
+case 63:
+/* # line 458 "gram.in" */
+{ yyval.ival = TYUNKNOWN; } break;
+case 64:
+/* # line 459 "gram.in" */
+{ NOEXT("AUTOMATIC statement"); yyval.ival = - STGAUTO; } break;
+case 65:
+/* # line 460 "gram.in" */
+{ NOEXT("STATIC statement"); yyval.ival = - STGBSS; } break;
+case 66:
+/* # line 464 "gram.in" */
+{ yyval.lval = varleng; } break;
+case 67:
+/* # line 466 "gram.in" */
+{
+ expptr p;
+ p = yypvt[-1].expval;
+ NO66("length specification *n");
+ if( ! ISICON(p) || p->constblock.Const.ci<0 )
+ {
+ yyval.lval = 0;
+ dclerr("length must be a positive integer constant",
+ NPNULL);
+ }
+ else {
+ if (vartype == TYCHAR)
+ yyval.lval = p->constblock.Const.ci;
+ else switch((int)p->constblock.Const.ci) {
+ case 1: yyval.lval = 1; break;
+ case 2: yyval.lval = typesize[TYSHORT]; break;
+ case 4: yyval.lval = typesize[TYLONG]; break;
+ case 8: yyval.lval = typesize[TYDREAL]; break;
+ case 16: yyval.lval = typesize[TYDCOMPLEX]; break;
+ default:
+ dclerr("invalid length",NPNULL);
+ yyval.lval = varleng;
+ }
+ }
+ } break;
+case 68:
+/* # line 492 "gram.in" */
+{ NO66("length specification *(*)"); yyval.lval = -1; } break;
+case 69:
+/* # line 496 "gram.in" */
+{ incomm( yyval.extval = comblock("") , yypvt[-0].namval ); } break;
+case 70:
+/* # line 498 "gram.in" */
+{ yyval.extval = yypvt[-1].extval; incomm(yypvt[-1].extval, yypvt[-0].namval); } break;
+case 71:
+/* # line 500 "gram.in" */
+{ yyval.extval = yypvt[-2].extval; incomm(yypvt[-2].extval, yypvt[-0].namval); } break;
+case 72:
+/* # line 502 "gram.in" */
+{ incomm(yypvt[-2].extval, yypvt[-0].namval); } break;
+case 73:
+/* # line 506 "gram.in" */
+{ yyval.extval = comblock(""); } break;
+case 74:
+/* # line 508 "gram.in" */
+{ yyval.extval = comblock(token); } break;
+case 75:
+/* # line 512 "gram.in" */
+{ setext(yypvt[-0].namval); } break;
+case 76:
+/* # line 514 "gram.in" */
+{ setext(yypvt[-0].namval); } break;
+case 77:
+/* # line 518 "gram.in" */
+{ NO66("INTRINSIC statement"); setintr(yypvt[-0].namval); } break;
+case 78:
+/* # line 520 "gram.in" */
+{ setintr(yypvt[-0].namval); } break;
+case 81:
+/* # line 528 "gram.in" */
+{
+ struct Equivblock *p;
+ if(nequiv >= maxequiv)
+ many("equivalences", 'q', maxequiv);
+ p = & eqvclass[nequiv++];
+ p->eqvinit = NO;
+ p->eqvbottom = 0;
+ p->eqvtop = 0;
+ p->equivs = yypvt[-1].eqvval;
+ } break;
+case 82:
+/* # line 541 "gram.in" */
+{ yyval.eqvval=ALLOC(Eqvchain);
+ yyval.eqvval->eqvitem.eqvlhs = (struct Primblock *)yypvt[-0].expval;
+ } break;
+case 83:
+/* # line 545 "gram.in" */
+{ yyval.eqvval=ALLOC(Eqvchain);
+ yyval.eqvval->eqvitem.eqvlhs = (struct Primblock *) yypvt[-0].expval;
+ yyval.eqvval->eqvnextp = yypvt[-2].eqvval;
+ } break;
+case 86:
+/* # line 556 "gram.in" */
+{ if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+ if(parstate < INDATA)
+ {
+ enddcl();
+ parstate = INDATA;
+ }
+ } break;
+case 87:
+/* # line 570 "gram.in" */
+{ ftnint junk;
+ if(nextdata(&junk) != NULL)
+ err("too few initializers");
+ frdata(yypvt[-4].chval);
+ frrpl();
+ } break;
+case 88:
+/* # line 578 "gram.in" */
+{ frchain(&datastack); curdtp = 0; } break;
+case 89:
+/* # line 580 "gram.in" */
+{ pop_datastack(); } break;
+case 90:
+/* # line 582 "gram.in" */
+{ toomanyinit = NO; } break;
+case 93:
+/* # line 587 "gram.in" */
+{ dataval(ENULL, yypvt[-0].expval); } break;
+case 94:
+/* # line 589 "gram.in" */
+{ dataval(yypvt[-2].expval, yypvt[-0].expval); } break;
+case 96:
+/* # line 594 "gram.in" */
+{ if( yypvt[-1].ival==OPMINUS && ISCONST(yypvt[-0].expval) )
+ consnegop((Constp)yypvt[-0].expval);
+ yyval.expval = yypvt[-0].expval;
+ } break;
+case 100:
+/* # line 606 "gram.in" */
+{ int k;
+ yypvt[-0].namval->vsave = YES;
+ k = yypvt[-0].namval->vstg;
+ if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
+ dclerr("can only save static variables", yypvt[-0].namval);
+ } break;
+case 104:
+/* # line 620 "gram.in" */
+{ if(yypvt[-2].namval->vclass == CLUNKNOWN)
+ make_param((struct Paramblock *)yypvt[-2].namval, yypvt[-0].expval);
+ else dclerr("cannot make into parameter", yypvt[-2].namval);
+ } break;
+case 105:
+/* # line 627 "gram.in" */
+{ if(ndim>0) setbound(yypvt[-1].namval, ndim, dims); } break;
+case 106:
+/* # line 631 "gram.in" */
+{ Namep np;
+ np = ( (struct Primblock *) yypvt[-0].expval) -> namep;
+ vardcl(np);
+ if(np->vstg == STGCOMMON)
+ extsymtab[np->vardesc.varno].extinit = YES;
+ else if(np->vstg==STGEQUIV)
+ eqvclass[np->vardesc.varno].eqvinit = YES;
+ else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
+ dclerr("inconsistent storage classes", np);
+ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL);
+ } break;
+case 107:
+/* # line 643 "gram.in" */
+{ chainp p; struct Impldoblock *q;
+ pop_datastack();
+ q = ALLOC(Impldoblock);
+ q->tag = TIMPLDO;
+ (q->varnp = (Namep) (yypvt[-1].chval->datap))->vimpldovar = 1;
+ p = yypvt[-1].chval->nextp;
+ if(p) { q->implb = (expptr)(p->datap); p = p->nextp; }
+ if(p) { q->impub = (expptr)(p->datap); p = p->nextp; }
+ if(p) { q->impstep = (expptr)(p->datap); }
+ frchain( & (yypvt[-1].chval) );
+ yyval.chval = mkchain((char *)q, CHNULL);
+ q->datalist = hookup(yypvt[-3].chval, yyval.chval);
+ } break;
+case 108:
+/* # line 659 "gram.in" */
+{ if (!datastack)
+ curdtp = 0;
+ datastack = mkchain((char *)curdtp, datastack);
+ curdtp = yypvt[-0].chval; curdtelt = 0;
+ } break;
+case 109:
+/* # line 665 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, yypvt[-0].chval); } break;
+case 110:
+/* # line 669 "gram.in" */
+{ ndim = 0; } break;
+case 112:
+/* # line 673 "gram.in" */
+{ ndim = 0; } break;
+case 115:
+/* # line 678 "gram.in" */
+{
+ if(ndim == maxdim)
+ err("too many dimensions");
+ else if(ndim < maxdim)
+ { dims[ndim].lb = 0;
+ dims[ndim].ub = yypvt[-0].expval;
+ }
+ ++ndim;
+ } break;
+case 116:
+/* # line 688 "gram.in" */
+{
+ if(ndim == maxdim)
+ err("too many dimensions");
+ else if(ndim < maxdim)
+ { dims[ndim].lb = yypvt[-2].expval;
+ dims[ndim].ub = yypvt[-0].expval;
+ }
+ ++ndim;
+ } break;
+case 117:
+/* # line 700 "gram.in" */
+{ yyval.expval = 0; } break;
+case 119:
+/* # line 705 "gram.in" */
+{ nstars = 1; labarray[0] = yypvt[-0].labval; } break;
+case 120:
+/* # line 707 "gram.in" */
+{ if(nstars < MAXLABLIST) labarray[nstars++] = yypvt[-0].labval; } break;
+case 121:
+/* # line 711 "gram.in" */
+{ yyval.labval = execlab( convci(toklen, token) ); } break;
+case 122:
+/* # line 715 "gram.in" */
+{ NO66("IMPLICIT statement"); } break;
+case 125:
+/* # line 721 "gram.in" */
+{ if (vartype != TYUNKNOWN)
+ dclerr("-- expected letter range",NPNULL);
+ setimpl(vartype, varleng, 'a', 'z'); } break;
+case 126:
+/* # line 726 "gram.in" */
+{ needkwd = 1; } break;
+case 130:
+/* # line 735 "gram.in" */
+{ setimpl(vartype, varleng, yypvt[-0].ival, yypvt[-0].ival); } break;
+case 131:
+/* # line 737 "gram.in" */
+{ setimpl(vartype, varleng, yypvt[-2].ival, yypvt[-0].ival); } break;
+case 132:
+/* # line 741 "gram.in" */
+{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
+ {
+ dclerr("implicit item must be single letter", NPNULL);
+ yyval.ival = 0;
+ }
+ else yyval.ival = token[0];
+ } break;
+case 135:
+/* # line 755 "gram.in" */
+{
+ if(yypvt[-2].namval->vclass == CLUNKNOWN)
+ {
+ yypvt[-2].namval->vclass = CLNAMELIST;
+ yypvt[-2].namval->vtype = TYINT;
+ yypvt[-2].namval->vstg = STGBSS;
+ yypvt[-2].namval->varxptr.namelist = yypvt[-0].chval;
+ yypvt[-2].namval->vardesc.varno = ++lastvarno;
+ }
+ else dclerr("cannot be a namelist name", yypvt[-2].namval);
+ } break;
+case 136:
+/* # line 769 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].namval, CHNULL); } break;
+case 137:
+/* # line 771 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].namval, CHNULL)); } break;
+case 138:
+/* # line 775 "gram.in" */
+{ switch(parstate)
+ {
+ case OUTSIDE: newproc();
+ startproc(ESNULL, CLMAIN);
+ case INSIDE: parstate = INDCL;
+ case INDCL: break;
+
+ case INDATA:
+ errstr(
+ "Statement order error: declaration after DATA",
+ CNULL);
+ break;
+
+ default:
+ dclerr("declaration among executables", NPNULL);
+ }
+ } break;
+case 139:
+/* # line 794 "gram.in" */
+{ yyval.chval = 0; } break;
+case 141:
+/* # line 799 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 142:
+/* # line 801 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].expval,CHNULL) ); } break;
+case 144:
+/* # line 806 "gram.in" */
+{ yyval.expval = yypvt[-1].expval; } break;
+case 148:
+/* # line 813 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 149:
+/* # line 815 "gram.in" */
+{ yyval.expval = mkexpr(OPSTAR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 150:
+/* # line 817 "gram.in" */
+{ yyval.expval = mkexpr(OPSLASH, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 151:
+/* # line 819 "gram.in" */
+{ yyval.expval = mkexpr(OPPOWER, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 152:
+/* # line 821 "gram.in" */
+{ if(yypvt[-1].ival == OPMINUS)
+ yyval.expval = mkexpr(OPNEG, yypvt[-0].expval, ENULL);
+ else yyval.expval = yypvt[-0].expval;
+ } break;
+case 153:
+/* # line 826 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 154:
+/* # line 828 "gram.in" */
+{ NO66(".EQV. operator");
+ yyval.expval = mkexpr(OPEQV, yypvt[-2].expval,yypvt[-0].expval); } break;
+case 155:
+/* # line 831 "gram.in" */
+{ NO66(".NEQV. operator");
+ yyval.expval = mkexpr(OPNEQV, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 156:
+/* # line 834 "gram.in" */
+{ yyval.expval = mkexpr(OPOR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 157:
+/* # line 836 "gram.in" */
+{ yyval.expval = mkexpr(OPAND, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 158:
+/* # line 838 "gram.in" */
+{ yyval.expval = mkexpr(OPNOT, yypvt[-0].expval, ENULL); } break;
+case 159:
+/* # line 840 "gram.in" */
+{ NO66("concatenation operator //");
+ yyval.expval = mkexpr(OPCONCAT, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 160:
+/* # line 844 "gram.in" */
+{ yyval.ival = OPPLUS; } break;
+case 161:
+/* # line 845 "gram.in" */
+{ yyval.ival = OPMINUS; } break;
+case 162:
+/* # line 848 "gram.in" */
+{ yyval.ival = OPEQ; } break;
+case 163:
+/* # line 849 "gram.in" */
+{ yyval.ival = OPGT; } break;
+case 164:
+/* # line 850 "gram.in" */
+{ yyval.ival = OPLT; } break;
+case 165:
+/* # line 851 "gram.in" */
+{ yyval.ival = OPGE; } break;
+case 166:
+/* # line 852 "gram.in" */
+{ yyval.ival = OPLE; } break;
+case 167:
+/* # line 853 "gram.in" */
+{ yyval.ival = OPNE; } break;
+case 168:
+/* # line 857 "gram.in" */
+{ yyval.expval = mkprim(yypvt[-0].namval, LBNULL, CHNULL); } break;
+case 169:
+/* # line 859 "gram.in" */
+{ NO66("substring operator :");
+ yyval.expval = mkprim(yypvt[-1].namval, LBNULL, yypvt[-0].chval); } break;
+case 170:
+/* # line 862 "gram.in" */
+{ yyval.expval = mkprim(yypvt[-3].namval, mklist(yypvt[-1].chval), CHNULL); } break;
+case 171:
+/* # line 864 "gram.in" */
+{ NO66("substring operator :");
+ yyval.expval = mkprim(yypvt[-4].namval, mklist(yypvt[-2].chval), yypvt[-0].chval); } break;
+case 172:
+/* # line 869 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-3].expval, mkchain((char *)yypvt[-1].expval,CHNULL)); } break;
+case 173:
+/* # line 873 "gram.in" */
+{ yyval.expval = 0; } break;
+case 175:
+/* # line 878 "gram.in" */
+{ if(yypvt[-0].namval->vclass == CLPARAM)
+ yyval.expval = (expptr) cpexpr(
+ ( (struct Paramblock *) (yypvt[-0].namval) ) -> paramval);
+ } break;
+case 177:
+/* # line 885 "gram.in" */
+{ yyval.expval = mklogcon(1); } break;
+case 178:
+/* # line 886 "gram.in" */
+{ yyval.expval = mklogcon(0); } break;
+case 179:
+/* # line 887 "gram.in" */
+{ yyval.expval = mkstrcon(toklen, token); } break;
+case 180:
+/* # line 888 "gram.in" */
+ { yyval.expval = mkintcon( convci(toklen, token) ); } break;
+case 181:
+/* # line 889 "gram.in" */
+ { yyval.expval = mkrealcon(tyreal, token); } break;
+case 182:
+/* # line 890 "gram.in" */
+ { yyval.expval = mkrealcon(TYDREAL, token); } break;
+case 184:
+/* # line 895 "gram.in" */
+{ yyval.expval = mkcxcon(yypvt[-3].expval,yypvt[-1].expval); } break;
+case 185:
+/* # line 899 "gram.in" */
+{ NOEXT("hex constant");
+ yyval.expval = mkbitcon(4, toklen, token); } break;
+case 186:
+/* # line 902 "gram.in" */
+{ NOEXT("octal constant");
+ yyval.expval = mkbitcon(3, toklen, token); } break;
+case 187:
+/* # line 905 "gram.in" */
+{ NOEXT("binary constant");
+ yyval.expval = mkbitcon(1, toklen, token); } break;
+case 189:
+/* # line 911 "gram.in" */
+{ yyval.expval = yypvt[-1].expval; } break;
+case 192:
+/* # line 917 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 193:
+/* # line 919 "gram.in" */
+{ yyval.expval = mkexpr(OPSTAR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 194:
+/* # line 921 "gram.in" */
+{ yyval.expval = mkexpr(OPSLASH, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 195:
+/* # line 923 "gram.in" */
+{ yyval.expval = mkexpr(OPPOWER, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 196:
+/* # line 925 "gram.in" */
+{ if(yypvt[-1].ival == OPMINUS)
+ yyval.expval = mkexpr(OPNEG, yypvt[-0].expval, ENULL);
+ else yyval.expval = yypvt[-0].expval;
+ } break;
+case 197:
+/* # line 930 "gram.in" */
+{ NO66("concatenation operator //");
+ yyval.expval = mkexpr(OPCONCAT, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 199:
+/* # line 935 "gram.in" */
+{
+ if(yypvt[-3].labval->labdefined)
+ execerr("no backward DO loops", CNULL);
+ yypvt[-3].labval->blklevel = blklevel+1;
+ exdo(yypvt[-3].labval->labelno, NPNULL, yypvt[-0].chval);
+ } break;
+case 200:
+/* # line 942 "gram.in" */
+{
+ exdo(ctls - ctlstack - 2, NPNULL, yypvt[-0].chval);
+ NOEXT("DO without label");
+ } break;
+case 201:
+/* # line 947 "gram.in" */
+{ exenddo(NPNULL); } break;
+case 202:
+/* # line 949 "gram.in" */
+{ exendif(); thiswasbranch = NO; } break;
+case 204:
+/* # line 952 "gram.in" */
+{ exelif(yypvt[-2].expval); lastwasbranch = NO; } break;
+case 205:
+/* # line 954 "gram.in" */
+{ exelse(); lastwasbranch = NO; } break;
+case 206:
+/* # line 956 "gram.in" */
+{ exendif(); lastwasbranch = NO; } break;
+case 207:
+/* # line 960 "gram.in" */
+{ exif(yypvt[-1].expval); } break;
+case 208:
+/* # line 964 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].namval, yypvt[-0].chval); } break;
+case 210:
+/* # line 969 "gram.in" */
+{ yyval.chval = mkchain(CNULL, (chainp)yypvt[-1].expval); } break;
+case 211:
+/* # line 973 "gram.in" */
+{ exequals((struct Primblock *)yypvt[-2].expval, yypvt[-0].expval); } break;
+case 212:
+/* # line 975 "gram.in" */
+{ exassign(yypvt[-0].namval, yypvt[-2].labval); } break;
+case 215:
+/* # line 979 "gram.in" */
+{ inioctl = NO; } break;
+case 216:
+/* # line 981 "gram.in" */
+{ exarif(yypvt[-6].expval, yypvt[-4].labval, yypvt[-2].labval, yypvt[-0].labval); thiswasbranch = YES; } break;
+case 217:
+/* # line 983 "gram.in" */
+{ excall(yypvt[-0].namval, LBNULL, 0, labarray); } break;
+case 218:
+/* # line 985 "gram.in" */
+{ excall(yypvt[-2].namval, LBNULL, 0, labarray); } break;
+case 219:
+/* # line 987 "gram.in" */
+{ if(nstars < MAXLABLIST)
+ excall(yypvt[-3].namval, mklist(yypvt[-1].chval), nstars, labarray);
+ else
+ err("too many alternate returns");
+ } break;
+case 220:
+/* # line 993 "gram.in" */
+{ exreturn(yypvt[-0].expval); thiswasbranch = YES; } break;
+case 221:
+/* # line 995 "gram.in" */
+{ exstop(yypvt[-2].ival, yypvt[-0].expval); thiswasbranch = yypvt[-2].ival; } break;
+case 222:
+/* # line 999 "gram.in" */
+{ yyval.labval = mklabel( convci(toklen, token) ); } break;
+case 223:
+/* # line 1003 "gram.in" */
+{ if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+ } break;
+case 224:
+/* # line 1012 "gram.in" */
+{ exgoto(yypvt[-0].labval); thiswasbranch = YES; } break;
+case 225:
+/* # line 1014 "gram.in" */
+{ exasgoto(yypvt[-0].namval); thiswasbranch = YES; } break;
+case 226:
+/* # line 1016 "gram.in" */
+{ exasgoto(yypvt[-4].namval); thiswasbranch = YES; } break;
+case 227:
+/* # line 1018 "gram.in" */
+{ if(nstars < MAXLABLIST)
+ putcmgo(putx(fixtype(yypvt[-0].expval)), nstars, labarray);
+ else
+ err("computed GOTO list too long");
+ } break;
+case 230:
+/* # line 1030 "gram.in" */
+{ nstars = 0; yyval.namval = yypvt[-0].namval; } break;
+case 231:
+/* # line 1034 "gram.in" */
+{ yyval.chval = (yypvt[-0].expval ? mkchain((char *)yypvt[-0].expval,CHNULL) : CHNULL); } break;
+case 232:
+/* # line 1036 "gram.in" */
+{ if(yypvt[-0].expval)
+ if(yypvt[-2].chval) yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].expval,CHNULL));
+ else yyval.chval = mkchain((char *)yypvt[-0].expval,CHNULL);
+ else
+ yyval.chval = yypvt[-2].chval;
+ } break;
+case 234:
+/* # line 1046 "gram.in" */
+{ if(nstars<MAXLABLIST) labarray[nstars++] = yypvt[-0].labval; yyval.expval = 0; } break;
+case 235:
+/* # line 1050 "gram.in" */
+{ yyval.ival = 0; } break;
+case 236:
+/* # line 1052 "gram.in" */
+{ yyval.ival = 1; } break;
+case 237:
+/* # line 1056 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 238:
+/* # line 1058 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].expval,CHNULL) ); } break;
+case 239:
+/* # line 1062 "gram.in" */
+{ if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+
+/* This next statement depends on the ordering of the state table encoding */
+
+ if(parstate < INDATA) enddcl();
+ } break;
+case 240:
+/* # line 1075 "gram.in" */
+{ intonly = YES; } break;
+case 241:
+/* # line 1079 "gram.in" */
+{ intonly = NO; } break;
+case 242:
+/* # line 1084 "gram.in" */
+{ endio(); } break;
+case 244:
+/* # line 1089 "gram.in" */
+{ ioclause(IOSUNIT, yypvt[-0].expval); endioctl(); } break;
+case 245:
+/* # line 1091 "gram.in" */
+{ ioclause(IOSUNIT, ENULL); endioctl(); } break;
+case 246:
+/* # line 1093 "gram.in" */
+{ ioclause(IOSUNIT, IOSTDERR); endioctl(); } break;
+case 248:
+/* # line 1096 "gram.in" */
+{ doio(CHNULL); } break;
+case 249:
+/* # line 1098 "gram.in" */
+{ doio(CHNULL); } break;
+case 250:
+/* # line 1100 "gram.in" */
+{ doio(yypvt[-0].chval); } break;
+case 251:
+/* # line 1102 "gram.in" */
+{ doio(yypvt[-0].chval); } break;
+case 252:
+/* # line 1104 "gram.in" */
+{ doio(yypvt[-0].chval); } break;
+case 253:
+/* # line 1106 "gram.in" */
+{ doio(CHNULL); } break;
+case 254:
+/* # line 1108 "gram.in" */
+{ doio(yypvt[-0].chval); } break;
+case 255:
+/* # line 1110 "gram.in" */
+{ doio(CHNULL); } break;
+case 256:
+/* # line 1112 "gram.in" */
+{ doio(yypvt[-0].chval); } break;
+case 258:
+/* # line 1119 "gram.in" */
+{ iostmt = IOBACKSPACE; } break;
+case 259:
+/* # line 1121 "gram.in" */
+{ iostmt = IOREWIND; } break;
+case 260:
+/* # line 1123 "gram.in" */
+{ iostmt = IOENDFILE; } break;
+case 262:
+/* # line 1130 "gram.in" */
+{ iostmt = IOINQUIRE; } break;
+case 263:
+/* # line 1132 "gram.in" */
+{ iostmt = IOOPEN; } break;
+case 264:
+/* # line 1134 "gram.in" */
+{ iostmt = IOCLOSE; } break;
+case 265:
+/* # line 1138 "gram.in" */
+{
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, yypvt[-0].expval);
+ endioctl();
+ } break;
+case 266:
+/* # line 1144 "gram.in" */
+{
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, ENULL);
+ endioctl();
+ } break;
+case 267:
+/* # line 1152 "gram.in" */
+{
+ ioclause(IOSUNIT, yypvt[-1].expval);
+ endioctl();
+ } break;
+case 268:
+/* # line 1157 "gram.in" */
+{ endioctl(); } break;
+case 271:
+/* # line 1165 "gram.in" */
+{ ioclause(IOSPOSITIONAL, yypvt[-0].expval); } break;
+case 272:
+/* # line 1167 "gram.in" */
+{ ioclause(IOSPOSITIONAL, ENULL); } break;
+case 273:
+/* # line 1169 "gram.in" */
+{ ioclause(IOSPOSITIONAL, IOSTDERR); } break;
+case 274:
+/* # line 1171 "gram.in" */
+{ ioclause(yypvt[-1].ival, yypvt[-0].expval); } break;
+case 275:
+/* # line 1173 "gram.in" */
+{ ioclause(yypvt[-1].ival, ENULL); } break;
+case 276:
+/* # line 1175 "gram.in" */
+{ ioclause(yypvt[-1].ival, IOSTDERR); } break;
+case 277:
+/* # line 1179 "gram.in" */
+{ yyval.ival = iocname(); } break;
+case 278:
+/* # line 1183 "gram.in" */
+{ iostmt = IOREAD; } break;
+case 279:
+/* # line 1187 "gram.in" */
+{ iostmt = IOWRITE; } break;
+case 280:
+/* # line 1191 "gram.in" */
+{
+ iostmt = IOWRITE;
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, yypvt[-1].expval);
+ endioctl();
+ } break;
+case 281:
+/* # line 1198 "gram.in" */
+{
+ iostmt = IOWRITE;
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, ENULL);
+ endioctl();
+ } break;
+case 282:
+/* # line 1207 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, CHNULL); } break;
+case 283:
+/* # line 1209 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].tagval, CHNULL)); } break;
+case 284:
+/* # line 1213 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-0].expval; } break;
+case 285:
+/* # line 1215 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval,yypvt[-3].chval); } break;
+case 286:
+/* # line 1219 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 287:
+/* # line 1221 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, CHNULL); } break;
+case 289:
+/* # line 1226 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].expval, mkchain((char *)yypvt[-0].expval, CHNULL) ); } break;
+case 290:
+/* # line 1228 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].expval, mkchain((char *)yypvt[-0].tagval, CHNULL) ); } break;
+case 291:
+/* # line 1230 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].tagval, mkchain((char *)yypvt[-0].expval, CHNULL) ); } break;
+case 292:
+/* # line 1232 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].tagval, mkchain((char *)yypvt[-0].tagval, CHNULL) ); } break;
+case 293:
+/* # line 1234 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].expval, CHNULL) ); } break;
+case 294:
+/* # line 1236 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].tagval, CHNULL) ); } break;
+case 295:
+/* # line 1240 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-0].expval; } break;
+case 296:
+/* # line 1242 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-1].expval; } break;
+case 297:
+/* # line 1244 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, mkchain((char *)yypvt[-3].expval, CHNULL) ); } break;
+case 298:
+/* # line 1246 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, mkchain((char *)yypvt[-3].tagval, CHNULL) ); } break;
+case 299:
+/* # line 1248 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, yypvt[-3].chval); } break;
+case 300:
+/* # line 1252 "gram.in" */
+{ startioctl(); } break;
+ }
+ goto yystack; /* reset registers in driver code */
+}
--- /dev/null
+spec: dcl
+ | common
+ | external
+ | intrinsic
+ | equivalence
+ | data
+ | implicit
+ | namelist
+ | SSAVE
+ { NO66("SAVE statement");
+ saveall = YES; }
+ | SSAVE savelist
+ { NO66("SAVE statement"); }
+ | SFORMAT
+ { fmtstmt(thislabel); setfmt(thislabel); }
+ | SPARAM in_dcl SLPAR paramlist SRPAR
+ { NO66("PARAMETER statement"); }
+ ;
+
+dcl: type opt_comma name in_dcl new_dcl dims lengspec
+ { settype($3, $1, $7);
+ if(ndim>0) setbound($3,ndim,dims);
+ }
+ | dcl SCOMMA name dims lengspec
+ { settype($3, $1, $5);
+ if(ndim>0) setbound($3,ndim,dims);
+ }
+ | dcl SSLASHD datainit vallist SSLASHD
+ { if (new_dcl == 2) {
+ err("attempt to give DATA in type-declaration");
+ new_dcl = 1;
+ }
+ }
+ ;
+
+new_dcl: { new_dcl = 2; }
+
+type: typespec lengspec
+ { varleng = $2;
+ if (vartype == TYLOGICAL && varleng == 1) {
+ varleng = 0;
+ err("treating LOGICAL*1 as LOGICAL");
+ --nerr; /* allow generation of .c file */
+ }
+ }
+ ;
+
+typespec: typename
+ { varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
+ vartype = $1; }
+ ;
+
+typename: SINTEGER { $$ = TYLONG; }
+ | SREAL { $$ = tyreal; }
+ | SCOMPLEX { ++complex_seen; $$ = TYCOMPLEX; }
+ | SDOUBLE { $$ = TYDREAL; }
+ | SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
+ | SLOGICAL { $$ = TYLOGICAL; }
+ | SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; }
+ | SUNDEFINED { $$ = TYUNKNOWN; }
+ | SDIMENSION { $$ = TYUNKNOWN; }
+ | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
+ | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; }
+ ;
+
+lengspec:
+ { $$ = varleng; }
+ | SSTAR intonlyon expr intonlyoff
+ {
+ expptr p;
+ p = $3;
+ NO66("length specification *n");
+ if( ! ISICON(p) || p->constblock.Const.ci<0 )
+ {
+ $$ = 0;
+ dclerr("length must be a positive integer constant",
+ NPNULL);
+ }
+ else {
+ if (vartype == TYCHAR)
+ $$ = p->constblock.Const.ci;
+ else switch((int)p->constblock.Const.ci) {
+ case 1: $$ = 1; break;
+ case 2: $$ = typesize[TYSHORT]; break;
+ case 4: $$ = typesize[TYLONG]; break;
+ case 8: $$ = typesize[TYDREAL]; break;
+ case 16: $$ = typesize[TYDCOMPLEX]; break;
+ default:
+ dclerr("invalid length",NPNULL);
+ $$ = varleng;
+ }
+ }
+ }
+ | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
+ { NO66("length specification *(*)"); $$ = -1; }
+ ;
+
+common: SCOMMON in_dcl var
+ { incomm( $$ = comblock("") , $3 ); }
+ | SCOMMON in_dcl comblock var
+ { $$ = $3; incomm($3, $4); }
+ | common opt_comma comblock opt_comma var
+ { $$ = $3; incomm($3, $5); }
+ | common SCOMMA var
+ { incomm($1, $3); }
+ ;
+
+comblock: SCONCAT
+ { $$ = comblock(""); }
+ | SSLASH SNAME SSLASH
+ { $$ = comblock(token); }
+ ;
+
+external: SEXTERNAL in_dcl name
+ { setext($3); }
+ | external SCOMMA name
+ { setext($3); }
+ ;
+
+intrinsic: SINTRINSIC in_dcl name
+ { NO66("INTRINSIC statement"); setintr($3); }
+ | intrinsic SCOMMA name
+ { setintr($3); }
+ ;
+
+equivalence: SEQUIV in_dcl equivset
+ | equivalence SCOMMA equivset
+ ;
+
+equivset: SLPAR equivlist SRPAR
+ {
+ struct Equivblock *p;
+ if(nequiv >= maxequiv)
+ many("equivalences", 'q', maxequiv);
+ p = & eqvclass[nequiv++];
+ p->eqvinit = NO;
+ p->eqvbottom = 0;
+ p->eqvtop = 0;
+ p->equivs = $2;
+ }
+ ;
+
+equivlist: lhs
+ { $$=ALLOC(Eqvchain);
+ $$->eqvitem.eqvlhs = (struct Primblock *)$1;
+ }
+ | equivlist SCOMMA lhs
+ { $$=ALLOC(Eqvchain);
+ $$->eqvitem.eqvlhs = (struct Primblock *) $3;
+ $$->eqvnextp = $1;
+ }
+ ;
+
+data: SDATA in_data datalist
+ | data opt_comma datalist
+ ;
+
+in_data:
+ { if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+ if(parstate < INDATA)
+ {
+ enddcl();
+ parstate = INDATA;
+ }
+ }
+ ;
+
+datalist: datainit datavarlist SSLASH datapop vallist SSLASH
+ { ftnint junk;
+ if(nextdata(&junk) != NULL)
+ err("too few initializers");
+ frdata($2);
+ frrpl();
+ }
+ ;
+
+datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
+
+datapop: /* nothing */ { pop_datastack(); }
+
+vallist: { toomanyinit = NO; } val
+ | vallist SCOMMA val
+ ;
+
+val: value
+ { dataval(ENULL, $1); }
+ | simple SSTAR value
+ { dataval($1, $3); }
+ ;
+
+value: simple
+ | addop simple
+ { if( $1==OPMINUS && ISCONST($2) )
+ consnegop((Constp)$2);
+ $$ = $2;
+ }
+ | complex_const
+ ;
+
+savelist: saveitem
+ | savelist SCOMMA saveitem
+ ;
+
+saveitem: name
+ { int k;
+ $1->vsave = YES;
+ k = $1->vstg;
+ if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
+ dclerr("can only save static variables", $1);
+ }
+ | comblock
+ ;
+
+paramlist: paramitem
+ | paramlist SCOMMA paramitem
+ ;
+
+paramitem: name SEQUALS expr
+ { if($1->vclass == CLUNKNOWN)
+ make_param((struct Paramblock *)$1, $3);
+ else dclerr("cannot make into parameter", $1);
+ }
+ ;
+
+var: name dims
+ { if(ndim>0) setbound($1, ndim, dims); }
+ ;
+
+datavar: lhs
+ { Namep np;
+ np = ( (struct Primblock *) $1) -> namep;
+ vardcl(np);
+ if(np->vstg == STGCOMMON)
+ extsymtab[np->vardesc.varno].extinit = YES;
+ else if(np->vstg==STGEQUIV)
+ eqvclass[np->vardesc.varno].eqvinit = YES;
+ else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
+ dclerr("inconsistent storage classes", np);
+ $$ = mkchain((char *)$1, CHNULL);
+ }
+ | SLPAR datavarlist SCOMMA dospec SRPAR
+ { chainp p; struct Impldoblock *q;
+ pop_datastack();
+ q = ALLOC(Impldoblock);
+ q->tag = TIMPLDO;
+ (q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
+ p = $4->nextp;
+ if(p) { q->implb = (expptr)(p->datap); p = p->nextp; }
+ if(p) { q->impub = (expptr)(p->datap); p = p->nextp; }
+ if(p) { q->impstep = (expptr)(p->datap); }
+ frchain( & ($4) );
+ $$ = mkchain((char *)q, CHNULL);
+ q->datalist = hookup($2, $$);
+ }
+ ;
+
+datavarlist: datavar
+ { if (!datastack)
+ curdtp = 0;
+ datastack = mkchain((char *)curdtp, datastack);
+ curdtp = $1; curdtelt = 0;
+ }
+ | datavarlist SCOMMA datavar
+ { $$ = hookup($1, $3); }
+ ;
+
+dims:
+ { ndim = 0; }
+ | SLPAR dimlist SRPAR
+ ;
+
+dimlist: { ndim = 0; } dim
+ | dimlist SCOMMA dim
+ ;
+
+dim: ubound
+ {
+ if(ndim == maxdim)
+ err("too many dimensions");
+ else if(ndim < maxdim)
+ { dims[ndim].lb = 0;
+ dims[ndim].ub = $1;
+ }
+ ++ndim;
+ }
+ | expr SCOLON ubound
+ {
+ if(ndim == maxdim)
+ err("too many dimensions");
+ else if(ndim < maxdim)
+ { dims[ndim].lb = $1;
+ dims[ndim].ub = $3;
+ }
+ ++ndim;
+ }
+ ;
+
+ubound: SSTAR
+ { $$ = 0; }
+ | expr
+ ;
+
+labellist: label
+ { nstars = 1; labarray[0] = $1; }
+ | labellist SCOMMA label
+ { if(nstars < MAXLABLIST) labarray[nstars++] = $3; }
+ ;
+
+label: SICON
+ { $$ = execlab( convci(toklen, token) ); }
+ ;
+
+implicit: SIMPLICIT in_dcl implist
+ { NO66("IMPLICIT statement"); }
+ | implicit SCOMMA implist
+ ;
+
+implist: imptype SLPAR letgroups SRPAR
+ | imptype
+ { if (vartype != TYUNKNOWN)
+ dclerr("-- expected letter range",NPNULL);
+ setimpl(vartype, varleng, 'a', 'z'); }
+ ;
+
+imptype: { needkwd = 1; } type
+ /* { vartype = $2; } */
+ ;
+
+letgroups: letgroup
+ | letgroups SCOMMA letgroup
+ ;
+
+letgroup: letter
+ { setimpl(vartype, varleng, $1, $1); }
+ | letter SMINUS letter
+ { setimpl(vartype, varleng, $1, $3); }
+ ;
+
+letter: SNAME
+ { if(toklen!=1 || token[0]<'a' || token[0]>'z')
+ {
+ dclerr("implicit item must be single letter", NPNULL);
+ $$ = 0;
+ }
+ else $$ = token[0];
+ }
+ ;
+
+namelist: SNAMELIST
+ | namelist namelistentry
+ ;
+
+namelistentry: SSLASH name SSLASH namelistlist
+ {
+ if($2->vclass == CLUNKNOWN)
+ {
+ $2->vclass = CLNAMELIST;
+ $2->vtype = TYINT;
+ $2->vstg = STGBSS;
+ $2->varxptr.namelist = $4;
+ $2->vardesc.varno = ++lastvarno;
+ }
+ else dclerr("cannot be a namelist name", $2);
+ }
+ ;
+
+namelistlist: name
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | namelistlist SCOMMA name
+ { $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
+ ;
+
+in_dcl:
+ { switch(parstate)
+ {
+ case OUTSIDE: newproc();
+ startproc(ESNULL, CLMAIN);
+ case INSIDE: parstate = INDCL;
+ case INDCL: break;
+
+ case INDATA:
+ errstr(
+ "Statement order error: declaration after DATA",
+ CNULL);
+ break;
+
+ default:
+ dclerr("declaration among executables", NPNULL);
+ }
+ }
+ ;
--- /dev/null
+exec: iffable
+ | SDO end_spec intonlyon label intonlyoff opt_comma dospecw
+ {
+ if($4->labdefined)
+ execerr("no backward DO loops", CNULL);
+ $4->blklevel = blklevel+1;
+ exdo($4->labelno, NPNULL, $7);
+ }
+ | SDO end_spec opt_comma dospecw
+ {
+ exdo(ctls - ctlstack - 2, NPNULL, $4);
+ NOEXT("DO without label");
+ }
+ | SENDDO
+ { exenddo(NPNULL); }
+ | logif iffable
+ { exendif(); thiswasbranch = NO; }
+ | logif STHEN
+ | SELSEIF end_spec SLPAR expr SRPAR STHEN
+ { exelif($4); lastwasbranch = NO; }
+ | SELSE end_spec
+ { exelse(); lastwasbranch = NO; }
+ | SENDIF end_spec
+ { exendif(); lastwasbranch = NO; }
+ ;
+
+logif: SLOGIF end_spec SLPAR expr SRPAR
+ { exif($4); }
+ ;
+
+dospec: name SEQUALS exprlist
+ { $$ = mkchain((char *)$1, $3); }
+ ;
+
+dospecw: dospec
+ | SWHILE SLPAR expr SRPAR
+ { $$ = mkchain(CNULL, (chainp)$3); }
+ ;
+
+iffable: let lhs SEQUALS expr
+ { exequals((struct Primblock *)$2, $4); }
+ | SASSIGN end_spec assignlabel STO name
+ { exassign($5, $3); }
+ | SCONTINUE end_spec
+ | goto
+ | io
+ { inioctl = NO; }
+ | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label
+ { exarif($4, $6, $8, $10); thiswasbranch = YES; }
+ | call
+ { excall($1, LBNULL, 0, labarray); }
+ | call SLPAR SRPAR
+ { excall($1, LBNULL, 0, labarray); }
+ | call SLPAR callarglist SRPAR
+ { if(nstars < MAXLABLIST)
+ excall($1, mklist($3), nstars, labarray);
+ else
+ err("too many alternate returns");
+ }
+ | SRETURN end_spec opt_expr
+ { exreturn($3); thiswasbranch = YES; }
+ | stop end_spec opt_expr
+ { exstop($1, $3); thiswasbranch = $1; }
+ ;
+
+assignlabel: SICON
+ { $$ = mklabel( convci(toklen, token) ); }
+ ;
+
+let: SLET
+ { if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+ }
+ ;
+
+goto: SGOTO end_spec label
+ { exgoto($3); thiswasbranch = YES; }
+ | SASGOTO end_spec name
+ { exasgoto($3); thiswasbranch = YES; }
+ | SASGOTO end_spec name opt_comma SLPAR labellist SRPAR
+ { exasgoto($3); thiswasbranch = YES; }
+ | SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr
+ { if(nstars < MAXLABLIST)
+ putcmgo(putx(fixtype($7)), nstars, labarray);
+ else
+ err("computed GOTO list too long");
+ }
+ ;
+
+opt_comma:
+ | SCOMMA
+ ;
+
+call: SCALL end_spec name
+ { nstars = 0; $$ = $3; }
+ ;
+
+callarglist: callarg
+ { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL); }
+ | callarglist SCOMMA callarg
+ { if($3)
+ if($1) $$ = hookup($1, mkchain((char *)$3,CHNULL));
+ else $$ = mkchain((char *)$3,CHNULL);
+ else
+ $$ = $1;
+ }
+ ;
+
+callarg: expr
+ | SSTAR label
+ { if(nstars<MAXLABLIST) labarray[nstars++] = $2; $$ = 0; }
+ ;
+
+stop: SPAUSE
+ { $$ = 0; }
+ | SSTOP
+ { $$ = 1; }
+ ;
+
+exprlist: expr
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | exprlist SCOMMA expr
+ { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); }
+ ;
+
+end_spec:
+ { if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+
+/* This next statement depends on the ordering of the state table encoding */
+
+ if(parstate < INDATA) enddcl();
+ }
+ ;
+
+intonlyon:
+ { intonly = YES; }
+ ;
+
+intonlyoff:
+ { intonly = NO; }
+ ;
--- /dev/null
+funarglist:
+ { $$ = 0; }
+ | funargs
+ ;
+
+funargs: expr
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | funargs SCOMMA expr
+ { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); }
+ ;
+
+
+expr: uexpr
+ | SLPAR expr SRPAR { $$ = $2; }
+ | complex_const
+ ;
+
+uexpr: lhs
+ | simple_const
+ | expr addop expr %prec SPLUS
+ { $$ = mkexpr($2, $1, $3); }
+ | expr SSTAR expr
+ { $$ = mkexpr(OPSTAR, $1, $3); }
+ | expr SSLASH expr
+ { $$ = mkexpr(OPSLASH, $1, $3); }
+ | expr SPOWER expr
+ { $$ = mkexpr(OPPOWER, $1, $3); }
+ | addop expr %prec SSTAR
+ { if($1 == OPMINUS)
+ $$ = mkexpr(OPNEG, $2, ENULL);
+ else $$ = $2;
+ }
+ | expr relop expr %prec SEQ
+ { $$ = mkexpr($2, $1, $3); }
+ | expr SEQV expr
+ { NO66(".EQV. operator");
+ $$ = mkexpr(OPEQV, $1,$3); }
+ | expr SNEQV expr
+ { NO66(".NEQV. operator");
+ $$ = mkexpr(OPNEQV, $1, $3); }
+ | expr SOR expr
+ { $$ = mkexpr(OPOR, $1, $3); }
+ | expr SAND expr
+ { $$ = mkexpr(OPAND, $1, $3); }
+ | SNOT expr
+ { $$ = mkexpr(OPNOT, $2, ENULL); }
+ | expr SCONCAT expr
+ { NO66("concatenation operator //");
+ $$ = mkexpr(OPCONCAT, $1, $3); }
+ ;
+
+addop: SPLUS { $$ = OPPLUS; }
+ | SMINUS { $$ = OPMINUS; }
+ ;
+
+relop: SEQ { $$ = OPEQ; }
+ | SGT { $$ = OPGT; }
+ | SLT { $$ = OPLT; }
+ | SGE { $$ = OPGE; }
+ | SLE { $$ = OPLE; }
+ | SNE { $$ = OPNE; }
+ ;
+
+lhs: name
+ { $$ = mkprim($1, LBNULL, CHNULL); }
+ | name substring
+ { NO66("substring operator :");
+ $$ = mkprim($1, LBNULL, $2); }
+ | name SLPAR funarglist SRPAR
+ { $$ = mkprim($1, mklist($3), CHNULL); }
+ | name SLPAR funarglist SRPAR substring
+ { NO66("substring operator :");
+ $$ = mkprim($1, mklist($3), $5); }
+ ;
+
+substring: SLPAR opt_expr SCOLON opt_expr SRPAR
+ { $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); }
+ ;
+
+opt_expr:
+ { $$ = 0; }
+ | expr
+ ;
+
+simple: name
+ { if($1->vclass == CLPARAM)
+ $$ = (expptr) cpexpr(
+ ( (struct Paramblock *) ($1) ) -> paramval);
+ }
+ | simple_const
+ ;
+
+simple_const: STRUE { $$ = mklogcon(1); }
+ | SFALSE { $$ = mklogcon(0); }
+ | SHOLLERITH { $$ = mkstrcon(toklen, token); }
+ | SICON = { $$ = mkintcon( convci(toklen, token) ); }
+ | SRCON = { $$ = mkrealcon(tyreal, token); }
+ | SDCON = { $$ = mkrealcon(TYDREAL, token); }
+ | bit_const
+ ;
+
+complex_const: SLPAR uexpr SCOMMA uexpr SRPAR
+ { $$ = mkcxcon($2,$4); }
+ ;
+
+bit_const: SHEXCON
+ { NOEXT("hex constant");
+ $$ = mkbitcon(4, toklen, token); }
+ | SOCTCON
+ { NOEXT("octal constant");
+ $$ = mkbitcon(3, toklen, token); }
+ | SBITCON
+ { NOEXT("binary constant");
+ $$ = mkbitcon(1, toklen, token); }
+ ;
+
+fexpr: unpar_fexpr
+ | SLPAR fexpr SRPAR
+ { $$ = $2; }
+ ;
+
+unpar_fexpr: lhs
+ | simple_const
+ | fexpr addop fexpr %prec SPLUS
+ { $$ = mkexpr($2, $1, $3); }
+ | fexpr SSTAR fexpr
+ { $$ = mkexpr(OPSTAR, $1, $3); }
+ | fexpr SSLASH fexpr
+ { $$ = mkexpr(OPSLASH, $1, $3); }
+ | fexpr SPOWER fexpr
+ { $$ = mkexpr(OPPOWER, $1, $3); }
+ | addop fexpr %prec SSTAR
+ { if($1 == OPMINUS)
+ $$ = mkexpr(OPNEG, $2, ENULL);
+ else $$ = $2;
+ }
+ | fexpr SCONCAT fexpr
+ { NO66("concatenation operator //");
+ $$ = mkexpr(OPCONCAT, $1, $3); }
+ ;
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+%{
+# include "defs.h"
+# include "p1defs.h"
+
+static int nstars; /* Number of labels in an
+ alternate return CALL */
+static int ndim;
+static int vartype;
+int new_dcl;
+static ftnint varleng;
+static struct { expptr lb, ub; } dims[MAXDIM+1];
+static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate
+ return CALL */
+
+/* The next two variables are used to verify that each statement might be reached
+ during runtime. lastwasbranch is tested only in the defintion of the
+ stat: nonterminal. */
+
+int lastwasbranch = NO;
+static int thiswasbranch = NO;
+extern ftnint yystno;
+extern flag intonly;
+static chainp datastack;
+extern long laststfcn, thisstno;
+extern int can_include; /* for netlib */
+
+ftnint convci();
+Addrp nextdata();
+expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
+expptr mkcxcon();
+struct Listblock *mklist();
+struct Listblock *mklist();
+struct Impldoblock *mkiodo();
+Extsym *comblock();
+#define ESNULL (Extsym *)0
+#define NPNULL (Namep)0
+#define LBNULL (struct Listblock *)0
+extern void freetemps(), make_param();
+
+ static void
+pop_datastack() {
+ chainp d0 = datastack;
+ if (d0->datap)
+ curdtp = (chainp)d0->datap;
+ datastack = d0->nextp;
+ d0->nextp = 0;
+ frchain(&d0);
+ }
+
+%}
+
+/* Specify precedences and associativities. */
+
+%union {
+ int ival;
+ ftnint lval;
+ char *charpval;
+ chainp chval;
+ tagptr tagval;
+ expptr expval;
+ struct Labelblock *labval;
+ struct Nameblock *namval;
+ struct Eqvchain *eqvval;
+ Extsym *extval;
+ }
+
+%left SCOMMA
+%nonassoc SCOLON
+%right SEQUALS
+%left SEQV SNEQV
+%left SOR
+%left SAND
+%left SNOT
+%nonassoc SLT SGT SLE SGE SEQ SNE
+%left SCONCAT
+%left SPLUS SMINUS
+%left SSTAR SSLASH
+%right SPOWER
+
+%start program
+%type <labval> thislabel label assignlabel
+%type <tagval> other inelt
+%type <ival> type typespec typename dcl letter addop relop stop nameeq
+%type <lval> lengspec
+%type <charpval> filename
+%type <chval> datavar datavarlist namelistlist funarglist funargs
+%type <chval> dospec dospecw
+%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
+%type <namval> name arg call var
+%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
+%type <expval> ubound simple value callarg complex_const simple_const bit_const
+%type <extval> common comblock entryname progname
+%type <eqvval> equivlist
+
+%%
+
+program:
+ | program stat SEOS
+ ;
+
+stat: thislabel entry
+ {
+/* stat: is the nonterminal for Fortran statements */
+
+ lastwasbranch = NO; }
+ | thislabel spec
+ | thislabel exec
+ { /* forbid further statement function definitions... */
+ if (parstate == INDATA && laststfcn != thisstno)
+ parstate = INEXEC;
+ thisstno++;
+ if($1 && ($1->labelno==dorange))
+ enddo($1->labelno);
+ if(lastwasbranch && thislabel==NULL)
+ warn("statement cannot be reached");
+ lastwasbranch = thiswasbranch;
+ thiswasbranch = NO;
+ if($1)
+ {
+ if($1->labtype == LABFORMAT)
+ err("label already that of a format");
+ else
+ $1->labtype = LABEXEC;
+ }
+ freetemps();
+ }
+ | thislabel SINCLUDE filename
+ { if (can_include)
+ doinclude( $3 );
+ else {
+ fprintf(diagfile, "Cannot open file %s\n", $3);
+ done(1);
+ }
+ }
+ | thislabel SEND end_spec
+ { if ($1)
+ lastwasbranch = NO;
+ endproc(); /* lastwasbranch = NO; -- set in endproc() */
+ }
+ | thislabel SUNKNOWN
+ { extern void unclassifiable();
+ unclassifiable();
+
+/* flline flushes the current line, ignoring the rest of the text there */
+
+ flline(); };
+ | error
+ { flline(); needkwd = NO; inioctl = NO;
+ yyerrok; yyclearin; }
+ ;
+
+thislabel: SLABEL
+ {
+ if(yystno != 0)
+ {
+ $$ = thislabel = mklabel(yystno);
+ if( ! headerdone ) {
+ if (procclass == CLUNKNOWN)
+ procclass = CLMAIN;
+ puthead(CNULL, procclass);
+ }
+ if(thislabel->labdefined)
+ execerr("label %s already defined",
+ convic(thislabel->stateno) );
+ else {
+ if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
+ && thislabel->labtype!=LABFORMAT)
+ warn1("there is a branch to label %s from outside block",
+ convic( (ftnint) (thislabel->stateno) ) );
+ thislabel->blklevel = blklevel;
+ thislabel->labdefined = YES;
+ if(thislabel->labtype != LABFORMAT)
+ p1_label((long)(thislabel - labeltab));
+ }
+ }
+ else $$ = thislabel = NULL;
+ }
+ ;
+
+entry: SPROGRAM new_proc progname
+ {startproc($3, CLMAIN); }
+ | SPROGRAM new_proc progname progarglist
+ { warn("ignoring arguments to main program");
+ /* hashclear(); */
+ startproc($3, CLMAIN); }
+ | SBLOCK new_proc progname
+ { if($3) NO66("named BLOCKDATA");
+ startproc($3, CLBLOCK); }
+ | SSUBROUTINE new_proc entryname arglist
+ { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); }
+ | SFUNCTION new_proc entryname arglist
+ { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
+ | type SFUNCTION new_proc entryname arglist
+ { entrypt(CLPROC, $1, varleng, $4, $5); }
+ | SENTRY entryname arglist
+ { if(parstate==OUTSIDE || procclass==CLMAIN
+ || procclass==CLBLOCK)
+ execerr("misplaced entry statement", CNULL);
+ entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
+ }
+ ;
+
+new_proc:
+ { newproc(); }
+ ;
+
+entryname: name
+ { $$ = newentry($1, 1); }
+ ;
+
+name: SNAME
+ { $$ = mkname(token); }
+ ;
+
+progname: { $$ = NULL; }
+ | entryname
+ ;
+
+progarglist:
+ SLPAR SRPAR
+ | SLPAR progargs SRPAR
+ ;
+
+progargs: progarg
+ | progargs SCOMMA progarg
+ ;
+
+progarg: SNAME
+ | SNAME SEQUALS SNAME
+ ;
+
+arglist:
+ { $$ = 0; }
+ | SLPAR SRPAR
+ { NO66(" () argument list");
+ $$ = 0; }
+ | SLPAR args SRPAR
+ {$$ = $2; }
+ ;
+
+args: arg
+ { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
+ | args SCOMMA arg
+ { if($3) $1 = $$ = mkchain((char *)$3, $1); }
+ ;
+
+arg: name
+ { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
+ dclerr("name declared as argument after use", $1);
+ $1->vstg = STGARG;
+ }
+ | SSTAR
+ { NO66("altenate return argument");
+
+/* substars means that '*'ed formal parameters should be replaced.
+ This is used to specify alternate return labels; in theory, only
+ parameter slots which have '*' should accept the statement labels.
+ This compiler chooses to ignore the '*'s in the formal declaration, and
+ always return the proper value anyway.
+
+ This variable is only referred to in proc.c */
+
+ $$ = 0; substars = YES; }
+ ;
+
+
+
+filename: SHOLLERITH
+ {
+ char *s;
+ s = copyn(toklen+1, token);
+ s[toklen] = '\0';
+ $$ = s;
+ }
+ ;
--- /dev/null
+ /* Input/Output Statements */
+
+io: io1
+ { endio(); }
+ ;
+
+io1: iofmove ioctl
+ | iofmove unpar_fexpr
+ { ioclause(IOSUNIT, $2); endioctl(); }
+ | iofmove SSTAR
+ { ioclause(IOSUNIT, ENULL); endioctl(); }
+ | iofmove SPOWER
+ { ioclause(IOSUNIT, IOSTDERR); endioctl(); }
+ | iofctl ioctl
+ | read ioctl
+ { doio(CHNULL); }
+ | read infmt
+ { doio(CHNULL); }
+ | read ioctl inlist
+ { doio($3); }
+ | read infmt SCOMMA inlist
+ { doio($4); }
+ | read ioctl SCOMMA inlist
+ { doio($4); }
+ | write ioctl
+ { doio(CHNULL); }
+ | write ioctl outlist
+ { doio($3); }
+ | print
+ { doio(CHNULL); }
+ | print SCOMMA outlist
+ { doio($3); }
+ ;
+
+iofmove: fmkwd end_spec in_ioctl
+ ;
+
+fmkwd: SBACKSPACE
+ { iostmt = IOBACKSPACE; }
+ | SREWIND
+ { iostmt = IOREWIND; }
+ | SENDFILE
+ { iostmt = IOENDFILE; }
+ ;
+
+iofctl: ctlkwd end_spec in_ioctl
+ ;
+
+ctlkwd: SINQUIRE
+ { iostmt = IOINQUIRE; }
+ | SOPEN
+ { iostmt = IOOPEN; }
+ | SCLOSE
+ { iostmt = IOCLOSE; }
+ ;
+
+infmt: unpar_fexpr
+ {
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, $1);
+ endioctl();
+ }
+ | SSTAR
+ {
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, ENULL);
+ endioctl();
+ }
+ ;
+
+ioctl: SLPAR fexpr SRPAR
+ {
+ ioclause(IOSUNIT, $2);
+ endioctl();
+ }
+ | SLPAR ctllist SRPAR
+ { endioctl(); }
+ ;
+
+ctllist: ioclause
+ | ctllist SCOMMA ioclause
+ ;
+
+ioclause: fexpr
+ { ioclause(IOSPOSITIONAL, $1); }
+ | SSTAR
+ { ioclause(IOSPOSITIONAL, ENULL); }
+ | SPOWER
+ { ioclause(IOSPOSITIONAL, IOSTDERR); }
+ | nameeq expr
+ { ioclause($1, $2); }
+ | nameeq SSTAR
+ { ioclause($1, ENULL); }
+ | nameeq SPOWER
+ { ioclause($1, IOSTDERR); }
+ ;
+
+nameeq: SNAMEEQ
+ { $$ = iocname(); }
+ ;
+
+read: SREAD end_spec in_ioctl
+ { iostmt = IOREAD; }
+ ;
+
+write: SWRITE end_spec in_ioctl
+ { iostmt = IOWRITE; }
+ ;
+
+print: SPRINT end_spec fexpr in_ioctl
+ {
+ iostmt = IOWRITE;
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, $3);
+ endioctl();
+ }
+ | SPRINT end_spec SSTAR in_ioctl
+ {
+ iostmt = IOWRITE;
+ ioclause(IOSUNIT, ENULL);
+ ioclause(IOSFMT, ENULL);
+ endioctl();
+ }
+ ;
+
+inlist: inelt
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | inlist SCOMMA inelt
+ { $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
+ ;
+
+inelt: lhs
+ { $$ = (tagptr) $1; }
+ | SLPAR inlist SCOMMA dospec SRPAR
+ { $$ = (tagptr) mkiodo($4,$2); }
+ ;
+
+outlist: uexpr
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | other
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | out2
+ ;
+
+out2: uexpr SCOMMA uexpr
+ { $$ = mkchain((char *)$1, mkchain((char *)$3, CHNULL) ); }
+ | uexpr SCOMMA other
+ { $$ = mkchain((char *)$1, mkchain((char *)$3, CHNULL) ); }
+ | other SCOMMA uexpr
+ { $$ = mkchain((char *)$1, mkchain((char *)$3, CHNULL) ); }
+ | other SCOMMA other
+ { $$ = mkchain((char *)$1, mkchain((char *)$3, CHNULL) ); }
+ | out2 SCOMMA uexpr
+ { $$ = hookup($1, mkchain((char *)$3, CHNULL) ); }
+ | out2 SCOMMA other
+ { $$ = hookup($1, mkchain((char *)$3, CHNULL) ); }
+ ;
+
+other: complex_const
+ { $$ = (tagptr) $1; }
+ | SLPAR expr SRPAR
+ { $$ = (tagptr) $2; }
+ | SLPAR uexpr SCOMMA dospec SRPAR
+ { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
+ | SLPAR other SCOMMA dospec SRPAR
+ { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
+ | SLPAR out2 SCOMMA dospec SRPAR
+ { $$ = (tagptr) mkiodo($4, $2); }
+ ;
+
+in_ioctl:
+ { startioctl(); }
+ ;
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "iob.h"
+
+/* State required for the C output */
+char *fl_fmt_string; /* Float format string */
+char *db_fmt_string; /* Double format string */
+char *cm_fmt_string; /* Complex format string */
+char *dcm_fmt_string; /* Double complex format string */
+
+chainp new_vars = CHNULL; /* List of newly created locals in this
+ function. These may have identifiers
+ which have underscores and more than VL
+ characters */
+chainp used_builtins = CHNULL; /* List of builtins used by this function.
+ These are all Addrps with UNAM_EXTERN
+ */
+chainp assigned_fmts = CHNULL; /* assigned formats */
+chainp allargs; /* union of args in all entry points */
+chainp earlylabs; /* labels seen before enddcl() */
+char main_alias[52]; /* PROGRAM name, if any is given */
+int tab_size = 4;
+
+
+FILEP infile;
+FILEP diagfile;
+
+FILEP c_file;
+FILEP pass1_file;
+FILEP initfile;
+FILEP blkdfile;
+
+
+char token[MAXTOKENLEN];
+int toklen;
+long lineno; /* Current line in the input file, NOT the
+ Fortran statement label number */
+char *infname;
+int needkwd;
+struct Labelblock *thislabel = NULL;
+int nerr;
+int nwarn;
+
+flag saveall;
+flag substars;
+int parstate = OUTSIDE;
+flag headerdone = NO;
+int blklevel;
+int doin_setbound;
+int impltype[26];
+ftnint implleng[26];
+int implstg[26];
+
+int tyint = TYLONG ;
+int tylogical = TYLONG;
+int typesize[NTYPES] = {
+ 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
+ 2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 0,
+ 4*SZLONG + SZADDR, /* sizeof(cilist) */
+ 4*SZLONG + 2*SZADDR, /* sizeof(icilist) */
+ 4*SZLONG + 5*SZADDR, /* sizeof(olist) */
+ 2*SZLONG + SZADDR, /* sizeof(cllist) */
+ 2*SZLONG, /* sizeof(alist) */
+ 11*SZLONG + 15*SZADDR /* sizeof(inlist) */
+ };
+
+int typealign[NTYPES] = {
+ 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
+ ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1,
+ ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
+
+int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT };
+
+char *typename[] = {
+ "<<unknown>>",
+ "address",
+ "shortint",
+ "integer",
+ "real",
+ "doublereal",
+ "complex",
+ "doublecomplex",
+ "logical",
+ "char" /* character */
+ };
+
+int type_pref[NTYPES] = { 0, 0, 2, 4, 5, 7, 6, 8, 3, 1 };
+
+char *protorettypes[] = {
+ "?", "??", "shortint", "integer", "real", "doublereal",
+ "C_f", "Z_f", "logical", "H_f", "int"
+ };
+
+char *casttypes[TYSUBR+1] = {
+ "U_fp", "??bug??",
+ "J_fp", "I_fp", "R_fp",
+ "D_fp", "C_fp", "Z_fp",
+ "L_fp", "H_fp", "S_fp"
+ };
+char *usedcasts[TYSUBR+1];
+
+char *dfltarg[] = {
+ 0, 0,
+ "(shortint *)0", "(integer *)0", "(real *)0",
+ "(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
+ "(logical *)0", "(char *)0"
+ };
+
+static char *dflt0proc[] = {
+ 0, 0,
+ "(shortint (*)())0", "(integer (*)())0", "(real (*)())0",
+ "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
+ "(logical (*)())0", "(char (*)())0", "(int (*)())0"
+ };
+
+char *dflt1proc[] = { "(U_fp)0", "(??bug??)0",
+ "(J_fp)0", "(I_fp)0", "(R_fp)0",
+ "(D_fp)0", "(C_fp)0", "(Z_fp)0",
+ "(L_fp)0", "(H_fp)0", "(S_fp)0"
+ };
+
+char **dfltproc = dflt0proc;
+
+char *ftn_types[] = { "external", "??",
+ "integer*2", "integer", "real",
+ "double precision", "complex", "double complex",
+ "logical", "character", "subroutine"
+ };
+
+int proctype = TYUNKNOWN;
+char *procname;
+int rtvlabel[NTYPES0];
+Addrp retslot; /* Holds automatic variable which was
+ allocated the function return value
+ */
+Addrp xretslot[NTYPES0]; /* for multiple entry points */
+int cxslot = -1;
+int chslot = -1;
+int chlgslot = -1;
+int procclass = CLUNKNOWN;
+int nentry;
+int nallargs;
+int nallchargs;
+flag multitype;
+ftnint procleng;
+long lastiolabno;
+int lastlabno;
+int lastvarno;
+int lastargslot;
+int autonum[TYVOID];
+char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","L","ch",
+ "??TYSUBR??", "??TYERROR??","ci", "ici",
+ "o", "cl", "al", "ioin" };
+
+extern int maxctl;
+struct Ctlframe *ctls;
+struct Ctlframe *ctlstack;
+struct Ctlframe *lastctl;
+
+Namep regnamep[MAXREGVAR];
+int highregvar;
+int nregvar;
+
+extern int maxext;
+Extsym *extsymtab;
+Extsym *nextext;
+Extsym *lastext;
+
+extern int maxequiv;
+struct Equivblock *eqvclass;
+
+extern int maxhash;
+struct Hashentry *hashtab;
+struct Hashentry *lasthash;
+
+extern int maxstno; /* Maximum number of statement labels */
+struct Labelblock *labeltab;
+struct Labelblock *labtabend;
+struct Labelblock *highlabtab;
+
+int maxdim = MAXDIM;
+struct Rplblock *rpllist = NULL;
+struct Chain *curdtp = NULL;
+flag toomanyinit;
+ftnint curdtelt;
+chainp templist[TYVOID];
+chainp holdtemps;
+int dorange = 0;
+struct Entrypoint *entries = NULL;
+
+chainp chains = NULL;
+
+flag inioctl;
+int iostmt;
+int nioctl;
+int nequiv = 0;
+int eqvstart = 0;
+int nintnames = 0;
+
+struct Literal litpool[MAXLITERALS];
+int nliterals;
+
+char dflttype[26];
+char hextoi_tab[256], Letters[256];
+char *wh_first, *wh_next, *wh_last;
+
+#define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x))
+
+fileinit()
+{
+ register char *s;
+ register int i, j;
+
+ lastiolabno = 100000;
+ lastlabno = 0;
+ lastvarno = 0;
+ nliterals = 0;
+ nerr = 0;
+
+ infile = stdin;
+
+ memset(dflttype, tyreal, 26);
+ memset(dflttype + 'i' - 'a', tyint, 6);
+ memset(hextoi_tab, 16, sizeof(hextoi_tab));
+ for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
+ hextoi(*s) = i;
+ for(i = 10, s = "ABCDEF"; *s; i++, s++)
+ hextoi(*s) = i;
+ for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
+ Letters[i] = Letters[i+'A'-'a'] = j;
+
+ ctls = ALLOCN(maxctl+1, Ctlframe);
+ extsymtab = ALLOCN(maxext, Extsym);
+ eqvclass = ALLOCN(maxequiv, Equivblock);
+ hashtab = ALLOCN(maxhash, Hashentry);
+ labeltab = ALLOCN(maxstno, Labelblock);
+
+ ctlstack = ctls++;
+ lastctl = ctls + maxctl;
+ nextext = extsymtab;
+ lastext = extsymtab + maxext;
+ lasthash = hashtab + maxhash;
+ labtabend = labeltab + maxstno;
+ highlabtab = labeltab;
+ main_alias[0] = '\0';
+ if (forcedouble)
+ dfltproc[TYREAL] = dfltproc[TYDREAL];
+
+/* Initialize the routines for providing C output */
+
+ out_init ();
+}
+
+hashclear() /* clear hash table */
+{
+ register struct Hashentry *hp;
+ register Namep p;
+ register struct Dimblock *q;
+ register int i;
+
+ for(hp = hashtab ; hp < lasthash ; ++hp)
+ if(p = hp->varp)
+ {
+ frexpr(p->vleng);
+ if(q = p->vdim)
+ {
+ for(i = 0 ; i < q->ndim ; ++i)
+ {
+ frexpr(q->dims[i].dimsize);
+ frexpr(q->dims[i].dimexpr);
+ }
+ frexpr(q->nelt);
+ frexpr(q->baseoffset);
+ frexpr(q->basexpr);
+ free( (charptr) q);
+ }
+ if(p->vclass == CLNAMELIST)
+ frchain( &(p->varxptr.namelist) );
+ free( (charptr) p);
+ hp->varp = NULL;
+ }
+ }
+
+procinit()
+{
+ register struct Labelblock *lp;
+ struct Chain *cp;
+ int i;
+ extern struct memblock *curmemblock, *firstmemblock;
+ extern char *mem_first, *mem_next, *mem_last, *mem0_last;
+ extern void frexchain();
+
+ curmemblock = firstmemblock;
+ mem_next = mem_first;
+ mem_last = mem0_last;
+ wh_next = wh_first = wh_last = 0;
+ iob_list = 0;
+ for(i = 0; i < 9; i++)
+ io_structs[i] = 0;
+
+ parstate = OUTSIDE;
+ headerdone = NO;
+ blklevel = 1;
+ saveall = NO;
+ substars = NO;
+ nwarn = 0;
+ thislabel = NULL;
+ needkwd = 0;
+
+ proctype = TYUNKNOWN;
+ procname = "MAIN_";
+ procclass = CLUNKNOWN;
+ nentry = 0;
+ nallargs = nallchargs = 0;
+ multitype = NO;
+ retslot = NULL;
+ for(i = 0; i < NTYPES0; i++) {
+ frexpr((expptr)xretslot[i]);
+ xretslot[i] = 0;
+ }
+ cxslot = -1;
+ chslot = -1;
+ chlgslot = -1;
+ procleng = 0;
+ blklevel = 1;
+ lastargslot = 0;
+
+ for(lp = labeltab ; lp < labtabend ; ++lp)
+ lp->stateno = 0;
+
+ hashclear();
+
+/* Clear the list of newly generated identifiers from the previous
+ function */
+
+ frexchain(&new_vars);
+ frexchain(&used_builtins);
+ frchain(&assigned_fmts);
+ frchain(&allargs);
+ frchain(&earlylabs);
+
+ nintnames = 0;
+ highlabtab = labeltab;
+
+ ctlstack = ctls - 1;
+ for(i = TYADDR; i < TYVOID; i++) {
+ for(cp = templist[i]; cp ; cp = cp->nextp)
+ free( (charptr) (cp->datap) );
+ frchain(templist + i);
+ autonum[i] = 0;
+ }
+ holdtemps = NULL;
+ dorange = 0;
+ nregvar = 0;
+ highregvar = 0;
+ entries = NULL;
+ rpllist = NULL;
+ inioctl = NO;
+ eqvstart += nequiv;
+ nequiv = 0;
+ dcomplex_seen = 0;
+
+ for(i = 0 ; i<NTYPES0 ; ++i)
+ rtvlabel[i] = 0;
+
+ if(undeftype)
+ setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
+ else
+ {
+ setimpl(tyreal, (ftnint) 0, 'a', 'z');
+ setimpl(tyint, (ftnint) 0, 'i', 'n');
+ }
+ setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
+ setlog();
+}
+
+
+
+
+setimpl(type, length, c1, c2)
+int type;
+ftnint length;
+int c1, c2;
+{
+ int i;
+ char buff[100];
+
+ if(c1==0 || c2==0)
+ return;
+
+ if(c1 > c2) {
+ sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
+ err(buff);
+ }
+ else {
+ c1 = letter(c1);
+ c2 = letter(c2);
+ if(type < 0)
+ for(i = c1 ; i<=c2 ; ++i)
+ implstg[i] = - type;
+ else {
+ type = lengtype(type, length);
+ if(type != TYCHAR)
+ length = 0;
+ for(i = c1 ; i<=c2 ; ++i) {
+ impltype[i] = type;
+ implleng[i] = length;
+ }
+ }
+ }
+ }
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+
+void cast_args ();
+
+union
+ {
+ int ijunk;
+ struct Intrpacked bits;
+ } packed;
+
+struct Intrbits
+ {
+ char intrgroup /* :3 */;
+ char intrstuff /* result type or number of generics */;
+ char intrno /* :7 */;
+ char dblcmplx;
+ char dblintrno; /* for -r8 */
+ };
+
+/* List of all intrinsic functions. */
+
+LOCAL struct Intrblock
+ {
+ char intrfname[8];
+ struct Intrbits intrval;
+ } intrtab[ ] =
+{
+"int", { INTRCONV, TYLONG },
+"real", { INTRCONV, TYREAL, 1 },
+ /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
+"dble", { INTRCONV, TYDREAL },
+"cmplx", { INTRCONV, TYCOMPLEX },
+"dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 },
+"ifix", { INTRCONV, TYLONG },
+"idint", { INTRCONV, TYLONG },
+"float", { INTRCONV, TYREAL },
+"dfloat", { INTRCONV, TYDREAL },
+"sngl", { INTRCONV, TYREAL },
+"ichar", { INTRCONV, TYLONG },
+"iachar", { INTRCONV, TYLONG },
+"char", { INTRCONV, TYCHAR },
+"achar", { INTRCONV, TYCHAR },
+
+/* any MAX or MIN can be used with any types; the compiler will cast them
+ correctly. So rules against bad syntax in these expressions are not
+ enforced */
+
+"max", { INTRMAX, TYUNKNOWN },
+"max0", { INTRMAX, TYLONG },
+"amax0", { INTRMAX, TYREAL },
+"max1", { INTRMAX, TYLONG },
+"amax1", { INTRMAX, TYREAL },
+"dmax1", { INTRMAX, TYDREAL },
+
+"and", { INTRBOOL, TYUNKNOWN, OPBITAND },
+"or", { INTRBOOL, TYUNKNOWN, OPBITOR },
+"xor", { INTRBOOL, TYUNKNOWN, OPBITXOR },
+"not", { INTRBOOL, TYUNKNOWN, OPBITNOT },
+"lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT },
+"rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT },
+
+"min", { INTRMIN, TYUNKNOWN },
+"min0", { INTRMIN, TYLONG },
+"amin0", { INTRMIN, TYREAL },
+"min1", { INTRMIN, TYLONG },
+"amin1", { INTRMIN, TYREAL },
+"dmin1", { INTRMIN, TYDREAL },
+
+"aint", { INTRGEN, 2, 0 },
+"dint", { INTRSPEC, TYDREAL, 1 },
+
+"anint", { INTRGEN, 2, 2 },
+"dnint", { INTRSPEC, TYDREAL, 3 },
+
+"nint", { INTRGEN, 4, 4 },
+"idnint", { INTRGEN, 2, 6 },
+
+"abs", { INTRGEN, 6, 8 },
+"iabs", { INTRGEN, 2, 9 },
+"dabs", { INTRSPEC, TYDREAL, 11 },
+"cabs", { INTRSPEC, TYREAL, 12, 0, 13 },
+"zabs", { INTRSPEC, TYDREAL, 13, 1 },
+
+"mod", { INTRGEN, 4, 14 },
+"amod", { INTRSPEC, TYREAL, 16, 0, 17 },
+"dmod", { INTRSPEC, TYDREAL, 17 },
+
+"sign", { INTRGEN, 4, 18 },
+"isign", { INTRGEN, 2, 19 },
+"dsign", { INTRSPEC, TYDREAL, 21 },
+
+"dim", { INTRGEN, 4, 22 },
+"idim", { INTRGEN, 2, 23 },
+"ddim", { INTRSPEC, TYDREAL, 25 },
+
+"dprod", { INTRSPEC, TYDREAL, 26 },
+
+"len", { INTRSPEC, TYLONG, 27 },
+"index", { INTRSPEC, TYLONG, 29 },
+
+"imag", { INTRGEN, 2, 31 },
+"aimag", { INTRSPEC, TYREAL, 31, 0, 32 },
+"dimag", { INTRSPEC, TYDREAL, 32 },
+
+"conjg", { INTRGEN, 2, 33 },
+"dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 },
+
+"sqrt", { INTRGEN, 4, 35 },
+"dsqrt", { INTRSPEC, TYDREAL, 36 },
+"csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
+"zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 },
+
+"exp", { INTRGEN, 4, 39 },
+"dexp", { INTRSPEC, TYDREAL, 40 },
+"cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
+"zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 },
+
+"log", { INTRGEN, 4, 43 },
+"alog", { INTRSPEC, TYREAL, 43, 0, 44 },
+"dlog", { INTRSPEC, TYDREAL, 44 },
+"clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
+"zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 },
+
+"log10", { INTRGEN, 2, 47 },
+"alog10", { INTRSPEC, TYREAL, 47, 0, 48 },
+"dlog10", { INTRSPEC, TYDREAL, 48 },
+
+"sin", { INTRGEN, 4, 49 },
+"dsin", { INTRSPEC, TYDREAL, 50 },
+"csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
+"zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 },
+
+"cos", { INTRGEN, 4, 53 },
+"dcos", { INTRSPEC, TYDREAL, 54 },
+"ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
+"zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 },
+
+"tan", { INTRGEN, 2, 57 },
+"dtan", { INTRSPEC, TYDREAL, 58 },
+
+"asin", { INTRGEN, 2, 59 },
+"dasin", { INTRSPEC, TYDREAL, 60 },
+
+"acos", { INTRGEN, 2, 61 },
+"dacos", { INTRSPEC, TYDREAL, 62 },
+
+"atan", { INTRGEN, 2, 63 },
+"datan", { INTRSPEC, TYDREAL, 64 },
+
+"atan2", { INTRGEN, 2, 65 },
+"datan2", { INTRSPEC, TYDREAL, 66 },
+
+"sinh", { INTRGEN, 2, 67 },
+"dsinh", { INTRSPEC, TYDREAL, 68 },
+
+"cosh", { INTRGEN, 2, 69 },
+"dcosh", { INTRSPEC, TYDREAL, 70 },
+
+"tanh", { INTRGEN, 2, 71 },
+"dtanh", { INTRSPEC, TYDREAL, 72 },
+
+"lge", { INTRSPEC, TYLOGICAL, 73},
+"lgt", { INTRSPEC, TYLOGICAL, 75},
+"lle", { INTRSPEC, TYLOGICAL, 77},
+"llt", { INTRSPEC, TYLOGICAL, 79},
+
+#if 0
+"epbase", { INTRCNST, 4, 0 },
+"epprec", { INTRCNST, 4, 4 },
+"epemin", { INTRCNST, 2, 8 },
+"epemax", { INTRCNST, 2, 10 },
+"eptiny", { INTRCNST, 2, 12 },
+"ephuge", { INTRCNST, 4, 14 },
+"epmrsp", { INTRCNST, 2, 18 },
+#endif
+
+"fpexpn", { INTRGEN, 4, 81 },
+"fpabsp", { INTRGEN, 2, 85 },
+"fprrsp", { INTRGEN, 2, 87 },
+"fpfrac", { INTRGEN, 2, 89 },
+"fpmake", { INTRGEN, 2, 91 },
+"fpscal", { INTRGEN, 2, 93 },
+
+"" };
+
+
+LOCAL struct Specblock
+ {
+ char atype; /* Argument type; every arg must have
+ this type */
+ char rtype; /* Result type */
+ char nargs; /* Number of arguments */
+ char spxname[8]; /* Name of the function in Fortran */
+ char othername; /* index into callbyvalue table */
+ } spectab[ ] =
+{
+ { TYREAL,TYREAL,1,"r_int" },
+ { TYDREAL,TYDREAL,1,"d_int" },
+
+ { TYREAL,TYREAL,1,"r_nint" },
+ { TYDREAL,TYDREAL,1,"d_nint" },
+
+ { TYREAL,TYSHORT,1,"h_nint" },
+ { TYREAL,TYLONG,1,"i_nint" },
+
+ { TYDREAL,TYSHORT,1,"h_dnnt" },
+ { TYDREAL,TYLONG,1,"i_dnnt" },
+
+ { TYREAL,TYREAL,1,"r_abs" },
+ { TYSHORT,TYSHORT,1,"h_abs" },
+ { TYLONG,TYLONG,1,"i_abs" },
+ { TYDREAL,TYDREAL,1,"d_abs" },
+ { TYCOMPLEX,TYREAL,1,"c_abs" },
+ { TYDCOMPLEX,TYDREAL,1,"z_abs" },
+
+ { TYSHORT,TYSHORT,2,"h_mod" },
+ { TYLONG,TYLONG,2,"i_mod" },
+ { TYREAL,TYREAL,2,"r_mod" },
+ { TYDREAL,TYDREAL,2,"d_mod" },
+
+ { TYREAL,TYREAL,2,"r_sign" },
+ { TYSHORT,TYSHORT,2,"h_sign" },
+ { TYLONG,TYLONG,2,"i_sign" },
+ { TYDREAL,TYDREAL,2,"d_sign" },
+
+ { TYREAL,TYREAL,2,"r_dim" },
+ { TYSHORT,TYSHORT,2,"h_dim" },
+ { TYLONG,TYLONG,2,"i_dim" },
+ { TYDREAL,TYDREAL,2,"d_dim" },
+
+ { TYREAL,TYDREAL,2,"d_prod" },
+
+ { TYCHAR,TYSHORT,1,"h_len" },
+ { TYCHAR,TYLONG,1,"i_len" },
+
+ { TYCHAR,TYSHORT,2,"h_indx" },
+ { TYCHAR,TYLONG,2,"i_indx" },
+
+ { TYCOMPLEX,TYREAL,1,"r_imag" },
+ { TYDCOMPLEX,TYDREAL,1,"d_imag" },
+ { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
+ { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
+
+ { TYREAL,TYREAL,1,"r_sqrt", 1 },
+ { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
+ { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
+ { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
+
+ { TYREAL,TYREAL,1,"r_exp", 2 },
+ { TYDREAL,TYDREAL,1,"d_exp", 2 },
+ { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
+ { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
+
+ { TYREAL,TYREAL,1,"r_log", 3 },
+ { TYDREAL,TYDREAL,1,"d_log", 3 },
+ { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
+ { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
+
+ { TYREAL,TYREAL,1,"r_lg10" },
+ { TYDREAL,TYDREAL,1,"d_lg10" },
+
+ { TYREAL,TYREAL,1,"r_sin", 4 },
+ { TYDREAL,TYDREAL,1,"d_sin", 4 },
+ { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
+ { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
+
+ { TYREAL,TYREAL,1,"r_cos", 5 },
+ { TYDREAL,TYDREAL,1,"d_cos", 5 },
+ { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
+ { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
+
+ { TYREAL,TYREAL,1,"r_tan", 6 },
+ { TYDREAL,TYDREAL,1,"d_tan", 6 },
+
+ { TYREAL,TYREAL,1,"r_asin", 7 },
+ { TYDREAL,TYDREAL,1,"d_asin", 7 },
+
+ { TYREAL,TYREAL,1,"r_acos", 8 },
+ { TYDREAL,TYDREAL,1,"d_acos", 8 },
+
+ { TYREAL,TYREAL,1,"r_atan", 9 },
+ { TYDREAL,TYDREAL,1,"d_atan", 9 },
+
+ { TYREAL,TYREAL,2,"r_atn2", 10 },
+ { TYDREAL,TYDREAL,2,"d_atn2", 10 },
+
+ { TYREAL,TYREAL,1,"r_sinh", 11 },
+ { TYDREAL,TYDREAL,1,"d_sinh", 11 },
+
+ { TYREAL,TYREAL,1,"r_cosh", 12 },
+ { TYDREAL,TYDREAL,1,"d_cosh", 12 },
+
+ { TYREAL,TYREAL,1,"r_tanh", 13 },
+ { TYDREAL,TYDREAL,1,"d_tanh", 13 },
+
+ { TYCHAR,TYLOGICAL,2,"hl_ge" },
+ { TYCHAR,TYLOGICAL,2,"l_ge" },
+
+ { TYCHAR,TYLOGICAL,2,"hl_gt" },
+ { TYCHAR,TYLOGICAL,2,"l_gt" },
+
+ { TYCHAR,TYLOGICAL,2,"hl_le" },
+ { TYCHAR,TYLOGICAL,2,"l_le" },
+
+ { TYCHAR,TYLOGICAL,2,"hl_lt" },
+ { TYCHAR,TYLOGICAL,2,"l_lt" },
+
+ { TYREAL,TYSHORT,1,"hr_expn" },
+ { TYREAL,TYLONG,1,"ir_expn" },
+ { TYDREAL,TYSHORT,1,"hd_expn" },
+ { TYDREAL,TYLONG,1,"id_expn" },
+
+ { TYREAL,TYREAL,1,"r_absp" },
+ { TYDREAL,TYDREAL,1,"d_absp" },
+
+ { TYREAL,TYDREAL,1,"r_rrsp" },
+ { TYDREAL,TYDREAL,1,"d_rrsp" },
+
+ { TYREAL,TYREAL,1,"r_frac" },
+ { TYDREAL,TYDREAL,1,"d_frac" },
+
+ { TYREAL,TYREAL,2,"r_make" },
+ { TYDREAL,TYDREAL,2,"d_make" },
+
+ { TYREAL,TYREAL,2,"r_scal" },
+ { TYDREAL,TYDREAL,2,"d_scal" },
+ { 0 }
+} ;
+
+#if 0
+LOCAL struct Incstblock
+ {
+ char atype;
+ char rtype;
+ char constno;
+ } consttab[ ] =
+{
+ { TYSHORT, TYLONG, 0 },
+ { TYLONG, TYLONG, 1 },
+ { TYREAL, TYLONG, 2 },
+ { TYDREAL, TYLONG, 3 },
+
+ { TYSHORT, TYLONG, 4 },
+ { TYLONG, TYLONG, 5 },
+ { TYREAL, TYLONG, 6 },
+ { TYDREAL, TYLONG, 7 },
+
+ { TYREAL, TYLONG, 8 },
+ { TYDREAL, TYLONG, 9 },
+
+ { TYREAL, TYLONG, 10 },
+ { TYDREAL, TYLONG, 11 },
+
+ { TYREAL, TYREAL, 0 },
+ { TYDREAL, TYDREAL, 1 },
+
+ { TYSHORT, TYLONG, 12 },
+ { TYLONG, TYLONG, 13 },
+ { TYREAL, TYREAL, 2 },
+ { TYDREAL, TYDREAL, 3 },
+
+ { TYREAL, TYREAL, 4 },
+ { TYDREAL, TYDREAL, 5 }
+};
+#endif
+
+char *callbyvalue[ ] =
+ {0,
+ "sqrt",
+ "exp",
+ "log",
+ "sin",
+ "cos",
+ "tan",
+ "asin",
+ "acos",
+ "atan",
+ "atan2",
+ "sinh",
+ "cosh",
+ "tanh"
+ };
+
+ void
+r8fix() /* adjust tables for -r8 */
+{
+ register struct Intrblock *I;
+ register struct Specblock *S;
+
+ for(I = intrtab; I->intrfname[0]; I++)
+ if (I->intrval.intrgroup != INTRGEN)
+ switch(I->intrval.intrstuff) {
+ case TYREAL:
+ I->intrval.intrstuff = TYDREAL;
+ I->intrval.intrno = I->intrval.dblintrno;
+ break;
+ case TYCOMPLEX:
+ I->intrval.intrstuff = TYDCOMPLEX;
+ I->intrval.intrno = I->intrval.dblintrno;
+ I->intrval.dblcmplx = 1;
+ }
+
+ for(S = spectab; S->atype; S++)
+ switch(S->atype) {
+ case TYCOMPLEX:
+ S->atype = TYDCOMPLEX;
+ if (S->rtype == TYREAL)
+ S->rtype = TYDREAL;
+ else if (S->rtype == TYCOMPLEX)
+ S->rtype = TYDCOMPLEX;
+ switch(S->spxname[0]) {
+ case 'r':
+ S->spxname[0] = 'd';
+ break;
+ case 'c':
+ S->spxname[0] = 'z';
+ break;
+ default:
+ Fatal("r8fix bug");
+ }
+ break;
+ case TYREAL:
+ S->atype = TYDREAL;
+ switch(S->rtype) {
+ case TYREAL:
+ S->rtype = TYDREAL;
+ if (S->spxname[0] != 'r')
+ Fatal("r8fix bug");
+ S->spxname[0] = 'd';
+ case TYDREAL: /* d_prod */
+ break;
+
+ case TYSHORT:
+ if (!strcmp(S->spxname, "hr_expn"))
+ S->spxname[1] = 'd';
+ else if (!strcmp(S->spxname, "h_nint"))
+ strcpy(S->spxname, "h_dnnt");
+ else Fatal("r8fix bug");
+ break;
+
+ case TYLONG:
+ if (!strcmp(S->spxname, "ir_expn"))
+ S->spxname[1] = 'd';
+ else if (!strcmp(S->spxname, "i_nint"))
+ strcpy(S->spxname, "i_dnnt");
+ else Fatal("r8fix bug");
+ break;
+
+ default:
+ Fatal("r8fix bug");
+ }
+ }
+ }
+
+expptr intrcall(np, argsp, nargs)
+Namep np;
+struct Listblock *argsp;
+int nargs;
+{
+ int i, rettype;
+ Addrp ap;
+ register struct Specblock *sp;
+ register struct Chain *cp;
+ expptr Inline(), mkcxcon(), mkrealcon();
+ expptr q, ep;
+ int mtype;
+ int op;
+ int f1field, f2field, f3field;
+
+ packed.ijunk = np->vardesc.varno;
+ f1field = packed.bits.f1;
+ f2field = packed.bits.f2;
+ f3field = packed.bits.f3;
+ if(nargs == 0)
+ goto badnargs;
+
+ mtype = 0;
+ for(cp = argsp->listp ; cp ; cp = cp->nextp)
+ {
+ ep = (expptr)cp->datap;
+ if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
+ cp->datap = (char *) mkconv(tyint, ep);
+ mtype = maxtype(mtype, ep->headblock.vtype);
+ }
+
+ switch(f1field)
+ {
+ case INTRBOOL:
+ op = f3field;
+ if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
+ goto badtype;
+ if(op == OPBITNOT)
+ {
+ if(nargs != 1)
+ goto badnargs;
+ q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
+ }
+ else
+ {
+ if(nargs != 2)
+ goto badnargs;
+ q = mkexpr(op, (expptr)argsp->listp->datap,
+ (expptr)argsp->listp->nextp->datap);
+ }
+ frchain( &(argsp->listp) );
+ free( (charptr) argsp);
+ return(q);
+
+ case INTRCONV:
+ rettype = f2field;
+ if(rettype == TYLONG)
+ rettype = tyint;
+ if( ISCOMPLEX(rettype) && nargs==2)
+ {
+ expptr qr, qi;
+ qr = (expptr) argsp->listp->datap;
+ qi = (expptr) argsp->listp->nextp->datap;
+ if(ISCONST(qr) && ISCONST(qi))
+ q = mkcxcon(qr,qi);
+ else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
+ mkconv(rettype-2,qi));
+ }
+ else if(nargs == 1) {
+ if (f3field && ((Exprp)argsp->listp->datap)->vtype
+ == TYDCOMPLEX)
+ rettype = TYDREAL;
+ q = mkconv(rettype, (expptr)argsp->listp->datap);
+ }
+ else goto badnargs;
+
+ q->headblock.vtype = rettype;
+ frchain(&(argsp->listp));
+ free( (charptr) argsp);
+ return(q);
+
+
+#if 0
+ case INTRCNST:
+
+/* Machine-dependent f77 stuff that f2c omits:
+
+intcon contains
+ radix for short int
+ radix for long int
+ radix for single precision
+ radix for double precision
+ precision for short int
+ precision for long int
+ precision for single precision
+ precision for double precision
+ emin for single precision
+ emin for double precision
+ emax for single precision
+ emax for double prcision
+ largest short int
+ largest long int
+
+realcon contains
+ tiny for single precision
+ tiny for double precision
+ huge for single precision
+ huge for double precision
+ mrsp (epsilon) for single precision
+ mrsp (epsilon) for double precision
+*/
+ { register struct Incstblock *cstp;
+ extern ftnint intcon[14];
+ extern double realcon[6];
+
+ cstp = consttab + f3field;
+ for(i=0 ; i<f2field ; ++i)
+ if(cstp->atype == mtype)
+ goto foundconst;
+ else
+ ++cstp;
+ goto badtype;
+
+foundconst:
+ switch(cstp->rtype)
+ {
+ case TYLONG:
+ return(mkintcon(intcon[cstp->constno]));
+
+ case TYREAL:
+ case TYDREAL:
+ return(mkrealcon(cstp->rtype,
+ realcon[cstp->constno]) );
+
+ default:
+ Fatal("impossible intrinsic constant");
+ }
+ }
+#endif
+
+ case INTRGEN:
+ sp = spectab + f3field;
+ if(no66flag)
+ if(sp->atype == mtype)
+ goto specfunct;
+ else err66("generic function");
+
+ for(i=0; i<f2field ; ++i)
+ if(sp->atype == mtype)
+ goto specfunct;
+ else
+ ++sp;
+ warn1 ("bad argument type to intrinsic %s", np->fvarname);
+
+/* Made this a warning rather than an error so things like "log (5) ==>
+ log (5.0)" can be accommodated. When none of these cases matches, the
+ argument is cast up to the first type in the spectab list; this first
+ type is assumed to be the "smallest" type, e.g. REAL before DREAL
+ before COMPLEX, before DCOMPLEX */
+
+ sp = spectab + f3field;
+ mtype = sp -> atype;
+ goto specfunct;
+
+ case INTRSPEC:
+ sp = spectab + f3field;
+specfunct:
+ if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
+ && (sp+1)->atype==sp->atype)
+ ++sp;
+
+ if(nargs != sp->nargs)
+ goto badnargs;
+ if(mtype != sp->atype)
+ goto badtype;
+
+/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
+ the inline expression wouldn't get put into the constant table */
+
+ fixargs (NO, argsp);
+ cast_args (mtype, argsp -> listp);
+
+ if(q = Inline(sp-spectab, mtype, argsp->listp))
+ {
+ frchain( &(argsp->listp) );
+ free( (charptr) argsp);
+ } else {
+
+ if(sp->othername) {
+ /* C library routines that return double... */
+ /* sp->rtype might be TYREAL */
+ ap = builtin(sp->rtype,
+ callbyvalue[sp->othername], 1);
+ q = fixexpr((Exprp)
+ mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
+ } else {
+ fixargs(YES, argsp);
+ ap = builtin(sp->rtype, sp->spxname, 0);
+ q = fixexpr((Exprp)
+ mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
+ } /* else */
+ } /* else */
+ return(q);
+
+ case INTRMIN:
+ case INTRMAX:
+ if(nargs < 2)
+ goto badnargs;
+ if( ! ONEOF(mtype, MSKINT|MSKREAL) )
+ goto badtype;
+ argsp->vtype = mtype;
+ q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
+
+ q->headblock.vtype = mtype;
+ rettype = f2field;
+ if(rettype == TYLONG)
+ rettype = tyint;
+ else if(rettype == TYUNKNOWN)
+ rettype = mtype;
+ return( mkconv(rettype, q) );
+
+ default:
+ fatali("intrcall: bad intrgroup %d", f1field);
+ }
+badnargs:
+ errstr("bad number of arguments to intrinsic %s", np->fvarname);
+ goto bad;
+
+badtype:
+ errstr("bad argument type to intrinsic %s", np->fvarname);
+
+bad:
+ return( errnode() );
+}
+
+
+
+
+intrfunct(s)
+char *s;
+{
+ register struct Intrblock *p;
+
+ for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
+ {
+ if( !strcmp(s, p->intrfname) )
+ {
+ packed.bits.f1 = p->intrval.intrgroup;
+ packed.bits.f2 = p->intrval.intrstuff;
+ packed.bits.f3 = p->intrval.intrno;
+ packed.bits.f4 = p->intrval.dblcmplx;
+ return(packed.ijunk);
+ }
+ }
+
+ return(0);
+}
+
+
+
+
+
+Addrp intraddr(np)
+Namep np;
+{
+ Addrp q;
+ register struct Specblock *sp;
+ int f3field;
+
+ if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
+ fatalstr("intraddr: %s is not intrinsic", np->fvarname);
+ packed.ijunk = np->vardesc.varno;
+ f3field = packed.bits.f3;
+
+ switch(packed.bits.f1)
+ {
+ case INTRGEN:
+ /* imag, log, and log10 arent specific functions */
+ if(f3field==31 || f3field==43 || f3field==47)
+ goto bad;
+
+ case INTRSPEC:
+ sp = spectab + f3field;
+ if(tyint==TYLONG && sp->rtype==TYSHORT)
+ ++sp;
+ q = builtin(sp->rtype, sp->spxname,
+ sp->othername ? 1 : 0);
+ return(q);
+
+ case INTRCONV:
+ case INTRMIN:
+ case INTRMAX:
+ case INTRBOOL:
+ case INTRCNST:
+bad:
+ errstr("cannot pass %s as actual", np->fvarname);
+ return((Addrp)errnode());
+ }
+ fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
+ /* NOT REACHED */ return 0;
+}
+
+
+
+void cast_args (maxtype, args)
+int maxtype;
+chainp args;
+{
+ for (; args; args = args -> nextp) {
+ expptr e = (expptr) args->datap;
+ if (e -> headblock.vtype != maxtype)
+ if (e -> tag == TCONST)
+ args->datap = (char *) mkconv(maxtype, e);
+ else {
+ Addrp temp = Mktemp(maxtype, ENULL);
+
+ puteq(cpexpr((expptr)temp), e);
+ args->datap = (char *)temp;
+ } /* else */
+ } /* for */
+} /* cast_args */
+
+
+
+expptr Inline(fno, type, args)
+int fno;
+int type;
+struct Chain *args;
+{
+ register expptr q, t, t1;
+
+ switch(fno)
+ {
+ case 8: /* real abs */
+ case 9: /* short int abs */
+ case 10: /* long int abs */
+ case 11: /* double precision abs */
+ if( addressable(q = (expptr) args->datap) )
+ {
+ t = q;
+ q = NULL;
+ }
+ else
+ t = (expptr) Mktemp(type,ENULL);
+ t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
+ cpexpr(t), ENULL);
+ if(q)
+ t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
+ frexpr(t);
+ return(t1);
+
+ case 26: /* dprod */
+ q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
+ (expptr)args->nextp->datap);
+ return(q);
+
+ case 27: /* len of character string */
+ q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
+ frexpr((expptr)args->datap);
+ return(q);
+
+ case 14: /* half-integer mod */
+ case 15: /* mod */
+ return mkexpr(OPMOD, (expptr) args->datap,
+ (expptr) args->nextp->datap);
+ }
+ return(NULL);
+}
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Routines to generate code for I/O statements.
+ Some corrections and improvements due to David Wasley, U. C. Berkeley
+*/
+
+/* TEMPORARY */
+#define TYIOINT TYLONG
+#define SZIOINT SZLONG
+
+#include "defs.h"
+#include "names.h"
+#include "iob.h"
+
+extern int inqmask;
+
+LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
+ doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
+ putio(), putiocall();
+
+iob_data *iob_list;
+Addrp io_structs[9];
+
+LOCAL char ioroutine[12];
+
+LOCAL long ioendlab;
+LOCAL long ioerrlab;
+LOCAL int endbit;
+LOCAL int errbit;
+LOCAL long jumplab;
+LOCAL long skiplab;
+LOCAL int ioformatted;
+LOCAL int statstruct = NO;
+LOCAL struct Labelblock *skiplabel;
+Addrp ioblkp;
+
+#define UNFORMATTED 0
+#define FORMATTED 1
+#define LISTDIRECTED 2
+#define NAMEDIRECTED 3
+
+#define V(z) ioc[z].iocval
+
+#define IOALL 07777
+
+LOCAL struct Ioclist
+{
+ char *iocname;
+ int iotype;
+ expptr iocval;
+}
+ioc[ ] =
+{
+ { "", 0 },
+ { "unit", IOALL },
+ { "fmt", M(IOREAD) | M(IOWRITE) },
+ { "err", IOALL },
+ { "end", M(IOREAD) },
+ { "iostat", IOALL },
+ { "rec", M(IOREAD) | M(IOWRITE) },
+ { "recl", M(IOOPEN) | M(IOINQUIRE) },
+ { "file", M(IOOPEN) | M(IOINQUIRE) },
+ { "status", M(IOOPEN) | M(IOCLOSE) },
+ { "access", M(IOOPEN) | M(IOINQUIRE) },
+ { "form", M(IOOPEN) | M(IOINQUIRE) },
+ { "blank", M(IOOPEN) | M(IOINQUIRE) },
+ { "exist", M(IOINQUIRE) },
+ { "opened", M(IOINQUIRE) },
+ { "number", M(IOINQUIRE) },
+ { "named", M(IOINQUIRE) },
+ { "name", M(IOINQUIRE) },
+ { "sequential", M(IOINQUIRE) },
+ { "direct", M(IOINQUIRE) },
+ { "formatted", M(IOINQUIRE) },
+ { "unformatted", M(IOINQUIRE) },
+ { "nextrec", M(IOINQUIRE) }
+};
+
+#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
+#define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR
+
+/* #define IOSUNIT 1 */
+/* #define IOSFMT 2 */
+#define IOSERR 3
+#define IOSEND 4
+#define IOSIOSTAT 5
+#define IOSREC 6
+#define IOSRECL 7
+#define IOSFILE 8
+#define IOSSTATUS 9
+#define IOSACCESS 10
+#define IOSFORM 11
+#define IOSBLANK 12
+#define IOSEXISTS 13
+#define IOSOPENED 14
+#define IOSNUMBER 15
+#define IOSNAMED 16
+#define IOSNAME 17
+#define IOSSEQUENTIAL 18
+#define IOSDIRECT 19
+#define IOSFORMATTED 20
+#define IOSUNFORMATTED 21
+#define IOSNEXTREC 22
+
+#define IOSTP V(IOSIOSTAT)
+
+
+/* offsets in generated structures */
+
+#define SZFLAG SZIOINT
+
+/* offsets for external READ and WRITE statements */
+
+#define XERR 0
+#define XUNIT SZFLAG
+#define XEND SZFLAG + SZIOINT
+#define XFMT 2*SZFLAG + SZIOINT
+#define XREC 2*SZFLAG + SZIOINT + SZADDR
+#define XRLEN 2*SZFLAG + 2*SZADDR
+#define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
+
+/* offsets for internal READ and WRITE statements */
+
+#define XIERR 0
+#define XIUNIT SZFLAG
+#define XIEND SZFLAG + SZADDR
+#define XIFMT 2*SZFLAG + SZADDR
+#define XIRLEN 2*SZFLAG + 2*SZADDR
+#define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
+#define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT
+
+/* offsets for OPEN statements */
+
+#define XFNAME SZFLAG + SZIOINT
+#define XFNAMELEN SZFLAG + SZIOINT + SZADDR
+#define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
+#define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
+
+/* offset for CLOSE statement */
+
+#define XCLSTATUS SZFLAG + SZIOINT
+
+/* offsets for INQUIRE statement */
+
+#define XFILE SZFLAG + SZIOINT
+#define XFILELEN SZFLAG + SZIOINT + SZADDR
+#define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
+#define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR
+#define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR
+#define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR
+#define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR
+#define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR
+#define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
+#define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
+#define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
+#define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR
+#define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR
+#define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
+#define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR
+#define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
+#define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR
+#define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
+#define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR
+#define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
+#define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR
+
+LOCAL char *cilist_names[] = {
+ "cilist",
+ "cierr",
+ "ciunit",
+ "ciend",
+ "cifmt",
+ "cirec"
+ };
+LOCAL char *icilist_names[] = {
+ "icilist",
+ "icierr",
+ "iciunit",
+ "iciend",
+ "icifmt",
+ "icirlen",
+ "icirnum"
+ };
+LOCAL char *olist_names[] = {
+ "olist",
+ "oerr",
+ "ounit",
+ "ofnm",
+ "ofnmlen",
+ "osta",
+ "oacc",
+ "ofm",
+ "orl",
+ "oblnk"
+ };
+LOCAL char *cllist_names[] = {
+ "cllist",
+ "cerr",
+ "cunit",
+ "csta"
+ };
+LOCAL char *alist_names[] = {
+ "alist",
+ "aerr",
+ "aunit"
+ };
+LOCAL char *inlist_names[] = {
+ "inlist",
+ "inerr",
+ "inunit",
+ "infile",
+ "infilen",
+ "inex",
+ "inopen",
+ "innum",
+ "innamed",
+ "inname",
+ "innamlen",
+ "inacc",
+ "inacclen",
+ "inseq",
+ "inseqlen",
+ "indir",
+ "indirlen",
+ "infmt",
+ "infmtlen",
+ "inform",
+ "informlen",
+ "inunf",
+ "inunflen",
+ "inrecl",
+ "innrec",
+ "inblank",
+ "inblanklen"
+ };
+
+LOCAL char **io_fields;
+
+#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
+
+LOCAL io_setup io_stuff[] = {
+ zork(cilist_names, TYCILIST), /* external read/write */
+ zork(inlist_names, TYINLIST), /* inquire */
+ zork(olist_names, TYOLIST), /* open */
+ zork(cllist_names, TYCLLIST), /* close */
+ zork(alist_names, TYALIST), /* rewind */
+ zork(alist_names, TYALIST), /* backspace */
+ zork(alist_names, TYALIST), /* endfile */
+ zork(icilist_names,TYICILIST), /* internal read */
+ zork(icilist_names,TYICILIST) /* internal write */
+ };
+
+#undef zork
+
+
+fmtstmt(lp)
+register struct Labelblock *lp;
+{
+ if(lp == NULL)
+ {
+ execerr("unlabeled format statement" , CNULL);
+ return(-1);
+ }
+ if(lp->labtype == LABUNKNOWN)
+ {
+ lp->labtype = LABFORMAT;
+ lp->labelno = newlabel();
+ }
+ else if(lp->labtype != LABFORMAT)
+ {
+ execerr("bad format number", CNULL);
+ return(-1);
+ }
+ return(lp->labelno);
+}
+
+
+setfmt(lp)
+struct Labelblock *lp;
+{
+ int n;
+ char *s0, *lexline();
+ register char *s, *se, *t;
+ register k;
+
+ s0 = s = lexline(&n);
+ se = t = s + n;
+
+ /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */
+ /* following FORMAT... */
+
+ if (n <= 0)
+ warn("No (...) after FORMAT");
+ else if (*s != '(')
+ warni("%c rather than ( after FORMAT", *s);
+ else if (se[-1] != ')') {
+ *se = 0;
+ while(--t > s && *t != ')') ;
+ if (t <= s)
+ warn("No ) at end of FORMAT statement");
+ else if (se - t > 30)
+ warn1("Extraneous text at end of FORMAT: ...%s", se-12);
+ else
+ warn1("Extraneous text at end of FORMAT: %s", t+1);
+ t = se;
+ }
+
+ /* fix MYQUOTES (\002's) and \\'s */
+
+ while(s < se)
+ switch(*s++) {
+ case 2:
+ t += 3; break;
+ case '"':
+ case '\\':
+ t++; break;
+ }
+ s = s0;
+ lp->fmtstring = t = mem(t - s + 1, 0);
+ while(s < se)
+ switch(k = *s++) {
+ case 2:
+ t[0] = '\\';
+ t[1] = '0';
+ t[2] = '0';
+ t[3] = '2';
+ t += 4;
+ break;
+ case '"':
+ case '\\':
+ *t++ = '\\';
+ /* no break */
+ default:
+ *t++ = k;
+ }
+ *t = 0;
+ flline();
+}
+
+
+
+startioctl()
+{
+ register int i;
+
+ inioctl = YES;
+ nioctl = 0;
+ ioformatted = UNFORMATTED;
+ for(i = 1 ; i<=NIOS ; ++i)
+ V(i) = NULL;
+}
+
+ static long
+newiolabel() {
+ long rv;
+ rv = ++lastiolabno;
+ skiplabel = mklabel(rv);
+ skiplabel->labdefined = 1;
+ return rv;
+ }
+
+
+endioctl()
+{
+ int i;
+ expptr p;
+ struct io_setup *ios;
+
+ inioctl = NO;
+
+ /* set up for error recovery */
+
+ ioerrlab = ioendlab = skiplab = jumplab = 0;
+
+ if(p = V(IOSEND))
+ if(ISICON(p))
+ execlab(ioendlab = p->constblock.Const.ci);
+ else
+ err("bad end= clause");
+
+ if(p = V(IOSERR))
+ if(ISICON(p))
+ execlab(ioerrlab = p->constblock.Const.ci);
+ else
+ err("bad err= clause");
+
+ if(IOSTP)
+ if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
+ {
+ err("iostat must be an integer variable");
+ frexpr(IOSTP);
+ IOSTP = NULL;
+ }
+
+ if(iostmt == IOREAD)
+ {
+ if(IOSTP)
+ {
+ if(ioerrlab && ioendlab && ioerrlab==ioendlab)
+ jumplab = ioerrlab;
+ else
+ skiplab = jumplab = newiolabel();
+ }
+ else {
+ if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
+ {
+ IOSTP = (expptr) Mktemp(TYINT, ENULL);
+ skiplab = jumplab = newiolabel();
+ }
+ else
+ jumplab = (ioerrlab ? ioerrlab : ioendlab);
+ }
+ }
+ else if(iostmt == IOWRITE)
+ {
+ if(IOSTP && !ioerrlab)
+ skiplab = jumplab = newiolabel();
+ else
+ jumplab = ioerrlab;
+ }
+ else
+ jumplab = ioerrlab;
+
+ endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */
+ errbit = IOSTP!=NULL || ioerrlab!=0;
+ if (jumplab && !IOSTP)
+ IOSTP = (expptr) Mktemp(TYINT, ENULL);
+
+ if(iostmt!=IOREAD && iostmt!=IOWRITE)
+ {
+ ios = io_stuff + iostmt;
+ io_fields = ios->fields;
+ ioblkp = io_structs[iostmt];
+ if(ioblkp == NULL)
+ io_structs[iostmt] = ioblkp =
+ autovar(1, ios->type, ENULL, "");
+ ioset(TYIOINT, XERR, ICON(errbit));
+ }
+
+ switch(iostmt)
+ {
+ case IOOPEN:
+ dofopen();
+ break;
+
+ case IOCLOSE:
+ dofclose();
+ break;
+
+ case IOINQUIRE:
+ dofinquire();
+ break;
+
+ case IOBACKSPACE:
+ dofmove("f_back");
+ break;
+
+ case IOREWIND:
+ dofmove("f_rew");
+ break;
+
+ case IOENDFILE:
+ dofmove("f_end");
+ break;
+
+ case IOREAD:
+ case IOWRITE:
+ startrw();
+ break;
+
+ default:
+ fatali("impossible iostmt %d", iostmt);
+ }
+ for(i = 1 ; i<=NIOS ; ++i)
+ if(i!=IOSIOSTAT && V(i)!=NULL)
+ frexpr(V(i));
+}
+
+
+
+iocname()
+{
+ register int i;
+ int found, mask;
+
+ found = 0;
+ mask = M(iostmt);
+ for(i = 1 ; i <= NIOS ; ++i)
+ if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
+ if(ioc[i].iotype & mask)
+ return(i);
+ else found = i;
+ if(found)
+ errstr("invalid control %s for statement", ioc[found].iocname);
+ else
+ errstr("unknown iocontrol %s", token);
+ return(IOSBAD);
+}
+
+
+ioclause(n, p)
+register int n;
+register expptr p;
+{
+ struct Ioclist *iocp;
+
+ ++nioctl;
+ if(n == IOSBAD)
+ return;
+ if(n == IOSPOSITIONAL)
+ {
+ n = nioctl;
+ if (nioctl == IOSFMT) {
+ if (iostmt == IOOPEN) {
+ n = IOSFILE;
+ NOEXT("file= specifier omitted from open");
+ }
+ else if (iostmt < IOREAD)
+ goto illegal;
+ }
+ else if(nioctl > IOSFMT)
+ {
+ illegal:
+ err("illegal positional iocontrol");
+ return;
+ }
+ }
+
+ if(p == NULL)
+ {
+ if(n == IOSUNIT)
+ p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
+ else if(n != IOSFMT)
+ {
+ err("illegal * iocontrol");
+ return;
+ }
+ }
+ if(n == IOSFMT)
+ ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
+
+ iocp = & ioc[n];
+ if(iocp->iocval == NULL)
+ {
+ if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) )
+ p = fixtype(p);
+ iocp->iocval = p;
+ }
+ else
+ errstr("iocontrol %s repeated", iocp->iocname);
+}
+
+/* io list item */
+
+doio(list)
+chainp list;
+{
+ expptr call0();
+
+ if(ioformatted == NAMEDIRECTED)
+ {
+ if(list)
+ err("no I/O list allowed in NAMELIST read/write");
+ }
+ else
+ {
+ doiolist(list);
+ ioroutine[0] = 'e';
+ jumplab = 0;
+ putiocall( call0(TYINT, ioroutine) );
+ }
+}
+
+
+
+
+
+ LOCAL void
+doiolist(p0)
+ chainp p0;
+{
+ chainp p;
+ register tagptr q;
+ register expptr qe;
+ register Namep qn;
+ Addrp tp, mkscalar();
+ int range;
+
+ for (p = p0 ; p ; p = p->nextp)
+ {
+ q = (tagptr)p->datap;
+ if(q->tag == TIMPLDO)
+ {
+ exdo(range=newlabel(), (Namep)0,
+ q->impldoblock.impdospec);
+ doiolist(q->impldoblock.datalist);
+ enddo(range);
+ free( (charptr) q);
+ }
+ else {
+ if(q->tag==TPRIM && q->primblock.argsp==NULL
+ && q->primblock.namep->vdim!=NULL)
+ {
+ vardcl(qn = q->primblock.namep);
+ if(qn->vdim->nelt) {
+ putio( fixtype(cpexpr(qn->vdim->nelt)),
+ (expptr)mkscalar(qn) );
+ qn->vlastdim = 0;
+ }
+ else
+ err("attempt to i/o array of unknown size");
+ }
+ else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
+ (qe = (expptr) memversion(q->primblock.namep)) )
+ putio(ICON(1),qe);
+ else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
+ (qe->addrblock.uname_tag != UNAM_CONST ||
+ !ISCOMPLEX(qe -> addrblock.vtype))) ||
+ (qe -> tag == TCONST && !ISCOMPLEX(qe ->
+ headblock.vtype))) {
+ if (qe -> tag == TCONST)
+ qe = (expptr) putconst((Constp)qe);
+ putio(ICON(1), qe);
+ }
+ else if(qe->headblock.vtype != TYERROR)
+ {
+ if(iostmt == IOWRITE)
+ {
+ ftnint lencat();
+ expptr qvl;
+ qvl = NULL;
+ if( ISCHAR(qe) )
+ {
+ qvl = (expptr)
+ cpexpr(qe->headblock.vleng);
+ tp = Mktemp(qe->headblock.vtype,
+ ICON(lencat(qe)));
+ }
+ else
+ tp = Mktemp(qe->headblock.vtype,
+ qe->headblock.vleng);
+ puteq( cpexpr((expptr)tp), qe);
+ if(qvl) /* put right length on block */
+ {
+ frexpr(tp->vleng);
+ tp->vleng = qvl;
+ }
+ putio(ICON(1), (expptr)tp);
+ }
+ else
+ err("non-left side in READ list");
+ }
+ frexpr(q);
+ }
+ }
+ frchain( &p0 );
+}
+
+ int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */
+
+ LOCAL void
+putio(nelt, addr)
+ expptr nelt;
+ register expptr addr;
+{
+ int type;
+ register expptr q;
+ extern Constp mkconst();
+ register Addrp c = 0;
+
+ type = addr->headblock.vtype;
+ if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
+ {
+ nelt = mkexpr(OPSTAR, ICON(2), nelt);
+ type -= (TYCOMPLEX-TYREAL);
+ }
+
+ /* pass a length with every item. for noncharacter data, fake one */
+ if(type != TYCHAR)
+ {
+
+ if( ISCONST(addr) )
+ addr = (expptr) putconst((Constp)addr);
+ c = ALLOC(Addrblock);
+ c->tag = TADDR;
+ c->vtype = TYLENG;
+ c->vstg = STGAUTO;
+ c->ntempelt = 1;
+ c->isarray = 1;
+ c->memoffset = ICON(0);
+ c->uname_tag = UNAM_IDENT;
+ c->charleng = 1;
+ sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
+ addr = mkexpr(OPCHARCAST, addr, ENULL);
+ }
+
+ nelt = fixtype( mkconv(TYLENG,nelt) );
+ if(ioformatted == LISTDIRECTED) {
+ expptr mc = mkconv(TYLONG, ICON(type));
+ q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
+ : call3(TYINT, "do_lio", mc, nelt, addr);
+ }
+ else {
+ char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
+ q = c ? call3(TYINT, s, nelt, addr, (expptr)c)
+ : call2(TYINT, s, nelt, addr);
+ }
+ iocalladdr = TYCHAR;
+ putiocall(q);
+ iocalladdr = TYADDR;
+}
+
+
+
+
+endio()
+{
+ extern void p1_label();
+
+ if(skiplab)
+ {
+ p1_label((long)(skiplabel - labeltab));
+ if(ioendlab) {
+ exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
+ exgoto(execlab(ioendlab));
+ exendif();
+ }
+ if(ioerrlab) {
+ exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
+ ? OPGT : OPNE,
+ cpexpr(IOSTP), ICON(0)));
+ exgoto(execlab(ioerrlab));
+ exendif();
+ }
+ }
+
+ if(IOSTP)
+ frexpr(IOSTP);
+}
+
+
+
+ LOCAL void
+putiocall(q)
+ register expptr q;
+{
+ int tyintsave;
+
+ tyintsave = tyint;
+ tyint = tyioint; /* for -I2 and -i2 */
+
+ if(IOSTP)
+ {
+ q->headblock.vtype = TYINT;
+ q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
+ }
+ putexpr(q);
+ if(jumplab) {
+ exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
+ exgoto(execlab(jumplab));
+ exendif();
+ }
+ tyint = tyintsave;
+}
+
+ void
+fmtname(np, q)
+ Namep np;
+ register Addrp q;
+{
+ register int k;
+ register char *s, *t;
+ extern chainp assigned_fmts;
+
+ if (!np->vfmt_asg) {
+ np->vfmt_asg = 1;
+ assigned_fmts = mkchain((char *)np, assigned_fmts);
+ }
+ k = strlen(s = np->fvarname);
+ if (k < IDENT_LEN - 4) {
+ q->uname_tag = UNAM_IDENT;
+ t = q->user.ident;
+ }
+ else {
+ q->uname_tag = UNAM_CHARP;
+ q->user.Charp = t = mem(k + 5,0);
+ }
+ sprintf(t, "%s_fmt", s);
+ }
+
+LOCAL Addrp asg_addr(p)
+ union Expression *p;
+{
+ register Addrp q;
+
+ if (p->tag != TPRIM)
+ badtag("asg_addr", p->tag);
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ q->vtype = TYCHAR;
+ q->vstg = STGAUTO;
+ q->ntempelt = 1;
+ q->isarray = 0;
+ q->memoffset = ICON(0);
+ fmtname(p->primblock.namep, q);
+ return q;
+ }
+
+startrw()
+{
+ register expptr p;
+ register Namep np;
+ register Addrp unitp, fmtp, recp;
+ register expptr nump;
+ Addrp mkscalar();
+ expptr mkaddcon();
+ int iostmt1;
+ flag intfile, sequential, ok, varfmt;
+ struct io_setup *ios;
+
+ /* First look at all the parameters and determine what is to be done */
+
+ ok = YES;
+ statstruct = YES;
+
+ intfile = NO;
+ if(p = V(IOSUNIT))
+ {
+ if( ISINT(p->headblock.vtype) )
+ unitp = (Addrp) cpexpr(p);
+ else if(p->headblock.vtype == TYCHAR)
+ {
+ intfile = YES;
+ if(p->tag==TPRIM && p->primblock.argsp==NULL &&
+ (np = p->primblock.namep)->vdim!=NULL)
+ {
+ vardcl(np);
+ if(np->vdim->nelt)
+ {
+ nump = (expptr) cpexpr(np->vdim->nelt);
+ if( ! ISCONST(nump) )
+ statstruct = NO;
+ }
+ else
+ {
+ err("attempt to use internal unit array of unknown size");
+ ok = NO;
+ nump = ICON(1);
+ }
+ unitp = mkscalar(np);
+ }
+ else {
+ nump = ICON(1);
+ unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
+ }
+ if(! isstatic((expptr)unitp) )
+ statstruct = NO;
+ }
+ }
+ else
+ {
+ err("bad unit specifier");
+ ok = NO;
+ }
+
+ sequential = YES;
+ if(p = V(IOSREC))
+ if( ISINT(p->headblock.vtype) )
+ {
+ recp = (Addrp) cpexpr(p);
+ sequential = NO;
+ }
+ else {
+ err("bad REC= clause");
+ ok = NO;
+ }
+ else
+ recp = NULL;
+
+
+ varfmt = YES;
+ fmtp = NULL;
+ if(p = V(IOSFMT))
+ {
+ if(p->tag==TPRIM && p->primblock.argsp==NULL)
+ {
+ np = p->primblock.namep;
+ if(np->vclass == CLNAMELIST)
+ {
+ ioformatted = NAMEDIRECTED;
+ fmtp = (Addrp) fixtype(p);
+ V(IOSFMT) = (expptr)fmtp;
+ goto endfmt;
+ }
+ vardcl(np);
+ if(np->vdim)
+ {
+ if( ! ONEOF(np->vstg, MSKSTATIC) )
+ statstruct = NO;
+ fmtp = mkscalar(np);
+ goto endfmt;
+ }
+ if( ISINT(np->vtype) ) /* ASSIGNed label */
+ {
+ statstruct = NO;
+ varfmt = YES;
+ fmtp = asg_addr(p);
+ goto endfmt;
+ }
+ }
+ p = V(IOSFMT) = fixtype(p);
+ if(p->headblock.vtype == TYCHAR
+ /* Since we allow write(6,n) */
+ /* we may as well allow write(6,n(2)) */
+ || p->tag == TADDR && ISINT(p->addrblock.vtype))
+ {
+ if( ! isstatic(p) )
+ statstruct = NO;
+ fmtp = (Addrp) cpexpr(p);
+ }
+ else if( ISICON(p) )
+ {
+ struct Labelblock *lp;
+ lp = mklabel(p->constblock.Const.ci);
+ if (fmtstmt(lp) > 0)
+ {
+ fmtp = (Addrp)mkaddcon(lp->stateno);
+ /* lp->stateno for names fmt_nnn */
+ lp->fmtlabused = 1;
+ varfmt = NO;
+ }
+ else
+ ioformatted = UNFORMATTED;
+ }
+ else {
+ err("bad format descriptor");
+ ioformatted = UNFORMATTED;
+ ok = NO;
+ }
+ }
+ else
+ fmtp = NULL;
+
+endfmt:
+ if(intfile) {
+ if (ioformatted==UNFORMATTED) {
+ err("unformatted internal I/O not allowed");
+ ok = NO;
+ }
+ if (recp) {
+ err("direct internal I/O not allowed");
+ ok = NO;
+ }
+ }
+ if(!sequential && ioformatted==LISTDIRECTED)
+ {
+ err("direct list-directed I/O not allowed");
+ ok = NO;
+ }
+ if(!sequential && ioformatted==NAMEDIRECTED)
+ {
+ err("direct namelist I/O not allowed");
+ ok = NO;
+ }
+
+ if( ! ok )
+ return;
+
+ /*
+ Now put out the I/O structure, statically if all the clauses
+ are constants, dynamically otherwise
+*/
+
+ if (intfile) {
+ ios = io_stuff + iostmt;
+ iostmt1 = IOREAD;
+ }
+ else {
+ ios = io_stuff;
+ iostmt1 = 0;
+ }
+ io_fields = ios->fields;
+ if(statstruct)
+ {
+ ioblkp = ALLOC(Addrblock);
+ ioblkp->tag = TADDR;
+ ioblkp->vtype = ios->type;
+ ioblkp->vclass = CLVAR;
+ ioblkp->vstg = STGINIT;
+ ioblkp->memno = ++lastvarno;
+ ioblkp->memoffset = ICON(0);
+ ioblkp -> uname_tag = UNAM_IDENT;
+ new_iob_data(ios,
+ temp_name("io_", lastvarno, ioblkp->user.ident)); }
+ else if(!(ioblkp = io_structs[iostmt1]))
+ io_structs[iostmt1] = ioblkp =
+ autovar(1, ios->type, ENULL, "");
+
+ ioset(TYIOINT, XERR, ICON(errbit));
+ if(iostmt == IOREAD)
+ ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
+
+ if(intfile)
+ {
+ ioset(TYIOINT, XIRNUM, nump);
+ ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
+ ioseta(XIUNIT, unitp);
+ }
+ else
+ ioset(TYIOINT, XUNIT, (expptr) unitp);
+
+ if(recp)
+ ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
+
+ if(varfmt)
+ ioseta( intfile ? XIFMT : XFMT , fmtp);
+ else
+ ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
+
+ ioroutine[0] = 's';
+ ioroutine[1] = '_';
+ ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
+ ioroutine[3] = "ds"[sequential];
+ ioroutine[4] = "ufln"[ioformatted];
+ ioroutine[5] = "ei"[intfile];
+ ioroutine[6] = '\0';
+
+ putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
+
+ if(statstruct)
+ {
+ frexpr((expptr)ioblkp);
+ statstruct = NO;
+ ioblkp = 0; /* unnecessary */
+ }
+}
+
+
+
+ LOCAL void
+dofopen()
+{
+ register expptr p;
+
+ if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+ ioset(TYIOINT, XUNIT, cpexpr(p) );
+ else
+ err("bad unit in open");
+ if( (p = V(IOSFILE)) )
+ if(p->headblock.vtype == TYCHAR)
+ ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
+ else
+ err("bad file in open");
+
+ iosetc(XFNAME, p);
+
+ if(p = V(IOSRECL))
+ if( ISINT(p->headblock.vtype) )
+ ioset(TYIOINT, XRECLEN, cpexpr(p) );
+ else
+ err("bad recl");
+ else
+ ioset(TYIOINT, XRECLEN, ICON(0) );
+
+ iosetc(XSTATUS, V(IOSSTATUS));
+ iosetc(XACCESS, V(IOSACCESS));
+ iosetc(XFORMATTED, V(IOSFORM));
+ iosetc(XBLANK, V(IOSBLANK));
+
+ putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
+}
+
+
+ LOCAL void
+dofclose()
+{
+ register expptr p;
+
+ if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+ {
+ ioset(TYIOINT, XUNIT, cpexpr(p) );
+ iosetc(XCLSTATUS, V(IOSSTATUS));
+ putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
+ }
+ else
+ err("bad unit in close statement");
+}
+
+
+ LOCAL void
+dofinquire()
+{
+ register expptr p;
+ if(p = V(IOSUNIT))
+ {
+ if( V(IOSFILE) )
+ err("inquire by unit or by file, not both");
+ ioset(TYIOINT, XUNIT, cpexpr(p) );
+ }
+ else if( ! V(IOSFILE) )
+ err("must inquire by unit or by file");
+ iosetlc(IOSFILE, XFILE, XFILELEN);
+ iosetip(IOSEXISTS, XEXISTS);
+ iosetip(IOSOPENED, XOPEN);
+ iosetip(IOSNUMBER, XNUMBER);
+ iosetip(IOSNAMED, XNAMED);
+ iosetlc(IOSNAME, XNAME, XNAMELEN);
+ iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
+ iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
+ iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
+ iosetlc(IOSFORM, XFORM, XFORMLEN);
+ iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
+ iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
+ iosetip(IOSRECL, XQRECL);
+ iosetip(IOSNEXTREC, XNEXTREC);
+ iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
+
+ putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) ));
+}
+
+
+
+ LOCAL void
+dofmove(subname)
+ char *subname;
+{
+ register expptr p;
+
+ if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+ {
+ ioset(TYIOINT, XUNIT, cpexpr(p) );
+ putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
+ }
+ else
+ err("bad unit in I/O motion statement");
+}
+
+static int ioset_assign = OPASSIGN;
+
+ LOCAL void
+ioset(type, offset, p)
+ int type, offset;
+ register expptr p;
+{
+ offset /= SZLONG;
+ if(statstruct && ISCONST(p)) {
+ register char *s;
+ switch(type) {
+ case TYADDR: /* stmt label */
+ s = "fmt_";
+ break;
+ case TYIOINT:
+ s = "";
+ break;
+ default:
+ badtype("ioset", type);
+ }
+ iob_list->fields[offset] =
+ string_num(s, p->constblock.Const.ci);
+ frexpr(p);
+ }
+ else {
+ register Addrp q;
+
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ q->vtype = type;
+ q->vstg = STGAUTO;
+ q->ntempelt = 1;
+ q->isarray = 0;
+ q->memoffset = ICON(0);
+ q->uname_tag = UNAM_IDENT;
+ sprintf(q->user.ident, "%s.%s",
+ statstruct ? iob_list->name : ioblkp->user.ident,
+ io_fields[offset + 1]);
+ if (type == TYADDR && p->tag == TCONST
+ && p->constblock.vtype == TYADDR) {
+ /* kludge */
+ register Addrp p1;
+ p1 = ALLOC(Addrblock);
+ p1->tag = TADDR;
+ p1->vtype = type;
+ p1->vstg = STGAUTO; /* wrong, but who cares? */
+ p1->ntempelt = 1;
+ p1->isarray = 0;
+ p1->memoffset = ICON(0);
+ p1->uname_tag = UNAM_IDENT;
+ sprintf(p1->user.ident, "fmt_%ld",
+ p->constblock.Const.ci);
+ frexpr(p);
+ p = (expptr)p1;
+ }
+ if (type == TYADDR && p->headblock.vtype == TYCHAR)
+ q->vtype = TYCHAR;
+ putexpr(mkexpr(ioset_assign, (expptr)q, p));
+ }
+}
+
+
+
+
+ LOCAL void
+iosetc(offset, p)
+ int offset;
+ register expptr p;
+{
+ if(p == NULL)
+ ioset(TYADDR, offset, ICON(0) );
+ else if(p->headblock.vtype == TYCHAR)
+ ioset(TYADDR, offset, addrof(cpexpr(p) ));
+ else
+ err("non-character control clause");
+}
+
+
+
+ LOCAL void
+ioseta(offset, p)
+ int offset;
+ register Addrp p;
+{
+ char *s, *s1;
+ static char who[] = "ioseta";
+ expptr e, mo;
+ Namep np;
+ ftnint ci;
+ int k;
+ char buf[24], buf1[24];
+ Extsym *comm;
+
+ if(statstruct)
+ {
+ if (!p)
+ return;
+ if (p->tag != TADDR)
+ badtag(who, p->tag);
+ offset /= SZLONG;
+ switch(p->uname_tag) {
+ case UNAM_NAME:
+ mo = p->memoffset;
+ if (mo->tag != TCONST)
+ badtag("ioseta/memoffset", mo->tag);
+ np = p->user.name;
+ np->visused = 1;
+ ci = mo->constblock.Const.ci - np->voffset;
+ if (np->vstg == STGCOMMON && !np->vcommequiv) {
+ comm = &extsymtab[np->vardesc.varno];
+ sprintf(buf, "%d.", comm->curno);
+ k = strlen(buf) + strlen(comm->cextname)
+ + strlen(np->cvarname);
+ if (ci) {
+ sprintf(buf1, "+%ld", ci);
+ k += strlen(buf1);
+ }
+ else
+ buf1[0] = 0;
+ s = mem(k + 1, 0);
+ sprintf(s, "%s%s%s%s", comm->cextname, buf,
+ np->cvarname, buf1);
+ }
+ else if (ci) {
+ sprintf(buf,"%ld", ci);
+ s1 = p->user.name->cvarname;
+ k = strlen(buf) + strlen(s1);
+ sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
+ }
+ else
+ s = cpstring(p->user.name->cvarname);
+ break;
+ case UNAM_CONST:
+ s = tostring(p->user.Const.ccp1.ccp0,
+ (int)p->vleng->constblock.Const.ci);
+ break;
+ default:
+ badthing("uname_tag", who, p->uname_tag);
+ }
+ /* kludge for Hollerith */
+ if (p->vtype != TYCHAR) {
+ s1 = mem(strlen(s)+10,0);
+ sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
+ s = s1;
+ }
+ iob_list->fields[offset] = s;
+ }
+ else {
+ if (!p)
+ e = ICON(0);
+ else if (p->vtype != TYCHAR) {
+ NOEXT("non-character variable as format or internal unit");
+ e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
+ }
+ else
+ e = addrof((expptr)p);
+ ioset(TYADDR, offset, e);
+ }
+}
+
+
+
+
+ LOCAL void
+iosetip(i, offset)
+ int i, offset;
+{
+ register expptr p;
+
+ if(p = V(i))
+ if(p->tag==TADDR &&
+ ONEOF(p->addrblock.vtype, inqmask) ) {
+ ioset_assign = OPASSIGNI;
+ ioset(TYADDR, offset, addrof(cpexpr(p)) );
+ ioset_assign = OPASSIGN;
+ }
+ else
+ errstr("impossible inquire parameter %s", ioc[i].iocname);
+ else
+ ioset(TYADDR, offset, ICON(0) );
+}
+
+
+
+ LOCAL void
+iosetlc(i, offp, offl)
+ int i, offp, offl;
+{
+ register expptr p;
+ if( (p = V(i)) && p->headblock.vtype==TYCHAR)
+ ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
+ iosetc(offp, p);
+}
--- /dev/null
+struct iob_data {
+ struct iob_data *next;
+ char *type;
+ char *name;
+ char *fields[1];
+ };
+struct io_setup {
+ char **fields;
+ int nelt, type;
+ };
+
+struct defines {
+ struct defines *next;
+ char defname[1];
+ };
+
+typedef struct iob_data iob_data;
+typedef struct io_setup io_setup;
+typedef struct defines defines;
+
+extern iob_data *iob_list;
+extern struct Addrblock *io_structs[9];
+extern void def_start(), new_iob_data(), other_undefs();
+extern char *tostring();
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "tokdefs.h"
+#include "p1defs.h"
+
+# define BLANK ' '
+# define MYQUOTE (2)
+# define SEOF 0
+
+/* card types */
+
+# define STEOF 1
+# define STINITIAL 2
+# define STCONTINUE 3
+
+/* lex states */
+
+#define NEWSTMT 1
+#define FIRSTTOKEN 2
+#define OTHERTOKEN 3
+#define RETEOS 4
+
+
+LOCAL int stkey; /* Type of the current statement (DO, END, IF, etc) */
+extern char token[]; /* holds the actual token text */
+static int needwkey;
+ftnint yystno;
+flag intonly;
+extern int new_dcl;
+LOCAL long int stno;
+LOCAL long int nxtstno; /* Statement label */
+LOCAL int parlev; /* Parentheses level */
+LOCAL int parseen;
+LOCAL int expcom;
+LOCAL int expeql;
+LOCAL char *nextch;
+LOCAL char *lastch;
+LOCAL char *nextcd = NULL;
+LOCAL char *endcd;
+LOCAL long prevlin;
+LOCAL long thislin;
+LOCAL int code; /* Card type; INITIAL, CONTINUE or EOF */
+LOCAL int lexstate = NEWSTMT;
+LOCAL char sbuf[1390]; /* Main buffer for Fortran source input. The number
+ comes from lines of at most 66 characters, with at
+ most 20 continuation cards (or something); this is
+ part of the defn of the standard */
+LOCAL char *send = sbuf+20*66;
+LOCAL int nincl = 0; /* Current number of include files */
+LOCAL long firstline;
+LOCAL char *laststb, *stb0;
+extern int addftnsrc;
+#define CONTMAX 100 /* max continuation lines for ! processing */
+char *linestart[CONTMAX];
+LOCAL int ncont;
+LOCAL char comstart[256];
+#define USC (unsigned char *)
+
+static char anum_buf[256];
+#define isalnum_(x) anum_buf[x]
+#define isalpha_(x) (anum_buf[x] == 1)
+
+#define COMMENT_BUF_STORE 4088
+
+typedef struct comment_buf {
+ struct comment_buf *next;
+ char *last;
+ char buf[COMMENT_BUF_STORE];
+ } comment_buf;
+static comment_buf *cbfirst, *cbcur;
+static char *cbinit, *cbnext, *cblast;
+static void flush_comments();
+
+
+/* Comment buffering data
+
+ Comments are kept in a list until the statement before them has
+ been parsed. This list is implemented with the above comment_buf
+ structure and the pointers cbnext and cblast.
+
+ The comments are stored with terminating NULL, and no other
+ intervening space. The last few bytes of each block are likely to
+ remain unused.
+*/
+
+/* struct Inclfile holds the state information for each include file */
+struct Inclfile
+{
+ struct Inclfile *inclnext;
+ FILEP inclfp;
+ char *inclname;
+ int incllno;
+ char *incllinp;
+ int incllen;
+ int inclcode;
+ ftnint inclstno;
+};
+
+LOCAL struct Inclfile *inclp = NULL;
+LOCAL struct Keylist {
+ char *keyname;
+ int keyval;
+ char notinf66;
+};
+LOCAL struct Punctlist {
+ char punchar;
+ int punval;
+};
+LOCAL struct Fmtlist {
+ char fmtchar;
+ int fmtval;
+};
+struct Dotlist {
+ char *dotname;
+ int dotval;
+ };
+LOCAL struct Keylist *keystart[26], *keyend[26];
+
+/* KEYWORD AND SPECIAL CHARACTER TABLES
+*/
+
+static struct Punctlist puncts[ ] =
+{
+ '(', SLPAR,
+ ')', SRPAR,
+ '=', SEQUALS,
+ ',', SCOMMA,
+ '+', SPLUS,
+ '-', SMINUS,
+ '*', SSTAR,
+ '/', SSLASH,
+ '$', SCURRENCY,
+ ':', SCOLON,
+ '<', SLT,
+ '>', SGT,
+ 0, 0 };
+
+LOCAL struct Dotlist dots[ ] =
+{
+ "and.", SAND,
+ "or.", SOR,
+ "not.", SNOT,
+ "true.", STRUE,
+ "false.", SFALSE,
+ "eq.", SEQ,
+ "ne.", SNE,
+ "lt.", SLT,
+ "le.", SLE,
+ "gt.", SGT,
+ "ge.", SGE,
+ "neqv.", SNEQV,
+ "eqv.", SEQV,
+ 0, 0 };
+
+LOCAL struct Keylist keys[ ] =
+{
+ { "assign", SASSIGN },
+ { "automatic", SAUTOMATIC, YES },
+ { "backspace", SBACKSPACE },
+ { "blockdata", SBLOCK },
+ { "call", SCALL },
+ { "character", SCHARACTER, YES },
+ { "close", SCLOSE, YES },
+ { "common", SCOMMON },
+ { "complex", SCOMPLEX },
+ { "continue", SCONTINUE },
+ { "data", SDATA },
+ { "dimension", SDIMENSION },
+ { "doubleprecision", SDOUBLE },
+ { "doublecomplex", SDCOMPLEX, YES },
+ { "elseif", SELSEIF, YES },
+ { "else", SELSE, YES },
+ { "endfile", SENDFILE },
+ { "endif", SENDIF, YES },
+ { "enddo", SENDDO, YES },
+ { "end", SEND },
+ { "entry", SENTRY, YES },
+ { "equivalence", SEQUIV },
+ { "external", SEXTERNAL },
+ { "format", SFORMAT },
+ { "function", SFUNCTION },
+ { "goto", SGOTO },
+ { "implicit", SIMPLICIT, YES },
+ { "include", SINCLUDE, YES },
+ { "inquire", SINQUIRE, YES },
+ { "intrinsic", SINTRINSIC, YES },
+ { "integer", SINTEGER },
+ { "logical", SLOGICAL },
+ { "namelist", SNAMELIST, YES },
+ { "none", SUNDEFINED, YES },
+ { "open", SOPEN, YES },
+ { "parameter", SPARAM, YES },
+ { "pause", SPAUSE },
+ { "print", SPRINT },
+ { "program", SPROGRAM, YES },
+ { "punch", SPUNCH, YES },
+ { "read", SREAD },
+ { "real", SREAL },
+ { "return", SRETURN },
+ { "rewind", SREWIND },
+ { "save", SSAVE, YES },
+ { "static", SSTATIC, YES },
+ { "stop", SSTOP },
+ { "subroutine", SSUBROUTINE },
+ { "then", STHEN, YES },
+ { "undefined", SUNDEFINED, YES },
+ { "while", SWHILE, YES },
+ { "write", SWRITE },
+ { 0, 0 }
+};
+
+LOCAL void analyz(), crunch(), store_comment();
+LOCAL int getcd(), getcds(), getkwd(), gettok();
+
+inilex(name)
+char *name;
+{
+ nincl = 0;
+ inclp = NULL;
+ doinclude(name);
+ lexstate = NEWSTMT;
+ return(NO);
+}
+
+
+
+/* throw away the rest of the current line */
+flline()
+{
+ lexstate = RETEOS;
+}
+
+
+
+char *lexline(n)
+int *n;
+{
+ *n = (lastch - nextch) + 1;
+ return(nextch);
+}
+
+
+
+
+
+doinclude(name)
+char *name;
+{
+ FILEP fp;
+ struct Inclfile *t;
+
+ if(inclp)
+ {
+ inclp->incllno = thislin;
+ inclp->inclcode = code;
+ inclp->inclstno = nxtstno;
+ if(nextcd)
+ inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
+ else
+ inclp->incllinp = 0;
+ }
+ nextcd = NULL;
+
+ if(++nincl >= MAXINCLUDES)
+ Fatal("includes nested too deep");
+ if(name[0] == '\0')
+ fp = stdin;
+ else
+ fp = fopen(name, textread);
+ if (fp)
+ {
+ t = inclp;
+ inclp = ALLOC(Inclfile);
+ inclp->inclnext = t;
+ prevlin = thislin = 0;
+ infname = inclp->inclname = name;
+ infile = inclp->inclfp = fp;
+ }
+ else
+ {
+ fprintf(diagfile, "Cannot open file %s\n", name);
+ done(1);
+ }
+}
+
+
+
+
+LOCAL popinclude()
+{
+ struct Inclfile *t;
+ register char *p;
+ register int k;
+
+ if(infile != stdin)
+ clf(&infile, infname, 1); /* Close the input file */
+ free(infname);
+
+ --nincl;
+ t = inclp->inclnext;
+ free( (charptr) inclp);
+ inclp = t;
+ if(inclp == NULL) {
+ infname = 0;
+ return(NO);
+ }
+
+ infile = inclp->inclfp;
+ infname = inclp->inclname;
+ prevlin = thislin = inclp->incllno;
+ code = inclp->inclcode;
+ stno = nxtstno = inclp->inclstno;
+ if(inclp->incllinp)
+ {
+ endcd = nextcd = sbuf;
+ k = inclp->incllen;
+ p = inclp->incllinp;
+ while(--k >= 0)
+ *endcd++ = *p++;
+ free( (charptr) (inclp->incllinp) );
+ }
+ else
+ nextcd = NULL;
+ return(YES);
+}
+
+ static void
+putlineno()
+{
+ static long lastline;
+ static char *lastfile = "??", *lastfile0 = "?";
+ static char fbuf[P1_FILENAME_MAX];
+ extern int gflag;
+ register char *s0, *s1;
+
+ if (gflag) {
+ if (lastline) {
+ if (lastfile != lastfile0) {
+ p1puts(P1_FILENAME, fbuf);
+ lastfile0 = lastfile;
+ }
+ p1_line_number(lastline);
+ }
+ lastline = firstline;
+ if (lastfile != infname)
+ if (lastfile = infname) {
+ strncpy(fbuf, lastfile, sizeof(fbuf));
+ fbuf[sizeof(fbuf)-1] = 0;
+ }
+ else
+ fbuf[0] = 0;
+ }
+ if (addftnsrc) {
+ if (laststb && *laststb) {
+ for(s1 = laststb; *s1; s1++) {
+ for(s0 = s1; *s1 != '\n'; s1++)
+ if (*s1 == '*' && s1[1] == '/')
+ *s1 = '+';
+ *s1 = 0;
+ p1puts(P1_FORTRAN, s0);
+ }
+ *laststb = 0; /* prevent trouble after EOF */
+ }
+ laststb = stb0;
+ }
+ }
+
+
+yylex()
+{
+ static int tokno;
+ int retval;
+
+ switch(lexstate)
+ {
+ case NEWSTMT : /* need a new statement */
+ retval = getcds();
+ putlineno();
+ if(retval == STEOF) {
+ retval = SEOF;
+ break;
+ } /* if getcds() == STEOF */
+ crunch();
+ tokno = 0;
+ lexstate = FIRSTTOKEN;
+ yystno = stno;
+ stno = nxtstno;
+ toklen = 0;
+ retval = SLABEL;
+ break;
+
+first:
+ case FIRSTTOKEN : /* first step on a statement */
+ analyz();
+ lexstate = OTHERTOKEN;
+ tokno = 1;
+ retval = stkey;
+ break;
+
+ case OTHERTOKEN : /* return next token */
+ if(nextch > lastch)
+ goto reteos;
+ ++tokno;
+ if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
+ goto first;
+
+ if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
+ nextch[0]=='t' && nextch[1]=='o')
+ {
+ nextch+=2;
+ retval = STO;
+ break;
+ }
+ retval = gettok();
+ break;
+
+reteos:
+ case RETEOS:
+ lexstate = NEWSTMT;
+ retval = SEOS;
+ break;
+ default:
+ fatali("impossible lexstate %d", lexstate);
+ break;
+ }
+
+ if (retval == SEOF)
+ flush_comments ();
+
+ return retval;
+}
+
+/* Get Cards.
+
+ Returns STEOF or STINITIAL, never STCONTINUE. Any continuation cards get
+merged into one long card (hence the size of the buffer named sbuf) */
+
+ LOCAL int
+getcds()
+{
+ register char *p, *q;
+
+ flush_comments ();
+top:
+ if(nextcd == NULL)
+ {
+ code = getcd( nextcd = sbuf, 1 );
+ stno = nxtstno;
+ prevlin = thislin;
+ }
+ if(code == STEOF)
+ if( popinclude() )
+ goto top;
+ else
+ return(STEOF);
+
+ if(code == STCONTINUE)
+ {
+ lineno = thislin;
+ nextcd = NULL;
+ goto top;
+ }
+
+/* Get rid of unused space at the head of the buffer */
+
+ if(nextcd > sbuf)
+ {
+ q = nextcd;
+ p = sbuf;
+ while(q < endcd)
+ *p++ = *q++;
+ endcd = p;
+ }
+
+/* Be aware that the input (i.e. the string at the address nextcd) is NOT
+ NULL-terminated */
+
+/* This loop merges all continuations into one long statement, AND puts the next
+ card to be read at the end of the buffer (i.e. it stores the look-ahead card
+ when there's room) */
+
+ ncont = 0;
+ do {
+ nextcd = endcd;
+ if (ncont < CONTMAX)
+ linestart[ncont++] = nextcd;
+ }
+ while(nextcd+66<=send && (code = getcd(nextcd,0))==STCONTINUE);
+ nextch = sbuf;
+ lastch = nextcd - 1;
+
+/* Handle buffer overflow by zeroing the 'next' pointer (nextcd) so that
+ the top of this function will initialize it next time it is called */
+
+ if(nextcd >= send)
+ nextcd = NULL;
+ lineno = prevlin;
+ prevlin = thislin;
+ return(STINITIAL);
+}
+
+ static void
+bang(a,b,c,d,e) /* save ! comments */
+ char *a, *b, *c;
+ register char *d, *e;
+{
+ char buf[COMMENT_BUFFER_SIZE + 1];
+ register char *p, *pe;
+
+ p = buf;
+ pe = buf + COMMENT_BUFFER_SIZE;
+ *pe = 0;
+ while(a < b)
+ if (!(*p++ = *a++))
+ p[-1] = 0;
+ if (b < c)
+ *p++ = '\t';
+ while(d < e) {
+ if (!(*p++ = *d++))
+ p[-1] = ' ';
+ if (p == pe) {
+ store_comment(buf);
+ p = buf;
+ }
+ }
+ if (p > buf) {
+ while(--p >= buf && *p == ' ');
+ p[1] = 0;
+ store_comment(buf);
+ }
+ }
+
+/* getcd - Get next input card
+
+ This function reads the next input card from global file pointer infile.
+It assumes that b points to currently empty storage somewhere in sbuf */
+
+ LOCAL int
+getcd(b, nocont)
+ register char *b;
+{
+ register int c;
+ register char *p, *bend;
+ int speclin; /* Special line - true when the line is allowed
+ to have more than 66 characters (e.g. the
+ "&" shorthand for continuation, use of a "\t"
+ to skip part of the label columns) */
+ static char a[6]; /* Statement label buffer */
+ static char *aend = a+6;
+ static char stbuf[3][P1_STMTBUFSIZE], *stb, *stbend;
+ static int nst;
+ char *atend, *endcd0;
+ int amp;
+ char storage[COMMENT_BUFFER_SIZE + 1];
+ char *pointer;
+
+top:
+ endcd = b;
+ bend = b+66;
+ amp = speclin = NO;
+ atend = aend;
+
+/* Handle the continuation shorthand of "&" in the first column, which stands
+ for " x" */
+
+ if( (c = getc(infile)) == '&')
+ {
+ a[0] = c;
+ a[1] = 0;
+ a[5] = 'x';
+ amp = speclin = YES;
+ bend = send;
+ p = aend;
+ }
+
+/* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */
+
+ else if(comstart[c & 0xff])
+ {
+ if (feof (infile))
+ return STEOF;
+
+ storage[COMMENT_BUFFER_SIZE] = c = '\0';
+ pointer = storage;
+ while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
+
+/* Handle obscure end of file conditions on many machines */
+
+ if (feof (infile) && (c == '\377' || c == EOF)) {
+ pointer--;
+ break;
+ } /* if (feof (infile)) */
+
+ if (c == '\0')
+ *(pointer - 1) = ' ';
+
+ if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
+ store_comment (storage);
+ pointer = storage;
+ } /* if (pointer == BUFFER_SIZE) */
+ } /* while */
+
+ if (pointer > storage) {
+ if (c == '\n')
+
+/* Get rid of the newline */
+
+ pointer[-1] = 0;
+ else
+ *pointer = 0;
+
+ store_comment (storage);
+ } /* if */
+
+ if (feof (infile))
+ if (c != '\n') /* To allow the line index to
+ increment correctly */
+ return STEOF;
+
+ ++thislin;
+ goto top;
+ }
+
+ else if(c != EOF)
+ {
+
+/* Load buffer a with the statement label */
+
+ /* a tab in columns 1-6 skips to column 7 */
+ ungetc(c, infile);
+ for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
+ if(c == '\t')
+
+/* The tab character translates into blank characters in the statement label */
+
+ {
+ atend = p;
+ while(p < aend)
+ *p++ = BLANK;
+ speclin = YES;
+ bend = send;
+ }
+ else
+ *p++ = c;
+ }
+
+/* By now we've read either a continuation character or the statement label
+ field */
+
+ if(c == EOF)
+ return(STEOF);
+
+/* The next 'if' block handles lines that have fewer than 7 characters */
+
+ if(c == '\n')
+ {
+ while(p < aend)
+ *p++ = BLANK;
+
+/* Blank out the buffer on lines which are not longer than 66 characters */
+
+ endcd0 = endcd;
+ if( ! speclin )
+ while(endcd < bend)
+ *endcd++ = BLANK;
+ }
+ else { /* read body of line */
+ while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
+ *endcd++ = c;
+ if(c == EOF)
+ return(STEOF);
+
+/* Drop any extra characters on the input card; this usually means those after
+ column 72 */
+
+ if(c != '\n')
+ {
+ while( (c=getc(infile)) != '\n')
+ if(c == EOF)
+ return(STEOF);
+ }
+
+ endcd0 = endcd;
+ if( ! speclin )
+ while(endcd < bend)
+ *endcd++ = BLANK;
+ }
+
+/* The flow of control usually gets to this line (unless an earlier RETURN has
+ been taken) */
+
+ ++thislin;
+
+ /* Fortran 77 specifies that a 0 in column 6 */
+ /* does not signify continuation */
+
+ if( !isspace(a[5]) && a[5]!='0') {
+ if (!amp)
+ for(p = a; p < aend;)
+ if (*p++ == '!' && p != aend)
+ goto initcheck;
+ if (addftnsrc && stb) {
+ if (stbend > stb + 7) { /* otherwise forget col 1-6 */
+ /* kludge around funny p1gets behavior */
+ *stb++ = '$';
+ if (amp)
+ *stb++ = '&';
+ else
+ for(p = a; p < atend;)
+ *stb++ = *p++;
+ }
+ if (endcd0 - b > stbend - stb) {
+ if (stb > stbend)
+ stb = stbend;
+ endcd0 = b + (stbend - stb);
+ }
+ for(p = b; p < endcd0;)
+ *stb++ = *p++;
+ *stb++ = '\n';
+ *stb = 0;
+ }
+ if (nocont) {
+ lineno = thislin;
+ errstr("illegal continuation card (starts \"%.6s\")",a);
+ }
+ else if (!amp && strncmp(a," ",5)) {
+ lineno = thislin;
+ errstr("labeled continuation line (starts \"%.6s\")",a);
+ }
+ return(STCONTINUE);
+ }
+initcheck:
+ for(p=a; p<atend; ++p)
+ if( !isspace(*p) ) {
+ if (*p++ != '!')
+ goto initline;
+ bang(p, atend, aend, b, endcd);
+ goto top;
+ }
+ for(p = b ; p<endcd ; ++p)
+ if( !isspace(*p) ) {
+ if (*p++ != '!')
+ goto initline;
+ bang(a, a, a, p, endcd);
+ goto top;
+ }
+
+/* Skip over blank cards by reading the next one right away */
+
+ goto top;
+
+initline:
+ if (addftnsrc) {
+ nst = (nst+1)%3;
+ if (!laststb && stb0)
+ laststb = stb0;
+ stb0 = stb = stbuf[nst];
+ *stb++ = '$'; /* kludge around funny p1gets behavior */
+ stbend = stb + sizeof(stbuf[0])-2;
+ for(p = a; p < atend;)
+ *stb++ = *p++;
+ if (atend < aend)
+ *stb++ = '\t';
+ for(p = b; p < endcd0;)
+ *stb++ = *p++;
+ *stb++ = '\n';
+ *stb = 0;
+ }
+
+/* Set nxtstno equal to the integer value of the statement label */
+
+ nxtstno = 0;
+ bend = a + 5;
+ for(p = a ; p < bend ; ++p)
+ if( !isspace(*p) )
+ if(isdigit(*p))
+ nxtstno = 10*nxtstno + (*p - '0');
+ else if (*p == '!') {
+ if (!addftnsrc)
+ bang(p+1,atend,aend,b,endcd);
+ endcd = b;
+ break;
+ }
+ else {
+ lineno = thislin;
+ errstr(
+ "nondigit in statement label field \"%.5s\"", a);
+ nxtstno = 0;
+ break;
+ }
+ firstline = thislin;
+ return(STINITIAL);
+}
+
+
+/* crunch -- deletes all space characters, folds the backslash chars and
+ Hollerith strings, quotes the Fortran strings */
+
+ LOCAL void
+crunch()
+{
+ register char *i, *j, *j0, *j1, *prvstr;
+ int k, ten, nh, quote;
+
+ /* i is the next input character to be looked at
+ j is the next output character */
+
+ new_dcl = needwkey = parlev = parseen = 0;
+ expcom = 0; /* exposed ','s */
+ expeql = 0; /* exposed equal signs */
+ j = sbuf;
+ prvstr = sbuf;
+ k = 0;
+ for(i=sbuf ; i<=lastch ; ++i)
+ {
+ if(isspace(*i) )
+ continue;
+ if (*i == '!') {
+ while(i >= linestart[k])
+ if (++k >= CONTMAX)
+ Fatal("too many continuations\n");
+ j0 = linestart[k];
+ if (!addftnsrc)
+ bang(sbuf,sbuf,sbuf,i+1,j0);
+ i = j0-1;
+ continue;
+ }
+
+/* Keep everything in a quoted string */
+
+ if(*i=='\'' || *i=='"')
+ {
+ int len = 0;
+
+ quote = *i;
+ *j = MYQUOTE; /* special marker */
+ for(;;)
+ {
+ if(++i > lastch)
+ {
+ err("unbalanced quotes; closing quote supplied");
+ if (j >= lastch)
+ j = lastch - 1;
+ break;
+ }
+ if(*i == quote)
+ if(i<lastch && i[1]==quote) ++i;
+ else break;
+ else if(*i=='\\' && i<lastch)
+ switch(*++i)
+ {
+ case 't':
+ *i = '\t';
+ break;
+ case 'b':
+ *i = '\b';
+ break;
+ case 'n':
+ *i = '\n';
+ break;
+ case 'f':
+ *i = '\f';
+ break;
+ case 'v':
+ *i = '\v';
+ break;
+ case '0':
+ *i = '\0';
+ break;
+ default:
+ break;
+ }
+ if (len + 2 < MAXTOKENLEN)
+ *++j = *i;
+ else if (len + 2 == MAXTOKENLEN)
+ erri
+ ("String too long, truncating to %d chars", MAXTOKENLEN - 2);
+ len++;
+ } /* for (;;) */
+
+ j[1] = MYQUOTE;
+ j += 2;
+ prvstr = j;
+ }
+ else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */
+ {
+ j0 = j - 1;
+ if( ! isdigit(*j0)) goto copychar;
+ nh = *j0 - '0';
+ ten = 10;
+ j1 = prvstr;
+ if (j1+4 < j)
+ j1 = j-4;
+ for(;;) {
+ if (j0-- <= j1)
+ goto copychar;
+ if( ! isdigit(*j0 ) ) break;
+ nh += ten * (*j0-'0');
+ ten*=10;
+ }
+ /* a hollerith must be preceded by a punctuation mark.
+ '*' is possible only as repetition factor in a data statement
+ not, in particular, in character*2h
+*/
+
+ if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
+ && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
+ goto copychar;
+ if(i+nh > lastch || nh + 2 > MAXTOKENLEN)
+ {
+ erri("%dH too big", nh);
+ nh = lastch - i;
+ }
+ j0[1] = MYQUOTE; /* special marker */
+ j = j0 + 1;
+ while(nh-- > 0)
+ {
+ if(*++i == '\\')
+ switch(*++i)
+ {
+ case 't':
+ *i = '\t';
+ break;
+ case 'b':
+ *i = '\b';
+ break;
+ case 'n':
+ *i = '\n';
+ break;
+ case 'f':
+ *i = '\f';
+ break;
+ case '0':
+ *i = '\0';
+ break;
+ default:
+ break;
+ }
+ *++j = *i;
+ }
+ j[1] = MYQUOTE;
+ j+=2;
+ prvstr = j;
+ }
+ else {
+ if(*i == '(') parseen = ++parlev;
+ else if(*i == ')') --parlev;
+ else if(parlev == 0)
+ if(*i == '=') expeql = 1;
+ else if(*i == ',') expcom = 1;
+copychar: /*not a string or space -- copy, shifting case if necessary */
+ if(shiftcase && isupper(*i))
+ *j++ = tolower(*i);
+ else *j++ = *i;
+ }
+ }
+ lastch = j - 1;
+ nextch = sbuf;
+}
+
+ LOCAL void
+analyz()
+{
+ register char *i;
+
+ if(parlev != 0)
+ {
+ err("unbalanced parentheses, statement skipped");
+ stkey = SUNKNOWN;
+ lastch = sbuf - 1; /* prevent double error msg */
+ return;
+ }
+ if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
+ {
+ /* assignment or if statement -- look at character after balancing paren */
+ parlev = 1;
+ for(i=nextch+3 ; i<=lastch; ++i)
+ if(*i == (MYQUOTE))
+ {
+ while(*++i != MYQUOTE)
+ ;
+ }
+ else if(*i == '(')
+ ++parlev;
+ else if(*i == ')')
+ {
+ if(--parlev == 0)
+ break;
+ }
+ if(i >= lastch)
+ stkey = SLOGIF;
+ else if(i[1] == '=')
+ stkey = SLET;
+ else if( isdigit(i[1]) )
+ stkey = SARITHIF;
+ else stkey = SLOGIF;
+ if(stkey != SLET)
+ nextch += 2;
+ }
+ else if(expeql) /* may be an assignment */
+ {
+ if(expcom && nextch<lastch &&
+ nextch[0]=='d' && nextch[1]=='o')
+ {
+ stkey = SDO;
+ nextch += 2;
+ }
+ else stkey = SLET;
+ }
+ else if (parseen && nextch + 7 < lastch
+ && nextch[2] != 'u' /* screen out "double..." early */
+ && nextch[0] == 'd' && nextch[1] == 'o'
+ && ((nextch[2] >= '0' && nextch[2] <= '9')
+ || nextch[2] == ','
+ || nextch[2] == 'w'))
+ {
+ stkey = SDO;
+ nextch += 2;
+ needwkey = 1;
+ }
+ /* otherwise search for keyword */
+ else {
+ stkey = getkwd();
+ if(stkey==SGOTO && lastch>=nextch)
+ if(nextch[0]=='(')
+ stkey = SCOMPGOTO;
+ else if(isalpha(nextch[0]))
+ stkey = SASGOTO;
+ }
+ parlev = 0;
+}
+
+
+
+ LOCAL int
+getkwd()
+{
+ register char *i, *j;
+ register struct Keylist *pk, *pend;
+ int k;
+
+ if(! isalpha(nextch[0]) )
+ return(SUNKNOWN);
+ k = letter(nextch[0]);
+ if(pk = keystart[k])
+ for(pend = keyend[k] ; pk<=pend ; ++pk )
+ {
+ i = pk->keyname;
+ j = nextch;
+ while(*++i==*++j && *i!='\0')
+ ;
+ if(*i=='\0' && j<=lastch+1)
+ {
+ nextch = j;
+ if(no66flag && pk->notinf66)
+ errstr("Not a Fortran 66 keyword: %s",
+ pk->keyname);
+ return(pk->keyval);
+ }
+ }
+ return(SUNKNOWN);
+}
+
+initkey()
+{
+ register struct Keylist *p;
+ register int i,j;
+ register char *s;
+
+ for(i = 0 ; i<26 ; ++i)
+ keystart[i] = NULL;
+
+ for(p = keys ; p->keyname ; ++p) {
+ j = letter(p->keyname[0]);
+ if(keystart[j] == NULL)
+ keystart[j] = p;
+ keyend[j] = p;
+ }
+ comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = 1;
+ s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
+ while(i = *s++)
+ anum_buf[i] = 1;
+ s = "0123456789";
+ while(i = *s++)
+ anum_buf[i] = 2;
+ }
+
+/* gettok -- moves the right amount of text from nextch into the token
+ buffer. token initially contains garbage (leftovers from the prev token) */
+
+ LOCAL int
+gettok()
+{
+ int havdot, havexp, havdbl;
+ int radix, val;
+ struct Punctlist *pp;
+ struct Dotlist *pd;
+ register int ch;
+
+ char *i, *j, *n1, *p;
+
+ ch = * USC nextch;
+ if(ch == (MYQUOTE))
+ {
+ ++nextch;
+ p = token;
+ while(*nextch != MYQUOTE)
+ *p++ = *nextch++;
+ ++nextch;
+ toklen = p - token;
+ *p = 0;
+ return (SHOLLERITH);
+ }
+ /* The next 40 lines or so were an early attempt to parse FORMAT
+ statements. They have been deleted */
+
+/* Not a format statement */
+
+ if(needkwd)
+ {
+ needkwd = 0;
+ return( getkwd() );
+ }
+
+ for(pp=puncts; pp->punchar; ++pp)
+ if(ch == pp->punchar) {
+ val = pp->punval;
+ if (++nextch <= lastch)
+ switch(ch) {
+ case '/':
+ if (*nextch == '/') {
+ nextch++;
+ val = SCONCAT;
+ }
+ else if (new_dcl && parlev == 0)
+ val = SSLASHD;
+ return val;
+ case '*':
+ if (*nextch == '*') {
+ nextch++;
+ return SPOWER;
+ }
+ break;
+ case '<':
+ if (*nextch == '=') {
+ nextch++;
+ val = SLE;
+ }
+ if (*nextch == '>') {
+ nextch++;
+ val = SNE;
+ }
+ goto extchk;
+ case '=':
+ if (*nextch == '=') {
+ nextch++;
+ val = SEQ;
+ goto extchk;
+ }
+ break;
+ case '>':
+ if (*nextch == '=') {
+ nextch++;
+ val = SGE;
+ }
+ extchk:
+ NOEXT("Fortran 8x comparison operator");
+ return val;
+ }
+ else if (ch == '/' && new_dcl && parlev == 0)
+ return SSLASHD;
+ switch(val) {
+ case SLPAR:
+ ++parlev;
+ break;
+ case SRPAR:
+ --parlev;
+ }
+ return(val);
+ }
+ if(ch == '.')
+ if(nextch >= lastch) goto badchar;
+ else if(isdigit(nextch[1])) goto numconst;
+ else {
+ for(pd=dots ; (j=pd->dotname) ; ++pd)
+ {
+ for(i=nextch+1 ; i<=lastch ; ++i)
+ if(*i != *j) break;
+ else if(*i != '.') ++j;
+ else {
+ nextch = i+1;
+ return(pd->dotval);
+ }
+ }
+ goto badchar;
+ }
+ if( isalpha(ch) )
+ {
+ p = token;
+ *p++ = *nextch++;
+ while(nextch<=lastch)
+ if( isalnum_(* USC nextch) )
+ *p++ = *nextch++;
+ else break;
+ toklen = p - token;
+ *p = 0;
+ if (needwkey) {
+ needwkey = 0;
+ if (toklen == 5
+ && nextch <= lastch && *nextch == '(' /*)*/
+ && !strcmp(token,"while"))
+ return(SWHILE);
+ }
+ if(inioctl && nextch<=lastch && *nextch=='=')
+ {
+ ++nextch;
+ return(SNAMEEQ);
+ }
+ if(toklen>8 && eqn(8,token,"function") && isalpha(token[8]) &&
+ nextch<lastch && nextch[0]=='(' &&
+ (nextch[1]==')' || isalpha(nextch[1])) )
+ {
+ nextch -= (toklen - 8);
+ return(SFUNCTION);
+ }
+
+ if(toklen > 50)
+ {
+ char buff[100];
+ sprintf(buff, toklen >= 60
+ ? "name %.56s... too long, truncated to %.*s"
+ : "name %s too long, truncated to %.*s",
+ token, 50, token);
+ err(buff);
+ toklen = 50;
+ token[50] = '\0';
+ }
+ if(toklen==1 && *nextch==MYQUOTE)
+ {
+ switch(token[0])
+ {
+ case 'z':
+ case 'Z':
+ case 'x':
+ case 'X':
+ radix = 16;
+ break;
+ case 'o':
+ case 'O':
+ radix = 8;
+ break;
+ case 'b':
+ case 'B':
+ radix = 2;
+ break;
+ default:
+ err("bad bit identifier");
+ return(SNAME);
+ }
+ ++nextch;
+ for(p = token ; *nextch!=MYQUOTE ; )
+ if( hextoi(*p++ = *nextch++) >= radix)
+ {
+ err("invalid binary character");
+ break;
+ }
+ ++nextch;
+ toklen = p - token;
+ *p = 0;
+ return( radix==16 ? SHEXCON :
+ (radix==8 ? SOCTCON : SBITCON) );
+ }
+ return(SNAME);
+ }
+
+ if (isdigit(ch)) {
+
+ /* Check for NAG's special hex constant */
+
+ if (nextch[1] == '#'
+ || nextch[2] == '#' && isdigit(nextch[1])) {
+
+ radix = atoi (nextch);
+ if (*++nextch != '#')
+ nextch++;
+ if (radix != 2 && radix != 8 && radix != 16) {
+ erri("invalid base %d for constant, defaulting to hex",
+ radix);
+ radix = 16;
+ } /* if */
+ if (++nextch > lastch)
+ goto badchar;
+ for (p = token; hextoi(*nextch) < radix;) {
+ *p++ = *nextch++;
+ if (nextch > lastch)
+ break;
+ }
+ toklen = p - token;
+ *p = 0;
+ return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
+ SBITCON);
+ }
+ }
+ else
+ goto badchar;
+numconst:
+ havdot = NO;
+ havexp = NO;
+ havdbl = NO;
+ for(n1 = nextch ; nextch<=lastch ; ++nextch)
+ {
+ if(*nextch == '.')
+ if(havdot) break;
+ else if(nextch+2<=lastch && isalpha(nextch[1])
+ && isalpha(nextch[2]))
+ break;
+ else havdot = YES;
+ else if( !intonly && (*nextch=='d' || *nextch=='e') )
+ {
+ p = nextch;
+ havexp = YES;
+ if(*nextch == 'd')
+ havdbl = YES;
+ if(nextch<lastch)
+ if(nextch[1]=='+' || nextch[1]=='-')
+ ++nextch;
+ if( ! isdigit(*++nextch) )
+ {
+ nextch = p;
+ havdbl = havexp = NO;
+ break;
+ }
+ for(++nextch ;
+ nextch<=lastch && isdigit(* USC nextch);
+ ++nextch);
+ break;
+ }
+ else if( ! isdigit(* USC nextch) )
+ break;
+ }
+ p = token;
+ i = n1;
+ while(i < nextch)
+ *p++ = *i++;
+ toklen = p - token;
+ *p = 0;
+ if(havdbl) return(SDCON);
+ if(havdot || havexp) return(SRCON);
+ return(SICON);
+badchar:
+ sbuf[0] = *nextch++;
+ return(SUNKNOWN);
+}
+
+/* Comment buffering code */
+
+ static void
+store_comment(str)
+ char *str;
+{
+ int len;
+ char *Alloc();
+ comment_buf *ncb;
+
+ if (nextcd == sbuf) {
+ flush_comments();
+ p1_comment(str);
+ return;
+ }
+ len = strlen(str) + 1;
+ if (cbnext + len > cblast) {
+ if (!cbcur || !(ncb = cbcur->next)) {
+ ncb = (comment_buf *) Alloc(sizeof(comment_buf));
+ if (cbcur) {
+ cbcur->last = cbnext;
+ cbcur->next = ncb;
+ }
+ else {
+ cbfirst = ncb;
+ cbinit = ncb->buf;
+ }
+ ncb->next = 0;
+ }
+ cbcur = ncb;
+ cbnext = ncb->buf;
+ cblast = cbnext + COMMENT_BUF_STORE;
+ }
+ strcpy(cbnext, str);
+ cbnext += len;
+ }
+
+ static void
+flush_comments()
+{
+ register char *s, *s1;
+ register comment_buf *cb;
+ if (cbnext == cbinit)
+ return;
+ cbcur->last = cbnext;
+ for(cb = cbfirst;; cb = cb->next) {
+ for(s = cb->buf; s < cb->last; s = s1) {
+ /* compute s1 = new s value first, since */
+ /* p1_comment may insert nulls into s */
+ s1 = s + strlen(s) + 1;
+ p1_comment(s);
+ }
+ if (cb == cbcur)
+ break;
+ }
+ cbcur = cbfirst;
+ cbnext = cbinit;
+ cblast = cbnext + COMMENT_BUF_STORE;
+ }
+
+ void
+unclassifiable()
+{
+ register char *s, *se;
+
+ s = sbuf;
+ se = lastch;
+ if (se < sbuf)
+ return;
+ lastch = s - 1;
+ if (se - s > 10)
+ se = s + 10;
+ for(; s < se; s++)
+ if (*s == MYQUOTE) {
+ se = s;
+ break;
+ }
+ *se = 0;
+ errstr("unclassifiable statment (starts \"%s\")", sbuf);
+ }
--- /dev/null
+main.o init.o gram.o lex.o proc.o equiv.o data.o format.o expr.o exec.o intr.o io.o misc.o error.o mem.o names.o output.o p1output.o pread.o put.o putpcc.o vax.o formatd.o safstrcp.o parsearg.o nicepr.o cds.o sysdep.o version.o
+
--- /dev/null
+#define TYLENG TYLONG /* char string length field */
+
+#define TYINT TYLONG
+#define SZADDR 4
+#define SZSHORT 2
+#define SZINT 4
+
+#define SZLONG 4
+#define SZLENG SZLONG
+
+#define SZDREAL 8
+
+/* Alignment restrictions */
+
+#define ALIADDR SZADDR
+#define ALISHORT SZSHORT
+#define ALILONG 4
+#define ALIDOUBLE 8
+#define ALIINT ALILONG
+#define ALILENG ALILONG
+
+#define BLANKCOMMON "_BLNK__" /* Name for the unnamed
+ common block; this is unique
+ because of underscores */
+
+#define LABELFMT "%s:\n"
+
+#define MAXREGVAR 4
+#define TYIREG TYLONG
+#define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies
+ which can be put in registers */
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+extern char F2C_version[];
+
+#include "defs.h"
+#include "parse.h"
+
+int complex_seen, dcomplex_seen;
+
+LOCAL int Max_ftn_files;
+
+char **ftn_files;
+int current_ftn_file = 0;
+
+flag ftn66flag = NO;
+flag nowarnflag = NO;
+flag noextflag = NO;
+flag no66flag = NO; /* Must also set noextflag to this
+ same value */
+flag zflag = YES; /* recognize double complex intrinsics */
+flag debugflag = NO;
+flag onetripflag = NO;
+flag shiftcase = YES;
+flag undeftype = NO;
+flag checksubs = NO;
+flag r8flag = NO;
+int tyreal = TYREAL;
+extern void r8fix(), read_Pfiles();
+
+int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */
+int maxequiv = MAXEQUIV;
+int maxext = MAXEXT;
+int maxstno = MAXSTNO;
+int maxctl = MAXCTL;
+int maxhash = MAXHASH;
+int extcomm, ext1comm, useauto;
+int can_include = YES; /* so we can disable includes for netlib */
+
+static char *def_i2 = "";
+
+static int useshortints = NO; /* YES => tyint = TYSHORT */
+static int uselongints = NO; /* YES => tyint = TYLONG */
+int addftnsrc = NO; /* Include ftn source in output */
+int usedefsforcommon = NO; /* Use #defines for common reference */
+int forcedouble = YES; /* force real functions to double */
+int Ansi = NO;
+int def_equivs = YES;
+int tyioint = TYLONG;
+int szleng = SZLENG;
+int inqmask = M(TYLONG)|M(TYLOGICAL);
+int wordalign = NO;
+static int skipC, skipversion;
+char *filename0, *parens;
+int Castargs = 1;
+static int typedefs = 0;
+int chars_per_wd, gflag, protostatus;
+int infertypes = 1;
+char used_rets[TYSUBR+1];
+extern char *tmpdir;
+
+#define f2c_entry(swit,count,type,store,size) \
+ p_entry ("-", swit, 0, count, type, store, size)
+
+static arg_info table[] = {
+ f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
+ f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
+ f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
+ f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
+ f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
+ f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
+ f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
+ f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
+ f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
+ f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
+ f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
+ f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
+ f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
+ f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
+ f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
+ f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
+ f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
+ f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
+ f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
+ f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
+ f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
+ f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
+ f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
+ f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
+ f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
+ f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
+ f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
+ f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
+ f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
+ f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
+ f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
+ f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
+ f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
+ f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
+ f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
+ f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
+ f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
+ f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
+ f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
+ f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
+ f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
+
+ /* options omitted from man pages */
+
+ /* -ev ==> implement equivalence with initialized pointers */
+ f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
+
+ /* -!it used to be the default when -it was more agressive */
+
+ f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
+
+ /* -Pd is similar to -P, but omits :ref: lines */
+ f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
+
+ /* -t ==> emit typedefs (under -A or -C++) for procedure
+ argument types used. This is meant for netlib's
+ f2c service, so -A and -C++ will work with older
+ versions of f2c.h
+ */
+ f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
+
+ /* -!V ==> omit version msg (to facilitate using diff in
+ regression testing)
+ */
+ f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
+
+}; /* table */
+
+extern char *c_functions; /* "c_functions" */
+extern char *coutput; /* "c_output" */
+extern char *initfname; /* "raw_data" */
+extern char *blkdfname; /* "block_data" */
+extern char *p1_file; /* "p1_file" */
+extern char *p1_bakfile; /* "p1_file.BAK" */
+extern char *sortfname; /* "init_file" */
+static char *proto_fname; /* "proto_file" */
+FILE *protofile;
+
+extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
+extern char *c_name();
+
+
+set_externs ()
+{
+/* Adjust the global flags according to the command line parameters */
+
+ if (chars_per_wd > 0) {
+ typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
+ typesize[TYLOGICAL] = chars_per_wd;
+ typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
+ typesize[TYDCOMPLEX] = chars_per_wd << 2;
+ typesize[TYSHORT] = chars_per_wd >> 1;
+ typesize[TYCILIST] = 5*chars_per_wd;
+ typesize[TYICILIST] = 6*chars_per_wd;
+ typesize[TYOLIST] = 9*chars_per_wd;
+ typesize[TYCLLIST] = 3*chars_per_wd;
+ typesize[TYALIST] = 2*chars_per_wd;
+ typesize[TYINLIST] = 26*chars_per_wd;
+ }
+
+ if (wordalign)
+ typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
+ if (!tyioint) {
+ tyioint = TYSHORT;
+ szleng = typesize[TYSHORT];
+ def_i2 = "#define f2c_i2 1\n";
+ inqmask = M(TYSHORT)|M(TYLOGICAL);
+ goto checklong;
+ }
+ else
+ szleng = typesize[TYLONG];
+ if (useshortints) {
+ inqmask = M(TYLONG);
+ checklong:
+ protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
+ typesize[TYLOGICAL] = typesize[TYSHORT];
+ casttypes[TYLOGICAL] = "K_fp";
+ if (uselongints)
+ err ("Can't use both long and short ints");
+ else
+ tyint = tylogical = TYSHORT;
+ }
+ else if (uselongints)
+ tyint = TYLONG;
+
+ if (no66flag)
+ noextflag = no66flag;
+ if (noextflag)
+ zflag = 0;
+
+ if (r8flag) {
+ tyreal = TYDREAL;
+ r8fix();
+ }
+ if (forcedouble) {
+ protorettypes[TYREAL] = "E_f";
+ casttypes[TYREAL] = "E_fp";
+ }
+
+ if (maxregvar > MAXREGVAR) {
+ warni("-O%d: too many register variables", maxregvar);
+ maxregvar = MAXREGVAR;
+ } /* if maxregvar > MAXREGVAR */
+
+/* Check the list of input files */
+
+ {
+ int bad, i, cur_max = Max_ftn_files;
+
+ for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
+ if (ftn_files[i][0] == '-') {
+ errstr ("Invalid flag '%s'", ftn_files[i]);
+ bad++;
+ }
+ if (bad)
+ exit(1);
+
+ } /* block */
+} /* set_externs */
+
+
+ static int
+comm2dcl()
+{
+ Extsym *ext;
+ if (ext1comm)
+ for(ext = extsymtab; ext < nextext; ext++)
+ if (ext->extstg == STGCOMMON && !ext->extinit)
+ return ext1comm;
+ return 0;
+ }
+
+ static void
+write_typedefs(outfile)
+ FILE *outfile;
+{
+ register int i;
+ register char *s, *p = 0;
+ static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
+ static char stl[4] = { 'E', 'C', 'Z', 'H' };
+
+ for(i = 0; i <= TYSUBR; i++)
+ if (s = usedcasts[i]) {
+ if (!p) {
+ p = Ansi == 1 ? "()" : "(...)";
+ nice_printf(outfile,
+ "/* Types for casting procedure arguments: */\
+\n\n#ifndef F2C_proc_par_types\n");
+ if (i == 0) {
+ nice_printf(outfile,
+ "typedef int /* Unknown procedure type */ (*%s)%s;\n",
+ s, p);
+ continue;
+ }
+ }
+ nice_printf(outfile, "typedef %s (*%s)%s;\n",
+ c_type_decl(i,1), s, p);
+ }
+ for(i = !forcedouble; i < 4; i++)
+ if (used_rets[st[i]])
+ nice_printf(outfile,
+ "typedef %s %c_f; /* %s function */\n",
+ p = i ? "VOID" : "doublereal",
+ stl[i], ftn_types[st[i]]);
+ if (p)
+ nice_printf(outfile, "#endif\n\n");
+ }
+
+ static void
+commonprotos(outfile)
+ register FILE *outfile;
+{
+ register Extsym *e, *ee;
+ register Argtypes *at;
+ Atype *a, *ae;
+ int k;
+ extern int proc_protochanges;
+
+ if (!outfile)
+ return;
+ for (e = extsymtab, ee = nextext; e < ee; e++)
+ if (e->extstg == STGCOMMON && e->allextp)
+ nice_printf(outfile, "/* comlen %s %ld */\n",
+ e->cextname, e->maxleng);
+ if (Castargs < 3)
+ return;
+
+ /* -Pr: special comments conveying current knowledge
+ of external references */
+
+ k = proc_protochanges;
+ for (e = extsymtab, ee = nextext; e < ee; e++)
+ if (e->extstg == STGEXT
+ && e->cextname != e->fextname) /* not a library function */
+ if (at = e->arginfo) {
+ if ((!e->extinit || at->changes & 1)
+ /* not defined here or
+ changed since definition */
+ && at->nargs >= 0) {
+ nice_printf(outfile, "/*:ref: %s %d %d",
+ e->cextname, e->extype, at->nargs);
+ a = at->atypes;
+ for(ae = a + at->nargs; a < ae; a++)
+ nice_printf(outfile, " %d", a->type);
+ nice_printf(outfile, " */\n");
+ if (at->changes & 1)
+ k++;
+ }
+ }
+ else if (e->extype)
+ /* typyed external, never invoked */
+ nice_printf(outfile, "/*:ref: %s %d :*/\n",
+ e->cextname, e->extype);
+ if (k) {
+ nice_printf(outfile,
+ "/* Rerunning f2c -P may change prototypes or declarations. */\n");
+ if (nerr)
+ return;
+ if (protostatus)
+ done(4);
+ if (protofile != stdout) {
+ fprintf(diagfile,
+ "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
+ filename0, proto_fname);
+ fflush(diagfile);
+ }
+ }
+ }
+
+ int retcode = 0;
+
+main(argc, argv)
+int argc;
+char **argv;
+{
+ int c2d, k;
+ FILE *c_output;
+ char *filename, *cdfilename;
+ static char stderrbuf[BUFSIZ];
+ extern void def_commons();
+ extern char **dfltproc, *dflt1proc[];
+
+ diagfile = stderr;
+ setbuf(stderr, stderrbuf); /* arrange for fast error msgs */
+
+ Max_ftn_files = argc - 1;
+ ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
+
+ parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
+ ftn_files, Max_ftn_files);
+ if (!can_include && ext1comm == 2)
+ ext1comm = 1;
+ if (ext1comm && !extcomm)
+ extcomm = 2;
+ if (protostatus)
+ Castargs = 3;
+ else if (Castargs == 1 && !Ansi)
+ Castargs = 0;
+ if (Castargs >= 2 && !Ansi)
+ Ansi = 1;
+
+ if (!Ansi)
+ parens = "()";
+ else if (!Castargs)
+ parens = Ansi == 1 ? "()" : "(...)";
+ else
+ dfltproc = dflt1proc;
+
+ set_externs();
+ fileinit();
+ read_Pfiles(ftn_files);
+
+ for(k = 1; ftn_files[k]; k++)
+ if (dofork())
+ break;
+ filename0 = filename = ftn_files[current_ftn_file = k - 1];
+
+ set_tmp_names();
+ sigcatch();
+
+ c_file = opf(c_functions, textwrite);
+ pass1_file=opf(p1_file, binwrite);
+ initkey();
+ if (filename && *filename) {
+ if (debugflag != 1) {
+ coutput = c_name(filename,'c');
+ if (Castargs >= 2)
+ proto_fname = c_name(filename,'P');
+ }
+ cdfilename = coutput;
+ if (Castargs >= 2
+ && !(protofile = fopen(proto_fname, textwrite)))
+ fatalstr("Can't open %.84s\n", proto_fname);
+ }
+ else {
+ filename = "";
+ cdfilename = "f2c_out.c";
+ c_output = stdout;
+ coutput = 0;
+ if (Castargs >= 2) {
+ protofile = stdout;
+ if (!skipC)
+ printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
+ }
+ }
+
+ if(inilex( copys(filename) ))
+ done(1);
+ if (filename0) {
+ fprintf(diagfile, "%s:\n", filename);
+ fflush(diagfile);
+ }
+
+ procinit();
+ if(k = yyparse())
+ {
+ fprintf(diagfile, "Bad parse, return code %d\n", k);
+ done(1);
+ }
+
+ commonprotos(protofile);
+ if (protofile == stdout && !skipC)
+ printf("#endif\n\n");
+
+ if(nerr)
+ done(1);
+
+ if (skipC)
+ goto C_skipped;
+
+ if (filename0
+ && (c_output = fopen (coutput, textwrite)) == (FILE *) NULL)
+ fatalstr("can't open %.86s", coutput);
+
+
+/* Write out the declarations which are global to this file */
+
+ if ((c2d = comm2dcl()) == 1)
+ nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
+/* Split this into several files by piping it through\n\n\
+sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
+ */\n\
+/*<<</dev/null>>>*/\n\
+/*>>>'%s'<<<*/\n", cdfilename);
+ if (!skipversion) {
+ nice_printf (c_output, "/* %s -- translated by f2c ", filename);
+ nice_printf (c_output, "(version of %s).\n", F2C_version);
+ nice_printf (c_output,
+ " You must link the resulting object file with the libraries:\n\
+ -lF77 -lI77 -lm -lc (in that order)\n*/\n\n");
+ }
+ if (Ansi == 2)
+ nice_printf(c_output,
+ "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
+ nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
+ if (Castargs && typedefs)
+ write_typedefs(c_output);
+ nice_printf (c_file, "\n");
+ fclose (c_file);
+ c_file = c_output; /* HACK to get the next indenting
+ to work */
+ wr_common_decls (c_output);
+ if (blkdfile)
+ list_init_data(&blkdfile, blkdfname, c_output);
+ wr_globals (c_output);
+ if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
+ Fatal("main - couldn't reopen c_functions");
+ ffilecopy (c_file, c_output);
+ if (*main_alias) {
+ nice_printf (c_output, "/* Main program alias */ ");
+ nice_printf (c_output, "int %s () { MAIN__ (); }\n",
+ main_alias);
+ }
+ if (Ansi == 2)
+ nice_printf(c_output,
+ "#ifdef __cplusplus\n\t}\n#endif\n");
+ if (c2d) {
+ if (c2d == 1)
+ fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
+ else
+ fclose(c_output);
+ def_commons(c_output);
+ }
+ if (c2d != 2)
+ fclose (c_output);
+
+ C_skipped:
+ if(parstate != OUTSIDE)
+ {
+ warn("missing END statement");
+ endproc();
+ }
+ done(nerr ? 1 : 0);
+}
+
+
+FILEP opf(fn, mode)
+char *fn, *mode;
+{
+ FILEP fp;
+ if( fp = fopen(fn, mode) )
+ return(fp);
+
+ fatalstr("cannot open intermediate file %s", fn);
+ /* NOT REACHED */ return 0;
+}
+
+
+clf(p, what, quit)
+ FILEP *p;
+ char *what;
+ int quit;
+{
+ if(p!=NULL && *p!=NULL && *p!=stdout)
+ {
+ if(ferror(*p)) {
+ fprintf(stderr, "I/O error on %s\n", what);
+ if (quit)
+ done(3);
+ retcode = 3;
+ }
+ fclose(*p);
+ }
+ *p = NULL;
+}
+
+
+done(k)
+int k;
+{
+ clf(&initfile, "initfile", 0);
+ clf(&c_file, "c_file", 0);
+ clf(&pass1_file, "pass1_file", 0);
+ Un_link_all(k);
+ exit(k|retcode);
+}
--- /dev/null
+CFLAGS = -O
+CC = cc
+
+YFLAGS = -Sr600 # SCO
+#YFLAGS = # SUN
+
+OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
+ expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
+ output.o p1output.o pread.o put.o putpcc.o vax.o formatd.o \
+ safstrcp.o parsearg.o nicepr.o cds.o sysdep.o version.o
+OBJECTS = $(OBJECTSd) malloc.o
+
+target : f2c
+
+f2c.exe: $(OBJECTS)
+ gcc @link.lnk -o f2c.out
+ strip f2c.out
+ aout2exe f2c.out
+ del f2c.out
+
+f2c: $(OBJECTS)
+ $(CC) $(CFLAGS) $(LDFLAGS) $(OBJECTS) -o f2c
+ strip f2c
+ mv f2c $(HOME)/bin
+
+#gram.c : gram.hd gram.dcl gram.exp gram.exe gram.io defs.h tokdefs.h
+# ( sed <tokdefs.h "s/#define/%token/" ;\
+# cat gram.hd gram.dcl gram.exp gram.exe gram.io ) >gram.in
+# $(YACC) $(YFLAGS) gram.in
+# echo "(expect 4 shift/reduce)"
+# sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
+# rm -f gram.in y.tab.c
+
+#tokdefs.h : tokens
+# grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+$(OBJECTSd): defs.h
+defs.h: ftypes.h defines.h machdefs.h
+exec.o: p1defs.h names.h
+expr.o: output.h nicepr.h names.h
+format.o: p1defs.h format.h output.h nicepr.h names.h iob.h
+formatd.o: format.h output.h nicepr.h names.h
+gram.o: p1defs.h
+init.o: output.h nicepr.h iob.h
+intr.o: names.h
+io.o: names.h iob.h
+lex.o : tokdefs.h p1defs.h
+main.o: parse.h usignal.h
+mem.o: iob.h
+names.o: iob.h names.h output.h nicepr.h
+nicepr.o: defs.h names.h output.h nicepr.h
+output.o: output.h nicepr.h names.h
+p1output.o: p1defs.h output.h nicepr.h names.h
+parsearg.o: parse.h
+proc.o: tokdefs.h names.h nicepr.h output.h p1defs.h
+put.o: names.h pccdefs.h p1defs.h
+putpcc.o: names.h
+vax.o: defs.h output.h pccdefs.h
+output.h: nicepr.h
+defs.h: ftypes.h defines.h machdefs.h
+put.o putpcc.o: pccdefs.h
+
+f2c.t: f2c.1t
+ troff -man f2c.1t >f2c.t
+
+f2c.1: f2c.1t
+ nroff -man f2c.1t | col -b | uniq >f2c.1
+
+clean:
+ -rm -f *.o
+CFLAGS = -O
--- /dev/null
+CFLAGS = -O
+CC = cc
+
+YFLAGS = -Sr600 # SCO
+#YFLAGS = # SUN
+
+OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
+ expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
+ output.o p1output.o pread.o put.o putpcc.o vax.o formatd.o \
+ safstrcp.o parsearg.o nicepr.o cds.o sysdep.o version.o
+OBJECTS = $(OBJECTSd) malloc.o
+
+target : f2c
+
+f2c.exe: $(OBJECTS)
+ gcc @link.lnk -o f2c.out
+ strip f2c.out
+ aout2exe f2c.out
+ del f2c.out
+
+f2c: $(OBJECTS)
+ $(CC) $(CFLAGS) $(LDFLAGS) $(OBJECTS) -o f2c
+ strip f2c
+ mv f2c $(HOME)/bin
+
+#gram.c : gram.hd gram.dcl gram.exp gram.exe gram.io defs.h tokdefs.h
+# ( sed <tokdefs.h "s/#define/%token/" ;\
+# cat gram.hd gram.dcl gram.exp gram.exe gram.io ) >gram.in
+# $(YACC) $(YFLAGS) gram.in
+# echo "(expect 4 shift/reduce)"
+# sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
+# rm -f gram.in y.tab.c
+
+#tokdefs.h : tokens
+# grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+$(OBJECTSd): defs.h
+defs.h: ftypes.h defines.h machdefs.h
+exec.o: p1defs.h names.h
+expr.o: output.h nicepr.h names.h
+format.o: p1defs.h format.h output.h nicepr.h names.h iob.h
+formatd.o: format.h output.h nicepr.h names.h
+gram.o: p1defs.h
+init.o: output.h nicepr.h iob.h
+intr.o: names.h
+io.o: names.h iob.h
+lex.o : tokdefs.h p1defs.h
+main.o: parse.h usignal.h
+mem.o: iob.h
+names.o: iob.h names.h output.h nicepr.h
+nicepr.o: defs.h names.h output.h nicepr.h
+output.o: output.h nicepr.h names.h
+p1output.o: p1defs.h output.h nicepr.h names.h
+parsearg.o: parse.h
+proc.o: tokdefs.h names.h nicepr.h output.h p1defs.h
+put.o: names.h pccdefs.h p1defs.h
+putpcc.o: names.h
+vax.o: defs.h output.h pccdefs.h
+output.h: nicepr.h
+defs.h: ftypes.h defines.h machdefs.h
+put.o putpcc.o: pccdefs.h
+
+f2c.t: f2c.1t
+ troff -man f2c.1t >f2c.t
+
+f2c.1: f2c.1t
+ nroff -man f2c.1t | col -b | uniq >f2c.1
+
+clean:
+ -rm -f *.o
+CFLAGS = -O
--- /dev/null
+CFLAGS = -O
+CC = cc
+
+YFLAGS = -Sr600 # SCO
+#YFLAGS = # SUN
+
+OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
+ expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
+ output.o p1output.o pread.o put.o putpcc.o vax.o formatd.o \
+ safstrcp.o parsearg.o nicepr.o cds.o sysdep.o version.o
+OBJECTS = $(OBJECTSd) malloc.o
+
+target : f2c
+
+f2c.exe: $(OBJECTS)
+ gcc @link.lnk -o f2c.out
+ strip f2c.out
+ aout2exe f2c.out
+ del f2c.out
+
+f2c: $(OBJECTS)
+ $(CC) $(CFLAGS) $(LDFLAGS) $(OBJECTS) -o f2c
+ strip f2c
+ mv f2c $(HOME)/bin
+
+#gram.c : gram.hd gram.dcl gram.exp gram.exe gram.io defs.h tokdefs.h
+# ( sed <tokdefs.h "s/#define/%token/" ;\
+# cat gram.hd gram.dcl gram.exp gram.exe gram.io ) >gram.in
+# $(YACC) $(YFLAGS) gram.in
+# echo "(expect 4 shift/reduce)"
+# sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
+# rm -f gram.in y.tab.c
+
+#tokdefs.h : tokens
+# grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+$(OBJECTSd): defs.h
+defs.h: ftypes.h defines.h machdefs.h
+exec.o: p1defs.h names.h
+expr.o: output.h nicepr.h names.h
+format.o: p1defs.h format.h output.h nicepr.h names.h iob.h
+formatd.o: format.h output.h nicepr.h names.h
+gram.o: p1defs.h
+init.o: output.h nicepr.h iob.h
+intr.o: names.h
+io.o: names.h iob.h
+lex.o : tokdefs.h p1defs.h
+main.o: parse.h usignal.h
+mem.o: iob.h
+names.o: iob.h names.h output.h nicepr.h
+nicepr.o: defs.h names.h output.h nicepr.h
+output.o: output.h nicepr.h names.h
+p1output.o: p1defs.h output.h nicepr.h names.h
+parsearg.o: parse.h
+proc.o: tokdefs.h names.h nicepr.h output.h p1defs.h
+put.o: names.h pccdefs.h p1defs.h
+putpcc.o: names.h
+vax.o: defs.h output.h pccdefs.h
+output.h: nicepr.h
+defs.h: ftypes.h defines.h machdefs.h
+put.o putpcc.o: pccdefs.h
+
+f2c.t: f2c.1t
+ troff -man f2c.1t >f2c.t
+
+f2c.1: f2c.1t
+ nroff -man f2c.1t | col -b | uniq >f2c.1
+
+clean:
+ -rm -f *.o
+CFLAGS = -O
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#ifndef CRAY
+#define STACKMIN 512
+#define MINBLK (2*sizeof(struct mem) + 16)
+#define MSTUFF _malloc_stuff_
+#define F MSTUFF.free
+#define B MSTUFF.busy
+#define SBGULP 8192
+void *memcpy();
+
+struct mem {
+ struct mem *next;
+ unsigned len;
+ };
+
+struct {
+ struct mem *free;
+ char *busy;
+ } MSTUFF;
+
+char *
+malloc(size)
+register unsigned size;
+{
+ struct mem *p, *q, *r, *s;
+ unsigned k, m;
+ extern char *sbrk();
+ char *top, *top1;
+
+ size = (size+7) & ~7;
+ r = (struct mem *) &F;
+ for (p = F, q = 0; p; r = p, p = p->next) {
+ if ((k = p->len) >= size && (!q || m > k)) { m = k; q = p; s = r; }
+ }
+ if (q) {
+ if (q->len - size >= MINBLK) { /* split block */
+ p = (struct mem *) (((char *) (q+1)) + size);
+ p->next = q->next;
+ p->len = q->len - size - sizeof(struct mem);
+ s->next = p;
+ q->len = size;
+ }
+ else s->next = q->next;
+ }
+ else {
+ top = B ? B : sbrk(0);
+ if (F && (char *)(F+1) + F->len == B)
+ { q = F; F = F->next; }
+ else q = (struct mem *) top;
+ top1 = (char *)(q+1) + size;
+ if (top1 > top) {
+ if (sbrk(top1-top+SBGULP) == (char *) -1)
+ return 0;
+ r = (struct mem *)top1;
+ r->len = SBGULP - sizeof(struct mem);
+ r->next = F;
+ F = r;
+ top1 += SBGULP;
+ }
+ q->len = size;
+ B = top1;
+ }
+ return (char *) (q+1);
+ }
+
+free(f)
+char *f;
+{
+ struct mem *p, *q, *r;
+ char *pn, *qn;
+
+ if (!f) return;
+ q = (struct mem *) (f - sizeof(struct mem));
+ qn = f + q->len;
+ for (p = F, r = (struct mem *) &F; ; r = p, p = p->next) {
+ if (qn == (char *) p) {
+ q->len += p->len + sizeof(struct mem);
+ p = p->next;
+ }
+ pn = p ? ((char *) (p+1)) + p->len : 0;
+ if (pn == (char *) q) {
+ p->len += sizeof(struct mem) + q->len;
+ q->len = 0;
+ q->next = p;
+ r->next = p;
+ break;
+ }
+ if (pn < (char *) q) {
+ r->next = q;
+ q->next = p;
+ break;
+ }
+ }
+ }
+
+char *
+realloc(f, size)
+char *f;
+unsigned size;
+{
+ struct mem *p;
+ char *q, *f1;
+ unsigned s1;
+
+ if (!f) return malloc(size);
+ p = (struct mem *) (f - sizeof(struct mem));
+ s1 = p->len;
+ free(f);
+ if (s1 > size) s1 = size + 7 & ~7;
+ if (!p->len) {
+ f1 = (char *)(p->next + 1);
+ memcpy(f1, f, s1);
+ f = f1;
+ }
+ q = malloc(size);
+ if (q && q != f)
+ memcpy(q, f, s1);
+ return q;
+ }
+#endif
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include <stdio.h>
+#include "iob.h"
+#include "string.h"
+
+#define MEMBSIZE 32000
+#define GMEMBSIZE 16000
+
+ extern char *Alloc();
+ extern void exit();
+
+ char *
+gmem(n, round)
+ int n, round;
+{
+ static char *last, *next;
+ char *rv;
+ if (round)
+ next =
+#ifdef CRAY
+ (long)next & 0xe000000000000000
+ ? (char *)(((long)next & 0x1fffffffffffffff) + 1)
+ : next;
+#else
+ (char *)(((long)next + sizeof(char *)-1)
+ & ~(sizeof(char *)-1));
+#endif
+ rv = next;
+ if ((next += n) > last) {
+ rv = Alloc(n + GMEMBSIZE);
+
+ next = rv + n;
+ last = next + GMEMBSIZE;
+ }
+ return rv;
+ }
+
+ struct memblock {
+ struct memblock *next;
+ char buf[MEMBSIZE];
+ };
+ typedef struct memblock memblock;
+
+ static memblock mem0;
+ memblock *curmemblock = &mem0, *firstmemblock = &mem0;
+
+ char *mem_first = mem0.buf,
+ *mem_next = mem0.buf,
+ *mem_last = mem0.buf + sizeof(mem0.buf),
+ *mem0_last = mem0.buf + sizeof(mem0.buf);
+
+ char *
+mem(n, round)
+ int n, round;
+{
+ memblock *b;
+ register char *rv, *s;
+
+ if (round)
+ mem_next =
+#ifdef CRAY
+ (long)mem_next & 0xe000000000000000
+ ? (char *)(((long)mem_next & 0x1fffffffffffffff) + 1)
+ : mem_next;
+#else
+ (char *)(((long)mem_next + sizeof(char *)-1)
+ & ~(sizeof(char *)-1));
+#endif
+ rv = mem_next;
+ s = rv + n;
+ if (s >= mem_last) {
+ if (n > sizeof(mem0.buf)) {
+ fprintf(stderr, "mem(%d) failure!\n", n);
+ exit(1);
+ }
+ if (!(b = curmemblock->next)) {
+ b = (memblock *)Alloc(sizeof(memblock));
+ curmemblock->next = b;
+ b->next = 0;
+ }
+ curmemblock = b;
+ rv = b->buf;
+ mem_last = rv + sizeof(b->buf);
+ s = rv + n;
+ }
+ mem_next = s;
+ return rv;
+ }
+
+ char *
+tostring(s,n)
+ register char *s;
+ int n;
+{
+ register char *s1, *se, **sf;
+ extern char *str_fmt[];
+ char *rv, *s0, *s2;
+ register int k = n + 2, t;
+
+ sf = str_fmt;
+ sf['%'] = "%";
+ s0 = s;
+ se = s + n;
+ for(; s < se; s++) {
+ t = *(unsigned char *)s;
+ s1 = sf[t < 127 ? t : 127];
+ while(*++s1)
+ k++;
+ }
+ rv = s1 = mem(k,0);
+ *s1++ = '"';
+ for(s = s0; s < se; s++) {
+ t = *(unsigned char *)s;
+ if (t < 127)
+ for(s2 = sf[t]; *s1 = *s2++; s1++);
+ else {
+ sprintf(s1, sf[127], t);
+ s1 += strlen(s1);
+ }
+ }
+ *s1 = 0;
+ sf['%'] = "%%";
+ return rv;
+ }
+
+ char *
+cpstring(s)
+ register char *s;
+{
+ return strcpy(mem(strlen(s)+1,0), s);
+ }
+
+ void
+new_iob_data(ios, name)
+ register io_setup *ios;
+ char *name;
+{
+ register iob_data *iod;
+ register char **s, **se;
+
+ iod = (iob_data *)
+ mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1);
+ iod->next = iob_list;
+ iob_list = iod;
+ iod->type = ios->fields[0];
+ iod->name = cpstring(name);
+ s = iod->fields;
+ se = s + ios->nelt;
+ while(s < se)
+ *s++ = "0";
+ *s = 0;
+ }
+
+ char *
+string_num(pfx, n)
+ char *pfx;
+ long n;
+{
+ char buf[32];
+ sprintf(buf, "%s%ld", pfx, n);
+ /* can't trust return type of sprintf -- BSD gets it wrong */
+ return strcpy(mem(strlen(buf)+1,0), buf);
+ }
+
+static defines *define_list;
+
+ void
+def_start(outfile, s1, s2, post)
+ FILE *outfile;
+ char *s1, *s2, *post;
+{
+ defines *d;
+ int n, n1;
+
+ n = n1 = strlen(s1);
+ if (s2)
+ n += strlen(s2);
+ d = (defines *)mem(sizeof(defines)+n, 1);
+ d->next = define_list;
+ define_list = d;
+ strcpy(d->defname, s1);
+ if (s2)
+ strcpy(d->defname + n1, s2);
+ nice_printf(outfile, "#define %s %s", d->defname, post);
+ }
+
+ void
+other_undefs(outfile)
+ FILE *outfile;
+{
+ defines *d;
+ if (d = define_list) {
+ define_list = 0;
+ nice_printf(outfile, "\n");
+ do
+ nice_printf(outfile, "#undef %s\n", d->defname);
+ while(d = d->next);
+ nice_printf(outfile, "\n");
+ }
+ }
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* This is for the benefit of people whose systems don't provide
+ * memset, memcpy, and memcmp. If yours is such a system, adjust
+ * the makefile by adding memset.o to the "OBJECTS =" assignment.
+ * WARNING: the memcpy below is adequate for f2c, but is not a
+ * general memcpy routine (which must correctly handle overlapping
+ * fields).
+ */
+
+ int
+memcmp(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+ register char *se;
+
+ for(se = s1 + n; s1 < se; s1++, s2++)
+ if (*s1 != *s2)
+ return *s1 - *s2;
+ return 0;
+ }
+
+ char *
+memcpy(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+ register char *s0 = s1, *se = s1 + n;
+
+ while(s1 < se)
+ *s1++ = *s2++;
+ return s0;
+ }
+
+memset(s, c, n)
+ register char *s;
+ register int c;
+ int n;
+{
+ register char *se = s + n;
+
+ while(s < se)
+ *s++ = c;
+ }
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+int oneof_stg (name, stg, mask)
+ Namep name;
+ int stg, mask;
+{
+ if (stg == STGCOMMON && name) {
+ if ((mask & M(STGEQUIV)))
+ return name->vcommequiv;
+ if ((mask & M(STGCOMMON)))
+ return !name->vcommequiv;
+ }
+ return ONEOF(stg, mask);
+ }
+
+
+/* op_assign -- given a binary opcode, return the associated assignment
+ operator */
+
+int op_assign (opcode)
+int opcode;
+{
+ int retval = -1;
+
+ switch (opcode) {
+ case OPPLUS: retval = OPPLUSEQ; break;
+ case OPMINUS: retval = OPMINUSEQ; break;
+ case OPSTAR: retval = OPSTAREQ; break;
+ case OPSLASH: retval = OPSLASHEQ; break;
+ case OPMOD: retval = OPMODEQ; break;
+ case OPLSHIFT: retval = OPLSHIFTEQ; break;
+ case OPRSHIFT: retval = OPRSHIFTEQ; break;
+ case OPBITAND: retval = OPBITANDEQ; break;
+ case OPBITXOR: retval = OPBITXOREQ; break;
+ case OPBITOR: retval = OPBITOREQ; break;
+ default:
+ erri ("op_assign: bad opcode '%d'", opcode);
+ break;
+ } /* switch */
+
+ return retval;
+} /* op_assign */
+
+
+ char *
+Alloc(n) /* error-checking version of malloc */
+ /* ckalloc initializes memory to 0; Alloc does not */
+ int n;
+{
+ extern char *malloc();
+ char errbuf[32];
+ register char *rv;
+
+ rv = malloc(n);
+ if (!rv) {
+ sprintf(errbuf, "malloc(%d) failure!", n);
+ Fatal(errbuf);
+ }
+ return rv;
+ }
+
+
+cpn(n, a, b)
+register int n;
+register char *a, *b;
+{
+ while(--n >= 0)
+ *b++ = *a++;
+}
+
+
+
+eqn(n, a, b)
+register int n;
+register char *a, *b;
+{
+ while(--n >= 0)
+ if(*a++ != *b++)
+ return(NO);
+ return(YES);
+}
+
+
+
+
+
+
+
+cmpstr(a, b, la, lb) /* compare two strings */
+register char *a, *b;
+ftnint la, lb;
+{
+ register char *aend, *bend;
+ aend = a + la;
+ bend = b + lb;
+
+
+ if(la <= lb)
+ {
+ while(a < aend)
+ if(*a != *b)
+ return( *a - *b );
+ else
+ {
+ ++a;
+ ++b;
+ }
+
+ while(b < bend)
+ if(*b != ' ')
+ return(' ' - *b);
+ else
+ ++b;
+ }
+
+ else
+ {
+ while(b < bend)
+ if(*a != *b)
+ return( *a - *b );
+ else
+ {
+ ++a;
+ ++b;
+ }
+ while(a < aend)
+ if(*a != ' ')
+ return(*a - ' ');
+ else
+ ++a;
+ }
+ return(0);
+}
+
+
+/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
+
+chainp hookup(x,y)
+register chainp x, y;
+{
+ register chainp p;
+
+ if(x == NULL)
+ return(y);
+
+ for(p = x ; p->nextp ; p = p->nextp)
+ ;
+ p->nextp = y;
+ return(x);
+}
+
+
+
+struct Listblock *mklist(p)
+chainp p;
+{
+ register struct Listblock *q;
+
+ q = ALLOC(Listblock);
+ q->tag = TLIST;
+ q->listp = p;
+ return(q);
+}
+
+
+chainp mkchain(p,q)
+register char * p;
+register chainp q;
+{
+ register chainp r;
+
+ if(chains)
+ {
+ r = chains;
+ chains = chains->nextp;
+ }
+ else
+ r = ALLOC(Chain);
+
+ r->datap = p;
+ r->nextp = q;
+ return(r);
+}
+
+ chainp
+revchain(next)
+ register chainp next;
+{
+ register chainp p, prev = 0;
+
+ while(p = next) {
+ next = p->nextp;
+ p->nextp = prev;
+ prev = p;
+ }
+ return prev;
+ }
+
+
+/* addunder -- turn a cvarname into an external name */
+/* The cvarname may already end in _ (to avoid C keywords); */
+/* if not, it has room for appending an _. */
+
+ char *
+addunder(s)
+ register char *s;
+{
+ register int c, i;
+ char *s0 = s;
+
+ i = 0;
+ while(c = *s++)
+ if (c == '_')
+ i++;
+ else
+ i = 0;
+ if (!i) {
+ *s-- = 0;
+ *s = '_';
+ }
+ return( s0 );
+ }
+
+
+/* copyn -- return a new copy of the input Fortran-string */
+
+char *copyn(n, s)
+register int n;
+register char *s;
+{
+ register char *p, *q;
+
+ p = q = (char *) Alloc(n);
+ while(--n >= 0)
+ *q++ = *s++;
+ return(p);
+}
+
+
+
+/* copys -- return a new copy of the input C-string */
+
+char *copys(s)
+char *s;
+{
+ return( copyn( strlen(s)+1 , s) );
+}
+
+
+
+/* convci -- Convert Fortran-string to integer; assumes that input is a
+ legal number, with no trailing blanks */
+
+ftnint convci(n, s)
+register int n;
+register char *s;
+{
+ ftnint sum;
+ sum = 0;
+ while(n-- > 0)
+ sum = 10*sum + (*s++ - '0');
+ return(sum);
+}
+
+/* convic - Convert Integer constant to string */
+
+char *convic(n)
+ftnint n;
+{
+ static char s[20];
+ register char *t;
+
+ s[19] = '\0';
+ t = s+19;
+
+ do {
+ *--t = '0' + n%10;
+ n /= 10;
+ } while(n > 0);
+
+ return(t);
+}
+
+
+
+/* mkname -- add a new identifier to the environment, including the closed
+ hash table. There is a BAD assumption that strlen (s) < VL */
+
+Namep mkname(s)
+register char *s;
+{
+ struct Hashentry *hp;
+ register Namep q;
+ register int c, hash, i;
+ register char *t;
+ char *s0;
+ char errbuf[64];
+
+ hash = i = 0;
+ s0 = s;
+ while(c = *s++) {
+ hash += c;
+ if (c == '_')
+ i = 1;
+ }
+ hash %= maxhash;
+
+/* Add the name to the closed hash table */
+
+ hp = hashtab + hash;
+
+ while(q = hp->varp)
+ if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
+ return(q);
+ else if(++hp >= lasthash)
+ hp = hashtab;
+
+ if(++nintnames >= maxhash-1)
+ many("names", 'n', maxhash); /* Fatal error */
+ hp->varp = q = ALLOC(Nameblock);
+ hp->hashval = hash;
+ q->tag = TNAME; /* TNAME means the tag type is NAME */
+ c = s - s0;
+ if (c > 7 && noextflag) {
+ sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
+ c > 36 ? "..." : "");
+ errext(errbuf);
+ }
+ q->fvarname = strcpy(mem(c,0), s0);
+ t = q->cvarname = mem(c + i + 1, 0);
+ s = s0;
+ /* add __ to the end of any name containing _ */
+ while(*t = *s++)
+ t++;
+ if (i) {
+ t[0] = t[1] = '_';
+ t[2] = 0;
+ }
+ else if (in_vector(s0) >= 0) {
+ t[0] = '_';
+ t[1] = 0;
+ }
+ return(q);
+}
+
+
+struct Labelblock *mklabel(l)
+ftnint l;
+{
+ register struct Labelblock *lp;
+
+ if(l <= 0)
+ return(NULL);
+
+ for(lp = labeltab ; lp < highlabtab ; ++lp)
+ if(lp->stateno == l)
+ return(lp);
+
+ if(++highlabtab > labtabend)
+ many("statement labels", 's', maxstno);
+
+ lp->stateno = l;
+ lp->labelno = newlabel();
+ lp->blklevel = 0;
+ lp->labused = NO;
+ lp->fmtlabused = NO;
+ lp->labdefined = NO;
+ lp->labinacc = NO;
+ lp->labtype = LABUNKNOWN;
+ lp->fmtstring = 0;
+ return(lp);
+}
+
+
+newlabel()
+{
+ return( ++lastlabno );
+}
+
+
+/* this label appears in a branch context */
+
+struct Labelblock *execlab(stateno)
+ftnint stateno;
+{
+ register struct Labelblock *lp;
+
+ if(lp = mklabel(stateno))
+ {
+ if(lp->labinacc)
+ warn1("illegal branch to inner block, statement label %s",
+ convic(stateno) );
+ else if(lp->labdefined == NO)
+ lp->blklevel = blklevel;
+ if(lp->labtype == LABFORMAT)
+ err("may not branch to a format");
+ else
+ lp->labtype = LABEXEC;
+ }
+ else
+ execerr("illegal label %s", convic(stateno));
+
+ return(lp);
+}
+
+
+/* find or put a name in the external symbol table */
+
+Extsym *mkext(f,s)
+char *f, *s;
+{
+ Extsym *p;
+
+ for(p = extsymtab ; p<nextext ; ++p)
+ if(!strcmp(s,p->cextname))
+ return( p );
+
+ if(nextext >= lastext)
+ many("external symbols", 'x', maxext);
+
+ nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
+ nextext->cextname = f == s
+ ? nextext->fextname
+ : strcpy(gmem(strlen(s)+1,0), s);
+ nextext->extstg = STGUNKNOWN;
+ nextext->extp = 0;
+ nextext->allextp = 0;
+ nextext->extleng = 0;
+ nextext->maxleng = 0;
+ nextext->extinit = 0;
+ nextext->curno = nextext->maxno = 0;
+ return( nextext++ );
+}
+
+
+Addrp builtin(t, s, dbi)
+int t, dbi;
+char *s;
+{
+ register Extsym *p;
+ register Addrp q;
+ extern chainp used_builtins;
+
+ p = mkext(s,s);
+ if(p->extstg == STGUNKNOWN)
+ p->extstg = STGEXT;
+ else if(p->extstg != STGEXT)
+ {
+ errstr("improper use of builtin %s", s);
+ return(0);
+ }
+
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ q->vtype = t;
+ q->vclass = CLPROC;
+ q->vstg = STGEXT;
+ q->memno = p - extsymtab;
+ q->dbl_builtin = dbi;
+
+/* A NULL pointer here tells you to use memno to check the external
+ symbol table */
+
+ q -> uname_tag = UNAM_EXTERN;
+
+/* Add to the list of used builtins */
+
+ if (dbi >= 0)
+ add_extern_to_list (q, &used_builtins);
+ return(q);
+}
+
+
+
+add_extern_to_list (addr, list_store)
+Addrp addr;
+chainp *list_store;
+{
+ chainp last = CHNULL;
+ chainp list;
+ int memno;
+
+ if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
+ return;
+
+ list = *list_store;
+ memno = addr -> memno;
+
+ for (;list; last = list, list = list -> nextp) {
+ Addrp this = (Addrp) (list -> datap);
+
+ if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
+ this -> memno == memno)
+ return;
+ } /* for */
+
+ if (*list_store == CHNULL)
+ *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
+ else
+ last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
+
+} /* add_extern_to_list */
+
+
+frchain(p)
+register chainp *p;
+{
+ register chainp q;
+
+ if(p==0 || *p==0)
+ return;
+
+ for(q = *p; q->nextp ; q = q->nextp)
+ ;
+ q->nextp = chains;
+ chains = *p;
+ *p = 0;
+}
+
+ void
+frexchain(p)
+ register chainp *p;
+{
+ register chainp q, r;
+
+ if (q = *p) {
+ for(;;q = r) {
+ frexpr((expptr)q->datap);
+ if (!(r = q->nextp))
+ break;
+ }
+ q->nextp = chains;
+ chains = *p;
+ *p = 0;
+ }
+ }
+
+
+tagptr cpblock(n,p)
+register int n;
+register char * p;
+{
+ register ptr q;
+
+ memcpy((char *)(q = ckalloc(n)), (char *)p, n);
+ return( (tagptr) q);
+}
+
+
+
+max(a,b)
+int a,b;
+{
+ return( a>b ? a : b);
+}
+
+
+ftnint lmax(a, b)
+ftnint a, b;
+{
+ return( a>b ? a : b);
+}
+
+ftnint lmin(a, b)
+ftnint a, b;
+{
+ return(a < b ? a : b);
+}
+
+
+
+
+maxtype(t1, t2)
+int t1, t2;
+{
+ int t;
+
+ t = max(t1, t2);
+ if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
+ t = TYDCOMPLEX;
+ return(t);
+}
+
+
+
+/* return log base 2 of n if n a power of 2; otherwise -1 */
+log_2(n)
+ftnint n;
+{
+ int k;
+
+ /* trick based on binary representation */
+
+ if(n<=0 || (n & (n-1))!=0)
+ return(-1);
+
+ for(k = 0 ; n >>= 1 ; ++k)
+ ;
+ return(k);
+}
+
+
+
+frrpl()
+{
+ struct Rplblock *rp;
+
+ while(rpllist)
+ {
+ rp = rpllist->rplnextp;
+ free( (charptr) rpllist);
+ rpllist = rp;
+ }
+}
+
+
+
+/* Call a Fortran function with an arbitrary list of arguments */
+
+int callk_kludge;
+
+expptr callk(type, name, args)
+int type;
+char *name;
+chainp args;
+{
+ register expptr p;
+
+ p = mkexpr(OPCALL,
+ (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
+ (expptr)args);
+ p->exprblock.vtype = type;
+ return(p);
+}
+
+
+
+expptr call4(type, name, arg1, arg2, arg3, arg4)
+int type;
+char *name;
+expptr arg1, arg2, arg3, arg4;
+{
+ struct Listblock *args;
+ args = mklist( mkchain((char *)arg1,
+ mkchain((char *)arg2,
+ mkchain((char *)arg3,
+ mkchain((char *)arg4, CHNULL)) ) ) );
+ return( callk(type, name, (chainp)args) );
+}
+
+
+
+
+expptr call3(type, name, arg1, arg2, arg3)
+int type;
+char *name;
+expptr arg1, arg2, arg3;
+{
+ struct Listblock *args;
+ args = mklist( mkchain((char *)arg1,
+ mkchain((char *)arg2,
+ mkchain((char *)arg3, CHNULL) ) ) );
+ return( callk(type, name, (chainp)args) );
+}
+
+
+
+
+
+expptr call2(type, name, arg1, arg2)
+int type;
+char *name;
+expptr arg1, arg2;
+{
+ struct Listblock *args;
+
+ args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
+ return( callk(type,name, (chainp)args) );
+}
+
+
+
+
+expptr call1(type, name, arg)
+int type;
+char *name;
+expptr arg;
+{
+ return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
+}
+
+
+expptr call0(type, name)
+int type;
+char *name;
+{
+ return( callk(type, name, CHNULL) );
+}
+
+
+
+struct Impldoblock *mkiodo(dospec, list)
+chainp dospec, list;
+{
+ register struct Impldoblock *q;
+
+ q = ALLOC(Impldoblock);
+ q->tag = TIMPLDO;
+ q->impdospec = dospec;
+ q->datalist = list;
+ return(q);
+}
+
+
+
+
+/* ckalloc -- Allocate 1 memory unit of size n, checking for out of
+ memory error */
+
+ptr ckalloc(n)
+register int n;
+{
+ register ptr p;
+ char *calloc();
+ if( p = (ptr)calloc(1, (unsigned) n) )
+ return(p);
+ fprintf(stderr, "failing to get %d bytes\n",n);
+ Fatal("out of memory");
+ /* NOT REACHED */ return 0;
+}
+
+
+
+isaddr(p)
+register expptr p;
+{
+ if(p->tag == TADDR)
+ return(YES);
+ if(p->tag == TEXPR)
+ switch(p->exprblock.opcode)
+ {
+ case OPCOMMA:
+ return( isaddr(p->exprblock.rightp) );
+
+ case OPASSIGN:
+ case OPASSIGNI:
+ case OPPLUSEQ:
+ case OPMINUSEQ:
+ case OPSLASHEQ:
+ case OPMODEQ:
+ case OPLSHIFTEQ:
+ case OPRSHIFTEQ:
+ case OPBITANDEQ:
+ case OPBITXOREQ:
+ case OPBITOREQ:
+ return( isaddr(p->exprblock.leftp) );
+ }
+ return(NO);
+}
+
+
+
+
+isstatic(p)
+register expptr p;
+{
+ if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
+ return(NO);
+
+ switch(p->tag)
+ {
+ case TCONST:
+ return(YES);
+
+ case TADDR:
+ if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
+ ISCONST(p->addrblock.memoffset))
+ return(YES);
+
+ default:
+ return(NO);
+ }
+}
+
+
+
+/* addressable -- return True iff it is a constant value, or can be
+ referenced by constant values */
+
+addressable(p)
+register expptr p;
+{
+ switch(p->tag)
+ {
+ case TCONST:
+ return(YES);
+
+ case TADDR:
+ return( addressable(p->addrblock.memoffset) );
+
+ default:
+ return(NO);
+ }
+}
+
+
+/* isnegative_const -- returns true if the constant is negative. Returns
+ false for imaginary and nonnumeric constants */
+
+int isnegative_const (cp)
+struct Constblock *cp;
+{
+ int retval;
+
+ if (cp == NULL)
+ return 0;
+
+ switch (cp -> vtype) {
+ case TYSHORT:
+ case TYLONG:
+ retval = cp -> Const.ci < 0;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ retval = cp->vstg ? *cp->Const.cds[0] == '-'
+ : cp->Const.cd[0] < 0.0;
+ break;
+ default:
+
+ retval = 0;
+ break;
+ } /* switch */
+
+ return retval;
+} /* isnegative_const */
+
+negate_const(cp)
+ Constp cp;
+{
+ if (cp == (struct Constblock *) NULL)
+ return;
+
+ switch (cp -> vtype) {
+ case TYSHORT:
+ case TYLONG:
+ cp -> Const.ci = - cp -> Const.ci;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ if (cp->vstg)
+ switch(*cp->Const.cds[1]) {
+ case '-':
+ ++cp->Const.cds[1];
+ break;
+ case '0':
+ break;
+ default:
+ --cp->Const.cds[1];
+ }
+ else
+ cp->Const.cd[1] = -cp->Const.cd[1];
+ /* no break */
+ case TYREAL:
+ case TYDREAL:
+ if (cp->vstg)
+ switch(*cp->Const.cds[0]) {
+ case '-':
+ ++cp->Const.cds[0];
+ break;
+ case '0':
+ break;
+ default:
+ --cp->Const.cds[0];
+ }
+ else
+ cp->Const.cd[0] = -cp->Const.cd[0];
+ break;
+ case TYCHAR:
+ case TYLOGICAL:
+ erri ("negate_const: can't negate type '%d'", cp -> vtype);
+ break;
+ default:
+ erri ("negate_const: bad type '%d'",
+ cp -> vtype);
+ break;
+ } /* switch */
+} /* negate_const */
+
+ffilecopy (infp, outfp)
+FILE *infp, *outfp;
+{
+ while (!feof (infp)) {
+ register c = getc (infp);
+ if (!feof (infp))
+ putc (c, outfp);
+ } /* while */
+} /* ffilecopy */
+
+
+#define NOT_IN_VECTOR -1
+
+/* in_vector -- verifies whether str is in c_keywords.
+ If so, the index is returned else NOT_IN_VECTOR is returned.
+ c_keywords must be in alphabetical order (as defined by strcmp).
+*/
+
+int in_vector(str)
+char *str;
+{
+ extern int n_keywords;
+ extern char *c_keywords[];
+ register int n = n_keywords;
+ register char **K = c_keywords;
+ register int n1, t;
+ extern int strcmp();
+
+ do {
+ n1 = n >> 1;
+ if (!(t = strcmp(str, K[n1])))
+ return K - c_keywords + n1;
+ if (t < 0)
+ n = n1;
+ else {
+ n -= ++n1;
+ K += n1;
+ }
+ }
+ while(n > 0);
+
+ return NOT_IN_VECTOR;
+ } /* in_vector */
+
+
+int is_negatable (Const)
+Constp Const;
+{
+ int retval = 0;
+ if (Const != (Constp) NULL)
+ switch (Const -> vtype) {
+ case TYSHORT:
+ retval = Const -> Const.ci >= -BIGGEST_SHORT;
+ break;
+ case TYLONG:
+ retval = Const -> Const.ci >= -BIGGEST_LONG;
+ break;
+ case TYREAL:
+ case TYDREAL:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ retval = 1;
+ break;
+ case TYLOGICAL:
+ case TYCHAR:
+ case TYSUBR:
+ default:
+ retval = 0;
+ break;
+ } /* switch */
+
+ return retval;
+} /* is_negatable */
+
+backup(fname, bname)
+ char *fname, *bname;
+{
+ FILE *b, *f;
+ static char couldnt[] = "Couldn't open %.80s";
+
+ if (!(f = fopen(fname, binread))) {
+ warn1(couldnt, fname);
+ return;
+ }
+ if (!(b = fopen(bname, binwrite))) {
+ warn1(couldnt, bname);
+ return;
+ }
+ ffilecopy(f, b);
+ fclose(f);
+ fclose(b);
+ }
+
+
+/* struct_eq -- returns YES if structures have the same field names and
+ types, NO otherwise */
+
+int struct_eq (s1, s2)
+chainp s1, s2;
+{
+ struct Dimblock *d1, *d2;
+ Constp cp1, cp2;
+
+ if (s1 == CHNULL && s2 == CHNULL)
+ return YES;
+ for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
+ register Namep v1 = (Namep) s1 -> datap;
+ register Namep v2 = (Namep) s2 -> datap;
+
+ if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
+ v2 == (Namep) NULL || v2 -> tag != TNAME)
+ return NO;
+
+ if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
+ || strcmp(v1->fvarname, v2->fvarname))
+ return NO;
+
+ /* compare dimensions (needed for comparing COMMON blocks) */
+
+ if (d1 = v1->vdim) {
+ if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
+ return NO;
+ if (!(d2 = v2->vdim))
+ if (cp1->Const.ci == 1)
+ continue;
+ else
+ return NO;
+ if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
+ || cp1->Const.ci != cp2->Const.ci)
+ return NO;
+ }
+ else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
+ || cp2->tag != TCONST
+ || cp2->Const.ci != 1))
+ return NO;
+ } /* while s1 != CHNULL && s2 != CHNULL */
+
+ return s1 == CHNULL && s2 == CHNULL;
+} /* struct_eq */
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+
+/* Names generated by the translator are guaranteed to be unique from the
+ Fortan names because Fortran does not allow underscores in identifiers,
+ and all of the system generated names do have underscores. The various
+ naming conventions are outlined below:
+
+ FORMAT APPLICATION
+ ----------------------------------------------------------------------
+ io_# temporaries generated by IO calls; these will
+ contain the device number (e.g. 5, 6, 0)
+ ret_val function return value, required for complex and
+ character functions.
+ ret_val_len length of the return value in character functions
+
+ ssss_len length of character argument "ssss"
+
+ c_# member of the literal pool, where # is an
+ arbitrary label assigned by the system
+ cs_# short integer constant in the literal pool
+ t_# expression temporary, # is the depth of arguments
+ on the stack.
+ L# label "#", given by user in the Fortran program.
+ This is unique because Fortran labels are numeric
+ pad_# label on an init field required for alignment
+ xxx_init label on a common block union, if a block data
+ requires a separate declaration
+*/
+
+/* generate variable references */
+
+char *c_type_decl (type, is_extern)
+int type, is_extern;
+{
+ static char buff[100];
+
+ switch (type) {
+ case TYADDR: strcpy (buff, "address"); break;
+ case TYSHORT: strcpy (buff, "shortint"); break;
+ case TYLONG: strcpy (buff, "integer"); break;
+ case TYREAL: if (!is_extern || !forcedouble)
+ { strcpy (buff, "real");break; }
+ case TYDREAL: strcpy (buff, "doublereal"); break;
+ case TYCOMPLEX: if (is_extern)
+ strcpy (buff, Ansi ? "/* Complex */ VOID"
+ : "/* Complex */ int");
+ else
+ strcpy (buff, "complex");
+ break;
+ case TYDCOMPLEX:if (is_extern)
+ strcpy (buff, Ansi ? "/* Double Complex */ VOID"
+ : "/* Double Complex */ int");
+ else
+ strcpy (buff, "doublecomplex");
+ break;
+ case TYLOGICAL: strcpy(buff, typename[TYLOGICAL]);
+ break;
+ case TYCHAR: if (is_extern)
+ strcpy (buff, Ansi ? "/* Character */ VOID"
+ : "/* Character */ int");
+ else
+ strcpy (buff, "char");
+ break;
+
+ case TYUNKNOWN: strcpy (buff, "UNKNOWN");
+
+/* If a procedure's type is unknown, assume it's a subroutine */
+
+ if (!is_extern)
+ break;
+
+/* Subroutines must return an INT, because they might return a label
+ value. Even if one doesn't, the caller will EXPECT it to. */
+
+ case TYSUBR: strcpy (buff, "/* Subroutine */ int");
+ break;
+ case TYERROR: strcpy (buff, "ERROR"); break;
+ case TYVOID: strcpy (buff, "void"); break;
+ case TYCILIST: strcpy (buff, "cilist"); break;
+ case TYICILIST: strcpy (buff, "icilist"); break;
+ case TYOLIST: strcpy (buff, "olist"); break;
+ case TYCLLIST: strcpy (buff, "cllist"); break;
+ case TYALIST: strcpy (buff, "alist"); break;
+ case TYINLIST: strcpy (buff, "inlist"); break;
+ case TYFTNLEN: strcpy (buff, "ftnlen"); break;
+ default: sprintf (buff, "BAD DECL '%d'", type);
+ break;
+ } /* switch */
+
+ return buff;
+} /* c_type_decl */
+
+
+char *new_func_length()
+{ return "ret_val_len"; }
+
+char *new_arg_length(arg)
+ Namep arg;
+{
+ static char buf[64];
+ sprintf (buf, "%s_len", arg->fvarname);
+
+ return buf;
+} /* new_arg_length */
+
+
+/* declare_new_addr -- Add a new local variable to the function, given a
+ pointer to an Addrblock structure (which must have the uname_tag set)
+ This list of idents will be printed in reverse (i.e., chronological)
+ order */
+
+ void
+declare_new_addr (addrp)
+struct Addrblock *addrp;
+{
+ extern chainp new_vars;
+
+ new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
+} /* declare_new_addr */
+
+
+wr_nv_ident_help (outfile, addrp)
+FILE *outfile;
+struct Addrblock *addrp;
+{
+ int eltcount = 0;
+
+ if (addrp == (struct Addrblock *) NULL)
+ return;
+
+ if (addrp -> isarray) {
+ frexpr (addrp -> memoffset);
+ addrp -> memoffset = ICON(0);
+ eltcount = addrp -> ntempelt;
+ addrp -> ntempelt = 0;
+ addrp -> isarray = 0;
+ } /* if */
+ out_addr (outfile, addrp);
+ if (eltcount)
+ nice_printf (outfile, "[%d]", eltcount);
+} /* wr_nv_ident_help */
+
+int nv_type_help (addrp)
+struct Addrblock *addrp;
+{
+ if (addrp == (struct Addrblock *) NULL)
+ return -1;
+
+ return addrp -> vtype;
+} /* nv_type_help */
+
+
+/* lit_name -- returns a unique identifier for the given literal. Make
+ the label useful, when possible. For example:
+
+ 1 -> c_1 (constant 1)
+ 2 -> c_2 (constant 2)
+ 1000 -> c_1000 (constant 1000)
+ 1000000 -> c_b<memno> (big constant number)
+ 1.2 -> c_1_2 (constant 1.2)
+ 1.234345 -> c_b<memno> (big constant number)
+ -1 -> c_n1 (constant -1)
+ -1.0 -> c_n1_0 (constant -1.0)
+ .true. -> c_true (constant true)
+ .false. -> c_false (constant false)
+ default -> c_b<memno> (default label)
+*/
+
+char *lit_name (litp)
+struct Literal *litp;
+{
+ static char buf[CONST_IDENT_MAX];
+
+ if (litp == (struct Literal *) NULL)
+ return NULL;
+
+ switch (litp -> littype) {
+ case TYSHORT:
+ if (litp -> litval.litival < 32768 &&
+ litp -> litval.litival > -32769) {
+ ftnint val = litp -> litval.litival;
+
+ if (val < 0)
+ sprintf (buf, "cs_n%ld", -val);
+ else
+ sprintf (buf, "cs__%ld", val);
+ } else
+ sprintf (buf, "c_b%d", litp -> litnum);
+ break;
+ case TYLONG:
+ if (litp -> litval.litival < 100000 &&
+ litp -> litval.litival > -10000) {
+ ftnint val = litp -> litval.litival;
+
+ if (val < 0)
+ sprintf (buf, "c_n%ld", -val);
+ else
+ sprintf (buf, "c__%ld", val);
+ } else
+ sprintf (buf, "c_b%d", litp -> litnum);
+ break;
+ case TYLOGICAL:
+ sprintf (buf, "c_%s", (litp -> litval.litival ? "true" : "false"));
+ break;
+ case TYREAL:
+ case TYDREAL:
+ /* Given a limit of 6 or 8 character on external names, */
+ /* few f.p. values can be meaningfully encoded in the */
+ /* constant name. Just going with the default cb_# */
+ /* seems to be the best course for floating-point */
+ /* constants. */
+ case TYCHAR:
+ /* Shouldn't be any of these */
+ case TYADDR:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ case TYSUBR:
+ default:
+ sprintf (buf, "c_b%d", litp -> litnum);
+ break;
+ } /* switch */
+ return buf;
+} /* lit_name */
+
+
+
+ char *
+comm_union_name(count)
+ int count;
+{
+ static char buf[12];
+
+ sprintf(buf, "%d", count);
+ return buf;
+ }
+
+
+
+
+/* wr_globals -- after every function has been translated, we need to
+ output the global declarations, such as the static table of constant
+ values */
+
+wr_globals (outfile)
+FILE *outfile;
+{
+ struct Literal *litp, *lastlit;
+ extern struct Literal litpool[]; /* Table of constant values */
+ extern int nliterals; /* Number of constants in table */
+ extern char *lit_name ();
+ int did_one, t;
+ struct Constblock cb;
+
+ if (nliterals == 0)
+ return;
+
+ lastlit = litpool + nliterals;
+ did_one = 0;
+ for (litp = litpool; litp < lastlit; litp++) {
+ if (!litp->lituse)
+ continue;
+ if (!did_one) {
+ margin_printf(outfile, "/* Table of constant values */\n\n");
+ did_one = 1;
+ }
+ nice_printf (outfile, "static %s %s%s = ", c_type_decl (litp -> littype,
+ 0), litp -> littype == TYCHAR ? "*" : "", lit_name (litp));
+
+ t = litp->littype;
+ if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
+ cb.vstg = 1;
+ cb.Const.cds[0] = litp->cds[0];
+ cb.Const.cds[1] = litp->cds[1];
+ }
+ else {
+ memcpy((char *)&cb.Const, (char *)&litp->litval,
+ sizeof(cb.Const));
+ cb.vstg = 0;
+ }
+ cb.vtype = litp->littype;
+ out_const (outfile, &cb);
+
+ nice_printf (outfile, ";\n");
+ } /* for */
+ if (did_one)
+ nice_printf (outfile, "\n");
+} /* wr_globals */
+
+ ftnint
+commlen(vl)
+ register chainp vl;
+{
+ ftnint size;
+ int type;
+ struct Dimblock *t;
+ Namep v;
+
+ while(vl->nextp)
+ vl = vl->nextp;
+ v = (Namep)vl->datap;
+ type = v->vtype;
+ if (type == TYCHAR)
+ size = v->vleng->constblock.Const.ci;
+ else
+ size = typesize[type];
+ if ((t = v->vdim) && ISCONST(t->nelt))
+ size *= t->nelt->constblock.Const.ci;
+ return size + v->voffset;
+ }
+
+ static void /* Pad common block if an EQUIVALENCE extended it. */
+pad_common(c)
+ Extsym *c;
+{
+ register chainp cvl;
+ register Namep v;
+ long L = c->maxleng;
+ int type;
+ struct Dimblock *t;
+ int szshort = typesize[TYSHORT];
+
+ for(cvl = c->allextp; cvl; cvl = cvl->nextp)
+ if (commlen((chainp)cvl->datap) >= L)
+ return;
+ v = ALLOC(Nameblock);
+ v->vtype = type = L % szshort ? TYCHAR
+ : type_choice[L/szshort % 4];
+ v->vstg = STGCOMMON;
+ v->vclass = CLVAR;
+ v->tag = TNAME;
+ v->vdim = t = ALLOC(Dimblock);
+ t->ndim = 1;
+ t->dims[0].dimsize = ICON(L / typesize[type]);
+ v->fvarname = v->cvarname = "eqv_pad";
+ c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
+ }
+
+
+/* wr_common_decls -- outputs the common declarations in one of three
+ formats. If all references to a common block look the same (field
+ names and types agree), only one actual declaration will appear.
+ Otherwise, the same block will require many structs. If there is no
+ block data, these structs will be union'ed together (so the linker
+ knows the size of the largest one). If there IS a block data, only
+ that version will be associated with the variable, others will only be
+ defined as types, so the pointer can be cast to it. e.g.
+
+ FORTRAN C
+----------------------------------------------------------------------
+ common /com1/ a, b, c struct { real a, b, c; } com1_;
+
+ common /com1/ a, b, c union {
+ common /com1/ i, j, k struct { real a, b, c; } _1;
+ struct { integer i, j, k; } _2;
+ } com1_;
+
+ common /com1/ a, b, c struct com1_1_ { real a, b, c; };
+ block data struct { integer i, j, k; } com1_ =
+ common /com1/ i, j, k { 1, 2, 3 };
+ data i/1/, j/2/, k/3/
+
+
+ All of these versions will be followed by #defines, since the code in
+ the function bodies can't know ahead of time which of these options
+ will be taken */
+
+/* Macros for deciding the output type */
+
+#define ONE_STRUCT 1
+#define UNION_STRUCT 2
+#define INIT_STRUCT 3
+
+wr_common_decls(outfile)
+ FILE *outfile;
+{
+ Extsym *ext;
+ extern int extcomm;
+ static char *Extern[4] = {"", "Extern ", "extern "};
+ char *E, *E0 = Extern[extcomm];
+ int did_one = 0;
+
+ for (ext = extsymtab; ext < nextext; ext++) {
+ if (ext -> extstg == STGCOMMON && ext->allextp) {
+ chainp comm;
+ int count = 1;
+ int which; /* which display to use;
+ ONE_STRUCT, UNION or INIT */
+
+ if (!did_one)
+ nice_printf (outfile, "/* Common Block Declarations */\n\n");
+
+ pad_common(ext);
+
+/* Construct the proper, condensed list of structs; eliminate duplicates
+ from the initial list ext -> allextp */
+
+ comm = ext->allextp = revchain(ext->allextp);
+
+ if (ext -> extinit)
+ which = INIT_STRUCT;
+ else if (comm->nextp) {
+ which = UNION_STRUCT;
+ nice_printf (outfile, "%sunion {\n", E0);
+ next_tab (outfile);
+ E = "";
+ }
+ else {
+ which = ONE_STRUCT;
+ E = E0;
+ }
+
+ for (; comm; comm = comm -> nextp, count++) {
+
+ if (which == INIT_STRUCT)
+ nice_printf (outfile, "struct %s%d_ {\n",
+ ext->cextname, count);
+ else
+ nice_printf (outfile, "%sstruct {\n", E);
+
+ next_tab (c_file);
+
+ wr_struct (outfile, (chainp) comm -> datap);
+
+ prev_tab (c_file);
+ if (which == UNION_STRUCT)
+ nice_printf (outfile, "} _%d;\n", count);
+ else if (which == ONE_STRUCT)
+ nice_printf (outfile, "} %s;\n", ext->cextname);
+ else
+ nice_printf (outfile, "};\n");
+ } /* for */
+
+ if (which == UNION_STRUCT) {
+ prev_tab (c_file);
+ nice_printf (outfile, "} %s;\n", ext->cextname);
+ } /* if */
+ did_one = 1;
+ nice_printf (outfile, "\n");
+
+ for (count = 1, comm = ext -> allextp; comm;
+ comm = comm -> nextp, count++) {
+ def_start(outfile, ext->cextname,
+ comm_union_name(count), "");
+ switch (which) {
+ case ONE_STRUCT:
+ extern_out (outfile, ext);
+ break;
+ case UNION_STRUCT:
+ nice_printf (outfile, "(");
+ extern_out (outfile, ext);
+ nice_printf(outfile, "._%d)", count);
+ break;
+ case INIT_STRUCT:
+ nice_printf (outfile, "(*(struct ");
+ extern_out (outfile, ext);
+ nice_printf (outfile, "%d_ *) &", count);
+ extern_out (outfile, ext);
+ nice_printf (outfile, ")");
+ break;
+ } /* switch */
+ nice_printf (outfile, "\n");
+ } /* for count = 1, comm = ext -> allextp */
+ nice_printf (outfile, "\n");
+ } /* if ext -> extstg == STGCOMMON */
+ } /* for ext = extsymtab */
+} /* wr_common_decls */
+
+
+wr_struct (outfile, var_list)
+FILE *outfile;
+chainp var_list;
+{
+ int last_type = -1;
+ int did_one = 0;
+ chainp this_var;
+
+ for (this_var = var_list; this_var; this_var = this_var -> nextp) {
+ Namep var = (Namep) this_var -> datap;
+ int type;
+ char *comment = NULL, *wr_ardecls ();
+
+ if (var == (Namep) NULL)
+ err ("wr_struct: null variable");
+ else if (var -> tag != TNAME)
+ erri ("wr_struct: bad tag on variable '%d'",
+ var -> tag);
+
+ type = var -> vtype;
+
+ if (last_type == type && did_one)
+ nice_printf (outfile, ", ");
+ else {
+ if (did_one)
+ nice_printf (outfile, ";\n");
+ nice_printf (outfile, "%s ",
+ c_type_decl (type, var -> vclass == CLPROC));
+ } /* else */
+
+/* Character type is really a string type. Put out a '*' for parameters
+ with unknown length and functions returning character */
+
+ if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
+ || var -> vclass == CLPROC))
+ nice_printf (outfile, "*");
+
+ var -> vstg = STGAUTO;
+ out_name (outfile, var);
+ if (var -> vclass == CLPROC)
+ nice_printf (outfile, "()");
+ else if (var -> vdim)
+ comment = wr_ardecls(outfile, var->vdim,
+ var->vtype == TYCHAR && ISICON(var->vleng)
+ ? var->vleng->constblock.Const.ci : 1L);
+ else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
+ ISICON ((var -> vleng)))
+ nice_printf (outfile, "[%ld]",
+ var -> vleng -> constblock.Const.ci);
+
+ if (comment)
+ nice_printf (outfile, "%s", comment);
+ did_one = 1;
+ last_type = type;
+ } /* for this_var */
+
+ if (did_one)
+ nice_printf (outfile, ";\n");
+} /* wr_struct */
+
+
+char *user_label(stateno)
+ftnint stateno;
+{
+ static char buf[USER_LABEL_MAX + 1];
+
+ if (stateno >= 0)
+ sprintf(buf, "L%ld", stateno);
+ else
+ sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
+ return buf;
+} /* user_label */
+
+
+char *temp_name (starter, num, storage)
+char *starter;
+int num;
+char *storage;
+{
+ static char buf[IDENT_LEN];
+ char *pointer = buf;
+ char *prefix = "t";
+
+ if (storage)
+ pointer = storage;
+
+ if (starter && *starter)
+ prefix = starter;
+
+ sprintf (pointer, "%s_%d", prefix, num);
+ return pointer;
+} /* temp_name */
+
+
+char *equiv_name (memno, store)
+int memno;
+char *store;
+{
+ static char buf[IDENT_LEN];
+ char *pointer = buf;
+
+ if (store)
+ pointer = store;
+
+ sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
+ return pointer;
+} /* equiv_name */
+
+ void
+def_commons(of)
+ FILE *of;
+{
+ Extsym *ext;
+ int c, onefile, Union;
+ char buf[64];
+ chainp comm;
+ extern int ext1comm;
+
+ if (ext1comm == 1) {
+ onefile = 1;
+ c_file = of;
+ fprintf(of, "/*>>>'/dev/null'<<<*/\n\
+#ifdef Define_COMMONs\n\
+/*<<</dev/null>>>*/\n");
+ }
+ else
+ onefile = 0;
+ for(ext = extsymtab; ext < nextext; ext++)
+ if (ext->extstg == STGCOMMON && !ext->extinit) {
+ sprintf(buf, "%scom.c", ext->cextname);
+ if (onefile)
+ fprintf(of, "/*>>>'%s'<<<*/\n",
+ buf);
+ else {
+ c_file = of = fopen(buf,textwrite);
+ if (!of)
+ fatalstr("can't open %s", buf);
+ }
+ fprintf(of, "#include \"f2c.h\"\n");
+ comm = ext->allextp;
+ if (comm->nextp) {
+ Union = 1;
+ nice_printf(of, "union {\n");
+ next_tab(of);
+ }
+ else
+ Union = 0;
+ for(c = 1; comm; comm = comm->nextp) {
+ nice_printf(of, "struct {\n");
+ next_tab(of);
+ wr_struct(of, (chainp)comm->datap);
+ prev_tab(of);
+ if (Union)
+ nice_printf(of, "} _%d;\n", c++);
+ }
+ if (Union)
+ prev_tab(of);
+ nice_printf(of, "} %s;\n", ext->cextname);
+ if (onefile)
+ fprintf(of, "/*<<<%s>>>*/\n", buf);
+ else
+ fclose(of);
+ }
+ if (onefile)
+ fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
+/*<<</dev/null>>>*/\n");
+ }
+
+/* C Language keywords. Needed to filter unwanted fortran identifiers like
+ * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
+ * Also includes C++ keywords and types used for I/O in f2c.h .
+ * These keywords must be in alphabetical order (as defined by strcmp()).
+ */
+
+char *c_keywords[] = {
+ "abs", "acos", "alist", "asin", "asm", "atan", "atan2", "auto",
+ "break", "case", "catch", "char", "cilist", "class", "cllist",
+ "const", "continue", "cos", "cosh",
+ "dabs", "default", "defined", "delete",
+ "dmax", "dmin", "do", "double",
+ "else", "entry", "enum", "exp", "extern",
+ "flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
+ "icilist", "if", "include", "inline", "inlist", "int",
+ "log", "long", "max", "min", "new",
+ "olist", "operator", "overload", "private", "protected", "public",
+ "register", "return",
+ "short", "signed", "sin", "sinh", "sizeof", "sqrt",
+ "static", "struct", "switch",
+ "tan", "tanh", "template", "this", "try", "typedef",
+ "union", "unsigned", "virtual", "void", "volatile", "while"
+}; /* c_keywords */
+
+int n_keywords = sizeof(c_keywords)/sizeof(char *);
--- /dev/null
+#define CONST_IDENT_MAX 30
+#define IO_IDENT_MAX 30
+#define ARGUMENT_MAX 30
+#define USER_LABEL_MAX 30
+
+#define EQUIV_INIT_NAME "equiv"
+
+#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a))
+#define nv_type(x) nv_type_help ((struct Addrblock *) x)
+
+extern char *c_keywords[];
+
+char *new_io_ident (/* char * */);
+char *new_func_retval (/* char * */);
+char *new_func_length (/* char * */);
+char *new_arg_length (/* Namep */);
+void declare_new_addr (/* struct Addrblock * */);
+char *nv_ident_help (/* struct Addrblock * */);
+int nv_type_help (/* struct Addrblock */);
+char *user_label (/* int */);
+char *temp_name (/* int, char */);
+char *c_type_decl (/* int, int */);
+char *equiv_name (/* int, char * */);
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+
+#define TOO_LONG_INDENT (2 * tab_size)
+#define MAX_INDENT 44
+#define MIN_INDENT 22
+static int last_was_newline = 0;
+int indent = 0;
+int in_comment = 0;
+
+ static int
+write_indent(fp, use_indent, extra_indent, start, end)
+ FILE *fp;
+ int use_indent, extra_indent;
+ char *start, *end;
+{
+ int ind, tab;
+
+ if (last_was_newline && use_indent) {
+ if (*start == '\n') do {
+ putc('\n', fp);
+ if (++start > end)
+ return;
+ }
+ while(*start == '\n');
+
+ ind = indent <= MAX_INDENT
+ ? indent
+ : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
+
+ tab = ind + extra_indent;
+
+ while (tab > 7) {
+ putc ('\t', fp);
+ tab -= 8;
+ } /* while */
+
+ while (tab-- > 0)
+ putc (' ', fp);
+ } /* if last_was_newline */
+
+ while (start <= end)
+ putc (*start++, fp);
+} /* write_indent */
+
+
+/*VARARGS2*/
+int margin_printf (fp, a, b, c, d, e, f, g)
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+ ind_printf (0, fp, a, b, c, d, e, f, g);
+} /* margin_printf */
+
+/*VARARGS2*/
+int nice_printf (fp, a, b, c, d, e, f, g)
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+ ind_printf (1, fp, a, b, c, d, e, f, g);
+} /* nice_printf */
+
+
+#define max_line_len c_output_line_length
+ /* 74Number of characters allowed on an output
+ line. This assumes newlines are handled
+ nicely, i.e. a newline after a full text
+ line on a terminal is ignored */
+
+/* output_buf holds the text of the next line to be printed. It gets
+ flushed when a newline is printed. next_slot points to the next
+ available location in the output buffer, i.e. where the next call to
+ nice_printf will have its output stored */
+
+static char output_buf[MAX_OUTPUT_SIZE] = "";
+static char *next_slot = output_buf;
+static char *string_start;
+
+static char *word_start = NULL;
+static int in_char = 0;
+static int cursor_pos = 0;
+
+ static char *
+adjust_pointer_in_string(pointer)
+ register char *pointer;
+{
+ register char *s, *s1, *se, *s0;
+
+ /* arrange not to break \002 */
+ s1 = string_start ? string_start : output_buf;
+ for(s = s1; s < pointer; s++) {
+ s0 = s1;
+ s1 = s;
+ if (*s == '\\') {
+ se = s++ + 4;
+ if (se > pointer)
+ break;
+ if (*s < '0' || *s > '7')
+ continue;
+ while(++s < se)
+ if (*s < '0' || *s > '7')
+ break;
+ --s;
+ }
+ }
+ return s0 - 1;
+ }
+
+/* isident -- true iff character could belong to a unit. C allows
+ letters, numbers and underscores in identifiers. This also doubles as
+ a check for numeric constants, since we include the decimal point and
+ minus sign. The minus has to be here, since the constant "10e-2"
+ cannot be broken up. The '.' also prevents structure references from
+ being broken, which is a quite acceptable side effect */
+
+#define isident(x) (Tr[x] & 1)
+#define isntident(x) (!Tr[x])
+
+int ind_printf (use_indent, fp, a, b, c, d, e, f, g)
+int use_indent;
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+ extern int max_line_len;
+ extern FILEP c_file;
+ extern char tr_tab[]; /* in output.c */
+ register char *Tr = tr_tab;
+ int ind;
+ static int extra_indent, last_indent, set_cursor = 1;
+
+ cursor_pos += indent - last_indent;
+ last_indent = indent;
+ sprintf (next_slot, a, b, c, d, e, f, g);
+
+ if (fp != c_file) {
+ fprintf (fp,"%s", next_slot);
+ return 1;
+ } /* if fp != c_file */
+
+ do {
+ char *pointer;
+
+/* The for loop will parse one output line */
+
+ if (set_cursor) {
+ ind = indent <= MAX_INDENT
+ ? indent
+ : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
+ cursor_pos = ind + extra_indent;
+ set_cursor = 0;
+ }
+ if (in_string)
+ for (pointer = next_slot; *pointer && *pointer != '\n' &&
+ cursor_pos <= max_line_len; pointer++)
+ cursor_pos++;
+ else
+ for (pointer = next_slot; *pointer && *pointer != '\n' &&
+ cursor_pos <= max_line_len; pointer++) {
+
+ /* Update state variables here */
+
+ switch (*pointer) {
+ case '"':
+ if (!in_char && !in_comment)
+ /* Ignore double quotes in char constants */
+ string_start = word_start = pointer;
+ break;
+ case '\'':
+ if (!in_comment) {
+ word_start = in_char ? NULL : pointer;
+ in_char = !in_char;
+ }
+ break;
+ case '\\':
+ if (in_char) {
+ pointer++;
+ cursor_pos++;
+ }
+ break;
+ case '\t':
+ cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1;
+ break;
+ default: {
+
+ if (in_char)
+ break;
+
+/* HACK Assumes that all characters in an atomic C token will be written
+ at the same time. Must check for tokens first, since '-' is considered
+ part of an identifier; checking isident first would mean breaking up "->" */
+
+ if (!word_start && isident(*(unsigned char *)pointer))
+ word_start = pointer;
+ else if (word_start && isntident(*(unsigned char *)pointer))
+ word_start = NULL;
+ break;
+ } /* default */
+ } /* switch */
+ cursor_pos++;
+ } /* for pointer = next_slot */
+ if (*pointer == '\0') {
+
+/* The output line is not complete, so break out and don't output
+ anything. The current line fragment will be stored in the buffer */
+
+ next_slot = pointer;
+ break;
+ } else {
+ char *safe_strncpy ();
+ char last_char;
+ int in_string0 = in_string;
+
+/* If the line was too long, move pointer back to the character before
+ the current word. This allows line breaking on word boundaries. Make
+ sure that 80 character comment lines get broken up somehow. We assume
+ that any non-string 80 character identifier must be in a comment.
+*/
+
+ if (word_start && *pointer != '\n' && word_start > output_buf)
+ if (in_string)
+ if (string_start && pointer - string_start < 5)
+ pointer = string_start - 1;
+ else {
+ pointer = adjust_pointer_in_string(pointer);
+ string_start = 0;
+ }
+ else if (word_start == string_start) {
+ pointer = adjust_pointer_in_string(next_slot);
+ in_string = 1;
+ string_start = 0;
+ }
+ else
+ pointer = word_start - 1;
+ else if (cursor_pos > max_line_len) {
+ extern char *strchr();
+ if (in_string)
+ pointer = adjust_pointer_in_string(pointer);
+ else if (strchr("&*+-/<=>|", *pointer)
+ && strchr("!%&*+-/<=>^|", pointer[-1])) {
+ pointer -= 2;
+ if (strchr("<>", *pointer)) /* <<=, >>= */
+ pointer--;
+ }
+ else
+ pointer--;
+ }
+ last_char = *pointer;
+ write_indent(fp, use_indent, extra_indent, output_buf, pointer);
+ next_slot = output_buf;
+ if (in_string && !string_start && Ansi == 1 && last_char != '\n')
+ *next_slot++ = '"';
+ (void) safe_strncpy (next_slot, pointer + 1, sizeof(output_buf)-1);
+ in_char = 0;
+
+/* insert a line break */
+
+ if (last_char == '\n') {
+ if (in_string)
+ last_was_newline = 0;
+ else {
+ last_was_newline = 1;
+ extra_indent = 0;
+ }
+ }
+ else {
+ extra_indent = TOO_LONG_INDENT;
+ if (in_string && !string_start) {
+ if (Ansi == 1) {
+ fprintf(fp, "\"\n");
+ use_indent = 1;
+ last_was_newline = 1;
+ }
+ else {
+ fprintf(fp, "\\\n");
+ last_was_newline = 0;
+ }
+ in_string = in_string0;
+ }
+ else {
+ putc ('\n', fp);
+ last_was_newline = 1;
+ }
+ } /* if *pointer != '\n' */
+
+ if (in_string && Ansi != 1 && !string_start)
+ cursor_pos = 0;
+ else
+ set_cursor = 1;
+
+ string_start = word_start = NULL;
+
+ } /* else */
+
+ } while (*next_slot);
+
+ return 0;
+} /* ind_printf */
--- /dev/null
+/* niceprintf.h -- contains constants and macros from the output filter
+ for the generated C code. We use macros for increased speed, less
+ function overhead. */
+
+#define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS
+ the length of the longest string
+ printed using nice_printf */
+
+
+
+#define next_tab(fp) (indent += tab_size)
+
+#define prev_tab(fp) (indent -= tab_size)
+
+
+
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+
+#ifndef TRUE
+# define TRUE 1
+#endif
+#ifndef FALSE
+# define FALSE 0
+#endif
+
+char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
+
+/* Opcode table -- This array is indexed by the OP_____ macros defined in
+ defines.h; these macros are expected to be adjacent integers, so that
+ this table is as small as possible. */
+
+table_entry opcode_table[] = {
+ { 0, 0, NULL },
+ /* OPPLUS 1 */ { BINARY_OP, 12, "%l + %r" },
+ /* OPMINUS 2 */ { BINARY_OP, 12, "%l - %r" },
+ /* OPSTAR 3 */ { BINARY_OP, 13, "%l * %r" },
+ /* OPSLASH 4 */ { BINARY_OP, 13, "%l / %r" },
+ /* OPPOWER 5 */ { BINARY_OP, 0, "power (%l, %r)" },
+ /* OPNEG 6 */ { UNARY_OP, 14, "-%l" },
+ /* OPOR 7 */ { BINARY_OP, 4, "%l || %r" },
+ /* OPAND 8 */ { BINARY_OP, 5, "%l && %r" },
+ /* OPEQV 9 */ { BINARY_OP, 9, "%l == %r" },
+ /* OPNEQV 10 */ { BINARY_OP, 9, "%l != %r" },
+ /* OPNOT 11 */ { UNARY_OP, 14, "! %l" },
+
+/* Have to find out more about CONCAT before it can be implemented */
+
+ /* OPCONCAT 12 */ { BINARY_OP, 0, "concat (%l, %r)" },
+ /* OPLT 13 */ { BINARY_OP, 10, "%l < %r" },
+ /* OPEQ 14 */ { BINARY_OP, 9, "%l == %r" },
+ /* OPGT 15 */ { BINARY_OP, 10, "%l > %r" },
+ /* OPLE 16 */ { BINARY_OP, 10, "%l <= %r" },
+ /* OPNE 17 */ { BINARY_OP, 9, "%l != %r" },
+ /* OPGE 18 */ { BINARY_OP, 10, "%l >= %r" },
+
+/* Have to find out more about CALL before it can be implemented */
+
+ /* OPCALL 19 */ { BINARY_OP, 0, SPECIAL_FMT },
+ /* OPCCALL 20 */ { BINARY_OP, 0, SPECIAL_FMT },
+
+/* Left hand side of an assignment cannot have outermost parens */
+
+ /* OPASSIGN 21 */ { BINARY_OP, 2, "%l = %r" },
+ /* OPPLUSEQ 22 */ { BINARY_OP, 2, "%l += %r" },
+ /* OPSTAREQ 23 */ { BINARY_OP, 2, "%l *= %r" },
+
+/* Why is this a binary operator? 15-jun-88 mwm */
+
+ /* OPCONV 24 */ { BINARY_OP, 14, "%l" },
+ /* OPLSHIFT 25 */ { BINARY_OP, 11, "%l << %r" },
+ /* OPMOD 26 */ { BINARY_OP, 13, "%l %% %r" },
+ /* OPCOMMA 27 */ { BINARY_OP, 1, "%l, %r" },
+
+/* Don't want to nest the colon operator in parens */
+
+ /* OPQUEST 28 */ { BINARY_OP, 3, "%l ? %r" },
+ /* OPCOLON 29 */ { BINARY_OP, 3, "%l : %r" },
+ /* OPABS 30 */ { UNARY_OP, 0, "abs(%l)" },
+ /* OPMIN 31 */ { BINARY_OP, 0, SPECIAL_FMT },
+ /* OPMAX 32 */ { BINARY_OP, 0, SPECIAL_FMT },
+ /* OPADDR 33 */ { UNARY_OP, 14, "&%l" },
+
+ /* OPCOMMA_ARG 34 */ { BINARY_OP, 15, SPECIAL_FMT },
+ /* OPBITOR 35 */ { BINARY_OP, 6, "%l | %r" },
+ /* OPBITAND 36 */ { BINARY_OP, 8, "%l & %r" },
+ /* OPBITXOR 37 */ { BINARY_OP, 7, "%l ^ %r" },
+ /* OPBITNOT 38 */ { UNARY_OP, 14, "~ %l" },
+ /* OPRSHIFT 39 */ { BINARY_OP, 11, "%l >> %r" },
+
+/* This isn't quite right -- it doesn't handle arrays, for instance */
+
+ /* OPWHATSIN 40 */ { UNARY_OP, 14, "*%l" },
+ /* OPMINUSEQ 41 */ { BINARY_OP, 2, "%l -= %r" },
+ /* OPSLASHEQ 42 */ { BINARY_OP, 2, "%l /= %r" },
+ /* OPMODEQ 43 */ { BINARY_OP, 2, "%l %%= %r" },
+ /* OPLSHIFTEQ 44 */ { BINARY_OP, 2, "%l <<= %r" },
+ /* OPRSHIFTEQ 45 */ { BINARY_OP, 2, "%l >>= %r" },
+ /* OPBITANDEQ 46 */ { BINARY_OP, 2, "%l &= %r" },
+ /* OPBITXOREQ 47 */ { BINARY_OP, 2, "%l ^= %r" },
+ /* OPBITOREQ 48 */ { BINARY_OP, 2, "%l |= %r" },
+ /* OPPREINC 49 */ { UNARY_OP, 14, "++%l" },
+ /* OPPREDEC 50 */ { UNARY_OP, 14, "--%l" },
+ /* OPDOT 51 */ { BINARY_OP, 15, "%l.%r" },
+ /* OPARROW 52 */ { BINARY_OP, 15, "%l -> %r"},
+ /* OPNEG1 53 */ { UNARY_OP, 14, "-%l" },
+ /* OPDMIN 54 */ { BINARY_OP, 0, "dmin(%l,%r)" },
+ /* OPDMAX 55 */ { BINARY_OP, 0, "dmax(%l,%r)" },
+ /* OPASSIGNI 56 */ { BINARY_OP, 2, "%l = &%r" },
+ /* OPIDENTITY 57 */ { UNARY_OP, 15, "%l" },
+ /* OPCHARCAST 58 */ { UNARY_OP, 14, "(char *)&%l" },
+ /* OPDABS 59 */ { UNARY_OP, 0, "dabs(%l)" },
+ /* OPMIN2 60 */ { BINARY_OP, 0, "min(%l,%r)" },
+ /* OPMAX2 61 */ { BINARY_OP, 0, "max(%l,%r)" },
+
+/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
+
+ /* OPNEG KLUDGE */ { UNARY_OP, 14, "-(doublereal)%l" }
+}; /* opcode_table */
+
+#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
+
+static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
+
+
+static void output_prim ();
+static void output_unary (), output_binary (), output_arg_list ();
+static void output_list (), output_literal ();
+
+
+
+void expr_out (fp, e)
+FILE *fp;
+expptr e;
+{
+ if (e == (expptr) NULL)
+ return;
+
+ switch (e -> tag) {
+ case TNAME: out_name (fp, (struct Nameblock *) e);
+ return;
+
+ case TCONST: out_const(fp, &e->constblock);
+ return;
+ case TEXPR:
+ break;
+
+ case TADDR: out_addr (fp, &(e -> addrblock));
+ return;
+
+ case TPRIM: warn ("expr_out: got TPRIM");
+ output_prim (fp, &(e -> primblock));
+ return;
+
+ case TLIST: output_list (fp, &(e -> listblock));
+ return;
+
+ case TIMPLDO: err ("expr_out: got TIMPLDO");
+ return;
+
+ case TERROR:
+ default:
+ erri ("expr_out: bad tag '%d'", e -> tag);
+ } /* switch */
+
+/* Now we know that the tag is TEXPR */
+
+/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
+
+ if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
+ e -> exprblock.rightp -> tag == TEXPR) {
+ int opcode;
+
+ opcode = e -> exprblock.rightp -> exprblock.opcode;
+
+ if (opeqable[opcode]) {
+ expptr leftp, rightp;
+
+ if ((leftp = e -> exprblock.leftp) &&
+ (rightp = e -> exprblock.rightp -> exprblock.leftp)) {
+
+ if (same_ident (leftp, rightp)) {
+ expptr temp = e -> exprblock.rightp;
+
+ e -> exprblock.opcode = op_assign(opcode);
+
+ e -> exprblock.rightp = temp -> exprblock.rightp;
+ temp->exprblock.rightp = 0;
+ frexpr(temp);
+ } /* if same_ident (leftp, rightp) */
+ } /* if leftp && rightp */
+ } /* if opcode == OPPLUS || */
+ } /* if e -> exprblock.opcode == OPASSIGN */
+
+
+/* Optimize on increment or decrement by 1 */
+
+ {
+ int opcode = e -> exprblock.opcode;
+ expptr leftp = e -> exprblock.leftp;
+ expptr rightp = e -> exprblock.rightp;
+
+ if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
+ ISINT (leftp -> headblock.vtype)) &&
+ (opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
+ ISINT (rightp -> headblock.vtype) &&
+ ISICON (e -> exprblock.rightp) &&
+ (ISONE (e -> exprblock.rightp) ||
+ e -> exprblock.rightp -> constblock.Const.ci == -1)) {
+
+/* Allow for the '-1' constant value */
+
+ if (!ISONE (e -> exprblock.rightp))
+ opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
+
+/* replace the existing opcode */
+
+ if (opcode == OPPLUSEQ)
+ e -> exprblock.opcode = OPPREINC;
+ else
+ e -> exprblock.opcode = OPPREDEC;
+
+/* Free up storage used by the right hand side */
+
+ frexpr (e -> exprblock.rightp);
+ e->exprblock.rightp = 0;
+ } /* if opcode == OPPLUS */
+ } /* block */
+
+
+ if (is_unary_op (e -> exprblock.opcode))
+ output_unary (fp, &(e -> exprblock));
+ else if (is_binary_op (e -> exprblock.opcode))
+ output_binary (fp, &(e -> exprblock));
+ else
+ erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
+
+} /* expr_out */
+
+
+void out_and_free_statement (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+ if (expr)
+ expr_out (outfile, expr);
+
+ nice_printf (outfile, ";\n");
+} /* out_and_free_statement */
+
+
+
+int same_ident (left, right)
+expptr left, right;
+{
+ if (!left || !right)
+ return 0;
+
+ if (left -> tag == TNAME && right -> tag == TNAME && left == right)
+ return 1;
+
+ if (left -> tag == TADDR && right -> tag == TADDR &&
+ left -> addrblock.uname_tag == right -> addrblock.uname_tag)
+ switch (left -> addrblock.uname_tag) {
+ case UNAM_NAME:
+
+/* Check for array subscripts */
+
+ if (left -> addrblock.user.name -> vdim ||
+ right -> addrblock.user.name -> vdim)
+ if (left -> addrblock.user.name !=
+ right -> addrblock.user.name ||
+ !same_expr (left -> addrblock.memoffset,
+ right -> addrblock.memoffset))
+ return 0;
+
+ return same_ident ((expptr) (left -> addrblock.user.name),
+ (expptr) right -> addrblock.user.name);
+ case UNAM_IDENT:
+ return strcmp(left->addrblock.user.ident,
+ right->addrblock.user.ident) == 0;
+ case UNAM_CHARP:
+ return strcmp(left->addrblock.user.Charp,
+ right->addrblock.user.Charp) == 0;
+ default:
+ return 0;
+ } /* switch */
+
+ if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
+ && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
+ return same_ident(left->exprblock.leftp,
+ right->exprblock.leftp);
+
+ return 0;
+} /* same_ident */
+
+ static int
+samefpconst(c1, c2, n)
+ register Constp c1, c2;
+ register int n;
+{
+ char *s1, *s2;
+ if (!c1->vstg && !c2->vstg)
+ return c1->Const.cd[n] == c2->Const.cd[n];
+ s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
+ s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
+ return !strcmp(s1, s2);
+ }
+
+ static int
+sameconst(c1, c2)
+ register Constp c1, c2;
+{
+ switch(c1->vtype) {
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ if (!samefpconst(c1,c2,1))
+ return 0;
+ case TYREAL:
+ case TYDREAL:
+ return samefpconst(c1,c2,0);
+ case TYCHAR:
+ return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
+ && c1->vleng->constblock.Const.ci
+ == c2->vleng->constblock.Const.ci
+ && !memcmp(c1->Const.ccp, c2->Const.ccp,
+ (int)c1->vleng->constblock.Const.ci);
+ case TYSHORT:
+ case TYINT:
+ case TYLOGICAL:
+ return c1->Const.ci == c2->Const.ci;
+ }
+ err("unexpected type in sameconst");
+ return 0;
+ }
+
+/* same_expr -- Returns true only if e1 and e2 match. This is
+ somewhat pessimistic, but can afford to be because it's just used to
+ optimize on the assignment operators (+=, -=, etc). */
+
+int same_expr (e1, e2)
+expptr e1, e2;
+{
+ if (!e1 || !e2)
+ return !e1 && !e2;
+
+ if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
+ return 0;
+
+ switch (e1 -> tag) {
+ case TEXPR:
+ if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
+ return 0;
+
+ return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
+ same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
+ case TNAME:
+ case TADDR:
+ return same_ident (e1, e2);
+ case TCONST:
+ return sameconst(&e1->constblock, &e2->constblock);
+ default:
+ return 0;
+ } /* switch */
+} /* same_expr */
+
+
+
+void out_name (fp, namep)
+ FILE *fp;
+ Namep namep;
+{
+ extern int usedefsforcommon;
+ Extsym *comm;
+
+ if (namep == NULL)
+ return;
+
+/* DON'T want to use oneof_stg() here; need to find the right common name
+ */
+
+ if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
+ comm = &extsymtab[namep->vardesc.varno];
+ extern_out(fp, comm);
+ nice_printf(fp, "%d.", comm->curno);
+ } /* if namep -> vstg == STGCOMMON */
+
+ if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
+ nice_printf(fp, xretslot[namep->vtype]->user.ident);
+ else
+ nice_printf (fp, "%s", namep->cvarname);
+} /* out_name */
+
+
+int in_string;
+char *str_fmt[128] = {
+ "\\x00", "\\x01", "\\x02", "\\x03", "\\x04", "\\x05", "\\x06", "\\x07",
+ "\\b", "\\t", "\\n", "\\v", "\\f", "\\r", "\\x0e", "\\x0f",
+ "\\x10", "\\x11", "\\x12", "\\x13", "\\x14", "\\x15", "\\x16", "\\x17",
+ "\\x18", "\\x19", "\\x1a", "\\x1b", "\\x1c", "\\x1d", "\\x1e", "\\x1f",
+ " ", "!", "\\\"", "#", "$", "%%", "&", "'",
+ "(", ")", "*", "+", ",", "-", ".", "/",
+ "0", "1", "2", "3", "4", "5", "6", "7",
+ "8", "9", ":", ";", "<", "=", ">", "?",
+ "@", "A", "B", "C", "D", "E", "F", "G",
+ "H", "I", "J", "K", "L", "M", "N", "O",
+ "P", "Q", "R", "S", "T", "U", "V", "W",
+ "X", "Y", "Z", "[", "\\\\", "]", "^", "_",
+ "`", "a", "b", "c", "d", "e", "f", "g",
+ "h", "i", "j", "k", "l", "m", "n", "o",
+ "p", "q", "r", "s", "t", "u", "v", "w",
+ "x", "y", "z", "{", "|", "}", "~", "\\x%02x"
+ };
+char *chr_fmt[128] = {
+ "\\x00", "\\x01", "\\x02", "\\x03", "\\x04", "\\x05", "\\x06", "\\x07",
+ "\\b", "\\t", "\\n", "\\v", "\\f", "\\r", "\\x0e", "\\x0f",
+ "\\x10", "\\x11", "\\x12", "\\x13", "\\x14", "\\x15", "\\x16", "\\x17",
+ "\\x18", "\\x19", "\\x1a", "\\x1b", "\\x1c", "\\x1d", "\\x1e", "\\x1f",
+ " ", "!", "\"", "#", "$", "%%", "&", "\\'",
+ "(", ")", "*", "+", ",", "-", ".", "/",
+ "0", "1", "2", "3", "4", "5", "6", "7",
+ "8", "9", ":", ";", "<", "=", ">", "?",
+ "@", "A", "B", "C", "D", "E", "F", "G",
+ "H", "I", "J", "K", "L", "M", "N", "O",
+ "P", "Q", "R", "S", "T", "U", "V", "W",
+ "X", "Y", "Z", "[", "\\\\", "]", "^", "_",
+ "`", "a", "b", "c", "d", "e", "f", "g",
+ "h", "i", "j", "k", "l", "m", "n", "o",
+ "p", "q", "r", "s", "t", "u", "v", "w",
+ "x", "y", "z", "{", "|", "}", "~", "\\x%02x"
+ };
+
+static char *Longfmt = "%ld";
+
+#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
+
+void out_const(fp, cp)
+ FILE *fp;
+ register Constp cp;
+{
+ static char real_buf[50], imag_buf[50];
+ unsigned int k;
+ int type = cp->vtype;
+
+ switch (type) {
+ case TYSHORT:
+ nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */
+ break;
+ case TYLONG:
+ nice_printf (fp, Longfmt, cp->Const.ci); /* don't cast ci! */
+ break;
+ case TYREAL:
+ nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
+ break;
+ case TYDREAL:
+ nice_printf(fp, "%s", cpd(0));
+ break;
+ case TYCOMPLEX:
+ nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
+ flconst(imag_buf, cpd(1)));
+ break;
+ case TYDCOMPLEX:
+ nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
+ break;
+ case TYLOGICAL:
+ nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
+ break;
+ case TYCHAR: {
+ char *c = cp->Const.ccp, *ce;
+
+ if (c == NULL) {
+ nice_printf (fp, "\"\"");
+ break;
+ } /* if c == NULL */
+
+ nice_printf (fp, "\"");
+ in_string = 1;
+ ce = c + cp->vleng->constblock.Const.ci;
+ while(c < ce) {
+ k = *(unsigned char *)c++;
+ nice_printf(fp, str_fmt[k < 127 ? k : 127], k);
+ }
+ for(k = cp->Const.ccp1.blanks; k > 0; k--)
+ nice_printf(fp, " ");
+ nice_printf (fp, "\"");
+ in_string = 0;
+ break;
+ } /* case TYCHAR */
+ default:
+ erri ("out_const: bad type '%d'", (int) type);
+ break;
+ } /* switch */
+
+} /* out_const */
+#undef cpd
+
+
+/* out_addr -- this routine isn't local because it is called by the
+ system-generated identifier printing routines */
+
+void out_addr (fp, addrp)
+FILE *fp;
+struct Addrblock *addrp;
+{
+ extern Extsym *extsymtab;
+ int was_array = 0;
+ char *s;
+
+
+ if (addrp == NULL)
+ return;
+ if (doin_setbound
+ && addrp->vstg == STGARG
+ && addrp->vtype != TYCHAR
+ && ISICON(addrp->memoffset)
+ && !addrp->memoffset->constblock.Const.ci)
+ nice_printf(fp, "*");
+
+ switch (addrp -> uname_tag) {
+ case UNAM_NAME:
+ out_name (fp, addrp -> user.name);
+ break;
+ case UNAM_IDENT:
+ if (*(s = addrp->user.ident) == ' ') {
+ if (multitype)
+ nice_printf(fp, "%s",
+ xretslot[addrp->vtype]->user.ident);
+ else
+ nice_printf(fp, "%s", s+1);
+ }
+ else {
+ nice_printf(fp, "%s", s);
+ }
+ break;
+ case UNAM_CHARP:
+ nice_printf(fp, "%s", addrp->user.Charp);
+ break;
+ case UNAM_EXTERN:
+ extern_out (fp, &extsymtab[addrp -> memno]);
+ break;
+ case UNAM_CONST:
+ switch(addrp->vstg) {
+ case STGCONST:
+ out_const(fp, (Constp)addrp);
+ break;
+ case STGMEMNO:
+ output_literal (fp, (int)addrp->memno,
+ (Constp)addrp);
+ break;
+ default:
+ Fatal("unexpected vstg in out_addr");
+ }
+ break;
+ case UNAM_UNKNOWN:
+ default:
+ nice_printf (fp, "Unknown Addrp");
+ break;
+ } /* switch */
+
+/* It's okay to just throw in the brackets here because they have a
+ precedence level of 15, the highest value. */
+
+ if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
+ || addrp->ntempelt > 1 || addrp->isarray)
+ && addrp->vtype != TYCHAR) {
+ expptr offset;
+
+ was_array = 1;
+
+ offset = addrp -> memoffset;
+ if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) &&
+ addrp -> uname_tag == UNAM_NAME)
+ offset = mkexpr (OPMINUS, offset, mkintcon (
+ addrp -> user.name -> voffset));
+
+ nice_printf (fp, "[");
+
+ offset = mkexpr (OPSLASH, offset,
+ ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
+ expr_out (fp, offset);
+ nice_printf (fp, "]");
+ }
+
+/* Check for structure field reference */
+
+ if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
+ addrp -> uname_tag != UNAM_UNKNOWN) {
+ if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
+ (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
+ && !was_array && (addrp->vclass != CLPROC || !multitype))
+ nice_printf (fp, "->%s", addrp -> Field);
+ else
+ nice_printf (fp, ".%s", addrp -> Field);
+ } /* if */
+
+/* Check for character subscripting */
+
+ if (addrp->vtype == TYCHAR &&
+ (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
+ && addrp->user.name->vprocclass == PTHISPROC) &&
+ addrp -> memoffset &&
+ (addrp -> uname_tag != UNAM_NAME ||
+ addrp -> user.name -> vtype == TYCHAR) &&
+ (!ISICON (addrp -> memoffset) ||
+ (addrp -> memoffset -> constblock.Const.ci))) {
+
+ int use_paren = 0;
+ expptr e = addrp -> memoffset;
+
+ if (!e)
+ return;
+
+ if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
+ && addrp -> uname_tag == UNAM_NAME) {
+ e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
+
+/* mkexpr will simplify it to zero if possible */
+ if (e->tag == TCONST && e->constblock.Const.ci == 0)
+ return;
+ } /* if addrp -> vstg == STGCOMMON */
+
+/* In the worst case, parentheses might be needed OUTSIDE the expression,
+ too. But since I think this subscripting can only appear as a
+ parameter in a procedure call, I don't think outside parens will ever
+ be needed. INSIDE parens are handled below */
+
+ nice_printf (fp, " + ");
+ if (e -> tag == TEXPR) {
+ int arg_prec = op_precedence (e -> exprblock.opcode);
+ int prec = op_precedence (OPPLUS);
+ use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
+ is_left_assoc (OPPLUS)));
+ } /* if e -> tag == TEXPR */
+ if (use_paren) nice_printf (fp, "(");
+ expr_out (fp, e);
+ if (use_paren) nice_printf (fp, ")");
+ } /* if */
+} /* out_addr */
+
+
+static void output_literal (fp, memno, cp)
+ FILE *fp;
+ int memno;
+ Constp cp;
+{
+ struct Literal *litp, *lastlit;
+ extern struct Literal litpool[];
+ extern int nliterals;
+ extern char *lit_name ();
+
+ lastlit = litpool + nliterals;
+
+ for (litp = litpool; litp < lastlit; litp++) {
+ if (litp -> litnum == memno)
+ break;
+ } /* for litp */
+
+ if (litp >= lastlit)
+ out_const (fp, cp);
+ else {
+ nice_printf (fp, "%s", lit_name (litp));
+ litp->lituse++;
+ }
+} /* output_literal */
+
+
+static void output_prim (fp, primp)
+FILE *fp;
+struct Primblock *primp;
+{
+ if (primp == NULL)
+ return;
+
+ out_name (fp, primp -> namep);
+ if (primp -> argsp)
+ output_arg_list (fp, primp -> argsp);
+
+ if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
+ nice_printf (fp, "Sorry, no substrings yet");
+}
+
+
+
+static void output_arg_list (fp, listp)
+FILE *fp;
+struct Listblock *listp;
+{
+ chainp arg_list;
+
+ if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
+ return;
+
+ nice_printf (fp, "(");
+
+ for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
+ expr_out (fp, (expptr) arg_list -> datap);
+ if (arg_list -> nextp != (chainp) NULL)
+
+/* Might want to add a hook in here to accomodate the style setting which
+ wants spaces after commas */
+
+ nice_printf (fp, ",");
+ } /* for arg_list */
+
+ nice_printf (fp, ")");
+} /* output_arg_list */
+
+
+
+static void output_unary (fp, e)
+FILE *fp;
+struct Exprblock *e;
+{
+ if (e == NULL)
+ return;
+
+ switch (e -> opcode) {
+ case OPNEG:
+ if (e->vtype == TYREAL && forcedouble) {
+ e->opcode = OPNEG_KLUDGE;
+ output_binary(fp,e);
+ e->opcode = OPNEG;
+ break;
+ }
+ case OPNEG1:
+ case OPNOT:
+ case OPABS:
+ case OPBITNOT:
+ case OPWHATSIN:
+ case OPPREINC:
+ case OPPREDEC:
+ case OPADDR:
+ case OPIDENTITY:
+ case OPCHARCAST:
+ case OPDABS:
+ output_binary (fp, e);
+ break;
+ case OPCALL:
+ case OPCCALL:
+ nice_printf (fp, "Sorry, no OPCALL yet");
+ break;
+ default:
+ erri ("output_unary: bad opcode", (int) e -> opcode);
+ break;
+ } /* switch */
+} /* output_unary */
+
+
+ static int
+opconv_fudge(fp,e)
+ FILE *fp;
+ struct Exprblock *e;
+{
+ /* special handling for ichar and character*1 */
+ register expptr lp = e->leftp;
+ register union Expression *Offset;
+ int lt = lp->headblock.vtype;
+ char buf[8];
+ unsigned int k;
+ Namep np;
+
+ if (lp->addrblock.vtype == TYCHAR) {
+ switch(lp->tag) {
+ case TNAME:
+ nice_printf(fp, "*");
+ out_name(fp, (Namep)lp);
+ return 1;
+ case TCONST:
+ tconst:
+ k = *(unsigned char *)lp->constblock.Const.ccp;
+ sprintf(buf, chr_fmt[k < 127 ? k : 127], k);
+ nice_printf(fp, "'%s'", buf);
+ return 1;
+ case TADDR:
+ if (lp->addrblock.vstg == STGCONST)
+ goto tconst;
+ lt = lp->addrblock.vtype = tyint;
+ Offset = lp->addrblock.memoffset;
+ if (lp->addrblock.uname_tag == UNAM_NAME) {
+ np = lp->addrblock.user.name;
+ if (ONEOF(np->vstg,
+ M(STGCOMMON)|M(STGEQUIV)))
+ Offset = mkexpr(OPMINUS, Offset,
+ ICON(np->voffset));
+ }
+ lp->addrblock.memoffset = Offset ?
+ mkexpr(OPSTAR, Offset,
+ ICON(typesize[tyint]))
+ : ICON(0);
+ lp->addrblock.isarray = 1;
+ /* STGCOMMON or STGEQUIV would cause */
+ /* voffset to be added in a second time */
+ lp->addrblock.vstg = STGUNKNOWN;
+ break;
+ default:
+ badtag("opconv_fudge", lp->tag);
+ }
+ }
+ if (lt != e->vtype)
+ nice_printf(fp, "(%s) ",
+ c_type_decl(e->vtype, 0));
+ return 0;
+ }
+
+
+static void output_binary (fp, e)
+FILE *fp;
+struct Exprblock *e;
+{
+ char *format;
+ extern table_entry opcode_table[];
+ int prec;
+
+ if (e == NULL || e -> tag != TEXPR)
+ return;
+
+/* Instead of writing a huge switch, I've incorporated the output format
+ into a table. Things like "%l" and "%r" stand for the left and
+ right subexpressions. This should allow both prefix and infix
+ functions to be specified (e.g. "(%l * %r", "z_div (%l, %r"). Of
+ course, I should REALLY think out the ramifications of writing out
+ straight text, as opposed to some intermediate format, which could
+ figure out and optimize on the the number of required blanks (we don't
+ want "x - (-y)" to become "x --y", for example). Special cases (such as
+ incomplete implementations) could still be implemented as part of the
+ switch, they will just have some dummy value instead of the string
+ pattern. Another difficulty is the fact that the complex functions
+ will differ from the integer and real ones */
+
+/* Handle a special case. We don't want to output "x + - 4", or "y - - 3"
+*/
+ if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
+ e -> rightp && e -> rightp -> tag == TCONST &&
+ isnegative_const (&(e -> rightp -> constblock)) &&
+ is_negatable (&(e -> rightp -> constblock))) {
+
+ e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
+ negate_const (&(e -> rightp -> constblock));
+ } /* if e -> opcode == PLUS or MINUS */
+
+ prec = op_precedence (e -> opcode);
+ format = op_format (e -> opcode);
+
+ if (format != SPECIAL_FMT) {
+ while (*format) {
+ if (*format == '%') {
+ int arg_prec, use_paren = 0;
+ expptr lp, rp;
+
+ switch (*(format + 1)) {
+ case 'l':
+ lp = e->leftp;
+ if (lp && lp->tag == TEXPR) {
+ arg_prec = op_precedence(lp->exprblock.opcode);
+
+ use_paren = arg_prec &&
+ (arg_prec < prec || (arg_prec == prec &&
+ is_right_assoc (prec)));
+ } /* if e -> leftp */
+ if (e->opcode == OPCONV && opconv_fudge(fp,e))
+ break;
+ if (use_paren)
+ nice_printf (fp, "(");
+ expr_out(fp, lp);
+ if (use_paren)
+ nice_printf (fp, ")");
+ break;
+ case 'r':
+ rp = e->rightp;
+ if (rp && rp->tag == TEXPR) {
+ arg_prec = op_precedence(rp->exprblock.opcode);
+
+ use_paren = arg_prec &&
+ (arg_prec < prec || (arg_prec == prec &&
+ is_left_assoc (prec)));
+ use_paren = use_paren ||
+ (rp->exprblock.opcode == OPNEG
+ && prec >= op_precedence(OPMINUS));
+ } /* if e -> rightp */
+ if (use_paren)
+ nice_printf (fp, "(");
+ expr_out(fp, rp);
+ if (use_paren)
+ nice_printf (fp, ")");
+ break;
+ case '\0':
+ case '%':
+ nice_printf (fp, "%%");
+ break;
+ default:
+ erri ("output_binary: format err: '%%%c' illegal",
+ (int) *(format + 1));
+ break;
+ } /* switch */
+ format += 2;
+ } else
+ nice_printf (fp, "%c", *format++);
+ } /* while *format */
+ } else {
+
+/* Handle Special cases of formatting */
+
+ switch (e -> opcode) {
+ case OPCCALL:
+ case OPCALL:
+ out_call (fp, (int) e -> opcode, e -> vtype,
+ e -> vleng, e -> leftp, e -> rightp);
+ break;
+
+ case OPCOMMA_ARG:
+ doin_setbound = 1;
+ nice_printf(fp, "(");
+ expr_out(fp, e->leftp);
+ nice_printf(fp, ", &");
+ doin_setbound = 0;
+ expr_out(fp, e->rightp);
+ nice_printf(fp, ")");
+ break;
+
+ case OPADDR:
+ default:
+ nice_printf (fp, "Sorry, can't format OPCODE '%d'",
+ e -> opcode);
+ break;
+ }
+
+ } /* else */
+} /* output_binary */
+
+
+out_call (outfile, op, ftype, len, name, args)
+FILE *outfile;
+int op, ftype;
+expptr len, name, args;
+{
+ chainp arglist; /* Pointer to any actual arguments */
+ chainp cp; /* Iterator over argument lists */
+ Addrp ret_val = (Addrp) NULL;
+ /* Function return value buffer, if any is
+ required */
+ int byvalue; /* True iff we're calling a C library
+ routine */
+ int done_once; /* Used for writing commas to outfile */
+ int narg, t;
+ register expptr q;
+ long L;
+ Argtypes *at;
+ Atype *A;
+ Namep np;
+
+/* Don't use addresses if we're calling a C function */
+
+ byvalue = op == OPCCALL;
+
+ if (args)
+ arglist = args -> listblock.listp;
+ else
+ arglist = CHNULL;
+
+/* If this is a CHARACTER function, the first argument is the result */
+
+ if (ftype == TYCHAR)
+ if (ISICON (len)) {
+ ret_val = (Addrp) (arglist -> datap);
+ arglist = arglist -> nextp;
+ } else {
+ err ("adjustable character function");
+ return;
+ } /* else */
+
+/* If this is a COMPLEX function, the first argument is the result */
+
+ else if (ISCOMPLEX (ftype)) {
+ ret_val = (Addrp) (arglist -> datap);
+ arglist = arglist -> nextp;
+ } /* if ISCOMPLEX */
+
+/* Now we can actually start to write out the function invocation */
+
+ if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
+ nice_printf (outfile, "(");
+ expr_out (outfile, name);
+ nice_printf (outfile, ")");
+ np = (Namep)name->exprblock.leftp;
+ }
+ else {
+ np = (Namep)name;
+ expr_out(outfile, name);
+ }
+
+ /* prepare to cast procedure parameters -- set A if we know how */
+
+ A = np->tag == TNAME && (at = np->arginfo) && at->nargs > 0
+ ? at->atypes : 0;
+
+ nice_printf(outfile, "(");
+
+ if (ret_val) {
+ if (ISCOMPLEX (ftype))
+ nice_printf (outfile, "&");
+ expr_out (outfile, (expptr) ret_val);
+
+/* The length of the result of a character function is the second argument */
+/* It should be in place from putcall(), so we won't touch it explicitly */
+
+ } /* if ret_val */
+ done_once = ret_val ? TRUE : FALSE;
+
+/* Now run through the named arguments */
+
+ narg = -1;
+ for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
+
+ if (done_once)
+ nice_printf (outfile, ", ");
+ narg++;
+
+ if (!( q = (expptr)cp->datap) )
+ continue;
+
+ if (q->tag == TADDR) {
+ if (q->addrblock.vtype > TYERROR) {
+ /* I/O block */
+ nice_printf(outfile, "&%s", q->addrblock.user.ident);
+ continue;
+ }
+ if (!byvalue && q->addrblock.isarray
+ && q->addrblock.vtype != TYCHAR
+ && q->addrblock.memoffset->tag == TCONST) {
+
+ /* check for 0 offset -- after */
+ /* correcting for equivalence. */
+ L = q->addrblock.memoffset->constblock.Const.ci;
+ if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
+ && q->addrblock.uname_tag == UNAM_NAME)
+ L -= q->addrblock.user.name->voffset;
+ if (L)
+ goto skip_deref;
+
+ /* &x[0] == x */
+ /* This also prevents &sizeof(doublereal)[0] */
+ switch(q->addrblock.uname_tag) {
+ case UNAM_NAME:
+ out_name(outfile, q->addrblock.user.name);
+ continue;
+ case UNAM_IDENT:
+ nice_printf(outfile, "%s",
+ q->addrblock.user.ident);
+ continue;
+ case UNAM_CHARP:
+ nice_printf(outfile, "%s",
+ q->addrblock.user.Charp);
+ continue;
+ case UNAM_EXTERN:
+ extern_out(outfile,
+ &extsymtab[q->addrblock.memno]);
+ continue;
+ }
+ }
+ }
+
+/* Skip over the dereferencing operator generated only for the
+ intermediate file */
+ skip_deref:
+ if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
+ q = q -> exprblock.leftp;
+
+ if (q->headblock.vclass == CLPROC
+ && Castargs
+ && (q->tag != TNAME
+ || q->nameblock.vprocclass != PTHISPROC))
+ {
+ if (A && (t = A[narg].type) >= 200)
+ t %= 100;
+ else {
+ t = q->headblock.vtype;
+ if (q->tag == TNAME && q->nameblock.vimpltype)
+ t = TYUNKNOWN;
+ }
+ nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
+ }
+
+ if ((q -> tag == TADDR || q-> tag == TNAME) &&
+ (byvalue || q -> headblock.vstg != STGREG)) {
+ if (byvalue && q -> headblock.vtype != TYCHAR) {
+
+/* Think about array access, too! Don't just think about argument storage
+ */
+
+ if (q -> tag == TADDR &&
+ !(q -> addrblock.uname_tag == UNAM_NAME &&
+ q -> addrblock.user.name -> vdim) &&
+ oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
+ M(STGARG)|M(STGEQUIV)))
+
+ nice_printf (outfile, "*");
+ else if (q -> tag == TNAME
+ && oneof_stg(&q->nameblock, q -> nameblock.vstg,
+ M(STGARG)|M(STGEQUIV))
+ && !(q -> nameblock.vdim))
+ nice_printf (outfile, "*");
+
+ } else if (q->headblock.vtype != TYCHAR) {
+ expptr memoffset;
+
+ if (q->tag == TADDR &&
+ !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
+ && (
+ ONEOF(q->addrblock.vstg,
+ M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
+ || ((memoffset = q->addrblock.memoffset)
+ && (!ISICON(memoffset)
+ || memoffset->constblock.Const.ci)))
+ || ONEOF(q->addrblock.vstg,
+ M(STGINIT)|M(STGAUTO)|M(STGBSS))
+ && !q->addrblock.isarray)
+ nice_printf (outfile, "&");
+ else if (q -> tag == TNAME
+ && !oneof_stg(&q->nameblock, q -> nameblock.vstg,
+ M(STGARG)|M(STGEXT)|M(STGEQUIV)))
+ nice_printf (outfile, "&");
+ } /* else */
+
+ expr_out (outfile, q);
+ } /* if q -> tag == TADDR || q -> tag == TNAME */
+
+/* Might be a Constant expression, e.g. string length, character constants */
+
+ else if (q -> tag == TCONST) {
+ if (tyioint == TYLONG)
+ Longfmt = "%ldL";
+ out_const(outfile, &q->constblock);
+ Longfmt = "%ld";
+ }
+
+/* Must be some other kind of expression, or register var, or constant.
+ In particular, this is likely to be a temporary variable assignment
+ which was generated in p1put_call */
+
+ else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
+ int use_paren = q -> tag == TEXPR &&
+ op_precedence (q -> exprblock.opcode) <=
+ op_precedence (OPCOMMA);
+
+ if (use_paren) nice_printf (outfile, "(");
+ expr_out (outfile, q);
+ if (use_paren) nice_printf (outfile, ")");
+ } /* if !ISCOMPLEX */
+ else
+ err ("out_call: unknown parameter");
+
+ } /* for (cp = arglist */
+
+ if (arglist)
+ frchain (&arglist);
+
+ nice_printf (outfile, ")");
+
+} /* out_call */
+
+
+ char *
+flconst(buf, x)
+ char *buf, *x;
+{
+ sprintf(buf, fl_fmt_string, x);
+ return buf;
+ }
+
+ char *
+dtos(x)
+ double x;
+{
+ static char buf[64];
+ sprintf(buf, db_fmt_string, x);
+ return buf;
+ }
+
+char tr_tab[256]; /* machine dependent */
+
+/* out_init -- Initialize the data structures used by the routines in
+ output.c. These structures include the output format to be used for
+ Float, Double, Complex, and Double Complex constants. */
+
+void out_init ()
+{
+ extern int tab_size;
+ register char *s;
+
+ s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
+ while(*s)
+ tr_tab[*s++] = 3;
+ tr_tab['>'] = 1;
+
+ opeqable[OPPLUS] = 1;
+ opeqable[OPMINUS] = 1;
+ opeqable[OPSTAR] = 1;
+ opeqable[OPSLASH] = 1;
+ opeqable[OPMOD] = 1;
+ opeqable[OPLSHIFT] = 1;
+ opeqable[OPBITAND] = 1;
+ opeqable[OPBITXOR] = 1;
+ opeqable[OPBITOR ] = 1;
+
+
+/* Set the output format for both types of floating point constants */
+
+ if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
+ fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
+
+ if (db_fmt_string == NULL || *db_fmt_string == '\0')
+ db_fmt_string = "%.17g";
+
+/* Set the output format for both types of complex constants. They will
+ have string parameters rather than float or double so that the decimal
+ point may be added to the strings generated by the {db,fl}_fmt_string
+ formats above */
+
+ if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
+ cm_fmt_string = "{%s,%s}";
+ } /* if cm_fmt_string == NULL */
+
+ if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
+ dcm_fmt_string = "{%s,%s}";
+ } /* if dcm_fmt_string == NULL */
+
+ tab_size = 4;
+} /* out_init */
+
+
+void extern_out (fp, extsym)
+FILE *fp;
+Extsym *extsym;
+{
+ if (extsym == (Extsym *) NULL)
+ return;
+
+ nice_printf (fp, "%s", extsym->cextname);
+
+} /* extern_out */
+
+
+
+static void output_list (fp, listp)
+FILE *fp;
+struct Listblock *listp;
+{
+ int did_one = 0;
+ chainp elts;
+
+ nice_printf (fp, "(");
+ if (listp)
+ for (elts = listp -> listp; elts; elts = elts -> nextp) {
+ if (elts -> datap) {
+ if (did_one)
+ nice_printf (fp, ", ");
+ expr_out (fp, (expptr) elts -> datap);
+ did_one = 1;
+ } /* if elts -> datap */
+ } /* for elts */
+ nice_printf (fp, ")");
+} /* output_list */
+
+
+void out_asgoto (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+ char *user_label();
+ chainp value;
+ Namep namep;
+ int k;
+
+ if (expr == (expptr) NULL) {
+ err ("out_asgoto: NULL variable expr");
+ return;
+ } /* if expr */
+
+ nice_printf (outfile, "switch (");
+ expr_out (outfile, expr);
+ nice_printf (outfile, ") {\n");
+ next_tab (outfile);
+
+/* The initial addrp value will be stored as a namep pointer */
+
+ switch(expr->tag) {
+ case TNAME:
+ /* local variable */
+ namep = &expr->nameblock;
+ break;
+ case TEXPR:
+ if (expr->exprblock.opcode == OPWHATSIN
+ && expr->exprblock.leftp->tag == TNAME)
+ /* argument */
+ namep = &expr->exprblock.leftp->nameblock;
+ else
+ goto bad;
+ break;
+ case TADDR:
+ if (expr->addrblock.uname_tag == UNAM_NAME) {
+ /* initialized local variable */
+ namep = expr->addrblock.user.name;
+ break;
+ }
+ default:
+ bad:
+ err("out_asgoto: bad expr");
+ return;
+ }
+
+ for(k = 0, value = namep -> varxptr.assigned_values; value;
+ value = value->nextp, k++) {
+ nice_printf (outfile, "case %d: goto %s;\n", k,
+ user_label((long)value->datap));
+ } /* for value */
+ prev_tab (outfile);
+
+ nice_printf (outfile, "}\n");
+} /* out_asgoto */
+
+void out_if (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+ nice_printf (outfile, "if (");
+ expr_out (outfile, expr);
+ nice_printf (outfile, ") {\n");
+ next_tab (outfile);
+} /* out_if */
+
+ static void
+output_rbrace(outfile, s)
+ FILE *outfile;
+ char *s;
+{
+ extern int last_was_label;
+ register char *fmt;
+
+ if (last_was_label) {
+ last_was_label = 0;
+ fmt = ";%s";
+ }
+ else
+ fmt = "%s";
+ nice_printf(outfile, fmt, s);
+ }
+
+void out_else (outfile)
+FILE *outfile;
+{
+ prev_tab (outfile);
+ output_rbrace(outfile, "} else {\n");
+ next_tab (outfile);
+} /* out_else */
+
+void elif_out (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+ prev_tab (outfile);
+ output_rbrace(outfile, "} else ");
+ out_if (outfile, expr);
+} /* elif_out */
+
+void endif_out (outfile)
+FILE *outfile;
+{
+ prev_tab (outfile);
+ output_rbrace(outfile, "}\n");
+} /* endif_out */
+
+void end_else_out (outfile)
+FILE *outfile;
+{
+ prev_tab (outfile);
+ output_rbrace(outfile, "}\n");
+} /* end_else_out */
+
+
+
+void compgoto_out (outfile, index, labels)
+FILE *outfile;
+expptr index, labels;
+{
+ if (index == ENULL)
+ err ("compgoto_out: null index for computed goto");
+ else if (labels && labels -> tag != TLIST)
+ erri ("compgoto_out: expected label list, got tag '%d'",
+ labels -> tag);
+ else {
+ extern char *user_label ();
+ chainp elts;
+ int i = 1;
+
+ nice_printf (outfile, "switch (");
+ expr_out (outfile, index);
+ nice_printf (outfile, ") {\n");
+ next_tab (outfile);
+
+ for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
+ if (elts -> datap) {
+ if (ISICON(((expptr) (elts -> datap))))
+ nice_printf (outfile, "case %d: goto %s;\n", i,
+ user_label(((expptr)(elts->datap))->constblock.Const.ci));
+ else
+ err ("compgoto_out: bad label in label list");
+ } /* if (elts -> datap) */
+ } /* for elts */
+ prev_tab (outfile);
+ nice_printf (outfile, "}\n");
+ } /* else */
+} /* compgoto_out */
+
+
+void out_for (outfile, init, test, inc)
+FILE *outfile;
+expptr init, test, inc;
+{
+ nice_printf (outfile, "for (");
+ expr_out (outfile, init);
+ nice_printf (outfile, "; ");
+ expr_out (outfile, test);
+ nice_printf (outfile, "; ");
+ expr_out (outfile, inc);
+ nice_printf (outfile, ") {\n");
+ next_tab (outfile);
+} /* out_for */
+
+
+void out_end_for (outfile)
+FILE *outfile;
+{
+ prev_tab (outfile);
+ nice_printf (outfile, "}\n");
+} /* out_end_for */
--- /dev/null
+/* nice_printf -- same arguments as fprintf.
+
+ All output which is to become C code must be directed through this
+ function. For now, no buffering is done. Later on, every line of
+ output will be filtered to accomodate the style definitions (e.g. one
+ statement per line, spaces between function names and argument lists,
+ etc.)
+*/
+#include "nicepr.h"
+
+extern int nice_printf ();
+
+
+/* Definitions for the opcode table. The table is indexed by the macros
+ which are #defined in defines.h */
+
+#define UNARY_OP 01
+#define BINARY_OP 02
+
+#define SPECIAL_FMT NULL
+
+#define is_unary_op(x) (opcode_table[x].type == UNARY_OP)
+#define is_binary_op(x) (opcode_table[x].type == BINARY_OP)
+#define op_precedence(x) (opcode_table[x].prec)
+#define op_format(x) (opcode_table[x].format)
+
+/* _assoc_table -- encodes left-associativity and right-associativity
+ information; indexed by precedence level. Only 2, 3, 14 are
+ right-associative. Source: Kernighan & Ritchie, p. 49 */
+
+extern char _assoc_table[];
+
+#define is_right_assoc(x) (_assoc_table [x])
+#define is_left_assoc(x) (! _assoc_table [x])
+
+
+typedef struct {
+ int type; /* UNARY_OP or BINARY_OP */
+ int prec; /* Precedence level, useful for adjusting
+ number of parens to insert. Zero is a
+ special level, and 2, 3, 14 are
+ right-associative */
+ char *format;
+} table_entry;
+
+
+extern char *fl_fmt_string; /* Float constant format string */
+extern char *db_fmt_string; /* Double constant format string */
+extern char *cm_fmt_string; /* Complex constant format string */
+extern char *dcm_fmt_string; /* Double Complex constant format string */
+
+extern int indent; /* Number of spaces to indent; this is a
+ temporary fix */
+extern int tab_size; /* Number of spaces in each tab */
+extern int in_string;
+
+extern table_entry opcode_table[];
+
+
+void expr_out (), out_init (), out_addr (), out_const ();
+void out_name (), extern_out (), out_asgoto ();
+void out_if (), out_else (), elif_out ();
+void endif_out (), end_else_out ();
+void compgoto_out (), out_for ();
+void out_end_for (), out_and_free_statement ();
--- /dev/null
+#define P1_UNKNOWN 0
+#define P1_COMMENT 1 /* Fortan comment string */
+#define P1_EOF 2 /* End of file dummy token */
+#define P1_SET_LINE 3 /* Reset the line counter */
+#define P1_FILENAME 4 /* Name of current input file */
+#define P1_NAME_POINTER 5 /* Pointer to hash table entry */
+#define P1_CONST 6 /* Some constant value */
+#define P1_EXPR 7 /* Followed by opcode */
+
+/* The next two tokens could be grouped together, since they always come
+ from an Addr structure */
+
+#define P1_IDENT 8 /* Char string identifier in addrp->user
+ field */
+#define P1_EXTERN 9 /* Pointer to external symbol entry */
+
+#define P1_HEAD 10 /* Function header info */
+#define P1_LIST 11 /* A list of data (e.g. arguments) will
+ follow the tag, type, and count */
+#define P1_LITERAL 12 /* Hold the index into the literal pool */
+#define P1_LABEL 13 /* label value */
+#define P1_ASGOTO 14 /* Store the hash table pointer of
+ variable used in assigned goto */
+#define P1_GOTO 15 /* Store the statement number */
+#define P1_IF 16 /* store the condition as an expression */
+#define P1_ELSE 17 /* No data */
+#define P1_ELIF 18 /* store the condition as an expression */
+#define P1_ENDIF 19 /* Marks the end of a block IF */
+#define P1_ENDELSE 20 /* Marks the end of a block ELSE */
+#define P1_ADDR 21 /* Addr data; used for arrays, common and
+ equiv addressing, NOT for names, idents
+ or externs */
+#define P1_SUBR_RET 22 /* Subroutine return; the return expression
+ follows */
+#define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */
+#define P1_FOR 24 /* C FOR loop; three expressions follow */
+#define P1_ENDFOR 25 /* End of C FOR loop */
+#define P1_FORTRAN 26 /* original Fortran source */
+#define P1_CHARP 27 /* user.Charp field -- for long names */
+#define P1_WHILE1START 28 /* start of DO WHILE */
+#define P1_WHILE2START 29 /* rest of DO WHILE */
+#define P1_PROCODE 30 /* invoke procode() -- to adjust params */
+
+#define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */
+#define P1_STMTBUFSIZE 1400
+
+
+
+#define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */
+#define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */
+
+extern void p1put (/* int */);
+extern void p1_comment (/* char * */);
+extern void p1_label (/* int */);
+extern void p1_line_number (/* int */);
+extern void p1put_filename();
+extern void p1_expr (/* expptr */);
+extern void p1_head (/* int, char * */);
+extern void p1_if (/* expptr */);
+extern void p1_else ();
+extern void p1_elif (/* expptr */);
+extern void p1_endif ();
+extern void p1else_end ();
+extern void p1_subr_ret (/* expptr */);
+extern void p1_goto(/* long */);
+extern void p1comp_goto (/* expptr, int, struct Labelblock *[] */);
+extern void p1_for (/* expptr, expptr, expptr */);
+extern void p1for_end ();
+
+
+extern void p1puts (/* int, char * */);
+
+/* The pass 1 intermediate file has the following format:
+
+ <ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n
+
+ e.g. 1: This is a comment
+
+ This format is destined to change in the future, but for now a readable
+ form is more desirable than a compact form.
+
+ NOTES ABOUT THE P1 FORMAT
+ ----------------------------------------------------------------------
+
+ P1_COMMENT: The comment string (in <data>) may be at most
+ COMMENT_BUFFER_SIZE bytes long. It must contain no newlines
+ or null characters. A side effect of the way comments are
+ read in lex.c is that no '\377' chars may be in a
+ comment either.
+
+ P1_SET_LINE: <data> holds the line number in the current source file.
+
+ P1_INC_LINE: Increment the source line number; <data> is empty.
+
+ P1_NAME_POINTER: <data> holds the integer representation of a
+ pointer into a hash table entry.
+
+ P1_CONST: the first field in <data> is a type tag (one of the
+ TYxxxx macros), the next field holds the constant
+ value
+
+ P1_EXPR: <data> holds the opcode number of the expression,
+ followed by the type of the expression (required for
+ OPCONV). Next is the value of vleng.
+ The type of operation represented by the
+ opcode determines how many of the following data items
+ are part of this expression.
+
+ P1_IDENT: <data> holds the type, then storage, then the
+ char string identifier in the addrp->user field.
+
+ P1_EXTERN: <data> holds an offset into the external symbol
+ table entry
+
+ P1_HEAD: the first field in <data> is the procedure class, the
+ second is the name of the procedure
+
+ P1_LIST: the first field in <data> is the tag, the second the
+ type of the list, the third the number of elements in
+ the list
+
+ P1_LITERAL: <data> holds the litnum of a value in the
+ literal pool.
+
+ P1_LABEL: <data> holds the statement number of the current
+ line
+
+ P1_ASGOTO: <data> holds the hash table pointer of the variable
+
+ P1_GOTO: <data> holds the statement number to jump to
+
+ P1_IF: <data> is empty, the following expression is the IF
+ condition.
+
+ P1_ELSE: <data> is empty.
+
+ P1_ELIF: <data> is empty, the following expression is the IF
+ condition.
+
+ P1_ENDIF: <data> is empty.
+
+ P1_ENDELSE: <data> is empty.
+
+ P1_ADDR: <data> holds a direct copy of the structure. The
+ next expression is a copy of vleng, and the next a
+ copy of memoffset.
+
+ P1_SUBR_RET: The next token is an expression for the return value.
+
+ P1_COMP_GOTO: The next token is an integer expression, the
+ following one a list of labels.
+
+ P1_FOR: The next three expressions are the Init, Test, and
+ Increment expressions of a C FOR loop.
+
+ P1_ENDFOR: Marks the end of the body of a FOR loop
+
+*/
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "output.h"
+#include "names.h"
+
+
+static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
+ p1_literal(), p1_name(), p1_unary(), p1putn();
+static void p1putd (/* int, int */);
+static void p1putds (/* int, int, char * */);
+static void p1putdds (/* int, int, int, char * */);
+static void p1putdd (/* int, int, int */);
+static void p1putddd (/* int, int, int, int */);
+
+
+/* p1_comment -- save the text of a Fortran comment in the intermediate
+ file. Make sure that there are no spurious "/ *" or "* /" characters by
+ mapping them onto "/+" and "+/". str is assumed to hold no newlines and be
+ null terminated; it may be modified by this function. */
+
+void p1_comment (str)
+char *str;
+{
+ register unsigned char *pointer, *ustr;
+
+ if (!str)
+ return;
+
+/* Get rid of any open or close comment combinations that may be in the
+ Fortran input */
+
+ ustr = (unsigned char *)str;
+ for(pointer = ustr; *pointer; pointer++)
+ if (*pointer == '*' && pointer[1] == '/')
+ *pointer = '+';
+ /* trim trailing white space */
+#ifdef isascii
+ while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
+#else
+ while(--pointer >= ustr && isspace(*pointer));
+#endif
+ pointer[1] = 0;
+ p1puts (P1_COMMENT, str);
+} /* p1_comment */
+
+void p1_line_number (line_number)
+long line_number;
+{
+
+ p1putd (P1_SET_LINE, line_number);
+} /* p1_line_number */
+
+/* p1_name -- Writes the address of a hash table entry into the
+ intermediate file */
+
+static void p1_name (namep)
+Namep namep;
+{
+ p1putd (P1_NAME_POINTER, (long) namep);
+ namep->visused = 1;
+} /* p1_name */
+
+
+
+void p1_expr (expr)
+expptr expr;
+{
+/* An opcode of 0 means a null entry */
+
+ if (expr == ENULL) {
+ p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */
+ return;
+ } /* if (expr == ENULL) */
+
+ switch (expr -> tag) {
+ case TNAME:
+ p1_name ((Namep) expr);
+ return;
+ case TCONST:
+ p1_const(&expr->constblock);
+ return;
+ case TEXPR:
+ /* Fall through the switch */
+ break;
+ case TADDR:
+ p1_addr (&(expr -> addrblock));
+ return;
+ case TPRIM:
+ warn ("p1_expr: got TPRIM");
+ return;
+ case TLIST:
+ p1_list (&(expr -> listblock));
+ return;
+ case TERROR:
+ return;
+ default:
+ erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
+ return;
+ } /* switch */
+
+/* Now we know that the tag is TEXPR */
+
+ if (is_unary_op (expr -> exprblock.opcode))
+ p1_unary (&(expr -> exprblock));
+ else if (is_binary_op (expr -> exprblock.opcode))
+ p1_binary (&(expr -> exprblock));
+ else
+ erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode);
+
+} /* p1_expr */
+
+
+
+static void p1_const(cp)
+ register Constp cp;
+{
+ int type = cp->vtype;
+ expptr vleng = cp->vleng;
+ union Constant *c = &cp->Const;
+ char cdsbuf0[64], cdsbuf1[64];
+ char *cds0, *cds1;
+
+ switch (type) {
+ case TYSHORT:
+ case TYLONG:
+ case TYLOGICAL:
+ p1putdd (P1_CONST, type, (int)c -> ci);
+ break;
+ case TYREAL:
+ case TYDREAL:
+ fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
+ cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ if (cp->vstg) {
+ cds0 = c->cds[0];
+ cds1 = c->cds[1];
+ }
+ else {
+ cds0 = cds(dtos(c->cd[0]), cdsbuf0);
+ cds1 = cds(dtos(c->cd[1]), cdsbuf1);
+ }
+ fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
+ cds0, cds1);
+ break;
+ case TYCHAR:
+ if (vleng && !ISICON (vleng))
+ erri("p1_const: bad vleng '%d'\n", (int) vleng);
+ else
+ fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
+ cpexpr((expptr)cp));
+ break;
+ default:
+ erri ("p1_const: bad constant type '%d'", type);
+ break;
+ } /* switch */
+} /* p1_const */
+
+
+void p1_asgoto (addrp)
+Addrp addrp;
+{
+ p1put (P1_ASGOTO);
+ p1_addr (addrp);
+} /* p1_asgoto */
+
+
+void p1_goto (stateno)
+ftnint stateno;
+{
+ p1putd (P1_GOTO, stateno);
+} /* p1_goto */
+
+
+static void p1_addr (addrp)
+ register struct Addrblock *addrp;
+{
+ int stg;
+
+ if (addrp == (struct Addrblock *) NULL)
+ return;
+
+ stg = addrp -> vstg;
+
+ if (ONEOF(stg, M(STGINIT)|M(STGREG))
+ || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
+ (!ISICON(addrp->memoffset)
+ || (addrp->uname_tag == UNAM_NAME
+ ? addrp->memoffset->constblock.Const.ci
+ != addrp->user.name->voffset
+ : addrp->memoffset->constblock.Const.ci))
+ || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
+ (!ISICON(addrp->memoffset)
+ || addrp->memoffset->constblock.Const.ci)
+ || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
+ {
+ p1_big_addr (addrp);
+ return;
+ }
+
+/* Write out a level of indirection for non-array arguments, which have
+ addrp -> memoffset set and are handled by p1_big_addr().
+ Lengths are passed by value, so don't check STGLENG
+ 28-Jun-89 (dmg) Added the check for != TYCHAR
+ */
+
+ if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
+ stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
+ p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
+ p1_expr (ENULL); /* Put dummy vleng */
+ } /* if stg == STGARG */
+
+ switch (addrp -> uname_tag) {
+ case UNAM_NAME:
+ p1_name (addrp -> user.name);
+ break;
+ case UNAM_IDENT:
+ p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
+ addrp->user.ident);
+ break;
+ case UNAM_CHARP:
+ p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
+ addrp->user.Charp);
+ break;
+ case UNAM_EXTERN:
+ p1putd (P1_EXTERN, (long) addrp -> memno);
+ if (addrp->vclass == CLPROC)
+ extsymtab[addrp->memno].extype = addrp->vtype;
+ break;
+ case UNAM_CONST:
+ if (addrp -> memno != BAD_MEMNO)
+ p1_literal (addrp -> memno);
+ else
+ p1_const((struct Constblock *)addrp);
+ break;
+ case UNAM_UNKNOWN:
+ default:
+ erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag);
+ break;
+ } /* switch */
+} /* p1_addr */
+
+
+static void p1_list (listp)
+struct Listblock *listp;
+{
+ chainp lis;
+ int count = 0;
+
+ if (listp == (struct Listblock *) NULL)
+ return;
+
+/* Count the number of parameters in the list */
+
+ for (lis = listp -> listp; lis; lis = lis -> nextp)
+ count++;
+
+ p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
+
+ for (lis = listp -> listp; lis; lis = lis -> nextp)
+ p1_expr ((expptr) lis -> datap);
+
+} /* p1_list */
+
+
+void p1_label (lab)
+long lab;
+{
+ if (parstate < INDATA)
+ earlylabs = mkchain((char *)lab, earlylabs);
+ else
+ p1putd (P1_LABEL, lab);
+ }
+
+
+
+static void p1_literal (memno)
+long memno;
+{
+ p1putd (P1_LITERAL, memno);
+} /* p1_literal */
+
+
+void p1_if (expr)
+expptr expr;
+{
+ p1put (P1_IF);
+ p1_expr (expr);
+} /* p1_if */
+
+
+
+
+void p1_elif (expr)
+expptr expr;
+{
+ p1put (P1_ELIF);
+ p1_expr (expr);
+} /* p1_elif */
+
+
+
+
+void p1_else ()
+{
+ p1put (P1_ELSE);
+} /* p1_else */
+
+
+
+
+void p1_endif ()
+{
+ p1put (P1_ENDIF);
+} /* p1_endif */
+
+
+
+
+void p1else_end ()
+{
+ p1put (P1_ENDELSE);
+} /* p1else_end */
+
+
+static void p1_big_addr (addrp)
+Addrp addrp;
+{
+ if (addrp == (Addrp) NULL)
+ return;
+
+ p1putn (P1_ADDR, sizeof (struct Addrblock), (char *) addrp);
+ p1_expr (addrp -> vleng);
+ p1_expr (addrp -> memoffset);
+ if (addrp->uname_tag == UNAM_NAME)
+ addrp->user.name->visused = 1;
+} /* p1_big_addr */
+
+
+
+static void p1_unary (e)
+struct Exprblock *e;
+{
+ if (e == (struct Exprblock *) NULL)
+ return;
+
+ p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
+ p1_expr (e -> vleng);
+
+ switch (e -> opcode) {
+ case OPNEG:
+ case OPNEG1:
+ case OPNOT:
+ case OPABS:
+ case OPBITNOT:
+ case OPPREINC:
+ case OPPREDEC:
+ case OPADDR:
+ case OPIDENTITY:
+ case OPCHARCAST:
+ case OPDABS:
+ p1_expr(e -> leftp);
+ break;
+ default:
+ erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
+ break;
+ } /* switch */
+
+} /* p1_unary */
+
+
+static void p1_binary (e)
+struct Exprblock *e;
+{
+ if (e == (struct Exprblock *) NULL)
+ return;
+
+ p1putdd (P1_EXPR, e -> opcode, e -> vtype);
+ p1_expr (e -> vleng);
+ p1_expr (e -> leftp);
+ p1_expr (e -> rightp);
+} /* p1_binary */
+
+
+void p1_head (class, name)
+int class;
+char *name;
+{
+ p1putds (P1_HEAD, class, name);
+} /* p1_head */
+
+
+void p1_subr_ret (retexp)
+expptr retexp;
+{
+
+ p1put (P1_SUBR_RET);
+ p1_expr (retexp);
+} /* p1_subr_ret */
+
+
+
+void p1comp_goto (index, count, labels)
+expptr index;
+int count;
+struct Labelblock *labels[];
+{
+ struct Constblock c;
+ int i;
+ register struct Labelblock *L;
+
+ p1put (P1_COMP_GOTO);
+ p1_expr (index);
+
+/* Write out a P1_LIST directly, to avoid the overhead of allocating a
+ list before it's needed HACK HACK HACK */
+
+ p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
+ c.vtype = TYLONG;
+ c.vleng = 0;
+
+ for (i = 0; i < count; i++) {
+ L = labels[i];
+ L->labused = 1;
+ c.Const.ci = L->stateno;
+ p1_const(&c);
+ } /* for i = 0 */
+} /* p1comp_goto */
+
+
+
+void p1_for (init, test, inc)
+expptr init, test, inc;
+{
+ p1put (P1_FOR);
+ p1_expr (init);
+ p1_expr (test);
+ p1_expr (inc);
+} /* p1_for */
+
+
+void p1for_end ()
+{
+ p1put (P1_ENDFOR);
+} /* p1for_end */
+
+
+
+
+/* ----------------------------------------------------------------------
+ The intermediate file actually gets written ONLY by the routines below.
+ To change the format of the file, you need only change these routines.
+ ----------------------------------------------------------------------
+*/
+
+
+/* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that
+ str contains no newlines and is null-terminated. */
+
+void p1puts (type, str)
+int type;
+char *str;
+{
+ fprintf (pass1_file, "%d: %s\n", type, str);
+} /* p1puts */
+
+
+/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
+
+static void p1putd (type, value)
+int type;
+long value;
+{
+ fprintf (pass1_file, "%d: %ld\n", type, value);
+} /* p1_putd */
+
+
+/* p1putdd -- Put a typed pair of integers into the intermediate file. */
+
+static void p1putdd (type, v1, v2)
+int type, v1, v2;
+{
+ fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
+} /* p1putdd */
+
+
+/* p1putddd -- Put a typed triple of integers into the intermediate file. */
+
+static void p1putddd (type, v1, v2, v3)
+int type, v1, v2, v3;
+{
+ fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
+} /* p1putddd */
+
+ union dL {
+ double d;
+ long L[2];
+ };
+
+static void p1putn (type, count, str)
+int type, count;
+char *str;
+{
+ int i;
+
+ fprintf (pass1_file, "%d: ", type);
+
+ for (i = 0; i < count; i++)
+ putc (str[i], pass1_file);
+
+ putc ('\n', pass1_file);
+} /* p1putn */
+
+
+
+/* p1put -- Put a type marker into the intermediate file. */
+
+void p1put(type)
+int type;
+{
+ fprintf (pass1_file, "%d:\n", type);
+} /* p1put */
+
+
+
+static void p1putds (type, i, str)
+int type;
+int i;
+char *str;
+{
+ fprintf (pass1_file, "%d: %d %s\n", type, i, str);
+} /* p1putds */
+
+
+static void p1putdds (token, type, stg, str)
+int token, type, stg;
+char *str;
+{
+ fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
+} /* p1putdds */
--- /dev/null
+#ifndef PARSE_INCLUDE
+# define PARSE_INCLUDE
+
+/* macros for the parse_args routine */
+
+#define P_STRING 1 /* Macros for the result_type attribute */
+#define P_CHAR 2
+#define P_SHORT 3
+#define P_LONG 4
+#define P_INT P_LONG
+#define P_FILE 5
+#define P_OLD_FILE 6
+#define P_NEW_FILE 7
+#define P_FLOAT 8
+#define P_DOUBLE 9
+
+#define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */
+#define P_REQUIRED_PREFIX 02
+
+#define P_NO_ARGS 0 /* Macros for the arg_count attribute */
+#define P_ONE_ARG 1
+#define P_INFINITE_ARGS 2
+
+#define p_entry(pref,swit,flag,count,type,store,size) \
+ { (pref), (swit), (flag), (count), (type), (int *) (store), (size) }
+
+typedef struct {
+ char *prefix;
+ char *string;
+ int flags;
+ int count;
+ int result_type;
+ int *result_ptr;
+ int table_size;
+} arg_info;
+
+extern int parse_args ();
+
+#endif
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* parse_args
+
+ This function will parse command line input into appropriate data
+ structures, output error messages when appropriate and provide some
+ minimal type conversion.
+
+ Input to the function consists of the standard argc,argv
+ values, and a table which directs the parser. Each table entry has the
+ following components:
+
+ prefix -- the (optional) switch character string, e.g. "-" "/" "="
+ switch -- the command string, e.g. "o" "data" "file" "F"
+ flags -- control flags, e.g. CASE_INSENSITIVE, REQUIRED_PREFIX
+ arg_count -- number of arguments this command requires, e.g. 0 for
+ booleans, 1 for filenames, INFINITY for input files
+ result_type -- how to interpret the switch arguments, e.g. STRING,
+ CHAR, FILE, OLD_FILE, NEW_FILE
+ result_ptr -- pointer to storage for the result, be it a table or
+ a string or whatever
+ table_size -- if the arguments fill a table, the maximum number of
+ entries; if there are no arguments, the value to
+ load into the result storage
+
+ Although the table can be used to hold a list of filenames, only
+ scalar values (e.g. pointers) can be stored in the table. No vector
+ processing will be done, only pointers to string storage will be moved.
+
+ An example entry, which could be used to parse input filenames, is:
+
+ "-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE
+
+*/
+
+#include <stdio.h>
+#ifndef NULL
+/* ANSI C */
+#include <stddef.h>
+#endif
+#include "parse.h"
+#include <math.h> /* For atof */
+#include <ctype.h>
+
+#define MAX_INPUT_SIZE 1000
+
+#define arg_prefix(x) ((x).prefix)
+#define arg_string(x) ((x).string)
+#define arg_flags(x) ((x).flags)
+#define arg_count(x) ((x).count)
+#define arg_result_type(x) ((x).result_type)
+#define arg_result_ptr(x) ((x).result_ptr)
+#define arg_table_size(x) ((x).table_size)
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+#ifndef FALSE
+#define FALSE 0
+#endif
+typedef int boolean;
+
+
+char *lower_string (/* char [], char * */);
+
+static char *this_program = "";
+
+extern long atol();
+static int arg_parse (/* char *, arg_info * */);
+
+
+boolean parse_args (argc, argv, table, entries, others, other_count)
+int argc;
+char *argv[];
+arg_info table[];
+int entries;
+char *others[];
+int other_count;
+{
+ boolean arg_verify (/* argv, table, entries */);
+ void init_store (/* table, entries */);
+
+ boolean result;
+
+ if (argv)
+ this_program = argv[0];
+
+/* Check the validity of the table and its parameters */
+
+ result = arg_verify (argv, table, entries);
+
+/* Initialize the storage values */
+
+ init_store (table, entries);
+
+ if (result) {
+ boolean use_prefix = TRUE;
+
+ argc--;
+ argv++;
+ while (argc) {
+ int index, length;
+
+ index = match_table (*argv, table, entries, use_prefix, &length);
+ if (index < 0) {
+
+/* The argument doesn't match anything in the table */
+
+ if (others) {
+
+/* Might want to filter out those strings which appear after earlier
+ switches in the current word. That is, only treat argv as valid if
+ use_prefix is true. Right now, any extra chars will be passed on */
+
+ if (other_count > 0) {
+ *others++ = *argv;
+ other_count--;
+ } else {
+ fprintf (stderr, "%s: too many parameters: ",
+ this_program);
+ fprintf (stderr, "'%s' ignored\n", *argv);
+ } /* else */
+ } /* if (others) */
+ argv++;
+ argc--;
+ } else {
+
+/* A match was found */
+
+ if (length >= strlen (*argv)) {
+ argc--;
+ argv++;
+ use_prefix = TRUE;
+ } else {
+ (*argv) += length;
+ use_prefix = FALSE;
+ } /* else */
+
+/* Parse any necessary arguments */
+
+ if (arg_count (table[index]) != P_NO_ARGS) {
+
+/* Now length will be used to store the number of parsed characters */
+
+ length = arg_parse(*argv, &table[index]);
+ if (*argv == NULL)
+ argc = 0;
+ else if (length >= strlen (*argv)) {
+ argc--;
+ argv++;
+ use_prefix = TRUE;
+ } else {
+ (*argv) += length;
+ use_prefix = FALSE;
+ } /* else */
+ } /* if (argv_count != P_NO_ARGS) */
+ else
+ *arg_result_ptr(table[index]) =
+ arg_table_size(table[index]);
+ } /* else */
+ } /* while (argc) */
+ } /* if (result) */
+
+ return result;
+} /* parse_args */
+
+
+boolean arg_verify (argv, table, entries)
+char *argv[];
+arg_info table[];
+int entries;
+{
+ int i;
+ char *this_program = "";
+
+ if (argv)
+ this_program = argv[0];
+
+ for (i = 0; i < entries; i++) {
+ arg_info *arg = &table[i];
+
+/* Check the argument flags */
+
+ if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) {
+ fprintf (stderr, "%s [arg_verify]: too many ", this_program);
+ fprintf (stderr, "flags in entry %d: '%x' (hex)\n", i,
+ arg_flags (*arg));
+ } /* if */
+
+/* Check the argument count */
+
+ { int count = arg_count (*arg);
+
+ if (count != P_NO_ARGS && count != P_ONE_ARG && count !=
+ P_INFINITE_ARGS) {
+ fprintf (stderr, "%s [arg_verify]: invalid ", this_program);
+ fprintf (stderr, "argument count in entry %d: '%d'\n", i,
+ count);
+ } /* if count != P_NO_ARGS ... */
+
+/* Check the result field; want to be able to store results */
+
+ else
+ if (arg_result_ptr (*arg) == (int *) NULL) {
+ fprintf (stderr, "%s [arg_verify]: ", this_program);
+ fprintf (stderr, "no argument storage given for ");
+ fprintf (stderr, "entry %d\n", i);
+ } /* if arg_result_ptr */
+ }
+
+/* Check the argument type */
+
+ { int type = arg_result_type (*arg);
+
+ if (type != P_STRING &&
+ type != P_CHAR &&
+ type != P_SHORT &&
+ type != P_LONG &&
+ type != P_INT &&
+ type != P_FILE &&
+ type != P_OLD_FILE &&
+ type != P_NEW_FILE &&
+ type != P_FLOAT &&
+ type != P_DOUBLE) {
+ fprintf (stderr, "%s [arg_verify]: bad ", this_program);
+ fprintf (stderr, "arg type in entry %d: '%d'\n", i,
+ type);
+ } /* if type != .... */
+ }
+
+/* Check table size */
+
+ { int size = arg_table_size (*arg);
+
+ if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) {
+ fprintf (stderr, "%s [arg_verify]: bad ", this_program);
+ fprintf (stderr, "table size in entry %d: '%d'\n", i,
+ size);
+ } /* if (arg_count == P_INFINITE_ARGS && size < 1) */
+ }
+
+ } /* for i = 0 */
+
+ return TRUE;
+} /* arg_verify */
+
+
+/* match_table -- returns the index of the best entry matching the input,
+ -1 if no match. The best match is the one of longest length which
+ appears lowest in the table. The length of the match will be returned
+ in length ONLY IF a match was found. */
+
+int match_table (norm_input, table, entries, use_prefix, length)
+register char *norm_input;
+arg_info table[];
+int entries;
+boolean use_prefix;
+int *length;
+{
+ extern int match (/* char *, char *, arg_info *, boolean */);
+
+ char low_input[MAX_INPUT_SIZE];
+ register int i;
+ int best_index = -1, best_length = 0;
+
+/* FUNCTION BODY */
+
+ (void) lower_string (low_input, norm_input);
+
+ for (i = 0; i < entries; i++) {
+ int this_length = match (norm_input, low_input, &table[i], use_prefix);
+
+ if (this_length > best_length) {
+ best_index = i;
+ best_length = this_length;
+ } /* if (this_length > best_length) */
+ } /* for (i = 0) */
+
+ if (best_index > -1 && length != (int *) NULL)
+ *length = best_length;
+
+ return best_index;
+} /* match_table */
+
+
+/* match -- takes an input string and table entry, and returns the length
+ of the longer match.
+
+ 0 ==> input doesn't match
+
+ For example:
+
+ INPUT PREFIX STRING RESULT
+----------------------------------------------------------------------
+ "abcd" "-" "d" 0
+ "-d" "-" "d" 2 (i.e. "-d")
+ "dout" "-" "d" 1 (i.e. "d")
+ "-d" "" "-d" 2 (i.e. "-d")
+ "dd" "d" "d" 2 <= here's the weird one
+*/
+
+int match (norm_input, low_input, entry, use_prefix)
+char *norm_input, *low_input;
+arg_info *entry;
+boolean use_prefix;
+{
+ char *norm_prefix = arg_prefix (*entry);
+ char *norm_string = arg_string (*entry);
+ boolean prefix_match = FALSE, string_match = FALSE;
+ int result = 0;
+
+/* Buffers for the lowercased versions of the strings being compared.
+ These are used when the switch is to be case insensitive */
+
+ static char low_prefix[MAX_INPUT_SIZE];
+ static char low_string[MAX_INPUT_SIZE];
+ int prefix_length = strlen (norm_prefix);
+ int string_length = strlen (norm_string);
+
+/* Pointers for the required strings (lowered or nonlowered) */
+
+ register char *input, *prefix, *string;
+
+/* FUNCTION BODY */
+
+/* Use the appropriate strings to handle case sensitivity */
+
+ if (arg_flags (*entry) & P_CASE_INSENSITIVE) {
+ input = low_input;
+ prefix = lower_string (low_prefix, norm_prefix);
+ string = lower_string (low_string, norm_string);
+ } else {
+ input = norm_input;
+ prefix = norm_prefix;
+ string = norm_string;
+ } /* else */
+
+/* First, check the string formed by concatenating the prefix onto the
+ switch string, but only when the prefix is not being ignored */
+
+ if (use_prefix && prefix != NULL && *prefix != '\0')
+ prefix_match = (strncmp (input, prefix, prefix_length) == 0) &&
+ (strncmp (input + prefix_length, string, string_length) == 0);
+
+/* Next, check just the switch string, if that's allowed */
+
+ if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0)
+ string_match = strncmp (input, string, string_length) == 0;
+
+ if (prefix_match)
+ result = prefix_length + string_length;
+ else if (string_match)
+ result = string_length;
+
+ return result;
+} /* match */
+
+
+char *lower_string (dest, src)
+char *dest, *src;
+{
+ char *result = dest;
+ register int c;
+
+ if (dest == NULL || src == NULL)
+ result = NULL;
+ else
+ while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c);
+
+ return result;
+} /* lower_string */
+
+
+/* arg_parse -- returns the number of characters parsed for this entry */
+
+static int arg_parse (str, entry)
+char *str;
+arg_info *entry;
+{
+ int length = 0;
+
+ if (arg_count (*entry) == P_ONE_ARG) {
+ char **store = (char **) arg_result_ptr (*entry);
+
+ length = put_one_arg (arg_result_type (*entry), str, store,
+ arg_prefix (*entry), arg_string (*entry));
+
+ } /* if (arg_count == P_ONE_ARG) */
+ else { /* Must be a table of arguments */
+ char **store = (char **) arg_result_ptr (*entry);
+
+ if (store) {
+ while (*store)
+ store++;
+
+ length = put_one_arg (arg_result_type (*entry), str, store++,
+ arg_prefix (*entry), arg_string (*entry));
+
+ *store = (char *) NULL;
+ } /* if (store) */
+ } /* else */
+
+ return length;
+} /* arg_parse */
+
+
+int put_one_arg (type, str, store, prefix, string)
+int type;
+char *str;
+char **store;
+char *prefix, *string;
+{
+ int length = 0;
+
+ if (store) {
+ switch (type) {
+ case P_STRING:
+ case P_FILE:
+ case P_OLD_FILE:
+ case P_NEW_FILE:
+ *store = str;
+ if (str == NULL)
+ fprintf (stderr, "%s: Missing argument after '%s%s'\n",
+ this_program, prefix, string);
+ length = str ? strlen (str) : 0;
+ break;
+ case P_CHAR:
+ *((char *) store) = *str;
+ length = 1;
+ break;
+ case P_SHORT: {
+ long int i = atol(str);
+
+ *((short *) store) = (short) i;
+ if (i > 32767 || i < -32768) {
+ fprintf (stderr, "%s%s parameter '%ld' is not a ",
+ prefix, string, i);
+ fprintf (stderr, "SHORT INT (truncating to %d)\n",
+ (short) (*store));
+ } /* if i > 32767 || i < -32768 */
+
+/* This is pessimistic, and should change */
+
+ length = strlen (str);
+ break; }
+ case P_LONG:
+ *((int *) store) = atol(str);
+
+/* This is pessimistic too */
+
+ length = strlen (str);
+ break;
+ case P_FLOAT:
+ *((float *) store) = (float) atof (str);
+ length = strlen (str);
+ break;
+ case P_DOUBLE:
+ *((double *) store) = (double) atof (str);
+ length = strlen (str);
+ break;
+ default:
+ fprintf (stderr, "put_one_arg: bad type '%d'\n",
+ type);
+ break;
+ } /* switch */
+ } /* if (store) */
+
+ return length;
+} /* put_one_arg */
+
+
+void init_store (table, entries)
+arg_info *table;
+int entries;
+{
+ int index;
+
+ for (index = 0; index < entries; index++)
+ if (arg_count (table[index]) == P_INFINITE_ARGS) {
+ char **place = (char **) arg_result_ptr (table[index]);
+
+ if (place)
+ *place = (char *) NULL;
+ } /* if arg_count == P_INFINITE_ARGS */
+
+} /* init_store */
+
--- /dev/null
+/* The following numbers are strange, and implementation-dependent */
+
+#define P2BAD -1
+#define P2NAME 2
+#define P2ICON 4 /* Integer constant */
+#define P2PLUS 6
+#define P2PLUSEQ 7
+#define P2MINUS 8
+#define P2NEG 10
+#define P2STAR 11
+#define P2STAREQ 12
+#define P2INDIRECT 13
+#define P2BITAND 14
+#define P2BITOR 17
+#define P2BITXOR 19
+#define P2QUEST 21
+#define P2COLON 22
+#define P2ANDAND 23
+#define P2OROR 24
+#define P2GOTO 37
+#define P2LISTOP 56
+#define P2ASSIGN 58
+#define P2COMOP 59
+#define P2SLASH 60
+#define P2MOD 62
+#define P2LSHIFT 64
+#define P2RSHIFT 66
+#define P2CALL 70
+#define P2CALL0 72
+
+#define P2NOT 76
+#define P2BITNOT 77
+#define P2EQ 80
+#define P2NE 81
+#define P2LE 82
+#define P2LT 83
+#define P2GE 84
+#define P2GT 85
+#define P2REG 94
+#define P2OREG 95
+#define P2CONV 104
+#define P2FORCE 108
+#define P2CBRANCH 109
+
+/* special operators included only for fortran's use */
+
+#define P2PASS 200
+#define P2STMT 201
+#define P2SWITCH 202
+#define P2LBRACKET 203
+#define P2RBRACKET 204
+#define P2EOF 205
+#define P2ARIF 206
+#define P2LABEL 207
+
+#define P2SHORT 3
+#define P2INT 4
+#define P2LONG 4
+
+#define P2CHAR 2
+#define P2REAL 6
+#define P2DREAL 7
+#define P2PTR 020
+#define P2FUNCT 040
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+ static char Ptok[128], Pct[256];
+ static char *Pfname;
+ static long Plineno;
+ static int Pbad;
+ static int *tfirst, *tlast, *tnext, tmax;
+
+#define P_space 1
+#define P_anum 2
+#define P_delim 3
+#define P_slash 4
+
+#define TGULP 100
+
+ static void
+trealloc()
+{
+ char *realloc();
+ int k = tmax;
+ tfirst = (int *)realloc((char *)tfirst,
+ (tmax += TGULP)*sizeof(int));
+ if (!tfirst) {
+ fprintf(stderr,
+ "Pfile: realloc failure!\n");
+ exit(2);
+ }
+ tlast = tfirst + tmax;
+ tnext = tfirst + k;
+ }
+
+ static void
+badchar(c)
+ int c;
+{
+ fprintf(stderr,
+ "unexpected character 0x%.2x = '%c' on line %ld of %s\n",
+ c, c, Plineno, Pfname);
+ exit(2);
+ }
+
+ static void
+bad_type()
+{
+ fprintf(stderr,
+ "unexpected type \"%s\" on line %ld of %s\n",
+ Ptok, Plineno, Pfname);
+ exit(2);
+ }
+
+ static void
+badflag(tname, option)
+ char *tname, *option;
+{
+ fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n",
+ tname, option, Plineno, Pfname);
+ Pbad++;
+ }
+
+ static void
+detected(msg)
+ char *msg;
+{
+ fprintf(stderr,
+ "%sdetected on line %ld of %s\n", msg, Plineno, Pfname);
+ Pbad++;
+ }
+
+ static void
+checklogical(k)
+ int k;
+{
+ static int lastmsg = 0;
+ static int seen[2] = {0,0};
+
+ seen[k] = 1;
+ if (seen[1-k]) {
+ if (lastmsg < 3) {
+ lastmsg = 3;
+ detected(
+ "Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t");
+ }
+ return;
+ }
+ if (k) {
+ if (tylogical == TYLONG || lastmsg >= 2)
+ return;
+ if (!lastmsg) {
+ lastmsg = 2;
+ badflag("LOGICAL", "I4");
+ }
+ }
+ else {
+ if (tylogical == TYSHORT || lastmsg & 1)
+ return;
+ if (!lastmsg) {
+ lastmsg = 1;
+ badflag("LOGICAL", "i2` or `f2c -I2");
+ }
+ }
+ }
+
+ static void
+checkreal(k)
+{
+ static int warned = 0;
+ static int seen[2] = {0,0};
+
+ seen[k] = 1;
+ if (seen[1-k]) {
+ if (warned < 2)
+ detected("Illegal mixture of -R and -!R ");
+ warned = 2;
+ return;
+ }
+ if (k == forcedouble || warned)
+ return;
+ warned = 1;
+ badflag("REAL return", k ? "!R" : "R");
+ }
+
+ static void
+Pnotboth(e)
+ Extsym *e;
+{
+ if (e->curno)
+ return;
+ Pbad++;
+ e->curno = 1;
+ fprintf(stderr,
+ "%s cannot be both a procedure and a common block (line %ld of %s)\n",
+ e->fextname, Plineno, Pfname);
+ }
+
+ static int
+numread(pf, n)
+ register FILE *pf;
+ int *n;
+{
+ register int c, k;
+
+ if ((c = getc(pf)) < '0' || c > '9')
+ return c;
+ k = c - '0';
+ for(;;) {
+ if ((c = getc(pf)) == ' ') {
+ *n = k;
+ return c;
+ }
+ if (c < '0' || c > '9')
+ break;
+ k = 10*k + c - '0';
+ }
+ return c;
+ }
+
+ static void argverify(), Pbadret();
+
+ static int
+readref(pf, e, ftype)
+ register FILE *pf;
+ Extsym *e;
+ int ftype;
+{
+ register int c, *t;
+ int i, nargs, type;
+ Argtypes *at;
+ Atype *a, *ae;
+
+ if (ftype > TYSUBR)
+ return 0;
+ if ((c = numread(pf, &nargs)) != ' ') {
+ if (c != ':')
+ return c == EOF;
+ /* just a typed external */
+ if (e->extstg == STGUNKNOWN) {
+ at = 0;
+ goto justsym;
+ }
+ if (e->extstg == STGEXT) {
+ if (e->extype != ftype)
+ Pbadret(ftype, e);
+ }
+ else
+ Pnotboth(e);
+ return 0;
+ }
+
+ tnext = tfirst;
+ for(i = 0; i < nargs; i++) {
+ if ((c = numread(pf, &type)) != ' '
+ || type >= 500
+ || type != TYFTNLEN + 100 && type % 100 > TYSUBR)
+ return c == EOF;
+ if (tnext >= tlast)
+ trealloc();
+ *tnext++ = type;
+ }
+
+ if (e->extstg == STGUNKNOWN) {
+ save_at:
+ at = (Argtypes *)
+ gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1);
+ at->nargs = nargs;
+ at->changes = 0;
+ t = tfirst;
+ a = at->atypes;
+ for(ae = a + nargs; a < ae; a++) {
+ a->type = *t++;
+ a->cp = 0;
+ }
+ justsym:
+ e->extstg = STGEXT;
+ e->extype = ftype;
+ e->arginfo = at;
+ }
+ else if (e->extstg != STGEXT) {
+ Pnotboth(e);
+ }
+ else if (!e->arginfo) {
+ if (e->extype != ftype)
+ Pbadret(ftype, e);
+ else
+ goto save_at;
+ }
+ else
+ argverify(ftype, e);
+ return 0;
+ }
+
+ static int
+comlen(pf)
+ register FILE *pf;
+{
+ register int c;
+ register char *s, *se;
+ char buf[128], cbuf[128];
+ int refread;
+ long L;
+ Extsym *e;
+
+ if ((c = getc(pf)) == EOF)
+ return 1;
+ if (c == ' ') {
+ refread = 0;
+ s = "comlen ";
+ }
+ else if (c == ':') {
+ refread = 1;
+ s = "ref: ";
+ }
+ else {
+ ret0:
+ if (c == '*')
+ ungetc(c,pf);
+ return 0;
+ }
+ while(*s) {
+ if ((c = getc(pf)) == EOF)
+ return 1;
+ if (c != *s++)
+ goto ret0;
+ }
+ s = buf;
+ se = buf + sizeof(buf) - 1;
+ for(;;) {
+ if ((c = getc(pf)) == EOF)
+ return 1;
+ if (c == ' ')
+ break;
+ if (s >= se || Pct[c] != P_anum)
+ goto ret0;
+ *s++ = c;
+ }
+ *s-- = 0;
+ if (s <= buf || *s != '_')
+ return 0;
+ strcpy(cbuf,buf);
+ *s-- = 0;
+ if (*s == '_') {
+ *s-- = 0;
+ if (s <= buf)
+ return 0;
+ }
+ for(L = 0;;) {
+ if ((c = getc(pf)) == EOF)
+ return 1;
+ if (c == ' ')
+ break;
+ if (c < '0' && c > '9')
+ goto ret0;
+ L = 10*L + c - '0';
+ }
+ if (!L && !refread)
+ return 0;
+ e = mkext(buf, cbuf);
+ if (refread)
+ return readref(pf, e, (int)L);
+ if (e->extstg == STGUNKNOWN) {
+ e->extstg = STGCOMMON;
+ e->maxleng = L;
+ }
+ else if (e->extstg != STGCOMMON)
+ Pnotboth(e);
+ else if (e->maxleng != L) {
+ fprintf(stderr,
+ "incompatible lengths for common block %s (line %ld of %s)\n",
+ buf, Plineno, Pfname);
+ if (e->maxleng < L)
+ e->maxleng = L;
+ }
+ return 0;
+ }
+
+ static int
+Ptoken(pf, canend)
+ FILE *pf;
+ int canend;
+{
+ register int c;
+ register char *s, *se;
+
+ top:
+ for(;;) {
+ c = getc(pf);
+ if (c == EOF) {
+ if (canend)
+ return 0;
+ goto badeof;
+ }
+ if (Pct[c] != P_space)
+ break;
+ if (c == '\n')
+ Plineno++;
+ }
+ switch(Pct[c]) {
+ case P_anum:
+ if (c == '_')
+ badchar(c);
+ s = Ptok;
+ se = s + sizeof(Ptok) - 1;
+ do {
+ if (s < se)
+ *s++ = c;
+ if ((c = getc(pf)) == EOF) {
+ badeof:
+ fprintf(stderr,
+ "unexpected end of file in %s\n",
+ Pfname);
+ exit(2);
+ }
+ }
+ while(Pct[c] == P_anum);
+ ungetc(c,pf);
+ *s = 0;
+ return P_anum;
+
+ case P_delim:
+ return c;
+
+ case P_slash:
+ if ((c = getc(pf)) != '*') {
+ if (c == EOF)
+ goto badeof;
+ badchar('/');
+ }
+ if (canend && comlen(pf))
+ goto badeof;
+ for(;;) {
+ while((c = getc(pf)) != '*') {
+ if (c == EOF)
+ goto badeof;
+ if (c == '\n')
+ Plineno++;
+ }
+ slashseek:
+ switch(getc(pf)) {
+ case '/':
+ goto top;
+ case EOF:
+ goto badeof;
+ case '*':
+ goto slashseek;
+ }
+ }
+ default:
+ badchar(c);
+ }
+ /* NOT REACHED */
+ return 0;
+ }
+
+ static int
+Pftype()
+{
+ switch(Ptok[0]) {
+ case 'C':
+ if (!strcmp(Ptok+1, "_f"))
+ return TYCOMPLEX;
+ break;
+ case 'E':
+ if (!strcmp(Ptok+1, "_f")) {
+ /* TYREAL under forcedouble */
+ checkreal(1);
+ return TYREAL;
+ }
+ break;
+ case 'H':
+ if (!strcmp(Ptok+1, "_f"))
+ return TYCHAR;
+ break;
+ case 'Z':
+ if (!strcmp(Ptok+1, "_f"))
+ return TYDCOMPLEX;
+ break;
+ case 'd':
+ if (!strcmp(Ptok+1, "oublereal"))
+ return TYDREAL;
+ break;
+ case 'i':
+ if (!strcmp(Ptok+1, "nt"))
+ return TYSUBR;
+ if (!strcmp(Ptok+1, "nteger"))
+ return TYLONG;
+ break;
+ case 'l':
+ if (!strcmp(Ptok+1, "ogical")) {
+ checklogical(1);
+ return TYLOGICAL;
+ }
+ break;
+ case 'r':
+ if (!strcmp(Ptok+1, "eal")) {
+ checkreal(0);
+ return TYREAL;
+ }
+ break;
+ case 's':
+ if (!strcmp(Ptok+1, "hortint"))
+ return TYSHORT;
+ if (!strcmp(Ptok+1, "hortlogical")) {
+ checklogical(0);
+ return TYLOGICAL;
+ }
+ break;
+ }
+ bad_type();
+ /* NOT REACHED */
+ return 0;
+ }
+
+ static void
+wanted(i, what)
+ int i;
+ char *what;
+{
+ if (i != P_anum) {
+ Ptok[0] = i;
+ Ptok[1] = 0;
+ }
+ fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n",
+ what, Ptok, Plineno, Pfname);
+ exit(2);
+ }
+
+ static int
+Ptype(pf)
+ FILE *pf;
+{
+ int i, rv;
+
+ i = Ptoken(pf,0);
+ if (i == ')')
+ return 0;
+ if (i != P_anum)
+ badchar(i);
+
+ rv = 0;
+ switch(Ptok[0]) {
+ case 'C':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYCOMPLEX+200;
+ break;
+ case 'D':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYDREAL+200;
+ break;
+ case 'E':
+ case 'R':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYREAL+200;
+ break;
+ case 'H':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYCHAR+200;
+ break;
+ case 'I':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYLONG+200;
+ break;
+ case 'J':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYSHORT+200;
+ break;
+ case 'K':
+ checklogical(0);
+ goto Logical;
+ case 'L':
+ checklogical(1);
+ Logical:
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYLOGICAL+200;
+ break;
+ case 'S':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYSUBR+200;
+ break;
+ case 'U':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYUNKNOWN+300;
+ break;
+ case 'Z':
+ if (!strcmp(Ptok+1, "_fp"))
+ rv = TYDCOMPLEX+200;
+ break;
+ case 'c':
+ if (!strcmp(Ptok+1, "har"))
+ rv = TYCHAR;
+ else if (!strcmp(Ptok+1, "omplex"))
+ rv = TYCOMPLEX;
+ break;
+ case 'd':
+ if (!strcmp(Ptok+1, "oublereal"))
+ rv = TYDREAL;
+ else if (!strcmp(Ptok+1, "oublecomplex"))
+ rv = TYDCOMPLEX;
+ break;
+ case 'f':
+ if (!strcmp(Ptok+1, "tnlen"))
+ rv = TYFTNLEN+100;
+ break;
+ case 'i':
+ if (!strcmp(Ptok+1, "nteger"))
+ rv = TYLONG;
+ break;
+ case 'l':
+ if (!strcmp(Ptok+1, "ogical")) {
+ checklogical(1);
+ rv = TYLOGICAL;
+ }
+ break;
+ case 'r':
+ if (!strcmp(Ptok+1, "eal"))
+ rv = TYREAL;
+ break;
+ case 's':
+ if (!strcmp(Ptok+1, "hortint"))
+ rv = TYSHORT;
+ else if (!strcmp(Ptok+1, "hortlogical")) {
+ checklogical(0);
+ rv = TYLOGICAL;
+ }
+ break;
+ case 'v':
+ if (tnext == tfirst && !strcmp(Ptok+1, "oid")) {
+ if ((i = Ptoken(pf,0)) != /*(*/ ')')
+ wanted(i, /*(*/ "\")\"");
+ return 0;
+ }
+ }
+ if (!rv)
+ bad_type();
+ if (rv < 100 && (i = Ptoken(pf,0)) != '*')
+ wanted(i, "\"*\"");
+ if ((i = Ptoken(pf,0)) == P_anum)
+ i = Ptoken(pf,0); /* skip variable name */
+ switch(i) {
+ case ')':
+ ungetc(i,pf);
+ break;
+ case ',':
+ break;
+ default:
+ wanted(i, "\",\" or \")\"");
+ }
+ return rv;
+ }
+
+ static char *
+trimunder()
+{
+ register char *s;
+ register int n;
+ static char buf[128];
+
+ s = Ptok + strlen(Ptok) - 1;
+ if (*s != '_') {
+ fprintf(stderr,
+ "warning: %s does not end in _ (line %ld of %s)\n",
+ Ptok, Plineno, Pfname);
+ return Ptok;
+ }
+ if (s[-1] == '_')
+ s--;
+ strncpy(buf, Ptok, n = s - Ptok);
+ buf[n] = 0;
+ return buf;
+ }
+
+ static void
+Pbadmsg(msg, p)
+ char *msg;
+ Extsym *p;
+{
+ Pbad++;
+ fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
+ p->fextname, Plineno, Pfname);
+ p->arginfo->nargs = -1;
+ }
+
+ char *Argtype();
+
+ static void
+Pbadret(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+ char buf1[32], buf2[32];
+
+ Pbadmsg("inconsistent types",p);
+ fprintf(stderr, "here %s, previously %s\n",
+ Argtype(ftype+200,buf1),
+ Argtype(p->extype+200,buf2));
+ }
+
+ static void
+argverify(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+ Argtypes *at;
+ register Atype *aty;
+ int i, j, k;
+ register int *t, *te;
+ char buf1[32], buf2[32];
+ int type_fixup();
+
+ at = p->arginfo;
+ if (at->nargs < 0)
+ return;
+ if (p->extype != ftype) {
+ Pbadret(ftype, p);
+ return;
+ }
+ t = tfirst;
+ te = tnext;
+ i = te - t;
+ if (at->nargs != i) {
+ j = at->nargs;
+ Pbadmsg("differing numbers of arguments",p);
+ fprintf(stderr, "here %d, previously %d\n",
+ i, j);
+ return;
+ }
+ for(aty = at->atypes; t < te; t++, aty++) {
+ if (*t == aty->type)
+ continue;
+ j = aty->type;
+ k = *t;
+ if (k >= 300 || k == j)
+ continue;
+ if (j >= 300) {
+ if (k >= 200) {
+ if (k == TYUNKNOWN + 200)
+ continue;
+ if (j % 100 != k - 200
+ && k != TYSUBR + 200
+ && j != TYUNKNOWN + 300
+ && !type_fixup(at,aty,k))
+ goto badtypes;
+ }
+ else if (j % 100 % TYSUBR != k % TYSUBR
+ && !type_fixup(at,aty,k))
+ goto badtypes;
+ }
+ else if (k < 200 || j < 200)
+ goto badtypes;
+ else if (k == TYUNKNOWN+200)
+ continue;
+ else if (j != TYUNKNOWN+200)
+ {
+ badtypes:
+ Pbadmsg("differing calling sequences",p);
+ i = t - tfirst + 1;
+ fprintf(stderr,
+ "arg %d: here %s, prevously %s\n",
+ i, Argtype(k,buf1), Argtype(j,buf2));
+ return;
+ }
+ /* We've subsequently learned the right type,
+ as in the call on zoo below...
+
+ subroutine foo(x, zap)
+ external zap
+ call goo(zap)
+ x = zap(3)
+ call zoo(zap)
+ end
+ */
+ aty->type = k;
+ at->changes = 1;
+ }
+ }
+
+ static void
+newarg(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+ Argtypes *at;
+ register Atype *aty;
+ register int *t, *te;
+ int i, k;
+
+ if (p->extstg == STGCOMMON) {
+ Pnotboth(p);
+ return;
+ }
+ p->extstg = STGEXT;
+ p->extype = ftype;
+ p->exproto = 1;
+ t = tfirst;
+ te = tnext;
+ i = te - t;
+ k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
+ at = p->arginfo = (Argtypes *)gmem(k,1);
+ at->nargs = i;
+ at->changes = 0;
+ for(aty = at->atypes; t < te; aty++) {
+ aty->type = *t++;
+ aty->cp = 0;
+ }
+ }
+
+ static int
+Pfile(fname)
+ char *fname;
+{
+ char *s;
+ int ftype, i;
+ FILE *pf;
+ Extsym *p;
+
+ for(s = fname; *s; s++);
+ if (s - fname < 2
+ || s[-2] != '.'
+ || (s[-1] != 'P' && s[-1] != 'p'))
+ return 0;
+
+ if (!(pf = fopen(fname, textread))) {
+ fprintf(stderr, "can't open %s\n", fname);
+ exit(2);
+ }
+ Pfname = fname;
+ Plineno = 1;
+ if (!Pct[' ']) {
+ for(s = " \t\n\r\v\f"; *s; s++)
+ Pct[*s] = P_space;
+ for(s = "*,();"; *s; s++)
+ Pct[*s] = P_delim;
+ for(i = '0'; i <= '9'; i++)
+ Pct[i] = P_anum;
+ for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++)
+ Pct[i] = Pct[i+'A'-'a'] = P_anum;
+ Pct['_'] = P_anum;
+ Pct['/'] = P_slash;
+ }
+
+ for(;;) {
+ if (!(i = Ptoken(pf,1)))
+ break;
+ if (i != P_anum
+ || !strcmp(Ptok, "extern")
+ && (i = Ptoken(pf,0)) != P_anum)
+ badchar(i);
+ ftype = Pftype();
+ getname:
+ if ((i = Ptoken(pf,0)) != P_anum)
+ badchar(i);
+ p = mkext(trimunder(), Ptok);
+
+ if ((i = Ptoken(pf,0)) != '(')
+ badchar(i);
+ tnext = tfirst;
+ while(i = Ptype(pf)) {
+ if (tnext >= tlast)
+ trealloc();
+ *tnext++ = i;
+ }
+ if (p->arginfo)
+ argverify(ftype, p);
+ else
+ newarg(ftype, p);
+ i = Ptoken(pf,0);
+ switch(i) {
+ case ';':
+ break;
+ case ',':
+ goto getname;
+ default:
+ wanted(i, "\";\" or \",\"");
+ }
+ }
+ fclose(pf);
+ return 1;
+ }
+
+ void
+read_Pfiles(ffiles)
+ char **ffiles;
+{
+ char **f1files, **f1files0, *s;
+ int k;
+ register Extsym *e, *ee;
+ register Argtypes *at;
+ extern int retcode;
+
+ f1files0 = f1files = ffiles;
+ while(s = *ffiles++)
+ if (!Pfile(s))
+ *f1files++ = s;
+ if (Pbad)
+ retcode = 8;
+ if (tfirst) {
+ free((char *)tfirst);
+ /* following should be unnecessary, as we won't be back here */
+ tfirst = tnext = tlast = 0;
+ tmax = 0;
+ }
+ *f1files = 0;
+ if (f1files == f1files0)
+ f1files[1] = 0;
+
+ k = 0;
+ ee = nextext;
+ for (e = extsymtab; e < ee; e++)
+ if (e->extstg == STGEXT
+ && (at = e->arginfo)) {
+ if (at->nargs < 0 || at->changes)
+ k++;
+ at->changes = 2;
+ }
+ if (k) {
+ fprintf(diagfile,
+ "%d prototype%s updated while reading prototypes.\n", k,
+ k > 1 ? "s" : "");
+ }
+ fflush(diagfile);
+ }
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+#include "p1defs.h"
+
+#define EXNULL (union Expression *)0
+
+LOCAL dobss(), docomleng(), docommon(), doentry(),
+ epicode(), nextarg(), retval();
+
+static char Blank[] = BLANKCOMMON;
+
+ static char *postfix[] = { "h", "i", "r", "d", "c", "z", "i" };
+
+ chainp new_procs;
+ int prev_proc, proc_argchanges, proc_protochanges;
+
+ void
+changedtype(q)
+ Namep q;
+{
+ char buf[200];
+ int qtype, type1;
+ register Extsym *e;
+ Argtypes *at;
+
+ if (q->vtypewarned)
+ return;
+ q->vtypewarned = 1;
+ qtype = q->vtype;
+ e = &extsymtab[q->vardesc.varno];
+ if (!(at = e->arginfo)) {
+ if (!e->exused)
+ return;
+ }
+ else if (at->changes & 2 && qtype != TYUNKNOWN)
+ proc_protochanges++;
+ type1 = e->extype;
+ if (type1 == TYUNKNOWN)
+ return;
+ if (qtype == TYUNKNOWN)
+ /* e.g.,
+ subroutine foo
+ end
+ external foo
+ call goo(foo)
+ end
+ */
+ return;
+ sprintf(buf, "%.90s: inconsistent declarations:\n\
+ here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
+ qtype == TYSUBR ? "" : " function",
+ ftn_types[type1], type1 == TYSUBR ? "" : " function");
+ warn(buf);
+ }
+
+ void
+unamstring(q, s)
+ register Addrp q;
+ register char *s;
+{
+ register int k;
+ register char *t;
+
+ k = strlen(s);
+ if (k < IDENT_LEN) {
+ q->uname_tag = UNAM_IDENT;
+ t = q->user.ident;
+ }
+ else {
+ q->uname_tag = UNAM_CHARP;
+ q->user.Charp = t = mem(k+1, 0);
+ }
+ strcpy(t, s);
+ }
+
+ static void
+fix_entry_returns() /* for multiple entry points */
+{
+ Addrp a;
+ int i;
+ struct Entrypoint *e;
+ Namep np;
+
+ e = entries = (struct Entrypoint *)revchain((chainp)entries);
+ allargs = revchain(allargs);
+ if (!multitype)
+ return;
+
+ /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
+
+ for(i = TYSHORT; i <= TYLOGICAL; i++)
+ if (a = xretslot[i])
+ sprintf(a->user.ident, "(*ret_val).%s",
+ postfix[i-TYSHORT]);
+
+ do {
+ np = e->enamep;
+ switch(np->vtype) {
+ case TYSHORT:
+ case TYLONG:
+ case TYREAL:
+ case TYDREAL:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ case TYLOGICAL:
+ np->vstg = STGARG;
+ }
+ }
+ while(e = e->entnextp);
+ }
+
+ static void
+putentries(outfile) /* put out wrappers for multiple entries */
+ FILE *outfile;
+{
+ char base[IDENT_LEN];
+ struct Entrypoint *e;
+ Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
+ chainp args, lengths, length_comp();
+ void listargs(), list_arg_types();
+ int i, k, mt, nL, type;
+ extern char *dfltarg[], **dfltproc;
+
+ nL = (nallargs + nallchargs) * sizeof(Namep *);
+ A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
+ Ae = A + nallargs;
+ Alp = (Namep **)(Ae1 = Ae + nallchargs);
+ i = k = 0;
+ for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
+ np = (Namep)args->datap;
+ if (np->vtype == TYCHAR && np->vclass != CLPROC)
+ *a1 = &Ae[i++];
+ }
+
+ e = entries;
+ mt = multitype;
+ multitype = 0;
+ sprintf(base, "%s0_", e->enamep->cvarname);
+ do {
+ np = e->enamep;
+ lengths = length_comp(e, 0);
+ proctype = type = np->vtype;
+ if (protofile)
+ protowrite(protofile, type, np->cvarname, e, lengths);
+ nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
+ nice_printf(outfile, "%s", np->cvarname);
+ if (!Ansi) {
+ listargs(outfile, e, 0, lengths);
+ nice_printf(outfile, "\n");
+ }
+ list_arg_types(outfile, e, lengths, 0, "\n");
+ nice_printf(outfile, "{\n");
+ frchain(&lengths);
+ next_tab(outfile);
+ if (mt)
+ nice_printf(outfile,
+ "Multitype ret_val;\n%s(%d, &ret_val",
+ base, k); /*)*/
+ else if (ISCOMPLEX(type))
+ nice_printf(outfile, "%s(%d,%s", base, k,
+ xretslot[type]->user.ident); /*)*/
+ else if (type == TYCHAR)
+ nice_printf(outfile,
+ "%s(%d, ret_val, ret_val_len", base, k); /*)*/
+ else
+ nice_printf(outfile, "return %s(%d", base, k); /*)*/
+ k++;
+ memset((char *)A, 0, nL);
+ for(args = e->arglist; args; args = args->nextp) {
+ np = (Namep)args->datap;
+ A[np->argno] = np;
+ if (np->vtype == TYCHAR && np->vclass != CLPROC)
+ *Alp[np->argno] = np;
+ }
+ args = allargs;
+ for(a = A; a < Ae; a++, args = args->nextp)
+ nice_printf(outfile, ", %s", (np = *a)
+ ? np->cvarname
+ : ((Namep)args->datap)->vclass == CLPROC
+ ? dfltproc[((Namep)args->datap)->vtype]
+ : dfltarg[((Namep)args->datap)->vtype]);
+ for(; a < Ae1; a++)
+ if (np = *a)
+ nice_printf(outfile, ", %s_len", np->cvarname);
+ else
+ nice_printf(outfile, ", (ftnint)0");
+ nice_printf(outfile, /*(*/ ");\n");
+ if (mt) {
+ if (type == TYCOMPLEX)
+ nice_printf(outfile,
+ "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
+ else if (type == TYDCOMPLEX)
+ nice_printf(outfile,
+ "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
+ else nice_printf(outfile, "return ret_val.%s;\n",
+ postfix[type-TYSHORT]);
+ }
+ else if (ONEOF(type, M(TYCHAR)|M(TYCOMPLEX)|M(TYDCOMPLEX)))
+ nice_printf(outfile, "return 0;\n");
+ nice_printf(outfile, "}\n");
+ prev_tab(outfile);
+ }
+ while(e = e->entnextp);
+ free((char *)A);
+ }
+
+ static void
+entry_goto(outfile)
+ FILEP outfile;
+{
+ struct Entrypoint *e = entries;
+ int k = 0;
+
+ nice_printf(outfile, "switch(n__) {\n");
+ next_tab(outfile);
+ while(e = e->entnextp)
+ nice_printf(outfile, "case %d: goto %s;\n", ++k,
+ user_label((long)(extsymtab - e->entryname - 1)));
+ nice_printf(outfile, "}\n\n");
+ prev_tab(outfile);
+ }
+
+/* start a new procedure */
+
+newproc()
+{
+ if(parstate != OUTSIDE)
+ {
+ execerr("missing end statement", CNULL);
+ endproc();
+ }
+
+ parstate = INSIDE;
+ procclass = CLMAIN; /* default */
+}
+
+ static void
+zap_changes()
+{
+ register chainp cp;
+ register Argtypes *at;
+
+ /* arrange to get correct count of prototypes that would
+ change by running f2c again */
+
+ if (prev_proc && proc_argchanges)
+ proc_protochanges++;
+ prev_proc = proc_argchanges = 0;
+ for(cp = new_procs; cp; cp = cp->nextp)
+ if (at = ((Namep)cp->datap)->arginfo)
+ at->changes &= ~1;
+ frchain(&new_procs);
+ }
+
+/* end of procedure. generate variables, epilogs, and prologs */
+
+endproc()
+{
+ struct Labelblock *lp;
+ Extsym *ext;
+
+ if(parstate < INDATA)
+ enddcl();
+ if(ctlstack >= ctls)
+ err("DO loop or BLOCK IF not closed");
+ for(lp = labeltab ; lp < labtabend ; ++lp)
+ if(lp->stateno!=0 && lp->labdefined==NO)
+ errstr("missing statement label %s",
+ convic(lp->stateno) );
+
+/* Save copies of the common variables in extptr -> allextp */
+
+ for (ext = extsymtab; ext < nextext; ext++)
+ if (ext -> extstg == STGCOMMON && ext -> extp) {
+ extern int usedefsforcommon;
+
+/* Write out the abbreviations for common block reference */
+
+ copy_data (ext -> extp);
+ if (usedefsforcommon) {
+ wr_abbrevs (c_file, 1, ext -> extp);
+ ext -> used_here = 1;
+ }
+ else
+ ext -> extp = CHNULL;
+
+ }
+
+ if (nentry > 1)
+ fix_entry_returns();
+ epicode();
+ donmlist();
+ dobss();
+ start_formatting ();
+ if (nentry > 1)
+ putentries(c_file);
+
+ zap_changes();
+ procinit(); /* clean up for next procedure */
+}
+
+
+
+/* End of declaration section of procedure. Allocate storage. */
+
+enddcl()
+{
+ register struct Entrypoint *ep;
+ struct Entrypoint *ep0;
+ extern void freetemps();
+ chainp cp;
+
+ docommon();
+
+/* Now the hash table entries for fields of common blocks have STGCOMMON,
+ vdcldone, voffset, and varno. And the common blocks themselves have
+ their full sizes in extleng. */
+
+ doequiv();
+ docomleng();
+
+/* This implies that entry points in the declarations are buffered in
+ entries but not written out */
+
+ if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
+ /* entries could be 0 in case of an error */
+ do doentry(ep);
+ while(ep = ep->entnextp);
+ entries = (struct Entrypoint *)revchain((chainp)ep0);
+ }
+ parstate = INEXEC;
+ p1put(P1_PROCODE);
+ freetemps();
+ if (earlylabs) {
+ for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
+ p1_label((long)cp->datap);
+ frchain(&earlylabs);
+ }
+}
+
+/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
+
+/* Main program or Block data */
+
+startproc(progname, class)
+Extsym * progname;
+int class;
+{
+ register struct Entrypoint *p;
+
+ p = ALLOC(Entrypoint);
+ if(class == CLMAIN) {
+ puthead(CNULL, CLMAIN);
+ if (progname)
+ strcpy (main_alias, progname->cextname);
+ } else
+ puthead(CNULL, CLBLOCK);
+ if(class == CLMAIN)
+ newentry( mkname(" MAIN"), 0 )->extinit = 1;
+ p->entryname = progname;
+ entries = p;
+
+ procclass = class;
+ fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
+ if(progname) {
+ fprintf(diagfile, " %s", progname->fextname);
+ procname = progname->cextname;
+ }
+ fprintf(diagfile, ":\n");
+ fflush(diagfile);
+}
+
+/* subroutine or function statement */
+
+Extsym *newentry(v, substmsg)
+ register Namep v;
+ int substmsg;
+{
+ register Extsym *p;
+ char buf[128], badname[64];
+ static int nbad = 0;
+ static char already[] = "external name already used";
+
+ p = mkext(v->fvarname, addunder(v->cvarname));
+
+ if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
+ {
+ sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
+ if (substmsg) {
+ sprintf(buf,"%s\n\tsubstituting \"%s\"",
+ already, badname);
+ dclerr(buf, v);
+ }
+ else
+ dclerr(already, v);
+ p = mkext(v->fvarname, badname);
+ }
+ v->vstg = STGAUTO;
+ v->vprocclass = PTHISPROC;
+ v->vclass = CLPROC;
+ if (p->extstg == STGEXT)
+ prev_proc = 1;
+ else
+ p->extstg = STGEXT;
+ p->extinit = YES;
+ v->vardesc.varno = p - extsymtab;
+ return(p);
+}
+
+
+entrypt(class, type, length, entry, args)
+int class, type;
+ftnint length;
+Extsym *entry;
+chainp args;
+{
+ register Namep q;
+ register struct Entrypoint *p;
+ extern int types3[];
+
+ if(class != CLENTRY)
+ puthead( procname = entry->cextname, class);
+ if(class == CLENTRY)
+ fprintf(diagfile, " entry ");
+ fprintf(diagfile, " %s:\n", entry->fextname);
+ fflush(diagfile);
+ q = mkname(entry->fextname);
+ if (type == TYSUBR)
+ q->vstg = STGEXT;
+
+ if( (type = lengtype(type, length)) != TYCHAR)
+ length = 0;
+ if(class == CLPROC)
+ {
+ procclass = CLPROC;
+ proctype = type;
+ procleng = length;
+ }
+
+ p = ALLOC(Entrypoint);
+
+ p->entnextp = entries;
+ entries = p;
+
+ p->entryname = entry;
+ p->arglist = revchain(args);
+ p->enamep = q;
+
+ if(class == CLENTRY)
+ {
+ class = CLPROC;
+ if(proctype == TYSUBR)
+ type = TYSUBR;
+ }
+
+ q->vclass = class;
+ q->vprocclass = PTHISPROC;
+ settype(q, type, length);
+ /* hold all initial entry points till end of declarations */
+ if(parstate >= INDATA)
+ doentry(p);
+}
+
+/* generate epilogs */
+
+/* epicode -- write out the proper function return mechanism at the end of
+ the procedure declaration. Handles multiple return value types, as
+ well as cooercion into the proper value */
+
+LOCAL epicode()
+{
+ extern int lastwasbranch;
+
+ if(procclass==CLPROC)
+ {
+ if(proctype==TYSUBR)
+ {
+
+/* Return a zero only when the alternate return mechanism has been
+ specified in the function header */
+
+ if (substars && lastwasbranch == NO)
+ p1_subr_ret (ICON(0));
+ }
+ else if (!multitype && lastwasbranch == NO)
+ retval(proctype);
+ }
+ lastwasbranch = NO;
+}
+
+
+/* generate code to return value of type t */
+
+LOCAL retval(t)
+register int t;
+{
+ register Addrp p;
+
+ switch(t)
+ {
+ case TYCHAR:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ break;
+
+ case TYLOGICAL:
+ t = tylogical;
+ case TYADDR:
+ case TYSHORT:
+ case TYLONG:
+ case TYREAL:
+ case TYDREAL:
+ p = (Addrp) cpexpr((expptr)retslot);
+ p->vtype = t;
+ p1_subr_ret (mkconv (t, fixtype((expptr)p)));
+ break;
+
+ default:
+ badtype("retval", t);
+ }
+}
+
+
+/* Do parameter adjustments */
+
+procode(outfile)
+FILE *outfile;
+{
+ prolog(outfile, allargs);
+
+ if (nentry > 1)
+ entry_goto(outfile);
+ }
+
+/* Finish bound computations now that all variables are declared.
+ * This used to be in setbound(), but under -u the following incurred
+ * an erroneous error message:
+ * subroutine foo(x,n)
+ * real x(n)
+ * integer n
+ */
+
+ static void
+dim_finish(v)
+ Namep v;
+{
+ register struct Dimblock *p;
+ register expptr q;
+ register int i, nd;
+ extern expptr make_int_expr();
+
+ p = v->vdim;
+ v->vdimfinish = 0;
+ nd = p->ndim;
+ doin_setbound = 1;
+ for(i = 0; i < nd; i++)
+ if (q = p->dims[i].dimexpr)
+ p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
+ if (q = p->basexpr)
+ p->basexpr = make_int_expr(putx(fixtype(q)));
+ doin_setbound = 0;
+ }
+
+ static void
+duparg(q)
+ Namep q;
+{ errstr("duplicate argument %.80s", q->fvarname); }
+
+/*
+ manipulate argument lists (allocate argument slot positions)
+ * keep track of return types and labels
+ */
+
+LOCAL doentry(ep)
+struct Entrypoint *ep;
+{
+ register int type;
+ register Namep np;
+ chainp p, p1;
+ register Namep q;
+ Addrp mkarg(), rs;
+ int it, k;
+ Extsym *entryname = ep->entryname;
+
+ if (++nentry > 1)
+ p1_label((long)(extsymtab - entryname - 1));
+
+/* The main program isn't allowed to have parameters, so any given
+ parameters are ignored */
+
+ if(procclass == CLMAIN || procclass == CLBLOCK)
+ return;
+
+/* So now we're working with something other than CLMAIN or CLBLOCK.
+ Determine the type of its return value. */
+
+ impldcl( np = mkname(entryname->fextname) );
+ type = np->vtype;
+ proc_argchanges = prev_proc && type != entryname->extype;
+ entryname->extseen = 1;
+ if(proctype == TYUNKNOWN)
+ if( (proctype = type) == TYCHAR)
+ procleng = np->vleng ? np->vleng->constblock.Const.ci
+ : (ftnint) (-1);
+
+ if(proctype == TYCHAR)
+ {
+ if(type != TYCHAR)
+ err("noncharacter entry of character function");
+
+/* Functions returning type char can only have multiple entries if all
+ entries return the same length */
+
+ else if( (np->vleng ? np->vleng->constblock.Const.ci :
+ (ftnint) (-1)) != procleng)
+ err("mismatched character entry lengths");
+ }
+ else if(type == TYCHAR)
+ err("character entry of noncharacter function");
+ else if(type != proctype)
+ multitype = YES;
+ if(rtvlabel[type] == 0)
+ rtvlabel[type] = newlabel();
+ ep->typelabel = rtvlabel[type];
+
+ if(type == TYCHAR)
+ {
+ if(chslot < 0)
+ {
+ chslot = nextarg(TYADDR);
+ chlgslot = nextarg(TYLENG);
+ }
+ np->vstg = STGARG;
+
+/* Put a new argument in the function, one which will hold the result of
+ a character function. This will have to be named sometime, probably in
+ mkarg(). */
+
+ if(procleng < 0) {
+ np->vleng = (expptr) mkarg(TYLENG, chlgslot);
+ np->vleng->addrblock.uname_tag = UNAM_IDENT;
+ strcpy (np -> vleng -> addrblock.user.ident,
+ new_func_length());
+ }
+ if (!xretslot[TYCHAR]) {
+ xretslot[TYCHAR] = rs =
+ autovar(0, type, ISCONST(np->vleng)
+ ? np->vleng : ICON(0), "");
+ strcpy(rs->user.ident, "ret_val");
+ }
+ }
+
+/* Handle a complex return type -- declare a new parameter (pointer to
+ a complex value) */
+
+ else if( ISCOMPLEX(type) ) {
+ if (!xretslot[type])
+ xretslot[type] =
+ autovar(0, type, EXNULL, " ret_val");
+ /* the blank is for use in out_addr */
+ np->vstg = STGARG;
+ if(cxslot < 0)
+ cxslot = nextarg(TYADDR);
+ }
+ else if (type != TYSUBR) {
+ if (!xretslot[type])
+ xretslot[type] = retslot =
+ autovar(1, type, EXNULL, " ret_val");
+ /* the blank is for use in out_addr */
+ np->vstg = STGAUTO;
+ }
+
+ for(p = ep->arglist ; p ; p = p->nextp)
+ if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
+ q->vknownarg = 1;
+ q->vardesc.varno = nextarg(TYADDR);
+ allargs = mkchain((char *)q, allargs);
+ q->argno = nallargs++;
+ }
+ else if (nentry == 1)
+ duparg(q);
+ else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
+ if ((Namep)p1->datap == q)
+ duparg(q);
+
+ k = 0;
+ for(p = ep->arglist ; p ; p = p->nextp) {
+ if(! (( q = (Namep) (p->datap) )->vdcldone) )
+ {
+ impldcl(q);
+ q->vdcldone = YES;
+ if(q->vtype == TYCHAR)
+ {
+
+/* If we don't know the length of a char*(*) (i.e. a string), we must add
+ in this additional length argument. */
+
+ ++nallchargs;
+ if (q->vclass == CLPROC)
+ nallchargs--;
+ else if (q->vleng == NULL) {
+ /* character*(*) */
+ q->vleng = (expptr)
+ mkarg(TYLENG, nextarg(TYLENG) );
+ unamstring((Addrp)q->vleng,
+ new_arg_length(q));
+ }
+ }
+ }
+ if (q->vdimfinish)
+ dim_finish(q);
+ if (q->vtype == TYCHAR && q->vclass != CLPROC)
+ k++;
+ }
+
+ if (entryname->extype != type)
+ changedtype(np);
+
+ /* save information for checking consistency of arg lists */
+
+ it = infertypes;
+ if (entryname->exproto)
+ infertypes = 1;
+ save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
+ 0, np->fvarname, STGEXT, k, np->vtype);
+ infertypes = it;
+}
+
+
+
+LOCAL nextarg(type)
+int type;
+{
+ int k;
+ k = lastargslot;
+ lastargslot += typesize[type];
+ return(k);
+}
+
+LOCAL dobss()
+{
+ register struct Hashentry *p;
+ register Namep q;
+ int qstg, qclass, qtype;
+ Extsym *e;
+
+ for(p = hashtab ; p<lasthash ; ++p)
+ if(q = p->varp)
+ {
+ qstg = q->vstg;
+ qtype = q->vtype;
+ qclass = q->vclass;
+
+ if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
+ (qclass==CLVAR && qstg==STGUNKNOWN) ) {
+ if (!(q->vis_assigned | q->vimpldovar))
+ warn1("local variable %s never used",
+ q->fvarname);
+ }
+ else if(qclass==CLVAR && qstg==STGBSS)
+ { ; }
+
+/* Give external procedures the proper storage class */
+
+ else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
+ && qstg!=STGARG) {
+ e = mkext(q->fvarname,addunder(q->cvarname));
+ e->extstg = STGEXT;
+ q->vardesc.varno = e - extsymtab;
+ if (e->extype != qtype)
+ changedtype(q);
+ }
+ if(qclass==CLVAR) {
+ if (qstg!=STGARG) {
+ if(q->vdim && !ISICON(q->vdim->nelt) )
+ dclerr("adjustable dimension on non-argument", q);
+ if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
+ dclerr("adjustable leng on nonargument", q);
+ } /* if qstg != STGARG */
+ } /* if qclass == CLVAR */
+ }
+
+}
+
+
+
+donmlist()
+{
+ register struct Hashentry *p;
+ register Namep q;
+
+ for(p=hashtab; p<lasthash; ++p)
+ if( (q = p->varp) && q->vclass==CLNAMELIST)
+ namelist(q);
+}
+
+
+/* iarrlen -- Returns the size of the array in bytes, or -1 */
+
+ftnint iarrlen(q)
+register Namep q;
+{
+ ftnint leng;
+
+ leng = typesize[q->vtype];
+ if(leng <= 0)
+ return(-1);
+ if(q->vdim)
+ if( ISICON(q->vdim->nelt) )
+ leng *= q->vdim->nelt->constblock.Const.ci;
+ else return(-1);
+ if(q->vleng)
+ if( ISICON(q->vleng) )
+ leng *= q->vleng->constblock.Const.ci;
+ else return(-1);
+ return(leng);
+}
+
+namelist(np)
+Namep np;
+{
+ register chainp q;
+ register Namep v;
+ int y;
+
+ if (!np->visused)
+ return;
+ y = 0;
+
+ for(q = np->varxptr.namelist ; q ; q = q->nextp)
+ {
+ vardcl( v = (Namep) (q->datap) );
+ if( !ONEOF(v->vstg, MSKSTATIC) )
+ dclerr("may not appear in namelist", v);
+ else {
+ v->vnamelist = 1;
+ v->visused = 1;
+ v->vsave = 1;
+ y = 1;
+ }
+ np->visused = y;
+ }
+}
+
+/* docommon -- called at the end of procedure declarations, before
+ equivalences and the procedure body */
+
+LOCAL docommon()
+{
+ register Extsym *extptr;
+ register chainp q, q1;
+ struct Dimblock *t;
+ expptr neltp;
+ register Namep comvar;
+ ftnint size;
+ int i, k, pref, type;
+ extern int type_pref[];
+
+ for(extptr = extsymtab ; extptr<nextext ; ++extptr)
+ if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
+
+/* If a common declaration also had a list of variables ... */
+
+ q = extptr->extp = revchain(q);
+ pref = 1;
+ for(k = TYCHAR; q ; q = q->nextp)
+ {
+ comvar = (Namep) (q->datap);
+
+ if(comvar->vdcldone == NO)
+ vardcl(comvar);
+ type = comvar->vtype;
+ if (pref < type_pref[type])
+ pref = type_pref[k = type];
+ if(extptr->extleng % typealign[type] != 0) {
+ dclerr("common alignment", comvar);
+ --nerr; /* don't give bad return code for this */
+#if 0
+ extptr->extleng = roundup(extptr->extleng, typealign[type]);
+#endif
+ } /* if extptr -> extleng % */
+
+/* Set the offset into the common block */
+
+ comvar->voffset = extptr->extleng;
+ comvar->vardesc.varno = extptr - extsymtab;
+ if(type == TYCHAR)
+ size = comvar->vleng->constblock.Const.ci;
+ else
+ size = typesize[type];
+ if(t = comvar->vdim)
+ if( (neltp = t->nelt) && ISCONST(neltp) )
+ size *= neltp->constblock.Const.ci;
+ else
+ dclerr("adjustable array in common", comvar);
+
+/* Adjust the length of the common block so far */
+
+ extptr->extleng += size;
+ } /* for */
+
+ extptr->extype = k;
+
+/* Determine curno and, if new, save this identifier chain */
+
+ q1 = extptr->extp;
+ for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
+ if (struct_eq((chainp)q->datap, q1))
+ break;
+ if (q)
+ extptr->curno = extptr->maxno - i;
+ else {
+ extptr->curno = ++extptr->maxno;
+ extptr->allextp = mkchain((char *)extptr->extp,
+ extptr->allextp);
+ }
+ } /* if extptr -> extstg == STGCOMMON */
+
+/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
+ varno. And the common block itself has its full size in extleng. */
+
+} /* docommon */
+
+
+/* copy_data -- copy the Namep entries so they are available even after
+ the hash table is empty */
+
+copy_data (list)
+chainp list;
+{
+ for (; list; list = list -> nextp) {
+ Namep namep = ALLOC (Nameblock);
+ int size, nd, i;
+ struct Dimblock *dp;
+
+ cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
+ namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
+ namep->fvarname);
+ namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
+ ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
+ : namep->fvarname;
+ if (namep -> vleng)
+ namep -> vleng = (expptr) cpexpr (namep -> vleng);
+ if (namep -> vdim) {
+ nd = namep -> vdim -> ndim;
+ size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
+ dp = (struct Dimblock *) ckalloc (size);
+ cpn(size, (char *)namep->vdim, (char *)dp);
+ namep -> vdim = dp;
+ dp->nelt = (expptr)cpexpr(dp->nelt);
+ for (i = 0; i < nd; i++) {
+ dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
+ } /* for */
+ } /* if */
+ list -> datap = (char *) namep;
+ } /* for */
+} /* copy_data */
+
+
+
+LOCAL docomleng()
+{
+ register Extsym *p;
+
+ for(p = extsymtab ; p < nextext ; ++p)
+ if(p->extstg == STGCOMMON)
+ {
+ if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
+ && strcmp(Blank, p->cextname) )
+ warn1("incompatible lengths for common block %.60s",
+ p->fextname);
+ if(p->maxleng < p->extleng)
+ p->maxleng = p->extleng;
+ p->extleng = 0;
+ }
+}
+
+
+/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
+
+frtemp(p)
+Addrp p;
+{
+ /* put block on chain of temps to be reclaimed */
+ holdtemps = mkchain((char *)p, holdtemps);
+}
+
+ void
+freetemps()
+{
+ register chainp p, p1;
+ register Addrp q;
+ register int t;
+
+ p1 = holdtemps;
+ while(p = p1) {
+ q = (Addrp)p->datap;
+ t = q->vtype;
+ if (t == TYCHAR && q->varleng != 0) {
+ /* restore clobbered character string lengths */
+ frexpr(q->vleng);
+ q->vleng = ICON(q->varleng);
+ }
+ p1 = p->nextp;
+ p->nextp = templist[t];
+ templist[t] = p;
+ }
+ holdtemps = 0;
+ }
+
+/* allocate an automatic variable slot for each of nelt variables */
+
+Addrp autovar(nelt0, t, lengp, name)
+register int nelt0, t;
+expptr lengp;
+char *name;
+{
+ ftnint leng;
+ register Addrp q;
+ char *temp_name ();
+ register int nelt = nelt0 > 0 ? nelt0 : 1;
+ extern char *av_pfix[];
+
+ if(t == TYCHAR)
+ if( ISICON(lengp) )
+ leng = lengp->constblock.Const.ci;
+ else {
+ Fatal("automatic variable of nonconstant length");
+ }
+ else
+ leng = typesize[t];
+
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ q->vtype = t;
+ if(t == TYCHAR)
+ {
+ q->vleng = ICON(leng);
+ q->varleng = leng;
+ }
+ q->vstg = STGAUTO;
+ q->ntempelt = nelt;
+ q->isarray = (nelt > 1);
+ q->memoffset = ICON(0);
+
+ /* kludge for nls so we can have ret_val rather than ret_val_4 */
+ if (*name == ' ')
+ unamstring(q, name+1);
+ else {
+ q->uname_tag = UNAM_IDENT;
+ temp_name(av_pfix[t], ++autonum[t], q->user.ident);
+ }
+ if (nelt0 > 0)
+ declare_new_addr (q);
+ return(q);
+}
+
+
+/* Returns a temporary of the appropriate type. Will reuse existing
+ temporaries when possible */
+
+Addrp mktmpn(nelt, type, lengp)
+int nelt;
+register int type;
+expptr lengp;
+{
+ ftnint leng;
+ chainp p, oldp;
+ register Addrp q;
+
+ if(type==TYUNKNOWN || type==TYERROR)
+ badtype("mktmpn", type);
+
+ if(type==TYCHAR)
+ if( ISICON(lengp) )
+ leng = lengp->constblock.Const.ci;
+ else {
+ err("adjustable length");
+ return( (Addrp) errnode() );
+ }
+ else if (type > TYCHAR || type < TYADDR) {
+ erri("mktmpn: unexpected type %d", type);
+ exit(1);
+ }
+/*
+ * if a temporary of appropriate shape is on the templist,
+ * remove it from the list and return it
+ */
+ for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
+ {
+ q = (Addrp) (p->datap);
+ if(q->ntempelt==nelt &&
+ (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
+ {
+ if(oldp)
+ oldp->nextp = p->nextp;
+ else
+ templist[type] = p->nextp;
+ free( (charptr) p);
+ return(q);
+ }
+ }
+ q = autovar(nelt, type, lengp, "");
+ return(q);
+}
+
+
+
+
+/* mktemp -- create new local variable; call it something like name
+ lengp is taken directly, not copied */
+
+Addrp Mktemp(type, lengp)
+int type;
+expptr lengp;
+{
+ Addrp rv;
+ /* arrange for temporaries to be recycled */
+ /* at the end of this statement... */
+ rv = mktmpn(1,type,lengp);
+ frtemp((Addrp)cpexpr((expptr)rv));
+ return rv;
+}
+
+/* mktmp0 omits frtemp() */
+Addrp mktmp0(type, lengp)
+int type;
+expptr lengp;
+{
+ Addrp rv;
+ /* arrange for temporaries to be recycled */
+ /* when this Addrp is freed */
+ rv = mktmpn(1,type,lengp);
+ rv->istemp = YES;
+ return rv;
+}
+
+/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
+
+/* comblock -- Declare a new common block. Input parameters name the block;
+ s will be NULL if the block is unnamed */
+
+Extsym *comblock(s)
+ register char *s;
+{
+ Extsym *p;
+ register char *t;
+ register int c, i;
+ char cbuf[256], *s0;
+
+/* Give the unnamed common block a unique name */
+
+ if(*s == 0)
+ p = mkext(Blank,Blank);
+ else {
+ s0 = s;
+ t = cbuf;
+ for(i = 0; c = *t = *s++; t++)
+ if (c == '_')
+ i = 1;
+ if (i)
+ *t++ = '_';
+ t[0] = '_';
+ t[1] = 0;
+ p = mkext(s0,cbuf);
+ }
+ if(p->extstg == STGUNKNOWN)
+ p->extstg = STGCOMMON;
+ else if(p->extstg != STGCOMMON)
+ {
+ errstr("%.68s cannot be a common block name", s);
+ return(0);
+ }
+
+ return( p );
+}
+
+
+/* incomm -- add a new variable to a common declaration */
+
+incomm(c, v)
+Extsym *c;
+Namep v;
+{
+ if (!c)
+ return;
+ if(v->vstg != STGUNKNOWN && !v->vimplstg)
+ dclerr("incompatible common declaration", v);
+ else
+ {
+ v->vstg = STGCOMMON;
+ c->extp = mkchain((char *)v, c->extp);
+ }
+}
+
+
+
+
+/* settype -- set the type or storage class of a Namep object. If
+ v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be
+ -type. This function will not change any earlier definitions in v,
+ in will only attempt to fill out more information give the other params */
+
+settype(v, type, length)
+register Namep v;
+register int type;
+register ftnint length;
+{
+ int type1;
+
+ if(type == TYUNKNOWN)
+ return;
+
+ if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
+ {
+ v->vtype = TYSUBR;
+ frexpr(v->vleng);
+ v->vleng = 0;
+ v->vimpltype = 0;
+ }
+ else if(type < 0) /* storage class set */
+ {
+ if(v->vstg == STGUNKNOWN)
+ v->vstg = - type;
+ else if(v->vstg != -type)
+ dclerr("incompatible storage declarations", v);
+ }
+ else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
+ {
+ if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0)
+ v->vleng = ICON(length);
+ v->vimpltype = 0;
+
+ if (v->vclass == CLPROC && v->vstg == STGEXT
+ && (type1 = extsymtab[v->vardesc.varno].extype)
+ && type1 != v->vtype)
+ changedtype(v);
+ }
+ else if(v->vtype!=type
+ || (type==TYCHAR && v->vleng->constblock.Const.ci!=length) )
+ dclerr("incompatible type declarations", v);
+}
+
+
+
+
+
+/* lengtype -- returns the proper compiler type, given input of Fortran
+ type and length specifier */
+
+lengtype(type, len)
+register int type;
+ftnint len;
+{
+ register int length = (int)len;
+ switch(type)
+ {
+ case TYREAL:
+ if(length == typesize[TYDREAL])
+ return(TYDREAL);
+ if(length == typesize[TYREAL])
+ goto ret;
+ break;
+
+ case TYCOMPLEX:
+ if(length == typesize[TYDCOMPLEX])
+ return(TYDCOMPLEX);
+ if(length == typesize[TYCOMPLEX])
+ goto ret;
+ break;
+
+ case TYSHORT:
+ case TYDREAL:
+ case TYDCOMPLEX:
+ case TYCHAR:
+ case TYUNKNOWN:
+ case TYSUBR:
+ case TYERROR:
+ goto ret;
+
+ case TYLOGICAL:
+ if(length == typesize[TYLOGICAL])
+ goto ret;
+ if(length == 1 || length == 2) {
+ erri("treating LOGICAL*%d as LOGICAL", length);
+ --nerr; /* allow generation of .c file */
+ goto ret;
+ }
+ break;
+
+ case TYLONG:
+ if(length == 0)
+ return(tyint);
+ if(length == typesize[TYSHORT])
+ return(TYSHORT);
+ if(length == typesize[TYLONG])
+ goto ret;
+ break;
+ default:
+ badtype("lengtype", type);
+ }
+
+ if(len != 0)
+ err("incompatible type-length combination");
+
+ret:
+ return(type);
+}
+
+
+
+
+
+/* setintr -- Set Intrinsic function */
+
+setintr(v)
+register Namep v;
+{
+ int k;
+
+ if(v->vstg == STGUNKNOWN)
+ v->vstg = STGINTR;
+ else if(v->vstg!=STGINTR)
+ dclerr("incompatible use of intrinsic function", v);
+ if(v->vclass==CLUNKNOWN)
+ v->vclass = CLPROC;
+ if(v->vprocclass == PUNKNOWN)
+ v->vprocclass = PINTRINSIC;
+ else if(v->vprocclass != PINTRINSIC)
+ dclerr("invalid intrinsic declaration", v);
+ if(k = intrfunct(v->fvarname)) {
+ if ((*(struct Intrpacked *)&k).f4)
+ if (noextflag)
+ goto unknown;
+ else
+ dcomplex_seen++;
+ v->vardesc.varno = k;
+ }
+ else {
+ unknown:
+ dclerr("unknown intrinsic function", v);
+ }
+}
+
+
+
+/* setext -- Set External declaration -- assume that unknowns will become
+ procedures */
+
+setext(v)
+register Namep v;
+{
+ if(v->vclass == CLUNKNOWN)
+ v->vclass = CLPROC;
+ else if(v->vclass != CLPROC)
+ dclerr("invalid external declaration", v);
+
+ if(v->vprocclass == PUNKNOWN)
+ v->vprocclass = PEXTERNAL;
+ else if(v->vprocclass != PEXTERNAL)
+ dclerr("invalid external declaration", v);
+} /* setext */
+
+
+
+
+/* create dimensions block for array variable */
+
+setbound(v, nd, dims)
+register Namep v;
+int nd;
+struct {
+ expptr lb, ub;
+} dims[ ];
+{
+ register expptr q, t;
+ register struct Dimblock *p;
+ int i;
+ extern chainp new_vars;
+ char buf[256];
+
+ if(v->vclass == CLUNKNOWN)
+ v->vclass = CLVAR;
+ else if(v->vclass != CLVAR)
+ {
+ dclerr("only variables may be arrays", v);
+ return;
+ }
+
+ v->vdim = p = (struct Dimblock *)
+ ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
+ p->ndim = nd--;
+ p->nelt = ICON(1);
+ doin_setbound = 1;
+
+ for(i = 0; i <= nd; ++i)
+ {
+ if( (q = dims[i].ub) == NULL)
+ {
+ if(i == nd)
+ {
+ frexpr(p->nelt);
+ p->nelt = NULL;
+ }
+ else
+ err("only last bound may be asterisk");
+ p->dims[i].dimsize = ICON(1);
+ ;
+ p->dims[i].dimexpr = NULL;
+ }
+ else
+ {
+
+ if(dims[i].lb)
+ {
+ q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
+ q = mkexpr(OPPLUS, q, ICON(1) );
+ }
+ if( ISCONST(q) )
+ {
+ p->dims[i].dimsize = q;
+ p->dims[i].dimexpr = (expptr) PNULL;
+ }
+ else {
+ sprintf(buf, " %s_dim%d", v->fvarname, i+1);
+ p->dims[i].dimsize = (expptr)
+ autovar(1, tyint, EXNULL, buf);
+ p->dims[i].dimexpr = q;
+ if (i == nd)
+ v->vlastdim = new_vars;
+ v->vdimfinish = 1;
+ }
+ if(p->nelt)
+ p->nelt = mkexpr(OPSTAR, p->nelt,
+ cpexpr(p->dims[i].dimsize) );
+ }
+ }
+
+ q = dims[nd].lb;
+ if(q == NULL)
+ q = ICON(1);
+
+ for(i = nd-1 ; i>=0 ; --i)
+ {
+ t = dims[i].lb;
+ if(t == NULL)
+ t = ICON(1);
+ if(p->dims[i].dimsize)
+ q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
+ }
+
+ if( ISCONST(q) )
+ {
+ p->baseoffset = q;
+ p->basexpr = NULL;
+ }
+ else
+ {
+ sprintf(buf, " %s_offset", v->fvarname);
+ p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
+ p->basexpr = q;
+ }
+ doin_setbound = 0;
+}
+
+
+
+wr_abbrevs (outfile, function_head, vars)
+FILE *outfile;
+int function_head;
+chainp vars;
+{
+ for (; vars; vars = vars -> nextp) {
+ Namep name = (Namep) vars -> datap;
+ if (!name->visused)
+ continue;
+
+ if (function_head)
+ nice_printf (outfile, "#define ");
+ else
+ nice_printf (outfile, "#undef ");
+ out_name (outfile, name);
+
+ if (function_head) {
+ Extsym *comm = &extsymtab[name -> vardesc.varno];
+
+ nice_printf (outfile, " (");
+ extern_out (outfile, comm);
+ nice_printf (outfile, "%d.", comm->curno);
+ nice_printf (outfile, "%s)", name->cvarname);
+ } /* if function_head */
+ nice_printf (outfile, "\n");
+ } /* for */
+} /* wr_abbrevs */
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/*
+ * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
+ * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
+*/
+
+#include "defs.h"
+#include "names.h" /* For LOCAL_CONST_NAME */
+#include "pccdefs.h"
+#include "p1defs.h"
+
+/* Definitions for putconst() */
+
+#define LIT_CHAR 1
+#define LIT_FLOAT 2
+#define LIT_INT 3
+
+
+/*
+char *ops [ ] =
+ {
+ "??", "+", "-", "*", "/", "**", "-",
+ "OR", "AND", "EQV", "NEQV", "NOT",
+ "CONCAT",
+ "<", "==", ">", "<=", "!=", ">=",
+ " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
+ " , ", " ? ", " : "
+ " abs ", " min ", " max ", " addr ", " indirect ",
+ " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
+ };
+*/
+
+/* Each of these values is defined in pccdefs */
+
+int ops2 [ ] =
+{
+ P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
+ P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
+ P2BAD,
+ P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
+ P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
+ P2COMOP, P2QUEST, P2COLON,
+ 1, P2BAD, P2BAD, P2BAD, P2BAD,
+ P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
+ P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
+ P2BAD, P2BAD, P2BAD, P2BAD,
+ 1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
+ 1,1,1,1 /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
+};
+
+
+int types2 [ ] =
+{
+ P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL,
+ P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD
+};
+
+
+setlog()
+{
+ types2[TYLOGICAL] = types2[tylogical];
+ typesize[TYLOGICAL] = typesize[tylogical];
+ typealign[TYLOGICAL] = typealign[tylogical];
+}
+
+
+void putex1(p)
+expptr p;
+{
+/* Write the expression to the p1 file */
+
+ p = (expptr) putx (fixtype (p));
+ p1_expr (p);
+}
+
+
+
+
+
+expptr putassign(lp, rp)
+expptr lp, rp;
+{
+ return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
+}
+
+
+
+
+void puteq(lp, rp)
+expptr lp, rp;
+{
+ putexpr(mkexpr(OPASSIGN, lp, rp) );
+}
+
+
+
+
+/* put code for a *= b */
+
+expptr putsteq(a, b)
+Addrp a, b;
+{
+ return putx( fixexpr((Exprp)
+ mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
+}
+
+
+
+
+Addrp mkfield(res, f, ty)
+register Addrp res;
+char *f;
+int ty;
+{
+ res -> vtype = ty;
+ res -> Field = f;
+ return res;
+} /* mkfield */
+
+
+Addrp realpart(p)
+register Addrp p;
+{
+ register Addrp q;
+ expptr mkrealcon();
+
+ if (p -> uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) {
+ return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
+ p->user.kludge.vstg1 ? p->user.Const.cds[0]
+ : cds(dtos(p->user.Const.cd[0]),CNULL));
+ } /* if p -> uname_tag */
+
+ q = (Addrp) cpexpr((expptr) p);
+ if( ISCOMPLEX(p->vtype) )
+ q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
+
+ return(q);
+}
+
+
+
+
+expptr imagpart(p)
+register Addrp p;
+{
+ register Addrp q;
+ expptr mkrealcon();
+
+ if( ISCOMPLEX(p->vtype) )
+ {
+ if (p -> uname_tag == UNAM_CONST)
+ return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
+ p->user.kludge.vstg1 ? p->user.Const.cds[1]
+ : cds(dtos(p->user.Const.cd[1]),CNULL));
+ q = (Addrp) cpexpr((expptr) p);
+ q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
+ return( (expptr) q );
+ }
+ else
+
+/* Cast an integer type onto a Double Real type */
+
+ return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
+}
+
+
+
+
+
+/* ncat -- computes the number of adjacent concatenation operations */
+
+ncat(p)
+register expptr p;
+{
+ if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
+ return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
+ else return(1);
+}
+
+
+
+
+/* lencat -- returns the length of the concatenated string. Each
+ substring must have a static (i.e. compile-time) fixed length */
+
+ftnint lencat(p)
+register expptr p;
+{
+ if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
+ return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
+ else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
+ return(p->headblock.vleng->constblock.Const.ci);
+ else if(p->tag==TADDR && p->addrblock.varleng!=0)
+ return(p->addrblock.varleng);
+ else
+ {
+ err("impossible element in concatenation");
+ return(0);
+ }
+}
+
+/* putconst -- Creates a new Addrp value which maps onto the input
+ constant value. The Addrp doesn't retain the value of the constant,
+ instead that value is copied into a table of constants (called
+ litpool, for pool of literal values). The only way to retrieve the
+ actual value of the constant is to look at the memno field of the
+ Addrp result. You know that the associated literal is the one referred
+ to by q when (q -> memno == litp -> litnum).
+*/
+
+Addrp putconst(p)
+register Constp p;
+{
+ register Addrp q;
+ struct Literal *litp, *lastlit;
+ int k, type;
+ int litflavor;
+ double cd[2];
+ char cdsbuf0[64], cdsbuf1[64], *ds[2];
+
+ if( p->tag != TCONST )
+ badtag("putconst", p->tag);
+
+ q = ALLOC(Addrblock);
+ q->tag = TADDR;
+ type = p->vtype;
+ q->vtype = ( type==TYADDR ? tyint : type );
+ q->vleng = (expptr) cpexpr(p->vleng);
+ q->vstg = STGCONST;
+
+/* Create the new label for the constant. This is wasteful of labels
+ because when the constant value already exists in the literal pool,
+ this label gets thrown away and is never reclaimed. It might be
+ cleaner to move this down past the first switch() statement below */
+
+ q->memno = newlabel();
+ q->memoffset = ICON(0);
+ q -> uname_tag = UNAM_CONST;
+
+/* Copy the constant info into the Addrblock; do this by copying the
+ largest storage elts */
+
+ q -> user.Const = p -> Const;
+ q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
+
+ /* check for value in literal pool, and update pool if necessary */
+
+ k = 1;
+ switch(type = p->vtype)
+ {
+ case TYCHAR:
+ /* Treat all character strings as too long for literal table */
+ q -> memno = BAD_MEMNO;
+ break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ k = 2;
+ if (p->vstg)
+ cd[1] = atof(ds[1] = p->Const.cds[1]);
+ else
+ ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
+ case TYREAL:
+ case TYDREAL:
+ litflavor = LIT_FLOAT;
+ if (p->vstg)
+ cd[0] = atof(ds[0] = p->Const.cds[0]);
+ else
+ ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
+ goto loop;
+
+ case TYLOGICAL:
+ type = tylogical;
+ goto lit_int_flavor;
+ case TYLONG:
+ type = tyint;
+ case TYSHORT:
+ lit_int_flavor:
+ litflavor = LIT_INT;
+
+/* Scan the literal pool for this constant value. If this same constant
+ has been assigned before, use the same label. Note that this routine
+ does NOT consider two differently-typed constants with the same bit
+ pattern to be the same constant */
+
+loop:
+ lastlit = litpool + nliterals;
+ for(litp = litpool ; litp<lastlit ; ++litp)
+
+/* Remove this type checking to ensure that all bit patterns are reused */
+
+ if(type == litp->littype) switch(litflavor)
+ {
+ case LIT_FLOAT:
+ if(cd[0] == litp->litval.litdval[0]
+ && !strcmp(ds[0], litp->cds[0])
+ && (k == 1 ||
+ cd[1] == litp->litval.litdval[1]
+ && !strcmp(ds[1], litp->cds[1]))) {
+ret:
+ q->memno = litp->litnum;
+ frexpr((expptr)p);
+ return(q);
+ }
+ break;
+
+ case LIT_INT:
+ if(p->Const.ci == litp->litval.litival)
+ goto ret;
+ break;
+ }
+
+/* If there's room in the literal pool, add this new value to the pool */
+
+ if(nliterals < MAXLITERALS)
+ {
+ ++nliterals;
+
+ /* litp now points to the next free elt */
+
+ litp->littype = type;
+ litp->litnum = q->memno;
+ switch(litflavor)
+ {
+ case LIT_FLOAT:
+ litp->litval.litdval[0] = cd[0];
+ litp->cds[0] = copys(ds[0]);
+ if (k == 2) {
+ litp->litval.litdval[1] = cd[1];
+ litp->cds[1] = copys(ds[1]);
+ }
+ break;
+
+ case LIT_INT:
+ litp->litval.litival = p->Const.ci;
+ break;
+ } /* switch (litflavor) */
+ } /* if (nliternals < MAXLITERALS) */
+ else {
+ Addrp t = Mktemp(type, q -> vleng);
+ puteq (cpexpr((expptr)t), (expptr)p);
+ free ((char *) q);
+ return t;
+ } /* else */
+
+ break;
+ case TYADDR:
+ break;
+ default:
+ badtype ("putconst", p -> vtype);
+ break;
+ } /* switch */
+
+ if (type != TYCHAR)
+ frexpr((expptr)p);
+ return( q );
+}
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
+/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h" /* for nice_printf */
+#include "names.h"
+#include "p1defs.h"
+
+Addrp realpart();
+LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 (), putchop ();
+LOCAL putct1 ();
+
+expptr putcxop();
+LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
+LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
+LOCAL expptr putcxcmp ();
+expptr imagpart();
+ftnint lencat();
+
+#define FOUR 4
+extern int ops2[];
+extern int types2[];
+extern int proc_argchanges, proc_protochanges;
+
+#define P2BUFFMAX 128
+
+/* Puthead -- output the header information about subroutines, functions
+ and entry points */
+
+puthead(s, class)
+char *s;
+int class;
+{
+ if (headerdone == NO) {
+ if (class == CLMAIN)
+ s = "MAIN__";
+ p1_head (class, s);
+ headerdone = YES;
+ }
+}
+
+putif(p, else_if_p)
+ register expptr p;
+ int else_if_p;
+{
+ register int k;
+
+ if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
+ {
+ if(k != TYERROR)
+ err("non-logical expression in IF statement");
+ }
+ else {
+ p = putx(p);
+ if (else_if_p)
+ p1_elif(p);
+ else
+ p1_if(p);
+ }
+ frexpr(p);
+}
+
+
+putexpr(p)
+expptr p;
+{
+ putex1(p);
+}
+
+
+putout(p)
+expptr p;
+{
+ p1_expr (p);
+
+/* Used to make temporaries in holdtemps available here, but they */
+/* may be reused too soon (e.g. when multiple **'s are involved). */
+}
+
+
+
+putcmgo(index, nlab, labs)
+expptr index;
+int nlab;
+struct Labelblock *labs[];
+{
+ if(! ISINT(index->headblock.vtype) )
+ {
+ execerr("computed goto index must be integer", CNULL);
+ return;
+ }
+
+ p1comp_goto (index, nlab, labs);
+}
+
+expptr putx(p)
+expptr p;
+{
+ int opc;
+ int k;
+
+ if (p)
+ switch(p->tag)
+ {
+ case TERROR:
+ break;
+
+ case TCONST:
+ switch(p->constblock.vtype)
+ {
+ case TYLOGICAL:
+ case TYLONG:
+ case TYSHORT:
+ break;
+
+ case TYADDR:
+ break;
+ case TYREAL:
+ case TYDREAL:
+
+/* Don't write it out to the p2 file, since you'd need to call putconst,
+ which is just what we need to avoid in the translator */
+
+ break;
+ default:
+ p = putx( (expptr)putconst((Constp)p) );
+ break;
+ }
+ break;
+
+ case TEXPR:
+ switch(opc = p->exprblock.opcode)
+ {
+ case OPCALL:
+ case OPCCALL:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else p = putcall(p, (Addrp *)NULL);
+ break;
+
+ case OPMIN:
+ case OPMAX:
+ p = putmnmx(p);
+ break;
+
+
+ case OPASSIGN:
+ if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
+ || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
+ (void) putcxeq(p);
+ p = ENULL;
+ } else if( ISCHAR(p) )
+ p = putcheq(p);
+ else
+ goto putopp;
+ break;
+
+ case OPEQ:
+ case OPNE:
+ if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
+ ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
+ {
+ p = putcxcmp(p);
+ break;
+ }
+ case OPLT:
+ case OPLE:
+ case OPGT:
+ case OPGE:
+ if(ISCHAR(p->exprblock.leftp))
+ {
+ p = putchcmp(p);
+ break;
+ }
+ goto putopp;
+
+ case OPPOWER:
+ p = putpower(p);
+ break;
+
+ case OPSTAR:
+ /* m * (2**k) -> m<<k */
+ if(INT(p->exprblock.leftp->headblock.vtype) &&
+ ISICON(p->exprblock.rightp) &&
+ ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
+ {
+ p->exprblock.opcode = OPLSHIFT;
+ frexpr(p->exprblock.rightp);
+ p->exprblock.rightp = ICON(k);
+ goto putopp;
+ }
+
+ case OPMOD:
+ goto putopp;
+ case OPPLUS:
+ case OPMINUS:
+ case OPSLASH:
+ case OPNEG:
+ case OPNEG1:
+ case OPABS:
+ case OPDABS:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else goto putopp;
+ break;
+
+ case OPCONV:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
+ {
+ p = putx( mkconv(p->exprblock.vtype,
+ (expptr)realpart(putcx1(p->exprblock.leftp))));
+ }
+ else goto putopp;
+ break;
+
+ case OPNOT:
+ case OPOR:
+ case OPAND:
+ case OPEQV:
+ case OPNEQV:
+ case OPADDR:
+ case OPPLUSEQ:
+ case OPSTAREQ:
+ case OPCOMMA:
+ case OPQUEST:
+ case OPCOLON:
+ case OPBITOR:
+ case OPBITAND:
+ case OPBITXOR:
+ case OPBITNOT:
+ case OPLSHIFT:
+ case OPRSHIFT:
+ case OPASSIGNI:
+ case OPIDENTITY:
+ case OPCHARCAST:
+ case OPMIN2:
+ case OPMAX2:
+ case OPDMIN:
+ case OPDMAX:
+putopp:
+ p = putop(p);
+ break;
+
+ default:
+ badop("putx", opc);
+ p = errnode ();
+ }
+ break;
+
+ case TADDR:
+ p = putaddr(p);
+ break;
+
+ default:
+ badtag("putx", p->tag);
+ p = errnode ();
+ }
+
+ return p;
+}
+
+
+
+LOCAL expptr putop(p)
+expptr p;
+{
+ expptr lp, tp;
+ int pt, lt;
+ int comma;
+
+ switch(p->exprblock.opcode) /* check for special cases and rewrite */
+ {
+ case OPCONV:
+ pt = p->exprblock.vtype;
+ lp = p->exprblock.leftp;
+ lt = lp->headblock.vtype;
+
+/* Simplify nested type casts */
+
+ while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
+ ( (ISREAL(pt)&&ISREAL(lt)) ||
+ (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
+ {
+#if SZINT < SZLONG
+ if(lp->tag != TEXPR)
+ {
+ if(pt==TYINT && lt==TYLONG)
+ break;
+ if(lt==TYINT && pt==TYLONG)
+ break;
+ }
+#endif
+
+
+ if(pt==TYDREAL && lt==TYREAL)
+ {
+ if(lp->tag==TEXPR &&
+ lp->exprblock.opcode==OPCONV &&
+ lp->exprblock.leftp->headblock.vtype==TYDREAL)
+ {
+ lp->exprblock.leftp =
+ putx(lp->exprblock.leftp);
+ return p;
+ }
+ else break;
+ }
+
+
+ if(lt==TYCHAR && lp->tag==TEXPR &&
+ lp->exprblock.opcode==OPCALL)
+ {
+
+/* May want to make a comma expression here instead. I had one, but took
+ it out for my convenience, not for the convenience of the end user */
+
+ putout (putcall (lp, (Addrp *) &(p ->
+ exprblock.leftp)));
+ return putop (p);
+ }
+ if (lt == TYCHAR) {
+ p->exprblock.leftp = putx(p->exprblock.leftp);
+ return p;
+ }
+ free( (charptr) p );
+ p = lp;
+ if (p->tag != TEXPR)
+ goto retputx;
+ pt = lt;
+ lp = p->exprblock.leftp;
+ lt = lp->headblock.vtype;
+ } /* while */
+ if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
+ break;
+ retputx:
+ return putx(p);
+
+ case OPADDR:
+ comma = NO;
+ lp = p->exprblock.leftp;
+ free( (charptr) p );
+ if(lp->tag != TADDR)
+ {
+ tp = (expptr)
+ Mktemp(lp->headblock.vtype,lp->headblock.vleng);
+ p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
+ lp = tp;
+ comma = YES;
+ }
+ if(comma)
+ p = mkexpr(OPCOMMA, p, putaddr(lp));
+ else
+ p = (expptr)putaddr(lp);
+ return p;
+
+ case OPASSIGN:
+ case OPASSIGNI:
+ case OPLT:
+ case OPLE:
+ case OPGT:
+ case OPGE:
+ case OPEQ:
+ case OPNE:
+ ;
+ }
+
+ if( ops2[p->exprblock.opcode] <= 0)
+ badop("putop", p->exprblock.opcode);
+ p -> exprblock.leftp = putx (p -> exprblock.leftp);
+ if (p -> exprblock.rightp)
+ p -> exprblock.rightp = putx (p -> exprblock.rightp);
+ return p;
+}
+
+LOCAL expptr putpower(p)
+expptr p;
+{
+ expptr base;
+ Addrp t1, t2;
+ ftnint k;
+ int type;
+ char buf[80]; /* buffer for text of comment */
+
+ if(!ISICON(p->exprblock.rightp) ||
+ (k = p->exprblock.rightp->constblock.Const.ci)<2)
+ Fatal("putpower: bad call");
+ base = p->exprblock.leftp;
+ type = base->headblock.vtype;
+ t1 = Mktemp(type, ENULL);
+ t2 = NULL;
+
+ free ((charptr) p);
+ p = putassign (cpexpr((expptr) t1), base);
+
+ sprintf (buf, "Computing %d%s power", k, k == 2 ? "nd" : (k == 3 ?
+ "rd" : "th"));
+ p1_comment (buf);
+
+ for( ; (k&1)==0 && k>2 ; k>>=1 )
+ {
+ p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
+ }
+
+ if(k == 2) {
+
+/* Write the power computation out immediately */
+ putout (p);
+ p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
+ } else {
+ t2 = Mktemp(type, ENULL);
+ p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
+ cpexpr((expptr)t1)));
+
+ for(k>>=1 ; k>1 ; k>>=1)
+ {
+ p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
+ if(k & 1)
+ {
+ p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
+ }
+ }
+/* Write the power computation out immediately */
+ putout (p);
+ p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
+ mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
+ }
+ frexpr((expptr)t1);
+ if(t2)
+ frexpr((expptr)t2);
+ return p;
+}
+
+
+
+
+LOCAL Addrp intdouble(p)
+Addrp p;
+{
+ register Addrp t;
+
+ t = Mktemp(TYDREAL, ENULL);
+ putout (putassign(cpexpr((expptr)t), (expptr)p));
+ return(t);
+}
+
+
+
+
+
+/* Complex-type variable assignment */
+
+LOCAL Addrp putcxeq(p)
+register expptr p;
+{
+ register Addrp lp, rp;
+ expptr code;
+
+ if(p->tag != TEXPR)
+ badtag("putcxeq", p->tag);
+
+ lp = putcx1(p->exprblock.leftp);
+ rp = putcx1(p->exprblock.rightp);
+ code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
+
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ {
+ code = mkexpr (OPCOMMA, code, putassign
+ (imagpart(lp), imagpart(rp)));
+ }
+ putout (code);
+ frexpr((expptr)rp);
+ free ((charptr) p);
+ return lp;
+}
+
+
+
+/* putcxop -- used to write out embedded calls to complex functions, and
+ complex arguments to procedures */
+
+expptr putcxop(p)
+expptr p;
+{
+ return (expptr)putaddr((expptr)putcx1(p));
+}
+
+#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
+
+LOCAL Addrp putcx1(p)
+register expptr p;
+{
+ expptr q;
+ Addrp lp, rp;
+ register Addrp resp;
+ int opcode;
+ int ltype, rtype;
+ long ts;
+ expptr mkrealcon();
+
+ if(p == NULL)
+ return(NULL);
+
+ switch(p->tag)
+ {
+ case TCONST:
+ if( ISCOMPLEX(p->constblock.vtype) )
+ p = (expptr) putconst((Constp)p);
+ return( (Addrp) p );
+
+ case TADDR:
+ resp = &p->addrblock;
+ if (addressable(p))
+ return (Addrp) p;
+ if ((q = resp->memoffset) && resp->isarray
+ && resp->vtype != TYCHAR) {
+ if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
+ && resp->uname_tag == UNAM_NAME)
+ q = mkexpr(OPMINUS, q,
+ mkintcon(resp->user.name->voffset));
+ ts = typesize[resp->vtype]
+ * (resp->Field ? 2 : 1);
+ q = resp->memoffset = mkexpr(OPSLASH, q, ICON(ts));
+ }
+ else
+ ts = 0;
+ resp = Mktemp(tyint, ENULL);
+ putout(putassign(cpexpr((expptr)resp), q));
+ p->addrblock.memoffset = (expptr)resp;
+ if (ts) {
+ resp = &p->addrblock;
+ q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
+ if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
+ && resp->uname_tag == UNAM_NAME)
+ q = mkexpr(OPPLUS, q,
+ mkintcon(resp->user.name->voffset));
+ resp->memoffset = q;
+ }
+ return (Addrp) p;
+
+ case TEXPR:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ break;
+ resp = Mktemp(TYDREAL, ENULL);
+ putout (putassign( cpexpr((expptr)resp), p));
+ return(resp);
+
+ default:
+ badtag("putcx1", p->tag);
+ }
+
+ opcode = p->exprblock.opcode;
+ if(opcode==OPCALL || opcode==OPCCALL)
+ {
+ Addrp t;
+ p = putcall(p, &t);
+ putout(p);
+ return t;
+ }
+ else if(opcode == OPASSIGN)
+ {
+ return putcxeq (p);
+ }
+
+/* BUG (inefficient) Generates too many temporary variables */
+
+ resp = Mktemp(p->exprblock.vtype, ENULL);
+ if(lp = putcx1(p->exprblock.leftp) )
+ ltype = lp->vtype;
+ if(rp = putcx1(p->exprblock.rightp) )
+ rtype = rp->vtype;
+
+ switch(opcode)
+ {
+ case OPCOMMA:
+ frexpr((expptr)resp);
+ resp = rp;
+ rp = NULL;
+ break;
+
+ case OPNEG:
+ case OPNEG1:
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
+ putassign( imagpart(resp),
+ mkexpr(OPNEG, imagpart(lp), ENULL))));
+ break;
+
+ case OPPLUS:
+ case OPMINUS: { expptr r;
+ r = putassign( (expptr)realpart(resp),
+ mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
+ if(rtype < TYCOMPLEX)
+ q = putassign( imagpart(resp), imagpart(lp) );
+ else if(ltype < TYCOMPLEX)
+ {
+ if(opcode == OPPLUS)
+ q = putassign( imagpart(resp), imagpart(rp) );
+ else
+ q = putassign( imagpart(resp),
+ mkexpr(OPNEG, imagpart(rp), ENULL) );
+ }
+ else
+ q = putassign( imagpart(resp),
+ mkexpr(opcode, imagpart(lp), imagpart(rp) ));
+ r = PAIR (r, q);
+ putout (r);
+ break;
+ } /* case OPPLUS, OPMINUS: */
+ case OPSTAR:
+ if(ltype < TYCOMPLEX)
+ {
+ if( ISINT(ltype) )
+ lp = intdouble(lp);
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)lp),
+ (expptr)realpart(rp))),
+ putassign( imagpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
+ }
+ else if(rtype < TYCOMPLEX)
+ {
+ if( ISINT(rtype) )
+ rp = intdouble(rp);
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)rp),
+ (expptr)realpart(lp))),
+ putassign( imagpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
+ }
+ else {
+ putout (PAIR (
+ putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
+ mkexpr(OPSTAR, (expptr)realpart(lp),
+ (expptr)realpart(rp)),
+ mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
+ putassign( imagpart(resp), mkexpr(OPPLUS,
+ mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
+ mkexpr(OPSTAR, imagpart(lp),
+ (expptr)realpart(rp))))));
+ }
+ break;
+
+ case OPSLASH:
+ /* fixexpr has already replaced all divisions
+ * by a complex by a function call
+ */
+ if( ISINT(rtype) )
+ rp = intdouble(rp);
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
+ putassign( imagpart(resp),
+ mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
+ break;
+
+ case OPCONV:
+ if( ISCOMPLEX(lp->vtype) )
+ q = imagpart(lp);
+ else if(rp != NULL)
+ q = (expptr) realpart(rp);
+ else
+ q = mkrealcon(TYDREAL, "0");
+ putout (PAIR (
+ putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
+ putassign( imagpart(resp), q)));
+ break;
+
+ default:
+ badop("putcx1", opcode);
+ }
+
+ frexpr((expptr)lp);
+ frexpr((expptr)rp);
+ free( (charptr) p );
+ return(resp);
+}
+
+
+
+
+/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
+ are not defined */
+
+LOCAL expptr putcxcmp(p)
+register expptr p;
+{
+ int opcode;
+ register Addrp lp, rp;
+ expptr q;
+
+ if(p->tag != TEXPR)
+ badtag("putcxcmp", p->tag);
+
+ opcode = p->exprblock.opcode;
+ lp = putcx1(p->exprblock.leftp);
+ rp = putcx1(p->exprblock.rightp);
+
+ q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
+ mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
+ mkexpr(opcode, imagpart(lp), imagpart(rp)) );
+
+ free( (charptr) lp);
+ free( (charptr) rp);
+ free( (charptr) p );
+ return putx( fixexpr((Exprp)q) );
+}
+
+/* putch1 -- Forces constants into the literal pool, among other things */
+
+LOCAL Addrp putch1(p)
+register expptr p;
+{
+ Addrp t;
+ expptr e;
+
+ switch(p->tag)
+ {
+ case TCONST:
+ return( putconst((Constp)p) );
+
+ case TADDR:
+ return( (Addrp) p );
+
+ case TEXPR:
+ switch(p->exprblock.opcode)
+ {
+ expptr q;
+
+ case OPCALL:
+ case OPCCALL:
+
+ p = putcall(p, &t);
+ putout (p);
+ break;
+
+ case OPCONCAT:
+ t = Mktemp(TYCHAR, ICON(lencat(p)));
+ q = (expptr) cpexpr(p->headblock.vleng);
+ p = putcat( cpexpr((expptr)t), p );
+ /* put the correct length on the block */
+ frexpr(t->vleng);
+ t->vleng = q;
+ putout (p);
+ break;
+
+ case OPCONV:
+ if(!ISICON(p->exprblock.vleng)
+ || p->exprblock.vleng->constblock.Const.ci!=1
+ || ! INT(p->exprblock.leftp->headblock.vtype) )
+ Fatal("putch1: bad character conversion");
+ t = Mktemp(TYCHAR, ICON(1));
+ e = mkexpr(OPCONV, (expptr)t, ENULL);
+ e->headblock.vtype = tyint;
+ p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
+ putout (p);
+ break;
+ default:
+ badop("putch1", p->exprblock.opcode);
+ }
+ return(t);
+
+ default:
+ badtag("putch1", p->tag);
+ }
+ /* NOT REACHED */ return 0;
+}
+
+
+/* putchop -- Write out a character actual parameter; that is, this is
+ part of a procedure invocation */
+
+LOCAL Addrp putchop(p)
+expptr p;
+{
+ p = putaddr((expptr)putch1(p));
+ return (Addrp)p;
+}
+
+
+
+
+LOCAL expptr putcheq(p)
+register expptr p;
+{
+ expptr lp, rp;
+
+ if(p->tag != TEXPR)
+ badtag("putcheq", p->tag);
+
+ lp = p->exprblock.leftp;
+ rp = p->exprblock.rightp;
+ frexpr(p->exprblock.vleng);
+ free( (charptr) p );
+
+/* If s = t // u, don't bother copying the result, write it directly into
+ this buffer */
+
+ if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
+ p = putcat(lp, rp);
+ else if( ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
+ lp = mkexpr(OPCONV, lp, ENULL);
+ rp = mkexpr(OPCONV, rp, ENULL);
+ lp->headblock.vtype = rp->headblock.vtype = tyint;
+ p = putop(mkexpr(OPASSIGN, lp, rp));
+ }
+ else
+ p = putx( call2(TYSUBR, "s_copy", lp, rp) );
+ return p;
+}
+
+
+
+
+LOCAL expptr putchcmp(p)
+register expptr p;
+{
+ expptr lp, rp;
+
+ if(p->tag != TEXPR)
+ badtag("putchcmp", p->tag);
+
+ lp = p->exprblock.leftp;
+ rp = p->exprblock.rightp;
+
+ if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
+ lp = mkexpr(OPCONV, putx(lp), ENULL);
+ rp = mkexpr(OPCONV, putx(rp), ENULL);
+ lp->headblock.vtype = rp->headblock.vtype = tyint;
+ }
+ else {
+ lp = call2(TYINT,"s_cmp", lp, rp);
+ rp = ICON(0);
+ }
+ p->exprblock.leftp = lp;
+ p->exprblock.rightp = rp;
+ p = putop(p);
+ return p;
+}
+
+
+
+
+
+/* putcat -- Writes out a concatenation operation. Two temporary arrays
+ are allocated, putct1() is called to initialize them, and then a
+ call to runtime library routine s_cat() is inserted.
+
+ This routine generates code which will perform an (nconc lhs rhs)
+ at runtime. The runtime funciton does not return a value, the routine
+ that calls this putcat must remember the name of lhs.
+*/
+
+
+LOCAL expptr putcat(lhs0, rhs)
+ expptr lhs0;
+ register expptr rhs;
+{
+ register Addrp lhs = (Addrp)lhs0;
+ int n, tyi;
+ Addrp length_var, string_var;
+ expptr p;
+ static char Writing_concatenation[] = "Writing concatenation";
+
+/* Create the temporary arrays */
+
+ n = ncat(rhs);
+ length_var = mktmpn(n, tyioint, ENULL);
+ string_var = mktmpn(n, TYADDR, ENULL);
+ frtemp((Addrp)cpexpr((expptr)length_var));
+ frtemp((Addrp)cpexpr((expptr)string_var));
+
+/* Initialize the arrays */
+
+ n = 0;
+ /* p1_comment scribbles on its argument, so we
+ * cannot safely pass a string literal here. */
+ p1_comment(Writing_concatenation);
+ putct1(rhs, length_var, string_var, &n);
+
+/* Create the invocation */
+
+ tyi = tyint;
+ tyint = tyioint; /* for -I2 */
+ p = putx (call4 (TYSUBR, "s_cat",
+ (expptr)lhs,
+ (expptr)string_var,
+ (expptr)length_var,
+ (expptr)putconst((Constp)ICON(n))));
+ tyint = tyi;
+
+ return p;
+}
+
+
+
+
+
+LOCAL putct1(q, length_var, string_var, ip)
+register expptr q;
+register Addrp length_var, string_var;
+int *ip;
+{
+ int i;
+ Addrp length_copy, string_copy;
+ extern int szleng;
+
+ if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
+ {
+ putct1(q->exprblock.leftp, length_var, string_var,
+ ip);
+ putct1(q->exprblock.rightp, length_var, string_var,
+ ip);
+ frexpr (q -> exprblock.vleng);
+ free ((charptr) q);
+ }
+ else
+ {
+ i = (*ip)++;
+ length_copy = (Addrp) cpexpr((expptr)length_var);
+ length_copy->memoffset =
+ mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
+ string_copy = (Addrp) cpexpr((expptr)string_var);
+ string_copy->memoffset =
+ mkexpr(OPPLUS, string_copy->memoffset,
+ ICON(i*typesize[TYLONG]));
+ putout (PAIR (putassign((expptr)length_copy, cpexpr
+ (q->headblock.vleng)),
+ putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
+ }
+}
+
+/* putaddr -- seems to write out function invocation actual parameters */
+
+LOCAL expptr putaddr(p0)
+ expptr p0;
+{
+ register Addrp p;
+
+ if (!(p = (Addrp)p0))
+ return ENULL;
+
+ if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
+ {
+ frexpr((expptr)p);
+ return ENULL;
+ }
+ if (p->isarray && p->memoffset)
+ p->memoffset = putx(p->memoffset);
+ return (expptr) p;
+}
+
+ LOCAL expptr
+addrfix(e) /* fudge character string length if it's a TADDR */
+ expptr e;
+{
+ return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
+ }
+
+ LOCAL int
+typekludge(ccall, q, at, j)
+ int ccall;
+ register expptr q;
+ Atype *at;
+ int j; /* alternate type */
+{
+ register int i, k;
+ extern int iocalladdr;
+ register Namep np;
+
+ /* Return value classes:
+ * < 100 ==> Fortran arg (pointer to type)
+ * < 200 ==> C arg
+ * < 300 ==> procedure arg
+ * < 400 ==> external, no explicit type
+ * < 500 ==> arg that may turn out to be
+ * either a variable or a procedure
+ */
+
+ k = q->headblock.vtype;
+ if (ccall) {
+ if (k == TYREAL)
+ k = TYDREAL; /* force double for library routines */
+ return k + 100;
+ }
+ if (k == TYADDR)
+ return iocalladdr;
+ i = q->tag;
+ if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
+ || (i == TADDR && q->addrblock.charleng)
+ || i == TCONST)
+ k = TYFTNLEN + 100;
+ else if (i == TADDR)
+ switch(q->addrblock.vclass) {
+ case CLPROC:
+ if (q->addrblock.uname_tag != UNAM_NAME)
+ k += 200;
+ else if ((np = q->addrblock.user.name)->vprocclass
+ != PTHISPROC) {
+ if (k && !np->vimpltype)
+ k += 200;
+ else {
+ if (j > 200 && infertypes && j < 300) {
+ k = j;
+ inferdcl(np, j-200);
+ }
+ else k = (np->vstg == STGEXT
+ ? extsymtab[np->vardesc.varno].extype
+ : 0) + 200;
+ at->cp = mkchain((char *)np, at->cp);
+ }
+ }
+ else if (k == TYSUBR)
+ k += 200;
+ break;
+
+ case CLUNKNOWN:
+ if (q->addrblock.vstg == STGARG
+ && q->addrblock.uname_tag == UNAM_NAME) {
+ k += 400;
+ at->cp = mkchain((char *)q->addrblock.user.name,
+ at->cp);
+ }
+ }
+ else if (i == TNAME && q->nameblock.vstg == STGARG) {
+ np = &q->nameblock;
+ switch(np->vclass) {
+ case CLPROC:
+ if (!np->vimpltype)
+ k += 200;
+ else if (j <= 200 || !infertypes || j >= 300)
+ k += 300;
+ else {
+ k = j;
+ inferdcl(np, j-200);
+ }
+ goto add2chain;
+
+ case CLUNKNOWN:
+ /* argument may be a scalar variable or a function */
+ if (np->vimpltype && j && infertypes
+ && j < 300) {
+ inferdcl(np, j % 100);
+ k = j;
+ }
+ else
+ k += 400;
+
+ /* to handle procedure args only so far known to be
+ * external, save a pointer to the symbol table entry...
+ */
+ add2chain:
+ at->cp = mkchain((char *)np, at->cp);
+ }
+ }
+ return k;
+ }
+
+ char *
+Argtype(k, buf)
+ int k;
+ char *buf;
+{
+ if (k < 100) {
+ sprintf(buf, "%s variable", ftn_types[k]);
+ return buf;
+ }
+ if (k < 200) {
+ k -= 100;
+ return k == TYFTNLEN ? "ftnlen" : ftn_types[k];
+ }
+ if (k < 300) {
+ k -= 200;
+ if (k == TYSUBR)
+ return ftn_types[TYSUBR];
+ sprintf(buf, "%s function", ftn_types[k]);
+ return buf;
+ }
+ if (k < 400)
+ return "external argument";
+ k -= 400;
+ sprintf(buf, "%s argument", ftn_types[k]);
+ return buf;
+ }
+
+ static void
+atype_squawk(at, msg)
+ Argtypes *at;
+ char *msg;
+{
+ register Atype *a, *ae;
+ warn(msg);
+ for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
+ frchain(&a->cp);
+ at->nargs = -1;
+ if (at->changes & 2)
+ proc_protochanges++;
+ }
+
+ static char inconsist[] = "inconsistent calling sequences for ";
+
+ void
+bad_atypes(at, fname, i, j, k, here, prev)
+ Argtypes *at;
+ char *fname, *here, *prev;
+ int i, j, k;
+{
+ char buf[208], buf1[32], buf2[32];
+
+ sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
+ inconsist, fname, i, here, Argtype(k, buf1),
+ prev, Argtype(j, buf2));
+ atype_squawk(at, buf);
+ }
+
+ int
+type_fixup(at,a,k)
+ Argtypes *at;
+ Atype *a;
+ int k;
+{
+ register struct Entrypoint *ep;
+ if (!infertypes)
+ return 0;
+ for(ep = entries; ep; ep = ep->entnextp)
+ if (at == ep->entryname->arginfo) {
+ a->type = k % 100;
+ return proc_argchanges = 1;
+ }
+ return 0;
+ }
+
+
+ void
+save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type)
+ chainp arglist;
+ Argtypes **at0, **at1;
+ int ccall, stg, nchargs, type;
+ char *fname;
+{
+ Argtypes *at;
+ chainp cp;
+ int i, i0, j, k, nargs, *t, *te;
+ Atype *atypes;
+ expptr q;
+ char buf[208];
+ static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
+ static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,
+ initargs, initargs+1,0,initargs+2};
+ static int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,
+ 1, 1, 0, 2};
+
+ i = i0 = init_ac[type];
+ t = init_ap[type];
+ te = t + i;
+ if (at = *at0) {
+ *at1 = at;
+ nargs = at->nargs;
+ if (nargs < 0) { /* inconsistent usage seen */
+ if (type) {
+ if (at->changes & 2)
+ --proc_protochanges;
+ goto newlist;
+ }
+ return;
+ }
+ for(cp = arglist; cp; cp = cp->nextp)
+ i++;
+ if ((i += nchargs) != nargs) {
+ sprintf(buf,
+ "%s%.90s:\n\there %d, previously %d args and string lengths.",
+ inconsist, fname, i, nargs);
+ atype_squawk(at, buf);
+ retn:
+ if (type)
+ goto newlist;
+ return;
+ }
+ atypes = at->atypes;
+ i = 0;
+ for(; t < te; atypes++) {
+ i++;
+ j = atypes->type;
+ k = *t++;
+ if (j != k)
+ goto badtypes;
+ }
+ for(cp = arglist; cp; atypes++, cp = cp->nextp) {
+ ++i;
+ j = atypes->type;
+ if (!(q = (expptr)cp->datap))
+ continue;
+ k = typekludge(ccall, q, atypes, j);
+ if (k >= 300 || k == j)
+ continue;
+ if (j >= 300) {
+ if (k >= 200) {
+ if (k == TYUNKNOWN + 200)
+ continue;
+ if (j % 100 != k - 200
+ && k != TYSUBR + 200
+ && j != TYUNKNOWN + 300
+ && !type_fixup(at,atypes,k))
+ goto badtypes;
+ }
+ else if (j % 100 % TYSUBR != k % TYSUBR
+ && !type_fixup(at,atypes,k))
+ goto badtypes;
+ }
+ else if (k < 200 || j < 200)
+ if (j)
+ goto badtypes;
+ else ; /* fall through to update */
+ else if (k == TYUNKNOWN+200)
+ continue;
+ else if (j != TYUNKNOWN+200)
+ {
+ badtypes:
+ bad_atypes(at, fname, i, j, k, "here ",
+ ", previously");
+ if (type) {
+ /* we're defining the procedure */
+ t = init_ap[type];
+ te = t + i0;
+ proc_argchanges = 1;
+ goto newlist;
+ }
+ goto retn;
+ }
+ /* We've subsequently learned the right type,
+ as in the call on zoo below...
+
+ subroutine foo(x, zap)
+ external zap
+ call goo(zap)
+ x = zap(3)
+ call zoo(zap)
+ end
+ */
+ atypes->type = k;
+ at->changes |= 1;
+ }
+ if (type)
+ at->changes = 0;
+ return;
+ }
+ newlist:
+ i = i0 + nchargs;
+ for(cp = arglist; cp; cp = cp->nextp)
+ i++;
+ k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
+ *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
+ : (Argtypes *) mem(k,1);
+ at->nargs = i;
+ at->changes = 0;
+ atypes = at->atypes;
+ for(; t < te; atypes++) {
+ atypes->type = *t++;
+ atypes->cp = 0;
+ }
+ for(cp = arglist; cp; atypes++, cp = cp->nextp) {
+ atypes->cp = 0;
+ atypes->type = (q = (expptr)cp->datap)
+ ? typekludge(ccall, q, atypes, 0)
+ : 0;
+ }
+ for(; --nchargs >= 0; atypes++) {
+ atypes->type = TYFTNLEN + 100;
+ atypes->cp = 0;
+ }
+ }
+
+ void
+saveargtypes(p) /* for writing prototypes */
+ register Exprp p;
+{
+ Addrp a;
+ Argtypes **at0, **at1;
+ Namep np;
+ chainp arglist;
+ expptr rp;
+ Extsym *e;
+ char *fname;
+
+ a = (Addrp)p->leftp;
+ switch(a->vstg) {
+ case STGEXT:
+ switch(a->uname_tag) {
+ case UNAM_EXTERN: /* e.g., sqrt() */
+ e = extsymtab + a->memno;
+ at0 = at1 = &e->arginfo;
+ fname = e->fextname;
+ break;
+ case UNAM_NAME:
+ np = a->user.name;
+ at0 = &extsymtab[np->vardesc.varno].arginfo;
+ at1 = &np->arginfo;
+ fname = np->fvarname;
+ break;
+ default:
+ goto bug;
+ }
+ break;
+ case STGARG:
+ if (a->uname_tag != UNAM_NAME)
+ goto bug;
+ np = a->user.name;
+ at0 = at1 = &np->arginfo;
+ fname = np->fvarname;
+ break;
+ default:
+ bug:
+ Fatal("Confusion in saveargtypes");
+ }
+ rp = p->rightp;
+ arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
+ save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
+ fname, a->vstg, 0, 0);
+ }
+
+/* putcall - fix up the argument list, and write out the invocation. p
+ is expected to be initialized and point to an OPCALL or OPCCALL
+ expression. The return value is a pointer to a temporary holding the
+ result of a COMPLEX or CHARACTER operation, or NULL. */
+
+LOCAL expptr putcall(p0, temp)
+ expptr p0;
+ Addrp *temp;
+{
+ register Exprp p = (Exprp)p0;
+ chainp arglist; /* Pointer to actual arguments, if any */
+ chainp charsp; /* List of copies of the variables which
+ hold the lengths of character
+ parameters (other than procedure
+ parameters) */
+ chainp cp; /* Iterator over argument lists */
+ register expptr q; /* Pointer to the current argument */
+ Addrp fval; /* Function return value */
+ int type; /* type of the call - presumably this was
+ set elsewhere */
+ int byvalue; /* True iff we don't want to massage the
+ parameter list, since we're calling a C
+ library routine */
+ extern int Castargs;
+ char *s;
+ extern struct Listblock *mklist();
+
+ type = p -> vtype;
+ charsp = NULL;
+ byvalue = (p->opcode == OPCCALL);
+
+/* Verify the actual parameters */
+
+ if (p == (Exprp) NULL)
+ err ("putcall: NULL call expression");
+ else if (p -> tag != TEXPR)
+ erri ("putcall: expected TEXPR, got '%d'", p -> tag);
+
+/* Find the argument list */
+
+ if(p->rightp && p -> rightp -> tag == TLIST)
+ arglist = p->rightp->listblock.listp;
+ else
+ arglist = NULL;
+
+/* Count the number of explicit arguments, including lengths of character
+ variables */
+
+ for(cp = arglist ; cp ; cp = cp->nextp)
+ if(!byvalue) {
+ q = (expptr) cp->datap;
+ if( ISCONST(q) )
+ {
+
+/* Even constants are passed by reference, so we need to put them in the
+ literal table */
+
+ q = (expptr) putconst((Constp)q);
+ cp->datap = (char *) q;
+ }
+
+/* Save the length expression of character variables (NOT character
+ procedures) for the end of the argument list */
+
+ if( ISCHAR(q) &&
+ (q->headblock.vclass != CLPROC
+ || q->headblock.vstg == STGARG
+ && q->tag == TADDR
+ && q->addrblock.uname_tag == UNAM_NAME
+ && q->addrblock.user.name->vprocclass == PTHISPROC))
+ {
+ charsp = mkchain((char *)cpexpr(q->headblock.vleng), charsp);
+ if (q->headblock.vclass == CLUNKNOWN
+ && q->headblock.vstg == STGARG)
+ q->addrblock.user.name->vpassed = 1;
+ }
+ }
+ charsp = revchain(charsp);
+
+/* If the routine is a CHARACTER function ... */
+
+ if(type == TYCHAR)
+ {
+ if( ISICON(p->vleng) )
+ {
+
+/* Allocate a temporary to hold the return value of the function */
+
+ fval = Mktemp(TYCHAR, p->vleng);
+ }
+ else {
+ err("adjustable character function");
+ if (temp)
+ *temp = 0;
+ return 0;
+ }
+ }
+
+/* If the routine is a COMPLEX function ... */
+
+ else if( ISCOMPLEX(type) )
+ fval = Mktemp(type, ENULL);
+ else
+ fval = NULL;
+
+/* Write the function name, without taking its address */
+
+ p -> leftp = putx(fixtype(putaddr(p->leftp)));
+
+ if(fval)
+ {
+ chainp prepend;
+
+/* Prepend a copy of the function return value buffer out as the first
+ argument. */
+
+ prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
+
+/* If it's a character function, also prepend the length of the result */
+
+ if(type==TYCHAR)
+ {
+
+ prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
+ p->vleng)), arglist);
+ }
+ if (!(q = p->rightp))
+ p->rightp = q = (expptr)mklist(CHNULL);
+ q->listblock.listp = prepend;
+ }
+
+/* Scan through the fortran argument list */
+
+ for(cp = arglist ; cp ; cp = cp->nextp)
+ {
+ q = (expptr) (cp->datap);
+ if (q == ENULL)
+ err ("putcall: NULL argument");
+
+/* call putaddr only when we've got a parameter for a C routine or a
+ memory resident parameter */
+
+ if (q -> tag == TCONST && !byvalue)
+ q = (expptr) putconst ((Constp)q);
+
+ if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) )
+ cp->datap = (char *)putaddr(q);
+ else if( ISCOMPLEX(q->headblock.vtype) )
+ cp -> datap = (char *) putx (fixtype(putcxop(q)));
+ else if (ISCHAR(q) )
+ cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
+ else if( ! ISERROR(q) )
+ {
+ if(byvalue
+ || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
+ cp -> datap = (char *) putx(q);
+ else {
+ expptr t, t1;
+
+/* If we've got a register parameter, or (maybe?) a constant, save it in a
+ temporary first */
+
+ t = (expptr) Mktemp(q->headblock.vtype, q->headblock.vleng);
+
+/* Assign to temporary variables before invoking the subroutine or
+ function */
+
+ t1 = putassign( cpexpr(t), q );
+ if (doin_setbound)
+ t = mkexpr(OPCOMMA_ARG, t1, t);
+ else
+ putout(t1);
+ cp -> datap = (char *) t;
+ } /* else */
+ } /* if !ISERROR(q) */
+ }
+
+/* Now adjust the lengths of the CHARACTER parameters */
+
+ for(cp = charsp ; cp ; cp = cp->nextp)
+ cp->datap = (char *)addrfix(putx(
+ /* in case MAIN has a character*(*)... */
+ (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
+ : ICON(0)));
+
+/* ... and add them to the end of the argument list */
+
+ hookup (arglist, charsp);
+
+/* Return the name of the temporary used to hold the results, if any was
+ necessary. */
+
+ if (temp) *temp = fval;
+ else frexpr ((expptr)fval);
+
+ saveargtypes(p);
+
+ return (expptr) p;
+}
+
+
+
+/* putmnmx -- Put min or max. p must point to an EXPR, not just a
+ CONST */
+
+LOCAL expptr putmnmx(p)
+register expptr p;
+{
+ int op, op2, type;
+ expptr arg, qp, temp;
+ chainp p0, p1;
+ Addrp sp, tp;
+ char comment_buf[80];
+ char *what;
+
+ if(p->tag != TEXPR)
+ badtag("putmnmx", p->tag);
+
+ type = p->exprblock.vtype;
+ op = p->exprblock.opcode;
+ op2 = op == OPMIN ? OPMIN2 : OPMAX2;
+ p0 = p->exprblock.leftp->listblock.listp;
+ free( (charptr) (p->exprblock.leftp) );
+ free( (charptr) p );
+
+ /* special case for two addressable operands */
+
+ if (addressable((expptr)p0->datap)
+ && (p1 = p0->nextp)
+ && addressable((expptr)p1->datap)
+ && !p1->nextp) {
+ if (type == TYREAL && forcedouble)
+ op2 = op == OPMIN ? OPDMIN : OPDMAX;
+ p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
+ mkconv(type, cpexpr((expptr)p1->datap)));
+ frchain(&p0);
+ return p;
+ }
+
+ /* general case */
+
+ sp = Mktemp(type, ENULL);
+
+/* We only need a second temporary if the arg list has an unaddressable
+ value */
+
+ tp = (Addrp) NULL;
+ qp = ENULL;
+ for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
+ if (!addressable ((expptr) p1 -> datap)) {
+ tp = Mktemp(type, ENULL);
+ qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
+ qp = fixexpr((Exprp)qp);
+ break;
+ } /* if */
+
+/* Now output the appropriate number of assignments and comparisons. Min
+ and max are implemented by the simple O(n) algorithm:
+
+ min (a, b, c, d) ==>
+ { <type> t1, t2;
+
+ t1 = a;
+ t2 = b; t1 = (t1 < t2) ? t1 : t2;
+ t2 = c; t1 = (t1 < t2) ? t1 : t2;
+ t2 = d; t1 = (t1 < t2) ? t1 : t2;
+ }
+*/
+
+ if (!doin_setbound) {
+ switch(op) {
+ case OPLT:
+ case OPMIN:
+ case OPDMIN:
+ case OPMIN2:
+ what = "IN";
+ break;
+ default:
+ what = "AX";
+ }
+ sprintf (comment_buf, "Computing M%s", what);
+ p1_comment (comment_buf);
+ }
+
+ p1 = p0->nextp;
+ temp = (expptr)p0->datap;
+ if (addressable(temp) && addressable((expptr)p1->datap)) {
+ p = mkconv(type, cpexpr(temp));
+ arg = mkconv(type, cpexpr((expptr)p1->datap));
+ temp = mkexpr(op2, p, arg);
+ if (!ISCONST(temp))
+ temp = fixexpr((Exprp)temp);
+ p1 = p1->nextp;
+ }
+ p = putassign (cpexpr((expptr)sp), temp);
+
+ for(; p1 ; p1 = p1->nextp)
+ {
+ if (addressable ((expptr) p1 -> datap)) {
+ arg = mkconv(type, cpexpr((expptr)p1->datap));
+ temp = mkexpr(op2, cpexpr((expptr)sp), arg);
+ temp = fixexpr((Exprp)temp);
+ } else {
+ temp = (expptr) cpexpr (qp);
+ p = mkexpr(OPCOMMA, p,
+ putassign(cpexpr((expptr)tp), (expptr)p1->datap));
+ } /* else */
+
+ if(p1->nextp)
+ p = mkexpr(OPCOMMA, p,
+ putassign(cpexpr((expptr)sp), temp));
+ else {
+ if (type == TYREAL && forcedouble)
+ temp->exprblock.opcode =
+ op == OPMIN ? OPDMIN : OPDMAX;
+ if (doin_setbound)
+ p = mkexpr(OPCOMMA, p, temp);
+ else {
+ putout (p);
+ p = putx(temp);
+ }
+ if (qp)
+ frexpr (qp);
+ } /* else */
+ } /* for */
+
+ frchain( &p0 );
+ return p;
+}
+
+
+ void
+putwhile(p)
+ expptr p;
+{
+ long where;
+ int k, n;
+ char *realloc();
+
+ if (wh_next >= wh_last)
+ {
+ k = wh_last - wh_first;
+ n = k + 100;
+ wh_next = mem(n,0);
+ wh_last = wh_first + n;
+ if (k)
+ memcpy(wh_next, wh_first, k);
+ wh_first = wh_next;
+ wh_next += k;
+ wh_last = wh_first + n;
+ }
+ if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
+ {
+ if(k != TYERROR)
+ err("non-logical expression in IF statement");
+ }
+ else {
+ p1put(P1_WHILE1START);
+ where = ftell(pass1_file);
+ p = putx(p);
+ *wh_next++ = ftell(pass1_file) > where;
+ p1put(P1_WHILE2START);
+ p1_expr(p);
+ }
+ frexpr(p);
+ }
--- /dev/null
+Type "make" to check the validity of the f2c source and compile f2c.
+
+The file usignal.h is for the benefit of strictly ANSI include files
+on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
+You may need to modify usignal.h if you are not running f2c on a UNIX
+system.
+
+Should you get the message "xsum0.out xsum1.out differ", see what lines
+are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
+the files in question "from f2c/src". For example, if exec.c and
+expr.c have incorrect check sums, you would send netlib the message
+ send exec.c expr.c from f2c/src
+
+On some systems, the malloc and free in malloc.c let f2c run faster
+than do the standard malloc and free. Other systems cannot tolerate
+redefinition of malloc and free. If yours is such a system, you may
+either modify the makefile appropriately, or simply execute
+ cc -c -DCRAY malloc.c
+before typing "make". Still other systems have a -lmalloc that
+provides performance competitive with that from malloc.c; you may
+wish to compare the two on your system.
+
+On some BSD systems, you may need to create a file named "string.h"
+whose single line is
+#include <strings.h>
+you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
+in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
+assignment in the makefile -- see the comments in memset.c .
+
+For non-UNIX systems, you may need to change some things in sysdep.c,
+such as the choice of intermediate file names.
+
+Please send bug reports to dmg@research.att.com . The index file
+("send index from f2c") will report recent changes in the recent-change
+log at its end; all changes will be shown in the "fixes" file
+("send fixes from f2c"). To keep current source, you will need to
+request xsum0.out and version.c, in addition to the changed source
+files.
--- /dev/null
+@echo off
+:begin
+if "%1" == "" goto :end
+echo %1
+del %1
+shift
+goto :begin
+:end
+
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* safe_strncpy
+
+ Copies at most max_length characters, stopping at the first \0
+ character in source. The algorithm correctly handles overlapping
+ buffer areas. */
+
+#include <stdio.h>
+#ifndef NULL
+/* ANSI C */
+#include <stddef.h>
+#endif
+
+char *safe_strncpy (dest, source, max_length)
+char *dest, *source;
+int max_length;
+{
+
+/* There are several conditions to be considered in determining buffer
+ area overlap:
+
+ Buffer Overlap? Picture Direction In Which To Copy
+---------------------------------------------------------------------------
+1. dest == source | dest/src | no copy necessary
+ ============
+
+2. tail of dest against | dest | | src | left to right
+ head of source ---------===--------
+
+3. head of dest against | src | | dest | right to left
+ tail of source --------===---------
+
+4. no overlap |src| |dest| or |dest| |src| either direction
+ ----- ------ ------ -----
+*/
+
+ register char *ret_val = dest;
+ register int real_length;
+
+ if (source == NULL || dest == NULL)
+ return NULL;
+
+/* Compute the actual length of the text to be copied */
+
+ for (real_length = 0; real_length < max_length && source[real_length];
+ real_length++);
+
+/* Account for condition 3, dest head v. source tail */
+
+ if (source + real_length >= dest && source < dest)
+ for (; real_length >= 0; real_length--)
+ dest[real_length] = source[real_length];
+
+/* Account for conditions 2 and 4, dest tail v. source head or no overlap */
+
+ else if (source != dest)
+ for (; real_length >= 0; real_length--)
+ *dest++ = *source++;
+
+/* Implicitly handle condition 1, by not performing the copy */
+
+ return ret_val;
+} /* safe_strncpy */
+
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+#include "defs.h"
+#include "usignal.h"
+
+char binread[] = "rb", textread[] = "r";
+char binwrite[] = "wb", textwrite[] = "w";
+char *c_functions = "c_functions";
+char *coutput = "c_output";
+char *initfname = "raw_data";
+char *initbname = "raw_data.b";
+char *blkdfname = "block_data";
+char *p1_file = "p1_file";
+char *p1_bakfile = "p1_file.BAK";
+char *sortfname = "init_file";
+
+#ifndef TMPDIR
+#ifdef MSDOS
+#define TMPDIR ""
+#else
+#define TMPDIR "/tmp"
+#endif
+#endif
+
+char *tmpdir = TMPDIR;
+
+ void
+Un_link_all(cdelete)
+{
+ if (!debugflag) {
+ unlink(c_functions);
+ unlink(initfname);
+ unlink(p1_file);
+ unlink(sortfname);
+ unlink(blkdfname);
+ if (cdelete && coutput)
+ unlink(coutput);
+ }
+ }
+
+ void
+set_tmp_names()
+{
+ int k;
+ if (debugflag == 1)
+ return;
+ k = strlen(tmpdir) + 16;
+ c_functions = (char *)ckalloc(7*k);
+ initfname = c_functions + k;
+ initbname = initfname + k;
+ blkdfname = initbname + k;
+ p1_file = blkdfname + k;
+ p1_bakfile = p1_file + k;
+ sortfname = p1_bakfile + k;
+ {
+#ifdef MSDOS
+ char buf[64], *s, *t;
+ if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
+ t = "";
+ else {
+ /* substitute \ for / to avoid confusion with a
+ * switch indicator in the system("sort ...")
+ * call in formatdata.c
+ */
+ for(s = tmpdir, t = buf; *s; s++, t++)
+ if ((*t = *s) == '/')
+ *t = '\\';
+ if (t[-1] != '\\')
+ *t++ = '\\';
+ *t = 0;
+ t = buf;
+ }
+ sprintf(c_functions, "%sf2c_func", t);
+ sprintf(initfname, "%sf2c_rd", t);
+ sprintf(blkdfname, "%sf2c_blkd", t);
+ sprintf(p1_file, "%sf2c_p1f", t);
+ sprintf(p1_bakfile, "%sf2c_p1fb", t);
+ sprintf(sortfname, "%sf2c_sort", t);
+#else
+ int pid = getpid();
+ sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
+ sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
+ sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
+ sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
+ sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
+ sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
+#endif
+ sprintf(initbname, "%s.b", initfname);
+ }
+ if (debugflag)
+ fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
+ initfname, blkdfname, p1_file, p1_bakfile, sortfname);
+ }
+
+ char *
+c_name(s,ft)char *s;
+{
+ char *b, *s0;
+ int c;
+
+ b = s0 = s;
+ while(c = *s++)
+ if (c == '/')
+ b = s;
+ if (--s < s0 + 3 || s[-2] != '.'
+ || ((c = *--s) != 'f' && c != 'F')) {
+ infname = s0;
+ Fatal("file name must end in .f or .F");
+ }
+ *s = ft;
+ b = copys(b);
+ *s = c;
+ return b;
+ }
+
+ static void
+killed()
+{
+ signal(SIGINT, SIG_IGN);
+#ifdef SIGQUIT
+ signal(SIGQUIT, SIG_IGN);
+#endif
+#ifdef SIGHUP
+ signal(SIGHUP, SIG_IGN);
+#endif
+ signal(SIGTERM, SIG_IGN);
+ Un_link_all(1);
+ exit(126);
+ }
+
+ static void
+sig1catch(sig) int sig;
+{
+ if (signal(sig, SIG_IGN) != SIG_IGN)
+ signal(sig, killed);
+ }
+
+ static void
+flovflo()
+{
+ Fatal("floating exception during constant evaluation; cannot recover");
+ /* vax returns a reserved operand that generates
+ an illegal operand fault on next instruction,
+ which if ignored causes an infinite loop.
+ */
+ signal(SIGFPE, flovflo);
+}
+
+ void
+sigcatch()
+{
+ sig1catch(SIGINT);
+#ifdef SIGQUIT
+ sig1catch(SIGQUIT);
+#endif
+#ifdef SIGHUP
+ sig1catch(SIGHUP);
+#endif
+ sig1catch(SIGTERM);
+ signal(SIGFPE, flovflo); /* catch overflows */
+ }
+
+
+dofork()
+{
+#ifdef MSDOS
+ Fatal("Only one Fortran input file allowed under MS-DOS");
+#else
+ int pid, status, w;
+ extern int retcode;
+
+ if (!(pid = fork()))
+ return 1;
+ if (pid == -1)
+ Fatal("bad fork");
+ while((w = wait(&status)) != pid)
+ if (w == -1)
+ Fatal("bad wait code");
+ retcode |= status >> 8;
+#endif
+ return 0;
+ }
+
+
+/* Unless SYSTEM_SORT is defined, the following gives a simple
+ * in-core version of dsort(). On Fortran source with huge DATA
+ * statements, the in-core version may exhaust the available memory,
+ * in which case you might either recompile this source file with
+ * SYSTEM_SORT defined (if that's reasonable on your system), or
+ * replace the dsort below with a more elaborate version that
+ * does a merging sort with the help of auxiliary files.
+ */
+
+#ifdef SYSTEM_SORT
+
+dsort(from, to)
+ char *from, *to;
+{
+ char buf[200];
+ sprintf(buf, "sort <%s >%s", from, to);
+ return system(buf) >> 8;
+ }
+#else
+
+ static int
+compare(a,b)
+ char *a, *b;
+{ return strcmp(*(char **)a, *(char **)b); }
+
+dsort(from, to)
+ char *from, *to;
+{
+ extern char *Alloc();
+
+ struct Memb {
+ struct Memb *next;
+ int n;
+ char buf[32000];
+ };
+ typedef struct Memb memb;
+ memb *mb, *mb1;
+ register char *x, *x0, *xe;
+ register int c, n;
+ FILE *f;
+ char **z, **z0;
+ int nn = 0;
+
+ f = opf(from, textread);
+ mb = (memb *)Alloc(sizeof(memb));
+ mb->next = 0;
+ x0 = x = mb->buf;
+ xe = x + sizeof(mb->buf);
+ n = 0;
+ for(;;) {
+ c = getc(f);
+ if (x >= xe && (c != EOF || x != x0)) {
+ if (!n)
+ return 126;
+ nn += n;
+ mb->n = n;
+ mb1 = (memb *)Alloc(sizeof(memb));
+ mb1->next = mb;
+ mb = mb1;
+ memcpy(mb->buf, x0, n = x-x0);
+ x0 = mb->buf;
+ x = x0 + n;
+ xe = x0 + sizeof(mb->buf);
+ n = 0;
+ }
+ if (c == EOF)
+ break;
+ if (c == '\n') {
+ ++n;
+ *x++ = 0;
+ x0 = x;
+ }
+ else
+ *x++ = c;
+ }
+ clf(&f, from, 1);
+ f = opf(to, textwrite);
+ if (x > x0) { /* shouldn't happen */
+ *x = 0;
+ ++n;
+ }
+ mb->n = n;
+ nn += n;
+ if (!nn) /* shouldn't happen */
+ goto done;
+ z = z0 = (char **)Alloc(nn*sizeof(char *));
+ for(mb1 = mb; mb1; mb1 = mb1->next) {
+ x = mb1->buf;
+ n = mb1->n;
+ for(;;) {
+ *z++ = x;
+ if (--n <= 0)
+ break;
+ while(*x++);
+ }
+ }
+ qsort((char *)z0, nn, sizeof(char *), compare);
+ for(n = nn, z = z0; n > 0; n--)
+ fprintf(f, "%s\n", *z++);
+ free((char *)z0);
+ done:
+ clf(&f, to, 1);
+ do {
+ mb1 = mb->next;
+ free((char *)mb);
+ }
+ while(mb = mb1);
+ return 0;
+ }
+#endif
--- /dev/null
+#define SEOS 1
+#define SCOMMENT 2
+#define SLABEL 3
+#define SUNKNOWN 4
+#define SHOLLERITH 5
+#define SICON 6
+#define SRCON 7
+#define SDCON 8
+#define SBITCON 9
+#define SOCTCON 10
+#define SHEXCON 11
+#define STRUE 12
+#define SFALSE 13
+#define SNAME 14
+#define SNAMEEQ 15
+#define SFIELD 16
+#define SSCALE 17
+#define SINCLUDE 18
+#define SLET 19
+#define SASSIGN 20
+#define SAUTOMATIC 21
+#define SBACKSPACE 22
+#define SBLOCK 23
+#define SCALL 24
+#define SCHARACTER 25
+#define SCLOSE 26
+#define SCOMMON 27
+#define SCOMPLEX 28
+#define SCONTINUE 29
+#define SDATA 30
+#define SDCOMPLEX 31
+#define SDIMENSION 32
+#define SDO 33
+#define SDOUBLE 34
+#define SELSE 35
+#define SELSEIF 36
+#define SEND 37
+#define SENDFILE 38
+#define SENDIF 39
+#define SENTRY 40
+#define SEQUIV 41
+#define SEXTERNAL 42
+#define SFORMAT 43
+#define SFUNCTION 44
+#define SGOTO 45
+#define SASGOTO 46
+#define SCOMPGOTO 47
+#define SARITHIF 48
+#define SLOGIF 49
+#define SIMPLICIT 50
+#define SINQUIRE 51
+#define SINTEGER 52
+#define SINTRINSIC 53
+#define SLOGICAL 54
+#define SNAMELIST 55
+#define SOPEN 56
+#define SPARAM 57
+#define SPAUSE 58
+#define SPRINT 59
+#define SPROGRAM 60
+#define SPUNCH 61
+#define SREAD 62
+#define SREAL 63
+#define SRETURN 64
+#define SREWIND 65
+#define SSAVE 66
+#define SSTATIC 67
+#define SSTOP 68
+#define SSUBROUTINE 69
+#define STHEN 70
+#define STO 71
+#define SUNDEFINED 72
+#define SWRITE 73
+#define SLPAR 74
+#define SRPAR 75
+#define SEQUALS 76
+#define SCOLON 77
+#define SCOMMA 78
+#define SCURRENCY 79
+#define SPLUS 80
+#define SMINUS 81
+#define SSTAR 82
+#define SSLASH 83
+#define SPOWER 84
+#define SCONCAT 85
+#define SAND 86
+#define SOR 87
+#define SNEQV 88
+#define SEQV 89
+#define SNOT 90
+#define SEQ 91
+#define SLT 92
+#define SGT 93
+#define SLE 94
+#define SGE 95
+#define SNE 96
+#define SENDDO 97
+#define SWHILE 98
+#define SSLASHD 99
--- /dev/null
+SEOS
+SCOMMENT
+SLABEL
+SUNKNOWN
+SHOLLERITH
+SICON
+SRCON
+SDCON
+SBITCON
+SOCTCON
+SHEXCON
+STRUE
+SFALSE
+SNAME
+SNAMEEQ
+SFIELD
+SSCALE
+SINCLUDE
+SLET
+SASSIGN
+SAUTOMATIC
+SBACKSPACE
+SBLOCK
+SCALL
+SCHARACTER
+SCLOSE
+SCOMMON
+SCOMPLEX
+SCONTINUE
+SDATA
+SDCOMPLEX
+SDIMENSION
+SDO
+SDOUBLE
+SELSE
+SELSEIF
+SEND
+SENDFILE
+SENDIF
+SENTRY
+SEQUIV
+SEXTERNAL
+SFORMAT
+SFUNCTION
+SGOTO
+SASGOTO
+SCOMPGOTO
+SARITHIF
+SLOGIF
+SIMPLICIT
+SINQUIRE
+SINTEGER
+SINTRINSIC
+SLOGICAL
+SNAMELIST
+SOPEN
+SPARAM
+SPAUSE
+SPRINT
+SPROGRAM
+SPUNCH
+SREAD
+SREAL
+SRETURN
+SREWIND
+SSAVE
+SSTATIC
+SSTOP
+SSUBROUTINE
+STHEN
+STO
+SUNDEFINED
+SWRITE
+SLPAR
+SRPAR
+SEQUALS
+SCOLON
+SCOMMA
+SCURRENCY
+SPLUS
+SMINUS
+SSTAR
+SSLASH
+SPOWER
+SCONCAT
+SAND
+SOR
+SNEQV
+SEQV
+SNOT
+SEQ
+SLT
+SGT
+SLE
+SGE
+SNE
+SENDDO
+SWHILE
+SSLASHD
--- /dev/null
+#include <signal.h>
+#ifndef SIGHUP
+#define SIGHUP 1 /* hangup */
+#endif
+#ifndef SIGQUIT
+#define SIGQUIT 3 /* quit */
+#endif
--- /dev/null
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h"
+
+int regnum[] = {
+ 11, 10, 9, 8, 7, 6 };
+
+/* Put out a constant integer */
+
+prconi(fp, n)
+FILEP fp;
+ftnint n;
+{
+ fprintf(fp, "\t%ld\n", n);
+}
+
+
+
+/* Put out a constant address */
+
+prcona(fp, a)
+FILEP fp;
+ftnint a;
+{
+ fprintf(fp, "\tL%ld\n", a);
+}
+
+
+
+prconr(fp, x, k)
+ FILEP fp;
+ int k;
+ Constp x;
+{
+ char *x0, *x1;
+ char cdsbuf0[64], cdsbuf1[64];
+
+ if (k > 1) {
+ if (x->vstg) {
+ x0 = x->Const.cds[0];
+ x1 = x->Const.cds[1];
+ }
+ else {
+ x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
+ x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
+ }
+ fprintf(fp, "\t%s %s\n", x0, x1);
+ }
+ else
+ fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
+ : cds(dtos(x->Const.cd[0]), cdsbuf0));
+}
+
+
+char *memname(stg, mem)
+ int stg;
+ long mem;
+{
+ static char s[20];
+
+ switch(stg)
+ {
+ case STGCOMMON:
+ case STGEXT:
+ sprintf(s, "_%s", extsymtab[mem].cextname);
+ break;
+
+ case STGBSS:
+ case STGINIT:
+ sprintf(s, "v.%ld", mem);
+ break;
+
+ case STGCONST:
+ sprintf(s, "L%ld", mem);
+ break;
+
+ case STGEQUIV:
+ sprintf(s, "q.%ld", mem+eqvstart);
+ break;
+
+ default:
+ badstg("memname", stg);
+ }
+ return(s);
+}
+
+/* make_int_expr -- takes an arbitrary expression, and replaces all
+ occurrences of arguments with indirection */
+
+expptr make_int_expr (e)
+expptr e;
+{
+ if (e != ENULL)
+ switch (e -> tag) {
+ case TADDR:
+ if (e -> addrblock.vstg == STGARG)
+ e = mkexpr (OPWHATSIN, e, ENULL);
+ break;
+ case TEXPR:
+ e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
+ e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
+ break;
+ default:
+ break;
+ } /* switch */
+
+ return e;
+} /* make_int_expr */
+
+
+
+/* prune_left_conv -- used in prolog() to strip type cast away from
+ left-hand side of parameter adjustments. This is necessary to avoid
+ error messages from cktype() */
+
+expptr prune_left_conv (e)
+expptr e;
+{
+ struct Exprblock *leftp;
+
+ if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
+ e -> exprblock.leftp -> tag == TEXPR) {
+ leftp = &(e -> exprblock.leftp -> exprblock);
+ if (leftp -> opcode == OPCONV) {
+ e -> exprblock.leftp = leftp -> leftp;
+ free ((charptr) leftp);
+ }
+ }
+
+ return e;
+} /* prune_left_conv */
+
+
+ static int wrote_comment;
+ static FILE *comment_file;
+
+ static void
+write_comment()
+{
+ if (!wrote_comment) {
+ wrote_comment = 1;
+ nice_printf (comment_file, "/* Parameter adjustments */\n");
+ }
+ }
+
+ static int *
+count_args()
+{
+ register int *ac;
+ register chainp cp;
+ register struct Entrypoint *ep;
+ register Namep q;
+
+ ac = (int *)ckalloc(nallargs*sizeof(int));
+
+ for(ep = entries; ep; ep = ep->entnextp)
+ for(cp = ep->arglist; cp; cp = cp->nextp)
+ if (q = (Namep)cp->datap)
+ ac[q->argno]++;
+ return ac;
+ }
+
+prolog(outfile, p)
+ FILE *outfile;
+ register chainp p;
+{
+ int addif, addif0, i, nd, size;
+ int *ac;
+ register Namep q;
+ register struct Dimblock *dp;
+
+ if(procclass == CLBLOCK)
+ return;
+ wrote_comment = 0;
+ comment_file = outfile;
+ ac = 0;
+
+/* Compute the base addresses and offsets for the array parameters, and
+ assign these values to local variables */
+
+ addif = addif0 = nentry > 1;
+ for(; p ; p = p->nextp)
+ {
+ q = (Namep) p->datap;
+ if(dp = q->vdim) /* if this param is an array ... */
+ {
+ expptr Q, expr;
+
+ /* See whether to protect the following with an if. */
+ /* This only happens when there are multiple entries. */
+
+ nd = dp->ndim - 1;
+ if (addif0) {
+ if (!ac)
+ ac = count_args();
+ if (ac[q->argno] == nentry)
+ addif = 0;
+ else if (dp->basexpr
+ || dp->baseoffset->constblock.Const.ci)
+ addif = 1;
+ else for(addif = i = 0; i <= nd; i++)
+ if (dp->dims[i].dimexpr
+ && (i < nd || !q->vlastdim)) {
+ addif = 1;
+ break;
+ }
+ if (addif) {
+ write_comment();
+ nice_printf(outfile, "if (%s) {\n", /*}*/
+ q->cvarname);
+ next_tab(outfile);
+ }
+ }
+ for(i = 0 ; i <= nd; ++i)
+
+/* Store the variable length of each dimension (which is fixed upon
+ runtime procedure entry) into a local variable */
+
+ if ((Q = dp->dims[i].dimexpr)
+ && (i < nd || !q->vlastdim)) {
+ expr = (expptr)cpexpr(Q);
+ write_comment();
+ out_and_free_statement (outfile, mkexpr (OPASSIGN,
+ fixtype(cpexpr(dp->dims[i].dimsize)), expr));
+ } /* if dp -> dims[i].dimexpr */
+
+/* size will equal the size of a single element, or -1 if the type is
+ variable length character type */
+
+ size = typesize[ q->vtype ];
+ if(q->vtype == TYCHAR)
+ if( ISICON(q->vleng) )
+ size *= q->vleng->constblock.Const.ci;
+ else
+ size = -1;
+
+ /* Fudge the argument pointers for arrays so subscripts
+ * are 0-based. Not done if array bounds are being checked.
+ */
+ if(dp->basexpr) {
+
+/* Compute the base offset for this procedure */
+
+ write_comment();
+ out_and_free_statement (outfile, mkexpr (OPASSIGN,
+ cpexpr(fixtype(dp->baseoffset)),
+ cpexpr(fixtype(dp->basexpr))));
+ } /* if dp -> basexpr */
+
+ if(! checksubs) {
+ if(dp->basexpr) {
+ expptr tp;
+
+/* If the base of this array has a variable adjustment ... */
+
+ tp = (expptr) cpexpr (dp -> baseoffset);
+ if(size < 0 || q -> vtype == TYCHAR)
+ tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
+
+ write_comment();
+ tp = mkexpr (OPMINUSEQ,
+ mkconv (TYADDR, (expptr)p->datap),
+ mkconv(TYINT, fixtype
+ (fixtype (tp))));
+/* Avoid type clash by removing the type conversion */
+ tp = prune_left_conv (tp);
+ out_and_free_statement (outfile, tp);
+ } else if(dp->baseoffset->constblock.Const.ci != 0) {
+
+/* if the base of this array has a nonzero constant adjustment ... */
+
+ expptr tp;
+
+ write_comment();
+ if(size > 0 && q -> vtype != TYCHAR) {
+ tp = prune_left_conv (mkexpr (OPMINUSEQ,
+ mkconv (TYADDR, (expptr)p->datap),
+ mkconv (TYINT, fixtype
+ (cpexpr (dp->baseoffset)))));
+ out_and_free_statement (outfile, tp);
+ } else {
+ tp = prune_left_conv (mkexpr (OPMINUSEQ,
+ mkconv (TYADDR, (expptr)p->datap),
+ mkconv (TYINT, fixtype
+ (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
+ cpexpr (q -> vleng))))));
+ out_and_free_statement (outfile, tp);
+ } /* else */
+ } /* if dp -> baseoffset -> const */
+ } /* if !checksubs */
+
+ if (addif) {
+ nice_printf(outfile, /*{*/ "}\n");
+ prev_tab(outfile);
+ }
+ }
+ }
+ if (wrote_comment)
+ nice_printf (outfile, "\n/* Function Body */\n");
+ if (ac)
+ free((char *)ac);
+} /* prolog */
--- /dev/null
+char F2C_version[] = "26 February 1990 17:38:00";
+char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 26 February 1990 17:38:00\n";
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+=======================================================================
+*/
+
+#include "glodefs.h"
+
+
+#ifndef NO_PROTOTYPES
+
+static void rsnuse(argnr);
+static void ptnuse(argnr);
+
+#else
+
+static void rsnuse();
+static void ptnuse();
+
+#endif
+
+
+static void rsnuse(n) argnr n;{
+
+ /* if no next use - replace by 'nop' and exit to 55 */
+
+ qaddr0 nextuse ;
+ int notrick ;
+ quadruple * curr ; /* gsg for PASCAL WITH translation */
+
+
+ notrick = ipmem[ tuple[ qcurr ].arg[ n ] ] ;
+/* with tuple[ qcurr ] do begin */
+ { curr = tuple + qcurr ; /* gsg PASCAL WITH translation */
+
+ nextuse = ipmem[ (curr->arg)[ n ] + 2 ] ;
+ (curr->nxtuse)[ n ] = nextuse ;
+ if ( (nextuse == 0) && (! slive(notrick)) )
+ {
+ if ((curr->opcode) > 5) /* #lslopen */
+ {
+ (curr->opcode) = 195 ;
+ nouse = TRUE ;
+ }
+ }
+ else
+ { ipmem[ (curr->arg)[ n ] + 2 ] = 0 ;
+ if (ctpoint < nextuse)
+ { /* set slocal */
+ putslocal(TRUE, notrick) ;
+ ipmem[ (curr->arg)[ n ] ] = notrick ;
+ }
+ }
+ } /* with */
+ } /* rsnuse */
+
+
+
+static void ptnuse(n) argnr n;{
+ qaddr0 nextuse ;
+ int notrick ;
+ quadruple * curr ; /* gsg for PASCAL WITH translation */
+
+/* with tuple[ qcurr ] do */
+ { curr = tuple + qcurr ; /* gsg PASCAL WITH translation */
+ nextuse = ipmem[ (curr->arg)[ n ] + 2 ] ;
+ ipmem[ (curr->arg)[ n ] + 2 ] = qcurr ;
+ (curr->nxtuse)[ n ] = nextuse ;
+ if (ctpoint < nextuse)
+ { /* set slocal */
+ notrick = ipmem[ (curr->arg)[ n ] ] ;
+ putslocal(TRUE,notrick) ;
+ ipmem[ (curr->arg)[ n ] ] = notrick ;
+ }
+ } /* with */
+} /* ptnuse */
+
+
+void back()
+
+ /* SCANS DOWN THE QUADRUPLES TABLE TO ESTABLISH 'NEXT USE' INFORMATION */
+ /* OPERATIONS YIELDING NOT REFERENCED RESULTS ARE REPLACED BY 'NOP'==195*/
+ /* IF VALUE IS USED AFTER CONTROL TRANSMISSION, THE ATTRIBUTE 'SLOCAL' */
+ /* IS SET. */
+
+/* LABEL 55 ; */ /* EXIST FROM RSNUSE IF NO NEXT USE */
+
+ { quadruple * curr ; /* gsg for PASCAL WITH translation */
+
+
+ /* Back */
+
+ ctpoint = qlast + 1 ;
+ qcurr = qlast ;
+ /* FOR QCURR = QLAST DOWNTO 1 */
+ while (qcurr > 0) /* DO WITH TUPLE [ QCURR ] DO */
+ { curr = tuple + qcurr ; /* PASCAL WITH translation */
+ nouse = FALSE ;
+ switch ( opdescr[ curr->opcode ] )
+ { case 0 :
+ case 1 : break ;
+
+ case 2 :
+ case 3 :
+ case 4 : ptnuse(1) ;
+ break ;
+
+ case 5 :
+ case 6 : ptnuse(1) ;
+ ptnuse(2) ;
+ if ( curr->opcode <= 160 )
+ ctpoint = qcurr ;
+ break ;
+
+ case 7 : ptnuse(1) ;
+ ptnuse(2) ;
+ ptnuse(3) ;
+ break ;
+
+ case 8 :
+ case 9 :
+ case 10 : rsnuse(1) ;
+ break ;
+
+ case 11 :
+ case 12 : rsnuse(1) ;
+ if ( nouse )
+ goto label55 ;
+ ptnuse(2) ;
+ break ;
+
+ case 13 : rsnuse(1) ;
+ if ( nouse )
+ goto label55 ;
+ ptnuse(2) ;
+ ptnuse(3) ;
+ break ;
+
+ case 14 :
+ case 15 : rsnuse(1) ;
+ if ( nouse )
+ goto label55 ;
+ rsnuse(2) ;
+ if ( nouse )
+ goto label55 ;
+ if ( curr->opcode > 3 )
+ ptnuse(3) ;
+ break ;
+
+ } /* switch */
+ label55 : ;
+ qcurr-- ;
+ } /* while */
+ } /* back */
+
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include <stdio.h>
+#include "glodefs.h"
+
+
+#ifndef NO_PROTOTYPES
+
+static long hash_search(char *);
+static int ord(char);
+
+#else
+
+static long hash_search();
+static int ord();
+
+#endif
+
+
+
+/* ===================== for debugger ======================== */
+/* files organization : */
+/* fil21 ( .DEB ) : */
+/* hash(maxhash), */
+/* idict(maxidict), ind, prot(ind) */
+/* dfile ( .DCD ) : */
+/* hash(maxhash), */
+/* idict(maxidict), protbreakl, ind, prot(ind) */
+
+#define maxhash 8000
+#define maxidict 500
+
+static int idict[maxidict]; /* dictionary of prototypes */
+static int *prot; /* array of prototypes */
+static int ind; /* last used in PROT */
+
+void db3(){
+ /* put dispnr and offset into prototypes */
+ int i=0,j,pr,prz,el;
+
+ while( i < maxidict ){
+
+ if( idict[i] != 0 ){
+
+ /* pr - address of zero word of the prototype */
+ pr = idict[i];
+ /* dispnr */
+ prot[pr+3] = i;
+ /* hash table of prototype */
+ for( j = pr+5 ; j <= pr+12 ; j++){
+
+ el = prot[j];
+ prz = prot[el];
+ /* el - address of zero word of list element */
+ while( prz != -100 ){
+
+ if( prot[el+1] % 8 < 4 ){ /* not not taken */
+
+ prz = prot[el+2];
+ /* prz - address of debugger protype */
+ if( prz < -15 ){ /* variable or constant */
+
+ prz = -prz;
+ if( prot[prz] == 5 ) /* variable */
+ prot[prz+3] = ipmem[prot[prz+3] - 2];
+ }
+ }
+ el = el+3;
+ prz = prot[el]; /* next element */
+ } /* while */
+ } /* for */
+ }
+ i++;
+ } /* while */
+}
+
+long hash[8000];
+
+void ts3( fname ) char *fname; {
+
+ /* wpisuje dispnr i offset do prototypow debuggera */
+ /* czyta prototypy z pliku fil21, pisze na dfile */
+
+ FILE *fil21; /* input - prototypes from TS2 */
+
+ char fnameaux[30];
+ long position;
+
+ strcpy( fnameaux, fname );
+ fil21 = fopen( strcat( fnameaux, ".deb" ) , "rw" );
+ fseek( fil21, maxhash * sizeof(int) ,0 );
+ fread( idict, sizeof(*idict), maxidict, fil21 );
+ fread( &ind, sizeof(ind), 1, fil21 );
+ /* reading PROT */
+ position = ftell( fil21 );
+ prot=(int *)calloc(ind+1,sizeof(int));
+ fread( prot+1, sizeof(int), ind*4, fil21 );
+ /* changing prototypes */
+ db3();
+ /* writing PROT */
+ fseek( fil21, position, 0 );
+ fwrite( prot+1, sizeof(int), ind*4, fil21 );
+fseek( fil21, 0L, 0);
+fread( hash, 8000, sizeof(long), fil21 );
+printf("searching do for begin aaa ala i nikldksjkehtr");getchar();
+printf("#%ld",hash_search("do"));getchar();
+printf("#%ld",hash_search("for"));getchar();
+printf("#%ld",hash_search("begin"));getchar();
+printf("#%ld",hash_search("aaa"));getchar();
+printf("#%ld",hash_search("ala"));getchar();
+printf("#%ld",hash_search("i"));getchar();
+printf("#%ld",hash_search("niksehfkertk"));getchar();
+ fclose( fil21 );
+ free(prot);
+}
+
+/* ======================================================== */
+
+#define BYTE 64
+#define M 1009
+
+static long hash_search (str) char *str;{
+
+ long name[21];
+ int result;
+ int i=0;
+ int H; /* do poszukiwan po hash */
+ int N; /* do przechodzenia po name */
+
+ /* pakowanie nazwy do poszukiwan w hash */
+
+ for( i=0; i<20 && *str!='\0'; i++ )
+ if( i % 2 == 0 ) name[ i/2 ] = ord( *( str++ ) );
+ else name[ i/2 ] = name[ i/2 ] * BYTE + ord( *( str++ ) );
+
+ name[ (i+1)/2 ]= -1 ;
+ i= i/2 + i%2;
+ H = ( name[0] % M ) * 2;
+
+ for(;;){
+printf("comparing name H=%d,name[0]=%d",H,name[0]);getchar();
+
+ N=0;
+ result = H;
+
+ while( hash[ H+1 ] <0 && hash[ H ] == name[ N ] ){
+printf("Nth pare OK %d",N);getchar();
+
+ H = - hash[ H+1 ] - 1;
+ N++;
+
+ }
+
+ if( hash[ H ] != name[ N ] ){
+
+ while( hash[ H+1 ] <0 ) H = - hash[ H+1 ] - 1;
+ if( hash[ H+1 ] == 0 ) return -1;
+ H = hash[ H+1 ] - 1;
+ continue;
+
+ }
+
+ if( name[ N+1 ] == -1 ) return result;
+ if( hash[ H+1 ] == 0 ) return -1;
+
+ H = hash[ H+1 ] - 1;
+
+ }
+
+}
+
+
+static int ord_tab[]={
+63,63,63,63,63,63,63,63,36,63,63,63,37,
+36,36,36,36,36,36,36,36,36,36,36,36,36,36,36,36,36,36,36,
+63,43,63,63,63,63,44,52,53,48,39,
+42,40,38,41,0,1,2,3,4,5,6,7,8,9,47,45,50,49,51,63,63,
+10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,
+30,31,32,33,34,35,63,63,63,63,46,
+63,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,
+30,31,32,33,34,35
+};
+
+static int ord(c) char c;{
+ if( c>122 ) return 63;
+ return ord_tab[ c-1 ];
+}
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "glodefs.h"
+
+
+void gen()
+{ address aftraise ;
+ addrmode md ;
+ address t1, t2 ;
+ b32b16c trick ;
+ int i ;
+ quadruple * curr1 ;
+ args_struct * curr2 ;
+ int l ;
+
+ for (qcurr = 1; qcurr <= qlast; qcurr++)
+ { curr1 = tuple + qcurr ; /* gsg for PASCAL WITH translation */
+ /* gsg WITH beginning */
+ defaultargs();
+ switch (curr1->opcode) {
+
+
+/*CBC... Fixed bug - added calls of ARGUMENT to release global temporary
+ variables in case of no further references to them */
+
+case 1 /* #LOPENRC */:
+ forceprot(3);
+ emit();
+ argument(1);
+ argument(2);
+ break;
+
+case 2 /* #LBACKADDR */:
+ emit();
+ argument(1);
+ argument(2);
+ break;
+
+/*...CBC*/
+case 3 /* #LRAISE */:
+ emit();
+ aftraise = fre;
+ fre++; /* this cell is to be filled further */
+ break;
+
+case 11 :
+ curr1->opcode = 60 ; /* #limove */
+ force(2,IMMEDIATE,(address)0,(address)0);
+ emit() ;
+ break;
+case 12 :
+ curr1->opcode= 61 ; /* #lvmove */
+ force(2,GLOBAL,realbase /* none */,(address)0);
+ emit() ;
+ break;
+
+case 13 :
+ curr1->opcode= 60 ; /* #limove */
+ force(2,GLOBAL,temporary,(address)0);
+ emit() ;
+ break;
+
+ /* M [ TEMPORARY ] STANDS FOR ANY REGISTER */
+case 15 : /* #LTHIS */
+case 20 : /* #LVIRTDISPL */
+
+ forceprot(2);
+ emit() ;
+ break;
+
+
+ case 16 :
+ curr1->opcode= 60 ; /* #limove */
+ forceprot(2);
+ args[ 2 ].mode=IMMEDIATE;
+ emit() ;
+ break ;
+
+case 21 /* #LSTATTYPE */:
+ args[ 3 ].off1= - ipmem[ args[ 3 ].off1 + 2 ];
+ emit() ;
+ break;
+
+case 22 : /* FETCH FORMAL TYPE THROUGH THE DISPLAY */
+ curr1->opcode= 61 ; /* #lvmove */
+ force(2,DOTACCESS, ipmem[ curr1->arg[ 3 ]-2 ] /*offset*/,
+ ipmem[ curr1->arg[ 3 ]-1 ] /* +display */ /*prot*/);
+ args[ 3 ].mode=NOARGUMENT;
+ emit() ;
+ break;
+
+
+case 23 :
+ notrick =ipmem[ curr1->arg[ 1 ] ];
+ switch(sap(notrick))
+ {
+ case APINT : break;
+ case APVIRT : curr1->opcode = 25 ; /* #lvparout */
+ break;
+ case APREAL : curr1->opcode=24 ; /* #lrparout */
+ break;
+ } /* switch */
+ emit() ;
+ break;
+
+case 29 :
+case 30 :
+case 133 : generror(NOTIMPL);
+ break;
+
+case 32 :
+ curr1->opcode = 113 ; /* #liadd */
+ force(3,IMMEDIATE,(address)1,(address)0);
+ emit() ;
+ break ;
+
+case 37 :
+case 39 :
+ curr1->opcode= 113 ; /* #liadd */
+ args[ 3 ].mode=IMMEDIATE;
+ emit() ;
+ break ;
+
+case 38 : /* MOVE & SAVE */
+ notrick =ipmem[ curr1->arg[ 1 ] ] ;
+ switch(sap(notrick))
+ {
+ case APINT : curr1->opcode= 60 ; /* #limove */
+ break ;
+ case APREAL : curr1->opcode= 62 ; /* #lrmove */
+ break ;
+ case APVIRT : curr1->opcode= 61 ; /* #lvmove */
+ break ;
+ } /* switch */
+ emit();
+ break ;
+
+case 54 /* #LLOADT */:
+ forceprot(3);
+ emit();
+ m[ fre ]=ipmem[ curr1->arg[ 3 ]-2 ]; /* offset */
+ fre+=APINT;
+ break ;
+
+case 53 : /* SHIFT BY CONSTANT NUMBER OF POSITIONS */
+ curr1->opcode= 116 ; /* #lshift */
+ args[ 3 ].mode=IMMEDIATE;
+ emit();
+ break ;
+
+case 55 : /* #LIS */
+case 56 : /* #LIN */
+case 57 : /* #LQUA */
+
+ /*WITH ARGS[ 3 ] DO */
+ curr2 = args + 3 ;
+ curr2->off1 =
+ - ipmem[ curr2->off1 + 2 ];
+ /* ADDRESS OF TYPE DESCRIPTION */
+ emit() ;
+ break ;
+
+case 149 /* #LQUATEST */:
+
+ args[ 2 ].off1= - ipmem[ args[ 2 ].off1 + 2 ];
+ /* ADDRESS OF TYPE DESCRIPTION */
+ emit() ;
+ break ;
+
+case 60 /* #LIMOVE */:
+
+ notrick = ipmem[ curr1->arg[ 1 ] ];
+ switch (sap(notrick)) {
+ case APINT : break ;
+ case APREAL : curr1->opcode = 62 ; /* #LRMOVE */ break ;
+ case APVIRT : curr1->opcode = 61 ; /* #LVMOVE */ break ;
+ case APFMPROC : curr1->opcode = 63 ; /* #LFPMOVE */ break ;
+ } /* CASE */;
+ emit() ;
+ break ;
+
+ case 61 :
+ curr1->opcode= 60 ; /* #limove */
+ args[ 2 ].mode=INDIRECT;
+ emit();
+ break ;
+
+ case 62 :
+ curr1->opcode= 61 ; /* #lvmove */
+ args[ 2 ].mode=INDIRECT;
+ emit();
+ break ;
+
+ case 63 :
+ curr1->opcode= 63 ; /* #lfpmove */
+ args[ 2 ].mode=INDIRECT;
+ emit();
+ break ;
+
+ case 64 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)2,(address)0);
+ emit() ;
+ break ;
+
+ case 65 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)3,(address)0);
+ emit() ;
+ break ;
+
+ case 66 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)4,(address)0);
+ emit() ;
+ break ;
+
+ case 67 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)5,(address)0);
+ emit() ;
+ break ;
+
+ case 68 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)6,(address)0);
+ emit() ;
+ break ;
+
+ case 69 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)7,(address)0);
+ emit() ;
+ break ;
+
+ case 70 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)8,(address)0);
+ emit() ;
+ break ;
+
+ case 71 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)9,(address)0);
+ emit() ;
+ break ;
+
+ case 72 :
+ curr1->opcode= 115 ; /* #limult */
+ force(3,IMMEDIATE,(address)10,(address)0);
+ emit() ;
+ break ;
+
+ case 73 :
+ curr1->opcode= 117 ; /* #lidive */
+ force(3,IMMEDIATE,(address)8,(address)0);
+ emit() ;
+ break ;
+
+ case 74 :
+ curr1->opcode= 117 ; /* #lidive */
+ force(3,IMMEDIATE,(address)4,(address)0);
+ emit() ;
+ break ;
+
+ case 75 :
+ curr1->opcode= 117 ; /* #lidive */
+ force(3,IMMEDIATE,(address)2,(address)0);
+ emit() ;
+ break ;
+
+ case 76 :
+ case 77 :
+ case 78 :
+ case 79 :
+ case 80 :
+ case 81 :
+
+ curr1->opcode = 106 + /* #liequal */(curr1->opcode-76);
+ force(3,IMMEDIATE,(address)0,(address)0);
+ emit() ;
+ break ;
+
+ case 84 :
+ curr1->opcode= 60 ; /* #limove */
+ args[ 2 ].mode=REMOTE; args[ 2 ].off2=args[ 2 ].off1; args[ 2 ].off1=ipmem[ curr1->arg[ 3 ]-2 ];
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ break ;
+
+ case 85 :
+ curr1->opcode= 61 ; /* #lvmove */
+ args[ 2 ].mode=REMOTE;
+ args[ 2 ].off2=args[ 2 ].off1;
+ args[ 2 ].off1=ipmem[ curr1->arg[ 3 ]-2 ];
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ break ;
+
+ case 86 :
+ curr1->opcode= 63 ; /* #lfpmove */
+ args[ 2 ].mode=REMOTE;
+ args[ 2 ].off2=args[ 2 ].off1;
+ args[ 2 ].off1=ipmem[ curr1->arg[ 3 ]-2 ];
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ break ;
+
+ case 88 :
+ case 89 :
+ case 90 :
+ case 91 :
+ case 92 :
+ case 93 :
+
+ curr1->opcode= 106 + /* #liequal */(curr1->opcode-88);
+ args[ 3 ].mode=IMMEDIATE;
+ emit() ;
+ break ;
+
+ case 94 :
+ case 95 :
+ case 96 :
+ case 97 :
+ case 98 :
+ case 99 :
+
+ curr1->opcode= 106 + /* #liequal */(curr1->opcode-94);
+ args[ 3 ].mode=IMMEDIATE;
+ emit() ;
+ break ;
+
+ case 137 :
+ curr1->opcode= 60 ; /* #limove */
+ force(1,REMOTE,ipmem[ curr1->arg[ 2 ]-2 ],args[ 1 ].off1);
+ force(2,IMMEDIATE,(address)0,(address)0);
+ emit();
+ break ;
+
+ case 138 :
+ curr1->opcode= 61 ; /* #lvmove */
+ force(1,REMOTE,ipmem[ curr1->arg[ 2 ]-2 ],args[ 1 ].off1);
+ force(2,GLOBAL,realbase,(address)0); /* none */
+ emit();
+ break ;
+
+ case 139 : if (curr1->arg[2] == -45) { /* file address */
+ curr1->opcode = 61;
+ args[2] = args[1];
+ force(1,GLOBAL,(address)CURRFILE,(address)0);
+ emit() ;
+ } else /*dsw*/
+ {
+ curr1->opcode= 60 ; /* #limove */
+ args[ 2 ]=args[ 1 ];
+ force(1,GLOBAL,temporary,(address)0); emit() ;
+ }
+ break ;
+
+ case 140 :
+ case 158 :
+ case 176 :
+ case 179 :
+ case 195 : break ;
+
+ case 141 :
+ notrick =ipmem[ curr1->arg[ 1 ] ];
+ locrelease(args[ 1 ].off1, sap(notrick));
+ break ;
+
+ case 145 :
+ notrick =ipmem[ curr1->arg[ 1 ] ];
+ switch (sap(notrick)) {
+ case APINT : break ;
+ case APVIRT : curr1->opcode= 147 ; /* #lvparinp */ break ;
+ case APREAL : curr1->opcode=148 ; /* #lrparinp */ break ;
+ } /* case */
+ emit();
+ break ;
+
+ case 147 :
+ curr1->opcode= 60 ; /* #limove */
+ args[ 1 ].mode=INDIRECT;
+ force(2,IMMEDIATE,(address)0,(address)0);
+ emit();
+ break ;
+
+ case 148 :
+ curr1->opcode= 61 ; /* #lvmove */
+ args[ 1 ].mode=INDIRECT;
+ args[ 2 ].mode=GLOBAL;
+ args[ 2 ].off1=realbase; /* none */
+ emit();
+ break ;
+
+ case 150 /* #lstype */:
+ args[ 2 ].off1= - ipmem[ args[ 2 ].off1 + 2 ];
+ emit() ;
+ break ;
+
+ case 152 /* #liftrue */ :
+ case 151 /* #liffalse */ :
+ case 182 /* #ljump */:
+
+ emit();
+ fre -- ;
+ uselabel(m[ fre ]);
+ fre ++ ;
+ break ;
+
+ case 153 : /* kill after raise */
+ m[ aftraise ]= fre + base;
+ curr1->opcode= 143 ; /* #lkill */
+ emit();
+ break ;
+
+ case 161 :
+ curr1->opcode= 60 ; /* #limove */
+ args[ 1 ].mode=INDIRECT;
+ emit();
+ break ;
+
+ case 162 :
+ curr1->opcode= 61 ; /* #lvmove */
+ args[ 1 ].mode=INDIRECT;
+ emit();
+ break ;
+
+ case 163 :
+ curr1->opcode= 63 ; /* #lfpmove */
+ args[ 1 ].mode=INDIRECT;
+ emit() ;
+ break ;
+
+ case 164 :
+ curr1->opcode= 60 ; /* #limove */
+ args[ 1 ].mode=REMOTE;
+ args[ 1 ].off2=args[ 1 ].off1;
+ args[ 1 ].off1=ipmem[ curr1->arg[ 3 ]-2 ]; /* offset */
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ break ;
+
+ case 165 :
+ curr1->opcode= 61 ; /* #lvmove */
+ args[ 1 ].mode=REMOTE;
+ args[ 1 ].off2= args[ 1 ].off1;
+ args[ 1 ].off1=ipmem[ curr1->arg[ 3 ]-2 ]; /* offset */
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ break ;
+
+ case 166 :
+ curr1->opcode= 63 ; /* #lfpmove */
+ args[ 1 ].mode=REMOTE;
+ args[ 1 ].off2=args[ 1 ].off1;
+ args[ 1 ].off1=ipmem[ curr1->arg[ 3 ]-2 ]; /* offset */
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ break ;
+
+ case 174 : /* lastwill */
+ /* printf("fre = %d , base = %d\n", fre, base) ;*/
+ prototype[ unitt ]->lastwill = fre + base;
+ t1=locspace(APVIRT);
+ t2=locspace(APINT);
+ curr1->opcode=2; /* lbackaddr */
+ force(1, TEMPLOCAL, t1, (address)0);
+ force(2, TEMPLOCAL, t2, (address)0);
+ emit();
+ locrelease(t2, APINT);
+ curr1->opcode=146; /* lgkill */
+ force(1, TEMPLOCAL, t1, (address)0);
+ force(2, NOARGUMENT, (address)0, (address)0);
+ emit();
+ locrelease(t1, APVIRT);
+ break ;
+
+ case 175 :
+ curr1->opcode= 182 ; /* #ljump */
+ force(1,CONSTANT,
+ prototype[ ipmem[ curr1->arg[ 1 ]-1 ] ]->lastwill,(address)0);
+ emit();
+ break ;
+
+ case 178 : /* inner */
+ emit();
+
+#if SMALL || HUGE
+ ipmem[ ipunit ] = fre + base; /* ADDRESS OF AFTER INNER STATEMENT */
+#elif LARGE
+ trick.t.b32 = fre+base;
+ ipmem[ ipunit ] = trick.f.r16;
+ ipmem[ ipunit+1 ] = trick.f.l16;
+#endif
+
+ mapdscr[ unitt ] = (tmpmapdscr *) new(mapdscr[ unitt ]);
+/* mapdscr[ unitt ]->map = ltmpmap ; */
+ for(l = 0; l <= MAXLOCTEMP; l++)
+ mapdscr[unitt]->map[l] = ltmpmap[l] ;
+ break ;
+
+ case 181 : deflabel(curr1->arg[ 1 ]);
+ break ;
+
+ case 183 : /* JUMP AFTER INNER */
+ curr1->opcode= 182 ; /* #LJUMP */
+
+#if SMALL || HUGE
+ args[ 1 ].off1 = ipmem[ curr1->arg[ 1 ] ];
+#elif LARGE
+ trick.f.r16 = ipmem[ curr1->arg[1] ];
+ trick.f.l16 = ipmem[ curr1->arg[1]+1 ];
+ args[ 1 ].off1 = trick.t.b32;
+#endif
+
+ emit();
+ break ;
+
+ case 184 : begunit(curr1->arg[ 1 ]);
+ break ;
+
+ case 185 : endunit() ;
+ break ;
+
+ case 186 : /* BLOCK */
+ /* EXTRA : 186,174,176 */
+ args[ 1 ].off1=ipmem[ curr1->arg[ 1 ]-1 ];
+ emit(); /* open object for block */
+ curr1->opcode=174;
+ args[ 1 ].mode=NOARGUMENT;
+ emit(); /* TRANSMIT CONTROL */
+ curr1->opcode=176;
+ emit(); /* KILL BLOCK OBJECT */
+ break ;
+
+ case 189 : /* CASE */
+ curr1->opcode=195;
+ args[ 3 ].mode=NOARGUMENT;
+ emit();
+ fre -- ;
+ uselabel(curr1->arg[ 2 ]); /* ADDRESS OF 'CASE' DESCRIPTION */
+ fre ++ ;
+ break ;
+
+ case 190 : esac() ;
+ break ;
+
+ case 223 : /* #LENABLE */
+ case 224 : /* #LDISABLE */
+ case 225 : /* #LACCEPT1 */
+ case 227 : /* #LBACKRPC */
+
+ forceconst(1);
+ emit();
+ if (fre+ curr1->arg[ 1 ] >= firstlabel)
+ generror(MEMOVF);
+ for (i=1; i <= curr1->arg[ 1 ]; i++)
+ m[ fre + i - 1 ] = proclist[ i ];
+ fre += curr1->arg[ 1 ];
+ break ;
+
+/*CBC... */
+/* 2 ,*/ /* #LBACKADDR */
+/*...CBC*/
+ case 31 : /* #LSIGN */
+ case 4 : /* #LOPEN */
+ case 5 : /* #LSLOPEN */
+ case 33 : /* #LLOWER */
+ case 34 :
+ case 35 : /* #LUPPER */
+ case 36 :
+ case 41 : /* #LCOPY */
+ case 42 : /* #LNOT */
+ case 43 : /* #LRCVAVIRT */
+ case 44 : /* #LVIRTDOT */
+ case 45 :
+ case 46 : /* #LADDRPH */
+ case 47 : /* #LADDRPH2 */
+ case 48 : /* #LIABS */
+ case 49 : /* #LINEG */
+ case 50 : /* #LRABS */
+ case 51 : /* #LRNEG */
+ case 52 : /* #LPARAMADDR */
+ case 58 : /* #LIFIX */
+ case 59 : /* #LFLOAT */
+ case 40 : /* #LGETTYPE */
+ case 87 : /* #LMDFTYPE */
+ case 82 : /* # LEQNONE */
+ case 83 : /* #LNENONE */
+ case 100 : /* #LOR */
+ case 101 : /* #LAND */
+ case 131 : /* #LXOR */
+ case 116 : /* #LSHIFT */
+ case 102 : /* #LARRAY */
+ case 103 :
+ case 104 :
+ case 105 : /* #LFARRAY */
+ case 112 : /* #LCOMBINE */
+ case 106 : /* #LIEQUAL */
+ case 107 : /* #LINEQUAL */
+ case 108 : /* #LILT */
+ case 109 : /* #LILE */
+ case 110 : /* #LIGT */
+ case 111 : /* #LIGE */
+ case 113 : /* #LIADD */
+ case 114 : /* #LISUB */
+ case 115 : /* #LIMULT */
+ case 117 : /* #LIDIVE */
+ case 118 : /* #LIMODE */
+ case 119 : /* #LRADD */
+ case 120 : /* #LRSUB */
+ case 121 : /* #LRMULT */
+ case 122 : /* #LRDIVE */
+ case 125 : /* #LREQ */
+ case 126 : /* #LRNE */
+ case 127 : /* #LRLT */
+ case 128 : /* #LRLE */
+ case 129 : /* #LRGT */
+ case 130 : /* #LRGE */
+ case 123 : /* #LEQREF */
+ case 124 : /* #LNEREF */
+ case 132 : /* #LCALLPROCSTAND */
+ case 143 : /* #LKILL */
+ case 144 : /* #LHEADS */
+ case 146 : /* #LGKILL */
+ case 159 : /* #LGO */
+ case 160 : /* #LGOLOCAL */
+ case 170 : /* #LDTYPE */
+ case 172 : /* #LTERMINATE */
+ case 173 : /* #LWIND */
+ case 177 : /* #LTRACE */
+ case 180 : /* #LBACKHD */
+ case 191 : /* #LBACKBL */
+ case 193 : /* #LBACK */
+ case 194 : /* #LFIN */
+ case 192 : /* #LBACKPR */
+ case 220 : /* #LRESUME */ /*CBC*/
+ case 221 : /* #LSTOP */ /*CBC*/
+ case 222 : /* #LKILLTEMP */ /*CBC*/
+ case 226 : /* #LACCEPT2 */ /*CBC*/
+ case 228 : /* #LASKPROT */ /*CBC*/
+ case 240 : /* #LSTEP */ /*CDSW&BC*/
+ case 188 : /* #LATTACH */
+ case 187 : /* #LDETACH */
+ emit(); /* NO EXTRA TREATMENT */
+ break ;
+
+ } /* switch opcode */
+ } /* for */
+ } /* GEN */
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#if GEN
+#define word address
+#endif
+
+
+/* Appetites of values : */
+#define APINT 1 /* integer,boolean,string,char */
+#define APREAL sizeof(real)/sizeof(word) /* real */
+#define APVIRT 4 /* TO TELL APART A VIRTUAL ADDRESS */
+ /* (ANY REFERENCE TYPE) FROM ANY OTHER TYPE */
+#define APREF 2 /* ACTUAL SIZE OF REFERENCE TYPE */
+#define APFMTYPE 2 /* FORMAL TYPE VALUE */
+#define APFMPROC 3 /* FORMAL PROCEURE OR FUNCTION VALUE, = APREF+1*/
+#define APOPCODE (sizeof(extopcode)+sizeof(word)-1)/sizeof(word)
+
+
+typedef int bool;
+#define FALSE 0
+#define TRUE 1
+
+
+/* Values identifying types and formal parameters : */
+
+#define FORMFUNC 7 /* parameter "function" */
+#define FORMPROC 8 /* parameter "procedure" */
+#define FORMTYPE 9 /* parameter "type", also formal type */
+#define PARIN 11 /* parameter "input" */
+#define PAROUT 12 /* parameter "output" */
+#define PARINOUT 16 /* parameter "inout" */
+#define PUREPROCESS 13 /* type PROCESS */
+#define PURECOROUTINE 14 /* type COROUTINE */
+#define PRIMITIVETYPE 15 /* simple type */
+#define CLASSTYPE 17 /* class type */
+#define FILETYPE 18 /* file type */
+
+
+/* Values to identify kinds of array elements : */
+
+#define AINT -1 /* arrayof integer */
+#define AREAL -3 /* arrayof real */
+#define AVIRT -2 /* arrayof reference */
+#define APROCESS -4 /* process reference implemented as arrayof */
+#define FILEOBJECT -11 /* file object */
+#define SKILLED -99 /* killed object, only for compactification */
+
+
+#define DUMMY -1 /* dummy unit or prefix : SL for main block */
+#define MAINBLOCK 0 /* main block prototype number */
+#define MAXPROT 500 /* limit for the number of prototypes */
+
+
+/* L-code instruction addressing modes : */
+
+#define GLOBAL 0 /* M[ N ] */
+#define LOCAL 1 /* M[ c1+N ] */
+#define TEMPLOCAL 2 /* M[ c2+N ] */
+#define REMOTE 3 /* M[ M[ K ]+N ] */
+#define INDIRECT 4 /* M[ M[ N ] ] */
+#define IMMEDIATE 5 /* N */
+#define CONSTANT 6 /* M[ N ] */
+#define DOTACCESS 7 /* M[ M[ display+K ]+N ] */
+#define NOARGUMENT 8 /* ------ */
+
+
+/* Prototype kind : */
+
+#define CLASS 0
+#define RECORD 1
+#define COROUTINE 2
+#define PROCESS 3
+#define BLOCK 4
+#define PREFBLOCK 5
+#define FUNCTION 6
+#define PROCEDURE 7
+#define HANDLER 8
+
+#if GEN
+#define LRECORD RECORD
+#define LFUNCTION FUNCTION
+#define LPROCEDURE PROCEDURE
+#endif
+
+
+#if GEN
+typedef int protaddr ; /* mainblock..maxprot ; mainblock = 0; */
+ /* INDIRECT ADDRESS OF PROTOTYPE */
+typedef int dprotaddr ; /* PROTADDR + DUMMY */
+typedef int protkind ;
+#else
+#define protaddr int
+#define dprotaddr int
+#define protkind int
+#endif
+
+
+/* Prototype : */
+
+typedef struct {
+ dprotaddr slprototype ; /* PROTOTYPE OF SYNTACTIC FATHER */
+ /* OR DUMMY FOR THE MAIN BLOCK */
+ word codeaddr; /* address of code */
+ word appetite; /* object's total length */
+ word span; /* distance from beginning of object to */
+ /* temporary reference variables */
+ word reflist; /* beginning and length of table with */
+
+ int lthreflist; /* offsets of reference values in object; */
+ /* without SL, DL, CL and temporary values */
+ word parlist; /* beginning and length of table with */
+ int lthparlist; /* offsets of parameters */
+
+ word preflist; /* beginning and length of table with */
+ int lthpreflist; /* prototype numbers of prefix sequence */
+
+ word lastwill; /* lastwill code address */
+ word handlerlist; /* list of handlers, 0 if empty */
+ word virtlist; /* address of table for conversion: */
+ /* virtual number --> prototype */
+
+ /* only for processes : */
+ protaddr maskbase ; /* lowest procedure prototype number */
+ int masksize ; /* size of RPC mask for that process */
+
+ /* for procedures and functions */
+ int virtnumber; /* virtual number or -1 if not virtual */
+
+ /* for all : */
+ protkind kind ; /* kind of unit */
+
+ /* only for procedures, functions and processes : */
+ word pfdescr; /* address of table with parameters descr. addresses */
+
+ /* only for functions : */
+ int nrarray;
+ word finaltype; /* type of result */
+
+} protdescr,*pointprdsc;
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include "glodefs.h"
+
+#ifndef NO_PROTOTYPES
+
+static void fputaddr(FILE *,address);
+static int fgetint(FILE *);
+
+#else
+
+static void fputaddr();
+static int fgetint();
+
+#endif
+
+int wordswritten = 0 ;
+
+void setfiles(name) char *name;{
+ char work[80];
+
+ strcpy(work, name) ;
+ strcat(work, ".lcd") ;
+ lfile = fopen(work, "rb");
+ if(lfile == NULL)
+ { puts(strcat("Couldn't open file ", work)) ;
+ exit(8) ;
+ }
+ strcpy(work, name) ;
+ strcat(work, ".pcd") ;
+ pfile = fopen(work, "wb") ;
+
+ strcpy(work, name) ;
+ strcat(work, ".ccd") ;
+ cfile = fopen(work, "wb") ;
+ if(cfile == NULL)
+ {
+ printf("Couldn't open file %s for writing\n", work);
+ exit(8) ;
+ }
+} /* setfiles */
+
+
+
+int next(){
+ int i;
+
+ if(!fread((char *)&i,sizeof(i),1,lfile)){
+ printf("Unexpected EOF ! Aborting...\n");
+ exit(8);
+ }
+ return i;
+} /* next */
+
+static int fgetint(f) FILE * f;{
+ int c ;
+ fread((char *)&c, sizeof(int), 1, f) ;
+ return c ;
+}
+
+static void fputaddr(f,v) FILE *f; address v;{
+ fwrite((char *)&v, sizeof(address), 1, f);
+}
+
+ /* Buffered version - not finished
+ static address buf[BUFSIZE] ;
+ static address * bufp = buf;
+ static int n = 0;
+
+ if(n==BUFSIZE) */
+
+void putstrings()
+{
+ int cc, i, ch2 ;
+ int c1, c2, start, nr=1 ;
+
+ cc = fgetint(lfile); /* character count */
+
+ while (cc != ENDOFSTRINGS)
+ {
+ m[ fre ] = cc;
+ fre ++ ;
+ start=fre;
+
+ for (i = 1; i <= (cc / CHARSINAD + 1) ; i++ )
+ /* extra 0 byte after string */
+ {
+
+#if SMALL || HUGE
+ ch2 = fgetint(lfile) ;
+ m[ fre ] = ch2;
+#elif LARGE
+ c1 = fgetint(lfile) ;
+ c2 = fgetint(lfile) ;
+ m[ fre ] = ( (long)c1 ) | ( ((long)c2) << 16 ) ;
+#endif
+
+ fre++ ;
+ }
+
+#if (TALK >= 2)
+ if(fre!=start+1)
+ printf("string %d = %s\n", nr++, (char *)(&m[start]));
+#endif
+
+ cc = fgetint(lfile) ;
+ }
+ } /* putstrings */
+
+
+void initiate()
+ /* read ipmem and some variables from the blank common of the compiler */
+{
+ int tarr[302];
+#ifdef DUMP
+ int k;
+#endif
+ fread((char *)tarr, sizeof(int), 302, lfile) ;
+
+
+ lmem = tarr[278] ;
+ lpmem = tarr[279] ;
+ irecn = tarr[280] ;
+ nrint = tarr[285] ;
+ nrre = tarr[286] ;
+ nrbool = tarr[287] ;
+ nrchr = tarr[288] ;
+ nrcor = tarr[289] ;
+ nrproc = tarr[290] ;
+ nrtext = tarr[291] ;
+ nblus = tarr[296] ;
+ addrnone = tarr[299] ; /*cdsw&ail */
+
+#if (TALK >= 2)
+ printf("Initiate\n lmem = %d, lpmem = %d, irecn = %d\n",
+ lmem, lpmem, irecn);
+ printf(" nrint = %d\n", nrint);
+ printf(" nrre = %d\n", nrre );
+ printf(" nrbool= %d\n", nrbool);
+ printf(" nrchr = %d\n", nrchr);
+ printf(" nrcor = %d\n", nrcor);
+ printf(" nrproc= %d\n", nrproc);
+ printf(" nrtext= %d\n", nrtext);
+ printf(" nblus = %d\n", nblus);
+ printf(" addrnone = %d\n", addrnone);
+#endif
+
+ ipmem = (int *) calloc(lmem + 1, sizeof(int));
+ fread( (char *)(ipmem + 1), sizeof(int), irecn, lfile);
+
+#ifdef DUMP
+ for (k = 1; k <= irecn; k++)
+ {
+ printf("%8d",ipmem[k]);
+ if (k % 16 == 0) printf("\n");
+ }
+ exit(0);
+#endif
+
+ }
+
+
+void putreals()
+ /* WRITE REAL CONSTANTS TO MEMORY */
+{
+ int i ;
+ union
+ {
+ float r ;
+ struct { int int1, int2 ; } p;
+ } trick1 ;
+
+ union
+ {
+ real r ;
+ struct { address int1, int2 ; } p;
+ } trick2 ;
+
+ i = lpmem + 1 ;
+ while (i <= irecn)
+ {
+#ifdef HUGE
+#if (TALK >=2 )
+ printf("real %10d:%18f\n",i,*(float *)&(ipmem[i]));
+#endif
+ m[ fre++ ] = ipmem[ i++ ] ;
+#else
+ trick1.p.int1 = ipmem[ i++ ] ;
+ trick1.p.int2 = ipmem[ i++ ] ;
+ trick2.r = trick1.r;
+#if (TALK >=2 )
+ printf("real %10d:%18f\n",i,trick1.r);
+#endif
+ m[ fre++ ] = trick2.p.int1;
+ m[ fre++ ] = trick2.p.int2;
+#endif
+ }
+}/* putreals */
+
+
+
+
+void generror(err)
+errtype err;
+{
+ switch (err)
+ {
+ case TMPROT : printf(" TOO MANY PROTOTYPES");
+ break ;
+
+ case TLDESCR : printf(" DESCRIPTIONS TOO LONG");
+ break ;
+
+ case MEMOVF : printf(" MEMORY OVERFLOW ");
+ break ;
+
+ case TMTEMP : printf(" TOO MANY TEMPORARY VARIABLES NEEDED");
+ break ;
+
+ case STSEQTL : printf(" STATEMENT SEQUENCE TOO LONG");
+ break ;
+
+ case NOTIMPL : printf(" FUNCTION NOT IMPLEMENTED");
+ break ;
+
+ case OBJTOLG : printf(" OBJECT TOO LONG");
+ break ;
+
+ case PROCLTL : printf(" PROCEDURE LIST TOO LONG ") ;
+ break ;
+ } /* switch */
+
+ exit(4);
+
+ } /* generror */
+
+
+
+
+void out(){
+ /* PUT THE CONTENTS OF M^[ 0 .. fre-1 ] ON THE FILE "CFILE" */
+ /* 'BASE$ IS UPDATED AND 'fre' IS RESET TO ZERO */
+
+ address n,w;
+
+#if (TALK > 2)
+ printf("Writing %4d words of code\n", fre) ;
+#endif
+
+ for (n=0; n <= fre-1; n++ ){
+ w = m[ n ];
+ fputaddr(cfile, w);
+ wordswritten ++ ;
+ }
+
+ base += fre;
+#if (TALK > 3)
+ printf("base = %d\n", base) ;
+ printf("fre = %d\n", fre) ;
+#endif
+ fre = 0;
+}
+
+
+void outprot()
+{
+ protaddr n ;
+ address lp ;
+
+ for (n = MAINBLOCK; n <= lastprot; n++)
+ fwrite( (char *)(prototype[ n ]), sizeof(*(prototype[0])), 1, pfile);
+
+ fputaddr(cfile,ipradr);
+ fputaddr(cfile,temporary);
+ fputaddr(cfile,strings);
+ lp = lastprot;
+ fputaddr(cfile, lp);
+ fputaddr(cfile,base);
+}
+
+
+int apet(ip) /* STRONGLY MACHINE DEPENDENT */
+int ip ;
+{
+ return ( iand( ishft( ipmem [ ip ],-14 ), 3 ) + 1 );
+}
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include "glodefs.h"
+
+
+#ifndef NO_PROTOTYPES
+
+static bool vtype(address,int);
+static void addressing(void);
+static void param(int,int);
+static void p2(int,int,address);
+static void par2(address,int);
+static void putaddr(int,int);
+static void parproc(int);
+static void parfunc(int);
+static void partype(int);
+static void signoffst(int);
+static void offsets(void);
+static void rpcmask(void);
+
+#else
+
+static bool vtype();
+static void addressing();
+static void param();
+static void p2();
+static void par2();
+static void putaddr();
+static void parproc();
+static void parfunc();
+static void partype();
+static void signoffst();
+static void offsets();
+static void rpcmask();
+
+#endif
+
+
+
+static bool vtype(i,ip) address i; int ip;{
+
+/* PUTS THE TYPE OF ITEM DESCRIBED AT ADDRESS IP IN IPMEM TO THE CELLS
+ m[ I ],m[ I+1 ] / NUMBER OF ARRAYOF,FINAL TYPE/ .
+ ASSIGNES TRUE TO REF IF THE TYPE IS A REFERENCE TYPE AND FALSE OTHERWISE.
+ IF THERE IS NO DESCRIPTION FOR THE TYPE YET,"I" IS ADDED TO THE LIST
+ OF UNSATISFIED REFERENCES */
+
+ int ft ; /* final type */
+ address fft ;
+ int n ;
+ bool ref;
+ fft = 0 ;
+ m[ i ] = ipmem[ ip - 4 ] ;
+LOG(i);
+ ft = ipmem[ ip-3 ] ;
+ ref = FALSE ;
+
+ /* PRIMITIVE TYPE ? */
+ if (ft==nrint) /* integer */
+ fft = ipradr + TINT ;
+ else
+ if (ft==nrre) /* real */
+ fft = ipradr + TREAL ;
+ else
+ if (ft==nrbool) /* boolean */
+ fft = ipradr + TBOOLEAN ;
+ else
+ if (ft==nrchr) /* char */
+ fft = ipradr + TCHAR ;
+ else
+ if (ft == nrtext) /* string */
+ fft = ipradr + TSTRING ;
+ else /* REFERENCE TYPE */
+ ref = TRUE;
+
+
+ if (ref || (ipmem[ip-4] > 0) )
+ {
+ ref = TRUE ;
+
+ if (ft==nrcor)
+ fft=ipradr + TCOROUT ;
+ else
+ if (ft==nrproc)
+ fft = ipradr + TPROCESS ;
+ else
+ if( (ipmem[ft] % 16) == 11 ) /*file*/
+ fft = ipradr + TFILE ;
+ else
+ if (fft == 0)
+ { /* CLASS OR FORMAL TYPE */
+ if (ipmem[ ft+2 ] < 0)
+ fft = -ipmem[ ft+2 ] ;
+ else /* UNKNOWN YET, ADD TO LIST OF UNSATISFIED REFERENCES */
+ {
+ n = -ipmem[ft-2] ;
+ ipmem[ft-2] = -(i+1) ;
+ fft = -n;
+ } /* else */
+ } /* CLASS OR FORMAL TYPE */
+ } /* REFERENCE TYPE */
+
+ m[ i + 1 ] = fft ;
+LOG(i + 1);
+ return(ref) ;
+} /* VTYPE */
+
+
+
+
+
+static void param(ia, parkind) int ia,parkind;{
+ /* PREPARES A DESCRIPTION OF INPUT, OUTPUT OR INOUT PARAMETER */
+ bool aux ; /* auxilliary */
+ pointprdsc curr ;
+
+ /* IA = PARAMETER ADDRESS IN IPMEM */
+ /* WITH PROTOTYPE[ LASTPROT ] ^ DO */
+ { curr = prototype[ lastprot ] ;
+ reserve(3);
+ m[ fre ]=parkind;
+LOG(fre);
+
+ aux = vtype(fre+1,ia);
+
+ if (aux)
+ { /* REFERENCE TYPE */
+ addtolist(&(listofref[ lastprot ]), ia);
+ curr->lthreflist++ ;
+ }
+
+ longaddtolist(&(listofpar[ lastprot ]), fre + base) ;
+ curr->lthparlist++ ;
+ fre += 3 ;
+ }
+}
+
+static void p2(pk,pda,ndscr) int pk,pda; address ndscr;{
+
+ /* CREATES DESCRIPTION OF PAR. INPUT,OUTPUT OR INOUT
+ OF FORMAL PROCEDURE OR FUNCTION */
+
+ reserve(3) ;
+ m [ ndscr ] = fre + base ;
+LOG(ndscr);
+ m [ fre ] = pk ;
+LOG(fre);
+
+ vtype(fre + 1, pda) ;
+ fre += 3 ; /* mb */
+}
+
+
+
+static void par2(am,ip) address am; int ip;{
+
+ /* MAKES DESCRIPTIONS FOR FORMAL PARAMETERS OF void OR FUNCTION
+ BEING A PARAMETER ITSELF .
+ AM = ADDRESS OF THIS UNIT DESCRIPTION IN M,
+ IP = ADDRESS IN IPMEM */
+
+ int pda;
+ address n,ndscr ;
+ pointprdsc curr ;
+
+/* WITH PROTOTYPE[ LASTPROT ] ^ DO */
+ { curr = prototype[lastprot] ;
+
+ longaddtolist(&listofpar[ lastprot ],am+base);
+ curr->lthparlist++ ;
+ addtolist(&listofref[ lastprot ],ip) ;
+ curr->lthreflist++ ;
+ } /* with */ ;
+
+ m [ am + 2 ]=ipmem[ ip + 4 ];
+LOG(am + 2);
+ /* number of parameters including 'result' */
+ m [ am + 1 ] = fre + base ;
+LOG(am + 1);
+
+ if( m [ am+2 ] != 0)
+ { /* NOT EMPTY PARAMETERS LIST */
+ reserve(m [ am+2 ]) ;
+ fre += m [ am+2 ] ;
+
+ for (n=0; n<=m[ am+2 ]-1; n++)
+ {
+ pda = ipmem[ ipmem[ ip+3 ] + n ] ;
+ /* PARAMETER ADDRESS IN IPMEM */
+ ndscr = m [ am+1 ] - base + n ;
+
+ switch(itemkind(pda))
+ {
+ case IFMPROC : m [ ndscr ] = ipradr + TPROC2;
+ LOG(ndscr);
+ break;
+
+ case IFMFUNC : m [ ndscr ] = ipradr + TFUNC2;
+ LOG(ndscr);
+ break;
+
+ case IFMTYPE : reserve(2);
+ m [ ndscr ] = fre +base ;
+ LOG(ndscr);
+ m [ fre ] = FORMTYPE;
+ LOG(fre);
+ m [ fre + 1 ] = -1;
+ LOG(fre + 1);
+ backpatch(pda,fre);
+ fre += 2;
+ break;
+ case IPARIN : p2(PARIN, pda,ndscr) ;
+ break ;
+ case IVAR : ;
+ /* BECAUSE OF THE BUG IN COMPILER : 'RESULT' NOT DESCRIBED */
+ /* CORRECTLY, SHOULD BE TREATED AS OUTPUT PARAMETER */
+
+ case IPAROUT : p2(PAROUT, pda, ndscr);
+ break;
+
+ case IPARINOUT : p2(PARINOUT, pda, ndscr);
+ break;
+ } /* switch */
+ } /* for */
+ } /* NOT EMPTY PARAMETER LIST */;
+} /* PAR2 */;
+
+
+
+static void parproc(ia) int ia;{ /* FORMAL PROCEDURE DESCRIPTION */
+ reserve(3);
+ m [ fre ] = FORMPROC ;
+LOG(fre);
+ fre += 3 ;
+ par2(fre-3, ia) ;
+}
+
+
+static void parfunc(ia) int ia;{ /* FORMAL FUNCTION DESCRIPTION */
+ address n;
+ reserve(5);
+ m [ fre ] = FORMFUNC;
+LOG(fre);
+ fre += 5;
+ n = fre;
+ par2(n-5,ia);
+ vtype(n-2,ia);
+}
+
+
+static void partype(ia) int ia;{ /* FORMAL TYPE PARAMETER */
+ reserve(3);
+
+ m [ fre ] = FORMTYPE ;
+LOG(fre);
+ m [ fre + 1 ] = lastprot ; /* sl */
+LOG(fre + 1);
+ m [ fre + 2 ] = offset ;
+LOG(fre + 2);
+ backpatch(ia,fre + base) ;
+
+ /* WITH PROTOTYPE[ LASTPROT ] ^ DO */
+ longaddtolist(&listofpar[ lastprot ],fre + base) ;
+ prototype[lastprot]->lthparlist++ ;
+
+ fre += 3 ;
+}
+
+
+static void putaddr(ap,a) int ap,a;{
+
+ /* PUT PROTOTYPE AND OFFSET INTO ATTRIBUTE DESCRIPTION AT "A" IN IPMEM */
+
+ ipmem[ a - 2 ] = offset ;
+ ipmem[ a - 1 ] = lastprot ;
+
+ if(ap == APVIRT) offset += APREF ;
+ else offset += ap ;
+}
+
+
+static void offsets(){
+
+ /* COMPUTE OFFSETS FOR ALL ATTRIBUTES, */
+ /* COMPUTE OFFSETS FOR ALL ATTRIBUTES, */
+ /* LINK PARAMETERS, */
+ /* LINK REFERENCE ATTRIBUTES */
+
+ int p, n, a ;
+ pointprdsc curr ;
+ {
+ curr = prototype[lastprot] ;
+ offset = curr->appetite; /* total length of attributes from prefix,if any */
+
+ /* GO THRU THE LIST OF ATTRIBUTES */
+ for (p = ipmem[ curr->codeaddr + 6 ] ; /* first element */
+ p != 0 ;
+ p = ipmem[ p+1 ] /* next element */){
+
+ /* LIST ELEMENT : POINTER TO ATTRIBUTE DESCRIPTION, */
+ /* POINTER TO THE NEXT ELEMENT */
+
+ a = ipmem[ p ] ; /* attribute address in ipmem */
+ switch (itemkind(a)){
+
+ case IFMPROC : parproc(a) ;
+ putaddr(APFMPROC, a) ;
+ break ;
+
+ case IFMFUNC : parfunc(a) ;
+ putaddr(APFMPROC, a) ;
+ break ;
+
+ case IFMTYPE : partype(a) ;
+ putaddr(APFMTYPE, a) ;
+ break ;
+
+ case IPARIN : param(a, PARIN) ;
+ putaddr(apet(a), a) ;
+ break ;
+
+ case IPAROUT : param(a, PAROUT) ;
+ putaddr(apet(a), a) ;
+ break ;
+
+ case IPARINOUT : param(a, PARINOUT) ;
+ putaddr(apet(a), a) ;
+ break ;
+
+ case IVAR : n = apet(a) ;
+ if (n == APVIRT)
+ {
+ addtolist(&listofref[ lastprot ], a) ;
+ curr->lthreflist++ ;
+ n = APREF ;
+ }
+
+ putaddr(n, a) ;
+ break ;
+ default : break ;
+ /* IBLOCK, IPREFBLOCK, IHANDLER, ISIGNAL : IMPOSSIBLE */
+
+ /* ICLASS,IRECORD,ICOROUT,IPROCESS,IFUNC,IPROC,ICONST: NOP */
+
+ } /* switch */
+
+ } /* for */
+
+ curr->appetite = offset ;
+ } /* WITH */
+
+} /* OFFSETS */
+
+
+
+
+static void signoffst(s) int s;{
+
+ /* COMPUTES THE OFFSETS OF PARAMETERS OF */
+ /* THE SIGNAL DESCRIBED IN IPMEM AT S */
+
+ int offset ;
+ int p ;
+ int param ; /* POINTER TO PARAMETER DESCRIPTION */
+ int ap ;
+
+ offset = APINT + APINT;
+
+ /* GO THRU THE LIST OF ATTRIBUTES */
+ for( p = ipmem[ s+6 ] ; /* first element */
+ (p != 0) ;
+ p = ipmem[ p+1 ] /* next element */)
+
+ {
+ /* LIST ELEMENT : POINTER TO ATTRIBUTE DESCRIPTION */
+ /* POINTER TO THE NEXT ELEMENT */
+ param = ipmem[ p ] ; /* attribute address in ipmem */
+
+ switch(itemkind(param))
+ {
+ case IFMPROC : ;
+ case IFMFUNC : ap = APFMPROC ;
+ break ;
+
+ case IFMTYPE : ap = APFMTYPE ;
+ break ;
+ default :
+ /* IPARIN,IPAROUT,IPARINOUT */
+ ap = apet(param) ;
+ if (ap == APVIRT)
+ ap = APREF ;
+ break ;
+ } /* switch */
+
+ ipmem[ param-2 ] = offset ;
+ offset += ap ;
+ } /* for */
+} /* SIGNOFFST */
+
+
+static void addressing()
+
+ /* FOR EACH UNIT ( IN TOPOLOGICAL ORDER ) : */
+ /* - NEW PROTOTYPE IS CREATED, */
+ /* ( FOR CLASS ALSO CLASS TYPE DESCRIPTION ) */
+ /* - UNIT'S ATTRIBUTES ARE ASSIGNED OFFSETS */
+ /* - REFERENCE VARIABLES ( INCLUDING FORMAL PROCEDURES ) ARE LINKED */
+ /* INTO LIST */
+ /* - PARAMETERS ARE LINKED INTO LIST */
+ /* ( THEIR DESCRIPTIONS ARE ALSO PRODUCED ) */
+
+{
+ int pip ; /* PROTOTYPE IN IPMEM */
+ protaddr nextunit ;
+ protkind pkind[ IFMFUNC + 1 ] ; /* AUXILIARY, READ-ONLY */
+ logitem it ;
+
+ pointprdsc curr; /* for translation of Pascal's WITH */
+
+ for (it = ICLASS; it <= IFMFUNC ; it++)
+ pkind[ it ] = it;
+
+ /* START FROM THE MAIN BLOCK */
+ nextunit = MAINBLOCK ;
+ pip = nblus; /* main block in ipmem */
+
+ do /* GET UNIT FROM THE LIST OF ALL UNITS */
+ {
+ it = itemkind(pip);
+ if ( (it == ICLASS) || (it == IRECORD) || (it == ICOROUT)
+ || (it == IPROCESS) || (it == IBLOCK) || (it == IPREFBLOCK)
+ || (it == IFUNC) || (it == IPROC) || (it == IHANDLER) )
+ { /* REAL UNIT */
+
+ if (nextunit > MAXPROT)
+ generror(TMPROT) ;
+ /* mb removed case which did the same in every case */
+ /* in doubts cf. Pascal version */
+ prototype[ nextunit ] = (pointprdsc) new(prototype[ nextunit ]) ;
+
+ /* WITH PROTOTYPE[ NEXTUNIT ] ^ DO */
+ { curr = prototype[nextunit] ;
+ curr->codeaddr = pip ; /* pointer to the description in ipmem */
+ curr->kind = pkind[ it ] ;
+ }
+
+ nextunit++ ;
+ } /* OF REAL UNIT */
+ else
+ if (it == ISIGNAL)
+ signoffst(pip) ;
+
+ pip = ipmem[ pip+2 ] ; /* move on to the next unit */
+ }
+ while (pip != 0) ; /* END OF LIST. */
+
+ lastprot = MAINBLOCK ;
+
+ do
+ {
+ pdescr() ; /* make prototype's description */
+ offsets(); /* compute offsets for all attributes */
+ lastprot++ ;
+ }
+ while (lastprot != nextunit) ;
+
+ lastprot = nextunit-1;
+} /* ADDRESSING */
+
+
+static void rpcmask(){
+ pointprdsc *prot ;
+
+ for (prot = prototype; prot <= &prototype[lastprot]; prot++)
+ {
+ if ((*prot)->kind == PROCESS)
+ {
+ (*prot)->maskbase = MAINBLOCK ;
+ (*prot)->masksize = (lastprot + 7) / 8 ;
+ }
+ }
+}
+
+
+
+ void genprot(){
+
+ /* PROTOTYPES CREATING */
+
+ out() ;
+ primdescr() ; /* primitive types descriptions */
+ addressing() ; /* offsets, prototypes without lists */
+ lists() ; /* preflist, parlist, virtlist, descrlist */
+ handlers() ; /* handlers lists */
+
+/*CBC Force unit kind of main to be PROCESS (instead of BLOCK) ...*/
+ prototype[ MAINBLOCK ]->kind = PROCESS ;
+
+/*CBC Added computing of base and size of RPC mask */
+ rpcmask() ;
+/*...CBC*/
+
+} /* GENPROT */
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include <stdio.h>
+#include <string.h>
+
+#ifndef NO_PROTOTYPES
+#include <stdlib.h>
+#endif
+
+
+/*#define DEBUG 0 Defined for debugging time, undefine when ready */
+/*#define LOG(i) fprintf(log,"%s #%d : m[%d]=%d\n",__FILE__,__LINE__,i+base,m[i])*/
+#define LOG(i)
+
+#define MAXINT 32767
+
+#define new(s) calloc(1, sizeof(*s))
+ /*cmb It is calloc here, because we want untouched fields to be 0 */
+ /* rather than a random value cmb */
+
+#if SMALL
+#define MEMLIMIT 32000 /* small memory for main */
+typedef float real;
+typedef int address; /* APOPCODE == 2 - appetite of extended opcode */
+
+#elif LARGE
+#define MEMLIMIT 16000
+typedef long address; /* APOPCODE == 1 */
+typedef double real;
+
+#elif HUGE
+#define MEMLIMIT 32000
+typedef long address; /* APOPCODE == 1 */
+typedef double real;
+
+#else
+#error Define one of SMALL/LARGE/HUGE
+#endif
+
+
+#define CHARSINAD ( sizeof(address) ) /* number of characters in word */
+
+
+/* compiler symbol table and memory */
+extern int *ipmem;
+extern address *m;
+extern address fre,base,firstlabel;
+
+#define MEMORYSIZE 32000 /* CODE AND ALL RUNNING-SYSTEM DATA STRUCTURES */
+#define MAXCOMTEMP 100 /* NUMBER OF GLOBAL TEMPORARY VARIABLES */
+#define MAXLOCTEMP 100 /* LIMIT FOR THE NUMBER OF LOCAL TEMPORARY VARIABLES*/
+#define MAXREFTEMP 30 /* LIMIT FOR THE NUMBER OF LOCAL TMP. REF.VARIABLES */
+#define MAXAPPT 32767 /* MAXIMUM APPETITE (EASILY EXTENSIBLE) */
+#define MAXPARAM 10
+
+
+/* SIMPLE TYPES ARE DISTINGUISHED BY THEIR OFFSET FROM "IPRADR" */
+#define TINT 0
+#define TREAL 1
+#define TBOOLEAN 2
+#define TCHAR 3
+#define TCOROUT 4
+#define TPROCESS 5
+#define TSTRING 6
+#define TFUNC2 7 /* parameter "function" of parameter */
+#define TPROC2 8 /* parameter "procedure" of parameter */
+#define TFILE 9
+
+
+#define CURRFILE 2 /* constant address of a current file virtual address */
+
+#define MAXNAME 70 /* file name length */
+
+
+#define GEN 1
+#include "genint.h"
+
+typedef int addrmode ; /* gsg it was an enumeration */
+
+typedef char argdescr[4] ;
+
+typedef struct {
+ argdescr args ; /* ARGS[0] IS OPCODE */
+} extopcode ; /* EXTENDED OPCODE */
+
+ /* mb think up removing record extopcode */
+
+/************************************************************/
+/* b32b16c = record 32-bit integer
+ case boolean of
+ true : ( b32 : longint
+ false : ( r16 : integer
+ l16 : integer
+ )
+ end; */
+
+typedef union {
+ struct { long int b32 ; } t ;
+ struct { int r16, l16 ; } f ;
+ } b32b16c ;
+
+/* ieopc = record
+ case integer of
+ 0 : (int1,int2 : integer);
+ 1 : (int : longint);
+ 2 : (eop : extopcode );
+ end; */
+
+typedef union {
+ struct { int int1f, int2f ; } c0 ;
+ struct { long int intf ; } c1 ;
+ struct { extopcode eop ; } c2 ;
+ } ieopc ;
+/************************************************************/
+typedef char filename[ MAXNAME + 1 ] ;
+
+
+/* mb declarations from main to follow...*/
+
+#define ENDOFSTRINGS -1 /* end of strings section marker */
+
+typedef int errtype ; /* gsg previously enumeration */
+#define TMPROT 0 /* TOO MANY PROTOTYPES */
+#define TLDESCR 1 /* DESCRIPTIONS TOO LONG */
+#define MEMOVF 2 /* MEMORY OVERFLOW */
+#define TMTEMP 3 /* TOO MANY TEMPORARY VARIABLES NEEDED */
+#define STSEQTL 4 /* STATEMENT SEQUENCE TOO LONG */
+#define NOTIMPL 5 /* FUNCTION NOT IMPLEMENTED */
+#define OBJTOLG 6 /* OBJECT TOO LONG */
+#define PROCLTL 7 /* PROCEDURE LIST TOO LONG */
+
+typedef struct {
+ unsigned int ap : 2 ; /* 0..3 */
+ unsigned int l : 1 ; /* 0..1 */
+ unsigned int ft : 1 ; /* 0..1 */
+ unsigned int v : 1 ; /* 0..1 */
+ unsigned int s : 3 ; /* 0..7 */
+ unsigned int zp : 4 ; /* 0..15 */
+ unsigned int t : 4 ; /* 0..15 */
+
+ } csti ; /* : SYMBOL TABLE ITEM, 16 bits long */
+
+
+typedef union {
+ int icstic_int ;
+ csti cst ;
+
+ } icstic ;
+
+
+ /* mb genprot declarations to follow */
+
+typedef int logitem ; /* loglan items */ /* gsg previously enumeration */
+#define ICLASS 0
+#define IRECORD 1
+#define ICOROUT 2
+#define IPROCESS 3
+#define IBLOCK 4
+#define IPREFBLOCK 5
+#define IFUNC 6
+#define IPROC 7
+#define IHANDLER 8
+#define IFMPROC 9
+#define IFMFUNC 10
+#define IFMTYPE 11
+#define IPARIN 12
+#define IPAROUT 13
+#define IPARINOUT 14
+#define IVAR 15
+#define ICONST 16
+#define ISIGNAL 17
+
+typedef int logunit ; /* iclass .. ifmfunc */ /* LOGLAN UNITS TOGETHER WITH FORMAL */
+ /* FUNCTION AND FORMAL PROCEDURE */
+
+
+ /* AUXILIARY */
+
+
+
+typedef struct s1 {
+ int ip ; /* ADDRESS IN IPMEM */
+ struct s1 * prevelem ; /* PREVIOUS ELEMENT */
+
+ } listelem ; /* LIST OF PARAMETERS OR OF REFERENCE ATTRIBUTES */
+
+typedef listelem * pointer ;
+
+
+
+typedef struct s2 {
+ address ip ; /* ADDRESS IN IPMEM */
+ struct s2 * prevelem ; /* PREVIOUS ELEMENT */
+
+ } longlistelem ; /* list of parameters or of reference attributes */
+
+typedef longlistelem * longpointer ;
+
+
+/* mb declarations of code to follow */
+
+#define QMAX 2400 /* MAXIMAL LENGTH OF THE QUADRUPLES SEQUENCE */
+#define TEMPGUARD 103 /* = MAXCOMTEMP + MAXIMAL APPETITE */
+
+/*CBC added concurrent statements... */
+#define MAXPROCLIST 30 /* maximum length of procedure ident. list */
+
+
+typedef int qaddr ; /* 1..QMAX */
+typedef int qaddr0 ; /* 0..QMAX */ /* 0 FOR NO NEXT USE */
+typedef int argnr ; /* gsg na razie int; moze wystarczy char ?; 1..3 */
+typedef int app ; /* APINT..APVIRT */
+
+typedef struct {
+ int opcode ;
+ int arg[4] ;
+ qaddr0 nxtuse[4] ;
+ } quadruple ;
+
+extern quadruple tuple[];
+
+typedef int stmode ; /* gsg previously enumeration */
+#define VARGLOB 0 /* GLOBAL VARIABLE */
+#define VARLOC 1 /* LOCAL VARIABLE */
+#define VARMID 2 /* MIDDLE LEVEL VARIABLE */
+#define TEMPVAR 3 /* TEMPORARY VARIABLE */
+#define INTCONST 4 /* CONSTANT: INTEGER,CHAR,BOOLEAN,STRING */
+#define REALCONST 5 /* REAL CONSTANT */
+
+
+typedef struct {
+ unsigned int smode:4;
+ unsigned int sap:3;
+ /* APPETITE, DISTINGUISHING REFERENCES */
+ unsigned int slive:1;
+ /* TRUE, IF USED OUTSIDE THE ADDRESSING SCOPE */
+ unsigned int slocal:1;
+ /* TRUE --> MUST BE ALLOCATED IN OBJECT */
+ /* FALSE --> MAY BE ALLOCATED IN GLOBAL AREA */
+
+ } stitem ; /* SYMBOL TABLE ITEM */
+ /* totalling 9 bits , less then 1 word */
+
+
+/* ISTIC =*/ /* INTEGER <--> SYMBOL TABLE ITEM CONVERSION */
+/* RECORD*/
+/* CASE BOOLEAN OF*/
+/* TRUE : ( INT : INTEGER );*/
+/* FALSE: ( STI : STITEM )*/
+/* END;*/
+
+typedef bool tmpmap[ MAXLOCTEMP + 1 ] ;
+
+typedef struct {
+ tmpmap map ;
+ int locsize ; /* 0..MAXLOCTEMP */
+ int refsize ; /* -1..MAXREFTEMP */
+
+ } tmpmapdscr ;
+#define ishft(i, n) (( (n) > 0) ? ((i) << (n)) : ((i) >> -(n)))
+
+#define iand(i,j) ((int)((i) & (j)))
+
+#define ior(i,j) ((int)((i) | (j)))
+
+typedef struct {
+ addrmode mode ;
+ address off1 ;
+ address off2 ; /* FOR REMOTE ONLY */
+} args_struct ;
+
+extern args_struct args[4];
+
+
+#define putsap(s, i) i = (i & 0xff03) | ((s) << 2)
+
+#define sap(i) ((i) & 255) >> 2
+
+#define putslive(b, i) ((b) ? (i |= 2) : (i &= -3))
+
+#define slive(i) (bool)((i & 2) == 2)
+
+#define putslocal(b, i) ((b) ? (i |= 1) : (i &= -2))
+
+#define slocal(i) (bool)((i & 1) == 1)
+
+#define smode(i) ((stmode)(i >> 8))
+
+#include "mainvar.h"
+#include "oxen.h"
+
+
+#ifndef NO_PROTOTYPES
+
+void out(void);
+void outprot(void);
+void back(void);
+void backpatch(int,address);
+void generror(errtype);
+void addtolist(pointer *,int);
+void longaddtolist(longpointer *,address);
+void gen(void);
+void genprot(void);
+void handlers(void);
+void initiate(void);
+void lists(void);
+void primdescr(void);
+void pdescr(void);
+void putreals(void);
+void putstrings(void);
+void setfiles(char *);
+void reserve(address);
+logitem itemkind(int);
+int apet(int);
+void dump_lcode(char *);
+void makeproclist(void);
+
+#else
+
+void out();
+void outprot();
+void back();
+void backpatch();
+void generror();
+void addtolist();
+void longaddtolist();
+void gen();
+void genprot();
+void handlers();
+void initiate();
+void lists();
+void primdescr();
+void pdescr();
+void putreals();
+void putstrings();
+void setfiles();
+void reserve();
+logitem itemkind();
+int apet();
+void dump_lcode();
+void makeproclist();
+
+#endif
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#if TALK >= 3
+
+#include <stdio.h>
+#include <string.h>
+
+#include "glodefs.h"
+#include "mainvar.h"
+
+
+void dump_lcode( name ) char *name;{
+
+ FILE *fout;
+ char outname[100];
+ unsigned char opdescr[ 229 ];
+ int args[ 3 ] , arg_no ;
+ int i, opcode, n ;
+
+ strcpy(outname,name);
+ fout=fopen(strcat(outname,".lco"),"w");
+ if( fout==NULL ){
+ fprintf(stderr,"Can't open file %s for writing\n",name);
+ exit(10);
+ }
+
+ /* initiate opdescr */
+
+ for( n=100; n<=131; n++ ) opdescr[ n ]=3;
+ for( n=30 ; n<=83 ; n++ ) opdescr[ n ]=2;
+ opdescr[ 29 ]=3;
+ opdescr[ 37 ]=3;
+ opdescr[ 39 ]=3;
+ opdescr[ 40 ]=3;
+ opdescr[ 44 ]=2;
+ opdescr[ 45 ]=2;
+ for( n=52 ; n<=57 ; n++ ) opdescr[ n ]=3;
+ for( n=84 ; n<=99 ; n++ ) opdescr[ n ]=3;
+ opdescr[ 11 ]=1;
+ opdescr[ 12 ]=1;
+ opdescr[ 13 ]=2;
+ opdescr[ 15 ]=2;
+ opdescr[ 16 ]=2;
+ for( n=20 ; n<=26 ; n++ ) opdescr[ n ]=3;
+ for( n=1 ; n<=5 ; n++ ) opdescr[ n ]=3;
+ opdescr[ 2 ]=2;
+ opdescr[ 132 ]=1;
+ opdescr[ 145 ]=3;
+ opdescr[ 137 ]=2;
+ opdescr[ 138 ]=2;
+ opdescr[ 139 ]=2;
+ opdescr[ 144 ]=2;
+ opdescr[ 149 ]=2;
+ opdescr[ 150 ]=2;
+ opdescr[ 151 ]=2;
+ opdescr[ 152 ]=2;
+ opdescr[ 140 ]=1;
+ opdescr[ 141 ]=1;
+ opdescr[ 143 ]=1;
+ opdescr[ 146 ]=1;
+ opdescr[ 147 ]=1;
+ opdescr[ 148 ]=1;
+ opdescr[ 153 ]=1;
+ opdescr[ 158 ]=1;
+ opdescr[ 159 ]=2;
+ opdescr[ 160 ]=2;
+ opdescr[ 161 ]=2;
+ opdescr[ 162 ]=2;
+ opdescr[ 163 ]=2;
+ opdescr[ 164 ]=3;
+ opdescr[ 165 ]=3;
+ opdescr[ 166 ]=3;
+ opdescr[ 170 ]=3;
+ for( n=172 ; n<= 194 ; n++ ) opdescr[ n ]=0;
+ opdescr[ 175 ]=1;
+ opdescr[ 177 ]=1;
+ opdescr[ 178 ]=1;
+ opdescr[ 181 ]=1;
+ opdescr[ 182 ]=1;
+ opdescr[ 183 ]=1;
+ opdescr[ 184 ]=1;
+ opdescr[ 186 ]=1;
+ opdescr[ 188 ]=1;
+ opdescr[ 189 ]=3;
+ opdescr[ 220 ]=1;
+ opdescr[ 221 ]=0;
+ opdescr[ 222 ]=0;
+ opdescr[ 223 ]=0;
+ opdescr[ 224 ]=0;
+ opdescr[ 225 ]=0;
+ opdescr[ 226 ]=0;
+ opdescr[ 227 ]=0;
+ opdescr[ 228 ]=1;
+ for( n = 195 ; n<=219 ; n++ ) opdescr[ n ]=2;
+ for( n = 201 ; n<=204 ; n++ ) opdescr[ n ]=1;
+
+
+ while( 1 ) {
+
+ opcode = next();
+ arg_no = opdescr[ opcode ] ;
+ for(i = 0 ; i < arg_no ; i++) args[ i ] = next();
+
+ fprintf(fout," %3d " , opcode );
+
+ switch( opcode ) {
+
+ case 13 :
+ if(args[ 1 ] > 0 )
+ fprintf(fout," t%-5d := R%1d",args[0],args[1]);
+ else
+ fprintf(fout," t%-5d := %5d(R6)",args[0],args[1]);
+ break;
+
+ case 23 :
+ fprintf(fout," t%-5d := sp%-3d.par%02d",args[0],args[1],args[2]);
+ break;
+
+ case 37 :
+ fprintf(fout," t%-5d := t%-5d + %d",args[0],args[1],args[2]);
+ break;
+
+ case 60 :
+ fprintf(fout," t%-5d := t%-5d",args[0],args[1]);
+ break;
+
+ case 64 :
+ case 65 :
+ case 66 :
+ case 67 :
+ case 68 :
+ case 69 :
+ case 70 :
+ case 71 :
+ case 72 :
+ fprintf(fout," t%-5d := %2d * t%-5d",args[0],opcode-62,args[1]);
+ break;
+
+ case 110 :
+ fprintf(fout," t%-5d := ( t%-5d > t-5d )",args[0],args[1],args[2]);
+ break;
+
+ case 132 :
+ fprintf(fout," call sp%-3d",args[0]);
+ break;
+
+ case 139 :
+ if( args[ 1 ] > 0 )
+ fprintf(fout," R%1d := t%-5d",args[1],args[0]);
+ else
+ fprintf(fout," %5d(R6) := t%-5d",-args[1],args[0]);
+ break;
+
+ case 140 :
+ fprintf(fout," nop");
+ break;
+
+ case 145 :
+ fprintf(fout," sp%-3d.par%02d := t%-5d",args[1],args[2],args[0]);
+ break;
+
+ case 151 :
+ fprintf(fout," if not t%-5d goto L%-4d",args[0],args[1]);
+ break;
+
+ case 152 :
+ fprintf(fout," if t%-5d goto L%-4d",args[0],args[1]);
+ break;
+
+ case 174 :
+ fprintf(fout,"LASTWILL :");
+ break;
+
+ case 177 :
+ fprintf(fout,"* line %5d",-args[0]+1);
+ break;
+
+ case 179 :
+ fprintf(fout," Entry point:");
+ break;
+
+ case 181 :
+ fprintf(fout,"L%-4d :",args[0]);
+ break;
+
+ case 182 :
+ fprintf(fout," jump L%-4d",args[0]);
+ break;
+
+ case 184 :
+ fprintf(fout,"BEGIN M%05d",args[0]);
+ break;
+
+ case 185 :
+ fprintf(fout,"END");
+ break;
+
+ case 191 :
+ fprintf(fout," backbl");
+ break;
+
+ case 192 :
+ fprintf(fout," backpr");
+ break;
+
+ case 193 :
+ fprintf(fout," back");
+ break;
+
+ case 194 :
+ fprintf(fout," fin");
+ break;
+
+ case 199 :
+ fprintf(fout," iconst t%-5d = %5d",args[0],args[1]);
+ break;
+
+ case 200 :
+ fprintf(fout,"END OF CODE" );
+ break;
+
+ case 201 :
+ fprintf(fout," tempvar1 t%-5d",args[0]);
+ break;
+
+ case 202 :
+ fprintf(fout," tempvar2 t%-5d",args[0]);
+ break;
+
+ case 203 :
+ fprintf(fout," tempvar3 t%-5d",args[0]);
+ break;
+
+ case 204 :
+ fprintf(fout," tempvar4 t%-5d",args[0]);
+ break;
+
+ case 205 :
+ fprintf(fout," globvar t%-5d [ desc = &5d ]",args[0],args[1]);
+ break;
+
+ case 208 :
+ fprintf(fout," livevar t%-5d := t%-5d",args[0],args[1]);
+ break;
+
+ case 223 :
+ case 224 :
+ case 225 :
+ case 227 :
+ {
+ qcurr=1;
+ makeproclist();
+ fprintf(fout," proclist ");
+ }
+ break;
+
+ default :
+ for( i=0; i<arg_no; i++ ) fprintf(fout," %c = %5d ",'A'+i,args[i]);
+ break;
+
+ }
+
+ fflush(fout);
+
+ fprintf(fout,"\n");
+
+ if( opcode>=172 && opcode<=176 || opcode>=178 && opcode<=194 )
+ fprintf(fout,"---------------------------------------------------\n");
+
+ if( opcode == 200 ) break ; /* end-marker */
+
+ }
+
+ fclose(fout);
+
+}
+
+#endif
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+=======================================================================
+*/
+
+#include <assert.h>
+#include "glodefs.h"
+
+#ifndef NO_PROTOTYPES
+
+static void makereflist (protaddr);
+static void makeprefseq (protaddr);
+static void makeparlist (protaddr);
+static void makevirtlist(protaddr);
+static void makeit (int,protaddr);
+
+#else
+
+static void makereflist();
+static void makeprefseq();
+static void makeparlist();
+static void makevirtlist();
+static void makeit();
+
+#endif
+
+logitem itemkind (i)
+ /* strongly implementation dependent, */
+ /* given the address in symbol table */
+ /* returns the kind of loglan item */
+ /* ctp */
+
+int i ;
+{
+ int n ;
+ csti trick ;
+
+ n = ipmem [ i ] ;
+
+/* WITH TRICK DO */
+ {
+ trick.t=iand(n,15); /* 000f */
+ /* bits 12..15 in 16-bits word */
+
+ trick.zp=ishft(iand(n,15*16),-4); /* 00f0 */
+ /* bits 8..11 in 16-bits word */
+
+ trick.s=ishft(iand(n,7*256),-8); /* 0700 */
+
+ /* bits 5.. 7 in 16-bits word */
+
+ switch(trick.t)
+ {
+ case 2 : return(IRECORD) ;
+
+ case 3 : return(ICLASS) ;
+
+ case 5 : return(IPROCESS) ;
+
+ case 6 : return(IFMTYPE) ;
+
+ case 7 : return(ICOROUT) ;
+
+ default :
+ /* 4,8,9,10,11,12,13,14,15 */ break;
+
+ case 1 : switch(trick.zp)
+ {
+ case 2 : return(IFMFUNC) ;
+
+ case 3 : return(IFMPROC);
+
+ case 5 : return(IPARIN);
+
+ case 6 : return(IPAROUT);
+
+ case 7 : return(IVAR);
+
+ case 8 : return(ICONST);
+
+ case 9 : return(IPARINOUT);
+
+ case 11 : return(ISIGNAL);
+
+
+
+ case 0 : switch(trick.s)
+ {
+ case 0 : return(IBLOCK);
+
+ case 1 : return(IPREFBLOCK);
+
+ case 2 : return(IFUNC);
+
+ case 4 : return(IPROC);
+
+ case 7 : return(IHANDLER);
+
+
+ default /* 3,5,6*/ : break ;
+ } /* switch trick.s */
+ default :
+ /* 1,4,10,12,13,14,15 */ break ;
+
+ } /* switch trick.zp */
+ } /* switch trick.t */;
+ } /* WITH */
+
+} /* itemkind */
+
+
+
+void reserve(n) address n;{ /* TEST IF THERE IS AT LEAST N EMPTY CELLS IN 'M' */
+ if((fre + n) > MEMLIMIT) generror(TLDESCR);
+}
+
+
+
+static void makereflist(prot) protaddr prot;{
+/* PREPARES THE TABLE WITH OFFSETS OF REFERENCE VARIABLES */
+/* FOR THE PROTOTYPE PROT */
+
+ pointer elem ;
+ int n ;
+ bool anytodo ;
+ dprotaddr pref ;
+ pointprdsc curr ; /* cmb */
+
+ curr = prototype[ prot ] ;
+ if (curr->lthreflist > 0){
+ anytodo = TRUE ;
+ pref = prefix[ prot ] ;
+
+ if (pref != DUMMY) /* prefixed unit */
+ if(( prototype[ pref ]->span != 0 )
+ && ( prototype[ pref ]->lthreflist == curr->lthreflist )){
+
+ /* prefix already processed and the same reference attributes */
+
+ anytodo = FALSE ;
+ curr->reflist = prototype[ pref ]->reflist ;
+ }
+
+ if(anytodo){
+ reserve(curr->lthreflist) ;
+ elem = listofref[ prot ] ;
+
+ /* COPY THESE OFFSETS */
+ for (n = curr->lthreflist-1; n>=0; n--)
+ {
+ m [ fre+n ] = ipmem[ (elem->ip) - 2 ] ; /* offset */
+LOG(fre + n);
+ elem = elem->prevelem ;
+ } /* COPYING */
+
+ curr->reflist = fre + base ;
+ fre += curr->lthreflist ;
+
+ } /* NOT DONE YET */
+ } /* IF NON EMPTY REFLIST */
+}
+
+
+
+static void makeprefseq(prot) protaddr prot;{
+ int n ;
+ dprotaddr pa ;
+ pointprdsc curr ;
+
+/* WITH PROTOTYPE[ PROT ]^ DO */
+
+ curr = prototype[ prot ] ;
+ reserve(curr->lthpreflist) ;
+ pa = prot ;
+
+ for (n = (curr->lthpreflist) - 1; n >= 0 ; n--)
+ {
+ m[ fre + n ] = pa ;
+LOG(fre + n);
+ pa = prefix[ pa ] ;
+ }
+
+ curr->preflist = fre + base ;
+ fre += curr->lthpreflist ;
+
+}
+
+
+
+static void makeparlist(prot) protaddr prot;{
+/* PREPARES TABLES WITH PARAMETERS OFFSETS AND DESCRIPTION ADDRESSES
+ FOR PROTOTYPE PROT */
+
+ longpointer elem ;
+ int ip , /* address in ipmem */
+ n ;
+ dprotaddr pref;
+ bool anytodo ;
+ pointprdsc curr ;
+
+/* WITH PROTOTYPE[ PROT ] ^ DO */
+{ curr = prototype[ prot ] ;
+ if (curr->lthparlist > 0)
+ {
+ /* TABLE WITH PARAMETERS OFFSETS */
+ reserve(curr->lthparlist) ;
+ curr->parlist = fre + base ;
+
+ if (curr->kind == HANDLER)
+ {
+ /* NO PARAMETER LIST IN IPMEM, USE ATTRIBUTE LIST*/
+ ip = ipmem[(curr->codeaddr) + 6 ] ;
+ /* FIRST ELEM. OF ATTRIBUTE LIST */
+ for (n = 0; (n <=(curr->lthparlist-1 )); n++)
+ {
+ m[ fre + n ] = ipmem[(ipmem[ ip ])-2 ] ; /* offset */
+LOG(fre + n);
+
+
+ ip = ipmem[ ip+1 ]; /* next */
+ } /* FOR */;
+
+ fre += curr->lthparlist;
+ } /* IF HANDLER */
+
+ else /* not handler */
+ {
+ anytodo = TRUE;
+ pref = prefix[ prot ];
+
+ if (pref != DUMMY)
+ if (( prototype[ pref ]->span != 0 ) /* prefix already processed */
+ && ( prototype[ pref ]->lthparlist == curr->lthparlist ))
+ /* the same parameters */
+ {
+ curr->parlist=prototype[ pref ]->parlist;
+ anytodo=FALSE;
+ }
+
+ if (anytodo)
+ {
+ /* COPY THESE OFFSETS USING PARAMETERS LIST FROM IPMEM */
+ ip=ipmem[ curr->codeaddr+3 ]; /* first parameter indirect address */
+
+ for (n=0;n <= (curr->lthparlist) - 1; n++)
+ m [ fre + n ] = ipmem[ ipmem[ ip+n ] - 2 ]; /* offset */
+LOG(fre + n - 1);
+
+ fre += curr->lthparlist;
+ } /* mb if anytodo (?) */
+
+ /* FOR PROCEDURE OR FUNCTION PREPARE TABLE WITH PARAMETERS
+ DESCRIPTIONS ADDRESSES */
+ if( (curr->kind == LFUNCTION) || (curr->kind == LPROCEDURE)
+ || (curr->kind == PROCESS) )
+ {
+ reserve(curr->lthparlist);
+ curr->pfdescr=fre+base;
+ elem = listofpar[ prot ];
+
+ for (n=curr->lthparlist-1; n >= 0; n--)
+ {
+ m [ fre + n ] = elem->ip; /* description's address */
+LOG(fre + n);
+ elem=elem->prevelem;
+ } /* for */
+
+ fre += curr->lthparlist;
+ } /* FUNCTION,PROCEDURE,PROCESS */
+ } /* NOT HANDLER */
+ } /* mb if lthparlist>0 ?? */
+ } /* WITH */
+
+ } /* makeparlist */
+
+static void makeit(ipr,prot)
+ int ipr ;
+ protaddr prot ;
+ /* mb added passing ipr,prot as parameters rather than globals */
+ /* for the ipmem prototype 'ipr' creates the table with virtuals
+ prototypes numbers and assignes its address to virtlist of
+ 'prot' . */
+{
+ int k,l,f ;
+
+ l=ipmem[ ipr+25 ]; /* length */
+ f=ipmem[ ipr+24 ]; /* first element address */
+ reserve(l);
+ prototype[ prot ]->virtlist=fre + base;
+ for (k=0; k<=l-1; k++)
+ m[ fre+k ]=ipmem[ (ipmem[ f+k ])-1 ]; /* virtual's prototype */
+LOG(fre + k);
+ fre+=l;
+ } /* makeit */
+
+static void makevirtlist(prot) protaddr prot;{
+ /* MAKES A TABLE WITH PROTOTYPES NUMBERS FOR VIRTUAL */
+ /* PROCEDURES OR FUNCTIONS (IF NOT MADE YET). */
+ /* PROPAGATES ITS ADDRESS THRU THE PREFIX SEQUENCE. */
+
+ int ipr ;
+ address n ;
+ pointprdsc curr;
+
+ {
+ curr = (prototype[prot]);
+ ipr = (int)(curr->codeaddr); /* address in ipmem */
+ if( ((curr->kind == CLASS) || (curr->kind == LRECORD) ||
+ (curr->kind ==COROUTINE) || (curr->kind ==PROCESS) ||
+ (curr->kind == PREFBLOCK) || (curr->kind ==LFUNCTION) ||
+ (curr->kind ==LPROCEDURE)) /* VIRTUALS ALLOWED */
+ && (curr->virtlist == 0) /* not processed yet */
+ && (ipmem[ ipr + 25 ] != 0))
+ { /* not empty virtuals list */
+ while (ipmem[ ipr + 25 ] < 0)
+ /* LIST INHERITED FROM PREFIX, GO THERE */
+ ipr=ipmem[ ipr + 21 ];
+ /* THE OWN LIST OF IPR */
+ n = prototype[ ipmem[ ipr - 1 ] ]->virtlist ;
+ if (!n) /* TABLE NOT MADE YET */
+ makeit(ipr, prot) ;
+ else
+ { curr->virtlist = n ;}
+ /* PROPAGATE IT UP THE PREFIX SEQUENCE TILL THE OWNER OF THE LIST */
+ ipr=(int)(curr->codeaddr); /* ipmem address for prot */
+ while (ipmem[ ipr+25 ] < 0)
+ {
+ ipr = (int)(ipmem[ ipr+21 ]); /* prefix */
+ prototype[ ipmem[ ipr-1 ] ]->virtlist = curr->virtlist;
+ }
+ } /* VIRTUALS ALLOWED AND EXIST, UNIT NOT PROCESSED */
+ } /* WITH */
+ } /* MAKEVIRTLIST */
+
+void lists(){
+
+ /* PREPARATION OF : REFLIST, PARLIST, PARDESCRLIST, PREFLIST */
+ /* UNITS ARE PROCESSED IN A REVERSED ORDER */
+
+ protaddr pr ;
+ dprotaddr prfx ;
+ pointprdsc pref ;
+ address n ;
+ pointprdsc curr ; /* gsg auxiliary for the Pascal WITH */
+
+ for(pr = lastprot; pr >= MAINBLOCK; pr--){
+ curr = prototype[pr] ;
+ if(curr->span == 0){ /* ALREADY PROCESSED ? */
+ /* NOT PROCESSED YET */
+ makeparlist(pr) ;
+ if(curr->kind == LFUNCTION){ /* SUPPLEMENT FUNCTION TYPE */
+ n = m[ curr->pfdescr - base + curr->lthparlist - 1 ] - base; /* result */
+ curr->nrarray = m[ n+1 ] ;
+ curr->finaltype = m[ n+2 ] ;
+ } /* SUPPLEMENT OF FUNCTION TYPE */
+
+ makereflist(pr) ;
+ makeprefseq(pr) ;
+ curr->span = 1 ; /* ==> processed */
+
+ /* GO UP THE PREFIX SEQUENCE */
+ prfx = prefix[ pr ] ;
+
+ while (prfx != DUMMY)
+ { pref = prototype[ prfx ] ;
+
+ if (pref->span != 0)
+ prfx = DUMMY ; /* FORCE EXIT */
+ else
+ { /* prefix not processed yet */
+ pref->span = 1 ; /* ==> processed */
+ pref->reflist = curr->reflist ;
+ pref->parlist = curr->parlist ;
+ pref->preflist = curr->preflist ;
+/*CBC added copying of PFDESCR (formal parameter description list) */
+ pref->pfdescr = curr->pfdescr ;
+ prfx = prefix[ prfx ] ;
+ } /* PREFIX NOT PROCESSED */
+ } /* WHILE */
+
+ } /* NOT PROCESSED */
+
+ makevirtlist(pr) ;
+ } /* for */
+
+} /* Lists */
+
+
+void handlers(){
+ protaddr prot;
+ address pip,listfrompref;
+ int h;
+
+ for (prot = MAINBLOCK; prot <= lastprot; prot++)
+ /* WITH PROTOTYPE[ PROT ] ^ DO */
+ { if (prototype[prot]->kind == HANDLER) /* SURELY NO OWN HANDLERS */
+ prototype[prot]->handlerlist = 0 ;
+ else
+ {
+ if (prototype[prot]->lthpreflist == 1) /* NO PREFIX */
+ listfrompref = 0 ;
+ else
+ listfrompref = prototype[ prefix[ prot ] ]->handlerlist ;
+
+ pip = prototype[prot]->codeaddr ; /* prototype in ipmem */
+
+ if (ipmem[ pip + 19 ] == 0) /* NO OWN HANDLERS */
+ prototype[prot]->handlerlist = listfrompref ;
+ else
+ { /* mb own handlers possible */
+ reserve( 3 * ( ipmem[ pip + 19 ]) ) ;
+ prototype[prot]->handlerlist = fre + base ;
+ h = ipmem[ pip + 20 ] ;
+ /* first element of handler list in ipmem */
+
+ do
+ {
+ m[ fre ] = ipmem[ h ] ; /*signal identifier */
+LOG(fre);
+ m[ fre + 1 ] = ipmem[ (int)(ipmem[ h + 1 ]) - 1 ] ;
+LOG(fre + 1);
+
+ /* handler prototype */
+ m[ fre + 2 ] = fre + 3 + base ; /* next */
+LOG(fre + 2);
+ h = ipmem[ h + 2 ] ;
+ fre += 3 ;
+ } while (h) ;
+
+ m[ fre - 1 ] = listfrompref ;
+LOG(fre - 1);
+
+ } /* else */
+ } /* OWN HANDLERS */
+ } /* for */
+} /* HANDLERS */
+
+
+
+void primdescr(){
+/* DESCRIPTIONS OF PRIMITIVE TYPES */
+
+ /*printf("primdescr: fre = %d\n", fre) ; */
+ assert(fre == 0 && base > 0);
+ ipradr =base + fre ;
+ m[ fre + TINT ] = PRIMITIVETYPE ;
+ m[ fre + TREAL ] = PRIMITIVETYPE ;
+ m[ fre + TBOOLEAN ] = PRIMITIVETYPE ;
+ m[ fre + TCHAR ] = PRIMITIVETYPE ;
+ m[ fre + TCOROUT ] = PURECOROUTINE ;
+ m[ fre + TPROCESS ]= PUREPROCESS ;
+ m[ fre + TSTRING ] = PRIMITIVETYPE ;
+ m[ fre + TFUNC2 ] = FORMFUNC ;
+ m[ fre + TPROC2 ] = FORMPROC ;
+ m[ fre + TFILE ] = FILETYPE ; /*DSW*/
+
+ /*dsw*/ /* fre=fre+TPROC2+1; */
+
+ fre = fre + TFILE + 1 ; /*dsw*/
+
+ /* STORE ADDRESSES OF THESE TYPES DESCRIPTIONS */
+
+ /*DSW&BC...*/
+ if (ipradr + TFILE > MAXINT - 1) generror(TLDESCR) ;
+
+ ipmem[ nrint + 2 ] = -(ipradr + TINT) ;
+ ipmem[ nrre + 2 ] = -(ipradr + TREAL) ;
+ ipmem[ nrbool + 2 ] = -(ipradr + TBOOLEAN) ;
+ ipmem[ nrchr + 2 ] = -(ipradr + TCHAR) ;
+ ipmem[ nrcor + 2 ] = -(ipradr + TCOROUT) ;
+ ipmem[ nrproc + 2 ] = -(ipradr + TPROCESS) ;
+ ipmem[ nrtext + 2 ] = -(ipradr + TSTRING) ;
+
+} /* PRIMDESCR */
+
+
+
+void addtolist(head, i) /* gsg ATTENTION !!! head is "var" parameter !!! */
+/* ADD THE NEW ELEMENT WITH VALUE "I" TO THE LIST
+ REFERED BY "HEAD" */
+/* head is passed by reference - it is an "inout" parameter */
+/* so it is pointer to pointer to first item */
+
+pointer * head ; /* i.e item **head */
+int i ;
+{
+ pointer elem ;
+
+ elem = *head ;
+ (*head) = (pointer) new(*head) ;
+ (*head)->ip = i ;
+ (*head)->prevelem = elem ;
+
+} /* ADDTOLIST */
+
+
+void longaddtolist(head, i) /* gsg ATTENTION !!! head is "var" parameter !!! */
+/* ADD THE NEW ELEMENT WITH VALUE "I" TO THE LIST
+ REFERED BY "HEAD" */
+longpointer * head ;
+address i ;
+{
+ longpointer elem ;
+
+ elem = (*head) ;
+ (*head) = (longpointer) new(*head);
+ (*head)->ip = i ;
+ (*head)->prevelem = elem ;
+
+} /* longaddtolist */
+
+
+void backpatch(i, a) int i; address a;{
+
+/* SATISFY REFERENCES (IF ANY) TO THE TYPE WITH IPMEM ADDRESS I */
+/* WITH THE VALUE A . */
+/* IPMEM(I+2) >= 0 ==> NO DESCRIPTION YET, */
+/* IF IPMEM(I-2) >= 0 THEN NOT REFERED YET, */
+/* OTHERWISE = -LINK TO THE FIRST ELEMENT OF LIST */
+/* IPMEM(I+2) < 0 ==> DESCRIPTION ALREADY MADE */
+/* AT ADDRESS = -IPMEM(I+2) */
+
+ address n,k;
+
+ /*DSW&BC...*/ if(a > MAXINT - 1) generror(TLDESCR);
+
+ /* ANY REFERENCES ? */
+ if(ipmem[ i - 2 ] < 0){
+ n = -ipmem[ i - 2 ];
+ ipmem[ i - 2 ] = 0;
+
+ while (n > 0){
+ k = n;
+ n = - m[n];
+ m[ k ] = a;
+ LOG(k);
+ }
+ }
+ ipmem[ i + 2 ] = -a ; /* DESCR. ALREADY MADE */
+}
+
+
+void pdescr(){
+/* FILLS THE PROTOTYPE OF UNIT. */
+/* FOR THE CLASS ALSO CREATES CLASS TYPE DESCRIPTION */
+
+ pointprdsc prfx ; /* POINTER TO PREFIX DESCRIPTION */
+ int ip ; /* ADDRESS IN IPMEM */
+ pointprdsc curr ; /* gsg translation of the Pascal WITH */
+
+ /* WITH PROTOTYPE[ LASTPROT ]^ DO */
+ { curr = prototype[ lastprot ] ;
+ ip = curr->codeaddr ;
+
+ if (lastprot == MAINBLOCK)
+ curr->slprototype = DUMMY ;
+ else
+ curr->slprototype = ipmem[ ipmem[ip-1]-1 ] ; /*PROTOTYPE NUMBER FOR SL*/
+
+ ipmem[ ip - 1 ] = lastprot ;
+ curr->appetite = APINT + APINT ; /* 2 CELLS: OBJECT'S APPETITE, */
+ /* PROTOTYPE ADDRESS */
+ curr->span = 0 ;
+ listofref[ lastprot ] = NULL ;
+ curr->lthreflist = 0 ;
+ listofpar[ lastprot ] = NULL ;
+ curr->lthparlist = 0 ;
+ curr->preflist = 0 ;
+ curr->lthpreflist = 1 ;
+ curr->lastwill = 0 ;
+ curr->handlerlist = 0 ;
+ curr->virtlist = 0 ;
+
+ /*CBC added virtual number ...*/
+ if (iand(ipmem[ ip ], 8 * 256) != 0) /* virtual ? 0800 */
+ curr->virtnumber = ipmem[ ip + 27 ] ; /* yes, store virtual number */
+ else
+ curr->virtnumber = -1 ; /* no, flag that not virtual */
+ /*...CBC*/
+
+ prefix[ lastprot ] = DUMMY ;
+
+ if ( (curr->kind == CLASS) || (curr->kind == LRECORD) ||
+ (curr->kind ==COROUTINE) || (curr->kind ==PROCESS) ||
+ (curr->kind == PREFBLOCK) || (curr->kind ==LFUNCTION) ||
+ (curr->kind ==LPROCEDURE) )
+
+ { /* POSSIBLY PREFIXED */
+ if (ipmem[ ip + 21 ] != 0)
+ { /* PREFIXED UNIT */
+ prefix[ lastprot ] = ipmem[ ipmem[ ip + 21 ] - 1 ] ;
+ prfx = prototype[ prefix[ lastprot ] ] ;
+ curr->lthpreflist = prfx->lthpreflist + 1 ;
+ listofref[ lastprot ] = listofref[ prefix[ lastprot ] ] ;
+ curr->lthreflist = prfx->lthreflist ;
+ listofpar[ lastprot ] = listofpar[ prefix[ lastprot ] ] ;
+ curr->lthparlist = prfx->lthparlist ;
+ curr->appetite = prfx->appetite ;
+ } /* PREFIXED UNIT */
+
+ if ( (curr->kind == CLASS) || (curr->kind == LRECORD) ||
+ (curr->kind ==COROUTINE) || (curr->kind ==PROCESS) )
+ { /* CREATE CLASS TYPE */
+ reserve(2) ;
+ backpatch(ip, fre + base) ;
+ m[ fre++ ] = CLASSTYPE ;
+LOG(fre - 1);
+ m[ fre++ ]= lastprot ;
+LOG(fre - 1);
+
+ } /* CLASS TYPE */
+ } /* POSSIBLE PREFIXED */
+ } /* WITH */
+
+} /* PDESCR */
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include "glodefs.h"
+#include <unistd.h>
+
+#ifndef NO_PROTOTYPES
+
+static void code(void);
+static void putstmode(stmode,int *);
+static void segments(void);
+
+#else
+
+static void code();
+static void putstmode();
+static void segments();
+
+#endif
+
+/* cas dodalem deklaracje zmiennej qcurr */
+/* DO CELOW URUCHOMIENIOWYCH */
+static address zmienna;
+int qcurr;
+
+static void putstmode(s,i) stmode s; int *i;{
+ (*i) &= 255 ; /* CLEAR LEFT BYTE */;
+ s <<= 8 ;
+ (*i) |= s ;
+}
+
+void makeproclist(){
+ int p, len ;
+
+ len = 0 ;
+ do
+ {
+ p = next() ;
+ if (p)
+ {
+ len ++ ;
+ if (p > 0)
+ proclist[ len ] = ipmem[ p-1 ] ;
+ else
+ proclist[ len ] = -ipmem[ -p-1 ] ;
+ }
+ } while ( ! ( (p == 0) || (len == MAXPROCLIST) )) ;
+
+ if (p)
+ generror(PROCLTL) ;
+
+ tuple[ qcurr ].arg[ 1 ] = len ;
+}
+
+
+
+
+static void segments(){
+ /* COMPLETES THE QUADRUPLES SEGMENT */
+ /* LABEL 100 ; EXIT AT END-MARKER */
+ bool stop ; /* segment completed */
+/*!!*/ static int op ; /* opcode */ /* static for debugging purposes */
+/*!!*/ static int a, b ; /* first and second argument */
+ int trck2 ;
+/* int n ; */
+ quadruple * curr ; /* gsg for PASCAL WITH translation */
+
+ while (TRUE) /* EXIT ONLY AT END-MARKER */
+ {
+ stop = FALSE ; /* COMPLETE THE SEGMENT */
+ qcurr = 1 ;
+ do /* WITH tuple[ qcurr ] DO BEGIN */
+ { curr = tuple + qcurr ; /* gsg PASCAL WITH statement translation */
+
+ op = next() ; /* Fetch operator */
+
+#if (TALK > 15)
+ printf(" op = %d\n", op) ;
+#endif
+if( op==210 || op==211 ){ printf("|opcode %d|\n",op); getchar(); }
+ if ( (op <= 194) || (op >= 220) )
+ {
+
+ stop = ( ((172 <= op) && (op <= 176)) || ((178 <= op) && (op <= 227)) ) ;
+ /* op in [172..176, 178..227] */
+ curr->opcode = op ;
+ /* Now fetch arguments */
+ switch (opdescr[ op ])
+ {
+ case 0 : break ;
+
+ case 1 :
+ case 2 :
+ case 8 : curr->arg[ 1 ] = next() ;
+ break ;
+
+ case 3 :
+ case 5 :
+ case 9 :
+ case 11 :
+ case 15 : curr->arg[ 1 ] = next() ;
+ curr->arg[ 2 ] = next() ;
+ break ;
+
+ case 4 :
+ case 6 :
+ case 7 :
+ case 10 :
+ case 12 :
+ case 13 :
+ case 14 : curr->arg[ 1 ] = next() ;
+ curr->arg[ 2 ] = next() ;
+ curr->arg[ 3 ] = next() ;
+ break ;
+
+ } /* switch */
+
+ if ( ((223 <= op) && (op <= 225)) || (op == 227) ) /*op in [223..225,227]*/
+ makeproclist() ;
+ qcurr ++ ;
+ }
+ else /* op in 195..219 */
+ if (op == 200)
+ goto label100 ; /* end-marker */
+ else /* SPECIAL CARE OPCODES */
+ {
+ a = next() ;
+ ipmem[ a + 2 ] = 0 ;
+ if ((op < 201 ) || (op > 204))
+ {
+ b = next() ;
+ ipmem[ a+1 ] = b ;
+ }
+ else
+ ipmem[ a+1 ] = 0 ;
+ /* SET DEFAULT VALUES */
+ /*SLOCAL = FALSE; SLIVE = FALSE; SMODE = TEMPVAR; SAP = APINT; */
+ putslocal(FALSE,notrick) ;
+ putslive(FALSE,notrick) ;
+ putstmode(TEMPVAR, ¬rick) ;
+ putsap(APINT,notrick) ;
+
+ switch (op)
+ { /* TEMPORARY VARIABLES */
+ case 201 : break ;
+
+ case 202 : putsap(APFMTYPE,notrick) ; /* == apreal */
+ break ;
+
+ case 203 : putsap(APFMPROC,notrick) ;
+ break ;
+
+ case 204 : /* reference */
+ putsap(APVIRT,notrick) ;
+ putslocal(TRUE,notrick) ;
+ break ;
+
+ /* declared variables */
+ case 205 : putstmode(VARGLOB, ¬rick) ;
+ putsap(apet(b),notrick) ;
+ putslive(TRUE,notrick) ;
+ break ;
+
+ case 206 : putstmode(VARMID, ¬rick) ;
+ putsap(apet(b),notrick) ;
+ putslive(TRUE,notrick) ;
+ break ;
+
+ case 207 : putstmode(VARLOC, ¬rick) ;
+ putsap(apet(b),notrick) ;
+ putslive(TRUE,notrick) ;
+ break ;
+
+ /* real or integer constant */
+ case 197 : putstmode(REALCONST, ¬rick) ;
+ putsap(APREAL,notrick) ;
+ break ;
+
+ case 198 :
+ case 199 : putstmode(INTCONST, ¬rick) ;
+ break ;
+
+ /* temporary but live */
+ case 195 :
+ case 208 : putslocal(TRUE,notrick) ;
+ if (op==195)
+ { /* move&save */
+ trck2 = ipmem[ b ] ;
+ putsap(sap(trck2),notrick) ;
+ }
+ else /* live temporary */
+ putslive(TRUE,notrick) ;
+ curr->opcode = 60 ; /* #limove */
+ /* proper opcode will be chosen further */
+ curr->arg[ 1 ] = a ;
+ curr->arg[ 2 ] = b ;
+ qcurr ++ ;
+ break ;
+ } /* switch */
+
+ ipmem[ a ] = notrick ;
+ } /* SPECIAL CARE OPCODES */
+ } while ( ! (stop || (qcurr > QMAX)) ) ;
+
+ qlast = qcurr - 1 ;
+ if (! stop)
+ generror(STSEQTL) ;
+ back() ; /* establish 'next-use' information */
+ gen() ;
+} /* while true */
+ label100: ; /* end-marker : all has been done */
+
+}
+
+
+
+static void code(){
+ /* TRANSFORMS L-CODE TO L'-CODE BY REDUCTION OF NUMBER OF OPCODES */
+ /* ALLOCATES TEMPORARY VARIABLES */
+
+ /* INSERT 'NONE' INTO THE SYMBOL TABLE */
+ /*cdsw&ail NONE = LMEM-3 ; */
+ none = addrnone ;
+ /* WITH TRICK.STI DO { */ /* CTRP
+ SAP = APVIRT ;
+ SMODE = REALCONST ;
+ SLOCAL = TRUE ;
+ SLIVE = TRUE ;
+ } ; */
+ putsap(APVIRT,notrick) ;
+ putstmode(REALCONST,¬rick) ;
+ putslocal(TRUE,notrick) ;
+ putslive(TRUE,notrick) ;
+ ipmem [ none ] = notrick ;
+ ipmem [ none+1 ] = 0 ; /* --> m [realbase] */
+ ipmem [ none+2 ] = 0 ;
+
+
+ /* CLEAR THE DICTIONARY OF LABELS */
+
+/* memset(m + fre, (char) 0, (MEMLIMIT - fre + 1) * sizeof(address)) ; */
+ for(zmienna = fre; zmienna <= MEMLIMIT; zmienna ++)
+ m[zmienna] = 0 ;
+ /* zerowanie pamieci */
+ /* n = MEMLIMIT ;*/
+
+ segments() ;
+
+ /* END OF CODE PREPARING */
+}
+
+
+void main(argc,argv) int argc; char *argv[];{
+
+/*
+ log = fopen("gen.log", "w") ;
+ if (log == NULL)
+ printf("cannot open dump file\n") ;
+*/
+ base = 0 ;
+
+ m = (address *) calloc(sizeof(address), MEMLIMIT + 1) ;
+
+ puts("") ;
+ puts(" LOGLAN-82 Compiler Version 4.00") ;
+ puts(" January 10, 1993") ;
+ puts(" (C)Copyright Institute of Informatics, University of Warsaw") ;
+ puts(" (C)Copyleft LITA Universite de Pau");
+ puts("\n Pass Two\n") ; fflush(stdout);
+ if(argc < 2){ printf("Usage : %s filename\n",argv[0]); exit(8); }
+#if (TALK >= 1)
+ puts("Setting files...") ; fflush(stdout);
+#endif
+ setfiles(argv[1]) ;
+ fre = 2 ; /* SKIP TWO WORDS RESERVED FOR DUMMY VIRT. */
+ m[fre++] = 0 ; /* dsw*//* free == currfile */
+ m[fre++] = 0 ; /* place for file virtual address */ /*dsw*/
+ strings = fre ; /* START STRING AREA */
+#if (TALK >= 1)
+ puts("Putting strings...") ; fflush(stdout);
+#endif
+ putstrings() ; /* WRITE STRINGS INTO MEMORY */
+ realbase = fre ; /* BASE FOR REAL CONSTANTS */
+#if (TALK >= 1)
+ puts("Initiating...") ; fflush(stdout);
+#endif
+ initiate() ; /* READ IPMEM AND OTHER VARIABLES */
+#if (TALK >= 3)
+ {
+ long seek=ftell(lfile);
+ dump_lcode(argv[1]);
+ fseek(lfile,seek,SEEK_SET);
+ }
+#endif
+#if (TALK >= 1)
+ puts("Putting reals...") ; fflush(stdout);
+#endif
+ putreals() ; /* WRITE REAL CONSTANTS INTO MEMORY */
+#if (TALK >= 1)
+ puts("Generating prototypes...") ; fflush(stdout);
+#endif
+ genprot() ;
+ /* PROTOTYPES ARE NUMBERED MAINBLOCK..LASTPROT */
+
+temporary = base+fre ;
+fre += MAXCOMTEMP + 1 ;
+
+/* mb removed some unimportant comments to improve readability ; cf text2.gen */
+
+#if (TALK >= 1)
+ puts("Outputing...") ; fflush(stdout);
+#endif
+#if (TALK >= 70)
+ for(zmienna = 0; zmienna < fre ; zmienna ++)
+ printf("M DUMP WORD # %lu VALUE %lu\n",
+ (unsigned long int)zmienna,(unsigned long int)(m[zmienna]));
+#endif
+
+ out() ; /*CBC*/
+
+
+/* fre == 0 */
+
+#if (TALK >= 1)
+ puts("Code preparation...") ; fflush(stdout);
+#endif
+ code() ; /* CODE PREPARING */
+
+
+#if (TALK >= 1)
+ puts("Putting debug info...") ; fflush(stdout);
+#endif
+
+/*
+ ts3(argv[1]);
+*/
+
+#if (TALK >= 1)
+ puts("Putting prototypes...") ; fflush(stdout);
+#endif
+
+ outprot() ; /* PUT PROTOTYPES ONTO THE FILE */
+
+/* fclose(log) ;*/
+/* *((int *)0xccL) = 0x1445 ;*/
+
+#if (TALK >= 1)
+ puts("Generation ok.") ; fflush(stdout);
+#endif
+
+}
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+=======================================================================
+*/
+
+#include "glodefs.h"
+
+ /* DATA STRUCTURES COPIED FROM LOGLAN COMPILER */
+#if DEBUG
+ FILE * log;
+#endif
+ /* compiler symbol table and memory */
+int * ipmem ;
+address * m ; /* "SMALL" M , FOR PROTOTYPES OR CODE FOR ONE UNIT ONLY */
+
+int nblus ; /* ADDRESS OF MAIN BLOCK IN IPMEM */
+int nrint ; /* ADDRESS OF TYPE INTEGER IN IPMEM */
+int nrre ;
+ /* ADDRESS OF TYPE REAL IN IPMEM */
+int nrbool ;
+ /* ADDRESS OF TYPE BOOLEAN IN IPMEM */
+int nrchr ;
+ /* ADDRESS OF TYPE CHAR IN IPMEM */
+int nrtext ;
+ /* ADDRESS OF TYPE STRING IN IPMEM */
+int nrcor ;
+ /* ADDRESS OF TYPE COROUTINE IN IPMEM */
+int nrproc ;
+ /* ADDRESS OF TYPE PROCESS IN IPMEM */
+int lpmem ;
+ /* THE LAST INDEX BELOW REAL CONSTANTS */
+int irecn ;
+ /* LAST INDEX OF REAL CONSTANT AREA */
+int lmem ;
+ /* ACTUAL (I.E. FROM COMPILER) SIZE OF IPMEM */
+int addrnone ;
+ /* dsw&ail*/
+
+ /* INFORMATION ADDED INTO IPMEM : */
+
+ /* LOWER ADDRESSES ARE OCCUPIED BY COMPILER SYMBOL TABLE */
+ /* UPPER ADDR. ARE USED IN 'CODE' FOR GENERATOR SYMBOL TABLE. */
+ /* EACH (GENERATOR) SYMBOL TABLE ITEM OCCUPIES 3 WORDS : */
+ /* (+0) = STITEM ( --> CODE) */
+ /* (+1) = VALUE OF CONSTANT */
+ /* OR OFFSET OF TEMPORARY VARIABLE, */
+ /* OR POINTER TO THE ATTRIBUTE DESCRIPTION IN COMP.SYM.TABLE */
+ /* (+2) = NEXT USE (QADDR) */
+
+ /* PROCEDURE 'GENPROT' MODIFIES INFORMATION IN COMPILER SYMBOL TABLE. */
+ /* PROCEDURE 'CODE' NEED THE FOLLOWING EXTRA INFORMATION : */
+
+ /* FOR EACH UNIT: (-1) = PROTADDR */
+ /* (+0) = ADDRESS OF 'AFTER INNER' STATEMENT */
+ /* ( STORED BY 'CODE' ) */
+ /* FOR EACH OBJECT ATTRIBUTE: */
+ /* (-2) = OFFSET */
+ /* (-1) = PROTADDR FOR THAT OBJECT */
+ /* FOR EACH TYPE (CLASS TYPE, FORMAL TYPE OR PRYMITIVE TYPE): */
+ /* (+2) = - ADDRESS OF TYPE DESCRIPTION IN M */
+
+ /* MOREOVER, EXTRA INFORMATION IS STORED TO LINK REFERENCES TO THE TYPES */
+ /* ( --> BACKPATCH) */
+
+address base ; /* TOTAL LENGTH OF JUST PRODUCED CODE;
+ TO BE ADDED TO INDEX IN "SMALL" M */
+address realbase ; /* BASE FOR REAL CONSTANTS */
+
+dprotaddr prefix[ MAXPROT + 1 ] ; /* PROTOTYPE NUMBER OF PREFIX */
+ /* OR DUMMY IF PREFIX ABSENT */
+
+
+
+ /* TYPES OF SOME OBJECTS BELONGING TO THE ADDRESS TYPE HAVE BEEN CHANGED */
+ /* TO INTEGER. THIS HAS BEEN FORCED DUE TO THE REQUIREMENTS OF THE PASCAL */
+ /* COMPILER ACCESSIBLE ON SIEMENS WHICH DEMANDS THAT THE PROCEDURE AND */
+ /* FUNCTION PARAMETERS PASSED BY VARIABLE HAVE STRICTLY THE SAME TYPE AS */
+ /* THEIR FORMAL CORRESPONENTS. */
+
+address offset;
+
+/* Variables of code to follow */
+/* qaddr0 qcurr ; */ /* CURRENT QUADRUPLE */
+qaddr qlast ; /* LAST QUADRUPLE */
+
+quadruple tuple[ QMAX + 1 ] ;
+
+protaddr unitt ; /* CURRENT UNIT */
+int ipunit ; /* UNIT ADDRES IN IPMEM */
+
+
+int notrick ; /* FOR INTEGER <--> STITEM CONVERSION */
+
+ /* M^ [ FIRSTLABEL..MEMLIMIT ] IS USED FOR HANDLING LABELS */
+ /* FOR LABEL L : */
+ /* M^ [ MEMLIMIT-L+1 ] < 0 */
+ /* --> = - VALUE OF ALREADY DEFINED LABEL */
+ /* M^ [ MEMLIMIT-L+1 ] > 0 */
+ /* --> = HEAD OF UNSATISFIED REFERENCES LIST */
+
+int none ; /* ADDRESS OF 'NONE' IN SYMBOL TABLE */
+
+int n ;
+
+ /*CBC added concurrent statements... */
+protaddr proclist[ MAXPROCLIST + 1 ] ;
+
+/* mb vars from back to follow */
+
+qaddr ctpoint ;
+bool nouse ;
+
+
+
+/*mb vars from gen to follow */
+
+filename file_name ; /* text given by the user as a file name */
+
+FILE * lfile ;
+ /* OUTPUT FROM LOGLAN COMPILER: */
+ /* STRINGS, */
+ /* SYMBOL TABLE, */
+ /* L-CODE. */
+ /* */
+ /* PARTICULAR SECTIONS ARE SEPARATED BY '#' OCCURRING IN THE */
+ /* FIRST POSITION OF LINE. ZEROS OCCURRING IN THE SYMBOL TA- */
+ /* BLE ARE COMPRESSED (SEE GETITEM). */
+
+/* TEMPORARY FILES: WRITEN BY GENERATOR, READ BY INTERPRETER */
+FILE * cfile ; /* CODE AND LISTS FOR PROTOTYPES */
+FILE * pfile ; /* PROTOTYPES */
+
+int error ; /* TRUE FOR FAILURE DURING GENERATION */
+
+pointprdsc prototype[MAXPROT + 1] ;
+
+address ipradr ; /* BASE FOR PRIMITIVE TYPES DESCRIPTIONS */
+address temporary ; /* ADDRESS OF GLOBAL TEMPORARY VARIABLES */
+address strings ; /* BASE FOR STRING CONSTANTS */
+protaddr lastprot ; /* THE LAST USED PROTOTYPE NUMBER */
+address fre ; /* FIRST FREE CELL IN M */
+
+
+
+pointer listofref[ MAXPROT + 1 ] ;
+ /* LISTS OF REFERENCE ATTRIBUTES WITH POINTERS TO IPMEM */
+
+longpointer listofpar[ MAXPROT + 1 ] ;
+ /* LISTS OF PRODUCED DESCRPTIONS OF FORMAL PARAMETERS */
+
+int opdescr[] = { 0,
+ 14, 15, 14, 14, 14, 0, 0, 0, 0, 0,
+ 8, 8, 9, 0, 9, 9, 0, 0, 0, 10,
+ 10, 10, 10, 10, 10, 10, 0, 0, 12, 11,
+ 11, 11, 11, 11, 11, 11, 12, 11, 12, 12,
+ 11, 11, 11, 9, 9, 11, 11, 11, 11, 11,
+ 11, 12, 12, 12, 12, 12, 12, 11, 11, 11,
+ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
+ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
+ 11, 11, 11, 12, 12, 12, 12, 12, 12, 12,
+ 12, 12, 12, 12, 12, 12, 12, 12, 12, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 1, 0, 0, 0, 0, 3, 3, 3, 2,
+ 2, 0, 2, 3, 4, 2, 2, 2, 3, 3,
+ 3, 3, 2, 0, 0, 0, 0, 2, 5, 5,
+ 5, 5, 5, 6, 6, 6, 0, 0, 0, 7,
+ 0, 0, 0, 0, 1, 0, 1, 1, 0, 0,
+ 1, 1, 1, 1, 0, 1, 0, 2, 4, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,
+ 0, 0, 0, 0, 0, 0, 0, 2, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 2 };
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+=======================================================================
+*/
+
+#if DEBUG
+ extern FILE * log ;
+#endif
+ /* DATA STRUCTURES COPIED FROM LOGLAN COMPILER */
+
+
+extern int nblus ; /* ADDRESS OF MAIN BLOCK IN IPMEM */
+extern int nrint ; /* ADDRESS OF TYPE INTEGER IN IPMEM */
+extern int nrre ; /* ADDRESS OF TYPE REAL IN IPMEM */
+extern int nrbool; /* ADDRESS OF TYPE BOOLEAN IN IPMEM */
+extern int nrchr ; /* ADDRESS OF TYPE CHAR IN IPMEM */
+extern int nrtext ; /* ADDRESS OF TYPE STRING IN IPMEM */
+extern int nrcor ; /* ADDRESS OF TYPE COROUTINE IN IPMEM */
+extern int nrproc ; /* ADDRESS OF TYPE PROCESS IN IPMEM */
+extern int lpmem ; /* THE LAST INDEX BELOW REAL CONSTANTS */
+extern int irecn ; /* LAST INDEX OF REAL CONSTANT AREA */
+extern int lmem ; /* ACTUAL (I.E. FROM COMPILER) SIZE OF IPMEM */
+extern int addrnone ;
+
+ /* dsw&ail*/
+
+ /* INFORMATION ADDED INTO IPMEM : */
+
+ /* LOWER ADDRESSES ARE OCCUPIED BY COMPILER SYMBOL TABLE */
+ /* UPPER ADDR. ARE USED IN 'CODE' FOR GENERATOR SYMBOL TABLE. */
+ /* EACH (GENERATOR) SYMBOL TABLE ITEM OCCUPIES 3 WORDS : */
+ /* (+0) = STITEM ( --> CODE) */
+ /* (+1) = VALUE OF CONSTANT */
+ /* OR OFFSET OF TEMPORARY VARIABLE, */
+ /* OR POINTER TO THE ATTRIBUTE DESCRIPTION IN COMP.SYM.TABLE */
+ /* (+2) = NEXT USE (QADDR) */
+
+ /* PROCEDURE 'GENPROT' MODIFIES INFORMATION IN COMPILER SYMBOL TABLE. */
+ /* PROCEDURE 'CODE' NEED THE FOLLOWING EXTRA INFORMATION : */
+
+ /* FOR EACH UNIT: (-1) = PROTADDR */
+ /* (+0) = ADDRESS OF 'AFTER INNER' STATEMENT */
+ /* ( STORED BY 'CODE' ) */
+ /* FOR EACH OBJECT ATTRIBUTE: */
+ /* (-2) = OFFSET */
+ /* (-1) = PROTADDR FOR THAT OBJECT */
+ /* FOR EACH TYPE (CLASS TYPE, FORMAL TYPE OR PRYMITIVE TYPE): */
+ /* (+2) = - ADDRESS OF TYPE DESCRIPTION IN M */
+
+ /* MOREOVER, EXTRA INFORMATION IS STORED TO LINK REFERENCES TO THE TYPES */
+ /* ( --> BACKPATCH) */
+
+extern address base ; /* TOTAL LENGTH OF JUST PRODUCED CODE;
+ TO BE ADDED TO INDEX IN "SMALL" M */
+extern address realbase ; /* BASE FOR REAL CONSTANTS */
+
+extern dprotaddr prefix[ MAXPROT + 1 ] ; /* PROTOTYPE NUMBER OF PREFIX */
+ /* OR DUMMY IF PREFIX ABSENT */
+
+
+
+ /* TYPES OF SOME OBJECTS BELONGING TO THE ADDRESS TYPE HAVE BEEN CHANGED */
+ /* TO INTEGER. THIS HAS BEEN FORCED DUE TO THE REQUIREMENTS OF THE PASCAL */
+ /* COMPILER ACCESSIBLE ON SIEMENS WHICH DEMANDS THAT THE PROCEDURE AND */
+ /* FUNCTION PARAMETERS PASSED BY VARIABLE HAVE STRICTLY THE SAME TYPE AS */
+ /* THEIR FORMAL CORRESPONENTS. */
+/* from addressing taken offset : */
+extern address offset;
+extern int opdescr[];
+
+extern protaddr lastprot;
+extern address ipradr;
+extern pointprdsc prototype[];
+extern pointer listofref[];
+extern longpointer listofpar[];
+extern protaddr unitt ;
+extern int ipunit ;
+extern int loctmp ;
+extern int reftmp ;
+extern tmpmap ltmpmap ;
+extern tmpmapdscr * mapdscr[] ;
+extern bool rtmpmap[] ;
+extern bool gtmpmap[] ;
+extern qaddr0 qcurr ;
+extern qaddr ctpoint ;
+extern bool nouse ;
+extern qaddr qlast ;
+extern int notrick ;
+extern address temporary ;
+extern protaddr proclist[] ;
+extern int none ;
+extern address strings ;
+extern int n ;
+extern FILE * lfile ;
+extern FILE * pfile ;
+extern FILE * cfile ;
+
--- /dev/null
+#/* Loglan82 Compiler&Interpreter\r
+# Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+# Copyright (C) 1993, 1994 LITA, Pau\r
+# \r
+# This program is free software; you can redistribute it and/or modify\r
+# it under the terms of the GNU General Public License as published by\r
+# the Free Software Foundation; either version 2 of the License, or\r
+# (at your option) any later version.\r
+# \r
+# This program is distributed in the hope that it will be useful,\r
+# but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+# GNU General Public License for more details.\r
+# \r
+# You should have received a copy of the GNU General Public License\r
+# along with this program; if not, write to the Free Software\r
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+#\r
+# contacts: Andrzej.Salwicki@univ-pau.fr\r
+#\r
+# or Andrzej Salwicki\r
+# LITA Departement d'Informatique\r
+# Universite de Pau\r
+# Avenue de l'Universite\r
+# 64000 Pau FRANCE\r
+# tel. ++33 59923154 fax. ++33 59841696\r
+#\r
+#=======================================================================\r
+#*/\r
+#\r
+# switches SMALL/LARGE/HUGE switch between :\r
+# 16-bit small, 16-bit large and 32-bit memory models\r
+
+SHELL=/bin/sh
+OBJ=gen.o mainvar.o genio.o lists.o genprot.o oxen.o back.o logen.o deb.o lcode.o
+
+#change this according to your system\r
+
+#CC=cl -Oelsgc -DSMALL -DTALK=0 -AC -Fo$*.o # MSC small\r
+#CC=cl -Oelsgc -DLARGE -DTALK=0 -AC -Fo$*.o # MSC large\r
+#CC=gcc -O -m486 -DHUGE -DTALK=20 # GCC\r
+CC=gcc -DHUGE -DNO_PROTOTYPES -DTALK=0 # SUN\r
+#CC=cc -Oactl -CSON -W2 -DHUGE -DTALK=0 # SCO\r
+
+target : gen
+
+# UNIX 32-bit version\r
+gen : $(OBJ)
+ $(CC) $(OBJ) -o gen
+ strip gen
+# cp gen $(HOME)/bin
+
+# GCC version HUGE 32-bit memory\r
+gen32.exe : $(OBJ)\r
+ $(CC) $(OBJ) -o gen.out\r
+ aout2exe gen.out\r
+ rm gen.out\r
+\r
+# MSC version LARGE 16-bit memory\r
+gen.exe : $(OBJ)\r
+ link /e $(OBJ)\r
+\r
+# MSC version SMALL 16-bit memory\r
+hgen.exe : $(OBJ)\r
+ link /e $(OBJ)\r
+
+.c.o :
+ $(CC) -c $*.c
+
+clean :
+ rm *.o gen
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+=======================================================================
+*/
+
+/**********************************************************/
+/* auxiliary functions for GEN */
+/* Written according to NEW m & ipmem declarations */
+/* Last modified : Mar-01-90 */
+/**********************************************************/
+
+#include <memory.h>
+#include "glodefs.h"
+
+address firstlabel;
+
+ /* static void globrelease(address n, app ap); */
+ /* releases temporary variable with appetite ap and */
+ /* address n within global area */
+
+
+#ifndef NO_PROTOTYPES
+
+static void globrelease(address,app);
+static int globspace(app);
+static void result(argnr);
+
+#else
+
+static void globrelease();
+static int globspace();
+static void result();
+
+#endif
+
+
+
+args_struct args[4];
+ /* M^ [ FIRSTLABEL..MEMLIMIT ] IS USED FOR HANDLING LABELS */
+ /* FOR LABEL L : */
+ /* M^ [ MEMLIMIT-L+1 ] < 0 */
+ /* --> = - VALUE OF ALREADY DEFINED LABEL */
+ /* M^ [ MEMLIMIT-L+1 ] > 0 */
+ /* --> = HEAD OF UNSATISFIED REFERENCES LIST */
+
+
+bool gtmpmap[ TEMPGUARD + 1 ] ;
+ /* MAP OF GLOBAL NON-REFERENCE TEMPORARY VARIABLES */
+
+bool rtmpmap[ MAXREFTEMP + 1 ] ;
+ /* MAP OF (LOCAL) REFERENCE TEMPORARY VARIABLES */
+
+tmpmap ltmpmap ;
+ /* MAP OF (LOCAL) NON-REFERENCE TEMPORARY VARIABLES */
+ /* TRUE STANDS FOR AVAILABLE WORD, FALSE FOR OCCUPIED ONE */
+
+int loctmp ; /* MAXIMAL NUMBER OF ALREADY USED WORDS FOR
+ LOCAL (NON-REFERENCE) TEMPORARY VARIABLES */
+
+int reftmp ; /* MAXIMAL NUMBER-1 OF ALREADY USED PAIRS OF WORDS
+ FOR REFERENCE TEMPORARY VARIABLES */
+
+tmpmapdscr * mapdscr[ MAXPROT + 1 ] ;
+ /* FOR CLASS ONLY : MAP OF TEMPORARIES USED AT 'INNER' */
+
+qaddr0 qcurr;
+/**********************************************************/
+
+
+
+void deflabel(lab)
+int lab;
+ /* DEFINES NEW LABEL AND SATISFIES REFERENCES (IF ANY) */
+{
+ address n, k ;
+
+ n = MEMLIMIT - lab + 1;
+ if (n < firstlabel)
+ if (n < fre)
+ generror(MEMOVF) ;
+ else
+ firstlabel = n ;
+ k = m [ n ] ;
+ m [ n ] = -(fre+base);
+ while (k > 0)
+ {
+ n = m [ k ] ;
+ m [ k ] = fre + base ;
+ k = n ;
+ }
+} /* DEFLABEL */
+
+
+void uselabel(lab) address lab;{
+ address n ; /* MAINTAINS THE USE OF LABEL LAB AT ADDRESS fre */
+
+ n = MEMLIMIT - lab + 1 ;
+ if (n < firstlabel)
+ if(n < fre) generror(MEMOVF) ;
+ else firstlabel = n ;
+ if (m [ n ] < 0) /* ALREADY DEFINED */
+ m [ fre ] = -m [ n ] ;
+ else /* ADD TO THE LIST OF UNSATISFIED REFERENCES */
+ {
+ m [ fre ] = m [ n ] ;
+ m [ n ] = fre ;
+ }
+
+} /* USELABEL */
+
+
+
+/* THE BEGINNING OF UNIT DESCRIBED AT 'IP' */
+
+void begunit(ip) int ip;{
+ int i,k;
+ pointprdsc prot = prototype[ipmem[ ip - 1 ]];
+
+ unitt = ipmem[ ip-1 ] ;
+ ipunit = ip ;
+
+ prot = prototype[unitt] ;
+ prot->codeaddr = fre + base;
+ if (prot->lthpreflist > 1){ /* prefixed unit */
+
+ k = prefix[ unitt ];
+ /* ltmpmap = mapdscr[k]->map ;*/
+ for (i=0; i<= MAXLOCTEMP; i++) ltmpmap[i] = mapdscr[k]->map[i];
+
+ loctmp = mapdscr[k]->locsize ;
+ reftmp = mapdscr[k]->refsize ;
+
+ }else{
+
+ for (k = 1; k<= MAXLOCTEMP; k++) ltmpmap[k] = TRUE; /* index negated */
+
+ /* fillword(ltmpmap + 1, (char) TRUE, MAXLOCTEMP) ;
+
+ k = MAXLOCTEMP ; */
+
+ loctmp = 0 ;
+ reftmp = -1 ;
+ }
+
+ for (k = 0; k <= MAXREFTEMP; k++) rtmpmap[ k ] = TRUE ;
+
+ /* memset(rtmpmap, (char) TRUE, MAXREFTEMP + 1) ;*/
+
+ for (k = 1; k <= TEMPGUARD; k++) gtmpmap[ k ] = TRUE ;
+
+ /* memset(gtmpmap + 1, (char) TRUE, TEMPGUARD) ; */
+
+
+ firstlabel = MEMLIMIT; /* IN FACT, MEMLIMIT+1 */
+
+ m[0]=m[MEMLIMIT]=0;
+ /* for (k = 0; k <= MEMLIMIT; k++) m[k]=0; */
+ /* memset( (char *)m, 0, (MEMLIMIT + 1)*sizeof(m[0]) ); */
+}
+
+void endunit(){
+ address systsize;
+ pointprdsc prot;
+ tmpmapdscr *mapd;
+
+ out() ;
+ /* with prototype[ unitt ] ^ do*/
+ { prot = prototype[ unitt ] ;
+ if(unitt != MAINBLOCK)
+ if ((prot->kind == CLASS) || (prot->kind == LRECORD)
+ || (prot->kind == COROUTINE) || (prot->kind == PROCESS))
+ /*with mapdscr[ unitt ]^ do*/
+ { mapd = mapdscr[unitt] ;
+ mapd ->locsize = loctmp ;
+ mapd ->refsize = reftmp ;
+ }
+ switch(prot->kind)
+ {
+ case LRECORD : systsize = 0 ;
+ break ;
+ case CLASS :
+ case BLOCK :
+ case PREFBLOCK : systsize = 2*(APREF+APINT) ;
+ /* sl, dl, lsc, status sl */
+ break ;
+ case LFUNCTION :
+ case LPROCEDURE : systsize = 3*APREF+2*APINT ;
+ /* sl, dl, rpcdl, lsc, status sl */
+ /*cbc add rpcdl field for procedures and functions...*/
+ break ;
+ case COROUTINE : systsize = 3*APREF+2*APINT ;
+ /* sl, dl, cl, lsc, status sl */
+ break ;
+ case PROCESS : systsize = 5*APREF+2*APINT+2*(lastprot+1);
+ /* sl, dl, cl, chd, virtsc, lsc, statsl, display, display2 */
+ break;
+ case HANDLER : systsize = 2*APREF+3*APINT ;
+ /* sl, dl, lsc, status sl, signal nr */
+ break ;
+ } /* switch */
+ prot->span = prot->appetite + loctmp;
+ prot->appetite = prot->span + (reftmp + 1) * APREF + systsize;
+ if (prot->appetite > MAXAPPT)
+ generror(OBJTOLG);
+ } /* with prototype */;
+
+ /* clear dictionary of labels */
+ for(systsize = firstlabel; systsize <= MEMLIMIT; systsize++)
+ m [ systsize ] = 0 ;
+
+ /* memset(m+firstlabel, (char)0, (MEMLIMIT-firstlabel+1)*sizeof(address)); */
+}
+
+
+static int globspace(ap) app ap;{
+
+ /* returns offset of the new temporary variable allocated in global area */
+ /* indexed 1..maxcomtemp */
+
+ int n ; /* 0..tempguard;*/
+
+ n = 0 ;
+ switch(ap)
+ {
+ case 1 : while (!gtmpmap[ ++n ]) ; /*not guarded */
+ if (n > MAXCOMTEMP)
+ generror(TMTEMP) ;
+ else
+ gtmpmap[ n ] = FALSE;
+ break ;
+ case 2 : do
+ {
+ n++ ;
+ n++ ;
+ }
+ while (!(gtmpmap[ n ] && gtmpmap[ n+1 ])) ;
+ if (n >= MAXCOMTEMP )
+ generror(TMTEMP) ;
+ else
+ {
+ gtmpmap[ n ] = FALSE ;
+ gtmpmap[ n + 1 ] = FALSE ;
+ }
+ break ;
+ case 3 : do
+ n += 3 ;
+ while(!(gtmpmap[ n ] && gtmpmap[ n+1 ] && gtmpmap[ n+2 ])) ;
+ if (n > MAXCOMTEMP - 2)
+ generror(TMTEMP) ;
+ else
+ {
+ gtmpmap[ n ] = FALSE ;
+ gtmpmap[ n+1 ] = FALSE ;
+ gtmpmap[ n+2 ] = FALSE ;
+ }
+ break ;
+ } /* switch */;
+
+ return(n) ;
+ } /* globspace */
+
+static void globrelease(n,ap) address n; app ap;{
+
+ /* releases temporary variable with appetite ap and */
+ /* address n within global area */
+
+ gtmpmap[ n ] = TRUE;
+ switch(ap)
+ {
+ case 1 : break ;
+ case 2 : gtmpmap[ n+1 ] = TRUE ;
+ break ;
+ case 3 : gtmpmap[ n+1 ] = TRUE ;
+ gtmpmap[ n+2 ] = TRUE ;
+ break ;
+ } /* switch */
+}
+
+int locspace (ap)
+app ap ;
+ /* returns offset of the new temporary variable allocated within local area */
+ /* indexed -maxloctemp .. -1 for non-reference or */
+ /* 0 .. maxreftemp for reference values */
+
+/* label 77; exit when successed */
+{
+ int n ;
+
+ if (ap == APVIRT) /* REFERENCE */
+ {/* reference variable, indexed 0..maxreftemp */
+ n = 0;
+ while ( !rtmpmap[ n ] && (n < MAXREFTEMP))
+ ++n ;
+ if (rtmpmap[ n ])
+ {
+ rtmpmap[ n ] = FALSE;
+ if (n > reftmp)
+ reftmp = n ;
+ }
+ else
+ generror(TMTEMP);
+ return (n * APREF);
+ }
+ else
+ { /* non-reference, indexed 1..maxloctemp */
+ n = ap ;
+ while (n <= MAXLOCTEMP)
+ { if (ltmpmap[ n ])
+ switch (ap)
+ { case 1 : ltmpmap[ n ] = FALSE ;
+ goto label77 ;
+
+
+ case 2 : if (ltmpmap[ n-1 ])
+ { ltmpmap[ n ] = FALSE ;
+ ltmpmap[ n-1 ] = FALSE ;
+ goto label77 ;
+ }
+ break ;
+
+ case 3 : if (ltmpmap[ n-1 ] && ltmpmap[ n-2 ])
+ { ltmpmap[ n ] = FALSE ;
+ ltmpmap[ n-1 ] = FALSE ;
+ ltmpmap[ n-2 ] = FALSE ;
+ goto label77;
+ }
+ break ;
+ } /* switch */
+
+ /*dsw else*/
+
+ n += ap ;
+ } /* while */;
+ /* exit on failure */
+ generror(TMTEMP) ;
+
+ label77 : /* found */
+ if (n > loctmp)
+ loctmp = n ;
+ return (-n) ;
+ } /* non-reference */
+} /*locspace */
+
+void locrelease(n, ap)
+address n;
+app ap ;
+
+/* releases temporary variable of appetite ap allocated at address n */
+/* within local area */
+
+{
+ if (ap == APVIRT) /* reference variable */
+ rtmpmap[ n / APREF ] = TRUE ;
+ else{ /* non-reference */
+ /*cmb indices to ltmpmap negated cmb*/
+ ltmpmap[ -n ] = TRUE ;
+ switch( ap ){
+ case 1 : break ;
+ case 2 : ltmpmap[ -n - 1 ] = TRUE ;
+ break ;
+ case 3 : ltmpmap[ -n - 1 ] = TRUE ;
+ ltmpmap[ -n - 2 ] = TRUE ;
+ break ;
+ }
+ }
+} /* locrelease */
+
+
+ void force(n, m, o1, o2)
+ /* FORCES THE N-TH ARGUMENT TO BE OF M-MODE WITH PARAMETERS O1,O2 */
+argnr n ;
+addrmode m ;
+address o1, o2 ;
+
+{ args_struct * curr ; /* gsg for PASCAL WITH translation */
+ curr = args + n ; /* WITH ARGS[ N ] DO BEGIN */
+
+ { curr->mode = m ;
+ curr->off1 = o1 ;
+ curr->off2 = o2 ;
+ }
+} /* force */
+/**********************************************************/
+
+
+ void forceconst(n)
+ /* FORCES THE N-TH ARGUMENT TO BE A CONSTANT */
+argnr n ;
+{ args_struct * curr ; /* gsg for PASCAL WITH translation */
+
+ curr = args + n ;
+/* WITH ARGS[ N ] DO BEGIN */
+ { curr->mode = CONSTANT ;
+ curr->off1 = tuple[ qcurr ].arg[ n ] ;
+ }
+} /* forceconst */
+/**********************************************************/
+
+
+
+ void forceprot(n)
+ /* FORCES THE N-TH ARGUMENT TO BE A PROTOTYPE NUMBER AS A CONSTANT */
+argnr n ;
+{ args_struct * curr ; /* gsg for PASCAL WITH translation */
+
+ curr = args + n ;
+/* WITH ARGS[ N ] DO BEGIN */
+ { curr->mode = CONSTANT ;
+ curr->off1 = ipmem[ tuple[ qcurr ].arg[ n ] - 1 ] ;
+ }
+} /* forceprot */
+/**********************************************************/
+
+ void argument(n)
+/* PUTS THE DESCRIPTION OF THE N-TH ARGUMENT INTO ARGS[N] */
+/* FOR TEMPORARY VARIABLES WITH NO NEXT USE AND NOT LIVE */
+/* THE CORRESPONDING IS RELEASED */
+
+argnr n ;
+{
+ address w1 ; /* ( + 1) WORD OF SYMBOL TABLE ITEM */
+/* qaddr0 nextuse ; */
+ quadruple * curr1 ; /* gsg for PASCAL WITH translation */
+ args_struct * curr2 ; /* gsg for PASCAL WITH translation */
+ int ad ;
+
+ curr1 = tuple + qcurr ;
+ curr2 = args + n ;
+/* WITH TUPLE[ QCURR ] DO BEGIN */
+ {
+ ad = curr1->arg[n] ;
+ notrick = ipmem[ ad ] ;
+ w1 = ipmem[ ++ad ] ;
+/* WITH ARGS[ N ] DO BEGIN */ /* WITH TRICK.STI DO */
+ {
+ switch (smode(notrick)) {
+/*CBC Replaced global absolute addressing by dot access to MAIN block object */
+/*CBC VARGLOB : { MODE = GLOBAL ; OFF1 = ipmem[ W1-2 ] + MAIN } */
+
+ case VARGLOB : curr2->mode = DOTACCESS ;
+ curr2->off1 = ipmem[ w1-2 ] ;
+ curr2->off2 = MAINBLOCK ;
+ break ;
+
+ case VARLOC : curr2->mode = LOCAL ;
+ curr2->off1 = ipmem[ w1 - 2 ] ;
+ break ;
+
+/*CBC Added new addressing mode for remote access through DISPLAY */
+ case VARMID : curr2->mode = DOTACCESS ;
+ curr2->off1 = ipmem[ w1 - 2 ] ;
+ curr2->off2 = /* DISPLAY + */ ipmem[ w1 - 1 ] ;
+ break ;
+
+ case TEMPVAR : if (slocal(notrick))
+ {
+ curr2->mode = TEMPLOCAL ;
+ curr2->off1 = w1 ;
+ if ( (curr1->nxtuse[ n ]==0) && (! slive(notrick)) )
+ locrelease(w1, sap(notrick)) ;
+ } /* slocal */
+ else
+ {
+ curr2->mode = GLOBAL ;
+ curr2->off1 = w1 + temporary ;
+ if ((curr1->nxtuse[ n ]==0) && (! slive(notrick)) )
+ globrelease(w1, sap(notrick)) ;
+ } /* else */
+ break ;
+
+ case INTCONST : curr2->mode = IMMEDIATE ;
+ curr2->off1 = w1 ;
+ break ;
+
+ case REALCONST : curr2->mode = GLOBAL ;
+ curr2->off1 = realbase + w1 ;
+ break ;
+
+ } /* switch */
+ } /* WITH ARGS */
+ } /* WITH TUPLE */
+} /* argument */
+/**********************************************************/
+
+
+static void result(n) argnr n;{
+
+ /* PUTS THE DESRIPTION OF N-TH ARGUMENT ( BEING DEFINED ) INTO ARGS[N]. */
+ /* FOR THE TEMPORARY VALUE THE NEW SPACE IS ASSIGNED */
+
+ int w1 ; /* ( + 1) WORD OF SYMBOL TABLE ITEM */
+ quadruple * curr1 ; /* gsg for PASCAL WITH translation */
+ args_struct * curr2 ; /* gsg for PASCAL WITH translation */
+
+ /* int globspace(app) ; */
+
+ curr1 = tuple + qcurr ;
+ curr2 = args + n ;
+/* WITH TUPLE[ QCURR ] DO BEGIN */
+ { notrick = ipmem[ curr1->arg[ n ] ] ;
+ w1 = ipmem[ curr1->arg[ n ] + 1 ] ;
+/* WITH ARGS[ N ] DO BEGIN */ /* WITH TRICK.STI DO */
+ {
+ switch (smode(notrick)) {
+/*CBC Replaced global absolute addressing by dot access to MAIN block object */
+/*CBC VARGLOB : { MODE = GLOBAL ; OFF1 = (ipmem)[ W1-2 ] + MAIN } */
+ case VARGLOB : curr2->mode = DOTACCESS ;
+ curr2->off1 = ipmem[ w1-2 ] ;
+ curr2->off2 = MAINBLOCK ;
+ break ;
+
+ case VARLOC : curr2->mode = LOCAL ;
+ curr2->off1 = ipmem[ w1-2 ] ;
+ break ;
+
+/*CBC Added new addressing mode for remote access through DISPLAY */
+ case VARMID : curr2->mode = DOTACCESS ;
+ curr2->off1 = ipmem[ w1 - 2 ] ;
+ curr2->off2 = /* DISPLAY + */ ipmem[ w1 - 1 ] ;
+ break ;
+
+ case TEMPVAR : /* ALLOCATE IT */
+ if (slocal(notrick))
+ { /* CANNOT USE GLOBAL TEMPORARIES */
+ args[ n ].mode = TEMPLOCAL ;
+ curr2->off1 = locspace(sap(notrick)) ;
+ ipmem[ curr1->arg[ n ] + 1 ] = curr2->off1 ;
+ }
+ else
+ { /* GLOBAL AREA MAY BE USED */
+ args[ n ].mode = GLOBAL ;
+ curr2->off1 = globspace(sap(notrick)) ;
+ ipmem[ curr1->arg[ n ] + 1 ] = curr2->off1 ;
+ curr2->off1 += temporary ;
+ }
+ break ;
+
+ case INTCONST :
+ case REALCONST : /* IMPOSSIBLE */
+ break ;
+ } /* switch */
+ } /* WITH ARGS */
+ } /* WITH TUPLE */
+} /* result */
+
+
+
+ void emit()
+{ ieopc trick ;
+ argnr i ;
+ args_struct * curr ; /* gsg for PASCAL WITH translation */
+
+#if (TALK > 31)
+ printf("on entrance to emit fre == %d\n", fre) ;
+#endif
+ for (i = 1; i <= 3 ; i++)
+ trick.c2.eop.args[ i ] = (char)(args[ i ].mode) ;
+ trick.c2.eop.args[ 0 ] = (char)(tuple[ qcurr ].opcode) ; /* opcode */
+
+#if SMALL
+ m[ fre ] = trick.c0.int1f ;
+ m[ fre + 1 ] = trick.c0.int2f ;
+ LOG(fre);
+ LOG(fre + 1);
+#elif LARGE || HUGE
+ m[ fre ] = trick.c1.intf ;
+ LOG(fre);
+#endif
+
+#if (TALK > 15)
+ printf(" emit %d\n", trick.c2.eop.args[0]);
+#endif
+
+ fre += APOPCODE ;
+
+ for (i = 1; i <= 3; i++) /* WITH ARGS[ I ] DO */
+ { curr = args + i ; /* gsg PASCAL WITH translation */
+
+ if (curr->mode != NOARGUMENT)
+ {
+ m[ fre ] = curr->off1 ;
+ fre += APINT ;
+ if ( (curr->mode == REMOTE) || /*cbc*/ (curr->mode == DOTACCESS) )
+ {
+ m[ fre ] = curr->off2 ;
+ fre += APINT ;
+ }
+ }
+ }
+ if (fre >= firstlabel)
+ generror(MEMOVF) ;
+#if (TALK > 31)
+ printf("on exit from emit fre == %d\n", fre) ;
+#endif
+} /* emit */
+
+
+ void defaultargs()
+ /* PREPARES DEFAULT DESCRIPTIONS OF ARGUMENTS */
+
+{
+ int d ;
+ /* void result(argnr) ; */
+
+ for (d = 1; d <= 3; d++)
+ args[ d ].mode = NOARGUMENT ;
+ d = opdescr[tuple[qcurr].opcode ] ; /*!!*/
+ if (d < 8)
+ /* NO RESULTS */
+ switch (d)
+ { case 0 : break ;
+
+ case 1 : forceconst(1) ;
+ break ;
+
+ case 2 : argument(1) ;
+ break ;
+
+ case 3 : argument(1) ;
+ forceconst(2) ;
+ break ;
+
+ case 4 : argument(1) ;
+ forceconst(2) ;
+ forceconst(3) ;
+ break ;
+
+ case 5 : argument(1) ;
+ argument(2) ;
+ break ;
+
+ case 6 : argument(1) ;
+ argument(2) ;
+ forceconst(3) ;
+ break ;
+
+ case 7 : argument(1) ;
+ argument(2) ;
+ argument(3) ;
+ break ;
+
+ } /* switch */
+ else
+ { /* AT LEAST ONE RESULT */
+ if (d < 14) /* 1 RESULT */
+ switch (d)
+ { case 8 : break ;
+
+ case 9 : forceconst(2) ;
+ break ;
+
+ case 10 : forceconst(2) ;
+ forceconst(3) ;
+ break ;
+
+ case 11 : argument(2) ;
+ break ;
+
+ case 12 : argument(2) ;
+ forceconst(3) ;
+ break ;
+
+ case 13 : argument(2) ;
+ argument(3) ;
+ break ;
+
+ } /* switch */
+
+ else { /* 2 RESULTS */
+ if (d == 14)
+ if (tuple[qcurr].opcode >= 4)
+ argument(3) ; /*!!*/
+ /* open , slopen */
+ else forceconst(3) /* openrc , raise */ ;
+ result(2) ;
+ } /* 2 results */
+
+ result(1) ;
+ } /* at least one result */
+
+ } /* defaultargs */
+
+
+ void esac()
+ /* PRODUCES A DESCRIPTION OF 'CASE' */
+{
+ int n,trick;
+ int lab,labnr,othrlab;
+ int val,valuee;
+ address tofill ;
+
+ /* WITH TUPLE[ QCURR ] DO */
+ {
+ labnr = next() ; /* number of labels */
+ othrlab = next() ; /* 'otherwise' label */
+ deflabel(othrlab - 1) ;/* 'switch' description label */
+ m[ fre ] = next() ; /* minimal value of 'switch' expression */
+ tofill = fre + 1 ; /* to be filled with the number of branches */
+ fre += 2 ;
+ val = 0 ;
+ for (n = 1; n <= labnr; n++)
+ {
+ trick = next() ;
+ valuee = iand(ishft(trick,-8),255) ;
+ lab = iand(trick,255) ;
+ while (val < valuee)
+ {
+ uselabel(othrlab) ;
+ fre ++ ;
+ val ++ ;
+ } /* while */
+ uselabel(othrlab + lab) ;
+ fre ++ ;
+ val ++ ;
+ } /* for */
+ m[ tofill ] = val ;
+ } /* with */
+} /* esac */
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+=======================================================================
+*/
+
+/**********************************************************/
+/* auxiliary functions for GEN */
+/* Written according to NEW m & ipmem declarations */
+/* Last modified : May-08-89 */
+/**********************************************************/
+
+#ifndef NO_PROTOTYPES
+
+int next(void);
+
+ /* M^ [ FIRSTLABEL..MEMLIMIT ] IS USED FOR HANDLING LABELS */
+ /* FOR LABEL L : */
+ /* M^ [ MEMLIMIT-L+1 ] < 0 */
+ /* --> = - VALUE OF ALREADY DEFINED LABEL */
+ /* M^ [ MEMLIMIT-L+1 ] > 0 */
+ /* --> = HEAD OF UNSATISFIED REFERENCES LIST */
+
+
+
+/**********************************************************/
+
+void deflabel(int);
+void begunit(int);
+void uselabel(address);
+void endunit(void);
+
+int locspace(app);
+void locrelease(address,app);
+
+ /* returns offset of the new temporary variable allocated in global area */
+ /* indexed 1..maxcomtemp */
+
+ /* returns offset of the new temporary variable allocated within local area */
+ /* indexed -maxloctemp .. -1 for non-reference or */
+ /* 0 .. maxreftemp for reference values */
+
+/* extern void locrelease(address n, app ap); */
+/* releases temporary variable of appetite ap allocated at address n */
+/* within local area */
+
+
+void force(argnr,addrmode,address,address);
+void forceconst(argnr);
+void forceprot(argnr);
+void argument(argnr);
+
+ /* void force(argnr n, addrmode m, address o1, address o2); */
+ /* forces the n-th argument to be of m-mode with parameters o1,o2 */
+
+ /* void forceconst(argnr n) ;*/
+ /* forces the n-th argument to be a constant */
+
+ /* extern void forceprot(argnr n); */
+ /* forces the n-th argument to be a prototype number as a constant */
+
+ /* extern void argument(argnr n); */
+/* puts the description of the n-th argument into args[n] */
+/* for temporary variables with no next use and not live */
+/* the corresponding is released */
+
+ /* static void result(argnr n); */
+ /* puts the desription of n-th argument ( being defined ) into args[n]. */
+ /* for the temporary value the new space is assigned */
+
+void emit(void);
+
+void defaultargs(void);
+ /* prepares default descriptions of arguments */
+
+void esac(void);
+ /* produces a description of 'case' */
+
+
+#else
+
+
+int next();
+void deflabel();
+void begunit();
+void uselabel();
+void endunit();
+int locspace();
+void locrelease();
+void force();
+void forceconst();
+void forceprot();
+void argument();
+void emit();
+void defaultargs();
+void esac();
+
+#endif
+
--- /dev/null
+@echo off\r
+:begin\r
+if "%1" == "" goto :end\r
+echo %1\r
+del %1\r
+shift\r
+goto :begin\r
+:end\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#if DLINK\r
+#include "dlink.h"\r
+#elif TCPIP\r
+#include "tcpip.h"\r
+#endif\r
+\r
+\r
+/* IIUW LOGLAN-82 Executor */\r
+/* Written in PASCAL by P.Gburzynski and A.Litwiniuk. */\r
+/* Modified by J.Findeisen, T.Przytycka, D.Szczepanska, B.Ciesielski. */\r
+/* Hand translated to C by B. Ciesielski. */\r
+
+
+#ifndef NO_PROTOTYPES
+static void load(char *);
+static void initiate(int,char **);
+int main(int,char **);
+#else
+static void load();
+static void initiate();
+int main();
+#endif
+\r
+\r
+/* Macro to decode addressing modes : */\r
+#define getargument(a, argnr) \\r
+ switch (eop->args[ argnr ]) \\r
+ { \\r
+ case GLOBAL : a = M[ ic++ ]; break; \\r
+ case LOCAL : a = c1+M[ ic++ ]; break; \\r
+ case TEMPLOCAL : a = c2+M[ ic++ ]; break; \\r
+ case REMOTE : a = M[ M[ ic+1 ] ]+M[ ic ]; ic+=2; break;\\r
+ case INDIRECT : a = M[ M[ ic++ ] ]; break;\\r
+ case IMMEDIATE : a = ic++; break;\\r
+ case CONSTANT : a = M[ ic++ ]; break;\\r
+ case DOTACCESS : a = M[ display+M[ ic+1 ] ]+M[ ic ]; ic += 2; break;\\r
+ case NOARGUMENT : return; \\r
+ }\r
+\r
+\r
+static void load(_filename) /* Load code and prototypes from file */\r
+ char *_filename;\r
+{\r
+ FILE *fp;\r
+ char *cp;\r
+ word n, left;\r
+ char filename[100]; /* should suffice on all systems */\r
+\r
+ strcpy( filename, _filename );\r
+\r
+ M = mallocate(memorysize+1); /* allocate main memory array */\r
+ if (M == NULL) abend("Memory size too large (use /m option)\n");\r
+\r
+ addext(filename, ".ccd");\r
+ if ((fp = fopen(filename, BINARYREAD)) == NULL)\r
+ abend("Cannot open .ccd file\n");\r
+\r
+ ic = 0; /* read static data and code */\r
+ left = memorysize+1; /* from .ccd file */\r
+ do\r
+ {\r
+ if (left == 0) abend("Memory size too small (use /m option)\n");\r
+ n = min(IOBLOCK/sizeof(word), left);\r
+ n = fread((char *) &M[ ic ], sizeof(word), (int) n, fp);\r
+ ic += n;\r
+ left -= n;\r
+ } while (n != 0); /* now ic = number of words read */\r
+\r
+ fclose(fp);\r
+ /* Get various addresses passed by GENERATOR */\r
+ ipradr = M[ ic-5 ]; /* primitive type desctriptions */\r
+ temporary = M[ ic-4 ]; /* global temporary variables */\r
+ strings = M[ ic-3 ]; /* string constants */\r
+ lastprot = M[ ic-2 ]; /* last prototype number */\r
+ freem = M[ ic-1 ]; /* first free word in memory */\r
+\r
+ /* Read prototypes from .pcd file */\r
+ addext(filename, ".pcd");\r
+ if ((fp = fopen(filename, BINARYREAD)) == NULL)\r
+ abend("Cannot open .pcd file\n");\r
+ for (n = MAINBLOCK; n <= lastprot; n++ )\r
+ {\r
+ cp = ballocate(sizeof(protdescr));\r
+ if (cp == NULL) abend("Memory size too large (use /m option)\n");\r
+ prototype[ n ] = (protdescr *) cp;\r
+ if (fread(cp, sizeof(protdescr), 1, fp) != 1)\r
+ abend("Cannot read .pcd file\n");\r
+ }\r
+ fclose(fp);\r
+\r
+ /* Open trace file */\r
+ if (debug)\r
+ {\r
+ addext(filename, ".trd");\r
+ if ((tracefile = fopen(filename, "w")) == NULL)\r
+ abend("Cannot open .trd file\n");\r
+ }\r
+} /* end load */\r
+\r
+\r
+static void initiate(argc, argv) /* Establish configuration parameters */\r
+int argc;\r
+char **argv;\r
+{\r
+ long m;\r
+ int c;\r
+ char *filename=NULL;\r
+\r
+ fprintf(stderr,"\n LOGLAN-82 Concurrent Executor Version 4.51\n");\r
+ fprintf(stderr," January 21, 1993\n");\r
+ fprintf(stderr,\r
+ " (C) Copyright Institute of Informatics University of Warsaw\n");\r
+ fprintf(stderr," (C) Copyleft LITA Universite de Pau\n");\r
+#if DLINK\r
+ fprintf(stderr," D-LINK version 3.21\n\n");\r
+#elif TCPIP\r
+ fprintf(stderr," TCPIP version 0.9\n\n");\r
+#else\r
+ fprintf(stderr,"\n");\r
+#endif\r
+ fflush(stderr);\r
+\r
+#if DLINK\r
+ ournode = net_logon(msginterrupt);\r
+ if (ournode >= 0) /* network driver installed */\r
+ network = TRUE;\r
+ else /* network driver not installed */\r
+ {\r
+ network = FALSE;\r
+ ournode = 0; /* only node 0 is available */\r
+ }\r
+#else\r
+ network = FALSE;\r
+ ournode = 0;\r
+#endif\r
+ argc--,argv++;\r
+\r
+ for( ; argc>0; argc--,argv++ ){\r
+ if( filename != NULL ) usage();\r
+ if( (*argv)[0]=='-' )\r
+ switch( (*argv)[1] ){\r
+\r
+ case 'i' :\r
+ infmode = TRUE;\r
+ break;\r
+\r
+ case 'd' :\r
+ debug = TRUE;\r
+ break;\r
+\r
+ case 'r' :\r
+#if DLINK\r
+ if (!network)\r
+ abend("D-Link Network Driver Version 3.21 must be installed\n");\r
+ argv++,argc--;\r
+ if( argc==0 ) usage();\r
+ if( sscanf( *argv, "%d", &c ) != 1 ) usage();\r
+ if( c < 0 || c >= 255 || c == ournode )\r
+ abend("Invalid console node number\n");\r
+ console = c;\r
+ remote = TRUE;\r
+#elif TCPIP\r
+ argv++,argc--;\r
+ if( argc==0 ) usage();\r
+ if( sscanf( *argv, "%d", &c ) != 1 ) usage();\r
+ if( c < 0 || c >= 255 )\r
+ abend("Invalid my console node number\n");\r
+ ournode = console = c;\r
+ argv++,argc--;\r
+ if( argc==0 ) usage();\r
+ /* here we test if we are remote */\r
+ /* master will have number of slaves to wait for */\r
+ /* slave - internet full address of master */\r
+ if( strchr(*argv,':') ){\r
+ /* internet address of master nn.nn.nn.nn:port */\r
+ remote = TRUE;\r
+ tcpip_connect_to_master( *argv );\r
+ }else{\r
+ /* # of slaves to wait for */\r
+ if( sscanf( *argv, "%d", &c ) != 1 ) usage();\r
+ if( c < 0 || c >= 254 ) usage();\r
+ tcpip_wait_for_slaves( c );\r
+ remote = FALSE;\r
+ }\r
+ puts("");\r
+ network = TRUE;\r
+#else\r
+ usage();\r
+#endif\r
+ break;\r
+\r
+ case 'm' :\r
+ argv++,argc--;\r
+ if( argc==0 ) usage();\r
+ if (sscanf( *argv, "%ld", &m ) != 1) usage();\r
+ if (m <= 0 || m > MAXMEMSIZE)\r
+ abend("Invalid memory size specified\n");\r
+ memorysize = m;\r
+ break;\r
+\r
+ default :\r
+ usage();\r
+ break;\r
+\r
+ } /* end of switch */\r
+ else{ /* this is not option */\r
+ if( filename != NULL ) usage();\r
+ filename = *argv ;\r
+ }\r
+ } /* end of for */\r
+\r
+ if( filename!=NULL )\r
+ load(filename); /* load code and prototypes */\r
+ else\r
+ usage();\r
+}\r
+\r
+\r
+void decode(){\r
+ extopcode *eop;\r
+ eop = (extopcode *)(M+ic); /* pointer to extended opcode in M */\r
+ lastic = ic; /* save ic for possible redecoding */\r
+ ic += APOPCODE;\r
+ opcode = ((int) eop->opcode ) & 0xFF ;\r
+ getargument(a1, 0);\r
+ getargument(a2, 1);\r
+ getargument(a3, 2);\r
+}\r
+\r
+\r
+int main(argc, argv)\r
+int argc;\r
+char **argv;\r
+{\r
+ initiate(argc, argv); /* initialize executor */\r
+ runsys(); /* initialize running system */\r
+ init_scheduler();\r
+ setjmp(contenv); /* set label for continue long jump */\r
+ while (TRUE) /* repeat until exit() is called */\r
+ {\r
+ schedule(); /* reschedule current process */\r
+ decode(); /* fetch instruction */\r
+ execute(); /* and execute it */\r
+ }\r
+ return 0;\r
+} /* end main */\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include <assert.h>\r
+\r
+\r
+#ifndef NO_PROTOTYPES\r
+\r
+static word get_pointer(word,word);\r
+static void phase1(void);\r
+static void phase2(void);\r
+static void phase2a(void);\r
+static void phase3(void);\r
+static void phase4(void);\r
+static void phase5(void);\r
+static void phase6(void);\r
+static void curtain(void);\r
+static void heap_walk(word);\r
+static void nonefy(virtaddr *);\r
+static void relocate(virtaddr *);\r
+static void traverse(word,void (*)(virtaddr *));\r
+static void what_we_have(virtaddr *);\r
+\r
+#else\r
+\r
+static word get_pointer();\r
+static void phase1();\r
+static void phase2();\r
+static void phase2a();\r
+static void phase3();\r
+static void phase4();\r
+static void phase5();\r
+static void phase6();\r
+static void curtain();\r
+static void heap_walk();\r
+static void nonefy();\r
+static void relocate();\r
+static void traverse();\r
+static void what_we_have();\r
+\r
+#endif\r
+\r
+\r
+#ifdef CDBG\r
+FILE *ff;\r
+static void what_we_have(va) virtaddr *va; {\r
+ fprintf(ff," pointer offset %d:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",\r
+ ((word*)va)-M,va->addr,va->mark,M[va->addr],M[va->addr+1]);\r
+ fflush(ff);\r
+}\r
+#endif\r
+\r
+\r
+/*\r
+ * Memory compactifier - a play in 6 acts\r
+ */\r
+\r
+static word nleng; /* free memory before compact. */\r
+static word curah; /* to preserve ah of current object */\r
+\r
+/* One of the actions for traverse: see below;\r
+ * converts none to absolute none, i.e. (0, 0)\r
+ */\r
+\r
+\r
+static void nonefy(va) virtaddr *va; {\r
+\r
+#ifdef CDBG\r
+ if(va->addr==0 && va->mark!=0){\r
+ fprintf(ff,"nonefy:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",\r
+ va->addr,va->mark,M[va->addr],M[va->addr+1]);\r
+ fflush(ff);\r
+ }\r
+#endif\r
+\r
+#ifndef OBJECTADDR\r
+ if(!isprocess(va))\r
+#else\r
+ assert( va->mark >= 0 );\r
+/* assert( va->mark <= M[ va->addr+1 ] );*/\r
+#endif\r
+#ifdef CDBG\r
+ fprintf(ff,"nonefy:|va=%d,va_mark=%d,am=%d,mark=%d|\n",\r
+ va->addr,va->mark,M[va->addr],M[va->addr+1]);\r
+ fflush(ff);\r
+#endif\r
+ if( va->mark != M[ va->addr+1 ] ) /* if NONE */\r
+ {\r
+\r
+#ifdef CDBG\r
+ fprintf(ff," set to NONE\n"); fflush(ff);\r
+#endif\r
+ va->addr = 0;\r
+ va->mark = 0;\r
+ }\r
+ assert( va->addr != 1 );\r
+} /* end nonefy */\r
+\r
+\r
+/* One of the actions for traverse; update the virtual address to\r
+ * correspond to its dictionary entry after compactification.\r
+ */\r
+\r
+static void relocate(va) virtaddr *va; {\r
+#ifndef OBJECTADDR\r
+ if(!isprocess(va)){\r
+#endif\r
+ va->addr = M[ va->addr+1 ]; /* new ah (after compression) */\r
+ va->mark = 0; /* clear mark */\r
+#ifndef OBJECTADDR\r
+ }\r
+#endif\r
+} /* end relocate */\r
+\r
+\r
+/* Traverse all the virtual variables of object am and perform action\r
+ * on each of them. Skip references to processes (see nonefy() and\r
+ * relocate()).\r
+ */\r
+\r
+static void traverse(am, action)\r
+ word am;\r
+#ifndef NO_PROTOTYPES\r
+ void (*action)(virtaddr *);\r
+#else\r
+ void (*action)();\r
+#endif\r
+{\r
+ word t1, t2, t3, length;\r
+ protdescr *ptr;\r
+\r
+ t1 = am+M[ am ]; /* LWA+1 of the object */\r
+ length = M[ am+PROTNUM ]; /* prototype number */\r
+ if (length == AINT || length == AREAL || length == AVIRT ||\r
+ length == FILEOBJECT\r
+#ifdef OBJECTADDR\r
+ || length == APROCESS\r
+#endif\r
+ )\r
+ {\r
+ if (length == AVIRT) /* ARRAYOF <reference> */\r
+ for (t2 = am+3; t2 < t1; t2 += 2)\r
+ (*action)((virtaddr *)(M+t2));\r
+ }\r
+ else /* neither an array nor a file */\r
+ {\r
+ ptr = prototype [ length ];\r
+ switch (ptr->kind) /* compute the number of the system */\r
+ /* virtual variables */\r
+ {\r
+ case RECORD : length = 0; t3 = 0; break;\r
+ case COROUTINE : length = 3; t3 = CL; break;\r
+ case PROCESS : length = 5; t3 = disp2off; break;\r
+ case FUNCTION :\r
+ case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */\r
+ case HANDLER : length = 2; t3 = SIGNR; break;\r
+ default : length = 2; t3 = STATSL; break;\r
+ }\r
+\r
+ /* action for system reference variables */\r
+ for (t2 = length; t2 >= 1; t2-- )\r
+ (*action)((virtaddr *)(M+t1+offset[ t2 ]));\r
+\r
+ /* action for temporary reference variables */\r
+ t1 = am+M[ am ]+t3;\r
+ for (t2 = am+ptr->span; t2 < t1; t2 += 2)\r
+ (*action)((virtaddr *)(M+t2));\r
+\r
+ /* action for user reference variables */\r
+ t1 = ptr->reflist;\r
+ for (t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- )\r
+ (*action)((virtaddr *)(M+am+M[ t2 ]));\r
+ }\r
+} /* end traverse */\r
+\r
+\r
+/* Mark killed objects by substituting prototype number by a special value.\r
+ * This way we will be able to tell apart the killed objects without\r
+ * recalling to the dictionary or to the list of killed objects.\r
+ */\r
+\r
+static void phase1()\r
+{\r
+ word t1, t2, t3, phead;\r
+\r
+ nleng = thisp->lastitem-thisp->lastused-1; /* free memory before comp. */\r
+ M[ 1 ] = 0; /* for proper update of none */\r
+ phead = thisp->prochead; /* head of current process */\r
+ M[ phead+M[ phead ]+SL ] = 0; /* make SL of head look like none */\r
+ t1 = thisp->headk2; /* flag killed objects */\r
+ while (t1 != 0) /* special list for appetite=2 */\r
+ {\r
+ t2 = t1+SHORTLINK;\r
+ t1 = M[ t2 ];\r
+ M[ t2 ] = SKILLED; /* flag object killed */\r
+ }\r
+ t1 = thisp->headk; /* now other killed objects */\r
+ while (t1 != thisp->lower)\r
+ {\r
+ t2 = t1;\r
+ while (t2 != 0)\r
+ {\r
+ t3 = t2+SHORTLINK;\r
+ t2 = M[ t3 ];\r
+ M[ t3 ] = SKILLED; /* flag object killed */\r
+ }\r
+ t1 = M[ t1+LONGLINK ]; /* goto other size list */\r
+ }\r
+} /* end phase1 */\r
+\r
+\r
+/* Step thru the memory area containing objects. For each object not being\r
+ * killed detect all its virtual variables pointing to none and convert\r
+ * them to absolute none i.e. (0, 0).\r
+ */\r
+\r
+static void phase2()\r
+{\r
+ word t1;\r
+\r
+ nonefy( &(thisp->procref ) );\r
+\r
+ t1 = thisp->lower+1; /* FWA of object area */\r
+ while (t1 <= thisp->lastused)\r
+ {\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);\r
+ fflush(ff);\r
+ if (M[ t1+1 ] != SKILLED) traverse(t1,what_we_have);\r
+#endif\r
+\r
+ if (M[ t1+1 ] != SKILLED) /* an active object */\r
+ traverse(t1, nonefy);\r
+ t1 += M[ t1 ]; /* next object address */\r
+ }\r
+} /* end phase2 */\r
+\r
+\r
+/* garbage collection */\r
+\r
+/* Find x-th pointer in am.\r
+ * Skip references to processes.\r
+ */\r
+\r
+static word get_pointer(am,x) word am,x; {\r
+\r
+ word t1, t2, t3, length, va;\r
+ protdescr *ptr;\r
+\r
+ t1 = am+M[ am ]; /* LWA+1 of the object */\r
+ length = M[ am+PROTNUM ]; /* prototype number */\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"|get_pointer(am=%d,x=%d)lenght=%d|",am,x,length);\r
+ fflush(ff);\r
+#endif\r
+\r
+ if (length == AINT || length == AREAL || length == AVIRT ||\r
+ length == FILEOBJECT\r
+#ifdef OBJECTADDR\r
+ || length == APROCESS\r
+#endif\r
+ )\r
+ {\r
+ if(length == AVIRT) /* ARRAYOF <reference> */\r
+ for(t2 = am+3; t2 < t1; t2 += 2){\r
+#ifndef OBJECTADDR\r
+ if(isprocess((virtaddr *)(M+t2))) continue;\r
+#endif\r
+ if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }\r
+#ifdef CDBG\r
+ fprintf(ff,"ARR");\r
+ fflush(ff);\r
+#endif\r
+ if(x==0){\r
+#ifdef CDBG\r
+ fprintf(ff,"=%d|\n",t2);\r
+ fflush(ff);\r
+#endif\r
+ return t2;\r
+ }\r
+ x--;\r
+ }\r
+ }\r
+ else /* neither an array nor a file */\r
+ {\r
+ ptr = prototype [ length ];\r
+ switch (ptr->kind) /* compute the number of the system */\r
+ /* virtual variables */\r
+ {\r
+ case RECORD : length = 0; t3 = 0; break;\r
+ case COROUTINE : length = 3; t3 = CL; break;\r
+ case PROCESS : length = 5; t3 = disp2off; break;\r
+ case FUNCTION :\r
+ case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */\r
+ case HANDLER : length = 2; t3 = SIGNR; break;\r
+ default : length = 2; t3 = STATSL; break;\r
+ }\r
+\r
+ /* system reference variables */\r
+ for(t2 = length; t2 >= 1; t2-- ){\r
+ va=t1+offset[ t2 ];\r
+#ifndef OBJECTADDR\r
+ if(isprocess((virtaddr *)(M+va))) continue;\r
+#endif\r
+ if(M[va]==0){ assert( M[va+1]==0 ); continue; }\r
+ if(x==0){\r
+#ifdef CDBG\r
+ fprintf(ff,"=%d|\n",va);\r
+ fflush(ff);\r
+#endif\r
+ return va;\r
+ }\r
+ x--;\r
+ }\r
+\r
+ /* temporary reference variables */\r
+ t1 = am+M[ am ]+t3;\r
+ for(t2 = am+ptr->span; t2 < t1; t2 += 2){\r
+#ifndef OBJECTADDR\r
+ if(isprocess((virtaddr *)(M+t2))) continue;\r
+#endif\r
+ if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }\r
+ if(x==0){\r
+#ifdef CDBG\r
+ fprintf(ff,"=%d|\n",t2);\r
+ fflush(ff);\r
+#endif\r
+ return t2;\r
+ }\r
+ x--;\r
+ }\r
+\r
+ /* user reference variables */\r
+ t1 = ptr->reflist;\r
+ for(t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- ){\r
+ va=am+M[ t2 ];\r
+#ifndef OBJECTADDR\r
+ if(isprocess((virtaddr *)(M+va))) continue;\r
+#endif\r
+ if(M[va]==0){ assert( M[va+1]==0 ); continue; }\r
+ if(x==0){\r
+#ifdef CDBG\r
+ fprintf(ff,"=%d|\n",va);\r
+ fflush(ff);\r
+#endif\r
+ return va;\r
+ }\r
+ x--;\r
+ }\r
+ }\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"=-1|\n");\r
+ fflush(ff);\r
+#endif\r
+\r
+ return -1;\r
+}\r
+\r
+static void heap_walk(curr_ah) word curr_ah;{\r
+ word aux,prev_ah=1; /* 1 is special value not expected in anyone virtaddr */\r
+ word level=0;\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"|prev_ah=%d|\n",prev_ah);\r
+ fflush(ff);\r
+#endif\r
+\r
+ for(;;){\r
+ word am=get_pointer(M[curr_ah],M[curr_ah+1]);\r
+ M[curr_ah+1]++;\r
+ if(am >= 0){\r
+ if(M[ M[am] +1] >0){\r
+#ifdef CDBG\r
+ fprintf(ff,"Object %d->%d invited.\n",M[am],M[M[am]]);\r
+ fflush(ff);\r
+#endif\r
+ continue;\r
+ }\r
+\r
+ /*** go ahead ***/\r
+ level++;\r
+ aux=M[am];\r
+ M[am]=prev_ah;\r
+ prev_ah=curr_ah;\r
+ curr_ah=aux;\r
+#ifdef CDBG\r
+ fprintf(ff,"|curr_ah set to %d|\n",curr_ah);\r
+ fflush(ff);\r
+#endif\r
+ continue;\r
+ }\r
+ if(prev_ah > 1){\r
+ /*** go back ***/\r
+#ifdef CDBG\r
+ fprintf(ff,"going back (prev_ah=%d)(lvl=%d)\n",prev_ah,level);\r
+ fflush(ff);\r
+#endif\r
+ level--;\r
+ aux=curr_ah;\r
+ curr_ah=prev_ah;\r
+ am=get_pointer(M[prev_ah],M[prev_ah+1]-1);\r
+ prev_ah=M[am];\r
+#ifdef CDBG\r
+ if(level==0)\r
+ fprintf(ff,"|prev_ah set to %d,next set to %d|\n",prev_ah,aux);\r
+ fflush(ff);\r
+#endif\r
+ M[am]=aux;\r
+ continue;\r
+ }\r
+ assert( prev_ah==1 );\r
+ assert( level == 0 );\r
+ break; /*** now all 'invited' objects have its mark >0 ***/\r
+ }\r
+}\r
+\r
+static void phase2a()\r
+{\r
+ word t1,c1_ah;\r
+\r
+ /*** generation number already is not needed so we reset it ***/\r
+\r
+ t1 = thisp->upper-1;\r
+ while(t1 >= thisp->lastitem){\r
+ if( M[t1] == c1 ) c1_ah=t1;\r
+ M[ t1+1 ] = 0;\r
+ t1-=2;\r
+ }\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"first phase of walk |from=%d,to=%d,procah=%d|\n",\r
+ thisp->lastitem,\r
+ thisp->upper-1,\r
+ thisp->procref.addr);\r
+ fflush(ff);\r
+#endif\r
+\r
+ heap_walk(thisp->procref.addr);\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"second phase of walk c1_ah=%d,c1=%d\n",c1_ah,c1);\r
+ fflush(ff);\r
+#endif\r
+\r
+ heap_walk(c1_ah);\r
+\r
+ if( thisp->blck1 != 0 )\r
+ heap_walk(thisp->blck1);\r
+\r
+ /*** Mark objects not traversed like SKILLED ***/\r
+\r
+ t1 = thisp->freeitem; /* head of free item list */\r
+ while (t1 != 0)\r
+ {\r
+ word t2;\r
+ t2 = M[ t1 ];\r
+ M[ t1 ]= 0-1; /* mark not to set object SKILLED */\r
+ t1 = t2; /* next free item */\r
+ }\r
+\r
+ t1 = thisp->upper-1; /* last dictionary item pointer */\r
+ while (t1 >= thisp->lastitem)\r
+ {\r
+ if (M[ t1+1 ] == 0 ){ /* entry not traversed - so killed */\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"MARKING dict. entry %d -> %d like SKILLED\n",t1,M[t1]);\r
+ fflush(ff);\r
+#endif\r
+\r
+ M[ t1+1 ] = MAXMARKER;\r
+ if( M[ t1 ] > 0 ) M [ M[ t1 ] +1 ] = SKILLED;\r
+ /* mark SKILLED if not set yet */\r
+ }\r
+ t1 -= 2;\r
+ }\r
+} /* end phase2a */\r
+\r
+\r
+\r
+/* For each free dictionary item set its mark to unusable status.\r
+ */\r
+\r
+static void phase3()\r
+{\r
+ word t1;\r
+\r
+ t1 = thisp->freeitem; /* head of free item list */\r
+ while (t1 != 0)\r
+ {\r
+ M[ t1+1 ] = MAXMARKER; /* flag item unusable */\r
+ t1 = M[ t1 ]; /* next free item */\r
+ }\r
+} /* end phase3 */\r
+\r
+\r
+/* Step thru the dictionary and virtually remove all unusable items.\r
+ * For each active item (after phase3 we have only active and unusable\r
+ * items) its mark is set to the new address of this item (after\r
+ * forthcomming compression). Moreover the contents of locations am and\r
+ * (old) ah are interchanged.\r
+ */\r
+\r
+static void phase4()\r
+{\r
+ word t1, t2, t3;\r
+\r
+ t1 = thisp->upper-1; /* last dictionary item pointer */\r
+ t2 = t1; /* initialize new address */\r
+ while (t1 >= thisp->lastitem)\r
+ {\r
+ if (M[ t1+1 ] == MAXMARKER) /* entry killed - don't decrement t2 */\r
+ M[ t1+1 ] = 0;\r
+ else\r
+ {\r
+ M[ t1+1 ] = t2; /* store new ah */;\r
+ t2 -= 2;\r
+ t3 = M[ t1 ]; /* am */\r
+ M[ t1 ] = M[ t3 ]; /* save (am) in (old ah) */\r
+ M[ t3 ] = t1; /* move old ah to (am) */\r
+ }\r
+ t1 -= 2;\r
+ }\r
+} /* end phase4 */\r
+\r
+\r
+/* The memory area of objects is traversed once again. Now the killed\r
+ * objects are removed and the remaining ones compressed. For each active\r
+ * object its virtual variables are relocated, their marks cleared, their\r
+ * ah's set to the proper new values. The contents of locations am and ah\r
+ * are interchanged back.\r
+ */\r
+\r
+static void phase5()\r
+{\r
+ word t1, t2, t3, t4, t5;\r
+\r
+ t2 = t1 = thisp->lower+1;\r
+ while (t1 <= thisp->lastused) /* traverse object area */\r
+ {\r
+ t5 = M[ t1 ]; /* old ah saved by phase4 */\r
+ if (M[ t1+1 ] == SKILLED){ /* ignore this object */\r
+#ifdef CDBG\r
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);\r
+ fflush(ff);\r
+#endif\r
+ t1 += t5; /* t5=appetite in this case */\r
+ }\r
+ else\r
+ {\r
+#ifdef CDBG\r
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);\r
+ fflush(ff);\r
+#endif\r
+ t3 = M[ t5 ]; /* appetite saved by phase4 */\r
+ M[ t2 ] = t3; /* send it to the new am */\r
+ for (t4 = 1; t4 < t3; t4++ ) /* copy the object into new am */\r
+ M[ t2+t4 ] = M[ t1+t4 ];\r
+#ifdef CDBG\r
+ traverse(t2,what_we_have);\r
+#endif\r
+\r
+ /* Update global absolute pointer to current object : */\r
+ if (t1 == c1) /* locate am of current */\r
+ {\r
+ c1 = t2;\r
+ curah = M[ t5+1 ]; /* new ah of current */\r
+ }\r
+ if (t1 == M[ temporary ])\r
+ M[ temporary ] = t2;\r
+\r
+ M[ t5 ] = t2; /* make (ah) looking ok */\r
+ traverse(t2, relocate); /* relocate virtual variables */\r
+#ifdef CDBG\r
+ fprintf(ff," --> am=%d,SIZE=%d,TYPE=%d\n",t2,M[t2],M[t2+1]);\r
+ fflush(ff);\r
+ traverse(t2,what_we_have);\r
+#endif\r
+ t1 += t3;\r
+ t2 += t3;\r
+ }\r
+ }\r
+ thisp->lastused = t2-1;\r
+\r
+\r
+ /* Update global absolute pointers to objects : */\r
+\r
+ relocate(&(thisp->procref ));\r
+\r
+ {\r
+ virtaddr v;\r
+ v.addr=thisp->blck1;\r
+ v.mark=0;\r
+ relocate(&v);\r
+ thisp->blck1=v.addr;\r
+ }\r
+\r
+} /* end phase5 */\r
+\r
+\r
+/* The dictionary is compressed. The unusable entries are moved out and\r
+ * the remaining ones are moved up to the positions indicated by their\r
+ * marks.\r
+ * If pointers to processes are implemented as objects we have to rebuild\r
+ * has table of these pointers too.\r
+ */\r
+\r
+static void phase6()\r
+{\r
+ word t1, t2, t3;\r
+\r
+#ifdef OBJECTADDR\r
+ hash_create(thisp,thisp->hash_size);\r
+#endif\r
+\r
+ t1 = thisp->upper+1;\r
+ for (t2 = t1-2; t2 >= thisp->lastitem; t2 -= 2) /* compress dictionary */\r
+ {\r
+ t3 = M[ t2+1 ];\r
+ if (t3 != 0) /* this is new ah */\r
+ {\r
+ M[ t3 ] = M[ t2 ];\r
+ M[ t3+1 ] = 0; /* clear mark */\r
+ t1 = t3;\r
+#ifdef OBJECTADDR\r
+ {\r
+ virtaddr vt3;\r
+ vt3.addr=t3;\r
+ vt3.mark=0;\r
+ if( isprocess(&vt3) ){\r
+ virtaddr obj;\r
+ procaddr mess;\r
+ obj.addr=t3;\r
+ obj.mark=0;\r
+ obj2mess(M,&obj,&mess);\r
+ /* force to create item - we not need it yet */\r
+ hash_set(&mess,t3);\r
+ }\r
+ }\r
+#endif\r
+ }\r
+ }\r
+ thisp->lastitem = t1;\r
+\r
+ thisp->prochead = M[ thisp->procref.addr ];\r
+ thisp->blck2 = M[ thisp->blck1 ];\r
+\r
+} /* end phase6 */\r
+\r
+\r
+/* System invariants are recovered, e.g. display is rebuilt to reflect the\r
+ * new physical addresses.\r
+ */\r
+\r
+static void curtain()\r
+{\r
+ word t1, phead;\r
+\r
+ phead = thisp->prochead;\r
+ t1=M[ c1 + PROTNUM ];\r
+ c2 = c1+prototype[ t1 ]->span;\r
+ t1 = phead+M[ phead ]; /* first free after process head */\r
+ display = t1+dispoff; /* display address */\r
+ display2 = t1+disp2off; /* indirect display */\r
+ M[ t1+SL ] = DUMMY; /* restore head's SL */\r
+ loosen(); /* rebuild DISPLAY */\r
+ update(c1, curah);\r
+ if (infmode){\r
+ fprintf(stderr,\r
+ "\n(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",\r
+ thispix,\r
+ (long) (thisp->lastitem-thisp->lastused-1-nleng),\r
+ (long) (thisp->lastitem-thisp->lastused-1));\r
+ fflush(stderr);\r
+ }\r
+#ifdef CDBG\r
+ fprintf(ff,\r
+ "(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",\r
+ thispix,\r
+ (long) (thisp->lastitem-thisp->lastused-1-nleng),\r
+ (long) (thisp->lastitem-thisp->lastused-1));\r
+ fflush(ff);\r
+#endif\r
+ thisp->freeitem = 0;\r
+ thisp->headk2 = 0;\r
+ thisp->headk = thisp->lower;\r
+ M[ 1 ] = 1; /* absolute none */\r
+ ic = lastic; /* re-decode current instruction ! */\r
+ decode();\r
+ if (opcode == 3 /*LRAISE*/) ic++; /* skip address after LRAISE */\r
+} /* end curtain */\r
+\r
+\r
+void compactify() /* Compactification */\r
+{\r
+#ifdef CDBG\r
+ ff=fopen("trace","a");\r
+ fprintf(ff,"----------------------------------------\n");\r
+ fprintf(ff,"COMPACTIFY (thisp=%d)\n",thispix);\r
+ fprintf(ff,"c1=%d,c2=%d,templ=%d\n",\r
+ thisp->c1,thisp->c2,thisp->template.addr);\r
+ fprintf(ff,"back=%d,back.mark=%d,backam=%d,backam.mark=%d\n",\r
+ thisp->backobj.addr,thisp->backobj.mark,\r
+ M[thisp->backobj.addr],M[thisp->backobj.addr+1]);\r
+ fprintf(ff,"blck1=%d,blck2=%d\n",thisp->blck1,thisp->blck2);\r
+ fflush(ff);\r
+#endif\r
+\r
+ phase1();\r
+ phase2();\r
+ phase2a(); /* garbage collection */\r
+/* phase3(); if only compactifier is needed uncomment this statement */\r
+/* and comment statement phase2a() */\r
+ phase4();\r
+ phase5();\r
+ phase6();\r
+ curtain();\r
+\r
+#ifdef CDBG\r
+ fprintf(ff,"----------------------------------------\n");\r
+ fflush(ff);\r
+ fclose(ff);\r
+#endif\r
+\r
+} /* end compactify */\r
+\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+/* Transfer of control routines */\r
+\r
+#ifndef NO_PROTOTYPES\r
+static void att2(virtaddr *, word, word);\r
+static void back1(word, word, virtaddr *, word *);\r
+#else\r
+static void att2();\r
+static void back1();\r
+#endif\r
+\r
+/* Transfer control to the newly created object.\r
+ */\r
+\r
+void go(ah, am)\r
+word ah, am;\r
+{\r
+ protdescr *ptr;\r
+ word pnum, plen, node, apt;\r
+ message msg;\r
+\r
+ ptr = prototype[ M[ am+PROTNUM ] ];\r
+ apt = am+M[ am ];\r
+ if (ptr->kind == PROCESS) /* new process creation */\r
+ {\r
+ thisp->template.addr = ah; /* save template address */\r
+ thisp->template.mark = M[ ah+1 ];\r
+ msg.control.type = CREATE;\r
+ msg.control.par = M[ am+PROTNUM ];\r
+ moveparams(thispix, am, &msg, PARIN, LOADPAR);\r
+ msg.control.receiver.pix = 0; /* pix will create receiver */\r
+ msg.control.receiver.mark= 0; /* mark will create receiver */\r
+ msg.control.receiver.node = getnode(am); /* node we decided */\r
+ sendmsg( &msg); /* send create request */\r
+# ifdef RPCDBG\r
+ fprintf(\r
+ stderr, "send new process from %d to node %d\n",\r
+ thispix,\r
+ msg.control.receiver.node\r
+ );\r
+# endif\r
+ passivate(WAITFORNEW); /* and wait for return from process */\r
+ }\r
+ else\r
+ if (isprocess((virtaddr*)(M+apt+SL))) /* remote procedure call */\r
+ {\r
+ thisp->backobj.addr = ah; /* save template address */\r
+ thisp->backobj.mark = M[ ah+1 ];\r
+ thisp->M[ temporary ] = am; /* physical address also */\r
+ {\r
+ virtaddr v;\r
+ loadvirt( v, apt+SL );\r
+ obj2mess( M, &v, &msg.control.receiver );\r
+# ifdef RPCDBG\r
+ fprintf(\r
+ stderr, "send rpc from process %d to (%d,%d,%d)\n",\r
+ thispix,\r
+ msg.control.receiver.node,\r
+ msg.control.receiver.pix,\r
+ msg.control.receiver.mark\r
+ );\r
+# endif\r
+ }\r
+ msg.control.type = RPCALL;\r
+ msg.control.par = M[ am+PROTNUM ];\r
+ moveparams(thispix, am, &msg, PARIN, LOADPAR);\r
+ sendmsg( &msg); /* send RPC request */\r
+ passivate(WAITFORRPC); /* and wait for RP return */\r
+ }\r
+ else\r
+ {\r
+ M[ c1+M[ c1 ]+LSC ] = ic; /* save local control */\r
+ loosen(); /* release DISPLAY */\r
+ update(am, ah); /* update DISPLAY */\r
+ c1 = am; /* new current */\r
+ c2 = c1+ptr->span;\r
+ pnum = ptr->preflist;\r
+ plen = ptr->lthpreflist;\r
+ while (TRUE) /* search for executable prefix */\r
+ if (plen <= 1)\r
+ {\r
+ ic = ptr->codeaddr;\r
+ break;\r
+ }\r
+ else\r
+ {\r
+ ptr = prototype[ M[ pnum ] ];\r
+ plen--;\r
+ pnum++;\r
+ if (ptr->kind != RECORD) plen = 0;\r
+ }\r
+ }\r
+}\r
+\r
+\r
+/* Transfer control to a local unprefixed procedure, function, block,\r
+ * class or coroutine.\r
+ */\r
+\r
+void goloc(ah, am)\r
+word ah, am;\r
+{\r
+ word t1;\r
+ protdescr *ptr;\r
+\r
+ M[ c1+M[ c1 ]+LSC ] = ic; /* save local control */\r
+ c1 = am; /* new current */\r
+ t1 = M[ am+PROTNUM ];\r
+ ptr = prototype[ t1 ];\r
+ c2 = am+ptr->span;\r
+ ic = ptr->codeaddr;\r
+ M[ display+t1 ] = am; /* simulate update display */\r
+ M[ display2+t1 ] = ah;\r
+ M[ am+M[ am ]+STATSL ]++;\r
+}\r
+\r
+\r
+void backbl(virt, am) /* Return from block. */\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ word t1;\r
+\r
+ t1 = M[ c1+PROTNUM ];\r
+ virt->addr = M[ display2+t1 ];\r
+ virt->mark = M[ virt->addr+1 ]; /* prepare old address */\r
+ *am = c1; /* am of old */\r
+ M[ display+t1 ] = 0; /* simulate loosen */\r
+ t1 = c1+M[ c1 ];\r
+ M[ t1+STATSL ]--; /* remove from SL chain */\r
+ c1 = M[ t1+SL ]; /* return up along SL */\r
+ if (c1 == DUMMY) endprocess(0); /* return from main */\r
+ c1 = M[ c1 ]; /* am of new current */\r
+ c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;\r
+ ic = M[ c1+M[ c1 ]+LSC ];\r
+ storevirt(*virt, *am+M[ *am ]+DL); /* force DL consistency */\r
+}\r
+\r
+\r
+static void back1(at1, at2, virt, am) /* Common code for some backs below. */\r
+word at1, at2;\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ word t1;\r
+\r
+ loosen();\r
+ if (at1 == 0) endprocess(0);\r
+ t1 = M[ c1+PROTNUM ];\r
+ virt->addr = M[ display2+t1 ]; /* ah of old */\r
+ virt->mark = M[ virt->addr+1 ];\r
+ *am = c1; /* am of old */\r
+ storevirt(*virt, at2); /* loop up DL */\r
+ at2 = M[ at1 ]; /* am of DL */\r
+ update(at2, at1);\r
+ c1 = at2;\r
+ c2 = c1 + prototype[ M[ c1+PROTNUM ] ]->span;\r
+ ic = M[ c1+M[ c1 ]+LSC ];\r
+}\r
+\r
+\r
+/* Return from classes, coroutines and by end from procedures.\r
+ */\r
+\r
+void back(virt, am, length)\r
+virtaddr *virt;\r
+word *am;\r
+word length;\r
+{\r
+ word t1, t2, plist;\r
+ int i;\r
+ protdescr *ptr;\r
+ message msg;\r
+\r
+ t2 = c1+M[ c1 ];\r
+ t1 = M[ t2+DL ]; /* ah of DL */\r
+ ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */\r
+ if (ptr->kind == PROCESS) /* RETURN in process */\r
+ {\r
+# ifdef RPCDBG\r
+ fprintf( stderr, "return from process %d\n", thispix );\r
+# endif\r
+ if (M[ c1+PROTNUM ] == MAINBLOCK) endprocess(0);\r
+ {\r
+ virtaddr v;\r
+ loadvirt( v, t2+DL );\r
+ obj2mess( M, &v, &msg.control.receiver ); /* father process */\r
+ }\r
+ msg.control.type = CREACK;\r
+ moveparams(thispix, c1, &msg, PAROUT, LOADPAR);\r
+ sendmsg(&msg); /* send create acknowledge */\r
+ M[ t2+DL ] = 0; /* cut DL of new process head */\r
+ passivate(STOPPED); /* and suspend new process */\r
+ }\r
+ else\r
+ if (ptr->kind == COROUTINE)\r
+ {\r
+ if (t1 != 0) /* nothing if detached */\r
+ {\r
+ M[ t2+LSC ] = ic;\r
+ back1(t1, t2+DL, virt, am);\r
+ }\r
+ }\r
+ else\r
+ {\r
+ plist = ic; /* save begining of prototype list */\r
+ if (ptr->lthpreflist==1 && t1==M[t2+SL] && M[t2+DL+1]==M[t2+SL+1])\r
+ backbl(virt, am);\r
+ else\r
+ back1(t1, t2+DL, virt, am);\r
+\r
+/*\r
+# ifdef RPCDBG\r
+ fprintf(\r
+ stderr, "back (thisp=%d) from %s to %s\n",\r
+ thispix,\r
+ (\r
+ (ptr->kind==PROCEDURE) ?\r
+ "PROCEDURE" :\r
+ (ptr->kind==FUNCTION) ?\r
+ "FUNCTION" :\r
+ "???"\r
+ ),\r
+ isprocess((virtaddr*)(M+t2+RPCDL)) ? "PROCESS" : "OBJECT"\r
+ );\r
+# endif\r
+*/\r
+ if ((ptr->kind == PROCEDURE || ptr->kind == FUNCTION) &&\r
+ isprocess((virtaddr*)(M+t2+RPCDL)))\r
+ {\r
+ {\r
+ virtaddr v;\r
+ loadvirt( v, t2+RPCDL );\r
+ obj2mess( M, &v, &msg.control.receiver ); /* remote DL */\r
+ }\r
+# ifdef RPCDBG\r
+ fprintf(\r
+ stderr, "send rpc ack from process %d to (%d,%d,%d)\n",\r
+ thispix,\r
+ msg.control.receiver.node,\r
+ msg.control.receiver.pix,\r
+ msg.control.receiver.mark\r
+ );\r
+# endif\r
+ msg.control.type = RPCACK;\r
+ moveparams(thispix, *am, &msg, PAROUT, LOADPAR);\r
+ sendmsg(&msg); /* send RP return - acknowledge */\r
+ gkill(virt); /* kill procedure object manualy */\r
+ popmask(thispix); /* restore RPC mask from stack */\r
+ for (i = 0; i < length; i++) /* and modify it */\r
+ {\r
+ t1 = virtprot(M[ plist++ ]); /* prototype number */\r
+ if (t1 > 0) enable(thispix, t1);\r
+ else disable(thispix, -t1);\r
+ }\r
+ evaluaterpc(thispix); /* check for enabled RPCs */\r
+ }\r
+ }\r
+}\r
+\r
+\r
+/* Return, end in procedures and functions without prefix.\r
+ */\r
+\r
+void backpr(virt, am)\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ word t1, t2, t3;\r
+\r
+ t2 = c1+M[ c1 ]+DL; /* DL pointer of current */\r
+ t1 = M[ t2 ]; /* ah of DL */\r
+ t3 = c1+M[ c1 ]+SL; /* SL pointer */\r
+ if (t1 == M[ t3 ] && M[ t2+1 ] == M[ t3+1 ]) backbl(virt, am); /* SL=DL */\r
+ else back1(t1, t2, virt, am);\r
+}\r
+\r
+\r
+void fin(backic, virt, am) /* End in classes and coroutines. */\r
+word backic;\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ word t1, t2, knd;\r
+\r
+ knd = prototype[ M[ c1+PROTNUM ] ]->kind;\r
+ if (knd != COROUTINE && knd != PROCESS)\r
+ back(virt, am, (word) 0); /* a class - exit as above */\r
+ else\r
+ {\r
+ ic = backic; /* backspace ic */\r
+ t2 = c1+M[ c1 ];\r
+ t1 = M[ t2+DL ]; /* ah of DL */\r
+ if (t1 == 0)\r
+ {\r
+ if (M[ t2+SL ] == DUMMY) endprocess(0);\r
+ ic = 0; /* coroutine terminated */\r
+ *am = 0;\r
+ detach();\r
+ }\r
+ else\r
+ {\r
+ M[ t2+LSC ] = ic;\r
+ back1(t1, t2+DL, virt, am);\r
+ }\r
+ }\r
+}\r
+\r
+\r
+static void att2(virt, ax, at1) /* Helper for attach/detach */\r
+virtaddr *virt;\r
+word ax, at1;\r
+{\r
+ word t1, t2, phead;\r
+\r
+ t1 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */\r
+ t2 = at1+M[ at1 ]+DL; /* DL of coroutine head */\r
+ M[ t2 ] = t1; /* loop up DL */\r
+ M[ t2+1 ] = M[ t1+1 ];\r
+ M[ c1+M[ c1 ]+LSC ] = ic; /* preserve local control */\r
+ loosen();\r
+ phead = thisp->prochead;\r
+ storevirt(*virt, phead+M[ phead ]+CHD);\r
+ t2 = M[ ax+DL ];\r
+ if (t2 == 0) errsignal(RTECORAC); /* coroutine active */\r
+ M[ ax+DL ] = 0; /* cut DL of new coroutine head */\r
+ c1 = M[ t2 ];\r
+ update(c1, t2);\r
+ c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;\r
+ ic = M[ c1+M[ c1 ]+LSC ];\r
+ if (ic == 0) errsignal(RTECORTM); /* coroutine terminated */\r
+}\r
+\r
+\r
+void attach(virt)\r
+virtaddr *virt;\r
+{\r
+ word t1, ax, phead, chead;\r
+ int knd;\r
+\r
+ if (M[ virt->addr+1 ] != virt->mark) errsignal(RTEILLAT);\r
+ else ax = M[ virt->addr ]; /* am */\r
+ t1 = M[ ax+PROTNUM ];\r
+ if (t1 == AINT || t1 == AREAL || t1 == AVIRT || t1 == FILEOBJECT)\r
+ errsignal(RTEILLAT);\r
+ knd = prototype[ t1 ]->kind;\r
+ if (knd != COROUTINE && knd != PROCESS) errsignal(RTEILLAT);\r
+ ax = ax+M[ ax ];\r
+ phead = thisp->prochead;\r
+ chead = phead+M[ phead ]+CHD;\r
+ if (virt->addr != M[ chead ] || virt->mark != M[ chead+1 ])\r
+ {\r
+ M[ ax+CL ] = M[ chead ];\r
+ M[ ax+CL+1 ] = M[ chead+1 ];\r
+ att2(virt, ax, M[ M[ chead ] ]);\r
+ }\r
+}\r
+\r
+\r
+void detach()\r
+{\r
+ virtaddr virt;\r
+ word t1, phead;\r
+\r
+ phead = thisp->prochead;\r
+ t1 = M[ M[ phead+M[ phead ]+CHD ] ]; /* am of coroutine head */\r
+ loadvirt(virt, t1+M[ t1 ]+CL); /* coroutine link */\r
+ if (M[ virt.addr+1 ] != virt.mark) errsignal(RTEILLDT);\r
+ att2(&virt, M[ virt.addr ]+M[ M[ virt.addr ] ], t1);\r
+}\r
+\r
+\r
+void inner(level) /* Simulate execution of inner */\r
+word level;\r
+{\r
+ word t1;\r
+ protdescr *ptr;\r
+\r
+ ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */\r
+ t1 = ptr->lthpreflist;\r
+ if (t1 != level)\r
+ if (level == t1-1) ic = ptr->codeaddr;\r
+ else ic = prototype[ M[ ptr->preflist+level ] ]->codeaddr;\r
+}\r
+\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#if MSDOS\r
+#undef UNIX\r
+#undef OS2\r
+#elif UNIX\r
+#undef OS2\r
+#elif OS2\r
+#undef UNIX\r
+#else\r
+#error Define one of MSDOS/OS2/UNIX\r
+#endif\r
+\r
+#if WORD_16BIT\r
+#undef DWORD_16BIT\r
+#undef WORD_32BIT\r
+#elif DWORD_16BIT\r
+#undef WORD_32BIT\r
+#elif WORD_32BIT\r
+#undef DWORD_16BIT\r
+#else\r
+#error Define one of WORD_16BIT/DWORD_16BIT/WORD_32BIT\r
+#endif\r
+\r
+\r
+#include <stdio.h>\r
+#include <malloc.h>\r
+#include <setjmp.h>\r
+#include <stdlib.h>\r
+#include <string.h>\r
+\r
+\r
+typedef struct {\r
+ char opcode;\r
+ char args[ 3 ];\r
+ } extopcode;\r
+\r
+typedef char *lword; /* max(word, char *) but in every case was char* */\r
+\r
+#define BINARYREAD "rb"\r
+#define BINARYWRITE "wb"\r
+#define DIRECTOLD "r+b"\r
+#define DIRECTNEW "w+b"\r
+\r
+\r
+#if WORD_16BIT\r
+\r
+typedef int word;\r
+typedef float real;\r
+typedef word *memory;\r
+\r
+#if UNIX\r
+extern char *calloc(int,int);\r
+#endif\r
+\r
+#define mallocate(n) ((memory) (char /*|||huge*/ *) calloc((n),sizeof(word)))\r
+#define ballocate(n) ((char /*|||huge*/ *) calloc((n),1))\r
+\r
+#define MAXINTEGER 0x7FFF\r
+#define DEFMEMSIZE 0x7FF0 /* 32K words = 64K bytes */\r
+#define MAXMEMSIZE 0x7FF0 /* 32K words = 64K bytes */\r
+\r
+#endif\r
+\r
+\r
+\r
+#if DWORD_16BIT\r
+\r
+typedef long word;\r
+typedef double real;\r
+typedef word huge *memory;\r
+\r
+#if UNIX\r
+\r
+extern char *calloc(int,int);\r
+\r
+#define mallocate(n) (((n)<60000)?(memory) calloc((n),sizeof(word)):abort())\r
+#define ballocate(n) (calloc((n),1))\r
+\r
+#define MAXINTEGER 0x7FFFFFFFL\r
+#define DEFMEMSIZE 0x13C00L /* 79K words = 316K bytes */\r
+#define MAXMEMSIZE 0x400000L /* 4M words = 16M bytes */\r
+\r
+#elif OS2\r
+\r
+extern char huge *halloc();\r
+\r
+#define mallocate(n) ((memory) halloc((long) (n), sizeof(word)))\r
+#define ballocate(n) (halloc((long) (n),1L))\r
+\r
+#define MAXINTEGER 0x7FFFFFFFL\r
+#define DEFMEMSIZE 0x13C00L /* 79K words = 316K bytes */\r
+#define MAXMEMSIZE 0x400000L /* 4M words = 16M bytes */\r
+\r
+#define INCL_DOSINFOSEG\r
+\r
+#include <os2.h> \r
+\r
+#elif MSDOS && TURBOC\r
+\r
+extern char far *farcalloc();\r
+\r
+#define mallocate(n) ((memory) farcalloc((long) (n), (long) sizeof(word)))\r
+#define ballocate(n) (farcalloc((long) (n),1L))\r
+\r
+#define MAXINTEGER 0x7FFFFFFFL\r
+#define DEFMEMSIZE 0x14000L /* 80K words = 320K bytes */\r
+#define MAXMEMSIZE 0x28000L /* 160K words = 640K bytes */\r
+\r
+#elif MSDOS\r
+\r
+extern void huge *halloc();\r
+#define mallocate(n) ((memory) halloc((long) (n), sizeof(word)))\r
+#define ballocate(n) (halloc((long) (n),1))\r
+\r
+#define MAXINTEGER 0x7FFFFFFFL\r
+#define DEFMEMSIZE 0xF000L /* 60K words = 120K bytes */\r
+#define MAXMEMSIZE 0x28000L /* 160K words = 640K bytes */\r
+\r
+#else\r
+#error Allocation macros not defined.\r
+#endif\r
+\r
+#endif\r
+\r
+\r
+\r
+#if WORD_32BIT\r
+\r
+typedef int word;\r
+typedef float real;\r
+typedef word *memory;\r
+\r
+#define mallocate(n) ((memory) (char *) calloc((n),sizeof(word)))\r
+#define ballocate(n) ((char *) calloc((n),1))\r
+\r
+/* printf("|%d*4|",(n)),getchar(),\ */\r
+\r
+#define MAXINTEGER 0x7FFFFFFFL\r
+#define DEFMEMSIZE 0x13C00L /* 79K words = 316K bytes */\r
+#define MAXMEMSIZE 0x400000L /* 4M words = 16M bytes */\r
+\r
+#endif\r
+\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+ NAME CINTA\r
+ PUBLIC _logon, _logoff, _attention, _ignore, _send, _receive\r
+ EXTRN _endrun:FAR, COPYOK:FAR\r
+\r
+DGROUP GROUP _data\r
+\r
+CINTA_TEXT SEGMENT PUBLIC 'CODE'\r
+ ASSUME CS:DRIVER\r
+\r
+; PATCH FOR RECEIVE MESSAGE INTERRUPT HANDLER\r
+PATCH PROC FAR\r
+ PUSHF\r
+ PUSH AX\r
+ PUSH BX\r
+ PUSH CX\r
+ PUSH DX\r
+ PUSH DS\r
+ PUSH ES\r
+ CALL FAR PTR _ignore ; DISABLE ATTENTION\r
+ MOV AX, DGROUP\r
+ MOV DS, AX\r
+ ASSUME CS:DRIVER, DS:DGROUP\r
+ PUSH AX\r
+ MOV AX, OFFSET DGROUP:MSGBUF\r
+ PUSH AX\r
+ CALL FAR PTR _receive\r
+ CALL DWORD PTR MSGINT\r
+ ADD SP, 4\r
+ POP ES\r
+ POP DS\r
+ POP DX\r
+ POP CX\r
+ POP BX\r
+ POP AX\r
+ POPF\r
+ RET\r
+PATCH ENDP\r
+PATLEN = $-PATCH\r
+SAVLEN = PATLEN\r
+CINTA_TEXT ENDS\r
+\r
+_data SEGMENT WORD PUBLIC 'data'\r
+SAVCOD DB SAVLEN DUP(?) ; SPACE FOR SAVING PATCHED CODE\r
+USER DB 8 DUP(?)\r
+MSGBUF DB 80 DUP(' ')\r
+MSGINT DD ?\r
+_data ENDS\r
+\r
+; SEGMENT FOR ADDRESSING DRIVER CODE\r
+DRIVER SEGMENT AT 0\r
+ ORG 102EH ; ***** ONLY FOR D-LINK VERSION 3.21 *****\r
+DISPLAY LABEL FAR ; RECEIVE MESSAGE INTERRUPT HANDLER\r
+ ORG $+PATLEN\r
+DRIVER ENDS\r
+\r
+CINTA_TEXT SEGMENT 'CODE'\r
+ ASSUME CS:CINTA_TEXT\r
+\r
+NETWORK DB 0 ; NETWORK OPERATION FLAG\r
+\r
+BREAK PROC FAR ; CONTROL-BREAK INTERRUPT ROUTINE\r
+ MOV AX, DGROUP\r
+ MOV DS, AX\r
+ CALL _endrun\r
+ RET 2\r
+BREAK ENDP\r
+\r
+; int logon(msgint)\r
+; void (*msgint)();\r
+;\r
+; CHECK IF DRIVER IS INSTALLED AND CONNECT TO RECEIVE MESSAGE INTERRUPT HANDLER.\r
+; RETURN NODE NUMBER (-1 MEANS NODE NOT LOGGED ON)\r
+\r
+_logon PROC FAR\r
+ PUSH BP\r
+ MOV BP,SP\r
+ PUSH SI\r
+ PUSH DI\r
+ PUSH DS\r
+ PUSH AX ; PUSH DUMMY PARAMETER FOR COPYOK\r
+ PUSH AX\r
+ CALL COPYOK ; CHECK FOR AUTHORIZATION\r
+ OR AX, AX\r
+ JZ NOTAUT ; UNAUTHORIZED DUPLICATE\r
+ MOV AX, 2523H ; REPLACE CONTROL-BREAK INTERRUPT\r
+ MOV DX, OFFSET BREAK\r
+ PUSH CS\r
+ POP DS\r
+ INT 21H\r
+ MOV AX, 357DH ; GET NIOS VECTOR INTO ES:BX\r
+ INT 21H\r
+ CMP WORD PTR ES:[BX-2], 'ns'\r
+ JNE NONE ; DRIVER NOT INSTALLED\r
+ MOV AH, 17H ; GET NIOS VERSION NUMBER\r
+ INT 7DH\r
+ CMP AX, 1503H ; IS VERSION = 3.21\r
+ JNE NONE ; INCORRECT NIOS VERSION\r
+ PUSH ES\r
+ POP DS\r
+ MOV AX, DGROUP\r
+ MOV ES, AX\r
+ ASSUME CS:CINTA_TEXT, DS:DRIVER, ES:DGROUP\r
+ MOV BX, OFFSET DGROUP:USER\r
+ MOV AH, 02H ; GET USER NAME\r
+ MOV DL, 0FFH ; OUR NODE (UNKNOWN YET)\r
+ INT 7DH\r
+ OR AL, AL\r
+ JNZ NONE\r
+ MOV NETWORK, 1 ; FLAG NETWORK INSTALLED\r
+ CLD\r
+ MOV SI, OFFSET DISPLAY\r
+ MOV DI, OFFSET DGROUP:SAVCOD\r
+ MOV CX, SAVLEN\r
+ REP MOVSB\r
+ CALL FAR PTR _ignore ; DISABLE ATTENTION FOR A MOMENT\r
+ PUSH DS ; AND REPLACE WITH OUR\r
+ POP ES\r
+ PUSH CS\r
+ POP DS\r
+ ASSUME CS:CINTA_TEXT, DS:CINTA_TEXT, ES:DRIVER\r
+ MOV SI, OFFSET PATCH\r
+ MOV DI, OFFSET DISPLAY\r
+ MOV CX, PATLEN\r
+ REP MOVSB\r
+ MOV AX, DGROUP\r
+ MOV DS, AX\r
+ ASSUME CS:CINTA_TEXT, DS:DGROUP, ES:DRIVER\r
+ MOV AX, [BP+6] ; STORE ADDRESS OF USER INTERRUPT ROUTINE\r
+ MOV WORD PTR MSGINT, AX\r
+ MOV AX, [BP+8]\r
+ MOV WORD PTR MSGINT+2, AX\r
+ MOV AL, DL ; RETURN OUR NODE NUMBER\r
+ XOR AH, AH\r
+ JMP SHORT L1\r
+NONE: MOV AX, -1\r
+ MOV NETWORK, 0\r
+ JMP SHORT L1\r
+NOTAUT: MOV AX, -2\r
+L1: POP DS\r
+ POP DI\r
+ POP SI\r
+ POP BP\r
+ RET\r
+_logon ENDP\r
+\r
+\r
+; void logoff()\r
+;\r
+; RESTORE ORIGINAL INTERRUPT HANDLER\r
+\r
+_logoff PROC FAR\r
+ PUSH BP\r
+ MOV BP,SP\r
+ PUSH SI\r
+ PUSH DI\r
+ PUSH DS\r
+ ASSUME CS:CINTA_TEXT\r
+ CMP NETWORK, 0\r
+ JZ L2 ; NOTHING IF NO NETWORK \r
+ CALL FAR PTR _ignore ; DISABLE ATTENTION FOR A MOMENT\r
+ CLD\r
+ MOV AX,DGROUP\r
+ MOV DS,AX\r
+ MOV AX,357DH ; GET DRIVER SEGMENT INTO ES\r
+ INT 21H\r
+ ASSUME CS:CINTA_TEXT, DS:DGROUP, ES:DRIVER\r
+ MOV SI,OFFSET DGROUP:SAVCOD\r
+ MOV DI,OFFSET DISPLAY \r
+ MOV CX,SAVLEN\r
+ REP MOVSB ; RESTORE PATCHED CODE\r
+ CALL FAR PTR _attention ; ATTENTION BACK ON\r
+L2: POP DS\r
+ POP DI\r
+ POP SI\r
+ POP BP\r
+ RET\r
+_logoff ENDP\r
+\r
+\r
+; void attention()\r
+;\r
+; ENABLE ATTENTION\r
+\r
+_attention PROC FAR\r
+ CMP NETWORK, 0\r
+ JZ A1\r
+ MOV AX,1600H\r
+ INT 7DH\r
+A1: RET\r
+_attention ENDP\r
+\r
+\r
+; void ignore()\r
+;\r
+; DISABLE ATTENTION\r
+\r
+_ignore PROC FAR\r
+ CMP NETWORK, 0\r
+ JZ I1\r
+ MOV AX,16FFH\r
+ INT 7DH\r
+I1: RET\r
+_ignore ENDP\r
+\r
+\r
+; int send(node, msg)\r
+; int node;\r
+; message *msg;\r
+;\r
+; SEND MESSAGE MSG TO NODE\r
+\r
+_send PROC FAR\r
+ PUSH BP\r
+ MOV BP,SP\r
+ MOV AH,0DH ; SEND MESSAGE\r
+ MOV DL,[BP+6] ; NODE NUMBER\r
+ LES BX,[BP+8] ; BUFFER ADDRESS\r
+ INT 7DH\r
+ XOR AH,AH\r
+ POP BP\r
+ RET\r
+_send ENDP\r
+\r
+\r
+; int receive(msg)\r
+; message *msg;\r
+;\r
+; GET STORED MESSAGE\r
+\r
+_receive PROC FAR\r
+ PUSH BP\r
+ MOV BP,SP\r
+ MOV AH,0EH ; GET MESSAGE\r
+ LES BX,[BP+6] ; BUFFER ADDRESS\r
+ INT 7DH\r
+ XOR AH,AH\r
+ POP BP\r
+ RET\r
+_receive ENDP\r
+\r
+\r
+; FUNCTION TICKS:INTEGER4; \r
+; RETURN BIOS TIME IN TICKS\r
+TICKS PROC FAR\r
+ MOV AH,0\r
+ INT 1AH\r
+ MOV AX,DX ; LOW WORD\r
+ MOV DX,CX ; HIGH WORD\r
+ RET\r
+TICKS ENDP\r
+\r
+; PROCEDURE DTIME(VAR H,M,S:INTEGER);\r
+; RETURN DOS DAY TIME IN HOURS, MINUTES, AND SECONDS\r
+DTIME PROC FAR\r
+ PUSH BP\r
+ MOV BP,SP\r
+ MOV AH,2CH ; GET TIME\r
+ INT 21H\r
+ MOV BX,[BP+10]\r
+ MOV [BX],CH ; HOURS\r
+ MOV BYTE PTR [BX+1],0\r
+ MOV BX,[BP+8]\r
+ MOV [BX],CL ; MINUTES\r
+ MOV BYTE PTR [BX+1],0\r
+ MOV BX,[BP+6]\r
+ MOV [BX],DH ; SECONDS\r
+ MOV BYTE PTR [BX+1],0\r
+ POP BP\r
+ RET 6\r
+DTIME ENDP\r
+\r
+; FUNCTION SHIFT(PATTERN, COUNT:INTEGER):INTEGER;\r
+; SHIFT LEFT LOGICALY PATTERN BY COUNT BITS\r
+SHIFT PROC FAR\r
+ PUSH BP\r
+ MOV BP,SP\r
+ MOV AX,[BP+8] ; PATTERN\r
+ MOV CL,[BP+6] ; BIT COUNT\r
+ AND CL,0FH ; MASK LOW 4 BITS\r
+ TEST CL,08H ; TEST THEIR SIGN BIT\r
+ JZ S0 ; OK IF POSITIVE\r
+ OR CL,0F0H ; EXTEND SIGN TO ENTIRE BYTE IF NEGATIVE\r
+S0: CMP CL,0 ; TEST BIT COUNT ONCE AGAIN\r
+ JZ S2 ; IF = 0 DO NOTHING\r
+ JG S1 ; IF > 0 SHIFT LEFT\r
+ NEG CL ; IF < 0 NEGATE BIT COUNT AND\r
+ SHR AX,CL ; SHIFT RIGHT\r
+ JMP SHORT S2\r
+S1: SHL AX,CL ; SHIFT LEFT\r
+S2: POP BP\r
+ RET 4\r
+SHIFT ENDP\r
+\r
+CINTA_TEXT ENDS\r
+ END\r
+\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#ifndef __DLINK_H__\r
+#define __DLINK_H__\r
+\r
+#ifndef NO_PROTOTYPES\r
+\r
+int net_logon( void (*)() );\r
+void net_logoff( void );\r
+void net_attention( void );\r
+int net_send(int,message *);\r
+void net_ignore( void );\r
+\r
+#else\r
+\r
+int net_logon();\r
+void net_logoff();\r
+void net_attention();\r
+int net_send();\r
+void net_ignore();\r
+\r
+#endif\r
+\r
+#endif\r
+\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include <dos.h>\r
+#include "graf\graf.h"\r
+\r
+\r
+static union REGS r;\r
+\r
+#ifndef NO_PROTOTYPES\r
+static char *normalize(char *);\r
+static int mouse(int,word *,word *,word *);\r
+#else\r
+static char *normalize();\r
+static int mouse();\r
+#endif\r
+\r
+\r
+\r
+static char *normalize(addr) /* Normalize segmented address */\r
+ char *addr;\r
+{\r
+ union{\r
+ char *address;\r
+ unsigned int words[2];\r
+ } conv;\r
+ conv.address = addr;\r
+#if !WORD_32BIT\r
+ conv.words[1] += conv.words[0] / 16;\r
+ conv.words[0] %= 16;\r
+#endif\r
+ return (conv.address);\r
+}\r
+\r
+\r
+\r
+static int mouse(func, bx, cx, dx) /* Call mouse driver INT 33H */\r
+int func;\r
+word *bx, *cx, *dx;\r
+{\r
+ union REGS r;\r
+ r.x.ax = func;\r
+ r.x.bx = *bx;\r
+ r.x.cx = *cx;\r
+ r.x.dx = *dx;\r
+ int86(0x33, &r, &r);\r
+ *bx = (int) r.x.bx;\r
+ *cx = (int) r.x.cx;\r
+ *dx = (int) r.x.dx;\r
+ return(r.x.ax);\r
+}\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+ case GRON :\r
+ gron((int *) ¶m[ 0 ].xword);\r
+ graphmode = TRUE;\r
+ break;\r
+ \r
+ case GROFF :\r
+ groff();\r
+ graphmode = FALSE;\r
+ break;\r
+ \r
+ case CLS :\r
+ cls();\r
+ break;\r
+ \r
+ case POINT :\r
+ point((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case MOVE :\r
+ move((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case DRAW :\r
+ draw((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case HFILL :\r
+ hfill((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case VFILL :\r
+ vfill((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case COLOR :\r
+ color((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case STYLE :\r
+ style((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case PATERN :\r
+ patern((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,\r
+ (int *) ¶m[ 2 ].xword, (int *) ¶m[ 3 ].xword);\r
+ break;\r
+ \r
+ case INTENS :\r
+ intens((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case PALETT :\r
+ pallet((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case BORDER :\r
+ border((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case VIDEO :\r
+ if (member(¶m[ 0 ].xvirt, &am))\r
+ if (M[ am ] >= 0x8000L/sizeof(word))\r
+ video(normalize((char *) &M[ am+3 ]));\r
+ else errsignal(RTEILLAB);\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+\r
+ case HPAGE :\r
+ i = (int) param[ 1 ].xword;\r
+ if (i == 0) graphmode = FALSE;\r
+ else\r
+ if (i == 1) graphmode = TRUE;\r
+ hpage((int *) ¶m[ 0 ].xword, &i,\r
+ (int *) ¶m[ 2 ].xword);\r
+ break;\r
+\r
+ case NOCARD :\r
+ param[ 0 ].xword = nocard(NULL);\r
+ break;\r
+ \r
+ case PUSHXY :\r
+ pushxy();\r
+ break;\r
+ \r
+ case POPHXY :\r
+ popxy();\r
+ break;\r
+ \r
+ case INXPOS :\r
+ param[ 0 ].xword = inxpos(NULL);\r
+ break;\r
+ \r
+ case INYPOS :\r
+ param[ 0 ].xword = inypos(NULL);\r
+ break;\r
+\r
+ case INPIX :\r
+ param[ 2 ].xword = inpix((int *) ¶m[ 0 ].xword,\r
+ (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case GETMAP :\r
+ t1 = abs(param[ 0 ].xword-inxpos(NULL))+1; /* cols */\r
+ t2 = abs(param[ 1 ].xword-inypos(NULL))+1; /* rows */\r
+ t1 = (4+t1*t2+sizeof(word)-1)/sizeof(word); /* no. of words, pixel=byte */\r
+ newarry((word) 1, t1, (word)AINT, ¶m[ 2 ].xvirt, &am);\r
+ getmap((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,\r
+ normalize((char *) &M[ am+3 ]));\r
+ break;\r
+ \r
+ case PUTMAP :\r
+ if (member(¶m[ 0 ].xvirt, &am))\r
+ putmap(normalize((char *) &M[ am+3 ]));\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case ORMAP :\r
+ if (member(¶m[ 0 ].xvirt, &am))\r
+ ormap(normalize((char *) &M[ am+3 ]));\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case XORMAP :\r
+ if (member(¶m[ 0 ].xvirt, &am))\r
+ xormap(normalize((char *) &M[ am+3 ]));\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case TRACK :\r
+ track((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+\r
+ case INKEY :\r
+ param[ 0 ].xword = inkey(NULL);\r
+ break;\r
+\r
+ case HASCII :\r
+ hascii((int *) ¶m[ 0 ].xword);\r
+ break;\r
+\r
+ case HFONT :\r
+ hfont((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case HFONT8 :\r
+ param[ 0 ].xword = 0;\r
+ param[ 1 ].xword = 0;\r
+ hfont8((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case OUTSTRING :\r
+ t1 = strings+param[ 0 ].xword;\r
+ outhli((int *) &M[ t1 ], (char *) &M[ t1+1 ]);\r
+ break;\r
+\r
+ case CIRB :\r
+ r1 = param[ 3 ].xreal;\r
+ r2 = param[ 4 ].xreal;\r
+ cirb((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,\r
+ (int *) ¶m[ 2 ].xword, &r1, &r2,\r
+ (int *) ¶m[ 5 ].xword, (int *) ¶m[ 6 ].xword,\r
+ (int *) ¶m[ 7 ].xword, (int *) ¶m[ 8 ].xword);\r
+ break;\r
+\r
+/* MOUSE */\r
+\r
+ case INIT :\r
+ ax = mouse(0, ¶m[ 0 ].xword, &cx, &dx);\r
+ param[ 1 ].xbool = lbool(ax);\r
+ break;\r
+ \r
+ case SHOWCURSOR :\r
+ mouse(1, &bx, &cx, &dx);\r
+ break;\r
+ \r
+ case HIDECURSOR :\r
+ mouse(2, &bx, &cx, &dx);\r
+ break;\r
+ \r
+ case STATUS :\r
+ mouse(3, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);\r
+ param[ 2 ].xbool = lbool(bx & 0x01);\r
+ param[ 3 ].xbool = lbool(bx & 0x02);\r
+ param[ 4 ].xbool = lbool(bx & 0x04);\r
+ break;\r
+ \r
+ case SETPOSITION :\r
+ mouse(4, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case GETPRESS :\r
+ case GETRELEASE :\r
+ i = ( nrproc == GETPRESS ? 5 : 6 );\r
+ bx = param[ 0 ].xword;\r
+ ax = mouse(i, &bx, ¶m[ 1 ].xword, ¶m[ 2 ].xword);\r
+ param[ 4 ].xbool = lbool(ax & 0x01);\r
+ param[ 5 ].xbool = lbool(ax & 0x02);\r
+ param[ 6 ].xbool = lbool(ax & 0x04);\r
+ param[ 3 ].xword = bx;\r
+ break;\r
+ \r
+ case SETWINDOW :\r
+ mouse(7, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);\r
+ mouse(8, &bx, ¶m[ 2 ].xword, ¶m[ 3 ].xword);\r
+ break;\r
+ \r
+ case DEFCURSOR :\r
+ mouse(10, ¶m[ 0 ].xword, ¶m[ 1 ].xword,\r
+ ¶m[ 2 ].xword);\r
+ break;\r
+\r
+ case GETMOVEMENT :\r
+ mouse(11, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);\r
+ break;\r
+\r
+ case SETSPEED :\r
+ mouse(15, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);\r
+ break;\r
+\r
+ case SETMARGINS :\r
+ r.x.ax = 16;\r
+ r.x.cx = param[ 0 ].xword;\r
+ r.x.dx = param[ 2 ].xword;\r
+ r.x.si = param[ 1 ].xword;\r
+ r.x.di = param[ 3 ].xword;\r
+ int86(0x33, &r, &r);\r
+ break;\r
+ \r
+ case SETTHRESHOLD :\r
+ mouse(19, &bx, &cx, ¶m[ 0 ].xword);\r
+ break;\r
+\r
+\r
--- /dev/null
+/**\r
+ ** EVENTQUE.H\r
+ **\r
+ ** Copyright (C) 1992, Csaba Biegl\r
+ ** 820 Stirrup Dr, Nashville, TN, 37221\r
+ ** csaba@vuse.vanderbilt.edu\r
+ **\r
+ ** This file is distributed under the terms listed in the document\r
+ ** "copying.cb", available from the author at the address above.\r
+ ** A copy of "copying.cb" should accompany this file; if not, a copy\r
+ ** should be available from where this file was obtained. This file\r
+ ** may not be distributed without a verbatim copy of "copying.cb".\r
+ ** You should also have received a copy of the GNU General Public\r
+ ** License along with this program (it is in the file "copying");\r
+ ** if not, write to the Free Software Foundation, Inc., 675 Mass Ave,\r
+ ** Cambridge, MA 02139, USA.\r
+ **\r
+ ** This program is distributed in the hope that it will be useful,\r
+ ** but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ ** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ ** GNU General Public License for more details.\r
+ **/\r
+\r
+#ifndef _EVENTQUE_H_\r
+#define _EVENTQUE_H_\r
+\r
+#ifdef __cplusplus\r
+extern "C" {\r
+#endif\r
+\r
+/*\r
+ * structures:\r
+ * BE CAREFUL when hacking!!! -- 16 and 32 bit compilers have to generate\r
+ * the same alignments\r
+ */\r
+typedef struct {\r
+ unsigned char evt_type; /* event type: 0: keyboard, 1: mouse */\r
+ unsigned char evt_kbstat; /* keyboard status (ALT, SHIFT, etc..) */\r
+ unsigned char evt_mask; /* mouse event mask */\r
+ unsigned char evt_button; /* button status */\r
+ unsigned short evt_xpos; /* X coord (or keycode if keybd event) */\r
+ unsigned short evt_ypos; /* Y coord */\r
+ unsigned long evt_time; /* time stamp of event */\r
+#define evt_keycode evt_xpos /* reuse this slot for keybd events !! */\r
+#define evt_scancode evt_ypos /* store here the BIOS scan code */\r
+} EventRecord;\r
+\r
+typedef struct {\r
+ unsigned short evq_maxsize; /* max size of event queue */\r
+ unsigned short evq_cursize; /* number of events in the queue */\r
+ unsigned short evq_rdptr; /* next event to read */\r
+ unsigned short evq_wrptr; /* next event to be written */\r
+ short evq_xpos; /* current X coordinate of mouse */\r
+ short evq_ypos; /* current Y coordinate of mouse */\r
+ short evq_xmin; /* minimal mouse X coordinate */\r
+ short evq_ymin; /* minimal mouse Y coordinate */\r
+ short evq_xmax; /* maximal mouse X coordinate */\r
+ short evq_ymax; /* maximal mouse Y coordinate */\r
+ short evq_xspeed; /* horizontal speed (mickey/coord) */\r
+ short evq_yspeed; /* vertical speed (mickey/coord) */\r
+ unsigned short evq_thresh; /* fast movement threshold */\r
+ unsigned short evq_accel; /* multiplier for fast move */\r
+ unsigned char evq_drawmouse; /* interrupt handler has to draw mouse */\r
+ unsigned char evq_moved; /* set if mouse moved */\r
+ unsigned char evq_delchar; /* character removed from BIOS buffer */\r
+ unsigned char evq_enable; /* event generation control flag */\r
+ EventRecord evq_events[1]; /* event buffer space */\r
+} EventQueue;\r
+\r
+/*\r
+ * event types\r
+ */\r
+#define EVENT_KEYBD 0\r
+#define EVENT_MOUSE 1\r
+\r
+/*\r
+ * MOUSE event flag bits\r
+ * (also defined in "mousex.h" of the graphics library)\r
+ */\r
+#ifndef M_MOTION\r
+\r
+#define M_MOTION 0x001\r
+#define M_LEFT_DOWN 0x002\r
+#define M_LEFT_UP 0x004\r
+#define M_RIGHT_DOWN 0x008\r
+#define M_RIGHT_UP 0x010\r
+#define M_MIDDLE_DOWN 0x020\r
+#define M_MIDDLE_UP 0x040\r
+#define M_BUTTON_DOWN (M_LEFT_DOWN | M_MIDDLE_DOWN | M_RIGHT_DOWN)\r
+#define M_BUTTON_UP (M_LEFT_UP | M_MIDDLE_UP | M_RIGHT_UP)\r
+#define M_BUTTON_CHANGE (M_BUTTON_UP | M_BUTTON_DOWN )\r
+\r
+/*\r
+ * MOUSE button status bits\r
+ */\r
+#define M_LEFT 1\r
+#define M_RIGHT 2\r
+#define M_MIDDLE 4\r
+\r
+#endif /* M_MOTION */\r
+\r
+/*\r
+ * KEYBOARD status word bits\r
+ * (also defined in "mousex.h" of the graphics library)\r
+ */\r
+#ifndef KB_SHIFT\r
+\r
+#define KB_RIGHTSHIFT 0x01 /* right shift key depressed */\r
+#define KB_LEFTSHIFT 0x02 /* left shift key depressed */\r
+#define KB_CTRL 0x04 /* CTRL depressed */\r
+#define KB_ALT 0x08 /* ALT depressed */\r
+#define KB_SCROLLOCK 0x10 /* SCROLL LOCK active */\r
+#define KB_NUMLOCK 0x20 /* NUM LOCK active */\r
+#define KB_CAPSLOCK 0x40 /* CAPS LOCK active */\r
+#define KB_INSERT 0x80 /* INSERT state active */\r
+\r
+#define KB_SHIFT (KB_LEFTSHIFT | KB_RIGHTSHIFT)\r
+\r
+#endif /* KB_SHIFT */\r
+\r
+/*\r
+ * set this bit in 'evq_enable' to generate the corresponding event\r
+ */\r
+#define EVENT_ENABLE(type) (1 << (type))\r
+\r
+/*\r
+ * prototypes\r
+ */\r
+#if defined(__TURBOC__) && defined(FOR_GO32)\r
+EventQueue *EventQueueInit(int qsize,int ms_stksize,void (*msdraw)(void),int,int);\r
+#else\r
+EventQueue *EventQueueInit(int qsize,int ms_stksize,void (*msdraw)(void));\r
+#endif\r
+\r
+void EventQueueDeInit(void);\r
+int EventQueueNextEvent(EventQueue *q,EventRecord *e);\r
+\r
+#ifdef __cplusplus\r
+}\r
+#endif\r
+\r
+#endif /* whole file */\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include <assert.h>\r
+\r
+\r
+/* Execute one L-code instruction */\r
+\r
+\r
+void execute()\r
+{\r
+ word t1, t2;\r
+ int i;\r
+ real r;\r
+ virtaddr virt1, virt2, virt3;\r
+\r
+#ifdef TRACE\r
+ fprintf(stderr,"pix %d,ic %d,opcode %d\n",thispix,ic,opcode);fflush(stderr);\r
+#endif\r
+\r
+ switch (opcode)\r
+ {\r
+ case 1 : /* LOPENRC */\r
+ openrc(a3, &virt2, &t2);\r
+ storevirt(virt2, a1);\r
+ M[ a2 ] = t2;\r
+ break;\r
+ \r
+ case 2 : /* LBACKADDR */\r
+ storevirt(thisp->backobj, a1);\r
+ M[ a2 ] = M[ temporary ];\r
+ break;\r
+ \r
+ case 3 : /* LRAISE */\r
+ ic++; /* skip the address */\r
+ raise_signal(a3, M[ ic-1 ], &t1, &t2);\r
+ M[ a1 ] = t1;\r
+ M[ a2 ] = t2;\r
+ break;\r
+ \r
+ case 4 : /* LOPEN */\r
+ openobj(M[ a3 ], &t1, &t2);\r
+ M[ a1 ] = t1;\r
+ M[ a2 ] = t2;\r
+ break;\r
+ \r
+ case 5 : /* LSLOPEN */\r
+ loadvirt(virt3, a3);\r
+ slopen(M[ a3+APREF ], &virt3, &t1, &t2);\r
+ M[ a1 ] = t1;\r
+ M[ a2 ] = t2;\r
+ break;\r
+\r
+ case 15 : /* LTHIS */\r
+ virt1.addr = M[ display2+a2 ];\r
+ virt1.mark = M[ virt1.addr+1 ];\r
+ storevirt(virt1, a1);\r
+ break;\r
+\r
+ case 20 : /* LVIRTDISPL */\r
+ t2 = M[ display+a2 ];\r
+ t1 = M[ t2+PROTNUM ];\r
+ M[ a1 ] = M[ prototype[ t1 ]->virtlist+a3 ];\r
+ break;\r
+\r
+ case 21 : /* LSTATTYPE */\r
+ M[ a1 ] = a2;\r
+ M[ a1+1 ] = a3;\r
+ break;\r
+\r
+ case 23 : /* LIPAROUT */\r
+ M[ a1 ] = param[ a3 ].xword;\r
+ break;\r
+\r
+ case 24 : /* LRPAROUT */\r
+ MR(a1) = param[ a3 ].xreal;\r
+ break;\r
+\r
+ case 25 : /* LVPAROUT */\r
+ storevirt(param[ a3 ].xvirt, a1);\r
+ break;\r
+\r
+ case 31 : /* LSIGN */\r
+ if (M[ a2 ] == 0) M[ a1 ] = 0;\r
+ else\r
+ if (M[ a2 ] < 0) M[ a1 ] = -1;\r
+ else M[ a1 ] = 1;\r
+ break;\r
+ \r
+ case 33 : /* LLOWER */\r
+ case 34 :\r
+ loadvirt(virt2, a2);\r
+ if (member(&virt2, &t1))\r
+ {\r
+ switch ((int) M[ t1+PROTNUM ])\r
+ {\r
+ case AINT : t2 = APINT; break;\r
+ case AREAL : t2 = APREAL; break;\r
+ case AVIRT : t2 = APREF; break;\r
+ }\r
+ M[ a1 ] = (M[ t1+2 ]+3)/t2;\r
+ }\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case 35 : /* LUPPER */\r
+ case 36 :\r
+ loadvirt(virt2, a2);\r
+ if (member(&virt2, &t1))\r
+ {\r
+ switch ((int) M[ t1+PROTNUM ])\r
+ {\r
+ case AINT : t2 = APINT; break;\r
+ case AREAL : t2 = APREAL; break;\r
+ case AVIRT : t2 = APREF; break;\r
+ }\r
+ M[ a1 ] = (M[ t1+2 ]+M[ t1 ])/t2-1;\r
+ }\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case 40 : /* LGETTYPE */\r
+ typep(M[ a2 ], a3, &virt1.addr, &virt1.mark);\r
+ storevirt(virt1, a1);\r
+ break;\r
+ \r
+ case 41 : /* LCOPY */\r
+ loadvirt(virt2, a2);\r
+ copy(&virt2, &virt1);\r
+ storevirt(virt1, a1);\r
+ break;\r
+ \r
+ case 42 : /* LNOT */\r
+ M[ a1 ] = ~ M[ a2 ];\r
+ break;\r
+\r
+ case 43 : /* LRCVAVIRT */ /* recover virtual address from ah */\r
+ virt1.addr = M[ a2 ];\r
+ virt1.mark = M[ virt1.addr+1 ];\r
+ storevirt(virt1, a1);\r
+ break;\r
+\r
+ case 44 : /* LVIRTDOT */\r
+ case 45 :\r
+ M[ a1 ] = M[ prototype[ M[ temporary ] ]->virtlist+a2 ];\r
+ break;\r
+\r
+ case 46 : /* LADDRPH */\r
+ case 47 : /* LADDRPH2 */\r
+ loadvirt(virt2, a2);\r
+ if (!member(&virt2, &M[ a1 ])) errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case 48 : /* LIABS */\r
+ t2 = M[ a2 ];\r
+ M[ a1 ] = absolute(t2);\r
+ break;\r
+ \r
+ case 49 : /* LINEG */\r
+ M[ a1 ] = -M[ a2 ];\r
+ break;\r
+ \r
+ case 50 : /* LRABS */\r
+ r = MR(a2);\r
+ if( r < (real)0.0 )\r
+ r=(real)0.0-r;\r
+ MR(a1) = r;\r
+ break;\r
+ \r
+ case 51 : /* LRNEG */\r
+ MR(a1) = -MR(a2);\r
+ break;\r
+\r
+ case 52 : /* LPARAMADDR */\r
+ t2 = M[ a2 ];\r
+ M[ a1 ] = t2+M[ prototype[ M[ t2+PROTNUM ] ]->parlist+a3 ];\r
+ break;\r
+\r
+ case 54 : /* LLOADT */\r
+ t1 = M[ ic++ ]; /* offset */\r
+ t2 = t1+loadt(M[ M[ a2 ] ], a3); /* object address */\r
+ loadvirt(virt1, t2);\r
+ storevirt(virt1, a1);\r
+ break;\r
+ \r
+ case 55 : /* LIS */\r
+ loadvirt(virt2, a2);\r
+ M[ a1 ] = lbool(is(&virt2, a3));\r
+ break;\r
+ \r
+ case 56 : /* LIN */\r
+ loadvirt(virt2, a2);\r
+ M[ a1 ] = lbool(inl(&virt2, a3));\r
+ break;\r
+ \r
+ case 57 : /* LQUA */\r
+ loadvirt(virt2, a2);\r
+ if (member(&virt2, &M[ a1 ]))\r
+ qua(&virt2, a3);\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+\r
+ case 58 : /* LIFIX */\r
+ M[ a1 ] = (word)( MR(a2) );\r
+ break;\r
+ \r
+ case 59 : /* LFLOAT */\r
+ MR(a1) = (real)( M[ a2 ] );\r
+ break;\r
+ \r
+ case 60 : /* LIMOVE */\r
+ M[ a1 ] = M[ a2 ];\r
+ break;\r
+ \r
+ case 61 : /* LVMOVE */\r
+ loadvirt(virt1, a2);\r
+ storevirt(virt1, a1);\r
+ break;\r
+ \r
+ case 62 : /* LRMOVE */ /* WARNING: these areas may overlap! */\r
+ r = MR(a2);\r
+ MR(a1) = r;\r
+ break;\r
+\r
+ case 63 : /* LFPMOVE */ /* WARNING: these areas may overlap! */\r
+ loadvirt(virt1, a2); /* MACHINE DEPENDENT */\r
+ t1 = M[ a2+2 ];\r
+ storevirt(virt1, a1);\r
+ M[ a1+2 ] = t1;\r
+ break;\r
+\r
+ case 82 : /* LEQNONE */\r
+ M[ a1 ] = lbool(M[ a2+1 ] != M[ M[ a2 ]+1 ]);\r
+ break;\r
+ \r
+ case 83 : /* LNENONE */\r
+ M[ a1 ] = lbool(M[ a2+1 ] == M[ M[ a2 ]+1 ]);\r
+ break;\r
+ \r
+ case 87 : /* LMDFTYPE */ /* modify the formal type */\r
+ loadvirt(virt1, a2);\r
+ virt1.addr += a3; /* number of "arrayof" */\r
+ storevirt(virt1, a1);\r
+ break;\r
+\r
+ case 100 : /* LOR */\r
+ M[ a1 ] = M[ a2 ] | M[ a3 ];\r
+ break;\r
+ \r
+ case 101 : /* LAND */\r
+ M[ a1 ] = M[ a2 ] & M[ a3 ];\r
+ break;\r
+\r
+ case 102 : /* LARRAY */\r
+ case 103 :\r
+ case 104 :\r
+ loadvirt(virt2, a2);\r
+ if (member(&virt2, &t2))\r
+ {\r
+ t1 = M[ a3 ]-M[ t2+2 ]; /* index-lower+3 */\r
+ if (t1 < 3 || t1 >= M[ t2 ]) errsignal(RTEINVIN);\r
+ else M[ a1 ] = t2+t1;\r
+ }\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case 105 : /* LFARRAY */ /* without any tests */\r
+ t1 = M[ M[ a2 ] ]; /* physical address */\r
+ M[ a1 ] = t1+M[ a3 ]-M[ t1+2 ];\r
+ break;\r
+ \r
+ case 106 : /* LIEQUAL */\r
+ M[ a1 ] = lbool(M[ a2 ] == M[ a3 ]);\r
+ break;\r
+ \r
+ case 107 : /* LINEQUAL */\r
+ M[ a1 ] = lbool(M[ a2 ] != M[ a3 ]);\r
+ break;\r
+ \r
+ case 108 : /* LILT */\r
+ M[ a1 ] = lbool(M[ a2 ] < M[ a3 ]);\r
+ break;\r
+ \r
+ case 109 : /* LILE */\r
+ M[ a1 ] = lbool(M[ a2 ] <= M[ a3 ]);\r
+ break;\r
+ \r
+ case 110 : /* LIGT */\r
+ M[ a1 ] = lbool(M[ a2 ] > M[ a3 ]);\r
+ break;\r
+ \r
+ case 111 : /* LIGE */\r
+ M[ a1 ] = lbool(M[ a2 ] >= M[ a3 ]);\r
+ break;\r
+ \r
+ case 112 : /* LCOMBINE */\r
+ loadvirt(virt2, a2);\r
+ t1 = M[ a3 ];\r
+ storevirt(virt2, a1);\r
+ M[ a1+APREF ] = t1;\r
+ break;\r
+ \r
+ case 113 : /* LIADD */\r
+ M[ a1 ] = M[ a2 ]+M[ a3 ];\r
+ break;\r
+ \r
+ case 114 : /* LISUB */\r
+ M[ a1 ] = M[ a2 ]-M[ a3 ];\r
+ break;\r
+ \r
+ case 115 : /* LIMULT */\r
+ M[ a1 ] = M[ a2 ] * M[ a3 ];\r
+ break;\r
+ \r
+ case 116 : /* LSHIFT */\r
+ M[ a1 ] = shift(M[ a2 ], M[ a3 ]);\r
+ break;\r
+ \r
+ case 117 : /* LIDIVE */\r
+ if (M[ a3 ] == 0) errsignal(RTEDIVBZ);\r
+ else M[ a1 ] = M[ a2 ] / M[ a3 ];\r
+ break;\r
+ \r
+ case 118 : /* LIMODE */\r
+ if (M[ a3 ] == 0) errsignal(RTEDIVBZ);\r
+ else M[ a1 ] = M[ a2 ] % M[ a3 ];\r
+ break;\r
+\r
+ case 119 : /* LRADD */\r
+ MR(a1) = MR(a2)+MR(a3);\r
+ break;\r
+\r
+ case 120 : /* LRSUB */\r
+ MR(a1) = MR(a2)-MR(a3);\r
+ break;\r
+\r
+ case 121 : /* LRMULT */\r
+ MR(a1) = MR(a2) * MR(a3);\r
+ break;\r
+\r
+ case 122 : /* LRDIVE */\r
+ if (MR(a3) == (real)0.0) errsignal(RTEDIVBZ);\r
+ else MR(a1) = MR(a2) / MR(a3);\r
+ break;\r
+\r
+ case 123 : /* LEQREF */\r
+ loadvirt(virt2, a2);\r
+ loadvirt(virt3, a3);\r
+ if (member(&virt2, &t1))\r
+ M[ a1 ] = lbool(member(&virt3, &t2) && t1 == t2);\r
+ else M[ a1 ] = lbool(!member(&virt3, &t2));\r
+ break;\r
+ \r
+ case 124 : /* LNEREF */\r
+ loadvirt(virt2, a2);\r
+ loadvirt(virt3, a3);\r
+ if (member(&virt2, &t1))\r
+ M[ a1 ] = lbool(!member(&virt3, &t2) || t1 != t2);\r
+ else M[ a1 ] = lbool(member(&virt3, &t2));\r
+ break;\r
+ \r
+ case 125 : /* LREQ */\r
+ M[ a1 ] = lbool(MR(a2) == MR(a3));\r
+ break;\r
+ \r
+ case 126 : /* LRNE */\r
+ M[ a1 ] = lbool(MR(a2) != MR(a3));\r
+ break;\r
+ \r
+ case 127 : /* LRLT */\r
+ M[ a1 ] = lbool(MR(a2) < MR(a3));\r
+ break;\r
+ \r
+ case 128 : /* LRLE */\r
+ M[ a1 ] = lbool(MR(a2) <= MR(a3));\r
+ break;\r
+ \r
+ case 129 : /* LRGT */\r
+ M[ a1 ] = lbool(MR(a2) > MR(a3));\r
+ break;\r
+ \r
+ case 130 : /* LRGE */\r
+ M[ a1 ] = lbool(MR(a2) >= MR(a3));\r
+ break;\r
+ \r
+ case 131 : /* LXOR */\r
+ M[ a1 ] = M[ a2 ] ^ M[ a3 ];\r
+ break;\r
+\r
+ case 132 : /* LCALLPROCSTAND */\r
+#if USE_ALARM\r
+ alarm(0); /* reschedule forced so alarm may be switched off */\r
+#endif\r
+ reschedule=TRUE;\r
+ standard(a1);\r
+ break;\r
+\r
+ case 143 : /* LKILL */\r
+ loadvirt(virt1, a1);\r
+ disp(&virt1);\r
+ break;\r
+\r
+ case 144 : /* LHEADS */\r
+ loadvirt(virt1, a1);\r
+ heads(&virt1, a2);\r
+ break;\r
+\r
+ case 145 : /* LIPARINP */\r
+ param[ a3 ].xword = M[ a1 ];\r
+ break;\r
+ \r
+ case 146 : /* LGKILL */\r
+ loadvirt(virt1, a1);\r
+ gkill(&virt1);\r
+ break;\r
+\r
+ case 147 : /* LVPARINP */\r
+ loadvirt(param[ a3 ].xvirt, a1);\r
+ break;\r
+ \r
+ case 148 : /* LRPARINP */\r
+ param[ a3 ].xreal = MR(a1);\r
+ break;\r
+\r
+ case 149 : /* LQUATEST */\r
+ loadvirt(virt1, a1);\r
+ qua(&virt1, a2);\r
+ break;\r
+ \r
+ case 150 : /* LSTYPE */\r
+ loadvirt(virt1, a1);\r
+ typref(&virt1, a2);\r
+ break;\r
+ \r
+ case 151 : /* LIFFALSE */\r
+ if (M[ a1 ] == LFALSE) ic = a2;\r
+ break;\r
+ \r
+ case 152 : /* LIFTRUE */\r
+ if (M[ a1 ] == LTRUE) ic = a2;\r
+ break;\r
+ \r
+ case 159 : /* LGO */\r
+ go(M[ a2 ], M[ a1 ]);\r
+ break;\r
+ \r
+ case 160 : /* LGOLOCAL */\r
+ goloc(M[ a2 ], M[ a1 ]);\r
+ break;\r
+\r
+ case 170 : /* LDTYPE */\r
+ loadvirt(virt1, a1); /* left side type */\r
+ loadvirt(virt2, a2);\r
+ loadvirt(virt3, a3); /* right side type */\r
+ typed(virt1.addr, virt1.mark, virt3.addr, virt3.mark, &virt2);\r
+ break;\r
+ \r
+ case 172 : /* LTERMINATE */\r
+ term();\r
+ break;\r
+ \r
+ case 173 : /* LWIND */\r
+ wind();\r
+ break;\r
+\r
+ case 174 : /* LBLOCK2 */\r
+ goloc(thisp->blck1, thisp->blck2);\r
+ break;\r
+ \r
+ case 176 : /* LBLOCK3 */\r
+ disp(&thisp->backobj);\r
+ break;\r
+ \r
+ case 177 : /* LTRACE */\r
+ trace(a1);\r
+ break;\r
+\r
+ case 178 : /* LINNER */\r
+ inner(a1);\r
+ break;\r
+\r
+ case 180 : /* LBACKHD */\r
+ backhd(&thisp->backobj, &M[ temporary ]);\r
+ break;\r
+ \r
+ case 182 : /* LJUMP */\r
+ ic = a1;\r
+ break;\r
+\r
+ case 186 : /* LBLOCK1 */\r
+ openobj(a1, &thisp->blck1, &thisp->blck2);\r
+ break;\r
+ \r
+ case 187 : /* LDETACH */\r
+ detach();\r
+ break;\r
+ \r
+ case 188 : /* LATTACH */\r
+ loadvirt(virt1, a1);\r
+ attach(&virt1);\r
+ break;\r
+ \r
+ case 191 : /* LBACKBL */\r
+ backbl(&thisp->backobj, &M[ temporary ]);\r
+ break;\r
+ \r
+ case 192 : /* LBACKPR */\r
+ /* backpr(&thisp->backobj, &M[ temporary ]); */\r
+ back(&thisp->backobj, &M[ temporary ], (word) 0);\r
+ break;\r
+ \r
+ case 193 : /* LBACK */\r
+ back(&thisp->backobj, &M[ temporary ], (word) 0);\r
+ break;\r
+\r
+ case 194 : /* LFIN */\r
+ fin(ic-APOPCODE, &thisp->backobj, &M[ temporary ]);\r
+ break;\r
+ \r
+ case 195 : /* LCASE */\r
+ /* a2 = address of case description : */\r
+ /* minimal value, number of branches, */\r
+ /* remaining branches followed by "otherwise" code */\r
+ t1 = M[ a1 ]-M[ a2 ]; /* in 0..number of branches-1 */\r
+ if (t1 < 0 || t1 >= M[ a2+1 ])\r
+ ic = a2+2+M[ a2+1 ]; /* otherwise */\r
+ else\r
+ ic = M[ a2+2+t1 ]; /* indirect jump */\r
+ break;\r
+\r
+ case 220 : /* LRESUME */\r
+ loadvirt(virt1, a1);\r
+ resume(&virt1);\r
+ break;\r
+\r
+ case 221 : /* LSTOP */\r
+ passivate(STOPPED);\r
+ break;\r
+\r
+ case 222 : /* LKILLTEMP */\r
+ disp(&thisp->template);\r
+ break;\r
+\r
+ case 223 : /* LENABLE */\r
+ for (i = 0; i < a1; i++)\r
+ enable(thispix, virtprot(M[ ic++ ]));\r
+ evaluaterpc(thispix);\r
+ break;\r
+\r
+ case 224 : /* LDISABLE */\r
+ for (i = 0; i < a1; i++)\r
+ disable(thispix, virtprot(M[ ic++ ]));\r
+ break;\r
+\r
+ case 225 : /* LACCEPT1 */\r
+ rpc_accept(a1);\r
+ break;\r
+\r
+ case 226 : /* LACCEPT2 */\r
+ popmask(thispix);\r
+ rpc3();\r
+ break;\r
+\r
+ case 227 : /* LBACKRPC */\r
+ back(&thisp->backobj, &M[ temporary ], a1);\r
+ break;\r
+\r
+ case 228 : /* LASKPROT */\r
+ loadvirt(virt1, a1);\r
+ askprot(&virt1);\r
+ break;\r
+\r
+ case 240 : /* LSTEP */\r
+ if (M[ a1 ] < 0) errsignal(RTENEGST);\r
+ break;\r
+\r
+ default :\r
+ fprintf( stderr, "Invalid opcode\n" );\r
+ errsignal(RTESYSER);\r
+ break;\r
+ }\r
+\r
+}\r
+\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include <stdio.h>\r
+\r
+/* File I/O routines */\r
+\r
+void loadfile(status, ftype, am, fp) /* Load parameters of current file */\r
+word status; /* expected status of file */\r
+word *ftype; /* file type */\r
+word *am; /* file object address */\r
+FILE **fp; /* file stream pointer */\r
+{\r
+ word s;\r
+ virtaddr virt;\r
+\r
+ loadvirt(virt, currfile);\r
+ if (member(&virt, am)) /* file object exists */\r
+ {\r
+ s = M[ *am+FSTAT ]; /* check status */\r
+ if (status != s && status != UNKNOWN) errsignal(RTEILLIO);\r
+ *ftype = M[ *am+FTYPE ];\r
+ *fp = MF(*am+FFILE);\r
+ }\r
+ else errsignal(RTEREFTN); /* file not opened yet */\r
+} /* end loadfile */\r
+\r
+\r
+/* Open file object\r
+ */\r
+\r
+void genfileobj(ftemp, ftyp, fnam, virt, am)\r
+bool ftemp; /* TRUE iff file is temporary */\r
+word ftyp; /* file type */\r
+char *fnam; /* file name */\r
+virtaddr *virt; /* output virtual address */\r
+word *am; /* output physical address */\r
+{\r
+ word t1;\r
+\r
+ request((word) APFILE, &t1, am); /* generate file object */\r
+ virt->addr = t1;\r
+ virt->mark = M[ t1+1 ];\r
+ M[ *am+PROTNUM ] = FILEOBJECT;\r
+ M[ *am+FSTAT ] = UNKNOWN;\r
+ M[ *am+FTEMP ] = lbool(ftemp);\r
+ M[ *am+FTYPE ] = ftyp;\r
+ MN(*am+FNAME) = fnam;\r
+} /* end genfileobj */\r
+\r
+\r
+void reset(am) /* Prepare file for reading */\r
+word am;\r
+{\r
+ FILE *fp;\r
+\r
+ if (M[ am+FSTAT ] != UNKNOWN) /* first close file if opened */\r
+ if (fclose(MF(am+FFILE))) errsignal(RTEIOERR);\r
+ switch ((int) M[ am+FTYPE ])\r
+ {\r
+ case TEXTF : /* open text file for reading */\r
+ fp = fopen(MN(am+FNAME), "r");\r
+ M[ am+FSTAT ] = READING;\r
+ break;\r
+ \r
+ case CHARF : /* open binary file for reading */\r
+ case INTF :\r
+ case REALF :\r
+ fp = fopen(MN(am+FNAME), BINARYREAD);\r
+ M[ am+FSTAT ] = READING;\r
+ break;\r
+ \r
+ case DIRECT : /* open existing file for update */\r
+ fp = fopen(MN(am+FNAME), DIRECTOLD);\r
+ M[ am+FSTAT ] = UPDATING;\r
+ break;\r
+ }\r
+ if (fp == NULL)\r
+ {\r
+ M[ am+FSTAT ] = UNKNOWN;\r
+ errsignal(RTECNTOP);\r
+ }\r
+ MF(am+FFILE) = fp; /* store stream pointer */\r
+} /* end reset */\r
+\r
+ \r
+void rewrite(am) /* Prepare file for writing */\r
+word am;\r
+{\r
+ FILE *fp;\r
+\r
+ if (M[ am+FSTAT ] != UNKNOWN) /* first close file if opened */\r
+ if (fclose(MF(am+FFILE))) errsignal(RTEIOERR);\r
+\r
+ switch ((int) M[ am+FTYPE ])\r
+ {\r
+ case TEXTF : /* open text file for writing */\r
+ fp = fopen(MN(am+FNAME), "w");\r
+ M[ am+FSTAT ] = WRITING;\r
+ break;\r
+ \r
+ case CHARF : /* open binary file for writing */\r
+ case INTF :\r
+ case REALF :\r
+ fp = fopen(MN(am+FNAME), BINARYWRITE);\r
+ M[ am+FSTAT ] = WRITING;\r
+ break;\r
+ \r
+ case DIRECT : /* create new file for update */\r
+ fp = fopen(MN(am+FNAME), DIRECTNEW);\r
+ M[ am+FSTAT ] = UPDATING;\r
+ break;\r
+ }\r
+ if (fp == NULL)\r
+ {\r
+ M[ am+FSTAT ] = UNKNOWN;\r
+ errsignal(RTECNTOP);\r
+ }\r
+ MF(am+FFILE) = fp; /* store stream pointer */\r
+} /* end rewrite */\r
+\r
+\r
+void delete(virt) /* Delete file */\r
+virtaddr *virt;\r
+{\r
+ word am;\r
+\r
+ if (member(virt, &am))\r
+ {\r
+ if (M[ am+FSTAT ] != UNKNOWN) /* first close file if opened */\r
+ if (fclose(MF(am+FFILE))) errsignal(RTEIOERR);\r
+ if (unlink(MN(am+FNAME))) errsignal(RTEIOERR); /* delete file */\r
+ free(MN(am+FNAME)); /* free memory used by file name */\r
+ disp(virt); /* and kill file object */\r
+ }\r
+ else errsignal(RTEREFTN);\r
+} /* end delete */\r
+\r
+\r
+char *tempfilename() /* Generate temporary file name */\r
+{\r
+ char *cp;\r
+ static int tempcnt = 0;\r
+\r
+ cp = ballocate(10);\r
+ if (cp == NULL) errsignal(RTEMEMOV);\r
+ sprintf(cp, "LOG%05d", tempcnt++);\r
+ return (cp);\r
+} /* end tempfilename */\r
+\r
+\r
+bool testeof(fp) /* Test for end of file */\r
+FILE *fp;\r
+{\r
+ int ch;\r
+\r
+ ch = getc(fp);\r
+ ungetc(ch, fp);\r
+ return (ch == EOF);\r
+} /* end testeof */\r
+\r
+\r
+bool testeoln(fp) /* Test for end of line */\r
+FILE *fp;\r
+{\r
+ int ch;\r
+\r
+ ch = getc(fp);\r
+ ungetc(ch, fp);\r
+ return (ch == '\n');\r
+} /* end testeoln */\r
+\r
+\r
+void readln(fp) /* Skip to end of line */\r
+FILE *fp;\r
+{\r
+ int ch;\r
+\r
+ while ((ch = getc(fp)) != '\n' && ch != EOF) ;\r
+} /* end readln */\r
+\r
+\r
+static char str[10];\r
+word readint(fp) /* Read integer */\r
+FILE *fp;\r
+{\r
+ long i=0L;\r
+ int j=0,c=0;\r
+ int bool=0;\r
+ while(c<'0' || c>'9'){\r
+ if(c=='-') bool=1;\r
+ else bool=0;\r
+ c=fgetc(fp);\r
+ if(c==EOF){\r
+ errsignal(RTEBADFM);\r
+ goto END;\r
+ }\r
+ }\r
+ \r
+ do{\r
+ i=10*i+(c-'0');\r
+ j++;\r
+ c=fgetc(fp);\r
+ }while(c>='0' && c<='9');\r
+ if(c!=EOF) ungetc(c,fp);\r
+ if (j == 0 ) errsignal(RTEBADFM);\r
+ END:\r
+ if(bool)\r
+ return(-i);\r
+ else\r
+ return (i);\r
+} /* end readint */\r
+\r
+\r
+double readreal(fp) /* Read real */\r
+FILE *fp;\r
+{\r
+ double r;\r
+\r
+ if (fscanf(fp, "%lf", &r) != 1) errsignal(RTEBADFM);\r
+ return (r);\r
+} /* end readreal */\r
+\r
+\r
+void writeint(n, field, fp) /* Write integer */\r
+word n, field;\r
+FILE *fp;\r
+{\r
+/* PS&MM static char format[ 32 ];\r
+\r
+ sprintf(format,"%%%dld",(int)field); */\r
+ if (fprintf(fp, "%*ld", (int)field, (long) n) == 0) errsignal(RTEIOERR);\r
+} /* end writeint */\r
+\r
+\r
+void writereal(r, field1, field2, fp) /* Write real */\r
+double r;\r
+word field1, field2;\r
+FILE *fp;\r
+{\r
+/* PS&MM char format[ 32 ];\r
+\r
+ sprintf(format, "%%%d.%dlf", (int) field1, (int) field2);\r
+ if (fprintf(fp, format, r) == 0) errsignal(RTEIOERR);\r
+*/\r
+ if (fprintf(fp,"%*.*lf", (int)field1, (int)field2, r) == 0)\r
+ errsignal(RTEIOERR);\r
+} /* end writereal */\r
+\r
+\r
+void writestring(offset, field, fp) /* Write string */\r
+word offset;\r
+word field;\r
+FILE *fp;\r
+{\r
+ word len, addr;\r
+ char *cp;\r
+\r
+ addr = strings+offset;\r
+ len = M[ addr ];\r
+ cp = (char *) &M[ addr+1 ]; /* pointer to first char of string */\r
+ while (len-- > 0 && field-- != 0)\r
+ if (putc(*cp++, fp) == EOF) errsignal(RTEIOERR);\r
+} /* end writestring */\r
+\r
+\r
+word directio(buf, len, action, fp) /* Perform direct access read/write */\r
+virtaddr *buf; /* buffer array */\r
+word len; /* number of bytes to transfer */\r
+#ifndef NO_PROTOTYPES\r
+int (*action)(char *,int,int,FILE *); /* fread() or fwrite() */\r
+#else\r
+int (*action)(); /* fread() or fwrite() */\r
+#endif\r
+FILE *fp; /* stream pointer */\r
+{\r
+ word am, t1, result;\r
+ int n;\r
+\r
+ if (member(buf, &am)) /* file not none */\r
+ {\r
+ if (fseek(fp, 0L, 1)) errsignal(RTEIOERR); /* seek to current */\r
+ /* position required */\r
+ len = min(len, (M[ am ]-3)*sizeof(word)); /* check appetite */\r
+ result = 0; /* number of bytes transfered */\r
+ t1 = am+3; /* address in memory for transfer */\r
+ while (len >= IOBLOCK) /* transfer full blocks */\r
+ {\r
+ n = (*action)((char *) &M[ t1 ], 1, IOBLOCK, fp);\r
+ result += n;\r
+ if (n != IOBLOCK) return(result);\r
+ len -= IOBLOCK;\r
+ t1 += IOBLOCK/sizeof(word);\r
+ }\r
+ if (len > 0) /* transfer last unfilled block */\r
+ {\r
+ n = (*action)((char *) &M[ t1 ], 1, (int) len, fp);\r
+ result += n;\r
+ }\r
+ return(result);\r
+ }\r
+ else errsignal(RTEREFTN);\r
+} /* end directio */\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#ifdef GEN\r
+#undef GEN\r
+#endif\r
+\r
+#if UNIX\r
+#include "../gen/genint.h"\r
+#else\r
+#include "..\gen\genint.h"\r
+#endif\r
+\r
+/* Variables : */\r
+\r
+extern protdescr *prototype[];\r
+extern word ipradr; /* address of primitive type descriptions */\r
+extern word temporary; /* address of global temporary variables */\r
+extern word strings; /* base for string constants */\r
+extern word lastprot; /* the last used prototype number */\r
+extern word freem; /* first free cell in M */\r
+extern word currfile; /* current file virtual address */\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+#define isign(k, i) (((i) >= 0) ? (k) : -(k))
+#define iabs(i) ((i) >= 0 ? (i) : -(i))
+#define sqr(x) ((x)*(x))
+#define min0(x, y) ((x) < (y) ? (x) : (y))
+#define max0(x, y) ((x) > (y) ? (x) : (y))
+
+#define alf(i) alf_[i]
+#define ix(i) ix_[i]
+#define iy(i) iy_[i]
+#define sx(i) sx_[i]
+#define sy(i) sy_[i]
+#define d(i) d_[i]
+#define min(i) min_[i]
+#define max(i) max_[i]
+#define mx(i) mx_[i]
+#define mx1(i) mx1_[i]
+#define incr1(i) incr1_[i]
+#define incr2(i) incr2_[i]
+#define ip(i) ip_[i]
+#define sj(i) sj_[i]
+#define sc(i) sc_[i]
+#define bl(i) bl_[i]
+#define bxy(i) bxy_[i]
+#define bp(i) bp_[i]
+#define g(i,j) g_[i][j]
+#define go(i,j) go_[i][j]
+
+#define logical int
+#define FALSE 0
+#define TRUE 1
+#define INT(x) ((int) (x))
+#define FLOAT(x) ((float) (x))
+#define SIN(x) sin((double) (x))
+#define COS(x) cos((double) (x))
+#define SQRT(x) sqrt((double) (x))
+
+int pa = 3, qa = 4;
+float asp = 0.75;
+
+void pascal cirb(xi, yi, ri, alfa, beta, cbord, bcint, p, q)
+int *xi, *yi, *ri;
+float *alfa, *beta;
+int *cbord, *bcint, *p, *q;
+{
+ extern void pascal wyc47();
+
+ wyc47(*xi, *yi, (double) *ri, (double) *alfa, (double) *beta,
+ *cbord, *bcint, pa*(*p), qa*(*q), (double) 1.0);
+}
+
+/***********************************************************************
+void pascal rcirb(xr, yr, r, alfa, beta, cbord, bcint, p, q)
+float *xr, *yr, *r, *alfa, *beta;
+int *cbord, *bcint, *p, *q;
+{
+ extern void pascal wyc47();
+ extern float mix, miy, sxx, syy;
+ extern int mii, maj;
+
+ wyc47(mii+INT(sxx*(*xr-mix)), maj-INT(syy*(*yr-miy)), (double) *r,
+ (double) *alfa, (double) *beta,
+ *cbord, *bcint, pa*(*p), qa*(*q), (double) sxx);
+}
+***********************************************************************/
+
+void pascal wyc47(ir, jr, r, alfa, beta, cbord, bcint, p, q, cx)
+int ir, jr;
+double r, alfa, beta;
+int cbord, bcint, p, q;
+double cx;
+{
+ extern double sin(), cos(), sqrt();
+ extern void pascal move(), pascal hfill(), pascal pushxy(),
+ pascal popxy(), pascal color(), pascal style();
+
+ float alfj,qasp,pr,a,s,c;
+ float alf(2+1);
+ long p1,q1,p2,q2,p4,q4,u,v,w,d1;
+ int i,j,j1,j2,j3,k,l,n,m,m1,m2,ri,x,y,py,px1,
+ px2,sxi,sy1,sy2,xi,dj,dxj,dyj,inc1,
+ pa,qa;
+ int ix(2+1),iy(2+1),sx(2+1),sy(3+1),d(2+1),min(5+1),max(5+1),
+ mx(2+1),mx1(2+1),incr1(2+1),incr2(2+1),ip(2+1),sj(2+1),
+ sc(3+1),g(3+1,2+1),go(3+1,2+1);
+ logical bl(2+1),bxy(2+1),bp(3+1);
+ logical bc;
+ static int one = 1;
+
+ qasp=asp*FLOAT(q);
+ a=cx*r;
+ ri=INT(a);
+ pr=a*FLOAT(p);
+ q1=q*q;
+ q2=2*q1;
+ q4=2*q2;
+ p1=p*p;
+ p2=2*p1;
+ p4=2*p2;
+ for (i=1; i <= 3; i++)
+ {
+ bp(i)=FALSE;
+ for (j=1; j <= 2; j++)
+ {
+ go(i,j)=3;
+ g(i,j)=3;
+ }
+ }
+ sj(1)=1;
+ sj(2)=-1 ;
+ if(alfa == beta) {
+ n=2;
+ sc(1)=1;
+ sc(2)=-1;
+ bp(3)=TRUE;
+ bl(1)=TRUE;
+ bl(2)=TRUE;
+ goto L45;
+ }
+ alf(1)=alfa;
+ alf(2)=beta;
+
+ for (j=1; j <= 2; j++)
+ {
+ alfj=alf(j);
+ c=COS(alfj);
+ s=SIN(alfj);
+ a=pr/SQRT(sqr(p*c)+sqr(qasp*s));
+ m=INT(a*c);
+ sx(j)=isign(1,m);
+ ix(j)=m;
+ m=-INT(a*asp*s);
+ sy(j)=isign(1,m);
+ iy(j)=iabs(m);
+ }
+
+ sy1=sy(1);
+ sy2=sy(2);
+ sc(1)=sy1;
+ sc(2)=sy2;
+ if (sy1 >= 0) {
+ j1=1;
+ j2=2;
+ } else {
+ j1=2;
+ j2=1;
+ }
+
+ if (sy1 == sy2) {
+ m=sy1*(ix(2)-ix(1));
+ if (isign(1,m) > 0) {
+ n=1;
+ bp(2)=TRUE;
+ bp(3)=TRUE;
+ g(1,1)=j1;
+ g(1,2)=j2;
+ go(1,1)=j1;
+ go(1,2)=j2;
+ } else {
+ n=3;
+ sc(3)=-sy1;
+ g(1,2)=j2;
+ g(2,1)=j1;
+ go(1,2)=j2;
+ go(2,1)=j1;
+ }
+ } else {
+ n=2;
+ bp(3)=TRUE;
+ g(1,j1)=1;
+ g(2,j1)=2;
+ go(1,j1)=1;
+ go(2,j1)=2;
+ }
+
+ bl(1)=FALSE;
+ bl(2)=FALSE;
+
+ for (j=1; j <= 2; j++)
+ {
+ dxj=iabs(ix(j));
+ ix(j)=dxj;
+ dyj=iy(j);
+ ip(j)=0;
+ if (dyj > dxj) {
+ bxy(j)=TRUE;
+ m=2*dxj;
+ d(j)=m-dyj;
+ incr2(j)=2*(dxj-dyj);
+ } else {
+ bxy(j)=FALSE;
+ m=2*dyj;
+ d(j)=m-dxj;
+ incr2(j)=2*(dyj-dxj);
+ }
+ incr1(j)=m;
+ }
+
+
+ L45: u=0;
+ v=ri*p4;
+ d1=q2-p1*(2*ri-1);
+ x=ri;
+ min(3)=x;
+ max(3)=x;
+ bc=FALSE;
+ y=0;
+
+
+ L300: for (j=1; j <= 2; j++)
+ {
+ if (bl(j)) continue;
+ dj=d(j);
+ xi=ip(j);
+ min(j)=xi;
+ m=ix(j);
+ if (bxy(j)) {
+ max(j)=xi;
+ if (dj > 0) {
+ d(j)=dj+incr2(j);
+ if (xi >= m) bl(j)=TRUE;
+ ip(j)=xi+1;
+ } else {
+ d(j)=dj+incr1(j);
+ }
+ } else {
+ inc1=incr1(j);
+ L40: if (dj > 0) {
+ d(j)=dj+incr2(j);
+ ip(j)=xi+1;
+ max(j)=xi;
+ } else {
+ dj=dj+inc1;
+ xi=xi+1;
+ if (xi >= m) {
+ dj=1;
+ bl(j)=TRUE;
+ }
+ goto L40;
+ }
+ }
+ if (y == iy(j)) bl(j)=TRUE;
+ }
+
+
+ for (i=1; i <= n; i++)
+ {
+ if (bp(i)) continue;
+ j1=g(i,1);
+ j2=g(i,2);
+ if (j1 != 3) {
+ j3=j1;
+ l=1;
+ } else {
+ j3=j2;
+ l=2;
+ }
+ j=j1+j2;
+ sy(3)=sc(i);
+ if ((j == 4 || j == 5) && bl(j3)) {
+ m=ix(j3);
+ if (sy(j3) == sj(j3)*sx(j3)) {
+ bp(i)=TRUE;
+ min(j)=m;
+ max(j)=max0(max(3),m);
+ if (j1 != 3) {
+ j2=j;
+ } else {
+ j1=j;
+ }
+ } else {
+ g(i,l)=3;
+ sc(i)=sy(j3);
+ min(j3)=min0(min(j3),min(3));
+ }
+ } else {
+ if (j == 3) {
+ for (l=1; l <= 2; l++)
+ {
+ j=g(i,l);
+ if (bl(j)) {
+ g(i,l)=3;
+ sc(i)=sy(j);
+ min(j)=min0(min(j),min(3));
+ }
+ }
+ }
+ }
+
+ j=j1;
+ for (l=1; l <= 2; l++)
+ {
+ m1=max(j);
+ m2=min(j);
+ if (j < 3) {
+ sxi=sx(j);
+ } else {
+ sxi=-sj(l);
+ if (j == 3) {
+ k=go(i,l);
+ if (k < 3) {
+ m1=min0(m1,max(k));
+ m2=min0(m1,m2);
+ }
+ }
+ }
+ if (sxi > 0) {
+ mx(l)=ir+m2;
+ mx1(l)=ir+m1;
+ } else {
+ mx(l)=ir-m1;
+ mx1(l)=ir-m2;
+ }
+ j=j2;
+ }
+
+ py=jr+sy(j3)*y;
+ if (bcint != 0) {
+ px1=mx1(1)+1;
+ px2=mx(2)-1;
+ if (px1 <= px2) {
+ move(&px1,&py);
+ hfill(&px2);
+ }
+ }
+ pushxy();
+ color(&cbord);
+ style(&one);
+ move(&mx(1),&py);
+ hfill(&mx1(1));
+ move(&mx(2),&py);
+ hfill(&mx1(2)) ;
+ popxy();
+ }
+
+ if (x == 0) return;
+
+
+ if (bp(1) && bp(2) && bp(3)) return;
+ if (bc) goto L240;
+
+ u=u+q4;
+ if (d1 < 0) {
+ d1=d1+u+q2;
+ } else {
+ v=v-p4;
+ w=u-v;
+ if (w > 0) {
+ bc=TRUE;
+ w=w/2-v;
+ }
+ d1=d1+w+q2;
+ x=x-1;
+ }
+ y=y+1;
+ min(3)=x;
+ max(3)=x;
+ if (bc) goto L250;
+ goto L300;
+
+ L240: max(3)=x;
+ y=y+1;
+ L250: v=v-p4;
+ x=x-1;
+ if (d1 > 0) {
+ d1=d1-v+p2;
+ } else {
+ u=u+q4;
+ d1=d1+u-v+p2;
+ min(3)=x+1;
+ goto L300;
+ }
+ if (x > 0) goto L250;
+ min(3)=x;
+ goto L300;
+}
+\1a
+\r
--- /dev/null
+
+ Zestaw dystrybucyjny pakietu
+ podstawowych procedur graficznych IIUWGRAF
+ ( wersja 2.2 )
+
+
+1. IIUWGRAF TXT - dokumentacja
+
+ DISTRIB.TXT - niniejszy tekst
+ IIUWGRAF.DOC - podrecznik ( pod PWORDem )
+ IIUWGRAF.STY - definicja stylow ( WORD )
+ IIUWGRAF.DHN - podrecznik ( WORD, wersja DHN )
+ IIUWGRAF.POL - podrecznik ( bez polskich liter, do drukowania )
+ GRAPH.H - deklaracja procedur IIUWGRAFu dla MS Pascala
+
+
+2. IIUWGRAF_LB - biblioteki
+
+ HGCMSF.LIB - Hercules, MS Fortran/Pascal
+ HGCMSF4.LIB - Hercules, MS Fortran v.4.00
+ MGCMSF.LIB - IBM Color/Graphics, MS Fortran/Pascal
+ MGCMSF4.LIB - IBM Color/Graphics, MS Fortran v.4.00
+ MGC64MSF.LIB - IBM Color/Graphics (tryb 640*200),
+ MS Fortran/Pascal
+ MGC64MF4.LIB - IBM Color/Graphics (tryb 640*200),
+ MS Fortran v.4.00
+ HGCCS.LIB - Hercules, Lattice C model S
+ HGCCD.LIB - Hercules, Lattice C model D
+ HGCCP.LIB - Hercules, Lattice C model P
+ HGCCL.LIB - Hercules, Lattice C model L
+
+
+3. IIUWGRAF_LC - biblioteki ( Lattice C )
+
+ MGCCS.LIB - IBM Color/Graphics, Lattice C model S
+ MGCCD.LIB - IBM Color/Graphics, Lattice C model D
+ MGCCP.LIB - IBM Color/Graphics, Lattice C model P
+ MGCCL.LIB - IBM Color/Graphics, Lattice C model L
+ MGC64CS.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model S
+ MGC64CD.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model D
+ MGC64CP.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model P
+ MGC64CL.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model L
+
+
+4. HGCDEMO
+
+ HGCDEMO.EXE - program pokazowy dla karty Hercules
+ HGCFEDIT.EXE - edytor znakow ( Hercules )
+ DUMP1.DAT - dane dla programu pokazowego
+ DUMP2.DAT - dane dla programu pokazowego
+ HGCPRINT.EXE - program do drukowania obrazu graficznego,
+ ( Hercules )
+
+\f
+
+5. MGCDEMO
+
+ MGCDEMO.EXE - program pokazowy dla karty IBM Color/Graphics
+ MGCFEDIT.EXE - edytor znakow ( IBM Color/Graphics )
+
+ MGC64DEM.EXE - program pokazowy dla karty
+ IBM Color/Graphics ( tryb 640*200 )
+ MGC64FED.EXE - edytor znakow
+ ( IBM Color/Graphics, tryb 640*200 )
+ MGCPRINT.EXE - program do drukowania obrazu graficznego
+ ( IBM Color/Graphics )
+
+
+6. IIUWGRAF EGA ( zestaw dystrybucyjny dla karty EGA )
+
+ EGAMSF.LIB - biblioteka, MS Fortran/Pascal
+ EGAMSF4.LIB - biblioteka, MS Fortran v.4.00
+ EGACS.LIB - biblioteka, Lattice C model S
+ EGACD.LIB - biblioteka, Lattice C model D
+ EGACP.LIB - biblioteka, Lattice C model P
+ EGACL.LIB - biblioteka, Lattice C model L
+
+ EGADEMO.EXE - program pokazowy
+ EGAFEDIT.EXE - edytor znakow
--- /dev/null
+
+ FEDIT - a simple font editor for IBM PC
+ a companion to IIUWGRAF graphics library
+
+FEDIT allows to create and modify 8*8 pixel patterns. Such
+patterns may be displayed as part of graphics screen image
+via the "hascii" function.
+
+Font tables can be prepared by FEDIT in two formats:
+
+ - as an assembly subroutine,
+ delivering address of the font table
+ in the form suitable for passing to "hfont"
+ - as an independent program,
+ setting up pointer to the font table in
+ the location of interrupt vector 31.
+
+The first format can be used to replace the standard font
+usually found in ROM BIOS at location F000:FA6E. It is used
+by "hascii" for drawing character codes 0 to 127. The subroutine
+generated by FEDIT has to be linked together with the application.
+This is "base 0" format.
+FEDIT generates the subroutine with the name "hfont8". Should
+another name be desired (e.g. when font tables are to be switched
+dynamically), it may changed by hand in the assembly source.
+
+The second format is used when drawing characters from the
+extended range 128 to 255. This font has to be loaded into
+memory before execution of the application program that
+uses it by invoking the program generated by FEDIT.
+This is "base 128" format.
+FEDIT generates this table as part of an independent program,
+that sets up the vector address and exits via "terminate and
+stay resident".
+FEDIT and HGCGRAPHICS do not provide facilities for dynamic
+switching of this extended font table.
+
+
+For example,
+
+ integer*2 iseg,ioffs
+ call hfont8(iseg,ioffs)
+ ...
+ call hascii(45) ; uses ROM BIOS
+ call hascii(145) ; extended table
+ ...
+ call hfont(iseg,ioffs)
+ call hascii(45) ; uses FEDIT font
+ call hascii(145) ; same extended table
+ ....
+ call hfont(16#f000,16#fa6e)
+ call hascii(45) ; ROM BIOS again
+ call hascii(145) ; same extended table
+
+
+FEDIT is a simple conversational program with few commands. The basic
+idea is to have a table of 8*8 pixel patterns that can be modified
+interactively. A single character can be brought out of the table for
+editing and returned, possibly to a different position in the table.
+There are two tables, one for character codes 0 through 127, the other
+for codes 128 through 255. The first table is read-only. The second table
+can be initialized by an already resident extended font table, loaded
+from a FEDIT-created file or initialized as empty. The second table can be
+written out to file in one of two formats discussed above.
+
+FEDIT commands are entered as single keystrokes selecting the commands
+listed in a menu appearing on top of the screen.
+Additional parameters, if any, are prompted for.
+
+FEDIT commands:
+
+< low redisplays the 0 to 127 table
+
+> high redisplays the 128 to 255 table
+
+i init initializes 128 to 255 table to all zeros
+
+l load loads the 128 to 255 table from file;
+ asks for the file name
+
+d dump dumps the 128 to 255 table to file;
+ asks for the file name;
+ asks for base, which should be either 0 or
+ 128, indicating one of the two formats
+ asks for target:
+ f - ms fortran, ms pascal
+ s - lattice c, s model
+ p - lattice c, p model
+ d - lattice c, d model
+ l - lattice c, l model
+
+e edit brings a character into the editing area
+ asks for a character code (in decimal);
+ during editing, cursor keys may be used
+ to select pixel position, "INS" to set
+ the pixel on, "DEL" to set it off, "END"
+ to exit edit mode.
+
+t text accepts a short text that will be displayed
+ during the editing as an additional help
+ for judgement of the quality of the appearance
+ of currently edited character;
+ asks for vspace & hspace : horizontal & vertical
+ spacing between adjacent character boxes,
+ then waits for a string (at most 40 chars).
+
+p put saves the pattern in the editing buffer
+ in the font table;
+ asks for a code (in decimal) which should
+ be in the range 128 through 255
+
+q quit exits from FEDIT
+
+FEDIT is not foolproof, e.g. it will not survive an attempt to load
+a non-existing font file and it will overwrite an existing file
+without warning if asked to.
--- /dev/null
+ PROGRAMMER'S REFERENCE FOR GENIUS MOUSE DRIVER
+
+*** 1 : BRIEF DESCRIPTION
+
+The Genius Mouse Driver enables you to use mouse hardware to move an on-screen
+cursor and control its movement through a software program. Various functions
+allow you to determine cursor placement, cursor shape, and button status.
+
+In order for you to interface your Genius Mouse with an application program, the
+following information on the Genius Driver has been provided.
+
+*** 2 : GRAPHICS AND TEXT CURSORS
+
+GMOUSE Driver supports a hardware text cursor, a software text cursor, and
+a graphics cursor. A hardware text cursor is a blinking cursor which moves from
+one character to another on-screen. This blinking cursor may take the form of a
+block or underscore. A software text cursor makes use of display attributes to
+change the visual appearance of a character on-screen. Movement is from
+character to character. A graphics cursor is a shape that moves over on-screen
+images.
+
+You can choose any of these three cursors to use on-screen, however, only one
+cursor can be displayed at a given time. Also, within your application program,
+you can switch back and forth between cursors.
+
+
+Display the Graphics Cursor
+
+The cursor appears on-screen or disappears from the screen through the calling
+program. This cursor consists of a block of pixels. As this block moves
+on-screen and affects the pixels beneath it, the cursor shape and background are
+created. This interaction is defined by two 16-by-16 bit arrays;
+one is the screen mask and the other is the cursor mask. The screen mask
+determines what part of the cursor pixel is to be the shape, and what part is
+is to be the background. The cursor mask determines which pixels contribute to
+the color of the cursor. Whenever changes are made to the screen which lie
+directly beneath the cursor, the cursor should be concealed so that old values
+are not restored to the screen.
+
+Please note that with a high resolution mode, you have a 16-by-16 pixel block;
+with a medium resolution (four color) mode, you have a 8-by-16 pixel block; with
+a medium resolution (sixteen color) mode, you have a 4-by-16 pixel block.
+
+Refer to function 9.
+
+To create the cursor, the software uses data from the computer's screen memory
+which defines the color of each pixel on-screen. Operations are performed that
+affect individual screen bits. Software ANDs the screen mask defining the
+pixels under the cursor and XORs the cursor mask with the result of the AND
+operation.
+
+Note the results when:
+
+
+
+
+
+
+ page 1
+\f
+Screen Mask Bit is Cursor Mask Bit is Resulting Screen Bit is
+------------------ ------------------ -----------------------
+ 0 0 0
+ 0 1 1
+ 1 0 unchanged
+ 1 1 inverted
+
+With each mouse function, a reference to the graphics cursor location is in
+reference to a point on-screen directly beneath the cursor. This point that the
+mouse software uses to determine the cursor coordinates is known as the cursor's
+hot spot.
+Generally, the upper_left hand corner of the cursor block is designated as the
+coordinates for the cursor default value. ((0,0) are the upper_left hand corner
+coordinates.)
+
+Software Text Cursor
+
+You can use this text cursor when your computer is in one of the text modes. By
+changing the character attributes beneath the cursor, the appearance of the
+character is influenced on-screen. This effect on the text cursor can be
+defined by two 16-bit mask values. These bits can be described as follows:
+bit 15 sets the blinking (1) or non-blinking (0) character ; bit 12 - 14 set the
+background (1); bits 8 - 10 set the foreground color; and bits 0 - 7 set the
+character code. These values in the screen mask and the cursor mask
+determine the character's new attributes when the cursor is covering the
+character. The screen mask decides which of the character's attributes are
+maintained. The cursor mask decides in what manner the attributes are altered
+to produce the cursor.
+
+In creating this cursor, the software works from data which defines each
+character on the screen. The software first ANDs the screen mask and the screen
+data bit for the character beneath the cursor. Next, the software XORs the
+cursor mask and the result of the AND operation.
+
+When a function refers to the text cursor location, it gives the coordinates of
+the character beneath the cursor.
+
+Refer to function 10.
+
+Hardware Text Cursor
+
+This cursor is also available when the computer is in one of the text modes.
+This cursor is the one seen on-screen when the computer is powered on. It
+consists of 8 pixels wide and 8 to 14 pixels tall. Software allows you to use
+this cursor for your needs. Scan lines determine a cursor's appearance
+on-screen. A scan line consists of a horizontal set of pixels.
+If a line is on, there will be flashing on the screen. If a line is off, there
+is no effect. Scan lines are numbered from 0 to 7, or 0 to 11 depending on the
+type of display used. 0 indicates the top scan line.
+
+Refer to function 10.
+
+*** 2.1 : Mouse Buttons
+
+Mouse functions can give the status of the mouse buttons and the number of times
+a certain button has been pressed and released. The button status is given as
+an integer. If a bit is set to 1 the button is down; if a bit is set to 0, the
+button is up.
+ page 2
+\f
+ Bit 0 - Left Button Status
+ Bit 1 - Right Button Status
+ Bit 2 - Middle Button Status
+Each time a mouse button is pressed, a counter records the number of presses and
+releases. The software sets the counter to zero once it has been read or after
+a reset.
+
+*** 2.2 : Unit of Distance - Mouse Motion
+
+The motion of the mouse can be expressed in a unit of distance (mouse motion)
+and is approximately 1/200 of an inch.
+
+With mouse movement, mouse software determines a horizontal and vertical mouse
+motion count. This count is used by the software to move a cursor a certain
+number of pixels on-screen. Software defines mouse motion sensitivity (the
+number of mouse motions needed to move the cursor 8 pixels on-screen) and this
+sensitivity determines the rate at which the cursor moves on-screen.
+
+Refer to function 15.
+
+*** 2.3 : Internal Cursor Flag
+
+Mouse software supports an internal flag. This flag determines when the cursor
+should appear on-screen. If the flag equals 0, the cursor appears on-screen; if
+the flag is any other number, the cursor disappears from the screen.
+
+You can call functions 1 and 2 a number of times, however, if you call function
+2, you must call function 1 later. This is necessary to restore the flag's
+previous value.
+
+Refer to functions 1 and 2.
+
+*** 3 : CALLING FROM ASSEMBLY LANGUAGE PROGRAMS
+
+To make mouse function calls:
+
+Load the appropriate registers (AX, BX, CX, DX) with the parameter values.
+These correspond to G1%, G2%, G3%, and G4% as shown in the BASIC example to
+follow. Then execute software interrupt 51 (33H). The values given by the
+mouse functions will be installed in the registers.
+
+
+Example:
+
+ ; * set cursor to location (150,100)
+ Mov AX,4 ;(function call 4)
+ Mov CX,150 ;(set horizontal to 150)
+ Mov DX,100 ;(set vertical to 100)
+ Int 51(33H) ;(interrupt to mouse)
+
+It is important to note that before using INT 33H, one should verify the
+presence of the mouse driver. Executing an INT 33H will cause uncertain results
+if the mouse driver is not loaded. Assume a mouse driver is present when INT
+33H vector is non-zero and the vector does not point to an IRET instruction.
+
+Note: When making a mouse call in Assembly Language, expect somewhat of a
+different value for the fourth parameter (when compared with calls using a BASIC
+program) involving functions 9, 12, and 16.
+ page 3
+\f
+*** 4 : CALLING FROM BASIC LANGUAGE PROGRAM
+
+To make mouse function calls:
+
+ Set a pair of integer variables in your program for the offset and the segment
+ of the mouse driver entry point.
+
+ In order to obtain the offset and segment values, the following statements
+ must be inserted into your program before any calls to mouse functions:
+
+10 DEF SEG = 0
+15 ' GET GMOUSE ENTRY POINT
+20 GMSEG = PEEK( 51*4 + 2 ) + 256 * PEEK( 51*4 + 3 ) ' GET SEGMENT ENTRY
+30 GMOUSE = 2 + PEEK( 51*4 ) + 256 * PEEK( 51*4 + 1 ) ' GET OFFSET ENTRY
+40 DEF SEG = GMSEG ' SET SEGMENT REGISTER AS THE SEGMENT OF GMOUSE
+
+To enter the mouse driver, use the CALL statement:
+
+ CALL GMOUSE (G1%, G2%, G3%, G4%)
+
+GMOUSE contains the entry offset of the mouse driver. G1%, G2%, G3%, and G4%
+are the integer variables given in the call. These four must be specified in
+the CALL statement even if a value is not assigned. When a value is assigned,
+it must be an integer, that is, a whole number.
+
+Example:
+
+50 ' Find the Activated Mode of Genius Mouse
+60 G1% = 0 : G2% = 0
+70 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+80 IF G2% AND 2 THEN PRINT "Genius Mouse ( 2_Button Mode ) Enable"
+90 IF G2% AND 3 THEN PRINT "Genius Mouse ( 3_Button Mode ) Enable"
+100 IF NOT G1% THEN PRINT "Can't Find Genius Mouse"
+
+*** 5 : MOUSE FUNCTIONS
+
+These functions listed apply to the Genius Mouse. Further descriptions of each
+mouse function will be given in the following pages.
+
+Functions Function Number
+-----------------------------------------------------------------
+Reset Genius Mouse Driver 0
+Enable Cursor Display 1
+Disable Cursor Display 2
+Read Cursor Location & Button State of Genius Mouse 3
+Set Cursor Location of Genius Mouse 4
+Read Button Press State of Genius Mouse 5
+Read Button Release State of Genius Mouse 6
+Define Horizontal (X) Range of Cursor Location 7
+Define Vertical (Y) Range of Cursor Location 8
+Define Graphics Mode Cursor Style 9
+Define Text Mode Cursor Style 10
+Read Genius Mouse Motion Number 11
+Define Event Handler Entry Location 12
+Enable Light Pen Emulation Function 13
+Disable Light Pen Emulation Function 14
+Define Sensitivity (Mouse Motion/Pixel) of Genius Mouse 15
+
+ page 4
+\f
+Disable Cursor Display in Special Range 16
+Define Double-Speed Threshold 19
+
+EGA functions are described in Section *** 7.
+
+*** 6 : DESCRIPTION OF THE MOUSE FUNCTIONS
+
+You'll notice that with the following mouse function descriptions, the
+parameters needed to make the calls and the expected outcome (return) for each
+is indicated. Also, any special conditions regarding any of the mouse functions
+have been included. Further, an example of a program has been provided in order
+for you to understand how to make the call.
+
+The input and return values are presented for 8086 registers and for BASIC in
+the following pages.
+
+It is important to note that each mouse function call needs four parameters.
+The Genius Mouse software does not verify any input values, and therefore, if
+any incorrect values are given, uncertain results will occur.
+
+Function 0: Reset Genius Mouse Driver
+
+Function 0 gives the current status of the mouse hardware plus the current
+status of the mouse software. The calling program is able to determine the
+presence of a mouse driver and/or a serial port.
+
+This function resets the mouse driver to the following default status as
+indicated:
+
+Variable Value
+------------------------------------------------------------------------------
+internal cursor flag -1 (cursor concealed)
+graphics cursor shape horizontal oval
+text cursor reverse video
+user-defined call mask all zeroes
+light pen emulation mode enabled
+vertical mouse motion/pixel ratio 16 to 8
+horizontal mouse motion/pixel ratio 8 to 8
+vertical min/max cursor coordinates 0/current display mode y values minus 1
+horizontal min/max cursor coordinates 0/current display mode x values minus 1
+
+8086 Register
+Input: AX = 0
+Return: AX = mouse state (-1: installed, 0: not installed)
+ BX = number of buttons (2 button mode, 3 button mode)
+
+BASIC
+Input: G1% = 0
+Return: G1% = mouse state (-1: installed, 0: not installed)
+ G2% = number of buttons (2 button mode, 3 button mode)
+
+Example: Used initially to determine if the GMOUSE driver is present and to
+ reset GMOUSE.
+
+
+
+
+
+ page 5
+\f
+50 ' Find the Actived Mode of Genius Mouse
+60 G1% = 0 : G2% = 0
+70 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+80 IF G2% AND 2 THEN PRINT "Genius Mouse ( 2_Button Mode ) Enable"
+90 IF G2% AND 3 THEN PRINT "Genius Mouse ( 3_Button Mode ) Enable"
+100 IF NOT G1% THEN PRINT "Can't Find Genius Mouse"
+
+Function 1: Enable Cursor Display
+
+Function 1 increments the internal cursor flag counter. If the counter is zero,
+the cursor is enabled and appears on-screen.
+
+The default value is -1 which indicates a concealed cursor. Function 1 must be
+called to display the cursor. In case the internal cursor flag is already zero,
+a call to this function produces no effect.
+
+8086 Register
+Input: AX = 1
+Return: none
+
+BASIC
+Input: G1% = 1
+Return: none
+
+Example:
+
+110 ' Enable Genius Mouse's Cursor
+120 G1% = 1
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 2: Disable Cursor Display
+
+Function 2 disables the cursor by removing it from the screen and decrementing
+the internal cursor flag. Even though the cursor cannot be seen, it still
+tracks any motion made with the mouse.
+
+You should use this function before changing any portion of the screen
+containing the cursor. You will avoid the problem of the cursor affecting
+screen data.
+
+Keep in mind that whenever your program calls function 2, it must later call
+function 1 to return the internal cursor flag to its default value. In
+addition, if your program changes the screen mode, function 2 is called
+automatically. Therefore, the cursor's movement is enabled the next time it is
+displayed.
+
+Call function 2 at the end of a program in order to conceal the cursor. This
+ensures that nothing remains on-screen.
+
+8086 Register
+Input: AX = 2
+Return: none
+
+BASIC
+Input: G1% = 2
+Return: none
+
+Example:
+ page 6
+\f
+110 ' Disable Genius Mouse's Cursor
+120 G1% = 2
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 3: Read Cursor Location & Button State of Genius Mouse
+
+Function 3 gives the status of mouse buttons, plus cursor location.
+
+Button status consists of a single integer value:
+ Bit 0 = left button (2 button mode, 3 button mode)
+ Bit 1 = right button (2 button mode, 3 button mode)
+ Bit 2 = middle button (3 button mode)
+
+The bit is 1 when the button is pressed. The bit is 0 when the button is
+released.
+
+8086 Register
+Input: AX = 3
+Return: BX = button status
+ CX = horizontal cursor coordinate
+ DX = vertical cursor coordinate
+
+BASIC
+Input: G1% = 3
+Return: G2% = button status
+ G3% = horizontal cursor coordinate
+ G4% = vertical cursor coordinate
+
+Example:
+
+110 ' Read Genius Mouse Location & Button State
+120 G1% = 3
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 PRINT "Genius Mouse Location : X_Coord=" G3% " Y_Coord=" G4%
+150 IF G2% AND 1 THEN PRINT "Left Button"
+160 IF G2% AND 2 THEN PRINT "Right Button"
+170 IF G2% AND 4 THEN PRINT "Middle Button"
+180 PRINT "Pressed"
+
+Function 4: Set Cursor Location of Genius Mouse
+
+Function 4 sets the current cursor location. Values must be within the
+coordinate ranges for the virtual screen and, if necessary, are rounded to the
+nearest values allowed for the current screen mode.
+
+ Screen Display Virtual Cell Bits/Pixel
+ Mode Adapter Screen (XxY) Size Graphics Mode
+--------- ------------ --------------- -------- ----------------
+ 0 C, E, 3270 640 x 200 16 x 8 -
+ 1 C, E, 3270 640 x 200 16 x 8 -
+ 2 C, E, 3270 640 x 200 8 x 8 -
+ 3 C, E, 3270 640 x 200 8 x 8 -
+ 4 C, E, 3270 640 x 200 2 x 1 2
+ 5 C, E, 3270 640 x 200 2 x 1 2
+ 6 C, E, 3270 640 x 200 1 x 1 1
+ 7 M, E, 3270 640 x 200 8 x 8 -
+
+
+ page 7
+\f
+ D E 640 x 200 16 x 8 2
+ E E 640 x 200 1 x 1 1
+ F E 640 x 350 1 x 1 1
+ 10 E 640 x 350 1 x 1 1
+ 30 3270 720 x 350 1 x 1 1
+ H 720 x 348 1 x 1 1
+
+Display Adapter:
+ M = IBM Monochrome Display/Printer Adapter
+ C = IBM Color/Graphics Adapter
+ E = IBM Enhanced Graphics Adapter
+3270 = IBM All Points Addressable Graphics Adapter (3270 PC)
+ H = Hercules Monochrome Graphics Card
+
+8086 Register
+Input: AX = 4
+ CX = new horizontal cursor coordinate
+ DX = new vertical cursor coordinate
+Return: none
+
+BASIC
+Input: G1% = 4
+ G3% = new horizontal cursor coordinate
+ G4% = new vertical cursor coordinate
+Return: none
+
+Example:
+
+110 ' Set Cursor Location at the Upper_Left Corner of Screen
+120 G1% = 4
+130 G3% = 0 : G4% = 0
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 5: Read Button Press State of Genius Mouse
+
+Function 5 provides status on the specified button, gives the number of button
+presses since the last call, and produces the location of the cursor at last
+button press.
+
+Button status consists of a single integer value. Again, as in function 3:
+ Bit 0 = left button (2 button mode, 3 button mode)
+ Bit 1 = right button (2 button mode, 3 button mode)
+ Bit 2 = middle button (3 button mode)
+
+The bit is 1 when the button is pressed. The bit is 0 when the button is
+released.
+
+The number of button presses will always fall in the range of 0 to 32767. There
+is no indicator for overflow. Following this function call, the count is reset
+to zero.
+
+8086 Register
+Input: AX = 5
+ BX = button status (left = 0, right = 1, middle = 2)
+Return: AX = button status
+ BX = number of button presses
+ CX = horizontal cursor coordinate at last press
+ DX = vertical cursor coordinate at last press
+ page 8
+\f
+BASIC
+Input: G1% = 5
+ G2% = button status (left = 0, right = 1, middle = 2)
+Return: G1% = button status
+ G2% = number of button presses
+ G3% = horizontal cursor coordinate at last press
+ G4% = vertical cursor coordinate at last press
+
+Example:
+
+110 ' Read the Left Button Press State of Genius Mouse
+120 G1% = 5 : G2% = 2
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 IF G1% AND 2 THEN PRINT "The Middle Button Pressed at X_loc=" G3%
+
+Function 6: Read Button Release State of Genius Mouse
+
+Function 6 provides status on the specified button, gives the number of button
+releases since the last call, and provides the location of the cursor at the
+last button release.
+
+Button status consists of a single integer value. Again, as in function 3:
+ Bit 0 = left button (2 button mode, 3 button mode)
+ Bit 1 = right button (2 button mode, 3 button mode)
+ Bit 2 = middle button (3 button mode)
+
+The bit is 1 when the button is pressed. The bit is 0 when the button is
+released.
+
+The number of button releases will always fall in the range of 0 to 32767.
+There is no indicator for overflow. Following this function call, the count is
+reset to zero.
+
+8086 Register
+Input: AX = 6
+ BX = button status (left = 0, right = 1, middle = 2)
+Return: AX = button status
+ BX = number of button releases
+ CX = horizontal cursor coordinate at last release
+ DX = vertical cursor coordinate at last release
+
+BASIC
+Input: G1% = 6
+ G2% = button status (left = 0, right = 1, middle = 2)
+Return: G1% = button status
+ G2% = number of button releases
+ G3% = horizontal cursor coordinate at last release
+ G4% = vertical cursor coordinate at last release
+
+Example:
+
+110 ' Read the Left Button Release State of Genius Mouse
+120 G1% = 6 : G2% = 2
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 IF NOT G1% OR &HFFFB THEN PRINT "The Middle Button Released at X_loc=" G3%
+
+
+
+ page 9
+\f
+Function 7: Define Horizontal (X) Range of Cursor Location
+
+Function 7 defines the horizontal range of the cursor on-screen. As a result,
+cursor movement is limited to this specified area. If a cursor happens to be
+outside of this area when a call is made, the cursor is moved to just inside the
+area.
+
+8086 Register
+Input: AX = 7
+ CX = minimum horizontal cursor coordinate
+ DX = maximum horizontal cursor coordinate
+Return: none
+
+BASIC
+Input: G1% = 7
+ G3% = minimum horizontal cursor coordinate
+ G4% = maximum horizontal cursor coordinate
+Return: none
+
+Example:
+
+110 ' Enable Cursor in Horizontal Range between 100 to 200
+120 G1% = 7
+130 G2% = 100 : G3% = 200
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 8: Define Vertical (Y) Range of Cursor Location
+
+Function 8 defines the vertical range of the cursor on-screen. As a result,
+cursor movement is limited to this specified area. If a cursor happens to be
+outside of this area when a call is made, the cursor is moved to just inside the
+area.
+
+8086 Register
+Input: AX = 8
+ CX = minimum vertical cursor coordinate
+ DX = maximum vertical cursor coordinate
+Return: none
+
+BASIC
+Input: G1% = 8
+ G3% = minimum vertical cursor coordinate
+ G4% = maximum vertical cursor coordinate
+Return: none
+
+Example:
+
+110 ' Enable Cursor in Vertical Range between 100 to 200
+120 G1% = 8
+130 G2% = 100 : G3% = 200
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 9: Define Graphics Mode Cursor Style
+
+Function 9 defines the style of the cursor in terms of color, shape, and center
+for the graphics. As mentioned before, this cursor is a 16-by-16 pixel block
+and is defined by two 16-bit arrays (the screen mask bit and the cursor mask
+bit). Cursor coordinates for the hot spot must be in the range of -16 to +16.
+ page 10
+\f
+8086 Register
+Input: AX = 9
+ BX = horizontal cursor hot spot
+ CX = vertical cursor hot spot
+ DX = pointer to screen and cursor mask
+Return: none
+
+BASIC
+Input: G1% = 9
+ G2% = horizontal cursor hot spot
+ G3% = vertical cursor hot spot
+ G4% = pointer to screen and cursor mask
+Return: none
+
+Example:
+
+10 ' Define the screen mask
+20 '
+30 cursor (0,0) = &HFFFF '1111111111111111
+40 cursor (1,0) = &HFFFF '1111111111111111
+50 cursor (2,0) = &HFFFF '1111111111111111
+60 cursor (3,0) = &HFFFF '1111111111111111
+70 cursor (4,0) = &HFFFF '1111111111111111
+80 cursor (5,0) = &HF00F '1111000000001111
+90 cursor (6,0) = &H0000 '0000000000000000
+100 cursor (7,0) = &H0000 '0000000000000000
+110 cursor (8,0) = &H0000 '0000000000000000
+120 cursor (9,0) = &H0000 '0000000000000000
+130 cursor (10,0) = &HF00F '1111000000001111
+140 cursor (11,0) = &HFFFF '1111111111111111
+150 cursor (12,0) = &HFFFF '1111111111111111
+160 cursor (13,0) = &HFFFF '1111111111111111
+170 cursor (14,0) = &HFFFF '1111111111111111
+180 cursor (15,0) = &HFFFF '1111111111111111
+190 '
+200 ' Define the cursor mask
+210 '
+220 cursor (0,1) = &H0000 '0000000000000000
+230 cursor (1,1) = &H0000 '0000000000000000
+240 cursor (2,1) = &H0000 '0000000000000000
+250 cursor (3,1) = &H0000 '0000000000000000
+260 cursor (4,1) = &H0000 '0000000000000000
+270 cursor (5,1) = &H0000 '0000000000000000
+280 cursor (6,1) = &H07E0 '0000011111100000
+290 cursor (7,1) = &H7FFE '0111111111111110
+300 cursor (8,1) = &H7FFE '0111111111111110
+310 cursor (9,1) = &H07E0 '0000011111100000
+320 cursor (10,1) = &H0000 '0000000000000000
+330 cursor (11,1) = &H0000 '0000000000000000
+340 cursor (12,1) = &H0000 '0000000000000000
+350 cursor (13,1) = &H0000 '0000000000000000
+360 cursor (14,1) = &H0000 '0000000000000000
+370 cursor (15,1) = &H0000 '0000000000000000
+380 '
+390 ' Set the cursor style and hot spot number of Genius Mouse
+400 '
+
+
+ page 11
+\f
+410 '
+420 G1% = 9
+430 G2% = 6 ' horizontal hot spot
+440 G3% = 5 ' vertical hot spot
+450 CALL GMOUSE ( G1%, G2%, G3%, cursor (0,0))
+
+Function 10: Define Text Mode Cursor Style
+
+Function 10 chooses the hardware or the software text cursor.
+
+For example, if BX (G2%) is 1, the hardware cursor is selected and the hardware
+is set up with the first and last scan lines which define the cursor.
+(Values for CX (G3%) and DX (G4%) range from 0 to 7 for the color display and 0
+to 11 for the monochrome display.)
+
+If BX (G2%) is 0, the software cursor is selected; and CX (G3%) and DX (G4%)
+must specify the screen and cursor masks. (These masks give the attributes and
+character code of the cursor, and their values are dependent on the type of
+display in use.)
+
+8086 Register
+Input: AX = 10
+ BX = select cursor (0: software text, 1: hardware text)
+ CX = screen mask value/scan line start
+ DX = cursor mask value/scan line stop
+Return: none
+
+BASIC
+Input: G1% = 10
+ G2% = select cursor (0: software text, 1: hardware text)
+ G3% = screen mask value/scan line start
+ G4% = cursor mask value/scan line stop
+Return: none
+
+Example:
+
+110 ' Enable an Inverting Cursor
+120 G1% = 10
+130 G2% = 0
+140 G3% = &HFFFF : G4% = &H7700
+150 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 11: Read Genius Mouse Motion Number
+
+Function 11 gives the mouse motion number since the last call. A positive
+horizontal number indicates rightward movement (negative shows leftward
+movement). A positive vertical number indicates downward movement (negative
+shows upward movement).
+The number is always in the range of -32768 to 32767. Overflow is disregarded.
+Once the call is completed, the number is set to 0.
+
+8086 Registers
+Input: AX = 11
+Return: CX = horizontal number
+ DX = vertical number
+
+
+
+ page 12
+\f
+BASIC
+Input: G1% = 11
+Return: G3% = horizontal number
+ G4% = vertical number
+
+Example:
+
+110 ' Read Genius Mouse Motion Number
+120 G1% = 11
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 IF G3% > 0 THEN PRINT "Genius Mouse is Moving to Right"
+150 IF G4% > 0 THEN PRINT "Genius Mouse is Moving Down"
+
+Function 12: Define Event Handler Entry Location
+
+Function 12 defines the address entry location of an event handler routine which
+is called when a certain event (defined by the call mask) occurs. The program
+is temporarily interrupted by the mouse driver. At the end of the event handler
+routine the program continues at the point it was interrupted.
+
+The call mask is a single integer value defining the conditions which will cause
+an interrupt.
+
+A specific condition corresponds to a bit in the call mask:
+
+Mask Bit Condition
+--------------------------------------------------
+ 0 cursor location changed
+ 1 left button pressed
+ 2 left button released
+ 3 right button pressed
+ 4 right button released
+ 5 middle button pressed
+ 6 middle button released
+ 7 - 15 not used
+
+In order to call the event handler routine, set the mask bit to 1 and put the
+mask in at CX (G3%). To disable, set the mask bit to 0 and put the mask in at
+CX (G3%). Always be sure to set the call mask to 0 before the program finishes.
+(Leave the system in the same state upon exit as if was upon entrance.)
+
+8086 Register
+Input: AX = 12
+ CX = call mask
+ ES:DX = pointer to event handler routine
+Return: none
+
+BASIC
+Input: G1% = 12
+ G3% = call mask
+ G4% = pointer to event handler routine
+Return: none
+
+Example:
+
+
+
+
+ page 13
+\f
+110 ' Active BUTTDOWN Event Handler Routine, When One or More Buttons Pressed
+120 G1% = 12
+130 G3% = &H002A : G4% = BUTTDOWN%
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 13: Enable Light Pen Emulation Function
+
+Function 13 permits the mouse to act like a light pen. When in this mode, calls
+to the pen function will give the cursor coordinates at the last pen down
+location.
+
+Note that the status of "pen down" and "pen off-screen" is controlled by the
+mouse buttons: all buttons up, pen off-screen; one button pressed, pen down.
+
+Light pen emulation is ON after each call to function 0 (Reset Mouse Driver).
+
+8086 Register
+Input: AX = 13
+Return: none
+
+BASIC
+Input: G1% = 13
+Return: none
+
+Example:
+
+110 ' Enable Light Pen Emulation Function
+120 G1% = 13
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 14: Disable Light Pen Emulation Function
+
+Function 14 turns off the light pen emulation mode. When disabled, any call to
+the pen function will give information only about a real light pen.
+
+8086 Register
+Input: AX = 14
+Return: none
+
+BASIC
+Input: G1% = 14
+Return: none
+
+Example:
+
+110 ' Disable Light Pen Emulation Function
+120 G1% = 14
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 15: Define Sensitivity (Mouse Motion/Pixel) of Genius Mouse
+
+Function 15 defines mouse sensitivity as determined by the mouse motion/pixel
+ratio. This is a way of setting the amount of cursor motion wanted for mouse
+movement. These ratios specify mouse motion per 8 pixels. These values must
+be in the range of 1 to 32767. With a larger ratio, the cursor movement is
+shortened for each mouse movement.
+
+
+ page 14
+\f
+Default values: horizontal ratio - 8 mouse motions to 8 pixels
+ vertical ratio - 16 mouse motions to 8 pixels
+
+Note: 1 mouse motion = 1/200 of an inch increment
+
+8086 Register
+Input: AX = 15
+ CX = horizontal mouse motion counts to pixel ratio
+ DX = vertical mouse motion counts to pixel ratio
+Return: none
+
+BASIC
+Input: G1% = 15
+ G3% = horizontal mouse motion counts to pixel ratio
+ G4% = vertical mouse motion counts to pixel ratio
+Return: none
+
+Example:
+
+110 ' Define Horizontal Sensitivity as 8
+120 ' Define Vertical Sensitivity as 16
+130 G1% = 15
+140 G3% = 8
+150 G4% = 16
+160 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 16: Disable Cursor Display in Special Range
+
+Function 16 sets up a special range on-screen. If the cursor moves to this area
+or is in this area, it will be disabled. After a call is made to this function,
+it is necessary to call function 1 to enable the cursor again.
+
+Define the special range with screen location values using four components:
+
+Components Values
+--------------------------------------------------------
+ 1 Left horizontal screen location
+ 2 Upper vertical screen location
+ 3 Right horizontal screen location
+ 4 Lower vertical screen location
+
+8086 Register
+Input: AX = 16
+ ES:DX = pointer to special range
+Return: none
+
+BASIC
+Input: G1% = 16
+ G4% = pointer to special range
+Return: none
+
+Example:
+
+110 ' Disable Cursor Display in (0,0) to (100,100) Range
+120 G1% = 16
+130 RANGE%(1) = 0 : RANGE%(2) = 0
+140 RANGE%(3) = 100 : RANGE%(4) = 100
+150 CALL GMOUSE ( G1%, G2%, G3%, RANGE%(0) )
+ page 15
+\f
+ .
+ .
+ .
+
+500 ' Enable Cursor Display Again
+510 G1% = 1
+520 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 19: Define Double-Speed Threshold
+
+Function 19 defines the threshold value (mouse motion per second) for doubling
+the cursor's motion. Should the mouse move faster than the DX (G4%) value, the
+cursor motion doubles. The default value is 64 mouse motions per second.
+
+If you should want to disable double-speed, just set the threshold to 32767
+(7FFFH) mouse motions/second.
+
+8086 Register
+Input: AX = 19
+ DX = threshold speed in mouse motions/second
+Return: none
+
+BASIC
+Input: G1% = 19
+ G4% = threshold speed in mouse motions/second
+Return: none
+
+Example:
+
+110 ' Define Double-Speed Threshold as 20 Mouse Motions/Second
+120 G1% = 19
+130 G4% = 20
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+ .
+ .
+ .
+
+500 ' Disable Double-Speed Threshold Function
+510 G1% = 19
+520 G4% = 256 'MAX. VALUE
+530 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+*** 7 : USING GENIUS MOUSE WITH IBM ENHANCED GRAPHICS ADAPTER
+
+Within the Genius Mouse driver, you'll find nine EGA functions. These functions
+permit your program to write to and read from write-only registers.
+
+The cursor in use is defined as a monochrome cursor with one bit per pixel. The
+bit masks are determined by function 9 and apply to all active planes.
+
+In order to make an EGA function call from an Assembly-Language program, first
+load the AX, BX, CX, DX, and ES registers with the values indicated for the
+parameters. Note that five values must be given for a high level language
+program. Next, execute software interrupt 16 (10h). The values that are
+returned are intalled in the registers by EGA functions.
+
+
+ page 16
+\f
+Upon start with DOS, PC BIOS will verify if the EGA BIOS exists. When this is
+verified, the PC will execute the EGA BIOS, booting up the program to write the
+INT 10h entry vector to the address of the INT 42h vector. Now, EGA BIOS
+address will be written to INT 10h. Following this, you are able to call EGA
+BIOS (by using INT 10h) and PC video BIOS (by using INT 42h).
+
+There are twenty functions in EGA BIOS. (PC BIOS has only 16.) The EGA BIOS
+routines only intercept the BIOS ROM video routines (INT 10h, AH = 13h or less).
+
+The following indicates nine EGA functions and the corresponding function
+number:
+
+Function Number (HEX)
+-----------------------------------------------------------------
+Retrieve Single Data F0
+Save Single Data F1
+Retrieve Registers on a Specified Port F2
+Save Registers on a Specified Port F3
+Retrieve Several Registers Data F4
+Save Several Registers Data F5
+Reset All Registers as Initial Values F6
+Set Initial Values F7
+Get Version Number of Genius Mouse Driver FA
+
+In the above functions, the EGA I/O port number and address are as follows:
+
+Port No. Register Name No. of Registers Index No. Address Select Register
+------------------------------------------------------------------------------
+ 00H CRT Controller 25 0 - 24 3x4H
+ 08H Sequencer 5 0 - 4 3C4H
+ 10H Graphics Controller 9 0 - 8 3CEH
+ 18H Attribute Controlle 20 0 - 19 3C0H
+ Singular Registers
+ 20H Miscellaneous Output 1 ignored 3C2H
+ 28H Feature Control 1 ignored 3xAH
+ 30H Graphics 1 Position 1 ignored 3CCH
+ 38H Graphics 2 Position 1 ignored 3CAH
+
+ Note: x = B or D depending on the base I/O address;
+ determined by Miscellaneous Output Register bit 1.
+
+Function F0: Retrieve Single Data
+
+This function retrieves data from a single register.
+
+Input: AH = F0H
+ BX = Index number
+ DX = Port number
+Return: BL = Retrieved data from EGA register
+
+Example:
+
+FUN_F0 EQU 0f0H ; Function F0
+;
+GR_CONTR EQU 010H ; Graphics Controller
+MODE_REG EQU 005H ; Mode Regisiter
+;
+
+ page 17
+\f
+GR1_PORT EQU 030H ; Graphics 1 Position Register
+GR2_PORT EQU 038H ; Graphics 2 Position Register
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Retrieve the Mode Register in Graphics Controller
+MODE_REG DB 00
+ ;
+ MOV DX, GR_CONTR
+ MOV BX, MODE_REG
+ MOV AH, FUN_F0
+ INT VIDEO
+ MOV MODE_REG, BL
+
+
+ ; Retrieve Graphics 1 Position Data
+GR1_POS DB 00
+ ;
+ MOV DX, GR1_POS
+ MOV AH, FUN_F0
+ INT VIDEO
+ MOV GR1_POS, NL
+
+
+Function F1: Save Single Data
+
+This function saves data to an EGA register. Upon finishing a call to this
+function, the BH and DX values are altered.
+
+Input: AH = F1H
+ BL = Index number (Non-single register only)
+ = Data (Single register only)
+ BH = Data (Non-single register only)
+ = Disregard (Single register only)
+ DX = Port number
+Return: None
+
+Example:
+
+FUN_F1 EQU 0f1H ; Function F1
+;
+SEQUENCE EQU 008H ; Sequencer
+MASK_REG EQU 002H ; Map Mask Register
+;
+FEAT_PORT EQU 028H ; Feature Control Register
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+ ; Save Map Mask Register of Sequencer
+MAP_MASK EQU 03H
+ ;
+ MOV DX, SEQUENCE
+ MOV BL, MASK_REG
+ MOV BH, MAP_MASK
+ MOV AH, FUN_F1
+ INT VIDEO
+ MOV MAP_MASK, BL
+ page 18
+\f
+
+ ; Save Feature Control Register
+FEATURE DB 02H
+ ;
+ MOV DX, FEAT_PORT
+ MOV BL, FEATURE
+ MOV AH, FUN_F1
+ INT VIDEO
+ MOV FEATURE, BL
+
+Function F2: Retrieve Registers on a Specified Port
+
+This function retrieves data from registers on a specifiã port. Upon finishing
+a call to this function, the CX value is altered.
+
+Input: AH = F3H
+ CH = Starting index number
+ CL = Number of registers
+ DX = Port number
+ ES:BX = Destination of returned data
+Return: Returned data to destination address
+
+Example:
+
+FUN_F2 EQU 0f2H ; Function F2
+;
+GR_CONTR EQU 010H ; Graphics Controller
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Retrieve Four Registers Data from Graphics Controller
+GRAPH_POOL DB 04 DUP (0)
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV DX, GR_CONTR
+ MOV BX, OFFSET GRAPH_POOL
+ MOV CX, 04H
+ MOV AH, FUN_F2
+ INT VIDEO
+
+Function F3: Save Registers on a Specified Port
+
+This function saves data from registers on a specifiã port. Upon finishing a
+call to this function, the BX, CX, and DX values are altered.
+
+Input: AH = F3H
+ CH = Starting index number
+ CL = Number of register
+ DX = Port number
+ ES:BX = Address source of incoming data
+Return: None
+
+Example:
+
+ page 19
+\f
+FUN_F3 EQU 0f3H ; Function F3
+;
+ATTR_CONTR EQU 018H ; Attribute Controller
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Save Four Registers Data into Attribute Controller
+PALET_DATA DB 1, 2, 4, 3
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV DX, ATTR_CONTR
+ MOV BX, OFFSET PALET_DATA
+ MOV CX, 08
+ MOV AH, FUN_F3
+ INT VIDEO
+
+Function F4: Retrieve Several Registers Data At The Same Time
+
+This function retrieves data from several registers at the same time. Upon
+finishing a call to this function, the CX value is altered.
+
+Input: AH = F4H
+ CX = Number of registers (more than 1)
+ ES:BX = Address of register packet (each consists of 4 bytes;
+ port address, byte 1-2; index number, byte 3;
+ returned data, byte 4)
+Return: Returned data is saved into byte 4
+
+Example:
+
+FUN_F4 EQU 0f4H ; Function F4
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+ ; Retrieve Follow Registers Data
+TABLE DW 030H ; Graphics 1 Position Register
+ DB 00 ; Single Register
+ DB 00 ; Retrieved Data
+ ;
+ DW 010H ; Graphics Controller
+ DB 05 ; Mode Register
+ DB 00 ; Retrieved Data
+ ;
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV BX, OFFSET TABLE
+ MOV CX, 02
+ MOV AH, FUN_F4
+ INT VIDEO
+
+
+Function F5: Save Several Registers Data At The Same Time
+
+ page 20
+\f
+This function saves data from several registers at the same time. Upon
+finishing a call to this function, the CX value is altered.
+
+Input: AH = F5H
+ CX = Number of registers (more than 1)
+ ES:BX = Address of register packet (each consists of 4 bytes;
+ port number, byte 1-2; index number, byte 3;
+ output data, byte 4)
+Return: None
+
+Example:
+
+FUN_F5 EQU 0f5H ; Function F5
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+ ; Save Follow Registers Data
+TABLE DW 20H ; Miscellaneous
+ DB 00 ; Single Register
+ DB 01 ; Data
+ ;
+ DW 18H ; Attribute Controller
+ DB 12H ; Color Plane Enable
+ DB 07H ; Data
+ ;
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV BX, OFFSET TABLE
+ MOV CX, 02
+ MOV AH, FUN_F5
+ INT VIDEO
+
+Function F6: Reset All Registers as Initial Values
+
+This function resets all values to default values for the specific registers.
+Function 7 sets the default values.
+
+Input: AH = F6H
+Return: None
+
+Example:
+
+FUN_F6 EQU 0f6H ; Function F6h
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+ MOV AH, FUN_F6
+ INT VIDEO
+
+Function F7: Set Initial Values
+
+This function sets the initial default values. Upon finishing a call to this
+function, the BX and DX values are altered.
+
+ page 21
+\f
+Input: AH = F7H
+ DX = Port number
+ ES:BX = Table of output data
+Return: None
+
+Example:
+
+FUN_F7 EQU 0f7H ; Function F7
+;
+ATTR_CONTR EQU 018H ; Attribute Controller
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Setting Initial Values for the Attribute Controller
+ATTR_DATA DB 1, 2, 4, 3, 5, 6, 0, 7
+ DB 0, 0, 0, 0, 0, 0, 0, 0
+ DB 0, 0, 0fh, 0
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV DX, ATTR_CONTR
+ MOV BX, OFFSET ATTR_DATA
+ MOV AH, FUN_F7
+ INT VIDEO
+
+Function FA: Get Version Number of Genius Mouse Driver
+
+This function will give the Genius Mouse driver version number.
+
+Input: AH = FAH
+ BX = 00H
+Return: ES:BX = Pointer to Genius Mouse driver version number.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ page 22
+
+
--- /dev/null
+(* --------------------------------------------------------- *)
+(* HERCULES GRAPHICS FOR MICROSOFT PASCAL *)
+(* *)
+(* External subprograms header *)
+(*$list-,$symtab- *)
+type ads_of_byte = ads of byte;
+
+procedure GRON(consts imode: integer); external;
+procedure GROFF; external;
+procedure CLS; external;
+procedure POINT(consts ix,iy: integer); external;
+procedure MOVE(consts ix,iy: integer); external;
+procedure DRAW(consts ix,iy: integer); external;
+procedure HFILL(consts maxx: integer); external;
+procedure VFILL(consts maxy: integer); external;
+procedure COLOR(consts c: integer); external;
+procedure STYLE(consts s: integer); external;
+procedure PATERN(consts p1, p2, p3, p4: integer); external;
+procedure INTENS(consts i: integer); external;
+procedure PALLET(consts p: integer); external;
+procedure BORDER(consts b: integer); external;
+procedure VIDEO(ads_of_buffer: ads_of_byte); external;
+procedure HPAGE(consts page, mode, clear: integer); external;
+function NOCARD(consts idummy: integer): integer; external;
+procedure PUSHXY; external;
+procedure POPXY; external;
+function INXPOS(consts idummy: integer): integer; external;
+function INYPOS(consts idummy: integer): integer; external;
+function INPIX(consts x,y: integer): integer; external;
+procedure GETMAP(consts x,y: integer; ads_of_array: ads_of_byte); external;
+procedure PUTMAP(ads_of_array: ads_of_byte); external;
+procedure ORMAP(ads_of_array: ads_of_byte); external;
+procedure XORMAP(ads_of_array: ads_of_byte); external;
+procedure TRACK(consts x,y: integer); external;
+function INKEY(consts idummy: integer): integer; external;
+procedure HASCII(consts ic: integer); external;
+procedure HFONT(consts seg, offs: integer); external;
+procedure HFONT8(vars seg, offs: integer); external;
+procedure OUTHLI(consts n:integer; ads_of_buffer: ads_of_byte); external;
+procedure INHLIN(vars n:integer;ads_of_buffer: ads_of_byte); external;
+procedure MKWNDW(consts x,y,icols,ilines: integer; ads_of_window: ads_of_byte;
+ consts iwndwsize,iborder: integer); external;
+procedure BURY(ads_of_window: ads_of_byte); external;
+procedure EXPOSE(ads_of_window: ads_of_byte; consts x,y: integer); external;
+procedure OUTWLI(ads_of_window: ads_of_byte; consts n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure INWLIN(ads_of_window: ads_of_byte; vars n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure SWINDO(rw, iw: ads_of_byte; consts scale: integer); external;
+procedure RWINDO(rw: ads_of_byte; consts scale: integer); external;
+procedure RMOVE(consts rx,ry: real); external;
+procedure RDRAW(consts rx,ry: real); external;
+procedure CIRB(consts ix,iy,ir: integer; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+procedure RCIRB(consts ix,iy,ir: real; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+(*$list+ *)
+(* --------------------------------------------------------- *)
+
+\1a
\ No newline at end of file
--- /dev/null
+(* --------------------------------------------------------- *)
+(* IIUWGRAF GRAPHICS FOR MICROSOFT PASCAL *)
+(* *)
+(* External subprograms header *)
+(*$list-,$symtab- *)
+type ads_of_byte = ads of byte;
+
+procedure GRON(consts imode: integer); external;
+procedure GROFF; external;
+procedure CLS; external;
+procedure POINT(consts ix,iy: integer); external;
+procedure MOVE(consts ix,iy: integer); external;
+procedure DRAW(consts ix,iy: integer); external;
+procedure HFILL(consts maxx: integer); external;
+procedure VFILL(consts maxy: integer); external;
+procedure COLOR(consts c: integer); external;
+procedure STYLE(consts s: integer); external;
+procedure PATERN(consts p1, p2, p3, p4 : integer); external;
+procedure INTENS(consts i: integer); external;
+procedure PALLET(consts p: integer); external;
+procedure BORDER(consts b: integer); external;
+procedure VIDEO(ads_of_buffer: ads_of_byte); external;
+procedure HPAGE(consts page, mode, clear: integer); external;
+function SCREEN(consts idummy: integer): integer; external;
+procedure PUSHXY; external;
+procedure POPXY; external;
+function INXPOS(consts idummy: integer): integer; external;
+function INYPOS(consts idummy: integer): integer; external;
+function INPIX(consts x,y: integer): integer; external;
+procedure GETMAP(consts x,y: integer; ads_of_array: ads_of_byte); external;
+procedure PUTMAP(ads_of_array: ads_of_byte); external;
+procedure ORMAP(ads_of_array: ads_of_byte); external;
+procedure XORMAP(ads_of_array: ads_of_byte); external;
+procedure TRACK(consts x,y: integer); external;
+function INKEY(consts idummy: integer): integer; external;
+procedure HASCII(consts ic: integer); external;
+procedure HFONT(consts seg, offs: integer); external;
+procedure HFONT8(vars seg, offs: integer); external;
+procedure OUTHLI(consts n:integer; ads_of_buffer: ads_of_byte); external;
+procedure INHLIN(vars n:integer;ads_of_buffer: ads_of_byte); external;
+procedure MKWNDW(consts x,y,icols,ilines: integer; ads_of_window: ads_of_byte;
+ consts iwndwsize,iborder: integer); external;
+procedure BURY(ads_of_window: ads_of_byte); external;
+procedure EXPOSE(ads_of_window: ads_of_byte; consts x,y: integer); external;
+procedure OUTWLI(ads_of_window: ads_of_byte; consts n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure INWLIN(ads_of_window: ads_of_byte; vars n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure SWINDO(rw, iw: ads_of_byte; consts scale: integer); external;
+procedure RWINDO(rw: ads_of_byte; consts scale: integer); external;
+procedure RMOVE(consts rx,ry: real); external;
+procedure RDRAW(consts rx,ry: real); external;
+function RINXPO(consts dummy: real): real; external;
+function RINYPO(consts dummy: real): real; external;
+procedure CIRB(consts ix,iy,ir: integer; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+procedure RCIRB(consts ix,iy,ir: real; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+procedure PRTSCR; external;
+(*$list+ *)
+(* --------------------------------------------------------- *)
--- /dev/null
+you can find here certain information about graphics operation in
+
+LOGLAN version DOS
+________________________________________________________________________
+
+
+IIUWGRAF - basic graphics support for MICROSOFT compilers:
+
+ FORTRAN 77 vsn 3.31
+ PASCAL vsn 3.31
+ and
+ Lattice C vsn 2.14
+
+ for IBM color graphics card & Hercules II monochrome card
+
+
+
+Osrodek Obliczeniowy,
+Instytut Informatyki Uniwersytetu Warszawskiego,
+00-901 Warszawa, PKiN VIII p.
+tel. (0048)22-200211-4028
+
+
+
+
+
+general info
+------------
+
+ Drawing is done by issuing calls to subroutines which
+ modify the contents of a bitmap video buffer. Its contents
+ usually is directly displayed on the screen, so the
+ changes are seen immediately.
+ The video buffer assignment, however, can be changed to
+ point to a user-supplied block of memory. In this case,
+ the changes in bitmap setting are not displayed and even
+ putting the real screen into graphics mode is not necessary.
+ The drawing may be constructed silently, saved away
+ and restored later on an active display or output to
+ a binary file.
+ The Hercules card offers additional possibilities of fast
+ switching between two directly displayable pages.
+
+
+ The interface routines are on two different levels:
+
+ level 1 - screen management on pixel basis
+ uses actual screen indices
+
+ level 2 - positioning & drawing
+ in abstract world coordinates
+
+ Description of calling sequences for Fortran and C
+ are given together with explanations below. Pascal
+ declarations may be found in the "graph.h" include
+ file in the distribution set.
+
+
+
+LEVEL 1 ROUTINES
+________________
+
+All parameters not specified explicitly as arrays or reals
+are integers.
+All integer parameters are assumed to be "integer*2" (16 bits)
+in Fortran, "integer" in Pascal and "int" in C.
+
+screen address range:
+
+ 0 <= ix <= 719 for Hercules card
+ 0 <= iy <= 347
+
+ 0 <= ix <= 319 for IBM color card
+ 0 <= iy <= 199
+
+ 0 <= ix <= 639 for IBM color card in mono mode
+ 0 <= iy <= 199
+
+ (0,0) is top left pixel
+
+ (0,0)-----------> (ix,0)
+ |
+ |
+ |
+ V
+ (0,iy)
+
+
+Three separate libraries are supplied, each for a different
+kind of graphics screen:
+
+ HGCMSF for Hercules
+ MGCMSF for IBM card in full color mode
+ MGC64MSF for IBM card in mono mode
+
+These libraries follow Microsoft Fortran and Pascal calling
+conventions.
+Optionally, each of these libraries can be supplied in four
+variants, following four Lattice C models (S, D, P, L).
+
+initialization/termination routines
+-----------------------------------
+
+---------------------------------------------->> SCREEN
+
+Fortran: | C:
+ |
+i=screen(dummy) | int screen();
+ |
+
+ returns code identifying which library is being used
+
+ 1 for Hercules
+ 2 for IBM in full color 320*200
+ 3 for IBM in monochrome 640*200
+ 4 for IBM in monochrome 320*200
+
+
+---------------------------------------------->> GRAPH
+
+call graph(i) | graph(i);
+
+ switches display to graphics mode
+ clears entire screen
+ involves a delay of approx. 3 secs [ for Hercules only ]
+ for IBM color display, "i" sets either regular color mode,
+ or black&white mode, more suitable for use on monochrome
+ displays
+ i should be 1 for color mode 320*200
+
+
+---------------------------------------------->> TEXT
+
+call text | text();
+
+ switches display to character mode
+ does not change current video buffer assignment
+ fills screen with blanks
+ delays for 3 secs [ for Hercules only ]
+
+
+---------------------------------------------->> CLS
+
+call cls | cls();
+
+ clears current video buffer in graphics mode,
+ without turning display off
+
+
+---------------------------------------------->> HPAGE
+
+call hpage(nr, mode, cflag) | hpage(nr,mode,cflag);
+
+
+[Hercules II only]
+
+ controls access to both pages of Hercules-II;
+
+ "nr" - page number ( 0 or 1)
+ "mode" - 0 for text display,
+ 1 for graphics display,
+ -1 for buffering only (display not affected)
+ "cflag" - 0 for preserving previous contents
+ - 1 for clearing buffer contents
+
+ switching pages via "hpage" is done without delay if the mode
+ remains unchanged;
+ otherwise, "call graph" is equivalent to "call hpage(0,1,1)"
+ "call text" is equivalent to "call hpage(0,0,1)"
+
+ the typical animation loop may be done as follows:
+
+ call hpage(0,1,1)
+ c draw initial picture
+ ...
+ page=1
+ 1 continue
+ call hpage(1-page,1,0) ; set display
+ call hpage(page,-1,1) ; set buffer
+ c draw modified picture
+ ...
+ page=1-page
+ if (.not.finished) go to 1
+
+
+---------------------------------------------->> VIDEO
+
+call video(array) | video(array);
+ | char *array;
+
+ sets video buffer to "array", which should have
+ 32K bytes for Hercules, 16K bytes for IBM card.
+ "video" preserves the previous contents of "array".
+ Subsequent calls to drawing subroutines
+ will not affect screen display, picture
+ created in this buffer may be transferred
+ to actual display via "getmap"-"putmap",
+ or some other form of saving & restoring.
+
+
+
+mode setting routines
+---------------------
+
+
+---------------------------------------------->> COLOR
+
+call color(i) | color(i);
+
+ sets current color to i
+ for monochrome displays, 0 means black, non-0 - white
+ for color displays, 0 means background
+
+
+---------------------------------------------->> STYLE
+
+call style(i) | style(i);
+
+ sets style of lines and fill shades to a combination
+ of current color and background color (for mono -
+ white and black, respectively) according to 5 predefined
+ patterns:
+
+ 0 ....
+ 1 ****
+ 2 ***.
+ 3 **..
+ 4 *.*.
+ 5 *...
+
+ where '*' means curent color, '.' background color
+
+
+---------------------------------------------->> PATERN
+
+call patern(iv,io) | pattern(iv,io);
+
+ sets style of lines and fill shades to an explicitly specified
+ combination of colors : "iv" for even scan lines, "io" for odd.
+ Color encoding is decimal, allowing 4 pixels.
+ Lines are drawn always according to "iv".
+
+ Examples:
+
+ call patern(1100,0011)
+ is equivalent to
+ call color(1), call style(3)
+
+
+ call patern(1212,2121)
+ produces a shade that cannot be otherwise achieved
+ ( a dotted line consisting of pixels in colors 1 and 2 )
+
+
+---------------------------------------------->> BORDER
+
+call border(i) | border(i);
+
+[ IBM color mode only ]
+
+ sets actual background color to i ( i = 0,1,...,15 )
+
+
+---------------------------------------------->> PALLET
+
+call pallet(ip) | pallet(ip);
+
+[ IBM color mode only ]
+
+ changes current pallette to pallette ip ( 0 or 1 )
+ default pallette is 0
+
+
+---------------------------------------------->> INTENS
+
+call intens(i) | intens(i);
+
+[ IBM color mode only ]
+
+ changes current intensity, 1 means more intensity, 0 less;
+ default intensity is 1
+
+
+positioning routines
+--------------------
+
+
+---------------------------------------------->> MOVE
+
+call move(ix,iy) | move(ix,iy);
+
+ sets current position to (ix,iy)
+ picture remains unchanged
+
+
+---------------------------------------------->> INXPOS
+ INYPOS
+
+ix=inxpos(idummy) | int inxpos();
+
+ returns current x screen coordinate
+
+
+iy=inypos(idummy) | int inypos();
+
+ returns current y screen coordinate
+
+
+---------------------------------------------->> PUSHXY
+ POPXY
+
+call pushxy | pushxy();
+
+ pushes current position, color & mode
+ stack is kept internally, max depth is 16
+
+
+call popxy | popxy();
+
+ restores position, color & mode from internal stack
+
+
+---------------------------------------------->> TRACK
+
+call track(ix,iy) | track(ix,iy);
+
+ displays a small (8*8) arrow-shaped cursor which can be
+ moved around with cursor keys; a single keystroke moves
+ it by 5 pixels, in shift mode step size is 1 pixel;
+ "home" key returns the cursor to the initial (ix,iy);
+ "end" removes cursor from screen, and returns - its
+ position can be read with "in?pos" above.
+
+
+
+pixel operations
+----------------
+
+---------------------------------------------->> POINT
+
+call point(ix,iy) | point(ix,iy);
+
+ moves to pixel (ix,iy) and sets it to current color
+
+
+---------------------------------------------->> INPIX
+
+ic=inpix(ix,iy) | int inpix(ix,iy);
+
+ moves to pixel (ix,iy) and returns its color setting;
+ for Hercules and IBM monochrome mode 640*200 :
+ it will be 1 if pixel is on, 0 if it is off.
+
+
+
+line drawing
+------------
+
+---------------------------------------------->> DRAW
+
+call draw(ix,iy) | draw(ix,iy);
+
+ draws a line from current screen position to (ix,iy);
+ sets current position to (ix,iy);
+ line is drawn in current color, with both terminal pixels
+ always turned white ( non-background) for non-black
+ ( non-background ) line color.
+ Bresenham algorithm is used.
+
+
+---------------------------------------------->> CIRB
+
+call cirb(xi,yi,ri,alfa,beta,cbord,bcint,p,q)
+real alfa,beta
+
+[ not available in Lattice C ]
+
+ draws a circle (or ellipse, depending on aspect value),
+ optionally filling its interior; does not preserve position;
+ (xi,yi) - center coordinates
+ ri - radius in pixels (horizontally)
+ alfa, beta - starting & ending angles; if alfa=beta a full
+ circle is drawn; values should be given in radians;
+ cbord - border color
+ bcint - if .ne.0, interior is filled in current style&color
+ p,q - aspect ratio; if p/q=1, a perfect circle is drawn,
+ if p/q<1, the horizontal axis is longer, if p/q>1 - the vertical
+ axis is longer;
+
+
+
+bitmap operations
+-----------------
+
+---------------------------------------------->> GETMAP
+
+call getmap(ix,iy,iarray) | getmap(ix,iy,iarray);
+ | char *iarray;
+
+ saves rectangular area between current position as
+ top left corner and (ix,iy) as bottom right corner,
+ including border lines;
+ position remains unchanged.
+ "iarray" should have 4 + ( rows * ( 3 + cols div 8))
+ bytes.
+
+
+---------------------------------------------->> PUTMAP
+
+call putmap(iarray) | putmap(iarray);
+ | char *iarray;
+
+ sets rectangular area of screen pixels to that saved
+ by "getmap" in "iarray";
+ same size is restored, with top left corner in current
+ position;
+ position remains unchanged.
+
+
+---------------------------------------------->> ORMAP
+
+call ormap(iarray) | ormap(iarray);
+ | char *iarray;
+
+ same as putmap, but saved bitmap is or'ed into screen
+ rather than just set.
+
+
+---------------------------------------------->> XORMAP
+
+call xormap(iarray) | xormap(iarray);
+ | char *iarray;
+
+ same as putmap, but saved bitmap is xor'ed into screen
+ rather than just set.
+
+
+
+character i/o
+-------------
+
+---------------------------------------------->> INKEY
+
+ik=inkey(idummy) | int inkey();
+
+ returns next character from keyboard buffer;
+ 0 is returned if buffer is empty;
+ special keys are returned as negative numbers;
+ ALT-NUM method may be used for entering character codes
+ above 127 (this makes entering special keys 128-132
+ impossible);
+ if a character is returned, it is also removed
+ from the buffer, so MS-DOS will not see it (CTRL-C!);
+ typeahead is allowed, echo is suppressed.
+
+
+---------------------------------------------->> HASCII
+
+call hascii(ic) | hascii(ic);
+
+ 'xor's the character in a 8*8 box with top left corner
+ in the current position;
+ moves current position by (8,0);
+ character code 0 sets complete box to black ( background ),
+ with no change in position.
+ BIOS ROM font for IBM color card is used. If the font
+ table is not at F000:FA6E, the character will probably
+ be unrecognizable, and most certainly wrong.
+ For codes >127, table pointed to by interrupt vector 31
+ is used.
+
+
+---------------------------------------------->> HFONT
+
+call hfont(iseg,ioffs) | hfont(iseg,ioffs);
+
+ sets 8*8 horizontal font table address to iseg:ioffs.
+
+
+---------------------------------------------->> HFONT8
+
+call hfont8(iseg,ioffs) | hfont8(iseg,ioffs);
+
+ includes a copy of IBM ROM 8*8 font and returns address
+ suitable for passing to "hfont";
+ use of "hfont8" makes program larger but quarantees
+ BIOS ROM independence.
+
+
+
+line -oriented i/o
+-------------------
+
+---------------------------------------------->> OUTHLINE
+
+call outhline(n,l) | outhline(n,l);
+ | char *l;
+
+ call "hascii" "n" times with subsequent bytes
+ from "l" array as arguments;
+ before each character is written, "hascii(0)" is
+ called.
+
+
+---------------------------------------------->> INHLINE
+
+call inhline(n,l) | inhline(n,l);
+ | int *n;
+ | char *l;
+
+ reads a line of at most "n" characters from
+ the keyboard, storing them in the "l" array;
+ characters are echoed at current position with "hascii"
+ as they are typed in;
+ a blinking cursor prompts for the next character;
+ BACKSPACE works as expected, RETURN completes the line;
+ typing "n"-th character also completes the line;
+ "l" is blank filled up to "n" bytes;
+ on return "n" is the total number of characters read.
+
+
+
+window - oriented i/o
+---------------------
+
+---------------------------------------------->> MKWNDW
+
+call mkwndw(ix,iy,icols,ilines,iwndw,iwndwsize,iborder)
+
+ | mkwndw(ix,iy,icols,ilines,iwndw,iwndwsize,iborder);
+ | int ix,iy, icols, ilines;
+ | int iwndw[];
+ | int iwndwsize, iborder;
+
+ makes a tty-like scrollable window for "ilines" lines
+ of alphanumeric text of "icols" characters each;
+ top left corner of the window is located at (ix,iy);
+ if "iborder" is non-zero, the window will have a solid
+ border and a margin of 2 black pixels drawn around it;
+ "iwndw" should be an array large enough to "getmap"
+ complete window into it, leaving 20 bytes free,
+ however, if "bury" and "expose" are not to be applied to
+ the window, 20 bytes total size is enough;
+ "iwndwsize" is size of "wndw" array, it is ignored now.
+
+ Window just defines scrolling size for subsequent
+ line-oriented i/o. Anything drawn across it will
+ simply scroll. If you want to have overlapping
+ windows, all you need to implement that is here.
+
+
+---------------------------------------------->> BURY
+
+call bury(iwndw) | bury(iwndw);
+ | int iwndw[];
+
+ makes the window disappear from the screen;
+ the contents is saved away, so it may be "exposed" later;
+ "iwndw" should have appeared before in call to "mkwndw".
+ "bury" may be called only if the array supplied to "mkwndw"
+ is large enough.
+
+
+---------------------------------------------->> EXPOSE
+
+call expose(iwndw,ix,iy) | expose(iwndw,ix,iy);
+ | int iwndw[];
+
+ makes the window reappear at (ix,iy) as its new top
+ left corner;
+ the window should have been "buried" before.
+
+
+---------------------------------------------->> OUTWLINE
+
+call outwline(iwndw,n,l) | outwline(iwndw,n,l);
+ | int iwndw[];
+ | char *l;
+
+ outputs "n" characters from "l" array at bottom line
+ in window "iwndw", scrolling it appropriately;
+ "n" may be larger than window line length - output
+ will take as many window lines as needed;
+
+
+---------------------------------------------->> INWLINE
+
+call inwline(iwndw,n,l) | inwline(iwndw,n,l);
+ | int iwndw[];
+ | int *n;
+ | char *l;
+
+ reads in a line of at most "n" characters from
+ window "iwndw", putting them into "l" array;
+ prompts at bottom of the window with ":";
+ "n" may be larger than window size - it will be done
+ in as many window lines as needed;
+ BACKSPACE can be used to erase characters on bottom
+ window line only;
+ when specifying length, one should remember that the first
+ column is used by the prompt;
+ on return "n" is the total number of read characters.
+
+
+secret operations
+-----------------
+
+---------------------------------------------->> HFILL
+
+call hfill(ix) | hfill(ix);
+
+ fills current row (horizontally) from current position
+ (ix0,iy0) up to (ix,iy0) with bit pattern depending
+ on current color, style and/or pattern and position on
+ the screen in such a way that adjacent "hfill"ed" rows
+ will produce a shade simulating color;
+ does not change current position;
+
+
+---------------------------------------------->> VFILL
+
+call vfill(iy) | vfill(iy);
+
+ fills current column ( vertically ) from current
+ position (ix0,iy0) up to (ix0,iy) in a similiar way
+ that "hfill" does;
+ rectangular area "vfill'ed" is not distinguishable
+ on the screen from same shape "hfill'ed", except that
+ it will take much longer to fill.
+
+
+
+
+LEVEL 2 ROUTINES
+_________________
+
+
+ These accept coordinates a real numbers and translate
+ them to actual pixel positions according to a previously
+ specified "window" definition;
+
+
+abstract world window definition
+________________________________
+
+
+---------------------------------------------->> SWINDOW
+
+call swindow(r,i,scale) | swindow(r,i,scale);
+real r(4) | float r[4];
+integer*2 i(4),scale | int i[4],scale;
+
+ enables positioning & drawing in abstract world
+ coordinates ( cf. "rmove", "rdraw")
+
+ defines rectangular window
+
+ r(1) <= x <= r(2),
+ r(3) <= y <= r(4)
+
+ in center of the rectangular area of the screen
+ with top left corner in position (i(1),i(3))
+ and right bottom corner in position (i(2),i(4));
+ if "scale" equals 0, the real proportions are not
+ preserved: the abstract window is simply mapped to fit
+ the entire area of the screen, otherwise the window
+ is adjusted to reflect the aspect ratio of the screen;
+ abstract coordinates are mapped to the screen in the
+ follwing way:
+
+ (r(1),r(4))
+ ^
+ |
+ |
+ |
+ (r(1),r(3))--------------------->(r(2),r(3))
+
+
+---------------------------------------------->> RWINDOW
+
+call rwindow(r,scale) | rwindow(r,scale);
+real r(4) | float r[4];
+integer*2 scale | integer scale;
+
+ equivalent to "swindow", using the entire screen;
+ a margin of 1 pixel, however, is left on all sides
+ to circumvent rounding problems
+
+
+positioning
+___________
+
+
+---------------------------------------------->> RMOVE
+
+call rmove(rx,ry) | rmove(rx,ry);
+real rx,ry | float rx,ry;
+
+ sets current abstract world position to (rx,ry)
+ (rounded to nearest pixel) within a window
+ that should have been defined in a previous call
+ to "rwindow" or "swindow";
+ picture remains unchanged
+
+
+---------------------------------------------->> RINXPOS
+
+x=rinxpos(dummy)
+real dummy
+
+ returns abstract "x" coordinate in latest window of the
+ current pixel position;
+ will bomb out if there was no previous call to "rwindow"
+ or "swindow";
+ in case of "swindow" returned value may be negative;
+
+---------------------------------------------->> RINYPOS
+
+y=rinypos(dummy)
+real dummy
+
+ returns abstract "y" coordinate in latest window of the
+ current pixel position;
+ will bomb out if there was no previous call to "rwindow"
+ or "swindow";
+ in case of "swindow" returned value may be negative;
+
+
+drawing
+_______
+
+
+---------------------------------------------->> RDRAW
+
+call rdraw(rx,ry) | rdraw(rx,ry);
+real rx,ry | float rx,ry;
+
+ draws a line in current color from current screen
+ position to position (rx,ry) in abstract world
+ coordinates ( using LEVEL 1 "draw" internally );
+ sets current position to (rx,ry) (rounded);
+ the window should have been defined before as for "rdraw".
+
+---------------------------------------------->> RCIRB
+
+call rcirb(xr,yr,rr,alfa,beta,cbord,bcint,p,q)
+real alfa,beta
+
+[not available in Lattice C]
+
+ draws a circle (or ellipse), accepting center coordinates
+ and radius value in abstract coordinates,
+ optionally filling its interior; does not preserve position;
+ (xr,yr) - center coordinates
+ rr - radius (scaled horizontally)
+ alfa, beta - starting & ending angles; if alfa=beta a full
+ circle is drawn; values should be given in radians;
+ cbord - border color
+ bcint - if .ne.0 , interior is filled in current style&color
+ p,q - aspect ratio; if p/q=1, a perfect circle is drawn,
+ if p/q<1, the horizontal axis is longer, if p/q>1 - the vertical
+ axis is longer;
+
+
+
+OTHER USEFUL THINGS
+___________________
+
+ Program "hgcprint.com", when called, sets up the system to
+ make hardcopy of HERCULES graphics image on a GEMINI STAR 10
+ dot matrix printer in the same way as MS-DOS GRAPHICS command
+ does for the color/graphics card.
+ To make the hardcopy, press SHIFT-PrtSc.
+ This will work only in graphics mode.
+
+ Note
+ Actually one cannot make hardcopy of IBM color graphics.
+
+
+A NOTE ON LINKING PASCAL PROGRAMS
+---------------------------------
+
+ When linking Pascal programs which call one of the following:
+
+ mkwndw inhlin outhlin bury window cirb rcirb
+ track inwlin outwlin expose rmove rdraw
+
+ linker will complain about the missing library FORTRAN.LIB.
+ Just ignore this complaint (simply type CR).
+
+
+A NOTE ON LINKING C PROGRAMS
+----------------------------
+
+ When linking C programs using one of the following:
+
+ rwindow swindow rmove rdraw rcirb cirb
+
+ keep in mind that the following global names
+ are used internally:
+
+ wir* (e.g. wirmix, wirmiy, etc.)
+ pqasp* (e.g. pqaspp, pqaspq, etc.)
+
--- /dev/null
+
+
+
+
+
+
+
+
+
+
+
+ IIUWGRAF
+
+ biblioteczka podstawowych procedur graficznych
+
+ moze wspolpracowac z kompilatorami firmy Microsoft:
+
+ Fortran 77 wersja 3.31 i 4.00
+ Pascal wersja 3.31
+
+ oraz
+
+ C (Lattice) wersja 3.10
+ Aztec C wersja 3.20d
+
+
+
+ dla IBM PC/XT
+
+ obsluguje karty IBM color/graphics, Hercules II oraz EGA
+
+
+
+
+
+
+ wersja 2.2, grudzien 1987
+
+
+
+
+
+
+
+Autorzy:
+
+ Piotr Carlson
+ Miroslawa Milkowska - procedury poziomu 1
+
+ Janina Jankowska
+ Michal Jankowski - procedury poziomu 2
+
+
+Osrodek Obliczeniowy Instytutu Informatyki
+Uniwersytet Warszawski\f
+
+
+ 2
+
+
+
+Spis tresci
+
+
+Informacje ogolne 3
+Procedury poziomu 1 4
+Procedury ustawiania trybu 5
+Procedury sterujace kolorami 8
+Procedury ustawiania pozycji 11
+Procedury obslugujace punkty 12
+Procedury rysowania linii 13
+Procedury operujace na fragmentach ekranu 15
+Procedury wejscia/wyjscia dla pojedynczych znakow 16
+Procedury wejscia/wyjscia dla linii 18
+Procedury wejscia/wyjscia dla okienek 19
+Procedury poziomu 2 20
+Informacje dodatkowe 22
+Procedury dodatkowe 22
+
+
+
+Dodatki
+
+A. Uzycie IIUWGRAFu z FORTRANem 77 23
+B. Uzycie IIUWGRAFu z Pascalem 24
+C. Uzycie IIUWGRAFu z Lattice C 25
+D. Uzycie IIUWGRAFu z LOGLANem 26
+E. Wykaz specyfikacji procedur IIUWGRAFu 27
+F. Wartosci kodow klawiszy specjalnych 29
+G. FEDIT - prosty program do edycji kroju znakow 30
+H. Zmiany IIUWGRAFu w stosunku do poprzednich wersji 33
+\f
+
+
+ 3
+
+
+
+Informacje ogolne
+
+
+
+ Rysunek jest tworzony na ekranie monitora za pomoca
+szeregu wywolan procedur bibliotecznych IIUWGRAF. Modyfikuja
+one zawartosc bufora mapy bitowej, ktora jest zwykle
+bezposrednio wyswietlana na ekranie. Zmiany te sa wtedy
+widoczne natychmiast. Umiejscowienie bufora roboczego moze
+byc jednak zmienione, tak aby byl on zwiazany z obszarem
+pamieci dostarczonym przez uzytkownika. W tym przypadku
+zmiany jego zawartosci oczywiscie nie sa wyswietlane, a
+nawet przestawienie monitora w tryb graficzny nie jest
+konieczne. Rysunek moze byc wtedy skonstruowany w pamieci,
+bez wyswietlania, przechowany na dysku w postaci binarnej i
+odtworzony pozniej na ekranie. Omowiony tryb pracy jest
+mozliwy jednak tylko dla karty Hercules II oraz karty IBM.
+ W opisie procedur slowo ekran, tam gdzie mowa o jego
+zawartosci, nalezy rozumiec wlasnie jako bufor roboczy.
+
+ Karty Hercules II oraz EGA daja dodatkowa mozliwosc
+blyskawicznego przelaczania pomiedzy dwiema
+rownouprawnionymi stronami graficznymi.
+
+ W wersji podstawowej karta graficzna EGA posiada
+64K bajty pamieci. Pamiec ta moze byc zwiekszona do 128K
+oraz 256K bajtow. Opisane ponizej procedury graficzne
+dotycza w zasadzie karty EGA z pelna pamiecia 256K bajtow.
+Tylko w tej wersji karty mozna bowiem uzywac 16 kolorow
+( z 64 istniejacych ) oraz dwoch stron graficznych. W obu
+wersjach z mniejsza pamiecia istnieje tylko jedna strona
+graficzna, a ponadto w wersji podstawowej uzytkownik ma
+mozliwosc korzystania tylko z 4 kolorow (z 16 istniejacych).
+
+ Dostarczone sa cztery zestawy oddzielnych bibliotek
+IIUWGRAF, kazda dla innego rodzaju ekranu:
+
+ HGCMSF i HGCMSF4 dla karty Hercules
+ MGCMSF i MGCMSF4 dla karty IBM color/graphics
+ MGC64MSF i MGC64MF4 dla karty IBM w trybie mono
+ EGAMSF i EGAMSF4 dla karty EGA
+
+ Biblioteki HGCMSF, MGCMSF, MGC64MSF i EGAMSF zgodne
+sa z konwencjami Fortranu ( wersja 3.31 ) i Pascala firmy
+Microsoft. Natomiast biblioteki HGCMSF4, MGCMSF4, MGC64MF4 i
+EGAMSF4 sa zgodne z konwencjami Fortranu ( wersja 4.00 )
+firmy Microsoft. Dodatkowo, kazda biblioteka moze byc
+dostarczona w konwencji Lattice C, oddzielnie dla czterech
+modeli kodu S, P, D i L.
+
+ Programy uzytkowe komunikuja sie z IIUWGRAFem na
+dwoch poziomach:
+
+ poziom 1 - zarzadzanie ekranem na poziomie pixli,
+przy uzyciu prawdziwych wspolrzednych na ekranie,
+
+ poziom 2 - rysowanie punktow i linii we
+wspolrzednych abstrakcyjnych.
+\f
+
+
+ 4
+
+
+
+Procedury poziomu 1
+
+ Wszystkie parametry bez podanej explicite
+specyfikacji maja typ integer. Wszystkie parametry calkowite
+powinny miec wartosci 16-bitowe (integer*2 w Fortranie,
+integer w Pascalu, int w C)
+
+
+Zakresy wspolrzednych ekranu:
+
+ 0 <= ix <= 719
+ 0 <= iy <= 347 dla karty Hercules
+
+ 0 <= ix <= 319
+ 0 <= iy <= 199 dla karty IBM color/graphics
+
+ 0 <= ix <= 639
+ 0 <= iy <= 199 dla karty IBM color/graphics
+ w trybie mono
+ 0 <= ix <= 639
+ 0 <= iy <= 349 dla karty EGA
+
+
+
+ (0,0)-----------> (ix,0)
+ |
+ |
+ |
+ V
+ (0,iy)
+\f
+
+
+ 5
+
+
+
+Procedury ustawiania trybu
+
+GRON(i)
+
+ Procedura GRON ustawia monitor w graficznym trybie
+pracy, czyszczac zawartosc jego ekranu, ktory jednoczesnie
+staje sie buforem roboczym. Parametr i ma znaczenie jedynie
+dla karty IBM w trybie 320*200: wartosc 1 wybiera normalne
+kolory, wartosc 0 - kolory zmodyfikowane do pracy na
+monitorach monochromatycznych. Dla kart Hercules, EGA oraz
+karty IBM w trybie 640*200 wartosc parametru i jest
+ignorowana. Przy przelaczaniu karty Hercules z trybu
+tekstowego na graficzny i odwrotnie stosowane jest
+programowo opoznienie ok. 3 sekund. Tryb karty IBM ustawiany
+jest wprost, bez pomocy przerwania 10H, tak aby mozliwa byla
+jednoczesna praca na monitorze kolorowym w trybie graficznym
+z praca na monitorze monochromatycznym w trybie tekstowym.
+Konsekwencja tego rozwiazania jest to, ze nie mozna
+korzystac z komendy GRAPHICS. Natomiast tryb karty EGA jest
+ustawiany wprost, za pomoca przerwania 10H.
+
+
+
+NOCARD(ple)
+
+ Funkcja NOCARD zwraca liczbe calkowita
+identyfikujaca rodzaj monitora obslugiwanego przez biezaco
+uzywana biblioteke:
+
+ 1 dla karty Hercules
+ 2 dla karty IBM w trybie kolor
+ 3 dla karty IBM w trybie mono 640*200
+ 4 dla karty IBM w trybie mono 320*200
+ 5 dla karty EGA
+
+ Funkcja NOCARD moze byc wywolana dopiero po
+zainicjowaniu trybu graficznego za pomoca procedury GRON.
+Parametr ple jest ignorowany.
+
+
+
+GROFF
+
+ Procedura GROFF przelacza monitor w tryb tekstowy,
+wypelniajac zawartosc jego ekranu spacjami. Przed
+zakonczeniem dzialania programu monitor, z ktorego byl
+wywolany, nalezy zawsze ustawic z powrotem w tryb tekstowy.
+
+
+CLS
+
+ Procedura CLS czysci ekran, wypelniajac go kolorem
+0. Czyszczenie odbywa sie bez wylaczania ekranu.\f
+
+
+ 6
+
+
+
+HPAGE(nr, tryb, zeruj)
+
+ Procedura HPAGE ma zastosowanie jedynie dla kart
+Hercules oraz EGA. Pozwala na dostep do drugiej strony
+graficznej monitora. Wywolanie HPAGE wybiera strone o
+numerze nr (0 lub 1), zeruje jej zawartosc, o ile parametr
+zeruj ma wartosc <> 0, oraz ustawia jej tryb:
+
+ tryb = 0 wyswietla zawartosc strony alfanumerycznie
+ tryb = 1 wyswietla zawartosc strony graficznie
+ tryb =-1 przypisuje do tej strony bufor roboczy
+
+
+ Przypisanie bufora roboczego trybem -1 nie zmienia
+numeru ani sposobu wyswietlania biezacej strony. Tryb 0
+wiaze bufor roboczy z wybrana wlasnie strona. Przelaczanie
+stron odbywa sie bez opoznien, o ile nie ulega zmianie tryb
+wyswietlania (alfanumeryka/grafika). Poza tym, wywolanie
+HPAGE(0,1,1) jest ( tylko dla karty Hercules ) rownowazne
+GRON(), a HPAGE(0,0,1) - wywolaniu GROFF.
+
+Typowa petla animacyjna moze byc zatem rozwiazana na
+przyklad tak:
+
+VAR NR: INTEGER;
+BEGIN
+ GRON(0);
+ NR := 1;
+ (* NARYSUJ PIERWOTNY OBRAZ *)
+ DRAW(...
+ ...
+ WHILE JESZCZE DO
+ HPAGE(1-NR,1,0); (* WYSWIETLANIE *)
+ HPAGE(NR,-1,1); (* BUFOROWANIE *)
+ (* NARYSUJ ZMODYFIKOWANY OBRAZ *)
+ DRAW(...
+ ...
+ NR := 1-NR
+ OD
+
+
+VIDEO(tablica)
+
+ Procedura VIDEO przelacza bufor roboczy tak, aby
+miescil sie on w tablicy podanej jako parametr jej
+wywolania.
+Samo wywolanie VIDEO nie zmienia zawartosci bufora. Obraz
+wyswietlany na monitorze nie bedzie ulegal teraz zmianom
+mimo wywolywania procedur modyfikujacych zawartosc ekranu.
+Wszelkie odwolania do ekranu beda teraz dokonywane w
+tablicy. Gotowy obraz moze byc przeniesiony na rzeczywisty
+ekran za pomoca procedur GETMAP/PUTMAP lub zapisany binarnie
+na dysku w celu pozniejszego odtworzenia. Tablica powinna
+miec 16K bajtow przy wspolpracy z karta IBM i 32K bajtow
+przy wspolpracy z karta Hercules.
+Procedury VIDEO nie mozna stosowac dla karty EGA.\f
+
+
+ 7
+
+
+Przyklad:
+
+VAR BOK: ARRAY[1..32K] OF BYTE;
+ FRAGM: ARRAY[1..MAX] OF BYTE;
+BEGIN
+ GRON(1);
+ (* NARYSUJ STRONE TYTULOWA *)
+ DRAW(...
+ ...
+ (* SKONSTRUUJ RYSUNEK "NA BOKU" *)
+ VIDEO(BOK);
+ DRAW(...
+ ...
+ (* ZAPAMIETAJ FRAGMENT GOTOWEGO RYSUNKU *)
+ MOVE(MINX,MINY);
+ GETMAP(MAXX,MAXY,FRAGM);
+ (* PRZYPISZ Z POWROTEM EKRAN DO MONITORA *)
+ GRON(1); (* NIESTETY, CZYSCI EKRAN *)
+ MOVE(MINX,MINY);
+ PUTMAP(FRAGM);
+ ...
+
+Uwaga:
+ W przypadku wywolania VIDEO(tablica(adres)), wartosc
+wyrazenia adres musi byc postaci 1+k*16, gdzie k=0,1,2,...
+\f
+
+
+ 8
+
+
+
+Procedury sterujace kolorami
+
+
+COLOR(kolor)
+
+ Procedura COLOR ustawia biezacy kolor. W tym
+kolorze beda odtad dokonywane zmiany zawartosci ekranu. Na
+monitorach monochromatycznych kolor 0 oznacza czarny (pixel
+wygaszony), kolor <> 0 oznacza bialy (pixel zapalony).
+Na monitorach kolorowych, dla karty IBM color/graphics,
+kolory maja nastepujace numery:
+
+ 0 - tlo (czarny lub ustalony wywolaniem BORDER)
+ 1 - zielony lub turkusowy - cyan ( zaleznie od wyboru
+palety)
+ 2 - czerwony lub purpurowy - magenta
+ 3 - zolty lub bialy
+
+Kolorem ustawionym poczatkowo jest 1.
+
+
+ Dla karty EGA kolor moze przyjmowac wartosci od 0
+do 15. Znaczenie tego parametru jest okreslone poprzez wybor
+palety ( przyporzadkowanie kazdemu z 16 identyfikatorow
+koloru dowolnego koloru z 64 istniejacych ), dokonywany za
+pomoca procedury PALLET.
+Kolorem ustawionym poczatkowo jest 7.
+
+
+STYLE(styl)
+
+ Procedura STYLE ustawia biezacy styl, czyli
+kombinacje kolorow uzywana do rysowania odcinkow (DRAW) i
+wypelniania obszarow (HFILL,VFILL). Styl wybiera jeden z
+szesciu nastepujacych sposobow mieszania tla (.) i biezacego
+koloru (*):
+
+ 0 - ....
+ 1 - ****
+ 2 - ***.
+ 3 - **..
+ 4 - *.*.
+ 5 - *...
+
+ Przy rysowaniu odcinkow kolejne pixle beda mialy
+kolor wyznaczony cyklicznie wzorcem stylu. Pierwszy i
+ostatni pixel odcinka bedzie zawsze mial biezacy kolor.
+Przy wypelnianiu, podany wzorzec dotyczy linii poziomych
+(pionowych) ekranu o parzystej wspolrzednej y (x). Wzorzec
+dla linii o wspolrzednych nieparzystych dobierany jest
+automatycznie.
+Inne sposoby mieszania, dopuszczajace uzycie wiekszej liczby
+kolorow sa dostepne za pomoca procedury PATERN.\f
+
+
+ 9
+
+
+PATERN(par,par1,par2,par3)
+
+ Procedura PATERN pozwala rysowac odcinki i
+wypelniac obszary dowolna kombinacja kolorow. Przy rysowaniu
+odcinkow brany jest pod uwage tylko par. Przy wypelnianiu,
+par oraz par2 dotycza linii poziomych (pionowych) o
+wspolrzednych y (x) parzystych, par1 oraz par3 - linii o
+wspolrzednych nieparzystych ( na zmiane kolejno par/par2
+oraz par1/par3 ). Wartosci par,...,par3 przedstawione jako
+czterocyfrowe liczby szesnastkowe daja wzorce mieszania
+numerow kolorow. 0 oznacza tlo, inne cyfry - zob. opis
+procedury COLOR.
+
+Przyklad:
+
+PATERN(#1100,#0011,#1100,#0011);
+ ODPOWIADA: COLOR(1); STYLE(3);
+
+natomiast efekt:
+
+PATERN(#1212,#0303,#2121,#3030);
+ NIE MOzE BYC UZYSKANY INACZEJ
+
+
+BORDER(kolor)
+
+ Procedura BORDER ustawia biezacy kolor tla.
+
+ kolor kolor
+
+ 0 czarny
+ 1 niebieski
+ 2 zielony
+ 3 turkusowy - cyan (niebiesko-zielony)
+ 4 czerwony
+ 5 karmazynowy - magenta (czerwono-niebieski)
+ 6 zolty
+ 7 jasno szary
+
+Kolory 8 - 15 to jasniejsze odcienie kolorow 0 - 7, przy
+czym kolor bialy ma numer 15.
+
+Przedstawione powyzej kolory dotycza tylko karty IBM, dla
+karty EGA natomiast parametr kolor moze przyjmowac wartosci
+od 0 do 63.
+
+
+PALLET(nr)
+
+ Dla karty IBM color/graphics :
+
+ procedura PALLET wybiera biezaca palete z dwu
+mozliwych
+
+
+ nr kolory
+
+ 0 turkusowy,karmazynowy,bialy
+ 1 zielony,czerwony,zolty
+\f
+
+
+ 10
+
+
+ Domyslna paleta jest paleta nr 0.
+
+ Dla karty EGA natomiast procedura PALLET sluzy do
+wyboru dowolnych 16 kolorow z 64 ogolnie dostepnych.
+Parametr nr powinien byc postaci
+ kolor16 * 256 + kolor64,
+gdzie
+ kolor16 oznacza identyfikator koloru ( uzywany
+przez procedure COLOR ), mogacy przyjmowac wartosci 0 - 15,
+ kolor64 oznacza wybrany kolor.
+
+
+ Standardowa paleta ( przyjmowana domyslnie )
+zawiera nastepujace kolory :
+
+ identyfikator kolor numer koloru
+
+ 0 czarny 0
+ 1 niebieski 1
+ 2 zielony 2
+ 3 turkusowy 3
+ 4 czerwony 4
+ 5 karmazynowy 5
+ 6 zolty 6
+ 7 bialy 7
+ 8 szary 56
+ 9 jasno-niebieski 57
+ 10 jasno-zielony 58
+ 11 jasno-turkusowy 59
+ 12 jasno-czerwony 60
+ 13 jasno-karmazynowy 61
+ 14 jasno-zolty 62
+ 15 intensywny bialy 63
+
+
+ Wszystkie dostepne kolory mozna obejrzec oraz
+poznac ich numery za pomoca programu demonstracyjnego
+EGADEMO.EXE.
+
+ Procedura PALLET nie ma zastosowania dla karty
+Hercules.
+
+
+
+INTENS(i)
+
+ Procedura INTENS wybiera intensywnosc kolorow.
+Dla i rownego 0 intensywnosc jest wieksza, dla i rownego 1
+mniejsza.
+Domyslnie intensywnosc jest ustawiona na poziomie 0.
+
+Procedura INTENS ma zastosowanie tylko dla karty IBM.\f
+
+
+ 11
+
+
+
+Procedury ustawiania pozycji
+
+
+MOVE(x,y)
+
+ Procedura MOVE ustawia biezaca pozycje na ekranie
+na pixel o wspolrzednych (x {kolumna}, y {wiersz}).
+
+
+INXPOS(ple), INYPOS(ple)
+
+ Funkcje calkowite INXPOS i INYPOS zwracaja
+odpowiednio wspolrzedne x i y biezacej pozycji. Parametr ple
+jest ignorowany.
+
+
+PUSHXY
+
+ Procedura PUSHXY powoduje przechowanie biezacej
+pozycji, koloru i stylu na wierzcholku wewnetrznego stosu
+IIUWGRAFu. Parametry te nie ulegaja przy tym zmianie.
+Maksymalna glebokosc stosu wynosi 16.
+
+
+POPXY
+
+ Procedura POPXY odtwarza biezacy styl, kolor i
+pozycje z wierzcholka wewnetrznego stosu IIUWGRAFu.
+Glebokosc stosu zmniejsza sie o 1.
+
+
+
+Przyklad:
+
+
+PROCEDURE SKOS;
+VAR IX,IY:INTEGER;
+BEGIN
+ PUSHXY;
+ IX := INXPOS(0);
+ IY := INYPOS(0);
+ DRAW(IX+10,IY+10);
+ POPXY;
+END;\f
+
+
+ 12
+
+
+
+TRACK(x,y)
+
+ Procedura TRACK wyswietla na ekranie wskaznik w
+ksztalcie malej (8*8 pixli) strzalki, skierowanej na punkt o
+wspolrzednych (x,y). Wskaznik ten moze byc przesuwany po
+ekranie za pomoca klawiszy kierunkowych. Nacisniecie
+klawisza powoduje przesuniecie wskaznika o 5 pixli.
+Nacisniecie odpowiedniego klawisza w trybie numerycznym
+przesuwa wskaznik o 1 pixel. Klawisz "home" powoduje powrot
+wskaznika do pozycji (x,y). Klawisz "End" usuwa wskaznik z
+ekranu i powoduje powrot z procedury, pozostawiajac biezaca
+pozycje w tym miejscu. Moze byc ona teraz odczytana za
+pomoca funkcji INXPOS i INYPOS.
+
+
+
+
+
+
+
+Procedury obslugujace punkty
+
+
+POINT(x,y)
+
+ Procedura POINT ustawia biezaca pozycje w punkcie
+(x,y) i zmienia jego kolor na biezacy.
+
+
+INPIX(x,y)
+
+ Funkcja INPIX ustawia biezaca pozycje w punkcie
+(x,y) i zwraca jego kolor.\f
+
+
+ 13
+
+
+
+Procedury rysowania linii
+
+
+DRAW(x,y)
+
+ Procedura DRAW rysuje odcinek od biezacej pozycji
+do pozycji o wspolrzednych (x,y). Rysowanie polega na
+zmianie koloru pixli nalezacych, wedlug algorytmu
+Bresenhama, do odcinka. Pixle te przyjmuja nowy stan
+zaleznie od biezacego koloru i stylu.
+
+
+
+CIRB(x,y,r,alfa,beta,kolb,wwyp,p,q)
+
+ Procedura CIRB rysuje na ekranie wycinek okregu
+lub elipsy, zaleznie od podanych wartosci p i q,
+okreslajacych aspekt. Aspekt wyznaczony jest stosunkiem p/q.
+Dla wartosci aspektu rownej 1 zostanie narysowany idealny
+okrag. Srodek bedzie umieszczony w punkcie (x,y), promien
+poziomy bedzie mial wielkosc r pixli, alfa i beta okreslaja,
+odpowiednio kat poczatkowy i koncowy rysowanego wycinka. Dla
+alfa = beta zostanie narysowany pelny okrag (lub elipsa).
+Wartosci alfa i beta sa wyrazane w radianach, w zwyklym
+ukladzie. Brzeg wycinka i jego promienie zostana narysowane
+kolorem kolb, niezaleznie od stylu. Jesli wwyp <> 0, wnetrze
+wycinka zostanie wypelnione biezacym kolorem i stylem.
+
+
+HFILL(x)
+
+ Procedura HFILL rysuje, w biezacym kolorze i stylu,
+odcinek poziomy od biezacej pozycji do punktu o
+wspolrzednych
+
+ (x,inypos(0))
+
+OSTROZNIE: HFILL nie zmienia biezacej pozycji.
+
+ Uzycie HFILL jest zalecane przy wypelnianiu
+obszarow, gdyz dziala znacznie szybciej niz odpowiedni DRAW.
+Rowniez mieszajac kolory w danym stylu, HFILL, w
+przeciwienstwie do DRAW nie bierze pod uwage poczatkowego
+punktu odcinka, co pozwala na uzyskanie substytutu
+dodatkowych kolorow.
+
+\f
+
+
+ 14
+
+
+VFILL(y)
+
+
+ Procedura VFILL rysuje, w biezacym kolorze i stylu,
+odcinek pionowy od biezacej pozycji do punktu o
+wspolrzednych
+
+ (inxpos(0),y)
+
+OSTROZNIE: VFILL nie zmienia biezacej pozycji.\f
+
+
+ 15
+
+
+
+Procedury operujace na fragmentach ekranu
+
+
+GETMAP(x,y,tablica)
+
+ Procedura GETMAP zapamietuje prostokatny obszar
+ekranu pomiedzy biezaca pozycja jako lewym gornym rogiem a
+punktem (x,y) jako prawym dolnym rogiem w tablicy. GETMAP
+nie zmienia przy tym biezacej pozycji. Tablica powinna miec
+co najmniej 4 + w*sufit(k/8)*kol bajtow, gdzie w i k sa,
+odpowiednio, liczba wierszy i kolumn zapamietywanego
+obszaru, natomiast wartosc wspolczynnika kol zalezy od
+rodzaju karty graficznej i wynosi 1 dla karty Hercules,
+2 dla karty IBM oraz 4 dla karty EGA.
+
+Przyklad: zapamietanie obszaru 101*101 polozonego w lewym
+gornym rogu ekranu.
+
+VAR OKNO: ARRAY[1..700] OF INTEGER;
+
+ ...
+ MOVE(0,0);
+ GETMAP(100,100,OKNO);
+ ...
+
+
+
+PUTMAP(tablica)
+
+ Procedura PUTMAP ustawia prostokatny obszar ekranu
+o lewym gornym rogu znajdujacym sie w biezacej pozycji
+zgodnie z zawartoscia tablicy, w ktorej uprzednio
+zapamietano fragment ekranu za pomoca procedury GETMAP.
+Biezaca pozycja nie ulega zmianie. Odtworzeniu podlega caly
+zapamietany obszar, ktory jest kopiowany w nowe miejsce.
+
+
+ORMAP(tablica)
+
+ Procedura ORMAP dziala podobnie jak PUTMAP, lecz o
+nowej zawartosci ekranu decyduje wynik zastosowania funkcji
+or do elementow tablicy i ekranu.
+
+
+XORMAP(tablica)
+
+ Procedura XORMAP dziala podobnie jak PUTMAP, lecz o
+nowej zawartosci ekranu decyduje wynik zastosowania funkcji
+xor do elementow tablicy i ekranu.\f
+
+
+ 16
+
+
+
+Procedury wejscia/wyjscia dla pojedynczych znakow
+
+
+INKEY(ple)
+
+ Funkcja calkowita INKEY podaje i usuwa nastepny
+znak z bufora klawiatury. Czytanie odbywa sie bez echa.
+Jesli bufor jest pusty, wynikiem jest 0. Klawisze specjalne
+kodowane sa jako liczby ujemne wedlug zalaczonej tablicy.
+Metoda ALT-NUM moze byc uzyta do wprowadzenia z klawiatury
+kodow powyzej 127 jako zwyklych znakow. Uniemozliwia to,
+niestety, korzystanie ze znakow specjalnych o kodach od 128
+do 132.
+
+Przyklad: zaczekaj na klawisz End.
+
+PROCEDURE WAIT_FOR_END;
+BEGIN
+ WHILE INKEY(0)<>-79 DO;
+END;
+
+Wartosci kodow klawiszy specjalnych podane sa w Dodatku F.
+
+
+HASCII(kod)
+
+ Procedura HASCII rysuje na ekranie znak
+alfanumeryczny. Znak wpisany jest w raster 8*8. Gorny lewy
+rog rastra umieszczony bedzie w biezacej pozycji, ktora
+jednoczesnie przesunie sie o 8 pixli w prawo. Uzyta funkcja
+rysujaca jest xor. Kroj znakow pobierany jest z tablicy
+znajdujacej sie w ROM BIOS standardowo pod adresem
+F000:FA6E. W przypadku niestandardowego ROM BIOSu obraz
+znaku alfanumerycznego bedzie zly. Uzycie procedur HFONT i
+HFONT8 pozwala uniezaleznic sie od wersji BIOSu a takze
+korzystac z innych, rowniez wlasnorecznie zaprojektowanych
+krojow znakow. Kod znaku 0 powoduje tylko wyczyszczenie
+miejsca przeznaczonego na znak, bez zmiany biezacej pozycji.
+Wszystkie kody maja tylko interpretacje graficzna, bez
+funkcji sterujacych (NL, CR etc.).
+
+Przyklad: napisanie slowa "oh" na gwarantowanie czystym tle.
+
+
+HASCII(0); HASCII('o'); HASCII(0); HASCII('h');
+
+Uwaga:
+ Parametr procedury HASCII moze byc typu integer lub
+znakowego ( character w Fortranie, char w Pascalu i C ).
+\f
+
+
+ 17
+
+
+
+HFONT(segment,offset)
+
+ Wywolanie procedury HFONT przelacza adres wzorca
+znakow alfanumerycznych na segment:offset. Bez uzycia HFONT
+uzywa sie adresu F000:FA6E.
+
+
+HFONT8(segment,offset)
+
+ Uzycie procedury HFONT8 dolacza do programu
+uzytkowego kopie tablicy kroju znakow z ROM BIOS i zwraca
+adres tej kopii jako segment:offset (parametry wyjsciowe).
+
+\f
+
+
+ 18
+
+
+
+Procedury wejscia/wyjscia dla linii
+
+
+OUTHLINE(dlugosc,bufor)
+
+ Procedura OUTHLINE wywoluje HASCII dlugosc razy,
+wypisujac na ekran znaki, ktorych kody zawarte sa w buforze.
+Przed narysowaniem kazdego znaku wywolywane jest HASCII(0).
+
+
+INHLINE(dlugosc,bufor)
+
+ Procedura INHLINE wczytuje z klawiatury linie
+zlozona z co najwyzej dlugosci znakow i umieszcza je w
+buforze. Do wczytywania uzyta jest procedura INKEY.
+Wyswietlane jest echo. Migajacy wskaznik oznacza oczekiwanie
+na nacisniecie klawisza. Klawisz BACKSPACE dziala tak, jak
+mozna tego oczekiwac. Linia moze byc zakonczona klawiszem CR
+albo wyczerpaniem jej dlugosci. Znak CR konczacy linie nie
+jest umieszczany w buforze. Przed rozpoczeciem czytania
+bufor jest wypelniany spacjami. Po zakonczeniu czytania
+parametr dlugosc zwraca liczbe wczytanych znakow.
+Migajacy wskaznik jest zawsze rysowany kolorem numer 1,
+wyswietlane znaki natomiast biezacym kolorem.
+
+
+Przyklad: echo wczytanej linii.
+
+VAR LINIA: ARRAY[1:40] OF INTEGER;
+ N: INTEGER;
+BEGIN
+ N:=80;
+ INHLINE(N,LINIA);
+ IF N=0 THEN MOVE(INXPOS(0),INYPOS(0)+10)
+ ELSE OUTHLINE(N,LINIA);
+ ...
+
+\f
+
+
+ 19
+
+
+
+Procedury wejscia/wyjscia dla okienek
+
+
+MKWNDW(x,y,kolumn,wierszy,okienko,rozmiar,ramka)
+
+ Procedura MKWNDW urzadza na ekranie prostokatne
+okienko do konwersacji. Lewy gorny rog okienka znajdzie sie
+w punkcie (x,y). Zmiesci ono zadana liczbe kolumn i wierszy
+tekstu alfanumerycznego. Opis okienka bedzie przechowany w
+dostarczonej przez uzytkownika tablicy okienko. Parametr
+rozmiar jest na razie ignorowany, a tablica powinna miec co
+najmniej 20 bajtow, lub duzo wiecej, jesli okienko ma byc
+zaslaniane i odslaniane ( patrz opis procedury BURY ). Jesli
+parametr ramka ma wartosc rozna od 0, obszar okienka bedzie
+obwiedziony ramka, co uczyni je nieco wiekszym.
+
+
+BURY(okienko)
+
+ Wywolanie BURY usuwa okienko z ekranu, przechowujac
+jego obraz w dalszej czesci tablicy okienko tak, aby moc
+odtworzyc je pozniej za pomoca EXPOSE. Tablica okienko musi
+miec odpowiednia wielkosc, aby GETMAP obszaru okienka
+pozostawilo w niej jeszcze co najmniej 20 bajtow.
+
+
+EXPOSE(okienko,x,y)
+
+ Wywolanie EXPOSE odtwarza okienko przechowane za
+pomoca BURY umieszczajac jego gorny lewy rog w punkcie
+(x,y).
+
+
+OUTWLINE(okienko,dlugosc,bufor)
+
+ Procedura OUTWLINE dziala podobnie jak OUTHLINE,
+wyswietlajac linie w ramach podanego okienka. Bufor o
+dlugosci wiekszej niz rozmiar okienka wyswietli sie w kilku
+liniach.
+
+
+INWLINE(okienko,dlugosc,bufor)
+
+ Procedura INWLINE, podobnie jak INHLINE, wczytuje z
+klawiatury linie tekstu. W przypadku INWLINE okienko
+wskazuje na obszar ekranu, w ktorym ma pojawiac sie echo.
+Jesli dlugosc bufora jest wieksza niz rozmiar okienka echo
+moze zajac w nim kilka linii. Poprawianie wprowadzanego
+tekstu przy uzyciu BACKSPACE jest mozliwe tylko w ostatniej
+czesci linii. Dlugosc jako parametr wyjsciowy zwraca liczbe
+wczytanych znakow, bez konczacego CR.\f
+
+
+ 20
+
+
+
+Procedury poziomu 2
+
+
+ Procedury te operuja wspolrzednymi wyrazonymi
+liczbami rzeczywistymi odnoszacymi sie do abstrakcyjnego
+okna o dowolnych rozmiarach.
+
+
+
+Definiowanie okna
+
+
+SWINDOW(rxy,ixy,skalowanie)
+
+ Procedura SWINDOW urzadza na ekranie prostokatne
+okno umieszczone pomiedzy punktami naroznikowymi podanymi w
+tablicy ixy jako calkowite wspolrzedne prawdziwych pixli.
+Program uzytkowy tworzacy rysunek w tym obszarze bedzie
+okreslal polozenie punktow w sposob abstrakcyjny we
+wspolrzednych rzeczywistych. Tablica rxy podaje zakresy tych
+wspolrzednych. Jesli parametr skalowanie ma wartosc 0,
+abstrakcyjny prostokat bedzie po prostu odwzorowany na
+wskazana czesc ekranu bez zachowania proporcji miedzy
+skalowaniem w pionie i w poziomie. Jesli natomiast parametr
+skalowanie bedzie rozny od zera, wykorzystana zostanie
+jedynie srodkowa czesc obszaru ekranu tak, aby zachowac
+rzeczywiste proporcje rysunku, niezaleznie od aspektu danego
+monitora.
+Odwzorowanie stosowane przez IIUWGRAF odwraca tez kierunek
+wzrastania wspolrzednej y do naturalnego ukladu:
+
+
+ (ixy(1),ixy(3))
+ /
+ (rxy(1),rxy(4))
+ ^
+ |
+ |
+ |
+ | (ixy(1),ixy(4)) (ixy(2),ixy(4))
+ | / /
+ (rxy(1),rxy(3))--------------------->(rxy(2),rxy(3))
+
+
+Przyklad: przygotowanie rysunku sinusoidy w gornej polowie
+ekranu Herculesa.
+
+
+VAR RW:ARRAY [1:4] OF REAL INIT (0.,6.29,-1.,1.);
+ IW:ARRAY [1:4] OF INTEGER INIT (0,719,0,173);
+BEGIN
+ SWINDOW(RW,IW,0);
+\f
+
+
+ 21
+
+
+RWINDOW(rxy,skalowanie)
+
+ Procedura RWINDOW jest skrotem wywolania SWINDOW
+dla odwzorowania obejmujacego caly ekran.
+
+
+
+RINXPOS(ple),RINYPOS(ple)
+
+ Funkcje rzeczywiste RINXPOS i RINYPOS zwracaja,
+odpowiednio wspolrzedne x i y biezacej pozycji w
+abstrakcyjnym oknie urzadzonym przez ostatnie wywolanie
+RWINDOW lub SWINDOW. Biezaca pozycja jest zawsze zaokraglana
+do najblizszego pixla.
+
+
+
+RMOVE(rx,ry)
+
+ Wywolanie procedury RMOVE ustawia biezaca pozycje w
+punkcie (rx,ry) w ostatnio urzadzonym oknie. Pozycja ta jest
+zaokraglona do najblizszego pixla.
+
+
+
+RDRAW(rx,ry)
+
+ Wywolanie procedury RDRAW powoduje narysowanie w
+biezacym kolorze i stylu odcinka od biezacej pozycji do
+pixla najblizszego punktowi (rx,ry) w ostatnio urzadzonym
+oknie.
+
+
+
+RCIRB(rx,ry,rr,alfa,beta,kolb,wwyp,p,q)
+
+ Procedura RCIRB odpowiada procedurze CIRB z poziomu
+1, z tym, ze wspolrzedne srodka (rx,ry) i promien rr
+wyrazane sa, jako liczby rzeczywiste, w oknie urzadzonym
+przez ostatnie wywolanie RWINDOW lub SWINDOW. Pozostale
+parametry maja znaczenie takie, jak w CIRB.\f
+
+
+ 22
+
+
+
+Informacje dodatkowe
+
+
+ Pakiet IIUWGRAF zawiera dodatkowo dwa programy
+HGCPRINT.EXE oraz MGCPRINT.EXE. Umozliwiaja one drukowanie
+tworzonych obrazow graficznych na powszechnie dostepnych
+drukarkach ( np. typu STAR GEMINI, EPSON ). W przypadku
+uzywania karty Hercules nalezy stosowac program HGCPRINT, a
+dla karty IBM color/graphics program MGCPRINT.
+
+ Programow tych powinno uzywac sie w nastepujacy
+sposob :
+ przed zaladowaniem wlasnego programu nalezy wykonac
+program HGCPRINT lub MGCPRINT, w zaleznosci od rodzaju
+uzywanej karty graficznej. Kazdy z tych programow ustawia
+znaczenie klawisza PrtSc. Kazdorazowe pozniejsze nacisniecie
+klawisza PrtSc powoduje wydrukowanie graficznej zawartosci
+ekranu.
+
+Uwaga. W przypadku karty Hercules drukowana jest
+zawartosc pierwszej strony graficznej, niezaleznie od tego,
+ktora strona jest aktualnie wyswietlana.
+ W przypadku karty IBM color/graphics klawisz PrtSc
+zaklada, ze jest ustawiony tryb kolor 320*200. Wydruk obrazu
+graficznego utworzonego w trybie mono 640*200 jest mozliwe
+poprzez uzycie procedury PRTSCR.
+
+ Mozliwosc drukowania obrazu graficznego nie
+istnieje dla karty EGA.
+
+ Autorem programow HGCPRINT oraz MGCPRINT jest
+Krzysztof Studzinski.
+
+
+
+
+Procedury dodatkowe
+
+
+PRTSCR(nr)
+
+ Procedura PRTSCR umozliwia drukowanie obrazow
+graficznych tworzonych na ekranie monitora pod kontrola
+programu. Parametr nr okresla numer strony graficznej
+(0 lub 1), ktorej zawartosc ma byc wydrukowana.
+
+ Wywolanie procedury PRTSCR z parametrem nr rownym
+zeru jest rownowazne nacisnieciu klawisza PrtSc.
+
+ W celu poprawnego dzialania tej procedury nalezy,
+analogicznie jak w przypadku klawisza PrtSc, uprzednio
+wykonac dolaczony program :
+ - HGCPRINT.EXE w przypadku uzywania karty
+Hercules lub
+ - MGCPRINT.EXE dla karty IBM.
+
+ Procedura PRTSCR nie dziala dla karty EGA.
+
+\f
+
+
+ 23
+
+
+
+
+ DODATEK A
+
+ Uzycie IIUWGRAFu z FORTRANem 77.
+
+
+1) Procedury IN?LINE i OUT?LINE dokonuja jedynie
+transmisji tekstu, bez zadnej konwersji pomiedzy postacia
+binarna i tekstowa. Aby takiej konwersji dokonac, mozna
+posluzyc sie instrukcjami formatowanego wejscia/wyjscia
+w polaczeniu z tzw. plikami wewnetrznymi (internal file).
+
+Przyklad:
+
+
+ INTEGER*2 I,J,SUM,W(10)
+ CHARACTER*20 LINE
+ CHARACTER LINEL(20)
+ EQUIVALENCE (LINE,LINEL(1))
+
+ ...
+ CALL MKWNDW(10,10,21,4,W,20,1)
+ CALL OUTWLINE(W,20,'PODAJ 2 LICZBY (2I3)')
+ CALL INWLINE(W,20,LINEL)
+ READ (LINE,'(2I3)') I,J
+ SUM=I+J
+ WRITE (LINE,'(8H SUMA = I4)') SUM
+ CALL OUTWLINE(W,12,LINEL) \f
+
+
+ 24
+
+
+
+
+
+ DODATEK B
+
+ Uzycie IIUWGRAFu z PASCALem.
+
+
+1) Microsoft Pascal dopuszcza jedynie 6 znakow w nazwie
+podprogramu, zatem nazwy: INHLIN(E), INWLIN(E), OUTHLI(NE),
+OUTWLI(NE), RWINDO(W), SWINDO(W), RINXPO(S), RINYPO(S) musza
+byc uzywane w skroconej postaci.
+
+2) Niektore procedury IIUWGRAFu sa napisane w FORTRANie.
+Przy linkowaniu LINK moze domagac sie dostarczenia
+biblioteki FORTRAN.LIB. Zadanie to nalezy zignorowac.
+
+3) Do linkowania nalezy uzywac LINK w wersji co najmniej
+3.04, do kompilacji Pascal w wersji co najmniej 3.31.\f
+
+
+ 25
+
+
+
+
+ DODATEK C
+
+ Uzycie IIUWGRAFu z Lattice C.
+
+
+1) Nalezy unikac konfliktow z nazwami globalnych zmiennych
+roboczych IIUWGRAFu. Zmienne te maja nazwy rozpoczynajace
+sie od liter WIR... i PQASP...
+
+2) W przypadku procedur majacych parametry wyjsciowe ( w
+dodatku E sa one zaznaczone jako vars ) nalezy przy ich
+wywolaniu przekazywac adres odpowiedniego parametru
+aktualnego.
+
+Przyklad:
+
+
+ CHAR LENGTH;
+ CHAR *TEXT;
+ ...
+ INHLINE(&LENGTH,TEXT)
+
+
+
+3) Adresy parametrow aktualnych nalezy przekazywac rowniez
+w przypadku parametrow bedacych tablicami znakowymi.
+
+
+Przyklad:
+
+
+ INT LENGTH;
+ CHAR *TEXT; /* LUB NP. CHAR TEXT[40]; */
+ ...
+ OUTHLINE(LENGTH, &TEXT[3]);
+ /* WYPISZ ZNAKI Z TABLICY 'TEXT', ROZPOCZYNAJAC OD
+CZWARTEGO */
+\f
+
+
+ 26
+
+
+
+
+ DODATEK D
+
+ Uzycie IIUWGRAFu z LOGLANem.
+
+
+1) W biezacej wersji LOGLANu dostepnych jest jedynie 7
+podstawowych procedur: GRON, GROFF, MOVE, DRAW, HASCII,
+HPAGE, INKEY obslugujacych wylacznie karte Hercules.
+
+2) System okienek do konwersacji nie bedzie w LOGLANie
+dostepny w postaci procedur standardowych. Podobnie okienka
+o wspolrzednych rzeczywistych.
+
+3) Niektore podprogramy dostepne jako funkcje standardowe
+LOGLANu musza miec zmienione specyfikacje parametrow w
+stosunku do oryginalnego IIUWGRAFu:
+
+ IIUWGRAF LOGLAN
+
+ GETMAP GETMAP:function:array of ?
+ INKEY INKEY:integer function; (* bez parametrow *)
+ INXPOS INXPOS:integer function;(* bez parametrow *)
+ INYPOS INYPOS:integer function;(* bez parametrow *)
+\f
+
+
+ 27
+
+
+
+
+ DODATEK E
+
+ Wykaz specyfikacji procedur IIUWGRAFu.
+
+
+ proc BORDER(consts b: integer);
+ L proc BURY(window: buffer);
+ proc CIRB(consts ix,iy,ir: integer;
+ consts alfa, beta: real;
+ consts cbord, bcint, p, q: integer);
+ proc CLS;
+ proc COLOR(consts c: integer);
+ proc DRAW(consts ix,iy: integer);
+ L proc EXPOSE(window: buffer; consts x,y: integer);
+ L proc GETMAP(consts x,y: integer; ekran: buffer);
+ L proc GROFF;
+ proc GRON(consts imode: integer);
+ proc HASCII(consts ic: integer);
+ proc HFILL(consts maxx: integer);
+ proc HFONT(consts seg, offs: integer);
+ proc HFONT8(vars seg, offs: integer);
+ proc HPAGE(consts page, mode, clear: integer);
+ P proc INHLINE(vars n:integer; line: tekst);
+ L func INKEY(consts idummy: integer): integer;
+ func INPIX(consts x,y: integer): integer;
+ proc INTENS(consts i: integer);
+ PL proc INWLINE(window: buffer; vars n: integer;
+ line: tekst);
+ L func INXPOS(consts idummy: integer): integer;
+ L func INYPOS(consts idummy: integer): integer;
+ L proc MKWNDW(consts x,y,icols,ilines: integer;
+ window: buffer;
+ consts iwndwsize,iborder: integer);
+ proc MOVE(consts ix,iy: integer);
+ L func NOCARD(consts idummy: integer): integer;
+ proc ORMAP(ekran: buffer);
+ PL proc OUTHLINE(consts n:integer; line: tekst);
+ PL proc OUTWLINE(window: buffer; consts n: integer;
+ line: tekst);
+ proc PALLET(consts p: integer);
+ proc PATERN(consts p1, p2, p3, p4: integer);
+ proc POINT(consts ix,iy: integer);
+ proc POPXY;
+ proc PRTSCR(consts nr: integer);
+ proc PUSHXY;
+ proc PUTMAP(ekran: buffer);
+ L proc RCIRB(consts ix,iy,ir: real;
+ consts alfa, beta: real;
+ consts cbord, bcint, p, q: integer);
+ L proc RDRAW(consts rx,ry: real);
+ PL func RINXPOS(consts dummy: real): real;
+ PL func RINYPOS(consts dummy: real): real;
+ L proc RMOVE(consts rx,ry: real);
+ PL proc RWINDOW(rw: array [1:4] of real;
+ consts s: integer);
+ proc STYLE(consts s: integer);\f
+
+
+ 28
+
+
+ PL proc SWINDOW(rw: array [1:4] of real;
+ iw: array [1:4] of integer;
+ consts s: integer);
+ proc TRACK(consts x,y: integer);
+ proc VFILL(consts maxy: integer);
+ proc VIDEO(ekran: buffer);
+ proc XORMAP(ekran: buffer);
+
+Uzyto notacji semi-pascalowej.
+Specyfikacja consts oznacza parametr przekazywany przez
+wartosc (tylko wejsciowy), vars - przez zmienna (wejsciowo-
+wyjsciowy).
+Typ buffer oznacza tablice bajtowa sluzaca do przechowania
+zawartosci okreslonego obszaru ekranu ( rozmiar jej zalezy
+od wielkosci tego obszaru ), typ tekst natomiast oznacza
+tablice znakowa.
+Litery w pierwszej kolumnie sugeruja dodatkowe wazne
+informacje (roznice) w kontekscie konkretnych jezykow
+(Fortran, Pascal, C, Loglan).\f
+
+
+ 29
+
+
+
+ DODATEK F
+
+ Wartosci kodow klawiszy specjalnych:
+
+
+ 3 - ctrl-2
+ 15 - back tab (shift-tab)
+ 16-25 - ALT-Q az do ALT-P
+ 30-38 - ALT-A az do ALT-L
+ 44-50 - ALT-Z az do ALT-M
+ 59-68 - F1 az do F10
+ 71 - Home
+ 72 - Cursor-Up
+ 73 - PgUp
+ 75 - Cursor-Left
+ 77 - Cursor-Right
+ 79 - End
+ 80 - Cursor-Down
+ 81 - PgDn
+ 82 - Ins
+ 83 - Del
+ 84-93 - Shift-F1 az do Shift-F10
+ 94-103 - Ctrl-F1 az do Ctrl-F10
+ 104-113 - Alt-F1 az do Alt-F10
+ 114 - Ctrl-PrtSc
+ 115 - Ctrl-Cursor-Left
+ 116 - Ctrl-Cursor-Right
+ 117 - Ctrl-End
+ 118 - Ctrl-PgDn
+ 119 - Ctrl-Home
+ 120-131 - Alt-1 az do Alt-=
+ 132 - Ctrl-PgUp\f
+
+
+ 30
+
+
+
+
+ DODATEK G
+
+ FEDIT
+
+ Prosty program do edycji kroju znakow.
+ Dodatek do biblioteki graficznej IIUWGRAF.
+
+FEDIT pozwala komponowac i modyfikowac uklady pixli o
+wymiarze 8*8. Takie uklady moga byc wyswietlane razem z
+grafika za pomoca procedury HASCII.
+
+FEDIT produkuje opisy tablic kroju znakow w dwoch
+postaciach:
+
+ - jako podprogram dostarczajacy adres tablicy kroju
+w postaci odpowiedniej do przekazania procedurze HFONT,
+
+ - jako niezalezny program umieszczajacy wskaznik do
+tablicy kroju w wektorze przerwania 14H.
+
+Pierwszy format moze byc uzyty do zastapienia standardowego
+zestawu znakow zwykle znajdujacego sie w ROM BIOS pod
+adresem F000:FA6E. Jest on uzywany przez procedure HASCII do
+rysowania znakow o kodach od 0 do 127. Stad jego nazwa :
+ "format 0".
+
+Podprogram wygenerowany przez FEDIT ma nazwe HFONT8. Po
+przetlumaczeniu przez MACROASSEMBLER musi byc on linkowany
+razem z programem uzytkowym. Jesli zajdzie potrzeba zmiany
+nazwy (np. w celu dynamicznego przelaczania pomiedzy kilkoma
+krojami znakow), nazwa moze byc zmieniona recznie w tekscie
+zrodlowym.
+
+Drugi format jest uzywany do rysowania znakow z
+rozszerzonego zakresu znakow o kodach od 128 do 255. Stad
+nazwa:
+ "format 128".
+
+Opis zestawu znakow w tym formacie musi byc zaladowany do
+pamieci przed rozpoczeciem wykonania programu, ktory z niego
+korzysta. Wskaznik do tablicy kroju musi byc wpisany w
+wektor przerwania 14H. Robi to program wygenerowany przez
+FEDIT, ktory nastepnie zawiesza sie za pomoca przerwania 27H
+(terminate but stay resident). W tym przypadku tekst
+zrodlowy po przetlumaczeniu przez MACROASSEMBLER musi byc
+zlinkowany (bez zadnych bibliotek) do postaci .EXE.
+IIUWGRAF i FEDIT nie daja mozliwosci dynamicznego
+przelaczania tablic znakow rozszerzonego zakresu.
+\f
+
+
+ 31
+
+
+Przyklad:
+
+VAR ISEG, IOFFS: INTEGER;
+BEGIN
+ HFONT8(ISEG,IOFFS); (* ADRES TABLICY FORMATU 0 *)
+ ...
+ HASCII(45); (* UZYWA ROM BIOS *)
+ HASCII(145); (* UZYWA ROZSZERZONEGO ZESTAWU *)
+ ...
+ HFONT(ISEG,IOFFS);
+ HASCII(45); (* UZYWA TABLICY FORMATU 0 *)
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)
+ ...
+ HFONT(16#F000,16#FA6E);
+ HASCII(45); (* ZNOWU ROM BIOS *)
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)
+
+
+ FEDIT jest prostym programem konwersacyjnym o kilku
+zaledwie rozkazach. Tablica kroju znakow zawiera wzorce
+ukladow pixli rozmiaru 8*8. Wzorzec pojedynczego znaku moze
+byc wyjety z tej tablicy w celu jego edycji i zapamietany z
+powrotem, byc moze w innym miejscu tablicy. Sa dwie tablice
+znakow: jedna dla kodow od 0 do 127, druga dla kodow od 128
+do 255. Pierwsza z nich nie moze byc modyfikowana. Druga z
+nich moze poczatkowo zawierac zaladowany wczesniej
+rozszerzony zestaw lub zostac wyczyszczona. Mozna tez
+wczytac do niej zestaw zawarty w pliku wygenerowanym
+wczesniej przez FEDIT. Po dokonaniu modyfikacji, zawartosc
+tej drugiej tablicy moze byc uzyta do generacji badz
+"formatu 0" badz "128".
+
+
+ Rozkazy FEDITu.
+
+
+Rozkazy FEDITu sa wprowadzane jako pojedyncze litery
+wybierajace czynnosci wymienione w jadlospisie wyswietlonym
+u gory ekranu. Dodatkowe parametry podaje sie po
+przynagleniu przez FEDIT.
+
+Komendy FEDITu:
+
+< low odswieza tablice "0 do 127"
+
+> high odswieza tablice "128 do 255"
+
+i init inicjalizuje zerami tablice "128 do 255"
+
+l load laduje tablice "128 do 255" z pliku
+ dodatkowy parametr:
+ - nazwa pliku (musi istniec)\f
+
+
+ 32
+
+
+
+d dump wypisuje zawartosc tablicy "128 do 255"
+ na plik; dodatkowe parametry:
+ - nazwa pliku (bedzie zapisany)
+ - baza ( 0 albo 128),
+ zaleznie od formatu
+ - jezyk:
+ f - MS Fortran, MS Pascal
+ s - Lattice C, model S
+ p - Lattice C, model P
+ d - Lattice C, model D
+ l - Lattice C, model L
+
+e edit wyjmuje z tablicy pojedynczy znak
+ i umieszcza go w obszarze roboczym.
+ dodatkowy parametr:
+ - kod znaku (dziesietnie)
+ Po obszarze roboczym mozna poruszac sie
+ za pomoca klawiszy kierunkowych. Pixel
+ zapala klawisz Ins, gasi klawisz Del.
+ Klawisz End powoduje wyjscie z tego trybu.
+
+t text wyswietla tekst pomocny przy ocenie
+ jakosci ksztaltu znakow. Tekst, nie dluzszy
+ niz 40 znakow jest wprowadzany przez uzytkow-
+ nika. Dodatkowe parametry:
+ - vspace,
+ - hspace - odpowiednio, pionowy i poziomy
+ odstep w pixlach pomiedzy znakami. Normalnie,
+ vspace wynosi 2, hspace - 0.
+
+p put przechowuje wzorzec z obszaru roboczego pod
+ wskazanym kodem. Dodatkowy parametr:
+ - kod pozycji (dziesietnie),
+ powinien byc miedzy 128 a 255
+
+q quit konczy dzialanie FEDIT
+
+
+Z FEDITem nalezy obchodzic sie ostroznie. Posiada on jedynie
+minimalne wbudowane zabezpieczenia i np. bez ostrzezenia
+zapisze nowa, nie wykonczona jeszcze wersje kroju znakow na
+pliku zawierajacym jedyny egzemplarz poprzedniej, bardzo
+potrzebnej wersji.\f
+
+
+ 33
+
+
+
+ DODATEK H
+
+ Zmiany IIUWGRAFu w stosunku do poprzednich wersji
+
+
+
+ Zmiany IIUWGRAFu w stosunku do wersji 1.1
+
+
+1) Rozszerzenie zestawu obslugiwanych kart graficznych o
+karte EGA ( IBM Enhanced Graphics Adapter ).
+
+2) Niewielkie modyfikacje procedur IIUWGRAFu :
+
+ - dodanie procedury PRTSCR,
+ - modyfikacja procedury PATERN polegajaca na :
+ zwiekszeniu liczby parametrow ( wzorcow ) z
+dwoch do czterech oraz
+ zmianie postaci tych parametrow ( zamiast
+liczb dziesietnych liczby szesnastkowe ),
+( rozszerzenie wzorcow oczywiscie oznacza rownoczesnie
+modyfikacje procedur HFILL oraz VFILL ),
+ - zmiany nazw procedur GRAPH, TEXT, SCREEN
+odpowiednio na GRON, GROFF, NOCARD.
+
+
+
+
+ Zmiany IIUWGRAFu w stosunku do wersji 2.1
+
+
+1) Udostepnienie procedur CIRB oraz RCIRB dla C.
+\f
--- /dev/null
+ TITLE NULLGRAF
+ PUBLIC GRON, GROFF, CLS, POINT, MOVE, DRAW, HFILL, VFILL
+ PUBLIC COLOR, STYLE, PATERN, INTENS, PALLET, BORDER, VIDEO, HPAGE
+ PUBLIC NOCARD, PUSHXY, POPXY, INXPOS, INYPOS, INPIX, GETMAP, PUTMAP
+ PUBLIC ORMAP, XORMAP, TRACK, INKEY, HASCII, HFONT, HFONT8, OUTHLI
+ PUBLIC CIRB
+
+DEFPRO MACRO ARG, PRLIST
+ LOCAL LAB
+ IRP X, <PRLIST>
+X LABEL FAR
+ ENDM
+LAB PROC FAR
+ RET ARG
+LAB ENDP
+ ENDM
+
+CODE SEGMENT 'CODE'
+ ASSUME CS:CODE
+
+ DEFPRO , <GROFF, CLS, PUSHXY, POPXY>
+ DEFPRO 4, <GRON, HFILL, VFILL, COLOR, STYLE, INTENS, PALLET, BORDER>
+ DEFPRO 4, <VIDEO, NOCARD, INXPOS, INYPOS, PUTMAP, ORMAP, XORMAP, INKEY>
+ DEFPRO 4, <HASCII>
+ DEFPRO 8, <POINT, MOVE, DRAW, INPIX, TRACK, HFONT, HFONT8, OUTHLI>
+ DEFPRO 12,<HPAGE, GETMAP>
+ DEFPRO 16,<PATERN>
+ DEFPRO 36,<CIRB>
+
+CODE ENDS
+ END
+\1a
\ No newline at end of file
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+
+void pascal draw( _col, _row )
+ int *_col,*_row;
+{
+ int X1 = inxpos(NULL);
+ int Y1 = inypos(NULL);
+ int X2 = *_col;
+ int Y2 = *_row;
+ int pos_slope;
+
+ int dX, dY, /* vector components */
+ row, col,
+ final, /* final row or col number */
+ G, /* used to test for new row or column */
+ inc1, /* G increment when row or column doesn't change */
+ inc2; /* G increment when row or column does change */
+
+ if( X2 < X1 )
+ {
+ X1 = *_col;
+ Y1 = *_row;
+ X2 = inxpos(NULL);
+ Y2 = inypos(NULL);
+ }
+
+ dX = X2 - X1; dY = Y2 - Y1; /* find vector component */
+ pos_slope = (dX > 0); /* is slope positive? */
+ if (dY < 0) pos_slope = !pos_slope;
+ if (abs(dX) > abs(dY)) { /* shallow line case */
+ if (dX > 0) { /* determine start point and last column */
+ col = X1; row = Y1; final = X2;
+ } else {
+ col = X1; row = Y2; final = X1;
+ }
+ inc1 = 2*abs(dY); /* determine increments and initial G */
+ G = inc1 - abs(dX);
+ inc2 = 2 * (abs(dY) - abs(dX));
+ if (pos_slope)
+ while (col<=final) { /* step thru cols. checking for new row */
+ point( &col, &row );
+ col++;
+ if (G >= 0) { /* it's time to change rows */
+ row++; G+= inc2; /* positive slope, so inc thru rows */
+ } else /* stay at the same row */
+ G += inc1;
+ } /* while */
+ else
+ while (col<=final) { /* step thru cols, check for new row */
+ point( &col, &row );
+ col++;
+ if (G > 0) { /* time to change the rows */
+ row--; G+= inc2; /* negative slope, dec thru rows */
+ } else
+ G += inc1; /* stay at the same row */
+ } /* while */
+ } /* if |dX| > |dY| */ else {
+ if (dY > 0) { /* steep line case, angle > 45 degree */
+ col = X1; row = Y1; final = Y2; /* find start point and last row */
+ } else {
+ col = X2; row = Y2; final = Y1;
+ }
+ inc1 = 2 * abs(dX); /* determine increments and initial G */
+ G = inc1 - abs(dY);
+ inc2 = 2 * (abs(dX) - abs(dY));
+ if (pos_slope)
+ while (row <= final) { /* step thru rows - check for new column */
+ point( &col, &row );
+ row++;
+ if (G >= 0) { /* it's time to change columns */
+ col++; G+= inc2; /* pos. slope, increment thru cols. */
+ } else
+ G += inc1; /* stay at the same column */
+ } /* while */
+ else
+ while (row <= final) {/* step thru rows, checking for new column */
+ point( &col, &row );
+ row++;
+ if (G > 0) { /* it's time to change columns */
+ col--; G+= inc2; /* neg slope, so decrement thru columns */
+ } else
+ G += inc1; /* stay at the same column */
+ } /* while */
+ } /* if |dY| > |dX| */
+
+ move( _col, _row );
+}
+
+
+\r
--- /dev/null
+\r
+#include "graf.h"
+
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+
+void pascal getmap( x, y, buf )
+ int *x,*y;
+ char *buf;
+{
+ /* buffer : 2 bytes X size, 2 bytes Y size, and rows * columns of pixels */
+ int i,j,x0,y0,x1,y1;
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ pushxy();
+ if( *x < x00 )
+ {
+ x0 = *x;
+ x1 = x00;
+ }
+ else
+ {
+ x1 = *x;
+ x0 = x00;
+ }
+ if( *y < y00 )
+ {
+ y0 = *y;
+ y1 = y00;
+ }
+ else
+ {
+ y1 = *y;
+ y0 = y00;
+ }
+ ((short int *)buf)[0] = (short int)(x1-x0+1);
+ ((short int *)buf)[1] = (short int)(y1-y0+1);
+ buf += 4;
+ for( j=y0; j<=y1; j++ )
+ for( i=x0; i<=x1; i++ )
+ *(buf++) = (char)inpix( &i, &j );
+ popxy();
+}
+
+
+void pascal putmap( buf )
+ char *buf;
+{
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ int xw = ((short int *)buf)[0];
+ int yw = ((short int *)buf)[1];
+ int i,j;
+ pushxy();
+ buf += 4;
+ for( j=y00; j<y00+yw; j++ )
+ for( i=x00; i<x00+xw; i++ )
+ {
+ int c = (int)*buf;
+ color( &c );
+ point( &i, &j );
+ buf++;
+ }
+ popxy();
+}
+
+
+void pascal ormap( buf )
+ char *buf;
+{
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ int xw = ((short int *)buf)[0];
+ int yw = ((short int *)buf)[1];
+ int i,j;
+ pushxy();
+ buf += 4;
+ for( j=y00; j<y00+yw; j++ )
+ for( i=x00; i<x00+xw; i++ )
+ {
+ int c = inpix( &i, &j );
+ c |= (int)*buf;
+ color( &c );
+ point( &i, &j );
+ buf++;
+ }
+ popxy();
+}
+
+
+void pascal xormap( buf )
+ char *buf;
+{
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ int xw = ((short int *)buf)[0];
+ int yw = ((short int *)buf)[1];
+ int i,j;
+ pushxy();
+ buf += 4;
+ for( j=y00; j<y00+yw; j++ )
+ for( i=x00; i<x00+xw; i++ )
+ {
+ int c = inpix( &i, &j );
+ c ^= (int)*buf;
+ color( &c );
+ point( &i, &j );
+ buf++;
+ }
+ popxy();
+}
+
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#ifndef NULL
+#define NULL (void *)0
+#endif
+
+
+void pascal gron( int * );
+void pascal groff( void );
+void pascal cls( void );
+void pascal point( int *, int * );
+void pascal move( int *, int * );
+void pascal draw( int *, int * );
+void pascal hfill( int * );
+void pascal vfill( int * );
+void pascal color( int * );
+void pascal style( int * );
+void pascal patern( int *, int *, int *, int * );
+void pascal intens( int * );
+void pascal pallet( int * );
+void pascal border( int * );
+void pascal video( char * /* normalized */ );
+void pascal hpage( int *, int *, int * );
+int pascal nocard( void * /* NULL */ );
+void pascal pushxy( void );
+void pascal popxy( void );
+int pascal inxpos( void * /* NULL */ );
+int pascal inypos( void * /* NULL */ );
+int pascal inpix( int *, int * );
+
+void pascal getmap( int *, int *, char * /* normalized */ );
+void pascal putmap( char * /* normalized */ );
+void pascal ormap( char * /* normalized */ );
+void pascal xormap( char * /* normalized */ );
+
+void pascal track( int *, int * );
+int pascal inkey( void * /* NULL */ );
+void pascal hascii( int * );
+void pascal hfont( int *, int * );
+void pascal hfont8( int *, int * );
+void pascal outhli( int *, char * );
+void pascal cirb( int *, int *, int *, float *, float *, int *, int *, int *, int * );
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+
+#define bound(x,y) ( x<0 || y<0 || x>719 || y>347 )
+
+
+int pascal nocard( dummy )
+ void *dummy;
+{
+ return 1;
+}
+
+
+#define index 0x3b4 /* 6845 ports */
+#define data 0x3b5
+#define mode 0x3b8 /* Herc ports */
+#define status 0x3ba
+#define config 0x3bf
+
+
+static int cur_color;
+static int cur_x;
+static int cur_y;
+static char *page_drawn;
+static int page_drawn_no;
+static int page_viewed;
+
+
+#if WORD_32BIT
+#define HERC_BASE 0xE00B0000UL
+#define CHAR_BASE 0xE00FFA6EUL
+#else
+#define HERC_BASE 0xB0000000UL
+#define CHAR_BASE 0xFFA6000EUL
+#endif
+
+
+static void set_page_drawn( page )
+ int page;
+{
+ if( page == 0 || page == 1 )
+ {
+ page_drawn = (char *)( HERC_BASE + page * 0x8000);
+ page_drawn_no = page;
+ }
+}
+
+
+static void screen_off()
+{
+ outportb( mode, '\0' );
+}
+
+
+static void set_page_viewed( page )
+ int page;
+{
+ if( page == 0 ) outportb( mode, '\x0a' );
+ else
+ if( page == 1 ) outportb( mode, '\x8a' );
+ page_viewed = page;
+}
+
+
+static void clear_buffer( buf )
+ char *buf;
+{
+ int i;
+ for( i=0; i<0x7fff; i++ ) buf[i] = '\0';
+}
+
+
+static void clear_gr_scr( page )
+ int page;
+{
+ if( page_viewed == page ) screen_off();
+ clear_buffer( (char *)(HERC_BASE + page*0x8000) );
+ if( page_viewed == page ) set_page_viewed( page );
+}
+
+
+static int in_graphics=0;
+void pascal gron( dummy )
+ int *dummy;
+{
+ char i;
+ static char params[16] = {
+ '\x35', '\x2d', '\x2e', '\x07', '\x5b', '\x02',
+ '\x57', '\x57', '\x02', '\x03', '\x00', '\x00',
+ '\x00', '\x00', '\x00', '\x00'
+ };
+
+ if( in_graphics ) return;
+ in_graphics = 1;
+
+ atexit( groff );
+
+/*
+ {
+ int i=0;
+ geninterrupt (0x11);
+ if (( AX & 0x30 ) == 0x30)
+ for (i=0; i<0x800; i++)
+ if (inportb(status) & 0x80)
+ {
+ i=-1;
+ break;
+ }
+ if( i != -1 )
+ {
+ fprintf( stderr, "This version runs only with HERCULES graphic card\n" );
+ exit( 1 );
+ }
+ }
+*/
+
+
+ outportb( config, 3 ); /* allows both graphics pages */
+ screen_off();
+ for( i=0; i<sizeof(params); i++) {
+ outportb( index, i );
+ outportb( data, params[i] );
+ }
+ set_page_viewed( 0 );
+ set_page_drawn ( 0 );
+ clear_gr_scr( 1 );
+ clear_gr_scr( 0 );
+ cur_color=1;
+ cur_x=0;
+ cur_y=0;
+}
+
+
+void pascal groff()
+{
+ char i;
+ static char params[16] = {
+ 0x61, 0x50, 0x52, 0x0f, 0x19, 0x06,
+ 0x19, 0x19, 0x02, 0x0d, 0x0b, 0x0c,
+ 0x00, 0x00, 0x00, 0x00
+ };
+
+ if( !in_graphics ) return;
+ in_graphics = 0;
+
+ outportb( config, 0 ); /* lock out graphics mode */
+ screen_off();
+ for( i=0; i<sizeof(params); i++) {
+ outportb( index, i );
+ outportb( data, params[i] );
+ }
+ outportb( mode, '\x28' ); /* enable blink and turn on screen */
+}
+
+
+void pascal hpage( nr, tryb, zeruj )
+ int *nr,*tryb,*zeruj;
+{
+ if( *nr == 0 )
+ {
+ if( *zeruj ) clear_gr_scr( 0 );
+ if( *tryb == 1 ) set_page_viewed( 0 );
+ if( *tryb == -1 ) set_page_viewed( 0 );
+ }
+ else
+ if( *nr == 1 )
+ {
+ if( *zeruj ) clear_gr_scr( 1 );
+ if( *tryb == 1 ) set_page_viewed( 1 );
+ if( *tryb == -1 ) set_page_viewed( 1 );
+ }
+}
+
+
+void pascal video( buffer )
+ char *buffer;
+{
+ page_drawn = buffer;
+ page_drawn_no = -1;
+}
+
+
+void pascal cls()
+{
+ if( page_viewed == page_drawn_no ) clear_gr_scr( page_viewed );
+ else clear_buffer( page_drawn );
+}
+
+
+void pascal point( col, row )
+ int *col,*row;
+{
+ int x=*col, y=*row;
+ int byte_ofs; /* offset within page for byte containing the point */
+ char mask; /* locates point within the byte */
+ if( bound( *col, *row ) ) return;
+ mask = 1 << (7 - (x % 8));
+ byte_ofs = 0x2000 * (y % 4) + 90 * (y/4) + (x/8);
+ if( cur_color == 1 ) /* draw the point */
+ page_drawn[ byte_ofs ] |= mask;
+ else /* erase the point */
+ page_drawn[ byte_ofs ] &= ~mask;
+ move( col, row );
+}
+
+
+void pascal move( col, row )
+ int *col,*row;
+{
+ cur_x = *col;
+ cur_y = *row;
+}
+
+
+int pascal inxpos( dummy ) void *dummy; { return cur_x; }
+int pascal inypos( dummy ) void *dummy; { return cur_y; }
+
+
+int pascal inpix( col, row )
+ int *col,*row;
+{
+ int x=*col, y=*row;
+ int byte_ofs; /* offset within page for byte containing the point */
+ char mask; /* locates point within the byte */
+ if( bound( *col, *row ) ) return 0;
+ move( col, row );
+ mask = 1 << (7 - (x % 8));
+ byte_ofs = 0x2000 * (y % 4) + 90 * (y/4) + (x/8);
+ return !!( page_drawn[ byte_ofs ] & mask );
+}
+
+
+void pascal color( c )
+ int *c;
+{
+ cur_color = *c;
+}
+
+
+void pascal intens( intensity ) int *intensity; {}
+void pascal pallet( palette ) int *palette; {}
+void pascal border( color ) int *color; {}
+void pascal style ( style_no ) int *style_no; {}
+void pascal patern( p1,p2,p3,p4 ) int *p1,*p2,*p3,*p4; {}
+
+
+static struct { int x,y,c; } stack[16];
+static int stack_top=0;
+void pascal pushxy()
+{
+ stack[stack_top ].x = cur_x;
+ stack[stack_top ].y = cur_y;
+ stack[stack_top++].c = cur_color;
+}
+void pascal popxy()
+{
+ cur_x = stack[--stack_top].x;
+ cur_y = stack[ stack_top].y;
+ cur_color = stack[ stack_top].c;
+}
+
+
+void pascal track ( x, y ) int *x,*y; {}
+
+static char *char_base = (char *)CHAR_BASE;
+void pascal hascii( chrp )
+ int *chrp;
+{
+ int i,j;
+ int chr = (*chrp) & 0x7F;
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ pushxy();
+ if( chr == 0 )
+ {
+ int col = cur_color;
+ cur_color = 0;
+ for( i=x00; i<x00+8; i++ ) for( j=y00; j<y00+8; j++ ) point(&i,&j);
+ cur_color = col;
+ }
+ else
+ {
+ char *c = char_base + 8*chr;
+ for( i=x00; i<x00+8; i++ ) for( j=y00; j<y00+8; j++ )
+ if( !!( c[j-y00] & (0x80>>(i-x00)) ) )
+ point(&i,&j);
+ }
+ popxy();
+ if( chr != 0 )
+ {
+ x00 += 8;
+ move( &x00, &y00 );
+ }
+}
+void pascal hfont ( seg, ofs ) int *seg,*ofs; {}
+void pascal hfont8( seg, ofs ) int *seg,*ofs; {}
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+/*
+ OUTHLINE(dlugosc,bufor)
+
+ Procedura OUTHLINE wywoluje HASCII dlugosc razy,
+ wypisujac na ekran znaki, ktorych kody zawarte sa w buforze.
+ Przed narysowaniem kazdego znaku wywolywane jest HASCII(0).
+*/
+
+#include "graf.h"
+
+void pascal outhli( length, buf )
+ int *length;
+ char *buf;
+{
+ int l = (*length) % 0x10000;
+ int zero = 0;
+ while( l-- > 0 )
+ {
+ hascii( &zero );
+ hascii( (int *)(buf++) );
+ }
+}
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+
+void pascal hfill( col )
+ int *col;
+{
+ int x = inxpos(NULL);
+ int y = inypos(NULL);
+ draw( col, &y );
+ move( &x, &y );
+}
+
+
+void pascal vfill( row )
+ int *row;
+{
+ int x = inxpos(NULL);
+ int y = inypos(NULL);
+ draw( &x, row );
+ move( &x, &y );
+}
+
+\r
--- /dev/null
+# /* Loglan82 Compiler&Interpreter\r
+# Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+# Copyright (C) 1993, 1994 LITA, Pau\r
+# \r
+# This program is free software; you can redistribute it and/or modify\r
+# it under the terms of the GNU General Public License as published by\r
+# the Free Software Foundation; either version 2 of the License, or\r
+# (at your option) any later version.\r
+# \r
+# This program is distributed in the hope that it will be useful,\r
+# but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+# GNU General Public License for more details.\r
+# \r
+# =======================================================================\r
+\r
+\r
+COMMON=hlineio.o draw.o hvfill.o cirb.o gpmap.o hercules.o
+
+CC=gcc -O -Dpascal= -DWORD_32BIT
+CCc=$(CC) -c
+
+#CC=cl -AL -Olsg
+#CCc=$(CC) -Fo$*.o -c
+
+.c.o :
+ $(CCc) $*.c
+
+hgc386.a : $(COMMON)
+ ar rv hgc386.a $(COMMON)
+
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+/* Handler routines */\r
+\r
+/* pataud le 13/10/94\r
+#if !NO_GRAPH || !DJE\r
+#if MSDOS\r
+#include "graf\graf.h"\r
+#else\r
+#include "graf/graf.h"\r
+#endif\r
+#endif\r
+*/\r
+\r
+void errsignal(exception)\r
+int exception;\r
+{\r
+ word signum, ah, am;\r
+\r
+ signum = scot[ exception ];\r
+ if (signum != -1) /* attempt to call a handler */\r
+ {\r
+ raise_signal(signum, (word) 0, &ah, &am);\r
+ if (ic != 0) /* continue execution */\r
+ {\r
+ go(ah, am);\r
+ longjmp(contenv, 1);\r
+ }\r
+ }\r
+\r
+#if MSDOS && !NO_GRAPH && !DJE\r
+ {\r
+ extern bool graphmode;\r
+\r
+ if (graphmode) groff();\r
+ graphmode = FALSE;\r
+ }\r
+#endif\r
+\r
+ putc('\n', stderr);\r
+ switch (exception)\r
+ {\r
+ case RTESLCOF: fprintf(stderr, " SL CHAIN CUT OFF"); break;\r
+ case RTEUNSTP: fprintf(stderr, " UNIMPLEMENTED STANDARD PROCEDURE"); break;\r
+ case RTEILLAT: fprintf(stderr, " ILLEGAL ATTACH"); break;\r
+ case RTEILLDT: fprintf(stderr, " ILLEGAL DETACH"); break;\r
+ case RTECORTM: fprintf(stderr, " COROUTINE TERMINATED"); break;\r
+ case RTECORAC: fprintf(stderr, " COROUTINE ACTIVE"); break;\r
+ case RTEINVIN: fprintf(stderr, " ARRAY INDEX ERROR"); break;\r
+ case RTEILLAB: fprintf(stderr, " INCORRECT ARRAY BOUNDS"); break;\r
+ case RTEINCQA: fprintf(stderr, " IMPROPER QUA"); break;\r
+ case RTEINCAS: fprintf(stderr, " ILLEGAL ASSIGNMENT"); break;\r
+ case RTEFTPMS: fprintf(stderr, " FORMAL TYPE MISSING"); break;\r
+ case RTEILLKL: fprintf(stderr, " ILLEGAL KILL"); break;\r
+ case RTEILLCP: fprintf(stderr, " ILLEGAL COPY"); break;\r
+ case RTEINCHS: fprintf(stderr, " INCOMPATIBLE HEADERS"); break;\r
+ case RTEHNDNF: fprintf(stderr, " HANDLER NOT FOUND"); break;\r
+ case RTEMEMOV: fprintf(stderr, " MEMORY OVERFLOW"); break;\r
+ case RTEFHTLG: fprintf(stderr, " FORMAL LIST TOO LONG"); break;\r
+ case RTEILLRT: fprintf(stderr, " ILLEGAL RETURN"); break;\r
+ case RTEREFTN: fprintf(stderr, " REFERENCE TO NONE"); break;\r
+ case RTEDIVBZ: fprintf(stderr, " DIVISION BY ZERO"); break;\r
+ case RTESYSER: fprintf(stderr, " SYSTEM ERROR"); break;\r
+ case RTEILLIO: fprintf(stderr, " ILLEGAL I/O OPERATION"); break;\r
+ case RTEIOERR: fprintf(stderr, " I/O ERROR"); break;\r
+ case RTECNTOP: fprintf(stderr, " CANNOT OPEN FILE"); break;\r
+ case RTEBADFM: fprintf(stderr, " INPUT DATA FORMAT BAD"); break;\r
+ case RTEILLRS: fprintf(stderr, " ILLEGAL RESUME"); break;\r
+ case RTETMPRC: fprintf(stderr, " TOO MANY PROCESSES ON ONE MACHINE"); break;\r
+ case RTEINVND: fprintf(stderr, " INVALID NODE NUMBER"); break;\r
+ case RTENEGST: fprintf(stderr, " NEGATIVE STEP VALUE"); break;\r
+ case RTENONGL: fprintf(stderr, " REFERENCE TO GLOBAL NON PROCESS OBJECT FROM PROCESS"); break;\r
+ default : fprintf(stderr, " UNRECOGNIZED ERROR");\r
+ }\r
+ if (thisp->trlnumber < 0) thisp->trlnumber = - thisp->trlnumber;\r
+ if (thisp->trlnumber != 0)\r
+ fprintf(stderr, "\n AT LINE: %ld\n", (long) thisp->trlnumber);\r
+ endprocess(4);\r
+} /* end errsignal */\r
+\r
+\r
+void raise_signal(signal, skip, ahnew, amnew) /* Raise exception */\r
+word signal, skip;\r
+word *ahnew, *amnew;\r
+{\r
+ word t1, t2, t3, t4, t5, virts;\r
+ protdescr *ptr;\r
+\r
+ t1 = 0; /* handler for others = no */\r
+ t2 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */\r
+ t3 = c1; /* am of current */\r
+ t5 = 0; /* flag handler not found */\r
+ do\r
+ {\r
+ ptr = prototype[ M[ t3+PROTNUM ] ]; /* prototype of current */\r
+ t4 = ptr->handlerlist;\r
+ if (t4 != 0) /* any handlers ? */\r
+ {\r
+ do\r
+ {\r
+ t5 = M[ t4 ]; /* signal number */\r
+ if (t5 != signal)\r
+ {\r
+ if (t5 == 0 && t1 == 0) t1 = t4;\r
+ t4 = M[ t4+2 ];\r
+ }\r
+ } while (t5 != signal && t4 != 0);\r
+ }\r
+ if (t5 != signal) /* look in DL or SL */\r
+ {\r
+ if (t1 != 0) t4 = t1; /* handler for others found */\r
+ else\r
+ {\r
+ t4 = t3+M[ t3 ];\r
+ if (ptr->kind == HANDLER)\r
+ t2 = M[ t4+SL ]; /* use SL for handlers */\r
+ else\r
+ t2 = M[ t4+DL ]; /* or DL for other goodies */\r
+ if (t2 == 0) /* handler not found */\r
+ {\r
+ if (signal <= MAXSYSSN)\r
+ { /* system signal */\r
+ ic = skip;\r
+ if (ic != 0) longjmp(contenv, 1);\r
+ else return;\r
+ }\r
+ else errsignal(RTEHNDNF);\r
+ }\r
+ t3 = M[ t2 ];\r
+ }\r
+ }\r
+ else t1 = 0;\r
+ } while (t1 == 0 && t5 != signal);\r
+\r
+ virts = thisp->prochead+M[ thisp->prochead ]+VIRTSC;\r
+ M[ virts ] = t2; /* compactification possible */\r
+ M[ virts+1 ] = M[ t2+1 ];\r
+ t3 = M[ t4+1 ]; /* prototype number of handler */\r
+ t5 = prototype[ t3 ]->appetite;\r
+ if (t1 != 0) /* others */\r
+ {\r
+ request(t5, ahnew, amnew);\r
+ M[ *amnew+M[ *amnew ]+SIGNR ] = 0;\r
+ }\r
+ else\r
+ {\r
+ if (signal == scot[ RTEMEMOV ] &&\r
+ thisp->lastitem-thisp->lastused-1 < t5)\r
+ {\r
+ scot[ RTEMEMOV ] = -1; /* make memov look like abort */\r
+ errsignal(RTEMEMOV);\r
+ }\r
+ request(t5, ahnew, amnew);\r
+ M[ *amnew+M[ *amnew ]+SIGNR ] = signal;\r
+ }\r
+ M[ *amnew+PROTNUM ] = t3; /* provide system attributes */\r
+ t5 = *amnew+M[ *amnew ];\r
+ M[ t5+SL ] = M[ virts ];\r
+ M[ t5+SL+1 ] = M[ virts+1 ];\r
+ t2 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */\r
+ M[ t5+DL ] = t2;\r
+ M[ t5+DL+1 ] = M[ t2+1 ];\r
+ if (t1 != 0) /* skip */\r
+ {\r
+ ic = skip;\r
+ go(*ahnew, *amnew);\r
+ }\r
+} /* end raise_signal */\r
+\r
+\r
+void wind()\r
+{\r
+ word t1, t2;\r
+\r
+ t1 = M[ M[ c1+M[ c1 ]+SL ] ]; /* am of handlers' SL */\r
+ t2 = c1; /* current */\r
+ while (TRUE)\r
+ {\r
+ t2 = M[ M[ t2+M[ t2 ]+DL ] ]; /* am of DL */\r
+ if (t2 == t1) break;\r
+ M[ t2+M[ t2 ]+LSC ] = prototype[ M[ t2+PROTNUM ] ]->lastwill;\r
+ }\r
+ back(&thisp->backobj, &M[ temporary ], (word) 0);\r
+} /* end wind */\r
+\r
+\r
+void term()\r
+{\r
+ word t1;\r
+\r
+ t1 = M[ M[ c1+M[ c1 ]+SL ] ]; /* am of handlers' SL */\r
+ M[ t1+M[ t1 ]+LSC ] = prototype[ M[ t1+PROTNUM ] ]->lastwill;\r
+ wind();\r
+} /* end term */\r
+\r
+\r
+/* This wraps up the above series of the handler procedures.\r
+ */\r
+\r
+void backhd(virt, am)\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ if (M[ c1+M[ c1 ]+SIGNR ] <= MAXSYSSN)\r
+ errsignal(RTEILLRT); /* illegal return */\r
+ else\r
+ back(virt, am, (word) 0);\r
+} /* end backhd */\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "nonstand.h"\r
+\r
+typedef int word;\r
+\r
+#include <X11/cursorfont.h>\r
+#include <X11/keysym.h>\r
+\r
+/*#include <X11/Xos.h>*/\r
+#include <X11/Xlib.h>\r
+#include <X11/Xutil.h>\r
+#include <X11/Xatom.h>\r
+\r
+#include <X11/MwmUtil.h>\r
+\r
+#include <stdio.h>\r
+#include <math.h>\r
+#include <ctype.h>\r
+\r
+XSizeHints theHints;\r
+Display *theDisp;\r
+int theDepth, theScreen, dispcells;\r
+Colormap theCmap;\r
+Window rootW, window, father;\r
+GC theGC;\r
+unsigned long fcol,bcol,white,black,style=1;\r
+Font mfont;\r
+XFontStruct *mfinfo;\r
+Visual *theVisual;\r
+XImage *theImage;\r
+XClientMessageEvent toFatherEv;\r
+XEvent event;\r
+Cursor theCursor;\r
+\r
+int iWIDE,iHIGH;\r
+int mouse_x=0,mouse_y=0,mouse_l=0,mouse_r=0,mouse_c=0,\r
+ mouse_l_prs=0,mouse_r_prs=0,mouse_c_prs=0,\r
+ mouse_l_p_x=0,mouse_r_p_x=0,mouse_c_p_x=0,\r
+ mouse_l_p_y=0,mouse_r_p_y=0,mouse_c_p_y=0,\r
+ mouse_l_rel=0,mouse_r_rel=0,mouse_c_rel=0,\r
+ mouse_l_r_x=0,mouse_r_r_x=0,mouse_c_r_x=0,\r
+ mouse_l_r_y=0,mouse_r_r_y=0,mouse_c_r_y=0;\r
+int tracking=0;\r
+#define END_OF_TRACK -9999\r
+\r
+Pixmap pixmap;\r
+\r
+#define get_shrt(w) w=(int)(*(pars++));\r
+#define get_word(w) w=((int)(pars[0])&0xffff)|((int)pars[1]<<16); pars+=2;\r
+\r
+#define put_shrt(w) toFatherEv.data.s[cnt++] = (short)(w);\r
+#define put_word(w) toFatherEv.data.s[cnt++] = (short)((w) & 0xffff); \\r
+ toFatherEv.data.s[cnt++] = (short)(((w) >> 16) & 0xffff);\r
+#define snd_father toFatherEv.type=ClientMessage; \\r
+ toFatherEv.format = 16; \\r
+ XSendEvent(theDisp,father,False,NoEventMask,&toFatherEv); \\r
+ XFlush(theDisp);\r
+\r
+#ifndef NO_PROTOTYPES\r
+void RealiseCmd(int,short *);\r
+#else\r
+void RealiseCmd();\r
+#endif\r
+\r
+\r
+static char *application_name="IIUWGRAPH";\r
+\r
+\r
+#define QSIZE 256\r
+static KeySym keycodes[QSIZE];\r
+static int keyhead=0,keytail=0;\r
+\r
+main(argc, argv)\r
+ int argc;\r
+ char *argv[];\r
+{\r
+ int w=0;\r
+ int i;\r
+ int events=0;\r
+\r
+ father = atoi(argv[1]);\r
+\r
+ for( i=2; i<argc; i++ ) argv[i-1]=argv[i];\r
+ argc--;\r
+\r
+ if ((theDisp = XOpenDisplay(NULL)) == NULL){\r
+ fprintf (stderr,"\n%s: Can't open display\n", argv[0]);\r
+ exit(1);\r
+ }\r
+\r
+ theScreen = DefaultScreen(theDisp);\r
+ theDepth = DefaultDepth(theDisp, theScreen);\r
+ rootW = RootWindow(theDisp,theScreen);\r
+ fcol=white= WhitePixel(theDisp,theScreen);\r
+ bcol=black= BlackPixel(theDisp,theScreen);\r
+ theVisual = DefaultVisual(theDisp,theScreen);\r
+ theCmap = XCreateColormap(theDisp,rootW,theVisual,AllocNone);\r
+ dispcells = DisplayCells(theDisp, theScreen);\r
+ theCursor = XCreateFontCursor(theDisp,XC_arrow);\r
+\r
+ iWIDE = 720; iHIGH = 348;\r
+\r
+ if ((mfinfo = XLoadQueryFont(theDisp,"fixed"))==NULL){\r
+ fprintf (stderr,"\n%s: Can't open 'fixed' font\n", argv[0]);\r
+ exit(1);\r
+ }\r
+ mfont=mfinfo->fid;\r
+\r
+ theHints.width =iWIDE;\r
+ theHints.height=iHIGH;\r
+ theHints.flags=PSize;\r
+ window = XCreateSimpleWindow(theDisp,rootW,10,10,iWIDE,iHIGH,3,fcol,bcol);\r
+\r
+ XSetStandardProperties(theDisp,window,"HERCULES","HERCULES",\r
+ None,argv,argc,theHints);\r
+ XDefineCursor(theDisp,window,theCursor);\r
+\r
+ XChangeProperty(theDisp,window,XA_WM_CLASS,XA_STRING,8,PropModeReplace,\r
+ application_name,strlen(application_name));\r
+\r
+ {\r
+ struct {\r
+ long flags;\r
+ long functions;\r
+ long decorations;\r
+ int input_mode;\r
+ } hints;\r
+ Atom a=XInternAtom(theDisp,_XA_MWM_HINTS,False);\r
+ hints.flags = MWM_HINTS_FUNCTIONS;\r
+ hints.functions = MWM_FUNC_CLOSE | MWM_FUNC_MOVE;\r
+ hints.decorations = 0;\r
+ hints.input_mode = 0;\r
+ XChangeProperty(theDisp,window,a,a,32,PropModeReplace,&hints,4);\r
+ }\r
+\r
+ theGC = XCreateGC(theDisp,window,0,0);\r
+ XSetFont(theDisp,theGC,mfont);\r
+ XSetForeground(theDisp,theGC,fcol);\r
+ XSetBackground(theDisp,theGC,bcol);\r
+\r
+ XSelectInput(theDisp,window,\r
+ ExposureMask |\r
+ KeyPressMask |\r
+ PointerMotionMask |\r
+ ButtonPressMask |\r
+ ButtonReleaseMask\r
+ );\r
+ XMapRaised(theDisp,window);\r
+\r
+ pixmap = XCreatePixmap(theDisp,window,iWIDE,iHIGH,theDepth);\r
+\r
+ for(;;){\r
+\r
+ XNextEvent(theDisp,&event);\r
+\r
+ switch (event.type){\r
+\r
+ case Expose:\r
+ {\r
+ int x=event.xexpose.x;\r
+ int y=event.xexpose.y;\r
+ int w=event.xexpose.width;\r
+ int h=event.xexpose.height;\r
+ int cnt=0;\r
+ XCopyArea(theDisp,pixmap,window,theGC,x,y,w,h,x,y);\r
+ if( events==0 ){\r
+ put_word(window);\r
+ snd_father\r
+ }\r
+ events=1;\r
+ }\r
+ break;\r
+\r
+ case ClientMessage:\r
+ RealiseCmd( (int)(event.xclient.message_type),event.xclient.data.s);\r
+ break;\r
+\r
+ case MappingNotify:\r
+ if( event.xmapping.request == MappingModifier ||\r
+ event.xmapping.request == MappingKeyboard )\r
+ XRefreshKeyboardMapping(&event);\r
+ break;\r
+\r
+ case KeyPress:\r
+ {\r
+ KeySym key;\r
+ char ch;\r
+ int i=XLookupString( &(event.xkey), &ch, 1, &key, NULL );\r
+\r
+ if( i>0 )\r
+ if( ch == '\177' ) keycodes[ keytail++ ] = -83;\r
+ else keycodes[ keytail++ ] = (int)ch;\r
+ else\r
+ if( key == NoSymbol ) break;\r
+ else\r
+ if( IsModifierKey( key ) ) break;\r
+ else\r
+ {\r
+ int to_return = 0;\r
+ switch( key ){\r
+ case XK_F1 : to_return = -59; break;\r
+ case XK_F2 : to_return = -60; break;\r
+ case XK_F3 : to_return = -61; break;\r
+ case XK_F4 : to_return = -62; break;\r
+ case XK_F5 : to_return = -63; break;\r
+ case XK_F6 : to_return = -64; break;\r
+ case XK_F7 : to_return = -65; break;\r
+ case XK_F8 : to_return = -66; break;\r
+ case XK_F9 : to_return = -67; break;\r
+ case XK_F10 : to_return = -68; break;\r
+ case XK_Home : to_return = -71; break;\r
+ case XK_Left : to_return = -75; break;\r
+ case XK_Up : to_return = -72; break;\r
+ case XK_Right : to_return = -77; break;\r
+ case XK_Down : to_return = -80; break;\r
+ case XK_End : to_return = -79; break;\r
+ case XK_Insert: to_return = -82; break;\r
+ case XK_Break : to_return = -3; break;\r
+ case XK_Prior : to_return = -73; break;\r
+ case XK_Next : to_return = -81; break;\r
+ }\r
+ if( to_return!=0 ) keycodes[ keytail++ ] = to_return;\r
+ else break;\r
+ }\r
+\r
+ if( keytail == QSIZE ) keytail = 0;\r
+ if( keytail == keyhead ){\r
+ keytail -- ;\r
+ if( keytail < 0 ) keytail = QSIZE ;\r
+ }\r
+ }\r
+ break;\r
+\r
+ case MotionNotify:\r
+ case ButtonPress:\r
+ case ButtonRelease:\r
+ mouse_x = event.xmotion.x;\r
+ mouse_y = event.xmotion.y;\r
+ if( event.type == ButtonPress ){\r
+ switch( event.xbutton.button ){\r
+ case Button1 : mouse_l=1; mouse_l_prs++;\r
+ mouse_l_p_x = mouse_x;\r
+ mouse_l_p_y = mouse_y;\r
+ if( tracking ){\r
+ tracking = 0;\r
+ RealiseCmd( END_OF_TRACK, NULL );\r
+ }\r
+ break;\r
+ case Button2 : mouse_c=1; mouse_c_prs++;\r
+ mouse_c_p_x = mouse_x;\r
+ mouse_c_p_y = mouse_y;\r
+ break;\r
+ case Button3 : mouse_r=1; mouse_r_prs++;\r
+ mouse_r_p_x = mouse_x;\r
+ mouse_r_p_y = mouse_y;\r
+ break;\r
+ }\r
+ }\r
+ if( event.type == ButtonRelease ){\r
+ switch( event.xbutton.button ){\r
+ case Button1 : mouse_l=0; mouse_l_rel++;\r
+ mouse_l_r_x = mouse_x;\r
+ mouse_l_r_y = mouse_y;\r
+ break;\r
+ case Button2 : mouse_c=0; mouse_c_rel++;\r
+ mouse_c_r_x = mouse_x;\r
+ mouse_c_r_y = mouse_y;\r
+ break;\r
+ case Button3 : mouse_r=0; mouse_r_rel++;\r
+ mouse_r_r_x = mouse_x;\r
+ mouse_r_r_y = mouse_y;\r
+ break;\r
+ }\r
+ }\r
+ break;\r
+\r
+ } /* end of switch */\r
+\r
+ } /* end of for */\r
+\r
+}\r
+\r
+\r
+\r
+word cmd=0,w,h,x,y,curx,cury,kolb,wwyp,p,q,r,color;\r
+word alfa,beta,aspect;\r
+char c;\r
+XImage *image;\r
+XImage *XGetImage();\r
+\r
+\r
+\r
+void RealiseCmd( cmd, pars ) int cmd; short *pars; {\r
+\r
+ int i=1;\r
+ int cnt=0;\r
+\r
+ switch( cmd ){\r
+\r
+ case CLS :\r
+ XSetForeground(theDisp,theGC,bcol);\r
+ XFillRectangle(theDisp,pixmap,theGC,0,0,iWIDE,iHIGH);\r
+ XFillRectangle(theDisp,window,theGC,0,0,iWIDE,iHIGH);\r
+ XSetForeground(theDisp,theGC,fcol);\r
+ break;\r
+\r
+ case GROFF :\r
+ XFreePixmap(theDisp,pixmap);\r
+ XDestroyWindow(theDisp,window);\r
+ XCloseDisplay(theDisp);\r
+ exit(0);\r
+ break;\r
+\r
+ case INKEY :\r
+ {\r
+ int keycode=0;\r
+ if( keyhead != keytail ){\r
+ keycode = keycodes[ keyhead++ ];\r
+ if( keyhead == QSIZE ) keyhead = 0;\r
+ }\r
+ put_word(keycode)\r
+ snd_father\r
+ }\r
+ break;\r
+\r
+ case POINT :\r
+ get_shrt( x );\r
+ get_shrt( y );\r
+ XDrawPoint(theDisp,pixmap,theGC,x,y);\r
+ XDrawPoint(theDisp,window,theGC,x,y);\r
+ break;\r
+\r
+ case DRAW :\r
+ get_shrt( curx );\r
+ get_shrt( cury );\r
+ get_shrt( x );\r
+ get_shrt( y );\r
+ XDrawLine(theDisp,pixmap,theGC,curx,cury,x,y);\r
+ XDrawLine(theDisp,window,theGC,curx,cury,x,y);\r
+ break;\r
+\r
+ case CIRB :\r
+ get_shrt( x );\r
+ get_shrt( y );\r
+ get_shrt( r );\r
+ get_shrt( aspect );\r
+ get_shrt( alfa );\r
+ get_shrt( beta );\r
+ XDrawArc(theDisp,pixmap,theGC,x,y,r,aspect,alfa,beta);\r
+ XDrawArc(theDisp,window,theGC,x,y,r,aspect,alfa,beta);\r
+ break;\r
+\r
+ case HFILL :\r
+ get_shrt( curx );\r
+ get_shrt( cury );\r
+ get_shrt( x );\r
+ XDrawLine(theDisp,pixmap,theGC,curx,cury,x,cury);\r
+ XDrawLine(theDisp,window,theGC,curx,cury,x,cury);\r
+ break;\r
+\r
+ case VFILL :\r
+ get_shrt( curx );\r
+ get_shrt( cury );\r
+ get_shrt( y );\r
+ XDrawLine(theDisp,pixmap,theGC,curx,cury,curx,y);\r
+ XDrawLine(theDisp,window,theGC,curx,cury,curx,y);\r
+ break;\r
+\r
+ case INPIX :\r
+ get_shrt( x );\r
+ get_shrt( y );\r
+ image=XGetImage(theDisp,pixmap,x,y,1,1,0x7fffffffL,ZPixmap);\r
+ color = XGetPixel(image,0,0);\r
+ XDestroyImage(image);\r
+ put_word(color)\r
+ snd_father\r
+ break;\r
+\r
+ case GETMAP :\r
+ {\r
+ Pixmap map;\r
+ get_shrt( x );\r
+ get_shrt( y );\r
+ get_shrt( w );\r
+ get_shrt( h );\r
+ if( w>iWIDE ) w=iWIDE;\r
+ if( h>iHIGH ) h=iHIGH;\r
+ map = XCreatePixmap(theDisp,window,w,h,theDepth);\r
+ XCopyArea(theDisp,pixmap,map,theGC,x,y,w,h,0,0);\r
+ put_word(map)\r
+ snd_father\r
+ }\r
+ break;\r
+\r
+ case PUTMAP :\r
+ case XORMAP :\r
+ case ORMAP :\r
+ {\r
+ Pixmap map;\r
+ switch( cmd ){\r
+ case XORMAP: XSetFunction(theDisp,theGC,GXxor); break;\r
+ case ORMAP: XSetFunction(theDisp,theGC,GXor ); break;\r
+ }\r
+ get_word( map );\r
+ get_shrt( curx );\r
+ get_shrt( cury );\r
+ get_shrt( w );\r
+ get_shrt( h );\r
+ if( w>iWIDE ) w=iWIDE;\r
+ if( h>iHIGH ) h=iHIGH;\r
+ XCopyArea(theDisp,map,pixmap,theGC,0,0,w,h,curx,cury);\r
+ XCopyArea(theDisp,map,window,theGC,0,0,w,h,curx,cury);\r
+ if( cmd != PUTMAP ) XSetFunction(theDisp,theGC,GXcopy);\r
+ }\r
+ break;\r
+\r
+ case COLOR :\r
+ get_shrt( color );\r
+ if( color == 0 ) fcol = black ;\r
+ else fcol = white ;\r
+ XSetForeground(theDisp,theGC,fcol);\r
+ break;\r
+\r
+ case BORDER :\r
+ get_shrt( color );\r
+ if( color == 0 ) bcol = black ;\r
+ else bcol = white ;\r
+ XSetBackground(theDisp,theGC,bcol);\r
+ break;\r
+\r
+ case STYLE :\r
+ {\r
+ static char style_2[]={ 6, 3 };\r
+ static char style_3[]={ 4, 6 };\r
+ static char style_4[]={ 2, 3 };\r
+ static char style_5[]={ 2, 9 };\r
+\r
+ get_shrt( style );\r
+ switch( style ){\r
+ case 0:\r
+ XSetForeground(theDisp,theGC,bcol);\r
+ XSetLineAttributes(theDisp,theGC,0,LineSolid,CapButt,JoinMiter);\r
+ break;\r
+ case 1:\r
+ XSetForeground(theDisp,theGC,fcol);\r
+ XSetLineAttributes(theDisp,theGC,0,LineSolid,CapButt,JoinMiter);\r
+ break;\r
+ case 2:\r
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,\r
+ CapButt,JoinMiter);\r
+ XSetDashes(theDisp,theGC,0,style_2,2);\r
+ break;\r
+ case 3:\r
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,\r
+ CapButt,JoinMiter);\r
+ XSetDashes(theDisp,theGC,0,style_3,2);\r
+ break;\r
+ case 4:\r
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,\r
+ CapButt,JoinMiter);\r
+ XSetDashes(theDisp,theGC,0,style_4,2);\r
+ break;\r
+ case 5:\r
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,\r
+ CapButt,JoinMiter);\r
+ XSetDashes(theDisp,theGC,0,style_5,2);\r
+ break;\r
+ }\r
+ }\r
+ break;\r
+\r
+ case HASCII :\r
+ get_shrt( curx );\r
+ get_shrt( cury );\r
+ get_shrt( r );\r
+ if( r==0 ){\r
+ XSetForeground(theDisp,theGC,bcol);\r
+ XFillRectangle(theDisp,pixmap,theGC,curx,cury,8,8);\r
+ XFillRectangle(theDisp,window,theGC,curx,cury,8,8);\r
+ XSetForeground(theDisp,theGC,fcol);\r
+ }else{\r
+ c = (char)r;\r
+ XDrawString(theDisp,pixmap,theGC,curx,cury+8,&c,1);\r
+ XDrawString(theDisp,window,theGC,curx,cury+8,&c,1);\r
+ }\r
+ break;\r
+\r
+ case STATUS :\r
+ put_shrt(mouse_x)\r
+ put_shrt(mouse_y)\r
+ put_shrt(mouse_l)\r
+ put_shrt(mouse_r)\r
+ put_shrt(mouse_c)\r
+ snd_father\r
+ break;\r
+\r
+ case GETPRESS :\r
+ case GETRELEASE :\r
+ {\r
+ int button;\r
+ get_shrt(button);\r
+ if( cmd == GETPRESS )\r
+ switch( button ){\r
+\r
+ case 0:\r
+ put_shrt( mouse_l_p_x );\r
+ put_shrt( mouse_l_p_y );\r
+ put_shrt( mouse_l_prs );\r
+ mouse_l_prs=0;\r
+ break;\r
+\r
+ case 1:\r
+ put_shrt( mouse_r_p_x );\r
+ put_shrt( mouse_r_p_y );\r
+ put_shrt( mouse_r_prs );\r
+ mouse_r_prs=0;\r
+ break;\r
+\r
+ case 2:\r
+ put_shrt( mouse_c_p_x );\r
+ put_shrt( mouse_c_p_y );\r
+ put_shrt( mouse_c_prs );\r
+ mouse_c_prs=0;\r
+ break;\r
+\r
+ default:put_shrt( 0 );\r
+ put_shrt( 0 );\r
+ put_shrt( 0 );\r
+ break;\r
+\r
+ }\r
+ else\r
+ switch( button ){\r
+\r
+ case 0:\r
+ put_shrt( mouse_l_r_x );\r
+ put_shrt( mouse_l_r_y );\r
+ put_shrt( mouse_l_rel );\r
+ mouse_l_rel=0;\r
+ break;\r
+\r
+ case 1:\r
+ put_shrt( mouse_r_r_x );\r
+ put_shrt( mouse_r_r_y );\r
+ put_shrt( mouse_r_rel );\r
+ mouse_r_rel=0;\r
+ break;\r
+\r
+ case 2:\r
+ put_shrt( mouse_c_r_x );\r
+ put_shrt( mouse_c_r_y );\r
+ put_shrt( mouse_c_rel );\r
+ mouse_c_rel=0;\r
+ break;\r
+\r
+ default:put_shrt( 0 );\r
+ put_shrt( 0 );\r
+ put_shrt( 0 );\r
+ break;\r
+\r
+ }\r
+ put_shrt(mouse_l)\r
+ put_shrt(mouse_r)\r
+ put_shrt(mouse_c)\r
+ snd_father\r
+ }\r
+ break;\r
+\r
+ case GETMOVEMENT :\r
+ {\r
+ static int x=0,y=0;\r
+ put_shrt(mouse_x-x)\r
+ put_shrt(mouse_y-y)\r
+ snd_father\r
+ x = mouse_x;\r
+ y = mouse_y;\r
+ }\r
+ break;\r
+\r
+ case TRACK:\r
+ {\r
+ int x,y;\r
+ get_shrt( x ) /* these parameters are not used */\r
+ get_shrt( y )\r
+ tracking = 1;\r
+ /* now we wait to point and press left button */\r
+ }\r
+ break;\r
+\r
+ case END_OF_TRACK:\r
+ put_shrt( mouse_x )\r
+ put_shrt( mouse_y )\r
+ snd_father\r
+ break;\r
+\r
+ default :\r
+ fprintf(stderr,"UKNOWN COMMAND for HERCULES emulation - %d\n",cmd);\r
+ fflush(stderr);\r
+ XFreePixmap(theDisp,pixmap);\r
+ XDestroyWindow(theDisp,window);\r
+ XCloseDisplay(theDisp);\r
+ exit(7);\r
+\r
+ }\r
+\r
+}\r
+\r
--- /dev/null
+#include "graf\graf.h"\r
+#include <dos.h>\r
+\r
+static union REGS r;\r
+\r
+int pascal inkey( dummy )\r
+ void *dummy;\r
+{\r
+ r.h.ah = 0x01;\r
+ int86( 0x16, &r, &r);\r
+ if( r.x.ax == 0 ) return 0;\r
+ else\r
+ {\r
+ r.h.ah = 0x00;\r
+ int86( 0x16, &r, &r);\r
+ if( r.h.al != '\0' )\r
+ return (int)(unsigned char)( r.h.al );\r
+ else\r
+ if( r.h.ah & '\x80' )\r
+ return (int)( -r.h.ah );\r
+ else\r
+ return (int)(unsigned char)( r.h.ah );\r
+ }\r
+}\r
+\r
--- /dev/null
+#define INCL_BASE\r
+#include <os2.h>\r
+\r
+int pascal inkey(dummy)\r
+int *dummy;\r
+{\r
+ KBDKEYINFO kdata;\r
+ int i;\r
+ unsigned u;\r
+ \r
+ KbdPeek(&kdata, 0);\r
+ if (kdata.fbStatus)\r
+ {\r
+ KbdCharIn(&kdata, 0, 0);\r
+ if (kdata.chChar != '\0')\r
+ {\r
+ u = kdata.chChar; \r
+ return(u);\r
+ }\r
+ else\r
+ {\r
+ i = kdata.chScan;\r
+ if (i < 0x80) return(-i); else return(i);\r
+ }\r
+ }\r
+ else\r
+ return(0);\r
+}\r
--- /dev/null
+#include <stdio.h>\r
+#include <signal.h>\r
+#include <assert.h>\r
+#include <string.h>\r
+#include <ctype.h>\r
+\r
+#include <termio.h>\r
+\r
+\r
+#include "graf/graf.h"\r
+\r
+#define KB_BACKSPACE (int)'\b' /* kb */\r
+#define KB_ENTER (int)'\r' /* RT */\r
+#define KB_TAB (int)'\t' /* TB */\r
+#define KB_ESC 0x1b /* EC */\r
+\r
+#define KB_HOME -71 /* kh or HM */\r
+#define KB_END -79 /* EN */\r
+#define KB_UP -72 /* ku or UP */\r
+#define KB_DOWN -80 /* kd */\r
+#define KB_LEFT -75 /* kl */\r
+#define KB_RIGHT -77 /* kr */\r
+#define KB_PGUP -73 /* PU */\r
+#define KB_PGDN -81 /* PD */\r
+#define KB_BACK_TAB -15 /* BT */\r
+#define KB_INS -82 /* al */\r
+#define KB_DEL -83 /* DL */\r
+\r
+#define KB_F1 -59 /* k1 */\r
+#define KB_F2 -60 /* k2 */\r
+#define KB_F3 -61 /* k3 */\r
+#define KB_F4 -62 /* k4 */\r
+#define KB_F5 -63 /* k5 */\r
+#define KB_F6 -64 /* k6 */\r
+#define KB_F7 -65 /* k7 */\r
+#define KB_F8 -66 /* k8 */\r
+#define KB_F9 -67 /* k9 */\r
+#define KB_F10 -68 /* k0 */\r
+\r
+#define KB_STR_EXISTS 1 /* string exists in tree or his prefix */\r
+#define KB_TOO_MANY_STRINGS 2 \r
+#define KB_NULL_STRING 3\r
+#define KB_OUT_OF_MEMORY 4\r
+#define KB_OK 0\r
+\r
+\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+\r
+#define TERMINAL 0\r
+#define KEYBOARD 1\r
+\r
+static char *capability,*capability_value;\r
+\r
+typedef struct _tree_node *tree; /* drzewo zawierajace ciagi znakow */\r
+struct _tree_node { /* odpowiadajace klawiszowi klawiatury */\r
+ int key;\r
+ tree way;\r
+ int outkey;\r
+}; \r
+\r
+#ifndef NO_PROTOTYPES\r
+static int tfirst(int);\r
+static int tnext(void);\r
+static void *___allocate_object(unsigned);\r
+static void ___free_object(void *);\r
+static char *object_str(char *); /* allocate space and copy string */\r
+static int __testkey(int*,int*);\r
+static int getkey(void);\r
+static int __inkey(void);\r
+static void kbinit(void);\r
+static tree new_tree_node(void);\r
+static int _create_new_leaf(tree,int,unsigned char *,int);\r
+static int inskey(int,char *);\r
+#else\r
+static int tfirst();\r
+static int tnext();\r
+static void *___allocate_object();\r
+static void ___free_object();\r
+static char *object_str();\r
+static int __testkey();\r
+static int getkey();\r
+static int __inkey();\r
+static void kbinit();\r
+static tree new_tree_node();\r
+static int _create_new_leaf();\r
+static int inskey();\r
+#endif\r
+\r
+\r
+\r
+\r
+\r
+#define object_kill(i) (___free_object(i),(i)=NULL)\r
+#define object_new(type) ((type *)___allocate_object(sizeof(type)))\r
+#define object_dim(i,type) ((type *)___allocate_object((i)*sizeof(type)))\r
+\r
+\r
+\r
+\r
+#define KB_NDEF 0xff /* KN - key suppressed by inkey() */\r
+\r
+#define NODE_SIZE 100\r
+\r
+\r
+#define QSIZE 256\r
+static int cqueue[QSIZE]; /* implementacja kolejki */\r
+static int qh=0,qt=0,qs=0;\r
+static int bget(){\r
+ int c;\r
+ if( qs == 0 ) return -1;\r
+ c = cqueue[ qh++ ];\r
+ qh &= QSIZE - 1 ;\r
+ qs--;\r
+ return c;\r
+}\r
+static void bput( c ) int c; {\r
+ if( qs == QSIZE ) return;\r
+ cqueue[ qt++ ] = c;\r
+ qt &= QSIZE - 1 ;\r
+ qs++;\r
+}\r
+static int qq;\r
+static int bfirst(){\r
+ if( qs == 0 ) return -1;\r
+ qq = qh + 1 ;\r
+ qq &= QSIZE - 1 ;\r
+ return cqueue[ qh ];\r
+}\r
+static int bnext(){\r
+ int c;\r
+ if( qq == qt ) return -1;\r
+ c = cqueue[ qq++ ];\r
+ qq &= QSIZE - 1 ;\r
+ return c;\r
+}\r
+\r
+\r
+static tree troot=NULL;\r
+\r
+#ifndef NDEBUG\r
+static FILE *f=NULL;\r
+static void _show_tree(root,r) tree root;int r;{\r
+ int i,j;\r
+ for(i=0;(i<NODE_SIZE) && (root[i].key!=-1);i++){\r
+ for(j=0;j<r;j++) fprintf(f,"i");\r
+ fflush(f);\r
+ fprintf(f,"%d ",root[i].key);fflush(f);\r
+ if(root[i].way==NULL){\r
+ fprintf(f,"%d\n",root[i].outkey);fflush(f);\r
+ }else _show_tree(root[i].way,r+1);\r
+ }\r
+}\r
+static void show_tree(){\r
+ f=fopen("show_tree","a");\r
+ if(f==NULL){printf("cant open");exit(7);}\r
+ fprintf(f,"%lx\n",troot);fflush(f);\r
+ _show_tree(troot,0);\r
+ fprintf(f,"********************\n");\r
+ fclose(f);\r
+}\r
+#endif\r
+\r
+\r
+#define NO_CHARS 0\r
+#define PART_SUBSTRING 1\r
+#define SUBSTRING 2\r
+#define STRING 3\r
+#define NO_MATCH 4\r
+\r
+static int __testkey(outkey,to_take) int *outkey,*to_take;\r
+{\r
+ int c,i;\r
+ tree tact;\r
+\r
+ tact=troot;\r
+ c=bfirst();\r
+\r
+ if(c==-1) return NO_CHARS; /* buffer empty - wait for char */\r
+\r
+ *to_take=1;\r
+\r
+ for(;;){\r
+ for(i=0;i<NODE_SIZE;i++){\r
+ if(tact[i].key==-1){ i=NODE_SIZE; break; }\r
+ if(tact[i].key==c)\r
+ if(tact[i].way!=NULL){\r
+ c=bnext();\r
+ (*to_take)++;\r
+ if(c==-1){\r
+ *outkey=tact[i].outkey;\r
+ if(*outkey != -1) return SUBSTRING;\r
+ else return PART_SUBSTRING;\r
+ }\r
+ tact=tact[i].way;\r
+ break;\r
+ }\r
+ else{\r
+ *outkey = tact[i].outkey;\r
+ return STRING;\r
+ }\r
+ }\r
+ if( i==NODE_SIZE ) return NO_MATCH;\r
+ } \r
+}\r
+\r
+\r
+static void (*prev_fun)()=NULL;\r
+static void alarm_fun(){}\r
+\r
+\r
+static int getkey(){\r
+ int c;\r
+ prev_fun = signal( SIGALRM, alarm_fun );\r
+ alarm(1);\r
+ c = getchar();\r
+ alarm(0);\r
+ signal( SIGALRM, prev_fun );\r
+ return c;\r
+}\r
+\r
+\r
+\r
+static int __inkey()\r
+{\r
+ int c,i,outkey,chars;\r
+ if(troot==NULL){printf("Not initialized\n\r");exit(7);}\r
+\r
+ alarm(0);\r
+\r
+ for(;;){\r
+\r
+ i=__testkey(&outkey,&chars);\r
+\r
+ switch( i ){\r
+\r
+ case NO_CHARS :\r
+ c = getkey();\r
+ if( c != -1 ) bput( c );\r
+ else return 0;\r
+ break;\r
+\r
+ case PART_SUBSTRING :\r
+ c = getkey();\r
+ if( c==-1 ) return bget();\r
+ bput( c );\r
+ break;\r
+\r
+ case SUBSTRING :\r
+ c = getkey();\r
+ if( c==-1 ){\r
+ while( chars-- ) bget();\r
+ return outkey;\r
+ }\r
+ bput( c );\r
+ break;\r
+\r
+ case STRING :\r
+ while( chars-- ) bget();\r
+ return outkey;\r
+ break;\r
+\r
+ case NO_MATCH :\r
+ return bget();\r
+ break;\r
+ }\r
+ }\r
+}\r
+\r
+\r
+static struct termio term_state,term_new;\r
+\r
+int inkey( dummy )\r
+ void *dummy;\r
+{ /* podaj znak z klawiatury - zapominanie KB_NDEF */\r
+ static int first_time=1;\r
+ int k;\r
+\r
+ if( first_time ){ kbinit(); first_time=0; }\r
+\r
+ ioctl(fileno(stdin),TCGETA,&term_state); /* RAW MODE */\r
+ term_new = term_state;\r
+ term_new.c_lflag&=~(ISIG|ICANON|ECHO); /* echo,canonical line processing */\r
+ /* signal processing = OFF */\r
+ term_new.c_iflag&=~(ICRNL|INLCR); /* conversions OFF */\r
+ term_new.c_oflag=0;\r
+ term_new.c_cc[VEOF]='\1'; /* every char flushed immedietly */\r
+ ioctl(fileno(stdin),TCSETA,&term_new);\r
+\r
+ do k=__inkey(); while(k==KB_NDEF);\r
+\r
+ ioctl(fileno(stdin),TCSETA,&term_state); /* PREVIOUS MODE */\r
+\r
+ return k;\r
+}\r
+\r
+\r
+static tree new_tree_node(){\r
+ tree p;\r
+ int i;\r
+ p=(tree)object_dim(NODE_SIZE+1,struct _tree_node);\r
+ p++;\r
+ for(i=0;i<NODE_SIZE;i++){\r
+ p[i].key=p[i].outkey=-1;\r
+ p[i].way=NULL;\r
+ }\r
+ return p;\r
+}\r
+\r
+\r
+static int inskey(ch,str)\r
+ int ch;\r
+ char *str;\r
+{\r
+ tree tact=troot;\r
+ int i;\r
+\r
+ if(troot==NULL) return KB_OUT_OF_MEMORY;\r
+ if(str==NULL || (!(*str))) return KB_NULL_STRING;\r
+\r
+ for(;;){\r
+ for(i=0;i<NODE_SIZE;i++){\r
+ if(tact[i].key==-1){\r
+ tact[i].key=(int)(*(str++));\r
+ return _create_new_leaf(tact,i,str,ch);\r
+ }\r
+ if(tact[i].key==(int)(*str)){\r
+ str++;\r
+ if(tact[i].way==NULL)\r
+ if( *str!='\0' ) return _create_new_leaf(tact,i,str,ch);\r
+ else return KB_STR_EXISTS;\r
+ if( *str=='\0' ){\r
+ tact[i].outkey=ch;\r
+ return KB_OK;\r
+ }\r
+ tact=tact[i].way;\r
+ break;\r
+ }\r
+ }\r
+ if(i==NODE_SIZE) return KB_TOO_MANY_STRINGS;\r
+ }\r
+}\r
+\r
+\r
+static int _create_new_leaf(tact,i,str,ch)\r
+ tree tact;\r
+ int i,ch;\r
+ unsigned char *str;\r
+{\r
+ while(*str!='\0'){\r
+ tact[i].way=new_tree_node();\r
+ tact[i].way[-1].way=tact;\r
+ tact=tact[i].way;\r
+ i=0;\r
+ tact[0].key=(int)(*(str++));\r
+ } \r
+ tact[i].outkey=ch;\r
+ return KB_OK;\r
+}\r
+\r
+\r
+static struct { int key; char capability[3]; } tab[]={\r
+\r
+ { KB_NDEF , "KN" },\r
+ { KB_BACKSPACE , "kb" },\r
+ { KB_ENTER , "RT" },\r
+ { KB_HOME , "kh" },\r
+ { KB_HOME , "HM" },\r
+ { KB_END , "EN" },\r
+ { KB_UP , "ku" },\r
+ { KB_UP , "UP" },\r
+ { KB_DOWN , "kd" },\r
+ { KB_LEFT , "kl" },\r
+ { KB_RIGHT , "kr" },\r
+ { KB_PGUP , "PU" },\r
+ { KB_PGDN , "PD" },\r
+ { KB_BACK_TAB , "BT" },\r
+ { KB_TAB , "TB" },\r
+ { KB_ESC , "EC" },\r
+ { KB_INS , "al" },\r
+ { KB_DEL , "DL" },\r
+ { KB_F1 , "k1" },\r
+ { KB_F2 , "k2" },\r
+ { KB_F3 , "k3" },\r
+ { KB_F4 , "k4" },\r
+ { KB_F5 , "k5" },\r
+ { KB_F6 , "k6" },\r
+ { KB_F7 , "k7" },\r
+ { KB_F8 , "k8" },\r
+ { KB_F9 , "k9" },\r
+ { KB_F10 , "k0" }\r
+ };\r
+\r
+\r
+static void kb_install(){\r
+ int i;\r
+ for(i=0;i<sizeof(tab)/sizeof(*tab);i++){\r
+ if(tab[i].capability[0]!=capability[0]) continue;\r
+ if(tab[i].capability[1]!=capability[1]) continue;\r
+ if(capability_value==NULL) return;\r
+ if(capability[2]!='='){\r
+ if( capability_value!=NULL) object_kill(capability_value);\r
+ return;\r
+ }\r
+ {\r
+ int err = inskey(tab[i].key,capability_value);\r
+ if(err==KB_OK) return;\r
+ if(err==KB_STR_EXISTS || err==KB_NULL_STRING){\r
+ object_kill(capability_value);\r
+ return;\r
+ }\r
+ printf("Capability %2.2s cannot be inserted:",capability);\r
+ if(err==KB_TOO_MANY_STRINGS) printf("too many strings\n\r");\r
+ if(err==KB_OUT_OF_MEMORY ) printf("out of memory\n\r");\r
+ exit(7);\r
+ }\r
+ return;\r
+ }\r
+ if(capability_value!=NULL) object_kill(capability_value);\r
+}\r
+\r
+\r
+static void kbinit() /* inicjalizacja klawiatury */\r
+{ /* RAW MODE */\r
+ char *s,*s1;\r
+ int i,err;\r
+\r
+ troot=new_tree_node();\r
+ troot[-1].way=NULL;\r
+\r
+ capability="DL=";\r
+ capability_value=object_str("\177");\r
+ kb_install();\r
+\r
+ if(tfirst(KEYBOARD)==0){\r
+ kb_install();\r
+ while(tnext()==0){\r
+ kb_install();\r
+ }\r
+ }\r
+\r
+ if(tfirst(TERMINAL)==0){\r
+ kb_install();\r
+ while(tnext()==0){\r
+ kb_install();\r
+ }\r
+ }\r
+\r
+}\r
+\r
+\r
+\r
+\r
+/* FUNCTIONS for search through one TERMCAP entry */\r
+\r
+\r
+static char *termcap=NULL;\r
+static char *keybcap=NULL;\r
+\r
+#ifndef NO_PROTOTYPES\r
+static char *envset(char *,char*);\r
+static char *findchar(char *,char);\r
+static int convert(char *,char *,int);\r
+static int next_char(FILE *);\r
+static int find_name(FILE *,char *);\r
+#else\r
+static char *envset();\r
+static char *findchar();\r
+static int convert();\r
+static int next_char();\r
+static int find_name();\r
+#endif\r
+\r
+\r
+static char *findchar(str,ch) char *str,ch;{\r
+ if(str==NULL) return NULL;\r
+ while( *str!='\0' && *str!=ch ) str++;\r
+ if(*str=='\0') return NULL;\r
+ return str;\r
+}\r
+\r
+static char *tgetent(dev)\r
+ /* gets info from variable TERMCAP */ \r
+ /* or var INKEY or file /etc/inkey */\r
+int dev;{\r
+\r
+ if(dev==TERMINAL){\r
+ if(termcap==NULL) termcap=envset("TERMCAP","termcap");\r
+ if(termcap==NULL){\r
+ fprintf(stderr,"\n\rfile [/etc/]termcap not found\n\r");\r
+ fflush(stderr);exit(7);\r
+ }\r
+ return termcap;\r
+ }else\r
+ if(dev==KEYBOARD){\r
+ if(keybcap==NULL) keybcap=envset("INKEY","inkey");\r
+ return keybcap;\r
+ }else{ printf("bad device for tgetent \n\r"); exit(7); }\r
+}\r
+\r
+\r
+\r
+\r
+static char stat_value[100];\r
+\r
+static int tfirst(dev)\r
+ int dev;\r
+{\r
+ char *value;\r
+ capability=tgetent(dev);\r
+ if(capability==NULL) return 1;\r
+ return tnext();\r
+}\r
+static int tnext(){\r
+ char *value,*colon;\r
+ do{\r
+ capability=findchar(capability,':');\r
+ if(capability==NULL) return 1;\r
+ capability++;\r
+ if(*capability=='\0') return 1;\r
+ } while( capability[0]==' ' || capability[0]=='\t' );\r
+ value=findchar(capability,'=');\r
+ colon=findchar(capability,':');\r
+ if( value==NULL || ( colon!=NULL && value!=NULL && colon<value ) ){\r
+ capability_value=object_str("");\r
+ return 0;\r
+ }\r
+ value++;\r
+ if(*value=='\0') return 1;\r
+ convert(stat_value,value,sizeof(stat_value));\r
+ capability_value=object_str(stat_value);\r
+ return 0;\r
+}\r
+\r
+\r
+static int convert(ptr,tptr,ptr_size) char *ptr,*tptr; int ptr_size; {\r
+ int i;\r
+ char c;\r
+ while( (tptr!=NULL) && (*tptr!=':') && (*tptr!='\0') )\r
+ switch(*tptr){\r
+ case '\\':tptr++;\r
+ switch(*tptr){\r
+ case 'E' :tptr++;ptr_size--;*(ptr++)='\x1b';break;\r
+ case 'n' :tptr++;ptr_size--;*(ptr++)='\n';break;\r
+ case 'r' :tptr++;ptr_size--;*(ptr++)='\r';break;\r
+ case 't' :tptr++;ptr_size--;*(ptr++)='\t';break;\r
+ case 'b' :tptr++;ptr_size--;*(ptr++)='\b';break;\r
+ case 'f' :tptr++;ptr_size--;*(ptr++)='\f';break;\r
+ case '\\':tptr++;ptr_size--;*(ptr++)='\\';break;\r
+ case '^' :tptr++;ptr_size--;*(ptr++)='^';break;\r
+ default :*ptr='\0';\r
+ for(i=0;i<3;i++){\r
+ if(*tptr<'0' || *tptr>'7') return 1;\r
+ *ptr*=8;\r
+ *ptr+=*(tptr++)-'0';\r
+ }\r
+ ptr++; ptr_size--;\r
+ }\r
+ break;\r
+ case '^': tptr++;\r
+ c=*(tptr++);\r
+ *(ptr++)=(char)((toupper(c))-'A'+1); ptr_size--;\r
+ break;\r
+ default: *(ptr++)=*(tptr++); ptr_size--; \r
+ } \r
+ *ptr='\0';\r
+ if( ptr_size<=0 ){\r
+ fprintf(stderr,"buffer exceeded in convert(%s)",__FILE__);\r
+ fflush(stderr);\r
+ exit(7);\r
+ }\r
+ return 0;\r
+}\r
+\r
+\r
+/* FUNCTIONS looking for entries in /ETC/TERMCAP */\r
+\r
+\r
+\r
+static char etcname[80];\r
+static char termname[80];\r
+static char *fname;\r
+\r
+\r
+static char *envset(envname,envfile) char *envname,*envfile;{\r
+ extern char *getenv();\r
+ char *TERM=getenv("TERM");\r
+ char *env=getenv(envname);\r
+ char *str,*ptr;\r
+ FILE *f;\r
+ int c,continued=1;\r
+\r
+ ptr=str=object_dim(32000,char);\r
+ if(str==NULL){\r
+ fprintf(stderr,"Out of memory.\n");\r
+ fflush(stderr);\r
+ exit(7);\r
+ }\r
+\r
+ if(TERM==NULL){\r
+ fprintf(stderr,"\n\renvironment variable TERM not found\n\r");\r
+ fflush(stderr);\r
+ exit(7);\r
+ }\r
+\r
+ strcpy(termname,TERM);\r
+\r
+ f=fopen(env,"r");\r
+ if( f==NULL ) f=fopen(envfile,"r"); else fname=env;\r
+ if( f==NULL ) f=fopen(strcat(strcpy(etcname,"/etc/"),envfile),"r");\r
+ else fname=envfile;\r
+ if( f==NULL ) return NULL;\r
+ else fname=etcname;\r
+\r
+ while( continued ){\r
+\r
+ char *rev,*tnm;\r
+\r
+ if( find_name(f,termname)==0 ) return object_str(":");\r
+\r
+ *(ptr++)=':';\r
+ c=' ';\r
+ do{\r
+ c=next_char(f);\r
+ if( c!='\0' ) *(ptr++)=(char)c;\r
+ }while( c!='\0' );\r
+\r
+ *(ptr)='\0';\r
+ rev=ptr-1;\r
+ while( rev>str && rev[-1]!=':' ) rev--;\r
+ if( rev[0]=='t' && rev[1]=='c' ){\r
+ ptr=rev-1;\r
+ rev+=3;\r
+ tnm=termname;\r
+ while( *rev!=':' ) *(tnm++)=*(rev++);\r
+ *tnm='\0';\r
+ continued=1;\r
+ }else continued=0;\r
+\r
+ }\r
+\r
+ ptr=object_str(str);\r
+ object_kill(str);\r
+ return ptr;\r
+\r
+}\r
+\r
+static int find_name(f,termname) FILE *f; char *termname;{\r
+ int i,c,lastc,found=0;\r
+ fseek(f,0L,0);\r
+\r
+ do{\r
+\r
+ do{\r
+ c=fgetc(f);\r
+ if(c==EOF) return 0;\r
+ if(c=='#' || c=='\t' || c==':' || c=='\n')\r
+ while(c!='\n'){\r
+ lastc=c;\r
+ c=fgetc(f);\r
+ if(c==EOF) return 0;\r
+ if( lastc=='\\' ) c=' ';\r
+ }\r
+ }while(c=='\n');\r
+\r
+ while( !found ){\r
+ for(i=0;termname[i]!='\0';i++){\r
+ if((char)c!=termname[i]) break;\r
+ c=fgetc(f);\r
+ }\r
+ if( termname[i]=='\0' ){ found=1; break; }\r
+ while( isalpha((char)c) ) c=fgetc(f);\r
+ if( c=='|' ) c=fgetc(f);\r
+ else{ ungetc('#',f); break; }\r
+ }\r
+\r
+ } while( !found );\r
+\r
+ while(c!=':'){\r
+ c=fgetc(f);\r
+ if(c==EOF) return 0;\r
+ }\r
+\r
+ return 1;\r
+}\r
+\r
+\r
+static int next_char(f) FILE *f;{\r
+ int c;\r
+ static int lastc='\0';\r
+ if( lastc!='\0' ){\r
+ c=lastc;\r
+ lastc='\0';\r
+ return c;\r
+ }\r
+ c=fgetc(f);\r
+ if( c==EOF || c=='\n' ) return '\0';\r
+ if( c=='\\' ){\r
+ c=fgetc(f);\r
+ if( c=='\n' ){\r
+ while( c=='\n' || c=='\t' || c==':' || c==' ' ) c=fgetc(f);\r
+ return c;\r
+ }\r
+ lastc=c;\r
+ return '\\';\r
+ }\r
+ return c;\r
+}\r
+\r
+\r
+\r
+\r
+static void *___allocate_object(size) unsigned size;{\r
+ char *p;\r
+ extern void *calloc();\r
+ if(size==0) return NULL;\r
+ p=calloc(size,1);\r
+ if( p==NULL ){\r
+ printf("\r\n");\r
+ printf("=======================================\r\n");\r
+ printf("Memory overflow ... \r\n");\r
+ printf("=======================================\r\n");\r
+ fflush(stdout);\r
+ system("stty sane");\r
+ exit(7);\r
+ }\r
+ return (void *)p;\r
+}\r
+\r
+static void ___free_object(ff) void *ff;{\r
+ assert(ff!=NULL);\r
+ free((char *)ff);\r
+}\r
+\r
+static char *object_str(str) char *str;{\r
+ char *buf=object_dim(strlen(str)+1,char);\r
+ strcpy(buf,str);\r
+ return buf;\r
+}\r
--- /dev/null
+#define MAXMARKER MAXINTEGER /* maximum special value of mark */\r
+#define MAXAPPT MAXINTEGER /* maximum appetite (easily extensible ?) */\r
+#define MAXTRACNT 13 /* maximum number of trace messages in line */\r
+#define MAXHDLEN 40 /* maximum length of formal procedure header */\r
+#define MAXSYSSN 62 /* maximum number of a system signal */\r
+#define MAXPARAM 10 /* maximum number of params to standard proc */\r
+#define IOBLOCK 0x4000 /* size of I/O transfer block in bytes */\r
+\r
+/* Object structure : */\r
+\r
+/* Offsets from the beginning : */\r
+#define PROTNUM 1 /* prototype number */\r
+#define SHORTLINK 1 /* link to same size list (killed only) */\r
+#define LONGLINK 2 /* link to other size list (killed only) */\r
+\r
+/* Files : */\r
+/* appetite 0 */\r
+/* prot number 1 always FILEOBJECT */\r
+#define FSTAT 2 /* file status */\r
+#define FTEMP 3 /* flag to tell if file is temporary */\r
+#define FTYPE 4 /* file type */\r
+#define FNAME 5 /* file name pointer */\r
+#define FFILE (FNAME+sizeof(char *)/sizeof(word)) /*file handle */\r
+#define APFILE (FFILE+sizeof(FILE *)/sizeof(word)) /*appetite of file*/\r
+ /* object */\r
+\r
+/* Offsets from the first address after object : */\r
+#define SL -2 /* static link */\r
+#define DL -4 /* dynamic link */\r
+#define LSC -5 /* local control */\r
+#define STATSL -6 /* number of times the object occurs in SL */\r
+#define SIGNR -7 /* signal number (handlers only) */\r
+#define RPCDL -8 /* remote dynamic link (procedures only) */\r
+#define CL -8 /* coroutine link (coroutine only) */\r
+#define CHD -10 /* coroutine head (process only) */\r
+#define VIRTSC -12 /* virtual scratch (process only) */\r
+\r
+/* Virtual address (also formal type) : */\r
+\r
+typedef struct {\r
+ word addr; /* address of dictionary item */\r
+ /* (node and process index for processes) */\r
+ /* (or for formal types - number of arrayof) */\r
+ word mark; /* address mark */\r
+ /* (negative for processes) */\r
+ /* (or for formal types - actual type) */\r
+ } virtaddr;\r
+\r
+#define loadvirt(v, a) { word ta; \\r
+ ta = (a); \\r
+ (v).addr = M[ ta++ ]; \\r
+ (v).mark = M[ ta ]; }\r
+#define storevirt(v, a) { word ta; \\r
+ ta = (a); \\r
+ M[ ta++ ] = (v).addr; \\r
+ M[ ta ] = (v).mark; }\r
+ \r
+#define MF(a) (*( (FILE **) (M+(a)) ))\r
+#define MN(a) (*( (char **) (M+(a)) ))\r
+#define MR(a) *( (real *) (M+(a)) )\r
+\r
+\r
+#ifdef max\r
+#undef max\r
+#endif\r
+\r
+#ifdef min\r
+#undef min\r
+#endif\r
+\r
+#define min(x, y) ((x) < (y) ? (x) : (y))\r
+#define max(x, y) ((x) > (y) ? (x) : (y))\r
+#define absolute(x) ((x) >= 0 ? (x) : -(x))\r
+\r
+/* LOGLAN's booleans : */\r
+#define LFALSE ((word)0)\r
+#define LTRUE (~LFALSE)\r
+#define lbool(b) ( (b) ? LTRUE : LFALSE )\r
+\r
+/* Type of files : */\r
+#define TEXTF 1 /* text file */\r
+#define CHARF 2 /* file of char */\r
+#define INTF 3 /* file of integer */\r
+#define REALF 4 /* file of real */\r
+#define DIRECT 5 /* direct access file */\r
+\r
+/* File status : */\r
+#define READING 0 /* sequential file opened for read */\r
+#define WRITING 1 /* sequential file opened for write */\r
+#define UPDATING 2 /* direct access file */\r
+#define UNKNOWN 3 /* file not opened */\r
+\r
+/* Run time error types : */\r
+\r
+#define RTESLCOF 0 /* SL chain cut off */\r
+#define RTEUNSTP 1 /* unimplemented standard procedure */\r
+#define RTEILLAT 2 /* illegal attach */\r
+#define RTEILLDT 3 /* illegal detach */\r
+#define RTECORTM 4 /* coroutine terminated */\r
+#define RTECORAC 5 /* coroutine active */\r
+#define RTEINVIN 6 /* array index error */\r
+#define RTEILLAB 7 /* incorrect array bounds */\r
+#define RTEINCQA 8 /* improper QUA */\r
+#define RTEINCAS 9 /* illegal assignment */\r
+#define RTEFTPMS 10 /* formal type missing */\r
+#define RTEILLKL 11 /* illegal kill */\r
+#define RTEILLCP 12 /* illegal copy */\r
+#define RTEINCHS 13 /* incompatible headers */\r
+#define RTEHNDNF 14 /* handler not found */\r
+#define RTEMEMOV 15 /* memory overflow */\r
+#define RTEFHTLG 16 /* formal header too long */\r
+#define RTEILLRT 17 /* illegal return */\r
+#define RTEREFTN 18 /* reference to NONE */\r
+#define RTEDIVBZ 19 /* division by zero */\r
+#define RTESYSER 20 /* system error */\r
+#define RTEILLIO 21 /* illegal I/O operation */\r
+#define RTEIOERR 22 /* I/O error */\r
+#define RTECNTOP 23 /* Cannot open file */\r
+#define RTEBADFM 24 /* Input data format bad */\r
+#define RTEILLRS 25 /* illegal resume */\r
+#define RTETMPRC 26 /* too many processes on one machine */\r
+#define RTEINVND 27 /* invalid node number */\r
+#define RTENEGST 28 /* negative step value */\r
+#define RTENONGL 29 /* only process may be global */\r
+\r
+union value {\r
+ unsigned int xint;\r
+ word xword;\r
+ real xreal;\r
+ virtaddr xvirt;\r
+ word xbool;\r
+ };\r
+\r
+/* Variables : */\r
+\r
+extern memory M; /* main memory for code and data */\r
+extern union value *param; /* pointer to standard proc. param list */\r
+extern int offset[]; /* offset conversion table for compact. */\r
+extern int scot[]; /* signal to number conversion table */\r
+extern int primapet[]; /* appetites of primitive types */\r
+extern word ic; /* instruction counter */\r
+extern word lastic; /* previous ic for redecoding after comp. */\r
+extern int opcode; /* opcode of L-code instruction */\r
+extern word a1, a2, a3; /* arguments of L-code instruction */\r
+\r
+/* kernel variables for the running system */\r
+\r
+extern word memorysize; /* size of memory array for code and data */\r
+extern word dispoff; /* DISPLAY offset in process object */\r
+extern word disp2off; /* indirect DISPLAY offset in process object */\r
+extern word display; /* DISPLAY address - physical addresses */\r
+extern word display2; /* DISPLAY address - indirect addresses */\r
+extern word c1, c2; /* pointers to current object */\r
+extern word mainprog; /* main block object */\r
+extern word mnoff; /* offset of variable main */\r
+\r
+\r
+extern bool infmode; /* TRUE if compactification message printed */\r
+extern bool debug; /* TRUE if trace is printed */\r
+extern FILE *tracefile; /* output file for trace */\r
+\r
+extern jmp_buf contenv; /* for continue execution */\r
+\r
+\r
+\r
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+/* Variables common with generator : */\r
+\r
+protdescr *prototype[ MAXPROT+1 ]; /* prototypes */\r
+word ipradr; /* address of primitive types descriptions */\r
+word temporary; /* address of global temporary variables */\r
+word strings; /* base for string constants */\r
+word lastprot; /* the last used prototype number */\r
+word freem; /* first free cell in M */\r
+word currfile = 2; /* current file virtual address */\r
+\r
+/* Interpreter own variables : */\r
+\r
+memory M; /* main memory for code and data */\r
+union value *param; /* for comunication with standard procs */\r
+\r
+/* offset conversion table for compactification */\r
+int offset[] = { DUMMY, SL, DL, CL, CHD, VIRTSC };\r
+\r
+/* signal to number conversion table */\r
+/* -1 stands for an unrecoverable error which cannot be serviced by handler */\r
+\r
+int scot[] =\r
+{\r
+ 20, /* RTESLCOF */\r
+ 20, /* RTEUNSTP */\r
+ 20, /* RTEILLAT */\r
+ 20, /* RTEILLDT */\r
+ 20, /* RTECORTM */\r
+ 20, /* RTECORAC */\r
+ 23, /* RTEINVIN */\r
+ 23, /* RTEILLAB */\r
+ 21, /* RTEINCQA */\r
+ 24, /* RTEINCAS */\r
+ 20, /* RTEFTPMS */\r
+ 20, /* RTEILLKL */\r
+ 20, /* RTEILLCP */\r
+ 24, /* RTEINCHS */\r
+ -1, /* RTEHNDNF */\r
+ 22, /* RTEMEMOV */\r
+ 22, /* RTEFHTLG */\r
+ -1, /* RTEILLRT */\r
+ 21, /* RTEREFTN */\r
+ 01, /* RTEDIVBZ */\r
+ 02, /* RTESYSER */\r
+ 02, /* RTEILLIO */\r
+ 02, /* RTEIOERR */\r
+ 02, /* RTECNTOP */\r
+ 02, /* RTEBADFM */\r
+ 20, /* RTEILLRS */\r
+ 02, /* RTETMPRC */\r
+ 02, /* RTEINVND */\r
+ 23, /* RTENEGST */\r
+ -1 /* RTENONGL */\r
+};\r
+\r
+/* Primitive type appetites for moveparams() : */\r
+\r
+int primapet[] =\r
+{\r
+ APINT, /* INTEGER */\r
+ APREAL, /* REAL */\r
+ APINT, /* BOOLEAN */\r
+ APINT, /* CHAR */\r
+ APREF, /* COROUTINE */\r
+ APREF, /* PROCESS */\r
+ APINT /* STRING */\r
+};\r
+\r
+word ic; /* instruction counter */\r
+word lastic; /* previous ic for redecoding after compact. */\r
+int opcode; /* opcode of L-code instruction */\r
+word a1, a2, a3; /* arguments of L-code instructions */\r
+\r
+/* kernel variables for the running system: */\r
+\r
+word memorysize = DEFMEMSIZE; /* code and data memory size */\r
+word c1, c2; /* pointers to current object */\r
+word dispoff; /* DISPLAY offset in process object */\r
+word disp2off; /* indirect DISPLAY offset in process object */\r
+word display; /* DISPLAY address - physical addresses */\r
+word display2; /* DISPLAY address - indirect addresses */\r
+word mainprog; /* main block object */\r
+word mnoff; /* offset of variable main */\r
+\r
+\r
+bool infmode = FALSE; /* default: no compactification message */\r
+bool debug = FALSE; /* TRUE if trace is printed */\r
+FILE *tracefile; /* output file for trace */\r
+\r
+jmp_buf contenv; /* for continue execution */\r
--- /dev/null
+#ifndef NO_PROTOTYPES\r
+\r
+unsigned alarm( unsigned );\r
+double prandom( void );\r
+\r
+void openrc(word,virtaddr *,word *);\r
+void raise_signal(word,word,word *,word *);\r
+void openobj(word,word *,word *);\r
+void slopen(word,virtaddr *,word *,word *);\r
+void errsignal(int);\r
+void typep(word,word,word *,word *);\r
+void copy(virtaddr *,virtaddr *);\r
+void qua(virtaddr *,word);\r
+void standard(word);\r
+void disp(virtaddr *);\r
+void gkill(virtaddr *);\r
+void typref(virtaddr *,word);\r
+void go(word,word);\r
+void goloc(word,word);\r
+void typed(word,word,word,word,virtaddr *);\r
+void term(void);\r
+void wind(void);\r
+void trace(word);\r
+void inner(word);\r
+void backhd(virtaddr *,word *);\r
+void backbl(virtaddr *,word *);\r
+void backpr(virtaddr *,word *);\r
+void back(virtaddr *,word *,word);\r
+void detach(void);\r
+void attach(virtaddr *);\r
+void fin(word,virtaddr *,word *);\r
+void heads(virtaddr *,word);\r
+void resume(virtaddr *);\r
+void passivate(int);\r
+void enable(word,word);\r
+void evaluaterpc(word);\r
+void disable(word,word);\r
+void rpc_accept(word);\r
+void rpc3(void);\r
+void popmask(word);\r
+void askprot(virtaddr *);\r
+bool member(virtaddr *,word *);\r
+word virtprot(word);\r
+word loadt(word,word);\r
+bool is(virtaddr *,word);\r
+bool inl(virtaddr *,word);\r
+word shift(word,word);\r
+void execute(void);\r
+void abend(char *);\r
+void addext(char *,char *);\r
+void usage( void );\r
+void decode( void );\r
+void init_scheduler( void );\r
+void runsys( void );\r
+void schedule( void );\r
+void msginterrupt( message * );\r
+void loosen( void );\r
+void update( word, word );\r
+void compactify( void );\r
+void moveparams(word, word, message *, int, int);\r
+void sendmsg(message *);\r
+word getnode(word);\r
+void endprocess(int);\r
+word entier(double);\r
+char *asciiz( virtaddr * );\r
+void ranset(void);\r
+void moveblock( char *,char *, word );\r
+void request( word, word *, word *);\r
+word memavail( void );\r
+void newarry( word, word, word, virtaddr *, word *);\r
+void initprocess( word,word,procaddr *);\r
+void activate( word );\r
+void reset( word );\r
+void pushmask( word );\r
+void trapmsg( void );\r
+void rpc2( void );\r
+void endrun( int );\r
+void loadfile(word,word *,word *,FILE **);\r
+word directio(virtaddr *,word,int (*)(),FILE *);\r
+void nonstandard( word );\r
+void genfileobj(bool,word,char *,virtaddr *,word *);\r
+void rewrite( word );\r
+void delete( virtaddr * );\r
+bool testeof( FILE * );\r
+bool testeoln( FILE * );\r
+char *tempfilename( void );\r
+word readint( FILE * );\r
+double readreal( FILE * );\r
+void writeint( word, word, FILE * );\r
+void writereal( double, word, word, FILE * );\r
+void writestring( word, word, FILE * );\r
+void readln( FILE * );\r
+void senderr( int, procaddr * );\r
+void rpcend( message * );\r
+void rpc1( message * );\r
+\r
+#else\r
+\r
+unsigned alarm();\r
+int unlink();\r
+int ioctl();\r
+\r
+void openrc();\r
+void raise_signal();\r
+void openobj();\r
+void slopen();\r
+void errsignal();\r
+void typep();\r
+void copy();\r
+void qua();\r
+void standard();\r
+void disp();\r
+void gkill();\r
+void typref();\r
+void go();\r
+void goloc();\r
+void typed();\r
+void term();\r
+void wind();\r
+void trace();\r
+void inner();\r
+void backhd();\r
+void backbl();\r
+void backpr();\r
+void back();\r
+void detach();\r
+void attach();\r
+void fin();\r
+void heads();\r
+void resume();\r
+void passivate();\r
+void enable();\r
+void evaluaterpc();\r
+void disable();\r
+void rpc_accept();\r
+void rpc3();\r
+void popmask();\r
+void askprot();\r
+bool member();\r
+word virtprot();\r
+word loadt();\r
+bool is();\r
+bool inl();\r
+word shift();\r
+void execute();\r
+void abend();\r
+void addext();\r
+void usage();\r
+void decode();\r
+void init_scheduler();\r
+void runsys();\r
+void schedule();\r
+void msginterrupt();\r
+void loosen();\r
+void update();\r
+void compactify();\r
+void moveparams();\r
+void sendmsg();\r
+word getnode();\r
+void endprocess();\r
+word entier();\r
+char *asciiz();\r
+void ranset();\r
+double prandom();\r
+void moveblock();\r
+void request();\r
+word memavail();\r
+void newarry();\r
+void initprocess();\r
+void activate();\r
+void pushmask();\r
+void trapmsg();\r
+void rpc2();\r
+void endrun();\r
+void loadfile();\r
+word directio();\r
+void nonstandard();\r
+void genfileobj();\r
+void reset();\r
+void rewrite();\r
+void delete();\r
+bool testeof();\r
+bool testeoln();\r
+char *tempfilename();\r
+word readint();\r
+double readreal();\r
+void writeint();\r
+void writereal();\r
+void writestring();\r
+void readln();\r
+void senderr();\r
+void rpcend();\r
+void rpc1();\r
+\r
+#endif\r
+\r
--- /dev/null
+cint.o compact.o control.o util.o handler.o intdt.o memory.o object.o runsys.o typchk.o standard.o execute.o fileio.o nonstand.o process.o procaddr.o queue.o rpcall.o
\ No newline at end of file
--- /dev/null
+SHELL=/bin/sh
+#.SUFFIXES: .o .c
+
+#############################################################################\r
+# switches :\r
+# OBJECTADDR - switch on special process addressing - object simulates\r
+# process pointer\r
+# CDBG - turn on debugging of compactifier, compactifier appends to file\r
+# 'trace' state of memory before & after the compactification,\r
+# also a history of compactification & process number is dumped\r
+# RPCDBG - debugging of alien call, all actions : alien call, acknowledges,\r
+# passivations and returns are written to stderr\r
+# NO_GRAPH - nonstand.c defines only INKEY grom IIUWGRAPH\r
+# DLINK - DLINK network version\r
+# TCPIP - TCPIP network version - needs also OBJECTADDR\r
+#\r
+# switches depending on environment :\r
+# TURBOC - if using BORLAND TURBO-C compiler\r
+# MSDOS/OS2/UNIX - choose operating system\r
+# USE_CLOCK - scheduler should use clock() function to measure time\r
+# USE_ALARM - scheduler should use alarm() function to measure time\r
+# WORD_16BIT/DWORD_16BIT/WORD_32BIT - choose memory model :\r
+# small 16-bit / large 16-bit / small 32-bit\r
+#\r
+# for DLINK use cinta.o ( cinta.asm )\r
+# for TCPIP use tcpip.o sock.o\r
+# for no network simply leave empty\r
+# NETFILE=tcpip.o sock.o\r
+\r
+#NETFILE=tcpip.o sock.o\r
+NETFILE=
+
+#CC=gcc -m486 -DDJE -DUSE_CLOCK -DWORD_32BIT -Dpascal= \r
+# MSDOS 32bit GNU CC\r
+
+#CC=cl -AL -Olsg -DMSDOS -DDWORD_16BIT # MSDOS 16bit LARGE\r
+#CC=cl -AL -Olsg -DMSDOS -DWORD_16BIT # MSDOS 16bit SMALL\r
+
+UNIXPARS=-DUNIX -DWORD_32BIT -DUSE_ALARM -Dpascal=
+UNIXPARSNG=$(UNIXPARS)
+
+#CC=cc $(UNIXPARSNG) -DNO_PROTOTYPES # SUN,HP\r
+#CC=rcc $(UNIXPARSNG) -O # SCO - AT&T C compiler\r
+#CC=cc -W1 $(UNIXPARSNG) # SCO\r
+#CC=cc -W1 $(UNIXPARSNG) -DOBJECTADDR # SCO\r
+#CC=cc -W1 $(UNIXPARSNG) -DOBJECTADDR -DTCPIP # SCO TCPIP\r
+CC=gcc $(UNIXPARSNG) -DOBJECTADDR -DXSIGHT # GNU C+
+#CC=cc -W1 $(UNIXPARS) -DSYSV -DXSIGHT # SCO with X11 graphics\r
+#CC=gcc -g $(UNIXPARS) -DSYSV -DXSIGHT # SCO GCC with X11 graphics\r
+
+CCc=$(CC) # common version\r
+#CCc=$(CC) -Fo$*.o # MSDOS MSC version\r
+
+target : int
+
+#############################################################################\r
+
+
+
+OBJ= cint.o compact.o control.o util.o handler.o intdt.o \
+ memory.o object.o runsys.o standard.o \
+ execute.o fileio.o nonstand.o process.o procaddr.o queue.o \
+ rpcall.o typchk.o $(NETFILE)
+
+.c.o :
+ $(CCc) -c $*.c
+.s.o:
+ as -o $*.o $*.s
+
+hgcint.exe: $(OBJ) inkeydos.o graf\lib\hgcmsf4.lib
+ link /e @link.lnk inkeydos.o, hgcint.exe, nul, graf\lib\hgcmsf4, ;
+
+egaint.exe: $(OBJ) inkeydos.o graf\lib\egamsf4.lib\r
+ link /e @link.lnk inkeydos.o, egaint.exe, nul, graf\lib\egamsf4, ;\r
+\r
+cgaint.exe: $(OBJ) inkeydos.o graf\lib\mgcmsf4.lib\r
+ link /e @link.lnk inkeydos.o, cgaint.exe, nul, graf\lib\mgcmsf4, ;\r
+\r
+cga64int.exe: $(OBJ) inkeydos.o graf\lib\mgc64mf4.lib\r
+ link /e @link.lnk inkeydos.o, cga64int.exe, nul, graf\lib\mgc64mf4, ;\r
+\r
+int386.exe: $(OBJ)\r
+ $(CC) @link.lnk -lm -lpc -lgrx -o svgaint\r
+ strip svgaint\r
+ coff2exe svgaint\r
+ rm svgaint\r
+# move svgaint.exe ..\examp\svgaint.exe\r
+
+int: $(OBJ) inkeyux.o
+ $(CC) $(OBJ) inkeyux.o -lm -lX11 -lmalloc -lsocket -o int
+ strip int
+# mv int $(HOME)/bin
+
+nonstand.o : nonstand.c x11graf1.c x11graf2.c
+
+herc : herc.c
+ $(CC) herc.c -lX11 -lmalloc -lsocket -o herc
+ strip herc
+
+clean :
+ rm *.o
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+/* Memory management routines */\r
+\r
+#ifndef NO_PROTOTYPES\r
+static void compandtake(word, word *, word *, word *, bool);\r
+static void sinsert(word);\r
+#else\r
+static void compandtake();\r
+static void sinsert();\r
+#endif\r
+\r
+\r
+int compactify_allowed=1;\r
+#define space 400 /* words */\r
+\r
+\r
+void request(app, ah, am)\r
+word app, *ah, *am;\r
+{\r
+ word t2, t4, t5;\r
+ bool wascompactified, found;\r
+\r
+ if (app >= MAXAPPT) errsignal(RTEMEMOV);\r
+ wascompactified = FALSE;\r
+\r
+ if( compactify_allowed && thisp->force_compactification ){\r
+ compactify();\r
+ thisp->force_compactification=FALSE;\r
+ wascompactified=TRUE;\r
+ }\r
+\r
+ if (thisp->freeitem != 0) /* reserve dictionary item */\r
+ {\r
+ *ah = thisp->freeitem;\r
+ thisp->freeitem = M[ *ah ];\r
+ }\r
+ else\r
+ {\r
+ *ah = thisp->lastitem-2;\r
+ if (*ah <= thisp->lastused + space) /* cannot take free item */\r
+ {\r
+ if( compactify_allowed )\r
+ if( !wascompactified ) compactify(),wascompactified=TRUE;\r
+ else ;\r
+ else\r
+ thisp->force_compactification=TRUE;\r
+ *ah = thisp->lastitem-2;\r
+ if (*ah <= thisp->lastused) errsignal(RTEMEMOV);\r
+ }\r
+\r
+ thisp->lastitem = *ah;\r
+ M[ *ah+1 ] = 0; /* clear mark */\r
+ } /* now we have a free dict. item */\r
+\r
+\r
+ if (app == 2 && thisp->headk2 != 0) /* special case app=2 */\r
+ {\r
+ *am = thisp->headk2;\r
+ thisp->headk2 = M[ *am+SHORTLINK ];\r
+ }\r
+ else\r
+ {\r
+ word t1 = thisp->headk;\r
+ found = FALSE;\r
+ t4 = 0;\r
+ while (t1 != thisp->lower && !found)\r
+ {\r
+ t2 = M[ t1 ];\r
+ if (t2 == app) found = TRUE;\r
+ else\r
+ if (t2-app >= 2) found = TRUE;\r
+ else\r
+ {\r
+ t4 = t1;\r
+ t1 = M[ t1+LONGLINK ];\r
+ }\r
+ }\r
+ if( found ) {\r
+ t5 = M[ t1+SHORTLINK ];\r
+ if (t5 != 0) M[ t5+LONGLINK ] = M[ t1+LONGLINK ];\r
+ else t5 = M[ t1+LONGLINK ];\r
+ if (t4 == 0) thisp->headk = t5; else M[ t4+LONGLINK ] = t5;\r
+ *am = t1;\r
+ if (t2 > app) /* at least two extra words */\r
+ {\r
+ t5 = t1+app;\r
+ M[ t5 ] = t2-app;\r
+ sinsert(t5);\r
+ }\r
+ }\r
+ else\r
+ if ( thisp->lastitem - thisp->lastused > app + space )\r
+ {\r
+ *am = thisp->lastused+1;\r
+ thisp->lastused += app;\r
+ }\r
+ else\r
+ {\r
+ M[ *ah ] = thisp->freeitem; /* return dictionary item */\r
+ thisp->freeitem = *ah;\r
+ if( compactify_allowed )\r
+ if( !wascompactified ) compactify();\r
+ else ;\r
+ else\r
+ thisp->force_compactification=TRUE;\r
+ *ah = thisp->lastitem-2; /* reserve dictionary item */\r
+ thisp->lastitem = *ah;\r
+ M[ *ah+1 ] = 0; /* clear mark */\r
+ if ( thisp->lastitem - thisp->lastused > app ) {\r
+ *am = thisp->lastused+1;\r
+ thisp->lastused += app;\r
+ }\r
+ else\r
+ errsignal(RTEMEMOV);\r
+ }\r
+ }\r
+\r
+ M[ *am ] = app;\r
+ for (t2 = *am+1; t2 < *am+app; t2++ ) M[ t2 ] = 0;\r
+ M[ *ah ] = *am;\r
+\r
+}\r
+\r
+\r
+static void sinsert(am) /* Dispose of a memory item. */\r
+word am;\r
+{\r
+ word t1, t2, t3, t4;\r
+\r
+ t1 = M[ am ]; /* appetite */\r
+ if (t1 == 2) /* a special list should be used */\r
+ {\r
+ M[ am+SHORTLINK ] = thisp->headk2;\r
+ thisp->headk2 = am;\r
+ }\r
+ else\r
+ {\r
+ t2 = thisp->headk;\r
+ t4 = 0;\r
+ while (TRUE) /* look for a proper place */\r
+ {\r
+ t3 = M[ t2 ]; /* appetite */\r
+ if (t1 == t3) /* an entry with matching appetite */\r
+ {\r
+ M[ am+SHORTLINK ] = M[ t2+SHORTLINK ];\r
+ M[ t2+SHORTLINK ] = am;\r
+ break;\r
+ }\r
+ else\r
+ if (t1 < t3)\r
+ {\r
+ M[ am+LONGLINK ] = t2;\r
+ M[ am+SHORTLINK ] = 0;\r
+ if (t4 == 0) thisp->headk = am;\r
+ else M[ t4+LONGLINK ] = am;\r
+ break;\r
+ }\r
+ else\r
+ {\r
+ t4 = t2;\r
+ t2 = M[ t2+LONGLINK ];\r
+ }\r
+ }\r
+ }\r
+}\r
+\r
+\r
+void disp(virt) /* Simple kill. */\r
+virtaddr *virt;\r
+{\r
+ word t1, t2;\r
+\r
+ t1 = M[ virt->addr+1 ];\r
+ if (t1 == virt->mark) /* not none */\r
+ {\r
+ t1++; /* advance mark */\r
+ t2 = M[ virt->addr ]; /* am */\r
+ M[ virt->addr+1 ] = t1;\r
+ if (t1 != MAXMARKER) /* mark still usable */\r
+ {\r
+ M[ virt->addr ] = thisp->freeitem;\r
+ thisp->freeitem = virt->addr;\r
+ } /* now dictionary item is released */\r
+ if (t2+M[ t2 ]-1 == thisp->lastused) /* on the boundary */\r
+ thisp->lastused = t2-1;\r
+ else sinsert(t2);\r
+ }\r
+} /* end disp */\r
+\r
+\r
+word memavail() /* Compute available memory size */\r
+{\r
+ word t1, t2, avail;\r
+\r
+ avail = thisp->lastitem-thisp->lastused-1; /* contiguos memory */\r
+ t1 = thisp->headk2; /* go through killed 2 list */\r
+ while (t1 != 0)\r
+ {\r
+ avail += 2;\r
+ t1 = M[ t1+SHORTLINK ];\r
+ }\r
+ t1 = thisp->headk;\r
+ while (t1 != thisp->lower) /* go through killed object list */\r
+ {\r
+ t2 = t1;\r
+ while (t2 != 0)\r
+ {\r
+ avail += M[ t2 ];\r
+ t2 = M[ t2+SHORTLINK ];\r
+ }\r
+ t1 = M[ t1+LONGLINK ];\r
+ }\r
+ t1 = thisp->freeitem; /* go through free item list */\r
+ while (t1 != 0)\r
+ {\r
+ avail += 2;\r
+ t1 = M[ t1 ];\r
+ }\r
+ return(avail);\r
+} /* end memavail */\r
--- /dev/null
+#include "sock.h"
+#include "srv.h"
+#include "graph.h"
+
+msg m;
+int sock;
+
+char *host;
+char *file;
+char *dest;
+FILE *fdest;
+
+
+#ifndef NO_PROTOTYPES
+int main(int argc,char **argv);
+#endif
+
+static int bytes_received=0;
+static char title[100];
+
+
+static void usage(s) char *s;{
+ printf("usage: %s [-ms] host file [dest_file]\n",s);
+ exit(0);
+}
+
+
+int main(argc,argv) int argc; char** argv; {
+
+ int file_size,file_packets,size,x,y;
+
+ if( argc < 3 || argc > 5 ) usage(argv[0]);
+
+ if( argv[1][0]=='-' ){
+ int i;
+ set_cli_recv_timeout( atoi(argv[1]+1) );
+ printf("timeout set to %d ms\n",atoi(argv[1]+1));
+ for( i=1; i<argc-1; i++ ) argv[i]=argv[i+1];
+ argc--;
+ }
+
+ host = argv[1];
+ file = argv[2];
+
+ if( argc > 3 )
+ dest = argv[3];
+ else
+ dest = file;
+
+ do{
+
+ printf("ask for %s:%s\n",host,file);
+
+ sock = sock_open( SOCK_DGRAM, "udp", host, NULL, PORT, AS_CLIENT );
+ if( sock<0 ) exit(10);
+ m.req = htonl( RQ_FILE_SIZE );
+ strcpy( m.data, file );
+ sock_cli_crc_send( sock, &m, HEAD+strlen(m.data)+1 );
+ size = sock_cli_crc_recv( sock, &m, sizeof(m) );
+ close( sock );
+
+ if( size>0 ){
+ file_size = ntohl(*(int *)(m.data));
+ if( file_size < 0 )
+ printf("file %s:%s not found\n",host,file),exit(0);
+ }else
+ if( size<0 )
+ printf("error in packet\n");
+ else
+ printf("timed out\n");
+
+ }while( size<=0 );
+
+ fdest = fopen(dest,"wb");
+ if( fdest==NULL ){
+ printf("can't open file %s for writing\n",dest);
+ }
+
+ file_packets = (file_size+DATA_PIECE-1)/DATA_PIECE;
+
+ {
+ int i;
+ for(i=0;i*i<file_packets;i++);
+ x=i;
+ y=i;
+ if(i*i>file_packets){
+ x=i;
+ y=i;
+ while(x*y>file_packets) y--;
+ if(x*y<file_packets) y++;
+ }
+ }
+
+ sprintf(title,"%s:%s(%d b,pkt=%d b)",host,file,file_size,DATA_PIECE);
+ graph_on(x,y,title);
+ graph_board(file_packets);
+
+ {
+ extern void *calloc();
+ char *tab=calloc(1,file_packets);
+ while( !get_part( tab , file_packets ) );
+ }
+
+ fclose(fdest);
+
+ graph_off();
+
+ printf("received %d bytes for file %s size %d\n",
+ bytes_received,file,file_size
+ );
+
+ return 0;
+}
+
+
+
+int get_part( file_table , file_packets ) char *file_table; int file_packets; {
+
+ int i=0,cnt=0,pos;
+ int skip_dupls=0,after_skip=0;
+
+ for( ; i<file_packets; i++ )
+ if( file_table[i]=='\0' )
+ break;
+
+ pos = i;
+
+ if( i == file_packets ) return 1;
+
+ for( ; i<file_packets; i++ )
+ if( file_table[i]!='\0' )
+ break;
+ else
+ cnt++;
+
+ after_skip = cnt;
+
+ while( i < file_packets ){
+
+ for( ; i<file_packets; i++ )
+ if( file_table[i]=='\0' )
+ break;
+ else
+ skip_dupls++;
+
+ if( i==file_packets ) break;
+
+ for( ; i<file_packets; i++ )
+ if( file_table[i]!='\0' )
+ break;
+ else
+ after_skip++;
+
+ /* if now we add skip_dupls & after_skip we will have duplicates */
+ /* but maybe with lower cost ! */
+
+ if( skip_dupls < after_skip )
+ cnt = skip_dupls + after_skip ;
+ else
+ break;
+
+ }
+
+ printf("ask for %d packets, seek from %d file %s:%s\n",cnt,pos,host,file);
+
+ sock = sock_open(SOCK_DGRAM,"udp",host,NULL,PORT,AS_CLIENT);
+ if( sock<0 ) exit(10);
+
+ m.req = htonl( RQ_FILE );
+ ((int *)m.data)[0] = htonl( pos ); /* seek position */
+ ((int *)m.data)[1] = htonl( cnt ); /* no of packets */
+ strcpy(m.data+2*sizeof(int),file);
+ sock_cli_crc_send(sock,&m,HEAD+2*sizeof(int)+strlen(m.data+2*sizeof(int))+1);
+
+ for(;;){
+ int packno;
+ int size=sock_cli_crc_recv( sock, &m, sizeof(m) );
+ if( size==0 ) break; /* timeout */
+ if( size>0 ) bytes_received += size;
+ packno=ntohl(m.req);
+ if( packno<0 || packno>=file_packets ) continue;
+ if( file_table[packno]!='\0' ){
+ continue;
+ }
+ if( size>0 ){
+ size-=HEAD;
+ fseek(fdest,packno*DATA_PIECE,0L);
+ if( fwrite(m.data,size,1,fdest)!=1 ){
+ printf("can't write file %s\n",file);
+ exit(10);
+ }
+ graph_point(packno,GRAPH_COL_OK);
+ file_table[packno]='\1';
+ }else /* error in packet */
+ graph_point(packno,GRAPH_COL_ERROR);
+ }
+
+ close( sock );
+
+ return 0;
+}
+
--- /dev/null
+#include <stdio.h>
+
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+
+#include <math.h>
+
+#include "graph.h"
+
+
+static int child_no=0;
+static int fcol=1,bcol=0;
+
+static Display *theDisplay;
+static Window myWindow,theWindow;
+static XClientMessageEvent theMessage;
+static XEvent retEv;
+
+static void send_sig(nrproc) int nrproc; {
+ theMessage.type=ClientMessage;
+ theMessage.format = 16;
+ theMessage.message_type = nrproc;
+ XSendEvent(theDisplay,theWindow,True,NoEventMask,&theMessage);
+ XFlush(theDisplay);
+}
+
+static void nxtev(){
+ do XNextEvent( theDisplay, &retEv );
+ while( retEv.type!=ClientMessage );
+}
+
+
+
+
+void graph_on(x,y,title) int x,y; char *title; {
+
+ if ((theDisplay = XOpenDisplay(NULL)) == NULL){
+ fprintf (stderr,"\ngraph: Can't open display\n");
+ exit(1);
+ }
+
+ myWindow = XCreateWindow(
+ theDisplay,
+ RootWindow(theDisplay,DefaultScreen(theDisplay)),
+ 0,0,1,1,0,
+ CopyFromParent,InputOnly,CopyFromParent,
+ 0,NULL
+ );
+
+ if( (child_no=fork())==0 ){
+ char me[16];
+ char xs[16];
+ char ys[16];
+ sprintf(me,"%d",(int)myWindow);
+ sprintf(xs,"%d",x);
+ sprintf(ys,"%d",y);
+ execlp("./graph","graph",me,xs,ys,title,NULL);
+ }
+
+ nxtev();
+ theWindow = (int)(retEv.xclient.data.l[0]);
+}
+
+
+void graph_off(){
+ send_sig(GRAPH_CMD_END);
+ child_no=0;
+}
+
+
+void graph_point( x,c ) int x,c; {
+ theMessage.data.l[0]=x;
+ theMessage.data.l[1]=c;
+ send_sig(GRAPH_CMD_POINT);
+}
+
+void graph_board( size ) int size; {
+ theMessage.data.l[0]=size;
+ send_sig(GRAPH_CMD_LINE);
+}
+
--- /dev/null
+#define GRAPH_CMD_POINT 1
+#define GRAPH_CMD_END 2
+#define GRAPH_CMD_LINE 3
+
+#define GRAPH_COL_BACK 0
+#define GRAPH_COL_BOARD 1
+#define GRAPH_COL_OK 2
+#define GRAPH_COL_ERROR 3
+
+#ifndef NO_PROTOTYPES
+void graph_on( int x, int y, char *title );
+void graph_off( void );
+void graph_point( int x, int color );
+void graph_board( int size );
+#else
+void graph_on();
+void graph_off();
+void graph_point();
+void graph_board();
+#endif
--- /dev/null
+#include "graph.h"
+
+#include <stdio.h>
+#include <math.h>
+#include <ctype.h>
+
+#include <X11/cursorfont.h>
+
+#ifndef NO_MWM
+#include <X11/Xos.h>
+#endif
+
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#include <X11/Xatom.h>
+
+#ifndef NO_MWM
+#include <X11/MwmUtil.h>
+#endif
+
+XSizeHints theHints;
+Display *theDisp;
+int theDepth, theScreen, dispcells;
+Colormap theCmap;
+Window rootW, window, father;
+GC theGC;
+unsigned long fcol,bcol,white,black,grey,yellow,red,style=1;
+XColor exact_color,closest_color;
+Font mfont;
+XFontStruct *mfinfo;
+Visual *theVisual;
+XImage *theImage;
+XClientMessageEvent toFatherEv;
+XEvent event;
+Cursor theCursor;
+
+int iWIDE,iHIGH,xWIDE;
+static int MARGIN=3;
+
+Pixmap pixmap;
+
+static void snd_father(){
+ toFatherEv.type=ClientMessage;
+ toFatherEv.format = 16;
+ XSendEvent(theDisp,father,False,NoEventMask,&toFatherEv);
+/* XFlush(theDisp);*/
+}
+
+#ifndef NO_PROTOTYPES
+void RealiseCmd(int,long *);
+#else
+void RealiseCmd();
+#endif
+
+
+static char *title;
+
+
+main(argc, argv)
+ int argc;
+ char *argv[];
+{
+ int w=0;
+ int i;
+ int events=0;
+
+ father = atoi(argv[1]);
+
+ iWIDE = atoi(argv[2])+2*MARGIN;
+ iHIGH = atoi(argv[3])+2*MARGIN;
+ xWIDE = atoi(argv[2]);
+ title = argv[4];
+
+ for( i=2; i<argc; i++ ) argv[i-1]=argv[i];
+ argc--;
+
+ if ((theDisp = XOpenDisplay(NULL)) == NULL){
+ fprintf (stderr,"\n%s: Can't open display\n", argv[0]);
+ exit(1);
+ }
+
+ theScreen = DefaultScreen(theDisp);
+ theDepth = DefaultDepth(theDisp, theScreen);
+ rootW = RootWindow(theDisp,theScreen);
+ fcol=white= WhitePixel(theDisp,theScreen);
+ bcol=black= BlackPixel(theDisp,theScreen);
+ theVisual = DefaultVisual(theDisp,theScreen);
+ theCmap = DefaultColormap(theDisp,theScreen);
+ dispcells = DisplayCells(theDisp, theScreen);
+ theCursor = XCreateFontCursor(theDisp,XC_watch);
+
+ if(!XAllocNamedColor(theDisp,theCmap,"grey",&exact_color,&closest_color))
+ grey = black;
+ else
+ grey = closest_color.pixel;
+
+ if(!XAllocNamedColor(theDisp,theCmap,"yellow",&exact_color,&closest_color))
+ yellow = white;
+ else
+ yellow = closest_color.pixel;
+
+ if(!XAllocNamedColor(theDisp,theCmap,"red",&exact_color,&closest_color))
+ red = black;
+ else
+ red = closest_color.pixel;
+
+ if ((mfinfo = XLoadQueryFont(theDisp,"fixed"))==NULL){
+ fprintf (stderr,"\n%s: Can't open 'fixed' font\n", argv[0]);
+ exit(1);
+ }
+ mfont=mfinfo->fid;
+
+ theHints.width =iWIDE;
+ theHints.height=iHIGH;
+ theHints.flags=PSize;
+ window = XCreateSimpleWindow(theDisp,rootW,10,10,iWIDE,iHIGH,3,fcol,bcol);
+
+ XSetStandardProperties(theDisp,window,title,title,None,argv,argc,&theHints);
+ XDefineCursor(theDisp,window,theCursor);
+
+ XChangeProperty(theDisp,window,XA_WM_CLASS,XA_STRING,8,PropModeReplace,
+ title,strlen(title));
+
+#ifndef NO_MWM
+ {
+ struct {
+ long flags;
+ long functions;
+ long decorations;
+ int input_mode;
+ } hints;
+ Atom a=XInternAtom(theDisp,_XA_MWM_HINTS,False);
+ hints.flags = MWM_HINTS_FUNCTIONS;
+ hints.functions = MWM_FUNC_CLOSE | MWM_FUNC_MOVE;
+ hints.decorations = 0;
+ hints.input_mode = 0;
+ XChangeProperty(theDisp,window,a,a,32,PropModeReplace,&hints,4);
+ }
+#endif
+
+ theGC = XCreateGC(theDisp,window,0,0);
+ XSetFont(theDisp,theGC,mfont);
+ XSetForeground(theDisp,theGC,fcol);
+ XSetBackground(theDisp,theGC,bcol);
+
+ XSelectInput(theDisp,window, ExposureMask | KeyPressMask);
+ XMapRaised(theDisp,window);
+
+ pixmap = XCreatePixmap(theDisp,window,iWIDE,iHIGH,theDepth);
+
+ XSetForeground(theDisp,theGC,bcol);
+ XFillRectangle(theDisp,pixmap,theGC,0,0,iWIDE,iHIGH);
+ XFillRectangle(theDisp,window,theGC,0,0,iWIDE,iHIGH);
+ XSetForeground(theDisp,theGC,fcol);
+
+ for(;;){
+
+ XNextEvent(theDisp,&event);
+
+ switch (event.type){
+
+ case Expose:
+ {
+ int x=event.xexpose.x;
+ int y=event.xexpose.y;
+ int w=event.xexpose.width;
+ int h=event.xexpose.height;
+ int cnt=0;
+ XCopyArea(theDisp,pixmap,window,theGC,x,y,w,h,x,y);
+ if( events==0 ){
+ toFatherEv.data.l[0] = window;
+ snd_father();
+ }
+ events=1;
+ }
+ break;
+
+ case ClientMessage:
+ RealiseCmd( (int)(event.xclient.message_type),event.xclient.data.l);
+ break;
+
+ case MappingNotify:
+ if( event.xmapping.request == MappingModifier ||
+ event.xmapping.request == MappingKeyboard )
+ XRefreshKeyboardMapping(&event);
+ break;
+
+ } /* end of switch */
+
+ } /* end of for */
+
+}
+
+
+
+static int cmd=0,w,h,x,y,curx,cury,kolb,wwyp,p,q,r,color;
+static char c;
+static XImage *image;
+XImage *XGetImage();
+
+
+
+void RealiseCmd( cmd, pars ) int cmd; long *pars; {
+
+ int size;
+
+ switch( cmd ){
+
+ case GRAPH_CMD_END:
+ XFreePixmap(theDisp,pixmap);
+ XDestroyWindow(theDisp,window);
+ XCloseDisplay(theDisp);
+ exit(0);
+ break;
+
+
+ case GRAPH_CMD_POINT:
+
+ x = pars[ 0 ];
+ color = pars[ 1 ];
+
+ if( color == GRAPH_COL_BACK ) fcol = black ;
+ else
+ if( color == GRAPH_COL_OK ) fcol = yellow ;
+ else
+ if( color == GRAPH_COL_BOARD ) fcol = grey ;
+ else
+ if( color == GRAPH_COL_ERROR ) fcol = red ;
+
+ XSetForeground(theDisp,theGC,fcol);
+ XDrawPoint(theDisp,pixmap,theGC,MARGIN+x%xWIDE,MARGIN+x/xWIDE);
+ XDrawPoint(theDisp,window,theGC,MARGIN+x%xWIDE,MARGIN+x/xWIDE);
+ break;
+
+
+ case GRAPH_CMD_LINE:
+
+ size = pars[ 0 ];
+ XSetForeground(theDisp,theGC,grey);
+ XFillRectangle(theDisp,pixmap,theGC,MARGIN,MARGIN,xWIDE,size/xWIDE);
+ XFillRectangle(theDisp,window,theGC,MARGIN,MARGIN,xWIDE,size/xWIDE);
+ if( size%xWIDE > 0 ){
+ XDrawLine(theDisp,pixmap,theGC,
+ MARGIN, MARGIN+size/xWIDE,
+ MARGIN+size%xWIDE-1, MARGIN+size/xWIDE
+ );
+ XDrawLine(theDisp,window,theGC,
+ MARGIN, MARGIN+size/xWIDE,
+ MARGIN+size%xWIDE-1, MARGIN+size/xWIDE
+ );
+ }
+ break;
+
+
+ default :
+ fprintf(stderr,"UKNOWN COMMAND - %d\n",cmd);
+ fflush(stderr);
+ XFreePixmap(theDisp,pixmap);
+ XDestroyWindow(theDisp,window);
+ XCloseDisplay(theDisp);
+ exit(7);
+
+ }
+}
+
--- /dev/null
+SHELL = /bin/sh
+
+
+#### SCO ####
+CFLAGS=-g -W1
+socket=-lsocket
+
+#### HP ####
+#CFLAGS=-g -DNO_PROTOTYPES -DNO_MWM -DBZERO
+#socket=
+
+
+
+PROD = cli srv graph time timediff
+
+install all: $(PROD)
+
+.c.o:
+ $(CC) $(CFLAGS) -c $*.c
+
+cli: cli.o graph.o sock.o sockcrc.o
+ $(CC) $(CFLAGS) -o cli cli.o graph.o sock.o sockcrc.o -lX11 $(socket)
+
+srv: srv.o sock.o sockcrc.o
+ $(CC) $(CFLAGS) -o srv srv.o sock.o sockcrc.o $(socket)
+
+graph: graphsrv.o
+ $(CC) $(CFLAGS) -o graph graphsrv.o -lX11 $(socket)
+
+time: time.o sock.o
+ $(CC) $(CFLAGS) -o time time.o sock.o $(socket)
+
+timediff: timediff.o sock.o
+ $(CC) $(CFLAGS) -o timediff timediff.o sock.o $(socket)
+
+clean:
+ -rm -f $(PROD)
+ -rm -f *.o
+ -rm -f srv.log
+
--- /dev/null
+#include "sock.h"
+
+
+#ifndef FD_SET
+#define BITS_PER_INT 32
+#define FD_SET(f,fds) (fds)->fds_bits[(f)/BITS_PER_INT]|=(1<<((f)%BITS_PER_INT))
+#define FD_ZERO(fds) { (fds)->fds_bits[0]=0; (fds)->fds_bits[1]=0; }
+#endif
+
+
+
+#ifdef BZERO
+void bzero( buf, size ) char *buf; int size; {
+ while( --size >= 0 )
+ buf[size]='\0';
+}
+void bcopy( from, to, size ) char *from,*to; int size; {
+ while( --size >= 0 )
+ to[size]=from[size];
+}
+#endif
+
+
+
+#ifndef INADDR_NONE
+#define INADDR_NONE 0xffffffffUL
+#endif
+
+
+int sock_open( socket_type, protocol, host, service, port, as_server )
+ char *host;
+ char *service;
+ char *protocol;
+ int socket_type,port;
+ int as_server;
+{
+ int fd;
+ unsigned long inaddr;
+ struct sockaddr_in my_addr,it_addr,*srv_addr;
+ struct servent *sp;
+ struct hostent *hp;
+ struct protoent *pp;
+
+ bzero((char *)&my_addr,sizeof(my_addr));
+ bzero((char *)&it_addr,sizeof(it_addr));
+
+ my_addr.sin_family=AF_INET;
+ it_addr.sin_family=AF_INET;
+
+ my_addr.sin_port=htons(0);
+ it_addr.sin_port=htons(0);
+
+ my_addr.sin_addr.s_addr=htonl(INADDR_ANY);
+ it_addr.sin_addr.s_addr=htonl(INADDR_ANY);
+
+ if( as_server )
+ srv_addr = &my_addr;
+ else
+ srv_addr = &it_addr;
+
+ if( (pp=getprotobyname(protocol)) == NULL ){
+ fprintf(stderr,"protocol %s unknown\n",protocol);
+ return -1;
+ }
+
+ if( service != NULL ){
+ if( (sp=getservbyname(service,protocol)) == NULL ){
+ fprintf(stderr,"port_open:unknown service %s/%s\n",service,protocol);
+ return -1;
+ }
+ srv_addr->sin_port = sp->s_port;
+ }
+
+ if( port>0 )
+ srv_addr->sin_port = htons( port );
+
+ if( host!=NULL )
+ if( (inaddr = inet_addr(host)) != INADDR_NONE ){
+ /* it is dotted-decimal address */
+ bcopy((char *)&inaddr,(char *)&(srv_addr->sin_addr),sizeof(inaddr));
+ } else {
+ if( (hp = gethostbyname(host)) == NULL ){
+ fprintf(stderr,"port_open:host name error %s\n",host);
+ return -1;
+ }
+ bcopy(hp->h_addr,(char *)&(srv_addr->sin_addr),hp->h_length);
+ }
+
+ if( (fd = socket(AF_INET,socket_type,pp->p_proto)) < 0 ){
+ perror("port_open:can't create socket");
+ errno=0;
+ return -1;
+ }
+
+ if( bind( fd, (struct sockaddr *)&my_addr, sizeof(my_addr) ) < 0 ){
+ perror("port_open:bind error");
+ errno=0;
+ return -1;
+ }
+
+ if( !as_server )
+ if( connect( fd, (struct sockaddr *)&it_addr, sizeof(it_addr) ) < 0 ){
+ perror("port_open:connect error");
+ errno=0;
+ return -1;
+ }
+
+ return fd;
+}
+
+
+int sock_cli_send( sock, m, size ) int sock,size; void *m; {
+ if( send(sock, m, size, 0) < 0) {
+ perror("cli:send failed");
+ errno=0;
+ return -1;
+ }
+ return 0;
+}
+
+
+
+int sock_poll( sock, ms ) int sock,ms; {
+ struct timeval timeout;
+ fd_set rd_fds;
+ int nfds;
+ FD_ZERO(&rd_fds);
+ timeout.tv_sec = ms/1000;
+ timeout.tv_usec = (ms%1000)*1000;
+ if( sock>=0 ) /* sock==-1 means we only sleep */
+ FD_SET(sock,&rd_fds);
+ nfds = select(sock+1,&rd_fds,NULL,NULL,&timeout);
+ errno=0;
+ return ( nfds == 1 );
+}
+
+
+static int cli_recv_timeout = 2000 /* miliseconds */;
+
+void set_cli_recv_timeout( ms ) int ms; { /* set timeout to miliseconds */
+ cli_recv_timeout = ms;
+}
+
+int sock_cli_recv( sock, m, size ) int sock,size; void *m; {
+ int recv_size;
+ int nfds;
+ nfds = sock_poll(sock,cli_recv_timeout);
+ if( nfds==0 ){ errno=0; return 0; } /* timeout */
+ if( nfds<0 ){
+ perror("cli:select failed");
+ errno=0;
+ return -1;
+ }
+ if( (recv_size=recv(sock, m, size, 0)) < 0) {
+ perror("cli:recv failed");
+ errno=0;
+ return -1;
+ }
+ return recv_size;
+}
+
+
+static int srv_send_wait_time = 1;
+
+void set_srv_send_delay( ms ) int ms; { /* set delay to miliseconds */
+ srv_send_wait_time = ms;
+}
+
+int sock_srv_send( sock, m, size, addr, namelen )
+ int sock,size,namelen;
+ void *m;
+ struct sockaddr_in *addr;
+{
+ sock_poll(-1,srv_send_wait_time);
+ if( sendto(sock,m,size,0,addr,namelen) <= 0) {
+ perror("srv:send failed");
+ errno=0;
+ return -1;
+ }
+ return 0;
+}
+
+int sock_srv_recv( sock, m, size, addr, namelen )
+ int sock,size,*namelen;
+ void *m;
+ struct sockaddr_in *addr;
+{
+ int recv_size;
+ if( (recv_size=recvfrom(sock, m, size, 0, addr, namelen )) < 0) {
+ perror("srv:recvfrom");
+ errno=0;
+ return -1;
+ }
+ return recv_size;
+}
+
+
--- /dev/null
+# include <stdio.h>
+# include <string.h>
+#ifndef NO_PROTOTYPES
+# include <stdlib.h>
+#endif
+# include <sys/types.h>
+# include <signal.h>
+# include <sys/socket.h>
+# include <sys/time.h>
+# include <netinet/in.h>
+# include <netdb.h>
+# include <errno.h>
+
+
+#define AS_CLIENT 0
+#define AS_SERVER 1
+
+
+#ifndef NO_PROTOTYPES
+int sock_open( int socket_type, char *protocol,
+ char *host, char *service, int port,
+ int as_server );
+int sock_cli_send( int sock, void *m, int size );
+int sock_cli_recv( int sock, void *m, int size );
+int sock_srv_recv( int sock, void *m, int size,
+ struct sockaddr_in *addr, int *namelen );
+int sock_srv_send( int sock, void *m, int size,
+ struct sockaddr_in *addr, int namelen );
+void set_cli_recv_timeout( int miliseconds );
+void set_srv_send_delay ( int miliseconds );
+int poll_socket( int sock, int miliseconds );
+#else
+int sock_open();
+int sock_cli_send();
+int sock_cli_recv();
+int sock_srv_recv();
+int sock_srv_send();
+void set_cli_recv_timeout();
+void set_srv_send_delay ();
+int poll_socket();
+#endif
+
+
+#ifndef NO_PROTOTYPES
+int sock_cli_crc_send( int sock, void *m, int size );
+int sock_cli_crc_recv( int sock, void *m, int size );
+int sock_srv_crc_recv( int sock, void *m, int size,
+ struct sockaddr_in *addr, int *namelen );
+int sock_srv_crc_send( int sock, void *m, int size,
+ struct sockaddr_in *addr, int namelen );
+#else
+int sock_cli_crc_send();
+int sock_cli_crc_recv();
+int sock_srv_crc_recv();
+int sock_srv_crc_send();
+#endif
+
--- /dev/null
+#include "sock.h"
+
+#ifndef NO_PROTOTYPES
+static int get_crc( char *data, int data_size );
+#else
+static int get_crc();
+#endif
+
+
+static char buffer[8192]; /* shouldn't be bigger message */
+
+
+int sock_cli_crc_send( sock, m, size ) int sock,size; void *m; {
+ *(int *)buffer = htonl(get_crc( m, size ));
+ bcopy( m, buffer+sizeof(int), size );
+ return sock_cli_send( sock, buffer, size+sizeof(int) );
+}
+
+int sock_cli_crc_recv( sock, m, size ) int sock,size; void *m; {
+ int recv_size;
+ recv_size = sock_cli_recv(sock, buffer, size+sizeof(int) );
+ if( recv_size == 0 ) return 0;
+ else
+ if( recv_size < sizeof(int) ) return -1;
+ else{
+ recv_size-=sizeof(int);
+ bcopy( buffer+sizeof(int), m, recv_size );
+ if( get_crc(m,recv_size)!=ntohl(*(int *)buffer) )
+ return -1; /* error */
+ else
+ return recv_size;
+ }
+}
+
+int sock_srv_crc_send( sock, m, size, addr, namelen )
+ int sock,size,namelen;
+ void *m;
+ struct sockaddr_in *addr;
+{
+ *(int *)buffer = htonl(get_crc( m, size ));
+ bcopy( m, buffer+sizeof(int), size );
+ return sock_srv_send( sock, buffer, size+sizeof(int) , addr, namelen );
+}
+
+int sock_srv_crc_recv( sock, m, size, addr, namelen )
+ int sock,size,*namelen;
+ void *m;
+ struct sockaddr_in *addr;
+{
+ int recv_size;
+ recv_size = sock_srv_recv(sock, buffer, size+sizeof(int), addr, namelen );
+ if( recv_size == 0 ) return -1;
+ else
+ if( recv_size < sizeof(int) ) return -1;
+ else{
+ recv_size-=sizeof(int);
+ bcopy( buffer+sizeof(int), m, recv_size );
+ if( get_crc(m,recv_size)!=ntohl(*(int *)buffer) )
+ return -1; /* error */
+ else
+ return recv_size;
+ }
+}
+
+
+
+static int get_crc( data, data_size ) char *data; int data_size; {
+ int i;
+ unsigned long crc=0L;
+ for( i=0; i<data_size; i++,data++ ){
+ crc ^= (unsigned long)(unsigned char)(*(char *)data);
+ if( crc&1 )
+ crc = ( crc<<1 ) | 1;
+ else
+ crc = ( crc<<1 );
+ }
+ return crc;
+}
+
--- /dev/null
+#include "sock.h"
+#include "srv.h"
+#include <sys/stat.h>
+
+struct sockaddr_in it;
+int sock, namelen, seq = 0;
+
+#ifndef NO_PROTOTYPES
+int main(int argc,char **argv);
+#endif
+
+int main(argc,argv) int argc; char** argv; {
+ msg m;
+
+ if( argc>1 ){
+ set_srv_send_delay( atoi(argv[1]) );
+ printf("delay set to %d ms\n",atoi(argv[1]));
+ }
+
+ fclose(stdin);
+
+ {
+ int retval=fork();
+ if( retval<0 ) perror("fork failed"),exit(0);
+ if( retval>0 ) exit(0);
+ }
+
+ setpgrp();
+ freopen("srv.log","a",stdout);
+ freopen("srv.log","a",stderr);
+
+ sock = sock_open( SOCK_DGRAM, "udp", NULL, NULL, PORT, AS_SERVER );
+ if( sock < 0 ){
+ perror("sockopen");
+ fflush(stdout);
+ fflush(stderr);
+ exit(10);
+ }
+
+ if (fork()) exit(0);
+
+ for ( ;; ) {
+
+ int namelen = sizeof(it);
+ int size;
+
+ fflush(stdout);
+ fflush(stderr);
+
+ size=sock_srv_crc_recv(sock, &m, sizeof(m), &it, &namelen );
+
+ if( size>0 ) /* there was no error & I'm not interested in 0 size */
+ switch( ntohl(m.req) ){
+
+ case RQ_FILE_SIZE :
+ {
+ struct stat status;
+ if( stat(m.data,&status) ) status.st_size=0;
+ m.req=htonl(0);
+ printf("file %s size %d\n",m.data,status.st_size);
+ fflush(stdout);
+ fflush(stderr);
+ *(int*)(m.data)=htonl(status.st_size);
+ sock_srv_crc_send(sock,&m,HEAD+sizeof(int),&it,namelen);
+ }
+ break;
+
+ case RQ_FILE :
+ {
+ FILE *f=fopen(m.data+2*sizeof(int),"rb");
+ int size,cnt=0;
+ int packets = ntohl(((int *)m.data)[1]);
+ int seek=ntohl(((int *)m.data)[0]);
+ int errors=0;
+ if( f==NULL ) break;
+ printf("file %s from %d %d packets\n",
+ m.data+2*sizeof(int),seek,packets);
+ fflush(stdout);
+ fflush(stderr);
+ fseek(f,DATA_PIECE*seek,0);
+ while( (size=fread(m.data,1,DATA_PIECE,f)) > 0 ){
+ m.req=htonl(seek++);
+ cnt++;
+ if(sock_srv_crc_send(sock,&m,HEAD+size,&it,namelen)<0)
+ errors++;
+ else
+ errors=0;
+ if( errors>=10 ) break;
+ if( cnt==packets ) break;
+ }
+ fclose(f);
+ while( sock_poll( sock, 0 ) )
+ sock_srv_crc_recv(sock,&m,sizeof(m),&it,&namelen);
+ }
+ break;
+
+ default:
+ printf("srv:unknown req %d\n",ntohl(m.req));
+
+ }
+ }
+
+ return 0;
+}
+
--- /dev/null
+#define PORT 3963
+#define DATA_PIECE 64
+
+typedef struct {
+ unsigned long req;
+ char data[DATA_PIECE];
+} msg;
+
+#define HEAD (sizeof(msg)-DATA_PIECE)
+
+
+#define RQ_FILE_SIZE 1
+#define RQ_FILE 2
+
--- /dev/null
+# include <stdio.h>
+# include <string.h>
+# include <stdlib.h>
+# include <sys/types.h>
+# include <signal.h>
+# include <sys/socket.h>
+# include <sys/time.h>
+# include <netinet/in.h>
+# include <netdb.h>
+# include <errno.h>
+
+
+int main(){
+
+ int i=0;
+ long diff;
+ struct timeval time_before,time_after;
+
+ if( gettimeofday(&time_before,NULL) ){
+ perror("gettimeofday:");
+ exit(1);
+ }
+
+ for(;;i++){
+
+ if( gettimeofday(&time_after ,NULL) ){
+ perror("gettimeofday:");
+ exit(1);
+ }
+
+ diff = (time_after.tv_sec - time_before.tv_sec)*1000;
+ diff -= time_before.tv_usec/1000;
+ diff += time_after .tv_usec/1000;
+
+ if( diff < 0 ){
+ printf("%d-th operation took %d ms\n",i,diff);
+ fflush(stdout);
+ i=0;
+ }
+
+/* printf("time now %d s %d us\n",time_after.tv_sec,time_after.tv_usec);
+*/
+ fflush(stdout);
+
+ time_before = time_after;
+
+ }
+
+ return 0;
+}
+
--- /dev/null
+#include "sock.h"
+
+char m[100];
+int sock;
+
+char *host;
+
+
+#ifndef NO_PROTOTYPES
+int main(int argc,char **argv);
+#endif
+
+static int bytes_received=0;
+static char title[100];
+
+
+static void usage(s) char *s;{
+ printf("usage: %s host\n",s);
+ exit(0);
+}
+
+
+static int do_rs( socket_type, protocol, host, service )
+ int socket_type;
+ char *host,*service,*protocol;
+{
+ int size=0;
+ int sock = sock_open( socket_type, protocol, host, service, 0, AS_CLIENT );
+ if( sock>=0 ){
+ if( !sock_cli_send( sock, m, 1 ) ){
+ size=sock_cli_recv(sock,m,sizeof(m));
+ if( size>=0 )
+ printf("packet size %d\n",size);
+ }
+ close( sock );
+ }
+ return ( size > 0 );
+}
+
+
+int main(argc,argv) int argc; char** argv; {
+
+ int size;
+
+ if( argc != 2 ) usage(argv[0]);
+ host = argv[1];
+ printf("ask for time on %s\n",host);
+
+ set_cli_recv_timeout( 5000 );
+
+ if( do_rs( SOCK_DGRAM, "udp", host, "time" ) )
+ printf("time on %s is %u s\n",host,ntohl(*(int *)m));
+
+ if( do_rs( SOCK_DGRAM, "udp", host, "daytime" ) )
+ printf("daytime on %s is %s\n",host,m);
+
+ if( do_rs( SOCK_STREAM, "tcp", host, "time" ) )
+ printf("time on %s is %u s\n",host,ntohl(*(int *)m));
+
+ if( do_rs( SOCK_STREAM, "tcp", host, "daytime" ) )
+ printf("daytime on %s is %s\n",host,m);
+
+ if( do_rs( SOCK_STREAM, "tcp", host, "ntp" ) )
+ printf("daytime on %s is %s\n",host,m);
+
+ return 0;
+}
+
--- /dev/null
+#include "sock.h"
+
+char m[100];
+int sock;
+
+char *host;
+
+
+#ifndef NO_PROTOTYPES
+int main(int argc,char **argv);
+#endif
+
+static int bytes_received=0;
+static char title[100];
+
+
+static void usage(s) char *s;{
+ printf("usage: %s host\n",s);
+ exit(0);
+}
+
+
+static int host_time( host )
+ char *host;
+{
+ int size=0;
+ int time;
+ int sock = sock_open( SOCK_STREAM, "tcp", host, "time", 0, AS_CLIENT );
+ if( sock>=0 ){
+ size=sock_cli_recv(sock,&time,sizeof(int));
+ close( sock );
+ }
+ if( size == sizeof(int) ) return ntohl(time);
+ else return 0;
+}
+
+
+int main(argc,argv) int argc; char** argv; {
+
+ int uid=getuid();
+
+ if( argc != 2 ) usage(argv[0]);
+ host = argv[1];
+
+ printf("STARTED\n");
+
+ for(;;sleep(60*15)){
+
+ int local,remote,i;
+ long diff;
+ struct timeval delta,olddelta;
+ struct timeval time_before,time_after;
+
+ errno=0;
+
+ for( i=0; i<3; i++ ){
+
+ if( gettimeofday(&time_before,NULL) ){
+ perror("gettimeofday:");
+ if( uid!=0 ) return 1;
+ continue;
+ }
+
+ local = host_time( "localhost" );
+ remote= host_time( host );
+
+ if( gettimeofday(&time_after ,NULL) ){
+ perror("gettimeofday:");
+ if( uid!=0 ) return 1;
+ continue;
+ }
+
+ diff = (time_after.tv_sec - time_before.tv_sec)*1000;
+ diff -= time_before.tv_usec/1000;
+ diff += time_after .tv_usec/1000;
+ if( diff >=0 && diff < 300 ) break;
+
+ }
+
+ if( i==3 ){
+ printf("transaction too long ( %dms ) or errors in time\n",diff);
+ fflush(stdout);
+ fflush(stderr);
+ if( uid==0 )
+ continue;
+ }
+
+ if( remote==0 ){
+ printf("error in connect to %s\n",host);
+ fflush(stdout);
+ fflush(stderr);
+ if( uid!=0 ) return 1;
+ continue;
+ }
+ if( local==0 ){
+ printf("error in connect to %s\n","localhost");
+ fflush(stdout);
+ fflush(stderr);
+ if( uid!=0 ) return 1;
+ continue;
+ }
+
+ delta.tv_sec=remote-local;
+ delta.tv_usec=0;
+
+ if( delta.tv_sec!=0 ){
+ if( delta.tv_sec > 1 ) delta.tv_sec = 1;
+ else
+ if( delta.tv_sec < -1 ) delta.tv_sec = -1;
+ else{
+ if( delta.tv_sec == 1 ) delta.tv_usec = 500000;
+ else delta.tv_usec = -500000;
+ delta.tv_sec = 0;
+ }
+ if( uid==0 )
+ if( adjtime(&delta,&olddelta)<0 ) perror("adjtime error:");
+ }
+
+ {
+ extern char *ctime();
+ extern time_t time();
+ time_t t=time(NULL);
+ char *c=ctime(&t);
+ if( c[strlen(c)-1]=='\n' ) c[strlen(c)-1]='\0';
+ if( remote > local )
+ printf("at %s(%dms) time on %s is %u s forward\n",
+ c,diff,host,remote-local);
+ if( remote < local )
+ printf("at %s(%dms) time on %s is %u s late\n",
+ c,diff,host,local-remote);
+ if( uid != 0 && remote == local )
+ printf("at %s(%dms) time on %s is equal\n",c,diff,host);
+ }
+
+ fflush(stdout);
+ fflush(stderr);
+
+ if( uid!=0 ) return 0;
+
+ }
+
+ return 0;
+}
+
--- /dev/null
+#ifndef NO_PROTOTYPES
+int sendmsg( int sock, struct msghdr *hdr, int flags );
+int recvmsg( int sock, struct msghdr *hdr, int flags );
+#else
+int sendmsg();
+int recvmsg();
+#endif
+
+
+#ifdef SCO
+#define msghdr dumb_name_for_wrong_msghdr_9873
+#endif
+
+#ifdef SCO
+#undef msghdr
+#endif
+
+#ifdef SCO /* wrong structute msghdr + sendmsg not implemented !!!? */
+
+struct iovec {
+ caddr_t iov_base;
+ int iov_len;
+};
+
+/*
+ * Message header for recvmsg and sendmsg calls.
+ */
+struct msghdr {
+ caddr_t msg_name; /* optional address */
+ int msg_namelen; /* size of address */
+ struct iovec *msg_iov; /* scatter/gather array */
+ int msg_iovlen; /* # elements in msg_iov */
+ caddr_t msg_accrights; /* access rights sent/received */
+ int msg_accrightslen;
+};
+
+
+
+
+/* SCO did not implement these functions ! */
+
+static char buffer[8192]; /* maybe there won't be bigger message */
+
+
+int sendmsg( sock, hdr, flags ) int sock; struct msghdr *hdr; int flags; {
+ int i,size;
+ char *ptr=buffer;
+
+ for( size=i=0;
+ i < hdr -> msg_iovlen ;
+ size+=hdr->msg_iov[i].iov_len, ptr+=hdr->msg_iov[i].iov_len, i++
+ ){
+ if( size + hdr->msg_iov[i].iov_len >= sizeof(buffer) ){
+ errno=EMSGSIZE;
+ return -1;
+ }
+ bcopy( hdr->msg_iov[i].iov_base, ptr, hdr->msg_iov[i].iov_len );
+ }
+
+ if( hdr->msg_name != NULL )
+ return sendto( sock,buffer,size,flags, hdr->msg_name,hdr->msg_namelen );
+ else
+ return send( sock,buffer,size,flags );
+}
+
+
+int recvmsg( sock, hdr, flags ) int sock; struct msghdr *hdr; int flags; {
+ int i,sizegot,size;
+ char *ptr=buffer;
+
+ if( hdr->msg_name != NULL )
+ size = recvfrom( sock,buffer,size,flags, hdr->msg_name,hdr->msg_namelen );
+ else
+ size = recv( sock,buffer,size,flags );
+
+ if( size<=0 ) return size;
+
+ for( sizegot=i=0;
+ i < hdr -> msg_iovlen ;
+ sizegot+=hdr->msg_iov[i].iov_len, ptr+=hdr->msg_iov[i].iov_len, i++
+ ){
+ if( sizegot + hdr->msg_iov[i].iov_len >= sizeof(buffer) ){
+ bcopy( ptr, hdr->msg_iov[i].iov_base, sizeof(buffer)-sizegot);
+ size = sizeof(buffer);
+ break;
+ }
+ bcopy( ptr, hdr->msg_iov[i].iov_base, hdr->msg_iov[i].iov_len );
+ }
+
+ return size;
+}
+
--- /dev/null
+#include <stdio.h>
+#include <rpc/rpc.h>
+#include "srvr.h"
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/time.h>
+#include <netdb.h>
+
+main(argc,argv) int argc; char **argv; {
+ struct hostent *hp;
+ struct timeval pertry_timeout,total_timeout;
+ struct sockaddr_in server_addr;
+ int addrlen;
+ int sock=RPC_ANYSOCK;
+ CLIENT *client;
+ enum clnt_stat clnt_stat;
+ char *s;
+ int pid=getpid();
+ int vers;
+
+ if(argc < 3) fprintf(stderr,"usage:%s hostname version\n",argv[0]),exit(-1);
+
+ vers=(int)atol(argv[2]);
+
+ if((hp=gethostbyname(argv[1]))==NULL)
+ fprintf(stderr,"cannot get addr for %s\n",argv[1]),exit(-1);
+
+ pertry_timeout.tv_sec = 60;
+ pertry_timeout.tv_usec = 0;
+
+ addrlen = sizeof( struct sockaddr_in );
+ {
+ int i;
+ for( i=0; i<hp->h_length ; i++ )
+ ((char *)(&server_addr.sin_addr))[i] = hp->h_addr[i];
+ }
+
+ server_addr.sin_family = AF_INET;
+ server_addr.sin_port = 0;
+
+ total_timeout.tv_sec = 2000;
+ total_timeout.tv_usec = 0;
+
+ if((client=clntudp_create(&server_addr,SRVRPROG,SRVRVERS+vers,total_timeout,&sock))==NULL){
+ perror("clntudp_create");
+ exit(-1);
+ }
+
+ clnt_stat=clnt_call(client,NULLPROC, xdr_void,NULL, xdr_void,NULL,
+ total_timeout);
+
+ if( clnt_stat != RPC_SUCCESS ){
+ clnt_perror( client, "rpc clnt call" );
+ exit(-1);
+ }
+
+ {
+ int i;
+ for( i=0; i<500; i++ ){
+
+ s=malloc(40);
+ sprintf(s,"client %d version %d",pid,vers);
+
+ clnt_stat = clnt_call( client, RENDERSTR,
+ xdr_wrapstring, &s, xdr_void, NULL,
+ total_timeout );
+
+ if( clnt_stat != RPC_SUCCESS ){
+ clnt_perror(client,"rpc");
+ exit(-1);
+ }
+
+ }
+ }
+
+ clnt_destroy( client );
+}
--- /dev/null
+SHELL=/bin/sh
+
+all : srvr clnt stop
+
+LIBS = -lrpc -lsocket
+SRVR_LIBS = -lrpcsvc $(LIBS)
+
+clean :
+ rm -f srvr clnt stop *.o a.out errs core
+
+srvr : srvr.c
+ cc -o srvr srvr.c $(SRVR_LIBS)
+
+clnt : clnt.c
+ cc -o clnt clnt.c $(LIBS)
+
+stop : stop.c
+ cc -o stop stop.c $(LIBS)
--- /dev/null
+#include <stdio.h>
+#include <rpc/rpc.h>
+#include "srvr.h"
+
+void dispatch();
+
+#define MAXPROCS 64
+
+#define disable(p) (mask&=~(1<<(sockets[p])))
+#define enable(p) (mask|= (1<<(sockets[p])))
+int sockets[MAXPROCS];
+unsigned int mask=0xffffffff;
+
+
+main(){
+ SVCXPRT *transp;
+
+ int i;
+ for(i=0;i<MAXPROCS;i++) sockets[i]=-1;
+
+ transp = svcudp_create(RPC_ANYSOCK);
+ if( transp == NULL ){
+ fprintf(stderr,"could not create an RPC1 server\n");
+ exit(1);
+ }
+ pmap_unset(SRVRPROG,SRVRVERS);
+ if(!svc_register(transp,SRVRPROG,SRVRVERS,dispatch,IPPROTO_UDP)){
+ fprintf(stderr,"could not register service 1\n");
+ exit(1);
+ }
+ sockets[0]=transp->xp_sock;
+
+ transp = svcudp_create(RPC_ANYSOCK);
+ if( transp == NULL ){
+ fprintf(stderr,"could not create an RPC2 server\n");
+ exit(1);
+ }
+ pmap_unset(SRVRPROG,SRVRVERS+1);
+ if(!svc_register(transp,SRVRPROG,SRVRVERS+1,dispatch,IPPROTO_UDP)){
+ fprintf(stderr,"could not register service 2\n");
+ exit(1);
+ }
+ sockets[1]=transp->xp_sock;
+
+ disable(1);
+
+ svc_run();
+ fprintf(stderr,"should never reach this point!\n");
+}
+
+void dispatch(rqstp,transp) struct svc_req *rqstp; SVCXPRT *transp; {
+ char *s=NULL;
+ static int sem=0;
+ static int cnt=0;
+ switch( rqstp->rq_proc ){
+
+ case NULLPROC:
+ printf("nullproc\n");
+ if(!svc_sendreply(transp,xdr_void,0)){
+ fprintf(stderr,"could not reply to RPC NULL call\n");
+ exit(1);
+ }
+ return;
+
+ case RENDERSTR:
+ sem++;
+ if(sem>1){ printf("ERROR sem=%d\n",sem); exit(1); }
+ enable(0);
+ if(cnt>50) enable(1);
+ if(!svc_getargs(transp,xdr_wrapstring,&s)){
+ fprintf(stderr,"could not decode arguments in RPC render call\n");
+ exit(1);
+ }
+ printf("got:%s\n",s);
+ if(!svc_sendreply(transp,xdr_void,0)){
+ fprintf(stderr,"could not reply to RPC render call\n");
+ exit(1);
+ }
+ if(rqstp->rq_vers-SRVRVERS==1)
+ if((cnt%9)==2)
+ disable(0);
+ cnt++;
+ sem--;
+ break;
+
+ case SRVR_END:
+ if(!svc_sendreply(transp,xdr_void,0)){
+ fprintf(stderr,"could not reply to RPC END call\n");
+ exit(1);
+ }
+ svc_unregister(SRVRPROG,rqstp->rq_vers);
+ svc_destroy(transp);
+ printf("server %d closed\n",rqstp->rq_vers-SRVRVERS);
+
+ default :
+ svcerr_noproc(transp);
+ return;
+
+ }
+ svc_freeargs(transp,xdr_wrapstring,&s);
+}
+
+
+void svc_run()
+{
+ int readfds;
+ for(;;){
+ readfds=svc_fds&mask;
+/* printf("sel:svc_fds=%x\n",svc_fds);*/
+ if( svc_fds == 0 ){
+ printf("server has no services - closing\n");
+ exit(0);
+ }
+ switch( select(32,&readfds,NULL,NULL,NULL) ){
+
+ case -1: perror("rstat: select");
+ return;
+
+ case 0: break;
+
+ default:
+/* printf(" req:svc_fds=%x\n",readfds);*/
+ svc_getreq(readfds);
+ }
+ }
+}
+
--- /dev/null
+#define SRVRPROG 120022
+#define SRVRVERS 1
+#define RENDERSTR 1
+#define SRVR_END 3
--- /dev/null
+#include <stdio.h>
+#include <rpc/rpc.h>
+#include "srvr.h"
+#include <sys/socket.h>
+#include <sys/time.h>
+#include <netdb.h>
+
+main(argc,argv) int argc; char **argv; {
+ struct hostent *hp;
+ struct timeval pertry_timeout,total_timeout;
+ struct sockaddr_in server_addr;
+ int addrlen;
+ int sock=RPC_ANYSOCK;
+ CLIENT *client;
+ enum clnt_stat clnt_stat;
+ int vers;
+
+ if(argc < 3) fprintf(stderr,"usage:%s hostname version\n",argv[0]),exit(-1);
+ vers=(int)atol(argv[2]);
+
+ if((hp=gethostbyname(argv[1]))==NULL)
+ fprintf(stderr,"cannot get addr for %s\n",argv[1]),exit(-1);
+
+ pertry_timeout.tv_sec = 10;
+ pertry_timeout.tv_usec = 0;
+
+ addrlen = sizeof( struct sockaddr_in );
+ {
+ int i;
+ for( i=0; i<hp->h_length ; i++ )
+ ((char *)(&server_addr.sin_addr))[i] = hp->h_addr[i];
+ }
+
+ server_addr.sin_family = AF_INET;
+ server_addr.sin_port = 0;
+
+ total_timeout.tv_sec = 20;
+ total_timeout.tv_usec = 0;
+
+ if((client=clntudp_create(&server_addr,SRVRPROG,SRVRVERS+vers,total_timeout,&sock))==NULL){
+ perror("clntudp_create in stop");
+ exit(-1);
+ }
+
+ clnt_stat=clnt_call(client,NULLPROC, xdr_void,NULL, xdr_void,NULL,
+ total_timeout);
+
+ if( clnt_stat != RPC_SUCCESS ){
+ clnt_perror( client, "rpc clnt call" );
+ exit(-1);
+ }
+
+ clnt_stat=clnt_call(client,SRVR_END, xdr_void,NULL, xdr_void,NULL,
+ total_timeout);
+
+ if( clnt_stat != RPC_SUCCESS ){
+ clnt_perror( client, "rpc" );
+ exit(-1);
+ }
+
+ clnt_destroy( client );
+}
--- /dev/null
+:
+int -r 1 1 p # colsole number 1, wait for one slave
+
--- /dev/null
+:
+int -r 1 2 p # colsole number 1, wait for 2 slaves
+
--- /dev/null
+program p;
+
+
+
+unit sync : process(nr:integer);
+
+ unit slock:procedure;
+ begin
+ accept sunlock;
+ end slock;
+
+ unit sunlock:procedure;
+ begin
+ end sunlock;
+
+ begin
+ return;
+ do
+ accept slock;
+ od;
+end sync;
+
+
+
+unit main_process : process( i:integer, s:sync );
+
+ var cnt : integer;
+
+ unit entry : procedure( i,j:integer );
+ begin
+ writeln("entry called from node ",i," #",j);
+ if j<0 then cnt:=cnt+1; fi;
+ end entry;
+
+ begin
+ cnt := 0;
+ return;
+ while cnt < 2 do
+ accept entry;
+ od;
+ call s.sunlock;
+end main_process;
+
+
+
+unit slave : process( i:integer, m:main_process );
+ var j:integer;
+ begin
+ return;
+ for j:=1 to 10 do
+ call m.entry( i, j );
+ od;
+ call m.entry( i, -1 );
+end slave;
+
+
+unit ender : process( i:integer );
+ begin
+ return;
+ call endrun;
+end ender;
+
+
+var m:main_process, s1,s2:slave, sem:sync, e:ender;
+
+begin
+
+ sem := new sync( 0 );
+ resume( sem );
+
+ m := new main_process( 0, sem );
+ resume( m );
+
+ s1 := new slave( 2, m );
+ resume( s1 );
+ s2 := new slave( 3, m );
+ resume( s2 );
+ call sem.slock;
+
+ e := new ender( 2 );
+ resume( e );
+ e := new ender( 3 );
+ resume( e );
+
+ writeln("end of program");
+ call endrun;
+
+end.
+
--- /dev/null
+:
+int -r 2 futrzak: p # console number 2, master at futrzak:
+
--- /dev/null
+:
+int -r 3 futrzak: p
+
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include "nonstand.h"\r
+\r
+/* Call (non)standard procedures.\r
+ * Almost totaly implementation dependent.\r
+ */\r
+\r
+bool graphmode = FALSE; /* TRUE iff graphics mode active */\r
+\r
+\r
+#ifndef NO_GRAPH\r
+# if DJE\r
+# include "svga1.c"\r
+# elif MSDOS\r
+# include "dosgraf1.c"\r
+# elif UNIX\r
+# include "x11graf1.c"\r
+# endif\r
+#endif\r
+\r
+\r
+\r
+void nonstandard(nrproc) /* Call (non)standard procedure */\r
+word nrproc;\r
+{\r
+\r
+ word am;\r
+ int cnt=0;\r
+ float r1, r2;\r
+ word ax,bx,cx,dx,i,t1,t2;\r
+ unsigned int v,p,h,l,r,c;\r
+ unsigned int Res_graph_X,Res_graph_Y;\r
+\r
+ switch ((int) nrproc)\r
+ {\r
+\r
+\r
+#ifndef NO_GRAPH\r
+# if DJE\r
+# include "svga2.c" \r
+# elif MSDOS\r
+# include "dosgraf2.c"\r
+# elif OS2\r
+# include "os2graf2.c"\r
+# elif UNIX\r
+# include "x11graf2.c"\r
+# else only /*INKEY defined */\r
+ case INKEY: \r
+ param[ 0 ].xword = inkey();\r
+ break;\r
+# endif\r
+#endif\r
+\r
+ default :\r
+ errsignal(RTEUNSTP);\r
+ }\r
+}\r
+\r
--- /dev/null
+/* Standard class IIUWGRAPH graphics primitives\r
+\r
+GRON:procedure(mode:integer) \r
+GROFF:procedure \r
+CLS:procedure \r
+POINT:procedure(x, y:integer) \r
+MOVE:procedure(x, y:integer) \r
+DRAW:procedure(x, y:integer) \r
+HFILL:procedure(x:integer) \r
+VFILL:procedure(y:integer) \r
+COLOR:procedure(color:integer) \r
+STYLE:procedure(style:integer) \r
+PATERN:procedure(p1, p2, p3, p4:integer) \r
+INTENS:procedure(intens:integer) \r
+PALLET:procedure(p:integer) \r
+BORDER:procedure(b:integer) \r
+VIDEO:procedure(buffer:arrayof integer) \r
+HPAGE:procedure(p, q, r:integer) \r
+NOCARD:function:integer \r
+PUSHXY:procedure \r
+POPXY:procedure \r
+INXPOS:function:integer \r
+INYPOS:function:integer \r
+INPIX:function(x, y:integer):integer \r
+GETMAP:function(x, y:integer):arrayof integer \r
+PUTMAP:procedure(arrayof integer) \r
+ORMAP:procedure(arrayof integer) \r
+XORMAP:procedure(arrayof integer) \r
+TRACK:procedure(x, y:integer) \r
+INKEY:function:integer \r
+HASCII:procedure(ch:integer) \r
+HFONT:procedure(off, seg:integer) \r
+HFONT8:procedure(output off, seg:integer) \r
+OUTSTRING:procedure(s:string) \r
+CIRB:procedure(x, y, r:integer, alpha, beta:real, b, i, p, q:integer)\r
+\r
+*/\r
+\r
+#define GRON 100\r
+#define GROFF 101\r
+#define CLS 102\r
+#define POINT 103\r
+#define MOVE 104\r
+#define DRAW 105\r
+#define HFILL 106\r
+#define VFILL 107\r
+#define COLOR 108\r
+#define STYLE 109\r
+#define PATERN 110\r
+#define INTENS 111\r
+#define PALETT 112\r
+#define BORDER 113\r
+#define VIDEO 114\r
+#define HPAGE 115\r
+#define NOCARD 116\r
+#define PUSHXY 117\r
+#define POPHXY 118\r
+#define INXPOS 119\r
+#define INYPOS 120\r
+#define INPIX 121\r
+#define GETMAP 122\r
+#define PUTMAP 123\r
+#define ORMAP 124\r
+#define XORMAP 125\r
+#define TRACK 126\r
+#define INKEY 127\r
+#define HASCII 128\r
+#define HFONT 129\r
+#define HFONT8 130\r
+#define OUTSTRING 131\r
+#define CIRB 132\r
+\r
+\r
+/* Standard class MOUSE mouse support\r
+\r
+INIT:function(output butttons:integer):boolean \r
+SHOWCURSOR:procedure \r
+HIDECURSOR:procedure \r
+STATUS:procedure(output x,y:integer, l,r,c:boolean) \r
+SETPOSITION:procedure(x, y:integer) \r
+GETPRESS:procedure(b:integer; output x,y,p:integer, l, r, c:boolean)\r
+GETRELEASE:procedure(b:integer; output x,y,p:integer, l, r, c:boolean)\r
+SETWINDOW:procedure(l, r, t, b:integer) \r
+DEFCURSOR:procedure(select, p, q:integer) \r
+GETMOVEMENT:procedure(output x, y:integer) \r
+SETSPEED:procedure(x, y:integer) \r
+SETMARGINS:procedure(l, r, t, b:integer) \r
+SETTHRESHOLD:procedure(t:integer) \r
+\r
+*/\r
+\r
+\r
+#define INIT 200\r
+#define SHOWCURSOR 201\r
+#define HIDECURSOR 202\r
+#define STATUS 203\r
+#define SETPOSITION 204\r
+#define GETPRESS 205\r
+#define GETRELEASE 206\r
+#define SETWINDOW 207\r
+#define DEFCURSOR 210\r
+#define GETMOVEMENT 211\r
+#define SETSPEED 215\r
+#define SETMARGINS 216\r
+#define SETTHRESHOLD 219\r
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+/* object management routines */\r
+\r
+\r
+void openrc(prot, virt, addr) /* Open new field for a record. */\r
+word prot;\r
+virtaddr *virt;\r
+word *addr;\r
+{\r
+ word t1;\r
+\r
+ request(prototype[ prot ]->appetite, &t1, addr);\r
+ M[ *addr+PROTNUM ] = prot;\r
+ virt->addr = t1;\r
+ virt->mark = M[ t1+1 ];\r
+} /* end openrc */\r
+\r
+\r
+void slopen(prot, sladr, ah, am)\r
+word prot;\r
+virtaddr *sladr;\r
+word *ah, *am;\r
+{\r
+ word t1, t2, virts;\r
+\r
+ virts = thisp->prochead+M[ thisp->prochead ]+VIRTSC;\r
+ storevirt(*sladr, virts); /* preserve for compactifier */\r
+ t1 = prototype[ prot ]->appetite;\r
+\r
+ request(t1, ah, am); /* open field */\r
+\r
+ M[ *am+PROTNUM ] = prot;\r
+ t1 = *am+t1; /* LWA+1 of object */\r
+ M[ t1+SL ] = M[ virts ]; /* prepare SL pointer */\r
+ M[ t1+SL+1 ] = M[ virts+1 ];\r
+ t2 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */\r
+ M[ t1+DL ] = t2;\r
+ M[ t1+DL+1 ] = M[ t2+1 ];\r
+\r
+} /* end slopen */\r
+\r
+\r
+void openobj(prot, ah, am)\r
+word prot;\r
+word *ah, *am;\r
+{\r
+ virtaddr v1;\r
+ word t1;\r
+\r
+ t1 = M[ display2+prototype[ prot ]->slprototype ];\r
+ v1.addr = t1; /* ah of SL */\r
+ v1.mark = M[ t1+1 ];\r
+ slopen(prot, &v1, ah, am);\r
+} /* end openobj */\r
+\r
+\r
+void newarry(low, up, kind, virt, am) /* Reserve room for array */\r
+word low, up, kind;\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ word ap;\r
+\r
+ switch ((int) kind)\r
+ {\r
+ case AINT : ap = APINT; break;\r
+ case AREAL : ap = APREAL; break;\r
+ case AVIRT : ap = APREF; break;\r
+ case APROCESS : ap = APINT; break;\r
+ }\r
+ low *= ap;\r
+ up *= ap;\r
+ if (up < low) errsignal(RTEILLAB); /* illegal array bounds */\r
+ low -= 3;\r
+ request(up-low+ap, &virt->addr, am);\r
+ M[ *am+1 ] = kind;\r
+ M[ *am+2 ] = low;\r
+ virt->mark = M[ virt->addr+1 ];\r
+} /* end newarry */\r
+\r
+\r
+void gkill(virt) /* Generalized killer */\r
+virtaddr *virt;\r
+{\r
+ word t1, t2, t3;\r
+ virtaddr vt;\r
+ protdescr *ptr;\r
+ message msg;\r
+\r
+ if (isprocess(virt)) /* kill remote process */\r
+ {\r
+ msg.control.type = KILLPR;\r
+ obj2mess( M, virt, &msg.control.receiver );\r
+ sendmsg( &msg);/* send remote kill request */\r
+ }\r
+ else\r
+ if (virt->mark == M[ virt->addr+1 ])\r
+ {\r
+ t1 = M[ virt->addr ]; /* am */\r
+ t2 = M[ t1+PROTNUM ];\r
+ if (t2 == AINT || t2 == AREAL || t2 == AVIRT)\r
+ disp(virt); /* simple kill for array */\r
+ else\r
+ if (t2 == FILEOBJECT)\r
+ { /* First close file if opened */\r
+ if (M[ t1+FSTAT ] != UNKNOWN)\r
+ if (fclose(MF(t1+FFILE))) errsignal(RTEILLIO);\r
+ /* Delete file if temporary */\r
+ if (M[ t1+FTEMP ] == LTRUE)\r
+ if (unlink(MN(t1+FNAME))) errsignal(RTEILLIO);\r
+ free(MN(t1+FNAME));\r
+ disp(virt);\r
+ }\r
+ else /* more than array or file */\r
+ {\r
+ ptr = prototype[ t2 ];\r
+ if (ptr->kind == RECORD)\r
+ disp(virt);\r
+ else\r
+ {\r
+ t3 = t1;\r
+ do\r
+ {\r
+ t3 += M[ t3 ]; /* LWA of object */\r
+ if (M[ t3+STATSL ] != 0) errsignal(RTEILLKL);\r
+ t3 = M[ t3+DL ]; /* next object in DL */\r
+ if (t3 == 0) errsignal(RTEILLKL);\r
+ t3 = M[ t3 ]; /* am of DL */\r
+ } while (t3 != t1);\r
+ do /* kill DL chain */\r
+ {\r
+ t3 += M[ t3 ];\r
+ loadvirt(vt, t3+DL);\r
+ disp(virt);\r
+ virt->addr = vt.addr;\r
+ virt->mark = vt.mark;\r
+ t3 = M[ virt->addr ];\r
+ } while (M[ virt->addr+1 ] == virt->mark);\r
+ }\r
+ }\r
+ }\r
+} /* end gkill */\r
+\r
+\r
+/* Copy object to a new object and locate it by fresh.\r
+ */\r
+\r
+void copy(old, fresh)\r
+virtaddr *old, *fresh;\r
+{\r
+ word t1, t2, t3, virts;\r
+ protdescr *ptr;\r
+ bool notrecord;\r
+\r
+ if (M[ old->addr+1 ] != old->mark)\r
+ { /* fine copy for none */\r
+ fresh->addr = 0;\r
+ fresh->mark = 0; /* note M[ 1 ] <> 0 */\r
+ }\r
+ else /* not none */\r
+ {\r
+ t1 = M[ old->addr ]; /* am of old */\r
+ notrecord = FALSE; /* assume it is a record */\r
+ t2 = M[ t1+PROTNUM ];\r
+ if (t2 != AINT && t2 != AREAL && t2 != AVIRT && t2 != FILEOBJECT)\r
+ { /* if not array nor file */\r
+ ptr = prototype[ t2 ];\r
+ if (ptr->kind != RECORD) /* our assumption was wrong */\r
+ {\r
+ notrecord = TRUE;\r
+ t3 = t1+M[ t1 ]+DL;\r
+ if (M[ t3 ] != old->addr || M[ t3+1 ] != old->mark)\r
+ errsignal(RTEILLCP); /* non-terminated object */\r
+ }\r
+ }\r
+ virts = thisp->prochead+M[ thisp->prochead ]+VIRTSC;\r
+ storevirt(*old, virts); /* preserve for compactification */\r
+ request(M[ t1 ], &t2, &t3); /* book field */\r
+ fresh->addr = t2; /* ah */\r
+ fresh->mark = M[ fresh->addr+1 ];\r
+ t1 = M[ M[ virts ] ];\r
+ for (t2 = 1; t2 < M[ t1 ]; t2++ )\r
+ M[ t3+t2 ] = M[ t1+t2 ];\r
+ if (notrecord)\r
+ {\r
+ storevirt(*fresh, t3+M[ t3 ]+DL); /* loop up DL */\r
+ M[ t3+M[ t3 ]+STATSL ] = 0; /* not in any SL chain */\r
+ }\r
+ }\r
+} /* end copy */\r
--- /dev/null
+ case INKEY :\r
+ param[ 0 ].xword = inkey(NULL);\r
+ break;\r
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include <assert.h>\r
+\r
+#define ldnode(addr) ((word) (addr & 0xFF))\r
+#define ldpix(addr) ((word) ((addr >> 8) & 0xFF))\r
+#define staddr(node, pix) ((word) ((pix << 8) | node))\r
+\r
+\r
+/*\r
+ These are converters from global to process pointers in memory\r
+ to global process pointers in message.\r
+ M denotes memory in which pair (pointer,object) exists or has to exist.\r
+ We want to create object denoting remote process instead of\r
+ dummy pointer without object.\r
+ The object will be like an arrayof integer of size 2.\r
+ arr[1..3] : arr[1]=node, arr[2]=pix.\r
+*/\r
+\r
+void obj2mess(M,obj,mess)\r
+ word *M;\r
+ virtaddr *obj;\r
+ procaddr *mess;\r
+{\r
+#ifdef OBJECTADDR\r
+ word am;\r
+ if( obj->mark != M[obj->addr+1] ){\r
+ mess->node=-1;\r
+ mess->pix =-1;\r
+ mess->mark=-1;\r
+ }else{\r
+ am=M[obj->addr];\r
+ mess->node=M[am+2];\r
+ mess->pix =M[am+3];\r
+ mess->mark=M[am+4];\r
+ }\r
+#else\r
+ mess->node=ldnode(obj->addr);\r
+ mess->pix =ldpix (obj->addr);\r
+ mess->mark=obj->mark;\r
+#endif\r
+}\r
+\r
+void mess2obj(p,mess,obj)\r
+ procdescr *p;\r
+ procaddr *mess;\r
+ virtaddr *obj;\r
+{\r
+\r
+#ifdef OBJECTADDR\r
+\r
+ word am;\r
+ word *currM=M;\r
+ word currpix=thispix;\r
+\r
+ extern int compactify_allowed;\r
+ compactify_allowed=0;\r
+\r
+ transfer(p-process);\r
+\r
+ hash_find(mess,obj);\r
+/*\r
+ newarry(1,4,APROCESS,obj,&am);\r
+ M[am+2]=mess->node;\r
+ M[am+3]=mess->pix;\r
+ M[am+4]=mess->mark;\r
+*/\r
+\r
+ transfer(currpix);\r
+ M=currM;\r
+\r
+ compactify_allowed=1;\r
+\r
+#else\r
+\r
+ obj->addr=staddr(mess->node,mess->pix);\r
+ obj->mark=mess->mark;\r
+\r
+#endif\r
+\r
+}\r
+\r
+\r
+\r
+bool isprocess(v) virtaddr *v; {\r
+\r
+#ifdef OBJECTADDR\r
+\r
+ word am=M[v->addr];\r
+/* assert(v->mark<=M[v->addr+1]);*/\r
+ if( v->mark!=M[v->addr+1] ) return 0;\r
+ else return ( M[am+1]==APROCESS );\r
+\r
+#else\r
+\r
+ return ( v->mark < 0 );\r
+\r
+#endif\r
+\r
+}\r
+\r
+\r
+\r
+#ifdef OBJECTADDR\r
+\r
+/* hash entry is a word pointing to dictionary or 0 if empty */\r
+\r
+#ifndef NO_PROTOTYPES\r
+static int hash_check_item( word, procaddr * );\r
+static void hash_new_item( virtaddr *, procaddr * );\r
+static int hash_mess( procaddr * );\r
+static int hash_2( int );\r
+#else\r
+static int hash_check_item();\r
+static void hash_new_item();\r
+#endif\r
+\r
+void hash_create(p,size) procdescr *p; int size;{\r
+ /* create hash table for p process */\r
+ int i;\r
+ if( p->hash!=NULL ) free( p->hash );\r
+ p->hash_size = size;\r
+ p->hash = mallocate(size);\r
+ if( p->hash==NULL ) errsignal(RTEMEMOV);\r
+ for( i=0; i<p->hash_size; i++ ) p->hash[i]=0;\r
+}\r
+\r
+\r
+/* find pointer in hash table, add if not exists */\r
+\r
+void hash_find(mess,obj) procaddr *mess; virtaddr *obj; {\r
+ int i,first,jump;\r
+ word am;\r
+ first=hash_mess( mess );\r
+ jump=hash_2(first);\r
+ for( i=first; thisp->hash[i]!=0; ){\r
+ if( hash_check_item(thisp->hash[i],mess) ){\r
+ obj->addr=thisp->hash[i];\r
+ obj->mark=M[thisp->hash[i]+1];\r
+ return;\r
+ }\r
+ i=(i+jump)%thisp->hash_size;\r
+ if( i==first ){\r
+ int *curhash=thisp->hash;\r
+ int cursize=thisp->hash_size;\r
+errsignal(RTEMEMOV); /* the rest is not debugged yet */\r
+ thisp->hash_size = cursize*3-1;\r
+ thisp->hash = mallocate(thisp->hash_size);\r
+ if( thisp->hash==NULL ) errsignal(RTEMEMOV);\r
+ for( i=0; i<thisp->hash_size; i++ ) thisp->hash[i]=0;\r
+ for( i=0; i<cursize; i++ ){\r
+ if( curhash[i]!=0 ){\r
+ virtaddr obj;\r
+ procaddr mess;\r
+ obj.addr=curhash[i];\r
+ obj.mark=M[curhash[i]+1];\r
+ obj2mess(M,&obj,&mess);\r
+ hash_set(&mess,curhash[i]);\r
+ }\r
+ }\r
+ hash_new_item( obj, mess );\r
+ hash_set( mess, obj->addr );\r
+ return;\r
+ }\r
+ }\r
+ /* not exists yet */\r
+ hash_new_item( obj, mess );\r
+ thisp->hash[i]=obj->addr;\r
+}\r
+\r
+void hash_set(mess,ah) procaddr *mess; word ah;{\r
+ int i,first,jump;\r
+ word am;\r
+ first=hash_mess( mess );\r
+ jump=hash_2(first);\r
+ for( i=first; thisp->hash[i]!=0; ){\r
+ assert( !hash_check_item(thisp->hash[i],mess) );\r
+ i=(i+jump)%thisp->hash_size;\r
+ if( i==first ) errsignal(RTEMEMOV);\r
+ }\r
+ /* not exists yet */\r
+ assert( thisp->hash[i]==0 );\r
+ thisp->hash[i]=ah;\r
+}\r
+\r
+#endif\r
+\r
+\r
+static int hash_check_item( ah, mess ) word ah; procaddr *mess; {\r
+ word am=M[ah];\r
+ return ( mess->node==M[am+2] && mess->pix==M[am+3] && mess->mark==M[am+4] );\r
+}\r
+\r
+static void hash_new_item( obj, mess ) virtaddr *obj; procaddr *mess; {\r
+ word am;\r
+ newarry(1,4,APROCESS,obj,&am);\r
+ M[am+2]=mess->node;\r
+ M[am+3]=mess->pix;\r
+ M[am+4]=mess->mark;\r
+}\r
+\r
+static int hash_mess( mess ) procaddr *mess;{\r
+ word hash=mess->pix;\r
+ hash *= abs( mess->mark );\r
+ hash += mess->node;\r
+ return hash % (thisp->hash_size);\r
+}\r
+\r
+static int hash_2( hash_1 ) int hash_1;{\r
+ return thisp->hash_size -2 - ( hash_1 % ( thisp->hash_size -2 ) );\r
+}\r
+\r
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#if DLINK\r
+# include "dlink.h"\r
+#elif TCPIP\r
+# include "tcpip.h"\r
+#endif\r
+\r
+#include <assert.h>\r
+\r
+\r
+/* Process management */\r
+\r
+procdescr process[ MAXPROCESS ]; /* process descriptor table */\r
+procdescr *thisp; /* pointer to current process descr */\r
+word thispix; /* current process index */\r
+queue ready; /* Round-Robin queue */\r
+bool network; /* TRUE if operating in network */\r
+message globmsgqueue[ MAXMSGQUEUE ]; /* queue of waiting messages */\r
+int msgready = 0; /* number of waiting messages */\r
+int msghead = 0, msgtail = 0; /* pointers to message queue */\r
+word ournode; /* this machine node number */\r
+word console; /* console node number */\r
+bool remote = FALSE; /* TRUE if remote node */\r
+bool reschedule = TRUE; /* TRUE if must re-schedule */\r
+\r
+\r
+\r
+#ifndef NO_PROTOTYPES\r
+static void ansprot(message *);\r
+static void localkill(message *);\r
+void transfer(word);\r
+static void backcreate(message *);\r
+static void createprocess(message *);\r
+static void localerror(message *);\r
+static void killprocess(word);\r
+static void mkglobal(word);\r
+word pix, ref;\r
+#else\r
+static void ansprot();\r
+static void localkill();\r
+void transfer();\r
+static void backcreate();\r
+static void createprocess();\r
+static void localerror();\r
+static void killprocess();\r
+static void mkglobal();\r
+#endif\r
+\r
+\r
+\r
+#if OS2\r
+PGINFOSEG ginf; /* pointer to Global Info Segment */\r
+#endif\r
+\r
+\r
+#if USE_ALARM\r
+# include <signal.h>\r
+# ifndef NO_PROTOTYPES\r
+ static void signal_catch( void );\r
+# else\r
+ static void signal_catch();\r
+# endif\r
+ static void signal_catch(){ reschedule=TRUE; }\r
+#endif\r
+\r
+\r
+void init_scheduler(){\r
+#if USE_ALARM\r
+ signal(SIGALRM,signal_catch);\r
+ alarm(1);\r
+#endif\r
+}\r
+\r
+void schedule() /* Choose next ready process to exec */\r
+{ /* STRONGLY machine dependent */\r
+#if USE_ALARM\r
+ if(reschedule){\r
+ alarm(0);\r
+ signal(SIGALRM,signal_catch);\r
+ alarm(1);\r
+#elif USE_CLOCK\r
+ static char last;\r
+ char c;\r
+ c = clock() >> 5; /* the most expensive method */\r
+ if (reschedule || c != last) /* context switch is needed */\r
+ {\r
+ last = c;\r
+#elif MSDOS && ( WORD_16BIT || DWORD_16BIT ) /* DOS real memory model */\r
+ static char last;\r
+ char c;\r
+ static char *clk = (char *) 0x0040006CL;\r
+ c = *clk >> 1;\r
+ if (reschedule || c != last) /* context switch is needed */\r
+ {\r
+ last = c;\r
+#elif OS2\r
+ static char last;\r
+ char c;\r
+ c = ginf->hundredths >> 3;\r
+ if (reschedule || c != last) /* context switch is needed */\r
+ {\r
+ last = c;\r
+#else\r
+#error Scheduler time counting method not implemented !\r
+#endif\r
+\r
+#if TCPIP\r
+ while (qempty(ready)){ /* wait for event if no processes */\r
+ tcpip_poll( -1 ); /* wait for message until arrives */\r
+ trapmsg();\r
+ }\r
+#else\r
+ while (qempty(ready)) /* wait for event if no processes */\r
+ trapmsg();\r
+#endif\r
+ ready = qrotate(ready); /* find another ready process */\r
+ transfer(pfront(ready)); /* transfer control to it */\r
+ reschedule = FALSE;\r
+ }\r
+}\r
+\r
+\r
+void transfer(pix) /* Context switch to another process */\r
+word pix;\r
+{\r
+ word apt;\r
+\r
+ if (pix == thispix) return; /* optimized for case of one process */\r
+\r
+ if( thisp != NULL ) /* previous process is alive */\r
+ {\r
+ thisp->ic = ic; /* store previous context */\r
+ thisp->c1 = c1;\r
+ thisp->c2 = c2;\r
+ }\r
+\r
+ thispix = pix; /* and load new context */\r
+ thisp = &process[ thispix ];\r
+ ic = thisp->ic;\r
+ c1 = thisp->c1;\r
+ c2 = thisp->c2;\r
+ M = thisp->M;\r
+ param = thisp->param;\r
+ apt = thisp->prochead+M[ thisp->prochead ];\r
+ display = apt+dispoff;\r
+ display2 = apt+disp2off;\r
+}\r
+\r
+\r
+void activate(pix) /* Resume process on this node */\r
+word pix;\r
+{\r
+ process[ pix ].status = EXECUTING; /* flag process as ready to execute */\r
+ ready = pinsert(ready, pix); /* insert into ready queue */\r
+ reschedule = TRUE; /* force context switch */\r
+# ifdef RPCDBG\r
+ fprintf(stderr,"activate process %d\n",pix);\r
+# endif\r
+}\r
+\r
+\r
+void passivate(newstatus) /* Passivate process */\r
+int newstatus;\r
+{\r
+ thisp->status = newstatus; /* change to some wait status */\r
+ ready = qremove(ready); /* remove from ready queue */\r
+ reschedule = TRUE; /* force context switch */\r
+# ifdef RPCDBG\r
+ fprintf(stderr,"passivate process %d to state %d\n",thispix,newstatus);\r
+# endif\r
+}\r
+\r
+\r
+/* Copy parameters from object to message or vice versa. */\r
+\r
+\r
+void moveparams(pix, am, msg, par1, dir)\r
+ word pix, am;\r
+ message *msg;\r
+ int par1, dir;\r
+{\r
+ protdescr *ptr;\r
+ procdescr *p;\r
+ word i, tpd, ap, pd, prim, offset;\r
+ char *cp;\r
+ bool cflag, convert;\r
+\r
+ p = &process[ pix ];\r
+ ptr = prototype[ p->M[ am+PROTNUM ] ];\r
+ cp = (char *) msg->params;\r
+\r
+ for (i = 0; i < ptr->lthparlist; i++) /* loop through parameters */\r
+ {\r
+\r
+ offset = M[ ptr->parlist+i ];\r
+ tpd = M[ ptr->pfdescr+i ]; /* type description of param */\r
+ pd = M[ tpd ];\r
+\r
+ if (par1 == PARIN)\r
+ cflag = ( pd==PARIN || pd==PARINOUT || pd==FORMFUNC || pd==FORMPROC );\r
+ else\r
+ cflag = ( pd==PAROUT || pd==PARINOUT );\r
+\r
+ if (cflag)\r
+ {\r
+ if (pd == FORMFUNC || pd == FORMPROC)\r
+ {\r
+ ap = APFMPROC;\r
+ convert = TRUE;\r
+ }\r
+ else\r
+ if (M[ M[ tpd+2 ] ] == CLASSTYPE)\r
+ {\r
+ ap = APREF;\r
+ convert = TRUE;\r
+ }\r
+ else\r
+ {\r
+ prim = M[ tpd+2 ]-ipradr;\r
+ ap = primapet[ prim ];\r
+ convert = (prim == 4 || prim == 5); /* process or coroutine */\r
+ }\r
+\r
+ ap *= sizeof(word); /* param appetite in bytes */\r
+\r
+ switch (dir) /* copy parameter in right direction */\r
+ {\r
+\r
+ case LOADPAR :\r
+\r
+ /* we always load parameters from OUR process */\r
+ assert(pix==thispix);\r
+\r
+ if (convert){\r
+ procaddr pa;\r
+ {\r
+ word ah=M[am+offset];\r
+ if( !isprocess((virtaddr*)(M+am+offset)) &&\r
+ M[ ah+1 ] == M[ am+offset+1 ]\r
+ )\r
+ if (prototype[ M[ M[ ah ]+PROTNUM ] ]->kind == PROCESS)\r
+ {\r
+ pa.node = ournode;\r
+ pa.pix = pix;\r
+ pa.mark = thisp->mark;\r
+ }\r
+ else\r
+ /*pat errsignal(RTENONGL); */ /* only process may be global */\r
+ /*pat*/ obj2mess(p->M,(virtaddr*)(p->M+am+offset),&pa);\r
+ else\r
+ obj2mess(M,(virtaddr*)(M+am+offset),&pa);\r
+ }\r
+/*\r
+ mkglobal(am+offset);\r
+ obj2mess(p->M,(virtaddr*)(p->M+am+offset),&pa);\r
+*/\r
+ moveblock((char *)&pa, cp, ap=sizeof(procaddr));\r
+ }else\r
+ moveblock((char *) &p->M[ am+offset ], cp, ap);\r
+ break;\r
+\r
+\r
+ case SAVEPAR :\r
+\r
+ if (convert){\r
+ procaddr pa;\r
+ ap=sizeof(procaddr);\r
+ moveblock(cp,(char *)&pa, ap);\r
+ mess2obj(p,&pa,(virtaddr*)(p->M+am+offset));\r
+ }else\r
+ moveblock(cp, (char *) &p->M[ am+offset ], ap);\r
+ break;\r
+\r
+ }\r
+\r
+ cp += ap;\r
+ assert(cp-msg->params <= sizeof(msg->params));\r
+ }\r
+ }\r
+}\r
+\r
+\r
+word getnode(am) /* Determine node number for process */\r
+word am;\r
+{\r
+ protdescr *ptr;\r
+ word p;\r
+ int i;\r
+\r
+ p = prototype[ M[ am+PROTNUM ] ]->preflist;\r
+ while (prototype[ M[ p ] ]->kind != PROCESS) p++;\r
+ ptr = prototype[ M[ p ] ];\r
+ if (ptr->lthpreflist == 1) i = 0;\r
+ else i = prototype[ M[ p-1 ] ]->lthparlist;\r
+ return (M[ am+M[ ptr->parlist+i ] ]);\r
+}\r
+\r
+\r
+void resume(virt) /* Perform RESUME instruction */\r
+virtaddr *virt;\r
+{\r
+ message msg;\r
+\r
+ if (isprocess(virt)) /* is it process realy ? */\r
+ {\r
+ msg.control.type = RESUME;\r
+ obj2mess( M, virt, &msg.control.receiver );\r
+ sendmsg( &msg); /* request remote resume */\r
+ }\r
+ else errsignal(RTEILLRS); /* illegal RESUME */\r
+}\r
+\r
+\r
+static void createprocess(msg) /* Create new process */\r
+message *msg;\r
+{\r
+ word i, prot;\r
+\r
+ for (i = 0; i < MAXPROCESS; i++) /* find unused process descr. */\r
+ if (!process[ i ].used && process[ i ].mark != -MAXMARKER) break;\r
+ if (i == MAXPROCESS) senderr(RTETMPRC, &(msg->control.sender) );\r
+ if (process[ i ].M == NULL) /* memory not allocated yet */\r
+ {\r
+ process[ i ].M = mallocate(memorysize+1);\r
+ if (process[ i ].M == NULL) senderr(RTEMEMOV, &msg->control.sender);\r
+ moveblock((char *) process[ 0 ].M, (char *) process[ i ].M,\r
+ freem * sizeof(word));\r
+ }\r
+ prot = msg->control.par; /* process prototype number */\r
+ initprocess(i, prot, &msg->control.sender);\r
+ moveparams(i, process[ i ].prochead, msg, PARIN, SAVEPAR);\r
+ process[ i ].status = GENERATING; /* execute process until RETURN */\r
+ ready = pinsert(ready, i);\r
+ reschedule = TRUE;\r
+}\r
+\r
+\r
+static void killprocess(pix) /* Release process descriptor */\r
+word pix;\r
+{\r
+ qfree(process[ pix ].msgqueue);\r
+ qfree(process[ pix ].rpcwait);\r
+ sfree(process[ pix ].rpcmask);\r
+\r
+ process[ pix ].used = FALSE; /* mark descriptor as unused */\r
+ process[ pix ].mark--; /* decrement marker */\r
+\r
+ if( pix == thispix )\r
+ {\r
+ thispix = -1;\r
+ thisp = NULL;\r
+ }\r
+}\r
+\r
+\r
+static void localkill(msg)\r
+message *msg;\r
+{\r
+ word pix;\r
+\r
+ pix = msg->control.receiver.pix;\r
+\r
+# if RPCDBG\r
+ fprintf( stderr, "kill process %d\n", pix );\r
+# endif\r
+\r
+ if (process[ pix ].mark == msg->control.receiver.mark) /* not none */\r
+ {\r
+ if (process[ pix ].status != STOPPED) /* is process suspended ? */\r
+ senderr(RTEILLKL, &msg->control.sender);\r
+ killprocess(pix);\r
+ }\r
+}\r
+\r
+\r
+void endprocess(status) /* Terminate current process */\r
+int status;\r
+{\r
+ int i;\r
+\r
+ passivate(STOPPED);\r
+# if RPCDBG\r
+ fprintf( stderr, "terminate process %d\n", thispix );\r
+# endif\r
+ killprocess(thispix);\r
+ if( ournode != console ) longjmp(contenv, 1);\r
+ for (i = 0; i < MAXPROCESS; i++)\r
+ if (process[ i ].used) longjmp(contenv, 1);\r
+ endrun(status);\r
+}\r
+\r
+\r
+static void backcreate(msg)\r
+message *msg;\r
+{\r
+ word pix, am;\r
+ procdescr *p;\r
+\r
+ pix = msg->control.receiver.pix;\r
+ p = &process[ pix ];\r
+\r
+ am = p->M[ p->template.addr ]; /* template physical address */\r
+ p->M[ temporary ] = am;\r
+ moveparams(pix, am, msg, PAROUT, SAVEPAR);\r
+\r
+ /*store new process address */\r
+ mess2obj(p,&(msg->control.sender),&(p->backobj));\r
+\r
+ activate(pix); /* end of waiting for NEW */\r
+}\r
+\r
+\r
+void senderr(exception, virt)\r
+int exception;\r
+procaddr *virt;\r
+{\r
+ message msg;\r
+\r
+ msg.control.type = ERRSIG;\r
+ msg.control.receiver=*virt;\r
+ msg.control.par = exception;\r
+ sendmsg(&msg); /* send error message */\r
+ longjmp(contenv, 1); /* continue from next instruction */\r
+}\r
+\r
+\r
+static void localerror(msg)\r
+message *msg;\r
+{\r
+ word pix;\r
+ int s;\r
+\r
+ pix = msg->control.receiver.pix;\r
+ s = process[ pix ].status;\r
+ if (process[ pix ].mark == msg->control.receiver.mark && s != STOPPED)\r
+ {\r
+ if (s == WAITFORNEW || s == WAITFORRPC) activate(pix);\r
+ while (pfront(ready) != pix)\r
+ ready = qrotate(ready);\r
+ transfer(pfront(ready));\r
+ errsignal(msg->control.par);\r
+ }\r
+}\r
+\r
+\r
+void askprot(virt) /* Ask for prototype of object */\r
+virtaddr *virt;\r
+{\r
+ word am;\r
+ message msg;\r
+\r
+ if (isprocess(virt)) /* send question to remote process */\r
+ {\r
+ obj2mess( M, virt, &msg.control.receiver );\r
+ msg.control.type = ASKPRO;\r
+ sendmsg( &msg );\r
+ passivate(WAITASKPRO);\r
+ }\r
+ else\r
+ {\r
+ if (member(virt, &am))\r
+ M[ temporary ] = M[ am+PROTNUM ];\r
+ else errsignal(RTEREFTN);\r
+ }\r
+}\r
+\r
+\r
+static void ansprot(msg) /* Answer with prototype of process */\r
+message *msg;\r
+{\r
+ message msg1;\r
+ word pix;\r
+\r
+ pix = msg->control.receiver.pix;\r
+ if (process[ pix ].mark == msg->control.receiver.mark) /* not none */\r
+ {\r
+ msg1.control.receiver = msg->control.sender;\r
+ msg1.control.type = PROACK;\r
+ msg1.control.par = process[ pix ].prot;\r
+ sendmsg( &msg1 );\r
+ }\r
+ else senderr(RTEREFTN, &msg->control.sender);\r
+}\r
+\r
+\r
+/* Message send/receive handling : */\r
+\r
+void msginterrupt(msg) /* Receive message interrupt handler */\r
+ message *msg;\r
+{\r
+ moveblock((char *)msg, (char *)&globmsgqueue[ msgtail ],\r
+ (word) sizeof(message));\r
+ msgtail = (msgtail+1) % MAXMSGQUEUE;\r
+ msgready++;\r
+#if DLINK\r
+ if (msgready < MAXMSGQUEUE-1) /* leave one place for own message */\r
+ net_attention();\r
+#endif\r
+}\r
+\r
+\r
+void sendmsg(msg) /* Send message via net */\r
+message *msg;\r
+{\r
+ msg->control.sender.node = ournode;\r
+ msg->control.sender.pix = thispix;\r
+ msg->control.sender.mark = thisp->mark;\r
+ if(\r
+ msg->control.receiver.node == ournode\r
+ ||\r
+ msg->control.receiver.node == 0\r
+ )\r
+ /* simulate receive message interrupt */\r
+ {\r
+#if DLINK\r
+ net_ignore(); /* disable attention */\r
+#endif\r
+ msg->control.receiver.node == ournode;\r
+ msginterrupt(msg); /* call directly interrupt handler */\r
+ }\r
+ else\r
+ {\r
+#if DLINK\r
+ if (!network) errsignal(RTEINVND); /* send message by net */\r
+ while (net_send((int) msg->control.receiver.node, msg)) ;\r
+#elif TCPIP\r
+ if (!network) errsignal(RTEINVND); /* send message by net */\r
+ tcpip_send( msg );\r
+#else\r
+ errsignal(RTEINVND);\r
+#endif\r
+ }\r
+}\r
+\r
+\r
+void trapmsg() /* Check for waiting message */\r
+{\r
+ message *msg;\r
+ procdescr *p;\r
+ word pix;\r
+\r
+#if TCPIP\r
+ /* check for message on TCPIP socket & move to queue */\r
+ if (msgready < MAXMSGQUEUE-1) /* there is place for new message */\r
+ if( tcpip_poll( 0 ) ) /* check for message */\r
+ if ( tcpip_recv( globmsgqueue + msgtail ) ){\r
+ msgtail = (msgtail+1) % MAXMSGQUEUE;\r
+ msgready++;\r
+ }\r
+#endif\r
+\r
+ if (msgready > 0) /* at least one message is waiting */\r
+ {\r
+#if DLINK\r
+ net_ignore(); /* disable attention for a moment */\r
+#endif\r
+ msg = &globmsgqueue[ msghead ]; /* get first message from queue */\r
+ msghead = (msghead+1) % MAXMSGQUEUE;\r
+ switch(msg->control.type)\r
+ {\r
+ case ERRSIG :\r
+ localerror(msg);\r
+ break;\r
+\r
+ case RESUME :\r
+ pix = msg->control.receiver.pix;\r
+ if (process[ pix ].mark != msg->control.receiver.mark)\r
+ senderr(RTEREFTN, &msg->control.sender);\r
+ if (process[ pix ].status != STOPPED)\r
+ senderr(RTEILLRS, &msg->control.sender);\r
+ activate(pix);\r
+ break;\r
+\r
+ case CREATE :\r
+ createprocess(msg);\r
+ break;\r
+\r
+ case CREACK :\r
+ backcreate(msg);\r
+ break;\r
+\r
+ case KILLPR :\r
+ localkill(msg);\r
+ break;\r
+\r
+ case RPCALL :\r
+ rpc1(msg);\r
+ break;\r
+\r
+ case RPCACK :\r
+ rpcend(msg);\r
+ break;\r
+\r
+ case ASKPRO :\r
+ ansprot(msg);\r
+ break;\r
+\r
+ case PROACK :\r
+ pix = msg->control.receiver.pix;\r
+ p = &process[ pix ];\r
+ p->M[ temporary ] = msg->control.par;\r
+ activate(pix);\r
+ break;\r
+\r
+ default :\r
+ fprintf( stderr, " Invalid message\n" );\r
+ senderr(RTESYSER, &msg->control.sender);\r
+ }\r
+ msgready--;\r
+#if DLINK\r
+ if (msgready < MAXMSGQUEUE-1) /* leave one place for own message */\r
+ net_attention(); /* attention back on */\r
+#endif\r
+ }\r
+}\r
+\r
+\r
+static void mkglobal(ref) /* Make global a process reference */\r
+ word ref;\r
+{\r
+ word ah;\r
+ ah = M[ ref ];\r
+ if (!isprocess((virtaddr*)(M+ref)) && M[ ah+1 ] == M[ ref+1 ])\r
+ if (prototype[ M[ M[ ah ]+PROTNUM ] ]->kind == PROCESS)\r
+ {\r
+ virtaddr va;\r
+ procaddr pa;\r
+ pa.node = ournode;\r
+ pa.pix = pix;\r
+ pa.mark = thisp->mark;\r
+ mess2obj(thisp,&pa,&va);\r
+ M[ ref ] = va.addr;\r
+ M[ ref+1 ] = va.mark;\r
+#ifdef RPCDBG\r
+fprintf(stderr,"mkglobal REAL (thisp=%d) isprocess:node=%d pix=%d mark=%d\n",thispix,pa.node,pa.pix,pa.mark);fflush(stderr);\r
+#endif\r
+ }\r
+ else errsignal(RTENONGL); /* only process may be global */\r
+}\r
+\r
+\r
+\r
+/*\r
+void show_m( char *s, message *msg ){\r
+ char *n;\r
+ switch(msg->control.type)\r
+ {\r
+ case ERRSIG : n = "ERRSIG"; break;\r
+ case RESUME : n = "RESUME"; break;\r
+ case CREATE : n = "CREATE"; break;\r
+ case CREACK : n = "CREACK"; break;\r
+ case KILLPR : n = "KILLPR"; break;\r
+ case RPCALL : n = "RPCALL"; break;\r
+ case RPCACK : n = "RPCACK"; break;\r
+ case ASKPRO : n = "ASKPRO"; break;\r
+ case PROACK : n = "PROACK"; break;\r
+ default : n = "??????"; break;\r
+ }\r
+ printf( "message %s type %s from %d:%d:%d to %d:%d:%d\n",\r
+ s, n,\r
+ msg->control.sender.node,\r
+ msg->control.sender.pix,\r
+ msg->control.sender.mark,\r
+ msg->control.receiver.node,\r
+ msg->control.receiver.pix,\r
+ msg->control.receiver.mark\r
+ );\r
+ fflush( stdout );\r
+}\r
+*/\r
+\r
--- /dev/null
+#include "queue.h"\r
+\r
+\r
+/* Process management definitions : */\r
+\r
+#define MAXPROCESS 64 /* maximum number of processes on one node */\r
+#define MAXMSGQUEUE 16 /* maximum number of waiting messages */\r
+\r
+#if DLINK\r
+#define MSGLENGTH 80 /* message length defined by D-Link driver */\r
+#elif TCPIP\r
+#define MSGLENGTH 256 /* message length defined by me (PS) */\r
+#else\r
+#define MSGLENGTH 256 /* message length defined by me (PS) */\r
+#endif\r
+\r
+\r
+/* Process state : */\r
+\r
+#define GENERATING 0 /* during generation of process object */\r
+#define STOPPED 1 /* non-active process (suspended by STOP) */\r
+#define EXECUTING 2 /* active process (ready to execute) */\r
+#define WAITFORNEW 3 /* waiting for NEW of another process */\r
+#define WAITFORRPC 4 /* waiting for remote procedure call */\r
+#define ACCEPTING 5 /* during execution of ACCEPT statement */\r
+#define WAITASKPRO 6 /* waiting for process prototype */\r
+\r
+/* Process descriptor : */\r
+\r
+typedef struct\r
+{\r
+ bool used; /* TRUE if in use by some process */\r
+ word mark; /* process mark for proper detecting of none */\r
+ int status; /* process state */\r
+ word prot; /* process prototype number */\r
+ memory M; /* pointer to memory array */\r
+ union value param[ MAXPARAM ];\r
+ word ic; /* instruction counter */\r
+ word trlnumber; /* trace line number */\r
+ word lower; /* first word of object area */\r
+ word upper; /* last word in memory */\r
+ word lastused; /* last word used by objects */\r
+ word lastitem; /* first word used by dictionary */\r
+ word freeitem; /* head of free dictionary item list */\r
+ word headk; /* head of killed object list for size > 2 */\r
+ word headk2; /* head of killed object list for size = 2 */\r
+ word prochead; /* am of process object */\r
+ virtaddr procref; /* process object virtual address */\r
+ virtaddr template; /* remote process or procedure template */\r
+ word c1, c2; /* pointers to current object */\r
+ virtaddr backobj; /* adress of object just left */\r
+ word blck1, blck2; /* used for LBLOCK1, LBLOCK2, LBLOCK3 */\r
+ queue msgqueue; /* queue of messages for this process */\r
+ queue rpcwait; /* queue of disabled RPC messages */\r
+ stack rpcmask; /* stack of set of enabled remote procedures */\r
+ bool force_compactification; /* next allocate will forace compact... */\r
+ word *hash; /* table of pointers to processes in process */\r
+ word hash_size;\r
+} procdescr;\r
+\r
+\r
+/* Message type : */\r
+\r
+#define ERRSIG 0 /* error signal */\r
+#define RESUME 1 /* resume request */\r
+#define CREATE 2 /* create new process request */\r
+#define CREACK 3 /* create process acknowledge */\r
+#define KILLPR 4 /* kill process */\r
+#define RPCALL 5 /* remote procedure call request */\r
+#define RPCACK 6 /* remote procedure return */\r
+#define ASKPRO 7 /* ask for process prototype */\r
+#define PROACK 8 /* answer with process prototype */\r
+\r
+typedef struct {\r
+ word node;\r
+ word pix;\r
+ word mark;\r
+} procaddr;\r
+\r
+struct ctrlmsg\r
+{\r
+ procaddr sender; /* address of the sender and */\r
+ procaddr receiver; /* receiver of the message */\r
+ int type; /* message type */\r
+ int par; /* prototype or error signal number */\r
+};\r
+\r
+#define MAXPROCPAR (MSGLENGTH-sizeof(struct ctrlmsg))\r
+\r
+typedef struct\r
+{\r
+ struct ctrlmsg control;\r
+ char params[ MAXPROCPAR ];\r
+} message;\r
+\r
+/* Direction of copying of parameters (for moveparams()) : */\r
+\r
+#define LOADPAR 0\r
+#define SAVEPAR 1\r
+\r
+typedef char *mask;\r
+\r
+extern procdescr process[]; /* process descriptor table */\r
+extern procdescr *thisp; /* pointer to current process descriptor */\r
+extern word thispix; /* current process index */\r
+extern queue ready; /* Round-Robin queue of ready processes */\r
+extern bool network; /* TRUE if operating in D-Link network */\r
+extern message globmsgqueue[]; /* queue of waiting messages */\r
+extern int msgready; /* number of waiting messages */\r
+extern int msghead, msgtail; /* pointers to message queue */\r
+extern word ournode; /* this machine node number */\r
+extern word console; /* console node number */\r
+extern bool remote; /* TRUE if remote node */\r
+extern bool reschedule; /* TRUE if rescheduling is mandatory */\r
+\r
+#if OS2\r
+extern PGINFOSEG ginf; /* pointer to Global Info Segment */\r
+#endif\r
+\r
+\r
+\r
+#ifndef NO_PROTOTYPES\r
+void obj2mess(word *,virtaddr *,procaddr*);\r
+void mess2obj(procdescr *,procaddr *,virtaddr*);\r
+bool isprocess(virtaddr *);\r
+void hash_find(procaddr *,virtaddr *);\r
+void hash_create(procdescr *,int);\r
+void hash_set(procaddr *,word);\r
+#else\r
+void obj2mess();\r
+void mess2obj();\r
+bool isprocess();\r
+void hash_find();\r
+void hash_create();\r
+void hash_set();\r
+#endif\r
+\r
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+\r
+/* Queue management */\r
+/* Single linked circular lists with queue represented as pointer to rear */\r
+\r
+queue qinit() /* Initialize empty queue */\r
+{\r
+ return (NULL);\r
+} /* end qinit */\r
+\r
+\r
+stack push(q, e) /* Insert element into the queue */\r
+stack q;\r
+selem e;\r
+{\r
+ stack p;\r
+\r
+ p = (stack) ballocate(sizeof(struct queuelem));\r
+ if (p == NULL) errsignal(RTEMEMOV);\r
+ p->elem = e;\r
+ if (q == NULL)\r
+ {\r
+ p->next = p; /* the lonely element of the queue */\r
+ q = p;\r
+ }\r
+ else\r
+ {\r
+ p->next = q->next; /* insert at rear */\r
+ q->next = p;\r
+ }\r
+ return(q);\r
+} /* end push */\r
+\r
+\r
+qelem qfront(q) /* Get first element of the queue */\r
+queue q;\r
+{\r
+ if (qempty(q)){\r
+ fprintf( stderr, "getting first element from empty queue\n");\r
+ errsignal(RTESYSER);\r
+ }\r
+ return (q->next->elem);\r
+} /* end qfront */\r
+\r
+\r
+queue qremove(q) /* Remove front element from the queue */\r
+queue q;\r
+{\r
+ queue p;\r
+\r
+ if (qempty(q)){\r
+ fprintf( stderr, "removing first element from empty queue\n");\r
+ errsignal(RTESYSER);\r
+ }\r
+ p = q->next;\r
+ q->next = q->next->next;\r
+ if (p == q) q = NULL; /* removing last element of the queue */\r
+ free(p);\r
+ return(q);\r
+} /* end qremove */\r
+\r
+\r
+queue qdelete(q, e) /* Delete arbitrary element */\r
+queue q;\r
+qelem e;\r
+{\r
+ queue p, r, s;\r
+\r
+ if (qempty(q)) return(q);\r
+ r = q;\r
+ p = r->next;\r
+ while (p->elem != e)\r
+ {\r
+ if (p == q) return(q);\r
+ r = p;\r
+ p = p->next;\r
+ }\r
+ r->next = p->next;\r
+ if (r == p) s = NULL;\r
+ else\r
+ if (p == q) s = r;\r
+ else s = q;\r
+ free(p);\r
+ return(s);\r
+} /* end qdelete */\r
+\r
+\r
+queue qrotate(q) /* Remove front and insert at rear */\r
+queue q;\r
+{\r
+ if (qempty(q)){\r
+ fprintf( stderr, "rotating empty queue\n");\r
+ errsignal(RTESYSER);\r
+ }\r
+ return (q->next);\r
+} /* end qrotate */\r
+\r
+\r
+void qfree(q)\r
+queue q;\r
+{\r
+ while (!qempty(q))\r
+ {\r
+ free(qfront(q));\r
+ q = qremove(q);\r
+ }\r
+} /* end qfree */\r
--- /dev/null
+/* Header for queue management module */\r
+\r
+typedef lword qelem;\r
+typedef qelem selem;\r
+struct queuelem { qelem elem;\r
+ struct queuelem *next;\r
+ };\r
+typedef struct queuelem *queue;\r
+typedef queue stack;\r
+\r
+#ifndef NO_PROTOTYPES\r
+queue qinit(void);\r
+stack push(stack,selem);\r
+qelem qfront(queue);\r
+queue qremove(queue);\r
+queue qdelete(queue,qelem);\r
+queue qrotate(queue);\r
+void qfree(queue);\r
+#else\r
+queue qinit();\r
+stack push();\r
+qelem qfront();\r
+queue qremove();\r
+queue qdelete();\r
+queue qrotate();\r
+void qfree();\r
+#endif\r
+\r
+#define qinsert(q, e) (((queue) push((stack) (q), (selem) (e)))->next)\r
+#define qempty(q) ((q) == NULL)\r
+#define pinsert(q, p) (qinsert(q, (qelem) (p)))\r
+#define pfront(q) ((word) qfront(q))\r
+#define minsert(q, m) (qinsert(q, (qelem) (m)))\r
+#define mfront(q) ((message *) qfront(q))\r
+#define mdelete(q, m) (qdelete(q, (qelem) (m)))\r
+#define mpush(q, m) ((queue) push((stack) q, (selem) m))\r
+#define sfree(s) qfree((queue) s)\r
+#define sinit qinit\r
+#define pop(s) ((stack) qremove((queue) s))\r
+#define top(s) ((selem) qfront((queue) s))\r
--- /dev/null
+@echo off\r
+:begin\r
+if "%1" == "" goto :end\r
+echo %1\r
+del %1\r
+shift\r
+goto :begin\r
+:end\r
+\r
--- /dev/null
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+\r
+#ifndef NO_PROTOTYPES\r
+static bool isenabled(word,word);\r
+static bool rpcready(word);\r
+static void bitaccess(word,word,int *,char *);\r
+static void dupmask(word);\r
+#else\r
+static bool isenabled();\r
+static bool rpcready();\r
+static void bitaccess();\r
+static void dupmask();\r
+#endif\r
+\r
+\r
+void rpc1(msg) /* preprocess RPC request */\r
+message *msg;\r
+{\r
+ word pix, prot;\r
+ procdescr *p;\r
+ message *msg1;\r
+\r
+ pix = msg->control.receiver.pix;\r
+ p = &process[ pix ];\r
+ if (p->mark != msg->control.receiver.mark)\r
+ senderr(RTEREFTN, &msg->control.sender);\r
+ msg1 = (message *) ballocate(sizeof(message));\r
+ if (msg1 == NULL) errsignal(RTEMEMOV);\r
+ moveblock((char *) msg, (char *) msg1, (word) sizeof(message));\r
+ prot = msg->control.par;\r
+ if (isenabled(pix, prot))\r
+ {\r
+ p->msgqueue = minsert(p->msgqueue, msg1);\r
+ if (p->status == ACCEPTING) activate(pix);\r
+ }\r
+ else p->rpcwait = minsert(p->rpcwait, msg1);\r
+}\r
+\r
+\r
+void rpc2()\r
+{\r
+ if (rpcready(thispix)) rpc3();\r
+}\r
+\r
+\r
+void rpc3() /* Actual remote procedure call */\r
+{\r
+ word prot, ah, am;\r
+ message *msg;\r
+\r
+ msg = mfront(thisp->msgqueue); /* remove first RPC message (enabled) */\r
+# ifdef RPCDBG\r
+ fprintf(\r
+ stderr, "rpc(thisp=%d) from: node=%d, pix=%d, mark=%d\n",\r
+ thispix,\r
+ msg->control.sender.node,\r
+ msg->control.sender.pix,\r
+ msg->control.sender.mark\r
+ );\r
+# endif\r
+ thisp->msgqueue = qremove(thisp->msgqueue);\r
+ pushmask(thispix); /* disable all procedures */\r
+ prot = msg->control.par;\r
+\r
+ slopen(prot, &thisp->procref, &ah, &am); /* open procedure object */\r
+\r
+ {\r
+ virtaddr v;\r
+ mess2obj( thisp, &(msg->control.sender), &v );\r
+ storevirt( v, am+M[ am ]+RPCDL ); /* set up remote DL */\r
+ }\r
+\r
+ moveparams(thispix, am, msg, PARIN, SAVEPAR);\r
+\r
+ go(ah, am); /* transfer control to procedure */\r
+\r
+ free(msg);\r
+\r
+}\r
+\r
+\r
+void rpcend(msg) /* After return from RPC */\r
+message *msg;\r
+{\r
+ word pix, am;\r
+ procdescr *p;\r
+\r
+ pix = msg->control.receiver.pix;\r
+#ifdef RPCDBG\r
+fprintf(stderr,"activate after rpc(thisp=%d)\n",pix);fflush(stderr);\r
+#endif\r
+ p = &process[ pix ];\r
+ am = p->M[ temporary ]; /* template physical address */\r
+ moveparams(pix, am, msg, PAROUT, SAVEPAR);\r
+ activate(pix); /* resume process waiting for RPC */\r
+}\r
+\r
+\r
+static void bitaccess(pix, prot, bytenr, bitmask)\r
+word pix, prot;\r
+int *bytenr;\r
+char *bitmask;\r
+{\r
+ int bitnr;\r
+\r
+ bitnr = prot-prototype[ process[ pix ].prot ]->maskbase;\r
+ *bytenr = bitnr / 8;\r
+ *bitmask = (char)(unsigned char)( 1 << (bitnr % 8) );\r
+}\r
+\r
+\r
+void enable(pix, prot) /* Enable remote procedure */\r
+word pix, prot;\r
+{\r
+ mask m;\r
+ int bytenr;\r
+ char bitmask;\r
+\r
+ m = top(process[ pix ].rpcmask);\r
+ bitaccess(pix, prot, &bytenr, &bitmask);\r
+ m[ bytenr ] |= bitmask;\r
+}\r
+\r
+\r
+void disable(pix, prot) /* Disable remote procedure */\r
+word pix, prot;\r
+{\r
+ mask m;\r
+ int bytenr;\r
+ char bitmask;\r
+\r
+ m = top(process[ pix ].rpcmask);\r
+ bitaccess(pix, prot, &bytenr, &bitmask);\r
+ m[ bytenr ] &= ~ bitmask;\r
+}\r
+\r
+\r
+static bool isenabled(pix, prot) /* Check if RPC allowed */\r
+word pix, prot;\r
+{\r
+ mask m;\r
+ int bytenr;\r
+ char bitmask;\r
+\r
+ m = top(process[ pix ].rpcmask);\r
+ bitaccess(pix, prot, &bytenr, &bitmask);\r
+ return( m[ bytenr ] & bitmask );\r
+}\r
+\r
+\r
+void pushmask(pix) /* Push empty RPC mask onto stack */\r
+word pix;\r
+{\r
+ mask m;\r
+ int i, size;\r
+\r
+ size = prototype[ process[ pix ].prot ]->masksize;\r
+ m = (mask) ballocate(size);\r
+ if (m == NULL) errsignal(RTEMEMOV);\r
+ for (i = 0; i < size; i++ ) m[ i ] = '\0'; /* disable all */\r
+ process[ pix ].rpcmask = push(process[ pix ].rpcmask, m);\r
+}\r
+\r
+\r
+static void dupmask(pix) /* Duplicate RPC mask from stack top */\r
+word pix;\r
+{\r
+ mask m;\r
+ int size;\r
+\r
+ size = prototype[ process[ pix ].prot ]->masksize;\r
+ m = (mask) ballocate(size);\r
+ if (m == NULL) errsignal(RTEMEMOV);\r
+ moveblock(top(process[ pix ].rpcmask), m, (word) size);\r
+ process[ pix ].rpcmask = push(process[ pix ].rpcmask, m);\r
+}\r
+\r
+\r
+void popmask(pix) /* Pop RPC mask from stack (restore) */\r
+word pix;\r
+{\r
+ mask m;\r
+\r
+ m = top(process[ pix ].rpcmask);\r
+ process[ pix ].rpcmask = pop(process[ pix ].rpcmask);\r
+ free((char *) m);\r
+}\r
+\r
+\r
+void evaluaterpc(pix) /* Check if any waiting RPC is enabled */\r
+word pix;\r
+{\r
+ queue q;\r
+ message *msg;\r
+\r
+ q = process[ pix ].rpcwait;\r
+ if (!qempty(q))\r
+ {\r
+ do\r
+ {\r
+ msg = mfront(q);\r
+ if (isenabled(pix, msg->control.par))\r
+ {\r
+ process[ pix ].msgqueue = mpush(process[ pix ].msgqueue, msg);\r
+ process[ pix ].rpcwait = mdelete(process[ pix ].rpcwait, msg);\r
+ return;\r
+ }\r
+ q = qrotate(q);\r
+ } while (q != process[ pix ].rpcwait);\r
+ }\r
+}\r
+\r
+\r
+void rpc_accept(length) /* Accept remote procedure call */\r
+word length;\r
+{\r
+ int i;\r
+\r
+ dupmask(thispix);\r
+ for (i = 0; i < length; i++)\r
+ enable(thispix, virtprot(M[ ic++ ]));\r
+ evaluaterpc(thispix);\r
+ if (!rpcready(thispix))\r
+ passivate(ACCEPTING);\r
+}\r
+\r
+\r
+static bool rpcready(pix)\r
+word pix;\r
+{\r
+ procdescr *p;\r
+ message *msg;\r
+ word prot;\r
+\r
+ p = &process[ pix ];\r
+ while (!qempty(p->msgqueue))\r
+ {\r
+ msg = mfront(p->msgqueue);\r
+ prot = msg->control.par;\r
+ if (isenabled(pix, prot)) return(TRUE);\r
+ p->msgqueue = qremove(p->msgqueue);\r
+ p->rpcwait = minsert(p->rpcwait, msg);\r
+ }\r
+ return(FALSE);\r
+}\r
+\r
+\r
+word virtprot(prot) /* Get actual prototype for virtual */\r
+word prot;\r
+{\r
+ bool sign;\r
+ word virtnr;\r
+\r
+ sign = (prot < 0);\r
+ prot = absolute(prot);\r
+ virtnr = prototype[ prot ]->virtnumber;\r
+ if (virtnr != -1) prot = M[ prototype[ thisp->prot ]->virtlist+virtnr ];\r
+ if (sign) return(-prot); else return(prot);\r
+}\r
+\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+\r
+/* Initialize memory structures for objects, main object and a few goodies\r
+ * more.\r
+ */\r
+\r
+void runsys()\r
+{\r
+ word apt, i;\r
+ procaddr father;\r
+\r
+ for (i = 0; i < MAXPROCESS; i++ ) /* initialize process descriptors */\r
+ {\r
+ process[ i ].used = FALSE; /* not used */\r
+ process[ i ].mark = -1; /* initial mark for processes */\r
+ process[ i ].M = NULL; /* memory not allocated */\r
+ process[ i ].hash = NULL;\r
+ }\r
+ process[ 0 ].M = M; /* always contains code */\r
+ dispoff = VIRTSC-(lastprot+1); /* DISPLAY offset in process object */\r
+ disp2off = dispoff-(lastprot+1); /* indirect DISPLAY offset */\r
+ ready = qinit(); /* initialize Round-Robin queue */\r
+ ranset(); /* init pseudo-random no. generator */\r
+\r
+#if OS2\r
+ {\r
+ SEL gsel, lsel;\r
+ DosGetInfoSeg(&gsel, &lsel);\r
+ ginf = MAKEPGINFOSEG(gsel);\r
+ }\r
+#endif\r
+\r
+ if (!remote) /* create main process */\r
+ {\r
+ father.node = 0; /* dummy DL for generated process */\r
+ father.pix = 0;\r
+ father.mark = 0;\r
+ thispix = 0; /* current process index */\r
+ thisp = &process[ thispix ]; /* current process descr pointer */\r
+ initprocess((word) 0, (word) MAINBLOCK, &father);\r
+ mainprog = thisp->prochead; /* am of main */\r
+ c1 = thisp->c1; /* pointers to current object */\r
+ c2 = thisp->c2;\r
+ ic = thisp->ic; /* instruction counter */\r
+ param = thisp->param; /* parameter vector */\r
+ apt = mainprog+M[ mainprog ]; /* LWA+1 of main */\r
+ display = apt+dispoff; /* DISPLAY in main */\r
+ display2 = apt+disp2off; /* indirect DISPLAY in main */\r
+ mnoff = 2; /* offset of variable mainprog */\r
+ storevirt(thisp->procref, mainprog+mnoff); /* init variable main */\r
+ M[ apt+STATSL ]++; /* flag main included in SL chain */\r
+ thisp->status = STOPPED;\r
+ activate(thispix); /* activate main process */\r
+ }\r
+ else /* remote */\r
+ {\r
+ thispix = 1; /* a dirty trick: set junk current */\r
+ thisp = &process[ thispix ]; /* process for first transfer() */\r
+ } /* (must save 'context' somewhere) */\r
+#if DLINK\r
+ net_attention();\r
+#endif\r
+}\r
+\r
+\r
+void initprocess(pix, prot, father) /* Initialize process descriptor */\r
+word pix, prot;\r
+procaddr *father;\r
+{\r
+ procdescr *p;\r
+ protdescr *ptr;\r
+ word i, j, ah, am, apt;\r
+\r
+#ifdef RPCDBG\r
+fprintf(stderr,"new process(n,p,m) (%d,%d,%d)",0,pix,process[pix].mark);\r
+fprintf(stderr," from (%d,%d,%d)\n",father->node,father->pix,father->mark);\r
+#endif\r
+\r
+ p = &process[ pix ];\r
+#ifdef OBJECTADDR\r
+ hash_create(p,119);\r
+#endif\r
+ p->used = TRUE; /* process descriptor is used */\r
+ p->prot = prot; /* prototype number */\r
+ p->freeitem = 0; /* null list of free dictionary items */\r
+ p->upper = memorysize-1; /* highest memory address */\r
+ p->lower = freem; /* lowest address for data */\r
+ p->headk = p->lower; /* head of killed objects list */\r
+ p->M[ p->headk ] = MAXAPPT; /* maximum appetite sentinel */\r
+ p->headk2 = 0;\r
+ ah = p->upper-1; /* dict. item for process itself */\r
+ p->lastitem = ah; /* first word used by dictionary */\r
+ ptr = prototype[ prot ];\r
+ if (p->upper - p->lower - ptr->appetite < 512)\r
+ if (prot == MAINBLOCK)\r
+ abend("Memory size too small (use /m option)\n");\r
+ else errsignal(RTEMEMOV);\r
+\r
+ /* generate process object */\r
+ p->lastused = p->lower+ptr->appetite;\r
+ am = p->lower+1;\r
+ p->M[ am ] = ptr->appetite;\r
+ p->M[ am+PROTNUM ] = prot;\r
+ for (i = PROTNUM+1; i < ptr->appetite; i++)\r
+ p->M[ am+i ] = 0;\r
+ p->M[ ah ] = am;\r
+ p->M[ ah+1 ] = 0;\r
+ p->prochead = am;\r
+ p->procref.addr = ah;\r
+ p->procref.mark = 0;\r
+ p->c1 = am; /* initialize current object ptrs */\r
+ p->c2 = am+ptr->span;\r
+ apt = am+ptr->appetite;\r
+ p->M[ apt+CHD ] = ah; /* initialize coroutine head ptr */\r
+ p->M[ apt+CHD+1 ] = 0;\r
+ p->M[ apt+SL ] = DUMMY; /* dummy SL for process */\r
+ p->M[ 1 ] = 1; /* absolute none */\r
+ for (i = MAINBLOCK; i <= lastprot; i++) /* initialize DISPLAY */\r
+ p->M[ apt+dispoff+i ] = 0;\r
+ p->M[ apt+disp2off+MAINBLOCK ] = DUMMY; /* dummmy entry for MAIN */\r
+ j = ptr->preflist; /* set DISPLAY entries for process */\r
+\r
+ for (i = j+ptr->lthpreflist-1; i >= j; i--)\r
+ {\r
+ p->M[ apt+dispoff+M[ i ] ] = am; /* physical address */\r
+ p->M[ apt+disp2off+M[ i ] ] = ah; /* indirect address */\r
+ }\r
+\r
+ {\r
+ virtaddr v;\r
+ mess2obj( p, father, &v );\r
+ p->M[ apt+DL ] = v.addr;\r
+ p->M[ apt+DL+1 ] = v.mark;\r
+ }\r
+\r
+ p->msgqueue = qinit();\r
+ p->rpcwait = qinit();\r
+ p->rpcmask = sinit();\r
+ pushmask(pix); /* initialy all RPCs are disabled */\r
+ p->trlnumber = 0; /* trace line number */\r
+ i = ptr->preflist; /* search for executable prefix */\r
+ while (prototype[ p->M[ i ] ]->kind == RECORD) i++;\r
+ p->ic = prototype[ M[ i ] ]->codeaddr; /* first instruction address */\r
+#if RPCDBG\r
+fprintf(stderr,"first instruction address %d of new process %d\n", p->ic, pix );\r
+#endif\r
+ p->force_compactification=FALSE;\r
+}\r
+\r
+\r
+bool member(virt, am)\r
+virtaddr *virt;\r
+word *am;\r
+{\r
+ *am = M[ virt->addr ];\r
+ return (virt->mark == M[ virt->addr+1 ]);\r
+}\r
+\r
+\r
+void update(am, ah) /* Update DISPLAY */\r
+word am, ah;\r
+{\r
+ word t1, t2, t3, t4, t5, t6;\r
+ protdescr *ptr;\r
+\r
+ while (TRUE)\r
+ {\r
+ t1 = am+M[ am ];\r
+ M[ t1+STATSL ]++; /* flag object included in SL */\r
+ ptr = prototype[ M[ am+PROTNUM ] ];\r
+ t2 = ptr->preflist;\r
+ t3 = t2+ptr->lthpreflist-1;\r
+ for (t4 = t3; t4 >= t2; t4-- )\r
+ {\r
+ t6 = M[ t4 ];\r
+ t5 = display+t6;\r
+ if (M[ t5 ] == 0) /* entry to be updated */\r
+ {\r
+ M[ t5 ] = am;\r
+ M[ display2+t6 ] = ah;\r
+ }\r
+ }\r
+ ah = M[ t1+SL ];\r
+ if (ah == DUMMY) break;\r
+ if (M[ ah+1 ] != M[ t1+SL+1 ]) errsignal(RTESLCOF);\r
+ am = M[ ah ];\r
+ }\r
+}\r
+\r
+\r
+void loosen() /* Loosen DISPLAY */\r
+{\r
+ word t1, t2, t3;\r
+ protdescr *ptr;\r
+\r
+ t1 = c1;\r
+ while (TRUE)\r
+ {\r
+ ptr = prototype[ M[ t1+PROTNUM ] ];\r
+ t2 = ptr->preflist;\r
+ for (t3 = t2+ptr->lthpreflist-1; t3 >= t2; t3-- )\r
+ M[ display+M[ t3 ] ] = 0;\r
+ t3 = t1+M[ t1 ];\r
+ M[ t3+STATSL ]--; /* flag object removed from SL */\r
+ t1 = M[ t3+SL ]; /* ah of SL */\r
+ if (t1 == DUMMY) break; /* still not main */\r
+ t1 = M[ t1 ]; /* am of SL */\r
+ }\r
+}\r
+\r
+\r
+static int tracecnt = 0; /* To count trace messages in line */\r
+\r
+void trace(lineno) /* Trace the program if debug mode */\r
+word lineno;\r
+{\r
+ thisp->trlnumber = lineno;\r
+ if (debug && lineno > 0)\r
+ {\r
+ tracecnt++;\r
+ if (tracecnt == MAXTRACNT) /* change line */\r
+ {\r
+ tracecnt = 0;\r
+ fprintf(tracefile, "\n");\r
+ }\r
+ fprintf(tracefile, "%6ld", (long) lineno);\r
+ }\r
+ trapmsg(); /* check for waiting message */\r
+ rpc2(); /* check for RPC message */\r
+}\r
+\r
+\r
+void endrun(status)\r
+int status;\r
+{\r
+ fflush(stdout);\r
+\r
+ fprintf(stderr, "\n\nEnd of LOGLAN-82 program execution\n");fflush(stderr);\r
+#if DLINK\r
+ net_logoff();\r
+#endif\r
+ if (debug) fclose(tracefile);\r
+ exit(status);\r
+}\r
+\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include <assert.h>\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include "sock.h"\r
+#include "tcpip.h"\r
+\r
+\r
+#ifndef FD_SET\r
+#define BITS_PER_INT 32\r
+#define FD_SET(f,fds) (fds)->fds_bits[(f)/BITS_PER_INT]|=(1<<((f)%BITS_PER_INT))\r
+#define FD_ZERO(fds) { (fds)->fds_bits[0]=0; (fds)->fds_bits[1]=0; }\r
+#endif\r
+\r
+\r
+\r
+#ifdef BZERO\r
+void bzero( buf, size ) char *buf; int size; {\r
+ while( --size >= 0 )\r
+ buf[size]='\0';\r
+}\r
+void bcopy( from, to, size ) char *from,*to; int size; {\r
+ while( --size >= 0 )\r
+ to[size]=from[size];\r
+}\r
+#endif\r
+\r
+\r
+\r
+#ifndef INADDR_NONE\r
+#define INADDR_NONE 0xffffffffUL\r
+#endif\r
+\r
+\r
+#define init_addr(addr) \\r
+ bzero((char *)&(addr),sizeof(addr)); \\r
+ (addr).sin_family=AF_INET; \\r
+ (addr).sin_port=htons(0); \\r
+ (addr).sin_addr.s_addr=htonl(INADDR_ANY);\r
+\r
+\r
+\r
+int host_addr( host, buf ) char *host; struct sockaddr_in *buf; {\r
+\r
+ long inaddr;\r
+ int port;\r
+ struct hostent *hp;\r
+ char *addr;\r
+\r
+ init_addr( *buf );\r
+\r
+ addr = strchr( host, ':' );\r
+ if( addr == NULL )\r
+ port = PORT;\r
+ else\r
+ {\r
+ *addr = '\0';\r
+ addr++;\r
+ if( *addr!='\0' )\r
+ if( sscanf( addr, "%d", &port ) != 1 ) usage();\r
+ else;\r
+ else\r
+ port = PORT;\r
+ }\r
+\r
+ buf->sin_port = htons( port );\r
+\r
+ /* try dotted-decimal address */\r
+ if( (inaddr = inet_addr(host)) == INADDR_NONE ){\r
+ if( (hp = gethostbyname(host)) == NULL )\r
+ return -1;\r
+ assert( hp->h_length == sizeof( inaddr ) );\r
+ bcopy( (char *)( hp->h_addr ), (char *)&( buf->sin_addr ), sizeof( inaddr ) );\r
+ }\r
+\r
+ return 0;\r
+}\r
+\r
+\r
+\r
+int sock_open( socket_type, protocol, service, port )\r
+ char *service;\r
+ char *protocol;\r
+ int socket_type,port;\r
+{\r
+ int fd;\r
+ struct sockaddr_in my_addr;\r
+ struct servent *sp;\r
+ struct protoent *pp;\r
+\r
+ init_addr( my_addr );\r
+\r
+ if( (pp=getprotobyname(protocol)) == NULL )\r
+ return -1;\r
+\r
+ if( service != NULL ){\r
+ if( (sp=getservbyname(service,protocol)) == NULL )\r
+ return -1;\r
+ my_addr.sin_port = sp->s_port;\r
+ }\r
+\r
+ if( port>0 )\r
+ my_addr.sin_port = htons( port );\r
+\r
+ if( (fd = socket(AF_INET,socket_type,pp->p_proto)) < 0 )\r
+ return -1;\r
+\r
+ if( bind( fd, (struct sockaddr *)&my_addr, sizeof(my_addr) ) < 0 )\r
+ return -1;\r
+\r
+ return fd;\r
+}\r
+\r
+\r
+\r
+int sock_poll( sock, ms ) int sock,ms; {\r
+ struct timeval timeout;\r
+ fd_set rd_fds;\r
+ int nfds;\r
+ FD_ZERO(&rd_fds);\r
+ timeout.tv_sec = ms/1000;\r
+ timeout.tv_usec = (ms%1000)*1000;\r
+ if( sock>=0 ) /* sock==-1 means we only sleep */\r
+ FD_SET(sock,&rd_fds);\r
+ if( ms >= 0 )\r
+ nfds = select(sock+1,&rd_fds,NULL,NULL,&timeout);\r
+ else\r
+ nfds = select(sock+1,&rd_fds,NULL,NULL,NULL);\r
+ errno=0;\r
+ return ( nfds == 1 );\r
+}\r
+\r
+\r
+\r
+static int send_wait_time = 0;\r
+\r
+void set_send_delay( ms ) int ms; { /* set delay to miliseconds */\r
+ send_wait_time = ms;\r
+}\r
+\r
+int sock_send( sock, buf, size, addr )\r
+ int sock,size;\r
+ void *buf;\r
+ struct sockaddr_in *addr;\r
+{\r
+ int namelen = sizeof( *addr );\r
+ if( send_wait_time > 0 )\r
+ sock_poll( -1, send_wait_time );\r
+ if( sendto( sock, buf, size, 0, addr, namelen ) <= 0 ){\r
+ fprintf(\r
+ stderr,\r
+ "socket send to %s:%d\n",\r
+ inet_ntoa( addr->sin_addr ),\r
+ (int)ntohs( addr->sin_port )\r
+ );\r
+ perror("send error");\r
+ abend("send error");\r
+ }\r
+ return 0;\r
+}\r
+\r
+int sock_recv( sock, buf, size, addr )\r
+ int sock,size;\r
+ void *buf;\r
+ struct sockaddr_in *addr;\r
+{\r
+ int recv_size;\r
+ int namelen = sizeof( struct sockaddr_in );\r
+ if( ( recv_size = recvfrom( sock, buf, size, 0, addr, &namelen ) ) < 0 ){\r
+ perror("recv");\r
+ return -1;\r
+ }\r
+ if( namelen != sizeof( struct sockaddr_in ) ){\r
+ printf("str sockaddr_in %d namelen %d\n",sizeof(struct sockaddr_in),namelen);\r
+ printf("addr %s\n",inet_ntoa(addr->sin_addr));\r
+ abend("strenge message");\r
+ }\r
+ return recv_size;\r
+}\r
+\r
+\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#ifndef __SOCK_H__\r
+#define __SOCK_H__\r
+\r
+#include <stdio.h>\r
+#include <string.h>\r
+\r
+#ifndef NO_PROTOTYPES\r
+#include <stdlib.h>\r
+#endif\r
+\r
+#include <sys/types.h>\r
+#include <signal.h>\r
+#include <sys/socket.h>\r
+#include <sys/time.h>\r
+#include <netinet/in.h>\r
+#include <netdb.h>\r
+#include <errno.h>\r
+\r
+\r
+#ifndef NO_PROTOTYPES\r
+int host_addr( char * /* host name */, struct sockaddr_in * );\r
+int sock_open( int socket_type, char *protocol, char *service, int port );\r
+int sock_recv( int sock, void *buf, int size, struct sockaddr_in *addr );\r
+int sock_send( int sock, void *buf, int size, struct sockaddr_in *addr );\r
+void set_send_delay ( int miliseconds );\r
+int sock_poll( int sock, int miliseconds );\r
+ /* sock == -1 -> equivalent of sleep */\r
+ /* miliseconds < 0 -> waits indefinitely */\r
+#else\r
+int host_addr();\r
+int sock_open();\r
+int sock_srv_recv();\r
+int sock_srv_send();\r
+void set_send_delay();\r
+int sock_poll();\r
+#endif\r
+\r
+\r
+#ifndef NO_PROTOTYPES\r
+int sock_crc_recv( int sock, void *m, int size, struct sockaddr_in *addr );\r
+int sock_crc_send( int sock, void *m, int size, struct sockaddr_in *addr );\r
+#else\r
+int sock_srv_crc_recv();\r
+int sock_srv_crc_send();\r
+#endif\r
+\r
+#endif\r
+\r
+\r
+\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include <math.h>\r
+#include <time.h>\r
+\r
+/* Call standard procedure */\r
+\r
+void standard(nrproc) /* Process call to a standard proc. */\r
+word nrproc;\r
+{\r
+ word t1, t2, t3, t5, t6;\r
+ double r;\r
+ bool absent;\r
+ int ch, n;\r
+ long tim;\r
+ char *cp;\r
+ FILE *fp;\r
+ \r
+ absent = FALSE;\r
+\r
+#ifdef TRACE\r
+ fprintf( stderr, "standard procedure %d\n", nrproc );\r
+#endif\r
+\r
+ switch ((int) nrproc)\r
+ {\r
+ case 1 : /* new array */\r
+ newarry(param[ 1 ].xword, param[ 0 ].xword, param[ 2 ].xword,\r
+ ¶m[ 3 ].xvirt, ¶m[ 4 ].xword);\r
+ break;\r
+\r
+ case 2 : /* rew */\r
+ case 3 : /* avf */\r
+ case 4 : /* bsf */\r
+ case 5 : /* weo */\r
+ case 6 : /* putrec */\r
+ case 7 : /* getrec */\r
+ case 8 : /* ass */\r
+ case 9 : /* assin */\r
+ case 10 : /* assout */\r
+ absent = TRUE;\r
+ break;\r
+ \r
+ case 11 : /* unpack:function(s:string):arrayof char */\r
+ t1 = strings+param[ 0 ].xword+1;\r
+ t6 = M[ t1-1 ]; /* length of the string */\r
+ if (t6 > 0) /* string not null */\r
+ {\r
+ newarry((word) 1, t6, (word) AINT, ¶m[ 1 ].xvirt, &t5);\r
+ t5 += 3;\r
+ cp = (char *) &M[ t1 ];\r
+ while (t6-- > 0) M[ t5++ ] = *cp++;\r
+ }\r
+ else /* null string */\r
+ {\r
+ param[ 1 ].xvirt.addr = 0;\r
+ param[ 1 ].xvirt.mark = 0;\r
+ }\r
+ break;\r
+ \r
+ case 12 : /* random:function:real */\r
+ param[ 0 ].xreal = (real)prandom();\r
+ break;\r
+ \r
+ case 13 : /* time:function:integer */\r
+ time(&tim);\r
+ param[ 0 ].xword = tim;\r
+ break;\r
+ \r
+ case 14 : /* sqrt:function(x:real):real */\r
+ param[ 1 ].xreal = (real)sqrt((double) param[ 0 ].xreal);\r
+ break;\r
+\r
+ case 15 : /* entier:function(x:real):integer */\r
+ param[ 1 ].xword = entier((double) param[ 0 ].xreal);\r
+ break;\r
+ \r
+ case 16 : /* round:function(x:real):integer */\r
+ param[ 1 ].xword = entier((double) (param[ 0 ].xreal+0.5));\r
+ break;\r
+ \r
+ case 17 : /* unused */\r
+ case 18 : /* intrinsic procedure */\r
+ absent = TRUE;\r
+ break;\r
+\r
+ case 19 : /* imin:function(x, y:integer):integer */\r
+ param[ 2 ].xword = min(param[ 0 ].xword, param[ 1 ].xword);\r
+ break;\r
+\r
+ case 20 : /* imax:function(x, y:integer):integer */\r
+ param[ 2 ].xword = max(param[ 0 ].xword, param[ 1 ].xword);\r
+ break;\r
+\r
+ case 21 : /* imin3:function(x, y, z:integer):integer */\r
+ t1 = min(param[ 0 ].xword, param[ 1 ].xword);\r
+ param[ 3 ].xword = min(t1, param[ 2 ].xword);\r
+ break;\r
+\r
+ case 22 : /* imax3:function(x, y, z:integer):integer */\r
+ t1 = max(param[ 0 ].xword, param[ 1 ].xword);\r
+ param[ 3 ].xword = max(t1, param[ 2 ].xword);\r
+ break;\r
+\r
+ case 23 : /* sin:function(x:real):real */\r
+ param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal);\r
+ break;\r
+\r
+ case 24 : /* cos:function(x:real):real */\r
+ param[ 1 ].xreal = (real)cos((double) param[ 0 ].xreal);\r
+ break;\r
+\r
+ case 25 : /* tan:function(x:real):real */\r
+ r = cos((double) param[ 0 ].xreal);\r
+ if (r == 0.0) errsignal(RTEDIVBZ);\r
+ param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal) / r;\r
+ break;\r
+ \r
+ case 26 : /* exp:function(x:real):real */\r
+ param[ 1 ].xreal = (real)exp((double) param[ 0 ].xreal);\r
+ break;\r
+\r
+ case 27 : /* ln:function(x:real):real */\r
+ param[ 1 ].xreal = (real)log((double) param[ 0 ].xreal);\r
+ break;\r
+\r
+ case 28 : /* atan:function(x:real):real */\r
+ param[ 1 ].xreal = (real)atan((double) param[ 0 ].xreal);\r
+ break;\r
+\r
+ case 29 : /* endrun:procedure */\r
+ endrun(0);\r
+ break;\r
+\r
+ case 30 : /* ranset:procedure(x:real) */\r
+ ranset();\r
+ break;\r
+ \r
+ case 31 : /* clock */\r
+ case 32 : /* option */\r
+ case 33 : /* lock */\r
+ case 34 : /* unlock */\r
+ case 35 : /* sched, boy! */\r
+ case 36 : /* date */\r
+ case 37 : /* execpar */\r
+ case 38 : /* test&set */\r
+ absent = TRUE;\r
+ break;\r
+\r
+ case 39 : /* eof */\r
+ param[ 0 ].xbool = lbool(testeof(stdin)); \r
+ break;\r
+ \r
+ case 40 : /* eof(f) */\r
+ loadfile((word) UNKNOWN, &t1, &t2, &fp);\r
+ t3 = M[ t2+FSTAT ];\r
+ if (t3 == READING || t3 == UPDATING)\r
+ param[ 0 ].xbool = lbool(testeof(fp));\r
+ else errsignal(RTEILLIO);\r
+ break;\r
+ \r
+ case 41 : /* readln */\r
+ readln(stdin);\r
+ break;\r
+ \r
+ case 42 : /* readln(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ readln(fp);\r
+ break;\r
+ \r
+ case 43 : /* readchar */\r
+ param[ 0 ].xword = getc(stdin);\r
+ break;\r
+ \r
+ case 44 : /* readchar(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);\r
+ param[ 0 ].xword = ch;\r
+ break;\r
+ \r
+ case 45 : /* readint */\r
+ param[ 0 ].xword = readint(stdin);\r
+ break;\r
+ \r
+ case 46 : /* readint(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ param[ 0 ].xword = readint(fp);\r
+ break;\r
+ \r
+ case 47 : /* readreal */\r
+ param[ 0 ].xreal = (real)readreal(stdin);\r
+ break;\r
+\r
+ case 48 : /* readreal(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ param[ 0 ].xreal = (real)readreal(fp);\r
+ break;\r
+\r
+ case 49 : /* getchar(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != CHARF) errsignal(RTEILLIO);\r
+ if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);\r
+ param[ 0 ].xword = ch;\r
+ break;\r
+ \r
+ case 50 : /* getint(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != INTF) errsignal(RTEILLIO);\r
+ n = fread((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);\r
+ if (n != 1) errsignal(RTEIOERR);\r
+ break;\r
+ \r
+ case 51 : /* getreal(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != REALF) errsignal(RTEILLIO);\r
+ n = fread((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);\r
+ if (n != 1) errsignal(RTEIOERR);\r
+ break;\r
+\r
+ case 52 : /* getobject(f) */\r
+ absent = TRUE;\r
+ break;\r
+\r
+ case 53 : /* putchar(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != CHARF) errsignal(RTEILLIO);\r
+ ch = (char) param[ 0 ].xword;\r
+ if (putc(ch, fp) == EOF) errsignal(RTEIOERR);\r
+ break;\r
+ \r
+ case 54 : /* putint(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != INTF) errsignal(RTEILLIO);\r
+ n = fwrite((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);\r
+ if (n != 1) errsignal(RTEIOERR);\r
+ break;\r
+ \r
+ case 55 : /* putreal(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != REALF) errsignal(RTEILLIO);\r
+ n = fwrite((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);\r
+ if (n != 1) errsignal(RTEIOERR);\r
+ break;\r
+ \r
+ case 56 : /* putobject(f) */\r
+ case 57 : /* putstring(f) */\r
+ absent = TRUE;\r
+ break;\r
+\r
+ case 58 : /* writeln(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ if (putc('\n', fp) == EOF) errsignal(RTEIOERR);\r
+ if (fflush(fp)) errsignal(RTEIOERR);\r
+ break;\r
+ \r
+ case 59 : /* writeln */\r
+ putc('\n', stdout);\r
+ break;\r
+ \r
+ case 60 : /* writechar(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ if (putc((char) param[ 0 ].xword, fp) == EOF) \r
+ errsignal(RTEIOERR);\r
+ break;\r
+ \r
+ case 61 : /* writechar */\r
+ putc((char) param[ 0 ].xword, stdout);\r
+ break;\r
+ \r
+ case 62 : /* writeint(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ writeint(param[ 0 ].xword, param[ 1 ].xword, fp);\r
+ break;\r
+ \r
+ case 63 : /* writeint */\r
+ writeint(param[ 0 ].xword, param[ 1 ].xword, stdout);\r
+ break;\r
+ \r
+ case 64 : /* writereal0(f) */\r
+ case 66 : /* writereal1(f) */\r
+ case 68 : /* writereal2(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ writereal((double) param[ 0 ].xreal, param[ 1 ].xword,\r
+ param[ 2 ].xword, fp);\r
+ break;\r
+ \r
+ case 65 : /* writereal0 */\r
+ case 67 : /* writereal1 */\r
+ case 69 : /* writereal2 */\r
+ writereal((double) param[ 0 ].xreal, param[ 1 ].xword,\r
+ param[ 2 ].xword, stdout);\r
+ break;\r
+ \r
+ case 70 : /* writestring(f) */\r
+ loadfile((word) WRITING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ writestring(param[ 0 ].xword, param[ 1 ].xword, fp);\r
+ break;\r
+ \r
+ case 71 : /* writestring */\r
+ writestring(param[ 0 ].xword, param[ 1 ].xword, stdout);\r
+ break;\r
+\r
+ case 72 : /* open temporary file */\r
+ genfileobj(TRUE , param[ 1 ].xword, tempfilename(),\r
+ ¶m[ 0 ].xvirt, &t1);\r
+ break;\r
+\r
+ case 73 : /* open external file */\r
+ genfileobj(FALSE, param[ 1 ].xword, asciiz(¶m[ 2 ].xvirt),\r
+ ¶m[ 0 ].xvirt, &t1);\r
+ break;\r
+ \r
+ case 74 : /* eoln */\r
+ param[ 0 ].xbool = lbool(testeoln(stdin)); \r
+ break;\r
+ \r
+ case 75 : /* eoln(f) */\r
+ loadfile((word) READING, &t1, &t2, &fp);\r
+ if (t1 != TEXTF) errsignal(RTEILLIO);\r
+ param[ 0 ].xbool = lbool(testeoln(fp)); \r
+ break;\r
+ \r
+ case 76 : /* this coroutine */\r
+ loadvirt(param[ 0 ].xvirt,\r
+ thisp->prochead+M[ thisp->prochead ]+CHD);\r
+ break;\r
+\r
+ case 77 : /* this process */\r
+ {\r
+ procaddr p;\r
+ virtaddr v;\r
+ p.node = ournode;\r
+ p.pix = thispix;\r
+ p.mark = thisp->mark;\r
+ mess2obj( thisp, &p, &v );\r
+ param[ 0 ].xvirt = v;\r
+ }\r
+ break;\r
+\r
+ case 78 : /* reset:procedure(f:file) */\r
+ if (member(¶m[ 0 ].xvirt, &t2))\r
+ reset(t2);\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case 79 : /* rewrite:procedure(f:file) */\r
+ if (member(¶m[ 0 ].xvirt, &t2))\r
+ rewrite(t2);\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+ case 80 : /* unlink:procedure(f:file) */\r
+ delete(¶m[ 0 ].xvirt);\r
+ break;\r
+\r
+ case 81 : /* seek:procedure(f:file, offset, base:integer) */\r
+ storevirt(param[ 0 ].xvirt, currfile);\r
+ loadfile((word) UPDATING, &t1, &t2, &fp);\r
+ if (t1 != DIRECT) errsignal(RTEILLIO);\r
+ if (fseek(fp, (long) param[ 1 ].xword, (int) param[ 2 ].xword))\r
+ errsignal(RTEIOERR);\r
+ break;\r
+\r
+ case 82 : /* getrec(f, a, n) */\r
+ loadfile((word) UPDATING, &t1, &t2, &fp);\r
+ if (t1 != DIRECT) errsignal(RTEILLIO);\r
+ param[ 1 ].xword = directio(\r
+ ¶m[ 0 ].xvirt,\r
+ param[ 1 ].xword,\r
+ (int (*)())fread,\r
+ fp\r
+ );\r
+ break;\r
+ \r
+ case 83 : /* putrec(f, a, n) */\r
+ loadfile((word) UPDATING, &t1, &t2, &fp);\r
+ if (t1 != DIRECT) errsignal(RTEILLIO);\r
+ param[ 1 ].xword = directio(\r
+ ¶m[ 0 ].xvirt,\r
+ param[ 1 ].xword,\r
+ (int (*)())fwrite,\r
+ fp\r
+ );\r
+ break;\r
+ \r
+ case 84 : /* position:function(f:file):real */\r
+ storevirt(param[ 0 ].xvirt, currfile);\r
+ loadfile((word) UPDATING, &t1, &t2, &fp);\r
+ if (t1 != DIRECT) errsignal(RTEILLIO);\r
+ param[ 1 ].xword =(int) ftell(fp);\r
+ break;\r
+\r
+ case 98 : /* memavail:function:integer */\r
+ param[ 0 ].xword = memavail();\r
+ break;\r
+\r
+ case 99 : /* exec:function(c:arrayof char):integer */\r
+ cp = asciiz(¶m[ 0 ].xvirt);\r
+ param[ 1 ].xword = system(cp);\r
+ free(cp);\r
+ break;\r
+ \r
+ default :\r
+ nonstandard(nrproc);\r
+ break;\r
+ }\r
+# if TRACE\r
+ fflush( stdout );\r
+# endif\r
+ if (absent) errsignal(RTEUNSTP);\r
+}\r
+\r
+\r
--- /dev/null
+#include <grx.h>\r
+#include <mousex.h>\r
+#include "eventque.h"\r
+\r
+int Couleur,Fond,CurX,CurY;\r
+int Coul[4],Pal;\r
+int MOUSE_PRESENT =0;\r
+\r
+MouseEvent *evt;\r
+EventQueue *q;\r
+char *ret;\r
+\r
+void mousenit(int mo,int ke)\r
+{\r
+ MouseEventMode(1);\r
+ MouseInit();\r
+ evt=(MouseEvent *)malloc(sizeof(MouseEvent));\r
+ MouseEventEnable(ke,mo);\r
+ MOUSE_PRESENT=1;\r
+}\r
+\r
+void mouseshow(void)\r
+{\r
+ MouseDisplayCursor();\r
+}\r
+\r
+void mousehide(void)\r
+{\r
+ MouseEraseCursor();\r
+}\r
+\r
+int mouse(v,p,h,l,r,c)\r
+unsigned int *v,*p,*h,*l,*r,*c;\r
+{\r
+ EventRecord e;\r
+ MouseEvent *ev1;\r
+ short result=0;\r
+\r
+ *v=0,*p=0,*h=0,*l=0,*r=0,*c=0;\r
+\r
+ ev1=evt;\r
+ evt=(MouseEvent *)calloc(1,sizeof(MouseEvent));\r
+ MouseGetEvent(M_EVENT | M_POLL | M_NOPAINT,evt);\r
+ *p=evt->kbstat; *l=evt->key;\r
+ *h=evt->x; *v=evt->y;\r
+ *r=evt->flags; *c=evt->buttons;\r
+ if(ev1->kbstat!=evt->kbstat || ev1->key!=evt->key || ev1->x!=evt->x ||\r
+ ev1->y!=evt->y || ev1->flags!=evt->flags || ev1->buttons!=evt->buttons)\r
+ result=1;\r
+ free(ev1);\r
+ return(result);\r
+}\r
+\r
+void afficheinteger(int x,int y,int valeur,int cf,int ce)\r
+{\r
+ char tst[20];\r
+\r
+ sprintf(tst,"%i",valeur);\r
+ GrTextXY(x,y,tst,ce,cf);\r
+ CurX+=8*strlen(tst);\r
+ if(CurX>GrMaxX())\r
+ {\r
+ CurX=0;\r
+ CurY+=14;\r
+ }\r
+}\r
+\r
+\r
+\r
+int readcara(int posx,int posy,int col_f,int col_e)\r
+{\r
+ char *t="_\0";\r
+ int a;\r
+\r
+ while(!kbhit())\r
+ {\r
+ GrHLine(posx,posx+8,posy+13,col_f);\r
+ delay(200);\r
+ GrHLine(posx,posx+8,posy+13,col_e);\r
+ delay(100);\r
+ }\r
+ GrHLine(posx,posx+8,posy+13,col_f);\r
+ a=getxkey();\r
+ if(!a)\r
+ return(getxkey());\r
+ else\r
+ return(a);\r
+}\r
+\r
+\r
+void beep(void)\r
+{\r
+ printf("%c\n",7);\r
+}\r
+\r
+int affiche_chaine(int x,int y,int lg,char *txtd,char *txtf,int av,int *ll,int col_e,int col_f)\r
+{\r
+ int larg;\r
+ char cara[2];\r
+\r
+\r
+ if(!av)\r
+ {\r
+ for(sprintf(&cara[0],"%c\0",*txtf),larg=0;txtf>=txtd;txtf--) /* affiche arriere */\r
+ {\r
+ GrTextXY(x+lg-larg,y,&cara[0],col_e,col_f);\r
+ larg+=8;\r
+ sprintf(&cara[0],"%c\0",*(txtf-1));\r
+ if((lg-larg-8)<0)\r
+ break;\r
+ }\r
+ if(txtf<=txtd)\r
+ {\r
+ *ll-=6;\r
+ return(1);\r
+ }\r
+ else\r
+ return(0);\r
+ }\r
+ else\r
+ {\r
+ for(sprintf(&cara[0],"%c\0",*txtd),larg=0;txtd<=txtf;txtd++) /* affiche avant */\r
+ {\r
+ GrTextXY(x+larg,y,&cara[0],col_e,col_f);\r
+ larg+=8;\r
+ sprintf(&cara[0],"%c\0",*(txtd+1));\r
+ if((lg-larg-8)<0)\r
+ break;\r
+ }\r
+ if(txtd<=txtf)\r
+ return(0);\r
+ else\r
+ return(1);\r
+ }\r
+}\r
+\r
+int gscanfnum(int x,int y,int lg,int min,int max,int deft,int col_f,int col_e,int col_c)\r
+{\r
+\r
+ char t[10],a;\r
+ int larg=0,flg=0;\r
+ char *ptd,*ptc;\r
+ int i;\r
+ int cpt=0;\r
+ short chgt=0;\r
+ short signe=0; /* par defaut 0(+) sinon 1(-) */\r
+\r
+ ptc=ptd=&t[0];\r
+ GrFilledBox(x,y,x+lg,y+14,col_f);\r
+ sprintf(t,"%lu\0",deft);\r
+ while(*ptc!='\0') ptc++;\r
+ GrTextXY(x+lg-strlen(t)*8,y,t,col_e,col_f);\r
+ do\r
+ {\r
+ a=readcara(x+lg-8,y,col_f,col_c);\r
+ switch(a)\r
+ {\r
+ case 8:\r
+ if(ptc>ptd)\r
+ {\r
+ ptc--;\r
+ cpt--;\r
+ if(flg)\r
+ larg-=8;\r
+ *(ptc)='\0';\r
+ }\r
+ else\r
+ {\r
+ larg=0;\r
+ ptc=ptd;\r
+ beep();\r
+ }\r
+ break;\r
+ case 13:\r
+ if(ptc==ptd)\r
+ {\r
+ *ptc='\0';\r
+ a=11;\r
+ }\r
+ break;\r
+ case 43:\r
+ signe=0;\r
+ chgt=1;\r
+ if(cpt==0)\r
+ *ptc='\0';\r
+ break;\r
+ case 45:\r
+ signe=1;\r
+ chgt=1;\r
+ if(cpt==0)\r
+ *ptc='\0';\r
+ break;\r
+ default:\r
+ if(cpt<10)\r
+ {\r
+ if((a<='9') && (a>='0'))\r
+ {\r
+ *(ptc++)=a;\r
+ cpt++;\r
+ *ptc='\0';\r
+ }\r
+ }\r
+ else\r
+ beep();\r
+ break;\r
+ }\r
+ GrFilledBox(x,y,x+lg,y+14,col_f);\r
+ affiche_chaine(x,y,lg,ptd,ptc,flg,&larg,col_e,col_f);\r
+ if(chgt)\r
+ if(signe)\r
+ GrTextXY(x,y,"-",col_e,col_f);\r
+ else\r
+ GrTextXY(x,y,"+",col_e,col_f);\r
+ }\r
+ while((a!=13) && (a!=27));\r
+ if(a==13)\r
+ {\r
+ i=atol(t);\r
+ if(signe)\r
+ i=-i;\r
+ if((i<=max) && (i>=min))\r
+ return(i);\r
+ else\r
+ {\r
+ beep();\r
+ return(gscanfnum(x,y,lg,min,max,deft,col_f,col_e,col_c));\r
+ }\r
+ }\r
+ else\r
+ return(gscanfnum(x,y,lg,min,max,deft,col_f,col_e,col_c));\r
+}\r
+\r
+\r
+/******************************************************************************/\r
+char *gschar(int x,int y,int lg,int *lgmax,char *defaut,int col_f,int col_e,int col_c)\r
+{\r
+\r
+ char *ptd,*ptc,a;\r
+ int larg=0,flg=1;\r
+\r
+ ptd=(char *)malloc(*lgmax);\r
+ ptc=ptd;\r
+ GrFilledBox(x,y,x+lg*8,y+14,col_f);\r
+ GrTextXY(x,y,defaut,col_e,col_f);\r
+ do\r
+ {\r
+ a=readcara((larg<(lg-1)*8) ? (x+larg) : (x+(lg-1)*8),y,col_f,col_c);\r
+ switch(a)\r
+ {\r
+ case 8:\r
+ if(ptc>ptd)\r
+ {\r
+ ptc--;\r
+ if(flg)\r
+ larg=(larg-8)>0 ? larg-8 : 0;\r
+ *(ptc)='\0';\r
+ }\r
+ else\r
+ {\r
+ larg=0;\r
+ ptc=ptd;\r
+ beep();\r
+ }\r
+ break;\r
+ case 13:\r
+ break;\r
+ default :\r
+ if(((ptc-ptd)/sizeof(char))<=*lgmax)\r
+ {\r
+ *(ptc++)=a;\r
+ *ptc='\0';\r
+ if(flg)\r
+ larg+=8;\r
+ }\r
+ else\r
+ beep();\r
+ }\r
+ GrFilledBox(x,y,x+lg*8,y+14,col_f);\r
+ flg=affiche_chaine(x,y,(lg-1)*8,ptd,ptc,flg,&larg,col_e,col_f);\r
+ }\r
+ while((a!=13) && (a!=27));\r
+ if((a==27) || (ptd==ptc))\r
+ {\r
+ ptc=ptd=defaut;\r
+ while(*ptc!='\0') ptc++;\r
+ }\r
+ else\r
+ *ptc='\0';\r
+ GrFilledBox(x,y,x+lg*8,y+14,col_f);\r
+ affiche_chaine(x,y,lg*8,ptd,ptc,1,&larg,col_e,col_f);\r
+ *lgmax=(ptc>ptd)? ptc-ptd+1 : 0;\r
+ return(ptd);\r
+}\r
--- /dev/null
+case GRON: switch (param[0].xword)\r
+ {\r
+ case 0: GrSetMode(GR_width_height_graphics,\r
+ 640,480,16);\r
+ Res_graph_X=640;\r
+ Res_graph_Y=480;\r
+ break;\r
+ case 1: GrSetMode(GR_width_height_graphics,\r
+ 640,480,256);\r
+ Res_graph_X=640;\r
+ Res_graph_Y=480;\r
+ break;\r
+ case 2: GrSetMode(GR_width_height_graphics,\r
+ 800,600,16);\r
+ Res_graph_X=800;\r
+ Res_graph_Y=600;\r
+ break;\r
+ \r
+ case 3: GrSetMode(GR_width_height_graphics,\r
+ 800,600,256);\r
+ Res_graph_X=800;\r
+ Res_graph_Y=600;\r
+ break;\r
+ case 4: GrSetMode(GR_width_height_graphics,\r
+ 1024,768,16);\r
+ Res_graph_X=1024;\r
+ Res_graph_Y=768;\r
+ break;\r
+ case 5: GrSetMode(GR_width_height_graphics,\r
+ 1024,768,256);\r
+ Res_graph_X=1024;\r
+ Res_graph_Y=768;\r
+ break;\r
+ case 6: GrSetMode(GR_width_height_graphics,\r
+ 1280,1024,16);\r
+ Res_graph_X=1280;\r
+ Res_graph_Y=1024;\r
+ break;\r
+ case 7: GrSetMode(GR_width_height_graphics,\r
+ 1280,1024,256);\r
+ Res_graph_X=1280;\r
+ Res_graph_Y=1024;\r
+ break;\r
+ case 8: GrSetMode(GR_width_height_graphics,\r
+ 1600,1280,16);\r
+ Res_graph_X=1600;\r
+ Res_graph_Y=1280;\r
+ break;\r
+ case 9: GrSetMode(GR_width_height_graphics,\r
+ 1600,1280,256);\r
+ Res_graph_X=1600;\r
+ Res_graph_Y=1280;\r
+ break;\r
+ default: GrSetMode(GR_width_height_graphics,\r
+ 320,200,256);\r
+ Res_graph_X=320;\r
+ Res_graph_Y=200;\r
+ }\r
+ GrClearScreen(0);\r
+ break;\r
+\r
+case POINT: CurX=param[0].xword;\r
+ CurY=param[1].xword;\r
+ GrPlot(CurX,CurY,Couleur);\r
+ break;\r
+\r
+case INPIX: CurX=param[0].xword;\r
+ CurY=param[1].xword;\r
+ param[2].xword=GrPixel(CurX,CurY);\r
+ break;\r
+\r
+case MOVE: CurX=param[0].xword;\r
+ CurY=param[1].xword;\r
+ break;\r
+\r
+case COLOR: Couleur=param[0].xword;\r
+ break;\r
+\r
+case PALETT: Coul[Pal++]=param[0].xword;\r
+ if (Pal==4)\r
+ {\r
+ GrSetColor(Coul[0],Coul[1],Coul[2],Coul[3]);\r
+ Pal=0;\r
+ }\r
+ break;\r
+\r
+case GROFF: if(MOUSE_PRESENT) MouseUnInit();\r
+ GrSetMode(GR_80_25_text);\r
+ break;\r
+\r
+case DRAW: GrLine(CurX,CurY,param[0].xword,param[1].xword,Couleur);\r
+ CurX=param[0].xword;\r
+ CurY=param[1].xword;\r
+ break;\r
+\r
+case HFILL: GrHLine(CurX,param[0].xword,CurY,Couleur);\r
+ CurX=param[0].xword;\r
+ break;\r
+\r
+case VFILL: GrVLine(CurX,CurY,param[0].xword,Couleur);\r
+ CurY=param[0].xword;\r
+ break;\r
+\r
+case CLS: GrClearScreen(Fond);\r
+ break;\r
+\r
+case BORDER: Fond=param[0].xword;\r
+ break;\r
+\r
+case INXPOS: param[0].xword=CurX;\r
+ break;\r
+\r
+case INYPOS: param[0].xword=CurY;\r
+ break;\r
+\r
+case OUTSTRING:\r
+ {\r
+ char *Texte= (char *)(M + strings + param[ 2 ].xword + 1);\r
+ if(param[0].xint==-1) ax=CurX;\r
+ else ax=param[0].xint;\r
+ if(param[1].xint==-1) bx=CurY;\r
+ else bx=param[1].xint;\r
+ if(param[3].xint==-1) cx=Couleur;\r
+ else cx=param[3].xint;\r
+ if(param[4].xint==-1) dx=Fond;\r
+ else dx=param[4].xint;\r
+ GrTextXY(ax,bx,Texte,cx,dx);\r
+ if(param[0].xint==-1 && param[1].xint==-1)\r
+ {\r
+ CurX+=8*strlen(Texte);\r
+ if(CurX>GrMaxX())\r
+ {\r
+ CurX=0;\r
+ CurY+=14;\r
+ }\r
+ }\r
+ }\r
+ break;\r
+\r
+case HASCII:\r
+ {\r
+ char *Texte=(char *)¶m[ 0 ].xword;\r
+ GrTextXY(CurX,CurY,Texte,Couleur,Fond);\r
+ CurX+=8;\r
+ if (CurX>GrMaxX())\r
+ {\r
+ CurX=0;\r
+ CurY+=14;\r
+ }\r
+ }\r
+ break;\r
+\r
+case INKEY:\r
+ {\r
+ int Touche;\r
+\r
+ Touche=kbhit();\r
+ if (Touche)\r
+ param[0].xword=getkey();\r
+ else\r
+ param[0].xword=0;\r
+ }\r
+ break;\r
+\r
+case GETMAP : {\r
+ int w,h;\r
+ GrContext *Destination;\r
+\r
+ w=abs(param[0].xword-CurX)+1;\r
+ h=abs(param[1].xword-CurY)+1;\r
+ newarry((word)1,3,(word)AINT,¶m[2].xvirt,&am);\r
+ Destination=GrCreateContext(w,h,\r
+ NULL,NULL);\r
+ M[am+3]=(int)Destination;\r
+ M[am+4]=w;\r
+ M[am+5]=h;\r
+ GrBitBlt(Destination,0,0,\r
+ NULL,CurX,CurY,param[0].xword,param[1].xword,\r
+ GrWRITE);\r
+ }\r
+ break;\r
+\r
+case PUTMAP : if (member(¶m[0].xvirt,&am))\r
+ GrBitBlt(NULL,CurX,CurY,\r
+ (GrContext *)M[am+3],0,0,M[am+4],M[am+5],GrWRITE);\r
+ else\r
+ errsignal(RTEREFTN);\r
+ break;\r
+\r
+case ORMAP : if (member(¶m[0].xvirt,&am))\r
+ GrBitBlt(NULL,CurX,CurY,\r
+ (GrContext *)M[am+3],0,0,M[am+4],M[am+5],GrOR);\r
+ else\r
+ errsignal(RTEREFTN);\r
+ break;\r
+\r
+case XORMAP : if (member(¶m[0].xvirt,&am))\r
+ GrBitBlt(NULL,CurX,CurY,\r
+ (GrContext *)M[am+3],0,0,M[am+4],M[am+5],GrXOR);\r
+ else\r
+ errsignal(RTEREFTN);\r
+ break;\r
+\r
+case INTENS : {\r
+ word am1,am2;\r
+ int i;\r
+ int pt1[30][2];\r
+\r
+ if(member(¶m[1].xvirt,&am1) && member(¶m[2].xvirt,&am2))\r
+ {\r
+ if(param[0].xint>30) param[0].xint=30;\r
+ for(i=0;i<param[0].xint;i++)\r
+ {\r
+ pt1[i][0]=M[am1+3+i];\r
+ pt1[i][1]=M[am2+3+i];\r
+ }\r
+ if(param[4].xint!=0)\r
+ GrFilledPolygon(param[0].xint,pt1,param[3].xint);\r
+ else\r
+ GrPolygon(param[0].xint,pt1,param[3].xint);\r
+ }\r
+ else\r
+ errsignal(RTEREFTN);\r
+ }\r
+ break;\r
+\r
+case PATERN :\r
+ if(param[5].xint!=0)\r
+ GrFilledBox(param[0].xint,param[1].xint,param[2].xint,param[3].xint,param[4].xint);\r
+ else\r
+ GrBox(param[0].xint,param[1].xint,param[2].xint,param[3].xint,param[4].xint);\r
+ break;\r
+case TRACK : afficheinteger(param[0].xint,param[1].xint,param[2].xint,param[3].xint,\r
+ param[4].xint);\r
+ break;\r
+case HFONT : param[9].xint=gscanfnum(param[0].xint,param[1].xint,param[2].xint*8,\r
+ param[3].xint,param[4].xint,param[5].xint,\r
+ param[6].xint,param[7].xint,param[8].xint);\r
+ break;\r
+\r
+case HFONT8 : {\r
+ char *Texte= (char *)(M + strings + param[ 4 ].xword + 1);\r
+\r
+ ret=gschar(param[0].xint,param[1].xint,param[2].xint,¶m[3].xint,\r
+ Texte,param[5].xint,param[6].xint,param[7].xint);\r
+\r
+ newarry((word) 0, param[3].xint-2,(word) AINT,¶m[8].xvirt,&ax);\r
+ ax+=3;\r
+ while(*ret!='\0')\r
+ M[ax++]=*(ret++);\r
+ }\r
+ break;\r
+\r
+case CIRB : {\r
+ ax=param[0].xint-param[2].xint; /* x */\r
+ bx=param[1].xint-param[3].xint; /* y */\r
+ cx=param[2].xint*2; /* rax */\r
+ dx=param[3].xint*2; /* ray */\r
+ if(param[7].xint!=0)\r
+ GrFilledEllipseArc(ax,bx,cx,dx,param[4].xint,param[5].xint,\r
+ param[6].xint);\r
+ else\r
+ GrEllipseArc(ax,bx,cx,dx,param[4].xint,param[5].xint,\r
+ param[6].xint);\r
+ }\r
+ break;\r
+/* MOUSE */\r
+\r
+case INIT : mousenit(param[0].xint,param[1].xint);\r
+ break;\r
+\r
+case SHOWCURSOR :\r
+ mouseshow();\r
+ break;\r
+\r
+case HIDECURSOR :\r
+ mousehide();\r
+ break;\r
+\r
+case STATUS :\r
+ break;\r
+\r
+case SETPOSITION :\r
+ MouseWarp(param[0].xint,param[1].xint);\r
+ break;\r
+\r
+case GETPRESS :\r
+case GETRELEASE :\r
+ \r
+ ax=mouse(&v,&p,&h,&l,&r,&c);\r
+ param[ 5 ].xint = c;\r
+ param[ 4 ].xint = r;\r
+ param[ 3 ].xint = l;\r
+ param[ 2 ].xint = p;\r
+ param[ 1 ].xint = v;\r
+ param[ 0 ].xint = h;\r
+ /* parametre en retour*/\r
+ if(ax)\r
+ param[ 6 ].xbool = TRUE;\r
+ else\r
+ param[ 6 ].xbool = FALSE;\r
+ break;\r
+\r
+case SETWINDOW :\r
+ MouseSetLimits(param[0].xint,param[1].xint,param[2].xint,param[3].xint);\r
+ break;\r
+\r
+case DEFCURSOR :\r
+ break;\r
+\r
+case GETMOVEMENT :\r
+ MouseEventEnable(param[1].xint,param[0].xint);\r
+ break;\r
+\r
+case SETSPEED :\r
+ MouseSetSpeed(param[0].xint);\r
+ break;\r
+\r
+case SETTHRESHOLD :\r
+ break;\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+\r
+#include "sock.h"\r
+#include "tcpip.h"\r
+\r
+#include <assert.h>\r
+\r
+\r
+static int sock;\r
+\r
+static int slaves=0;\r
+static struct addr {\r
+ int console;\r
+ struct sockaddr_in addr;\r
+} *phone_book;\r
+\r
+\r
+#define MAX_NODES 256\r
+static int node2book[ MAX_NODES ]; /* only 256 nodes - can be changed */\r
+\r
+\r
+static void sock_recv_from( void *, int, struct sockaddr_in * );\r
+static void sock_recv_from( buf, buflen, from_addr )\r
+ int buflen;\r
+ void *buf;\r
+ struct sockaddr_in *from_addr;\r
+{\r
+ struct sockaddr_in addr;\r
+ int retval;\r
+ for(;;){\r
+ if( ( retval = sock_recv( sock, buf, buflen, &addr ) ) < 0 )\r
+ perror("receive"),abend("no answer from master");\r
+ if(\r
+ from_addr->sin_port != addr.sin_port\r
+ ||\r
+ from_addr->sin_addr.s_addr != addr.sin_addr.s_addr\r
+ ||\r
+ buflen != retval\r
+ )\r
+ fprintf( stderr, "unexpected message from %s:%d length %d\n",\r
+ inet_ntoa( from_addr->sin_addr ),\r
+ (int)ntohs( from_addr->sin_port ),\r
+ retval\r
+ );\r
+ else\r
+ break;\r
+ }\r
+}\r
+\r
+ /* nn.nn.nn.nn:port address */\r
+void tcpip_connect_to_master( addr ) char *addr; {\r
+\r
+ char *host = addr;\r
+ int namelen;\r
+ int aux;\r
+ struct sockaddr_in m_address;\r
+\r
+ for( aux = 0; aux < MAX_NODES; aux++ )\r
+ node2book[ aux ] = -1;\r
+\r
+ if( host_addr( host, &m_address ) < 0 ){\r
+ perror("invalid host name:");\r
+ usage();\r
+ }\r
+\r
+ sock = sock_open( SOCK_DGRAM, "udp", NULL, 0 ); /* any port */\r
+ if( sock < 0 ) perror("can't open any socket"),exit(10);\r
+\r
+ {\r
+ struct sockaddr_in addr;\r
+ int namelen = sizeof(struct sockaddr_in);\r
+ getsockname( sock, &addr, &namelen );\r
+ fprintf( stderr, "socket opened on %s:%d\n",\r
+ inet_ntoa(addr.sin_addr),\r
+ (int)ntohs(addr.sin_port)\r
+ );\r
+ }\r
+\r
+ aux = htonl( console );\r
+ sock_send( sock, &aux, sizeof(aux), &m_address );\r
+ fprintf(\r
+ stderr, "waiting for acknowledge from %s:%d\n",\r
+ host, (int)ntohs( m_address.sin_port )\r
+ );\r
+\r
+ sock_recv_from( &aux, sizeof(aux), &m_address );\r
+ slaves = ntohl( aux );\r
+ fprintf( stderr, "answer from master: %d interpreters\n", slaves );\r
+\r
+ phone_book = (struct addr *)calloc( slaves, sizeof( struct addr ) );\r
+ if( phone_book==NULL ) abend("can't allocate table of addresses");\r
+\r
+ sock_recv_from( &aux, sizeof(aux), &m_address );\r
+ phone_book[0].console = ntohl( aux );\r
+ phone_book[0].addr = m_address;\r
+\r
+ fprintf( stderr, "master console %d at %s:%d\n",\r
+ phone_book[0].console,\r
+ inet_ntoa(phone_book[0].addr.sin_addr),\r
+ (int)ntohs(phone_book[0].addr.sin_port)\r
+ );\r
+\r
+ node2book[ phone_book[ 0 ].console ] = 0;\r
+\r
+ {\r
+ int i;\r
+ for( i=1; i<slaves; i++ ){ /* on 0 will be master */\r
+\r
+ sock_recv_from( &aux, sizeof(aux), &m_address );\r
+ phone_book[i].console = ntohl( aux );\r
+ sock_recv_from(\r
+ &(phone_book[i].addr),\r
+ sizeof(struct sockaddr_in),\r
+ &m_address\r
+ );\r
+ fprintf( stderr, "interpreter %d connected at %s:%d\n",\r
+ phone_book[i].console,\r
+ inet_ntoa(phone_book[i].addr.sin_addr),\r
+ (int)ntohs(phone_book[i].addr.sin_port)\r
+ );\r
+ node2book[ phone_book[ i ].console ] = i;\r
+\r
+ }\r
+ }\r
+ fprintf( stderr, "\nprogram started\n\n" );\r
+}\r
+\r
+\r
+\r
+\r
+void tcpip_wait_for_slaves( _slaves ) int _slaves; {\r
+\r
+ int aux;\r
+ int slave_console;\r
+ struct sockaddr_in slave_address;\r
+ int namelen = sizeof(struct sockaddr_in);\r
+\r
+ for( aux = 0; aux < MAX_NODES; aux++ )\r
+ node2book[ aux ] = -1;\r
+\r
+ slaves = _slaves+1;\r
+\r
+ phone_book = (struct addr *)calloc( slaves, sizeof( struct addr ) );\r
+ if( phone_book==NULL ) abend("can't allocate table of addresses");\r
+\r
+ sock = sock_open( SOCK_DGRAM, "udp", NULL, PORT );\r
+ if( sock < 0 ) perror("master socket"),abend("can't install master");\r
+\r
+ phone_book[0].console = console;\r
+ getsockname( sock, &(phone_book[0].addr), &namelen );\r
+ assert( namelen == sizeof( struct sockaddr_in ) );\r
+\r
+ fprintf( stderr, "waiting for %d slaves on console %d at %s:%d\n",\r
+ _slaves,\r
+ phone_book[0].console,\r
+ inet_ntoa(phone_book[0].addr.sin_addr),\r
+ (int)ntohs(phone_book[0].addr.sin_port)\r
+ );\r
+\r
+ node2book[ console ] = 0;\r
+\r
+ while( _slaves > 0 ){\r
+\r
+ if( sock_recv( sock , &slave_console, sizeof(slave_console), &slave_address ) < 0 )\r
+ perror("server receive"),abend("can't connect slave");\r
+\r
+ fprintf( stderr, "slave %d connected at %s:%d\n",\r
+ ntohl(slave_console),\r
+ inet_ntoa(slave_address.sin_addr),\r
+ (int)ntohs(slave_address.sin_port)\r
+ );\r
+\r
+ slave_console = ntohl( slave_console );\r
+\r
+ phone_book[_slaves].console = slave_console;\r
+ phone_book[_slaves].addr = slave_address;\r
+\r
+ if( node2book[ slave_console ] != -1 ){\r
+ fprintf( stderr, "node %d already bound\n", slave_console );\r
+ abend("exiting");\r
+ }\r
+ node2book[ slave_console ] = _slaves;\r
+\r
+ _slaves--;\r
+\r
+ }\r
+\r
+ fprintf( stderr, "all slaves notified - sending acknowledges\n" );\r
+\r
+ {\r
+ int i,j;\r
+ for( i=1; i<slaves; i++ ){\r
+\r
+ aux = htonl(slaves);\r
+ sock_send( sock, &aux, sizeof(aux), &(phone_book[i].addr) );\r
+\r
+ aux = htonl(console);\r
+ sock_send( sock, &aux, sizeof(aux), &(phone_book[i].addr) );\r
+\r
+ for( j=1; j<slaves; j++ ){\r
+ aux = htonl(phone_book[j].console);\r
+ sock_send( sock, &aux, sizeof(aux), &(phone_book[i].addr) );\r
+ sock_send(\r
+ sock,\r
+ &(phone_book[j].addr),\r
+ sizeof(struct sockaddr_in),\r
+ &(phone_book[i].addr)\r
+ );\r
+ }\r
+ }\r
+ }\r
+\r
+ fprintf( stderr, "\nprogram started\n\n" );\r
+}\r
+\r
+\r
+void tcpip_send( msg ) message *msg; {\r
+ int node = msg->control.receiver.node;\r
+ int ix = node2book[ node ];\r
+ if( ix == -1 ){\r
+ fprintf( stderr, "tcpip send message to not existing node %d\n", node );\r
+ abend("exiting");\r
+ }\r
+/*\r
+ fprintf( stderr, "tcpip send message to node %d indx %d\n", node, ix );\r
+*/\r
+ sock_send(\r
+ sock,\r
+ msg,\r
+ sizeof( message ),\r
+ &( phone_book[ ix ].addr )\r
+ );\r
+}\r
+\r
+bool tcpip_poll( ms ) int ms; {\r
+ return sock_poll( sock, ms );\r
+}\r
+\r
+bool tcpip_recv( msg ) message *msg; {\r
+ int retval;\r
+ struct sockaddr_in addr;\r
+ if( ( retval = sock_recv( sock, msg, sizeof( message ), &addr ) ) < 0 ){\r
+ perror("receive");\r
+ return FALSE;\r
+ }\r
+/*\r
+ if( retval == sizeof( message ) )\r
+ fprintf(stderr,"tcpip recv message from node %d\n",msg->control.sender.node);\r
+ else\r
+ fprintf(stderr,"tcpip recv incorrect message from node %d\n",msg->control.sender.node);\r
+*/\r
+ return ( retval == sizeof( message ) );\r
+}\r
+\r
+\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#ifndef __TCPIP_H__\r
+#define __TCPIP_H__\r
+\r
+#ifndef NO_PROTOTYPES\r
+void tcpip_connect_to_master( char * ); /* nn.nn.nn.nn:port address */\r
+void tcpip_wait_for_slaves( int ); /* slaves number */\r
+void tcpip_send( message * );\r
+bool tcpip_poll( int miliseconds ); /* < 0 -> blocks indefinitely */\r
+bool tcpip_recv( message * );\r
+#else\r
+void tcpip_connect_to_master();\r
+void tcpip_wait_for_slaves();\r
+void tcpip_send();\r
+bool tcpip_poll();\r
+void tcpip_recv();\r
+#endif\r
+\r
+#define PORT 3600\r
+\r
+#endif\r
+\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+/* Type checking routines */\r
+\r
+\r
+/* Determine if prot occurs in the prefix sequence of object am\r
+ */\r
+\r
+#ifndef NO_PROTOTYPES\r
+static bool pref(word,word);\r
+static bool typep0(word,word,bool,word *,word *);\r
+static bool prefh(word,word);\r
+static bool typef(word,word,word,word);\r
+#else\r
+static bool pref();\r
+static bool typep0();\r
+static bool prefh();\r
+static bool typef();\r
+#endif\r
+\r
+\r
+static bool pref(am, prot)\r
+word am, prot;\r
+{\r
+ word t1, t2;\r
+ protdescr *ptr;\r
+\r
+ t1 = M[ am+PROTNUM ];\r
+ if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT)\r
+ { /* neither array nor file */\r
+ ptr = prototype[ t1 ];\r
+ t1 = ptr->preflist;\r
+ t2 = t1+ptr->lthpreflist;\r
+ while (t1 < t2)\r
+ {\r
+ if (prot == M[ t1 ]) return (TRUE);\r
+ t1++;\r
+ }\r
+ }\r
+ return (FALSE);\r
+} /* end pref */\r
+\r
+\r
+void qua(virt, tp) /* Validate qualification of object */\r
+virtaddr *virt;\r
+word tp;\r
+{\r
+ if (virt->mark != M[ virt->addr+1 ]) errsignal(RTEREFTN);\r
+ if (M[ tp ] != CLASSTYPE) errsignal(RTEINCQA);\r
+ if (!pref(M[ virt->addr ], M[ tp+1 ])) errsignal(RTEINCQA);\r
+} /* end qua */\r
+\r
+\r
+bool inl(virt, tp) /* Determine if A in B */\r
+virtaddr *virt;\r
+word tp;\r
+{\r
+ if (virt->mark != M[ virt->addr+1 ])\r
+ return (TRUE); /* none is in everything */\r
+ else\r
+ if (M[ tp ] != CLASSTYPE) return (FALSE);\r
+ else return (pref(M[ virt->addr ], M[ tp+1 ]));\r
+} /* end inl */\r
+\r
+\r
+bool is(virt, tp) /* Determine if A is B */\r
+virtaddr *virt;\r
+word tp;\r
+{\r
+ if (virt->mark != M[ virt->addr+1 ] || M[ tp ] != CLASSTYPE)\r
+ return (FALSE);\r
+ else return (M[ M[ virt->addr ]+PROTNUM ] == M[ tp+1 ]);\r
+} /* end is */\r
+\r
+\r
+/* Check correctness of an especially clumsy assignment statement\r
+ */\r
+\r
+void typref(virt, tp)\r
+virtaddr *virt;\r
+word tp;\r
+{\r
+ word t1, t2, t3;\r
+ int knd;\r
+\r
+ if (virt->mark == M[ virt->addr+1 ]) /* none always allowed */\r
+ {\r
+ t3 = M[ virt->addr ]; /* am of right hand side */\r
+ t1 = M[ t3+PROTNUM ];\r
+ if (t1 == AINT || t1 == AREAL || t1 == AVIRT) errsignal(RTEINCAS);\r
+ t2 = M[ tp ]; /* right hand side type */\r
+ if (t2 == FILETYPE)\r
+ {\r
+ if (t1 != FILEOBJECT) errsignal(RTEINCAS);\r
+ }\r
+ else\r
+ if (t2 == PURECOROUTINE || t2 == PUREPROCESS)\r
+ {\r
+ if (t2 == PURECOROUTINE) knd = COROUTINE;\r
+ else knd = PROCESS;\r
+ if (prototype[ t1 ]->kind != knd) errsignal(RTEINCAS);\r
+ }\r
+ else\r
+ {\r
+ if (t2 != CLASSTYPE) errsignal(RTEINCAS);\r
+ if (!pref(t3, M[ tp+1 ])) errsignal(RTEINCAS);\r
+ }\r
+ }\r
+} /* end typref */\r
+\r
+\r
+/* Check correctness of a dynamic assignment\r
+ */\r
+\r
+void typed(ldim, lt, rdim, rt, virt)\r
+word ldim, lt, rdim, rt;\r
+virtaddr *virt;\r
+{\r
+ if (ldim != rdim) errsignal(RTEINCAS);\r
+ if (ldim == 0) typref(virt, lt);\r
+ else\r
+ if (lt != rt) errsignal(RTEINCAS);\r
+} /* end typed */\r
+\r
+\r
+/* Search the SL chain of object am to find the nearest Y such that Y in A.\r
+ * prot = prototype number of A\r
+ */\r
+\r
+word loadt(am, prot)\r
+word am, prot;\r
+{\r
+ word t1, t2, t3, t4;\r
+\r
+ while( !pref(am, prot) )\r
+ {\r
+ t1 = am+M[ am ]+SL;\r
+ t2 = M[ t1 ]; /* try next object in chain */\r
+ t3 = M[ t1+1 ];\r
+ t4 = M[ t2+1 ];\r
+ if( t3 != t4 ) errsignal( RTEFTPMS );\r
+ am = M[ t2 ];\r
+ }\r
+ return (am);\r
+}\r
+\r
+\r
+/* Compute type of a formal parameter - see also typep (below). */\r
+\r
+static bool typep0(am, pdaddr, protp, dim, tp)\r
+word am, pdaddr;\r
+bool protp;\r
+word *dim, *tp;\r
+{\r
+ word t1;\r
+ protdescr *ptr;\r
+\r
+ if (protp) /* prototype number on input */\r
+ {\r
+ ptr = prototype[ pdaddr ];\r
+ *dim = ptr->nrarray;\r
+ *tp = ptr->finaltype;\r
+ }\r
+ else /* type address on input */\r
+ {\r
+ *dim = M[ pdaddr+1 ];\r
+ *tp = M[ pdaddr+2 ];\r
+ }\r
+ if (M[ *tp ] != FORMTYPE) return (TRUE);\r
+ else\r
+ {\r
+ t1 = M[ *tp+1 ]; /* SL prototype number */\r
+ if (t1 == DUMMY) return (FALSE);\r
+ else /* undefined */\r
+ {\r
+ *tp = loadt(am, t1)+M[ *tp+2 ];\r
+ *dim += M[ *tp ]; /* accumulate dim */\r
+ *tp = M[ *tp+1 ];\r
+ return (TRUE); /* AIL 1989.02.02 */\r
+ }\r
+ }\r
+} /* end typep0 */\r
+\r
+\r
+void typep(am, nr, dim, tp) /* Compute type of formal parameter */\r
+word am, nr;\r
+word *dim, *tp;\r
+{\r
+ if (!typep0(am, M[ prototype[ M[ am+PROTNUM ] ]->pfdescr+nr ],\r
+ FALSE, dim, tp)) errsignal(RTESYSER);\r
+} /* end typep */\r
+\r
+\r
+/* Auxiliary function for heads, almost the same as pref.\r
+ */\r
+\r
+static bool prefh(tp, prot)\r
+word tp, prot;\r
+{\r
+ word t1, t2;\r
+ protdescr *ptr;\r
+\r
+ ptr = prototype[ M[ tp+1 ] ];\r
+ t2 = ptr->preflist;\r
+ t1 = t2+ptr->lthpreflist-1;\r
+ do\r
+ {\r
+ if (M[ t1 ] == prot) return (TRUE);\r
+ else t1--;\r
+ } while (t1 >= t2);\r
+ return (FALSE);\r
+} /* end prefh */\r
+\r
+\r
+/* Check compatibility of generalized types, used by heads only.\r
+ */\r
+\r
+static bool typef(dima, ta, dimb, tb)\r
+word dima, ta, dimb, tb;\r
+{\r
+ word t1, t2;\r
+ int knd;\r
+\r
+ if (dima != dimb) errsignal(RTEINCHS); /* incompatible headers */\r
+ if (ta != tb) /* types different somehow */\r
+ {\r
+ if (dima != 0) errsignal(RTEINCHS); /* dim must be 0 now */\r
+ t1 = M[ ta ];\r
+ t2 = M[ tb ];\r
+ if (t1 == PRIMITIVETYPE || t1 == FILETYPE) errsignal(RTEINCHS);\r
+ if (t2 == PRIMITIVETYPE || t2 == FILETYPE) errsignal(RTEINCHS);\r
+ if (t1 != PURECOROUTINE && t1 != PUREPROCESS)\r
+ {\r
+ if (t2 == PURECOROUTINE || t2 == PUREPROCESS) return (TRUE);\r
+ else\r
+ {\r
+ if (!prefh(ta, M[ tb+1 ]))\r
+ {\r
+ if (!prefh(tb, M[ ta+1 ])) errsignal(RTEINCHS);\r
+ else return (TRUE);\r
+ }\r
+ }\r
+ }\r
+ else /* something pure */\r
+ {\r
+ if (t1 != t2)\r
+ {\r
+ /* AIL : t1 below replaced with t2, 1989.02.02 */\r
+ /* if (t1 == PURECOROUTINE || t1 == PUREPROCESS) */\r
+ if (t2 == PURECOROUTINE || t2 == PUREPROCESS)\r
+ knd = RECORD; /* used as junk */\r
+ else knd = prototype[ M[ tb+1 ] ]->kind;\r
+\r
+ if ((t1 == PURECOROUTINE && knd != COROUTINE) ||\r
+ (t1 == PUREPROCESS && knd != PROCESS))\r
+ {\r
+ if ((t1 != PURECOROUTINE) ||\r
+ (knd != PROCESS && t2 != PUREPROCESS))\r
+ return (TRUE);\r
+ }\r
+ }\r
+ }\r
+ }\r
+ return (FALSE);\r
+} /* end typef */\r
+\r
+\r
+/* Verify the compatibility of formal/actual procedure (function) heads.\r
+ */\r
+\r
+void heads(virt, nr)\r
+virtaddr *virt;\r
+word nr;\r
+{\r
+ word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv;\r
+ protdescr *ptr;\r
+ bool junk;\r
+ word x[ MAXHDLEN+1 ], y[ MAXHDLEN+1 ];\r
+ /* The two arrays declared above may be dynamically generated as objects */\r
+ /* upon entry to heads. In fact heads was implemented this way in the */\r
+ /* original LOGLAN running system on MERA-400 */\r
+ \r
+ oba = M[ virt->addr ];\r
+ ptr = prototype[ M[ oba+PROTNUM ] ];\r
+ fp = M[ ptr->pfdescr+nr ]; /* parameter description pointer */\r
+ slen = M[ fp+2 ]; /* length of its desclist */\r
+ if (slen > MAXHDLEN) errsignal(RTEFHTLG);\r
+ ftv = oba+M[ ptr->parlist+nr ]; /* type value pointer */\r
+ g = M[ ftv ];\r
+ if (M[ ftv+1 ] == M[ g+1 ]) /* not none */\r
+ g = M[ g ]; /* am of SL */\r
+ else errsignal(RTESLCOF); /* SL chain cut off */\r
+ gp = M[ ftv+2 ]; /* prototype number of g */\r
+ ptr = prototype[ gp ];\r
+ t2 = M[ fp ]; /* t2 = F-kind */\r
+ if (ptr->kind == FUNCTION)\r
+ {\r
+ if (t2 != FORMFUNC) errsignal(RTEINCHS);\r
+ junk = typep0(g, gp, TRUE, &dim, &tp);\r
+ junk = typep0(oba, fp+2, FALSE, &t1, &t2);\r
+ if (typef(dim, tp, t1, t2)) errsignal(RTEINCHS);\r
+ }\r
+ else\r
+ if (t2 != FORMPROC) errsignal(RTEINCHS);\r
+ if (slen != ptr->lthparlist) /* incompatible lengths */\r
+ errsignal(RTEINCHS);\r
+ t1 = M[ fp+1 ]-1; /* oba descriptlist */\r
+ t2 = ptr->pfdescr-1; /* g descriptlist */\r
+ for (i = 1; i <= slen; i++ ) /* verify second order lists */\r
+ {\r
+ x[ i ] = DUMMY; /* mark entry as empty */\r
+ y[ i ] = DUMMY;\r
+ fp = M[ t1+i ]; /* first type pointer */\r
+ gp = M[ t2+i ]; /* second type pointer */\r
+ tp = M[ fp ]; /* first type ordinal */\r
+ if (tp != M[ gp ]) errsignal(RTEINCHS);\r
+ if (tp == FORMTYPE)\r
+ {\r
+ x[ i ] = fp; /* save pointers to formal types */\r
+ y[ i ] = gp;\r
+ }\r
+ else\r
+ {\r
+ if (tp == PARIN || tp == PAROUT || tp == PARINOUT)\r
+ {\r
+ /* AIL 1989.02.02 */\r
+ /* if (typep0(oba, fp, FALSE, &dim, &tp)) */\r
+ if (! typep0(oba, fp, FALSE, &dim, &tp))\r
+ { /* undefined yet */\r
+ /* search preceding formals */\r
+ for (j = 1; j <= i; j++ )\r
+ if (x[ j ] == M[ fp+2 ])\r
+ break;\r
+ if (j > i) errsignal(RTEINCHS);\r
+ if (y[ j ] != M[ gp+2 ]) errsignal(RTEINCHS);\r
+ }\r
+ else /* already defined */\r
+ {\r
+ for (j = 1; j <= i; j++ )\r
+ if (y [ j ] == M[ gp+2 ])\r
+ errsignal(RTEINCHS);\r
+ junk = typep0(g, gp, FALSE, &j, &ftv);\r
+ junk = typef(dim, tp, j, ftv);\r
+ }\r
+ }\r
+ }\r
+ }\r
+}\r
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include "depend.h"\r
+#include "genint.h"\r
+#include "int.h"\r
+#include "process.h"\r
+#include "intproto.h"\r
+\r
+#include "tcpip.h"\r
+\r
+#include <time.h>\r
+\r
+/* Utility routines */\r
+\r
+\r
+word entier(x) /* Compute entier (floor) */\r
+double x;\r
+{\r
+ word i;\r
+\r
+ if (x >= 0.0)\r
+ {\r
+ i = (word)x;\r
+ return(i);\r
+ }\r
+ else\r
+ {\r
+ i = (word)(-x);\r
+ i = -i;\r
+ if ((double)i <= x) return(i); else return(i-1);\r
+ }\r
+} /* end entier */\r
+\r
+\r
+word shift(x, n) /* shift x by n bits */\r
+word x, n;\r
+{\r
+ if (n == 0) return (x);\r
+ if (n > 0) return (x << n);\r
+ else return ( (x >> -n) & ~(~(word)0 << (8*sizeof(word)+n)) );\r
+} /* end shift */\r
+\r
+\r
+char *asciiz(virt) /* Get ASCIIZ string from arrayof char */\r
+virtaddr *virt;\r
+{\r
+ word am;\r
+ int len, i;\r
+ char *cp;\r
+\r
+ if (member(virt, &am))\r
+ {\r
+ len = M[ am ]-3; /* length of the string */\r
+ cp = ballocate(len+1); /* allocate buffer for the string */\r
+ if (cp == NULL) errsignal(RTEMEMOV);\r
+ for (i = 0; i < len; i++) cp[ i ] = (char) M[ am+3+i ];\r
+ cp[ len ] = '\0'; /* terminate string with 0 byte */\r
+ return (cp);\r
+ }\r
+ else errsignal(RTEREFTN); /* reference to none */\r
+} /* end asciiz */\r
+\r
+\r
+void addext(fname, ext) /* Add extension to a file name */\r
+char *fname, *ext;\r
+{\r
+ char *cp;\r
+\r
+ cp = fname;\r
+ while (*cp != '\0' && *cp != '.') cp++;\r
+ strcpy(cp, ext);\r
+} /* end addext */\r
+\r
+\r
+void usage()\r
+{\r
+#if DLINK\r
+ fprintf(stderr,"Usage: int [-i] [-d] [-m memsize] [-r console] file\n");\r
+ net_logoff();\r
+#elif TCPIP\r
+ fprintf(stderr,"Usage: int [-i] [-d] [-m memsize]\n");\r
+ fprintf(stderr,"\t[-r console_number #_of_slaves_to_wait_for|master_address]\n");\r
+ fprintf(stderr,"\tfile\n");\r
+ fprintf(stderr,"master address in form: nnn.nnn.nnn.nnn:[port]\n");\r
+ fprintf(stderr," or : host_name:[port]\n");\r
+ fprintf(stderr,"default port number : %d\n",PORT);\r
+#else\r
+ fprintf(stderr,"Usage: int [-i] [-d] [-m memsize] file\n");\r
+#endif\r
+ exit(4);\r
+}\r
+\r
+\r
+void abend(msg) /* Print error message and abort */\r
+char *msg;\r
+{\r
+ fprintf(stderr, "Error: %s\n", msg);\r
+#if DLINK\r
+ net_logoff();\r
+#endif\r
+ exit(8);\r
+} /* end abend */\r
+\r
+\r
+/* Pseudo random number generator */\r
+\r
+static int ranpat1 = 7, ranpat2 = 503, ranpat3 = 15661;\r
+\r
+void ranset() /* Initialize generator */\r
+{\r
+ long tim;\r
+\r
+ time(&tim);\r
+ ranpat1 = tim % 30269;\r
+ ranpat2 = tim % 30307;\r
+ ranpat3 = tim % 30323;\r
+} /* end ranset */\r
+\r
+\r
+double prandom() /* Produce next pseudo random number */\r
+{\r
+ int i;\r
+ double r;\r
+\r
+ ranpat1 = 171*(ranpat1 % 177)- 2*(ranpat1 / 177);\r
+ if (ranpat1 < 0) ranpat1 += 30269;\r
+ ranpat2 = 172*(ranpat2 % 176)-35*(ranpat2 / 176);\r
+ if (ranpat2 < 0) ranpat2 += 30307;\r
+ ranpat3 = 170*(ranpat3 % 178)-63*(ranpat3 / 178);\r
+ if (ranpat3 < 0) ranpat3 += 30323;\r
+ r = ranpat1/30269.0 + ranpat2/30307.0 + ranpat3/30323.0;\r
+ i = (int)r;\r
+ return (r-i);\r
+}\r
+\r
+\r
+void moveblock(from, to, len) /* Copy a block of memory */\r
+char *from, *to;\r
+word len;\r
+{\r
+ while (len-- > 0) *to++ = *from++;\r
+} /* end moveblock */\r
+\r
+\r
+/**************************************************************\r
+\r
+#define LINE 10\r
+void dump(pix, from, len)\r
+word pix, from;\r
+int len;\r
+{\r
+ int i;\r
+ memory M;\r
+\r
+ M = process[ pix ].M;\r
+ while (len > 0)\r
+ {\r
+ printf("%6ld: ", (long) from);\r
+ for (i = 0; i < LINE; i++) printf("%7ld", (long)M[from++]);\r
+ putchar('\n');\r
+ len -= LINE;\r
+ }\r
+}\r
+\r
+ **************************************************************/\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#include <X11/Xlib.h>\r
+#include <X11/Xutil.h>\r
+\r
+#include <termio.h>\r
+#include <math.h>\r
+\r
+static int child_no=0;\r
+static int curx=0,cury=0;\r
+static int fcol=1,bcol=0;\r
+static int style=1;\r
+\r
+static Display *theDisplay;\r
+static Window myWindow,theWindow;\r
+static XClientMessageEvent theMessage;\r
+static XEvent retEv;\r
+\r
+static word w;\r
+\r
+static struct { int x,y,fcol,bcol,style; } xystack[16];\r
+static stackptr=0;\r
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\r
+\r
+ contacts: Andrzej.Salwicki@univ-pau.fr\r
+\r
+or Andrzej Salwicki\r
+ LITA Departement d'Informatique\r
+ Universite de Pau\r
+ Avenue de l'Universite\r
+ 64000 Pau FRANCE\r
+ tel. ++33 59923154 fax. ++33 59841696\r
+\r
+=======================================================================\r
+*/\r
+\r
+#define send_par(par) theMessage.data.s[cnt++]=(short)(param[par].xword);\r
+#define send_shrt(wd) theMessage.data.s[cnt++]=(short)(wd);\r
+#define send_word(wd) theMessage.data.s[cnt++]=(short)((wd)&0xffff); \\r
+ theMessage.data.s[cnt++]=(short)(((wd)>>16)&0xffff);\r
+\r
+\r
+#define send_sig \\r
+ theMessage.type=ClientMessage; \\r
+ theMessage.format = 16; \\r
+ theMessage.message_type = nrproc; \\r
+ XSendEvent(theDisplay,theWindow,True,NoEventMask,&theMessage); \\r
+ XFlush(theDisplay);\r
+\r
+#define nxtev do XNextEvent( theDisplay, &retEv ); \\r
+ while( retEv.type!=ClientMessage ); \\r
+ cnt = 0;\r
+\r
+#define rec_par(par) param[par].xword=(int)(retEv.xclient.data.s[cnt++]);\r
+#define rec_shrt(sh) sh = (int)(retEv.xclient.data.s[cnt++]);\r
+#define rec_word(wd) wd = (int)(retEv.xclient.data.s[cnt++]) & 0xffff; \\r
+ wd |= (int)(retEv.xclient.data.s[cnt++]) << 16;\r
+\r
+\r
+\r
+ case GRON :\r
+ if ((theDisplay = XOpenDisplay(NULL)) == NULL){\r
+ fprintf (stderr,"\nint: Can't open display\n");\r
+ exit(1);\r
+ }\r
+ myWindow = XCreateWindow(\r
+ theDisplay,\r
+ RootWindow(theDisplay,DefaultScreen(theDisplay)),\r
+ 0,0,1,1,0,\r
+ CopyFromParent,InputOnly,CopyFromParent,\r
+ 0,NULL\r
+ );\r
+ if( (child_no=fork())==0 ){\r
+ char me[16];\r
+ sprintf(me,"%d",(int)myWindow);\r
+ execlp("herc","herc",me,NULL);\r
+ }\r
+ graphmode = TRUE;\r
+ curx=cury=0;\r
+ nxtev\r
+ rec_word(theWindow);\r
+ break;\r
+ \r
+ case GROFF :\r
+ if( graphmode == FALSE ) break;\r
+ send_sig\r
+ child_no=0;\r
+ graphmode = FALSE;\r
+ break;\r
+ \r
+ case CLS :\r
+ send_sig\r
+ break;\r
+ \r
+\r
+ case PUSHXY :\r
+ xystack[stackptr].x = curx;\r
+ xystack[stackptr].y = cury;\r
+ xystack[stackptr].fcol = fcol;\r
+ xystack[stackptr].bcol = bcol;\r
+ xystack[stackptr].style= style;\r
+\r
+ stackptr++;\r
+ if( stackptr == 16 ) stackptr--;\r
+\r
+ break;\r
+\r
+\r
+ case POPHXY :\r
+\r
+ stackptr--;\r
+ if( stackptr < 0 ){\r
+ stackptr = 0;\r
+ break;\r
+ }\r
+\r
+ curx = xystack[stackptr].x;\r
+ cury = xystack[stackptr].y;\r
+ fcol = xystack[stackptr].fcol;\r
+ bcol = xystack[stackptr].bcol;\r
+ style= xystack[stackptr].style;\r
+\r
+ cnt = 0;\r
+ nrproc = COLOR;\r
+ send_shrt(fcol)\r
+ send_sig\r
+\r
+ cnt = 0;\r
+ nrproc = BORDER;\r
+ send_shrt(bcol)\r
+ send_sig\r
+\r
+ cnt = 0;\r
+ nrproc = STYLE;\r
+ send_shrt(style)\r
+ send_sig\r
+\r
+ break;\r
+\r
+\r
+ case POINT :\r
+ send_par(0)\r
+ send_par(1)\r
+ send_sig\r
+ case MOVE :\r
+ curx=param[0].xword;\r
+ cury=param[1].xword;\r
+ break;\r
+ \r
+ case DRAW :\r
+ send_shrt(curx)\r
+ send_shrt(cury)\r
+ send_par(0)\r
+ send_par(1)\r
+ send_sig\r
+ curx=param[0].xword;\r
+ cury=param[1].xword;\r
+ break;\r
+ \r
+ case INXPOS :\r
+ param[0].xword = curx;\r
+ break;\r
+ \r
+ case INYPOS :\r
+ param[0].xword = cury;\r
+ break;\r
+ \r
+ case HFILL :\r
+ case VFILL :\r
+ send_shrt(curx)\r
+ send_shrt(cury)\r
+ send_par(0)\r
+ send_sig\r
+ break;\r
+ \r
+ case HASCII :\r
+ send_shrt(curx)\r
+ send_shrt(cury)\r
+ send_par(0)\r
+ send_sig\r
+ if( param[0].xword != 0 ) curx += 8;\r
+ break;\r
+ \r
+ case COLOR :\r
+ fcol = param[0].xword;\r
+ send_par(0)\r
+ send_sig\r
+ break;\r
+ \r
+ case BORDER :\r
+ bcol = param[0].xword;\r
+ send_par(0)\r
+ send_sig\r
+ break;\r
+ \r
+ case STYLE :\r
+ bcol = param[0].xword;\r
+ send_par(0)\r
+ send_sig\r
+ break;\r
+ \r
+ case INPIX :\r
+ send_par(0)\r
+ send_par(1)\r
+ send_sig\r
+ curx=param[0].xword;\r
+ cury=param[1].xword;\r
+ nxtev\r
+ rec_par(2)\r
+ break;\r
+\r
+ case OUTSTRING :\r
+ {\r
+ char *s= (char *)(M + strings + param[ 0 ].xword + 1);\r
+ int signs=M[ strings + param[ 0 ].xword ];\r
+ nrproc=HASCII;\r
+ while( signs-- ){\r
+ word sign=0;\r
+ cnt = 0;\r
+ send_shrt(curx)\r
+ send_shrt(cury)\r
+ send_shrt(sign)\r
+ send_sig\r
+ sign = (word)(*s);\r
+ cnt = 0;\r
+ send_shrt(curx)\r
+ send_shrt(cury)\r
+ send_shrt(sign)\r
+ send_sig\r
+ s++;\r
+ curx+=8;\r
+ }\r
+ }\r
+ break;\r
+\r
+ case GETMAP :\r
+ {\r
+ word map;\r
+ word x=param[0].xword;\r
+ word y=param[1].xword;\r
+ word w = x - curx + 1;\r
+ word h = y - cury + 1;\r
+ x = curx;\r
+ y = cury;\r
+ if( w <= 0 ){ w=-w; x-=w; }\r
+ if( h <= 0 ){ h=-h; y-=h; }\r
+ send_shrt(x)\r
+ send_shrt(y)\r
+ send_shrt(w)\r
+ send_shrt(h)\r
+ send_sig\r
+ nxtev\r
+ rec_word(map)\r
+ newarry((word) 1, 3, (word)AINT, ¶m[ 2 ].xvirt, &am);\r
+ M[ am+3 ] = map;\r
+ M[ am+4 ] = w;\r
+ M[ am+5 ] = h;\r
+ }\r
+ break;\r
+\r
+ case PUTMAP :\r
+ case ORMAP :\r
+ case XORMAP :\r
+ if (member(¶m[ 0 ].xvirt, &am)){\r
+ send_word( M[ am+3 ] )\r
+ send_shrt(curx)\r
+ send_shrt(cury)\r
+ send_shrt( M[ am+4 ] )\r
+ send_shrt( M[ am+5 ] )\r
+ send_sig\r
+ }else errsignal(RTEREFTN);\r
+ break;\r
+ \r
+/*\r
+ case PATERN :\r
+ patern((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,\r
+ (int *) ¶m[ 2 ].xword, (int *) ¶m[ 3 ].xword);\r
+ break;\r
+ \r
+ case INTENS :\r
+ intens((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case PALETT :\r
+ pallet((int *) ¶m[ 0 ].xword);\r
+ break;\r
+ \r
+ case VIDEO :\r
+ if (member(¶m[ 0 ].xvirt, &am))\r
+ if (M[ am ] >= 0x8000L/sizeof(word))\r
+ video(normalize((char *) &M[ am+3 ]));\r
+ else errsignal(RTEILLAB);\r
+ else errsignal(RTEREFTN);\r
+ break;\r
+\r
+ case HPAGE :\r
+ i = (int) param[ 1 ].xword;\r
+ if (i == 0) graphmode = FALSE;\r
+ else\r
+ if (i == 1) graphmode = TRUE;\r
+ hpage((int *) ¶m[ 0 ].xword, &i,\r
+ (int *) ¶m[ 2 ].xword);\r
+ break;\r
+\r
+ case NOCARD :\r
+ param[ 0 ].xword = nocard(NULL);\r
+ break;\r
+*/\r
+ \r
+ case TRACK :\r
+ send_par(0)\r
+ send_par(1)\r
+ send_sig\r
+ nxtev\r
+ rec_shrt( curx )\r
+ rec_shrt( cury )\r
+ break;\r
+\r
+ case INKEY :\r
+ if( child_no == 0 ) param[ 0 ].xword = inkey();\r
+ else\r
+ {\r
+ int keycode;\r
+ send_sig\r
+ nxtev\r
+ rec_word(keycode)\r
+ param[ 0 ].xword = keycode;\r
+ }\r
+ break;\r
+\r
+/*\r
+ case HFONT :\r
+ hfont((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+ \r
+ case HFONT8 :\r
+ param[ 0 ].xword = 0;\r
+ param[ 1 ].xword = 0;\r
+ hfont8((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);\r
+ break;\r
+*/\r
+\r
+ case CIRB :\r
+ {\r
+ double alfa,beta,aspect,abs; word kolb,wwyp;\r
+\r
+ send_par(0)\r
+ send_par(1)\r
+ param[2].xword *= 2;\r
+ send_par(2)\r
+ alfa = (double)(param[3].xreal);\r
+ beta = (double)(param[4].xreal);\r
+ kolb = param[5].xword;\r
+ wwyp = param[6].xword;\r
+\r
+ aspect = (double)(param[7].xword) / (double)(param[8].xword);\r
+ aspect *= (double)(param[2].xword);\r
+\r
+ alfa = alfa / M_PI * 180.0 * 64.0 ;\r
+ beta = beta / M_PI * 180.0 * 64.0 ;\r
+\r
+ abs = alfa - beta;\r
+ if( abs < 0.0 ) abs = -abs;\r
+ if( abs < 0.0001 )\r
+ beta+=360.0*64.0;\r
+\r
+ send_shrt( (unsigned)aspect )\r
+ send_shrt( (unsigned)alfa )\r
+ send_shrt( (unsigned)beta )\r
+ send_sig\r
+ }\r
+ break;\r
+\r
+/* MOUSE */\r
+\r
+ case INIT :\r
+ param[ 0 ].xbool = 2;\r
+ param[ 1 ].xbool = lbool(1);\r
+ break;\r
+ \r
+ case STATUS :\r
+ send_sig\r
+ nxtev\r
+ rec_par(0)\r
+ rec_par(1)\r
+ rec_par(2)\r
+ rec_par(3)\r
+ rec_par(4)\r
+ break;\r
+ \r
+ case GETPRESS :\r
+ case GETRELEASE :\r
+ send_par(0)\r
+ send_sig\r
+ nxtev\r
+ rec_par(1)\r
+ rec_par(2)\r
+ rec_par(3)\r
+ rec_par(4)\r
+ rec_par(5)\r
+ rec_par(6)\r
+ break;\r
+ \r
+ case SHOWCURSOR :\r
+ case HIDECURSOR :\r
+ case SETPOSITION :\r
+ case SETWINDOW :\r
+ case DEFCURSOR :\r
+ case SETSPEED :\r
+ case SETMARGINS :\r
+ case SETTHRESHOLD :\r
+ break;\r
+\r
+ case GETMOVEMENT :\r
+ send_sig\r
+ nxtev\r
+ rec_par(0)\r
+ rec_par(1)\r
+ break;\r
+\r
--- /dev/null
+ \r
+ Warsaw 1990, Michal Pakier\r
+ \r
+ Loglan Environment Manager \r
+ --------------------------\r
+ \r
+1:Program installation\r
+----------------------\r
+ Just run LOTEK.EXE - the system contains some additional files but you\r
+ need not know anything about that. \r
+ \r
+ The whole system comprises of the following files :\r
+ LOTEK.EXE - main program,\r
+ MPLOGED.EXE - editor,\r
+ LSTTEST.EXE - auxiliary file used during compilation,\r
+ LOTEK.HLP - help file text,\r
+ LOTEKINS.EXE - installation file. \r
+\r
+2:Text editor \r
+-------------\r
+ You may treat the whole program as a Loglan-oriented editor.\r
+ It supports the following facilities : \r
+ 1.Block operations \r
+ All common block operations, such as deleting, moving, copying,\r
+ indenting, unindenting, saving, loading, are implemented as well as some\r
+ sophisticated ones : moving and copying with whole block adjusting,\r
+ making a frame in comments for blocks (you may set such frame parameters\r
+ as width, pattern, text adjusting inside the block).\r
+ You may also copy or move a block into itself (while moving,the block\r
+ will be adjusted in such a way that the block beginning will be placed\r
+ at the cursor position).\r
+ 2.Find and replace word operations \r
+ You may find or find and replace given word or the word pointed\r
+ by the cursor. You may also change small letters into capital ones\r
+ (or the other way round) in Loglan keywords globally or locally.\r
+ There is a function that changes all the characters into small \r
+ or capital letters (globally, locally or in comments).\r
+ 3.Fast moving round the text \r
+ You may mark two positions in the text and go to that places \r
+ from anywhere. You may go to the text beginning or end, too. \r
+ 4.Help \r
+ You may always press the F1 key to get short review of all available \r
+ at the moment operations.\r
+ 5.Macro instructions\r
+ They really make writing programs much easier than when you have to get\r
+ round without them.\r
+ You may bind a macro instruction to every key from among [a..z,0..9,\r
+ F1..F10]. A macro is then called just by pressing the Alt key \r
+ with desired key.\r
+ A macro may be any sequence of characters. Using macros you may define\r
+ on-line some useful operarations, eg inserting a blank line, upcasing\r
+ words, marking blocks, ...\r
+ 6.File handling \r
+ The following operations are implemented :\r
+ loading a file from disc, \r
+ editing a file (unnamed new file has name 'noname.log'),\r
+ saving a file to disc,\r
+ changing a file name.\r
+ You may also choose a file for editing from among last ten used.\r
+ \r
+3:Windows\r
+---------\r
+ You may use three windows.\r
+ The first one is the main window, in which you may process everything that\r
+ is supported by the system. In the second window you cannot only compile\r
+ programs and process operations from window 'Execute'. The third window \r
+ does not let you edit but is used for viewing the database that contains\r
+ data about Loglan.\r
+ You may use up to two windows at the same time. The main window is always\r
+ visible so you cannot use both of the additional windows at the same time.\r
+ While being in the main window you may move or copy a block from another\r
+ visible window (all options are available).\r
+\r
+4:Compiling\r
+-----------\r
+ You may compile a file from the main window without returning to DOS.\r
+ You may execute the first, the second pass of compilation, run compiled\r
+ program, trace run program.\r
+ You do not have to remember which passes of compilation have been executed\r
+ or whether have they been executed at all - LOTEK will take care of it.\r
+ You may view found errors after the first pass of compilation. Information\r
+ about errors will displayed in the bottom line and the cursor will indicate\r
+ the position of its occurence.\r
+ \r
+5:Window 'Execute'\r
+------------------\r
+ You may define this window during the installation. It lets you call any DOS\r
+ function or any executable program. After this call you will find yourself\r
+ back in the editor as if you were doing nothing but editing. You may pass\r
+ command line parameters (name of edited file) to called programs, too.\r
+ \r
+6:Database\r
+----------\r
+ It is meant to be a database on Loglan but you may set any other database \r
+ instead (created by program MPH) during installation.\r
+ Such a database consists of maximum 6 windows, every of which may comprise\r
+ of maximum 22 lines. Every line is mapped to any length contents and every\r
+ contents line is mapped to any length text.\r
+ While viewing the database you may evoke some of the editor functions :\r
+ namely finding given word and marking a block. A marked block may be later on\r
+ moved to the main program.\r
+ It is possible to have the information from the database you are interested\r
+ in in one window and to edit your program in the main window.\r
+7:Using LOTEK\r
+--- ----------\r
+ Just run the program LOTEK.\r
+ There are displayed all the functions available at the moment at the bottom\r
+ of the screen. If you want to have more room for editing, just press the F10\r
+ key and this information will disappear. \r
+ LOTEK saves all the options on file MPLED.DAT before exit, so when you run\r
+ LOTEK once more you will find yourself in exactly the same conditions \r
+ (ie the same file, the same cursor position, the same options, ...) as you\r
+ were in when using LOTEK for the last time.\r
+ The editor has a built-in mechanism protecting the monitor - there will\r
+ appear a sky on the screen after two minutes during which you have not \r
+ pressed any key. The sky will vanish when you press any key.\r
+ LOTEK always saves the last but one version of the program, which is being\r
+ edited, so you have a copy of the program. This file's name is the same as\r
+ yours file but its extension is .BAK.\r
+ \r
+ \1a
\ No newline at end of file
--- /dev/null
+ 103 156 ³ Informacje ogolne\r
+ 166 193 ³ Procedury poziomu 1\r
+ 203 345 ³ Procedury ustawiania trybu\r
+ 356 527 ³ Procedury sterujace kolorami\r
+ 537 596 ³ Procedury ustawiania pozycji\r
+ 607 616 ³ Procedury obslugujace punkty\r
+ 626 684 ³ Procedury rysowania linii\r
+ 694 739 ³ Procedury operujace na fragmentach ekranu\r
+ 749 813 ³ Procedury wejscia/wyjscia dla pojedynczych znakow\r
+ 825 857 ³ Procedury wejscia/wyjscia dla linii\r
+ 869 916 ³ Procedury wejscia/wyjscia dla okienek\r
+ 926 928 ³ Procedury poziomu 2\r
+ 935 1021 ³ Definiowanie okna\r
+ 1031 1059 ³ Informacje dodatkowe\r
+ 1067 1084 ³ Procedury dodatkowe\r
+ 1099 1120 ³ Uzycie IIUWGRAFu z FORTRANem 77.\r
+ 1134 1144 ³ Uzycie IIUWGRAFu z PASCALem.\r
+ 1157 1188 ³ Uzycie IIUWGRAFu z Lattice C.\r
+ 1202 1219 ³ Uzycie IIUWGRAFu z LOGLANem.\r
+ 1233 1307 ³ Wykaz specyfikacji procedur IIUWGRAFu.\r
+ 1357 1507 ³ FEDIT\r
+ 1520 1545 ³ Zmiany IIUWGRAFu w stosunku do poprzednich wersj\r
+ 197 222 ³ List of symbols\r
+ 226 444 ³ 1. Preface\r
+ 3 89 ³ 2. The basic characteristics of LOGLAN-82\r
+ 451 597 ³ 2.1. Control structure\r
+ 601 690 ³ 2.2. Block structure\r
+ 694 734 ³ 2.3. Procedures and functions\r
+ 738 789 ³ 2.4. Classes\r
+ 793 885 ³ 2.5. Prefixing\r
+ 889 932 ³ 2.6. Object deallocator\r
+ 936 975 ³ 2.7. Arrays\r
+ 980 1032 ³ 2.8. Parameters\r
+ 1036 1076 ³ 2.9. Coroutines\r
+ 1081 1132 ³ 2.10. Processes\r
+ 1136 1168 ³ 2.11. Other important features\r
+ 1172 1297 ³ 3. Lexical and textual structure\r
+ 1301 1341 ³ 4. Types\r
+ 1345 1391 ³ 4.1. Primitive types\r
+ 1395 1441 ³ 4.2. System types\r
+ 1445 1456 ³ 4.3. Compound types and objects\r
+ 1457 1498 ³ 4.3.1. Array type\r
+ 1502 1528 ³ 4.3.2. Class type\r
+ 1532 1556 ³ 4.4. Formal types\r
+ 1560 1591 ³ 5.Declarations\r
+ 1594 1619 ³ 5.1. Constant declaration\r
+ 1623 1672 ³ 5.2. Variable declaration\r
+ 1677 1690 ³ 5.3. Unit declaration\r
+ 1691 1731 ³ 5.3.1. Class declaration (introduction)\r
+ 1735 1806 ³ 5.3.2. Subprogram declaration (introduction)\r
+ 1810 1843 ³ 5.3.3. Block\r
+ 1847 1879 ³ 5.3.4. Prefixing\r
+ 1883 2015 ³ 5.3.5. Formal parameters\r
+ 2019 2112 ³ 5.3.6. Unit body\r
+ 2116 2133 ³ 6. Static and dynamic locations\r
+ 2135 2164 ³ 6.1. Unit attributes\r
+ 2168 2177 ³ 6.2. Protected attributes\r
+ 2179 2206 ³ 6.2.1. Hidden attributes\r
+ 2210 2223 ³ 6.2.2. Taken attributes\r
+ 2226 2249 ³ 6.2.3. Legal and illegal identifiers\r
+ 2253 2304 ³ 6.2.4. Close attributes\r
+ 2308 2390 ³ 6.3. Static location\r
+ 2394 2427 ³ 6.4. Objects\r
+ 2431 2564 ³ 6.4.1. Virtual attributes\r
+ 2568 2663 ³ 6.4.2. Valuation of virtuals\r
+ 2667 2720 ³ 6.5. Dynamic location\r
+ 2724 2783 ³ 7. Consistency of types\r
+ 2787 2835 ³ 8. Expressions\r
+ 2839 2864 ³ 8.1. Constant\r
+ 2868 2889 ³ 8.2. Variable\r
+ 2893 2927 ³ 8.2.1. Simple variable\r
+ 2931 2971 ³ 8.2.2. Subscripted variable\r
+ 2975 3018 ³ 8.2.3. Dotted variable\r
+ 3022 3059 ³ 8.2.4. System variable\r
+ 3063 3176 ³ 8.3. Arithmetic expression\r
+ 3180 3359 ³ 8.4. Boolean expression\r
+ 3363 3406 ³ 8.5. Character expression\r
+ 3410 3453 ³ 8.6. String expression\r
+ 3457 3525 ³ 8.7. Object expression\r
+ 3529 3551 ³ 9. Sequential statements.\r
+ 3558 3585 ³ 9.1. Sequential primitive statements\r
+ 3590 3737 ³ 9.1.1. Evaluation statement\r
+ 3741 3758 ³ 9.1.2. Configuration statement\r
+ 3761 4133 ³ 9.1.2.1. Allocation statement\r
+ 4137 4201 ³ 9.1.2.2. Deallocation statement\r
+ 4205 4291 ³ 9.1.3. Simple control statement\r
+ 4295 4348 ³ 9.1.4. Coroutine statement\r
+ 4352 4368 ³ 9.2. Compound statements\r
+ 4373 4439 ³ 9.2.1. Conditional statement\r
+ 4443 4499 ³ 9.2.2. Case statement\r
+ 4506 4799 ³ 9.2.3. Iteration statement\r
+ 4803 4819 ³ 10. Exception handling\r
+ 4822 4844 ³ 10.1. Signal specification\r
+ 4848 4898 ³ 10.2. Signal handlers\r
+ 4902 5046 ³ 10.3. Signal raising\r
+ 5050 5145 ³ 10.4. Handler execution\r
+ 5149 5183 ³ 10.5. System signals\r
+ 5187 5269 ³ 11. Processes\r
+ 5274 5403 ³ 11.1. Transition state statement\r
+ 5407 5588 ³ 11.2. Primitive synchronizing statement\r
+ 5592 5760 ³ 11.3. Monitors (compound synchronization facilities)\r
+ 5765 5862 ³ 12. Separate compilation of units\r
+ 5866 5920 ³ 12.1. Library items\r
+ 5924 6084 ³ 12.1.1. Interface\r
+ 6088 6140 ³ 12.1.2. Using languages\r
+ 6144 6151 ³ 12.1.3. Using externals\r
+ 6155 6198 ³ 12.1.4. Using sl-virtuals\r
+ 6202 6224 ³ 12.2. Linking library items\r
+ 6227 6373 ³ 12.2.1. Connecting the interface\r
+ 6377 6419 ³ 12.3. Binary items\r
+ 6423 6425 ³ 12.4. Processing libraries\r
+ 6427 6452 ³ 12.4.1. Recompilation\r
+ 6456 6482 ³ 12.4.2. Insertions and deletions\r
+ 3 89 ³ 13. File processing\r
+ 6490 6524 ³ 13.1. External and internal files\r
+ 6528 6608 ³ 13.2. File generation and deallocation\r
+ 6612 6663 ³ 13.3. Binary input-output\r
+ 6667 6723 ³ 13.4. Other predefined operations\r
+ 6727 6817 ³ 13.5. Text input-output\r
+ 6821 6880 ³ 13.6. Example of high-level file processing\r
+ 6884 6973 ³ Bibliography\r
+ 19 100 ³Wstep\r
+ 105 349 ³1. Compound statements\r
+ 354 443 ³2. Modularity\r
+ 449 637 ³3. Procedures and functions\r
+ 642 829 ³4. Classes\r
+ 834 975 ³5. Adjustable arrays\r
+ 981 1158 ³6. Coroutines and semicoroutines\r
+ 1164 1490 ³7. Prefixing\r
+ 1496 1548 ³8. Formal types\r
+ 1554 1591 ³9. Protection techniques\r
+ 1597 1691 ³10. Programmed deallocation\r
+ 1697 1781 ³11. Exception handling\r
+ 1785 1788 ³12. Separate compilation (this section does not apply to PC vers\r
+ 1793 1999 ³13. Processes\r
+ 2005 2009 ³References.\r
+ 20 29 ³Wstep\r
+ 110 118 ³0. Preface\r
+ 123 141 ³1. Using Loglan-82 system\r
+ 146 184 ³ 1.1. Compilation\r
+ 187 216 ³ 1.2. Compiler switches\r
+ 220 245 ³ 1.3. Code generation\r
+ 249 294 ³ 1.4. Program interpretation\r
+ 296 327 ³ 1.5. Compile time error\r
+ 332 341 ³ 1.6. Run-time errors\r
+ 346 359 ³2. Compiler options\r
+ 362 371 ³ 2.1. Option format\r
+ 378 403 ³ 2.2. Options list\r
+ 408 410 ³3. Loglan implementation specification\r
+ 411 419 ³ 3.1. Implemented subset of Loglan\r
+ 422 432 ³ 3.2. Non-standard language elements\r
+ 437 442 ³ 3.3. File system\r
+ 445 461 ³ 3.3.1. File variables\r
+ 465 501 ³ 3.3.2. File generation\r
+ 504 508 ³ 3.3.3. File deallocation\r
+ 512 530 ³ 3.3.4. General file operations\r
+ 535 556 ³ 3.3.5. Text files\r
+ 560 577 ³ 3.3.6. Binary sequential files\r
+ 581 630 ³ 3.3.7. Direct access binary files\r
+ 635 644 ³ 3.4. Concurrency\r
+ 647 676 ³ 3.4.1. Invoking the LOGLAN interpreter for concurrent pro\r
+ 679 753 ³ 3.4.2. Restrictions and differences from the report\r
+ 756 841 ³ 3.4.3. Communication mechanism\r
+ 846 865 ³ 3.5. System signals\r
+ 870 910 ³ 3.6. Implementation restrictions\r
+ 913 922 ³A. Standard constants\r
+ 928 1077 ³B. Standard classes\r
+ 931 972 ³ IIUWGRAPH\r
+ 976 1077 ³ MOUSE\r
+ 1082 1196 ³C. Standard procedures and functions\r
+ 1202 1755 ³D. Error codes\r
+ 1758 1833 ³E. Loglan runtime errors\r
+ 1835 1914 ³F. Character set\r
+ 1919 1923 ³Bibliography\r
+ 435 455 ³ proc BORDER(consts b: integer);\r
+ 883 889 ³ L proc BURY(window: buffer);\r
+ 636 649 ³ proc CIRB(consts ix,iy,ir: integer;\r
+ 636 649 ³ consts alfa, beta: real;\r
+ 636 649 ³ consts cbord, bcint, p, q: integer);\r
+ 250 253 ³ proc CLS;\r
+ 356 379 ³ proc COLOR(consts c: integer);\r
+ 626 632 ³ proc DRAW(consts ix,iy: integer);\r
+ 892 896 ³ L proc EXPOSE(window: buffer; consts x,y: integer)\r
+ 694 714 ³ L proc GETMAP(consts x,y: integer; ekran: buffer);\r
+ 242 247 ³ L proc GROFF;\r
+ 203 220 ³ proc GRON(consts imode: integer);\r
+ 770 794 ³ proc HASCII(consts ic: integer);\r
+ 652 667 ³ proc HFILL(consts maxx: integer);\r
+ 802 806 ³ proc HFONT(consts seg, offs: integer);\r
+ 809 813 ³ proc HFONT8(vars seg, offs: integer);\r
+ 260 298 ³ proc HPAGE(consts page, mode, clear: integer);\r
+ 832 857 ³ P proc INHLINE(vars n:integer; line: tekst);\r
+ 520 527 ³ proc INTENS(consts i: integer);\r
+ 907 916 ³ PL proc INWLINE(window: buffer; vars n: integer;\r
+ 907 916 ³ line: tekst);\r
+ 869 880 ³ L proc MKWNDW(consts x,y,icols,ilines: integer;\r
+ 869 880 ³ window: buffer;\r
+ 869 880 ³ consts iwndwsize,iborder: integer);\r
+ 537 547 ³ proc MOVE(consts ix,iy: integer);\r
+ 728 732 ³ proc ORMAP(ekran: buffer);\r
+ 825 829 ³ PL proc OUTHLINE(consts n:integer; line: tekst);\r
+ 899 904 ³ PL proc OUTWLINE(window: buffer; consts n: integer;\r
+ 899 904 ³ line: tekst);\r
+ 458 516 ³ proc PALLET(consts p: integer);\r
+ 411 432 ³ proc PATERN(consts p1, p2, p3, p4: integer);\r
+ 607 610 ³ proc POINT(consts ix,iy: integer);\r
+ 558 577 ³ proc POPXY;\r
+ 1067 1084 ³ proc PRTSCR(consts nr: integer);\r
+ 550 555 ³ proc PUSHXY;\r
+ 718 725 ³ proc PUTMAP(ekran: buffer);\r
+ 1015 1021 ³ L proc RCIRB(consts ix,iy,ir: real;\r
+ 1015 1021 ³ consts alfa, beta: real;\r
+ 1015 1021 ³ consts cbord, bcint, p, q: integer);\r
+ 1006 1011 ³ L proc RDRAW(consts rx,ry: real);\r
+ 998 1002 ³ L proc RMOVE(consts rx,ry: real);\r
+ 981 984 ³ PL proc RWINDOW(rw: array [1:4] of real;\r
+ 981 984 ³ consts s: integer);\r
+ 382 405 ³ proc STYLE(consts s: integer);\f\r
+ 935 974 ³ PL proc SWINDOW(rw: array [1:4] of real;\r
+ 935 974 ³ iw: array [1:4] of integer;\r
+ 935 974 ³ consts s: integer);\r
+ 584 596 ³ proc TRACK(consts x,y: integer);\r
+ 675 684 ³ proc VFILL(consts maxy: integer);\r
+ 301 345 ³ proc VIDEO(ekran: buffer);\r
+ 735 739 ³ proc XORMAP(ekran: buffer);\r
+ 979 982 ³MOUSE\r
+ 989 993 ³showcursor:procedure\r
+ 995 999 ³hidecursor:procedure\r
+ 1001 1007 ³status:procedure(output h, v:integer, l, r, c:boolean)\r
+ 1009 1014 ³setposition:procedure(h, v:integer)\r
+ 1016 1022 ³getpress:procedure(b:integer; output h, v, p:integer, l, r, c:boo\r
+ 1024 1030 ³getrelease:procedure(b:integer; output h, v, p:integer, l, r, c:b\r
+ 1032 1036 ³setwindow:procedure(l, r, t, b:integer)\r
+ 1039 1054 ³defcursor:procedure(s, x, y:integer)\r
+ 1056 1058 ³getmovement:procedure(output h, v:integer)\r
+ 1060 1069 ³setspeed:procedure(h, v:integer)\r
+ 1071 1077 ³setthreshold:procedure(s:integer)\r
+ 1085 1086 ³ ENDRUN:procedure;\r
+ 1088 1089 ³ RANSET:procedure(x:real);\r
+ 1180 1182 ³ RESET:procedure(f:file);\r
+ 1184 1187 ³ REWRITE:procedure(f:file);\r
+ 1189 1190 ³ UNLINK:procedure(f:file);\r
+ 1192 1193 ³ SEEK:procedure(f:file; offset, base:integer);\r
+ 749 765 ³ L func INKEY(consts idummy: integer): integer;\r
+ 613 616 ³ func INPIX(consts x,y: integer): integer;\r
+ 543 547 ³ L func INXPOS(consts idummy: integer): integer;\r
+ 543 547 ³ L func INYPOS(consts idummy: integer): integer;\r
+ 224 238 ³ L func NOCARD(consts idummy: integer): integer;\r
+ 988 994 ³ PL func RINXPOS(consts dummy: real): real;\r
+ 988 994 ³ PL func RINYPOS(consts dummy: real): real;\r
+ 976 982 ³MOUSE\r
+ 984 987 ³init:function(output b:integer):boolean\r
+ 1091 1093 ³ RANDOM:function:real;\r
+ 1095 1096 ³ SQRT:function(x:real):real;\r
+ 1098 1099 ³ SIN:function(x:real):real;\r
+ 1101 1102 ³ COS:function(x:real):real;\r
+ 1104 1105 ³ TAN:function(x:real):real;\r
+ 1107 1108 ³ EXP:function(x:real):real;\r
+ 1110 1111 ³ LN:function(x:real):real;\r
+ 1113 1114 ³ ATAN:function(x:real):real;\r
+ 1116 1117 ³ ENTIER:function(x:real):integer;\r
+ 1119 1121 ³ ROUND:function(x:real):integer;\r
+ 1123 1124 ³ IMIN:function(x, y:integer):integer;\r
+ 1126 1127 ³ IMAX:function(x, y:integer):integer;\r
+ 1129 1130 ³ IMIN3:function(x, y, z:integer):integer;\r
+ 1132 1133 ³ IMAX3:function(x, y, z:integer):integer;\r
+ 1135 1137 ³ ISHFT:function(x, k:integer):integer;\r
+ 1139 1140 ³ IAND:function(n, k:integer):integer;\r
+ 1142 1143 ³ IOR:function(n, k:integer):integer;\r
+ 1145 1146 ³ XOR:function(n, k:integer):integer;\r
+ 1148 1150 ³ INOT:function(n:integer):integer;\r
+ 1152 1156 ³ ORD:function(c:char):integer;\r
+ 1158 1160 ³ CHR:function(n:integer):char;\r
+ 1162 1164 ³ UNPACK:function(s:string):arrayof char;\r
+ 1166 1168 ³ MEMAVAIL:function:integer;\r
+ 1170 1173 ³ EXEC:function(cmd:arrayof char):integer;\r
+ 1175 1178 ³ TIME:function: integer;\r
+ 1195 1196 ³ POSITION:function(f:file):real;\r
+ 1319 1345 ³ Wartosci kodow klawiszy specjalnych:\r
+ 1206 1213 ³ 0 - ***declaration part overloaded\r
+ 1214 1217 ³ 10 - ***too many errors\r
+ 1218 1219 ³ 41 - ***declaration part overloaded\r
+ 1220 1220 ³ 101 - ':=' expected\r
+ 1221 1221 ³ 102 - ';' expected\r
+ 1222 1222 ³ 103 - 'then' expected\r
+ 1223 1223 ³ 104 - 'fi'/'else' expected\r
+ 1224 1224 ³ 105 - 'od' expected\r
+ 1225 1225 ³ 106 - '(' expected\r
+ 1226 1226 ³ 107 - ')' expected\r
+ 1227 1227 ³ 108 - 'do' expected\r
+ 1228 1228 ³ 109 - identifier expected\r
+ 1229 1231 ³ 110 - too many exits found\r
+ 1232 1232 ³ 111 - illegal character\r
+ 1233 1233 ³ 112 - wrong structure of 'if'-statement\r
+ 1234 1234 ³ 113 - 'end' missing\r
+ 1235 1235 ³ 114 - '.' expected\r
+ 1236 1238 ³ 115 - illegal constant in expression\r
+ 1239 1239 ³ 116 - '=' expected\r
+ 1240 1240 ³ 117 - constant expected\r
+ 1241 1241 ³ 118 - ':' expected\r
+ 1242 1244 ³ 119 - unit kind specification expected\r
+ 1245 1245 ³ 120 - 'hidden' or 'close' occurred twice\r
+ 1246 1246 ³ 121 - 'hidden' or 'close' out of a class\r
+ 1247 1247 ³ 122 - 'block' expected\r
+ 1248 1250 ³ 123 - object expression is not a generator\r
+ 1251 1251 ³ 124 - 'dim' expected\r
+ 1252 1252 ³ 125 - 'to'/'downto' expected\r
+ 1253 1253 ³ 126 - illegal arithmetic operator\r
+ 1254 1254 ³ 127 - declaration part expected\r
+ 1255 1257 ³ 128 - incorrect identifier at 'end'\r
+ 1258 1258 ³ 129 - wrong structure of 'case'-statement\r
+ 1259 1259 ³ 130 - wrong structure of 'do'-statement\r
+ 1260 1262 ³ 131 - illegal use of 'main'\r
+ 1263 1263 ³ 132 - 'when' expected\r
+ 1264 1266 ³ 133 - too many branches in 'case'-statement\r
+ 1267 1267 ³ 134 - 'begin' missed\r
+ 1268 1268 ³ 135 - bad option\r
+ 1269 1271 ³ 136 - is it really a loglan program???\r
+ 1272 1276 ³ 137 - 'block' missed - parsing began\r
+ 1277 1279 ³ 138 - 'repeat' out of a loop\r
+ 1280 1280 ³ 139 - there is no path to this statement\r
+ 1281 1281 ³ 140 - 'andif'/'orif' mixed\r
+ 1282 1282 ³ 141 - array of 'semaphore' is illegal\r
+ 1283 1285 ³ 142 - wrong handler end\r
+ 1286 1286 ³ 143 - lastwill inside a structured statement\r
+ 1287 1289 ³ 144 - repeated lastwill\r
+ 1290 1290 ³ 145 - no parameter specification\r
+ 1291 1291 ³ 146 - wrong register specification\r
+ 1292 1292 ³ 147 - "," expected\r
+ 1293 1296 ³ 191 - ***null program\r
+ 1297 1300 ³ 196 - ***too many identifiers\r
+ 1301 1304 ³ 197 - ***too many formal parameters\r
+ 1305 1307 ³ 198 - ***parsing stack overloaded\r
+ 1308 1311 ³ 199 - ***too many prototypes\r
+ 1312 1312 ³ 201 - wrong real constant\r
+ 1313 1313 ³ 202 - wrong comment\r
+ 1314 1314 ³ 203 - wrong character constant\r
+ 1315 1315 ³ 204 - wrong integer constant\r
+ 1316 1317 ³ 205 - integer overflow\r
+ 1318 1319 ³ 206 - real overflow\r
+ 1320 1322 ³ 211 - identifier too long\r
+ 1323 1325 ³ 212 - string too long\r
+ 1326 1329 ³ 301 - prefix is not a class id\r
+ 1330 1332 ³ 303 - coroutine/process illegal here as prefix id\r
+ 1333 1335 ³ 304 - hidden identifier cannot be taken id\r
+ 1336 1336 ³ 305 - undeclared identifier id\r
+ 1337 1337 ³ 306 - undeclared type identifier id\r
+ 1338 1342 ³ 307 - type identifier expected id\r
+ 1343 1343 ³ 308 - undeclared prefix identifier id\r
+ 1344 1344 ³ 309 - declared more than once id\r
+ 1345 1345 ³ 310 - taken list in unprefixed unit\r
+ 1346 1349 ³ 316 - formal type specification after use id\r
+ 1350 1353 ³ 317 - hidden type identifier id\r
+ 1354 1356 ³ 318 - type identifier not taken id\r
+ 1357 1359 ³ 319 - hidden identifier in the list id\r
+ 1360 1363 ³ 320 - identifier in the list not taken id\r
+ 1364 1366 ³ 321 - identifier cannot be taken id\r
+ 1367 1368 ³ 322 - hidden prefix identifier id\r
+ 1369 1370 ³ 323 - prefix identifier not taken id\r
+ 1371 1373 ³ 329 - only procedure and function may be virtual\r
+ 1374 1374 ³ 330 - virtual in unprefixed block/procedure/function\r
+ 1375 1378 ³ 331 - incompatible kinds of virtuals id\r
+ 1379 1381 ³ 332 - incompatible types of virtuals id\r
+ 1382 1384 ³ 333 - different lengths of form.param.lists in virtuals\r
+ 1385 1390 ³ 334 - conflict kinds of the 1st level parameters\r
+ 1391 1395 ³ 335 - incompatible types of the 1st level parameters\r
+ 1396 1400 ³ 336 - different lengths of the 2nd level params lists\r
+ 1401 1405 ³ 337 - incompatible kinds of the 2nd level parameters i\r
+ 1406 1410 ³ 338 - incompatible types of the 2nd level parameters i\r
+ 1411 1412 ³ 341 - ***declaration part overloaded\r
+ 1413 1413 ³ 342 - ***too many classes declared\r
+ 1414 1415 ³ 343 - ***too many prototypes\r
+ 1416 1416 ³ 350 - undeclared signal identifier id\r
+ 1417 1418 ³ 351 - hidden signal identifier id\r
+ 1419 1420 ³ 352 - signal identifier not taken id\r
+ 1421 1423 ³ 353 - signal identifier expected id\r
+ 1424 1428 ³ 354 - different types of parameters id\r
+ 1429 1432 ³ 355 - incompatible kinds of parameters id\r
+ 1433 1436 ³ 356 - different identifiers of parameters id\r
+ 1437 1438 ³ 357 - incompatible kinds of the 2nd level parameters i\r
+ 1439 1440 ³ 358 - different types of the 2nd level parameters\r
+ 1441 1446 ³ 359 - different lengths of the 2nd level params lists\r
+ 1447 1450 ³ 360 - different lengths of form. param. lists in signal\r
+ 1451 1453 ³ 361 - non-local formal type cannot be used id\r
+ 1454 1456 ³ 362 - repeated handler for signal id\r
+ 1457 1459 ³ 370 - only 'input' is legal here\r
+ 1460 1473 ³ 398 - class prefixed by itself id\r
+ 1474 1476 ³ 404 - repeated label in 'case'-statement id\r
+ 1477 1479 ³ 405 - illegal type of 'case' expression id\r
+ 1480 1480 ³ 406 - different types of labels and 'case' expression\r
+ 1481 1481 ³ 407 - non-logical expression after 'if'/'while' i\r
+ 1482 1484 ³ 408 - real constant out of integer range\r
+ 1485 1487 ³ 410 - simple variable expected id\r
+ 1488 1490 ³ 411 - non-integer control variable id\r
+ 1491 1495 ³ 412 - non-integer expression id\r
+ 1496 1496 ³ 413 - file expression expected id\r
+ 1497 1497 ³ 414 - string expression expected id\r
+ 1498 1501 ³ 415 - reference expression expected id\r
+ 1502 1502 ³ 416 - array expression expected id\r
+ 1503 1503 ³ 417 - boolean expression expected id\r
+ 1504 1504 ³ 418 - semaphore variable expected\r
+ 1505 1507 ³ 419 - illegal type in 'open'\r
+ 1508 1511 ³ 420 - variable expected id\r
+ 1512 1514 ³ 421 - class identifier after 'new' expected id\r
+ 1515 1515 ³ 422 - procedure identifier after 'call' expected\r
+ 1516 1518 ³ 423 - 'new' missing id\r
+ 1519 1521 ³ 424 - 'call' missing id\r
+ 1522 1522 ³ 425 - 'inner' out of a class\r
+ 1523 1523 ³ 426 - 'inner' occurred more than once\r
+ 1524 1524 ³ 427 - 'wind'/'terminate' out of a handler\r
+ 1525 1525 ³ 428 - 'inner' inside lastwill\r
+ 1526 1528 ³ 429 - definition cannot be reduced to constant id\r
+ 1529 1529 ³ 430 - undefined constant in the definition id\r
+ 1530 1532 ³ 431 - wrong number of indices id\r
+ 1533 1533 ³ 432 - index out of range id\r
+ 1534 1534 ³ 433 - upper bound less than lower bound id\r
+ 1535 1536 ³ 434 - too many subscripts id\r
+ 1537 1537 ³ 435 - variable is not array id\r
+ 1538 1541 ³ 440 - type identifier expected after 'arrayof' id\r
+ 1542 1545 ³ 441 - incorrect format in 'write'\r
+ 1546 1548 ³ 442 - illegal expression in 'write'\r
+ 1549 1551 ³ 443 - illegal type of variable in 'read' id\r
+ 1552 1553 ³ 444 - no data for i/o transfer\r
+ 1554 1554 ³ 445 - illegal expression in 'put'\r
+ 1555 1555 ³ 446 - illegal expression in 'get'\r
+ 1556 1558 ³ 448 - 'raise' missing id\r
+ 1559 1561 ³ 449 - signal identifier expected id\r
+ 1562 1563 ³ 450 - illegal procedure occurrence id\r
+ 1564 1565 ³ 451 - illegal class occurrence id\r
+ 1566 1567 ³ 452 - illegal type occurrence id\r
+ 1568 1569 ³ 453 - illegal signal occurrence id\r
+ 1570 1570 ³ 454 - illegal operator occurence\r
+ 1571 1571 ³ 455 - wrong number of operands\r
+ 1572 1572 ³ 460 - divided by zero\r
+ 1573 1576 ³ 470 - illegal input parameter id\r
+ 1577 1579 ³ 471 - illegal output parameter id\r
+ 1580 1582 ³ 472 - illegal type parameter id\r
+ 1583 1585 ³ 473 - illegal procedure parameter id\r
+ 1586 1588 ³ 474 - illegal function parameter id\r
+ 1589 1591 ³ 475 - illegal left side of 'is'/'in' id\r
+ 1592 1594 ³ 476 - illegal right side od 'is'/'in' id\r
+ 1595 1597 ³ 477 - illegal parameter of 'attach' id\r
+ 1598 1598 ³ 478 - illegal type of expression\r
+ 1599 1599 ³ 479 - negative step value\r
+ 1600 1606 ³ 550 - ***stack overloaded\r
+ 1607 1610 ³ 551 - ***too many auxiliary variables needed\r
+ 1611 1612 ³ 552 - ***too many auxiliary reference variable needed\r
+ 1613 1617 ³ 553 - ***statement sequence too long or too complicated\r
+ 1618 1621 ³ 554 - ***real constants dictionary overflow\r
+ 1622 1622 ³ 600 - undeclared identifier id\r
+ 1623 1625 ³ 601 - illegal type before '.' id\r
+ 1626 1629 ³ 602 - close identifier after '.' id\r
+ 1630 1634 ³ 603 - undeclared identifier after '.' id\r
+ 1635 1637 ³ 604 - illegal operand type id\r
+ 1638 1640 ³ 605 - illegal type in 'div/'mod' term id\r
+ 1641 1642 ³ 606 - incompatible types in comparison id\r
+ 1643 1646 ³ 607 - unrelated class types in comparison id\r
+ 1647 1648 ³ 608 - string cannot be compared id\r
+ 1649 1654 ³ 609 - incompatible types in assignment/transmission id\r
+ 1655 1656 ³ 610 - unrelated class types in assignment/transmission\r
+ 1657 1658 ³ 611 - constant after '.' id\r
+ 1659 1662 ³ 612 - this class does not occur in sl-chain id\r
+ 1663 1667 ³ 613,614 - class identifier expected id\r
+ 1668 1671 ³ 615 - illegal type before 'qua' id\r
+ 1672 1676 ³ 616,617 - illegal type after 'qua' id\r
+ 1677 1680 ³ 618 - unrelated types in 'qua'-expression id\r
+ 1681 1684 ³ 619 - hidden identifier id\r
+ 1685 1688 ³ 620 - not taken identifier id\r
+ 1689 1691 ³ 621 - invisible identifier after '.' id\r
+ 1692 1696 ³ 622 - formal parameter list is shorter id\r
+ 1697 1698 ³ 623 - formal parameter list is longer id\r
+ 1699 1702 ³ 624 - actual parameter is not a reference type id\r
+ 1703 1705 ³ 625 - actual parameter is not a type id\r
+ 1706 1710 ³ 626 - procedure-function conflict between parameters i\r
+ 1711 1716 ³ 627 - unmatched heads-wrong kinds of parameters i\r
+ 1717 1721 ³ 628 - unmatched heads-incompatible types in lists\r
+ 1722 1726 ³ 629 - unmatched heads-unrelated class types in lists i\r
+ 1727 1729 ³ 630 - unmatched heads-different numbers of parameters\r
+ 1730 1733 ³ 631 - incompatible types of function parameters\r
+ 1734 1737 ³ 632 - function/procedure expected id\r
+ 1738 1744 ³ 633 - actual function type defined weaker than formal\r
+ 1745 1750 ³ 634 - unmatched heads-too weak type in actual list\r
+ 1751 1753 ³ 635 - standard function/procedure cannot be actual par.\r
+ 1754 1754 ³ 636 - illegal use of semaphore id\r
+ 1755 1755 ³ 637 - 'semaphore' cannot be used id\r
+ 1760 1761 ³LOGLAN RUNTIME ERRORS\r
+ 1763 1764 ³ARRAY INDEX ERROR (CONERROR)\r
+ 1765 1765 ³NEGATIVE STEP VALUE (CONERROR)\r
+ 1766 1768 ³SL CHAIN CUT OFF (LOGERROR)\r
+ 1769 1771 ³ILLEGAL ATTACH (LOGERROR)\r
+ 1772 1774 ³ILLEGAL DETACH (LOGERROR)\r
+ 1775 1777 ³ILLEGAL RESUME (LOGERROR)\r
+ 1778 1779 ³TOO MANY PROCESSES ON ONE MACHINE (SYSERROR)\r
+ 1780 1782 ³INVALID NODE NUMBER (SYSERROR)\r
+ 1783 1786 ³IMPROPER QUA (LOGERROR)\r
+ 1787 1789 ³ILLEGAL ASSIGNMENT (TYPERROR)\r
+ 1790 1791 ³FORMAL TYPE MISSING (LOGERROR)\r
+ 1792 1793 ³ILLEGAL KILL (LOGERROR)\r
+ 1794 1797 ³ILLEGAL COPY (LOGERROR)\r
+ 1798 1800 ³REFERENCE TO NONE (ACCERROR)\r
+ 1801 1801 ³MEMORY OVERFLOW (MEMERROR)\r
+ 1802 1806 ³INCOMPATIBLE HEADERS (TYPERROR)\r
+ 1807 1809 ³INCORRECT ARRAY BOUNDS (CONERROR)\r
+ 1810 1810 ³DIVISION BY ZERO (NUMERROR)\r
+ 1811 1812 ³COROUTINE TERMINATED (LOGERROR)\r
+ 1813 1814 ³COROUTINE ACTIVE (LOGERROR)\r
+ 1815 1816 ³HANDLER NOT FOUND (LOGERROR)\r
+ 1817 1819 ³ILLEGAL RETURN (LOGERROR)\r
+ 1820 1821 ³UNIMPLEMENTED STANDARD PRC. (LOGERROR)\r
+ 1822 1823 ³FORMAL LIST TOO LONG (MEMERROR)\r
+ 1824 1826 ³ILLEGAL I/O OPERATION (SYSERROR)\r
+ 1827 1828 ³I/O ERROR (SYSERROR)\r
+ 1829 1829 ³CANNOT OPEN FILE (SYSERROR)\r
+ 1830 1830 ³INPUT DATA FORMAT BAD (SYSERROR)\r
+ 1831 1832 ³SYSTEM ERROR (SYSERROR)\r
+ 1833 1833 ³UNRECOGNIZED ERROR\r
+ 1838 1914 ³CHARACTER SET\r
--- /dev/null
+(* Loglanizator Tekstowy wersja 1.0 1990 Warszawa Michal Pakier *)\r
+===============REKORD 1=======================================|===============\r
++ 9 2 42 4 5 6 7 8\r
+ Obsluga edytora LOglanizator TEKstowy wersja 1.1\r
+ \r
+ Poslugiwanie sie helpem nacisnij <0>\r
+ Operacje edytorskie <1>\r
+ F3 Operacje plikowe <2>\r
+ F4 Wyszukiwanie bledow <3>\r
+ F5 Zmiana aktualnego okienka <4>\r
+ F8 Programy pomocnicze <5>\r
+ F9 Kompilacja <6>\r
+===============REKORD 2=======================================|===============\r
++ 11\r
+ INFORMACJA O POSLUGIWANIU SIE HELPEM.\r
+ \r
+ W kazdej sytuacji po nacisnieciu klawisza F1 mozemy otrzymac\r
+informacje o aktualnie dostepnych opcjach. Na wyswietlonym\r
+czesto moze byc wspomniane o mozliwosci uzyskania dokladniej-\r
+szych informacji na podany temat. Uzyskuje sie ja przez nacis-\r
+niecie jednego z klawiszy {0,1,2,3,4,5,6,7,8,9},co jest przed-\r
+stawione na ekranie przez wypisanie nazwy danego klawisza w na-\r
+wiasach trujkatnych.\r
+ Esc opuszczenie helpa\r
+ F1 przejscie do glownego okienka helpa\r
+===============REKORD 3=======================================|===============\r
++ 10 2 4\r
+ Nagrywanie pliku na dysk (F2,F3S)\r
+ \r
+Moze sie zdarzyc, ze z jakiegos powodu nie mozna nagrac pliku\r
+w katalogu, z ktorego go wgralismy. Wtedy nalezy przejsc (F3 L)\r
+do katalogu,w ktorym mamy wszystkie prawa i tam zgrac nasz plik\r
+opcja F3 W.\r
+ \r
+Aby dowiedziec sie wiecej o operacjach plikowych nacisnij <1>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 4=======================================|===============\r
++ 17 2 23 3 24 25 26 41\r
+ Operacje plikowe (F3)\r
+ \r
+Przy pomocy znajdujacych sie tu funkcji mozemy wybrac dowolny\r
+plik do edycji.\r
+Mamy do dyspozycji nastepujace funkcje:\r
+ \r
+ L Ladowanie pliku z dysku <1>\r
+ S Nagrywanie pliku na dysk <2>\r
+ N Rozpoczynanie edycji nowego pliku <3>\r
+ W Zmiana nazwy pliku <4>\r
+ P Ostatnio uzywane pliki <5>\r
+ O Rozne opcje <6>\r
+ G Informacje o edytowanych plikach i ilosci\r
+ wolnej pamieci.\r
+ Q Wyjscie z programu\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 5=======================================|===============\r
++ 18 2\r
+ POPRAWIANIE BLEDOW\r
+ \r
+Ta opcja ulatwia poprawianie bledow w programie. W najnizszej\r
+linii pojawia sie numer linii, w ktorej wystapil blad, numer\r
+bledu i krotki opis. Kursor automatycznie ustawia sie w miejscu\r
+wystapinia. Dla niektorych bledow wskazuje dokladnie wiersz\r
+i kolumne,dla innych tylko wiersz i wtedy ustawia sie w pierw-\r
+szej kolumnie. Jesli ustawilismy opcje wyswietlania menu (F10)\r
+to nad linia z opisem bledu pojawia sie sciagawka o sposobie\r
+przegladania bledow.Dostepne sa nastepujace funkcje:\r
+ Ctrl F5 - Przejscie do pierwszego bledu\r
+ Ctrl F6 - Przejscie do ostatniego bledu\r
+ Ctrl F8 - Przejscie do nastepnego bledu\r
+ Ctrl F7 _ Przejscie do poprzedniego bledu\r
+ Ctrl F10 - Koniec poprawiania bledow\r
+Ponowne wcisniecie F4 powoduje wyjscie z opcji.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 6=======================================|===============\r
++ 10 2 12\r
+ ZMIANA AKTUALNEGO OKNA\r
+ \r
+ Dzieki tej funkcji mozemy zmienic okienko robocze.\r
+Mamy do wyboru nastepujace funkcje:\r
+ F Rozszerza aktualne okienko na caly ekran.\r
+ H Przechodzimy do okienka z baza danych o Loglanie.<1>\r
+ A Przechodzimy do okienka dodatkowego\r
+ M przechodzimy do okienka glownego.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 7=======================================|===============\r
++ 19 2\r
+ PRZECHODZENIE DO PROGRAMOW POMOCNICZYCH\r
+ \r
+Ta opcja umozliwia wykonywanie pewnych programow, bez wycho-\r
+dzenia z tego prograwu do systemu.To okienko mozemy zdefiniowac\r
+sobie sami w czasie instalacji edytora.Umozliwia ono miedzy\r
+innymi wykonywanie pewnych operacjii na edytowanym pliku(nazwa\r
+pliku jest umieszczana w parametrach wywolanego programu).\r
+Jako jedna z opcji mozna umiescic program LOTEKINS co pozwala\r
+na zmiane tego okienka w trakcie pracy.Wywolanie opcji tego\r
+okienka moze byc umieszczone w makroinstrukcji\r
+(Przyklad: Jesli mamy komputer z dwoma monitorami i zdefiniuje-\r
+my instrukcje:C COLOR (mode co80) i M MONO (mode mono)\r
+to makroinstrukcja <AltH> @8M@5H@5F spowoduje,ze bedziemy mogli\r
+ogladac baze danych na moanitorze z karta Hercules.\r
+ <AltM> @8C@5M@5F spowoduje,ze bedziemy mogli\r
+edytowac plik glowny na ekranie kolorowy(ale baza danych nie\r
+zniknie z ekranu monochromatycznego)\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 8=======================================|===============\r
++ 13 2 36\r
+ KOMPILOWANIE PROGRAMU\r
+ \r
+Tutaj mamy nastepujace opcje:\r
+ L: Pass 1 Pierwszy przebieg kompilacji (program Loglan) tu\r
+ sa miedzy innymi wykrywane popelnione przez nas bledy (F4)\r
+ G: Pass 2 Drugi lub pierwszy i drugi przebieg kompilacji\r
+ (program Gen) tu jest generowany gotowy do wykonania program\r
+ R: Run Wykonywanie programu (lub takze kompilacja).\r
+ D: Debuger Najpierw wykonujemy program,a potem mozemy prze-\r
+ sledzic instrukcja po instrukcji jak przebiegalo to wykonanie\r
+ O: Options<1> Tu ustawia sie rozne opcje zwiazane z kompilacja\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 9=======================================|===============\r
++ 19 2 27 28 29 30 31 32 33 34 35\r
+ OPERACJE BLOKOWE\r
+ \r
+Po nacisnieciu Ctrl_K wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie zrobimy to\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+ \r
+Mamy do dyspozycji nastepujaca funkcje:\r
+ \r
+ K,B,T,L -zaznaczanie bloku <1>\r
+ Y -kasowanie bloku <2>\r
+ C,V -zwyczajne przenoszenie bloku <3>\r
+ S,M -przenoszenie z wyrownywaniem <4>\r
+ R,W -blok z dysku i na dysk <5>\r
+ U,I -przesuwanie bloku <6>\r
+ H -chowanie bloku <7>\r
+ F -blok w ramke <8>\r
+ O -opcje <9>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 10=======================================|===============\r
++ 15 2 37 38 39 40\r
+ OPERACJE KONTROLOWANEGO PRZEMIESZCZANIA SIE PO TEKSCIE\r
+ \r
+Po nacisnieciu Ctrl_J wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie z\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+ \r
+Mamy do dyspozycji nastepujace funkcje:\r
+ \r
+ S -ustawienie miejsca dla skoku <1>\r
+ R -powrot do ostatnio ustawionego miejsca <2>\r
+ J -skok do ostatnio ustawionego miejsca <3>\r
+ L -skok do podanej linii\r
+ B,K -skoki do poczatku i konca bloku <4>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 11=======================================|===============\r
++ 19 2 15 16 17 18 19 20\r
+ OPERACJE WYSZUKIWANIA I ZAMIANY SLOW\r
+ \r
+Po nacisnieciu Ctrl_Q wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie zrobimy to\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+ \r
+Mamy do dyspozycji nastepujace opcje:\r
+ \r
+ F -znajdz podane slowo <1>\r
+ A -znajdz slowo i zamien je na inne <2>\r
+ C -zamien znaki <3>\r
+ K -zamien slowa kluczowe <4>\r
+ T -znajdz slowo wskazywane przez kursor <5>\r
+ R -znajdz i zamien slowo wskazywane przez kursor <6>\r
+ \r
+UWAGA:Naciskajac Ctrl L mozesz powtorzyc ostatnio wykonywana\r
+ funkcje wyszukiwania i zamiany.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 12=======================================|===============\r
++ 16 2 13 14\r
+ SPIS TRESCI WIADOMOSCI O LOGLANIE\r
+ \r
+ Kazda linia jaka widzisz na ekranie oznacza jakis tekst.\r
+Podkreslenie oznacza linie,ktora mozna aktualnie wybrac.\r
+ \r
+ Enter -przejscie do ogladania podrozdzialu <1>\r
+ kursor w gore -poprzenia linia\r
+ kursor w dol -nastepna linia\r
+ Ctrl PgUp -do poczatku spisu\r
+ Ctrl PgDn -do konca spisu\r
+ PgUp,PgDn -o strone w gore lub w dol\r
+ Tab -wybieranie roznych innych rozdzialow <2>\r
+ Ctrl_Q_F -wyszukiwanie podanego slowa\r
+ Esc - powrot do glownego okienka edycyjnego\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 13=======================================|===============\r
++ 14 2 12 14\r
+ TRESC PODROZDZIALU\r
+ \r
+ Enter -powrot do spisu tresci <1>\r
+ Tab -wybieranie roznych innych rozdzialow <2>\r
+ Up,Down,Left,Right -przemieszczanie kursora\r
+ Home,End -do poczatku i konca linii\r
+ Ctrl PgUp -do poczatku tekstu\r
+ Ctrl PgDn -do konca tekstu\r
+ PgUp,PgDn -o strone w gore lub w dol\r
+ Ctrl_K_B,K,L,T -zaznaczanie bloku\r
+ Ctrl_Q_F -wyszukiwanie slowa\r
+ Esc -powrot do glownego okienka edycyjnego\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 14=======================================|===============\r
++ 11 2\r
+ WYBOR ROZDZIALU INFORMACJI O LOGLANIE\r
+ \r
+ Na ekranie widzimy okienko z wypisanymi nazwami rozdzialow\r
+jakie z niego mozemy otrzymac.Kursorami w gore i w dol wedru-\r
+jemy po okienku Home i End przenosi nas na poczatek lub koniec.\r
+Enter pozwala wybrac wskazywany rozdzial i odrazu przechodzimy\r
+do niego.Kursorami w lewo i w prawo przechodzimy do sasiednich\r
+okienek z innymi rozdzialami.Esc powoduje powrot do ostatnio\r
+ogladanego rozdzialu.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 15=======================================|===============\r
++ 17 2 46\r
+ (F) WYSZUKIWANIE WYRAZEN REGULARNYCH W TEKSCIE\r
+ \r
+Najpierw podajemy tresc slowa, ktore chcemy znalezc (Find :?).\r
+Przy zapisie slowa obowiazuja pewne reguly, ktore poznasz naci-\r
+skajac klawisz <1>\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+nastepnej pozycji za nim.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n............................Szukanie az do n-tego wystapienie.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 16=======================================|===============\r
++ 21 2 46 48\r
+ (A) ZAMIANA WYSTAPIEN PODANEGO SLOWA W TEKSCIE\r
+ \r
+Najpierw podajemy tresc slowa, ktore chcemy znalezc. (Find :?)\r
+Przy zapisie slowa obowiazuja pewne reguly, ktore poznasz naci-\r
+skajac klawisz <1>\r
+Potem podajemy na co chcemy zamienic to slowo. (Replace with :?)\r
+Tu obowiazuja takze pewne reguly (nacisnij <2>).\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+tym slowia a w najwyzszej linii ekranu pojawia sie pytanie, czy\r
+zamienic to slowo,czy tez nie.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n...............................Zamiana pierwszych n wystapien.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ N...........Zamiana bezwarunkowa (bez pytania za kazdym razem).\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 17=======================================|===============\r
++ 13 2\r
+ (C) ZAMIANA ZNAKOW\r
+ \r
+Ta funkcja umozliwia zamiane duzych liter na male lub odwrotnie\r
+Dzialaja nastepujace opcje :\r
+ D.......................................Zamiana na duze litery.\r
+ S.......................................Zamiana na male litery.\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ C............................Zamiana tylko wewnatrz komentarzy.\r
+ T......................................Zamiana tylko w tekscie.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 18=======================================|===============\r
++ 12 2\r
+ (K) ZAMIANA SLOW KLUCZOWYCH\r
+ \r
+Ta funkcja umozliwia nam zamiane wszystkich slow kluczowych\r
+jezyka Loglan.\r
+Dzialaja nastepujace opcje :\r
+ D.......................................Zamiana na duze litery.\r
+ S.......................................Zamiana na male litery.\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 19=======================================|===============\r
++ 14 2\r
+ (T) SZUKANIE SLOWA WSKAZYWANEGO PRZEZ KURSOR\r
+ \r
+Najpierw podajemy opcje , a potem nastepuje szukanie.\r
+Jesli znaleziono podane slowo to kursor ustawia sie na\r
+nastepnej pozycji za nim.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n............................Szukanie az do n-tego wystapienie.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 20=======================================|===============\r
++ 17 2\r
+ (R) SZUKANIE I ZAMIANA SLOWA WSKAZYWANEGO PRZEZ KURSOR\r
+ \r
+Najpierw podajemy na co chcemy zamienic to slowo.\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+tym slowia a w najwyzszej linii ekranu pojawia sie pytanie, czy\r
+zamienic to slowo,czy tez nie.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n...............................Zamiana pierwszych n wystapien.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ N...........Zamiana bezwarunkowa (bez pytania za kazdym razem).\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 21=======================================|===============\r
++ 15 2 29 30\r
+ OPERACJE WYMIANY BLOKOW MIEDZY OKNAMI TEKSTOWYMI I INNE\r
+ \r
+Po nacisnieciu Ctrl_W wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie z\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+ \r
+Mamy do dyspozycji nastepujace funkcje:\r
+ C -przekopiowanie bloku z drugiego widocznego na ekranie okna\r
+ V -przeniesienie bloku z drugiego widocznego na ekranie okna\r
+ S -przekopiowanie z przesunieciem z drugiego okna\r
+ M -przeniesienie z przesunieciem z drugiego okna\r
+ \r
+Patrz C,V <1> S,M <2>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 22=======================================|===============\r
++ 21 2\r
+ DEFINIOWANIE MAKROROZKAZOW\r
+ \r
+Kazdemu klawiszowi odpowiadajacemu literze,cyfrze lub klawiszo-\r
+wi funkcyjnemu mozemy przyporzadkowac makroinstrukcje.\r
+Makroinstrukcje sa uruchamiane przez jednoczesne nacisniecie Alt\r
+i odpowiedniego klawisza.\r
+W definicji makrorozkazu moga wystapic oprucz zwyczajnych znakow\r
+ASCII zastepujace symbole:\r
+ ^.............Oznacza Ctrl + nastepny klawisz (A..Z oraz 0..9)\r
+ &..............Oznacza Alt + nastepny klawisz (A..Z oraz 0..9)\r
+ @........Oznacza klawisz funkcyjny.Nastepnym znakiem moze byc:\r
+ 1..0 - F1..F10 ³ <>^v - kursor ³ H - Home ³ E - End ³\r
+ U - PgUp ³ D - PgDn ³ I - Insert ³ L - Delete ³\r
+ S - Esc ³ B - Backspace ³ ³ ³\r
+ C - Enter ³ ³ ³ ³\r
+ #..Nastepny znak po ty nie jest interpretowany np.## oznacza #\r
+Nawiasy klamrowe oznaczaja powtorzenie ich zawartosci pewna\r
+liczbe razy . Np. {^C(* *)}12 spowoduje utworzenie 12 nowych\r
+linii zawierajacych napis "(* *)"\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 23=======================================|===============\r
++ 19 2\r
+ (L) WGRYWANIE PLIKU Z DYSKU\r
+ \r
+Pojawia sie okienko,w ktorym mozemy podac nazwe pliku,lub maske\r
+opisujaca grupe plikow. Jezeli podamy nazwe to dany plik jest\r
+wgrywany ( jesli nie istnieje to rozpoczynamy jego edycje ).\r
+Jezeli podamy maske to pojawiaja sie wszystkie odpowiadajace\r
+jej nazwy plikow oraz podkatalogow.\r
+>>>Mamy dostepne nastepujace klawisze:\r
+ Esc.........Powrot,bez wczytania pliku.Zostajemy w aktualnie\r
+ ustawionym podkatalogu.\r
+ \18 \19 < >......................Przemieszczanie sie po okienku.\r
+ Enter.........Jesli wskazywana jest nazwa pliku to dany plik\r
+ jest wczytywany i mozemy rozpoczac jego edycje.\r
+ Jezeli wskazywany jest podkatalog to jest on\r
+ dodawany do aktualnej sciezki.\r
+ PgUp,PgDn......Przejscie do poprzedniej lub nastepnej strony\r
+ (w okienku miesci sie tylko 20 nazw).\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 24=======================================|===============\r
++ 7 2\r
+ (N) ROZPOCZECIE EDYCJI NOWEGO PLIKU\r
+ \r
+Czysci bufor tekstu i rozpoczyna edycje pliku o domyslnej\r
+nazwie NONAME.LOG .Przy nagrywaniu na dysk program bedzie pro-\r
+ponowal zmiane tej nazwy na inna.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 25=======================================|===============\r
++ 10 2\r
+ (W) ZMIANA NAZWY AKTUALNEGO PLIKU\r
+ \r
+Zmienia nazwe aktualnie edytowanego pliku i nagrywa go na dysk\r
+w aktualnym katalogu (ustawianie aktualnego katalogu funkcja L)\r
+Jesli byl juz plik o takiej nazwie to pyta, czy go skasowac\r
+UWAGA: Mozemy podac od razu nazwe nowego pliku lub maske\r
+i wtedy zastepujemy aktualnie edytowanym plikiem jakis juz\r
+istiejacy na dysku (Wybieranie tak jak w opcji L).\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 26=======================================|===============\r
++ 6 2\r
+ (P) OSTATNIO UZYWANE PLIKI\r
+ \r
+Pojawia sie okienko z ostatnio wgrywanymi plikami ponumerowanymi\r
+od 0 do 9 mozemy wybrac jakis plik lub przejsc do opcji Load (L)\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 27=======================================|===============\r
++ 8 2\r
+ ZAZNACZANIE BLOKU\r
+ \r
+ B -zaznaczenie poczatku bloku\r
+ K -zaznaczenie konca bloku\r
+ T -zaznaczenie slowa,na ktorym stoi kursor jako bloku\r
+ L -zaznaczenie linii,na ktorej stoi kursor jako bloku\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 28=======================================|===============\r
++ 5 2\r
+ KASOWANIE ZAZNACZONEGO BLOKU\r
+ \r
+ Jezeli zaznaczyles blok to mozesz go skasowac.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 29=======================================|===============\r
++ 17 2 30\r
+ (C,V) KOPIOWANIE LUB PRZENOSZENIE ZAZNACZONEGO BLOKU\r
+ \r
+ Funkcja.C.kopiuje zaznaczony przez nas blok (Ctrl K + B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+Pierwsza linia bloku bedzie przesunieta tak , aby jej poczatek\r
+znajdowal sie w pozycji kursora natomiast pozostale linie nie\r
+zostana przesuniete.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+ Funkcja.V.przenosi zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+W poprzednim miejscu blok bedzie skasowany.\r
+Pierwsza linia bloku bedzie przesunieta tak , aby jej poczatek\r
+znajdowal sie w pozycji kursora natomiast pozostale linie nie\r
+zostana przesuniete.\r
+ ----> Ctrl K S,M <1>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 30=======================================|===============\r
++ 20 2 29\r
+ (S) KOPIOWANIE LUB PRZENOSZENIE BLOKU Z WYROWNYWANIEM\r
+ \r
+ Funkcja.S. kopiuje zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+Jest jednak inna niz funkcja Ctrl K C.\r
+Wszystkie linie bloku zostana przesuniete tak,aby poczatek\r
+pierwszej linii znajdowal sie w pozycji kursora.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+ Funkcja.M.przenosi zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+W poprzednim miejscu blok bedzie skasowany.\r
+Jest jednak inna niz funkcja Ctrl K M.\r
+Wszystkie linie bloku zostana przesuniete tak,aby poczatek\r
+pierwszej linii znajdowal sie w pozycji kursora.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+W tym przypadku spowoduje to, ze blok nie przesunie sie w pionie\r
+tylko w poziomie.Jego poczatek ustawi sie w kolumnie kursora.\r
+ -----> Ctrl K C,V <1>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 31=======================================|===============\r
++ 12 2 23\r
+ (R,W) WCZYTANIE I ZGRYWANIE BLOKU Z DYSKU\r
+ \r
+ Funkcja.R. umozliwia dolaczenie do naszego tekstu dowolnego\r
+pliku z dysku.Plik jest dolaczany w miejscu wskazywanym przez\r
+kursor,bez wyrownywania (tak jak Ctrl K C).\r
+Pojawia sie okienko,w ktorym mozemy podac nazwe zbioru lub maske\r
+i wtedy wybieramy odpowiedni plik tak jak w funkcji F3 L <1>\r
+ Funkcja.W. umozliwia zgranie zaznaczonego bloku na dysk.\r
+Pojawia sie okienko,w ktorym mozemy podac nazwe zbioru lub maske\r
+i wtedy wybieramy odpowiedni plik tak jak w funkcji F3 L <1>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 32=======================================|===============\r
++ 10 2\r
+ (I,U) PRZESUNIECIE BLOKU O JEDEN ZNAK W PRAWO LUB W LEWO\r
+ \r
+ Funkcja.I. przesuwa wszystkie linie zawierajace blok o jeden\r
+znak w prawo.Przesuwane jest takze to co jest przed blokiem\r
+w pierwszej linii bloku oraz za blokiem w ostatniej linii bloku\r
+ Funkcja.U. przesuwa wszystkie linie zawierajace blok o jeden\r
+znak w lewo.Przesuwane jest takze to co jest przed blokiem\r
+w pierwszej linii bloku oraz za blokiem w ostatniej linii bloku\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 33=======================================|===============\r
++ 7 2\r
+ CHOWANIE ZAZNACZONEGO BLOKU\r
+ \r
+ Wybranie tej funkcji powoduje,ze blok staje sie niewidoczny.\r
+Ponowne jej wybranie ustawia blok taki,jaki byl przed zaslo-\r
+nieciem.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 34=======================================|===============\r
++ 8 2 35\r
+ (F) TWORZENIE RAMKI\r
+ \r
+ Dookola linii zawierajacych blok tworzona jest ramka.\r
+W opcjach mozemy sobie ustawic wszelkie mozliwe parametry\r
+ramki.\r
+ -----> Ctrl K O <1>\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 35=======================================|===============\r
++ 21 2\r
+ (O) ROZNE CIEKAWE PARAMETRY\r
+ \r
+Te opcje dotycza przede wszystkim ksztaltu ramki ale nie tylko\r
+ 3 nastepne linie to wzor ramki.\r
+ - lewy gorny , srodkowy gorny , prawy gorny\r
+ - lewy , srodkowy , prawy\r
+ - lewy dolny , srodkowy dolny , prawy dolny\r
+ F.......................................Pierwsza kolumna ramki.\r
+ - musi byc z przedzialu 0..255\r
+ - musi byc mniejsza niz ostatnia kolumna ramki\r
+ - 0 ma specjalne znaczenie : ramka zacznie sie tam,gdzie\r
+ zaczyna sie zaznaczony tekst.\r
+ L.......................................Ostatnia kolumna ramki.\r
+ - musi byc z przedzialu 0..255\r
+ - musi byc wieksza niz pierwsza kolumna ramki\r
+ - 0 ma specjalne znaczenie : ramka zkonczy sie tam,gdzie\r
+ zaczyna sie zaznaczony tekst.\r
+ T.....Wyrownywanie tekstu w ramce.Moze o n byc z lewej,z prawej\r
+ lub w srodku ramki.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 36=======================================|===============\r
++ 16 2\r
+ OPCJE DLA KOMPILACJI\r
+ \r
+Tu mozna wplynac na pewne parametry kompilacji i wykonywania\r
+programu.\r
+D: Debug info on/off Wlaczenie powoduje,ze przy wykonywaniu\r
+ programu na specjalny plik sa wyprowadzane numery kolejno\r
+ wykonywanych instrukcji.Zwalnia to wykonywanie programu ale\r
+ umozliwia jego puzniejsze przesledzenie (patrz opcja DEBUGER)\r
+M: Memory ______ Jest to podzielona przez 4 ilosc\r
+ pamieci zarezerwowana dla naszego programu.Moze ona przyjac\r
+ wartosc od 16384 do 100000. Korzystnie jest ustawiac 16384\r
+ bo wtedy program szybciej sie wykonuje.\r
+C: Cursor on/off Jest to opcja dla koneserow.Wlaczenie\r
+ jej powoduje,ze na czas wykonywania programu znika kursor\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 37=======================================|===============\r
++ 6 2\r
+ (S) ZAZNACZANIE POZYCJI DLA SKOKOW\r
+ \r
+Ta funkcja zapamietuje aktualna pozycje kursora i umozliwia\r
+wykonanie w przyszlosci skoku do tego miejsca.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 38=======================================|===============\r
++ 7 2\r
+ (R) POWROT DO ZAZNACZONEGO WCZESNIEJ MIEJSCA\r
+ \r
+Podobnie jak Ctrl J J skacze do zaznaczonego wczesniej miejsca\r
+z ta roznica,ze zanim skoczy zaznacza aktualna pozycje tak , aby\r
+potem mozna bylo do niej wrocic opcjami Ctrl J J/R.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 39=======================================|===============\r
++ 6 2\r
+ (J) SKOK DO ZAZNACZONEGO PRZEDTEM MIEJSCA W TEKSCIE\r
+ \r
+Kursor jest przenoszony do miejsca,ktore wczesniej zaznaczylismy\r
+opcja Ctrl J S\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 40=======================================|===============\r
++ 6 2\r
+ SKOKI DO BLOKU\r
+ \r
+ B -skok do poczatku zaznaczonego bloku\r
+ K -skok do konca zaznaczonego bloku\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 41=======================================|===============\r
++ 22 2\r
+ OPCJE PLIKOWE (F3O)\r
+ \r
+Tutaj mozemy ustawiac rozne opcje wplywajace na dzialanie prog-\r
+ramu.\r
+ S..Jest to numer linii bedacej granica miedzy okienkami\r
+ (np. miedzy plikiem glownym i dodatkowym lub plikiem glownym\r
+ i baza danych)\r
+ B..Czy maja byc robione kopie bezpiczenstwa plikow.\r
+ Jesli jest wlaczone,to przy kazdym nagraniu pliku na dysk\r
+ poprzednia wersja tego pliku nie jest kasowana tylko dosta-\r
+ je rozszerzenie BAK\r
+ D..Opuznienie odswierzania ekranu.\r
+ Jesli przez jakis czas (ustawiony w tym miejscu) nie zosta-\r
+ nie wcisniety zaden klawisz to na ekranie pojawia sie mru-\r
+ gajace niebo.\r
+ W..Opuznienie pojawiania sie okienek.\r
+ Po wybraniu funkcji edytora pojawia sie najpierw sam naglo-\r
+ a dopiero po pewnym czasie jesli nie wybierzemy zadnej\r
+ opcji okienko menu.Tutaj mamy mozliwosc ustawic czas,jaki\r
+ minie od pojawienia sie naglowka do wyswietlenia okienka.\r
+---------------------------------------------------------------\r
+ABY DOWIEDZIEC SIE JAK POSLUGIWAC SIE HELPEM NACISNIJ <0>\r
+===============REKORD 42=======================================|===============\r
++ 10 43 44 9 11 10 21 22 45\r
+ Operacje edytorskie\r
+ \r
+ Przesuwanie kursora <0>\r
+ Kasowanie znakow <1>\r
+ ^K Operacje blokowe <2>\r
+ ^Q Wyszukiwanie i zamiana slow <3>\r
+ ^J Skakanie po tekscie <4>\r
+ ^W Przenoszenie blokow miedzy oknami <5>\r
+ ^V Makroinstrukcje <6>\r
+ Inne <7>\r
+===============REKORD 43=======================================|===============\r
++ 11\r
+ Przesuwanie kursora\r
+ \r
+^v<>.ruchy kursora | ^>........o jedno slowo w prawo\r
+^u.........o linie w gore | ^<.........o jedno slowo w lewo\r
+^d.........o linie w dol | wzgledem wyzszej linii:\r
+pgdn.......o strone w gore | ^n........o jedno slowo w prawo\r
+pgup........o strone w dol | ^p.........o jedno slowo w lewo\r
+^pgdn.....na poczatek tekstu | ^home.......na poczatek okienka\r
+^pgup.......na koniec tekstu | ^end..........na koniec okienka\r
+tab......przestawia kursor pod nastepne slowo,\r
+ przesuwa to co bylo za kursorem\r
+===============REKORD 44=======================================|===============\r
++ 8\r
+ Kasowanie znakow\r
+ \r
+ Backspace kasowanie znaku w lewo\r
+ Del kasowanie znaku w prawo\r
+ ^Y kasowanie linii\r
+ ^T kasowanie slowa wskazywanego przez kursor\r
+ ^A kasowanie linii w lewo\r
+ ^S kasowanie linii w prawo\r
+===============REKORD 45=======================================|===============\r
++ 12\r
+ Inne operacje\r
+ \r
+Enter - nowa linia\r
+Insert - zmiana trybu pracy.\r
+ jesli jest wlaczone to znaki beda wstawiane miedzy\r
+ juz istniejace\r
+ w przeciwnym przypadku sa nadpisywane.\r
+Esc - jesli jestesmy w glownym okienku edycyjnym\r
+ to wracamy do DOS'u\r
+ jesli jestesmy w okienku dodatkowym to przechodzimy\r
+ do okienka glownego\r
+F10 - powoduje znikniecie linii z menu programu\r
+===============REKORD 46=======================================|===============\r
++ 20 47\r
+ WYSZUKIWANIE WYRAZEN REGULARNYCH\r
+ \r
+Interpretowane sa nastepujace oznaczenia:\r
+ \r
+ c znak graficzny c\r
+ ? dowolny znak\r
+ % poczatek wiersza (jesli jest to pierwszy znak)\r
+ $ koniec wiersza (jesli jest to ostatni znak)\r
+ [...] dowolny znak z posrod wymienionych\r
+ [^...] dowolny znak oprucz wymienionych\r
+ [|...|...|] jeden z ciagow miedzy pionowymi kreskami\r
+ {...} zaznaczenie fragmentu do wymiany\r
+ * zero lub wiecej wystapien poprzedniego znaku\r
+ @c znak c (z pominieciem jego specjalnego znaczenia\r
+ wewnatrz nawiasow [..] [^...]\r
+ c1-c2 przedzial znakow\r
+Przyklady: nacisnij <0>\r
+ Specjalne znaczenie znakow zanika, jesli nie ma ono sensu np:\r
+ % w srodku wzorca\r
+ * wewnatrz [...] itp.\r
+===============REKORD 47=======================================|===============\r
++ 13\r
+ PRZYKLADY WYRAZEN REGULARNYCH\r
+ \r
+[0-9][0-9]* pasuje co liczby posiadajacej conajmniej jedna\r
+ cyfre\r
+%?ab pasuje do slow trzyliterowych zaczynajacych sie\r
+ od poczatku linii dowolnym znakiem a konczacych\r
+ literami 'ab'\r
+[^a-z][a-zA-Z]* pasuje do slow nie rozpoczynajacych sie mala\r
+ litera\r
+[|begin|end|] pasuje do slowa begin lub end\r
+procedure pasuje do slowa procedure\r
+ \r
+itd.\r
+===============REKORD 48=======================================|===============\r
++ 12\r
+ BUDOWA WZORCA DO WYMIANY\r
+ \r
+ c -znak graficzny c\r
+ @c -znak graficzny c\r
+ {}n -fragment tekstu pasujacy do n-tego fragmentu wzorca\r
+ Przyklad:\r
+ szukany wzorzec : %{[0-9][0-9]*}{?*}\r
+ zamieniamy na : {}2 {}1\r
+ szukany wzorzec pasuje do linii rozpoczynajacych sie numerem\r
+ (%{[0-9][0-9]*} oznacza numer na poczatku wiersza a {?*}\r
+ pasuje do dalszej czesci linii) zamiana spowoduje\r
+ przestawienie numeru na koniec wiersza\r
+=============KONIEC============================================|==============\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
--- /dev/null
+ \r
+ Warszawa 1990 Michal Pakier\r
+ \r
+ Program zarzadzajacy srodowiskiem jezyka LOGLAN\r
+ -----------------------------------------------\r
+ \r
+1:Instalacja programu\r
+---------------------\r
+ W sklad systemu wchodza nastepujace pliki:\r
+ LOTEK.EXE zarzadzajacy wszystkim pozostalym\r
+ MPLOGED.EXE wlasciwy program\r
+ LSTTEST.EXE popmocniczy przy kompilacji\r
+ LOTEK.HLP tekst helpa\r
+ LOTEKINS.EXE program instalacyjny\r
+2:Edytor tekstow.\r
+-----------------\r
+ Caly program jest jakby edytorem tekstow ukierunkowanym na pisanie\r
+ programow w LOGLAN'ie.Oprocz podstawowych funkcji zwiera on takze\r
+ inne ciekawe mozliwosci ulatwiajace prace.\r
+ 1\Operacje blokowe\r
+ Oprocz zwyklych operacji na blokach,takich jak:kasowanie,przenosze-\r
+ nie,kopiowanie, przesuwanie w lewo i prawo oraz wgrywanie na dysk\r
+ i z dysku sa takze inne , uwzgledniajace specyficzna strukture pro-\r
+ gramow komputerowych. Sa to: przenoszenie i kopiowanie z wyrownywa-\r
+ niem (przesuwa w poziomie caly blok , a nie tylko pierwsza linie),\r
+ wstawianie bloku w ramke z komentarzy (mozna dowolnie ustawic para-\r
+ metry ramki:szerokosc,wzor,wyrownawanie tekstu wewnatrz).Edytor ten\r
+ pozwala kopiowac i przenosic blok do wnetrza jego samego (przeno-\r
+ szenie powoduje przesuniecie w bok, tak by poczatek byl w kolumnie\r
+ wskazywanej przez kursor).\r
+ 2\Operacje wyszukiwania i zamiany slow\r
+ Mozna znalezc lub znalezc i zamienic podane slowo lub wskazywane\r
+ przez kursor. Mozliwa jest tez zamiana wszystkich loglanowych slow\r
+ kluczowych na duze lub male litery(w calym tekscie lub jego wskaza-\r
+ nym fragmencie) .Jest tez funkcja zamieniajaca wszystkie znaki na\r
+ duze badz male litery (w wybranym fragmencie tekstu lub tylko w ko-\r
+ mentarzach lub tylko w tekscie).\r
+ 3\Operacje szybkiego poruszania sie po tekscie\r
+ Mozna zaznaczyc punkt w tekscie i nastepnie z dowolnego miejsca\r
+ skoczyc do niego. Sa dwa rodzaje skokow:skok normalny i z zaznacze-\r
+ niem aktualnego punktu. Wykonujac ten drugi mozemy skakac miedzy\r
+ dwoma miejscami w tekscie. Oczywiscie mozna tez skoczyc do poczatku\r
+ i konca zaznaczonego bloku.\r
+ 4\Help\r
+ W kazdym momencie po nacisnieciu klawisza F1 pojawia sie na ekranie\r
+ krotki opis wszystkich aktualnie dostepnych funkcji.\r
+ 5\Makroinstrukcje\r
+ Jest to cos co bardzo ulatwia pisanie programow. Dla kazdego klawi-\r
+ sza (a..z,0..9,F1..F10) mozna zdefiniowac makrorozkaz. Jest on poz-\r
+ niej wywolywany przez nacisniecie Alt+ <odpowiedni klawisz>.Makro-\r
+ instrukcja jest to ciag znakow wstawianych naraz do bufora klawia-\r
+ tury (mozna tez kazac aby jakas sekwencja byla wstawiona kilka ra-\r
+ zy). Z pomoca makrorozkazow mozna sobie na bierzaco definiowac roz-\r
+ ne pozyteczne funkcje np : linia oddzielajaca, zamienienie slowa na\r
+ duze litery,zaznaczenie trzech nastepnych linii jako blok,...\r
+ 6\Operacje plikowe\r
+ Sa dostepne nastepujace operacje : wgranie pliku z dysku (jesli nie\r
+ ma pliku o podanej nazwie to rozpoczynamy jego edycje) ,rozpoczecie\r
+ edycji nowego pliku (przyjmuje nazwe noname.log) , zgranie pliku na\r
+ dysk,zmiana nazwy edytowanego pliku (dokladnie nagranie w aktualnym\r
+ katalogu edytowanego pliku z nowa nazwa i rozpoczecie jego edycji).\r
+ Mozna takze wybrac do edycji plik z posrod dziesieciu ostatnio uzy-\r
+ wanych.\r
+3:Okna\r
+------\r
+ W programie mozemy kozystac jakby z trzech okien edycyjnych.Pierwsze to\r
+ okienko glowne ,w ktory mozemy wykonywac wszystkie mozliwe operacje. Dru-\r
+ gie to okienko dodatkowe, dla ktorego nie mozna jedynie wykonywac kompi-\r
+ lacji i operacji z okienka Execute. Trzecie okienko nie zezwala nam na\r
+ edycje czegokolwiek umozliwia ono podladanie bazy danych zawierajacej\r
+ wszelkie mozliwe informacje o loglanie. Na ekranie moga byc maksymalnie\r
+ dwa okienka :okienko Glowne i ktores z pozostalych. Bedac w okienku glow-\r
+ nym lub dodatkowym mozna przeniesc z drugiego widocznego okienka blok\r
+ (sa tu wszelkie odmiany przenoszenia blokow).\r
+4:Kompilacja\r
+------------\r
+ Program umozliwia skompilowanie (bez wychodzenia z edytora) pliku znajdu-\r
+ jacego sie w okienku glownym. Mozna wykonac pierwszy lub drugi przebieg\r
+ kompilacji, uruchomic skompilowany program a po powrocie przesledzic jego\r
+ wykonanie. Program automatycznie zapamietuje jakie operacje dla danego\r
+ pliku byly wykonywane i na przyklad jezeli wywolamy opcje RUN a byl tylko\r
+ pierwszy przebieg to zostanie wykonany tez drugi. Po wykonaniu pierwszego\r
+ przebiegu kompilacji mozna ogladac znalezione bledy. W dolnej linii wy-\r
+ swietla sie opis bledu a kursor wskazuje jego wystapienie w tekscie.\r
+5:Okienko Execute\r
+-----------------\r
+ To okienko kazdy uzytkownik moze sobie zdefiniowac sam podczas instalowa-\r
+ nia programu Pozwala ono na wywolanie dowolnych funkcji dosu,programow\r
+ lub plikow *.BAT a nastepnie na powrot do edytcji. Do wywolanego programu\r
+ mozna oczywiscie kazac automatycznie wstawiac nazwe edytowanego pliku\r
+ (w parametrze).\r
+6:Baza danych\r
+-------------\r
+ Jest to zasadniczo zbior informacji o Loglanie ale moze tu byc podczas\r
+ instalacji podlaczona dowolna inna baza danych (stworzona za pomoca pro-\r
+ gramu MPH ). Baza taka sklada sie z 6-ciu okienek po max. 22 linie.Kazdej\r
+ linii przyporzadkowany jest dowolnej dlugosci spis tresci a kazdej linii\r
+ spisu tresci dowolnej wielkosci tekst. Bedac w spisie tresci lub w te-\r
+ kscie mozna wywolac niektore funkcje edytora: Wyszukanie podanego slowa\r
+ i zaznaczenie bloku. Zaznaczony blok moze byc potem przeniesiony do pliku\r
+ glownego. Mozliwe jest wejscie do bazy danych wyszukanie interesujacego\r
+ nas tekstu, a nastepnie powrot do edycji bez utraty podgladu na wybrany\r
+ tekst.\r
+7:Praca w srodowisku LOTEK\r
+--------------------------\r
+ Prace rozpoczyna sie uruchamiajac program LOTEK.EXE.Na dole ekranu wypi-\r
+ sane sa wszsystkie funkcje, ktore sa aktualnie dostepne. Jesli ktos chce\r
+ miec o jedna linie wiecej dla edycji to moze spowodowac,ze linia informa-\r
+ cyjna bedzie niewidoczna. Po kazdym wyjsciu z programu na dysk nagrywane\r
+ sa wszelkie parametry (na pliku MPLED.DAT) i przy ponownym uruchomieniu\r
+ jestesmy w takim stanie jak wtedy, gdy skonczylismy. Edytor ma wbudowany\r
+ mechanizm zapobiegajacy wypaluniu sie monitora. Jesli przez 2 minuty nie\r
+ nacisniemy zadnego klawisza,to obraz znika i pojawia sie "niebo".Po naci-\r
+ snieciu dowolnego klawisza niebo znika. Zawsze przy nagrywaniu pliku na\r
+ dysk jest tworzona wersja bezpieczenstwa (.BAK)\r
+ \r
+ \r
+ \r
--- /dev/null
+ Ne2Lotek Warszawa 1990 Michal Pakier\r
+\r
+ Program sluzy do zamiany plikow z formatu tworzonego \r
+przez Norton Edytor na format zrozumialy przez edytor srodowiska\r
+loglanowego LOTEK. Norton Edytor zamienia kazde 8 spawcji wystepujacych \r
+po sobie na znak ascii o kodzie 9 . Program Ne2Lotek wykonuje czynnosc\r
+odwrotna.\r
+\r
+ Program wywoluje sie w nastepujacy sposob:\r
+\r
+NE2LOTEK par1\r
+\r
+ par1 - nazwa pliku , ktory ma byc poddany konwersji.\r
+\r
+ Pracujac w srodowisku LOTEK mozna wstawic program Ne2Lotek \r
+do okienka EXECUTE. Wtedy bedziemy mogli uszlachetniac pliki nie wychodzac\r
+z edytora. Robi sie to wpisujac w programie LOTEKINS w opcji tworzenia \r
+okienka w wybranej linii :\r
+\r
+ C Convert NE to LOTEK ³ ne2lotek !\r
+ \r
+ \r
--- /dev/null
+ \r
+ Uwagi o uzytkowaniu programu LOTEK.\r
+ ----------------------------------\r
+ Program wywolujemy uruchamiajac program lotek.exe.(wczesniej musimy w danym\r
+podkatalogu dokonac instalacji lotekins.exe).\r
+ \r
+Do dzialania calego srodowiska loglanu potrzebne sa:\r
+ \r
+ loglan,hgen,cgen,int,hint - kompilator loglanu.Musza byc widoczne tak,jakby\r
+ byly w aktualnym katalogu.\r
+ \r
+ MPloged.exe,lsttest.exe,lotek.hlp - pliki srodowiska ,musza byc w jednym\r
+ podkatalogu.\r
+ \r
+ prep.exe,logdeb.exe - debuger,musza byc w jednym podkatalogu\r
+ \r
+ logrprt.hlp,loghlp.str - baza danych o loglanie,musza byc\r
+ w jednym katalogu\r
+ report.hlp - tekst raportu loglanu.Jest uzywany w bazie danych.\r
+ Musi znajdowac sie na dysku(ten egzemplarz,ktory\r
+ dolaczylem,poniewarz nie ma on niektorych linii\r
+ i uzywanie innego pliku z raportem spowoduje ble-\r
+ dne dzialanie bazy danych)\r
+ \r
+ lotek.exe - musi byc widoczny (ten program zarzadza wszystkimi\r
+ innymi).\r
+ lotek.pth - ten plik jest generowany podczas instalacji(lotekins).Musi on\r
+ byc w kazdym katalogu,z ktorego uruchamiamy program\r
+ \r
+W trakcie pracy generowane sa w aktualnym katalogu dwa pliki:\r
+ praca.bat - jest to plik pomocniczy i mozna na niego nie zwracac uwagi.\r
+ mpled.dat - tu jest zapisany aktualny stan programu.Nie nalezy tego pliku\r
+ kasowac,jesli chce sie w przyszlosci kontynuowac przerwana\r
+ prace\r
+ \r
+Dolaczona baza danych jest tylko przykladowa.Maksymalna wersja moze miec 6\r
+okienek po 22 linii (ta ma 1 okienko z 1 linia) i moze zarzadzac danymi\r
+ze 132 plikow tekstowych dowolnej wielkosci.(Jednoczesnie w pamieci siedzi\r
+tylko to co widac na ekranie).\r
+ \r
+Przyklady makroinstrukcji\r
+ \r
+begin@C@^@E{@<}5@vend; -wpisanie begin'a i w linii nizej end'a\r
+ \r
+(**)@<@< -narysowanie komentarza i ustawienie w srodku\r
+ kursora.\r
+ \r
+@H(*{*}74*} -wstawienie linii oddzielajacej z gwiazdek\r
+ \r
+^KT^QCdl@C^KK^KB -zamienienie slowa wskazywanego przez kursor\r
+ na duze litery.\r
+ \r
+ \r
+ \r
+ \r
+ \r
--- /dev/null
+W katalogu SOURCE sa pliki zrodlowe.\r
+\r
+W katalogu LOTEK sa wlasciwe programy oraz wszystkie inne pliki potrzebne\r
+do uruchomienia systemu (helpy itd.)\r
+\r
+W katalogu MPH jest program, przy pomocy ktorego mozna zmieniac\r
+baze danych (IIUWGRAF itd.). Posiada on helpa i wydaje mi sie, ze mozna\r
+sie zorientowac jak dziala. Exe do tego programu jest w katalogu MPH/MPH.\r
+Po dokonaniu zmian nalezy uruchomic program instalacyjny LOTEKINS, aby\r
+"skompilowac" utworzona baze danych.\r
+\r
+\r
+\r
+ \r
+ \r
--- /dev/null
+==============================================================|REKORD 1\r
++ 13 11 2 3 4 5\r
+ MENU GLOWNE\r
+Program ten sluzy do tworzenia tekstowych baz danych,ktore\r
+moga byc wykorzystywane samodzielnie (przy pomocy programu\r
+MPHLP,po uprzednim skompilowaniu programem MPHCOMP).\r
+ Aktualnie jestesmy w menu glownym edytora.Mamy do dyspozy-\r
+cji nastepujace funkcje:\r
+ LOAD HELP...<1>....................wgrywanie helpa z dysku\r
+ SAVE HELP...<2>..........nagranie aktualnego helpa na dysk\r
+ NEW HELP...<3>............rozpoczecie edycji nowego helpa\r
+ EDIT HELP...<4>.................kontynuowanie edycji helpa\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 2\r
++ 7 11\r
+ WGRYWANIE HELPA Z DYSKU\r
+ Po wybraniu opcji L glownego menu mozemy wgrac poprzednio\r
+edytowanego helpa z dysku i kontynuowac prace nad nim.\r
+Nazwa pliku z helpem powinna miec rozszerzenie HLP\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 3\r
++ 10 11\r
+ NAGRYWANIE HELPA NA DYSK\r
+ Po wybraniu opcji S glownego menu zgrywamy aktualnie tworzo-\r
+nego helpa na dysk.Jest on nagrywany do pliku z rozszerzeniem\r
+HLP i ten wlasnie plik jest juz gotowy do skompilowania\r
+programem MPHCOMP.\r
+ Jako nazwa pliku jest brana nazwa helpa,ktora podales rozpo-\r
+czynajac jego edycje.\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 4\r
++ 12 11\r
+ TWORZENIE NOWEGO HELPA\r
+ Po wybraniu opcji N glownego menu rozpoczynamy edycje nowego\r
+helpa.Do tej pory edytowany help jest kasowany.\r
+ Na poczatku musimy podac nazwe helpa(jest to nazwa pliku,na\r
+ktorym,bedzie trzymany help).Potem definiujemy pierwsze okno\r
+(podajemy jego nazwe,oraz jedna linie,czyli tresc linii i plik\r
+jej odpowiadajacy).\r
+ Po zdefiniowaniu nowego okienka od razu przechodzimy do jego\r
+edycji.\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 5\r
++ 7 11\r
+ EDYCJA HELPA\r
+ Po wybraniu opcji E glownego menu rozpoczynamy edycje aktu-\r
+alnego helpa.Jest to ten,nad ktorym do tej pory pracowalismy,\r
+lub ktory wlasnie wgralismy z dysku.\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 6\r
++ 13 11 7\r
+ WYBIERANIE OKIENKA\r
+ Jestes w trybie wybierania okienka.Strzalkami kursora w lewo\r
+i prawo oraz klawiszami Home i End wybierasz sobie jakies\r
+okienko.Enter powoduje przejscie do edycji wskazywanego okien-\r
+ka.\r
+ Naciskajac Esc wracasz do glownego menu.\r
+ Po wcisnieciu F9 pojawi sie na dole dodatkowe menu z opera-\r
+ cjami,ktore mozesz aktualnie wykonac,jednak wszystkie one\r
+ sa dostepne takze besposrednio,o czym sie dowiesz naciskajac\r
+ <1>\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 7\r
++ 13 11\r
+ OPERACJE PODCZAS WYBIERANIA OKIENKA\r
+ Masz dostepne nastepujace operacje:\r
+ C zmiana naglowka wskazywanego okienka takze Ctrl C\r
+ S nagranie wskazywanego okienka na dysk takze Ctrl S\r
+ L wstawienie nowego okienka wgranego z dysku Ctrl L\r
+ M stworzenie nowego okienka takze Ins\r
+ (moze byc najwyzej 6 okienek,kazdego naglowek moze\r
+ miec do 15 znakow ale laczna suma musi byc mniejsza\r
+ niz 70 znakow)\r
+ D skasowanie wskazywanego okna takze Del\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 8\r
++ 14 11 9\r
+ TRYB WYBIERANIA LINII OKIENKA\r
+ Jestes w trybie wybierania linii okienka.Strzalkami kursora\r
+w w gore i w dol oraz klawiszami Home i End wybierasz sobie\r
+jakas linie.Klawiszami kursora w lewo i w prawo przechodzisz\r
+do sasiednich okienak.Enter powoduje przejscie do edycji\r
+wskazywanej linii.\r
+ Naciskajac Esc wracasz do trybu wybierania okienka\r
+ Po wcisnieciu F9 pojawi sie na dole dodatkowe menu z opera-\r
+ cjami,ktore mozesz aktualnie wykonac,jednak wszystkie one\r
+ sa dostepne takze besposrednio,o czym sie dowiesz naciskajac\r
+ <1>\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 9\r
++ 17 11\r
+ OPERACJE PODCZAS WYBIERANIA LINII OKIENKA\r
+ Masz dostepne nastepujace operacje:\r
+ C zmiana tresci wskazywanej linii takze Ctrl C\r
+ S nagranie wskazywanej linii na dysk takze Ctrl S\r
+ L wstawienie nowej linii wgranej z dysku takze Ctrl L\r
+ M stworzenie nowej linii takze Ins\r
+ (moze byc najwyzej 22 linie.Kazda linia zaczyna sie\r
+ znakiem klawisza,ktorego nacisniecie bedzie automa-\r
+ tycznie wywolywac edycje tej linii.\r
+ Przyklad:\r
+ P Pierwsza linia\r
+ D skasowanie wskazywanej linii takze Del\r
+Uwaga:przy tworzeniu nowej linii musimy takze wskazac plik\r
+ tekstowy,z ktorego bedziemy pobierac informacje.\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 10\r
++ 18 11 12 13\r
+ EDYCJA POJEDYNCZEJ LINII\r
+ Na ekranie widac dwa okienka.Pierwsze jest spisem tresci ,\r
+drygie plikiem tekstowym,ktory wskazalismy definiujac te\r
+linie.Kazda linia spisu tresci sklada sie z dwoch pol oddzie-\r
+lonych pionowa linia.Pierwsze pole zawiera numery pierwszej\r
+i ostatniej linii (kolejno) fragmentu tekstu z drygiego okien-\r
+ka,ktorego dotyczy ta linia spisu tresci.Drugie pole zawiera\r
+tresc linii spisu tresci.\r
+ Esc powrot do trybu wybierania linii\r
+ Tab zmiana okienka (aktualne ma podwojna ramke)\r
+ ScrollLock zmiana polozenia i wielkosci okienek <1>\r
+ F9 dodatkowe operacje <2>\r
+\r
+Poruszanie sie po okienku:\r
+ left,right,up,down,PgUp,PgDn,Ctrl PgUp,Ctrl PgDn,Home,End\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 11\r
++ 14\r
+ POSLUGIWANIE SIE HELPEM\r
+Jest to bardzo proste.W dowolnym momencie,kiedy czegos nie\r
+wiemy naciskamy F1 i pojawia sie tresc aktualnego okienka\r
+helpa (dotyczaca tego,co wlasnie robimy).Ale czytajac tresc\r
+jakiejs tresci helpa mozemy zwykle przejsc do innej czesci,\r
+bedacej rozwinieciem tego,co nas interesuje.Robi sie to naci-\r
+skajac klawisze z cyferkami {0,1,2,3,4,5,6,7,8,9}.Zawsze jest\r
+napisane jakie cyferki mozemy w danum momencie nacisnac (sa\r
+one wypisane w nawiasach trujkatnych).\r
+ Esc wyjscie z helpa\r
+ F1 powrot do poczatku helpa\r
+Uwaga:niektore informacje mozemy uzyskac spogladajac na\r
+najnizsza linie ekranu,gdzie jest napisane jakie podstawowe\r
+operacje mozemy wykonac.\r
+==============================================================|REKORD 12\r
++ 9 11\r
+ ZMIANA POLOZENIA I WIELKOSCI OKIENEK\r
+ Tab zmiana aktywnego okienka\r
+ klawisze kursora przesuwanie okienka\r
+ Shift Left/Up zmniejszanie okienka\r
+ Shift Right/Down zwiekszanie okienka\r
+ ScrollLock przejscie do normalnego trybu\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|REKORD 13\r
++ 20 11\r
+ OPERACJE PODCZAS EDYCJI LINII\r
+ M utworzenie nowej linii spisu tresci zawierajacej linie\r
+ z tekstu (przeniesienie jednej linii z tekstu do sp. tr.).\r
+ N tworzenie nowej linii spisu tresci\r
+ R kasowanie aktualnej linii spisu tresci\r
+ B zaznaczenie poczatku tekstu,ktorego dotyczy aktualna linia\r
+ spisu tresci (jesli jestesmy w spisie tresci to przesuwa\r
+ tekst ,tak aby byl widoczny poczatek zaznaczotego fra-\r
+ gmentu).\r
+ E zaznaczenie konca tekstu,ktorego dotyczy aktualna linia\r
+ spisu tresci (jesli jestesmy w spisie tresci to przesuwa\r
+ tekst ,tak aby byl widoczny koniec zaznaczotego fragmen-\r
+ tu).\r
+ Y skasowanie zaznaczenia fragmentu tekstu.\r
+ U przesuniecie kursora spisu tresci do gory\r
+ D przesuniecie kursora spisu treci w dol\r
+ C zmiana tresci aktualnie wskazywanej linii spisu tresci.\r
+\r
+Jesli chcesz dowiedziec sie,jak poslugiwac sie uzywanym aktua-\r
+lnie przez ciebie helpem nacisnij klawisz <0>.\r
+==============================================================|\r
+\1a
\ No newline at end of file
--- /dev/null
+1995.11.09
+ Zmienilem nazwe funkcji 'sendmsg' na sendmsg1 , bo funkcja
+sendmsg istnieje jako standardowa. O.S.
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#if DLINK
+#include "dlink.h"
+#elif TCPIP
+#include "tcpip.h"
+#endif
+
+
+/* IIUW LOGLAN-82 Executor */
+/* Written in PASCAL by P.Gburzynski and A.Litwiniuk. */
+/* Modified by J.Findeisen, T.Przytycka, D.Szczepanska, B.Ciesielski. */
+/* Hand translated to C by B. Ciesielski. */
+
+
+#ifndef NO_PROTOTYPES
+static void load(char *);
+static void initiate(int,char **);
+int main(int,char **);
+#else
+static void load();
+static void initiate();
+int main();
+#endif
+
+
+/* Macro to decode addressing modes : */
+#define getargument(a, argnr) \
+ switch (eop->args[ argnr ]) \
+ { \
+ case GLOBAL : a = M[ ic++ ]; break; \
+ case LOCAL : a = c1+M[ ic++ ]; break; \
+ case TEMPLOCAL : a = c2+M[ ic++ ]; break; \
+ case REMOTE : a = M[ M[ ic+1 ] ]+M[ ic ]; ic+=2; break;\
+ case INDIRECT : a = M[ M[ ic++ ] ]; break;\
+ case IMMEDIATE : a = ic++; break;\
+ case CONSTANT : a = M[ ic++ ]; break;\
+ case DOTACCESS : a = M[ display+M[ ic+1 ] ]+M[ ic ]; ic += 2; break;\
+ case NOARGUMENT : return; \
+ }
+
+
+static void load(_filename) /* Load code and prototypes from file */
+ char *_filename;
+{
+ FILE *fp;
+ char *cp;
+ word n, left;
+ char filename[100]; /* should suffice on all systems */
+
+ strcpy( filename, _filename );
+
+ M = mallocate(memorysize+1); /* allocate main memory array */
+ if (M == NULL) abend("Memory size too large (use /m option)\n");
+
+ addext(filename, ".ccd");
+ if ((fp = fopen(filename, BINARYREAD)) == NULL)
+ abend("Cannot open .ccd file\n");
+
+ ic = 0; /* read static data and code */
+ left = memorysize+1; /* from .ccd file */
+ do
+ {
+ if (left == 0) abend("Memory size too small (use /m option)\n");
+ n = min(IOBLOCK/sizeof(word), left);
+ n = fread((char *) &M[ ic ], sizeof(word), (int) n, fp);
+ ic += n;
+ left -= n;
+ } while (n != 0); /* now ic = number of words read */
+
+ fclose(fp);
+ /* Get various addresses passed by GENERATOR */
+ ipradr = M[ ic-5 ]; /* primitive type desctriptions */
+ temporary = M[ ic-4 ]; /* global temporary variables */
+ strings = M[ ic-3 ]; /* string constants */
+ lastprot = M[ ic-2 ]; /* last prototype number */
+ freem = M[ ic-1 ]; /* first free word in memory */
+
+ /* Read prototypes from .pcd file */
+ addext(filename, ".pcd");
+ if ((fp = fopen(filename, BINARYREAD)) == NULL)
+ abend("Cannot open .pcd file\n");
+ for (n = MAINBLOCK; n <= lastprot; n++ )
+ {
+ cp = ballocate(sizeof(protdescr));
+ if (cp == NULL) abend("Memory size too large (use /m option)\n");
+ prototype[ n ] = (protdescr *) cp;
+ if (fread(cp, sizeof(protdescr), 1, fp) != 1)
+ abend("Cannot read .pcd file\n");
+ }
+ fclose(fp);
+
+ /* Open trace file */
+ if (debug)
+ {
+ addext(filename, ".trd");
+ if ((tracefile = fopen(filename, "w")) == NULL)
+ abend("Cannot open .trd file\n");
+ }
+} /* end load */
+
+
+static void initiate(argc, argv) /* Establish configuration parameters */
+int argc;
+char **argv;
+{
+ long m;
+ int c;
+ char *filename=NULL;
+
+ fprintf(stderr,"\n LOGLAN-82 Concurrent Executor Version 4.51\n");
+ fprintf(stderr," January 21, 1993\n");
+ fprintf(stderr,
+ " (C) Copyright Institute of Informatics University of Warsaw\n");
+ fprintf(stderr," (C) Copyleft LITA Universite de Pau\n");
+#if DLINK
+ fprintf(stderr," D-LINK version 3.21\n\n");
+#elif TCPIP
+ fprintf(stderr," TCPIP version 0.9\n\n");
+#else
+ fprintf(stderr,"\n");
+#endif
+ fflush(stderr);
+
+#if DLINK
+ ournode = net_logon(msginterrupt);
+ if (ournode >= 0) /* network driver installed */
+ network = TRUE;
+ else /* network driver not installed */
+ {
+ network = FALSE;
+ ournode = 0; /* only node 0 is available */
+ }
+#else
+ network = FALSE;
+ ournode = 0;
+#endif
+ argc--,argv++;
+
+ for( ; argc>0; argc--,argv++ ){
+ if( filename != NULL ) usage();
+ if( (*argv)[0]=='-' )
+ switch( (*argv)[1] ){
+
+ case 'i' :
+ infmode = TRUE;
+ break;
+
+ case 'd' :
+ debug = TRUE;
+ break;
+
+ case 'r' :
+#if DLINK
+ if (!network)
+ abend("D-Link Network Driver Version 3.21 must be installed\n");
+ argv++,argc--;
+ if( argc==0 ) usage();
+ if( sscanf( *argv, "%d", &c ) != 1 ) usage();
+ if( c < 0 || c >= 255 || c == ournode )
+ abend("Invalid console node number\n");
+ console = c;
+ remote = TRUE;
+#elif TCPIP
+ argv++,argc--;
+ if( argc==0 ) usage();
+ if( sscanf( *argv, "%d", &c ) != 1 ) usage();
+ if( c < 0 || c >= 255 )
+ abend("Invalid my console node number\n");
+ ournode = console = c;
+ argv++,argc--;
+ if( argc==0 ) usage();
+ /* here we test if we are remote */
+ /* master will have number of slaves to wait for */
+ /* slave - internet full address of master */
+ if( strchr(*argv,':') ){
+ /* internet address of master nn.nn.nn.nn:port */
+ remote = TRUE;
+ tcpip_connect_to_master( *argv );
+ }else{
+ /* # of slaves to wait for */
+ if( sscanf( *argv, "%d", &c ) != 1 ) usage();
+ if( c < 0 || c >= 254 ) usage();
+ tcpip_wait_for_slaves( c );
+ remote = FALSE;
+ }
+ puts("");
+ network = TRUE;
+#else
+ usage();
+#endif
+ break;
+
+ case 'm' :
+ argv++,argc--;
+ if( argc==0 ) usage();
+ if (sscanf( *argv, "%ld", &m ) != 1) usage();
+ if (m <= 0 || m > MAXMEMSIZE)
+ abend("Invalid memory size specified\n");
+ memorysize = m;
+ break;
+
+ default :
+ usage();
+ break;
+
+ } /* end of switch */
+ else{ /* this is not option */
+ if( filename != NULL ) usage();
+ filename = *argv ;
+ }
+ } /* end of for */
+
+ if( filename!=NULL )
+ load(filename); /* load code and prototypes */
+ else
+ usage();
+}
+
+
+void decode(){
+ extopcode *eop;
+ eop = (extopcode *)(M+ic); /* pointer to extended opcode in M */
+ lastic = ic; /* save ic for possible redecoding */
+ ic += APOPCODE;
+ opcode = ((int) eop->opcode ) & 0xFF ;
+ getargument(a1, 0);
+ getargument(a2, 1);
+ getargument(a3, 2);
+}
+
+
+int main(argc, argv)
+int argc;
+char **argv;
+{
+ initiate(argc, argv); /* initialize executor */
+ runsys(); /* initialize running system */
+ init_scheduler();
+ setjmp(contenv); /* set label for continue long jump */
+ while (TRUE) /* repeat until exit() is called */
+ {
+ schedule(); /* reschedule current process */
+ decode(); /* fetch instruction */
+ execute(); /* and execute it */
+ }
+ return 0;
+} /* end main */
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include <assert.h>
+
+
+#ifndef NO_PROTOTYPES
+
+static word get_pointer(word,word);
+static void phase1(void);
+static void phase2(void);
+static void phase2a(void);
+static void phase3(void);
+static void phase4(void);
+static void phase5(void);
+static void phase6(void);
+static void curtain(void);
+static void heap_walk(word);
+static void nonefy(virtaddr *);
+static void relocate(virtaddr *);
+static void traverse(word,void (*)(virtaddr *));
+static void what_we_have(virtaddr *);
+
+#else
+
+static word get_pointer();
+static void phase1();
+static void phase2();
+static void phase2a();
+static void phase3();
+static void phase4();
+static void phase5();
+static void phase6();
+static void curtain();
+static void heap_walk();
+static void nonefy();
+static void relocate();
+static void traverse();
+static void what_we_have();
+
+#endif
+
+
+#ifdef CDBG
+FILE *ff;
+static void what_we_have(va) virtaddr *va; {
+ fprintf(ff," pointer offset %d:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",
+ ((word*)va)-M,va->addr,va->mark,M[va->addr],M[va->addr+1]);
+ fflush(ff);
+}
+#endif
+
+
+/*
+ * Memory compactifier - a play in 6 acts
+ */
+
+static word nleng; /* free memory before compact. */
+static word curah; /* to preserve ah of current object */
+
+/* One of the actions for traverse: see below;
+ * converts none to absolute none, i.e. (0, 0)
+ */
+
+
+static void nonefy(va) virtaddr *va; {
+
+#ifdef CDBG
+ if(va->addr==0 && va->mark!=0){
+ fprintf(ff,"nonefy:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",
+ va->addr,va->mark,M[va->addr],M[va->addr+1]);
+ fflush(ff);
+ }
+#endif
+
+#ifndef OBJECTADDR
+ if(!isprocess(va))
+#else
+ assert( va->mark >= 0 );
+/* assert( va->mark <= M[ va->addr+1 ] );*/
+#endif
+#ifdef CDBG
+ fprintf(ff,"nonefy:|va=%d,va_mark=%d,am=%d,mark=%d|\n",
+ va->addr,va->mark,M[va->addr],M[va->addr+1]);
+ fflush(ff);
+#endif
+ if( va->mark != M[ va->addr+1 ] ) /* if NONE */
+ {
+
+#ifdef CDBG
+ fprintf(ff," set to NONE\n"); fflush(ff);
+#endif
+ va->addr = 0;
+ va->mark = 0;
+ }
+ assert( va->addr != 1 );
+} /* end nonefy */
+
+
+/* One of the actions for traverse; update the virtual address to
+ * correspond to its dictionary entry after compactification.
+ */
+
+static void relocate(va) virtaddr *va; {
+#ifndef OBJECTADDR
+ if(!isprocess(va)){
+#endif
+ va->addr = M[ va->addr+1 ]; /* new ah (after compression) */
+ va->mark = 0; /* clear mark */
+#ifndef OBJECTADDR
+ }
+#endif
+} /* end relocate */
+
+
+/* Traverse all the virtual variables of object am and perform action
+ * on each of them. Skip references to processes (see nonefy() and
+ * relocate()).
+ */
+
+static void traverse(am, action)
+ word am;
+#ifndef NO_PROTOTYPES
+ void (*action)(virtaddr *);
+#else
+ void (*action)();
+#endif
+{
+ word t1, t2, t3, length;
+ protdescr *ptr;
+
+ t1 = am+M[ am ]; /* LWA+1 of the object */
+ length = M[ am+PROTNUM ]; /* prototype number */
+ if (length == AINT || length == AREAL || length == AVIRT ||
+ length == FILEOBJECT
+#ifdef OBJECTADDR
+ || length == APROCESS
+#endif
+ )
+ {
+ if (length == AVIRT) /* ARRAYOF <reference> */
+ for (t2 = am+3; t2 < t1; t2 += 2)
+ (*action)((virtaddr *)(M+t2));
+ }
+ else /* neither an array nor a file */
+ {
+ ptr = prototype [ length ];
+ switch (ptr->kind) /* compute the number of the system */
+ /* virtual variables */
+ {
+ case RECORD : length = 0; t3 = 0; break;
+ case COROUTINE : length = 3; t3 = CL; break;
+ case PROCESS : length = 5; t3 = disp2off; break;
+ case FUNCTION :
+ case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */
+ case HANDLER : length = 2; t3 = SIGNR; break;
+ default : length = 2; t3 = STATSL; break;
+ }
+
+ /* action for system reference variables */
+ for (t2 = length; t2 >= 1; t2-- )
+ (*action)((virtaddr *)(M+t1+offset[ t2 ]));
+
+ /* action for temporary reference variables */
+ t1 = am+M[ am ]+t3;
+ for (t2 = am+ptr->span; t2 < t1; t2 += 2)
+ (*action)((virtaddr *)(M+t2));
+
+ /* action for user reference variables */
+ t1 = ptr->reflist;
+ for (t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- )
+ (*action)((virtaddr *)(M+am+M[ t2 ]));
+ }
+} /* end traverse */
+
+
+/* Mark killed objects by substituting prototype number by a special value.
+ * This way we will be able to tell apart the killed objects without
+ * recalling to the dictionary or to the list of killed objects.
+ */
+
+static void phase1()
+{
+ word t1, t2, t3, phead;
+
+ nleng = thisp->lastitem-thisp->lastused-1; /* free memory before comp. */
+ M[ 1 ] = 0; /* for proper update of none */
+ phead = thisp->prochead; /* head of current process */
+ M[ phead+M[ phead ]+SL ] = 0; /* make SL of head look like none */
+ t1 = thisp->headk2; /* flag killed objects */
+ while (t1 != 0) /* special list for appetite=2 */
+ {
+ t2 = t1+SHORTLINK;
+ t1 = M[ t2 ];
+ M[ t2 ] = SKILLED; /* flag object killed */
+ }
+ t1 = thisp->headk; /* now other killed objects */
+ while (t1 != thisp->lower)
+ {
+ t2 = t1;
+ while (t2 != 0)
+ {
+ t3 = t2+SHORTLINK;
+ t2 = M[ t3 ];
+ M[ t3 ] = SKILLED; /* flag object killed */
+ }
+ t1 = M[ t1+LONGLINK ]; /* goto other size list */
+ }
+} /* end phase1 */
+
+
+/* Step thru the memory area containing objects. For each object not being
+ * killed detect all its virtual variables pointing to none and convert
+ * them to absolute none i.e. (0, 0).
+ */
+
+static void phase2()
+{
+ word t1;
+
+ nonefy( &(thisp->procref ) );
+
+ t1 = thisp->lower+1; /* FWA of object area */
+ while (t1 <= thisp->lastused)
+ {
+
+#ifdef CDBG
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
+ fflush(ff);
+ if (M[ t1+1 ] != SKILLED) traverse(t1,what_we_have);
+#endif
+
+ if (M[ t1+1 ] != SKILLED) /* an active object */
+ traverse(t1, nonefy);
+ t1 += M[ t1 ]; /* next object address */
+ }
+} /* end phase2 */
+
+
+/* garbage collection */
+
+/* Find x-th pointer in am.
+ * Skip references to processes.
+ */
+
+static word get_pointer(am,x) word am,x; {
+
+ word t1, t2, t3, length, va;
+ protdescr *ptr;
+
+ t1 = am+M[ am ]; /* LWA+1 of the object */
+ length = M[ am+PROTNUM ]; /* prototype number */
+
+#ifdef CDBG
+ fprintf(ff,"|get_pointer(am=%d,x=%d)lenght=%d|",am,x,length);
+ fflush(ff);
+#endif
+
+ if (length == AINT || length == AREAL || length == AVIRT ||
+ length == FILEOBJECT
+#ifdef OBJECTADDR
+ || length == APROCESS
+#endif
+ )
+ {
+ if(length == AVIRT) /* ARRAYOF <reference> */
+ for(t2 = am+3; t2 < t1; t2 += 2){
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+t2))) continue;
+#endif
+ if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }
+#ifdef CDBG
+ fprintf(ff,"ARR");
+ fflush(ff);
+#endif
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",t2);
+ fflush(ff);
+#endif
+ return t2;
+ }
+ x--;
+ }
+ }
+ else /* neither an array nor a file */
+ {
+ ptr = prototype [ length ];
+ switch (ptr->kind) /* compute the number of the system */
+ /* virtual variables */
+ {
+ case RECORD : length = 0; t3 = 0; break;
+ case COROUTINE : length = 3; t3 = CL; break;
+ case PROCESS : length = 5; t3 = disp2off; break;
+ case FUNCTION :
+ case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */
+ case HANDLER : length = 2; t3 = SIGNR; break;
+ default : length = 2; t3 = STATSL; break;
+ }
+
+ /* system reference variables */
+ for(t2 = length; t2 >= 1; t2-- ){
+ va=t1+offset[ t2 ];
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+va))) continue;
+#endif
+ if(M[va]==0){ assert( M[va+1]==0 ); continue; }
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",va);
+ fflush(ff);
+#endif
+ return va;
+ }
+ x--;
+ }
+
+ /* temporary reference variables */
+ t1 = am+M[ am ]+t3;
+ for(t2 = am+ptr->span; t2 < t1; t2 += 2){
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+t2))) continue;
+#endif
+ if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",t2);
+ fflush(ff);
+#endif
+ return t2;
+ }
+ x--;
+ }
+
+ /* user reference variables */
+ t1 = ptr->reflist;
+ for(t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- ){
+ va=am+M[ t2 ];
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+va))) continue;
+#endif
+ if(M[va]==0){ assert( M[va+1]==0 ); continue; }
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",va);
+ fflush(ff);
+#endif
+ return va;
+ }
+ x--;
+ }
+ }
+
+#ifdef CDBG
+ fprintf(ff,"=-1|\n");
+ fflush(ff);
+#endif
+
+ return -1;
+}
+
+static void heap_walk(curr_ah) word curr_ah;{
+ word aux,prev_ah=1; /* 1 is special value not expected in anyone virtaddr */
+ word level=0;
+
+#ifdef CDBG
+ fprintf(ff,"|prev_ah=%d|\n",prev_ah);
+ fflush(ff);
+#endif
+
+ for(;;){
+ word am=get_pointer(M[curr_ah],M[curr_ah+1]);
+ M[curr_ah+1]++;
+ if(am >= 0){
+ if(M[ M[am] +1] >0){
+#ifdef CDBG
+ fprintf(ff,"Object %d->%d invited.\n",M[am],M[M[am]]);
+ fflush(ff);
+#endif
+ continue;
+ }
+
+ /*** go ahead ***/
+ level++;
+ aux=M[am];
+ M[am]=prev_ah;
+ prev_ah=curr_ah;
+ curr_ah=aux;
+#ifdef CDBG
+ fprintf(ff,"|curr_ah set to %d|\n",curr_ah);
+ fflush(ff);
+#endif
+ continue;
+ }
+ if(prev_ah > 1){
+ /*** go back ***/
+#ifdef CDBG
+ fprintf(ff,"going back (prev_ah=%d)(lvl=%d)\n",prev_ah,level);
+ fflush(ff);
+#endif
+ level--;
+ aux=curr_ah;
+ curr_ah=prev_ah;
+ am=get_pointer(M[prev_ah],M[prev_ah+1]-1);
+ prev_ah=M[am];
+#ifdef CDBG
+ if(level==0)
+ fprintf(ff,"|prev_ah set to %d,next set to %d|\n",prev_ah,aux);
+ fflush(ff);
+#endif
+ M[am]=aux;
+ continue;
+ }
+ assert( prev_ah==1 );
+ assert( level == 0 );
+ break; /*** now all 'invited' objects have its mark >0 ***/
+ }
+}
+
+static void phase2a()
+{
+ word t1,c1_ah;
+
+ /*** generation number already is not needed so we reset it ***/
+
+ t1 = thisp->upper-1;
+ while(t1 >= thisp->lastitem){
+ if( M[t1] == c1 ) c1_ah=t1;
+ M[ t1+1 ] = 0;
+ t1-=2;
+ }
+
+#ifdef CDBG
+ fprintf(ff,"first phase of walk |from=%d,to=%d,procah=%d|\n",
+ thisp->lastitem,
+ thisp->upper-1,
+ thisp->procref.addr);
+ fflush(ff);
+#endif
+
+ heap_walk(thisp->procref.addr);
+
+#ifdef CDBG
+ fprintf(ff,"second phase of walk c1_ah=%d,c1=%d\n",c1_ah,c1);
+ fflush(ff);
+#endif
+
+ heap_walk(c1_ah);
+
+ if( thisp->blck1 != 0 )
+ heap_walk(thisp->blck1);
+
+ /*** Mark objects not traversed like SKILLED ***/
+
+ t1 = thisp->freeitem; /* head of free item list */
+ while (t1 != 0)
+ {
+ word t2;
+ t2 = M[ t1 ];
+ M[ t1 ]= 0-1; /* mark not to set object SKILLED */
+ t1 = t2; /* next free item */
+ }
+
+ t1 = thisp->upper-1; /* last dictionary item pointer */
+ while (t1 >= thisp->lastitem)
+ {
+ if (M[ t1+1 ] == 0 ){ /* entry not traversed - so killed */
+
+#ifdef CDBG
+ fprintf(ff,"MARKING dict. entry %d -> %d like SKILLED\n",t1,M[t1]);
+ fflush(ff);
+#endif
+
+ M[ t1+1 ] = MAXMARKER;
+ if( M[ t1 ] > 0 ) M [ M[ t1 ] +1 ] = SKILLED;
+ /* mark SKILLED if not set yet */
+ }
+ t1 -= 2;
+ }
+} /* end phase2a */
+
+
+
+/* For each free dictionary item set its mark to unusable status.
+ */
+
+static void phase3()
+{
+ word t1;
+
+ t1 = thisp->freeitem; /* head of free item list */
+ while (t1 != 0)
+ {
+ M[ t1+1 ] = MAXMARKER; /* flag item unusable */
+ t1 = M[ t1 ]; /* next free item */
+ }
+} /* end phase3 */
+
+
+/* Step thru the dictionary and virtually remove all unusable items.
+ * For each active item (after phase3 we have only active and unusable
+ * items) its mark is set to the new address of this item (after
+ * forthcomming compression). Moreover the contents of locations am and
+ * (old) ah are interchanged.
+ */
+
+static void phase4()
+{
+ word t1, t2, t3;
+
+ t1 = thisp->upper-1; /* last dictionary item pointer */
+ t2 = t1; /* initialize new address */
+ while (t1 >= thisp->lastitem)
+ {
+ if (M[ t1+1 ] == MAXMARKER) /* entry killed - don't decrement t2 */
+ M[ t1+1 ] = 0;
+ else
+ {
+ M[ t1+1 ] = t2; /* store new ah */;
+ t2 -= 2;
+ t3 = M[ t1 ]; /* am */
+ M[ t1 ] = M[ t3 ]; /* save (am) in (old ah) */
+ M[ t3 ] = t1; /* move old ah to (am) */
+ }
+ t1 -= 2;
+ }
+} /* end phase4 */
+
+
+/* The memory area of objects is traversed once again. Now the killed
+ * objects are removed and the remaining ones compressed. For each active
+ * object its virtual variables are relocated, their marks cleared, their
+ * ah's set to the proper new values. The contents of locations am and ah
+ * are interchanged back.
+ */
+
+static void phase5()
+{
+ word t1, t2, t3, t4, t5;
+
+ t2 = t1 = thisp->lower+1;
+ while (t1 <= thisp->lastused) /* traverse object area */
+ {
+ t5 = M[ t1 ]; /* old ah saved by phase4 */
+ if (M[ t1+1 ] == SKILLED){ /* ignore this object */
+#ifdef CDBG
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
+ fflush(ff);
+#endif
+ t1 += t5; /* t5=appetite in this case */
+ }
+ else
+ {
+#ifdef CDBG
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
+ fflush(ff);
+#endif
+ t3 = M[ t5 ]; /* appetite saved by phase4 */
+ M[ t2 ] = t3; /* send it to the new am */
+ for (t4 = 1; t4 < t3; t4++ ) /* copy the object into new am */
+ M[ t2+t4 ] = M[ t1+t4 ];
+#ifdef CDBG
+ traverse(t2,what_we_have);
+#endif
+
+ /* Update global absolute pointer to current object : */
+ if (t1 == c1) /* locate am of current */
+ {
+ c1 = t2;
+ curah = M[ t5+1 ]; /* new ah of current */
+ }
+ if (t1 == M[ temporary ])
+ M[ temporary ] = t2;
+
+ M[ t5 ] = t2; /* make (ah) looking ok */
+ traverse(t2, relocate); /* relocate virtual variables */
+#ifdef CDBG
+ fprintf(ff," --> am=%d,SIZE=%d,TYPE=%d\n",t2,M[t2],M[t2+1]);
+ fflush(ff);
+ traverse(t2,what_we_have);
+#endif
+ t1 += t3;
+ t2 += t3;
+ }
+ }
+ thisp->lastused = t2-1;
+
+
+ /* Update global absolute pointers to objects : */
+
+ relocate(&(thisp->procref ));
+
+ {
+ virtaddr v;
+ v.addr=thisp->blck1;
+ v.mark=0;
+ relocate(&v);
+ thisp->blck1=v.addr;
+ }
+
+} /* end phase5 */
+
+
+/* The dictionary is compressed. The unusable entries are moved out and
+ * the remaining ones are moved up to the positions indicated by their
+ * marks.
+ * If pointers to processes are implemented as objects we have to rebuild
+ * has table of these pointers too.
+ */
+
+static void phase6()
+{
+ word t1, t2, t3;
+
+#ifdef OBJECTADDR
+ hash_create(thisp,thisp->hash_size);
+#endif
+
+ t1 = thisp->upper+1;
+ for (t2 = t1-2; t2 >= thisp->lastitem; t2 -= 2) /* compress dictionary */
+ {
+ t3 = M[ t2+1 ];
+ if (t3 != 0) /* this is new ah */
+ {
+ M[ t3 ] = M[ t2 ];
+ M[ t3+1 ] = 0; /* clear mark */
+ t1 = t3;
+#ifdef OBJECTADDR
+ {
+ virtaddr vt3;
+ vt3.addr=t3;
+ vt3.mark=0;
+ if( isprocess(&vt3) ){
+ virtaddr obj;
+ procaddr mess;
+ obj.addr=t3;
+ obj.mark=0;
+ obj2mess(M,&obj,&mess);
+ /* force to create item - we not need it yet */
+ hash_set(&mess,t3);
+ }
+ }
+#endif
+ }
+ }
+ thisp->lastitem = t1;
+
+ thisp->prochead = M[ thisp->procref.addr ];
+ thisp->blck2 = M[ thisp->blck1 ];
+
+} /* end phase6 */
+
+
+/* System invariants are recovered, e.g. display is rebuilt to reflect the
+ * new physical addresses.
+ */
+
+static void curtain()
+{
+ word t1, phead;
+
+ phead = thisp->prochead;
+ t1=M[ c1 + PROTNUM ];
+ c2 = c1+prototype[ t1 ]->span;
+ t1 = phead+M[ phead ]; /* first free after process head */
+ display = t1+dispoff; /* display address */
+ display2 = t1+disp2off; /* indirect display */
+ M[ t1+SL ] = DUMMY; /* restore head's SL */
+ loosen(); /* rebuild DISPLAY */
+ update(c1, curah);
+ if (infmode){
+ fprintf(stderr,
+ "\n(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",
+ thispix,
+ (long) (thisp->lastitem-thisp->lastused-1-nleng),
+ (long) (thisp->lastitem-thisp->lastused-1));
+ fflush(stderr);
+ }
+#ifdef CDBG
+ fprintf(ff,
+ "(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",
+ thispix,
+ (long) (thisp->lastitem-thisp->lastused-1-nleng),
+ (long) (thisp->lastitem-thisp->lastused-1));
+ fflush(ff);
+#endif
+ thisp->freeitem = 0;
+ thisp->headk2 = 0;
+ thisp->headk = thisp->lower;
+ M[ 1 ] = 1; /* absolute none */
+ ic = lastic; /* re-decode current instruction ! */
+ decode();
+ if (opcode == 3 /*LRAISE*/) ic++; /* skip address after LRAISE */
+} /* end curtain */
+
+
+void compactify() /* Compactification */
+{
+#ifdef CDBG
+ ff=fopen("trace","a");
+ fprintf(ff,"----------------------------------------\n");
+ fprintf(ff,"COMPACTIFY (thisp=%d)\n",thispix);
+ fprintf(ff,"c1=%d,c2=%d,templ=%d\n",
+ thisp->c1,thisp->c2,thisp->template.addr);
+ fprintf(ff,"back=%d,back.mark=%d,backam=%d,backam.mark=%d\n",
+ thisp->backobj.addr,thisp->backobj.mark,
+ M[thisp->backobj.addr],M[thisp->backobj.addr+1]);
+ fprintf(ff,"blck1=%d,blck2=%d\n",thisp->blck1,thisp->blck2);
+ fflush(ff);
+#endif
+
+ phase1();
+ phase2();
+ phase2a(); /* garbage collection */
+/* phase3(); if only compactifier is needed uncomment this statement */
+/* and comment statement phase2a() */
+ phase4();
+ phase5();
+ phase6();
+ curtain();
+
+#ifdef CDBG
+ fprintf(ff,"----------------------------------------\n");
+ fflush(ff);
+ fclose(ff);
+#endif
+
+} /* end compactify */
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+/* Transfer of control routines */
+
+#ifndef NO_PROTOTYPES
+static void att2(virtaddr *, word, word);
+static void back1(word, word, virtaddr *, word *);
+#else
+static void att2();
+static void back1();
+#endif
+
+/* Transfer control to the newly created object.
+ */
+
+void go(ah, am)
+word ah, am;
+{
+ protdescr *ptr;
+ word pnum, plen, node, apt;
+ message msg;
+
+ ptr = prototype[ M[ am+PROTNUM ] ];
+ apt = am+M[ am ];
+ if (ptr->kind == PROCESS) /* new process creation */
+ {
+ thisp->template.addr = ah; /* save template address */
+ thisp->template.mark = M[ ah+1 ];
+ msg.control.type = CREATE;
+ msg.control.par = M[ am+PROTNUM ];
+ moveparams(thispix, am, &msg, PARIN, LOADPAR);
+ msg.control.receiver.pix = 0; /* pix will create receiver */
+ msg.control.receiver.mark= 0; /* mark will create receiver */
+ msg.control.receiver.node = getnode(am); /* node we decided */
+ sendmsg1( &msg); /* send create request */
+# ifdef RPCDBG
+ fprintf(
+ stderr, "send new process from %d to node %d\n",
+ thispix,
+ msg.control.receiver.node
+ );
+# endif
+ passivate(WAITFORNEW); /* and wait for return from process */
+ }
+ else
+ if (isprocess((virtaddr*)(M+apt+SL))) /* remote procedure call */
+ {
+ thisp->backobj.addr = ah; /* save template address */
+ thisp->backobj.mark = M[ ah+1 ];
+ thisp->M[ temporary ] = am; /* physical address also */
+ {
+ virtaddr v;
+ loadvirt( v, apt+SL );
+ obj2mess( M, &v, &msg.control.receiver );
+# ifdef RPCDBG
+ fprintf(
+ stderr, "send rpc from process %d to (%d,%d,%d)\n",
+ thispix,
+ msg.control.receiver.node,
+ msg.control.receiver.pix,
+ msg.control.receiver.mark
+ );
+# endif
+ }
+ msg.control.type = RPCALL;
+ msg.control.par = M[ am+PROTNUM ];
+ moveparams(thispix, am, &msg, PARIN, LOADPAR);
+ sendmsg1( &msg); /* send RPC request */
+ passivate(WAITFORRPC); /* and wait for RP return */
+ }
+ else
+ {
+ M[ c1+M[ c1 ]+LSC ] = ic; /* save local control */
+ loosen(); /* release DISPLAY */
+ update(am, ah); /* update DISPLAY */
+ c1 = am; /* new current */
+ c2 = c1+ptr->span;
+ pnum = ptr->preflist;
+ plen = ptr->lthpreflist;
+ while (TRUE) /* search for executable prefix */
+ if (plen <= 1)
+ {
+ ic = ptr->codeaddr;
+ break;
+ }
+ else
+ {
+ ptr = prototype[ M[ pnum ] ];
+ plen--;
+ pnum++;
+ if (ptr->kind != RECORD) plen = 0;
+ }
+ }
+}
+
+
+/* Transfer control to a local unprefixed procedure, function, block,
+ * class or coroutine.
+ */
+
+void goloc(ah, am)
+word ah, am;
+{
+ word t1;
+ protdescr *ptr;
+
+ M[ c1+M[ c1 ]+LSC ] = ic; /* save local control */
+ c1 = am; /* new current */
+ t1 = M[ am+PROTNUM ];
+ ptr = prototype[ t1 ];
+ c2 = am+ptr->span;
+ ic = ptr->codeaddr;
+ M[ display+t1 ] = am; /* simulate update display */
+ M[ display2+t1 ] = ah;
+ M[ am+M[ am ]+STATSL ]++;
+}
+
+
+void backbl(virt, am) /* Return from block. */
+virtaddr *virt;
+word *am;
+{
+ word t1;
+
+ t1 = M[ c1+PROTNUM ];
+ virt->addr = M[ display2+t1 ];
+ virt->mark = M[ virt->addr+1 ]; /* prepare old address */
+ *am = c1; /* am of old */
+ M[ display+t1 ] = 0; /* simulate loosen */
+ t1 = c1+M[ c1 ];
+ M[ t1+STATSL ]--; /* remove from SL chain */
+ c1 = M[ t1+SL ]; /* return up along SL */
+ if (c1 == DUMMY) endprocess(0); /* return from main */
+ c1 = M[ c1 ]; /* am of new current */
+ c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;
+ ic = M[ c1+M[ c1 ]+LSC ];
+ storevirt(*virt, *am+M[ *am ]+DL); /* force DL consistency */
+}
+
+
+static void back1(at1, at2, virt, am) /* Common code for some backs below. */
+word at1, at2;
+virtaddr *virt;
+word *am;
+{
+ word t1;
+
+ loosen();
+ if (at1 == 0) endprocess(0);
+ t1 = M[ c1+PROTNUM ];
+ virt->addr = M[ display2+t1 ]; /* ah of old */
+ virt->mark = M[ virt->addr+1 ];
+ *am = c1; /* am of old */
+ storevirt(*virt, at2); /* loop up DL */
+ at2 = M[ at1 ]; /* am of DL */
+ update(at2, at1);
+ c1 = at2;
+ c2 = c1 + prototype[ M[ c1+PROTNUM ] ]->span;
+ ic = M[ c1+M[ c1 ]+LSC ];
+}
+
+
+/* Return from classes, coroutines and by end from procedures.
+ */
+
+void back(virt, am, length)
+virtaddr *virt;
+word *am;
+word length;
+{
+ word t1, t2, plist;
+ int i;
+ protdescr *ptr;
+ message msg;
+
+ t2 = c1+M[ c1 ];
+ t1 = M[ t2+DL ]; /* ah of DL */
+ ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */
+ if (ptr->kind == PROCESS) /* RETURN in process */
+ {
+# ifdef RPCDBG
+ fprintf( stderr, "return from process %d\n", thispix );
+# endif
+ if (M[ c1+PROTNUM ] == MAINBLOCK) endprocess(0);
+ {
+ virtaddr v;
+ loadvirt( v, t2+DL );
+ obj2mess( M, &v, &msg.control.receiver ); /* father process */
+ }
+ msg.control.type = CREACK;
+ moveparams(thispix, c1, &msg, PAROUT, LOADPAR);
+ sendmsg1(&msg); /* send create acknowledge */
+ M[ t2+DL ] = 0; /* cut DL of new process head */
+ passivate(STOPPED); /* and suspend new process */
+ }
+ else
+ if (ptr->kind == COROUTINE)
+ {
+ if (t1 != 0) /* nothing if detached */
+ {
+ M[ t2+LSC ] = ic;
+ back1(t1, t2+DL, virt, am);
+ }
+ }
+ else
+ {
+ plist = ic; /* save begining of prototype list */
+ if (ptr->lthpreflist==1 && t1==M[t2+SL] && M[t2+DL+1]==M[t2+SL+1])
+ backbl(virt, am);
+ else
+ back1(t1, t2+DL, virt, am);
+
+/*
+# ifdef RPCDBG
+ fprintf(
+ stderr, "back (thisp=%d) from %s to %s\n",
+ thispix,
+ (
+ (ptr->kind==PROCEDURE) ?
+ "PROCEDURE" :
+ (ptr->kind==FUNCTION) ?
+ "FUNCTION" :
+ "???"
+ ),
+ isprocess((virtaddr*)(M+t2+RPCDL)) ? "PROCESS" : "OBJECT"
+ );
+# endif
+*/
+ if ((ptr->kind == PROCEDURE || ptr->kind == FUNCTION) &&
+ isprocess((virtaddr*)(M+t2+RPCDL)))
+ {
+ {
+ virtaddr v;
+ loadvirt( v, t2+RPCDL );
+ obj2mess( M, &v, &msg.control.receiver ); /* remote DL */
+ }
+# ifdef RPCDBG
+ fprintf(
+ stderr, "send rpc ack from process %d to (%d,%d,%d)\n",
+ thispix,
+ msg.control.receiver.node,
+ msg.control.receiver.pix,
+ msg.control.receiver.mark
+ );
+# endif
+ msg.control.type = RPCACK;
+ moveparams(thispix, *am, &msg, PAROUT, LOADPAR);
+ sendmsg1(&msg); /* send RP return - acknowledge */
+ gkill(virt); /* kill procedure object manualy */
+ popmask(thispix); /* restore RPC mask from stack */
+ for (i = 0; i < length; i++) /* and modify it */
+ {
+ t1 = virtprot(M[ plist++ ]); /* prototype number */
+ if (t1 > 0) enable(thispix, t1);
+ else disable(thispix, -t1);
+ }
+ evaluaterpc(thispix); /* check for enabled RPCs */
+ }
+ }
+}
+
+
+/* Return, end in procedures and functions without prefix.
+ */
+
+void backpr(virt, am)
+virtaddr *virt;
+word *am;
+{
+ word t1, t2, t3;
+
+ t2 = c1+M[ c1 ]+DL; /* DL pointer of current */
+ t1 = M[ t2 ]; /* ah of DL */
+ t3 = c1+M[ c1 ]+SL; /* SL pointer */
+ if (t1 == M[ t3 ] && M[ t2+1 ] == M[ t3+1 ]) backbl(virt, am); /* SL=DL */
+ else back1(t1, t2, virt, am);
+}
+
+
+void fin(backic, virt, am) /* End in classes and coroutines. */
+word backic;
+virtaddr *virt;
+word *am;
+{
+ word t1, t2, knd;
+
+ knd = prototype[ M[ c1+PROTNUM ] ]->kind;
+ if (knd != COROUTINE && knd != PROCESS)
+ back(virt, am, (word) 0); /* a class - exit as above */
+ else
+ {
+ ic = backic; /* backspace ic */
+ t2 = c1+M[ c1 ];
+ t1 = M[ t2+DL ]; /* ah of DL */
+ if (t1 == 0)
+ {
+ if (M[ t2+SL ] == DUMMY) endprocess(0);
+ ic = 0; /* coroutine terminated */
+ *am = 0;
+ detach();
+ }
+ else
+ {
+ M[ t2+LSC ] = ic;
+ back1(t1, t2+DL, virt, am);
+ }
+ }
+}
+
+
+static void att2(virt, ax, at1) /* Helper for attach/detach */
+virtaddr *virt;
+word ax, at1;
+{
+ word t1, t2, phead;
+
+ t1 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */
+ t2 = at1+M[ at1 ]+DL; /* DL of coroutine head */
+ M[ t2 ] = t1; /* loop up DL */
+ M[ t2+1 ] = M[ t1+1 ];
+ M[ c1+M[ c1 ]+LSC ] = ic; /* preserve local control */
+ loosen();
+ phead = thisp->prochead;
+ storevirt(*virt, phead+M[ phead ]+CHD);
+ t2 = M[ ax+DL ];
+ if (t2 == 0) errsignal(RTECORAC); /* coroutine active */
+ M[ ax+DL ] = 0; /* cut DL of new coroutine head */
+ c1 = M[ t2 ];
+ update(c1, t2);
+ c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;
+ ic = M[ c1+M[ c1 ]+LSC ];
+ if (ic == 0) errsignal(RTECORTM); /* coroutine terminated */
+}
+
+
+void attach(virt)
+virtaddr *virt;
+{
+ word t1, ax, phead, chead;
+ int knd;
+
+ if (M[ virt->addr+1 ] != virt->mark) errsignal(RTEILLAT);
+ else ax = M[ virt->addr ]; /* am */
+ t1 = M[ ax+PROTNUM ];
+ if (t1 == AINT || t1 == AREAL || t1 == AVIRT || t1 == FILEOBJECT)
+ errsignal(RTEILLAT);
+ knd = prototype[ t1 ]->kind;
+ if (knd != COROUTINE && knd != PROCESS) errsignal(RTEILLAT);
+ ax = ax+M[ ax ];
+ phead = thisp->prochead;
+ chead = phead+M[ phead ]+CHD;
+ if (virt->addr != M[ chead ] || virt->mark != M[ chead+1 ])
+ {
+ M[ ax+CL ] = M[ chead ];
+ M[ ax+CL+1 ] = M[ chead+1 ];
+ att2(virt, ax, M[ M[ chead ] ]);
+ }
+}
+
+
+void detach()
+{
+ virtaddr virt;
+ word t1, phead;
+
+ phead = thisp->prochead;
+ t1 = M[ M[ phead+M[ phead ]+CHD ] ]; /* am of coroutine head */
+ loadvirt(virt, t1+M[ t1 ]+CL); /* coroutine link */
+ if (M[ virt.addr+1 ] != virt.mark) errsignal(RTEILLDT);
+ att2(&virt, M[ virt.addr ]+M[ M[ virt.addr ] ], t1);
+}
+
+
+void inner(level) /* Simulate execution of inner */
+word level;
+{
+ word t1;
+ protdescr *ptr;
+
+ ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */
+ t1 = ptr->lthpreflist;
+ if (t1 != level)
+ if (level == t1-1) ic = ptr->codeaddr;
+ else ic = prototype[ M[ ptr->preflist+level ] ]->codeaddr;
+}
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#if MSDOS
+#undef UNIX
+#undef OS2
+#elif UNIX
+#undef OS2
+#elif OS2
+#undef UNIX
+#else
+#error Define one of MSDOS/OS2/UNIX
+#endif
+
+#if WORD_16BIT
+#undef DWORD_16BIT
+#undef WORD_32BIT
+#elif DWORD_16BIT
+#undef WORD_32BIT
+#elif WORD_32BIT
+#undef DWORD_16BIT
+#else
+#error Define one of WORD_16BIT/DWORD_16BIT/WORD_32BIT
+#endif
+
+
+#include <stdio.h>
+#include <malloc.h>
+#include <setjmp.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+typedef struct {
+ char opcode;
+ char args[ 3 ];
+ } extopcode;
+
+typedef char *lword; /* max(word, char *) but in every case was char* */
+
+#define BINARYREAD "rb"
+#define BINARYWRITE "wb"
+#define DIRECTOLD "r+b"
+#define DIRECTNEW "w+b"
+
+
+#if WORD_16BIT
+
+typedef int word;
+typedef float real;
+typedef word *memory;
+
+#if UNIX
+extern char *calloc(int,int);
+#endif
+
+#define mallocate(n) ((memory) (char /*|||huge*/ *) calloc((n),sizeof(word)))
+#define ballocate(n) ((char /*|||huge*/ *) calloc((n),1))
+
+#define MAXINTEGER 0x7FFF
+#define DEFMEMSIZE 0x7FF0 /* 32K words = 64K bytes */
+#define MAXMEMSIZE 0x7FF0 /* 32K words = 64K bytes */
+
+#endif
+
+
+
+#if DWORD_16BIT
+
+typedef long word;
+typedef double real;
+typedef word huge *memory;
+
+#if UNIX
+
+extern char *calloc(int,int);
+
+#define mallocate(n) (((n)<60000)?(memory) calloc((n),sizeof(word)):abort())
+#define ballocate(n) (calloc((n),1))
+
+#define MAXINTEGER 0x7FFFFFFFL
+#define DEFMEMSIZE 0x13C00L /* 79K words = 316K bytes */
+#define MAXMEMSIZE 0x400000L /* 4M words = 16M bytes */
+
+#elif OS2
+
+extern char huge *halloc();
+
+#define mallocate(n) ((memory) halloc((long) (n), sizeof(word)))
+#define ballocate(n) (halloc((long) (n),1L))
+
+#define MAXINTEGER 0x7FFFFFFFL
+#define DEFMEMSIZE 0x13C00L /* 79K words = 316K bytes */
+#define MAXMEMSIZE 0x400000L /* 4M words = 16M bytes */
+
+#define INCL_DOSINFOSEG
+
+#include <os2.h>
+
+#elif MSDOS && TURBOC
+
+extern char far *farcalloc();
+
+#define mallocate(n) ((memory) farcalloc((long) (n), (long) sizeof(word)))
+#define ballocate(n) (farcalloc((long) (n),1L))
+
+#define MAXINTEGER 0x7FFFFFFFL
+#define DEFMEMSIZE 0x14000L /* 80K words = 320K bytes */
+#define MAXMEMSIZE 0x28000L /* 160K words = 640K bytes */
+
+#elif MSDOS
+
+extern void huge *halloc();
+#define mallocate(n) ((memory) halloc((long) (n), sizeof(word)))
+#define ballocate(n) (halloc((long) (n),1))
+
+#define MAXINTEGER 0x7FFFFFFFL
+#define DEFMEMSIZE 0xF000L /* 60K words = 120K bytes */
+#define MAXMEMSIZE 0x28000L /* 160K words = 640K bytes */
+
+#else
+#error Allocation macros not defined.
+#endif
+
+#endif
+
+
+
+#if WORD_32BIT
+
+typedef int word;
+typedef float real;
+typedef word *memory;
+
+#define mallocate(n) ((memory) (char *) calloc((n),sizeof(word)))
+#define ballocate(n) ((char *) calloc((n),1))
+
+/* printf("|%d*4|",(n)),getchar(),\ */
+
+#define MAXINTEGER 0x7FFFFFFFL
+#define DEFMEMSIZE 0x13C00L /* 79K words = 316K bytes */
+#define MAXMEMSIZE 0x400000L /* 4M words = 16M bytes */
+
+#endif
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+ NAME CINTA
+ PUBLIC _logon, _logoff, _attention, _ignore, _send, _receive
+ EXTRN _endrun:FAR, COPYOK:FAR
+
+DGROUP GROUP _data
+
+CINTA_TEXT SEGMENT PUBLIC 'CODE'
+ ASSUME CS:DRIVER
+
+; PATCH FOR RECEIVE MESSAGE INTERRUPT HANDLER
+PATCH PROC FAR
+ PUSHF
+ PUSH AX
+ PUSH BX
+ PUSH CX
+ PUSH DX
+ PUSH DS
+ PUSH ES
+ CALL FAR PTR _ignore ; DISABLE ATTENTION
+ MOV AX, DGROUP
+ MOV DS, AX
+ ASSUME CS:DRIVER, DS:DGROUP
+ PUSH AX
+ MOV AX, OFFSET DGROUP:MSGBUF
+ PUSH AX
+ CALL FAR PTR _receive
+ CALL DWORD PTR MSGINT
+ ADD SP, 4
+ POP ES
+ POP DS
+ POP DX
+ POP CX
+ POP BX
+ POP AX
+ POPF
+ RET
+PATCH ENDP
+PATLEN = $-PATCH
+SAVLEN = PATLEN
+CINTA_TEXT ENDS
+
+_data SEGMENT WORD PUBLIC 'data'
+SAVCOD DB SAVLEN DUP(?) ; SPACE FOR SAVING PATCHED CODE
+USER DB 8 DUP(?)
+MSGBUF DB 80 DUP(' ')
+MSGINT DD ?
+_data ENDS
+
+; SEGMENT FOR ADDRESSING DRIVER CODE
+DRIVER SEGMENT AT 0
+ ORG 102EH ; ***** ONLY FOR D-LINK VERSION 3.21 *****
+DISPLAY LABEL FAR ; RECEIVE MESSAGE INTERRUPT HANDLER
+ ORG $+PATLEN
+DRIVER ENDS
+
+CINTA_TEXT SEGMENT 'CODE'
+ ASSUME CS:CINTA_TEXT
+
+NETWORK DB 0 ; NETWORK OPERATION FLAG
+
+BREAK PROC FAR ; CONTROL-BREAK INTERRUPT ROUTINE
+ MOV AX, DGROUP
+ MOV DS, AX
+ CALL _endrun
+ RET 2
+BREAK ENDP
+
+; int logon(msgint)
+; void (*msgint)();
+;
+; CHECK IF DRIVER IS INSTALLED AND CONNECT TO RECEIVE MESSAGE INTERRUPT HANDLER.
+; RETURN NODE NUMBER (-1 MEANS NODE NOT LOGGED ON)
+
+_logon PROC FAR
+ PUSH BP
+ MOV BP,SP
+ PUSH SI
+ PUSH DI
+ PUSH DS
+ PUSH AX ; PUSH DUMMY PARAMETER FOR COPYOK
+ PUSH AX
+ CALL COPYOK ; CHECK FOR AUTHORIZATION
+ OR AX, AX
+ JZ NOTAUT ; UNAUTHORIZED DUPLICATE
+ MOV AX, 2523H ; REPLACE CONTROL-BREAK INTERRUPT
+ MOV DX, OFFSET BREAK
+ PUSH CS
+ POP DS
+ INT 21H
+ MOV AX, 357DH ; GET NIOS VECTOR INTO ES:BX
+ INT 21H
+ CMP WORD PTR ES:[BX-2], 'ns'
+ JNE NONE ; DRIVER NOT INSTALLED
+ MOV AH, 17H ; GET NIOS VERSION NUMBER
+ INT 7DH
+ CMP AX, 1503H ; IS VERSION = 3.21
+ JNE NONE ; INCORRECT NIOS VERSION
+ PUSH ES
+ POP DS
+ MOV AX, DGROUP
+ MOV ES, AX
+ ASSUME CS:CINTA_TEXT, DS:DRIVER, ES:DGROUP
+ MOV BX, OFFSET DGROUP:USER
+ MOV AH, 02H ; GET USER NAME
+ MOV DL, 0FFH ; OUR NODE (UNKNOWN YET)
+ INT 7DH
+ OR AL, AL
+ JNZ NONE
+ MOV NETWORK, 1 ; FLAG NETWORK INSTALLED
+ CLD
+ MOV SI, OFFSET DISPLAY
+ MOV DI, OFFSET DGROUP:SAVCOD
+ MOV CX, SAVLEN
+ REP MOVSB
+ CALL FAR PTR _ignore ; DISABLE ATTENTION FOR A MOMENT
+ PUSH DS ; AND REPLACE WITH OUR
+ POP ES
+ PUSH CS
+ POP DS
+ ASSUME CS:CINTA_TEXT, DS:CINTA_TEXT, ES:DRIVER
+ MOV SI, OFFSET PATCH
+ MOV DI, OFFSET DISPLAY
+ MOV CX, PATLEN
+ REP MOVSB
+ MOV AX, DGROUP
+ MOV DS, AX
+ ASSUME CS:CINTA_TEXT, DS:DGROUP, ES:DRIVER
+ MOV AX, [BP+6] ; STORE ADDRESS OF USER INTERRUPT ROUTINE
+ MOV WORD PTR MSGINT, AX
+ MOV AX, [BP+8]
+ MOV WORD PTR MSGINT+2, AX
+ MOV AL, DL ; RETURN OUR NODE NUMBER
+ XOR AH, AH
+ JMP SHORT L1
+NONE: MOV AX, -1
+ MOV NETWORK, 0
+ JMP SHORT L1
+NOTAUT: MOV AX, -2
+L1: POP DS
+ POP DI
+ POP SI
+ POP BP
+ RET
+_logon ENDP
+
+
+; void logoff()
+;
+; RESTORE ORIGINAL INTERRUPT HANDLER
+
+_logoff PROC FAR
+ PUSH BP
+ MOV BP,SP
+ PUSH SI
+ PUSH DI
+ PUSH DS
+ ASSUME CS:CINTA_TEXT
+ CMP NETWORK, 0
+ JZ L2 ; NOTHING IF NO NETWORK
+ CALL FAR PTR _ignore ; DISABLE ATTENTION FOR A MOMENT
+ CLD
+ MOV AX,DGROUP
+ MOV DS,AX
+ MOV AX,357DH ; GET DRIVER SEGMENT INTO ES
+ INT 21H
+ ASSUME CS:CINTA_TEXT, DS:DGROUP, ES:DRIVER
+ MOV SI,OFFSET DGROUP:SAVCOD
+ MOV DI,OFFSET DISPLAY
+ MOV CX,SAVLEN
+ REP MOVSB ; RESTORE PATCHED CODE
+ CALL FAR PTR _attention ; ATTENTION BACK ON
+L2: POP DS
+ POP DI
+ POP SI
+ POP BP
+ RET
+_logoff ENDP
+
+
+; void attention()
+;
+; ENABLE ATTENTION
+
+_attention PROC FAR
+ CMP NETWORK, 0
+ JZ A1
+ MOV AX,1600H
+ INT 7DH
+A1: RET
+_attention ENDP
+
+
+; void ignore()
+;
+; DISABLE ATTENTION
+
+_ignore PROC FAR
+ CMP NETWORK, 0
+ JZ I1
+ MOV AX,16FFH
+ INT 7DH
+I1: RET
+_ignore ENDP
+
+
+; int send(node, msg)
+; int node;
+; message *msg;
+;
+; SEND MESSAGE MSG TO NODE
+
+_send PROC FAR
+ PUSH BP
+ MOV BP,SP
+ MOV AH,0DH ; SEND MESSAGE
+ MOV DL,[BP+6] ; NODE NUMBER
+ LES BX,[BP+8] ; BUFFER ADDRESS
+ INT 7DH
+ XOR AH,AH
+ POP BP
+ RET
+_send ENDP
+
+
+; int receive(msg)
+; message *msg;
+;
+; GET STORED MESSAGE
+
+_receive PROC FAR
+ PUSH BP
+ MOV BP,SP
+ MOV AH,0EH ; GET MESSAGE
+ LES BX,[BP+6] ; BUFFER ADDRESS
+ INT 7DH
+ XOR AH,AH
+ POP BP
+ RET
+_receive ENDP
+
+
+; FUNCTION TICKS:INTEGER4;
+; RETURN BIOS TIME IN TICKS
+TICKS PROC FAR
+ MOV AH,0
+ INT 1AH
+ MOV AX,DX ; LOW WORD
+ MOV DX,CX ; HIGH WORD
+ RET
+TICKS ENDP
+
+; PROCEDURE DTIME(VAR H,M,S:INTEGER);
+; RETURN DOS DAY TIME IN HOURS, MINUTES, AND SECONDS
+DTIME PROC FAR
+ PUSH BP
+ MOV BP,SP
+ MOV AH,2CH ; GET TIME
+ INT 21H
+ MOV BX,[BP+10]
+ MOV [BX],CH ; HOURS
+ MOV BYTE PTR [BX+1],0
+ MOV BX,[BP+8]
+ MOV [BX],CL ; MINUTES
+ MOV BYTE PTR [BX+1],0
+ MOV BX,[BP+6]
+ MOV [BX],DH ; SECONDS
+ MOV BYTE PTR [BX+1],0
+ POP BP
+ RET 6
+DTIME ENDP
+
+; FUNCTION SHIFT(PATTERN, COUNT:INTEGER):INTEGER;
+; SHIFT LEFT LOGICALY PATTERN BY COUNT BITS
+SHIFT PROC FAR
+ PUSH BP
+ MOV BP,SP
+ MOV AX,[BP+8] ; PATTERN
+ MOV CL,[BP+6] ; BIT COUNT
+ AND CL,0FH ; MASK LOW 4 BITS
+ TEST CL,08H ; TEST THEIR SIGN BIT
+ JZ S0 ; OK IF POSITIVE
+ OR CL,0F0H ; EXTEND SIGN TO ENTIRE BYTE IF NEGATIVE
+S0: CMP CL,0 ; TEST BIT COUNT ONCE AGAIN
+ JZ S2 ; IF = 0 DO NOTHING
+ JG S1 ; IF > 0 SHIFT LEFT
+ NEG CL ; IF < 0 NEGATE BIT COUNT AND
+ SHR AX,CL ; SHIFT RIGHT
+ JMP SHORT S2
+S1: SHL AX,CL ; SHIFT LEFT
+S2: POP BP
+ RET 4
+SHIFT ENDP
+
+CINTA_TEXT ENDS
+ END
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#ifndef __DLINK_H__
+#define __DLINK_H__
+
+#ifndef NO_PROTOTYPES
+
+int net_logon( void (*)() );
+void net_logoff( void );
+void net_attention( void );
+int net_send(int,message *);
+void net_ignore( void );
+
+#else
+
+int net_logon();
+void net_logoff();
+void net_attention();
+int net_send();
+void net_ignore();
+
+#endif
+
+#endif
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include <dos.h>
+#include "graf\graf.h"
+
+
+static union REGS r;
+
+#ifndef NO_PROTOTYPES
+static char *normalize(char *);
+static int mouse(int,word *,word *,word *);
+#else
+static char *normalize();
+static int mouse();
+#endif
+
+
+
+static char *normalize(addr) /* Normalize segmented address */
+ char *addr;
+{
+ union{
+ char *address;
+ unsigned int words[2];
+ } conv;
+ conv.address = addr;
+#if !WORD_32BIT
+ conv.words[1] += conv.words[0] / 16;
+ conv.words[0] %= 16;
+#endif
+ return (conv.address);
+}
+
+
+
+static int mouse(func, bx, cx, dx) /* Call mouse driver INT 33H */
+int func;
+word *bx, *cx, *dx;
+{
+ union REGS r;
+ r.x.ax = func;
+ r.x.bx = *bx;
+ r.x.cx = *cx;
+ r.x.dx = *dx;
+ int86(0x33, &r, &r);
+ *bx = (int) r.x.bx;
+ *cx = (int) r.x.cx;
+ *dx = (int) r.x.dx;
+ return(r.x.ax);
+}
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+ case GRON :
+ gron((int *) ¶m[ 0 ].xword);
+ graphmode = TRUE;
+ break;
+
+ case GROFF :
+ groff();
+ graphmode = FALSE;
+ break;
+
+ case CLS :
+ cls();
+ break;
+
+ case POINT :
+ point((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case MOVE :
+ move((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case DRAW :
+ draw((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case HFILL :
+ hfill((int *) ¶m[ 0 ].xword);
+ break;
+
+ case VFILL :
+ vfill((int *) ¶m[ 0 ].xword);
+ break;
+
+ case COLOR :
+ color((int *) ¶m[ 0 ].xword);
+ break;
+
+ case STYLE :
+ style((int *) ¶m[ 0 ].xword);
+ break;
+
+ case PATERN :
+ patern((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,
+ (int *) ¶m[ 2 ].xword, (int *) ¶m[ 3 ].xword);
+ break;
+
+ case INTENS :
+ intens((int *) ¶m[ 0 ].xword);
+ break;
+
+ case PALETT :
+ pallet((int *) ¶m[ 0 ].xword);
+ break;
+
+ case BORDER :
+ border((int *) ¶m[ 0 ].xword);
+ break;
+
+ case VIDEO :
+ if (member(¶m[ 0 ].xvirt, &am))
+ if (M[ am ] >= 0x8000L/sizeof(word))
+ video(normalize((char *) &M[ am+3 ]));
+ else errsignal(RTEILLAB);
+ else errsignal(RTEREFTN);
+ break;
+
+ case HPAGE :
+ i = (int) param[ 1 ].xword;
+ if (i == 0) graphmode = FALSE;
+ else
+ if (i == 1) graphmode = TRUE;
+ hpage((int *) ¶m[ 0 ].xword, &i,
+ (int *) ¶m[ 2 ].xword);
+ break;
+
+ case NOCARD :
+ param[ 0 ].xword = nocard(NULL);
+ break;
+
+ case PUSHXY :
+ pushxy();
+ break;
+
+ case POPHXY :
+ popxy();
+ break;
+
+ case INXPOS :
+ param[ 0 ].xword = inxpos(NULL);
+ break;
+
+ case INYPOS :
+ param[ 0 ].xword = inypos(NULL);
+ break;
+
+ case INPIX :
+ param[ 2 ].xword = inpix((int *) ¶m[ 0 ].xword,
+ (int *) ¶m[ 1 ].xword);
+ break;
+
+ case GETMAP :
+ t1 = abs(param[ 0 ].xword-inxpos(NULL))+1; /* cols */
+ t2 = abs(param[ 1 ].xword-inypos(NULL))+1; /* rows */
+ t1 = (4+t1*t2+sizeof(word)-1)/sizeof(word); /* no. of words, pixel=byte */
+ newarry((word) 1, t1, (word)AINT, ¶m[ 2 ].xvirt, &am);
+ getmap((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,
+ normalize((char *) &M[ am+3 ]));
+ break;
+
+ case PUTMAP :
+ if (member(¶m[ 0 ].xvirt, &am))
+ putmap(normalize((char *) &M[ am+3 ]));
+ else errsignal(RTEREFTN);
+ break;
+
+ case ORMAP :
+ if (member(¶m[ 0 ].xvirt, &am))
+ ormap(normalize((char *) &M[ am+3 ]));
+ else errsignal(RTEREFTN);
+ break;
+
+ case XORMAP :
+ if (member(¶m[ 0 ].xvirt, &am))
+ xormap(normalize((char *) &M[ am+3 ]));
+ else errsignal(RTEREFTN);
+ break;
+
+ case TRACK :
+ track((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case INKEY :
+ param[ 0 ].xword = inkey(NULL);
+ break;
+
+ case HASCII :
+ hascii((int *) ¶m[ 0 ].xword);
+ break;
+
+ case HFONT :
+ hfont((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case HFONT8 :
+ param[ 0 ].xword = 0;
+ param[ 1 ].xword = 0;
+ hfont8((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case OUTSTRING :
+ t1 = strings+param[ 0 ].xword;
+ outhli((int *) &M[ t1 ], (char *) &M[ t1+1 ]);
+ break;
+
+ case CIRB :
+ r1 = param[ 3 ].xreal;
+ r2 = param[ 4 ].xreal;
+ cirb((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,
+ (int *) ¶m[ 2 ].xword, &r1, &r2,
+ (int *) ¶m[ 5 ].xword, (int *) ¶m[ 6 ].xword,
+ (int *) ¶m[ 7 ].xword, (int *) ¶m[ 8 ].xword);
+ break;
+
+/* MOUSE */
+
+ case INIT :
+ ax = mouse(0, ¶m[ 0 ].xword, &cx, &dx);
+ param[ 1 ].xbool = lbool(ax);
+ break;
+
+ case SHOWCURSOR :
+ mouse(1, &bx, &cx, &dx);
+ break;
+
+ case HIDECURSOR :
+ mouse(2, &bx, &cx, &dx);
+ break;
+
+ case STATUS :
+ mouse(3, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);
+ param[ 2 ].xbool = lbool(bx & 0x01);
+ param[ 3 ].xbool = lbool(bx & 0x02);
+ param[ 4 ].xbool = lbool(bx & 0x04);
+ break;
+
+ case SETPOSITION :
+ mouse(4, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);
+ break;
+
+ case GETPRESS :
+ case GETRELEASE :
+ i = ( nrproc == GETPRESS ? 5 : 6 );
+ bx = param[ 0 ].xword;
+ ax = mouse(i, &bx, ¶m[ 1 ].xword, ¶m[ 2 ].xword);
+ param[ 4 ].xbool = lbool(ax & 0x01);
+ param[ 5 ].xbool = lbool(ax & 0x02);
+ param[ 6 ].xbool = lbool(ax & 0x04);
+ param[ 3 ].xword = bx;
+ break;
+
+ case SETWINDOW :
+ mouse(7, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);
+ mouse(8, &bx, ¶m[ 2 ].xword, ¶m[ 3 ].xword);
+ break;
+
+ case DEFCURSOR :
+ mouse(10, ¶m[ 0 ].xword, ¶m[ 1 ].xword,
+ ¶m[ 2 ].xword);
+ break;
+
+ case GETMOVEMENT :
+ mouse(11, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);
+ break;
+
+ case SETSPEED :
+ mouse(15, &bx, ¶m[ 0 ].xword, ¶m[ 1 ].xword);
+ break;
+
+ case SETMARGINS :
+ r.x.ax = 16;
+ r.x.cx = param[ 0 ].xword;
+ r.x.dx = param[ 2 ].xword;
+ r.x.si = param[ 1 ].xword;
+ r.x.di = param[ 3 ].xword;
+ int86(0x33, &r, &r);
+ break;
+
+ case SETTHRESHOLD :
+ mouse(19, &bx, &cx, ¶m[ 0 ].xword);
+ break;
+
+
--- /dev/null
+/**
+ ** EVENTQUE.H
+ **
+ ** Copyright (C) 1992, Csaba Biegl
+ ** 820 Stirrup Dr, Nashville, TN, 37221
+ ** csaba@vuse.vanderbilt.edu
+ **
+ ** This file is distributed under the terms listed in the document
+ ** "copying.cb", available from the author at the address above.
+ ** A copy of "copying.cb" should accompany this file; if not, a copy
+ ** should be available from where this file was obtained. This file
+ ** may not be distributed without a verbatim copy of "copying.cb".
+ ** You should also have received a copy of the GNU General Public
+ ** License along with this program (it is in the file "copying");
+ ** if not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+ ** Cambridge, MA 02139, USA.
+ **
+ ** This program is distributed in the hope that it will be useful,
+ ** but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ** GNU General Public License for more details.
+ **/
+
+#ifndef _EVENTQUE_H_
+#define _EVENTQUE_H_
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * structures:
+ * BE CAREFUL when hacking!!! -- 16 and 32 bit compilers have to generate
+ * the same alignments
+ */
+typedef struct {
+ unsigned char evt_type; /* event type: 0: keyboard, 1: mouse */
+ unsigned char evt_kbstat; /* keyboard status (ALT, SHIFT, etc..) */
+ unsigned char evt_mask; /* mouse event mask */
+ unsigned char evt_button; /* button status */
+ unsigned short evt_xpos; /* X coord (or keycode if keybd event) */
+ unsigned short evt_ypos; /* Y coord */
+ unsigned long evt_time; /* time stamp of event */
+#define evt_keycode evt_xpos /* reuse this slot for keybd events !! */
+#define evt_scancode evt_ypos /* store here the BIOS scan code */
+} EventRecord;
+
+typedef struct {
+ unsigned short evq_maxsize; /* max size of event queue */
+ unsigned short evq_cursize; /* number of events in the queue */
+ unsigned short evq_rdptr; /* next event to read */
+ unsigned short evq_wrptr; /* next event to be written */
+ short evq_xpos; /* current X coordinate of mouse */
+ short evq_ypos; /* current Y coordinate of mouse */
+ short evq_xmin; /* minimal mouse X coordinate */
+ short evq_ymin; /* minimal mouse Y coordinate */
+ short evq_xmax; /* maximal mouse X coordinate */
+ short evq_ymax; /* maximal mouse Y coordinate */
+ short evq_xspeed; /* horizontal speed (mickey/coord) */
+ short evq_yspeed; /* vertical speed (mickey/coord) */
+ unsigned short evq_thresh; /* fast movement threshold */
+ unsigned short evq_accel; /* multiplier for fast move */
+ unsigned char evq_drawmouse; /* interrupt handler has to draw mouse */
+ unsigned char evq_moved; /* set if mouse moved */
+ unsigned char evq_delchar; /* character removed from BIOS buffer */
+ unsigned char evq_enable; /* event generation control flag */
+ EventRecord evq_events[1]; /* event buffer space */
+} EventQueue;
+
+/*
+ * event types
+ */
+#define EVENT_KEYBD 0
+#define EVENT_MOUSE 1
+
+/*
+ * MOUSE event flag bits
+ * (also defined in "mousex.h" of the graphics library)
+ */
+#ifndef M_MOTION
+
+#define M_MOTION 0x001
+#define M_LEFT_DOWN 0x002
+#define M_LEFT_UP 0x004
+#define M_RIGHT_DOWN 0x008
+#define M_RIGHT_UP 0x010
+#define M_MIDDLE_DOWN 0x020
+#define M_MIDDLE_UP 0x040
+#define M_BUTTON_DOWN (M_LEFT_DOWN | M_MIDDLE_DOWN | M_RIGHT_DOWN)
+#define M_BUTTON_UP (M_LEFT_UP | M_MIDDLE_UP | M_RIGHT_UP)
+#define M_BUTTON_CHANGE (M_BUTTON_UP | M_BUTTON_DOWN )
+
+/*
+ * MOUSE button status bits
+ */
+#define M_LEFT 1
+#define M_RIGHT 2
+#define M_MIDDLE 4
+
+#endif /* M_MOTION */
+
+/*
+ * KEYBOARD status word bits
+ * (also defined in "mousex.h" of the graphics library)
+ */
+#ifndef KB_SHIFT
+
+#define KB_RIGHTSHIFT 0x01 /* right shift key depressed */
+#define KB_LEFTSHIFT 0x02 /* left shift key depressed */
+#define KB_CTRL 0x04 /* CTRL depressed */
+#define KB_ALT 0x08 /* ALT depressed */
+#define KB_SCROLLOCK 0x10 /* SCROLL LOCK active */
+#define KB_NUMLOCK 0x20 /* NUM LOCK active */
+#define KB_CAPSLOCK 0x40 /* CAPS LOCK active */
+#define KB_INSERT 0x80 /* INSERT state active */
+
+#define KB_SHIFT (KB_LEFTSHIFT | KB_RIGHTSHIFT)
+
+#endif /* KB_SHIFT */
+
+/*
+ * set this bit in 'evq_enable' to generate the corresponding event
+ */
+#define EVENT_ENABLE(type) (1 << (type))
+
+/*
+ * prototypes
+ */
+#if defined(__TURBOC__) && defined(FOR_GO32)
+EventQueue *EventQueueInit(int qsize,int ms_stksize,void (*msdraw)(void),int,int);
+#else
+EventQueue *EventQueueInit(int qsize,int ms_stksize,void (*msdraw)(void));
+#endif
+
+void EventQueueDeInit(void);
+int EventQueueNextEvent(EventQueue *q,EventRecord *e);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* whole file */
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include <assert.h>
+
+
+/* Execute one L-code instruction */
+
+
+void execute()
+{
+ word t1, t2;
+ int i;
+ real r;
+ virtaddr virt1, virt2, virt3;
+
+#ifdef TRACE
+ fprintf(stderr,"pix %d,ic %d,opcode %d\n",thispix,ic,opcode);fflush(stderr);
+#endif
+
+ switch (opcode)
+ {
+ case 1 : /* LOPENRC */
+ openrc(a3, &virt2, &t2);
+ storevirt(virt2, a1);
+ M[ a2 ] = t2;
+ break;
+
+ case 2 : /* LBACKADDR */
+ storevirt(thisp->backobj, a1);
+ M[ a2 ] = M[ temporary ];
+ break;
+
+ case 3 : /* LRAISE */
+ ic++; /* skip the address */
+ raise_signal(a3, M[ ic-1 ], &t1, &t2);
+ M[ a1 ] = t1;
+ M[ a2 ] = t2;
+ break;
+
+ case 4 : /* LOPEN */
+ openobj(M[ a3 ], &t1, &t2);
+ M[ a1 ] = t1;
+ M[ a2 ] = t2;
+ break;
+
+ case 5 : /* LSLOPEN */
+ loadvirt(virt3, a3);
+ slopen(M[ a3+APREF ], &virt3, &t1, &t2);
+ M[ a1 ] = t1;
+ M[ a2 ] = t2;
+ break;
+
+ case 15 : /* LTHIS */
+ virt1.addr = M[ display2+a2 ];
+ virt1.mark = M[ virt1.addr+1 ];
+ storevirt(virt1, a1);
+ break;
+
+ case 20 : /* LVIRTDISPL */
+ t2 = M[ display+a2 ];
+ t1 = M[ t2+PROTNUM ];
+ M[ a1 ] = M[ prototype[ t1 ]->virtlist+a3 ];
+ break;
+
+ case 21 : /* LSTATTYPE */
+ M[ a1 ] = a2;
+ M[ a1+1 ] = a3;
+ break;
+
+ case 23 : /* LIPAROUT */
+ M[ a1 ] = param[ a3 ].xword;
+ break;
+
+ case 24 : /* LRPAROUT */
+ MR(a1) = param[ a3 ].xreal;
+ break;
+
+ case 25 : /* LVPAROUT */
+ storevirt(param[ a3 ].xvirt, a1);
+ break;
+
+ case 31 : /* LSIGN */
+ if (M[ a2 ] == 0) M[ a1 ] = 0;
+ else
+ if (M[ a2 ] < 0) M[ a1 ] = -1;
+ else M[ a1 ] = 1;
+ break;
+
+ case 33 : /* LLOWER */
+ case 34 :
+ loadvirt(virt2, a2);
+ if (member(&virt2, &t1))
+ {
+ switch ((int) M[ t1+PROTNUM ])
+ {
+ case AINT : t2 = APINT; break;
+ case AREAL : t2 = APREAL; break;
+ case AVIRT : t2 = APREF; break;
+ }
+ M[ a1 ] = (M[ t1+2 ]+3)/t2;
+ }
+ else errsignal(RTEREFTN);
+ break;
+
+ case 35 : /* LUPPER */
+ case 36 :
+ loadvirt(virt2, a2);
+ if (member(&virt2, &t1))
+ {
+ switch ((int) M[ t1+PROTNUM ])
+ {
+ case AINT : t2 = APINT; break;
+ case AREAL : t2 = APREAL; break;
+ case AVIRT : t2 = APREF; break;
+ }
+ M[ a1 ] = (M[ t1+2 ]+M[ t1 ])/t2-1;
+ }
+ else errsignal(RTEREFTN);
+ break;
+
+ case 40 : /* LGETTYPE */
+ typep(M[ a2 ], a3, &virt1.addr, &virt1.mark);
+ storevirt(virt1, a1);
+ break;
+
+ case 41 : /* LCOPY */
+ loadvirt(virt2, a2);
+ copy(&virt2, &virt1);
+ storevirt(virt1, a1);
+ break;
+
+ case 42 : /* LNOT */
+ M[ a1 ] = ~ M[ a2 ];
+ break;
+
+ case 43 : /* LRCVAVIRT */ /* recover virtual address from ah */
+ virt1.addr = M[ a2 ];
+ virt1.mark = M[ virt1.addr+1 ];
+ storevirt(virt1, a1);
+ break;
+
+ case 44 : /* LVIRTDOT */
+ case 45 :
+ M[ a1 ] = M[ prototype[ M[ temporary ] ]->virtlist+a2 ];
+ break;
+
+ case 46 : /* LADDRPH */
+ case 47 : /* LADDRPH2 */
+ loadvirt(virt2, a2);
+ if (!member(&virt2, &M[ a1 ])) errsignal(RTEREFTN);
+ break;
+
+ case 48 : /* LIABS */
+ t2 = M[ a2 ];
+ M[ a1 ] = absolute(t2);
+ break;
+
+ case 49 : /* LINEG */
+ M[ a1 ] = -M[ a2 ];
+ break;
+
+ case 50 : /* LRABS */
+ r = MR(a2);
+ if( r < (real)0.0 )
+ r=(real)0.0-r;
+ MR(a1) = r;
+ break;
+
+ case 51 : /* LRNEG */
+ MR(a1) = -MR(a2);
+ break;
+
+ case 52 : /* LPARAMADDR */
+ t2 = M[ a2 ];
+ M[ a1 ] = t2+M[ prototype[ M[ t2+PROTNUM ] ]->parlist+a3 ];
+ break;
+
+ case 54 : /* LLOADT */
+ t1 = M[ ic++ ]; /* offset */
+ t2 = t1+loadt(M[ M[ a2 ] ], a3); /* object address */
+ loadvirt(virt1, t2);
+ storevirt(virt1, a1);
+ break;
+
+ case 55 : /* LIS */
+ loadvirt(virt2, a2);
+ M[ a1 ] = lbool(is(&virt2, a3));
+ break;
+
+ case 56 : /* LIN */
+ loadvirt(virt2, a2);
+ M[ a1 ] = lbool(inl(&virt2, a3));
+ break;
+
+ case 57 : /* LQUA */
+ loadvirt(virt2, a2);
+ if (member(&virt2, &M[ a1 ]))
+ qua(&virt2, a3);
+ else errsignal(RTEREFTN);
+ break;
+
+ case 58 : /* LIFIX */
+ M[ a1 ] = (word)( MR(a2) );
+ break;
+
+ case 59 : /* LFLOAT */
+ MR(a1) = (real)( M[ a2 ] );
+ break;
+
+ case 60 : /* LIMOVE */
+ M[ a1 ] = M[ a2 ];
+ break;
+
+ case 61 : /* LVMOVE */
+ loadvirt(virt1, a2);
+ storevirt(virt1, a1);
+ break;
+
+ case 62 : /* LRMOVE */ /* WARNING: these areas may overlap! */
+ r = MR(a2);
+ MR(a1) = r;
+ break;
+
+ case 63 : /* LFPMOVE */ /* WARNING: these areas may overlap! */
+ loadvirt(virt1, a2); /* MACHINE DEPENDENT */
+ t1 = M[ a2+2 ];
+ storevirt(virt1, a1);
+ M[ a1+2 ] = t1;
+ break;
+
+ case 82 : /* LEQNONE */
+ M[ a1 ] = lbool(M[ a2+1 ] != M[ M[ a2 ]+1 ]);
+ break;
+
+ case 83 : /* LNENONE */
+ M[ a1 ] = lbool(M[ a2+1 ] == M[ M[ a2 ]+1 ]);
+ break;
+
+ case 87 : /* LMDFTYPE */ /* modify the formal type */
+ loadvirt(virt1, a2);
+ virt1.addr += a3; /* number of "arrayof" */
+ storevirt(virt1, a1);
+ break;
+
+ case 100 : /* LOR */
+ M[ a1 ] = M[ a2 ] | M[ a3 ];
+ break;
+
+ case 101 : /* LAND */
+ M[ a1 ] = M[ a2 ] & M[ a3 ];
+ break;
+
+ case 102 : /* LARRAY */
+ case 103 :
+ case 104 :
+ loadvirt(virt2, a2);
+ if (member(&virt2, &t2))
+ {
+ t1 = M[ a3 ]-M[ t2+2 ]; /* index-lower+3 */
+ if (t1 < 3 || t1 >= M[ t2 ]) errsignal(RTEINVIN);
+ else M[ a1 ] = t2+t1;
+ }
+ else errsignal(RTEREFTN);
+ break;
+
+ case 105 : /* LFARRAY */ /* without any tests */
+ t1 = M[ M[ a2 ] ]; /* physical address */
+ M[ a1 ] = t1+M[ a3 ]-M[ t1+2 ];
+ break;
+
+ case 106 : /* LIEQUAL */
+ M[ a1 ] = lbool(M[ a2 ] == M[ a3 ]);
+ break;
+
+ case 107 : /* LINEQUAL */
+ M[ a1 ] = lbool(M[ a2 ] != M[ a3 ]);
+ break;
+
+ case 108 : /* LILT */
+ M[ a1 ] = lbool(M[ a2 ] < M[ a3 ]);
+ break;
+
+ case 109 : /* LILE */
+ M[ a1 ] = lbool(M[ a2 ] <= M[ a3 ]);
+ break;
+
+ case 110 : /* LIGT */
+ M[ a1 ] = lbool(M[ a2 ] > M[ a3 ]);
+ break;
+
+ case 111 : /* LIGE */
+ M[ a1 ] = lbool(M[ a2 ] >= M[ a3 ]);
+ break;
+
+ case 112 : /* LCOMBINE */
+ loadvirt(virt2, a2);
+ t1 = M[ a3 ];
+ storevirt(virt2, a1);
+ M[ a1+APREF ] = t1;
+ break;
+
+ case 113 : /* LIADD */
+ M[ a1 ] = M[ a2 ]+M[ a3 ];
+ break;
+
+ case 114 : /* LISUB */
+ M[ a1 ] = M[ a2 ]-M[ a3 ];
+ break;
+
+ case 115 : /* LIMULT */
+ M[ a1 ] = M[ a2 ] * M[ a3 ];
+ break;
+
+ case 116 : /* LSHIFT */
+ M[ a1 ] = shift(M[ a2 ], M[ a3 ]);
+ break;
+
+ case 117 : /* LIDIVE */
+ if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
+ else M[ a1 ] = M[ a2 ] / M[ a3 ];
+ break;
+
+ case 118 : /* LIMODE */
+ if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
+ else M[ a1 ] = M[ a2 ] % M[ a3 ];
+ break;
+
+ case 119 : /* LRADD */
+ MR(a1) = MR(a2)+MR(a3);
+ break;
+
+ case 120 : /* LRSUB */
+ MR(a1) = MR(a2)-MR(a3);
+ break;
+
+ case 121 : /* LRMULT */
+ MR(a1) = MR(a2) * MR(a3);
+ break;
+
+ case 122 : /* LRDIVE */
+ if (MR(a3) == (real)0.0) errsignal(RTEDIVBZ);
+ else MR(a1) = MR(a2) / MR(a3);
+ break;
+
+ case 123 : /* LEQREF */
+ loadvirt(virt2, a2);
+ loadvirt(virt3, a3);
+ if (member(&virt2, &t1))
+ M[ a1 ] = lbool(member(&virt3, &t2) && t1 == t2);
+ else M[ a1 ] = lbool(!member(&virt3, &t2));
+ break;
+
+ case 124 : /* LNEREF */
+ loadvirt(virt2, a2);
+ loadvirt(virt3, a3);
+ if (member(&virt2, &t1))
+ M[ a1 ] = lbool(!member(&virt3, &t2) || t1 != t2);
+ else M[ a1 ] = lbool(member(&virt3, &t2));
+ break;
+
+ case 125 : /* LREQ */
+ M[ a1 ] = lbool(MR(a2) == MR(a3));
+ break;
+
+ case 126 : /* LRNE */
+ M[ a1 ] = lbool(MR(a2) != MR(a3));
+ break;
+
+ case 127 : /* LRLT */
+ M[ a1 ] = lbool(MR(a2) < MR(a3));
+ break;
+
+ case 128 : /* LRLE */
+ M[ a1 ] = lbool(MR(a2) <= MR(a3));
+ break;
+
+ case 129 : /* LRGT */
+ M[ a1 ] = lbool(MR(a2) > MR(a3));
+ break;
+
+ case 130 : /* LRGE */
+ M[ a1 ] = lbool(MR(a2) >= MR(a3));
+ break;
+
+ case 131 : /* LXOR */
+ M[ a1 ] = M[ a2 ] ^ M[ a3 ];
+ break;
+
+ case 132 : /* LCALLPROCSTAND */
+#if USE_ALARM
+ alarm(0); /* reschedule forced so alarm may be switched off */
+#endif
+ reschedule=TRUE;
+ standard(a1);
+ break;
+
+ case 143 : /* LKILL */
+ loadvirt(virt1, a1);
+ disp(&virt1);
+ break;
+
+ case 144 : /* LHEADS */
+ loadvirt(virt1, a1);
+ heads(&virt1, a2);
+ break;
+
+ case 145 : /* LIPARINP */
+ param[ a3 ].xword = M[ a1 ];
+ break;
+
+ case 146 : /* LGKILL */
+ loadvirt(virt1, a1);
+ gkill(&virt1);
+ break;
+
+ case 147 : /* LVPARINP */
+ loadvirt(param[ a3 ].xvirt, a1);
+ break;
+
+ case 148 : /* LRPARINP */
+ param[ a3 ].xreal = MR(a1);
+ break;
+
+ case 149 : /* LQUATEST */
+ loadvirt(virt1, a1);
+ qua(&virt1, a2);
+ break;
+
+ case 150 : /* LSTYPE */
+ loadvirt(virt1, a1);
+ typref(&virt1, a2);
+ break;
+
+ case 151 : /* LIFFALSE */
+ if (M[ a1 ] == LFALSE) ic = a2;
+ break;
+
+ case 152 : /* LIFTRUE */
+ if (M[ a1 ] == LTRUE) ic = a2;
+ break;
+
+ case 159 : /* LGO */
+ go(M[ a2 ], M[ a1 ]);
+ break;
+
+ case 160 : /* LGOLOCAL */
+ goloc(M[ a2 ], M[ a1 ]);
+ break;
+
+ case 170 : /* LDTYPE */
+ loadvirt(virt1, a1); /* left side type */
+ loadvirt(virt2, a2);
+ loadvirt(virt3, a3); /* right side type */
+ typed(virt1.addr, virt1.mark, virt3.addr, virt3.mark, &virt2);
+ break;
+
+ case 172 : /* LTERMINATE */
+ term();
+ break;
+
+ case 173 : /* LWIND */
+ wind();
+ break;
+
+ case 174 : /* LBLOCK2 */
+ goloc(thisp->blck1, thisp->blck2);
+ break;
+
+ case 176 : /* LBLOCK3 */
+ disp(&thisp->backobj);
+ break;
+
+ case 177 : /* LTRACE */
+ trace(a1);
+ break;
+
+ case 178 : /* LINNER */
+ inner(a1);
+ break;
+
+ case 180 : /* LBACKHD */
+ backhd(&thisp->backobj, &M[ temporary ]);
+ break;
+
+ case 182 : /* LJUMP */
+ ic = a1;
+ break;
+
+ case 186 : /* LBLOCK1 */
+ openobj(a1, &thisp->blck1, &thisp->blck2);
+ break;
+
+ case 187 : /* LDETACH */
+ detach();
+ break;
+
+ case 188 : /* LATTACH */
+ loadvirt(virt1, a1);
+ attach(&virt1);
+ break;
+
+ case 191 : /* LBACKBL */
+ backbl(&thisp->backobj, &M[ temporary ]);
+ break;
+
+ case 192 : /* LBACKPR */
+ /* backpr(&thisp->backobj, &M[ temporary ]); */
+ back(&thisp->backobj, &M[ temporary ], (word) 0);
+ break;
+
+ case 193 : /* LBACK */
+ back(&thisp->backobj, &M[ temporary ], (word) 0);
+ break;
+
+ case 194 : /* LFIN */
+ fin(ic-APOPCODE, &thisp->backobj, &M[ temporary ]);
+ break;
+
+ case 195 : /* LCASE */
+ /* a2 = address of case description : */
+ /* minimal value, number of branches, */
+ /* remaining branches followed by "otherwise" code */
+ t1 = M[ a1 ]-M[ a2 ]; /* in 0..number of branches-1 */
+ if (t1 < 0 || t1 >= M[ a2+1 ])
+ ic = a2+2+M[ a2+1 ]; /* otherwise */
+ else
+ ic = M[ a2+2+t1 ]; /* indirect jump */
+ break;
+
+ case 220 : /* LRESUME */
+ loadvirt(virt1, a1);
+ resume(&virt1);
+ break;
+
+ case 221 : /* LSTOP */
+ passivate(STOPPED);
+ break;
+
+ case 222 : /* LKILLTEMP */
+ disp(&thisp->template);
+ break;
+
+ case 223 : /* LENABLE */
+ for (i = 0; i < a1; i++)
+ enable(thispix, virtprot(M[ ic++ ]));
+ evaluaterpc(thispix);
+ break;
+
+ case 224 : /* LDISABLE */
+ for (i = 0; i < a1; i++)
+ disable(thispix, virtprot(M[ ic++ ]));
+ break;
+
+ case 225 : /* LACCEPT1 */
+ rpc_accept(a1);
+ break;
+
+ case 226 : /* LACCEPT2 */
+ popmask(thispix);
+ rpc3();
+ break;
+
+ case 227 : /* LBACKRPC */
+ back(&thisp->backobj, &M[ temporary ], a1);
+ break;
+
+ case 228 : /* LASKPROT */
+ loadvirt(virt1, a1);
+ askprot(&virt1);
+ break;
+
+ case 240 : /* LSTEP */
+ if (M[ a1 ] < 0) errsignal(RTENEGST);
+ break;
+
+ default :
+ fprintf( stderr, "Invalid opcode\n" );
+ errsignal(RTESYSER);
+ break;
+ }
+
+}
+
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include <stdio.h>
+
+/* File I/O routines */
+
+void loadfile(status, ftype, am, fp) /* Load parameters of current file */
+word status; /* expected status of file */
+word *ftype; /* file type */
+word *am; /* file object address */
+FILE **fp; /* file stream pointer */
+{
+ word s;
+ virtaddr virt;
+
+ loadvirt(virt, currfile);
+ if (member(&virt, am)) /* file object exists */
+ {
+ s = M[ *am+FSTAT ]; /* check status */
+ if (status != s && status != UNKNOWN) errsignal(RTEILLIO);
+ *ftype = M[ *am+FTYPE ];
+ *fp = MF(*am+FFILE);
+ }
+ else errsignal(RTEREFTN); /* file not opened yet */
+} /* end loadfile */
+
+
+/* Open file object
+ */
+
+void genfileobj(ftemp, ftyp, fnam, virt, am)
+bool ftemp; /* TRUE iff file is temporary */
+word ftyp; /* file type */
+char *fnam; /* file name */
+virtaddr *virt; /* output virtual address */
+word *am; /* output physical address */
+{
+ word t1;
+
+ request((word) APFILE, &t1, am); /* generate file object */
+ virt->addr = t1;
+ virt->mark = M[ t1+1 ];
+ M[ *am+PROTNUM ] = FILEOBJECT;
+ M[ *am+FSTAT ] = UNKNOWN;
+ M[ *am+FTEMP ] = lbool(ftemp);
+ M[ *am+FTYPE ] = ftyp;
+ MN(*am+FNAME) = fnam;
+} /* end genfileobj */
+
+
+void reset(am) /* Prepare file for reading */
+word am;
+{
+ FILE *fp;
+
+ if (M[ am+FSTAT ] != UNKNOWN) /* first close file if opened */
+ if (fclose(MF(am+FFILE))) errsignal(RTEIOERR);
+ switch ((int) M[ am+FTYPE ])
+ {
+ case TEXTF : /* open text file for reading */
+ fp = fopen(MN(am+FNAME), "r");
+ M[ am+FSTAT ] = READING;
+ break;
+
+ case CHARF : /* open binary file for reading */
+ case INTF :
+ case REALF :
+ fp = fopen(MN(am+FNAME), BINARYREAD);
+ M[ am+FSTAT ] = READING;
+ break;
+
+ case DIRECT : /* open existing file for update */
+ fp = fopen(MN(am+FNAME), DIRECTOLD);
+ M[ am+FSTAT ] = UPDATING;
+ break;
+ }
+ if (fp == NULL)
+ {
+ M[ am+FSTAT ] = UNKNOWN;
+ errsignal(RTECNTOP);
+ }
+ MF(am+FFILE) = fp; /* store stream pointer */
+} /* end reset */
+
+
+void rewrite(am) /* Prepare file for writing */
+word am;
+{
+ FILE *fp;
+
+ if (M[ am+FSTAT ] != UNKNOWN) /* first close file if opened */
+ if (fclose(MF(am+FFILE))) errsignal(RTEIOERR);
+
+ switch ((int) M[ am+FTYPE ])
+ {
+ case TEXTF : /* open text file for writing */
+ fp = fopen(MN(am+FNAME), "w");
+ M[ am+FSTAT ] = WRITING;
+ break;
+
+ case CHARF : /* open binary file for writing */
+ case INTF :
+ case REALF :
+ fp = fopen(MN(am+FNAME), BINARYWRITE);
+ M[ am+FSTAT ] = WRITING;
+ break;
+
+ case DIRECT : /* create new file for update */
+ fp = fopen(MN(am+FNAME), DIRECTNEW);
+ M[ am+FSTAT ] = UPDATING;
+ break;
+ }
+ if (fp == NULL)
+ {
+ M[ am+FSTAT ] = UNKNOWN;
+ errsignal(RTECNTOP);
+ }
+ MF(am+FFILE) = fp; /* store stream pointer */
+} /* end rewrite */
+
+
+void delete(virt) /* Delete file */
+virtaddr *virt;
+{
+ word am;
+
+ if (member(virt, &am))
+ {
+ if (M[ am+FSTAT ] != UNKNOWN) /* first close file if opened */
+ if (fclose(MF(am+FFILE))) errsignal(RTEIOERR);
+ if (unlink(MN(am+FNAME))) errsignal(RTEIOERR); /* delete file */
+ free(MN(am+FNAME)); /* free memory used by file name */
+ disp(virt); /* and kill file object */
+ }
+ else errsignal(RTEREFTN);
+} /* end delete */
+
+
+char *tempfilename() /* Generate temporary file name */
+{
+ char *cp;
+ static int tempcnt = 0;
+
+ cp = ballocate(10);
+ if (cp == NULL) errsignal(RTEMEMOV);
+ sprintf(cp, "LOG%05d", tempcnt++);
+ return (cp);
+} /* end tempfilename */
+
+
+bool testeof(fp) /* Test for end of file */
+FILE *fp;
+{
+ int ch;
+
+ ch = getc(fp);
+ ungetc(ch, fp);
+ return (ch == EOF);
+} /* end testeof */
+
+
+bool testeoln(fp) /* Test for end of line */
+FILE *fp;
+{
+ int ch;
+
+ ch = getc(fp);
+ ungetc(ch, fp);
+ return (ch == '\n');
+} /* end testeoln */
+
+
+void readln(fp) /* Skip to end of line */
+FILE *fp;
+{
+ int ch;
+
+ while ((ch = getc(fp)) != '\n' && ch != EOF) ;
+} /* end readln */
+
+
+static char str[10];
+word readint(fp) /* Read integer */
+FILE *fp;
+{
+ long i=0L;
+ int j=0,c=0;
+ int bool=0;
+ while(c<'0' || c>'9'){
+ if(c=='-') bool=1;
+ else bool=0;
+ c=fgetc(fp);
+ if(c==EOF){
+ errsignal(RTEBADFM);
+ goto END;
+ }
+ }
+
+ do{
+ i=10*i+(c-'0');
+ j++;
+ c=fgetc(fp);
+ }while(c>='0' && c<='9');
+ if(c!=EOF) ungetc(c,fp);
+ if (j == 0 ) errsignal(RTEBADFM);
+ END:
+ if(bool)
+ return(-i);
+ else
+ return (i);
+} /* end readint */
+
+
+double readreal(fp) /* Read real */
+FILE *fp;
+{
+ double r;
+
+ if (fscanf(fp, "%lf", &r) != 1) errsignal(RTEBADFM);
+ return (r);
+} /* end readreal */
+
+
+void writeint(n, field, fp) /* Write integer */
+word n, field;
+FILE *fp;
+{
+/* PS&MM static char format[ 32 ];
+
+ sprintf(format,"%%%dld",(int)field); */
+ if (fprintf(fp, "%*ld", (int)field, (long) n) == 0) errsignal(RTEIOERR);
+} /* end writeint */
+
+
+void writereal(r, field1, field2, fp) /* Write real */
+double r;
+word field1, field2;
+FILE *fp;
+{
+/* PS&MM char format[ 32 ];
+
+ sprintf(format, "%%%d.%dlf", (int) field1, (int) field2);
+ if (fprintf(fp, format, r) == 0) errsignal(RTEIOERR);
+*/
+ if (fprintf(fp,"%*.*lf", (int)field1, (int)field2, r) == 0)
+ errsignal(RTEIOERR);
+} /* end writereal */
+
+
+void writestring(offset, field, fp) /* Write string */
+word offset;
+word field;
+FILE *fp;
+{
+ word len, addr;
+ char *cp;
+
+ addr = strings+offset;
+ len = M[ addr ];
+ cp = (char *) &M[ addr+1 ]; /* pointer to first char of string */
+ while (len-- > 0 && field-- != 0)
+ if (putc(*cp++, fp) == EOF) errsignal(RTEIOERR);
+} /* end writestring */
+
+
+word directio(buf, len, action, fp) /* Perform direct access read/write */
+virtaddr *buf; /* buffer array */
+word len; /* number of bytes to transfer */
+#ifndef NO_PROTOTYPES
+int (*action)(char *,int,int,FILE *); /* fread() or fwrite() */
+#else
+int (*action)(); /* fread() or fwrite() */
+#endif
+FILE *fp; /* stream pointer */
+{
+ word am, t1, result;
+ int n;
+
+ if (member(buf, &am)) /* file not none */
+ {
+ if (fseek(fp, 0L, 1)) errsignal(RTEIOERR); /* seek to current */
+ /* position required */
+ len = min(len, (M[ am ]-3)*sizeof(word)); /* check appetite */
+ result = 0; /* number of bytes transfered */
+ t1 = am+3; /* address in memory for transfer */
+ while (len >= IOBLOCK) /* transfer full blocks */
+ {
+ n = (*action)((char *) &M[ t1 ], 1, IOBLOCK, fp);
+ result += n;
+ if (n != IOBLOCK) return(result);
+ len -= IOBLOCK;
+ t1 += IOBLOCK/sizeof(word);
+ }
+ if (len > 0) /* transfer last unfilled block */
+ {
+ n = (*action)((char *) &M[ t1 ], 1, (int) len, fp);
+ result += n;
+ }
+ return(result);
+ }
+ else errsignal(RTEREFTN);
+} /* end directio */
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#ifdef GEN
+#undef GEN
+#endif
+
+#if UNIX
+#include "../gen/genint.h"
+#else
+#include "..\gen\genint.h"
+#endif
+
+/* Variables : */
+
+extern protdescr *prototype[];
+extern word ipradr; /* address of primitive type descriptions */
+extern word temporary; /* address of global temporary variables */
+extern word strings; /* base for string constants */
+extern word lastprot; /* the last used prototype number */
+extern word freem; /* first free cell in M */
+extern word currfile; /* current file virtual address */
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+#define isign(k, i) (((i) >= 0) ? (k) : -(k))
+#define iabs(i) ((i) >= 0 ? (i) : -(i))
+#define sqr(x) ((x)*(x))
+#define min0(x, y) ((x) < (y) ? (x) : (y))
+#define max0(x, y) ((x) > (y) ? (x) : (y))
+
+#define alf(i) alf_[i]
+#define ix(i) ix_[i]
+#define iy(i) iy_[i]
+#define sx(i) sx_[i]
+#define sy(i) sy_[i]
+#define d(i) d_[i]
+#define min(i) min_[i]
+#define max(i) max_[i]
+#define mx(i) mx_[i]
+#define mx1(i) mx1_[i]
+#define incr1(i) incr1_[i]
+#define incr2(i) incr2_[i]
+#define ip(i) ip_[i]
+#define sj(i) sj_[i]
+#define sc(i) sc_[i]
+#define bl(i) bl_[i]
+#define bxy(i) bxy_[i]
+#define bp(i) bp_[i]
+#define g(i,j) g_[i][j]
+#define go(i,j) go_[i][j]
+
+#define logical int
+#define FALSE 0
+#define TRUE 1
+#define INT(x) ((int) (x))
+#define FLOAT(x) ((float) (x))
+#define SIN(x) sin((double) (x))
+#define COS(x) cos((double) (x))
+#define SQRT(x) sqrt((double) (x))
+
+int pa = 3, qa = 4;
+float asp = 0.75;
+
+void pascal cirb(xi, yi, ri, alfa, beta, cbord, bcint, p, q)
+int *xi, *yi, *ri;
+float *alfa, *beta;
+int *cbord, *bcint, *p, *q;
+{
+ extern void pascal wyc47();
+
+ wyc47(*xi, *yi, (double) *ri, (double) *alfa, (double) *beta,
+ *cbord, *bcint, pa*(*p), qa*(*q), (double) 1.0);
+}
+
+/***********************************************************************
+void pascal rcirb(xr, yr, r, alfa, beta, cbord, bcint, p, q)
+float *xr, *yr, *r, *alfa, *beta;
+int *cbord, *bcint, *p, *q;
+{
+ extern void pascal wyc47();
+ extern float mix, miy, sxx, syy;
+ extern int mii, maj;
+
+ wyc47(mii+INT(sxx*(*xr-mix)), maj-INT(syy*(*yr-miy)), (double) *r,
+ (double) *alfa, (double) *beta,
+ *cbord, *bcint, pa*(*p), qa*(*q), (double) sxx);
+}
+***********************************************************************/
+
+void pascal wyc47(ir, jr, r, alfa, beta, cbord, bcint, p, q, cx)
+int ir, jr;
+double r, alfa, beta;
+int cbord, bcint, p, q;
+double cx;
+{
+ extern double sin(), cos(), sqrt();
+ extern void pascal move(), pascal hfill(), pascal pushxy(),
+ pascal popxy(), pascal color(), pascal style();
+
+ float alfj,qasp,pr,a,s,c;
+ float alf(2+1);
+ long p1,q1,p2,q2,p4,q4,u,v,w,d1;
+ int i,j,j1,j2,j3,k,l,n,m,m1,m2,ri,x,y,py,px1,
+ px2,sxi,sy1,sy2,xi,dj,dxj,dyj,inc1,
+ pa,qa;
+ int ix(2+1),iy(2+1),sx(2+1),sy(3+1),d(2+1),min(5+1),max(5+1),
+ mx(2+1),mx1(2+1),incr1(2+1),incr2(2+1),ip(2+1),sj(2+1),
+ sc(3+1),g(3+1,2+1),go(3+1,2+1);
+ logical bl(2+1),bxy(2+1),bp(3+1);
+ logical bc;
+ static int one = 1;
+
+ qasp=asp*FLOAT(q);
+ a=cx*r;
+ ri=INT(a);
+ pr=a*FLOAT(p);
+ q1=q*q;
+ q2=2*q1;
+ q4=2*q2;
+ p1=p*p;
+ p2=2*p1;
+ p4=2*p2;
+ for (i=1; i <= 3; i++)
+ {
+ bp(i)=FALSE;
+ for (j=1; j <= 2; j++)
+ {
+ go(i,j)=3;
+ g(i,j)=3;
+ }
+ }
+ sj(1)=1;
+ sj(2)=-1 ;
+ if(alfa == beta) {
+ n=2;
+ sc(1)=1;
+ sc(2)=-1;
+ bp(3)=TRUE;
+ bl(1)=TRUE;
+ bl(2)=TRUE;
+ goto L45;
+ }
+ alf(1)=alfa;
+ alf(2)=beta;
+
+ for (j=1; j <= 2; j++)
+ {
+ alfj=alf(j);
+ c=COS(alfj);
+ s=SIN(alfj);
+ a=pr/SQRT(sqr(p*c)+sqr(qasp*s));
+ m=INT(a*c);
+ sx(j)=isign(1,m);
+ ix(j)=m;
+ m=-INT(a*asp*s);
+ sy(j)=isign(1,m);
+ iy(j)=iabs(m);
+ }
+
+ sy1=sy(1);
+ sy2=sy(2);
+ sc(1)=sy1;
+ sc(2)=sy2;
+ if (sy1 >= 0) {
+ j1=1;
+ j2=2;
+ } else {
+ j1=2;
+ j2=1;
+ }
+
+ if (sy1 == sy2) {
+ m=sy1*(ix(2)-ix(1));
+ if (isign(1,m) > 0) {
+ n=1;
+ bp(2)=TRUE;
+ bp(3)=TRUE;
+ g(1,1)=j1;
+ g(1,2)=j2;
+ go(1,1)=j1;
+ go(1,2)=j2;
+ } else {
+ n=3;
+ sc(3)=-sy1;
+ g(1,2)=j2;
+ g(2,1)=j1;
+ go(1,2)=j2;
+ go(2,1)=j1;
+ }
+ } else {
+ n=2;
+ bp(3)=TRUE;
+ g(1,j1)=1;
+ g(2,j1)=2;
+ go(1,j1)=1;
+ go(2,j1)=2;
+ }
+
+ bl(1)=FALSE;
+ bl(2)=FALSE;
+
+ for (j=1; j <= 2; j++)
+ {
+ dxj=iabs(ix(j));
+ ix(j)=dxj;
+ dyj=iy(j);
+ ip(j)=0;
+ if (dyj > dxj) {
+ bxy(j)=TRUE;
+ m=2*dxj;
+ d(j)=m-dyj;
+ incr2(j)=2*(dxj-dyj);
+ } else {
+ bxy(j)=FALSE;
+ m=2*dyj;
+ d(j)=m-dxj;
+ incr2(j)=2*(dyj-dxj);
+ }
+ incr1(j)=m;
+ }
+
+
+ L45: u=0;
+ v=ri*p4;
+ d1=q2-p1*(2*ri-1);
+ x=ri;
+ min(3)=x;
+ max(3)=x;
+ bc=FALSE;
+ y=0;
+
+
+ L300: for (j=1; j <= 2; j++)
+ {
+ if (bl(j)) continue;
+ dj=d(j);
+ xi=ip(j);
+ min(j)=xi;
+ m=ix(j);
+ if (bxy(j)) {
+ max(j)=xi;
+ if (dj > 0) {
+ d(j)=dj+incr2(j);
+ if (xi >= m) bl(j)=TRUE;
+ ip(j)=xi+1;
+ } else {
+ d(j)=dj+incr1(j);
+ }
+ } else {
+ inc1=incr1(j);
+ L40: if (dj > 0) {
+ d(j)=dj+incr2(j);
+ ip(j)=xi+1;
+ max(j)=xi;
+ } else {
+ dj=dj+inc1;
+ xi=xi+1;
+ if (xi >= m) {
+ dj=1;
+ bl(j)=TRUE;
+ }
+ goto L40;
+ }
+ }
+ if (y == iy(j)) bl(j)=TRUE;
+ }
+
+
+ for (i=1; i <= n; i++)
+ {
+ if (bp(i)) continue;
+ j1=g(i,1);
+ j2=g(i,2);
+ if (j1 != 3) {
+ j3=j1;
+ l=1;
+ } else {
+ j3=j2;
+ l=2;
+ }
+ j=j1+j2;
+ sy(3)=sc(i);
+ if ((j == 4 || j == 5) && bl(j3)) {
+ m=ix(j3);
+ if (sy(j3) == sj(j3)*sx(j3)) {
+ bp(i)=TRUE;
+ min(j)=m;
+ max(j)=max0(max(3),m);
+ if (j1 != 3) {
+ j2=j;
+ } else {
+ j1=j;
+ }
+ } else {
+ g(i,l)=3;
+ sc(i)=sy(j3);
+ min(j3)=min0(min(j3),min(3));
+ }
+ } else {
+ if (j == 3) {
+ for (l=1; l <= 2; l++)
+ {
+ j=g(i,l);
+ if (bl(j)) {
+ g(i,l)=3;
+ sc(i)=sy(j);
+ min(j)=min0(min(j),min(3));
+ }
+ }
+ }
+ }
+
+ j=j1;
+ for (l=1; l <= 2; l++)
+ {
+ m1=max(j);
+ m2=min(j);
+ if (j < 3) {
+ sxi=sx(j);
+ } else {
+ sxi=-sj(l);
+ if (j == 3) {
+ k=go(i,l);
+ if (k < 3) {
+ m1=min0(m1,max(k));
+ m2=min0(m1,m2);
+ }
+ }
+ }
+ if (sxi > 0) {
+ mx(l)=ir+m2;
+ mx1(l)=ir+m1;
+ } else {
+ mx(l)=ir-m1;
+ mx1(l)=ir-m2;
+ }
+ j=j2;
+ }
+
+ py=jr+sy(j3)*y;
+ if (bcint != 0) {
+ px1=mx1(1)+1;
+ px2=mx(2)-1;
+ if (px1 <= px2) {
+ move(&px1,&py);
+ hfill(&px2);
+ }
+ }
+ pushxy();
+ color(&cbord);
+ style(&one);
+ move(&mx(1),&py);
+ hfill(&mx1(1));
+ move(&mx(2),&py);
+ hfill(&mx1(2)) ;
+ popxy();
+ }
+
+ if (x == 0) return;
+
+
+ if (bp(1) && bp(2) && bp(3)) return;
+ if (bc) goto L240;
+
+ u=u+q4;
+ if (d1 < 0) {
+ d1=d1+u+q2;
+ } else {
+ v=v-p4;
+ w=u-v;
+ if (w > 0) {
+ bc=TRUE;
+ w=w/2-v;
+ }
+ d1=d1+w+q2;
+ x=x-1;
+ }
+ y=y+1;
+ min(3)=x;
+ max(3)=x;
+ if (bc) goto L250;
+ goto L300;
+
+ L240: max(3)=x;
+ y=y+1;
+ L250: v=v-p4;
+ x=x-1;
+ if (d1 > 0) {
+ d1=d1-v+p2;
+ } else {
+ u=u+q4;
+ d1=d1+u-v+p2;
+ min(3)=x+1;
+ goto L300;
+ }
+ if (x > 0) goto L250;
+ min(3)=x;
+ goto L300;
+}
+\1a
+\r
--- /dev/null
+
+ Zestaw dystrybucyjny pakietu
+ podstawowych procedur graficznych IIUWGRAF
+ ( wersja 2.2 )
+
+
+1. IIUWGRAF TXT - dokumentacja
+
+ DISTRIB.TXT - niniejszy tekst
+ IIUWGRAF.DOC - podrecznik ( pod PWORDem )
+ IIUWGRAF.STY - definicja stylow ( WORD )
+ IIUWGRAF.DHN - podrecznik ( WORD, wersja DHN )
+ IIUWGRAF.POL - podrecznik ( bez polskich liter, do drukowania )
+ GRAPH.H - deklaracja procedur IIUWGRAFu dla MS Pascala
+
+
+2. IIUWGRAF_LB - biblioteki
+
+ HGCMSF.LIB - Hercules, MS Fortran/Pascal
+ HGCMSF4.LIB - Hercules, MS Fortran v.4.00
+ MGCMSF.LIB - IBM Color/Graphics, MS Fortran/Pascal
+ MGCMSF4.LIB - IBM Color/Graphics, MS Fortran v.4.00
+ MGC64MSF.LIB - IBM Color/Graphics (tryb 640*200),
+ MS Fortran/Pascal
+ MGC64MF4.LIB - IBM Color/Graphics (tryb 640*200),
+ MS Fortran v.4.00
+ HGCCS.LIB - Hercules, Lattice C model S
+ HGCCD.LIB - Hercules, Lattice C model D
+ HGCCP.LIB - Hercules, Lattice C model P
+ HGCCL.LIB - Hercules, Lattice C model L
+
+
+3. IIUWGRAF_LC - biblioteki ( Lattice C )
+
+ MGCCS.LIB - IBM Color/Graphics, Lattice C model S
+ MGCCD.LIB - IBM Color/Graphics, Lattice C model D
+ MGCCP.LIB - IBM Color/Graphics, Lattice C model P
+ MGCCL.LIB - IBM Color/Graphics, Lattice C model L
+ MGC64CS.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model S
+ MGC64CD.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model D
+ MGC64CP.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model P
+ MGC64CL.LIB - IBM Color/Graphics (tryb 640*200),
+ Lattice C model L
+
+
+4. HGCDEMO
+
+ HGCDEMO.EXE - program pokazowy dla karty Hercules
+ HGCFEDIT.EXE - edytor znakow ( Hercules )
+ DUMP1.DAT - dane dla programu pokazowego
+ DUMP2.DAT - dane dla programu pokazowego
+ HGCPRINT.EXE - program do drukowania obrazu graficznego,
+ ( Hercules )
+
+\f
+
+5. MGCDEMO
+
+ MGCDEMO.EXE - program pokazowy dla karty IBM Color/Graphics
+ MGCFEDIT.EXE - edytor znakow ( IBM Color/Graphics )
+
+ MGC64DEM.EXE - program pokazowy dla karty
+ IBM Color/Graphics ( tryb 640*200 )
+ MGC64FED.EXE - edytor znakow
+ ( IBM Color/Graphics, tryb 640*200 )
+ MGCPRINT.EXE - program do drukowania obrazu graficznego
+ ( IBM Color/Graphics )
+
+
+6. IIUWGRAF EGA ( zestaw dystrybucyjny dla karty EGA )
+
+ EGAMSF.LIB - biblioteka, MS Fortran/Pascal
+ EGAMSF4.LIB - biblioteka, MS Fortran v.4.00
+ EGACS.LIB - biblioteka, Lattice C model S
+ EGACD.LIB - biblioteka, Lattice C model D
+ EGACP.LIB - biblioteka, Lattice C model P
+ EGACL.LIB - biblioteka, Lattice C model L
+
+ EGADEMO.EXE - program pokazowy
+ EGAFEDIT.EXE - edytor znakow
--- /dev/null
+
+ FEDIT - a simple font editor for IBM PC
+ a companion to IIUWGRAF graphics library
+
+FEDIT allows to create and modify 8*8 pixel patterns. Such
+patterns may be displayed as part of graphics screen image
+via the "hascii" function.
+
+Font tables can be prepared by FEDIT in two formats:
+
+ - as an assembly subroutine,
+ delivering address of the font table
+ in the form suitable for passing to "hfont"
+ - as an independent program,
+ setting up pointer to the font table in
+ the location of interrupt vector 31.
+
+The first format can be used to replace the standard font
+usually found in ROM BIOS at location F000:FA6E. It is used
+by "hascii" for drawing character codes 0 to 127. The subroutine
+generated by FEDIT has to be linked together with the application.
+This is "base 0" format.
+FEDIT generates the subroutine with the name "hfont8". Should
+another name be desired (e.g. when font tables are to be switched
+dynamically), it may changed by hand in the assembly source.
+
+The second format is used when drawing characters from the
+extended range 128 to 255. This font has to be loaded into
+memory before execution of the application program that
+uses it by invoking the program generated by FEDIT.
+This is "base 128" format.
+FEDIT generates this table as part of an independent program,
+that sets up the vector address and exits via "terminate and
+stay resident".
+FEDIT and HGCGRAPHICS do not provide facilities for dynamic
+switching of this extended font table.
+
+
+For example,
+
+ integer*2 iseg,ioffs
+ call hfont8(iseg,ioffs)
+ ...
+ call hascii(45) ; uses ROM BIOS
+ call hascii(145) ; extended table
+ ...
+ call hfont(iseg,ioffs)
+ call hascii(45) ; uses FEDIT font
+ call hascii(145) ; same extended table
+ ....
+ call hfont(16#f000,16#fa6e)
+ call hascii(45) ; ROM BIOS again
+ call hascii(145) ; same extended table
+
+
+FEDIT is a simple conversational program with few commands. The basic
+idea is to have a table of 8*8 pixel patterns that can be modified
+interactively. A single character can be brought out of the table for
+editing and returned, possibly to a different position in the table.
+There are two tables, one for character codes 0 through 127, the other
+for codes 128 through 255. The first table is read-only. The second table
+can be initialized by an already resident extended font table, loaded
+from a FEDIT-created file or initialized as empty. The second table can be
+written out to file in one of two formats discussed above.
+
+FEDIT commands are entered as single keystrokes selecting the commands
+listed in a menu appearing on top of the screen.
+Additional parameters, if any, are prompted for.
+
+FEDIT commands:
+
+< low redisplays the 0 to 127 table
+
+> high redisplays the 128 to 255 table
+
+i init initializes 128 to 255 table to all zeros
+
+l load loads the 128 to 255 table from file;
+ asks for the file name
+
+d dump dumps the 128 to 255 table to file;
+ asks for the file name;
+ asks for base, which should be either 0 or
+ 128, indicating one of the two formats
+ asks for target:
+ f - ms fortran, ms pascal
+ s - lattice c, s model
+ p - lattice c, p model
+ d - lattice c, d model
+ l - lattice c, l model
+
+e edit brings a character into the editing area
+ asks for a character code (in decimal);
+ during editing, cursor keys may be used
+ to select pixel position, "INS" to set
+ the pixel on, "DEL" to set it off, "END"
+ to exit edit mode.
+
+t text accepts a short text that will be displayed
+ during the editing as an additional help
+ for judgement of the quality of the appearance
+ of currently edited character;
+ asks for vspace & hspace : horizontal & vertical
+ spacing between adjacent character boxes,
+ then waits for a string (at most 40 chars).
+
+p put saves the pattern in the editing buffer
+ in the font table;
+ asks for a code (in decimal) which should
+ be in the range 128 through 255
+
+q quit exits from FEDIT
+
+FEDIT is not foolproof, e.g. it will not survive an attempt to load
+a non-existing font file and it will overwrite an existing file
+without warning if asked to.
--- /dev/null
+ PROGRAMMER'S REFERENCE FOR GENIUS MOUSE DRIVER
+
+*** 1 : BRIEF DESCRIPTION
+
+The Genius Mouse Driver enables you to use mouse hardware to move an on-screen
+cursor and control its movement through a software program. Various functions
+allow you to determine cursor placement, cursor shape, and button status.
+
+In order for you to interface your Genius Mouse with an application program, the
+following information on the Genius Driver has been provided.
+
+*** 2 : GRAPHICS AND TEXT CURSORS
+
+GMOUSE Driver supports a hardware text cursor, a software text cursor, and
+a graphics cursor. A hardware text cursor is a blinking cursor which moves from
+one character to another on-screen. This blinking cursor may take the form of a
+block or underscore. A software text cursor makes use of display attributes to
+change the visual appearance of a character on-screen. Movement is from
+character to character. A graphics cursor is a shape that moves over on-screen
+images.
+
+You can choose any of these three cursors to use on-screen, however, only one
+cursor can be displayed at a given time. Also, within your application program,
+you can switch back and forth between cursors.
+
+
+Display the Graphics Cursor
+
+The cursor appears on-screen or disappears from the screen through the calling
+program. This cursor consists of a block of pixels. As this block moves
+on-screen and affects the pixels beneath it, the cursor shape and background are
+created. This interaction is defined by two 16-by-16 bit arrays;
+one is the screen mask and the other is the cursor mask. The screen mask
+determines what part of the cursor pixel is to be the shape, and what part is
+is to be the background. The cursor mask determines which pixels contribute to
+the color of the cursor. Whenever changes are made to the screen which lie
+directly beneath the cursor, the cursor should be concealed so that old values
+are not restored to the screen.
+
+Please note that with a high resolution mode, you have a 16-by-16 pixel block;
+with a medium resolution (four color) mode, you have a 8-by-16 pixel block; with
+a medium resolution (sixteen color) mode, you have a 4-by-16 pixel block.
+
+Refer to function 9.
+
+To create the cursor, the software uses data from the computer's screen memory
+which defines the color of each pixel on-screen. Operations are performed that
+affect individual screen bits. Software ANDs the screen mask defining the
+pixels under the cursor and XORs the cursor mask with the result of the AND
+operation.
+
+Note the results when:
+
+
+
+
+
+
+ page 1
+\f
+Screen Mask Bit is Cursor Mask Bit is Resulting Screen Bit is
+------------------ ------------------ -----------------------
+ 0 0 0
+ 0 1 1
+ 1 0 unchanged
+ 1 1 inverted
+
+With each mouse function, a reference to the graphics cursor location is in
+reference to a point on-screen directly beneath the cursor. This point that the
+mouse software uses to determine the cursor coordinates is known as the cursor's
+hot spot.
+Generally, the upper_left hand corner of the cursor block is designated as the
+coordinates for the cursor default value. ((0,0) are the upper_left hand corner
+coordinates.)
+
+Software Text Cursor
+
+You can use this text cursor when your computer is in one of the text modes. By
+changing the character attributes beneath the cursor, the appearance of the
+character is influenced on-screen. This effect on the text cursor can be
+defined by two 16-bit mask values. These bits can be described as follows:
+bit 15 sets the blinking (1) or non-blinking (0) character ; bit 12 - 14 set the
+background (1); bits 8 - 10 set the foreground color; and bits 0 - 7 set the
+character code. These values in the screen mask and the cursor mask
+determine the character's new attributes when the cursor is covering the
+character. The screen mask decides which of the character's attributes are
+maintained. The cursor mask decides in what manner the attributes are altered
+to produce the cursor.
+
+In creating this cursor, the software works from data which defines each
+character on the screen. The software first ANDs the screen mask and the screen
+data bit for the character beneath the cursor. Next, the software XORs the
+cursor mask and the result of the AND operation.
+
+When a function refers to the text cursor location, it gives the coordinates of
+the character beneath the cursor.
+
+Refer to function 10.
+
+Hardware Text Cursor
+
+This cursor is also available when the computer is in one of the text modes.
+This cursor is the one seen on-screen when the computer is powered on. It
+consists of 8 pixels wide and 8 to 14 pixels tall. Software allows you to use
+this cursor for your needs. Scan lines determine a cursor's appearance
+on-screen. A scan line consists of a horizontal set of pixels.
+If a line is on, there will be flashing on the screen. If a line is off, there
+is no effect. Scan lines are numbered from 0 to 7, or 0 to 11 depending on the
+type of display used. 0 indicates the top scan line.
+
+Refer to function 10.
+
+*** 2.1 : Mouse Buttons
+
+Mouse functions can give the status of the mouse buttons and the number of times
+a certain button has been pressed and released. The button status is given as
+an integer. If a bit is set to 1 the button is down; if a bit is set to 0, the
+button is up.
+ page 2
+\f
+ Bit 0 - Left Button Status
+ Bit 1 - Right Button Status
+ Bit 2 - Middle Button Status
+Each time a mouse button is pressed, a counter records the number of presses and
+releases. The software sets the counter to zero once it has been read or after
+a reset.
+
+*** 2.2 : Unit of Distance - Mouse Motion
+
+The motion of the mouse can be expressed in a unit of distance (mouse motion)
+and is approximately 1/200 of an inch.
+
+With mouse movement, mouse software determines a horizontal and vertical mouse
+motion count. This count is used by the software to move a cursor a certain
+number of pixels on-screen. Software defines mouse motion sensitivity (the
+number of mouse motions needed to move the cursor 8 pixels on-screen) and this
+sensitivity determines the rate at which the cursor moves on-screen.
+
+Refer to function 15.
+
+*** 2.3 : Internal Cursor Flag
+
+Mouse software supports an internal flag. This flag determines when the cursor
+should appear on-screen. If the flag equals 0, the cursor appears on-screen; if
+the flag is any other number, the cursor disappears from the screen.
+
+You can call functions 1 and 2 a number of times, however, if you call function
+2, you must call function 1 later. This is necessary to restore the flag's
+previous value.
+
+Refer to functions 1 and 2.
+
+*** 3 : CALLING FROM ASSEMBLY LANGUAGE PROGRAMS
+
+To make mouse function calls:
+
+Load the appropriate registers (AX, BX, CX, DX) with the parameter values.
+These correspond to G1%, G2%, G3%, and G4% as shown in the BASIC example to
+follow. Then execute software interrupt 51 (33H). The values given by the
+mouse functions will be installed in the registers.
+
+
+Example:
+
+ ; * set cursor to location (150,100)
+ Mov AX,4 ;(function call 4)
+ Mov CX,150 ;(set horizontal to 150)
+ Mov DX,100 ;(set vertical to 100)
+ Int 51(33H) ;(interrupt to mouse)
+
+It is important to note that before using INT 33H, one should verify the
+presence of the mouse driver. Executing an INT 33H will cause uncertain results
+if the mouse driver is not loaded. Assume a mouse driver is present when INT
+33H vector is non-zero and the vector does not point to an IRET instruction.
+
+Note: When making a mouse call in Assembly Language, expect somewhat of a
+different value for the fourth parameter (when compared with calls using a BASIC
+program) involving functions 9, 12, and 16.
+ page 3
+\f
+*** 4 : CALLING FROM BASIC LANGUAGE PROGRAM
+
+To make mouse function calls:
+
+ Set a pair of integer variables in your program for the offset and the segment
+ of the mouse driver entry point.
+
+ In order to obtain the offset and segment values, the following statements
+ must be inserted into your program before any calls to mouse functions:
+
+10 DEF SEG = 0
+15 ' GET GMOUSE ENTRY POINT
+20 GMSEG = PEEK( 51*4 + 2 ) + 256 * PEEK( 51*4 + 3 ) ' GET SEGMENT ENTRY
+30 GMOUSE = 2 + PEEK( 51*4 ) + 256 * PEEK( 51*4 + 1 ) ' GET OFFSET ENTRY
+40 DEF SEG = GMSEG ' SET SEGMENT REGISTER AS THE SEGMENT OF GMOUSE
+
+To enter the mouse driver, use the CALL statement:
+
+ CALL GMOUSE (G1%, G2%, G3%, G4%)
+
+GMOUSE contains the entry offset of the mouse driver. G1%, G2%, G3%, and G4%
+are the integer variables given in the call. These four must be specified in
+the CALL statement even if a value is not assigned. When a value is assigned,
+it must be an integer, that is, a whole number.
+
+Example:
+
+50 ' Find the Activated Mode of Genius Mouse
+60 G1% = 0 : G2% = 0
+70 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+80 IF G2% AND 2 THEN PRINT "Genius Mouse ( 2_Button Mode ) Enable"
+90 IF G2% AND 3 THEN PRINT "Genius Mouse ( 3_Button Mode ) Enable"
+100 IF NOT G1% THEN PRINT "Can't Find Genius Mouse"
+
+*** 5 : MOUSE FUNCTIONS
+
+These functions listed apply to the Genius Mouse. Further descriptions of each
+mouse function will be given in the following pages.
+
+Functions Function Number
+-----------------------------------------------------------------
+Reset Genius Mouse Driver 0
+Enable Cursor Display 1
+Disable Cursor Display 2
+Read Cursor Location & Button State of Genius Mouse 3
+Set Cursor Location of Genius Mouse 4
+Read Button Press State of Genius Mouse 5
+Read Button Release State of Genius Mouse 6
+Define Horizontal (X) Range of Cursor Location 7
+Define Vertical (Y) Range of Cursor Location 8
+Define Graphics Mode Cursor Style 9
+Define Text Mode Cursor Style 10
+Read Genius Mouse Motion Number 11
+Define Event Handler Entry Location 12
+Enable Light Pen Emulation Function 13
+Disable Light Pen Emulation Function 14
+Define Sensitivity (Mouse Motion/Pixel) of Genius Mouse 15
+
+ page 4
+\f
+Disable Cursor Display in Special Range 16
+Define Double-Speed Threshold 19
+
+EGA functions are described in Section *** 7.
+
+*** 6 : DESCRIPTION OF THE MOUSE FUNCTIONS
+
+You'll notice that with the following mouse function descriptions, the
+parameters needed to make the calls and the expected outcome (return) for each
+is indicated. Also, any special conditions regarding any of the mouse functions
+have been included. Further, an example of a program has been provided in order
+for you to understand how to make the call.
+
+The input and return values are presented for 8086 registers and for BASIC in
+the following pages.
+
+It is important to note that each mouse function call needs four parameters.
+The Genius Mouse software does not verify any input values, and therefore, if
+any incorrect values are given, uncertain results will occur.
+
+Function 0: Reset Genius Mouse Driver
+
+Function 0 gives the current status of the mouse hardware plus the current
+status of the mouse software. The calling program is able to determine the
+presence of a mouse driver and/or a serial port.
+
+This function resets the mouse driver to the following default status as
+indicated:
+
+Variable Value
+------------------------------------------------------------------------------
+internal cursor flag -1 (cursor concealed)
+graphics cursor shape horizontal oval
+text cursor reverse video
+user-defined call mask all zeroes
+light pen emulation mode enabled
+vertical mouse motion/pixel ratio 16 to 8
+horizontal mouse motion/pixel ratio 8 to 8
+vertical min/max cursor coordinates 0/current display mode y values minus 1
+horizontal min/max cursor coordinates 0/current display mode x values minus 1
+
+8086 Register
+Input: AX = 0
+Return: AX = mouse state (-1: installed, 0: not installed)
+ BX = number of buttons (2 button mode, 3 button mode)
+
+BASIC
+Input: G1% = 0
+Return: G1% = mouse state (-1: installed, 0: not installed)
+ G2% = number of buttons (2 button mode, 3 button mode)
+
+Example: Used initially to determine if the GMOUSE driver is present and to
+ reset GMOUSE.
+
+
+
+
+
+ page 5
+\f
+50 ' Find the Actived Mode of Genius Mouse
+60 G1% = 0 : G2% = 0
+70 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+80 IF G2% AND 2 THEN PRINT "Genius Mouse ( 2_Button Mode ) Enable"
+90 IF G2% AND 3 THEN PRINT "Genius Mouse ( 3_Button Mode ) Enable"
+100 IF NOT G1% THEN PRINT "Can't Find Genius Mouse"
+
+Function 1: Enable Cursor Display
+
+Function 1 increments the internal cursor flag counter. If the counter is zero,
+the cursor is enabled and appears on-screen.
+
+The default value is -1 which indicates a concealed cursor. Function 1 must be
+called to display the cursor. In case the internal cursor flag is already zero,
+a call to this function produces no effect.
+
+8086 Register
+Input: AX = 1
+Return: none
+
+BASIC
+Input: G1% = 1
+Return: none
+
+Example:
+
+110 ' Enable Genius Mouse's Cursor
+120 G1% = 1
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 2: Disable Cursor Display
+
+Function 2 disables the cursor by removing it from the screen and decrementing
+the internal cursor flag. Even though the cursor cannot be seen, it still
+tracks any motion made with the mouse.
+
+You should use this function before changing any portion of the screen
+containing the cursor. You will avoid the problem of the cursor affecting
+screen data.
+
+Keep in mind that whenever your program calls function 2, it must later call
+function 1 to return the internal cursor flag to its default value. In
+addition, if your program changes the screen mode, function 2 is called
+automatically. Therefore, the cursor's movement is enabled the next time it is
+displayed.
+
+Call function 2 at the end of a program in order to conceal the cursor. This
+ensures that nothing remains on-screen.
+
+8086 Register
+Input: AX = 2
+Return: none
+
+BASIC
+Input: G1% = 2
+Return: none
+
+Example:
+ page 6
+\f
+110 ' Disable Genius Mouse's Cursor
+120 G1% = 2
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 3: Read Cursor Location & Button State of Genius Mouse
+
+Function 3 gives the status of mouse buttons, plus cursor location.
+
+Button status consists of a single integer value:
+ Bit 0 = left button (2 button mode, 3 button mode)
+ Bit 1 = right button (2 button mode, 3 button mode)
+ Bit 2 = middle button (3 button mode)
+
+The bit is 1 when the button is pressed. The bit is 0 when the button is
+released.
+
+8086 Register
+Input: AX = 3
+Return: BX = button status
+ CX = horizontal cursor coordinate
+ DX = vertical cursor coordinate
+
+BASIC
+Input: G1% = 3
+Return: G2% = button status
+ G3% = horizontal cursor coordinate
+ G4% = vertical cursor coordinate
+
+Example:
+
+110 ' Read Genius Mouse Location & Button State
+120 G1% = 3
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 PRINT "Genius Mouse Location : X_Coord=" G3% " Y_Coord=" G4%
+150 IF G2% AND 1 THEN PRINT "Left Button"
+160 IF G2% AND 2 THEN PRINT "Right Button"
+170 IF G2% AND 4 THEN PRINT "Middle Button"
+180 PRINT "Pressed"
+
+Function 4: Set Cursor Location of Genius Mouse
+
+Function 4 sets the current cursor location. Values must be within the
+coordinate ranges for the virtual screen and, if necessary, are rounded to the
+nearest values allowed for the current screen mode.
+
+ Screen Display Virtual Cell Bits/Pixel
+ Mode Adapter Screen (XxY) Size Graphics Mode
+--------- ------------ --------------- -------- ----------------
+ 0 C, E, 3270 640 x 200 16 x 8 -
+ 1 C, E, 3270 640 x 200 16 x 8 -
+ 2 C, E, 3270 640 x 200 8 x 8 -
+ 3 C, E, 3270 640 x 200 8 x 8 -
+ 4 C, E, 3270 640 x 200 2 x 1 2
+ 5 C, E, 3270 640 x 200 2 x 1 2
+ 6 C, E, 3270 640 x 200 1 x 1 1
+ 7 M, E, 3270 640 x 200 8 x 8 -
+
+
+ page 7
+\f
+ D E 640 x 200 16 x 8 2
+ E E 640 x 200 1 x 1 1
+ F E 640 x 350 1 x 1 1
+ 10 E 640 x 350 1 x 1 1
+ 30 3270 720 x 350 1 x 1 1
+ H 720 x 348 1 x 1 1
+
+Display Adapter:
+ M = IBM Monochrome Display/Printer Adapter
+ C = IBM Color/Graphics Adapter
+ E = IBM Enhanced Graphics Adapter
+3270 = IBM All Points Addressable Graphics Adapter (3270 PC)
+ H = Hercules Monochrome Graphics Card
+
+8086 Register
+Input: AX = 4
+ CX = new horizontal cursor coordinate
+ DX = new vertical cursor coordinate
+Return: none
+
+BASIC
+Input: G1% = 4
+ G3% = new horizontal cursor coordinate
+ G4% = new vertical cursor coordinate
+Return: none
+
+Example:
+
+110 ' Set Cursor Location at the Upper_Left Corner of Screen
+120 G1% = 4
+130 G3% = 0 : G4% = 0
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 5: Read Button Press State of Genius Mouse
+
+Function 5 provides status on the specified button, gives the number of button
+presses since the last call, and produces the location of the cursor at last
+button press.
+
+Button status consists of a single integer value. Again, as in function 3:
+ Bit 0 = left button (2 button mode, 3 button mode)
+ Bit 1 = right button (2 button mode, 3 button mode)
+ Bit 2 = middle button (3 button mode)
+
+The bit is 1 when the button is pressed. The bit is 0 when the button is
+released.
+
+The number of button presses will always fall in the range of 0 to 32767. There
+is no indicator for overflow. Following this function call, the count is reset
+to zero.
+
+8086 Register
+Input: AX = 5
+ BX = button status (left = 0, right = 1, middle = 2)
+Return: AX = button status
+ BX = number of button presses
+ CX = horizontal cursor coordinate at last press
+ DX = vertical cursor coordinate at last press
+ page 8
+\f
+BASIC
+Input: G1% = 5
+ G2% = button status (left = 0, right = 1, middle = 2)
+Return: G1% = button status
+ G2% = number of button presses
+ G3% = horizontal cursor coordinate at last press
+ G4% = vertical cursor coordinate at last press
+
+Example:
+
+110 ' Read the Left Button Press State of Genius Mouse
+120 G1% = 5 : G2% = 2
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 IF G1% AND 2 THEN PRINT "The Middle Button Pressed at X_loc=" G3%
+
+Function 6: Read Button Release State of Genius Mouse
+
+Function 6 provides status on the specified button, gives the number of button
+releases since the last call, and provides the location of the cursor at the
+last button release.
+
+Button status consists of a single integer value. Again, as in function 3:
+ Bit 0 = left button (2 button mode, 3 button mode)
+ Bit 1 = right button (2 button mode, 3 button mode)
+ Bit 2 = middle button (3 button mode)
+
+The bit is 1 when the button is pressed. The bit is 0 when the button is
+released.
+
+The number of button releases will always fall in the range of 0 to 32767.
+There is no indicator for overflow. Following this function call, the count is
+reset to zero.
+
+8086 Register
+Input: AX = 6
+ BX = button status (left = 0, right = 1, middle = 2)
+Return: AX = button status
+ BX = number of button releases
+ CX = horizontal cursor coordinate at last release
+ DX = vertical cursor coordinate at last release
+
+BASIC
+Input: G1% = 6
+ G2% = button status (left = 0, right = 1, middle = 2)
+Return: G1% = button status
+ G2% = number of button releases
+ G3% = horizontal cursor coordinate at last release
+ G4% = vertical cursor coordinate at last release
+
+Example:
+
+110 ' Read the Left Button Release State of Genius Mouse
+120 G1% = 6 : G2% = 2
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 IF NOT G1% OR &HFFFB THEN PRINT "The Middle Button Released at X_loc=" G3%
+
+
+
+ page 9
+\f
+Function 7: Define Horizontal (X) Range of Cursor Location
+
+Function 7 defines the horizontal range of the cursor on-screen. As a result,
+cursor movement is limited to this specified area. If a cursor happens to be
+outside of this area when a call is made, the cursor is moved to just inside the
+area.
+
+8086 Register
+Input: AX = 7
+ CX = minimum horizontal cursor coordinate
+ DX = maximum horizontal cursor coordinate
+Return: none
+
+BASIC
+Input: G1% = 7
+ G3% = minimum horizontal cursor coordinate
+ G4% = maximum horizontal cursor coordinate
+Return: none
+
+Example:
+
+110 ' Enable Cursor in Horizontal Range between 100 to 200
+120 G1% = 7
+130 G2% = 100 : G3% = 200
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 8: Define Vertical (Y) Range of Cursor Location
+
+Function 8 defines the vertical range of the cursor on-screen. As a result,
+cursor movement is limited to this specified area. If a cursor happens to be
+outside of this area when a call is made, the cursor is moved to just inside the
+area.
+
+8086 Register
+Input: AX = 8
+ CX = minimum vertical cursor coordinate
+ DX = maximum vertical cursor coordinate
+Return: none
+
+BASIC
+Input: G1% = 8
+ G3% = minimum vertical cursor coordinate
+ G4% = maximum vertical cursor coordinate
+Return: none
+
+Example:
+
+110 ' Enable Cursor in Vertical Range between 100 to 200
+120 G1% = 8
+130 G2% = 100 : G3% = 200
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 9: Define Graphics Mode Cursor Style
+
+Function 9 defines the style of the cursor in terms of color, shape, and center
+for the graphics. As mentioned before, this cursor is a 16-by-16 pixel block
+and is defined by two 16-bit arrays (the screen mask bit and the cursor mask
+bit). Cursor coordinates for the hot spot must be in the range of -16 to +16.
+ page 10
+\f
+8086 Register
+Input: AX = 9
+ BX = horizontal cursor hot spot
+ CX = vertical cursor hot spot
+ DX = pointer to screen and cursor mask
+Return: none
+
+BASIC
+Input: G1% = 9
+ G2% = horizontal cursor hot spot
+ G3% = vertical cursor hot spot
+ G4% = pointer to screen and cursor mask
+Return: none
+
+Example:
+
+10 ' Define the screen mask
+20 '
+30 cursor (0,0) = &HFFFF '1111111111111111
+40 cursor (1,0) = &HFFFF '1111111111111111
+50 cursor (2,0) = &HFFFF '1111111111111111
+60 cursor (3,0) = &HFFFF '1111111111111111
+70 cursor (4,0) = &HFFFF '1111111111111111
+80 cursor (5,0) = &HF00F '1111000000001111
+90 cursor (6,0) = &H0000 '0000000000000000
+100 cursor (7,0) = &H0000 '0000000000000000
+110 cursor (8,0) = &H0000 '0000000000000000
+120 cursor (9,0) = &H0000 '0000000000000000
+130 cursor (10,0) = &HF00F '1111000000001111
+140 cursor (11,0) = &HFFFF '1111111111111111
+150 cursor (12,0) = &HFFFF '1111111111111111
+160 cursor (13,0) = &HFFFF '1111111111111111
+170 cursor (14,0) = &HFFFF '1111111111111111
+180 cursor (15,0) = &HFFFF '1111111111111111
+190 '
+200 ' Define the cursor mask
+210 '
+220 cursor (0,1) = &H0000 '0000000000000000
+230 cursor (1,1) = &H0000 '0000000000000000
+240 cursor (2,1) = &H0000 '0000000000000000
+250 cursor (3,1) = &H0000 '0000000000000000
+260 cursor (4,1) = &H0000 '0000000000000000
+270 cursor (5,1) = &H0000 '0000000000000000
+280 cursor (6,1) = &H07E0 '0000011111100000
+290 cursor (7,1) = &H7FFE '0111111111111110
+300 cursor (8,1) = &H7FFE '0111111111111110
+310 cursor (9,1) = &H07E0 '0000011111100000
+320 cursor (10,1) = &H0000 '0000000000000000
+330 cursor (11,1) = &H0000 '0000000000000000
+340 cursor (12,1) = &H0000 '0000000000000000
+350 cursor (13,1) = &H0000 '0000000000000000
+360 cursor (14,1) = &H0000 '0000000000000000
+370 cursor (15,1) = &H0000 '0000000000000000
+380 '
+390 ' Set the cursor style and hot spot number of Genius Mouse
+400 '
+
+
+ page 11
+\f
+410 '
+420 G1% = 9
+430 G2% = 6 ' horizontal hot spot
+440 G3% = 5 ' vertical hot spot
+450 CALL GMOUSE ( G1%, G2%, G3%, cursor (0,0))
+
+Function 10: Define Text Mode Cursor Style
+
+Function 10 chooses the hardware or the software text cursor.
+
+For example, if BX (G2%) is 1, the hardware cursor is selected and the hardware
+is set up with the first and last scan lines which define the cursor.
+(Values for CX (G3%) and DX (G4%) range from 0 to 7 for the color display and 0
+to 11 for the monochrome display.)
+
+If BX (G2%) is 0, the software cursor is selected; and CX (G3%) and DX (G4%)
+must specify the screen and cursor masks. (These masks give the attributes and
+character code of the cursor, and their values are dependent on the type of
+display in use.)
+
+8086 Register
+Input: AX = 10
+ BX = select cursor (0: software text, 1: hardware text)
+ CX = screen mask value/scan line start
+ DX = cursor mask value/scan line stop
+Return: none
+
+BASIC
+Input: G1% = 10
+ G2% = select cursor (0: software text, 1: hardware text)
+ G3% = screen mask value/scan line start
+ G4% = cursor mask value/scan line stop
+Return: none
+
+Example:
+
+110 ' Enable an Inverting Cursor
+120 G1% = 10
+130 G2% = 0
+140 G3% = &HFFFF : G4% = &H7700
+150 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 11: Read Genius Mouse Motion Number
+
+Function 11 gives the mouse motion number since the last call. A positive
+horizontal number indicates rightward movement (negative shows leftward
+movement). A positive vertical number indicates downward movement (negative
+shows upward movement).
+The number is always in the range of -32768 to 32767. Overflow is disregarded.
+Once the call is completed, the number is set to 0.
+
+8086 Registers
+Input: AX = 11
+Return: CX = horizontal number
+ DX = vertical number
+
+
+
+ page 12
+\f
+BASIC
+Input: G1% = 11
+Return: G3% = horizontal number
+ G4% = vertical number
+
+Example:
+
+110 ' Read Genius Mouse Motion Number
+120 G1% = 11
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+140 IF G3% > 0 THEN PRINT "Genius Mouse is Moving to Right"
+150 IF G4% > 0 THEN PRINT "Genius Mouse is Moving Down"
+
+Function 12: Define Event Handler Entry Location
+
+Function 12 defines the address entry location of an event handler routine which
+is called when a certain event (defined by the call mask) occurs. The program
+is temporarily interrupted by the mouse driver. At the end of the event handler
+routine the program continues at the point it was interrupted.
+
+The call mask is a single integer value defining the conditions which will cause
+an interrupt.
+
+A specific condition corresponds to a bit in the call mask:
+
+Mask Bit Condition
+--------------------------------------------------
+ 0 cursor location changed
+ 1 left button pressed
+ 2 left button released
+ 3 right button pressed
+ 4 right button released
+ 5 middle button pressed
+ 6 middle button released
+ 7 - 15 not used
+
+In order to call the event handler routine, set the mask bit to 1 and put the
+mask in at CX (G3%). To disable, set the mask bit to 0 and put the mask in at
+CX (G3%). Always be sure to set the call mask to 0 before the program finishes.
+(Leave the system in the same state upon exit as if was upon entrance.)
+
+8086 Register
+Input: AX = 12
+ CX = call mask
+ ES:DX = pointer to event handler routine
+Return: none
+
+BASIC
+Input: G1% = 12
+ G3% = call mask
+ G4% = pointer to event handler routine
+Return: none
+
+Example:
+
+
+
+
+ page 13
+\f
+110 ' Active BUTTDOWN Event Handler Routine, When One or More Buttons Pressed
+120 G1% = 12
+130 G3% = &H002A : G4% = BUTTDOWN%
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 13: Enable Light Pen Emulation Function
+
+Function 13 permits the mouse to act like a light pen. When in this mode, calls
+to the pen function will give the cursor coordinates at the last pen down
+location.
+
+Note that the status of "pen down" and "pen off-screen" is controlled by the
+mouse buttons: all buttons up, pen off-screen; one button pressed, pen down.
+
+Light pen emulation is ON after each call to function 0 (Reset Mouse Driver).
+
+8086 Register
+Input: AX = 13
+Return: none
+
+BASIC
+Input: G1% = 13
+Return: none
+
+Example:
+
+110 ' Enable Light Pen Emulation Function
+120 G1% = 13
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 14: Disable Light Pen Emulation Function
+
+Function 14 turns off the light pen emulation mode. When disabled, any call to
+the pen function will give information only about a real light pen.
+
+8086 Register
+Input: AX = 14
+Return: none
+
+BASIC
+Input: G1% = 14
+Return: none
+
+Example:
+
+110 ' Disable Light Pen Emulation Function
+120 G1% = 14
+130 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 15: Define Sensitivity (Mouse Motion/Pixel) of Genius Mouse
+
+Function 15 defines mouse sensitivity as determined by the mouse motion/pixel
+ratio. This is a way of setting the amount of cursor motion wanted for mouse
+movement. These ratios specify mouse motion per 8 pixels. These values must
+be in the range of 1 to 32767. With a larger ratio, the cursor movement is
+shortened for each mouse movement.
+
+
+ page 14
+\f
+Default values: horizontal ratio - 8 mouse motions to 8 pixels
+ vertical ratio - 16 mouse motions to 8 pixels
+
+Note: 1 mouse motion = 1/200 of an inch increment
+
+8086 Register
+Input: AX = 15
+ CX = horizontal mouse motion counts to pixel ratio
+ DX = vertical mouse motion counts to pixel ratio
+Return: none
+
+BASIC
+Input: G1% = 15
+ G3% = horizontal mouse motion counts to pixel ratio
+ G4% = vertical mouse motion counts to pixel ratio
+Return: none
+
+Example:
+
+110 ' Define Horizontal Sensitivity as 8
+120 ' Define Vertical Sensitivity as 16
+130 G1% = 15
+140 G3% = 8
+150 G4% = 16
+160 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 16: Disable Cursor Display in Special Range
+
+Function 16 sets up a special range on-screen. If the cursor moves to this area
+or is in this area, it will be disabled. After a call is made to this function,
+it is necessary to call function 1 to enable the cursor again.
+
+Define the special range with screen location values using four components:
+
+Components Values
+--------------------------------------------------------
+ 1 Left horizontal screen location
+ 2 Upper vertical screen location
+ 3 Right horizontal screen location
+ 4 Lower vertical screen location
+
+8086 Register
+Input: AX = 16
+ ES:DX = pointer to special range
+Return: none
+
+BASIC
+Input: G1% = 16
+ G4% = pointer to special range
+Return: none
+
+Example:
+
+110 ' Disable Cursor Display in (0,0) to (100,100) Range
+120 G1% = 16
+130 RANGE%(1) = 0 : RANGE%(2) = 0
+140 RANGE%(3) = 100 : RANGE%(4) = 100
+150 CALL GMOUSE ( G1%, G2%, G3%, RANGE%(0) )
+ page 15
+\f
+ .
+ .
+ .
+
+500 ' Enable Cursor Display Again
+510 G1% = 1
+520 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+Function 19: Define Double-Speed Threshold
+
+Function 19 defines the threshold value (mouse motion per second) for doubling
+the cursor's motion. Should the mouse move faster than the DX (G4%) value, the
+cursor motion doubles. The default value is 64 mouse motions per second.
+
+If you should want to disable double-speed, just set the threshold to 32767
+(7FFFH) mouse motions/second.
+
+8086 Register
+Input: AX = 19
+ DX = threshold speed in mouse motions/second
+Return: none
+
+BASIC
+Input: G1% = 19
+ G4% = threshold speed in mouse motions/second
+Return: none
+
+Example:
+
+110 ' Define Double-Speed Threshold as 20 Mouse Motions/Second
+120 G1% = 19
+130 G4% = 20
+140 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+ .
+ .
+ .
+
+500 ' Disable Double-Speed Threshold Function
+510 G1% = 19
+520 G4% = 256 'MAX. VALUE
+530 CALL GMOUSE ( G1%, G2%, G3%, G4% )
+
+*** 7 : USING GENIUS MOUSE WITH IBM ENHANCED GRAPHICS ADAPTER
+
+Within the Genius Mouse driver, you'll find nine EGA functions. These functions
+permit your program to write to and read from write-only registers.
+
+The cursor in use is defined as a monochrome cursor with one bit per pixel. The
+bit masks are determined by function 9 and apply to all active planes.
+
+In order to make an EGA function call from an Assembly-Language program, first
+load the AX, BX, CX, DX, and ES registers with the values indicated for the
+parameters. Note that five values must be given for a high level language
+program. Next, execute software interrupt 16 (10h). The values that are
+returned are intalled in the registers by EGA functions.
+
+
+ page 16
+\f
+Upon start with DOS, PC BIOS will verify if the EGA BIOS exists. When this is
+verified, the PC will execute the EGA BIOS, booting up the program to write the
+INT 10h entry vector to the address of the INT 42h vector. Now, EGA BIOS
+address will be written to INT 10h. Following this, you are able to call EGA
+BIOS (by using INT 10h) and PC video BIOS (by using INT 42h).
+
+There are twenty functions in EGA BIOS. (PC BIOS has only 16.) The EGA BIOS
+routines only intercept the BIOS ROM video routines (INT 10h, AH = 13h or less).
+
+The following indicates nine EGA functions and the corresponding function
+number:
+
+Function Number (HEX)
+-----------------------------------------------------------------
+Retrieve Single Data F0
+Save Single Data F1
+Retrieve Registers on a Specified Port F2
+Save Registers on a Specified Port F3
+Retrieve Several Registers Data F4
+Save Several Registers Data F5
+Reset All Registers as Initial Values F6
+Set Initial Values F7
+Get Version Number of Genius Mouse Driver FA
+
+In the above functions, the EGA I/O port number and address are as follows:
+
+Port No. Register Name No. of Registers Index No. Address Select Register
+------------------------------------------------------------------------------
+ 00H CRT Controller 25 0 - 24 3x4H
+ 08H Sequencer 5 0 - 4 3C4H
+ 10H Graphics Controller 9 0 - 8 3CEH
+ 18H Attribute Controlle 20 0 - 19 3C0H
+ Singular Registers
+ 20H Miscellaneous Output 1 ignored 3C2H
+ 28H Feature Control 1 ignored 3xAH
+ 30H Graphics 1 Position 1 ignored 3CCH
+ 38H Graphics 2 Position 1 ignored 3CAH
+
+ Note: x = B or D depending on the base I/O address;
+ determined by Miscellaneous Output Register bit 1.
+
+Function F0: Retrieve Single Data
+
+This function retrieves data from a single register.
+
+Input: AH = F0H
+ BX = Index number
+ DX = Port number
+Return: BL = Retrieved data from EGA register
+
+Example:
+
+FUN_F0 EQU 0f0H ; Function F0
+;
+GR_CONTR EQU 010H ; Graphics Controller
+MODE_REG EQU 005H ; Mode Regisiter
+;
+
+ page 17
+\f
+GR1_PORT EQU 030H ; Graphics 1 Position Register
+GR2_PORT EQU 038H ; Graphics 2 Position Register
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Retrieve the Mode Register in Graphics Controller
+MODE_REG DB 00
+ ;
+ MOV DX, GR_CONTR
+ MOV BX, MODE_REG
+ MOV AH, FUN_F0
+ INT VIDEO
+ MOV MODE_REG, BL
+
+
+ ; Retrieve Graphics 1 Position Data
+GR1_POS DB 00
+ ;
+ MOV DX, GR1_POS
+ MOV AH, FUN_F0
+ INT VIDEO
+ MOV GR1_POS, NL
+
+
+Function F1: Save Single Data
+
+This function saves data to an EGA register. Upon finishing a call to this
+function, the BH and DX values are altered.
+
+Input: AH = F1H
+ BL = Index number (Non-single register only)
+ = Data (Single register only)
+ BH = Data (Non-single register only)
+ = Disregard (Single register only)
+ DX = Port number
+Return: None
+
+Example:
+
+FUN_F1 EQU 0f1H ; Function F1
+;
+SEQUENCE EQU 008H ; Sequencer
+MASK_REG EQU 002H ; Map Mask Register
+;
+FEAT_PORT EQU 028H ; Feature Control Register
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+ ; Save Map Mask Register of Sequencer
+MAP_MASK EQU 03H
+ ;
+ MOV DX, SEQUENCE
+ MOV BL, MASK_REG
+ MOV BH, MAP_MASK
+ MOV AH, FUN_F1
+ INT VIDEO
+ MOV MAP_MASK, BL
+ page 18
+\f
+
+ ; Save Feature Control Register
+FEATURE DB 02H
+ ;
+ MOV DX, FEAT_PORT
+ MOV BL, FEATURE
+ MOV AH, FUN_F1
+ INT VIDEO
+ MOV FEATURE, BL
+
+Function F2: Retrieve Registers on a Specified Port
+
+This function retrieves data from registers on a specifiã port. Upon finishing
+a call to this function, the CX value is altered.
+
+Input: AH = F3H
+ CH = Starting index number
+ CL = Number of registers
+ DX = Port number
+ ES:BX = Destination of returned data
+Return: Returned data to destination address
+
+Example:
+
+FUN_F2 EQU 0f2H ; Function F2
+;
+GR_CONTR EQU 010H ; Graphics Controller
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Retrieve Four Registers Data from Graphics Controller
+GRAPH_POOL DB 04 DUP (0)
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV DX, GR_CONTR
+ MOV BX, OFFSET GRAPH_POOL
+ MOV CX, 04H
+ MOV AH, FUN_F2
+ INT VIDEO
+
+Function F3: Save Registers on a Specified Port
+
+This function saves data from registers on a specifiã port. Upon finishing a
+call to this function, the BX, CX, and DX values are altered.
+
+Input: AH = F3H
+ CH = Starting index number
+ CL = Number of register
+ DX = Port number
+ ES:BX = Address source of incoming data
+Return: None
+
+Example:
+
+ page 19
+\f
+FUN_F3 EQU 0f3H ; Function F3
+;
+ATTR_CONTR EQU 018H ; Attribute Controller
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Save Four Registers Data into Attribute Controller
+PALET_DATA DB 1, 2, 4, 3
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV DX, ATTR_CONTR
+ MOV BX, OFFSET PALET_DATA
+ MOV CX, 08
+ MOV AH, FUN_F3
+ INT VIDEO
+
+Function F4: Retrieve Several Registers Data At The Same Time
+
+This function retrieves data from several registers at the same time. Upon
+finishing a call to this function, the CX value is altered.
+
+Input: AH = F4H
+ CX = Number of registers (more than 1)
+ ES:BX = Address of register packet (each consists of 4 bytes;
+ port address, byte 1-2; index number, byte 3;
+ returned data, byte 4)
+Return: Returned data is saved into byte 4
+
+Example:
+
+FUN_F4 EQU 0f4H ; Function F4
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+ ; Retrieve Follow Registers Data
+TABLE DW 030H ; Graphics 1 Position Register
+ DB 00 ; Single Register
+ DB 00 ; Retrieved Data
+ ;
+ DW 010H ; Graphics Controller
+ DB 05 ; Mode Register
+ DB 00 ; Retrieved Data
+ ;
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV BX, OFFSET TABLE
+ MOV CX, 02
+ MOV AH, FUN_F4
+ INT VIDEO
+
+
+Function F5: Save Several Registers Data At The Same Time
+
+ page 20
+\f
+This function saves data from several registers at the same time. Upon
+finishing a call to this function, the CX value is altered.
+
+Input: AH = F5H
+ CX = Number of registers (more than 1)
+ ES:BX = Address of register packet (each consists of 4 bytes;
+ port number, byte 1-2; index number, byte 3;
+ output data, byte 4)
+Return: None
+
+Example:
+
+FUN_F5 EQU 0f5H ; Function F5
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+ ; Save Follow Registers Data
+TABLE DW 20H ; Miscellaneous
+ DB 00 ; Single Register
+ DB 01 ; Data
+ ;
+ DW 18H ; Attribute Controller
+ DB 12H ; Color Plane Enable
+ DB 07H ; Data
+ ;
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV BX, OFFSET TABLE
+ MOV CX, 02
+ MOV AH, FUN_F5
+ INT VIDEO
+
+Function F6: Reset All Registers as Initial Values
+
+This function resets all values to default values for the specific registers.
+Function 7 sets the default values.
+
+Input: AH = F6H
+Return: None
+
+Example:
+
+FUN_F6 EQU 0f6H ; Function F6h
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+ MOV AH, FUN_F6
+ INT VIDEO
+
+Function F7: Set Initial Values
+
+This function sets the initial default values. Upon finishing a call to this
+function, the BX and DX values are altered.
+
+ page 21
+\f
+Input: AH = F7H
+ DX = Port number
+ ES:BX = Table of output data
+Return: None
+
+Example:
+
+FUN_F7 EQU 0f7H ; Function F7
+;
+ATTR_CONTR EQU 018H ; Attribute Controller
+;
+VIDEO EQU 010H ; BIOS ROM Video Routine Entry
+
+
+
+ ; Setting Initial Values for the Attribute Controller
+ATTR_DATA DB 1, 2, 4, 3, 5, 6, 0, 7
+ DB 0, 0, 0, 0, 0, 0, 0, 0
+ DB 0, 0, 0fh, 0
+ ;
+ MOV DX, DS
+ MOV ES, DX
+ ;
+ MOV DX, ATTR_CONTR
+ MOV BX, OFFSET ATTR_DATA
+ MOV AH, FUN_F7
+ INT VIDEO
+
+Function FA: Get Version Number of Genius Mouse Driver
+
+This function will give the Genius Mouse driver version number.
+
+Input: AH = FAH
+ BX = 00H
+Return: ES:BX = Pointer to Genius Mouse driver version number.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ page 22
+
+
--- /dev/null
+(* --------------------------------------------------------- *)
+(* HERCULES GRAPHICS FOR MICROSOFT PASCAL *)
+(* *)
+(* External subprograms header *)
+(*$list-,$symtab- *)
+type ads_of_byte = ads of byte;
+
+procedure GRON(consts imode: integer); external;
+procedure GROFF; external;
+procedure CLS; external;
+procedure POINT(consts ix,iy: integer); external;
+procedure MOVE(consts ix,iy: integer); external;
+procedure DRAW(consts ix,iy: integer); external;
+procedure HFILL(consts maxx: integer); external;
+procedure VFILL(consts maxy: integer); external;
+procedure COLOR(consts c: integer); external;
+procedure STYLE(consts s: integer); external;
+procedure PATERN(consts p1, p2, p3, p4: integer); external;
+procedure INTENS(consts i: integer); external;
+procedure PALLET(consts p: integer); external;
+procedure BORDER(consts b: integer); external;
+procedure VIDEO(ads_of_buffer: ads_of_byte); external;
+procedure HPAGE(consts page, mode, clear: integer); external;
+function NOCARD(consts idummy: integer): integer; external;
+procedure PUSHXY; external;
+procedure POPXY; external;
+function INXPOS(consts idummy: integer): integer; external;
+function INYPOS(consts idummy: integer): integer; external;
+function INPIX(consts x,y: integer): integer; external;
+procedure GETMAP(consts x,y: integer; ads_of_array: ads_of_byte); external;
+procedure PUTMAP(ads_of_array: ads_of_byte); external;
+procedure ORMAP(ads_of_array: ads_of_byte); external;
+procedure XORMAP(ads_of_array: ads_of_byte); external;
+procedure TRACK(consts x,y: integer); external;
+function INKEY(consts idummy: integer): integer; external;
+procedure HASCII(consts ic: integer); external;
+procedure HFONT(consts seg, offs: integer); external;
+procedure HFONT8(vars seg, offs: integer); external;
+procedure OUTHLI(consts n:integer; ads_of_buffer: ads_of_byte); external;
+procedure INHLIN(vars n:integer;ads_of_buffer: ads_of_byte); external;
+procedure MKWNDW(consts x,y,icols,ilines: integer; ads_of_window: ads_of_byte;
+ consts iwndwsize,iborder: integer); external;
+procedure BURY(ads_of_window: ads_of_byte); external;
+procedure EXPOSE(ads_of_window: ads_of_byte; consts x,y: integer); external;
+procedure OUTWLI(ads_of_window: ads_of_byte; consts n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure INWLIN(ads_of_window: ads_of_byte; vars n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure SWINDO(rw, iw: ads_of_byte; consts scale: integer); external;
+procedure RWINDO(rw: ads_of_byte; consts scale: integer); external;
+procedure RMOVE(consts rx,ry: real); external;
+procedure RDRAW(consts rx,ry: real); external;
+procedure CIRB(consts ix,iy,ir: integer; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+procedure RCIRB(consts ix,iy,ir: real; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+(*$list+ *)
+(* --------------------------------------------------------- *)
+
+\1a
\ No newline at end of file
--- /dev/null
+(* --------------------------------------------------------- *)
+(* IIUWGRAF GRAPHICS FOR MICROSOFT PASCAL *)
+(* *)
+(* External subprograms header *)
+(*$list-,$symtab- *)
+type ads_of_byte = ads of byte;
+
+procedure GRON(consts imode: integer); external;
+procedure GROFF; external;
+procedure CLS; external;
+procedure POINT(consts ix,iy: integer); external;
+procedure MOVE(consts ix,iy: integer); external;
+procedure DRAW(consts ix,iy: integer); external;
+procedure HFILL(consts maxx: integer); external;
+procedure VFILL(consts maxy: integer); external;
+procedure COLOR(consts c: integer); external;
+procedure STYLE(consts s: integer); external;
+procedure PATERN(consts p1, p2, p3, p4 : integer); external;
+procedure INTENS(consts i: integer); external;
+procedure PALLET(consts p: integer); external;
+procedure BORDER(consts b: integer); external;
+procedure VIDEO(ads_of_buffer: ads_of_byte); external;
+procedure HPAGE(consts page, mode, clear: integer); external;
+function SCREEN(consts idummy: integer): integer; external;
+procedure PUSHXY; external;
+procedure POPXY; external;
+function INXPOS(consts idummy: integer): integer; external;
+function INYPOS(consts idummy: integer): integer; external;
+function INPIX(consts x,y: integer): integer; external;
+procedure GETMAP(consts x,y: integer; ads_of_array: ads_of_byte); external;
+procedure PUTMAP(ads_of_array: ads_of_byte); external;
+procedure ORMAP(ads_of_array: ads_of_byte); external;
+procedure XORMAP(ads_of_array: ads_of_byte); external;
+procedure TRACK(consts x,y: integer); external;
+function INKEY(consts idummy: integer): integer; external;
+procedure HASCII(consts ic: integer); external;
+procedure HFONT(consts seg, offs: integer); external;
+procedure HFONT8(vars seg, offs: integer); external;
+procedure OUTHLI(consts n:integer; ads_of_buffer: ads_of_byte); external;
+procedure INHLIN(vars n:integer;ads_of_buffer: ads_of_byte); external;
+procedure MKWNDW(consts x,y,icols,ilines: integer; ads_of_window: ads_of_byte;
+ consts iwndwsize,iborder: integer); external;
+procedure BURY(ads_of_window: ads_of_byte); external;
+procedure EXPOSE(ads_of_window: ads_of_byte; consts x,y: integer); external;
+procedure OUTWLI(ads_of_window: ads_of_byte; consts n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure INWLIN(ads_of_window: ads_of_byte; vars n: integer;
+ ads_of_buffer: ads_of_byte); external;
+procedure SWINDO(rw, iw: ads_of_byte; consts scale: integer); external;
+procedure RWINDO(rw: ads_of_byte; consts scale: integer); external;
+procedure RMOVE(consts rx,ry: real); external;
+procedure RDRAW(consts rx,ry: real); external;
+function RINXPO(consts dummy: real): real; external;
+function RINYPO(consts dummy: real): real; external;
+procedure CIRB(consts ix,iy,ir: integer; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+procedure RCIRB(consts ix,iy,ir: real; consts alfa, beta: real;
+ consts cbord, bcint: integer;
+ consts p, q: integer); external;
+procedure PRTSCR; external;
+(*$list+ *)
+(* --------------------------------------------------------- *)
--- /dev/null
+you can find here certain information about graphics operation in
+
+LOGLAN version DOS
+________________________________________________________________________
+
+
+IIUWGRAF - basic graphics support for MICROSOFT compilers:
+
+ FORTRAN 77 vsn 3.31
+ PASCAL vsn 3.31
+ and
+ Lattice C vsn 2.14
+
+ for IBM color graphics card & Hercules II monochrome card
+
+
+
+Osrodek Obliczeniowy,
+Instytut Informatyki Uniwersytetu Warszawskiego,
+00-901 Warszawa, PKiN VIII p.
+tel. (0048)22-200211-4028
+
+
+
+
+
+general info
+------------
+
+ Drawing is done by issuing calls to subroutines which
+ modify the contents of a bitmap video buffer. Its contents
+ usually is directly displayed on the screen, so the
+ changes are seen immediately.
+ The video buffer assignment, however, can be changed to
+ point to a user-supplied block of memory. In this case,
+ the changes in bitmap setting are not displayed and even
+ putting the real screen into graphics mode is not necessary.
+ The drawing may be constructed silently, saved away
+ and restored later on an active display or output to
+ a binary file.
+ The Hercules card offers additional possibilities of fast
+ switching between two directly displayable pages.
+
+
+ The interface routines are on two different levels:
+
+ level 1 - screen management on pixel basis
+ uses actual screen indices
+
+ level 2 - positioning & drawing
+ in abstract world coordinates
+
+ Description of calling sequences for Fortran and C
+ are given together with explanations below. Pascal
+ declarations may be found in the "graph.h" include
+ file in the distribution set.
+
+
+
+LEVEL 1 ROUTINES
+________________
+
+All parameters not specified explicitly as arrays or reals
+are integers.
+All integer parameters are assumed to be "integer*2" (16 bits)
+in Fortran, "integer" in Pascal and "int" in C.
+
+screen address range:
+
+ 0 <= ix <= 719 for Hercules card
+ 0 <= iy <= 347
+
+ 0 <= ix <= 319 for IBM color card
+ 0 <= iy <= 199
+
+ 0 <= ix <= 639 for IBM color card in mono mode
+ 0 <= iy <= 199
+
+ (0,0) is top left pixel
+
+ (0,0)-----------> (ix,0)
+ |
+ |
+ |
+ V
+ (0,iy)
+
+
+Three separate libraries are supplied, each for a different
+kind of graphics screen:
+
+ HGCMSF for Hercules
+ MGCMSF for IBM card in full color mode
+ MGC64MSF for IBM card in mono mode
+
+These libraries follow Microsoft Fortran and Pascal calling
+conventions.
+Optionally, each of these libraries can be supplied in four
+variants, following four Lattice C models (S, D, P, L).
+
+initialization/termination routines
+-----------------------------------
+
+---------------------------------------------->> SCREEN
+
+Fortran: | C:
+ |
+i=screen(dummy) | int screen();
+ |
+
+ returns code identifying which library is being used
+
+ 1 for Hercules
+ 2 for IBM in full color 320*200
+ 3 for IBM in monochrome 640*200
+ 4 for IBM in monochrome 320*200
+
+
+---------------------------------------------->> GRAPH
+
+call graph(i) | graph(i);
+
+ switches display to graphics mode
+ clears entire screen
+ involves a delay of approx. 3 secs [ for Hercules only ]
+ for IBM color display, "i" sets either regular color mode,
+ or black&white mode, more suitable for use on monochrome
+ displays
+ i should be 1 for color mode 320*200
+
+
+---------------------------------------------->> TEXT
+
+call text | text();
+
+ switches display to character mode
+ does not change current video buffer assignment
+ fills screen with blanks
+ delays for 3 secs [ for Hercules only ]
+
+
+---------------------------------------------->> CLS
+
+call cls | cls();
+
+ clears current video buffer in graphics mode,
+ without turning display off
+
+
+---------------------------------------------->> HPAGE
+
+call hpage(nr, mode, cflag) | hpage(nr,mode,cflag);
+
+
+[Hercules II only]
+
+ controls access to both pages of Hercules-II;
+
+ "nr" - page number ( 0 or 1)
+ "mode" - 0 for text display,
+ 1 for graphics display,
+ -1 for buffering only (display not affected)
+ "cflag" - 0 for preserving previous contents
+ - 1 for clearing buffer contents
+
+ switching pages via "hpage" is done without delay if the mode
+ remains unchanged;
+ otherwise, "call graph" is equivalent to "call hpage(0,1,1)"
+ "call text" is equivalent to "call hpage(0,0,1)"
+
+ the typical animation loop may be done as follows:
+
+ call hpage(0,1,1)
+ c draw initial picture
+ ...
+ page=1
+ 1 continue
+ call hpage(1-page,1,0) ; set display
+ call hpage(page,-1,1) ; set buffer
+ c draw modified picture
+ ...
+ page=1-page
+ if (.not.finished) go to 1
+
+
+---------------------------------------------->> VIDEO
+
+call video(array) | video(array);
+ | char *array;
+
+ sets video buffer to "array", which should have
+ 32K bytes for Hercules, 16K bytes for IBM card.
+ "video" preserves the previous contents of "array".
+ Subsequent calls to drawing subroutines
+ will not affect screen display, picture
+ created in this buffer may be transferred
+ to actual display via "getmap"-"putmap",
+ or some other form of saving & restoring.
+
+
+
+mode setting routines
+---------------------
+
+
+---------------------------------------------->> COLOR
+
+call color(i) | color(i);
+
+ sets current color to i
+ for monochrome displays, 0 means black, non-0 - white
+ for color displays, 0 means background
+
+
+---------------------------------------------->> STYLE
+
+call style(i) | style(i);
+
+ sets style of lines and fill shades to a combination
+ of current color and background color (for mono -
+ white and black, respectively) according to 5 predefined
+ patterns:
+
+ 0 ....
+ 1 ****
+ 2 ***.
+ 3 **..
+ 4 *.*.
+ 5 *...
+
+ where '*' means curent color, '.' background color
+
+
+---------------------------------------------->> PATERN
+
+call patern(iv,io) | pattern(iv,io);
+
+ sets style of lines and fill shades to an explicitly specified
+ combination of colors : "iv" for even scan lines, "io" for odd.
+ Color encoding is decimal, allowing 4 pixels.
+ Lines are drawn always according to "iv".
+
+ Examples:
+
+ call patern(1100,0011)
+ is equivalent to
+ call color(1), call style(3)
+
+
+ call patern(1212,2121)
+ produces a shade that cannot be otherwise achieved
+ ( a dotted line consisting of pixels in colors 1 and 2 )
+
+
+---------------------------------------------->> BORDER
+
+call border(i) | border(i);
+
+[ IBM color mode only ]
+
+ sets actual background color to i ( i = 0,1,...,15 )
+
+
+---------------------------------------------->> PALLET
+
+call pallet(ip) | pallet(ip);
+
+[ IBM color mode only ]
+
+ changes current pallette to pallette ip ( 0 or 1 )
+ default pallette is 0
+
+
+---------------------------------------------->> INTENS
+
+call intens(i) | intens(i);
+
+[ IBM color mode only ]
+
+ changes current intensity, 1 means more intensity, 0 less;
+ default intensity is 1
+
+
+positioning routines
+--------------------
+
+
+---------------------------------------------->> MOVE
+
+call move(ix,iy) | move(ix,iy);
+
+ sets current position to (ix,iy)
+ picture remains unchanged
+
+
+---------------------------------------------->> INXPOS
+ INYPOS
+
+ix=inxpos(idummy) | int inxpos();
+
+ returns current x screen coordinate
+
+
+iy=inypos(idummy) | int inypos();
+
+ returns current y screen coordinate
+
+
+---------------------------------------------->> PUSHXY
+ POPXY
+
+call pushxy | pushxy();
+
+ pushes current position, color & mode
+ stack is kept internally, max depth is 16
+
+
+call popxy | popxy();
+
+ restores position, color & mode from internal stack
+
+
+---------------------------------------------->> TRACK
+
+call track(ix,iy) | track(ix,iy);
+
+ displays a small (8*8) arrow-shaped cursor which can be
+ moved around with cursor keys; a single keystroke moves
+ it by 5 pixels, in shift mode step size is 1 pixel;
+ "home" key returns the cursor to the initial (ix,iy);
+ "end" removes cursor from screen, and returns - its
+ position can be read with "in?pos" above.
+
+
+
+pixel operations
+----------------
+
+---------------------------------------------->> POINT
+
+call point(ix,iy) | point(ix,iy);
+
+ moves to pixel (ix,iy) and sets it to current color
+
+
+---------------------------------------------->> INPIX
+
+ic=inpix(ix,iy) | int inpix(ix,iy);
+
+ moves to pixel (ix,iy) and returns its color setting;
+ for Hercules and IBM monochrome mode 640*200 :
+ it will be 1 if pixel is on, 0 if it is off.
+
+
+
+line drawing
+------------
+
+---------------------------------------------->> DRAW
+
+call draw(ix,iy) | draw(ix,iy);
+
+ draws a line from current screen position to (ix,iy);
+ sets current position to (ix,iy);
+ line is drawn in current color, with both terminal pixels
+ always turned white ( non-background) for non-black
+ ( non-background ) line color.
+ Bresenham algorithm is used.
+
+
+---------------------------------------------->> CIRB
+
+call cirb(xi,yi,ri,alfa,beta,cbord,bcint,p,q)
+real alfa,beta
+
+[ not available in Lattice C ]
+
+ draws a circle (or ellipse, depending on aspect value),
+ optionally filling its interior; does not preserve position;
+ (xi,yi) - center coordinates
+ ri - radius in pixels (horizontally)
+ alfa, beta - starting & ending angles; if alfa=beta a full
+ circle is drawn; values should be given in radians;
+ cbord - border color
+ bcint - if .ne.0, interior is filled in current style&color
+ p,q - aspect ratio; if p/q=1, a perfect circle is drawn,
+ if p/q<1, the horizontal axis is longer, if p/q>1 - the vertical
+ axis is longer;
+
+
+
+bitmap operations
+-----------------
+
+---------------------------------------------->> GETMAP
+
+call getmap(ix,iy,iarray) | getmap(ix,iy,iarray);
+ | char *iarray;
+
+ saves rectangular area between current position as
+ top left corner and (ix,iy) as bottom right corner,
+ including border lines;
+ position remains unchanged.
+ "iarray" should have 4 + ( rows * ( 3 + cols div 8))
+ bytes.
+
+
+---------------------------------------------->> PUTMAP
+
+call putmap(iarray) | putmap(iarray);
+ | char *iarray;
+
+ sets rectangular area of screen pixels to that saved
+ by "getmap" in "iarray";
+ same size is restored, with top left corner in current
+ position;
+ position remains unchanged.
+
+
+---------------------------------------------->> ORMAP
+
+call ormap(iarray) | ormap(iarray);
+ | char *iarray;
+
+ same as putmap, but saved bitmap is or'ed into screen
+ rather than just set.
+
+
+---------------------------------------------->> XORMAP
+
+call xormap(iarray) | xormap(iarray);
+ | char *iarray;
+
+ same as putmap, but saved bitmap is xor'ed into screen
+ rather than just set.
+
+
+
+character i/o
+-------------
+
+---------------------------------------------->> INKEY
+
+ik=inkey(idummy) | int inkey();
+
+ returns next character from keyboard buffer;
+ 0 is returned if buffer is empty;
+ special keys are returned as negative numbers;
+ ALT-NUM method may be used for entering character codes
+ above 127 (this makes entering special keys 128-132
+ impossible);
+ if a character is returned, it is also removed
+ from the buffer, so MS-DOS will not see it (CTRL-C!);
+ typeahead is allowed, echo is suppressed.
+
+
+---------------------------------------------->> HASCII
+
+call hascii(ic) | hascii(ic);
+
+ 'xor's the character in a 8*8 box with top left corner
+ in the current position;
+ moves current position by (8,0);
+ character code 0 sets complete box to black ( background ),
+ with no change in position.
+ BIOS ROM font for IBM color card is used. If the font
+ table is not at F000:FA6E, the character will probably
+ be unrecognizable, and most certainly wrong.
+ For codes >127, table pointed to by interrupt vector 31
+ is used.
+
+
+---------------------------------------------->> HFONT
+
+call hfont(iseg,ioffs) | hfont(iseg,ioffs);
+
+ sets 8*8 horizontal font table address to iseg:ioffs.
+
+
+---------------------------------------------->> HFONT8
+
+call hfont8(iseg,ioffs) | hfont8(iseg,ioffs);
+
+ includes a copy of IBM ROM 8*8 font and returns address
+ suitable for passing to "hfont";
+ use of "hfont8" makes program larger but quarantees
+ BIOS ROM independence.
+
+
+
+line -oriented i/o
+-------------------
+
+---------------------------------------------->> OUTHLINE
+
+call outhline(n,l) | outhline(n,l);
+ | char *l;
+
+ call "hascii" "n" times with subsequent bytes
+ from "l" array as arguments;
+ before each character is written, "hascii(0)" is
+ called.
+
+
+---------------------------------------------->> INHLINE
+
+call inhline(n,l) | inhline(n,l);
+ | int *n;
+ | char *l;
+
+ reads a line of at most "n" characters from
+ the keyboard, storing them in the "l" array;
+ characters are echoed at current position with "hascii"
+ as they are typed in;
+ a blinking cursor prompts for the next character;
+ BACKSPACE works as expected, RETURN completes the line;
+ typing "n"-th character also completes the line;
+ "l" is blank filled up to "n" bytes;
+ on return "n" is the total number of characters read.
+
+
+
+window - oriented i/o
+---------------------
+
+---------------------------------------------->> MKWNDW
+
+call mkwndw(ix,iy,icols,ilines,iwndw,iwndwsize,iborder)
+
+ | mkwndw(ix,iy,icols,ilines,iwndw,iwndwsize,iborder);
+ | int ix,iy, icols, ilines;
+ | int iwndw[];
+ | int iwndwsize, iborder;
+
+ makes a tty-like scrollable window for "ilines" lines
+ of alphanumeric text of "icols" characters each;
+ top left corner of the window is located at (ix,iy);
+ if "iborder" is non-zero, the window will have a solid
+ border and a margin of 2 black pixels drawn around it;
+ "iwndw" should be an array large enough to "getmap"
+ complete window into it, leaving 20 bytes free,
+ however, if "bury" and "expose" are not to be applied to
+ the window, 20 bytes total size is enough;
+ "iwndwsize" is size of "wndw" array, it is ignored now.
+
+ Window just defines scrolling size for subsequent
+ line-oriented i/o. Anything drawn across it will
+ simply scroll. If you want to have overlapping
+ windows, all you need to implement that is here.
+
+
+---------------------------------------------->> BURY
+
+call bury(iwndw) | bury(iwndw);
+ | int iwndw[];
+
+ makes the window disappear from the screen;
+ the contents is saved away, so it may be "exposed" later;
+ "iwndw" should have appeared before in call to "mkwndw".
+ "bury" may be called only if the array supplied to "mkwndw"
+ is large enough.
+
+
+---------------------------------------------->> EXPOSE
+
+call expose(iwndw,ix,iy) | expose(iwndw,ix,iy);
+ | int iwndw[];
+
+ makes the window reappear at (ix,iy) as its new top
+ left corner;
+ the window should have been "buried" before.
+
+
+---------------------------------------------->> OUTWLINE
+
+call outwline(iwndw,n,l) | outwline(iwndw,n,l);
+ | int iwndw[];
+ | char *l;
+
+ outputs "n" characters from "l" array at bottom line
+ in window "iwndw", scrolling it appropriately;
+ "n" may be larger than window line length - output
+ will take as many window lines as needed;
+
+
+---------------------------------------------->> INWLINE
+
+call inwline(iwndw,n,l) | inwline(iwndw,n,l);
+ | int iwndw[];
+ | int *n;
+ | char *l;
+
+ reads in a line of at most "n" characters from
+ window "iwndw", putting them into "l" array;
+ prompts at bottom of the window with ":";
+ "n" may be larger than window size - it will be done
+ in as many window lines as needed;
+ BACKSPACE can be used to erase characters on bottom
+ window line only;
+ when specifying length, one should remember that the first
+ column is used by the prompt;
+ on return "n" is the total number of read characters.
+
+
+secret operations
+-----------------
+
+---------------------------------------------->> HFILL
+
+call hfill(ix) | hfill(ix);
+
+ fills current row (horizontally) from current position
+ (ix0,iy0) up to (ix,iy0) with bit pattern depending
+ on current color, style and/or pattern and position on
+ the screen in such a way that adjacent "hfill"ed" rows
+ will produce a shade simulating color;
+ does not change current position;
+
+
+---------------------------------------------->> VFILL
+
+call vfill(iy) | vfill(iy);
+
+ fills current column ( vertically ) from current
+ position (ix0,iy0) up to (ix0,iy) in a similiar way
+ that "hfill" does;
+ rectangular area "vfill'ed" is not distinguishable
+ on the screen from same shape "hfill'ed", except that
+ it will take much longer to fill.
+
+
+
+
+LEVEL 2 ROUTINES
+_________________
+
+
+ These accept coordinates a real numbers and translate
+ them to actual pixel positions according to a previously
+ specified "window" definition;
+
+
+abstract world window definition
+________________________________
+
+
+---------------------------------------------->> SWINDOW
+
+call swindow(r,i,scale) | swindow(r,i,scale);
+real r(4) | float r[4];
+integer*2 i(4),scale | int i[4],scale;
+
+ enables positioning & drawing in abstract world
+ coordinates ( cf. "rmove", "rdraw")
+
+ defines rectangular window
+
+ r(1) <= x <= r(2),
+ r(3) <= y <= r(4)
+
+ in center of the rectangular area of the screen
+ with top left corner in position (i(1),i(3))
+ and right bottom corner in position (i(2),i(4));
+ if "scale" equals 0, the real proportions are not
+ preserved: the abstract window is simply mapped to fit
+ the entire area of the screen, otherwise the window
+ is adjusted to reflect the aspect ratio of the screen;
+ abstract coordinates are mapped to the screen in the
+ follwing way:
+
+ (r(1),r(4))
+ ^
+ |
+ |
+ |
+ (r(1),r(3))--------------------->(r(2),r(3))
+
+
+---------------------------------------------->> RWINDOW
+
+call rwindow(r,scale) | rwindow(r,scale);
+real r(4) | float r[4];
+integer*2 scale | integer scale;
+
+ equivalent to "swindow", using the entire screen;
+ a margin of 1 pixel, however, is left on all sides
+ to circumvent rounding problems
+
+
+positioning
+___________
+
+
+---------------------------------------------->> RMOVE
+
+call rmove(rx,ry) | rmove(rx,ry);
+real rx,ry | float rx,ry;
+
+ sets current abstract world position to (rx,ry)
+ (rounded to nearest pixel) within a window
+ that should have been defined in a previous call
+ to "rwindow" or "swindow";
+ picture remains unchanged
+
+
+---------------------------------------------->> RINXPOS
+
+x=rinxpos(dummy)
+real dummy
+
+ returns abstract "x" coordinate in latest window of the
+ current pixel position;
+ will bomb out if there was no previous call to "rwindow"
+ or "swindow";
+ in case of "swindow" returned value may be negative;
+
+---------------------------------------------->> RINYPOS
+
+y=rinypos(dummy)
+real dummy
+
+ returns abstract "y" coordinate in latest window of the
+ current pixel position;
+ will bomb out if there was no previous call to "rwindow"
+ or "swindow";
+ in case of "swindow" returned value may be negative;
+
+
+drawing
+_______
+
+
+---------------------------------------------->> RDRAW
+
+call rdraw(rx,ry) | rdraw(rx,ry);
+real rx,ry | float rx,ry;
+
+ draws a line in current color from current screen
+ position to position (rx,ry) in abstract world
+ coordinates ( using LEVEL 1 "draw" internally );
+ sets current position to (rx,ry) (rounded);
+ the window should have been defined before as for "rdraw".
+
+---------------------------------------------->> RCIRB
+
+call rcirb(xr,yr,rr,alfa,beta,cbord,bcint,p,q)
+real alfa,beta
+
+[not available in Lattice C]
+
+ draws a circle (or ellipse), accepting center coordinates
+ and radius value in abstract coordinates,
+ optionally filling its interior; does not preserve position;
+ (xr,yr) - center coordinates
+ rr - radius (scaled horizontally)
+ alfa, beta - starting & ending angles; if alfa=beta a full
+ circle is drawn; values should be given in radians;
+ cbord - border color
+ bcint - if .ne.0 , interior is filled in current style&color
+ p,q - aspect ratio; if p/q=1, a perfect circle is drawn,
+ if p/q<1, the horizontal axis is longer, if p/q>1 - the vertical
+ axis is longer;
+
+
+
+OTHER USEFUL THINGS
+___________________
+
+ Program "hgcprint.com", when called, sets up the system to
+ make hardcopy of HERCULES graphics image on a GEMINI STAR 10
+ dot matrix printer in the same way as MS-DOS GRAPHICS command
+ does for the color/graphics card.
+ To make the hardcopy, press SHIFT-PrtSc.
+ This will work only in graphics mode.
+
+ Note
+ Actually one cannot make hardcopy of IBM color graphics.
+
+
+A NOTE ON LINKING PASCAL PROGRAMS
+---------------------------------
+
+ When linking Pascal programs which call one of the following:
+
+ mkwndw inhlin outhlin bury window cirb rcirb
+ track inwlin outwlin expose rmove rdraw
+
+ linker will complain about the missing library FORTRAN.LIB.
+ Just ignore this complaint (simply type CR).
+
+
+A NOTE ON LINKING C PROGRAMS
+----------------------------
+
+ When linking C programs using one of the following:
+
+ rwindow swindow rmove rdraw rcirb cirb
+
+ keep in mind that the following global names
+ are used internally:
+
+ wir* (e.g. wirmix, wirmiy, etc.)
+ pqasp* (e.g. pqaspp, pqaspq, etc.)
+
--- /dev/null
+
+
+
+
+
+
+
+
+
+
+
+ IIUWGRAF
+
+ biblioteczka podstawowych procedur graficznych
+
+ moze wspolpracowac z kompilatorami firmy Microsoft:
+
+ Fortran 77 wersja 3.31 i 4.00
+ Pascal wersja 3.31
+
+ oraz
+
+ C (Lattice) wersja 3.10
+ Aztec C wersja 3.20d
+
+
+
+ dla IBM PC/XT
+
+ obsluguje karty IBM color/graphics, Hercules II oraz EGA
+
+
+
+
+
+
+ wersja 2.2, grudzien 1987
+
+
+
+
+
+
+
+Autorzy:
+
+ Piotr Carlson
+ Miroslawa Milkowska - procedury poziomu 1
+
+ Janina Jankowska
+ Michal Jankowski - procedury poziomu 2
+
+
+Osrodek Obliczeniowy Instytutu Informatyki
+Uniwersytet Warszawski\f
+
+
+ 2
+
+
+
+Spis tresci
+
+
+Informacje ogolne 3
+Procedury poziomu 1 4
+Procedury ustawiania trybu 5
+Procedury sterujace kolorami 8
+Procedury ustawiania pozycji 11
+Procedury obslugujace punkty 12
+Procedury rysowania linii 13
+Procedury operujace na fragmentach ekranu 15
+Procedury wejscia/wyjscia dla pojedynczych znakow 16
+Procedury wejscia/wyjscia dla linii 18
+Procedury wejscia/wyjscia dla okienek 19
+Procedury poziomu 2 20
+Informacje dodatkowe 22
+Procedury dodatkowe 22
+
+
+
+Dodatki
+
+A. Uzycie IIUWGRAFu z FORTRANem 77 23
+B. Uzycie IIUWGRAFu z Pascalem 24
+C. Uzycie IIUWGRAFu z Lattice C 25
+D. Uzycie IIUWGRAFu z LOGLANem 26
+E. Wykaz specyfikacji procedur IIUWGRAFu 27
+F. Wartosci kodow klawiszy specjalnych 29
+G. FEDIT - prosty program do edycji kroju znakow 30
+H. Zmiany IIUWGRAFu w stosunku do poprzednich wersji 33
+\f
+
+
+ 3
+
+
+
+Informacje ogolne
+
+
+
+ Rysunek jest tworzony na ekranie monitora za pomoca
+szeregu wywolan procedur bibliotecznych IIUWGRAF. Modyfikuja
+one zawartosc bufora mapy bitowej, ktora jest zwykle
+bezposrednio wyswietlana na ekranie. Zmiany te sa wtedy
+widoczne natychmiast. Umiejscowienie bufora roboczego moze
+byc jednak zmienione, tak aby byl on zwiazany z obszarem
+pamieci dostarczonym przez uzytkownika. W tym przypadku
+zmiany jego zawartosci oczywiscie nie sa wyswietlane, a
+nawet przestawienie monitora w tryb graficzny nie jest
+konieczne. Rysunek moze byc wtedy skonstruowany w pamieci,
+bez wyswietlania, przechowany na dysku w postaci binarnej i
+odtworzony pozniej na ekranie. Omowiony tryb pracy jest
+mozliwy jednak tylko dla karty Hercules II oraz karty IBM.
+ W opisie procedur slowo ekran, tam gdzie mowa o jego
+zawartosci, nalezy rozumiec wlasnie jako bufor roboczy.
+
+ Karty Hercules II oraz EGA daja dodatkowa mozliwosc
+blyskawicznego przelaczania pomiedzy dwiema
+rownouprawnionymi stronami graficznymi.
+
+ W wersji podstawowej karta graficzna EGA posiada
+64K bajty pamieci. Pamiec ta moze byc zwiekszona do 128K
+oraz 256K bajtow. Opisane ponizej procedury graficzne
+dotycza w zasadzie karty EGA z pelna pamiecia 256K bajtow.
+Tylko w tej wersji karty mozna bowiem uzywac 16 kolorow
+( z 64 istniejacych ) oraz dwoch stron graficznych. W obu
+wersjach z mniejsza pamiecia istnieje tylko jedna strona
+graficzna, a ponadto w wersji podstawowej uzytkownik ma
+mozliwosc korzystania tylko z 4 kolorow (z 16 istniejacych).
+
+ Dostarczone sa cztery zestawy oddzielnych bibliotek
+IIUWGRAF, kazda dla innego rodzaju ekranu:
+
+ HGCMSF i HGCMSF4 dla karty Hercules
+ MGCMSF i MGCMSF4 dla karty IBM color/graphics
+ MGC64MSF i MGC64MF4 dla karty IBM w trybie mono
+ EGAMSF i EGAMSF4 dla karty EGA
+
+ Biblioteki HGCMSF, MGCMSF, MGC64MSF i EGAMSF zgodne
+sa z konwencjami Fortranu ( wersja 3.31 ) i Pascala firmy
+Microsoft. Natomiast biblioteki HGCMSF4, MGCMSF4, MGC64MF4 i
+EGAMSF4 sa zgodne z konwencjami Fortranu ( wersja 4.00 )
+firmy Microsoft. Dodatkowo, kazda biblioteka moze byc
+dostarczona w konwencji Lattice C, oddzielnie dla czterech
+modeli kodu S, P, D i L.
+
+ Programy uzytkowe komunikuja sie z IIUWGRAFem na
+dwoch poziomach:
+
+ poziom 1 - zarzadzanie ekranem na poziomie pixli,
+przy uzyciu prawdziwych wspolrzednych na ekranie,
+
+ poziom 2 - rysowanie punktow i linii we
+wspolrzednych abstrakcyjnych.
+\f
+
+
+ 4
+
+
+
+Procedury poziomu 1
+
+ Wszystkie parametry bez podanej explicite
+specyfikacji maja typ integer. Wszystkie parametry calkowite
+powinny miec wartosci 16-bitowe (integer*2 w Fortranie,
+integer w Pascalu, int w C)
+
+
+Zakresy wspolrzednych ekranu:
+
+ 0 <= ix <= 719
+ 0 <= iy <= 347 dla karty Hercules
+
+ 0 <= ix <= 319
+ 0 <= iy <= 199 dla karty IBM color/graphics
+
+ 0 <= ix <= 639
+ 0 <= iy <= 199 dla karty IBM color/graphics
+ w trybie mono
+ 0 <= ix <= 639
+ 0 <= iy <= 349 dla karty EGA
+
+
+
+ (0,0)-----------> (ix,0)
+ |
+ |
+ |
+ V
+ (0,iy)
+\f
+
+
+ 5
+
+
+
+Procedury ustawiania trybu
+
+GRON(i)
+
+ Procedura GRON ustawia monitor w graficznym trybie
+pracy, czyszczac zawartosc jego ekranu, ktory jednoczesnie
+staje sie buforem roboczym. Parametr i ma znaczenie jedynie
+dla karty IBM w trybie 320*200: wartosc 1 wybiera normalne
+kolory, wartosc 0 - kolory zmodyfikowane do pracy na
+monitorach monochromatycznych. Dla kart Hercules, EGA oraz
+karty IBM w trybie 640*200 wartosc parametru i jest
+ignorowana. Przy przelaczaniu karty Hercules z trybu
+tekstowego na graficzny i odwrotnie stosowane jest
+programowo opoznienie ok. 3 sekund. Tryb karty IBM ustawiany
+jest wprost, bez pomocy przerwania 10H, tak aby mozliwa byla
+jednoczesna praca na monitorze kolorowym w trybie graficznym
+z praca na monitorze monochromatycznym w trybie tekstowym.
+Konsekwencja tego rozwiazania jest to, ze nie mozna
+korzystac z komendy GRAPHICS. Natomiast tryb karty EGA jest
+ustawiany wprost, za pomoca przerwania 10H.
+
+
+
+NOCARD(ple)
+
+ Funkcja NOCARD zwraca liczbe calkowita
+identyfikujaca rodzaj monitora obslugiwanego przez biezaco
+uzywana biblioteke:
+
+ 1 dla karty Hercules
+ 2 dla karty IBM w trybie kolor
+ 3 dla karty IBM w trybie mono 640*200
+ 4 dla karty IBM w trybie mono 320*200
+ 5 dla karty EGA
+
+ Funkcja NOCARD moze byc wywolana dopiero po
+zainicjowaniu trybu graficznego za pomoca procedury GRON.
+Parametr ple jest ignorowany.
+
+
+
+GROFF
+
+ Procedura GROFF przelacza monitor w tryb tekstowy,
+wypelniajac zawartosc jego ekranu spacjami. Przed
+zakonczeniem dzialania programu monitor, z ktorego byl
+wywolany, nalezy zawsze ustawic z powrotem w tryb tekstowy.
+
+
+CLS
+
+ Procedura CLS czysci ekran, wypelniajac go kolorem
+0. Czyszczenie odbywa sie bez wylaczania ekranu.\f
+
+
+ 6
+
+
+
+HPAGE(nr, tryb, zeruj)
+
+ Procedura HPAGE ma zastosowanie jedynie dla kart
+Hercules oraz EGA. Pozwala na dostep do drugiej strony
+graficznej monitora. Wywolanie HPAGE wybiera strone o
+numerze nr (0 lub 1), zeruje jej zawartosc, o ile parametr
+zeruj ma wartosc <> 0, oraz ustawia jej tryb:
+
+ tryb = 0 wyswietla zawartosc strony alfanumerycznie
+ tryb = 1 wyswietla zawartosc strony graficznie
+ tryb =-1 przypisuje do tej strony bufor roboczy
+
+
+ Przypisanie bufora roboczego trybem -1 nie zmienia
+numeru ani sposobu wyswietlania biezacej strony. Tryb 0
+wiaze bufor roboczy z wybrana wlasnie strona. Przelaczanie
+stron odbywa sie bez opoznien, o ile nie ulega zmianie tryb
+wyswietlania (alfanumeryka/grafika). Poza tym, wywolanie
+HPAGE(0,1,1) jest ( tylko dla karty Hercules ) rownowazne
+GRON(), a HPAGE(0,0,1) - wywolaniu GROFF.
+
+Typowa petla animacyjna moze byc zatem rozwiazana na
+przyklad tak:
+
+VAR NR: INTEGER;
+BEGIN
+ GRON(0);
+ NR := 1;
+ (* NARYSUJ PIERWOTNY OBRAZ *)
+ DRAW(...
+ ...
+ WHILE JESZCZE DO
+ HPAGE(1-NR,1,0); (* WYSWIETLANIE *)
+ HPAGE(NR,-1,1); (* BUFOROWANIE *)
+ (* NARYSUJ ZMODYFIKOWANY OBRAZ *)
+ DRAW(...
+ ...
+ NR := 1-NR
+ OD
+
+
+VIDEO(tablica)
+
+ Procedura VIDEO przelacza bufor roboczy tak, aby
+miescil sie on w tablicy podanej jako parametr jej
+wywolania.
+Samo wywolanie VIDEO nie zmienia zawartosci bufora. Obraz
+wyswietlany na monitorze nie bedzie ulegal teraz zmianom
+mimo wywolywania procedur modyfikujacych zawartosc ekranu.
+Wszelkie odwolania do ekranu beda teraz dokonywane w
+tablicy. Gotowy obraz moze byc przeniesiony na rzeczywisty
+ekran za pomoca procedur GETMAP/PUTMAP lub zapisany binarnie
+na dysku w celu pozniejszego odtworzenia. Tablica powinna
+miec 16K bajtow przy wspolpracy z karta IBM i 32K bajtow
+przy wspolpracy z karta Hercules.
+Procedury VIDEO nie mozna stosowac dla karty EGA.\f
+
+
+ 7
+
+
+Przyklad:
+
+VAR BOK: ARRAY[1..32K] OF BYTE;
+ FRAGM: ARRAY[1..MAX] OF BYTE;
+BEGIN
+ GRON(1);
+ (* NARYSUJ STRONE TYTULOWA *)
+ DRAW(...
+ ...
+ (* SKONSTRUUJ RYSUNEK "NA BOKU" *)
+ VIDEO(BOK);
+ DRAW(...
+ ...
+ (* ZAPAMIETAJ FRAGMENT GOTOWEGO RYSUNKU *)
+ MOVE(MINX,MINY);
+ GETMAP(MAXX,MAXY,FRAGM);
+ (* PRZYPISZ Z POWROTEM EKRAN DO MONITORA *)
+ GRON(1); (* NIESTETY, CZYSCI EKRAN *)
+ MOVE(MINX,MINY);
+ PUTMAP(FRAGM);
+ ...
+
+Uwaga:
+ W przypadku wywolania VIDEO(tablica(adres)), wartosc
+wyrazenia adres musi byc postaci 1+k*16, gdzie k=0,1,2,...
+\f
+
+
+ 8
+
+
+
+Procedury sterujace kolorami
+
+
+COLOR(kolor)
+
+ Procedura COLOR ustawia biezacy kolor. W tym
+kolorze beda odtad dokonywane zmiany zawartosci ekranu. Na
+monitorach monochromatycznych kolor 0 oznacza czarny (pixel
+wygaszony), kolor <> 0 oznacza bialy (pixel zapalony).
+Na monitorach kolorowych, dla karty IBM color/graphics,
+kolory maja nastepujace numery:
+
+ 0 - tlo (czarny lub ustalony wywolaniem BORDER)
+ 1 - zielony lub turkusowy - cyan ( zaleznie od wyboru
+palety)
+ 2 - czerwony lub purpurowy - magenta
+ 3 - zolty lub bialy
+
+Kolorem ustawionym poczatkowo jest 1.
+
+
+ Dla karty EGA kolor moze przyjmowac wartosci od 0
+do 15. Znaczenie tego parametru jest okreslone poprzez wybor
+palety ( przyporzadkowanie kazdemu z 16 identyfikatorow
+koloru dowolnego koloru z 64 istniejacych ), dokonywany za
+pomoca procedury PALLET.
+Kolorem ustawionym poczatkowo jest 7.
+
+
+STYLE(styl)
+
+ Procedura STYLE ustawia biezacy styl, czyli
+kombinacje kolorow uzywana do rysowania odcinkow (DRAW) i
+wypelniania obszarow (HFILL,VFILL). Styl wybiera jeden z
+szesciu nastepujacych sposobow mieszania tla (.) i biezacego
+koloru (*):
+
+ 0 - ....
+ 1 - ****
+ 2 - ***.
+ 3 - **..
+ 4 - *.*.
+ 5 - *...
+
+ Przy rysowaniu odcinkow kolejne pixle beda mialy
+kolor wyznaczony cyklicznie wzorcem stylu. Pierwszy i
+ostatni pixel odcinka bedzie zawsze mial biezacy kolor.
+Przy wypelnianiu, podany wzorzec dotyczy linii poziomych
+(pionowych) ekranu o parzystej wspolrzednej y (x). Wzorzec
+dla linii o wspolrzednych nieparzystych dobierany jest
+automatycznie.
+Inne sposoby mieszania, dopuszczajace uzycie wiekszej liczby
+kolorow sa dostepne za pomoca procedury PATERN.\f
+
+
+ 9
+
+
+PATERN(par,par1,par2,par3)
+
+ Procedura PATERN pozwala rysowac odcinki i
+wypelniac obszary dowolna kombinacja kolorow. Przy rysowaniu
+odcinkow brany jest pod uwage tylko par. Przy wypelnianiu,
+par oraz par2 dotycza linii poziomych (pionowych) o
+wspolrzednych y (x) parzystych, par1 oraz par3 - linii o
+wspolrzednych nieparzystych ( na zmiane kolejno par/par2
+oraz par1/par3 ). Wartosci par,...,par3 przedstawione jako
+czterocyfrowe liczby szesnastkowe daja wzorce mieszania
+numerow kolorow. 0 oznacza tlo, inne cyfry - zob. opis
+procedury COLOR.
+
+Przyklad:
+
+PATERN(#1100,#0011,#1100,#0011);
+ ODPOWIADA: COLOR(1); STYLE(3);
+
+natomiast efekt:
+
+PATERN(#1212,#0303,#2121,#3030);
+ NIE MOzE BYC UZYSKANY INACZEJ
+
+
+BORDER(kolor)
+
+ Procedura BORDER ustawia biezacy kolor tla.
+
+ kolor kolor
+
+ 0 czarny
+ 1 niebieski
+ 2 zielony
+ 3 turkusowy - cyan (niebiesko-zielony)
+ 4 czerwony
+ 5 karmazynowy - magenta (czerwono-niebieski)
+ 6 zolty
+ 7 jasno szary
+
+Kolory 8 - 15 to jasniejsze odcienie kolorow 0 - 7, przy
+czym kolor bialy ma numer 15.
+
+Przedstawione powyzej kolory dotycza tylko karty IBM, dla
+karty EGA natomiast parametr kolor moze przyjmowac wartosci
+od 0 do 63.
+
+
+PALLET(nr)
+
+ Dla karty IBM color/graphics :
+
+ procedura PALLET wybiera biezaca palete z dwu
+mozliwych
+
+
+ nr kolory
+
+ 0 turkusowy,karmazynowy,bialy
+ 1 zielony,czerwony,zolty
+\f
+
+
+ 10
+
+
+ Domyslna paleta jest paleta nr 0.
+
+ Dla karty EGA natomiast procedura PALLET sluzy do
+wyboru dowolnych 16 kolorow z 64 ogolnie dostepnych.
+Parametr nr powinien byc postaci
+ kolor16 * 256 + kolor64,
+gdzie
+ kolor16 oznacza identyfikator koloru ( uzywany
+przez procedure COLOR ), mogacy przyjmowac wartosci 0 - 15,
+ kolor64 oznacza wybrany kolor.
+
+
+ Standardowa paleta ( przyjmowana domyslnie )
+zawiera nastepujace kolory :
+
+ identyfikator kolor numer koloru
+
+ 0 czarny 0
+ 1 niebieski 1
+ 2 zielony 2
+ 3 turkusowy 3
+ 4 czerwony 4
+ 5 karmazynowy 5
+ 6 zolty 6
+ 7 bialy 7
+ 8 szary 56
+ 9 jasno-niebieski 57
+ 10 jasno-zielony 58
+ 11 jasno-turkusowy 59
+ 12 jasno-czerwony 60
+ 13 jasno-karmazynowy 61
+ 14 jasno-zolty 62
+ 15 intensywny bialy 63
+
+
+ Wszystkie dostepne kolory mozna obejrzec oraz
+poznac ich numery za pomoca programu demonstracyjnego
+EGADEMO.EXE.
+
+ Procedura PALLET nie ma zastosowania dla karty
+Hercules.
+
+
+
+INTENS(i)
+
+ Procedura INTENS wybiera intensywnosc kolorow.
+Dla i rownego 0 intensywnosc jest wieksza, dla i rownego 1
+mniejsza.
+Domyslnie intensywnosc jest ustawiona na poziomie 0.
+
+Procedura INTENS ma zastosowanie tylko dla karty IBM.\f
+
+
+ 11
+
+
+
+Procedury ustawiania pozycji
+
+
+MOVE(x,y)
+
+ Procedura MOVE ustawia biezaca pozycje na ekranie
+na pixel o wspolrzednych (x {kolumna}, y {wiersz}).
+
+
+INXPOS(ple), INYPOS(ple)
+
+ Funkcje calkowite INXPOS i INYPOS zwracaja
+odpowiednio wspolrzedne x i y biezacej pozycji. Parametr ple
+jest ignorowany.
+
+
+PUSHXY
+
+ Procedura PUSHXY powoduje przechowanie biezacej
+pozycji, koloru i stylu na wierzcholku wewnetrznego stosu
+IIUWGRAFu. Parametry te nie ulegaja przy tym zmianie.
+Maksymalna glebokosc stosu wynosi 16.
+
+
+POPXY
+
+ Procedura POPXY odtwarza biezacy styl, kolor i
+pozycje z wierzcholka wewnetrznego stosu IIUWGRAFu.
+Glebokosc stosu zmniejsza sie o 1.
+
+
+
+Przyklad:
+
+
+PROCEDURE SKOS;
+VAR IX,IY:INTEGER;
+BEGIN
+ PUSHXY;
+ IX := INXPOS(0);
+ IY := INYPOS(0);
+ DRAW(IX+10,IY+10);
+ POPXY;
+END;\f
+
+
+ 12
+
+
+
+TRACK(x,y)
+
+ Procedura TRACK wyswietla na ekranie wskaznik w
+ksztalcie malej (8*8 pixli) strzalki, skierowanej na punkt o
+wspolrzednych (x,y). Wskaznik ten moze byc przesuwany po
+ekranie za pomoca klawiszy kierunkowych. Nacisniecie
+klawisza powoduje przesuniecie wskaznika o 5 pixli.
+Nacisniecie odpowiedniego klawisza w trybie numerycznym
+przesuwa wskaznik o 1 pixel. Klawisz "home" powoduje powrot
+wskaznika do pozycji (x,y). Klawisz "End" usuwa wskaznik z
+ekranu i powoduje powrot z procedury, pozostawiajac biezaca
+pozycje w tym miejscu. Moze byc ona teraz odczytana za
+pomoca funkcji INXPOS i INYPOS.
+
+
+
+
+
+
+
+Procedury obslugujace punkty
+
+
+POINT(x,y)
+
+ Procedura POINT ustawia biezaca pozycje w punkcie
+(x,y) i zmienia jego kolor na biezacy.
+
+
+INPIX(x,y)
+
+ Funkcja INPIX ustawia biezaca pozycje w punkcie
+(x,y) i zwraca jego kolor.\f
+
+
+ 13
+
+
+
+Procedury rysowania linii
+
+
+DRAW(x,y)
+
+ Procedura DRAW rysuje odcinek od biezacej pozycji
+do pozycji o wspolrzednych (x,y). Rysowanie polega na
+zmianie koloru pixli nalezacych, wedlug algorytmu
+Bresenhama, do odcinka. Pixle te przyjmuja nowy stan
+zaleznie od biezacego koloru i stylu.
+
+
+
+CIRB(x,y,r,alfa,beta,kolb,wwyp,p,q)
+
+ Procedura CIRB rysuje na ekranie wycinek okregu
+lub elipsy, zaleznie od podanych wartosci p i q,
+okreslajacych aspekt. Aspekt wyznaczony jest stosunkiem p/q.
+Dla wartosci aspektu rownej 1 zostanie narysowany idealny
+okrag. Srodek bedzie umieszczony w punkcie (x,y), promien
+poziomy bedzie mial wielkosc r pixli, alfa i beta okreslaja,
+odpowiednio kat poczatkowy i koncowy rysowanego wycinka. Dla
+alfa = beta zostanie narysowany pelny okrag (lub elipsa).
+Wartosci alfa i beta sa wyrazane w radianach, w zwyklym
+ukladzie. Brzeg wycinka i jego promienie zostana narysowane
+kolorem kolb, niezaleznie od stylu. Jesli wwyp <> 0, wnetrze
+wycinka zostanie wypelnione biezacym kolorem i stylem.
+
+
+HFILL(x)
+
+ Procedura HFILL rysuje, w biezacym kolorze i stylu,
+odcinek poziomy od biezacej pozycji do punktu o
+wspolrzednych
+
+ (x,inypos(0))
+
+OSTROZNIE: HFILL nie zmienia biezacej pozycji.
+
+ Uzycie HFILL jest zalecane przy wypelnianiu
+obszarow, gdyz dziala znacznie szybciej niz odpowiedni DRAW.
+Rowniez mieszajac kolory w danym stylu, HFILL, w
+przeciwienstwie do DRAW nie bierze pod uwage poczatkowego
+punktu odcinka, co pozwala na uzyskanie substytutu
+dodatkowych kolorow.
+
+\f
+
+
+ 14
+
+
+VFILL(y)
+
+
+ Procedura VFILL rysuje, w biezacym kolorze i stylu,
+odcinek pionowy od biezacej pozycji do punktu o
+wspolrzednych
+
+ (inxpos(0),y)
+
+OSTROZNIE: VFILL nie zmienia biezacej pozycji.\f
+
+
+ 15
+
+
+
+Procedury operujace na fragmentach ekranu
+
+
+GETMAP(x,y,tablica)
+
+ Procedura GETMAP zapamietuje prostokatny obszar
+ekranu pomiedzy biezaca pozycja jako lewym gornym rogiem a
+punktem (x,y) jako prawym dolnym rogiem w tablicy. GETMAP
+nie zmienia przy tym biezacej pozycji. Tablica powinna miec
+co najmniej 4 + w*sufit(k/8)*kol bajtow, gdzie w i k sa,
+odpowiednio, liczba wierszy i kolumn zapamietywanego
+obszaru, natomiast wartosc wspolczynnika kol zalezy od
+rodzaju karty graficznej i wynosi 1 dla karty Hercules,
+2 dla karty IBM oraz 4 dla karty EGA.
+
+Przyklad: zapamietanie obszaru 101*101 polozonego w lewym
+gornym rogu ekranu.
+
+VAR OKNO: ARRAY[1..700] OF INTEGER;
+
+ ...
+ MOVE(0,0);
+ GETMAP(100,100,OKNO);
+ ...
+
+
+
+PUTMAP(tablica)
+
+ Procedura PUTMAP ustawia prostokatny obszar ekranu
+o lewym gornym rogu znajdujacym sie w biezacej pozycji
+zgodnie z zawartoscia tablicy, w ktorej uprzednio
+zapamietano fragment ekranu za pomoca procedury GETMAP.
+Biezaca pozycja nie ulega zmianie. Odtworzeniu podlega caly
+zapamietany obszar, ktory jest kopiowany w nowe miejsce.
+
+
+ORMAP(tablica)
+
+ Procedura ORMAP dziala podobnie jak PUTMAP, lecz o
+nowej zawartosci ekranu decyduje wynik zastosowania funkcji
+or do elementow tablicy i ekranu.
+
+
+XORMAP(tablica)
+
+ Procedura XORMAP dziala podobnie jak PUTMAP, lecz o
+nowej zawartosci ekranu decyduje wynik zastosowania funkcji
+xor do elementow tablicy i ekranu.\f
+
+
+ 16
+
+
+
+Procedury wejscia/wyjscia dla pojedynczych znakow
+
+
+INKEY(ple)
+
+ Funkcja calkowita INKEY podaje i usuwa nastepny
+znak z bufora klawiatury. Czytanie odbywa sie bez echa.
+Jesli bufor jest pusty, wynikiem jest 0. Klawisze specjalne
+kodowane sa jako liczby ujemne wedlug zalaczonej tablicy.
+Metoda ALT-NUM moze byc uzyta do wprowadzenia z klawiatury
+kodow powyzej 127 jako zwyklych znakow. Uniemozliwia to,
+niestety, korzystanie ze znakow specjalnych o kodach od 128
+do 132.
+
+Przyklad: zaczekaj na klawisz End.
+
+PROCEDURE WAIT_FOR_END;
+BEGIN
+ WHILE INKEY(0)<>-79 DO;
+END;
+
+Wartosci kodow klawiszy specjalnych podane sa w Dodatku F.
+
+
+HASCII(kod)
+
+ Procedura HASCII rysuje na ekranie znak
+alfanumeryczny. Znak wpisany jest w raster 8*8. Gorny lewy
+rog rastra umieszczony bedzie w biezacej pozycji, ktora
+jednoczesnie przesunie sie o 8 pixli w prawo. Uzyta funkcja
+rysujaca jest xor. Kroj znakow pobierany jest z tablicy
+znajdujacej sie w ROM BIOS standardowo pod adresem
+F000:FA6E. W przypadku niestandardowego ROM BIOSu obraz
+znaku alfanumerycznego bedzie zly. Uzycie procedur HFONT i
+HFONT8 pozwala uniezaleznic sie od wersji BIOSu a takze
+korzystac z innych, rowniez wlasnorecznie zaprojektowanych
+krojow znakow. Kod znaku 0 powoduje tylko wyczyszczenie
+miejsca przeznaczonego na znak, bez zmiany biezacej pozycji.
+Wszystkie kody maja tylko interpretacje graficzna, bez
+funkcji sterujacych (NL, CR etc.).
+
+Przyklad: napisanie slowa "oh" na gwarantowanie czystym tle.
+
+
+HASCII(0); HASCII('o'); HASCII(0); HASCII('h');
+
+Uwaga:
+ Parametr procedury HASCII moze byc typu integer lub
+znakowego ( character w Fortranie, char w Pascalu i C ).
+\f
+
+
+ 17
+
+
+
+HFONT(segment,offset)
+
+ Wywolanie procedury HFONT przelacza adres wzorca
+znakow alfanumerycznych na segment:offset. Bez uzycia HFONT
+uzywa sie adresu F000:FA6E.
+
+
+HFONT8(segment,offset)
+
+ Uzycie procedury HFONT8 dolacza do programu
+uzytkowego kopie tablicy kroju znakow z ROM BIOS i zwraca
+adres tej kopii jako segment:offset (parametry wyjsciowe).
+
+\f
+
+
+ 18
+
+
+
+Procedury wejscia/wyjscia dla linii
+
+
+OUTHLINE(dlugosc,bufor)
+
+ Procedura OUTHLINE wywoluje HASCII dlugosc razy,
+wypisujac na ekran znaki, ktorych kody zawarte sa w buforze.
+Przed narysowaniem kazdego znaku wywolywane jest HASCII(0).
+
+
+INHLINE(dlugosc,bufor)
+
+ Procedura INHLINE wczytuje z klawiatury linie
+zlozona z co najwyzej dlugosci znakow i umieszcza je w
+buforze. Do wczytywania uzyta jest procedura INKEY.
+Wyswietlane jest echo. Migajacy wskaznik oznacza oczekiwanie
+na nacisniecie klawisza. Klawisz BACKSPACE dziala tak, jak
+mozna tego oczekiwac. Linia moze byc zakonczona klawiszem CR
+albo wyczerpaniem jej dlugosci. Znak CR konczacy linie nie
+jest umieszczany w buforze. Przed rozpoczeciem czytania
+bufor jest wypelniany spacjami. Po zakonczeniu czytania
+parametr dlugosc zwraca liczbe wczytanych znakow.
+Migajacy wskaznik jest zawsze rysowany kolorem numer 1,
+wyswietlane znaki natomiast biezacym kolorem.
+
+
+Przyklad: echo wczytanej linii.
+
+VAR LINIA: ARRAY[1:40] OF INTEGER;
+ N: INTEGER;
+BEGIN
+ N:=80;
+ INHLINE(N,LINIA);
+ IF N=0 THEN MOVE(INXPOS(0),INYPOS(0)+10)
+ ELSE OUTHLINE(N,LINIA);
+ ...
+
+\f
+
+
+ 19
+
+
+
+Procedury wejscia/wyjscia dla okienek
+
+
+MKWNDW(x,y,kolumn,wierszy,okienko,rozmiar,ramka)
+
+ Procedura MKWNDW urzadza na ekranie prostokatne
+okienko do konwersacji. Lewy gorny rog okienka znajdzie sie
+w punkcie (x,y). Zmiesci ono zadana liczbe kolumn i wierszy
+tekstu alfanumerycznego. Opis okienka bedzie przechowany w
+dostarczonej przez uzytkownika tablicy okienko. Parametr
+rozmiar jest na razie ignorowany, a tablica powinna miec co
+najmniej 20 bajtow, lub duzo wiecej, jesli okienko ma byc
+zaslaniane i odslaniane ( patrz opis procedury BURY ). Jesli
+parametr ramka ma wartosc rozna od 0, obszar okienka bedzie
+obwiedziony ramka, co uczyni je nieco wiekszym.
+
+
+BURY(okienko)
+
+ Wywolanie BURY usuwa okienko z ekranu, przechowujac
+jego obraz w dalszej czesci tablicy okienko tak, aby moc
+odtworzyc je pozniej za pomoca EXPOSE. Tablica okienko musi
+miec odpowiednia wielkosc, aby GETMAP obszaru okienka
+pozostawilo w niej jeszcze co najmniej 20 bajtow.
+
+
+EXPOSE(okienko,x,y)
+
+ Wywolanie EXPOSE odtwarza okienko przechowane za
+pomoca BURY umieszczajac jego gorny lewy rog w punkcie
+(x,y).
+
+
+OUTWLINE(okienko,dlugosc,bufor)
+
+ Procedura OUTWLINE dziala podobnie jak OUTHLINE,
+wyswietlajac linie w ramach podanego okienka. Bufor o
+dlugosci wiekszej niz rozmiar okienka wyswietli sie w kilku
+liniach.
+
+
+INWLINE(okienko,dlugosc,bufor)
+
+ Procedura INWLINE, podobnie jak INHLINE, wczytuje z
+klawiatury linie tekstu. W przypadku INWLINE okienko
+wskazuje na obszar ekranu, w ktorym ma pojawiac sie echo.
+Jesli dlugosc bufora jest wieksza niz rozmiar okienka echo
+moze zajac w nim kilka linii. Poprawianie wprowadzanego
+tekstu przy uzyciu BACKSPACE jest mozliwe tylko w ostatniej
+czesci linii. Dlugosc jako parametr wyjsciowy zwraca liczbe
+wczytanych znakow, bez konczacego CR.\f
+
+
+ 20
+
+
+
+Procedury poziomu 2
+
+
+ Procedury te operuja wspolrzednymi wyrazonymi
+liczbami rzeczywistymi odnoszacymi sie do abstrakcyjnego
+okna o dowolnych rozmiarach.
+
+
+
+Definiowanie okna
+
+
+SWINDOW(rxy,ixy,skalowanie)
+
+ Procedura SWINDOW urzadza na ekranie prostokatne
+okno umieszczone pomiedzy punktami naroznikowymi podanymi w
+tablicy ixy jako calkowite wspolrzedne prawdziwych pixli.
+Program uzytkowy tworzacy rysunek w tym obszarze bedzie
+okreslal polozenie punktow w sposob abstrakcyjny we
+wspolrzednych rzeczywistych. Tablica rxy podaje zakresy tych
+wspolrzednych. Jesli parametr skalowanie ma wartosc 0,
+abstrakcyjny prostokat bedzie po prostu odwzorowany na
+wskazana czesc ekranu bez zachowania proporcji miedzy
+skalowaniem w pionie i w poziomie. Jesli natomiast parametr
+skalowanie bedzie rozny od zera, wykorzystana zostanie
+jedynie srodkowa czesc obszaru ekranu tak, aby zachowac
+rzeczywiste proporcje rysunku, niezaleznie od aspektu danego
+monitora.
+Odwzorowanie stosowane przez IIUWGRAF odwraca tez kierunek
+wzrastania wspolrzednej y do naturalnego ukladu:
+
+
+ (ixy(1),ixy(3))
+ /
+ (rxy(1),rxy(4))
+ ^
+ |
+ |
+ |
+ | (ixy(1),ixy(4)) (ixy(2),ixy(4))
+ | / /
+ (rxy(1),rxy(3))--------------------->(rxy(2),rxy(3))
+
+
+Przyklad: przygotowanie rysunku sinusoidy w gornej polowie
+ekranu Herculesa.
+
+
+VAR RW:ARRAY [1:4] OF REAL INIT (0.,6.29,-1.,1.);
+ IW:ARRAY [1:4] OF INTEGER INIT (0,719,0,173);
+BEGIN
+ SWINDOW(RW,IW,0);
+\f
+
+
+ 21
+
+
+RWINDOW(rxy,skalowanie)
+
+ Procedura RWINDOW jest skrotem wywolania SWINDOW
+dla odwzorowania obejmujacego caly ekran.
+
+
+
+RINXPOS(ple),RINYPOS(ple)
+
+ Funkcje rzeczywiste RINXPOS i RINYPOS zwracaja,
+odpowiednio wspolrzedne x i y biezacej pozycji w
+abstrakcyjnym oknie urzadzonym przez ostatnie wywolanie
+RWINDOW lub SWINDOW. Biezaca pozycja jest zawsze zaokraglana
+do najblizszego pixla.
+
+
+
+RMOVE(rx,ry)
+
+ Wywolanie procedury RMOVE ustawia biezaca pozycje w
+punkcie (rx,ry) w ostatnio urzadzonym oknie. Pozycja ta jest
+zaokraglona do najblizszego pixla.
+
+
+
+RDRAW(rx,ry)
+
+ Wywolanie procedury RDRAW powoduje narysowanie w
+biezacym kolorze i stylu odcinka od biezacej pozycji do
+pixla najblizszego punktowi (rx,ry) w ostatnio urzadzonym
+oknie.
+
+
+
+RCIRB(rx,ry,rr,alfa,beta,kolb,wwyp,p,q)
+
+ Procedura RCIRB odpowiada procedurze CIRB z poziomu
+1, z tym, ze wspolrzedne srodka (rx,ry) i promien rr
+wyrazane sa, jako liczby rzeczywiste, w oknie urzadzonym
+przez ostatnie wywolanie RWINDOW lub SWINDOW. Pozostale
+parametry maja znaczenie takie, jak w CIRB.\f
+
+
+ 22
+
+
+
+Informacje dodatkowe
+
+
+ Pakiet IIUWGRAF zawiera dodatkowo dwa programy
+HGCPRINT.EXE oraz MGCPRINT.EXE. Umozliwiaja one drukowanie
+tworzonych obrazow graficznych na powszechnie dostepnych
+drukarkach ( np. typu STAR GEMINI, EPSON ). W przypadku
+uzywania karty Hercules nalezy stosowac program HGCPRINT, a
+dla karty IBM color/graphics program MGCPRINT.
+
+ Programow tych powinno uzywac sie w nastepujacy
+sposob :
+ przed zaladowaniem wlasnego programu nalezy wykonac
+program HGCPRINT lub MGCPRINT, w zaleznosci od rodzaju
+uzywanej karty graficznej. Kazdy z tych programow ustawia
+znaczenie klawisza PrtSc. Kazdorazowe pozniejsze nacisniecie
+klawisza PrtSc powoduje wydrukowanie graficznej zawartosci
+ekranu.
+
+Uwaga. W przypadku karty Hercules drukowana jest
+zawartosc pierwszej strony graficznej, niezaleznie od tego,
+ktora strona jest aktualnie wyswietlana.
+ W przypadku karty IBM color/graphics klawisz PrtSc
+zaklada, ze jest ustawiony tryb kolor 320*200. Wydruk obrazu
+graficznego utworzonego w trybie mono 640*200 jest mozliwe
+poprzez uzycie procedury PRTSCR.
+
+ Mozliwosc drukowania obrazu graficznego nie
+istnieje dla karty EGA.
+
+ Autorem programow HGCPRINT oraz MGCPRINT jest
+Krzysztof Studzinski.
+
+
+
+
+Procedury dodatkowe
+
+
+PRTSCR(nr)
+
+ Procedura PRTSCR umozliwia drukowanie obrazow
+graficznych tworzonych na ekranie monitora pod kontrola
+programu. Parametr nr okresla numer strony graficznej
+(0 lub 1), ktorej zawartosc ma byc wydrukowana.
+
+ Wywolanie procedury PRTSCR z parametrem nr rownym
+zeru jest rownowazne nacisnieciu klawisza PrtSc.
+
+ W celu poprawnego dzialania tej procedury nalezy,
+analogicznie jak w przypadku klawisza PrtSc, uprzednio
+wykonac dolaczony program :
+ - HGCPRINT.EXE w przypadku uzywania karty
+Hercules lub
+ - MGCPRINT.EXE dla karty IBM.
+
+ Procedura PRTSCR nie dziala dla karty EGA.
+
+\f
+
+
+ 23
+
+
+
+
+ DODATEK A
+
+ Uzycie IIUWGRAFu z FORTRANem 77.
+
+
+1) Procedury IN?LINE i OUT?LINE dokonuja jedynie
+transmisji tekstu, bez zadnej konwersji pomiedzy postacia
+binarna i tekstowa. Aby takiej konwersji dokonac, mozna
+posluzyc sie instrukcjami formatowanego wejscia/wyjscia
+w polaczeniu z tzw. plikami wewnetrznymi (internal file).
+
+Przyklad:
+
+
+ INTEGER*2 I,J,SUM,W(10)
+ CHARACTER*20 LINE
+ CHARACTER LINEL(20)
+ EQUIVALENCE (LINE,LINEL(1))
+
+ ...
+ CALL MKWNDW(10,10,21,4,W,20,1)
+ CALL OUTWLINE(W,20,'PODAJ 2 LICZBY (2I3)')
+ CALL INWLINE(W,20,LINEL)
+ READ (LINE,'(2I3)') I,J
+ SUM=I+J
+ WRITE (LINE,'(8H SUMA = I4)') SUM
+ CALL OUTWLINE(W,12,LINEL) \f
+
+
+ 24
+
+
+
+
+
+ DODATEK B
+
+ Uzycie IIUWGRAFu z PASCALem.
+
+
+1) Microsoft Pascal dopuszcza jedynie 6 znakow w nazwie
+podprogramu, zatem nazwy: INHLIN(E), INWLIN(E), OUTHLI(NE),
+OUTWLI(NE), RWINDO(W), SWINDO(W), RINXPO(S), RINYPO(S) musza
+byc uzywane w skroconej postaci.
+
+2) Niektore procedury IIUWGRAFu sa napisane w FORTRANie.
+Przy linkowaniu LINK moze domagac sie dostarczenia
+biblioteki FORTRAN.LIB. Zadanie to nalezy zignorowac.
+
+3) Do linkowania nalezy uzywac LINK w wersji co najmniej
+3.04, do kompilacji Pascal w wersji co najmniej 3.31.\f
+
+
+ 25
+
+
+
+
+ DODATEK C
+
+ Uzycie IIUWGRAFu z Lattice C.
+
+
+1) Nalezy unikac konfliktow z nazwami globalnych zmiennych
+roboczych IIUWGRAFu. Zmienne te maja nazwy rozpoczynajace
+sie od liter WIR... i PQASP...
+
+2) W przypadku procedur majacych parametry wyjsciowe ( w
+dodatku E sa one zaznaczone jako vars ) nalezy przy ich
+wywolaniu przekazywac adres odpowiedniego parametru
+aktualnego.
+
+Przyklad:
+
+
+ CHAR LENGTH;
+ CHAR *TEXT;
+ ...
+ INHLINE(&LENGTH,TEXT)
+
+
+
+3) Adresy parametrow aktualnych nalezy przekazywac rowniez
+w przypadku parametrow bedacych tablicami znakowymi.
+
+
+Przyklad:
+
+
+ INT LENGTH;
+ CHAR *TEXT; /* LUB NP. CHAR TEXT[40]; */
+ ...
+ OUTHLINE(LENGTH, &TEXT[3]);
+ /* WYPISZ ZNAKI Z TABLICY 'TEXT', ROZPOCZYNAJAC OD
+CZWARTEGO */
+\f
+
+
+ 26
+
+
+
+
+ DODATEK D
+
+ Uzycie IIUWGRAFu z LOGLANem.
+
+
+1) W biezacej wersji LOGLANu dostepnych jest jedynie 7
+podstawowych procedur: GRON, GROFF, MOVE, DRAW, HASCII,
+HPAGE, INKEY obslugujacych wylacznie karte Hercules.
+
+2) System okienek do konwersacji nie bedzie w LOGLANie
+dostepny w postaci procedur standardowych. Podobnie okienka
+o wspolrzednych rzeczywistych.
+
+3) Niektore podprogramy dostepne jako funkcje standardowe
+LOGLANu musza miec zmienione specyfikacje parametrow w
+stosunku do oryginalnego IIUWGRAFu:
+
+ IIUWGRAF LOGLAN
+
+ GETMAP GETMAP:function:array of ?
+ INKEY INKEY:integer function; (* bez parametrow *)
+ INXPOS INXPOS:integer function;(* bez parametrow *)
+ INYPOS INYPOS:integer function;(* bez parametrow *)
+\f
+
+
+ 27
+
+
+
+
+ DODATEK E
+
+ Wykaz specyfikacji procedur IIUWGRAFu.
+
+
+ proc BORDER(consts b: integer);
+ L proc BURY(window: buffer);
+ proc CIRB(consts ix,iy,ir: integer;
+ consts alfa, beta: real;
+ consts cbord, bcint, p, q: integer);
+ proc CLS;
+ proc COLOR(consts c: integer);
+ proc DRAW(consts ix,iy: integer);
+ L proc EXPOSE(window: buffer; consts x,y: integer);
+ L proc GETMAP(consts x,y: integer; ekran: buffer);
+ L proc GROFF;
+ proc GRON(consts imode: integer);
+ proc HASCII(consts ic: integer);
+ proc HFILL(consts maxx: integer);
+ proc HFONT(consts seg, offs: integer);
+ proc HFONT8(vars seg, offs: integer);
+ proc HPAGE(consts page, mode, clear: integer);
+ P proc INHLINE(vars n:integer; line: tekst);
+ L func INKEY(consts idummy: integer): integer;
+ func INPIX(consts x,y: integer): integer;
+ proc INTENS(consts i: integer);
+ PL proc INWLINE(window: buffer; vars n: integer;
+ line: tekst);
+ L func INXPOS(consts idummy: integer): integer;
+ L func INYPOS(consts idummy: integer): integer;
+ L proc MKWNDW(consts x,y,icols,ilines: integer;
+ window: buffer;
+ consts iwndwsize,iborder: integer);
+ proc MOVE(consts ix,iy: integer);
+ L func NOCARD(consts idummy: integer): integer;
+ proc ORMAP(ekran: buffer);
+ PL proc OUTHLINE(consts n:integer; line: tekst);
+ PL proc OUTWLINE(window: buffer; consts n: integer;
+ line: tekst);
+ proc PALLET(consts p: integer);
+ proc PATERN(consts p1, p2, p3, p4: integer);
+ proc POINT(consts ix,iy: integer);
+ proc POPXY;
+ proc PRTSCR(consts nr: integer);
+ proc PUSHXY;
+ proc PUTMAP(ekran: buffer);
+ L proc RCIRB(consts ix,iy,ir: real;
+ consts alfa, beta: real;
+ consts cbord, bcint, p, q: integer);
+ L proc RDRAW(consts rx,ry: real);
+ PL func RINXPOS(consts dummy: real): real;
+ PL func RINYPOS(consts dummy: real): real;
+ L proc RMOVE(consts rx,ry: real);
+ PL proc RWINDOW(rw: array [1:4] of real;
+ consts s: integer);
+ proc STYLE(consts s: integer);\f
+
+
+ 28
+
+
+ PL proc SWINDOW(rw: array [1:4] of real;
+ iw: array [1:4] of integer;
+ consts s: integer);
+ proc TRACK(consts x,y: integer);
+ proc VFILL(consts maxy: integer);
+ proc VIDEO(ekran: buffer);
+ proc XORMAP(ekran: buffer);
+
+Uzyto notacji semi-pascalowej.
+Specyfikacja consts oznacza parametr przekazywany przez
+wartosc (tylko wejsciowy), vars - przez zmienna (wejsciowo-
+wyjsciowy).
+Typ buffer oznacza tablice bajtowa sluzaca do przechowania
+zawartosci okreslonego obszaru ekranu ( rozmiar jej zalezy
+od wielkosci tego obszaru ), typ tekst natomiast oznacza
+tablice znakowa.
+Litery w pierwszej kolumnie sugeruja dodatkowe wazne
+informacje (roznice) w kontekscie konkretnych jezykow
+(Fortran, Pascal, C, Loglan).\f
+
+
+ 29
+
+
+
+ DODATEK F
+
+ Wartosci kodow klawiszy specjalnych:
+
+
+ 3 - ctrl-2
+ 15 - back tab (shift-tab)
+ 16-25 - ALT-Q az do ALT-P
+ 30-38 - ALT-A az do ALT-L
+ 44-50 - ALT-Z az do ALT-M
+ 59-68 - F1 az do F10
+ 71 - Home
+ 72 - Cursor-Up
+ 73 - PgUp
+ 75 - Cursor-Left
+ 77 - Cursor-Right
+ 79 - End
+ 80 - Cursor-Down
+ 81 - PgDn
+ 82 - Ins
+ 83 - Del
+ 84-93 - Shift-F1 az do Shift-F10
+ 94-103 - Ctrl-F1 az do Ctrl-F10
+ 104-113 - Alt-F1 az do Alt-F10
+ 114 - Ctrl-PrtSc
+ 115 - Ctrl-Cursor-Left
+ 116 - Ctrl-Cursor-Right
+ 117 - Ctrl-End
+ 118 - Ctrl-PgDn
+ 119 - Ctrl-Home
+ 120-131 - Alt-1 az do Alt-=
+ 132 - Ctrl-PgUp\f
+
+
+ 30
+
+
+
+
+ DODATEK G
+
+ FEDIT
+
+ Prosty program do edycji kroju znakow.
+ Dodatek do biblioteki graficznej IIUWGRAF.
+
+FEDIT pozwala komponowac i modyfikowac uklady pixli o
+wymiarze 8*8. Takie uklady moga byc wyswietlane razem z
+grafika za pomoca procedury HASCII.
+
+FEDIT produkuje opisy tablic kroju znakow w dwoch
+postaciach:
+
+ - jako podprogram dostarczajacy adres tablicy kroju
+w postaci odpowiedniej do przekazania procedurze HFONT,
+
+ - jako niezalezny program umieszczajacy wskaznik do
+tablicy kroju w wektorze przerwania 14H.
+
+Pierwszy format moze byc uzyty do zastapienia standardowego
+zestawu znakow zwykle znajdujacego sie w ROM BIOS pod
+adresem F000:FA6E. Jest on uzywany przez procedure HASCII do
+rysowania znakow o kodach od 0 do 127. Stad jego nazwa :
+ "format 0".
+
+Podprogram wygenerowany przez FEDIT ma nazwe HFONT8. Po
+przetlumaczeniu przez MACROASSEMBLER musi byc on linkowany
+razem z programem uzytkowym. Jesli zajdzie potrzeba zmiany
+nazwy (np. w celu dynamicznego przelaczania pomiedzy kilkoma
+krojami znakow), nazwa moze byc zmieniona recznie w tekscie
+zrodlowym.
+
+Drugi format jest uzywany do rysowania znakow z
+rozszerzonego zakresu znakow o kodach od 128 do 255. Stad
+nazwa:
+ "format 128".
+
+Opis zestawu znakow w tym formacie musi byc zaladowany do
+pamieci przed rozpoczeciem wykonania programu, ktory z niego
+korzysta. Wskaznik do tablicy kroju musi byc wpisany w
+wektor przerwania 14H. Robi to program wygenerowany przez
+FEDIT, ktory nastepnie zawiesza sie za pomoca przerwania 27H
+(terminate but stay resident). W tym przypadku tekst
+zrodlowy po przetlumaczeniu przez MACROASSEMBLER musi byc
+zlinkowany (bez zadnych bibliotek) do postaci .EXE.
+IIUWGRAF i FEDIT nie daja mozliwosci dynamicznego
+przelaczania tablic znakow rozszerzonego zakresu.
+\f
+
+
+ 31
+
+
+Przyklad:
+
+VAR ISEG, IOFFS: INTEGER;
+BEGIN
+ HFONT8(ISEG,IOFFS); (* ADRES TABLICY FORMATU 0 *)
+ ...
+ HASCII(45); (* UZYWA ROM BIOS *)
+ HASCII(145); (* UZYWA ROZSZERZONEGO ZESTAWU *)
+ ...
+ HFONT(ISEG,IOFFS);
+ HASCII(45); (* UZYWA TABLICY FORMATU 0 *)
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)
+ ...
+ HFONT(16#F000,16#FA6E);
+ HASCII(45); (* ZNOWU ROM BIOS *)
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)
+
+
+ FEDIT jest prostym programem konwersacyjnym o kilku
+zaledwie rozkazach. Tablica kroju znakow zawiera wzorce
+ukladow pixli rozmiaru 8*8. Wzorzec pojedynczego znaku moze
+byc wyjety z tej tablicy w celu jego edycji i zapamietany z
+powrotem, byc moze w innym miejscu tablicy. Sa dwie tablice
+znakow: jedna dla kodow od 0 do 127, druga dla kodow od 128
+do 255. Pierwsza z nich nie moze byc modyfikowana. Druga z
+nich moze poczatkowo zawierac zaladowany wczesniej
+rozszerzony zestaw lub zostac wyczyszczona. Mozna tez
+wczytac do niej zestaw zawarty w pliku wygenerowanym
+wczesniej przez FEDIT. Po dokonaniu modyfikacji, zawartosc
+tej drugiej tablicy moze byc uzyta do generacji badz
+"formatu 0" badz "128".
+
+
+ Rozkazy FEDITu.
+
+
+Rozkazy FEDITu sa wprowadzane jako pojedyncze litery
+wybierajace czynnosci wymienione w jadlospisie wyswietlonym
+u gory ekranu. Dodatkowe parametry podaje sie po
+przynagleniu przez FEDIT.
+
+Komendy FEDITu:
+
+< low odswieza tablice "0 do 127"
+
+> high odswieza tablice "128 do 255"
+
+i init inicjalizuje zerami tablice "128 do 255"
+
+l load laduje tablice "128 do 255" z pliku
+ dodatkowy parametr:
+ - nazwa pliku (musi istniec)\f
+
+
+ 32
+
+
+
+d dump wypisuje zawartosc tablicy "128 do 255"
+ na plik; dodatkowe parametry:
+ - nazwa pliku (bedzie zapisany)
+ - baza ( 0 albo 128),
+ zaleznie od formatu
+ - jezyk:
+ f - MS Fortran, MS Pascal
+ s - Lattice C, model S
+ p - Lattice C, model P
+ d - Lattice C, model D
+ l - Lattice C, model L
+
+e edit wyjmuje z tablicy pojedynczy znak
+ i umieszcza go w obszarze roboczym.
+ dodatkowy parametr:
+ - kod znaku (dziesietnie)
+ Po obszarze roboczym mozna poruszac sie
+ za pomoca klawiszy kierunkowych. Pixel
+ zapala klawisz Ins, gasi klawisz Del.
+ Klawisz End powoduje wyjscie z tego trybu.
+
+t text wyswietla tekst pomocny przy ocenie
+ jakosci ksztaltu znakow. Tekst, nie dluzszy
+ niz 40 znakow jest wprowadzany przez uzytkow-
+ nika. Dodatkowe parametry:
+ - vspace,
+ - hspace - odpowiednio, pionowy i poziomy
+ odstep w pixlach pomiedzy znakami. Normalnie,
+ vspace wynosi 2, hspace - 0.
+
+p put przechowuje wzorzec z obszaru roboczego pod
+ wskazanym kodem. Dodatkowy parametr:
+ - kod pozycji (dziesietnie),
+ powinien byc miedzy 128 a 255
+
+q quit konczy dzialanie FEDIT
+
+
+Z FEDITem nalezy obchodzic sie ostroznie. Posiada on jedynie
+minimalne wbudowane zabezpieczenia i np. bez ostrzezenia
+zapisze nowa, nie wykonczona jeszcze wersje kroju znakow na
+pliku zawierajacym jedyny egzemplarz poprzedniej, bardzo
+potrzebnej wersji.\f
+
+
+ 33
+
+
+
+ DODATEK H
+
+ Zmiany IIUWGRAFu w stosunku do poprzednich wersji
+
+
+
+ Zmiany IIUWGRAFu w stosunku do wersji 1.1
+
+
+1) Rozszerzenie zestawu obslugiwanych kart graficznych o
+karte EGA ( IBM Enhanced Graphics Adapter ).
+
+2) Niewielkie modyfikacje procedur IIUWGRAFu :
+
+ - dodanie procedury PRTSCR,
+ - modyfikacja procedury PATERN polegajaca na :
+ zwiekszeniu liczby parametrow ( wzorcow ) z
+dwoch do czterech oraz
+ zmianie postaci tych parametrow ( zamiast
+liczb dziesietnych liczby szesnastkowe ),
+( rozszerzenie wzorcow oczywiscie oznacza rownoczesnie
+modyfikacje procedur HFILL oraz VFILL ),
+ - zmiany nazw procedur GRAPH, TEXT, SCREEN
+odpowiednio na GRON, GROFF, NOCARD.
+
+
+
+
+ Zmiany IIUWGRAFu w stosunku do wersji 2.1
+
+
+1) Udostepnienie procedur CIRB oraz RCIRB dla C.
+\f
--- /dev/null
+ TITLE NULLGRAF
+ PUBLIC GRON, GROFF, CLS, POINT, MOVE, DRAW, HFILL, VFILL
+ PUBLIC COLOR, STYLE, PATERN, INTENS, PALLET, BORDER, VIDEO, HPAGE
+ PUBLIC NOCARD, PUSHXY, POPXY, INXPOS, INYPOS, INPIX, GETMAP, PUTMAP
+ PUBLIC ORMAP, XORMAP, TRACK, INKEY, HASCII, HFONT, HFONT8, OUTHLI
+ PUBLIC CIRB
+
+DEFPRO MACRO ARG, PRLIST
+ LOCAL LAB
+ IRP X, <PRLIST>
+X LABEL FAR
+ ENDM
+LAB PROC FAR
+ RET ARG
+LAB ENDP
+ ENDM
+
+CODE SEGMENT 'CODE'
+ ASSUME CS:CODE
+
+ DEFPRO , <GROFF, CLS, PUSHXY, POPXY>
+ DEFPRO 4, <GRON, HFILL, VFILL, COLOR, STYLE, INTENS, PALLET, BORDER>
+ DEFPRO 4, <VIDEO, NOCARD, INXPOS, INYPOS, PUTMAP, ORMAP, XORMAP, INKEY>
+ DEFPRO 4, <HASCII>
+ DEFPRO 8, <POINT, MOVE, DRAW, INPIX, TRACK, HFONT, HFONT8, OUTHLI>
+ DEFPRO 12,<HPAGE, GETMAP>
+ DEFPRO 16,<PATERN>
+ DEFPRO 36,<CIRB>
+
+CODE ENDS
+ END
+\1a
\ No newline at end of file
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+
+void pascal draw( _col, _row )
+ int *_col,*_row;
+{
+ int X1 = inxpos(NULL);
+ int Y1 = inypos(NULL);
+ int X2 = *_col;
+ int Y2 = *_row;
+ int pos_slope;
+
+ int dX, dY, /* vector components */
+ row, col,
+ final, /* final row or col number */
+ G, /* used to test for new row or column */
+ inc1, /* G increment when row or column doesn't change */
+ inc2; /* G increment when row or column does change */
+
+ if( X2 < X1 )
+ {
+ X1 = *_col;
+ Y1 = *_row;
+ X2 = inxpos(NULL);
+ Y2 = inypos(NULL);
+ }
+
+ dX = X2 - X1; dY = Y2 - Y1; /* find vector component */
+ pos_slope = (dX > 0); /* is slope positive? */
+ if (dY < 0) pos_slope = !pos_slope;
+ if (abs(dX) > abs(dY)) { /* shallow line case */
+ if (dX > 0) { /* determine start point and last column */
+ col = X1; row = Y1; final = X2;
+ } else {
+ col = X1; row = Y2; final = X1;
+ }
+ inc1 = 2*abs(dY); /* determine increments and initial G */
+ G = inc1 - abs(dX);
+ inc2 = 2 * (abs(dY) - abs(dX));
+ if (pos_slope)
+ while (col<=final) { /* step thru cols. checking for new row */
+ point( &col, &row );
+ col++;
+ if (G >= 0) { /* it's time to change rows */
+ row++; G+= inc2; /* positive slope, so inc thru rows */
+ } else /* stay at the same row */
+ G += inc1;
+ } /* while */
+ else
+ while (col<=final) { /* step thru cols, check for new row */
+ point( &col, &row );
+ col++;
+ if (G > 0) { /* time to change the rows */
+ row--; G+= inc2; /* negative slope, dec thru rows */
+ } else
+ G += inc1; /* stay at the same row */
+ } /* while */
+ } /* if |dX| > |dY| */ else {
+ if (dY > 0) { /* steep line case, angle > 45 degree */
+ col = X1; row = Y1; final = Y2; /* find start point and last row */
+ } else {
+ col = X2; row = Y2; final = Y1;
+ }
+ inc1 = 2 * abs(dX); /* determine increments and initial G */
+ G = inc1 - abs(dY);
+ inc2 = 2 * (abs(dX) - abs(dY));
+ if (pos_slope)
+ while (row <= final) { /* step thru rows - check for new column */
+ point( &col, &row );
+ row++;
+ if (G >= 0) { /* it's time to change columns */
+ col++; G+= inc2; /* pos. slope, increment thru cols. */
+ } else
+ G += inc1; /* stay at the same column */
+ } /* while */
+ else
+ while (row <= final) {/* step thru rows, checking for new column */
+ point( &col, &row );
+ row++;
+ if (G > 0) { /* it's time to change columns */
+ col--; G+= inc2; /* neg slope, so decrement thru columns */
+ } else
+ G += inc1; /* stay at the same column */
+ } /* while */
+ } /* if |dY| > |dX| */
+
+ move( _col, _row );
+}
+
+
+\r
--- /dev/null
+\r
+#include "graf.h"
+
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+
+void pascal getmap( x, y, buf )
+ int *x,*y;
+ char *buf;
+{
+ /* buffer : 2 bytes X size, 2 bytes Y size, and rows * columns of pixels */
+ int i,j,x0,y0,x1,y1;
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ pushxy();
+ if( *x < x00 )
+ {
+ x0 = *x;
+ x1 = x00;
+ }
+ else
+ {
+ x1 = *x;
+ x0 = x00;
+ }
+ if( *y < y00 )
+ {
+ y0 = *y;
+ y1 = y00;
+ }
+ else
+ {
+ y1 = *y;
+ y0 = y00;
+ }
+ ((short int *)buf)[0] = (short int)(x1-x0+1);
+ ((short int *)buf)[1] = (short int)(y1-y0+1);
+ buf += 4;
+ for( j=y0; j<=y1; j++ )
+ for( i=x0; i<=x1; i++ )
+ *(buf++) = (char)inpix( &i, &j );
+ popxy();
+}
+
+
+void pascal putmap( buf )
+ char *buf;
+{
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ int xw = ((short int *)buf)[0];
+ int yw = ((short int *)buf)[1];
+ int i,j;
+ pushxy();
+ buf += 4;
+ for( j=y00; j<y00+yw; j++ )
+ for( i=x00; i<x00+xw; i++ )
+ {
+ int c = (int)*buf;
+ color( &c );
+ point( &i, &j );
+ buf++;
+ }
+ popxy();
+}
+
+
+void pascal ormap( buf )
+ char *buf;
+{
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ int xw = ((short int *)buf)[0];
+ int yw = ((short int *)buf)[1];
+ int i,j;
+ pushxy();
+ buf += 4;
+ for( j=y00; j<y00+yw; j++ )
+ for( i=x00; i<x00+xw; i++ )
+ {
+ int c = inpix( &i, &j );
+ c |= (int)*buf;
+ color( &c );
+ point( &i, &j );
+ buf++;
+ }
+ popxy();
+}
+
+
+void pascal xormap( buf )
+ char *buf;
+{
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ int xw = ((short int *)buf)[0];
+ int yw = ((short int *)buf)[1];
+ int i,j;
+ pushxy();
+ buf += 4;
+ for( j=y00; j<y00+yw; j++ )
+ for( i=x00; i<x00+xw; i++ )
+ {
+ int c = inpix( &i, &j );
+ c ^= (int)*buf;
+ color( &c );
+ point( &i, &j );
+ buf++;
+ }
+ popxy();
+}
+
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#ifndef NULL
+#define NULL (void *)0
+#endif
+
+
+void pascal gron( int * );
+void pascal groff( void );
+void pascal cls( void );
+void pascal point( int *, int * );
+void pascal move( int *, int * );
+void pascal draw( int *, int * );
+void pascal hfill( int * );
+void pascal vfill( int * );
+void pascal color( int * );
+void pascal style( int * );
+void pascal patern( int *, int *, int *, int * );
+void pascal intens( int * );
+void pascal pallet( int * );
+void pascal border( int * );
+void pascal video( char * /* normalized */ );
+void pascal hpage( int *, int *, int * );
+int pascal nocard( void * /* NULL */ );
+void pascal pushxy( void );
+void pascal popxy( void );
+int pascal inxpos( void * /* NULL */ );
+int pascal inypos( void * /* NULL */ );
+int pascal inpix( int *, int * );
+
+void pascal getmap( int *, int *, char * /* normalized */ );
+void pascal putmap( char * /* normalized */ );
+void pascal ormap( char * /* normalized */ );
+void pascal xormap( char * /* normalized */ );
+
+void pascal track( int *, int * );
+int pascal inkey( void * /* NULL */ );
+void pascal hascii( int * );
+void pascal hfont( int *, int * );
+void pascal hfont8( int *, int * );
+void pascal outhli( int *, char * );
+void pascal cirb( int *, int *, int *, float *, float *, int *, int *, int *, int * );
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+
+#define bound(x,y) ( x<0 || y<0 || x>719 || y>347 )
+
+
+int pascal nocard( dummy )
+ void *dummy;
+{
+ return 1;
+}
+
+
+#define index 0x3b4 /* 6845 ports */
+#define data 0x3b5
+#define mode 0x3b8 /* Herc ports */
+#define status 0x3ba
+#define config 0x3bf
+
+
+static int cur_color;
+static int cur_x;
+static int cur_y;
+static char *page_drawn;
+static int page_drawn_no;
+static int page_viewed;
+
+
+#if WORD_32BIT
+#define HERC_BASE 0xE00B0000UL
+#define CHAR_BASE 0xE00FFA6EUL
+#else
+#define HERC_BASE 0xB0000000UL
+#define CHAR_BASE 0xFFA6000EUL
+#endif
+
+
+static void set_page_drawn( page )
+ int page;
+{
+ if( page == 0 || page == 1 )
+ {
+ page_drawn = (char *)( HERC_BASE + page * 0x8000);
+ page_drawn_no = page;
+ }
+}
+
+
+static void screen_off()
+{
+ outportb( mode, '\0' );
+}
+
+
+static void set_page_viewed( page )
+ int page;
+{
+ if( page == 0 ) outportb( mode, '\x0a' );
+ else
+ if( page == 1 ) outportb( mode, '\x8a' );
+ page_viewed = page;
+}
+
+
+static void clear_buffer( buf )
+ char *buf;
+{
+ int i;
+ for( i=0; i<0x7fff; i++ ) buf[i] = '\0';
+}
+
+
+static void clear_gr_scr( page )
+ int page;
+{
+ if( page_viewed == page ) screen_off();
+ clear_buffer( (char *)(HERC_BASE + page*0x8000) );
+ if( page_viewed == page ) set_page_viewed( page );
+}
+
+
+static int in_graphics=0;
+void pascal gron( dummy )
+ int *dummy;
+{
+ char i;
+ static char params[16] = {
+ '\x35', '\x2d', '\x2e', '\x07', '\x5b', '\x02',
+ '\x57', '\x57', '\x02', '\x03', '\x00', '\x00',
+ '\x00', '\x00', '\x00', '\x00'
+ };
+
+ if( in_graphics ) return;
+ in_graphics = 1;
+
+ atexit( groff );
+
+/*
+ {
+ int i=0;
+ geninterrupt (0x11);
+ if (( AX & 0x30 ) == 0x30)
+ for (i=0; i<0x800; i++)
+ if (inportb(status) & 0x80)
+ {
+ i=-1;
+ break;
+ }
+ if( i != -1 )
+ {
+ fprintf( stderr, "This version runs only with HERCULES graphic card\n" );
+ exit( 1 );
+ }
+ }
+*/
+
+
+ outportb( config, 3 ); /* allows both graphics pages */
+ screen_off();
+ for( i=0; i<sizeof(params); i++) {
+ outportb( index, i );
+ outportb( data, params[i] );
+ }
+ set_page_viewed( 0 );
+ set_page_drawn ( 0 );
+ clear_gr_scr( 1 );
+ clear_gr_scr( 0 );
+ cur_color=1;
+ cur_x=0;
+ cur_y=0;
+}
+
+
+void pascal groff()
+{
+ char i;
+ static char params[16] = {
+ 0x61, 0x50, 0x52, 0x0f, 0x19, 0x06,
+ 0x19, 0x19, 0x02, 0x0d, 0x0b, 0x0c,
+ 0x00, 0x00, 0x00, 0x00
+ };
+
+ if( !in_graphics ) return;
+ in_graphics = 0;
+
+ outportb( config, 0 ); /* lock out graphics mode */
+ screen_off();
+ for( i=0; i<sizeof(params); i++) {
+ outportb( index, i );
+ outportb( data, params[i] );
+ }
+ outportb( mode, '\x28' ); /* enable blink and turn on screen */
+}
+
+
+void pascal hpage( nr, tryb, zeruj )
+ int *nr,*tryb,*zeruj;
+{
+ if( *nr == 0 )
+ {
+ if( *zeruj ) clear_gr_scr( 0 );
+ if( *tryb == 1 ) set_page_viewed( 0 );
+ if( *tryb == -1 ) set_page_viewed( 0 );
+ }
+ else
+ if( *nr == 1 )
+ {
+ if( *zeruj ) clear_gr_scr( 1 );
+ if( *tryb == 1 ) set_page_viewed( 1 );
+ if( *tryb == -1 ) set_page_viewed( 1 );
+ }
+}
+
+
+void pascal video( buffer )
+ char *buffer;
+{
+ page_drawn = buffer;
+ page_drawn_no = -1;
+}
+
+
+void pascal cls()
+{
+ if( page_viewed == page_drawn_no ) clear_gr_scr( page_viewed );
+ else clear_buffer( page_drawn );
+}
+
+
+void pascal point( col, row )
+ int *col,*row;
+{
+ int x=*col, y=*row;
+ int byte_ofs; /* offset within page for byte containing the point */
+ char mask; /* locates point within the byte */
+ if( bound( *col, *row ) ) return;
+ mask = 1 << (7 - (x % 8));
+ byte_ofs = 0x2000 * (y % 4) + 90 * (y/4) + (x/8);
+ if( cur_color == 1 ) /* draw the point */
+ page_drawn[ byte_ofs ] |= mask;
+ else /* erase the point */
+ page_drawn[ byte_ofs ] &= ~mask;
+ move( col, row );
+}
+
+
+void pascal move( col, row )
+ int *col,*row;
+{
+ cur_x = *col;
+ cur_y = *row;
+}
+
+
+int pascal inxpos( dummy ) void *dummy; { return cur_x; }
+int pascal inypos( dummy ) void *dummy; { return cur_y; }
+
+
+int pascal inpix( col, row )
+ int *col,*row;
+{
+ int x=*col, y=*row;
+ int byte_ofs; /* offset within page for byte containing the point */
+ char mask; /* locates point within the byte */
+ if( bound( *col, *row ) ) return 0;
+ move( col, row );
+ mask = 1 << (7 - (x % 8));
+ byte_ofs = 0x2000 * (y % 4) + 90 * (y/4) + (x/8);
+ return !!( page_drawn[ byte_ofs ] & mask );
+}
+
+
+void pascal color( c )
+ int *c;
+{
+ cur_color = *c;
+}
+
+
+void pascal intens( intensity ) int *intensity; {}
+void pascal pallet( palette ) int *palette; {}
+void pascal border( color ) int *color; {}
+void pascal style ( style_no ) int *style_no; {}
+void pascal patern( p1,p2,p3,p4 ) int *p1,*p2,*p3,*p4; {}
+
+
+static struct { int x,y,c; } stack[16];
+static int stack_top=0;
+void pascal pushxy()
+{
+ stack[stack_top ].x = cur_x;
+ stack[stack_top ].y = cur_y;
+ stack[stack_top++].c = cur_color;
+}
+void pascal popxy()
+{
+ cur_x = stack[--stack_top].x;
+ cur_y = stack[ stack_top].y;
+ cur_color = stack[ stack_top].c;
+}
+
+
+void pascal track ( x, y ) int *x,*y; {}
+
+static char *char_base = (char *)CHAR_BASE;
+void pascal hascii( chrp )
+ int *chrp;
+{
+ int i,j;
+ int chr = (*chrp) & 0x7F;
+ int x00 = inxpos(NULL);
+ int y00 = inypos(NULL);
+ pushxy();
+ if( chr == 0 )
+ {
+ int col = cur_color;
+ cur_color = 0;
+ for( i=x00; i<x00+8; i++ ) for( j=y00; j<y00+8; j++ ) point(&i,&j);
+ cur_color = col;
+ }
+ else
+ {
+ char *c = char_base + 8*chr;
+ for( i=x00; i<x00+8; i++ ) for( j=y00; j<y00+8; j++ )
+ if( !!( c[j-y00] & (0x80>>(i-x00)) ) )
+ point(&i,&j);
+ }
+ popxy();
+ if( chr != 0 )
+ {
+ x00 += 8;
+ move( &x00, &y00 );
+ }
+}
+void pascal hfont ( seg, ofs ) int *seg,*ofs; {}
+void pascal hfont8( seg, ofs ) int *seg,*ofs; {}
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+/*
+ OUTHLINE(dlugosc,bufor)
+
+ Procedura OUTHLINE wywoluje HASCII dlugosc razy,
+ wypisujac na ekran znaki, ktorych kody zawarte sa w buforze.
+ Przed narysowaniem kazdego znaku wywolywane jest HASCII(0).
+*/
+
+#include "graf.h"
+
+void pascal outhli( length, buf )
+ int *length;
+ char *buf;
+{
+ int l = (*length) % 0x10000;
+ int zero = 0;
+ while( l-- > 0 )
+ {
+ hascii( &zero );
+ hascii( (int *)(buf++) );
+ }
+}
+
+\r
--- /dev/null
+ /* Loglan82 Compiler&Interpreter\r
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+ Copyright (C) 1993, 1994 LITA, Pau\r
+ \r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+ \r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+ \r
+=======================================================================\r
+*/\r
+\r
+#include "graf.h"
+
+
+void pascal hfill( col )
+ int *col;
+{
+ int x = inxpos(NULL);
+ int y = inypos(NULL);
+ draw( col, &y );
+ move( &x, &y );
+}
+
+
+void pascal vfill( row )
+ int *row;
+{
+ int x = inxpos(NULL);
+ int y = inypos(NULL);
+ draw( &x, row );
+ move( &x, &y );
+}
+
+\r
--- /dev/null
+# /* Loglan82 Compiler&Interpreter\r
+# Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw\r
+# Copyright (C) 1993, 1994 LITA, Pau\r
+# \r
+# This program is free software; you can redistribute it and/or modify\r
+# it under the terms of the GNU General Public License as published by\r
+# the Free Software Foundation; either version 2 of the License, or\r
+# (at your option) any later version.\r
+# \r
+# This program is distributed in the hope that it will be useful,\r
+# but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+# GNU General Public License for more details.\r
+# \r
+# =======================================================================\r
+\r
+\r
+COMMON=hlineio.o draw.o hvfill.o cirb.o gpmap.o hercules.o
+
+CC=gcc -O -Dpascal= -DWORD_32BIT
+CCc=$(CC) -c
+
+#CC=cl -AL -Olsg
+#CCc=$(CC) -Fo$*.o -c
+
+.c.o :
+ $(CCc) $*.c
+
+hgc386.a : $(COMMON)
+ ar rv hgc386.a $(COMMON)
+
+\r
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+/* Handler routines */
+
+/* pataud le 13/10/94
+#if !NO_GRAPH || !DJE
+#if MSDOS
+#include "graf\graf.h"
+#else
+#include "graf/graf.h"
+#endif
+#endif
+*/
+
+void errsignal(exception)
+int exception;
+{
+ word signum, ah, am;
+
+ signum = scot[ exception ];
+ if (signum != -1) /* attempt to call a handler */
+ {
+ raise_signal(signum, (word) 0, &ah, &am);
+ if (ic != 0) /* continue execution */
+ {
+ go(ah, am);
+ longjmp(contenv, 1);
+ }
+ }
+
+#if MSDOS && !NO_GRAPH && !DJE
+ {
+ extern bool graphmode;
+
+ if (graphmode) groff();
+ graphmode = FALSE;
+ }
+#endif
+
+ putc('\n', stderr);
+ switch (exception)
+ {
+ case RTESLCOF: fprintf(stderr, " SL CHAIN CUT OFF"); break;
+ case RTEUNSTP: fprintf(stderr, " UNIMPLEMENTED STANDARD PROCEDURE"); break;
+ case RTEILLAT: fprintf(stderr, " ILLEGAL ATTACH"); break;
+ case RTEILLDT: fprintf(stderr, " ILLEGAL DETACH"); break;
+ case RTECORTM: fprintf(stderr, " COROUTINE TERMINATED"); break;
+ case RTECORAC: fprintf(stderr, " COROUTINE ACTIVE"); break;
+ case RTEINVIN: fprintf(stderr, " ARRAY INDEX ERROR"); break;
+ case RTEILLAB: fprintf(stderr, " INCORRECT ARRAY BOUNDS"); break;
+ case RTEINCQA: fprintf(stderr, " IMPROPER QUA"); break;
+ case RTEINCAS: fprintf(stderr, " ILLEGAL ASSIGNMENT"); break;
+ case RTEFTPMS: fprintf(stderr, " FORMAL TYPE MISSING"); break;
+ case RTEILLKL: fprintf(stderr, " ILLEGAL KILL"); break;
+ case RTEILLCP: fprintf(stderr, " ILLEGAL COPY"); break;
+ case RTEINCHS: fprintf(stderr, " INCOMPATIBLE HEADERS"); break;
+ case RTEHNDNF: fprintf(stderr, " HANDLER NOT FOUND"); break;
+ case RTEMEMOV: fprintf(stderr, " MEMORY OVERFLOW"); break;
+ case RTEFHTLG: fprintf(stderr, " FORMAL LIST TOO LONG"); break;
+ case RTEILLRT: fprintf(stderr, " ILLEGAL RETURN"); break;
+ case RTEREFTN: fprintf(stderr, " REFERENCE TO NONE"); break;
+ case RTEDIVBZ: fprintf(stderr, " DIVISION BY ZERO"); break;
+ case RTESYSER: fprintf(stderr, " SYSTEM ERROR"); break;
+ case RTEILLIO: fprintf(stderr, " ILLEGAL I/O OPERATION"); break;
+ case RTEIOERR: fprintf(stderr, " I/O ERROR"); break;
+ case RTECNTOP: fprintf(stderr, " CANNOT OPEN FILE"); break;
+ case RTEBADFM: fprintf(stderr, " INPUT DATA FORMAT BAD"); break;
+ case RTEILLRS: fprintf(stderr, " ILLEGAL RESUME"); break;
+ case RTETMPRC: fprintf(stderr, " TOO MANY PROCESSES ON ONE MACHINE"); break;
+ case RTEINVND: fprintf(stderr, " INVALID NODE NUMBER"); break;
+ case RTENEGST: fprintf(stderr, " NEGATIVE STEP VALUE"); break;
+ case RTENONGL: fprintf(stderr, " REFERENCE TO GLOBAL NON PROCESS OBJECT FROM PROCESS"); break;
+ default : fprintf(stderr, " UNRECOGNIZED ERROR");
+ }
+ if (thisp->trlnumber < 0) thisp->trlnumber = - thisp->trlnumber;
+ if (thisp->trlnumber != 0)
+ fprintf(stderr, "\n AT LINE: %ld\n", (long) thisp->trlnumber);
+ endprocess(4);
+} /* end errsignal */
+
+
+void raise_signal(signal, skip, ahnew, amnew) /* Raise exception */
+word signal, skip;
+word *ahnew, *amnew;
+{
+ word t1, t2, t3, t4, t5, virts;
+ protdescr *ptr;
+
+ t1 = 0; /* handler for others = no */
+ t2 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */
+ t3 = c1; /* am of current */
+ t5 = 0; /* flag handler not found */
+ do
+ {
+ ptr = prototype[ M[ t3+PROTNUM ] ]; /* prototype of current */
+ t4 = ptr->handlerlist;
+ if (t4 != 0) /* any handlers ? */
+ {
+ do
+ {
+ t5 = M[ t4 ]; /* signal number */
+ if (t5 != signal)
+ {
+ if (t5 == 0 && t1 == 0) t1 = t4;
+ t4 = M[ t4+2 ];
+ }
+ } while (t5 != signal && t4 != 0);
+ }
+ if (t5 != signal) /* look in DL or SL */
+ {
+ if (t1 != 0) t4 = t1; /* handler for others found */
+ else
+ {
+ t4 = t3+M[ t3 ];
+ if (ptr->kind == HANDLER)
+ t2 = M[ t4+SL ]; /* use SL for handlers */
+ else
+ t2 = M[ t4+DL ]; /* or DL for other goodies */
+ if (t2 == 0) /* handler not found */
+ {
+ if (signal <= MAXSYSSN)
+ { /* system signal */
+ ic = skip;
+ if (ic != 0) longjmp(contenv, 1);
+ else return;
+ }
+ else errsignal(RTEHNDNF);
+ }
+ t3 = M[ t2 ];
+ }
+ }
+ else t1 = 0;
+ } while (t1 == 0 && t5 != signal);
+
+ virts = thisp->prochead+M[ thisp->prochead ]+VIRTSC;
+ M[ virts ] = t2; /* compactification possible */
+ M[ virts+1 ] = M[ t2+1 ];
+ t3 = M[ t4+1 ]; /* prototype number of handler */
+ t5 = prototype[ t3 ]->appetite;
+ if (t1 != 0) /* others */
+ {
+ request(t5, ahnew, amnew);
+ M[ *amnew+M[ *amnew ]+SIGNR ] = 0;
+ }
+ else
+ {
+ if (signal == scot[ RTEMEMOV ] &&
+ thisp->lastitem-thisp->lastused-1 < t5)
+ {
+ scot[ RTEMEMOV ] = -1; /* make memov look like abort */
+ errsignal(RTEMEMOV);
+ }
+ request(t5, ahnew, amnew);
+ M[ *amnew+M[ *amnew ]+SIGNR ] = signal;
+ }
+ M[ *amnew+PROTNUM ] = t3; /* provide system attributes */
+ t5 = *amnew+M[ *amnew ];
+ M[ t5+SL ] = M[ virts ];
+ M[ t5+SL+1 ] = M[ virts+1 ];
+ t2 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */
+ M[ t5+DL ] = t2;
+ M[ t5+DL+1 ] = M[ t2+1 ];
+ if (t1 != 0) /* skip */
+ {
+ ic = skip;
+ go(*ahnew, *amnew);
+ }
+} /* end raise_signal */
+
+
+void wind()
+{
+ word t1, t2;
+
+ t1 = M[ M[ c1+M[ c1 ]+SL ] ]; /* am of handlers' SL */
+ t2 = c1; /* current */
+ while (TRUE)
+ {
+ t2 = M[ M[ t2+M[ t2 ]+DL ] ]; /* am of DL */
+ if (t2 == t1) break;
+ M[ t2+M[ t2 ]+LSC ] = prototype[ M[ t2+PROTNUM ] ]->lastwill;
+ }
+ back(&thisp->backobj, &M[ temporary ], (word) 0);
+} /* end wind */
+
+
+void term()
+{
+ word t1;
+
+ t1 = M[ M[ c1+M[ c1 ]+SL ] ]; /* am of handlers' SL */
+ M[ t1+M[ t1 ]+LSC ] = prototype[ M[ t1+PROTNUM ] ]->lastwill;
+ wind();
+} /* end term */
+
+
+/* This wraps up the above series of the handler procedures.
+ */
+
+void backhd(virt, am)
+virtaddr *virt;
+word *am;
+{
+ if (M[ c1+M[ c1 ]+SIGNR ] <= MAXSYSSN)
+ errsignal(RTEILLRT); /* illegal return */
+ else
+ back(virt, am, (word) 0);
+} /* end backhd */
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "nonstand.h"
+
+typedef int word;
+
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+
+/*#include <X11/Xos.h>*/
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#include <X11/Xatom.h>
+
+#include <X11/MwmUtil.h>
+
+#include <stdio.h>
+#include <math.h>
+#include <ctype.h>
+
+XSizeHints theHints;
+Display *theDisp;
+int theDepth, theScreen, dispcells;
+Colormap theCmap;
+Window rootW, window, father;
+GC theGC;
+unsigned long fcol,bcol,white,black,style=1;
+Font mfont;
+XFontStruct *mfinfo;
+Visual *theVisual;
+XImage *theImage;
+XClientMessageEvent toFatherEv;
+XEvent event;
+Cursor theCursor;
+
+int iWIDE,iHIGH;
+int mouse_x=0,mouse_y=0,mouse_l=0,mouse_r=0,mouse_c=0,
+ mouse_l_prs=0,mouse_r_prs=0,mouse_c_prs=0,
+ mouse_l_p_x=0,mouse_r_p_x=0,mouse_c_p_x=0,
+ mouse_l_p_y=0,mouse_r_p_y=0,mouse_c_p_y=0,
+ mouse_l_rel=0,mouse_r_rel=0,mouse_c_rel=0,
+ mouse_l_r_x=0,mouse_r_r_x=0,mouse_c_r_x=0,
+ mouse_l_r_y=0,mouse_r_r_y=0,mouse_c_r_y=0;
+int tracking=0;
+#define END_OF_TRACK -9999
+
+Pixmap pixmap;
+
+#define get_shrt(w) w=(int)(*(pars++));
+#define get_word(w) w=((int)(pars[0])&0xffff)|((int)pars[1]<<16); pars+=2;
+
+#define put_shrt(w) toFatherEv.data.s[cnt++] = (short)(w);
+#define put_word(w) toFatherEv.data.s[cnt++] = (short)((w) & 0xffff); \
+ toFatherEv.data.s[cnt++] = (short)(((w) >> 16) & 0xffff);
+#define snd_father toFatherEv.type=ClientMessage; \
+ toFatherEv.format = 16; \
+ XSendEvent(theDisp,father,False,NoEventMask,&toFatherEv); \
+ XFlush(theDisp);
+
+#ifndef NO_PROTOTYPES
+void RealiseCmd(int,short *);
+#else
+void RealiseCmd();
+#endif
+
+
+static char *application_name="IIUWGRAPH";
+
+
+#define QSIZE 256
+static KeySym keycodes[QSIZE];
+static int keyhead=0,keytail=0;
+
+main(argc, argv)
+ int argc;
+ char *argv[];
+{
+ int w=0;
+ int i;
+ int events=0;
+
+ father = atoi(argv[1]);
+
+ for( i=2; i<argc; i++ ) argv[i-1]=argv[i];
+ argc--;
+
+ if ((theDisp = XOpenDisplay(NULL)) == NULL){
+ fprintf (stderr,"\n%s: Can't open display\n", argv[0]);
+ exit(1);
+ }
+
+ theScreen = DefaultScreen(theDisp);
+ theDepth = DefaultDepth(theDisp, theScreen);
+ rootW = RootWindow(theDisp,theScreen);
+ fcol=white= WhitePixel(theDisp,theScreen);
+ bcol=black= BlackPixel(theDisp,theScreen);
+ theVisual = DefaultVisual(theDisp,theScreen);
+ theCmap = XCreateColormap(theDisp,rootW,theVisual,AllocNone);
+ dispcells = DisplayCells(theDisp, theScreen);
+ theCursor = XCreateFontCursor(theDisp,XC_arrow);
+
+ iWIDE = 720; iHIGH = 348;
+
+ if ((mfinfo = XLoadQueryFont(theDisp,"fixed"))==NULL){
+ fprintf (stderr,"\n%s: Can't open 'fixed' font\n", argv[0]);
+ exit(1);
+ }
+ mfont=mfinfo->fid;
+
+ theHints.width =iWIDE;
+ theHints.height=iHIGH;
+ theHints.flags=PSize;
+ window = XCreateSimpleWindow(theDisp,rootW,10,10,iWIDE,iHIGH,3,fcol,bcol);
+
+ XSetStandardProperties(theDisp,window,"HERCULES","HERCULES",
+ None,argv,argc,theHints);
+ XDefineCursor(theDisp,window,theCursor);
+
+ XChangeProperty(theDisp,window,XA_WM_CLASS,XA_STRING,8,PropModeReplace,
+ application_name,strlen(application_name));
+
+ {
+ struct {
+ long flags;
+ long functions;
+ long decorations;
+ int input_mode;
+ } hints;
+ Atom a=XInternAtom(theDisp,_XA_MWM_HINTS,False);
+ hints.flags = MWM_HINTS_FUNCTIONS;
+ hints.functions = MWM_FUNC_CLOSE | MWM_FUNC_MOVE;
+ hints.decorations = 0;
+ hints.input_mode = 0;
+ XChangeProperty(theDisp,window,a,a,32,PropModeReplace,&hints,4);
+ }
+
+ theGC = XCreateGC(theDisp,window,0,0);
+ XSetFont(theDisp,theGC,mfont);
+ XSetForeground(theDisp,theGC,fcol);
+ XSetBackground(theDisp,theGC,bcol);
+
+ XSelectInput(theDisp,window,
+ ExposureMask |
+ KeyPressMask |
+ PointerMotionMask |
+ ButtonPressMask |
+ ButtonReleaseMask
+ );
+ XMapRaised(theDisp,window);
+
+ pixmap = XCreatePixmap(theDisp,window,iWIDE,iHIGH,theDepth);
+
+ for(;;){
+
+ XNextEvent(theDisp,&event);
+
+ switch (event.type){
+
+ case Expose:
+ {
+ int x=event.xexpose.x;
+ int y=event.xexpose.y;
+ int w=event.xexpose.width;
+ int h=event.xexpose.height;
+ int cnt=0;
+ XCopyArea(theDisp,pixmap,window,theGC,x,y,w,h,x,y);
+ if( events==0 ){
+ put_word(window);
+ snd_father
+ }
+ events=1;
+ }
+ break;
+
+ case ClientMessage:
+ RealiseCmd( (int)(event.xclient.message_type),event.xclient.data.s);
+ break;
+
+ case MappingNotify:
+ if( event.xmapping.request == MappingModifier ||
+ event.xmapping.request == MappingKeyboard )
+ XRefreshKeyboardMapping(&event);
+ break;
+
+ case KeyPress:
+ {
+ KeySym key;
+ char ch;
+ int i=XLookupString( &(event.xkey), &ch, 1, &key, NULL );
+
+ if( i>0 )
+ if( ch == '\177' ) keycodes[ keytail++ ] = -83;
+ else keycodes[ keytail++ ] = (int)ch;
+ else
+ if( key == NoSymbol ) break;
+ else
+ if( IsModifierKey( key ) ) break;
+ else
+ {
+ int to_return = 0;
+ switch( key ){
+ case XK_F1 : to_return = -59; break;
+ case XK_F2 : to_return = -60; break;
+ case XK_F3 : to_return = -61; break;
+ case XK_F4 : to_return = -62; break;
+ case XK_F5 : to_return = -63; break;
+ case XK_F6 : to_return = -64; break;
+ case XK_F7 : to_return = -65; break;
+ case XK_F8 : to_return = -66; break;
+ case XK_F9 : to_return = -67; break;
+ case XK_F10 : to_return = -68; break;
+ case XK_Home : to_return = -71; break;
+ case XK_Left : to_return = -75; break;
+ case XK_Up : to_return = -72; break;
+ case XK_Right : to_return = -77; break;
+ case XK_Down : to_return = -80; break;
+ case XK_End : to_return = -79; break;
+ case XK_Insert: to_return = -82; break;
+ case XK_Break : to_return = -3; break;
+ case XK_Prior : to_return = -73; break;
+ case XK_Next : to_return = -81; break;
+ }
+ if( to_return!=0 ) keycodes[ keytail++ ] = to_return;
+ else break;
+ }
+
+ if( keytail == QSIZE ) keytail = 0;
+ if( keytail == keyhead ){
+ keytail -- ;
+ if( keytail < 0 ) keytail = QSIZE ;
+ }
+ }
+ break;
+
+ case MotionNotify:
+ case ButtonPress:
+ case ButtonRelease:
+ mouse_x = event.xmotion.x;
+ mouse_y = event.xmotion.y;
+ if( event.type == ButtonPress ){
+ switch( event.xbutton.button ){
+ case Button1 : mouse_l=1; mouse_l_prs++;
+ mouse_l_p_x = mouse_x;
+ mouse_l_p_y = mouse_y;
+ if( tracking ){
+ tracking = 0;
+ RealiseCmd( END_OF_TRACK, NULL );
+ }
+ break;
+ case Button2 : mouse_c=1; mouse_c_prs++;
+ mouse_c_p_x = mouse_x;
+ mouse_c_p_y = mouse_y;
+ break;
+ case Button3 : mouse_r=1; mouse_r_prs++;
+ mouse_r_p_x = mouse_x;
+ mouse_r_p_y = mouse_y;
+ break;
+ }
+ }
+ if( event.type == ButtonRelease ){
+ switch( event.xbutton.button ){
+ case Button1 : mouse_l=0; mouse_l_rel++;
+ mouse_l_r_x = mouse_x;
+ mouse_l_r_y = mouse_y;
+ break;
+ case Button2 : mouse_c=0; mouse_c_rel++;
+ mouse_c_r_x = mouse_x;
+ mouse_c_r_y = mouse_y;
+ break;
+ case Button3 : mouse_r=0; mouse_r_rel++;
+ mouse_r_r_x = mouse_x;
+ mouse_r_r_y = mouse_y;
+ break;
+ }
+ }
+ break;
+
+ } /* end of switch */
+
+ } /* end of for */
+
+}
+
+
+
+word cmd=0,w,h,x,y,curx,cury,kolb,wwyp,p,q,r,color;
+word alfa,beta,aspect;
+char c;
+XImage *image;
+XImage *XGetImage();
+
+
+
+void RealiseCmd( cmd, pars ) int cmd; short *pars; {
+
+ int i=1;
+ int cnt=0;
+
+ switch( cmd ){
+
+ case CLS :
+ XSetForeground(theDisp,theGC,bcol);
+ XFillRectangle(theDisp,pixmap,theGC,0,0,iWIDE,iHIGH);
+ XFillRectangle(theDisp,window,theGC,0,0,iWIDE,iHIGH);
+ XSetForeground(theDisp,theGC,fcol);
+ break;
+
+ case GROFF :
+ XFreePixmap(theDisp,pixmap);
+ XDestroyWindow(theDisp,window);
+ XCloseDisplay(theDisp);
+ exit(0);
+ break;
+
+ case INKEY :
+ {
+ int keycode=0;
+ if( keyhead != keytail ){
+ keycode = keycodes[ keyhead++ ];
+ if( keyhead == QSIZE ) keyhead = 0;
+ }
+ put_word(keycode)
+ snd_father
+ }
+ break;
+
+ case POINT :
+ get_shrt( x );
+ get_shrt( y );
+ XDrawPoint(theDisp,pixmap,theGC,x,y);
+ XDrawPoint(theDisp,window,theGC,x,y);
+ break;
+
+ case DRAW :
+ get_shrt( curx );
+ get_shrt( cury );
+ get_shrt( x );
+ get_shrt( y );
+ XDrawLine(theDisp,pixmap,theGC,curx,cury,x,y);
+ XDrawLine(theDisp,window,theGC,curx,cury,x,y);
+ break;
+
+ case CIRB :
+ get_shrt( x );
+ get_shrt( y );
+ get_shrt( r );
+ get_shrt( aspect );
+ get_shrt( alfa );
+ get_shrt( beta );
+ XDrawArc(theDisp,pixmap,theGC,x,y,r,aspect,alfa,beta);
+ XDrawArc(theDisp,window,theGC,x,y,r,aspect,alfa,beta);
+ break;
+
+ case HFILL :
+ get_shrt( curx );
+ get_shrt( cury );
+ get_shrt( x );
+ XDrawLine(theDisp,pixmap,theGC,curx,cury,x,cury);
+ XDrawLine(theDisp,window,theGC,curx,cury,x,cury);
+ break;
+
+ case VFILL :
+ get_shrt( curx );
+ get_shrt( cury );
+ get_shrt( y );
+ XDrawLine(theDisp,pixmap,theGC,curx,cury,curx,y);
+ XDrawLine(theDisp,window,theGC,curx,cury,curx,y);
+ break;
+
+ case INPIX :
+ get_shrt( x );
+ get_shrt( y );
+ image=XGetImage(theDisp,pixmap,x,y,1,1,0x7fffffffL,ZPixmap);
+ color = XGetPixel(image,0,0);
+ XDestroyImage(image);
+ put_word(color)
+ snd_father
+ break;
+
+ case GETMAP :
+ {
+ Pixmap map;
+ get_shrt( x );
+ get_shrt( y );
+ get_shrt( w );
+ get_shrt( h );
+ if( w>iWIDE ) w=iWIDE;
+ if( h>iHIGH ) h=iHIGH;
+ map = XCreatePixmap(theDisp,window,w,h,theDepth);
+ XCopyArea(theDisp,pixmap,map,theGC,x,y,w,h,0,0);
+ put_word(map)
+ snd_father
+ }
+ break;
+
+ case PUTMAP :
+ case XORMAP :
+ case ORMAP :
+ {
+ Pixmap map;
+ switch( cmd ){
+ case XORMAP: XSetFunction(theDisp,theGC,GXxor); break;
+ case ORMAP: XSetFunction(theDisp,theGC,GXor ); break;
+ }
+ get_word( map );
+ get_shrt( curx );
+ get_shrt( cury );
+ get_shrt( w );
+ get_shrt( h );
+ if( w>iWIDE ) w=iWIDE;
+ if( h>iHIGH ) h=iHIGH;
+ XCopyArea(theDisp,map,pixmap,theGC,0,0,w,h,curx,cury);
+ XCopyArea(theDisp,map,window,theGC,0,0,w,h,curx,cury);
+ if( cmd != PUTMAP ) XSetFunction(theDisp,theGC,GXcopy);
+ }
+ break;
+
+ case COLOR :
+ get_shrt( color );
+ if( color == 0 ) fcol = black ;
+ else fcol = white ;
+ XSetForeground(theDisp,theGC,fcol);
+ break;
+
+ case BORDER :
+ get_shrt( color );
+ if( color == 0 ) bcol = black ;
+ else bcol = white ;
+ XSetBackground(theDisp,theGC,bcol);
+ break;
+
+ case STYLE :
+ {
+ static char style_2[]={ 6, 3 };
+ static char style_3[]={ 4, 6 };
+ static char style_4[]={ 2, 3 };
+ static char style_5[]={ 2, 9 };
+
+ get_shrt( style );
+ switch( style ){
+ case 0:
+ XSetForeground(theDisp,theGC,bcol);
+ XSetLineAttributes(theDisp,theGC,0,LineSolid,CapButt,JoinMiter);
+ break;
+ case 1:
+ XSetForeground(theDisp,theGC,fcol);
+ XSetLineAttributes(theDisp,theGC,0,LineSolid,CapButt,JoinMiter);
+ break;
+ case 2:
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,
+ CapButt,JoinMiter);
+ XSetDashes(theDisp,theGC,0,style_2,2);
+ break;
+ case 3:
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,
+ CapButt,JoinMiter);
+ XSetDashes(theDisp,theGC,0,style_3,2);
+ break;
+ case 4:
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,
+ CapButt,JoinMiter);
+ XSetDashes(theDisp,theGC,0,style_4,2);
+ break;
+ case 5:
+ XSetLineAttributes(theDisp,theGC,0,LineDoubleDash,
+ CapButt,JoinMiter);
+ XSetDashes(theDisp,theGC,0,style_5,2);
+ break;
+ }
+ }
+ break;
+
+ case HASCII :
+ get_shrt( curx );
+ get_shrt( cury );
+ get_shrt( r );
+ if( r==0 ){
+ XSetForeground(theDisp,theGC,bcol);
+ XFillRectangle(theDisp,pixmap,theGC,curx,cury,8,8);
+ XFillRectangle(theDisp,window,theGC,curx,cury,8,8);
+ XSetForeground(theDisp,theGC,fcol);
+ }else{
+ c = (char)r;
+ XDrawString(theDisp,pixmap,theGC,curx,cury+8,&c,1);
+ XDrawString(theDisp,window,theGC,curx,cury+8,&c,1);
+ }
+ break;
+
+ case STATUS :
+ put_shrt(mouse_x)
+ put_shrt(mouse_y)
+ put_shrt(mouse_l)
+ put_shrt(mouse_r)
+ put_shrt(mouse_c)
+ snd_father
+ break;
+
+ case GETPRESS :
+ case GETRELEASE :
+ {
+ int button;
+ get_shrt(button);
+ if( cmd == GETPRESS )
+ switch( button ){
+
+ case 0:
+ put_shrt( mouse_l_p_x );
+ put_shrt( mouse_l_p_y );
+ put_shrt( mouse_l_prs );
+ mouse_l_prs=0;
+ break;
+
+ case 1:
+ put_shrt( mouse_r_p_x );
+ put_shrt( mouse_r_p_y );
+ put_shrt( mouse_r_prs );
+ mouse_r_prs=0;
+ break;
+
+ case 2:
+ put_shrt( mouse_c_p_x );
+ put_shrt( mouse_c_p_y );
+ put_shrt( mouse_c_prs );
+ mouse_c_prs=0;
+ break;
+
+ default:put_shrt( 0 );
+ put_shrt( 0 );
+ put_shrt( 0 );
+ break;
+
+ }
+ else
+ switch( button ){
+
+ case 0:
+ put_shrt( mouse_l_r_x );
+ put_shrt( mouse_l_r_y );
+ put_shrt( mouse_l_rel );
+ mouse_l_rel=0;
+ break;
+
+ case 1:
+ put_shrt( mouse_r_r_x );
+ put_shrt( mouse_r_r_y );
+ put_shrt( mouse_r_rel );
+ mouse_r_rel=0;
+ break;
+
+ case 2:
+ put_shrt( mouse_c_r_x );
+ put_shrt( mouse_c_r_y );
+ put_shrt( mouse_c_rel );
+ mouse_c_rel=0;
+ break;
+
+ default:put_shrt( 0 );
+ put_shrt( 0 );
+ put_shrt( 0 );
+ break;
+
+ }
+ put_shrt(mouse_l)
+ put_shrt(mouse_r)
+ put_shrt(mouse_c)
+ snd_father
+ }
+ break;
+
+ case GETMOVEMENT :
+ {
+ static int x=0,y=0;
+ put_shrt(mouse_x-x)
+ put_shrt(mouse_y-y)
+ snd_father
+ x = mouse_x;
+ y = mouse_y;
+ }
+ break;
+
+ case TRACK:
+ {
+ int x,y;
+ get_shrt( x ) /* these parameters are not used */
+ get_shrt( y )
+ tracking = 1;
+ /* now we wait to point and press left button */
+ }
+ break;
+
+ case END_OF_TRACK:
+ put_shrt( mouse_x )
+ put_shrt( mouse_y )
+ snd_father
+ break;
+
+ default :
+ fprintf(stderr,"UKNOWN COMMAND for HERCULES emulation - %d\n",cmd);
+ fflush(stderr);
+ XFreePixmap(theDisp,pixmap);
+ XDestroyWindow(theDisp,window);
+ XCloseDisplay(theDisp);
+ exit(7);
+
+ }
+
+}
+
--- /dev/null
+control.c: sendmsg1( &msg); /* send create request */
+control.c: sendmsg1( &msg); /* send RPC request */
+control.c: sendmsg1(&msg); /* send create acknowledge */
+control.c: sendmsg1(&msg); /* send RP return - acknowledge */
+object.c: sendmsg1( &msg);/* send remote kill request */
+process.c: sendmsg1( &msg); /* request remote resume */
+process.c: sendmsg1(&msg); /* send error message */
+process.c: sendmsg1( &msg );
+process.c: sendmsg1( &msg1 );
+process.c:void sendmsg1(msg) /* Send message via net */
+process.c:fprintf(stdout,"After sendmsg1\n");
--- /dev/null
+#include "graf\graf.h"
+#include <dos.h>
+
+static union REGS r;
+
+int pascal inkey( dummy )
+ void *dummy;
+{
+ r.h.ah = 0x01;
+ int86( 0x16, &r, &r);
+ if( r.x.ax == 0 ) return 0;
+ else
+ {
+ r.h.ah = 0x00;
+ int86( 0x16, &r, &r);
+ if( r.h.al != '\0' )
+ return (int)(unsigned char)( r.h.al );
+ else
+ if( r.h.ah & '\x80' )
+ return (int)( -r.h.ah );
+ else
+ return (int)(unsigned char)( r.h.ah );
+ }
+}
+
--- /dev/null
+#define INCL_BASE
+#include <os2.h>
+
+int pascal inkey(dummy)
+int *dummy;
+{
+ KBDKEYINFO kdata;
+ int i;
+ unsigned u;
+
+ KbdPeek(&kdata, 0);
+ if (kdata.fbStatus)
+ {
+ KbdCharIn(&kdata, 0, 0);
+ if (kdata.chChar != '\0')
+ {
+ u = kdata.chChar;
+ return(u);
+ }
+ else
+ {
+ i = kdata.chScan;
+ if (i < 0x80) return(-i); else return(i);
+ }
+ }
+ else
+ return(0);
+}
--- /dev/null
+#include <stdio.h>
+#include <signal.h>
+#include <assert.h>
+#include <string.h>
+#include <ctype.h>
+
+#include <termio.h>
+
+
+#include "graf/graf.h"
+
+#define KB_BACKSPACE (int)'\b' /* kb */
+#define KB_ENTER (int)'\r' /* RT */
+#define KB_TAB (int)'\t' /* TB */
+#define KB_ESC 0x1b /* EC */
+
+#define KB_HOME -71 /* kh or HM */
+#define KB_END -79 /* EN */
+#define KB_UP -72 /* ku or UP */
+#define KB_DOWN -80 /* kd */
+#define KB_LEFT -75 /* kl */
+#define KB_RIGHT -77 /* kr */
+#define KB_PGUP -73 /* PU */
+#define KB_PGDN -81 /* PD */
+#define KB_BACK_TAB -15 /* BT */
+#define KB_INS -82 /* al */
+#define KB_DEL -83 /* DL */
+
+#define KB_F1 -59 /* k1 */
+#define KB_F2 -60 /* k2 */
+#define KB_F3 -61 /* k3 */
+#define KB_F4 -62 /* k4 */
+#define KB_F5 -63 /* k5 */
+#define KB_F6 -64 /* k6 */
+#define KB_F7 -65 /* k7 */
+#define KB_F8 -66 /* k8 */
+#define KB_F9 -67 /* k9 */
+#define KB_F10 -68 /* k0 */
+
+#define KB_STR_EXISTS 1 /* string exists in tree or his prefix */
+#define KB_TOO_MANY_STRINGS 2
+#define KB_NULL_STRING 3
+#define KB_OUT_OF_MEMORY 4
+#define KB_OK 0
+
+
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+
+#define TERMINAL 0
+#define KEYBOARD 1
+
+static char *capability,*capability_value;
+
+typedef struct _tree_node *tree; /* drzewo zawierajace ciagi znakow */
+struct _tree_node { /* odpowiadajace klawiszowi klawiatury */
+ int key;
+ tree way;
+ int outkey;
+};
+
+#ifndef NO_PROTOTYPES
+static int tfirst(int);
+static int tnext(void);
+static void *___allocate_object(unsigned);
+static void ___free_object(void *);
+static char *object_str(char *); /* allocate space and copy string */
+static int __testkey(int*,int*);
+static int getkey(void);
+static int __inkey(void);
+static void kbinit(void);
+static tree new_tree_node(void);
+static int _create_new_leaf(tree,int,unsigned char *,int);
+static int inskey(int,char *);
+#else
+static int tfirst();
+static int tnext();
+static void *___allocate_object();
+static void ___free_object();
+static char *object_str();
+static int __testkey();
+static int getkey();
+static int __inkey();
+static void kbinit();
+static tree new_tree_node();
+static int _create_new_leaf();
+static int inskey();
+#endif
+
+
+
+
+
+#define object_kill(i) (___free_object(i),(i)=NULL)
+#define object_new(type) ((type *)___allocate_object(sizeof(type)))
+#define object_dim(i,type) ((type *)___allocate_object((i)*sizeof(type)))
+
+
+
+
+#define KB_NDEF 0xff /* KN - key suppressed by inkey() */
+
+#define NODE_SIZE 100
+
+
+#define QSIZE 256
+static int cqueue[QSIZE]; /* implementacja kolejki */
+static int qh=0,qt=0,qs=0;
+static int bget(){
+ int c;
+ if( qs == 0 ) return -1;
+ c = cqueue[ qh++ ];
+ qh &= QSIZE - 1 ;
+ qs--;
+ return c;
+}
+static void bput( c ) int c; {
+ if( qs == QSIZE ) return;
+ cqueue[ qt++ ] = c;
+ qt &= QSIZE - 1 ;
+ qs++;
+}
+static int qq;
+static int bfirst(){
+ if( qs == 0 ) return -1;
+ qq = qh + 1 ;
+ qq &= QSIZE - 1 ;
+ return cqueue[ qh ];
+}
+static int bnext(){
+ int c;
+ if( qq == qt ) return -1;
+ c = cqueue[ qq++ ];
+ qq &= QSIZE - 1 ;
+ return c;
+}
+
+
+static tree troot=NULL;
+
+#ifndef NDEBUG
+static FILE *f=NULL;
+static void _show_tree(root,r) tree root;int r;{
+ int i,j;
+ for(i=0;(i<NODE_SIZE) && (root[i].key!=-1);i++){
+ for(j=0;j<r;j++) fprintf(f,"i");
+ fflush(f);
+ fprintf(f,"%d ",root[i].key);fflush(f);
+ if(root[i].way==NULL){
+ fprintf(f,"%d\n",root[i].outkey);fflush(f);
+ }else _show_tree(root[i].way,r+1);
+ }
+}
+static void show_tree(){
+ f=fopen("show_tree","a");
+ if(f==NULL){printf("cant open");exit(7);}
+ fprintf(f,"%lx\n",troot);fflush(f);
+ _show_tree(troot,0);
+ fprintf(f,"********************\n");
+ fclose(f);
+}
+#endif
+
+
+#define NO_CHARS 0
+#define PART_SUBSTRING 1
+#define SUBSTRING 2
+#define STRING 3
+#define NO_MATCH 4
+
+static int __testkey(outkey,to_take) int *outkey,*to_take;
+{
+ int c,i;
+ tree tact;
+
+ tact=troot;
+ c=bfirst();
+
+ if(c==-1) return NO_CHARS; /* buffer empty - wait for char */
+
+ *to_take=1;
+
+ for(;;){
+ for(i=0;i<NODE_SIZE;i++){
+ if(tact[i].key==-1){ i=NODE_SIZE; break; }
+ if(tact[i].key==c)
+ if(tact[i].way!=NULL){
+ c=bnext();
+ (*to_take)++;
+ if(c==-1){
+ *outkey=tact[i].outkey;
+ if(*outkey != -1) return SUBSTRING;
+ else return PART_SUBSTRING;
+ }
+ tact=tact[i].way;
+ break;
+ }
+ else{
+ *outkey = tact[i].outkey;
+ return STRING;
+ }
+ }
+ if( i==NODE_SIZE ) return NO_MATCH;
+ }
+}
+
+
+static void (*prev_fun)()=NULL;
+static void alarm_fun(){}
+
+
+static int getkey(){
+ int c;
+ prev_fun = signal( SIGALRM, alarm_fun );
+ alarm(1);
+ c = getchar();
+ alarm(0);
+ signal( SIGALRM, prev_fun );
+ return c;
+}
+
+
+
+static int __inkey()
+{
+ int c,i,outkey,chars;
+ if(troot==NULL){printf("Not initialized\n\r");exit(7);}
+
+ alarm(0);
+
+ for(;;){
+
+ i=__testkey(&outkey,&chars);
+
+ switch( i ){
+
+ case NO_CHARS :
+ c = getkey();
+ if( c != -1 ) bput( c );
+ else return 0;
+ break;
+
+ case PART_SUBSTRING :
+ c = getkey();
+ if( c==-1 ) return bget();
+ bput( c );
+ break;
+
+ case SUBSTRING :
+ c = getkey();
+ if( c==-1 ){
+ while( chars-- ) bget();
+ return outkey;
+ }
+ bput( c );
+ break;
+
+ case STRING :
+ while( chars-- ) bget();
+ return outkey;
+ break;
+
+ case NO_MATCH :
+ return bget();
+ break;
+ }
+ }
+}
+
+
+static struct termio term_state,term_new;
+
+int inkey( dummy )
+ void *dummy;
+{ /* podaj znak z klawiatury - zapominanie KB_NDEF */
+ static int first_time=1;
+ int k;
+
+ if( first_time ){ kbinit(); first_time=0; }
+
+ ioctl(fileno(stdin),TCGETA,&term_state); /* RAW MODE */
+ term_new = term_state;
+ term_new.c_lflag&=~(ISIG|ICANON|ECHO); /* echo,canonical line processing */
+ /* signal processing = OFF */
+ term_new.c_iflag&=~(ICRNL|INLCR); /* conversions OFF */
+ term_new.c_oflag=0;
+ term_new.c_cc[VEOF]='\1'; /* every char flushed immedietly */
+ ioctl(fileno(stdin),TCSETA,&term_new);
+
+ do k=__inkey(); while(k==KB_NDEF);
+
+ ioctl(fileno(stdin),TCSETA,&term_state); /* PREVIOUS MODE */
+
+ return k;
+}
+
+
+static tree new_tree_node(){
+ tree p;
+ int i;
+ p=(tree)object_dim(NODE_SIZE+1,struct _tree_node);
+ p++;
+ for(i=0;i<NODE_SIZE;i++){
+ p[i].key=p[i].outkey=-1;
+ p[i].way=NULL;
+ }
+ return p;
+}
+
+
+static int inskey(ch,str)
+ int ch;
+ char *str;
+{
+ tree tact=troot;
+ int i;
+
+ if(troot==NULL) return KB_OUT_OF_MEMORY;
+ if(str==NULL || (!(*str))) return KB_NULL_STRING;
+
+ for(;;){
+ for(i=0;i<NODE_SIZE;i++){
+ if(tact[i].key==-1){
+ tact[i].key=(int)(*(str++));
+ return _create_new_leaf(tact,i,str,ch);
+ }
+ if(tact[i].key==(int)(*str)){
+ str++;
+ if(tact[i].way==NULL)
+ if( *str!='\0' ) return _create_new_leaf(tact,i,str,ch);
+ else return KB_STR_EXISTS;
+ if( *str=='\0' ){
+ tact[i].outkey=ch;
+ return KB_OK;
+ }
+ tact=tact[i].way;
+ break;
+ }
+ }
+ if(i==NODE_SIZE) return KB_TOO_MANY_STRINGS;
+ }
+}
+
+
+static int _create_new_leaf(tact,i,str,ch)
+ tree tact;
+ int i,ch;
+ unsigned char *str;
+{
+ while(*str!='\0'){
+ tact[i].way=new_tree_node();
+ tact[i].way[-1].way=tact;
+ tact=tact[i].way;
+ i=0;
+ tact[0].key=(int)(*(str++));
+ }
+ tact[i].outkey=ch;
+ return KB_OK;
+}
+
+
+static struct { int key; char capability[3]; } tab[]={
+
+ { KB_NDEF , "KN" },
+ { KB_BACKSPACE , "kb" },
+ { KB_ENTER , "RT" },
+ { KB_HOME , "kh" },
+ { KB_HOME , "HM" },
+ { KB_END , "EN" },
+ { KB_UP , "ku" },
+ { KB_UP , "UP" },
+ { KB_DOWN , "kd" },
+ { KB_LEFT , "kl" },
+ { KB_RIGHT , "kr" },
+ { KB_PGUP , "PU" },
+ { KB_PGDN , "PD" },
+ { KB_BACK_TAB , "BT" },
+ { KB_TAB , "TB" },
+ { KB_ESC , "EC" },
+ { KB_INS , "al" },
+ { KB_DEL , "DL" },
+ { KB_F1 , "k1" },
+ { KB_F2 , "k2" },
+ { KB_F3 , "k3" },
+ { KB_F4 , "k4" },
+ { KB_F5 , "k5" },
+ { KB_F6 , "k6" },
+ { KB_F7 , "k7" },
+ { KB_F8 , "k8" },
+ { KB_F9 , "k9" },
+ { KB_F10 , "k0" }
+ };
+
+
+static void kb_install(){
+ int i;
+ for(i=0;i<sizeof(tab)/sizeof(*tab);i++){
+ if(tab[i].capability[0]!=capability[0]) continue;
+ if(tab[i].capability[1]!=capability[1]) continue;
+ if(capability_value==NULL) return;
+ if(capability[2]!='='){
+ if( capability_value!=NULL) object_kill(capability_value);
+ return;
+ }
+ {
+ int err = inskey(tab[i].key,capability_value);
+ if(err==KB_OK) return;
+ if(err==KB_STR_EXISTS || err==KB_NULL_STRING){
+ object_kill(capability_value);
+ return;
+ }
+ printf("Capability %2.2s cannot be inserted:",capability);
+ if(err==KB_TOO_MANY_STRINGS) printf("too many strings\n\r");
+ if(err==KB_OUT_OF_MEMORY ) printf("out of memory\n\r");
+ exit(7);
+ }
+ return;
+ }
+ if(capability_value!=NULL) object_kill(capability_value);
+}
+
+
+static void kbinit() /* inicjalizacja klawiatury */
+{ /* RAW MODE */
+ char *s,*s1;
+ int i,err;
+
+ troot=new_tree_node();
+ troot[-1].way=NULL;
+
+ capability="DL=";
+ capability_value=object_str("\177");
+ kb_install();
+
+ if(tfirst(KEYBOARD)==0){
+ kb_install();
+ while(tnext()==0){
+ kb_install();
+ }
+ }
+
+ if(tfirst(TERMINAL)==0){
+ kb_install();
+ while(tnext()==0){
+ kb_install();
+ }
+ }
+
+}
+
+
+
+
+/* FUNCTIONS for search through one TERMCAP entry */
+
+
+static char *termcap=NULL;
+static char *keybcap=NULL;
+
+#ifndef NO_PROTOTYPES
+static char *envset(char *,char*);
+static char *findchar(char *,char);
+static int convert(char *,char *,int);
+static int next_char(FILE *);
+static int find_name(FILE *,char *);
+#else
+static char *envset();
+static char *findchar();
+static int convert();
+static int next_char();
+static int find_name();
+#endif
+
+
+static char *findchar(str,ch) char *str,ch;{
+ if(str==NULL) return NULL;
+ while( *str!='\0' && *str!=ch ) str++;
+ if(*str=='\0') return NULL;
+ return str;
+}
+
+static char *tgetent(dev)
+ /* gets info from variable TERMCAP */
+ /* or var INKEY or file /etc/inkey */
+int dev;{
+
+ if(dev==TERMINAL){
+ if(termcap==NULL) termcap=envset("TERMCAP","termcap");
+ if(termcap==NULL){
+ fprintf(stderr,"\n\rfile [/etc/]termcap not found\n\r");
+ fflush(stderr);exit(7);
+ }
+ return termcap;
+ }else
+ if(dev==KEYBOARD){
+ if(keybcap==NULL) keybcap=envset("INKEY","inkey");
+ return keybcap;
+ }else{ printf("bad device for tgetent \n\r"); exit(7); }
+}
+
+
+
+
+static char stat_value[100];
+
+static int tfirst(dev)
+ int dev;
+{
+ char *value;
+ capability=tgetent(dev);
+ if(capability==NULL) return 1;
+ return tnext();
+}
+static int tnext(){
+ char *value,*colon;
+ do{
+ capability=findchar(capability,':');
+ if(capability==NULL) return 1;
+ capability++;
+ if(*capability=='\0') return 1;
+ } while( capability[0]==' ' || capability[0]=='\t' );
+ value=findchar(capability,'=');
+ colon=findchar(capability,':');
+ if( value==NULL || ( colon!=NULL && value!=NULL && colon<value ) ){
+ capability_value=object_str("");
+ return 0;
+ }
+ value++;
+ if(*value=='\0') return 1;
+ convert(stat_value,value,sizeof(stat_value));
+ capability_value=object_str(stat_value);
+ return 0;
+}
+
+
+static int convert(ptr,tptr,ptr_size) char *ptr,*tptr; int ptr_size; {
+ int i;
+ char c;
+ while( (tptr!=NULL) && (*tptr!=':') && (*tptr!='\0') )
+ switch(*tptr){
+ case '\\':tptr++;
+ switch(*tptr){
+ case 'E' :tptr++;ptr_size--;*(ptr++)='\x1b';break;
+ case 'n' :tptr++;ptr_size--;*(ptr++)='\n';break;
+ case 'r' :tptr++;ptr_size--;*(ptr++)='\r';break;
+ case 't' :tptr++;ptr_size--;*(ptr++)='\t';break;
+ case 'b' :tptr++;ptr_size--;*(ptr++)='\b';break;
+ case 'f' :tptr++;ptr_size--;*(ptr++)='\f';break;
+ case '\\':tptr++;ptr_size--;*(ptr++)='\\';break;
+ case '^' :tptr++;ptr_size--;*(ptr++)='^';break;
+ default :*ptr='\0';
+ for(i=0;i<3;i++){
+ if(*tptr<'0' || *tptr>'7') return 1;
+ *ptr*=8;
+ *ptr+=*(tptr++)-'0';
+ }
+ ptr++; ptr_size--;
+ }
+ break;
+ case '^': tptr++;
+ c=*(tptr++);
+ *(ptr++)=(char)((toupper(c))-'A'+1); ptr_size--;
+ break;
+ default: *(ptr++)=*(tptr++); ptr_size--;
+ }
+ *ptr='\0';
+ if( ptr_size<=0 ){
+ fprintf(stderr,"buffer exceeded in convert(%s)",__FILE__);
+ fflush(stderr);
+ exit(7);
+ }
+ return 0;
+}
+
+
+/* FUNCTIONS looking for entries in /ETC/TERMCAP */
+
+
+
+static char etcname[80];
+static char termname[80];
+static char *fname;
+
+
+static char *envset(envname,envfile) char *envname,*envfile;{
+ extern char *getenv();
+ char *TERM=getenv("TERM");
+ char *env=getenv(envname);
+ char *str,*ptr;
+ FILE *f;
+ int c,continued=1;
+
+ ptr=str=object_dim(32000,char);
+ if(str==NULL){
+ fprintf(stderr,"Out of memory.\n");
+ fflush(stderr);
+ exit(7);
+ }
+
+ if(TERM==NULL){
+ fprintf(stderr,"\n\renvironment variable TERM not found\n\r");
+ fflush(stderr);
+ exit(7);
+ }
+
+ strcpy(termname,TERM);
+
+ f=fopen(env,"r");
+ if( f==NULL ) f=fopen(envfile,"r"); else fname=env;
+ if( f==NULL ) f=fopen(strcat(strcpy(etcname,"/etc/"),envfile),"r");
+ else fname=envfile;
+ if( f==NULL ) return NULL;
+ else fname=etcname;
+
+ while( continued ){
+
+ char *rev,*tnm;
+
+ if( find_name(f,termname)==0 ) return object_str(":");
+
+ *(ptr++)=':';
+ c=' ';
+ do{
+ c=next_char(f);
+ if( c!='\0' ) *(ptr++)=(char)c;
+ }while( c!='\0' );
+
+ *(ptr)='\0';
+ rev=ptr-1;
+ while( rev>str && rev[-1]!=':' ) rev--;
+ if( rev[0]=='t' && rev[1]=='c' ){
+ ptr=rev-1;
+ rev+=3;
+ tnm=termname;
+ while( *rev!=':' ) *(tnm++)=*(rev++);
+ *tnm='\0';
+ continued=1;
+ }else continued=0;
+
+ }
+
+ ptr=object_str(str);
+ object_kill(str);
+ return ptr;
+
+}
+
+static int find_name(f,termname) FILE *f; char *termname;{
+ int i,c,lastc,found=0;
+ fseek(f,0L,0);
+
+ do{
+
+ do{
+ c=fgetc(f);
+ if(c==EOF) return 0;
+ if(c=='#' || c=='\t' || c==':' || c=='\n')
+ while(c!='\n'){
+ lastc=c;
+ c=fgetc(f);
+ if(c==EOF) return 0;
+ if( lastc=='\\' ) c=' ';
+ }
+ }while(c=='\n');
+
+ while( !found ){
+ for(i=0;termname[i]!='\0';i++){
+ if((char)c!=termname[i]) break;
+ c=fgetc(f);
+ }
+ if( termname[i]=='\0' ){ found=1; break; }
+ while( isalpha((char)c) ) c=fgetc(f);
+ if( c=='|' ) c=fgetc(f);
+ else{ ungetc('#',f); break; }
+ }
+
+ } while( !found );
+
+ while(c!=':'){
+ c=fgetc(f);
+ if(c==EOF) return 0;
+ }
+
+ return 1;
+}
+
+
+static int next_char(f) FILE *f;{
+ int c;
+ static int lastc='\0';
+ if( lastc!='\0' ){
+ c=lastc;
+ lastc='\0';
+ return c;
+ }
+ c=fgetc(f);
+ if( c==EOF || c=='\n' ) return '\0';
+ if( c=='\\' ){
+ c=fgetc(f);
+ if( c=='\n' ){
+ while( c=='\n' || c=='\t' || c==':' || c==' ' ) c=fgetc(f);
+ return c;
+ }
+ lastc=c;
+ return '\\';
+ }
+ return c;
+}
+
+
+
+
+static void *___allocate_object(size) unsigned size;{
+ char *p;
+ extern void *calloc();
+ if(size==0) return NULL;
+ p=calloc(size,1);
+ if( p==NULL ){
+ printf("\r\n");
+ printf("=======================================\r\n");
+ printf("Memory overflow ... \r\n");
+ printf("=======================================\r\n");
+ fflush(stdout);
+ system("stty sane");
+ exit(7);
+ }
+ return (void *)p;
+}
+
+static void ___free_object(ff) void *ff;{
+ assert(ff!=NULL);
+ free((char *)ff);
+}
+
+static char *object_str(str) char *str;{
+ char *buf=object_dim(strlen(str)+1,char);
+ strcpy(buf,str);
+ return buf;
+}
--- /dev/null
+#define MAXMARKER MAXINTEGER /* maximum special value of mark */
+#define MAXAPPT MAXINTEGER /* maximum appetite (easily extensible ?) */
+#define MAXTRACNT 13 /* maximum number of trace messages in line */
+#define MAXHDLEN 40 /* maximum length of formal procedure header */
+#define MAXSYSSN 62 /* maximum number of a system signal */
+#define MAXPARAM 10 /* maximum number of params to standard proc */
+#define IOBLOCK 0x4000 /* size of I/O transfer block in bytes */
+
+/* Object structure : */
+
+/* Offsets from the beginning : */
+#define PROTNUM 1 /* prototype number */
+#define SHORTLINK 1 /* link to same size list (killed only) */
+#define LONGLINK 2 /* link to other size list (killed only) */
+
+/* Files : */
+/* appetite 0 */
+/* prot number 1 always FILEOBJECT */
+#define FSTAT 2 /* file status */
+#define FTEMP 3 /* flag to tell if file is temporary */
+#define FTYPE 4 /* file type */
+#define FNAME 5 /* file name pointer */
+#define FFILE (FNAME+sizeof(char *)/sizeof(word)) /*file handle */
+#define APFILE (FFILE+sizeof(FILE *)/sizeof(word)) /*appetite of file*/
+ /* object */
+
+/* Offsets from the first address after object : */
+#define SL -2 /* static link */
+#define DL -4 /* dynamic link */
+#define LSC -5 /* local control */
+#define STATSL -6 /* number of times the object occurs in SL */
+#define SIGNR -7 /* signal number (handlers only) */
+#define RPCDL -8 /* remote dynamic link (procedures only) */
+#define CL -8 /* coroutine link (coroutine only) */
+#define CHD -10 /* coroutine head (process only) */
+#define VIRTSC -12 /* virtual scratch (process only) */
+
+/* Virtual address (also formal type) : */
+
+typedef struct {
+ word addr; /* address of dictionary item */
+ /* (node and process index for processes) */
+ /* (or for formal types - number of arrayof) */
+ word mark; /* address mark */
+ /* (negative for processes) */
+ /* (or for formal types - actual type) */
+ } virtaddr;
+
+#define loadvirt(v, a) { word ta; \
+ ta = (a); \
+ (v).addr = M[ ta++ ]; \
+ (v).mark = M[ ta ]; }
+#define storevirt(v, a) { word ta; \
+ ta = (a); \
+ M[ ta++ ] = (v).addr; \
+ M[ ta ] = (v).mark; }
+
+#define MF(a) (*( (FILE **) (M+(a)) ))
+#define MN(a) (*( (char **) (M+(a)) ))
+#define MR(a) *( (real *) (M+(a)) )
+
+
+#ifdef max
+#undef max
+#endif
+
+#ifdef min
+#undef min
+#endif
+
+#define min(x, y) ((x) < (y) ? (x) : (y))
+#define max(x, y) ((x) > (y) ? (x) : (y))
+#define absolute(x) ((x) >= 0 ? (x) : -(x))
+
+/* LOGLAN's booleans : */
+#define LFALSE ((word)0)
+#define LTRUE (~LFALSE)
+#define lbool(b) ( (b) ? LTRUE : LFALSE )
+
+/* Type of files : */
+#define TEXTF 1 /* text file */
+#define CHARF 2 /* file of char */
+#define INTF 3 /* file of integer */
+#define REALF 4 /* file of real */
+#define DIRECT 5 /* direct access file */
+
+/* File status : */
+#define READING 0 /* sequential file opened for read */
+#define WRITING 1 /* sequential file opened for write */
+#define UPDATING 2 /* direct access file */
+#define UNKNOWN 3 /* file not opened */
+
+/* Run time error types : */
+
+#define RTESLCOF 0 /* SL chain cut off */
+#define RTEUNSTP 1 /* unimplemented standard procedure */
+#define RTEILLAT 2 /* illegal attach */
+#define RTEILLDT 3 /* illegal detach */
+#define RTECORTM 4 /* coroutine terminated */
+#define RTECORAC 5 /* coroutine active */
+#define RTEINVIN 6 /* array index error */
+#define RTEILLAB 7 /* incorrect array bounds */
+#define RTEINCQA 8 /* improper QUA */
+#define RTEINCAS 9 /* illegal assignment */
+#define RTEFTPMS 10 /* formal type missing */
+#define RTEILLKL 11 /* illegal kill */
+#define RTEILLCP 12 /* illegal copy */
+#define RTEINCHS 13 /* incompatible headers */
+#define RTEHNDNF 14 /* handler not found */
+#define RTEMEMOV 15 /* memory overflow */
+#define RTEFHTLG 16 /* formal header too long */
+#define RTEILLRT 17 /* illegal return */
+#define RTEREFTN 18 /* reference to NONE */
+#define RTEDIVBZ 19 /* division by zero */
+#define RTESYSER 20 /* system error */
+#define RTEILLIO 21 /* illegal I/O operation */
+#define RTEIOERR 22 /* I/O error */
+#define RTECNTOP 23 /* Cannot open file */
+#define RTEBADFM 24 /* Input data format bad */
+#define RTEILLRS 25 /* illegal resume */
+#define RTETMPRC 26 /* too many processes on one machine */
+#define RTEINVND 27 /* invalid node number */
+#define RTENEGST 28 /* negative step value */
+#define RTENONGL 29 /* only process may be global */
+
+union value {
+ unsigned int xint;
+ word xword;
+ real xreal;
+ virtaddr xvirt;
+ word xbool;
+ };
+
+/* Variables : */
+
+extern memory M; /* main memory for code and data */
+extern union value *param; /* pointer to standard proc. param list */
+extern int offset[]; /* offset conversion table for compact. */
+extern int scot[]; /* signal to number conversion table */
+extern int primapet[]; /* appetites of primitive types */
+extern word ic; /* instruction counter */
+extern word lastic; /* previous ic for redecoding after comp. */
+extern int opcode; /* opcode of L-code instruction */
+extern word a1, a2, a3; /* arguments of L-code instruction */
+
+/* kernel variables for the running system */
+
+extern word memorysize; /* size of memory array for code and data */
+extern word dispoff; /* DISPLAY offset in process object */
+extern word disp2off; /* indirect DISPLAY offset in process object */
+extern word display; /* DISPLAY address - physical addresses */
+extern word display2; /* DISPLAY address - indirect addresses */
+extern word c1, c2; /* pointers to current object */
+extern word mainprog; /* main block object */
+extern word mnoff; /* offset of variable main */
+
+
+extern bool infmode; /* TRUE if compactification message printed */
+extern bool debug; /* TRUE if trace is printed */
+extern FILE *tracefile; /* output file for trace */
+
+extern jmp_buf contenv; /* for continue execution */
+
+
+
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+/* Variables common with generator : */
+
+protdescr *prototype[ MAXPROT+1 ]; /* prototypes */
+word ipradr; /* address of primitive types descriptions */
+word temporary; /* address of global temporary variables */
+word strings; /* base for string constants */
+word lastprot; /* the last used prototype number */
+word freem; /* first free cell in M */
+word currfile = 2; /* current file virtual address */
+
+/* Interpreter own variables : */
+
+memory M; /* main memory for code and data */
+union value *param; /* for comunication with standard procs */
+
+/* offset conversion table for compactification */
+int offset[] = { DUMMY, SL, DL, CL, CHD, VIRTSC };
+
+/* signal to number conversion table */
+/* -1 stands for an unrecoverable error which cannot be serviced by handler */
+
+int scot[] =
+{
+ 20, /* RTESLCOF */
+ 20, /* RTEUNSTP */
+ 20, /* RTEILLAT */
+ 20, /* RTEILLDT */
+ 20, /* RTECORTM */
+ 20, /* RTECORAC */
+ 23, /* RTEINVIN */
+ 23, /* RTEILLAB */
+ 21, /* RTEINCQA */
+ 24, /* RTEINCAS */
+ 20, /* RTEFTPMS */
+ 20, /* RTEILLKL */
+ 20, /* RTEILLCP */
+ 24, /* RTEINCHS */
+ -1, /* RTEHNDNF */
+ 22, /* RTEMEMOV */
+ 22, /* RTEFHTLG */
+ -1, /* RTEILLRT */
+ 21, /* RTEREFTN */
+ 01, /* RTEDIVBZ */
+ 02, /* RTESYSER */
+ 02, /* RTEILLIO */
+ 02, /* RTEIOERR */
+ 02, /* RTECNTOP */
+ 02, /* RTEBADFM */
+ 20, /* RTEILLRS */
+ 02, /* RTETMPRC */
+ 02, /* RTEINVND */
+ 23, /* RTENEGST */
+ -1 /* RTENONGL */
+};
+
+/* Primitive type appetites for moveparams() : */
+
+int primapet[] =
+{
+ APINT, /* INTEGER */
+ APREAL, /* REAL */
+ APINT, /* BOOLEAN */
+ APINT, /* CHAR */
+ APREF, /* COROUTINE */
+ APREF, /* PROCESS */
+ APINT /* STRING */
+};
+
+word ic; /* instruction counter */
+word lastic; /* previous ic for redecoding after compact. */
+int opcode; /* opcode of L-code instruction */
+word a1, a2, a3; /* arguments of L-code instructions */
+
+/* kernel variables for the running system: */
+
+word memorysize = DEFMEMSIZE; /* code and data memory size */
+word c1, c2; /* pointers to current object */
+word dispoff; /* DISPLAY offset in process object */
+word disp2off; /* indirect DISPLAY offset in process object */
+word display; /* DISPLAY address - physical addresses */
+word display2; /* DISPLAY address - indirect addresses */
+word mainprog; /* main block object */
+word mnoff; /* offset of variable main */
+
+
+bool infmode = FALSE; /* default: no compactification message */
+bool debug = FALSE; /* TRUE if trace is printed */
+FILE *tracefile; /* output file for trace */
+
+jmp_buf contenv; /* for continue execution */
--- /dev/null
+#ifndef NO_PROTOTYPES
+
+unsigned alarm( unsigned );
+double prandom( void );
+
+void openrc(word,virtaddr *,word *);
+void raise_signal(word,word,word *,word *);
+void openobj(word,word *,word *);
+void slopen(word,virtaddr *,word *,word *);
+void errsignal(int);
+void typep(word,word,word *,word *);
+void copy(virtaddr *,virtaddr *);
+void qua(virtaddr *,word);
+void standard(word);
+void disp(virtaddr *);
+void gkill(virtaddr *);
+void typref(virtaddr *,word);
+void go(word,word);
+void goloc(word,word);
+void typed(word,word,word,word,virtaddr *);
+void term(void);
+void wind(void);
+void trace(word);
+void inner(word);
+void backhd(virtaddr *,word *);
+void backbl(virtaddr *,word *);
+void backpr(virtaddr *,word *);
+void back(virtaddr *,word *,word);
+void detach(void);
+void attach(virtaddr *);
+void fin(word,virtaddr *,word *);
+void heads(virtaddr *,word);
+void resume(virtaddr *);
+void passivate(int);
+void enable(word,word);
+void evaluaterpc(word);
+void disable(word,word);
+void rpc_accept(word);
+void rpc3(void);
+void popmask(word);
+void askprot(virtaddr *);
+bool member(virtaddr *,word *);
+word virtprot(word);
+word loadt(word,word);
+bool is(virtaddr *,word);
+bool inl(virtaddr *,word);
+word shift(word,word);
+void execute(void);
+void abend(char *);
+void addext(char *,char *);
+void usage( void );
+void decode( void );
+void init_scheduler( void );
+void runsys( void );
+void schedule( void );
+void msginterrupt( message * );
+void loosen( void );
+void update( word, word );
+void compactify( void );
+void moveparams(word, word, message *, int, int);
+void sendmsg1(message *);
+word getnode(word);
+void endprocess(int);
+word entier(double);
+char *asciiz( virtaddr * );
+void ranset(void);
+void moveblock( char *,char *, word );
+void request( word, word *, word *);
+word memavail( void );
+void newarry( word, word, word, virtaddr *, word *);
+void initprocess( word,word,procaddr *);
+void activate( word );
+void reset( word );
+void pushmask( word );
+void trapmsg( void );
+void rpc2( void );
+void endrun( int );
+void loadfile(word,word *,word *,FILE **);
+word directio(virtaddr *,word,int (*)(),FILE *);
+void nonstandard( word );
+void genfileobj(bool,word,char *,virtaddr *,word *);
+void rewrite( word );
+void delete( virtaddr * );
+bool testeof( FILE * );
+bool testeoln( FILE * );
+char *tempfilename( void );
+word readint( FILE * );
+double readreal( FILE * );
+void writeint( word, word, FILE * );
+void writereal( double, word, word, FILE * );
+void writestring( word, word, FILE * );
+void readln( FILE * );
+void senderr( int, procaddr * );
+void rpcend( message * );
+void rpc1( message * );
+
+#else
+
+unsigned alarm();
+int unlink();
+int ioctl();
+
+void openrc();
+void raise_signal();
+void openobj();
+void slopen();
+void errsignal();
+void typep();
+void copy();
+void qua();
+void standard();
+void disp();
+void gkill();
+void typref();
+void go();
+void goloc();
+void typed();
+void term();
+void wind();
+void trace();
+void inner();
+void backhd();
+void backbl();
+void backpr();
+void back();
+void detach();
+void attach();
+void fin();
+void heads();
+void resume();
+void passivate();
+void enable();
+void evaluaterpc();
+void disable();
+void rpc_accept();
+void rpc3();
+void popmask();
+void askprot();
+bool member();
+word virtprot();
+word loadt();
+bool is();
+bool inl();
+word shift();
+void execute();
+void abend();
+void addext();
+void usage();
+void decode();
+void init_scheduler();
+void runsys();
+void schedule();
+void msginterrupt();
+void loosen();
+void update();
+void compactify();
+void moveparams();
+void sendmsg();
+word getnode();
+void endprocess();
+word entier();
+char *asciiz();
+void ranset();
+double prandom();
+void moveblock();
+void request();
+word memavail();
+void newarry();
+void initprocess();
+void activate();
+void pushmask();
+void trapmsg();
+void rpc2();
+void endrun();
+void loadfile();
+word directio();
+void nonstandard();
+void genfileobj();
+void reset();
+void rewrite();
+void delete();
+bool testeof();
+bool testeoln();
+char *tempfilename();
+word readint();
+double readreal();
+void writeint();
+void writereal();
+void writestring();
+void readln();
+void senderr();
+void rpcend();
+void rpc1();
+
+#endif
+
--- /dev/null
+cint.o compact.o control.o util.o handler.o intdt.o memory.o object.o runsys.o typchk.o standard.o execute.o fileio.o nonstand.o process.o procaddr.o queue.o rpcall.o
\ No newline at end of file
--- /dev/null
+SHELL=/bin/csh
+#.SUFFIXES: .o .c
+
+#############################################################################
+# switches :
+# OBJECTADDR - switch on special process addressing - object simulates
+# process pointer
+# CDBG - turn on debugging of compactifier, compactifier appends to file
+# 'trace' state of memory before & after the compactification,
+# also a history of compactification & process number is dumped
+# RPCDBG - debugging of alien call, all actions : alien call, acknowledges,
+# passivations and returns are written to stderr
+# NO_GRAPH - nonstand.c defines only INKEY grom IIUWGRAPH
+# DLINK - DLINK network version
+# TCPIP - TCPIP network version - needs also OBJECTADDR
+#
+# switches depending on environment :
+# TURBOC - if using BORLAND TURBO-C compiler
+# MSDOS/OS2/UNIX - choose operating system
+# USE_CLOCK - scheduler should use clock() function to measure time
+# USE_ALARM - scheduler should use alarm() function to measure time
+# WORD_16BIT/DWORD_16BIT/WORD_32BIT - choose memory model :
+# small 16-bit / large 16-bit / small 32-bit
+#
+# for DLINK use cinta.o ( cinta.asm )
+# for TCPIP use tcpip.o sock.o
+# for no network simply leave empty
+# NETFILE=tcpip.o sock.o
+
+#NETFILE=tcpip.o sock.o
+NETFILE=
+
+#CC=gcc -m486 -DDJE -DUSE_CLOCK -DWORD_32BIT -Dpascal=
+# MSDOS 32bit GNU CC
+
+#CC=cl -AL -Olsg -DMSDOS -DDWORD_16BIT # MSDOS 16bit LARGE
+#CC=cl -AL -Olsg -DMSDOS -DWORD_16BIT # MSDOS 16bit SMALL
+
+UNIXPARS=-DUNIX -DWORD_32BIT -DUSE_ALARM -Dpascal=
+UNIXPARSNG=$(UNIXPARS) -DNO_GRAPH
+
+#CC=cc $(UNIXPARSNG) -DNO_PROTOTYPES # SUN,HP
+#CC=rcc $(UNIXPARSNG) -O # SCO - AT&T C compiler
+#CC=cc -W1 $(UNIXPARSNG) # SCO
+#CC=cc -W1 $(UNIXPARSNG) -DOBJECTADDR # SCO
+#CC=cc -W1 $(UNIXPARSNG) -DOBJECTADDR -DTCPIP # SCO TCPIP
+CC=gcc $(UNIXPARSNG) -DOBJECTADDR -DSYSV # GNU C++ TCPIP
+#CC=cc -W1 $(UNIXPARS) -DSYSV -DXSIGHT # SCO with X11 graphics
+#CC=gcc -g $(UNIXPARS) -DSYSV -DXSIGHT # SCO GCC with X11 graphics
+
+CCc=$(CC) # common version
+#CCc=$(CC) -Fo$*.o # MSDOS MSC version
+
+target : int
+
+#############################################################################
+
+
+
+OBJ= cint.o compact.o control.o util.o handler.o intdt.o \
+ memory.o object.o runsys.o standard.o \
+ execute.o fileio.o nonstand.o process.o procaddr.o queue.o \
+ rpcall.o typchk.o $(NETFILE)
+
+.c.o :
+ $(CCc) -c $*.c
+.s.o:
+ as -o $*.o $*.s
+
+hgcint.exe: $(OBJ) inkeydos.o graf\lib\hgcmsf4.lib
+ link /e @link.lnk inkeydos.o, hgcint.exe, nul, graf\lib\hgcmsf4, ;
+
+egaint.exe: $(OBJ) inkeydos.o graf\lib\egamsf4.lib
+ link /e @link.lnk inkeydos.o, egaint.exe, nul, graf\lib\egamsf4, ;
+
+cgaint.exe: $(OBJ) inkeydos.o graf\lib\mgcmsf4.lib
+ link /e @link.lnk inkeydos.o, cgaint.exe, nul, graf\lib\mgcmsf4, ;
+
+cga64int.exe: $(OBJ) inkeydos.o graf\lib\mgc64mf4.lib
+ link /e @link.lnk inkeydos.o, cga64int.exe, nul, graf\lib\mgc64mf4, ;
+
+int386.exe: $(OBJ)
+ $(CC) @link.lnk -lm -lpc -lgrx -o svgaint
+ strip svgaint
+ coff2exe svgaint
+ rm svgaint
+# move svgaint.exe ..\examp\svgaint.exe
+
+int: $(OBJ) inkeyux.o
+# $(CC) $(OBJ) inkeyux.o -lm -lX11 -lmalloc -lsocket -o int
+ $(CC) $(OBJ) inkeyux.o -lm -o int
+ strip int
+# mv int $(HOME)/LOGLAN.PAU/bin
+
+nonstand.o : nonstand.c dosgraf1.c dosgraf2.c os2graf2.c x11graf1.c x11graf2.c svga1.c svga2.c
+
+herc : herc.c
+ $(CC) herc.c -lX11 -lmalloc -lsocket -o herc
+ strip herc
+
+clean :
+ rm *.o
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+/* Memory management routines */
+
+#ifndef NO_PROTOTYPES
+static void compandtake(word, word *, word *, word *, bool);
+static void sinsert(word);
+#else
+static void compandtake();
+static void sinsert();
+#endif
+
+
+int compactify_allowed=1;
+#define space 400 /* words */
+
+
+void request(app, ah, am)
+word app, *ah, *am;
+{
+ word t2, t4, t5;
+ bool wascompactified, found;
+
+ if (app >= MAXAPPT) errsignal(RTEMEMOV);
+ wascompactified = FALSE;
+
+ if( compactify_allowed && thisp->force_compactification ){
+ compactify();
+ thisp->force_compactification=FALSE;
+ wascompactified=TRUE;
+ }
+
+ if (thisp->freeitem != 0) /* reserve dictionary item */
+ {
+ *ah = thisp->freeitem;
+ thisp->freeitem = M[ *ah ];
+ }
+ else
+ {
+ *ah = thisp->lastitem-2;
+ if (*ah <= thisp->lastused + space) /* cannot take free item */
+ {
+ if( compactify_allowed )
+ if( !wascompactified ) compactify(),wascompactified=TRUE;
+ else ;
+ else
+ thisp->force_compactification=TRUE;
+ *ah = thisp->lastitem-2;
+ if (*ah <= thisp->lastused) errsignal(RTEMEMOV);
+ }
+
+ thisp->lastitem = *ah;
+ M[ *ah+1 ] = 0; /* clear mark */
+ } /* now we have a free dict. item */
+
+
+ if (app == 2 && thisp->headk2 != 0) /* special case app=2 */
+ {
+ *am = thisp->headk2;
+ thisp->headk2 = M[ *am+SHORTLINK ];
+ }
+ else
+ {
+ word t1 = thisp->headk;
+ found = FALSE;
+ t4 = 0;
+ while (t1 != thisp->lower && !found)
+ {
+ t2 = M[ t1 ];
+ if (t2 == app) found = TRUE;
+ else
+ if (t2-app >= 2) found = TRUE;
+ else
+ {
+ t4 = t1;
+ t1 = M[ t1+LONGLINK ];
+ }
+ }
+ if( found ) {
+ t5 = M[ t1+SHORTLINK ];
+ if (t5 != 0) M[ t5+LONGLINK ] = M[ t1+LONGLINK ];
+ else t5 = M[ t1+LONGLINK ];
+ if (t4 == 0) thisp->headk = t5; else M[ t4+LONGLINK ] = t5;
+ *am = t1;
+ if (t2 > app) /* at least two extra words */
+ {
+ t5 = t1+app;
+ M[ t5 ] = t2-app;
+ sinsert(t5);
+ }
+ }
+ else
+ if ( thisp->lastitem - thisp->lastused > app + space )
+ {
+ *am = thisp->lastused+1;
+ thisp->lastused += app;
+ }
+ else
+ {
+ M[ *ah ] = thisp->freeitem; /* return dictionary item */
+ thisp->freeitem = *ah;
+ if( compactify_allowed )
+ if( !wascompactified ) compactify();
+ else ;
+ else
+ thisp->force_compactification=TRUE;
+ *ah = thisp->lastitem-2; /* reserve dictionary item */
+ thisp->lastitem = *ah;
+ M[ *ah+1 ] = 0; /* clear mark */
+ if ( thisp->lastitem - thisp->lastused > app ) {
+ *am = thisp->lastused+1;
+ thisp->lastused += app;
+ }
+ else
+ errsignal(RTEMEMOV);
+ }
+ }
+
+ M[ *am ] = app;
+ for (t2 = *am+1; t2 < *am+app; t2++ ) M[ t2 ] = 0;
+ M[ *ah ] = *am;
+
+}
+
+
+static void sinsert(am) /* Dispose of a memory item. */
+word am;
+{
+ word t1, t2, t3, t4;
+
+ t1 = M[ am ]; /* appetite */
+ if (t1 == 2) /* a special list should be used */
+ {
+ M[ am+SHORTLINK ] = thisp->headk2;
+ thisp->headk2 = am;
+ }
+ else
+ {
+ t2 = thisp->headk;
+ t4 = 0;
+ while (TRUE) /* look for a proper place */
+ {
+ t3 = M[ t2 ]; /* appetite */
+ if (t1 == t3) /* an entry with matching appetite */
+ {
+ M[ am+SHORTLINK ] = M[ t2+SHORTLINK ];
+ M[ t2+SHORTLINK ] = am;
+ break;
+ }
+ else
+ if (t1 < t3)
+ {
+ M[ am+LONGLINK ] = t2;
+ M[ am+SHORTLINK ] = 0;
+ if (t4 == 0) thisp->headk = am;
+ else M[ t4+LONGLINK ] = am;
+ break;
+ }
+ else
+ {
+ t4 = t2;
+ t2 = M[ t2+LONGLINK ];
+ }
+ }
+ }
+}
+
+
+void disp(virt) /* Simple kill. */
+virtaddr *virt;
+{
+ word t1, t2;
+
+ t1 = M[ virt->addr+1 ];
+ if (t1 == virt->mark) /* not none */
+ {
+ t1++; /* advance mark */
+ t2 = M[ virt->addr ]; /* am */
+ M[ virt->addr+1 ] = t1;
+ if (t1 != MAXMARKER) /* mark still usable */
+ {
+ M[ virt->addr ] = thisp->freeitem;
+ thisp->freeitem = virt->addr;
+ } /* now dictionary item is released */
+ if (t2+M[ t2 ]-1 == thisp->lastused) /* on the boundary */
+ thisp->lastused = t2-1;
+ else sinsert(t2);
+ }
+} /* end disp */
+
+
+word memavail() /* Compute available memory size */
+{
+ word t1, t2, avail;
+
+ avail = thisp->lastitem-thisp->lastused-1; /* contiguos memory */
+ t1 = thisp->headk2; /* go through killed 2 list */
+ while (t1 != 0)
+ {
+ avail += 2;
+ t1 = M[ t1+SHORTLINK ];
+ }
+ t1 = thisp->headk;
+ while (t1 != thisp->lower) /* go through killed object list */
+ {
+ t2 = t1;
+ while (t2 != 0)
+ {
+ avail += M[ t2 ];
+ t2 = M[ t2+SHORTLINK ];
+ }
+ t1 = M[ t1+LONGLINK ];
+ }
+ t1 = thisp->freeitem; /* go through free item list */
+ while (t1 != 0)
+ {
+ avail += 2;
+ t1 = M[ t1 ];
+ }
+ return(avail);
+} /* end memavail */
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include "nonstand.h"
+
+/* Call (non)standard procedures.
+ * Almost totaly implementation dependent.
+ */
+
+bool graphmode = FALSE; /* TRUE iff graphics mode active */
+
+
+#ifndef NO_GRAPH
+# if DJE
+# include "svga1.c"
+# elif MSDOS
+# include "dosgraf1.c"
+# elif UNIX
+# include "x11graf1.c"
+# endif
+#endif
+
+
+
+void nonstandard(nrproc) /* Call (non)standard procedure */
+word nrproc;
+{
+
+ word am;
+ int cnt=0;
+ float r1, r2;
+ word ax,bx,cx,dx,i,t1,t2;
+ unsigned int v,p,h,l,r,c;
+ unsigned int Res_graph_X,Res_graph_Y;
+
+ switch ((int) nrproc)
+ {
+
+
+#ifndef NO_GRAPH
+# if DJE
+# include "svga2.c"
+# elif MSDOS
+# include "dosgraf2.c"
+# elif OS2
+# include "os2graf2.c"
+# elif UNIX
+# include "x11graf2.c"
+# else only /*INKEY defined */
+ case INKEY:
+ param[ 0 ].xword = inkey();
+ break;
+# endif
+#endif
+
+ default :
+ errsignal(RTEUNSTP);
+ }
+}
+
--- /dev/null
+/* Standard class IIUWGRAPH graphics primitives
+
+GRON:procedure(mode:integer)
+GROFF:procedure
+CLS:procedure
+POINT:procedure(x, y:integer)
+MOVE:procedure(x, y:integer)
+DRAW:procedure(x, y:integer)
+HFILL:procedure(x:integer)
+VFILL:procedure(y:integer)
+COLOR:procedure(color:integer)
+STYLE:procedure(style:integer)
+PATERN:procedure(p1, p2, p3, p4:integer)
+INTENS:procedure(intens:integer)
+PALLET:procedure(p:integer)
+BORDER:procedure(b:integer)
+VIDEO:procedure(buffer:arrayof integer)
+HPAGE:procedure(p, q, r:integer)
+NOCARD:function:integer
+PUSHXY:procedure
+POPXY:procedure
+INXPOS:function:integer
+INYPOS:function:integer
+INPIX:function(x, y:integer):integer
+GETMAP:function(x, y:integer):arrayof integer
+PUTMAP:procedure(arrayof integer)
+ORMAP:procedure(arrayof integer)
+XORMAP:procedure(arrayof integer)
+TRACK:procedure(x, y:integer)
+INKEY:function:integer
+HASCII:procedure(ch:integer)
+HFONT:procedure(off, seg:integer)
+HFONT8:procedure(output off, seg:integer)
+OUTSTRING:procedure(s:string)
+CIRB:procedure(x, y, r:integer, alpha, beta:real, b, i, p, q:integer)
+
+*/
+
+#define GRON 100
+#define GROFF 101
+#define CLS 102
+#define POINT 103
+#define MOVE 104
+#define DRAW 105
+#define HFILL 106
+#define VFILL 107
+#define COLOR 108
+#define STYLE 109
+#define PATERN 110
+#define INTENS 111
+#define PALETT 112
+#define BORDER 113
+#define VIDEO 114
+#define HPAGE 115
+#define NOCARD 116
+#define PUSHXY 117
+#define POPHXY 118
+#define INXPOS 119
+#define INYPOS 120
+#define INPIX 121
+#define GETMAP 122
+#define PUTMAP 123
+#define ORMAP 124
+#define XORMAP 125
+#define TRACK 126
+#define INKEY 127
+#define HASCII 128
+#define HFONT 129
+#define HFONT8 130
+#define OUTSTRING 131
+#define CIRB 132
+
+
+/* Standard class MOUSE mouse support
+
+INIT:function(output butttons:integer):boolean
+SHOWCURSOR:procedure
+HIDECURSOR:procedure
+STATUS:procedure(output x,y:integer, l,r,c:boolean)
+SETPOSITION:procedure(x, y:integer)
+GETPRESS:procedure(b:integer; output x,y,p:integer, l, r, c:boolean)
+GETRELEASE:procedure(b:integer; output x,y,p:integer, l, r, c:boolean)
+SETWINDOW:procedure(l, r, t, b:integer)
+DEFCURSOR:procedure(select, p, q:integer)
+GETMOVEMENT:procedure(output x, y:integer)
+SETSPEED:procedure(x, y:integer)
+SETMARGINS:procedure(l, r, t, b:integer)
+SETTHRESHOLD:procedure(t:integer)
+
+*/
+
+
+#define INIT 200
+#define SHOWCURSOR 201
+#define HIDECURSOR 202
+#define STATUS 203
+#define SETPOSITION 204
+#define GETPRESS 205
+#define GETRELEASE 206
+#define SETWINDOW 207
+#define DEFCURSOR 210
+#define GETMOVEMENT 211
+#define SETSPEED 215
+#define SETMARGINS 216
+#define SETTHRESHOLD 219
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+/* object management routines */
+
+
+void openrc(prot, virt, addr) /* Open new field for a record. */
+word prot;
+virtaddr *virt;
+word *addr;
+{
+ word t1;
+
+ request(prototype[ prot ]->appetite, &t1, addr);
+ M[ *addr+PROTNUM ] = prot;
+ virt->addr = t1;
+ virt->mark = M[ t1+1 ];
+} /* end openrc */
+
+
+void slopen(prot, sladr, ah, am)
+word prot;
+virtaddr *sladr;
+word *ah, *am;
+{
+ word t1, t2, virts;
+
+ virts = thisp->prochead+M[ thisp->prochead ]+VIRTSC;
+ storevirt(*sladr, virts); /* preserve for compactifier */
+ t1 = prototype[ prot ]->appetite;
+
+ request(t1, ah, am); /* open field */
+
+ M[ *am+PROTNUM ] = prot;
+ t1 = *am+t1; /* LWA+1 of object */
+ M[ t1+SL ] = M[ virts ]; /* prepare SL pointer */
+ M[ t1+SL+1 ] = M[ virts+1 ];
+ t2 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */
+ M[ t1+DL ] = t2;
+ M[ t1+DL+1 ] = M[ t2+1 ];
+
+} /* end slopen */
+
+
+void openobj(prot, ah, am)
+word prot;
+word *ah, *am;
+{
+ virtaddr v1;
+ word t1;
+
+ t1 = M[ display2+prototype[ prot ]->slprototype ];
+ v1.addr = t1; /* ah of SL */
+ v1.mark = M[ t1+1 ];
+ slopen(prot, &v1, ah, am);
+} /* end openobj */
+
+
+void newarry(low, up, kind, virt, am) /* Reserve room for array */
+word low, up, kind;
+virtaddr *virt;
+word *am;
+{
+ word ap;
+
+ switch ((int) kind)
+ {
+ case AINT : ap = APINT; break;
+ case AREAL : ap = APREAL; break;
+ case AVIRT : ap = APREF; break;
+ case APROCESS : ap = APINT; break;
+ }
+ low *= ap;
+ up *= ap;
+ if (up < low) errsignal(RTEILLAB); /* illegal array bounds */
+ low -= 3;
+ request(up-low+ap, &virt->addr, am);
+ M[ *am+1 ] = kind;
+ M[ *am+2 ] = low;
+ virt->mark = M[ virt->addr+1 ];
+} /* end newarry */
+
+
+void gkill(virt) /* Generalized killer */
+virtaddr *virt;
+{
+ word t1, t2, t3;
+ virtaddr vt;
+ protdescr *ptr;
+ message msg;
+
+ if (isprocess(virt)) /* kill remote process */
+ {
+ msg.control.type = KILLPR;
+ obj2mess( M, virt, &msg.control.receiver );
+ sendmsg1( &msg);/* send remote kill request */
+ }
+ else
+ if (virt->mark == M[ virt->addr+1 ])
+ {
+ t1 = M[ virt->addr ]; /* am */
+ t2 = M[ t1+PROTNUM ];
+ if (t2 == AINT || t2 == AREAL || t2 == AVIRT)
+ disp(virt); /* simple kill for array */
+ else
+ if (t2 == FILEOBJECT)
+ { /* First close file if opened */
+ if (M[ t1+FSTAT ] != UNKNOWN)
+ if (fclose(MF(t1+FFILE))) errsignal(RTEILLIO);
+ /* Delete file if temporary */
+ if (M[ t1+FTEMP ] == LTRUE)
+ if (unlink(MN(t1+FNAME))) errsignal(RTEILLIO);
+ free(MN(t1+FNAME));
+ disp(virt);
+ }
+ else /* more than array or file */
+ {
+ ptr = prototype[ t2 ];
+ if (ptr->kind == RECORD)
+ disp(virt);
+ else
+ {
+ t3 = t1;
+ do
+ {
+ t3 += M[ t3 ]; /* LWA of object */
+ if (M[ t3+STATSL ] != 0) errsignal(RTEILLKL);
+ t3 = M[ t3+DL ]; /* next object in DL */
+ if (t3 == 0) errsignal(RTEILLKL);
+ t3 = M[ t3 ]; /* am of DL */
+ } while (t3 != t1);
+ do /* kill DL chain */
+ {
+ t3 += M[ t3 ];
+ loadvirt(vt, t3+DL);
+ disp(virt);
+ virt->addr = vt.addr;
+ virt->mark = vt.mark;
+ t3 = M[ virt->addr ];
+ } while (M[ virt->addr+1 ] == virt->mark);
+ }
+ }
+ }
+} /* end gkill */
+
+
+/* Copy object to a new object and locate it by fresh.
+ */
+
+void copy(old, fresh)
+virtaddr *old, *fresh;
+{
+ word t1, t2, t3, virts;
+ protdescr *ptr;
+ bool notrecord;
+
+ if (M[ old->addr+1 ] != old->mark)
+ { /* fine copy for none */
+ fresh->addr = 0;
+ fresh->mark = 0; /* note M[ 1 ] <> 0 */
+ }
+ else /* not none */
+ {
+ t1 = M[ old->addr ]; /* am of old */
+ notrecord = FALSE; /* assume it is a record */
+ t2 = M[ t1+PROTNUM ];
+ if (t2 != AINT && t2 != AREAL && t2 != AVIRT && t2 != FILEOBJECT)
+ { /* if not array nor file */
+ ptr = prototype[ t2 ];
+ if (ptr->kind != RECORD) /* our assumption was wrong */
+ {
+ notrecord = TRUE;
+ t3 = t1+M[ t1 ]+DL;
+ if (M[ t3 ] != old->addr || M[ t3+1 ] != old->mark)
+ errsignal(RTEILLCP); /* non-terminated object */
+ }
+ }
+ virts = thisp->prochead+M[ thisp->prochead ]+VIRTSC;
+ storevirt(*old, virts); /* preserve for compactification */
+ request(M[ t1 ], &t2, &t3); /* book field */
+ fresh->addr = t2; /* ah */
+ fresh->mark = M[ fresh->addr+1 ];
+ t1 = M[ M[ virts ] ];
+ for (t2 = 1; t2 < M[ t1 ]; t2++ )
+ M[ t3+t2 ] = M[ t1+t2 ];
+ if (notrecord)
+ {
+ storevirt(*fresh, t3+M[ t3 ]+DL); /* loop up DL */
+ M[ t3+M[ t3 ]+STATSL ] = 0; /* not in any SL chain */
+ }
+ }
+} /* end copy */
--- /dev/null
+ case INKEY :
+ param[ 0 ].xword = inkey(NULL);
+ break;
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include <assert.h>
+
+#define ldnode(addr) ((word) (addr & 0xFF))
+#define ldpix(addr) ((word) ((addr >> 8) & 0xFF))
+#define staddr(node, pix) ((word) ((pix << 8) | node))
+
+
+/*
+ These are converters from global to process pointers in memory
+ to global process pointers in message.
+ M denotes memory in which pair (pointer,object) exists or has to exist.
+ We want to create object denoting remote process instead of
+ dummy pointer without object.
+ The object will be like an arrayof integer of size 2.
+ arr[1..3] : arr[1]=node, arr[2]=pix.
+*/
+
+void obj2mess(M,obj,mess)
+ word *M;
+ virtaddr *obj;
+ procaddr *mess;
+{
+#ifdef OBJECTADDR
+ word am;
+ if( obj->mark != M[obj->addr+1] ){
+ mess->node=-1;
+ mess->pix =-1;
+ mess->mark=-1;
+ }else{
+ am=M[obj->addr];
+ mess->node=M[am+2];
+ mess->pix =M[am+3];
+ mess->mark=M[am+4];
+ }
+#else
+ mess->node=ldnode(obj->addr);
+ mess->pix =ldpix (obj->addr);
+ mess->mark=obj->mark;
+#endif
+}
+
+void mess2obj(p,mess,obj)
+ procdescr *p;
+ procaddr *mess;
+ virtaddr *obj;
+{
+
+#ifdef OBJECTADDR
+
+ word am;
+ word *currM=M;
+ word currpix=thispix;
+
+ extern int compactify_allowed;
+ compactify_allowed=0;
+ transfer(p-process);
+ hash_find(mess,obj);
+/*
+ newarry(1,4,APROCESS,obj,&am);
+ M[am+2]=mess->node;
+ M[am+3]=mess->pix;
+ M[am+4]=mess->mark;
+*/
+ transfer(currpix);
+ M=currM;
+
+ compactify_allowed=1;
+
+#else
+ obj->addr=staddr(mess->node,mess->pix);
+ obj->mark=mess->mark;
+
+#endif
+
+}
+
+
+
+bool isprocess(v) virtaddr *v; {
+
+#ifdef OBJECTADDR
+
+ word am=M[v->addr];
+/* assert(v->mark<=M[v->addr+1]);*/
+ if( v->mark!=M[v->addr+1] ) return 0;
+ else return ( M[am+1]==APROCESS );
+
+#else
+
+ return ( v->mark < 0 );
+
+#endif
+
+}
+
+
+
+#ifdef OBJECTADDR
+
+/* hash entry is a word pointing to dictionary or 0 if empty */
+
+#ifndef NO_PROTOTYPES
+static int hash_check_item( word, procaddr * );
+static void hash_new_item( virtaddr *, procaddr * );
+static int hash_mess( procaddr * );
+static int hash_2( int );
+#else
+static int hash_check_item();
+static void hash_new_item();
+#endif
+
+void hash_create(p,size) procdescr *p; int size;{
+ /* create hash table for p process */
+ int i;
+ if( p->hash!=NULL ) free( p->hash );
+ p->hash_size = size;
+ p->hash = mallocate(size);
+ if( p->hash==NULL ) errsignal(RTEMEMOV);
+ for( i=0; i<p->hash_size; i++ ) p->hash[i]=0;
+}
+
+
+/* find pointer in hash table, add if not exists */
+
+void hash_find(mess,obj) procaddr *mess; virtaddr *obj; {
+ int i,first,jump;
+ word am;
+ first=hash_mess( mess );
+ jump=hash_2(first);
+ for( i=first; thisp->hash[i]!=0; ){
+ if( hash_check_item(thisp->hash[i],mess) ){
+ obj->addr=thisp->hash[i];
+ obj->mark=M[thisp->hash[i]+1];
+ return;
+ }
+ i=(i+jump)%thisp->hash_size;
+ if( i==first ){
+ int *curhash=thisp->hash;
+ int cursize=thisp->hash_size;
+errsignal(RTEMEMOV); /* the rest is not debugged yet */
+ thisp->hash_size = cursize*3-1;
+ thisp->hash = mallocate(thisp->hash_size);
+ if( thisp->hash==NULL ) errsignal(RTEMEMOV);
+ for( i=0; i<thisp->hash_size; i++ ) thisp->hash[i]=0;
+ for( i=0; i<cursize; i++ ){
+ if( curhash[i]!=0 ){
+ virtaddr obj;
+ procaddr mess;
+ obj.addr=curhash[i];
+ obj.mark=M[curhash[i]+1];
+ obj2mess(M,&obj,&mess);
+ hash_set(&mess,curhash[i]);
+ }
+ }
+ hash_new_item( obj, mess );
+ hash_set( mess, obj->addr );
+ return;
+ }
+ }
+ /* not exists yet */
+ hash_new_item( obj, mess );
+ thisp->hash[i]=obj->addr;
+}
+
+void hash_set(mess,ah) procaddr *mess; word ah;{
+ int i,first,jump;
+ word am;
+ first=hash_mess( mess );
+ jump=hash_2(first);
+ for( i=first; thisp->hash[i]!=0; ){
+ assert( !hash_check_item(thisp->hash[i],mess) );
+ i=(i+jump)%thisp->hash_size;
+ if( i==first ) errsignal(RTEMEMOV);
+ }
+ /* not exists yet */
+ assert( thisp->hash[i]==0 );
+ thisp->hash[i]=ah;
+}
+
+#endif
+
+
+static int hash_check_item( ah, mess ) word ah; procaddr *mess; {
+ word am=M[ah];
+ return ( mess->node==M[am+2] && mess->pix==M[am+3] && mess->mark==M[am+4] );
+}
+
+static void hash_new_item( obj, mess ) virtaddr *obj; procaddr *mess; {
+ word am;
+ newarry(1,4,APROCESS,obj,&am);
+ M[am+2]=mess->node;
+ M[am+3]=mess->pix;
+ M[am+4]=mess->mark;
+}
+
+static int hash_mess( mess ) procaddr *mess;{
+ word hash=mess->pix;
+ hash *= abs( mess->mark );
+ hash += mess->node;
+ return hash % (thisp->hash_size);
+}
+
+static int hash_2( hash_1 ) int hash_1;{
+ return thisp->hash_size -2 - ( hash_1 % ( thisp->hash_size -2 ) );
+}
+
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#if DLINK
+# include "dlink.h"
+#elif TCPIP
+# include "tcpip.h"
+#endif
+
+#include <assert.h>
+
+
+/* Process management */
+
+procdescr process[ MAXPROCESS ]; /* process descriptor table */
+procdescr *thisp; /* pointer to current process descr */
+word thispix; /* current process index */
+queue ready; /* Round-Robin queue */
+bool network; /* TRUE if operating in network */
+message globmsgqueue[ MAXMSGQUEUE ]; /* queue of waiting messages */
+int msgready = 0; /* number of waiting messages */
+int msghead = 0, msgtail = 0; /* pointers to message queue */
+word ournode; /* this machine node number */
+word console; /* console node number */
+bool remote = FALSE; /* TRUE if remote node */
+bool reschedule = TRUE; /* TRUE if must re-schedule */
+
+
+
+#ifndef NO_PROTOTYPES
+static void ansprot(message *);
+static void localkill(message *);
+void transfer(word);
+static void backcreate(message *);
+static void createprocess(message *);
+static void localerror(message *);
+static void killprocess(word);
+static void mkglobal(word);
+word pix, ref;
+#else
+static void ansprot();
+static void localkill();
+void transfer();
+static void backcreate();
+static void createprocess();
+static void localerror();
+static void killprocess();
+static void mkglobal();
+#endif
+
+
+
+#if OS2
+PGINFOSEG ginf; /* pointer to Global Info Segment */
+#endif
+
+
+#if USE_ALARM
+# include <signal.h>
+# ifndef NO_PROTOTYPES
+ static void signal_catch( void );
+# else
+ static void signal_catch();
+# endif
+ static void signal_catch(){ reschedule=TRUE; }
+#endif
+
+
+void init_scheduler(){
+#if USE_ALARM
+ signal(SIGALRM,signal_catch);
+ alarm(1);
+#endif
+}
+
+void schedule() /* Choose next ready process to exec */
+{ /* STRONGLY machine dependent */
+#if USE_ALARM
+ if(reschedule){
+ alarm(0);
+ signal(SIGALRM,signal_catch);
+ alarm(1);
+#elif USE_CLOCK
+ static char last;
+ char c;
+ c = clock() >> 5; /* the most expensive method */
+ if (reschedule || c != last) /* context switch is needed */
+ {
+ last = c;
+#elif MSDOS && ( WORD_16BIT || DWORD_16BIT ) /* DOS real memory model */
+ static char last;
+ char c;
+ static char *clk = (char *) 0x0040006CL;
+ c = *clk >> 1;
+ if (reschedule || c != last) /* context switch is needed */
+ {
+ last = c;
+#elif OS2
+ static char last;
+ char c;
+ c = ginf->hundredths >> 3;
+ if (reschedule || c != last) /* context switch is needed */
+ {
+ last = c;
+#else
+#error Scheduler time counting method not implemented !
+#endif
+
+#if TCPIP
+ while (qempty(ready)){ /* wait for event if no processes */
+ tcpip_poll( -1 ); /* wait for message until arrives */
+ trapmsg();
+ }
+#else
+ while (qempty(ready)) /* wait for event if no processes */
+ trapmsg();
+#endif
+ ready = qrotate(ready); /* find another ready process */
+ transfer(pfront(ready)); /* transfer control to it */
+ reschedule = FALSE;
+ }
+}
+
+
+void transfer(pix) /* Context switch to another process */
+word pix;
+{
+ word apt;
+ if (pix == thispix) return; /* optimized for case of one process */
+
+ if( thisp != NULL ) /* previous process is alive */
+ {
+ thisp->ic = ic; /* store previous context */
+ thisp->c1 = c1;
+ thisp->c2 = c2;
+ }
+ thispix = pix; /* and load new context */
+ thisp = &process[ thispix ];
+ ic = thisp->ic;
+ c1 = thisp->c1;
+ c2 = thisp->c2;
+ M = thisp->M;
+ param = thisp->param;
+ apt = thisp->prochead+M[ thisp->prochead ];
+ display = apt+dispoff;
+ display2 = apt+disp2off;
+}
+
+
+void activate(pix) /* Resume process on this node */
+word pix;
+{
+ process[ pix ].status = EXECUTING; /* flag process as ready to execute */
+ ready = pinsert(ready, pix); /* insert into ready queue */
+ reschedule = TRUE; /* force context switch */
+# ifdef RPCDBG
+ fprintf(stderr,"activate process %d\n",pix);
+# endif
+}
+
+
+void passivate(newstatus) /* Passivate process */
+int newstatus;
+{
+ thisp->status = newstatus; /* change to some wait status */
+ ready = qremove(ready); /* remove from ready queue */
+ reschedule = TRUE; /* force context switch */
+# ifdef RPCDBG
+ fprintf(stderr,"passivate process %d to state %d\n",thispix,newstatus);
+# endif
+}
+
+
+/* Copy parameters from object to message or vice versa. */
+
+
+void moveparams(pix, am, msg, par1, dir)
+ word pix, am;
+ message *msg;
+ int par1, dir;
+{
+ protdescr *ptr;
+ procdescr *p;
+ word i, tpd, ap, pd, prim, offset;
+ char *cp;
+ bool cflag, convert;
+
+ p = &process[ pix ];
+ ptr = prototype[ p->M[ am+PROTNUM ] ];
+ cp = (char *) msg->params;
+
+ for (i = 0; i < ptr->lthparlist; i++) /* loop through parameters */
+ {
+
+ offset = M[ ptr->parlist+i ];
+ tpd = M[ ptr->pfdescr+i ]; /* type description of param */
+ pd = M[ tpd ];
+
+ if (par1 == PARIN)
+ cflag = ( pd==PARIN || pd==PARINOUT || pd==FORMFUNC || pd==FORMPROC );
+ else
+ cflag = ( pd==PAROUT || pd==PARINOUT );
+
+ if (cflag)
+ {
+ if (pd == FORMFUNC || pd == FORMPROC)
+ {
+ ap = APFMPROC;
+ convert = TRUE;
+ }
+ else
+ if (M[ M[ tpd+2 ] ] == CLASSTYPE)
+ {
+ ap = APREF;
+ convert = TRUE;
+ }
+ else
+ {
+ prim = M[ tpd+2 ]-ipradr;
+ ap = primapet[ prim ];
+ convert = (prim == 4 || prim == 5); /* process or coroutine */
+ }
+
+ ap *= sizeof(word); /* param appetite in bytes */
+
+ switch (dir) /* copy parameter in right direction */
+ {
+
+ case LOADPAR :
+
+ /* we always load parameters from OUR process */
+ assert(pix==thispix);
+
+ if (convert){
+ procaddr pa;
+ {
+ word ah=M[am+offset];
+ if( !isprocess((virtaddr*)(M+am+offset)) &&
+ M[ ah+1 ] == M[ am+offset+1 ]
+ )
+ if (prototype[ M[ M[ ah ]+PROTNUM ] ]->kind == PROCESS)
+ {
+ pa.node = ournode;
+ pa.pix = pix;
+ pa.mark = thisp->mark;
+ }
+ else
+ /*pat errsignal(RTENONGL); */ /* only process may be global */
+ /*pat*/ obj2mess(p->M,(virtaddr*)(p->M+am+offset),&pa);
+ else
+ obj2mess(M,(virtaddr*)(M+am+offset),&pa);
+ }
+/*
+ mkglobal(am+offset);
+ obj2mess(p->M,(virtaddr*)(p->M+am+offset),&pa);
+*/
+ moveblock((char *)&pa, cp, ap=sizeof(procaddr));
+ }else
+ moveblock((char *) &p->M[ am+offset ], cp, ap);
+ break;
+
+
+ case SAVEPAR :
+
+ if (convert){
+ procaddr pa;
+ ap=sizeof(procaddr);
+ moveblock(cp,(char *)&pa, ap);
+ mess2obj(p,&pa,(virtaddr*)(p->M+am+offset));
+ }else
+ moveblock(cp, (char *) &p->M[ am+offset ], ap);
+ break;
+
+ }
+
+ cp += ap;
+ assert(cp-msg->params <= sizeof(msg->params));
+ }
+ }
+}
+
+
+word getnode(am) /* Determine node number for process */
+word am;
+{
+ protdescr *ptr;
+ word p;
+ int i;
+
+ p = prototype[ M[ am+PROTNUM ] ]->preflist;
+ while (prototype[ M[ p ] ]->kind != PROCESS) p++;
+ ptr = prototype[ M[ p ] ];
+ if (ptr->lthpreflist == 1) i = 0;
+ else i = prototype[ M[ p-1 ] ]->lthparlist;
+ return (M[ am+M[ ptr->parlist+i ] ]);
+}
+
+
+void resume(virt) /* Perform RESUME instruction */
+virtaddr *virt;
+{
+ message msg;
+
+ if (isprocess(virt)) /* is it process realy ? */
+ {
+ msg.control.type = RESUME;
+ obj2mess( M, virt, &msg.control.receiver );
+ sendmsg1( &msg); /* request remote resume */
+ }
+ else errsignal(RTEILLRS); /* illegal RESUME */
+}
+
+
+static void createprocess(msg) /* Create new process */
+message *msg;
+{
+ word i, prot;
+ for (i = 0; i < MAXPROCESS; i++) /* find unused process descr. */
+ if (!process[ i ].used && process[ i ].mark != -MAXMARKER) break;
+ if (i == MAXPROCESS) senderr(RTETMPRC, &(msg->control.sender) );
+ if (process[ i ].M == NULL) /* memory not allocated yet */
+ {
+ process[ i ].M = mallocate(memorysize+1);
+ if (process[ i ].M == NULL) senderr(RTEMEMOV, &msg->control.sender);
+ moveblock((char *) process[ 0 ].M, (char *) process[ i ].M,
+ freem * sizeof(word));
+ }
+ prot = msg->control.par; /* process prototype number */
+ initprocess(i, prot, &msg->control.sender);
+ moveparams(i, process[ i ].prochead, msg, PARIN, SAVEPAR);
+ process[ i ].status = GENERATING; /* execute process until RETURN */
+ ready = pinsert(ready, i);
+ reschedule = TRUE;
+}
+
+
+static void killprocess(pix) /* Release process descriptor */
+word pix;
+{
+ qfree(process[ pix ].msgqueue);
+ qfree(process[ pix ].rpcwait);
+ sfree(process[ pix ].rpcmask);
+
+ process[ pix ].used = FALSE; /* mark descriptor as unused */
+ process[ pix ].mark--; /* decrement marker */
+
+ if( pix == thispix )
+ {
+ thispix = -1;
+ thisp = NULL;
+ }
+}
+
+
+static void localkill(msg)
+message *msg;
+{
+ word pix;
+
+ pix = msg->control.receiver.pix;
+
+# if RPCDBG
+ fprintf( stderr, "kill process %d\n", pix );
+# endif
+
+ if (process[ pix ].mark == msg->control.receiver.mark) /* not none */
+ {
+ if (process[ pix ].status != STOPPED) /* is process suspended ? */
+ senderr(RTEILLKL, &msg->control.sender);
+ killprocess(pix);
+ }
+}
+
+
+void endprocess(status) /* Terminate current process */
+int status;
+{
+ int i;
+
+ passivate(STOPPED);
+# if RPCDBG
+ fprintf( stderr, "terminate process %d\n", thispix );
+# endif
+ killprocess(thispix);
+ if( ournode != console ) longjmp(contenv, 1);
+ for (i = 0; i < MAXPROCESS; i++)
+ if (process[ i ].used) longjmp(contenv, 1);
+ endrun(status);
+}
+
+
+static void backcreate(msg)
+message *msg;
+{
+ word pix, am;
+ procdescr *p;
+
+ pix = msg->control.receiver.pix;
+ p = &process[ pix ];
+
+ am = p->M[ p->template.addr ]; /* template physical address */
+ p->M[ temporary ] = am;
+ moveparams(pix, am, msg, PAROUT, SAVEPAR);
+
+ /*store new process address */
+ mess2obj(p,&(msg->control.sender),&(p->backobj));
+
+ activate(pix); /* end of waiting for NEW */
+}
+
+
+void senderr(exception, virt)
+int exception;
+procaddr *virt;
+{
+ message msg;
+
+ msg.control.type = ERRSIG;
+ msg.control.receiver=*virt;
+ msg.control.par = exception;
+ sendmsg1(&msg); /* send error message */
+ longjmp(contenv, 1); /* continue from next instruction */
+}
+
+
+static void localerror(msg)
+message *msg;
+{
+ word pix;
+ int s;
+
+ pix = msg->control.receiver.pix;
+ s = process[ pix ].status;
+ if (process[ pix ].mark == msg->control.receiver.mark && s != STOPPED)
+ {
+ if (s == WAITFORNEW || s == WAITFORRPC) activate(pix);
+ while (pfront(ready) != pix)
+ ready = qrotate(ready);
+ transfer(pfront(ready));
+ errsignal(msg->control.par);
+ }
+}
+
+
+void askprot(virt) /* Ask for prototype of object */
+virtaddr *virt;
+{
+ word am;
+ message msg;
+
+ if (isprocess(virt)) /* send question to remote process */
+ {
+ obj2mess( M, virt, &msg.control.receiver );
+ msg.control.type = ASKPRO;
+ sendmsg1( &msg );
+ passivate(WAITASKPRO);
+ }
+ else
+ {
+ if (member(virt, &am))
+ M[ temporary ] = M[ am+PROTNUM ];
+ else errsignal(RTEREFTN);
+ }
+}
+
+
+static void ansprot(msg) /* Answer with prototype of process */
+message *msg;
+{
+ message msg1;
+ word pix;
+
+ pix = msg->control.receiver.pix;
+ if (process[ pix ].mark == msg->control.receiver.mark) /* not none */
+ {
+ msg1.control.receiver = msg->control.sender;
+ msg1.control.type = PROACK;
+ msg1.control.par = process[ pix ].prot;
+ sendmsg1( &msg1 );
+ }
+ else senderr(RTEREFTN, &msg->control.sender);
+}
+
+
+/* Message send/receive handling : */
+
+void msginterrupt(msg) /* Receive message interrupt handler */
+ message *msg;
+{
+ moveblock((char *)msg, (char *)&globmsgqueue[ msgtail ],
+ (word) sizeof(message));
+ msgtail = (msgtail+1) % MAXMSGQUEUE;
+ msgready++;
+#if DLINK
+ if (msgready < MAXMSGQUEUE-1) /* leave one place for own message */
+ net_attention();
+#endif
+}
+
+
+void sendmsg1(msg) /* Send message via net */
+message *msg;
+{
+ msg->control.sender.node = ournode;
+ msg->control.sender.pix = thispix;
+ msg->control.sender.mark = thisp->mark;
+ if(
+ msg->control.receiver.node == ournode
+ ||
+ msg->control.receiver.node == 0
+ )
+ /* simulate receive message interrupt */
+ {
+#if DLINK
+ net_ignore(); /* disable attention */
+#endif
+ msg->control.receiver.node == ournode;
+ msginterrupt(msg); /* call directly interrupt handler */
+ }
+ else
+ {
+#if DLINK
+ if (!network) errsignal(RTEINVND); /* send message by net */
+ while (net_send((int) msg->control.receiver.node, msg)) ;
+#elif TCPIP
+ if (!network) errsignal(RTEINVND); /* send message by net */
+ tcpip_send( msg );
+#else
+ errsignal(RTEINVND);
+#endif
+ }
+}
+
+
+void trapmsg() /* Check for waiting message */
+{
+ message *msg;
+ procdescr *p;
+ word pix;
+
+#if TCPIP
+ /* check for message on TCPIP socket & move to queue */
+ if (msgready < MAXMSGQUEUE-1) /* there is place for new message */
+ if( tcpip_poll( 0 ) ) /* check for message */
+ if ( tcpip_recv( globmsgqueue + msgtail ) ){
+ msgtail = (msgtail+1) % MAXMSGQUEUE;
+ msgready++;
+ }
+#endif
+
+ if (msgready > 0) /* at least one message is waiting */
+ {
+#if DLINK
+ net_ignore(); /* disable attention for a moment */
+#endif
+ msg = &globmsgqueue[ msghead ]; /* get first message from queue */
+ msghead = (msghead+1) % MAXMSGQUEUE;
+#ifdef RPCDBG
+ printf("Received message %d\n",msg->control.type);
+ fflush(stdout);
+#endif
+ switch(msg->control.type)
+ {
+ case ERRSIG :
+ localerror(msg);
+ break;
+
+ case RESUME :
+ pix = msg->control.receiver.pix;
+ if (process[ pix ].mark != msg->control.receiver.mark)
+ senderr(RTEREFTN, &msg->control.sender);
+ if (process[ pix ].status != STOPPED)
+ senderr(RTEILLRS, &msg->control.sender);
+ activate(pix);
+ break;
+
+ case CREATE :
+ createprocess(msg);
+ break;
+
+ case CREACK :
+ backcreate(msg);
+ break;
+
+ case KILLPR :
+ localkill(msg);
+ break;
+
+ case RPCALL :
+ rpc1(msg);
+ break;
+
+ case RPCACK :
+ rpcend(msg);
+ break;
+
+ case ASKPRO :
+ ansprot(msg);
+ break;
+
+ case PROACK :
+ pix = msg->control.receiver.pix;
+ p = &process[ pix ];
+ p->M[ temporary ] = msg->control.par;
+ activate(pix);
+ break;
+
+ default :
+ fprintf( stderr, " Invalid message\n" );
+ senderr(RTESYSER, &msg->control.sender);
+ }
+ msgready--;
+#if DLINK
+ if (msgready < MAXMSGQUEUE-1) /* leave one place for own message */
+ net_attention(); /* attention back on */
+#endif
+ }
+}
+
+
+static void mkglobal(ref) /* Make global a process reference */
+ word ref;
+{
+ word ah;
+ ah = M[ ref ];
+ if (!isprocess((virtaddr*)(M+ref)) && M[ ah+1 ] == M[ ref+1 ])
+ if (prototype[ M[ M[ ah ]+PROTNUM ] ]->kind == PROCESS)
+ {
+ virtaddr va;
+ procaddr pa;
+ pa.node = ournode;
+ pa.pix = pix;
+ pa.mark = thisp->mark;
+ mess2obj(thisp,&pa,&va);
+ M[ ref ] = va.addr;
+ M[ ref+1 ] = va.mark;
+#ifdef RPCDBG
+fprintf(stderr,"mkglobal REAL (thisp=%d) isprocess:node=%d pix=%d mark=%d\n",thispix,pa.node,pa.pix,pa.mark);fflush(stderr);
+#endif
+ }
+ else errsignal(RTENONGL); /* only process may be global */
+}
+
+
+
+/*
+void show_m( char *s, message *msg ){
+ char *n;
+ switch(msg->control.type)
+ {
+ case ERRSIG : n = "ERRSIG"; break;
+ case RESUME : n = "RESUME"; break;
+ case CREATE : n = "CREATE"; break;
+ case CREACK : n = "CREACK"; break;
+ case KILLPR : n = "KILLPR"; break;
+ case RPCALL : n = "RPCALL"; break;
+ case RPCACK : n = "RPCACK"; break;
+ case ASKPRO : n = "ASKPRO"; break;
+ case PROACK : n = "PROACK"; break;
+ default : n = "??????"; break;
+ }
+#ifdef RPCDBG
+ printf( "message %s type %s from %d:%d:%d to %d:%d:%d\n",
+ s, n,
+ msg->control.sender.node,
+ msg->control.sender.pix,
+ msg->control.sender.mark,
+ msg->control.receiver.node,
+ msg->control.receiver.pix,
+ msg->control.receiver.mark
+ );
+ fflush( stdout );
+#endif
+}
+*/
+
--- /dev/null
+#include "queue.h"
+
+
+/* Process management definitions : */
+
+#define MAXPROCESS 64 /* maximum number of processes on one node */
+#define MAXMSGQUEUE 16 /* maximum number of waiting messages */
+
+#if DLINK
+#define MSGLENGTH 80 /* message length defined by D-Link driver */
+#elif TCPIP
+#define MSGLENGTH 256 /* message length defined by me (PS) */
+#else
+#define MSGLENGTH 256 /* message length defined by me (PS) */
+#endif
+
+
+/* Process state : */
+
+#define GENERATING 0 /* during generation of process object */
+#define STOPPED 1 /* non-active process (suspended by STOP) */
+#define EXECUTING 2 /* active process (ready to execute) */
+#define WAITFORNEW 3 /* waiting for NEW of another process */
+#define WAITFORRPC 4 /* waiting for remote procedure call */
+#define ACCEPTING 5 /* during execution of ACCEPT statement */
+#define WAITASKPRO 6 /* waiting for process prototype */
+
+/* Process descriptor : */
+
+typedef struct
+{
+ bool used; /* TRUE if in use by some process */
+ word mark; /* process mark for proper detecting of none */
+ int status; /* process state */
+ word prot; /* process prototype number */
+ memory M; /* pointer to memory array */
+ union value param[ MAXPARAM ];
+ word ic; /* instruction counter */
+ word trlnumber; /* trace line number */
+ word lower; /* first word of object area */
+ word upper; /* last word in memory */
+ word lastused; /* last word used by objects */
+ word lastitem; /* first word used by dictionary */
+ word freeitem; /* head of free dictionary item list */
+ word headk; /* head of killed object list for size > 2 */
+ word headk2; /* head of killed object list for size = 2 */
+ word prochead; /* am of process object */
+ virtaddr procref; /* process object virtual address */
+ virtaddr template; /* remote process or procedure template */
+ word c1, c2; /* pointers to current object */
+ virtaddr backobj; /* adress of object just left */
+ word blck1, blck2; /* used for LBLOCK1, LBLOCK2, LBLOCK3 */
+ queue msgqueue; /* queue of messages for this process */
+ queue rpcwait; /* queue of disabled RPC messages */
+ stack rpcmask; /* stack of set of enabled remote procedures */
+ bool force_compactification; /* next allocate will forace compact... */
+ word *hash; /* table of pointers to processes in process */
+ word hash_size;
+} procdescr;
+
+
+/* Message type : */
+
+#define ERRSIG 0 /* error signal */
+#define RESUME 1 /* resume request */
+#define CREATE 2 /* create new process request */
+#define CREACK 3 /* create process acknowledge */
+#define KILLPR 4 /* kill process */
+#define RPCALL 5 /* remote procedure call request */
+#define RPCACK 6 /* remote procedure return */
+#define ASKPRO 7 /* ask for process prototype */
+#define PROACK 8 /* answer with process prototype */
+
+typedef struct {
+ word node;
+ word pix;
+ word mark;
+} procaddr;
+
+struct ctrlmsg
+{
+ procaddr sender; /* address of the sender and */
+ procaddr receiver; /* receiver of the message */
+ int type; /* message type */
+ int par; /* prototype or error signal number */
+};
+
+#define MAXPROCPAR (MSGLENGTH-sizeof(struct ctrlmsg))
+
+typedef struct
+{
+ struct ctrlmsg control;
+ char params[ MAXPROCPAR ];
+} message;
+
+/* Direction of copying of parameters (for moveparams()) : */
+
+#define LOADPAR 0
+#define SAVEPAR 1
+
+typedef char *mask;
+
+extern procdescr process[]; /* process descriptor table */
+extern procdescr *thisp; /* pointer to current process descriptor */
+extern word thispix; /* current process index */
+extern queue ready; /* Round-Robin queue of ready processes */
+extern bool network; /* TRUE if operating in D-Link network */
+extern message globmsgqueue[]; /* queue of waiting messages */
+extern int msgready; /* number of waiting messages */
+extern int msghead, msgtail; /* pointers to message queue */
+extern word ournode; /* this machine node number */
+extern word console; /* console node number */
+extern bool remote; /* TRUE if remote node */
+extern bool reschedule; /* TRUE if rescheduling is mandatory */
+
+#if OS2
+extern PGINFOSEG ginf; /* pointer to Global Info Segment */
+#endif
+
+
+
+#ifndef NO_PROTOTYPES
+void obj2mess(word *,virtaddr *,procaddr*);
+void mess2obj(procdescr *,procaddr *,virtaddr*);
+bool isprocess(virtaddr *);
+void hash_find(procaddr *,virtaddr *);
+void hash_create(procdescr *,int);
+void hash_set(procaddr *,word);
+#else
+void obj2mess();
+void mess2obj();
+bool isprocess();
+void hash_find();
+void hash_create();
+void hash_set();
+#endif
+
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+
+/* Queue management */
+/* Single linked circular lists with queue represented as pointer to rear */
+
+queue qinit() /* Initialize empty queue */
+{
+ return (NULL);
+} /* end qinit */
+
+
+stack push(q, e) /* Insert element into the queue */
+stack q;
+selem e;
+{
+ stack p;
+
+ p = (stack) ballocate(sizeof(struct queuelem));
+ if (p == NULL) errsignal(RTEMEMOV);
+ p->elem = e;
+ if (q == NULL)
+ {
+ p->next = p; /* the lonely element of the queue */
+ q = p;
+ }
+ else
+ {
+ p->next = q->next; /* insert at rear */
+ q->next = p;
+ }
+ return(q);
+} /* end push */
+
+
+qelem qfront(q) /* Get first element of the queue */
+queue q;
+{
+ if (qempty(q)){
+ fprintf( stderr, "getting first element from empty queue\n");
+ errsignal(RTESYSER);
+ }
+ return (q->next->elem);
+} /* end qfront */
+
+
+queue qremove(q) /* Remove front element from the queue */
+queue q;
+{
+ queue p;
+
+ if (qempty(q)){
+ fprintf( stderr, "removing first element from empty queue\n");
+ errsignal(RTESYSER);
+ }
+ p = q->next;
+ q->next = q->next->next;
+ if (p == q) q = NULL; /* removing last element of the queue */
+ free(p);
+ return(q);
+} /* end qremove */
+
+
+queue qdelete(q, e) /* Delete arbitrary element */
+queue q;
+qelem e;
+{
+ queue p, r, s;
+
+ if (qempty(q)) return(q);
+ r = q;
+ p = r->next;
+ while (p->elem != e)
+ {
+ if (p == q) return(q);
+ r = p;
+ p = p->next;
+ }
+ r->next = p->next;
+ if (r == p) s = NULL;
+ else
+ if (p == q) s = r;
+ else s = q;
+ free(p);
+ return(s);
+} /* end qdelete */
+
+
+queue qrotate(q) /* Remove front and insert at rear */
+queue q;
+{
+ if (qempty(q)){
+ fprintf( stderr, "rotating empty queue\n");
+ errsignal(RTESYSER);
+ }
+ return (q->next);
+} /* end qrotate */
+
+
+void qfree(q)
+queue q;
+{
+ while (!qempty(q))
+ {
+ free(qfront(q));
+ q = qremove(q);
+ }
+} /* end qfree */
--- /dev/null
+/* Header for queue management module */
+
+typedef lword qelem;
+typedef qelem selem;
+struct queuelem { qelem elem;
+ struct queuelem *next;
+ };
+typedef struct queuelem *queue;
+typedef queue stack;
+
+#ifndef NO_PROTOTYPES
+queue qinit(void);
+stack push(stack,selem);
+qelem qfront(queue);
+queue qremove(queue);
+queue qdelete(queue,qelem);
+queue qrotate(queue);
+void qfree(queue);
+#else
+queue qinit();
+stack push();
+qelem qfront();
+queue qremove();
+queue qdelete();
+queue qrotate();
+void qfree();
+#endif
+
+#define qinsert(q, e) (((queue) push((stack) (q), (selem) (e)))->next)
+#define qempty(q) ((q) == NULL)
+#define pinsert(q, p) (qinsert(q, (qelem) (p)))
+#define pfront(q) ((word) qfront(q))
+#define minsert(q, m) (qinsert(q, (qelem) (m)))
+#define mfront(q) ((message *) qfront(q))
+#define mdelete(q, m) (qdelete(q, (qelem) (m)))
+#define mpush(q, m) ((queue) push((stack) q, (selem) m))
+#define sfree(s) qfree((queue) s)
+#define sinit qinit
+#define pop(s) ((stack) qremove((queue) s))
+#define top(s) ((selem) qfront((queue) s))
--- /dev/null
+@echo off
+:begin
+if "%1" == "" goto :end
+echo %1
+del %1
+shift
+goto :begin
+:end
+
--- /dev/null
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+
+#ifndef NO_PROTOTYPES
+static bool isenabled(word,word);
+static bool rpcready(word);
+static void bitaccess(word,word,int *,char *);
+static void dupmask(word);
+#else
+static bool isenabled();
+static bool rpcready();
+static void bitaccess();
+static void dupmask();
+#endif
+
+
+void rpc1(msg) /* preprocess RPC request */
+message *msg;
+{
+ word pix, prot;
+ procdescr *p;
+ message *msg1;
+
+ pix = msg->control.receiver.pix;
+ p = &process[ pix ];
+ if (p->mark != msg->control.receiver.mark)
+ senderr(RTEREFTN, &msg->control.sender);
+ msg1 = (message *) ballocate(sizeof(message));
+ if (msg1 == NULL) errsignal(RTEMEMOV);
+ moveblock((char *) msg, (char *) msg1, (word) sizeof(message));
+ prot = msg->control.par;
+ if (isenabled(pix, prot))
+ {
+ p->msgqueue = minsert(p->msgqueue, msg1);
+ if (p->status == ACCEPTING) activate(pix);
+ }
+ else p->rpcwait = minsert(p->rpcwait, msg1);
+}
+
+
+void rpc2()
+{
+ if (rpcready(thispix)) rpc3();
+}
+
+
+void rpc3() /* Actual remote procedure call */
+{
+ word prot, ah, am;
+ message *msg;
+
+ msg = mfront(thisp->msgqueue); /* remove first RPC message (enabled) */
+# ifdef RPCDBG
+ fprintf(
+ stderr, "rpc(thisp=%d) from: node=%d, pix=%d, mark=%d\n",
+ thispix,
+ msg->control.sender.node,
+ msg->control.sender.pix,
+ msg->control.sender.mark
+ );
+# endif
+ thisp->msgqueue = qremove(thisp->msgqueue);
+ pushmask(thispix); /* disable all procedures */
+ prot = msg->control.par;
+
+ slopen(prot, &thisp->procref, &ah, &am); /* open procedure object */
+
+ {
+ virtaddr v;
+ mess2obj( thisp, &(msg->control.sender), &v );
+ storevirt( v, am+M[ am ]+RPCDL ); /* set up remote DL */
+ }
+
+ moveparams(thispix, am, msg, PARIN, SAVEPAR);
+
+ go(ah, am); /* transfer control to procedure */
+
+ free(msg);
+
+}
+
+
+void rpcend(msg) /* After return from RPC */
+message *msg;
+{
+ word pix, am;
+ procdescr *p;
+
+ pix = msg->control.receiver.pix;
+#ifdef RPCDBG
+fprintf(stderr,"activate after rpc(thisp=%d)\n",pix);fflush(stderr);
+#endif
+ p = &process[ pix ];
+ am = p->M[ temporary ]; /* template physical address */
+ moveparams(pix, am, msg, PAROUT, SAVEPAR);
+ activate(pix); /* resume process waiting for RPC */
+}
+
+
+static void bitaccess(pix, prot, bytenr, bitmask)
+word pix, prot;
+int *bytenr;
+char *bitmask;
+{
+ int bitnr;
+
+ bitnr = prot-prototype[ process[ pix ].prot ]->maskbase;
+ *bytenr = bitnr / 8;
+ *bitmask = (char)(unsigned char)( 1 << (bitnr % 8) );
+}
+
+
+void enable(pix, prot) /* Enable remote procedure */
+word pix, prot;
+{
+ mask m;
+ int bytenr;
+ char bitmask;
+
+ m = top(process[ pix ].rpcmask);
+ bitaccess(pix, prot, &bytenr, &bitmask);
+ m[ bytenr ] |= bitmask;
+}
+
+
+void disable(pix, prot) /* Disable remote procedure */
+word pix, prot;
+{
+ mask m;
+ int bytenr;
+ char bitmask;
+
+ m = top(process[ pix ].rpcmask);
+ bitaccess(pix, prot, &bytenr, &bitmask);
+ m[ bytenr ] &= ~ bitmask;
+}
+
+
+static bool isenabled(pix, prot) /* Check if RPC allowed */
+word pix, prot;
+{
+ mask m;
+ int bytenr;
+ char bitmask;
+
+ m = top(process[ pix ].rpcmask);
+ bitaccess(pix, prot, &bytenr, &bitmask);
+ return( m[ bytenr ] & bitmask );
+}
+
+
+void pushmask(pix) /* Push empty RPC mask onto stack */
+word pix;
+{
+ mask m;
+ int i, size;
+
+ size = prototype[ process[ pix ].prot ]->masksize;
+ m = (mask) ballocate(size);
+ if (m == NULL) errsignal(RTEMEMOV);
+ for (i = 0; i < size; i++ ) m[ i ] = '\0'; /* disable all */
+ process[ pix ].rpcmask = push(process[ pix ].rpcmask, m);
+}
+
+
+static void dupmask(pix) /* Duplicate RPC mask from stack top */
+word pix;
+{
+ mask m;
+ int size;
+
+ size = prototype[ process[ pix ].prot ]->masksize;
+ m = (mask) ballocate(size);
+ if (m == NULL) errsignal(RTEMEMOV);
+ moveblock(top(process[ pix ].rpcmask), m, (word) size);
+ process[ pix ].rpcmask = push(process[ pix ].rpcmask, m);
+}
+
+
+void popmask(pix) /* Pop RPC mask from stack (restore) */
+word pix;
+{
+ mask m;
+
+ m = top(process[ pix ].rpcmask);
+ process[ pix ].rpcmask = pop(process[ pix ].rpcmask);
+ free((char *) m);
+}
+
+
+void evaluaterpc(pix) /* Check if any waiting RPC is enabled */
+word pix;
+{
+ queue q;
+ message *msg;
+
+ q = process[ pix ].rpcwait;
+ if (!qempty(q))
+ {
+ do
+ {
+ msg = mfront(q);
+ if (isenabled(pix, msg->control.par))
+ {
+ process[ pix ].msgqueue = mpush(process[ pix ].msgqueue, msg);
+ process[ pix ].rpcwait = mdelete(process[ pix ].rpcwait, msg);
+ return;
+ }
+ q = qrotate(q);
+ } while (q != process[ pix ].rpcwait);
+ }
+}
+
+
+void rpc_accept(length) /* Accept remote procedure call */
+word length;
+{
+ int i;
+
+ dupmask(thispix);
+ for (i = 0; i < length; i++)
+ enable(thispix, virtprot(M[ ic++ ]));
+ evaluaterpc(thispix);
+ if (!rpcready(thispix))
+ passivate(ACCEPTING);
+}
+
+
+static bool rpcready(pix)
+word pix;
+{
+ procdescr *p;
+ message *msg;
+ word prot;
+
+ p = &process[ pix ];
+ while (!qempty(p->msgqueue))
+ {
+ msg = mfront(p->msgqueue);
+ prot = msg->control.par;
+ if (isenabled(pix, prot)) return(TRUE);
+ p->msgqueue = qremove(p->msgqueue);
+ p->rpcwait = minsert(p->rpcwait, msg);
+ }
+ return(FALSE);
+}
+
+
+word virtprot(prot) /* Get actual prototype for virtual */
+word prot;
+{
+ bool sign;
+ word virtnr;
+
+ sign = (prot < 0);
+ prot = absolute(prot);
+ virtnr = prototype[ prot ]->virtnumber;
+ if (virtnr != -1) prot = M[ prototype[ thisp->prot ]->virtlist+virtnr ];
+ if (sign) return(-prot); else return(prot);
+}
+
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+
+/* Initialize memory structures for objects, main object and a few goodies
+ * more.
+ */
+
+void runsys()
+{
+ word apt, i;
+ procaddr father;
+
+ for (i = 0; i < MAXPROCESS; i++ ) /* initialize process descriptors */
+ {
+ process[ i ].used = FALSE; /* not used */
+ process[ i ].mark = -1; /* initial mark for processes */
+ process[ i ].M = NULL; /* memory not allocated */
+ process[ i ].hash = NULL;
+ }
+ process[ 0 ].M = M; /* always contains code */
+ dispoff = VIRTSC-(lastprot+1); /* DISPLAY offset in process object */
+ disp2off = dispoff-(lastprot+1); /* indirect DISPLAY offset */
+ ready = qinit(); /* initialize Round-Robin queue */
+ ranset(); /* init pseudo-random no. generator */
+
+#if OS2
+ {
+ SEL gsel, lsel;
+ DosGetInfoSeg(&gsel, &lsel);
+ ginf = MAKEPGINFOSEG(gsel);
+ }
+#endif
+
+ if (!remote) /* create main process */
+ {
+ father.node = 0; /* dummy DL for generated process */
+ father.pix = 0;
+ father.mark = 0;
+ thispix = 0; /* current process index */
+ thisp = &process[ thispix ]; /* current process descr pointer */
+ initprocess((word) 0, (word) MAINBLOCK, &father);
+ mainprog = thisp->prochead; /* am of main */
+ c1 = thisp->c1; /* pointers to current object */
+ c2 = thisp->c2;
+ ic = thisp->ic; /* instruction counter */
+ param = thisp->param; /* parameter vector */
+ apt = mainprog+M[ mainprog ]; /* LWA+1 of main */
+ display = apt+dispoff; /* DISPLAY in main */
+ display2 = apt+disp2off; /* indirect DISPLAY in main */
+ mnoff = 2; /* offset of variable mainprog */
+ storevirt(thisp->procref, mainprog+mnoff); /* init variable main */
+ M[ apt+STATSL ]++; /* flag main included in SL chain */
+ thisp->status = STOPPED;
+ activate(thispix); /* activate main process */
+ }
+ else /* remote */
+ {
+ thispix = 1; /* a dirty trick: set junk current */
+ thisp = &process[ thispix ]; /* process for first transfer() */
+ } /* (must save 'context' somewhere) */
+#if DLINK
+ net_attention();
+#endif
+}
+
+
+void initprocess(pix, prot, father) /* Initialize process descriptor */
+word pix, prot;
+procaddr *father;
+{
+ procdescr *p;
+ protdescr *ptr;
+ word i, j, ah, am, apt;
+
+#ifdef RPCDBG
+fprintf(stderr,"new process(n,p,m) (%d,%d,%d)",0,pix,process[pix].mark);
+fprintf(stderr," from (%d,%d,%d)\n",father->node,father->pix,father->mark);
+#endif
+
+ p = &process[ pix ];
+
+#ifdef OBJECTADDR
+ hash_create(p,119);
+#endif
+ p->used = TRUE; /* process descriptor is used */
+ p->prot = prot; /* prototype number */
+ p->freeitem = 0; /* null list of free dictionary items */
+ p->upper = memorysize-1; /* highest memory address */
+ p->lower = freem; /* lowest address for data */
+ p->headk = p->lower; /* head of killed objects list */
+ p->M[ p->headk ] = MAXAPPT; /* maximum appetite sentinel */
+ p->headk2 = 0;
+ ah = p->upper-1; /* dict. item for process itself */
+ p->lastitem = ah; /* first word used by dictionary */
+ ptr = prototype[ prot ];
+ if (p->upper - p->lower - ptr->appetite < 512)
+ if (prot == MAINBLOCK)
+ abend("Memory size too small (use /m option)\n");
+ else errsignal(RTEMEMOV);
+
+ /* generate process object */
+ p->lastused = p->lower+ptr->appetite;
+ am = p->lower+1;
+ p->M[ am ] = ptr->appetite;
+ p->M[ am+PROTNUM ] = prot;
+ for (i = PROTNUM+1; i < ptr->appetite; i++)
+ p->M[ am+i ] = 0;
+ p->M[ ah ] = am;
+ p->M[ ah+1 ] = 0;
+ p->prochead = am;
+ p->procref.addr = ah;
+ p->procref.mark = 0;
+ p->c1 = am; /* initialize current object ptrs */
+ p->c2 = am+ptr->span;
+ apt = am+ptr->appetite;
+ p->M[ apt+CHD ] = ah; /* initialize coroutine head ptr */
+ p->M[ apt+CHD+1 ] = 0;
+ p->M[ apt+SL ] = DUMMY; /* dummy SL for process */
+ p->M[ 1 ] = 1; /* absolute none */
+ for (i = MAINBLOCK; i <= lastprot; i++) /* initialize DISPLAY */
+ p->M[ apt+dispoff+i ] = 0;
+ p->M[ apt+disp2off+MAINBLOCK ] = DUMMY; /* dummmy entry for MAIN */
+ j = ptr->preflist; /* set DISPLAY entries for process */
+
+ for (i = j+ptr->lthpreflist-1; i >= j; i--)
+ {
+ p->M[ apt+dispoff+M[ i ] ] = am; /* physical address */
+ p->M[ apt+disp2off+M[ i ] ] = ah; /* indirect address */
+ }
+
+ {
+ virtaddr v;
+ mess2obj( p, father, &v );
+ p->M[ apt+DL ] = v.addr;
+ p->M[ apt+DL+1 ] = v.mark;
+ }
+ p->msgqueue = qinit();
+ p->rpcwait = qinit();
+ p->rpcmask = sinit();
+ pushmask(pix); /* initialy all RPCs are disabled */
+ p->trlnumber = 0; /* trace line number */
+ i = ptr->preflist; /* search for executable prefix */
+ while (prototype[ p->M[ i ] ]->kind == RECORD) i++;
+ p->ic = prototype[ M[ i ] ]->codeaddr; /* first instruction address */
+#if RPCDBG
+fprintf(stderr,"first instruction address %d of new process %d\n", p->ic, pix );
+#endif
+ p->force_compactification=FALSE;
+}
+
+
+bool member(virt, am)
+virtaddr *virt;
+word *am;
+{
+ *am = M[ virt->addr ];
+ return (virt->mark == M[ virt->addr+1 ]);
+}
+
+
+void update(am, ah) /* Update DISPLAY */
+word am, ah;
+{
+ word t1, t2, t3, t4, t5, t6;
+ protdescr *ptr;
+
+ while (TRUE)
+ {
+ t1 = am+M[ am ];
+ M[ t1+STATSL ]++; /* flag object included in SL */
+ ptr = prototype[ M[ am+PROTNUM ] ];
+ t2 = ptr->preflist;
+ t3 = t2+ptr->lthpreflist-1;
+ for (t4 = t3; t4 >= t2; t4-- )
+ {
+ t6 = M[ t4 ];
+ t5 = display+t6;
+ if (M[ t5 ] == 0) /* entry to be updated */
+ {
+ M[ t5 ] = am;
+ M[ display2+t6 ] = ah;
+ }
+ }
+ ah = M[ t1+SL ];
+ if (ah == DUMMY) break;
+ if (M[ ah+1 ] != M[ t1+SL+1 ]) errsignal(RTESLCOF);
+ am = M[ ah ];
+ }
+}
+
+
+void loosen() /* Loosen DISPLAY */
+{
+ word t1, t2, t3;
+ protdescr *ptr;
+
+ t1 = c1;
+ while (TRUE)
+ {
+ ptr = prototype[ M[ t1+PROTNUM ] ];
+ t2 = ptr->preflist;
+ for (t3 = t2+ptr->lthpreflist-1; t3 >= t2; t3-- )
+ M[ display+M[ t3 ] ] = 0;
+ t3 = t1+M[ t1 ];
+ M[ t3+STATSL ]--; /* flag object removed from SL */
+ t1 = M[ t3+SL ]; /* ah of SL */
+ if (t1 == DUMMY) break; /* still not main */
+ t1 = M[ t1 ]; /* am of SL */
+ }
+}
+
+
+static int tracecnt = 0; /* To count trace messages in line */
+
+void trace(lineno) /* Trace the program if debug mode */
+word lineno;
+{
+ thisp->trlnumber = lineno;
+ if (debug && lineno > 0)
+ {
+ tracecnt++;
+ if (tracecnt == MAXTRACNT) /* change line */
+ {
+ tracecnt = 0;
+ fprintf(tracefile, "\n");
+ }
+ fprintf(tracefile, "%6ld", (long) lineno);
+ }
+ trapmsg(); /* check for waiting message */
+ rpc2(); /* check for RPC message */
+}
+
+
+void endrun(status)
+int status;
+{
+ fflush(stdout);
+
+ fprintf(stderr, "\n\nEnd of LOGLAN-82 program execution\n");fflush(stderr);
+#if DLINK
+ net_logoff();
+#endif
+ if (debug) fclose(tracefile);
+ exit(status);
+}
+
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include <assert.h>
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+#include "soct.h"
+#include "sock.h"
+#include "tcpip.h"
+
+
+#ifndef FD_SET
+#define BITS_PER_INT 32
+#define FD_SET(f,fds) (fds)->fds_bits[(f)/BITS_PER_INT]|=(1<<((f)%BITS_PER_INT))
+#define FD_ZERO(fds) { (fds)->fds_bits[0]=0; (fds)->fds_bits[1]=0; }
+#endif
+
+
+
+#ifdef BZERO
+void bzero( buf, size ) char *buf; int size; {
+ while( --size >= 0 )
+ buf[size]='\0';
+}
+void bcopy( from, to, size ) char *from,*to; int size; {
+ while( --size >= 0 )
+ to[size]=from[size];
+}
+#endif
+
+
+
+#ifndef INADDR_NONE
+#define INADDR_NONE 0xffffffffUL
+#endif
+
+/* Zerowanie adresu O.S.*/
+#define init_addr(addr) \
+ bzero((char *)&(addr),sizeof(addr)); \
+ (addr).sin_family=AF_INET; \
+ (addr).sin_port=htons(0); \
+ (addr).sin_addr.s_addr=htonl(INADDR_ANY);
+
+
+
+int host_addr( host, buf ) char *host; struct sockaddr_in *buf; {
+
+ long inaddr;
+ int port;
+ struct hostent *hp;
+ char *addr;
+
+ init_addr( *buf );
+
+ addr = strchr( host, ':' );
+ if( addr == NULL )
+ port = PORT;
+ else
+ {
+ *addr = '\0';
+ addr++;
+ if( *addr!='\0' )
+ if( sscanf( addr, "%d", &port ) != 1 ) usage();
+ else;
+ else
+ port = PORT;
+ }
+
+ buf->sin_port = htons( port );
+
+ /* try dotted-decimal address */
+ if( (inaddr = inet_addr(host)) == INADDR_NONE ){
+ if( (hp = gethostbyname(host)) == NULL )
+ return -1;
+ assert( hp->h_length == sizeof( inaddr ) );
+ bcopy( (char *)( hp->h_addr ), (char *)&( buf->sin_addr ), sizeof( inaddr ) );
+ }
+
+ return 0;
+}
+
+
+/* zwraca otwarte gniazdko */
+
+int sock_open( socket_type, protocol, service, port )
+ char *service;
+ char *protocol;
+ int socket_type,port;
+{
+ int fd;
+ struct sockaddr_in my_addr;
+ struct servent *sp;
+ struct protoent *pp;
+
+ init_addr( my_addr );
+
+ if( (pp=getprotobyname(protocol)) == NULL )
+ return -1;
+
+ if( service != NULL ){
+ if( (sp=getservbyname(service,protocol)) == NULL )
+ return -1;
+ my_addr.sin_port = sp->s_port;
+ }
+
+ if( port>0 )
+ my_addr.sin_port = htons( port );
+
+ if( (fd = socket(AF_INET,socket_type,pp->p_proto)) < 0 )
+ return -1;
+
+ if( bind( fd, (struct sockaddr *)&my_addr, sizeof(my_addr) ) < 0 )
+ return -1;
+
+ return fd;
+}
+
+
+
+int sock_poll( sock, ms ) int sock,ms; {
+ struct timeval timeout;
+ fd_set rd_fds;
+ int nfds;
+ FD_ZERO(&rd_fds);
+ timeout.tv_sec = ms/1000;
+ timeout.tv_usec = (ms%1000)*1000;
+ if( sock>=0 ) /* sock==-1 means we only sleep */
+ FD_SET(sock,&rd_fds);
+ if( ms >= 0 )
+ nfds = select(sock+1,&rd_fds,NULL,NULL,&timeout);
+ else
+ nfds = select(sock+1,&rd_fds,NULL,NULL,NULL);
+ errno=0;
+ return ( nfds == 1 );
+}
+
+
+
+static int send_wait_time = 0;
+
+void set_send_delay( ms ) int ms; { /* set delay to miliseconds */
+ send_wait_time = ms;
+}
+
+int sock_send( sock, buf, size, addr )
+ int sock,size;
+ void *buf;
+ struct sockaddr_in *addr;
+{
+ struct sockaddr *adr;
+
+ int namelen = sizeof( *addr );
+ if( send_wait_time > 0 )
+ sock_poll( -1, send_wait_time );
+ if( sendto( sock, (char *)buf, size, 0, addr, namelen ) <= 0 ){
+ fprintf(
+ stderr,
+ "socket send to %s:%d\n",
+ inet_ntoa( addr->sin_addr ),
+ (int)ntohs( addr->sin_port )
+ );
+ perror("send error");
+ abend("send error");
+ }
+ return 0;
+}
+
+int sock_recv( sock, buf, size, addr )
+ int sock,size;
+ void *buf;
+ struct sockaddr_in *addr;
+{
+ int recv_size;
+ int namelen = sizeof( struct sockaddr_in );
+ if( ( recv_size = recvfrom( sock, buf, size, 0, addr, &namelen ) ) < 0 ){
+ perror("recv");
+ return -1;
+ }
+ if( namelen != sizeof( struct sockaddr_in ) ){
+ printf("str sockaddr_in %d namelen %d\n",sizeof(struct sockaddr_in),namelen);
+ printf("addr %s\n",inet_ntoa(addr->sin_addr));
+ abend("strenge message");
+ }
+ return recv_size;
+}
+
+
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#ifndef __SOCK_H__
+#define __SOCK_H__
+
+#include <stdio.h>
+#include <string.h>
+
+#ifndef NO_PROTOTYPES
+#include <stdlib.h>
+#endif
+
+#include <sys/types.h>
+#include <signal.h>
+#include <sys/socket.h>
+#include <sys/time.h>
+#include <netinet/in.h>
+#include <netdb.h>
+#include <errno.h>
+
+
+#ifndef NO_PROTOTYPES
+int host_addr( char * /* host name */, struct sockaddr_in * );
+int sock_open( int socket_type, char *protocol, char *service, int port );
+int sock_recv( int sock, void *buf, int size, struct sockaddr_in *addr );
+int sock_send( int sock, void *buf, int size, struct sockaddr_in *addr );
+void set_send_delay ( int miliseconds );
+int sock_poll( int sock, int miliseconds );
+ /* sock == -1 -> equivalent of sleep */
+ /* miliseconds < 0 -> waits indefinitely */
+#else
+int host_addr();
+int sock_open();
+int sock_srv_recv();
+int sock_srv_send();
+void set_send_delay();
+int sock_poll();
+#endif
+
+
+#ifndef NO_PROTOTYPES
+int sock_crc_recv( int sock, void *m, int size, struct sockaddr *addr );
+int sock_crc_send( int sock, void *m, int size, struct sockaddr *addr );
+#else
+int sock_srv_crc_recv();
+int sock_srv_crc_send();
+#endif
+
+#endif
+
+
+
+
--- /dev/null
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <errno.h>
+#include <netdb.h>
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include <math.h>
+#include <time.h>
+
+/* Call standard procedure */
+
+void standard(nrproc) /* Process call to a standard proc. */
+word nrproc;
+{
+ word t1, t2, t3, t5, t6;
+ double r;
+ bool absent;
+ int ch, n;
+ long tim;
+ char *cp;
+ FILE *fp;
+
+ absent = FALSE;
+
+#ifdef TRACE
+ fprintf( stderr, "standard procedure %d\n", nrproc );
+#endif
+
+ switch ((int) nrproc)
+ {
+ case 1 : /* new array */
+ newarry(param[ 1 ].xword, param[ 0 ].xword, param[ 2 ].xword,
+ ¶m[ 3 ].xvirt, ¶m[ 4 ].xword);
+ break;
+
+ case 2 : /* rew */
+ case 3 : /* avf */
+ case 4 : /* bsf */
+ case 5 : /* weo */
+ case 6 : /* putrec */
+ case 7 : /* getrec */
+ case 8 : /* ass */
+ case 9 : /* assin */
+ case 10 : /* assout */
+ absent = TRUE;
+ break;
+
+ case 11 : /* unpack:function(s:string):arrayof char */
+ t1 = strings+param[ 0 ].xword+1;
+ t6 = M[ t1-1 ]; /* length of the string */
+ if (t6 > 0) /* string not null */
+ {
+ newarry((word) 1, t6, (word) AINT, ¶m[ 1 ].xvirt, &t5);
+ t5 += 3;
+ cp = (char *) &M[ t1 ];
+ while (t6-- > 0) M[ t5++ ] = *cp++;
+ }
+ else /* null string */
+ {
+ param[ 1 ].xvirt.addr = 0;
+ param[ 1 ].xvirt.mark = 0;
+ }
+ break;
+
+ case 12 : /* random:function:real */
+ param[ 0 ].xreal = (real)prandom();
+ break;
+
+ case 13 : /* time:function:integer */
+ time(&tim);
+ param[ 0 ].xword = tim;
+ break;
+
+ case 14 : /* sqrt:function(x:real):real */
+ param[ 1 ].xreal = (real)sqrt((double) param[ 0 ].xreal);
+ break;
+
+ case 15 : /* entier:function(x:real):integer */
+ param[ 1 ].xword = entier((double) param[ 0 ].xreal);
+ break;
+
+ case 16 : /* round:function(x:real):integer */
+ param[ 1 ].xword = entier((double) (param[ 0 ].xreal+0.5));
+ break;
+
+ case 17 : /* unused */
+ case 18 : /* intrinsic procedure */
+ absent = TRUE;
+ break;
+
+ case 19 : /* imin:function(x, y:integer):integer */
+ param[ 2 ].xword = min(param[ 0 ].xword, param[ 1 ].xword);
+ break;
+
+ case 20 : /* imax:function(x, y:integer):integer */
+ param[ 2 ].xword = max(param[ 0 ].xword, param[ 1 ].xword);
+ break;
+
+ case 21 : /* imin3:function(x, y, z:integer):integer */
+ t1 = min(param[ 0 ].xword, param[ 1 ].xword);
+ param[ 3 ].xword = min(t1, param[ 2 ].xword);
+ break;
+
+ case 22 : /* imax3:function(x, y, z:integer):integer */
+ t1 = max(param[ 0 ].xword, param[ 1 ].xword);
+ param[ 3 ].xword = max(t1, param[ 2 ].xword);
+ break;
+
+ case 23 : /* sin:function(x:real):real */
+ param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal);
+ break;
+
+ case 24 : /* cos:function(x:real):real */
+ param[ 1 ].xreal = (real)cos((double) param[ 0 ].xreal);
+ break;
+
+ case 25 : /* tan:function(x:real):real */
+ r = cos((double) param[ 0 ].xreal);
+ if (r == 0.0) errsignal(RTEDIVBZ);
+ param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal) / r;
+ break;
+
+ case 26 : /* exp:function(x:real):real */
+ param[ 1 ].xreal = (real)exp((double) param[ 0 ].xreal);
+ break;
+
+ case 27 : /* ln:function(x:real):real */
+ param[ 1 ].xreal = (real)log((double) param[ 0 ].xreal);
+ break;
+
+ case 28 : /* atan:function(x:real):real */
+ param[ 1 ].xreal = (real)atan((double) param[ 0 ].xreal);
+ break;
+
+ case 29 : /* endrun:procedure */
+ endrun(0);
+ break;
+
+ case 30 : /* ranset:procedure(x:real) */
+ ranset();
+ break;
+
+ case 31 : /* clock */
+ case 32 : /* option */
+ case 33 : /* lock */
+ case 34 : /* unlock */
+ case 35 : /* sched, boy! */
+ case 36 : /* date */
+ case 37 : /* execpar */
+ case 38 : /* test&set */
+ absent = TRUE;
+ break;
+
+ case 39 : /* eof */
+ param[ 0 ].xbool = lbool(testeof(stdin));
+ break;
+
+ case 40 : /* eof(f) */
+ loadfile((word) UNKNOWN, &t1, &t2, &fp);
+ t3 = M[ t2+FSTAT ];
+ if (t3 == READING || t3 == UPDATING)
+ param[ 0 ].xbool = lbool(testeof(fp));
+ else errsignal(RTEILLIO);
+ break;
+
+ case 41 : /* readln */
+ readln(stdin);
+ break;
+
+ case 42 : /* readln(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ readln(fp);
+ break;
+
+ case 43 : /* readchar */
+ param[ 0 ].xword = getc(stdin);
+ break;
+
+ case 44 : /* readchar(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);
+ param[ 0 ].xword = ch;
+ break;
+
+ case 45 : /* readint */
+ param[ 0 ].xword = readint(stdin);
+ break;
+
+ case 46 : /* readint(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ param[ 0 ].xword = readint(fp);
+ break;
+
+ case 47 : /* readreal */
+ param[ 0 ].xreal = (real)readreal(stdin);
+ break;
+
+ case 48 : /* readreal(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ param[ 0 ].xreal = (real)readreal(fp);
+ break;
+
+ case 49 : /* getchar(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != CHARF) errsignal(RTEILLIO);
+ if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);
+ param[ 0 ].xword = ch;
+ break;
+
+ case 50 : /* getint(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != INTF) errsignal(RTEILLIO);
+ n = fread((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
+ if (n != 1) errsignal(RTEIOERR);
+ break;
+
+ case 51 : /* getreal(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != REALF) errsignal(RTEILLIO);
+ n = fread((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
+ if (n != 1) errsignal(RTEIOERR);
+ break;
+
+ case 52 : /* getobject(f) */
+ absent = TRUE;
+ break;
+
+ case 53 : /* putchar(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != CHARF) errsignal(RTEILLIO);
+ ch = (char) param[ 0 ].xword;
+ if (putc(ch, fp) == EOF) errsignal(RTEIOERR);
+ break;
+
+ case 54 : /* putint(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != INTF) errsignal(RTEILLIO);
+ n = fwrite((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
+ if (n != 1) errsignal(RTEIOERR);
+ break;
+
+ case 55 : /* putreal(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != REALF) errsignal(RTEILLIO);
+ n = fwrite((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
+ if (n != 1) errsignal(RTEIOERR);
+ break;
+
+ case 56 : /* putobject(f) */
+ case 57 : /* putstring(f) */
+ absent = TRUE;
+ break;
+
+ case 58 : /* writeln(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ if (putc('\n', fp) == EOF) errsignal(RTEIOERR);
+ if (fflush(fp)) errsignal(RTEIOERR);
+ break;
+
+ case 59 : /* writeln */
+ putc('\n', stdout);
+ break;
+
+ case 60 : /* writechar(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ if (putc((char) param[ 0 ].xword, fp) == EOF)
+ errsignal(RTEIOERR);
+ break;
+
+ case 61 : /* writechar */
+ putc((char) param[ 0 ].xword, stdout);
+ break;
+
+ case 62 : /* writeint(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ writeint(param[ 0 ].xword, param[ 1 ].xword, fp);
+ break;
+
+ case 63 : /* writeint */
+ writeint(param[ 0 ].xword, param[ 1 ].xword, stdout);
+ break;
+
+ case 64 : /* writereal0(f) */
+ case 66 : /* writereal1(f) */
+ case 68 : /* writereal2(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ writereal((double) param[ 0 ].xreal, param[ 1 ].xword,
+ param[ 2 ].xword, fp);
+ break;
+
+ case 65 : /* writereal0 */
+ case 67 : /* writereal1 */
+ case 69 : /* writereal2 */
+ writereal((double) param[ 0 ].xreal, param[ 1 ].xword,
+ param[ 2 ].xword, stdout);
+ break;
+
+ case 70 : /* writestring(f) */
+ loadfile((word) WRITING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ writestring(param[ 0 ].xword, param[ 1 ].xword, fp);
+ break;
+
+ case 71 : /* writestring */
+ writestring(param[ 0 ].xword, param[ 1 ].xword, stdout);
+ break;
+
+ case 72 : /* open temporary file */
+ genfileobj(TRUE , param[ 1 ].xword, tempfilename(),
+ ¶m[ 0 ].xvirt, &t1);
+ break;
+
+ case 73 : /* open external file */
+ genfileobj(FALSE, param[ 1 ].xword, asciiz(¶m[ 2 ].xvirt),
+ ¶m[ 0 ].xvirt, &t1);
+ break;
+
+ case 74 : /* eoln */
+ param[ 0 ].xbool = lbool(testeoln(stdin));
+ break;
+
+ case 75 : /* eoln(f) */
+ loadfile((word) READING, &t1, &t2, &fp);
+ if (t1 != TEXTF) errsignal(RTEILLIO);
+ param[ 0 ].xbool = lbool(testeoln(fp));
+ break;
+
+ case 76 : /* this coroutine */
+ loadvirt(param[ 0 ].xvirt,
+ thisp->prochead+M[ thisp->prochead ]+CHD);
+ break;
+
+ case 77 : /* this process */
+ {
+ procaddr p;
+ virtaddr v;
+ p.node = ournode;
+ p.pix = thispix;
+ p.mark = thisp->mark;
+ mess2obj( thisp, &p, &v );
+ param[ 0 ].xvirt = v;
+ }
+ break;
+
+ case 78 : /* reset:procedure(f:file) */
+ if (member(¶m[ 0 ].xvirt, &t2))
+ reset(t2);
+ else errsignal(RTEREFTN);
+ break;
+
+ case 79 : /* rewrite:procedure(f:file) */
+ if (member(¶m[ 0 ].xvirt, &t2))
+ rewrite(t2);
+ else errsignal(RTEREFTN);
+ break;
+
+ case 80 : /* unlink:procedure(f:file) */
+ delete(¶m[ 0 ].xvirt);
+ break;
+
+ case 81 : /* seek:procedure(f:file, offset, base:integer) */
+ storevirt(param[ 0 ].xvirt, currfile);
+ loadfile((word) UPDATING, &t1, &t2, &fp);
+ if (t1 != DIRECT) errsignal(RTEILLIO);
+ if (fseek(fp, (long) param[ 1 ].xword, (int) param[ 2 ].xword))
+ errsignal(RTEIOERR);
+ break;
+
+ case 82 : /* getrec(f, a, n) */
+ loadfile((word) UPDATING, &t1, &t2, &fp);
+ if (t1 != DIRECT) errsignal(RTEILLIO);
+ param[ 1 ].xword = directio(
+ ¶m[ 0 ].xvirt,
+ param[ 1 ].xword,
+ (int (*)())fread,
+ fp
+ );
+ break;
+
+ case 83 : /* putrec(f, a, n) */
+ loadfile((word) UPDATING, &t1, &t2, &fp);
+ if (t1 != DIRECT) errsignal(RTEILLIO);
+ param[ 1 ].xword = directio(
+ ¶m[ 0 ].xvirt,
+ param[ 1 ].xword,
+ (int (*)())fwrite,
+ fp
+ );
+ break;
+
+ case 84 : /* position:function(f:file):real */
+ storevirt(param[ 0 ].xvirt, currfile);
+ loadfile((word) UPDATING, &t1, &t2, &fp);
+ if (t1 != DIRECT) errsignal(RTEILLIO);
+ param[ 1 ].xword =(int) ftell(fp);
+ break;
+
+ case 98 : /* memavail:function:integer */
+ param[ 0 ].xword = memavail();
+ break;
+
+ case 99 : /* exec:function(c:arrayof char):integer */
+ cp = asciiz(¶m[ 0 ].xvirt);
+ param[ 1 ].xword = system(cp);
+ free(cp);
+ break;
+
+ default :
+ nonstandard(nrproc);
+ break;
+ }
+# if TRACE
+ fflush( stdout );
+# endif
+ if (absent) errsignal(RTEUNSTP);
+}
+
+
--- /dev/null
+#include <grx.h>
+#include <mousex.h>
+#include "eventque.h"
+
+int Couleur,Fond,CurX,CurY;
+int Coul[4],Pal;
+int MOUSE_PRESENT =0;
+
+MouseEvent *evt;
+EventQueue *q;
+char *ret;
+
+void mousenit(int mo,int ke)
+{
+ MouseEventMode(1);
+ MouseInit();
+ evt=(MouseEvent *)malloc(sizeof(MouseEvent));
+ MouseEventEnable(ke,mo);
+ MOUSE_PRESENT=1;
+}
+
+void mouseshow(void)
+{
+ MouseDisplayCursor();
+}
+
+void mousehide(void)
+{
+ MouseEraseCursor();
+}
+
+int mouse(v,p,h,l,r,c)
+unsigned int *v,*p,*h,*l,*r,*c;
+{
+ EventRecord e;
+ MouseEvent *ev1;
+ short result=0;
+
+ *v=0,*p=0,*h=0,*l=0,*r=0,*c=0;
+
+ ev1=evt;
+ evt=(MouseEvent *)calloc(1,sizeof(MouseEvent));
+ MouseGetEvent(M_EVENT | M_POLL | M_NOPAINT,evt);
+ *p=evt->kbstat; *l=evt->key;
+ *h=evt->x; *v=evt->y;
+ *r=evt->flags; *c=evt->buttons;
+ if(ev1->kbstat!=evt->kbstat || ev1->key!=evt->key || ev1->x!=evt->x ||
+ ev1->y!=evt->y || ev1->flags!=evt->flags || ev1->buttons!=evt->buttons)
+ result=1;
+ free(ev1);
+ return(result);
+}
+
+void afficheinteger(int x,int y,int valeur,int cf,int ce)
+{
+ char tst[20];
+
+ sprintf(tst,"%i",valeur);
+ GrTextXY(x,y,tst,ce,cf);
+ CurX+=8*strlen(tst);
+ if(CurX>GrMaxX())
+ {
+ CurX=0;
+ CurY+=14;
+ }
+}
+
+
+
+int readcara(int posx,int posy,int col_f,int col_e)
+{
+ char *t="_\0";
+ int a;
+
+ while(!kbhit())
+ {
+ GrHLine(posx,posx+8,posy+13,col_f);
+ delay(200);
+ GrHLine(posx,posx+8,posy+13,col_e);
+ delay(100);
+ }
+ GrHLine(posx,posx+8,posy+13,col_f);
+ a=getxkey();
+ if(!a)
+ return(getxkey());
+ else
+ return(a);
+}
+
+
+void beep(void)
+{
+ printf("%c\n",7);
+}
+
+int affiche_chaine(int x,int y,int lg,char *txtd,char *txtf,int av,int *ll,int col_e,int col_f)
+{
+ int larg;
+ char cara[2];
+
+
+ if(!av)
+ {
+ for(sprintf(&cara[0],"%c\0",*txtf),larg=0;txtf>=txtd;txtf--) /* affiche arriere */
+ {
+ GrTextXY(x+lg-larg,y,&cara[0],col_e,col_f);
+ larg+=8;
+ sprintf(&cara[0],"%c\0",*(txtf-1));
+ if((lg-larg-8)<0)
+ break;
+ }
+ if(txtf<=txtd)
+ {
+ *ll-=6;
+ return(1);
+ }
+ else
+ return(0);
+ }
+ else
+ {
+ for(sprintf(&cara[0],"%c\0",*txtd),larg=0;txtd<=txtf;txtd++) /* affiche avant */
+ {
+ GrTextXY(x+larg,y,&cara[0],col_e,col_f);
+ larg+=8;
+ sprintf(&cara[0],"%c\0",*(txtd+1));
+ if((lg-larg-8)<0)
+ break;
+ }
+ if(txtd<=txtf)
+ return(0);
+ else
+ return(1);
+ }
+}
+
+int gscanfnum(int x,int y,int lg,int min,int max,int deft,int col_f,int col_e,int col_c)
+{
+
+ char t[10],a;
+ int larg=0,flg=0;
+ char *ptd,*ptc;
+ int i;
+ int cpt=0;
+ short chgt=0;
+ short signe=0; /* par defaut 0(+) sinon 1(-) */
+
+ ptc=ptd=&t[0];
+ GrFilledBox(x,y,x+lg,y+14,col_f);
+ sprintf(t,"%lu\0",deft);
+ while(*ptc!='\0') ptc++;
+ GrTextXY(x+lg-strlen(t)*8,y,t,col_e,col_f);
+ do
+ {
+ a=readcara(x+lg-8,y,col_f,col_c);
+ switch(a)
+ {
+ case 8:
+ if(ptc>ptd)
+ {
+ ptc--;
+ cpt--;
+ if(flg)
+ larg-=8;
+ *(ptc)='\0';
+ }
+ else
+ {
+ larg=0;
+ ptc=ptd;
+ beep();
+ }
+ break;
+ case 13:
+ if(ptc==ptd)
+ {
+ *ptc='\0';
+ a=11;
+ }
+ break;
+ case 43:
+ signe=0;
+ chgt=1;
+ if(cpt==0)
+ *ptc='\0';
+ break;
+ case 45:
+ signe=1;
+ chgt=1;
+ if(cpt==0)
+ *ptc='\0';
+ break;
+ default:
+ if(cpt<10)
+ {
+ if((a<='9') && (a>='0'))
+ {
+ *(ptc++)=a;
+ cpt++;
+ *ptc='\0';
+ }
+ }
+ else
+ beep();
+ break;
+ }
+ GrFilledBox(x,y,x+lg,y+14,col_f);
+ affiche_chaine(x,y,lg,ptd,ptc,flg,&larg,col_e,col_f);
+ if(chgt)
+ if(signe)
+ GrTextXY(x,y,"-",col_e,col_f);
+ else
+ GrTextXY(x,y,"+",col_e,col_f);
+ }
+ while((a!=13) && (a!=27));
+ if(a==13)
+ {
+ i=atol(t);
+ if(signe)
+ i=-i;
+ if((i<=max) && (i>=min))
+ return(i);
+ else
+ {
+ beep();
+ return(gscanfnum(x,y,lg,min,max,deft,col_f,col_e,col_c));
+ }
+ }
+ else
+ return(gscanfnum(x,y,lg,min,max,deft,col_f,col_e,col_c));
+}
+
+
+/******************************************************************************/
+char *gschar(int x,int y,int lg,int *lgmax,char *defaut,int col_f,int col_e,int col_c)
+{
+
+ char *ptd,*ptc,a;
+ int larg=0,flg=1;
+
+ ptd=(char *)malloc(*lgmax);
+ ptc=ptd;
+ GrFilledBox(x,y,x+lg*8,y+14,col_f);
+ GrTextXY(x,y,defaut,col_e,col_f);
+ do
+ {
+ a=readcara((larg<(lg-1)*8) ? (x+larg) : (x+(lg-1)*8),y,col_f,col_c);
+ switch(a)
+ {
+ case 8:
+ if(ptc>ptd)
+ {
+ ptc--;
+ if(flg)
+ larg=(larg-8)>0 ? larg-8 : 0;
+ *(ptc)='\0';
+ }
+ else
+ {
+ larg=0;
+ ptc=ptd;
+ beep();
+ }
+ break;
+ case 13:
+ break;
+ default :
+ if(((ptc-ptd)/sizeof(char))<=*lgmax)
+ {
+ *(ptc++)=a;
+ *ptc='\0';
+ if(flg)
+ larg+=8;
+ }
+ else
+ beep();
+ }
+ GrFilledBox(x,y,x+lg*8,y+14,col_f);
+ flg=affiche_chaine(x,y,(lg-1)*8,ptd,ptc,flg,&larg,col_e,col_f);
+ }
+ while((a!=13) && (a!=27));
+ if((a==27) || (ptd==ptc))
+ {
+ ptc=ptd=defaut;
+ while(*ptc!='\0') ptc++;
+ }
+ else
+ *ptc='\0';
+ GrFilledBox(x,y,x+lg*8,y+14,col_f);
+ affiche_chaine(x,y,lg*8,ptd,ptc,1,&larg,col_e,col_f);
+ *lgmax=(ptc>ptd)? ptc-ptd+1 : 0;
+ return(ptd);
+}
--- /dev/null
+case GRON: switch (param[0].xword)
+ {
+ case 0: GrSetMode(GR_width_height_graphics,
+ 640,480,16);
+ Res_graph_X=640;
+ Res_graph_Y=480;
+ break;
+ case 1: GrSetMode(GR_width_height_graphics,
+ 640,480,256);
+ Res_graph_X=640;
+ Res_graph_Y=480;
+ break;
+ case 2: GrSetMode(GR_width_height_graphics,
+ 800,600,16);
+ Res_graph_X=800;
+ Res_graph_Y=600;
+ break;
+
+ case 3: GrSetMode(GR_width_height_graphics,
+ 800,600,256);
+ Res_graph_X=800;
+ Res_graph_Y=600;
+ break;
+ case 4: GrSetMode(GR_width_height_graphics,
+ 1024,768,16);
+ Res_graph_X=1024;
+ Res_graph_Y=768;
+ break;
+ case 5: GrSetMode(GR_width_height_graphics,
+ 1024,768,256);
+ Res_graph_X=1024;
+ Res_graph_Y=768;
+ break;
+ case 6: GrSetMode(GR_width_height_graphics,
+ 1280,1024,16);
+ Res_graph_X=1280;
+ Res_graph_Y=1024;
+ break;
+ case 7: GrSetMode(GR_width_height_graphics,
+ 1280,1024,256);
+ Res_graph_X=1280;
+ Res_graph_Y=1024;
+ break;
+ case 8: GrSetMode(GR_width_height_graphics,
+ 1600,1280,16);
+ Res_graph_X=1600;
+ Res_graph_Y=1280;
+ break;
+ case 9: GrSetMode(GR_width_height_graphics,
+ 1600,1280,256);
+ Res_graph_X=1600;
+ Res_graph_Y=1280;
+ break;
+ default: GrSetMode(GR_width_height_graphics,
+ 320,200,256);
+ Res_graph_X=320;
+ Res_graph_Y=200;
+ }
+ GrClearScreen(0);
+ break;
+
+case POINT: CurX=param[0].xword;
+ CurY=param[1].xword;
+ GrPlot(CurX,CurY,Couleur);
+ break;
+
+case INPIX: CurX=param[0].xword;
+ CurY=param[1].xword;
+ param[2].xword=GrPixel(CurX,CurY);
+ break;
+
+case MOVE: CurX=param[0].xword;
+ CurY=param[1].xword;
+ break;
+
+case COLOR: Couleur=param[0].xword;
+ break;
+
+case PALETT: Coul[Pal++]=param[0].xword;
+ if (Pal==4)
+ {
+ GrSetColor(Coul[0],Coul[1],Coul[2],Coul[3]);
+ Pal=0;
+ }
+ break;
+
+case GROFF: if(MOUSE_PRESENT) MouseUnInit();
+ GrSetMode(GR_80_25_text);
+ break;
+
+case DRAW: GrLine(CurX,CurY,param[0].xword,param[1].xword,Couleur);
+ CurX=param[0].xword;
+ CurY=param[1].xword;
+ break;
+
+case HFILL: GrHLine(CurX,param[0].xword,CurY,Couleur);
+ CurX=param[0].xword;
+ break;
+
+case VFILL: GrVLine(CurX,CurY,param[0].xword,Couleur);
+ CurY=param[0].xword;
+ break;
+
+case CLS: GrClearScreen(Fond);
+ break;
+
+case BORDER: Fond=param[0].xword;
+ break;
+
+case INXPOS: param[0].xword=CurX;
+ break;
+
+case INYPOS: param[0].xword=CurY;
+ break;
+
+case OUTSTRING:
+ {
+ char *Texte= (char *)(M + strings + param[ 2 ].xword + 1);
+ if(param[0].xint==-1) ax=CurX;
+ else ax=param[0].xint;
+ if(param[1].xint==-1) bx=CurY;
+ else bx=param[1].xint;
+ if(param[3].xint==-1) cx=Couleur;
+ else cx=param[3].xint;
+ if(param[4].xint==-1) dx=Fond;
+ else dx=param[4].xint;
+ GrTextXY(ax,bx,Texte,cx,dx);
+ if(param[0].xint==-1 && param[1].xint==-1)
+ {
+ CurX+=8*strlen(Texte);
+ if(CurX>GrMaxX())
+ {
+ CurX=0;
+ CurY+=14;
+ }
+ }
+ }
+ break;
+
+case HASCII:
+ {
+ char *Texte=(char *)¶m[ 0 ].xword;
+ GrTextXY(CurX,CurY,Texte,Couleur,Fond);
+ CurX+=8;
+ if (CurX>GrMaxX())
+ {
+ CurX=0;
+ CurY+=14;
+ }
+ }
+ break;
+
+case INKEY:
+ {
+ int Touche;
+
+ Touche=kbhit();
+ if (Touche)
+ param[0].xword=getkey();
+ else
+ param[0].xword=0;
+ }
+ break;
+
+case GETMAP : {
+ int w,h;
+ GrContext *Destination;
+
+ w=abs(param[0].xword-CurX)+1;
+ h=abs(param[1].xword-CurY)+1;
+ newarry((word)1,3,(word)AINT,¶m[2].xvirt,&am);
+ Destination=GrCreateContext(w,h,
+ NULL,NULL);
+ M[am+3]=(int)Destination;
+ M[am+4]=w;
+ M[am+5]=h;
+ GrBitBlt(Destination,0,0,
+ NULL,CurX,CurY,param[0].xword,param[1].xword,
+ GrWRITE);
+ }
+ break;
+
+case PUTMAP : if (member(¶m[0].xvirt,&am))
+ GrBitBlt(NULL,CurX,CurY,
+ (GrContext *)M[am+3],0,0,M[am+4],M[am+5],GrWRITE);
+ else
+ errsignal(RTEREFTN);
+ break;
+
+case ORMAP : if (member(¶m[0].xvirt,&am))
+ GrBitBlt(NULL,CurX,CurY,
+ (GrContext *)M[am+3],0,0,M[am+4],M[am+5],GrOR);
+ else
+ errsignal(RTEREFTN);
+ break;
+
+case XORMAP : if (member(¶m[0].xvirt,&am))
+ GrBitBlt(NULL,CurX,CurY,
+ (GrContext *)M[am+3],0,0,M[am+4],M[am+5],GrXOR);
+ else
+ errsignal(RTEREFTN);
+ break;
+
+case INTENS : {
+ word am1,am2;
+ int i;
+ int pt1[30][2];
+
+ if(member(¶m[1].xvirt,&am1) && member(¶m[2].xvirt,&am2))
+ {
+ if(param[0].xint>30) param[0].xint=30;
+ for(i=0;i<param[0].xint;i++)
+ {
+ pt1[i][0]=M[am1+3+i];
+ pt1[i][1]=M[am2+3+i];
+ }
+ if(param[4].xint!=0)
+ GrFilledPolygon(param[0].xint,pt1,param[3].xint);
+ else
+ GrPolygon(param[0].xint,pt1,param[3].xint);
+ }
+ else
+ errsignal(RTEREFTN);
+ }
+ break;
+
+case PATERN :
+ if(param[5].xint!=0)
+ GrFilledBox(param[0].xint,param[1].xint,param[2].xint,param[3].xint,param[4].xint);
+ else
+ GrBox(param[0].xint,param[1].xint,param[2].xint,param[3].xint,param[4].xint);
+ break;
+case TRACK : afficheinteger(param[0].xint,param[1].xint,param[2].xint,param[3].xint,
+ param[4].xint);
+ break;
+case HFONT : param[9].xint=gscanfnum(param[0].xint,param[1].xint,param[2].xint*8,
+ param[3].xint,param[4].xint,param[5].xint,
+ param[6].xint,param[7].xint,param[8].xint);
+ break;
+
+case HFONT8 : {
+ char *Texte= (char *)(M + strings + param[ 4 ].xword + 1);
+
+ ret=gschar(param[0].xint,param[1].xint,param[2].xint,¶m[3].xint,
+ Texte,param[5].xint,param[6].xint,param[7].xint);
+
+ newarry((word) 0, param[3].xint-2,(word) AINT,¶m[8].xvirt,&ax);
+ ax+=3;
+ while(*ret!='\0')
+ M[ax++]=*(ret++);
+ }
+ break;
+
+case CIRB : {
+ ax=param[0].xint-param[2].xint; /* x */
+ bx=param[1].xint-param[3].xint; /* y */
+ cx=param[2].xint*2; /* rax */
+ dx=param[3].xint*2; /* ray */
+ if(param[7].xint!=0)
+ GrFilledEllipseArc(ax,bx,cx,dx,param[4].xint,param[5].xint,
+ param[6].xint);
+ else
+ GrEllipseArc(ax,bx,cx,dx,param[4].xint,param[5].xint,
+ param[6].xint);
+ }
+ break;
+/* MOUSE */
+
+case INIT : mousenit(param[0].xint,param[1].xint);
+ break;
+
+case SHOWCURSOR :
+ mouseshow();
+ break;
+
+case HIDECURSOR :
+ mousehide();
+ break;
+
+case STATUS :
+ break;
+
+case SETPOSITION :
+ MouseWarp(param[0].xint,param[1].xint);
+ break;
+
+case GETPRESS :
+case GETRELEASE :
+
+ ax=mouse(&v,&p,&h,&l,&r,&c);
+ param[ 5 ].xint = c;
+ param[ 4 ].xint = r;
+ param[ 3 ].xint = l;
+ param[ 2 ].xint = p;
+ param[ 1 ].xint = v;
+ param[ 0 ].xint = h;
+ /* parametre en retour*/
+ if(ax)
+ param[ 6 ].xbool = TRUE;
+ else
+ param[ 6 ].xbool = FALSE;
+ break;
+
+case SETWINDOW :
+ MouseSetLimits(param[0].xint,param[1].xint,param[2].xint,param[3].xint);
+ break;
+
+case DEFCURSOR :
+ break;
+
+case GETMOVEMENT :
+ MouseEventEnable(param[1].xint,param[0].xint);
+ break;
+
+case SETSPEED :
+ MouseSetSpeed(param[0].xint);
+ break;
+
+case SETTHRESHOLD :
+ break;
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+
+#include "sock.h"
+#include "tcpip.h"
+
+#include <assert.h>
+
+
+static int sock;
+
+static int slaves=0;
+static struct addr {
+ int console;
+ struct sockaddr_in addr;
+} *phone_book;
+
+
+#define MAX_NODES 256
+static int node2book[ MAX_NODES ]; /* only 256 nodes - can be changed */
+
+
+static void sock_recv_from( void *, int, struct sockaddr_in * );
+static void sock_recv_from( buf, buflen, from_addr )
+ int buflen;
+ void *buf;
+ struct sockaddr_in *from_addr;
+{
+ struct sockaddr_in addr;
+ int retval;
+ for(;;){
+ if( ( retval = sock_recv( sock, buf, buflen, &addr ) ) < 0 )
+ perror("receive"),abend("no answer from master");
+ if(
+ from_addr->sin_port != addr.sin_port
+ ||
+ from_addr->sin_addr.s_addr != addr.sin_addr.s_addr
+ ||
+ buflen != retval
+ )
+ fprintf( stderr, "unexpected message from %s:%d length %d\n",
+ inet_ntoa( from_addr->sin_addr ),
+ (int)ntohs( from_addr->sin_port ),
+ retval
+ );
+ else
+ break;
+ }
+}
+
+ /* nn.nn.nn.nn:port address */
+void tcpip_connect_to_master( addr ) char *addr; {
+
+ char *host = addr;
+ int namelen;
+ int aux;
+ struct sockaddr_in m_address;
+
+ for( aux = 0; aux < MAX_NODES; aux++ )
+ node2book[ aux ] = -1;
+
+ if( host_addr( host, &m_address ) < 0 ){
+ perror("invalid host name:");
+ usage();
+ }
+
+ sock = sock_open( SOCK_DGRAM, "udp", NULL, 0 ); /* any port */
+ if( sock < 0 ) perror("can't open any socket"),exit(10);
+
+ {
+ struct sockaddr_in addr;
+ int namelen = sizeof(struct sockaddr_in);
+ getsockname( sock, &addr, &namelen );
+ fprintf( stderr, "socket opened on %s:%d\n",
+ inet_ntoa(addr.sin_addr),
+ (int)ntohs(addr.sin_port)
+ );
+ }
+
+ aux = htonl( console );
+ sock_send( sock, &aux, sizeof(aux), &m_address );
+ fprintf(
+ stderr, "waiting for acknowledge from %s:%d\n",
+ host, (int)ntohs( m_address.sin_port )
+ );
+
+ sock_recv_from( &aux, sizeof(aux), &m_address );
+ slaves = ntohl( aux );
+ fprintf( stderr, "answer from master: %d interpreters\n", slaves );
+
+ phone_book = (struct addr *)calloc( slaves, sizeof( struct addr ) );
+ if( phone_book==NULL ) abend("can't allocate table of addresses");
+
+ sock_recv_from( &aux, sizeof(aux), &m_address );
+ phone_book[0].console = ntohl( aux );
+ phone_book[0].addr = m_address;
+
+ fprintf( stderr, "master console %d at %s:%d\n",
+ phone_book[0].console,
+ inet_ntoa(phone_book[0].addr.sin_addr),
+ (int)ntohs(phone_book[0].addr.sin_port)
+ );
+
+ node2book[ phone_book[ 0 ].console ] = 0;
+
+ {
+ int i;
+ for( i=1; i<slaves; i++ ){ /* on 0 will be master */
+
+ sock_recv_from( &aux, sizeof(aux), &m_address );
+ phone_book[i].console = ntohl( aux );
+ sock_recv_from(
+ &(phone_book[i].addr),
+ sizeof(struct sockaddr_in),
+ &m_address
+ );
+ fprintf( stderr, "interpreter %d connected at %s:%d\n",
+ phone_book[i].console,
+ inet_ntoa(phone_book[i].addr.sin_addr),
+ (int)ntohs(phone_book[i].addr.sin_port)
+ );
+ node2book[ phone_book[ i ].console ] = i;
+
+ }
+ }
+ fprintf( stderr, "\nprogram started\n\n" );
+}
+
+
+
+
+void tcpip_wait_for_slaves( _slaves ) int _slaves; {
+
+ int aux;
+ int slave_console;
+ struct sockaddr_in slave_address;
+ int namelen = sizeof(struct sockaddr_in);
+
+ for( aux = 0; aux < MAX_NODES; aux++ )
+ node2book[ aux ] = -1;
+
+ slaves = _slaves+1;
+
+ phone_book = (struct addr *)calloc( slaves, sizeof( struct addr ) );
+ if( phone_book==NULL ) abend("can't allocate table of addresses");
+
+ sock = sock_open( SOCK_DGRAM, "udp", NULL, PORT );
+ if( sock < 0 ) perror("master socket"),abend("can't install master");
+
+ phone_book[0].console = console;
+ getsockname( sock, &(phone_book[0].addr), &namelen );
+ assert( namelen == sizeof( struct sockaddr_in ) );
+
+ fprintf( stderr, "waiting for %d slaves on console %d at %s:%d\n",
+ _slaves,
+ phone_book[0].console,
+ inet_ntoa(phone_book[0].addr.sin_addr),
+ (int)ntohs(phone_book[0].addr.sin_port)
+ );
+
+ node2book[ console ] = 0;
+
+ while( _slaves > 0 ){
+
+ if( sock_recv( sock , &slave_console, sizeof(slave_console), &slave_address ) < 0 )
+ perror("server receive"),abend("can't connect slave");
+
+ fprintf( stderr, "slave %d connected at %s:%d\n",
+ ntohl(slave_console),
+ inet_ntoa(slave_address.sin_addr),
+ (int)ntohs(slave_address.sin_port)
+ );
+
+ slave_console = ntohl( slave_console );
+
+ phone_book[_slaves].console = slave_console;
+ phone_book[_slaves].addr = slave_address;
+
+ if( node2book[ slave_console ] != -1 ){
+ fprintf( stderr, "node %d already bound\n", slave_console );
+ abend("exiting");
+ }
+ node2book[ slave_console ] = _slaves;
+
+ _slaves--;
+
+ }
+
+ fprintf( stderr, "all slaves notified - sending acknowledges\n" );
+
+ {
+ int i,j;
+ for( i=1; i<slaves; i++ ){
+
+ aux = htonl(slaves);
+ sock_send( sock, &aux, sizeof(aux), &(phone_book[i].addr) );
+
+ aux = htonl(console);
+ sock_send( sock, &aux, sizeof(aux), &(phone_book[i].addr) );
+
+ for( j=1; j<slaves; j++ ){
+ aux = htonl(phone_book[j].console);
+ sock_send( sock, &aux, sizeof(aux), &(phone_book[i].addr) );
+ sock_send(
+ sock,
+ &(phone_book[j].addr),
+ sizeof(struct sockaddr_in),
+ &(phone_book[i].addr)
+ );
+ }
+ }
+ }
+
+ fprintf( stderr, "\nprogram started\n\n" );
+}
+
+
+void tcpip_send( msg ) message *msg; {
+ int node = msg->control.receiver.node;
+ int ix = node2book[ node ];
+ if( ix == -1 ){
+ fprintf( stderr, "tcpip send message to not existing node %d\n", node );
+ abend("exiting");
+ }
+#ifdef RPCDBG
+ fprintf( stderr, "tcpip send message to node %d indx %d\n", node, ix );
+#endif
+ sock_send(
+ sock,
+ msg,
+ sizeof( message ),
+ &( phone_book[ ix ].addr )
+ );
+}
+
+bool tcpip_poll( ms ) int ms; {
+ return sock_poll( sock, ms );
+}
+
+bool tcpip_recv( msg ) message *msg; {
+ int retval;
+ struct sockaddr_in addr;
+ if( ( retval = sock_recv( sock, msg, sizeof( message ), &addr ) ) < 0 ){
+ perror("receive");
+ return FALSE;
+ }
+
+ if( retval == sizeof( message ) )
+#ifdef RPCDBG
+ fprintf(stderr,"tcpip recv message from node %d\n",msg->control.sender.node);
+ else
+ fprintf(stderr,"tcpip recv incorrect message from node %d\n",msg->control.sender.node);
+#endif
+ return ( retval == sizeof( message ) );
+}
+
+
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#ifndef __TCPIP_H__
+#define __TCPIP_H__
+
+#ifndef NO_PROTOTYPES
+void tcpip_connect_to_master( char * ); /* nn.nn.nn.nn:port address */
+void tcpip_wait_for_slaves( int ); /* slaves number */
+void tcpip_send( message * );
+bool tcpip_poll( int miliseconds ); /* < 0 -> blocks indefinitely */
+bool tcpip_recv( message * );
+#else
+void tcpip_connect_to_master();
+void tcpip_wait_for_slaves();
+void tcpip_send();
+bool tcpip_poll();
+void tcpip_recv();
+#endif
+
+#define PORT 3600
+
+#endif
+
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+/* Type checking routines */
+
+
+/* Determine if prot occurs in the prefix sequence of object am
+ */
+
+#ifndef NO_PROTOTYPES
+static bool pref(word,word);
+static bool typep0(word,word,bool,word *,word *);
+static bool prefh(word,word);
+static bool typef(word,word,word,word);
+#else
+static bool pref();
+static bool typep0();
+static bool prefh();
+static bool typef();
+#endif
+
+
+static bool pref(am, prot)
+word am, prot;
+{
+ word t1, t2;
+ protdescr *ptr;
+
+ t1 = M[ am+PROTNUM ];
+ if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT)
+ { /* neither array nor file */
+ ptr = prototype[ t1 ];
+ t1 = ptr->preflist;
+ t2 = t1+ptr->lthpreflist;
+ while (t1 < t2)
+ {
+ if (prot == M[ t1 ]) return (TRUE);
+ t1++;
+ }
+ }
+ return (FALSE);
+} /* end pref */
+
+
+void qua(virt, tp) /* Validate qualification of object */
+virtaddr *virt;
+word tp;
+{
+ if (virt->mark != M[ virt->addr+1 ]) errsignal(RTEREFTN);
+ if (M[ tp ] != CLASSTYPE) errsignal(RTEINCQA);
+ if (!pref(M[ virt->addr ], M[ tp+1 ])) errsignal(RTEINCQA);
+} /* end qua */
+
+
+bool inl(virt, tp) /* Determine if A in B */
+virtaddr *virt;
+word tp;
+{
+ if (virt->mark != M[ virt->addr+1 ])
+ return (TRUE); /* none is in everything */
+ else
+ if (M[ tp ] != CLASSTYPE) return (FALSE);
+ else return (pref(M[ virt->addr ], M[ tp+1 ]));
+} /* end inl */
+
+
+bool is(virt, tp) /* Determine if A is B */
+virtaddr *virt;
+word tp;
+{
+ if (virt->mark != M[ virt->addr+1 ] || M[ tp ] != CLASSTYPE)
+ return (FALSE);
+ else return (M[ M[ virt->addr ]+PROTNUM ] == M[ tp+1 ]);
+} /* end is */
+
+
+/* Check correctness of an especially clumsy assignment statement
+ */
+
+void typref(virt, tp)
+virtaddr *virt;
+word tp;
+{
+ word t1, t2, t3;
+ int knd;
+
+ if (virt->mark == M[ virt->addr+1 ]) /* none always allowed */
+ {
+ t3 = M[ virt->addr ]; /* am of right hand side */
+ t1 = M[ t3+PROTNUM ];
+ if (t1 == AINT || t1 == AREAL || t1 == AVIRT) errsignal(RTEINCAS);
+ t2 = M[ tp ]; /* right hand side type */
+ if (t2 == FILETYPE)
+ {
+ if (t1 != FILEOBJECT) errsignal(RTEINCAS);
+ }
+ else
+ if (t2 == PURECOROUTINE || t2 == PUREPROCESS)
+ {
+ if (t2 == PURECOROUTINE) knd = COROUTINE;
+ else knd = PROCESS;
+ if (prototype[ t1 ]->kind != knd) errsignal(RTEINCAS);
+ }
+ else
+ {
+ if (t2 != CLASSTYPE) errsignal(RTEINCAS);
+ if (!pref(t3, M[ tp+1 ])) errsignal(RTEINCAS);
+ }
+ }
+} /* end typref */
+
+
+/* Check correctness of a dynamic assignment
+ */
+
+void typed(ldim, lt, rdim, rt, virt)
+word ldim, lt, rdim, rt;
+virtaddr *virt;
+{
+ if (ldim != rdim) errsignal(RTEINCAS);
+ if (ldim == 0) typref(virt, lt);
+ else
+ if (lt != rt) errsignal(RTEINCAS);
+} /* end typed */
+
+
+/* Search the SL chain of object am to find the nearest Y such that Y in A.
+ * prot = prototype number of A
+ */
+
+word loadt(am, prot)
+word am, prot;
+{
+ word t1, t2, t3, t4;
+
+ while( !pref(am, prot) )
+ {
+ t1 = am+M[ am ]+SL;
+ t2 = M[ t1 ]; /* try next object in chain */
+ t3 = M[ t1+1 ];
+ t4 = M[ t2+1 ];
+ if( t3 != t4 ) errsignal( RTEFTPMS );
+ am = M[ t2 ];
+ }
+ return (am);
+}
+
+
+/* Compute type of a formal parameter - see also typep (below). */
+
+static bool typep0(am, pdaddr, protp, dim, tp)
+word am, pdaddr;
+bool protp;
+word *dim, *tp;
+{
+ word t1;
+ protdescr *ptr;
+
+ if (protp) /* prototype number on input */
+ {
+ ptr = prototype[ pdaddr ];
+ *dim = ptr->nrarray;
+ *tp = ptr->finaltype;
+ }
+ else /* type address on input */
+ {
+ *dim = M[ pdaddr+1 ];
+ *tp = M[ pdaddr+2 ];
+ }
+ if (M[ *tp ] != FORMTYPE) return (TRUE);
+ else
+ {
+ t1 = M[ *tp+1 ]; /* SL prototype number */
+ if (t1 == DUMMY) return (FALSE);
+ else /* undefined */
+ {
+ *tp = loadt(am, t1)+M[ *tp+2 ];
+ *dim += M[ *tp ]; /* accumulate dim */
+ *tp = M[ *tp+1 ];
+ return (TRUE); /* AIL 1989.02.02 */
+ }
+ }
+} /* end typep0 */
+
+
+void typep(am, nr, dim, tp) /* Compute type of formal parameter */
+word am, nr;
+word *dim, *tp;
+{
+ if (!typep0(am, M[ prototype[ M[ am+PROTNUM ] ]->pfdescr+nr ],
+ FALSE, dim, tp)) errsignal(RTESYSER);
+} /* end typep */
+
+
+/* Auxiliary function for heads, almost the same as pref.
+ */
+
+static bool prefh(tp, prot)
+word tp, prot;
+{
+ word t1, t2;
+ protdescr *ptr;
+
+ ptr = prototype[ M[ tp+1 ] ];
+ t2 = ptr->preflist;
+ t1 = t2+ptr->lthpreflist-1;
+ do
+ {
+ if (M[ t1 ] == prot) return (TRUE);
+ else t1--;
+ } while (t1 >= t2);
+ return (FALSE);
+} /* end prefh */
+
+
+/* Check compatibility of generalized types, used by heads only.
+ */
+
+static bool typef(dima, ta, dimb, tb)
+word dima, ta, dimb, tb;
+{
+ word t1, t2;
+ int knd;
+
+ if (dima != dimb) errsignal(RTEINCHS); /* incompatible headers */
+ if (ta != tb) /* types different somehow */
+ {
+ if (dima != 0) errsignal(RTEINCHS); /* dim must be 0 now */
+ t1 = M[ ta ];
+ t2 = M[ tb ];
+ if (t1 == PRIMITIVETYPE || t1 == FILETYPE) errsignal(RTEINCHS);
+ if (t2 == PRIMITIVETYPE || t2 == FILETYPE) errsignal(RTEINCHS);
+ if (t1 != PURECOROUTINE && t1 != PUREPROCESS)
+ {
+ if (t2 == PURECOROUTINE || t2 == PUREPROCESS) return (TRUE);
+ else
+ {
+ if (!prefh(ta, M[ tb+1 ]))
+ {
+ if (!prefh(tb, M[ ta+1 ])) errsignal(RTEINCHS);
+ else return (TRUE);
+ }
+ }
+ }
+ else /* something pure */
+ {
+ if (t1 != t2)
+ {
+ /* AIL : t1 below replaced with t2, 1989.02.02 */
+ /* if (t1 == PURECOROUTINE || t1 == PUREPROCESS) */
+ if (t2 == PURECOROUTINE || t2 == PUREPROCESS)
+ knd = RECORD; /* used as junk */
+ else knd = prototype[ M[ tb+1 ] ]->kind;
+
+ if ((t1 == PURECOROUTINE && knd != COROUTINE) ||
+ (t1 == PUREPROCESS && knd != PROCESS))
+ {
+ if ((t1 != PURECOROUTINE) ||
+ (knd != PROCESS && t2 != PUREPROCESS))
+ return (TRUE);
+ }
+ }
+ }
+ }
+ return (FALSE);
+} /* end typef */
+
+
+/* Verify the compatibility of formal/actual procedure (function) heads.
+ */
+
+void heads(virt, nr)
+virtaddr *virt;
+word nr;
+{
+ word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv;
+ protdescr *ptr;
+ bool junk;
+ word x[ MAXHDLEN+1 ], y[ MAXHDLEN+1 ];
+ /* The two arrays declared above may be dynamically generated as objects */
+ /* upon entry to heads. In fact heads was implemented this way in the */
+ /* original LOGLAN running system on MERA-400 */
+
+ oba = M[ virt->addr ];
+ ptr = prototype[ M[ oba+PROTNUM ] ];
+ fp = M[ ptr->pfdescr+nr ]; /* parameter description pointer */
+ slen = M[ fp+2 ]; /* length of its desclist */
+ if (slen > MAXHDLEN) errsignal(RTEFHTLG);
+ ftv = oba+M[ ptr->parlist+nr ]; /* type value pointer */
+ g = M[ ftv ];
+ if (M[ ftv+1 ] == M[ g+1 ]) /* not none */
+ g = M[ g ]; /* am of SL */
+ else errsignal(RTESLCOF); /* SL chain cut off */
+ gp = M[ ftv+2 ]; /* prototype number of g */
+ ptr = prototype[ gp ];
+ t2 = M[ fp ]; /* t2 = F-kind */
+ if (ptr->kind == FUNCTION)
+ {
+ if (t2 != FORMFUNC) errsignal(RTEINCHS);
+ junk = typep0(g, gp, TRUE, &dim, &tp);
+ junk = typep0(oba, fp+2, FALSE, &t1, &t2);
+ if (typef(dim, tp, t1, t2)) errsignal(RTEINCHS);
+ }
+ else
+ if (t2 != FORMPROC) errsignal(RTEINCHS);
+ if (slen != ptr->lthparlist) /* incompatible lengths */
+ errsignal(RTEINCHS);
+ t1 = M[ fp+1 ]-1; /* oba descriptlist */
+ t2 = ptr->pfdescr-1; /* g descriptlist */
+ for (i = 1; i <= slen; i++ ) /* verify second order lists */
+ {
+ x[ i ] = DUMMY; /* mark entry as empty */
+ y[ i ] = DUMMY;
+ fp = M[ t1+i ]; /* first type pointer */
+ gp = M[ t2+i ]; /* second type pointer */
+ tp = M[ fp ]; /* first type ordinal */
+ if (tp != M[ gp ]) errsignal(RTEINCHS);
+ if (tp == FORMTYPE)
+ {
+ x[ i ] = fp; /* save pointers to formal types */
+ y[ i ] = gp;
+ }
+ else
+ {
+ if (tp == PARIN || tp == PAROUT || tp == PARINOUT)
+ {
+ /* AIL 1989.02.02 */
+ /* if (typep0(oba, fp, FALSE, &dim, &tp)) */
+ if (! typep0(oba, fp, FALSE, &dim, &tp))
+ { /* undefined yet */
+ /* search preceding formals */
+ for (j = 1; j <= i; j++ )
+ if (x[ j ] == M[ fp+2 ])
+ break;
+ if (j > i) errsignal(RTEINCHS);
+ if (y[ j ] != M[ gp+2 ]) errsignal(RTEINCHS);
+ }
+ else /* already defined */
+ {
+ for (j = 1; j <= i; j++ )
+ if (y [ j ] == M[ gp+2 ])
+ errsignal(RTEINCHS);
+ junk = typep0(g, gp, FALSE, &j, &ftv);
+ junk = typef(dim, tp, j, ftv);
+ }
+ }
+ }
+ }
+}
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include "tcpip.h"
+
+#include <time.h>
+
+/* Utility routines */
+
+
+word entier(x) /* Compute entier (floor) */
+double x;
+{
+ word i;
+
+ if (x >= 0.0)
+ {
+ i = (word)x;
+ return(i);
+ }
+ else
+ {
+ i = (word)(-x);
+ i = -i;
+ if ((double)i <= x) return(i); else return(i-1);
+ }
+} /* end entier */
+
+
+word shift(x, n) /* shift x by n bits */
+word x, n;
+{
+ if (n == 0) return (x);
+ if (n > 0) return (x << n);
+ else return ( (x >> -n) & ~(~(word)0 << (8*sizeof(word)+n)) );
+} /* end shift */
+
+
+char *asciiz(virt) /* Get ASCIIZ string from arrayof char */
+virtaddr *virt;
+{
+ word am;
+ int len, i;
+ char *cp;
+
+ if (member(virt, &am))
+ {
+ len = M[ am ]-3; /* length of the string */
+ cp = ballocate(len+1); /* allocate buffer for the string */
+ if (cp == NULL) errsignal(RTEMEMOV);
+ for (i = 0; i < len; i++) cp[ i ] = (char) M[ am+3+i ];
+ cp[ len ] = '\0'; /* terminate string with 0 byte */
+ return (cp);
+ }
+ else errsignal(RTEREFTN); /* reference to none */
+} /* end asciiz */
+
+
+void addext(fname, ext) /* Add extension to a file name */
+char *fname, *ext;
+{
+ char *cp;
+
+ cp = fname;
+ while (*cp != '\0' && *cp != '.') cp++;
+ strcpy(cp, ext);
+} /* end addext */
+
+
+void usage()
+{
+#if DLINK
+ fprintf(stderr,"Usage: int [-i] [-d] [-m memsize] [-r console] file\n");
+ net_logoff();
+#elif TCPIP
+ fprintf(stderr,"Usage: int [-i] [-d] [-m memsize]\n");
+ fprintf(stderr,"\t[-r console_number #_of_slaves_to_wait_for|master_address]\n");
+ fprintf(stderr,"\tfile\n");
+ fprintf(stderr,"master address in form: nnn.nnn.nnn.nnn:[port]\n");
+ fprintf(stderr," or : host_name:[port]\n");
+ fprintf(stderr,"default port number : %d\n",PORT);
+#else
+ fprintf(stderr,"Usage: int [-i] [-d] [-m memsize] file\n");
+#endif
+ exit(4);
+}
+
+
+void abend(msg) /* Print error message and abort */
+char *msg;
+{
+ fprintf(stderr, "Error: %s\n", msg);
+#if DLINK
+ net_logoff();
+#endif
+ exit(8);
+} /* end abend */
+
+
+/* Pseudo random number generator */
+
+static int ranpat1 = 7, ranpat2 = 503, ranpat3 = 15661;
+
+void ranset() /* Initialize generator */
+{
+ long tim;
+
+ time(&tim);
+ ranpat1 = tim % 30269;
+ ranpat2 = tim % 30307;
+ ranpat3 = tim % 30323;
+} /* end ranset */
+
+
+double prandom() /* Produce next pseudo random number */
+{
+ int i;
+ double r;
+
+ ranpat1 = 171*(ranpat1 % 177)- 2*(ranpat1 / 177);
+ if (ranpat1 < 0) ranpat1 += 30269;
+ ranpat2 = 172*(ranpat2 % 176)-35*(ranpat2 / 176);
+ if (ranpat2 < 0) ranpat2 += 30307;
+ ranpat3 = 170*(ranpat3 % 178)-63*(ranpat3 / 178);
+ if (ranpat3 < 0) ranpat3 += 30323;
+ r = ranpat1/30269.0 + ranpat2/30307.0 + ranpat3/30323.0;
+ i = (int)r;
+ return (r-i);
+}
+
+
+void moveblock(from, to, len) /* Copy a block of memory */
+char *from, *to;
+word len;
+{
+ while (len-- > 0) *to++ = *from++;
+} /* end moveblock */
+
+
+/**************************************************************
+
+#define LINE 10
+void dump(pix, from, len)
+word pix, from;
+int len;
+{
+ int i;
+ memory M;
+
+ M = process[ pix ].M;
+ while (len > 0)
+ {
+ printf("%6ld: ", (long) from);
+ for (i = 0; i < LINE; i++) printf("%7ld", (long)M[from++]);
+ putchar('\n');
+ len -= LINE;
+ }
+}
+
+ **************************************************************/
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+
+#include <termio.h>
+#include <math.h>
+
+static int child_no=0;
+static int curx=0,cury=0;
+static int fcol=1,bcol=0;
+static int style=1;
+
+static Display *theDisplay;
+static Window myWindow,theWindow;
+static XClientMessageEvent theMessage;
+static XEvent retEv;
+
+static word w;
+
+static struct { int x,y,fcol,bcol,style; } xystack[16];
+static stackptr=0;
+
--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#define send_par(par) theMessage.data.s[cnt++]=(short)(param[par].xword);
+#define send_shrt(wd) theMessage.data.s[cnt++]=(short)(wd);
+#define send_word(wd) theMessage.data.s[cnt++]=(short)((wd)&0xffff); \
+ theMessage.data.s[cnt++]=(short)(((wd)>>16)&0xffff);
+
+
+#define send_sig \
+ theMessage.type=ClientMessage; \
+ theMessage.format = 16; \
+ theMessage.message_type = nrproc; \
+ XSendEvent(theDisplay,theWindow,True,NoEventMask,&theMessage); \
+ XFlush(theDisplay);
+
+#define nxtev do XNextEvent( theDisplay, &retEv ); \
+ while( retEv.type!=ClientMessage ); \
+ cnt = 0;
+
+#define rec_par(par) param[par].xword=(int)(retEv.xclient.data.s[cnt++]);
+#define rec_shrt(sh) sh = (int)(retEv.xclient.data.s[cnt++]);
+#define rec_word(wd) wd = (int)(retEv.xclient.data.s[cnt++]) & 0xffff; \
+ wd |= (int)(retEv.xclient.data.s[cnt++]) << 16;
+
+
+
+ case GRON :
+ if ((theDisplay = XOpenDisplay(NULL)) == NULL){
+ fprintf (stderr,"\nint: Can't open display\n");
+ exit(1);
+ }
+ myWindow = XCreateWindow(
+ theDisplay,
+ RootWindow(theDisplay,DefaultScreen(theDisplay)),
+ 0,0,1,1,0,
+ CopyFromParent,InputOnly,CopyFromParent,
+ 0,NULL
+ );
+ if( (child_no=fork())==0 ){
+ char me[16];
+ sprintf(me,"%d",(int)myWindow);
+ execlp("herc","herc",me,NULL);
+ }
+ graphmode = TRUE;
+ curx=cury=0;
+ nxtev
+ rec_word(theWindow);
+ break;
+
+ case GROFF :
+ if( graphmode == FALSE ) break;
+ send_sig
+ child_no=0;
+ graphmode = FALSE;
+ break;
+
+ case CLS :
+ send_sig
+ break;
+
+
+ case PUSHXY :
+ xystack[stackptr].x = curx;
+ xystack[stackptr].y = cury;
+ xystack[stackptr].fcol = fcol;
+ xystack[stackptr].bcol = bcol;
+ xystack[stackptr].style= style;
+
+ stackptr++;
+ if( stackptr == 16 ) stackptr--;
+
+ break;
+
+
+ case POPHXY :
+
+ stackptr--;
+ if( stackptr < 0 ){
+ stackptr = 0;
+ break;
+ }
+
+ curx = xystack[stackptr].x;
+ cury = xystack[stackptr].y;
+ fcol = xystack[stackptr].fcol;
+ bcol = xystack[stackptr].bcol;
+ style= xystack[stackptr].style;
+
+ cnt = 0;
+ nrproc = COLOR;
+ send_shrt(fcol)
+ send_sig
+
+ cnt = 0;
+ nrproc = BORDER;
+ send_shrt(bcol)
+ send_sig
+
+ cnt = 0;
+ nrproc = STYLE;
+ send_shrt(style)
+ send_sig
+
+ break;
+
+
+ case POINT :
+ send_par(0)
+ send_par(1)
+ send_sig
+ case MOVE :
+ curx=param[0].xword;
+ cury=param[1].xword;
+ break;
+
+ case DRAW :
+ send_shrt(curx)
+ send_shrt(cury)
+ send_par(0)
+ send_par(1)
+ send_sig
+ curx=param[0].xword;
+ cury=param[1].xword;
+ break;
+
+ case INXPOS :
+ param[0].xword = curx;
+ break;
+
+ case INYPOS :
+ param[0].xword = cury;
+ break;
+
+ case HFILL :
+ case VFILL :
+ send_shrt(curx)
+ send_shrt(cury)
+ send_par(0)
+ send_sig
+ break;
+
+ case HASCII :
+ send_shrt(curx)
+ send_shrt(cury)
+ send_par(0)
+ send_sig
+ if( param[0].xword != 0 ) curx += 8;
+ break;
+
+ case COLOR :
+ fcol = param[0].xword;
+ send_par(0)
+ send_sig
+ break;
+
+ case BORDER :
+ bcol = param[0].xword;
+ send_par(0)
+ send_sig
+ break;
+
+ case STYLE :
+ bcol = param[0].xword;
+ send_par(0)
+ send_sig
+ break;
+
+ case INPIX :
+ send_par(0)
+ send_par(1)
+ send_sig
+ curx=param[0].xword;
+ cury=param[1].xword;
+ nxtev
+ rec_par(2)
+ break;
+
+ case OUTSTRING :
+ {
+ char *s= (char *)(M + strings + param[ 0 ].xword + 1);
+ int signs=M[ strings + param[ 0 ].xword ];
+ nrproc=HASCII;
+ while( signs-- ){
+ word sign=0;
+ cnt = 0;
+ send_shrt(curx)
+ send_shrt(cury)
+ send_shrt(sign)
+ send_sig
+ sign = (word)(*s);
+ cnt = 0;
+ send_shrt(curx)
+ send_shrt(cury)
+ send_shrt(sign)
+ send_sig
+ s++;
+ curx+=8;
+ }
+ }
+ break;
+
+ case GETMAP :
+ {
+ word map;
+ word x=param[0].xword;
+ word y=param[1].xword;
+ word w = x - curx + 1;
+ word h = y - cury + 1;
+ x = curx;
+ y = cury;
+ if( w <= 0 ){ w=-w; x-=w; }
+ if( h <= 0 ){ h=-h; y-=h; }
+ send_shrt(x)
+ send_shrt(y)
+ send_shrt(w)
+ send_shrt(h)
+ send_sig
+ nxtev
+ rec_word(map)
+ newarry((word) 1, 3, (word)AINT, ¶m[ 2 ].xvirt, &am);
+ M[ am+3 ] = map;
+ M[ am+4 ] = w;
+ M[ am+5 ] = h;
+ }
+ break;
+
+ case PUTMAP :
+ case ORMAP :
+ case XORMAP :
+ if (member(¶m[ 0 ].xvirt, &am)){
+ send_word( M[ am+3 ] )
+ send_shrt(curx)
+ send_shrt(cury)
+ send_shrt( M[ am+4 ] )
+ send_shrt( M[ am+5 ] )
+ send_sig
+ }else errsignal(RTEREFTN);
+ break;
+
+/*
+ case PATERN :
+ patern((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword,
+ (int *) ¶m[ 2 ].xword, (int *) ¶m[ 3 ].xword);
+ break;
+
+ case INTENS :
+ intens((int *) ¶m[ 0 ].xword);
+ break;
+
+ case PALETT :
+ pallet((int *) ¶m[ 0 ].xword);
+ break;
+
+ case VIDEO :
+ if (member(¶m[ 0 ].xvirt, &am))
+ if (M[ am ] >= 0x8000L/sizeof(word))
+ video(normalize((char *) &M[ am+3 ]));
+ else errsignal(RTEILLAB);
+ else errsignal(RTEREFTN);
+ break;
+
+ case HPAGE :
+ i = (int) param[ 1 ].xword;
+ if (i == 0) graphmode = FALSE;
+ else
+ if (i == 1) graphmode = TRUE;
+ hpage((int *) ¶m[ 0 ].xword, &i,
+ (int *) ¶m[ 2 ].xword);
+ break;
+
+ case NOCARD :
+ param[ 0 ].xword = nocard(NULL);
+ break;
+*/
+
+ case TRACK :
+ send_par(0)
+ send_par(1)
+ send_sig
+ nxtev
+ rec_shrt( curx )
+ rec_shrt( cury )
+ break;
+
+ case INKEY :
+ if( child_no == 0 ) param[ 0 ].xword = inkey();
+ else
+ {
+ int keycode;
+ send_sig
+ nxtev
+ rec_word(keycode)
+ param[ 0 ].xword = keycode;
+ }
+ break;
+
+/*
+ case HFONT :
+ hfont((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+
+ case HFONT8 :
+ param[ 0 ].xword = 0;
+ param[ 1 ].xword = 0;
+ hfont8((int *) ¶m[ 0 ].xword, (int *) ¶m[ 1 ].xword);
+ break;
+*/
+
+ case CIRB :
+ {
+ double alfa,beta,aspect,abs; word kolb,wwyp;
+
+ send_par(0)
+ send_par(1)
+ param[2].xword *= 2;
+ send_par(2)
+ alfa = (double)(param[3].xreal);
+ beta = (double)(param[4].xreal);
+ kolb = param[5].xword;
+ wwyp = param[6].xword;
+
+ aspect = (double)(param[7].xword) / (double)(param[8].xword);
+ aspect *= (double)(param[2].xword);
+
+ alfa = alfa / M_PI * 180.0 * 64.0 ;
+ beta = beta / M_PI * 180.0 * 64.0 ;
+
+ abs = alfa - beta;
+ if( abs < 0.0 ) abs = -abs;
+ if( abs < 0.0001 )
+ beta+=360.0*64.0;
+
+ send_shrt( (unsigned)aspect )
+ send_shrt( (unsigned)alfa )
+ send_shrt( (unsigned)beta )
+ send_sig
+ }
+ break;
+
+/* MOUSE */
+
+ case INIT :
+ param[ 0 ].xbool = 2;
+ param[ 1 ].xbool = lbool(1);
+ break;
+
+ case STATUS :
+ send_sig
+ nxtev
+ rec_par(0)
+ rec_par(1)
+ rec_par(2)
+ rec_par(3)
+ rec_par(4)
+ break;
+
+ case GETPRESS :
+ case GETRELEASE :
+ send_par(0)
+ send_sig
+ nxtev
+ rec_par(1)
+ rec_par(2)
+ rec_par(3)
+ rec_par(4)
+ rec_par(5)
+ rec_par(6)
+ break;
+
+ case SHOWCURSOR :
+ case HIDECURSOR :
+ case SETPOSITION :
+ case SETWINDOW :
+ case DEFCURSOR :
+ case SETSPEED :
+ case SETMARGINS :
+ case SETTHRESHOLD :
+ break;
+
+ case GETMOVEMENT :
+ send_sig
+ nxtev
+ rec_par(0)
+ rec_par(1)
+ break;
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE AL1
+C-----------------------------------------------------------------------
+C
+C 1983.01.06
+C
+C * * * * * * * * * * * * * * * * * * * *
+C
+C THE FOLLOWING FILE UNITS ARE USED :
+C
+C 1 - INTERACTIVE INPUT FROM THE TERMINAL ( FOR TESTING ONLY )
+C 2 - INTERACTIVE OUTPUT TO THE TERMINAL ( FOR TESTING ONLY )
+C 13 - LISTING OUTPUT ( TEST MESSAGES )
+C 14 - WORKING FILE SCRATCH - CODE FROM PARSER AND L-CODE
+C ( USED ONLY VIA SEEK,PUT,GET WITH IBUF3 )
+C 15 - L-CODE OUTPUT ( TEXTUAL (HEXADECIMAL) REPRESENTATION
+C OF SYMBOL TABLE AND L-CODE )
+C
+C * * * * * * * * * * * * * * * * * * * *
+C
+C STRUMIENIE :
+C 3 - BINARNY - KOD Z PARSERA
+C LO - WYDRUKI KONTROLNE /ZNAKOWY/
+C 3 - PRODUKOWANE CZWORKI /BINARNY/ - SEKWENCYJNIE,
+C OD REKORDU NUMER IOP(2)+1 .
+C /REKORD O NUMERZE IOP(2) BUFORUJE STOS "CASE"/
+C
+C * * * * * * * * * * * * * * * * * * * *
+C
+C
+C
+C
+C ##### OUTPUT CODE : 200 .
+C
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
+C
+ COMMON/SUMMARY/FREE
+ COMMON/CASE/DEEP,OVER
+C
+C
+cdeb --------------- added ------------
+ common /brid/breaklid
+c breaklid - numer w displayu (dla interpretera) procedury breakl
+
+ common /debug/deb,breakt(500),brnr,maxbr
+ logical deb
+cdeb -----------------------------------
+
+ common/MJLMSG/IERC,MSG
+cdsw ----------------------------
+ integer*4 msg
+cdsw ----------------------------
+cdsw&bc
+ common /stacks/ btsins, btstem
+C
+C
+ IERC=0
+ msg = 'al1 '
+C
+ CALL STEST
+C WCZYTANA OPCJA WYDRUKOW KONTROLNYCH
+ CALL SABORT
+C WYLAPANIE ABORTU
+C
+C
+ LSTWRD=LMEM-260
+C OSTATNIE ZAJETE SLOWO W BUFORZE WYJSCIOWYM / LMEM-259 .. LMEM-1 /
+ BOTTOM=LMEM-916
+ STACK(BOTTOM)=-1
+C DNO STOSU / LMEM-916 .. LMEM-516 / Z WARTOWNIKIEM = -1
+ FREE=LMEM-516-BOTTOM
+C ROZMIAR STOSU = 400
+ DEEP=LMEM-600
+C PUSTY STOS INSTRUKCJI "CASE" / LMEM-515 .. LMEM-260 /
+ QRECNR=IOP(2)
+C NAJWIEKSZY UZYTY NUMER REKORDU STRUMIENIA 3
+C
+cdsw&bc
+ btsins = lpml
+ btstem = lpmf
+cdsw ----------------- added ----------------------------------
+c inicjalizacje zmiennych z common przeniesione z podprogramow
+c przeniesione z sinit
+ stckag = 0
+ stcka0 = 8
+ do 1 i=1,14
+ stckap(i) = 8
+1 continue
+ stckap(5) = 10
+ stckap(6) = 4
+ apetyt(1) = 1
+#if WSIZE == 4
+ apetyt(2) = 1
+#else
+ apetyt(2) = 2
+#endif
+ apetyt(3) = 3
+ apetyt(4) = 2
+c przeniesione z scase
+ over = 0
+cdsw -----------------------------------------------------------------
+c
+ CALL SPASS2
+C
+cdeb ----------------- added -------------------
+c instrukcja L-kodu przekazujaca breaklid
+ if (.not.deb) go to 2001
+ call quadr1(211)
+ if(breaklid.eq.0) go to 2001
+ call quadr2(210,breaklid)
+2001 continue
+cdeb -------------------------------------------
+C
+C WYPISZ ZNACZNIK KONCA PRODUKOWANEGO KODU POSREDNIEGO
+ CALL QUADR1(200)
+C JESLI TRZEBA - WYPISZ BUFOR Z CZWORKAMI
+ IF(ERRFLG) GO TO 2000
+ IF(LSTWRD.EQ.LMEM-260)GO TO 1000
+cdsw ****************************
+cdsw QRECNR=QRECNR+1
+cdsw CALL SEEK(IBUF3,QRECNR)
+cdsw CALL PUT(IBUF3,IPMEM(LMEM-259))
+cbc write(18) (ipmem(i),i=lmem-259,lmem-4)
+ call ffwrite_ints(18, ipmem(lmem-259), 256)
+cbc
+cdsw *****************************
+C
+C
+C WRITE HEXADECIMAL REPRESENTATION OF SYMBOL TABLE AND L-CODE
+ 1000 CALL SLCSTOUT
+
+ 2000 CONTINUE
+
+ call ffclose(18)
+C CLOSED TEMPORARY 18 should BE AUTOMATICALLY DELETED but ...
+ call ffunlink(18)
+
+C
+C
+C WYLACZ 'RECOVERY'
+ CALL SRCVOFF
+C
+C
+C.....PRZYGOTUJ DANE STATYSTYCZNE
+C
+C
+ IPMEM(ISFIN-3)=QRECNR-IOP(2)
+C = LICZBA WYPRODUKOWANYCH REKORDOW Z KODEM POSREDNIM
+ IPMEM(ISFIN-4)=(400-FREE)/4
+C = % UZYTEGO STOSU /WZOR POPRAWNY DLA ROZMIARU = 400 /
+C
+C
+cdsw MSG=HAL1
+ CALL MESS
+C PRINT LISTING
+ CALL ML2
+C STOP
+C PO ABORCIE /BLAD W KOMPILATORZE/
+C7777 ERRFLG=.TRUE. CHANGED TO COMMENT 04.01.84
+CBC GO TO 1000
+ END
+
+
+ SUBROUTINE SPASS2
+C-----------------------------------------------------------------------------
+C
+C PROCEDURA STERUJACA PRZEBIEGIEM 2.
+C DWUKROTNIE PRZECHODZI PRZEZ WSZYSTKIE MODULY.
+C FAZA 1 : WYLICZANIE WARTOSCI STALYCH /INIT=TRUE/
+C - WYBIERA TYLKO MODULY ZAWIERAJACE STALE WYLICZANE
+C FAZA 2 : WLASCIWA GENERACJA KODU /INIT=FALSE/
+C - PRZECHODZI PRZEZ WSZYSTKIE MODULY ZAWIERAJACE INSTRUKCJE
+C W OBU FAZACH PRZECHODZI KOLEJNO PRZEZ MODULY I DLA KAZDEGO MODULU
+C WSTAWIA JEGO ADRES DO P ,WCZYTUJE PIERWSZY REKORD Z KODEM POSREDNIM,
+C USTAWIA WB I INDEKS SYMBOLU DLA SNEXT,INICJALIZUJE STRUKTURY DANYCH,
+C WOLA SDPDA.
+C
+C STARTUJE OD BLOKU WSKAZANEGO PRZEZ NBLUS.
+C DLA KAZDEGO MODULU REKORDY Z KODEM POSREDNIM Z PARSERA POWIAZANE
+C SA W LISTE : SLOWO +8 ZAWIERA NUMER PIERWSZEGO REKORDU /JESLI SLOWO
+C +9 =0 TO LISTA JEST PUSTA/ A SLOWO +9 INDEKS PIERWSZEGO SYMBOLU
+C W REKORDZIE. SLOWO 256 REKORDU ZAWIERA NUMER NASTEPNEGO REKORDU
+C LISTY. KOD DLA KAZDEGO MODULU JEST ZAKONCZONY PARA <FIN,NUMER ETYKIETY>.
+C
+C SLOWO +2 W OPISIE MODULU ZAWIERA ADRES /W IPMEM/ NASTEPNEGO MODULU.
+C
+#include "stos.h"
+#include "blank.h"
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+C
+ LOGICAL INIT
+C = TRUE DLA FAZY WYLICZANIA STALYCH
+C
+C INTERNAL 2000 CHANGED TO COMMENT 04.01.84
+C PUNKT POWROTU PO PRZEPELNIENIU STOSU W SPUSH
+C
+C
+C................. FAZA WYLICZANIA STALYCH
+C /PIERWSZE PRZEJSCIE PRZEZ KOD DLA MODULOW/
+C
+ INIT=.TRUE.
+C
+C.....USTAW P NA BLOK GLOWNY
+ 100 P=NBLUS
+C
+C
+C.....INICJALIZACJA DLA PROTOTYPU P
+ 1000 CONTINUE
+
+ IF(.NOT.TESTC) GOTO 5000
+ call ffputcs(13,' ------------ PASS2 ---------- P =')
+ call ffputi (13,P,6)
+ call ffputnl(13)
+5000 CONTINUE
+
+C POMIN,JESLI TO PROTOTYP FORMALNY/PROC.,FUN.,SYGNAL/
+ IF(IAND(ISHFT(IPMEM(P),-4),15).NE.0)GO TO 2000
+C
+C ... PODCZAS WYLICZANIA STALYCH POMIN,JESLI MODUL ICH NIE MA
+ IF(INIT.AND.IPMEM(P-1).EQ.0)GO TO 2000
+C
+C POMIN , JESLI NIE MA INSTRUKCJI
+ IF(IPMEM(P+9).EQ.0)GO TO 2500
+C
+C ... ODSZUKAJ PIERWSZY REKORD Z KODEM POSREDNIM
+ N=IPMEM(P+8)
+C WSTAW NUMER I WCZYTAJ PIERWSZY REKORD
+ IX(258)=N
+ CALL SEEK(IBUF3,N)
+
+ IF(.NOT.TESTC) GOTO 6000
+ call ffputcs(13,' REKORD')
+ call ffputi (13,N,5)
+ call ffputcs(13,' SYMBOL')
+ call ffputi (13,IPMEM(P+9),4)
+ call ffputnl(13)
+6000 CONTINUE
+
+ CALL GET(IBUF3,IX)
+ WB=IPMEM(P+9)
+C WSTAW INDEKS BIEZACEGO SYMBOLU,USTAW WB
+ IX(257)=WB
+ WB=IX(WB)
+
+C INICJALIZACJA
+
+ CALL MPROTO
+ CALL SDPDA(INIT)
+ CALL MPROTC
+
+
+C...........WEZ NASTEPNY MODUL
+ 2000 P=IPMEM(P+2)
+ IF(P.NE.0)GO TO 1000
+C WSZYSTKIE MODULY JUZ SKOMPILOWANE.
+C
+C................. FAZA GENERACJI KODU
+C /DRUGIE PRZEJSCIE PRZEZ KOD DLA MODULOW/
+C
+ IF(.NOT.INIT)RETURN
+ INIT=.FALSE.
+ GO TO 100
+C
+C
+C.....MODUL BEZ INSTRUKCJI. PREFIKS?
+ 2500 IDL=IPMEM(P+21)
+ IF(IDL.EQ.0)GO TO 2600
+C TAK. PRZEPISZ INFORMACJE O INSTRUKCJACH PO INNER
+ IPMEM(P-7)=IPMEM(IDL-7)
+ GO TO 2000
+C ... BEZ PREFIKSU. DLA KLASY,REKORDU WSTAW: BRAK INSTR. PO INNER
+ 2600 IF(IAND(IPMEM(P),15).NE.1)IPMEM(P-7)=0
+cdsw&bc
+ if (.not. init) call stclass
+ GO TO 2000
+ END
+
+
+ subroutine stclass
+ implicit integer(a-z)
+#include "blank.h"
+c
+c not yet used as prefix
+ ipmem(p+1) = 0
+c begin of module
+ call quadr2(184, p)
+c begin of instructions
+ call quadr1(179)
+c inner
+ call quadr2(178, ipmem(p+23))
+c after inner label
+ call quadr2(181, 1)
+c fin
+ call quadr1(194)
+c lastwill
+ call quadr1(174)
+ ipmem(p+8) = 0
+c back
+ call quadr1(193)
+c end module
+ call quadr1(185)
+ return
+ end
+
+ SUBROUTINE SDPDA(INICJA)
+C-----------------------------------------------------------------------------
+C
+C WERSJA 1983.03.09
+C
+C GLOBAL JUMPS ARE CHANGED TO LOCAL JUMPS IF POSSIBLE OTHERWISE THEY ARE
+C CHANGED TO COMPUTED JUMPS 8.5.84
+C
+C MAIN ROUTINE OF SEMANTIC ANALYSIS AND CODE GENERATION
+C GLOWNA PROCEDURA ANALIZY SEMANTYCZNEJ I GENERACJI KODU POSREDNIEGO
+C /CZWOREK/ DLA MODULU.
+C PRACUJE JAK DETERMINISTYCZNY AUTOMAT ZE STOSEM STEROWANY SYMBOLEM
+C WEJSCIOWYM.
+C W ZALEZNOSCI OD WB /SYMBOL WEJSCIOWY/ WYBIERANA JEST AKCJA DO WYKONANIA
+C O ETYKIECIE 100*WB : OD 100 DO 7200.
+C WB MUSI MIEC NADANA WARTOSC PRZED WYWOLANIEM SDPDA.
+C
+C DLA KAZDEGO MODULU WOLANA DWUKROTNIE:
+C PIERWSZY RAZ W FAZIE WYLICZANIA STALYCH /O ILE MODUL ZAWIERAL
+C STALE WYLICZANE/ I DRUGI RAZ W FAZIE GENERACJI KODU /O ILE
+C BYLY INSTRUKCJE/.
+C W FAZIE WYLICZANIA STALYCH PO WYSTAPIENIU ZNACZNIKA PIERWSZEJ
+C INSTRUKCJI ZASTEPUJE W PROTOTYPIE ADRES POCZATKU KODU DLA MODULU
+C PRZEZ NUMER REKORDU I MIEJSCE W REKORDZIE ZAWIERAJACE TEN ZNACZNIK.
+C
+C
+C
+C ##### OUTPUT CODE : 15 , 23 , 31 , 33 , 34 , 35 , 36 , 41 ,
+C 85 , 132 , 145 , 149 , 151 , 152 ,
+C 172 , 173 , 176 , 177 , 178 , 179 ,
+C 181 , 182 , 186 , 187 .
+C
+C
+C ##### DETECTED ERROR(S) : 407 , 410 , 411 , 414 , 415 , 416 ,
+C 418 , 420 , 421 , 422 , 423 , 424 , 426 , 427 ,
+C 428 , 429 , 430 , 440 , 444 , 449 , 454 , 604 .
+C
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+C STACK - STOS DLA ANALIZY SEMANTYCZNEJ. OD LEWEJ WKLADANE SA
+C ELEMENTY,OD PRAWEJ OPISY PARAMETROW OUTPUT.
+C KAZDY ELEMENT STOSU ZAJMUJE KILKA KOLEJNYCH SLOW
+C OZNACZANYCH -9,...,-1,0. ZEROWE SLOWO OKRESLA RODZAJ
+C ELEMENTU.
+C OPISY PAR. OUTPUT ZAJMUJA ZAWSZE 12 SLOW: -9,..,+2
+C STOS /400 SLOW + WARTOWNIK/ ZAJMUJE W TABLICY IPMEM
+C SLOWA OD BOTTOM = LMEM-916 DO LMEM-516
+C ELEMENTY STOSU :
+C 0 - UNIWERSALNY
+C 1 - STALA
+C 2 - WARTOSC
+C 3 - ZMIENNA
+C 4 - ELEMENT TABLICY DYN.
+C 5 - TABLICA STATYCZNA
+C 6 - OPIS PETLI "FOR"
+C 7 - NAZWA TYPU
+C 8 - REKORD
+C 9 - KLASA
+C 10 - BLOK PREFIKSOWANY
+C 11 - PROCEDURA
+C 12 - FUNKCJA
+C 13 - SYGNAL
+C 14 - OPERATOR
+C BOTTOM - WSKAZUJE DNO STOSU / WARTOWNIKA = -1 /
+C VALTOP - CZUBEK STOSU /INDEKS ZEROWEGO SLOWA/
+C VLPREV - INDEKS ZEROWEGO SLOWA POPRZEDNIEGO ELEMENTU
+C STCKAG,STCKA0,STCKAP - TABLICA -1..14 APETYTOW ELEMENTOW STOSU
+C /TZN. STCKAP(I)=APETYT ELEMENTU TYPU I/
+C STCKAP(-1)= 0 =APETYT WARTOWNIKA DLA POP
+C APETYT - TABLICA OKRESLAJACA DLA KAZDEGO RODZAJU TYPU JEGO
+C APETYT. 1,2,3,4 --> 1,2,3,2
+C LSTFOR - INDEKS OSTATNIEGO SLOWA ZAJETEGO PRZEZ PETLE FOR
+C LSTLSE - " " LSE NA STOSIE /LSE ,TZN. LEWE STRONY
+C PODSTAWIENIA SA UMIESZCZONE POWYZEJ LSTFOR DO LSTLSE/
+C KIND - RODZAJ WOLANEGO MODULU: 0-ZWYKLY,1-VIRTUALNY,2-FORMALNY
+C PHADR - ATS ADRESU FIZYCZNEGO POLA DANYCH GENEROWANEGO OBIEKTU
+C LUB 0 ,GDY ADR.FIZYCZNY TRZEBA ODTWORZYC Z ADR.VIRT.
+C LASTPR - JESLI NA STOSIE JEST FUNKCJA,PROCEDURA,KLASA,REKORD,
+C SYGNAL,BLOK PREF. , DLA KTOREGO PAMIETANY JEST TYLKO
+C ADRES POSREDNI ZAMIAST PELNEGO ADR.VIRTUALNEGO, TO
+C LASTPR= INDEKS TEGO ELEMENTU; INACZEJ ZERO
+C FSTOUT - INDEKS PIERWSZEGO SLOWA ZAJETEGO PRZEZ OPISY PAR.
+C OUTPUT
+C WB - BIEZACY SYMBOL /WEJSCIOWY/ KODU POSREDNIEGO
+C RESULT - ATS WYNIKU OPERACJI
+C CONSNR - TABLICA ZAWIERAJACA ADRESY /INDEKSY W IPMEM/ TYPOW:
+C BOOLEAN,CHAR,INTEGER,NONE,REAL,STRING I UNIWERSALNEGO .
+C LSTSAF - OSTATNI ELEMENT STOSU NIE WYMAGAJACY ZABEZPIECZENIA
+C PRZEZ SAFEST ,USTAWIA SAFEST,OBNIZA SPOP.
+C TEMPNR - POCZATEK ADRESOW W /BUDOWANEJ/ TABLICY SYMBOLI
+C UZYWANYCH DLA ATRYBUTOW ROBOCZYCH,
+C ADRESY WIEKSZE ZAREZERWOWANE DLA PETLI FOR,
+C ZMNIEJSZANE O 6 NA POCZATKU, A ZWIEKSZANE NA KONCU
+C PETLI.
+C LSTEMP - NAJMNIEJSZY UZYTY ADRES ATRYBUTU ROBOCZEGO
+C
+C QRECNR - OSTATNI UZYTY NUMER REKORDU W STRUMIENIU 3
+C BUFOR NA GENEROWANY KOD POSREDNI WYSYLANY NA STRUMIEN 3
+C ZAJMUJE 259 SLOW W TABLICY IPMEM : OD LMEM-259 DO LMEM-1 .
+C LSTWRD - INDEKS OSTATNIEGO ZAJETEGO SLOWA W BUFORZE.
+C
+C ZASADA WYPELNIANIA BUFORA : SA CO NAJMNIEJ 4 WOLNE SLOWA
+C / LSTWRD < LMEM-4 / . PROCEDURY QUADR1 .. QUADR4
+C DOPISUJA ZA LSTWRD SWOJE ARGUMENTY I ZWIEKSZAJA LSTWRD.
+C JESLI POZOSTANA MNIEJ NIZ 4 SLOWA - WOLAJA QDROUT.
+C QDROUT WYPISUJE PIERWSZE 256 SLOW I OSTATNIE 3 SLOWA
+C PRZEPISUJE NA POCZATEK, ZMNIEJSZAJAC LSTWRD O 256.
+C FRSTTS - PIERWSZE SLOWO W IPMEM NA NOWE OPISY ATRYBUTOW
+C W TABLICY SYMBOLI
+C ZAPELNIANIE TABLICY SYMBOLI: TSINSE --> <-- TSTEMP
+C OBSZAR WOLNY - FRSTTS .. LSTEMP-1
+C UNIT - RODZAJ BIEZACEGO MODULU:
+C 1 - BLOK
+C 2 - HANDLER
+C 3 - BLOK PREFIKSOWANY
+C 4 - PROCEDURA
+C 5 - FUNKCJA
+C 6 - KLASA
+C INNER = 0 - NIE BYLO "INNER",ALE JEST LEGALNY
+C 1 - WYSTAPIENIE "INNER" BEDZIE NIELEGALNE
+C 2 - JUZ WYSTAPIL
+C 4 - LAST-WILL WYSTAPIENIE INNER NIELEGALNE
+C LSTWILL - TRUE,JESLI WYSTAPILO LAST WILL
+C
+C TEST - OPCJA / U3 / WYDRUKOW KONTROLNYCH ,
+C = 0 --> BEZ WYDRUKOW , <> 0 --> WYDRUKI
+C
+C ARG - INFORMACJA O STALYCH ARGUMENTACH /USTAWIANA PRZEZ
+C SARGMT/ :
+C 1 - OBA STALE
+C 2 - LEWY STALY,PRAWY NIE
+C 3 - LEWY NIE,PRAWY STALY
+C 4 - OBA ROZNE OD STALYCH
+C ATLINE - NUMER LINII, W KTOREJ PRZEBIEG MA SIE ZAWIESIC
+C
+C FILE - ADRES PLIKU NA STOSIE LUB 0 DLA OPERACJI NA PLIKU
+C STANDARDOWYM
+C
+C FLARGS - INFORMACJA O PRZETWORZONYCH ARGUMENTACH OPERACJI
+C WE/WY :
+C 0 - NIE WYSTAPIL ZADEN ARGUMENT
+C 1 - WYSTAPIL TYLKO ADRES PLIKU
+C 2 - WYSTAPIL CO NAJMNIEJ 1 ARGUMENT
+C ( LUB READLN/WRITELN )
+C
+C FLREADY - TRUE, JESLI (R6-12) ZAWIERA ADRES PLIKU, ZAPALANE PRZEZ
+C SFLADR, GASZONE PRZEZ SCALLB I DLA 'I-O-END'
+C
+C FLMODF - PRZELACZNIK NUMERU PROCEDURY STANDARDOWEJ UZYWANY
+C DLA WE/WY : 1 DLA PLIKU STANDARDOWEGO
+C 0 DLA WSKAZYWANEGO
+C NUMERY PROCEDUR WE/WY (ROZNE PUNKTY WEJSCIA) SA
+C POWIAZANE :
+C INPUT : N-1
+C WSKAZYWANY : N
+C OUTPUT : N+1
+C
+C.............
+C COMDECK OPT? 04.01.84
+C COMMON/OPTION/OPTMEM,OPTOPT,OPTIND,OPTTYP,OPTTRC,OPTCSC,OPTCSF
+C LOGICAL OPTOPT,OPTTYP,OPTTRC
+C FROM LOGLAN.08
+C
+C ***** OPCJE KOMPILATORA *****
+C
+C OPTMEM - 0 - TRZEBA ROBIC MEMBER
+C 1 - NIE TRZEBA ROBIC MEMBER
+C OPTOPT - .TRUE. - WOLNO OPTYMALIZOWAC
+C .FALSE. - NIE WOLNO
+C OPTIND - 0 - KONTROLA INDEKSOW DLA TABLIC
+C 2 - BEZ KONTROLI INDEKSOW
+C OPTTYP - .TRUE. - BEZ DYNAMICZNEJ KONTROLI TYPOW
+C
+C OPTTRC - .TRUE. - KOMPILAT POWINIEN ZAWIERAC SLEDZENIE
+C
+C OPTCSC - 1 - BEZ KONTROLI ZAKRESU DLA "CASE"
+C 0 WYMAGANA KONTROLA
+C OPTCSF - 0 - SZYBKI "CASE"
+C 1 - PAMIECIOOSZCZEDNY
+C
+C
+C................
+C
+C*COMDECK BLANKSEM
+C LOGICAL INSYS, OWN
+C COMMON /BLANK/ IOP(4),
+C X P,
+C X TLDIM, TLBAS, IDL, OBJL,
+C X TRDIM, TRBAS, IDR, OBJR,
+C X TRESLT,
+C X TRESLT,
+C X CONVL, CONVR,
+C X NRPAR,
+C X IX (261),
+C X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+C X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+C X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+C X LOCAL, OWN, OBJECT,
+C X IPMEM(5000)
+C REAL STALER(100)
+C INTEGER STACK(5000)
+C EQUIVALENCE(STALER(1),IPMEM(1))
+C EQUIVALENCE(STACK(1),IPMEM(1))
+C......COMDECK BLANKSEM
+C FROM LOGLAN.08 17.01.84
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I IPMEM
+C
+C CZESC SEMANT
+C P - PROTOTYP AKTUALNY
+C TLDIM - LICZBA ARRAY OF W TYPIE LEWEGO ARGUMENTU
+C TLBAS - TYP BAZOWY LEWEGO ARGUMENTU
+C DISPL - .TRUE. JESLI LEWY ARGUMENT JEST DOSTEPNY PRZEZ
+C DISPLAY
+C OBJL - PROTOTYP OBIEKTU, Z KTOEGO POCHODZI TEN ATRYBUT
+C IDL - IDENTYFIKATOR LEWEGO ARGUMENTU (DO SYGNALIZACJI BLE-
+C DOW)
+C TRDIM, TRBAS, DISPR, IDR, OBJR - ANALOGICZNIE DLA PRAWEGO ARGU-
+C MENTU
+C TRESLT - TYP BAZOWY WYNIKU OPERACJI ARYTMETYCZNEJ
+C CONVL, CONVR - FLAGA KONWERSJI LEWEGO I PRAWEGO ARGUMENTU
+C OPERACJI ARYTMETYCZNYCH LUB RELACJI
+C WARTOSCI :
+C 0 - BRAK KONWERSJI
+C 1 - KONWERSJA DO REAL
+C 2 - KONWERSJA DO INTEGER (?)
+C NRPAR - NUMER PARAMETRU (PROCEDURA MPKIND)
+C
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
+C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
+C NRRE - REAL
+C NRBOOL - BOOLEAN
+C NRCHR - CHARACTER
+C NRCOR - COROUTINE
+C NRPROC - PROCESS
+C NRTEXT - STRING (TEXT)
+C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
+C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
+C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
+C REFERENCYJNY)
+C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
+C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
+C
+C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
+C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
+C MOWEJ
+C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT
+C BYL LOKALNY
+C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
+C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
+C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
+C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
+C
+C
+ COMMON/STREAM/ ERRFLG,LINE,IBUF23(272),JUNK(260)
+ LOGICAL ERRFLG
+ LOGICAL MLOCTP,MDISTP
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+cdsw&bc
+ real y
+ integer*2 m(2)
+ equivalence (y, m(1))
+cdsw&bc
+ common /stacks/ btsins, btstem
+C
+C
+ LOGICAL INICJA
+C INICJA=.TRUE. W FAZIE WYLICZANIA WARTOSCI STALYCH SYMBOLICZNYCH I GRANIC
+C TABLIC STATYCZNYCH.
+C
+C
+C
+ INTEGER ERROR
+C ERROR=NUMER BLEDU DLA WSPOLNEJ SYGNALIZACJI /9900/
+C
+ LOGICAL FORSTP
+C DLA PETLI "FOR" : TRUE --> WYSTAPILO "STEP", FALSE --> NIE WYSTAPILO
+C
+C
+C
+C AUXILIARY VARIABLES
+ INTEGER ATS,ELEM,I,IND
+C
+C.....INICJALIZACJA
+cdsw&bc FRSTTS=LPMEM+1
+ frstts = btsins
+c
+C =INDEKS POCZATKU TABLICY SYMBOLI - CZESC DLA ATRYBUTOW DEKLAROWANYCH
+ IPMEM(LMEM)=BOTTOM-1
+C OSTATNIE SLOWO IPMEM ZAWIERA INDEKS PIERWSZEGO OD PRAWEJ WOLNEGO
+C SLOWA NA POMOCNICZY SLOWNIK DLA WYZNACZANIA ADRESOW ATRYBUTOW
+C DEKLAROWANYCH W TABLICY SYMBOLI.
+C
+C
+C
+ CONSNR(1)=NRBOOL
+ CONSNR(2)=NRCHR
+ CONSNR(3)=NRINT
+ CONSNR(4)=NRNONE
+ CONSNR(5)=NRRE
+ CONSNR(6)=NRTEXT
+ CONSNR(7)=NRUNIV
+cdsw&bc
+ consnr(8)=-17
+ IF(INICJA)GO TO 10
+ CALL SINIT
+ 10 VALTOP=BOTTOM
+ VLPREV=BOTTOM
+ LSTLSE=BOTTOM
+ LSTFOR=BOTTOM
+ LASTPR=0
+ LSTSAF=BOTTOM
+ FSTOUT=BOTTOM+401
+cdsw&bc TEMPNR=LMEM-6
+ tempnr = btstem-6
+c
+ LSTEMP=TEMPNR
+ FILE=0
+ FLARGS=0
+ FLREADY=.FALSE.
+ FLMODF=1
+ ICOUNT=0
+ OCOUNT=0
+ GO TO 50
+C
+C
+C
+ 30 CALL SPOP
+ 40 CALL SNEXT
+C.....GLOWNA PETLA. W ZALEZNOSCI OD SYMBOLU Z WEJSCIA WYBIERZ AKCJE
+ 50 CONTINUE
+ GO TO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,
+ X 1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,2400,2500,
+ X 2600,2700,2800,2900,3000,3100,3200,3300,3400,3500,3600,3700,
+ X 3800,3900,4000,4100,4200,4300,4400,4500,4600,4700,4800,4900,
+ X 5000,5100,5200,5300,5400,5500,5600,5700,5800,5900,6000,6100,
+ X 6200,6300,6400,6500,6600,6700,6800,6900,7000,7100,7200,7300,
+ X 7400,7500,7600,7700,7800,7900,8000,8100,8200,8300,8400,8500,
+ X 8600,8700,8800,8900,9000,9100,9200,9300,9400),WB
+cbc X 8600,8700,8800,8900,9000),WB
+cbc X 8600,8700,8800),WB
+C
+C---------------- AND --------------------------
+C
+ 100 CALL SBOOLEX(1)
+ GO TO 40
+C
+C--------------- ARRAY OF ------------------------
+C
+C ZWRACA : SLOWO -2 =0 - TYP STATYCZNY (-3),(-4)
+C SLOWO -2 >0 - ATS ZMODYFIKOWANEGO TYPU FORMALNEGO
+C
+ 200 CALL SNEXT
+C WB=LICZBA ARRAY OF
+C CZY NA CZUBKU JEST KLASA,REKORD LUB NAZWA TYPU?
+ ELEM=STACK(VALTOP)
+ IF(ELEM.EQ.0)GO TO 40
+ IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 250
+C OK. WPISZ LICZBE ARRAY OF
+ STACK(VALTOP-3)=WB
+C CZY TYP FORMALNY?
+ IF(STACK(VALTOP-2).NE.0) CALL SMODIFY(STACK(VALTOP-2),WB)
+ GO TO 40
+C.....NIEPOPRAWNY CZUBEK STOSU
+ 250 ERROR=440
+ GO TO 9900
+C
+C--------------- ASSIGN --------------------------
+C
+C CZUBEK STOSU POWINIEN ZAWIERAC WARTOSC,PONIZEJ SA LSE /POWYZEJ LSTFOR DO
+C
+ 300 CALL SASSIGN
+ GO TO 40
+C
+C--------------- ASSIGN CONST --------------------
+C CZUBEK STOSU POWINIEN ZAWIERAC STALA /WARTOSC WYRAZENIA DEFINIUJACEGO/,
+C PONIZEJ CZUBKA JEST STALA DEFINIOWANA,MAJACA W SLOWIE -2 INDEKS
+C SWOJEGO OPISU W IPMEM.
+C
+C STALA?
+ 400 IF(STACK(VLPREV).EQ.0 .OR. STACK(VALTOP).EQ.0)GO TO 420
+ IF(STACK(VALTOP).EQ.1)GO TO 410
+ CALL SERRO2(429,VLPREV)
+ GO TO 420
+C POBIERZ ADRES OPISU STALEJ DEFINIOWANEJ
+ 410 ELEM=STACK(VLPREV-2)
+C WPISZ WARTOSC I TYP
+ IPMEM(ELEM-1)=STACK(VALTOP-2)
+ IPMEM(ELEM-4)=0
+ IPMEM(ELEM-3)=STACK(VALTOP-4)
+ 420 CALL SPOP
+ GO TO 30
+C
+C--------------- ATTACH --------------------------
+C CZUBEK STOSU POWINIEN ZAWIERAC REFERENCJE
+C
+ 500 CALL SATTACH
+ LSTEMP=TEMPNR
+ GO TO 30
+C
+C--------------- BLOCK ---------------------------
+C WYSTAPIENIE BLOKU O NUMERZE WN
+ 600 CALL SNEXT
+ CALL QUADR2(186,IPMEM(WB))
+ LSTEMP=TEMPNR
+ GO TO 40
+C
+C--------------- CALL ----------------------------
+C NA PEWNO BLAD: PROCEDURA SAMA "ZJADA" CALL.
+C
+ 700 CALL SERROR(422)
+ GO TO 30
+C
+C--------------- CASE ----------------------------
+ 800 CALL SCASE
+ GO TO 30
+C WRACA DO ETYKIETY 30
+C--------------- CASE LABEL ----------------------
+ 900 CALL SCSLAB
+ GO TO 30
+C WRACA DO ETYKIETY 30
+C--------------- COMA ----------------------------
+C
+C PONIZEJ CZUBKA JEST :
+C UNIWERSALNY LUB ELEMENT TABLICY/DYN./ LUB TABLICA STATYCZNA
+C LUB REKORD,KLASA,BLOK PREF.,PROCEDURA,FUNKCJA.
+C NA CZUBKU JEST INDEKS LUB PARAMETR AKTUALNY.
+C PO OBSLUZENIU WOLA SNEXT
+C
+ 1000 ELEM=STACK(VLPREV)
+C JESLI UNIWERSALNY-OMIN
+ IF(ELEM.EQ.0)GO TO 30
+C CZY TO PARAMETR?
+ IF(ELEM.GT.7)GO TO 1050
+C NIE,MOZE TABLICA STATYCZNA?
+ IF(ELEM.EQ.5)GO TO 1060
+C ZATEM TABLICA DYNAMICZNA /ELEMENT TABLICY/
+ CALL SINDEX
+ GO TO 30
+ 1050 CALL SPARAM
+ GO TO 40
+ 1060 CALL SINDXS
+ GO TO 40
+C
+C--------------- CONST:BOOL,CHAR,INT,NONE,REAL,STRING -----
+C
+ 1100 CONTINUE
+ 1200 CONTINUE
+ 1300 CONTINUE
+ 1500 CONTINUE
+ 1600 ELEM=WB-10
+ CALL SNEXT
+C.....WSPOLNA AKCJA DLA WSZYSTKICH STALYCH,ROWNIEZ NONE
+ 1650 CALL SPUSH(1)
+ STACK(VALTOP-1)=0
+ STACK(VALTOP-2)=WB
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=CONSNR(ELEM)
+ STACK(VALTOP-5)=0
+ GO TO 40
+C.....WYROZNIONY POCZATEK DLA NONE
+ 1400 ELEM=4
+ WB=0
+ GO TO 1650
+C
+C
+C--------------- COPY ----------------------------
+C NA CZUBKU STOSU JEST WARTOSC DO SKOPIOWANIA.
+C
+ 1700 CALL SVALUE
+C JESLI UNIWERSALNY-POMIN
+ IF(STACK(VALTOP).EQ.0)GO TO 40
+C ZBADAJ TYP. POMIN NONE.
+ ELEM=STACK(VALTOP-4)
+ IF( ELEM.EQ.NRNONE) GO TO 40
+C MOZE TO TABLICA?
+ IF(STACK(VALTOP-3).GT.0)GO TO 1750
+C NIE. CZY TYP PIERWOTNY?
+ DO 1730 I=1,6
+ IF(CONSNR(I).EQ.ELEM)GO TO 1790
+ 1730 CONTINUE
+C.....ZATEM O.K.
+ 1750 ATS=TSTEMP(4)
+ CALL QUADR3(41,ATS,STACK(VALTOP-2))
+ STACK(VALTOP)=2
+ STACK(VALTOP-2)=ATS
+ GO TO 40
+C.....NIE REFERENCJA
+ 1790 ERROR=415
+ GO TO 9900
+C
+C--------------- DETACH --------------------------
+C
+ 1800 CALL QUADR1(187)
+ LSTEMP=TEMPNR
+ GO TO 40
+C
+C--------------- DOT ------------------------------
+C
+ 1900 CALL SNEXT
+C WB=IDENT
+ CALL SNEXT
+C WB = NAZWA PO KROPCE
+ CALL SVALUE
+ IF(STACK(VALTOP).NE.0)GO TO 1910
+C UNIWERSALNY.IDENT ZASTAP PRZEZ UNIWERSALNY Z NAZWA PO KROPCE
+ STACK(VALTOP-1)=WB
+ GO TO 40
+C O.K.
+ 1910 I=STACK(VALTOP-4)
+C I=KWALIFIKACJA WARTOSCI PRZED KROPKA
+ IND=MDOT(STACK(VALTOP-3),I,STACK(VALTOP-1),WB)
+ ATS=STACK(VALTOP-2)
+C ATS=WARTOSC PRZED KROPKA
+ CALL SPOP
+C DALEJ JAK DLA WIDOCZNEGO IDENTYFIKATORA
+ GO TO 2805
+C--------------- DOWNTO --------------------------
+ 2000 CALL SFORTO(.FALSE.,FORSTP)
+ GO TO 40
+C POWROT DO ETYKIETY 40
+C--------------- SIGN ----------------------------
+ 2100 CALL SVALUE
+ ELEM=STACK(VALTOP)
+ IDL=STACK(VALTOP-2)
+ IF(ELEM.EQ.0)GO TO 40
+ IF(STACK(VALTOP-3).GT.0)GO TO 2110
+ ATS= +1
+ IF(STACK(VALTOP-4).EQ.NRINT)GO TO 2130
+ IF(STACK(VALTOP-4).EQ.NRRE)GO TO 2150
+C ... NIEPOPRAWNY TYP ARGUMENTU SIGN
+ 2110 ERROR=604
+ GO TO 9900
+C ... INTEGER. STALA ?
+ 2130 IF(ELEM.NE.1)GO TO 2160
+ IF(IDL.LT.0) ATS= -1
+ IF(IDL.EQ.0) ATS= 0
+ GO TO 2170
+C ... REAL. STALA ?
+ 2150 IF(ELEM.NE.1)GO TO 2160
+cdsw&bc IF(STALER(IDL).LT. 0.0) ATS= -1
+cdsw&bc IF(STALER(IDL).EQ. 0.0) ATS= 0
+#if WSIZE == 4
+ if(staler(idl) .lt. 0.0) ats= -1
+ if(staler(idl) .eq. 0.0) ats= 0
+#else
+ n1 = idl*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ if(y .lt. 0.0) ats= -1
+ if(y .eq. 0.0) ats= 0
+#endif
+c
+ GO TO 2170
+C ... GENERUJ KOD
+ 2160 ATS=TSTEMP(1)
+ CALL QUADR3(31,ATS,IDL)
+C ZASTAP PRZEZ WARTOSC
+ STACK(VALTOP)=2
+ 2170 STACK(VALTOP-1)=0
+ STACK(VALTOP-2)=ATS
+ STACK(VALTOP-4)=NRINT
+ GO TO 40
+C--------------- ESAC ----------------------------
+ 2200 CALL SESAC
+ GO TO 40
+C--------------- FIN -----------------------------
+C
+ 2300 CALL SEND
+ RETURN
+C
+C
+C--------------- FIRSTINSTR ----------------------
+C
+C JESLI TO FAZA WYLICZANIA STALYCH - ZAPAMIETAJ TO MIEJSCE I KONCZ.
+C
+ 2400 IF(INICJA)GO TO 2450
+ CALL SNEXT
+C PIERWSZA INSTRUKCJA MODULU, WB=NUMER INSTRUKCJI
+ CALL QUADR1(179)
+ LINE=WB
+ GO TO 40
+C
+C ... KONIEC WYLICZANIA STALYCH DLA TEGO MODULU
+ 2450 IPMEM(P+8)=IX(258)
+ IPMEM(P+9)=IX(257)
+ RETURN
+C--------------- FOR END -------------------------
+C
+ 2500 CALL SFOREND
+ GO TO 30
+C POWROT DO ETYKIETY 30
+C--------------- FOR VARIABLE --------------------
+C
+C PISZ : KONIEC BLOKU BAZOWEGO /BY UNIKNAC PONOWNEGO PRZYDZIALU
+C TYCH SAMYCH ATRYBUTOW ROBOCZYCH W JEDNYM BLOKU/
+ 2600 CALL QUADR1(176)
+C ZAREZERWUJ 2 NUMERY DLA ATRYBUTOW ROBOCZYCH DLA PETLI FOR
+ TEMPNR=TEMPNR-6
+ IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
+C
+C
+ LSTEMP=TEMPNR
+C
+C
+C ... ZMIENNA PROSTA?
+ IND=STACK(VALTOP)
+ IF(IND.EQ.0)GO TO 40
+ ERROR=410
+C ="OCZEKIWANA ZMIENNA PROSTA"
+ IF(IND.NE.3 .OR. STACK(VALTOP-7).NE.0)GO TO 9900
+C TAK. INTEGER?
+ CALL SCHECK(411,NRINT)
+ LSTLSE=VALTOP
+ GO TO 40
+C--------------- FROM ----------------------------
+C
+ 2700 CALL SINDTYP
+ FORSTP=.FALSE.
+ GO TO 40
+C--------------- IDENTYFIKATOR -------------------
+C WB=IDENT , WN=NAZWA ZE SCANNERA
+ 2800 CALL SNEXT
+ IND=MIDENT(WB)
+ ATS=0
+C..........WSPOLNE ROZPOZNANIE I OBSLUGA DLA IDENTYFIKATORA PRZEZ KROPKE
+C LUB WIDOCZNEGO.
+C IND = ADRES ZEROWEGO SLOWA OPISU ROZPOZNANEGO IDENTYFIKATORA
+C ATS= ATS WARTOSCI PRZED KROPKA /I=KWALIFIKACJA/ LUB ZERO
+C
+ 2805 ELEM=SWHAT(IND)
+C WLOZ NA STOS , WPISZ NAZWE , WEZ KOLEJNY SYMBOL
+ CALL SPUSH(ELEM)
+ STACK(VALTOP-1)=WB
+ CALL SNEXT
+C FAZA WYLICZANIA STALYCH ?
+ IF(INICJA)GO TO 2850
+C NIE.
+C JESLI TO "UNIWERSALNY"-NIC NIE ROB
+ IF(ELEM.EQ.0)GO TO 50
+ 2807 STACK(VALTOP-6)=0
+ STACK(VALTOP-7)=ATS
+ STACK(VALTOP-5)=0
+C NAZWA TYPU?
+ IF(ELEM.EQ.7)GO TO 2880
+ IF(ELEM.GT.5)GO TO 2870
+C.....STALA,ZMIENNA,TABLICA STATYCZNA. WSTAW TYP.
+ STACK(VALTOP-4)=IPMEM(IND-3)
+C STALA?
+ IF(ELEM.NE.1)GO TO 2815
+C....."STALA"
+ STACK(VALTOP-3)=0
+ IF(.NOT.INICJA)STACK(VALTOP-2)=IPMEM(IND-1)
+C WSTAWIONY TYP,WARTOSC STALEJ
+ GO TO 50
+C....."ZMIENNA","TABLICA STATYCZNA"
+ 2815 STACK(VALTOP-3)=IPMEM(IND-4)
+ STACK(VALTOP-2)=IND
+ IF(ATS.EQ.0)STACK(VALTOP-2)=TSINSE(IND,LOCAL)
+C WSTAWIONY ATS
+C.....TYPU FORMALNEGO?
+ ELEM=STACK(VALTOP-4)
+ 2820 ELEM=IAND(IPMEM(ELEM),15)
+C ELEM=POLE T TYPU ZMIENNEJ
+ IF(ELEM.NE.6)GO TO 2830
+C A WIEC TYP FORMALNY. PRZEZ KROPKE?
+ IF(ATS.NE.0)GO TO 2825
+C.....PRZEZ DISPLAY
+ STACK(VALTOP-6)=OBJECT
+C CZY TYP DOSTEPNY PRZEZ DISPLAY?
+ IF(MDISTP(IPMEM(IND-1),STACK(VALTOP-4),ELEM))GO TO 2823
+C TYP NIEDOSTEPNY PRZEZ DISPLAY,WSTAW SL ZMIENNEJ
+ STACK(VALTOP-5)= - IPMEM(IND-1)
+ GO TO 2830
+C TYP DOSTEPNY PRZEZ DISPLAY,WSTAW WARSTWE
+ 2823 STACK(VALTOP-5)=ELEM
+ GO TO 2830
+C.....PRZEZ KROPKE. TYP JEST LOKALNYM ATRYBUTEM?
+ 2825 STACK(VALTOP-5)= -1
+ IF(MLOCTP(STACK(VALTOP-4),I))STACK(VALTOP-5)= +1
+C.....TYP JUZ WSTAWIONY
+ 2830 IF(STACK(VALTOP).EQ.3)GO TO 50
+ IF(STACK(VALTOP).EQ.12)GO TO 2875
+C....."TABLICA STATYCZNA"
+ CONTINUE
+C NA RAZIE B R A K
+ GO TO 50
+C
+C ... W FAZIE WYLICZANIA STALYCH
+ 2850 IF(ELEM.LT.2)GO TO 2860
+C NIELEGALNY OBIEKT W WYRAZENIU DEFINIUJACYM STALA.
+ ERROR=429
+ GO TO 9901
+ 2860 IF(ELEM.EQ.0)GO TO 50
+C STALA DEFINIOWANA ? /TAK,JESLI WB = "LSE" /
+ IF(WB.NE.39)GO TO 2865
+C TAK. WSTAW DO SLOWA -2 ADRES OPISU STALEJ
+ STACK(VALTOP-2)=IND
+ GO TO 50
+C STALA W WYRAZENIU DEFINIUJACYM. WSTAW DO SLOWA -2 WARTOSC
+C / DLA REAL - NUMER STALEJ /
+ 2865 STACK(VALTOP-2)=IPMEM(IND-1)
+C CZY STALA MA JUZ OKRESLONA WARTOSC ?
+ IF(IPMEM(IND-3).NE.0)GO TO 2807
+C TYP = 0 /SLOWO -3/ OZNACZA,ZE STALA JESZCZE NIE MIALA OKRESLONEJ
+C WARTOSCI
+ ERROR=430
+ GO TO 9901
+C
+C.....REKORD,KLASA,PROCEDURA,FUNKCJA,SYGNAL,OPERATOR.
+ 2870 ELEM=IPMEM(IND-3)
+ STACK(VALTOP-4)=IND
+ STACK(VALTOP-3)=0
+ IDR=STACK(VALTOP)-7
+C DLA FUNKCJI ZBADAJ CZY TYP FORMALNY
+ GO TO (2872,2872,2872,2875,2820,2875,2890),IDR
+C
+C ... KLASA,REKORD . NEW ?
+ 2872 STACK(VALTOP-2)=0
+C - TYP STATYCZNY
+ IF(WB.EQ.40)GO TO 2873
+C LEWY NAWIAS?
+ IF(WB.NE.36)GO TO 50
+C BRAK NEW PRZED LEWYM NAWIASEM
+ CALL SERROR(423)
+ GO TO 2874
+C NEW
+ 2873 CALL SNEXT
+ 2874 CALL SCALLB
+ GO TO 50
+C ... PROCEDURA,SYGNAL, C.D. DLA FUNKCJI
+C JESLI WB ROZNE OD "," LUB ")" - WYWOLAJ /INACZEJ-PODEJRZEWAJ PARAMETR/
+ 2875 IF(WB.NE.10 .AND. WB.NE.54)GO TO 2874
+ GO TO 50
+C....."NAZWA TYPU" /PARAMETR FORMALNY "TYPE"/
+ 2880 STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=IND
+C PRZEZ KROPKE?
+ IF(ATS.NE.0)GO TO 2885
+C PRZEZ DISPLAY
+ STACK(VALTOP-2)=TSINSE(IND,LOCAL)
+C ZERO ARRAY OF,TYP FORMALNY,ATS TEGO TYPU
+ STACK(VALTOP-6)=OBJECT
+ GO TO 50
+C.....PARAMETR "TYPE" PRZEZ KROPKE
+C ODCZYTAJ TYP
+ 2885 STACK(VALTOP-2)=TSTEMP(2)
+ CALL QUADR4(85,STACK(VALTOP-2),SMEMBER(VALTOP),IND)
+ GO TO 50
+C.....OPERATOR, JESLI WB ROZNE OD "(" - BLAD
+ 2890 ERROR=454
+C = NIELEGALNE WYSTAPIENIE NAZWY OPERATORA
+ IF(WB.NE.36)GO TO 9901
+ GO TO 50
+C--------------- IF-FALSE , IF-TRUE ----------------
+ 2900 CONTINUE
+ 3000 CALL SVALUE
+ IND=WB-29
+C IND= 1 DLA IF-TRUE , = 0 DLA IF-FALSE
+ CALL SNEXT
+C NA CZUBKU WARTOSC TYPU BOOLEAN?
+ CALL SCHECK(407,NRBOOL)
+C STALA?
+ IF(STACK(VALTOP).EQ.1)GO TO 3050
+ CALL QUADR3(151+IND,STACK(VALTOP-2),WB)
+ GO TO 30
+C SKOK PRZY STALEJ WARTOSCI WYRAZENIA
+ 3050 IF(IND+STACK(VALTOP-2).NE.0) GOTO 30
+C ZATEM TRUE, IF TRUE FALSE, IF FALSE
+ CALL SPOP
+ GOTO 3350
+C
+C------ INNER --------
+C LOKALNE WYSTAPIENIE
+3100 IF (INNER.NE.0) CALL MERR(424+INNER,0)
+ INNER = 2
+ CALL QUADR2(178,IPMEM(P+23))
+C ZAZNACZ: INSTRUKCJE PO INNER
+ IPMEM(P-7) = P
+ LSTEMP = TEMPNR
+ GOTO 40
+C
+C------- INSTREND--------
+C
+3200 CALL SNEXT
+ LINE= WB
+CJF IF (LINE.EQ.ATLINE) CALL STOPAT(ATLINE)
+ CALL SNEXT
+C JESLI BYLY BLEDY CZYSC STOS
+ IF (ERRFLG) GOTO 10
+ IF (INICJA) GOTO 50
+C
+C
+C PRZY ZGASZONEJ OPCJI "OPTIMALIZATION" LUB "SYSPP" ZAKONCZ BLOK BAZOWY
+ IF(OPTOPT.AND.IPMEM(NBLSYS+4).EQ.0)GO TO 3250
+ LSTEMP=TEMPNR
+ CALL QUADR1(176)
+C
+C PRZY WYLACZONEJ OPCJI "TRACE" WYPISZ UJEMNY NUMER
+ 3250 ELEM=LINE
+ IF(.NOT.OPTTRC)ELEM=-LINE
+ CALL QUADR2(177,ELEM)
+ GO TO 50
+C--------------- JUMP -----------------------------------
+ 3300 CALL SNEXT
+ 3350 CALL QUADR2(182,WB)
+ LSTEMP=TEMPNR
+ GO TO 40
+C--------------- KILL ----------------------------
+C CZUBEK POWINIEN ZAWIERAC WARTOSC REFERENCYJNA
+C
+ 3400 CALL SKILL
+ GO TO 30
+C
+C--------------- LABEL ----------------------------
+ 3500 CALL SNEXT
+C WYPISZ ETYKIETE
+ CALL QUADR2(181,WB)
+ LSTEMP=TEMPNR
+ GO TO 40
+C--------------- LEFT PARANTHESIS ----------------
+C
+ 3600 IF(STACK(VALTOP).LT.8)CALL SVALUE
+
+ GO TO 40
+C
+C--------------- ----------------------------
+ 3700 CONTINUE
+ GO TO 40
+C--------------- LOWINDEX ------------------------
+C NA CZUBKU POWINIEN BYC ELEMENT SPROWADZALNY DO WARTOSCI INTEGER
+ 3800 CALL SINDTYP
+ GO TO 40
+C--------------- LSE -----------------------------
+C NA CZUBKU POWINNA BYC LEWA STRONA PODSTAWIENIA: UNIWERSALNY,
+C ZMIENNA,ELEM. TABLICY,TABLICA STATYCZNA LUB - DLA INICJALIZACJI-
+C STALA DEFINIOWANA
+C
+ 3900 LSTLSE=VALTOP
+ ELEM=STACK(VALTOP)+1
+ IF(ELEM.GT.6)GO TO 3980
+ GO TO(40,3910,3980,40,40,40),ELEM
+C.....STALA. LEGALNE TYLKO PODCZAS INICJALIZACJI.
+ 3910 IF(INICJA)GO TO 40
+C.....BLAD.
+ 3980 ERROR=420
+C ZASTAP PRZEZ UNIWERSALNY I OBSLUZ OD NOWA
+ GO TO 9901
+C
+C--------------- NEW -----------------------------
+C NA PEWNO BLAD: KLASA /REKORD/ SAMA "ZJADA" NEW
+C
+ 4000 ERROR=421
+ GO TO 9900
+C
+C--------------- NEWARRAY ------------------------
+C
+ 4100 CALL SNEWARR
+ GO TO 30
+C
+C--------------- NOT -----------------------------
+C
+ 4200 CALL SNOT
+ GO TO 50
+C
+C--------------- OPERATION -----------------------
+C
+ 4300 CALL SNEXT
+C WB=NUMER OPERACJI
+ CALL SARITH
+ GO TO 40
+C
+C--------------- OPTION --------------------------
+C
+ 4400 CALL SOPTION
+ GO TO 40
+C
+C--------------- OR ------------------------------
+C
+ 4500 CALL SBOOLEX(0)
+ GO TO 40
+C
+C--------------- OTHERWISE -------------------------
+C
+ 4600 CALL SOTHER
+ GO TO 40
+C
+C--------------- PREFBLOCK -------------------------
+C
+ 4700 CALL SNEXT
+ CALL SPUSH(10)
+ STACK(VALTOP-1)=0
+ STACK(VALTOP-7)=0
+ STACK(VALTOP-4)=IPMEM(WB)
+ CALL SNEXT
+ CALL SCALLB
+ GO TO 50
+C--------------- PRIMITIVE TYPE ------------------
+C
+ 4800 CALL SNEXT
+ CALL SPUSH(7)
+ STACK(VALTOP-1)=0
+ STACK(VALTOP-2)=0
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=CONSNR(WB)
+ GO TO 40
+C
+C--------------- QUA -----------------------------
+C
+ 4900 CALL SVALUE
+ CALL SNEXT
+ IF(STACK(VALTOP).EQ.0)GO TO 40
+ TLDIM=STACK(VALTOP-3)
+ TLBAS=STACK(VALTOP-4)
+ IDL=STACK(VALTOP-1)
+ STACK(VALTOP-4)=MAQUAB(WB)
+ CALL QUADR3(149,STACK(VALTOP-2),STACK(VALTOP-4))
+ GO TO 40
+C
+C--------------- I-O-END -------------------------
+C
+C WYSTAPILY ARGUMENTY ?
+ 5000 IF(FLARGS.LT.2)CALL MERR(444,0)
+ IF(FILE.NE.0)CALL SPOP
+ FILE=0
+ FLARGS=0
+ FLREADY=.FALSE.
+ FLMODF=1
+ GO TO 40
+C
+C--------------- RELATION ------------------------
+C
+ 5100 CALL SNEXT
+C WB=NUMER RELACJI
+ CALL SRELAT
+ GO TO 40
+CBC added
+C--------------- RESUME --------------------------
+C
+ 5200 call sresum
+ LSTEMP=TEMPNR
+ GO TO 30
+C
+C--------------- RETURN --------------------------
+C
+ 5300 LSTEMP=TEMPNR
+ CALL SRETURN
+cbc GO TO 40
+ goto 50
+C
+C--------------- RIGHT PARENTHESIS -------------
+C
+ 5400 IF(STACK(VLPREV).LT.8)GO TO 1000
+C KONIEC WYWOLANIA
+ CALL SPARAM
+ CALL SNEXT
+ CALL SCALLE
+ GO TO 50
+C
+C--------------- START -------------------------
+C
+ 5500 CONTINUE
+ GO TO 40
+C
+C--------------- STEP ---------------------------
+ 5600 CALL SINDTYP
+ FORSTP=.TRUE.
+cdsw&bc
+c check if constant step
+ if (stack(valtop) .ne. 1) goto 5601
+c yes, error if step < 0
+ if (stack(valtop-2) .lt. 0) call serror(479)
+ goto 40
+
+ 5601 continue
+c not constant
+c generate code to check if step >= 0
+ call quadr2(240, stack(valtop-2))
+c
+ GO TO 40
+C
+C--------------- STOP --------------------------
+C
+ 5700 CONTINUE
+cbc...
+ call quadr1(221)
+c...bc
+ GO TO 40
+C
+C--------------- THIS --------------------------
+C
+ 5800 CALL SNEXT
+C WB=NAZWA PO 'THIS'
+C WEZ Z DISPLAYA ADR.VIRTUALNY,WSTAW NA STOS WARTOSC
+ CALL SPUSH(2)
+ STACK(VALTOP-1)=WB
+ STACK(VALTOP-2)=TSTEMP(4)
+ STACK(VALTOP-4)=MTHIS(WB)
+ CALL QUADR3(15,STACK(VALTOP-2),STACK(VALTOP-4))
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-5)=0
+ GO TO 40
+C
+C--------------- TO ----------------------------
+ 5900 CALL SFORTO(.TRUE.,FORSTP)
+ GO TO 40
+C
+C--------------- WAIT ---------------------------
+C
+ 6000 CONTINUE
+ GO TO 40
+C
+C--------------- WRITE ---------------------------
+C6100 CALL SWRITE
+cdsw 6100 CALL SWRITE(*30,*40)
+C POWROT DO ETYKIETY 30 LUB 40
+cdsw -----------------------------
+ 6100 call swrite(whdsw)
+ go to(30,40),whdsw
+cdsw -----------------------------
+C
+C--------------- WRITELN -------------------------
+ 6200 CALL SFLADR
+ FLARGS=2
+ CALL QUADR2(132,58+FLMODF)
+ GO TO 40
+C
+C--------------- BOUNDS ----------------------------
+C
+ 6300 CONTINUE
+ GO TO 40
+C
+C--------------- LOWER , UPPER ----------------------
+C
+C CZUBEK STOSU ZAWIERA ADRES TABLICY
+ 6400 CONTINUE
+ 6500 CALL SVALUE
+C WARTOSC TABLICOWA?
+ ERROR=416
+ IF(STACK(VALTOP-3).EQ.0)GO TO 9900
+C O.K.
+ RESULT=TSTEMP(1)
+ CALL QUADR3(2*WB-95+OPTMEM,RESULT,STACK(VALTOP-2))
+C ZASTAP PRZEZ WARTOSC INTEGER
+ CALL SRESLT1(NRINT)
+ GO TO 40
+C
+C--------------- LOCK , UNLOCK ---------------------
+C
+ 6600 CONTINUE
+ 6700 IDL=WB-33
+C = NUMER PROCEDURY STANDARDOWEJ LOCK,UNLOCK
+ 6710 CALL SVARADR
+C PRZEKAZ ADRES ZMIENNEJ
+ CALL QUADR4(145,RESULT,IDL,0)
+C WYWOLAJ PROCEDURE
+ CALL QUADR2(132,IDL)
+C ZBADAJ TYP : SEMAPHORE ?
+ IDR=STACK(VALTOP-4)
+ IF(STACK(VALTOP-3).GT.0.OR.IAND(IPMEM(IDR),15).NE.9)
+ X CALL SERROR(418)
+C DLA LOCK,UNLOCK TO JUZ WSZYSTKO
+ IF(WB.NE.68)GO TO 30
+C ... TEST&SET . ODCZYTAJ WARTOSC
+ REsULT=TSTEMP(1)
+ CALL QUADR4(23,RESULT,IDL,1)
+C ZASTAP PRZEZ WARTOSC
+ CALL SRESLT1(NRBOOL)
+ GO TO 40
+C--------------- TEST&SET --------------------------
+ 6800 IDL=38
+ GO TO 6710
+C
+C--------------- WIND , TERMINATE ------------------
+C
+C NIELEGALNE POZA HANDLEREM
+ 6900 CONTINUE
+ 7000 IF(UNIT.EQ.2)GO TO 7050
+ CALL MERR(427,0)
+ GO TO 40
+C O.K.
+ 7050 CALL QUADR1(103+WB)
+ GO TO 40
+C
+C--------------- RAISE -----------------------------
+C
+C NA PEWNO BLAD: SYGNAL SAM "ZJADA" RAISE.
+ 7100 CALL SERROR(449)
+ GO TO 30
+C
+C--------------- LAST-WILL -------------------------
+C
+C ZAKONCZ INSTRUKCJE MODULU
+ 7200 CALL SFIN
+ LSTWILL=.TRUE.
+C INNER BEDZIE NIELEGALNY
+ INNER=4
+C WYPISZ ETYKIETE LAST-WILL
+ CALL SLWILL
+ GO TO 40
+C
+C--------------- READ ----------------------------
+cdsw 7300 CALL SREAD(*30,*40)
+cdsw -------------------------------
+ 7300 call sread(whdsw)
+ go to(30,40),whdsw
+cdsw --------------------------------
+C POWROT DO ETYKIETY 30 LUB 40
+C--------------- READLN --------------------------
+ 7400 CALL SFLADR
+ FLARGS=2
+ CALL QUADR2(132,42-FLMODF)
+ GO TO 40
+C
+C--------------- PUT -----------------------------
+C7500 CALL SPUT
+cdsw 7500 CALL SPUT(*30,*40)
+C POWROT DO ETYKIETY 30 LUB 40
+cdsw ---------------------------
+ 7500 call sput(whdsw)
+ go to (30,40),whdsw
+cdsw ---------------------------
+C
+C--------------- GET -----------------------------
+C7600 CALL SGET
+cdsw 7600 CALL SGET(*30,*40)
+cdsw --------------------------
+ 7600 call sget(whdsw)
+ go to (30,40),whdsw
+cdsw ---------------------------
+C POWROT DO ETYKIETY 30 LUB 40
+C
+C--------------- OPEN2 ---------------------------
+ 7800 CALL SVALUE
+ ATS=SVATS(VALTOP)
+C CZUBEK POWINIEN ZAWIERAC NAZWE PLIKU (arrayof char)
+cbc CALL SCHECK(414,NRTEXT)
+ if (stack(valtop-3) .ne. 1) goto 7801
+ n = stack(valtop-4)
+ if (n .ne. nrchr) goto 7801
+
+cfile CALL QUADR4(145,ATS,73,1)
+cfile -------------------------
+ call quadr4(145,ats,73,2)
+cfile --------------------------
+ CALL SPOP
+C DALEJ JAK DLA OPEN1
+C
+C--------------- OPEN1 ---------------------------
+cfile 7700 N=STACK(VALTOP)
+cfile ----------- added ------------------------
+c wspolna obsluga
+c nowa postac OPEN: OPEN(f,T,nazwa) - proc.stand. 73
+c OPEN(f,T) - proc.stand. 72
+c T okresla rodzaj operacji. Dozwolone: integer, real ,boolean, char, text
+c zmiana w interpreterze dla procedur standardowych 72 i 73:
+c parametr 0: output, adres nowego obiektu typu file
+c parametr 1: rodzaj operdcji () zalezy do T):
+c 1-text, 2-char, 3-int, 4-real, 5-direct
+c parametr 2: nazwa ( tylko dla 73)
+c
+c stos zawiera na czubku T, ponizej F
+c
+7700 continue
+c nazwa typu pierwotnego?
+ if(stack(valtop).ne.7) go to 7702
+c legalne nazwy typu: text, char ,integer, real
+ n = stack(valtop-4)
+c n - ident. typu
+ if(n.eq.nrtext) go to 7701
+ if(n.eq.nrint) go to 7705
+ if(n.eq.nrre) go to 7706
+ if(n.eq.nrchr) go to 7708
+cbc
+ if (n .eq. -17) goto 7709
+c error - nie nazwa typu lub nielegalny typ
+7702 call serror(419)
+ go to 7715
+c nrtext
+ 7701 n = 1
+ go to 7710
+c nrint
+7705 n = 3
+ go to 7710
+c nrreal
+7706 n = 4
+ go to 7710
+c nrchr
+7708 n = 2
+ goto 7710
+cbc
+7709 n = 5
+7710 n = sconst(n)
+ call quadr4(145,n,wb-5,1)
+7715 call spop
+c
+ n = stack(valtop)
+cfile -------------------------------------
+C ZMIENNA ?
+ IF(N.GT.2 .AND. N.LT.6)GO TO 7720
+ CALL SERROR(420)
+ GO TO 30
+C TYPU 'FILE'
+ 7720 CALL SFTEST
+ CALL QUADR2(132,WB-5)
+ ATS=TSTEMP(4)
+ CALL QUADR4(23,ATS,WB-5,0)
+ CALL SSTORE(VALTOP,ATS)
+ GO TO 30
+7801 call serror(416)
+ goto 30
+C
+C--------------- EOF0 ----------------------------
+C
+C = EOF(INPUT)
+ 7900 CALL SEOF0(39)
+ GOTO 40
+C
+C--------------- EOF1 ----------------------------
+ 8000 CALL SEOF(40)
+ GO TO 40
+C WRACA BEZPOSREDNIO DO ETYKIETY 40
+C
+C--------------- PAR. INPUT ----------------------
+C UNIMPLEMENTED
+ 8100 CONTINUE
+C PARAMETR INPUT WSTAWKI W ASSEMBLERZE
+C8100 CALL SNEXT
+C WB = NUMER REJESTRU. C.D. DLA IN-OUT
+C8150 CALL SVALUE
+C WPISZ NUMER REJESTRU DO SLOWA -1
+C STACK(VALTOP-1)=SREGSTR(WB)
+C ICOUNT=ICOUNT+1
+C GO TO 40
+C
+C--------------- PAR. OUTPUT ---------------------
+C UNIMPLEMENTED
+ 8200 CONTINUE
+C PARAMETR OUTPUT WSTAWKI W ASSEMBLERZE
+C8200 CALL SOUTPAR
+C ZDEJMIJ ZE STOSU
+C GO TO 30
+C
+C--------------- PAR. INOUT ----------------------
+C UNIMPLEMENTED
+ 8300 CONTINUE
+C PARAMETR IN-OUT WSTAWKI W ASSEMBLERZE
+C NAJPIERW OBSLUZ JAK PAR.OUTPUT, POTEM JAK PAR.INPUT
+C8300 CALL SOUTPAR
+C GO TO 8150
+C
+C--------------- ASSEMBLER -----------------------
+C UNIMPLEMENTED
+ 8400 CONTINUE
+C WSTAWIANY TEKST W ASSEMBLERZE
+C8400 CALL SBODY
+C GO TO 40
+C
+C--------------- EOLN0 ---------------------------
+C
+ 8500 CALL SEOF0(74)
+ GO TO 40
+C
+C--------------- EOLN1 ---------------------------
+C
+ 8600 CALL SEOF(75)
+ GO TO 40
+C
+C-------- THIS-COROUTINE ----------------------------
+C
+ 8700 N=NRCOR
+C WLOZ NA STOS 'WARTOSC'
+ 8720 CALL SPUSH(2)
+ ATS=TSTEMP(4)
+ STACK(VALTOP-1)=0
+ STACK(VALTOP-2)=ATS
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=N
+ STACK(VALTOP-5)=0
+C ODCZYTAJ WARTOSC : FUNKCJA STANDARDOWA 76,77
+ CALL QUADR2(132,WB-11)
+ CALL QUADR4(23,ATS,WB-11,0)
+ GO TO 40
+C
+C--------- THIS-PROCESS ----------------------------
+C
+ 8800 N=NRPROC
+ GO TO 8720
+C
+c--------- putrec -----------------------------------
+c
+ 8900 call spgrec(83)
+ goto 30
+c
+c--------- getrec -----------------------------------
+ 9000 call spgrec(82)
+ goto 30
+c
+cbc added concurrent statements
+c--------- enable -----------------------------------
+ 9100 call sconc(223)
+ goto 40
+c
+c--------- disable ----------------------------------
+ 9200 call sconc(224)
+ goto 40
+c
+c--------- accept -----------------------------------
+ 9300 call sconc(225)
+ goto 40
+c--------- procedure list end -----------------------
+c error - skip and read next symbol
+ 9400 goto 40
+c
+C------------------------------------------------------
+C
+C..........WSPOLNA OBSLUGA BLEDOW. ERROR=NUMER BLEDU.
+C ZASTAPIENIE CZUBKA STOSU PRZEZ UNIWERSALNY Z ZACHOWANIEM NAZWY.
+C WRACA NA POCZATEK PETLI.
+ 9900 CALL SNEXT
+ 9901 CALL SERROR(ERROR)
+ ELEM=STACK(VALTOP-1)
+ CALL SPOP
+ CALL SPUSH(0)
+ STACK(VALTOP-1)=ELEM
+ GO TO 50
+ END
+ SUBROUTINE SINIT
+C------------------------------------------------------
+C
+C POMOCNICZA. INICJALIZACJA SLOWNIKA ATRYBUTOW,
+C ZMIENNYCH UNIT,INNER,LSTWILL
+C NIE JEST WOLANA W FAZIE WYLICZANIA STALYCH.
+C
+C DLA KLAS WSTAWIA DO SLOWA +1 ZERO.
+C JESLI MODUL MA PREFIKS,WSTAWIA DO SLOWA +1 PREFIKSU 1.
+C
+C ##### OUTPUT CODE : 184 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER AUX0(8),AUX(7)
+ EQUIVALENCE (AUX0(2),AUX(1))
+ DATA AUX0/1,3,5,5,4,4,3,2/
+C = RODZAJ MODULU W ZALEZNOSCI OD POLA "S" ZEROWEGO SLOWA
+C
+cdsw DATA STCKAG,STCKA0,STCKAP /0,8,8,8,8,8,10,4,8,8,8,8,8,8,8,8/
+cdsw X ,APETYT /1,2,3,2/
+C
+C
+C.....JAKI TO MODUL ?
+ LSTWILL=.FALSE.
+ INNER=1
+ N=IPMEM(P)
+C SPRAWDZ POLE "S" : BITY 5..7
+ UNIT=IAND(ISHFT(N,-8),7)
+ UNIT=AUX(UNIT)
+C MOZE KLASA ? /JESLI POLE "T",BITY 12..15, <> 1 /
+ IF(IAND(N,15).EQ.1)GO TO 100
+C KLASA
+ UNIT=6
+ INNER=0
+ 100 CONTINUE
+C.....ZAZNACZ : JESZCZE NIE UZYWANY JAKO PREFIKS
+ IPMEM(P+1)=0
+ IF(UNIT.LT.3)GO TO 200
+C JESLI MA PREFIKS - ZAZNACZ DLA PREFIKSU,ZE UZYWANY
+ IDL=IPMEM(P+21)
+ IF(IDL.NE.0)IPMEM(IDL+1)=1
+C.....WYPISZ : POCZATEK MODULU
+ 200 CALL QUADR2(184,P)
+ RETURN
+ END
+
+
+ SUBROUTINE SNEXT
+C-----------------------------------------------------------------------------
+C
+C DOSTARCZA KOLEJNEGO SYMBOLU KODU POSREDNIEGO WYGENEROWANEGO
+C PRZEZ PARSER. SYMBOL TEN WPISUJE NA WB.
+C
+C CZYTA ZE STRUMIENIA "INP" , OPISANEGO W BUFORZE IBUF3 ,DO TABLICY IX .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+C
+C
+ INTEGER CURRENT
+C = INDEKS W BUFORZE IX OSTATNIO WCZYTANEGO SYMBOLU
+ EQUIVALENCE (IX(257),CURRENT)
+ INTEGER RECORD
+C = NUMER OSTATNIO WCZYTANEGO REKORDU
+ EQUIVALENCE (IX(258),RECORD)
+ COMMON/STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C.....OSTATNI W REKORDZIE?
+ IF(CURRENT.EQ.255)GO TO 200
+C NIE.
+ CURRENT=CURRENT+1
+ 100 WB=IX(CURRENT)
+C
+C
+C1000 FORMAT(' NEXT, WB =',I6)
+C
+C
+ RETURN
+C.....OSTATNI. WCZYTAJ KOLEJNY REKORD
+ 200 RECORD=IX(256)
+C SLOWO 256 ZAWIERA NUMER KOLEJNEGO REKORDU
+ CALL SEEK(IBUF3,RECORD)
+ CALL GET(IBUF3,IX)
+ CURRENT=1
+ GO TO 100
+ END
+
+
+ SUBROUTINE SATTACH
+C------------------------------------------------------
+C
+C NA CZUBKU JEST ARGUMENT ATTACH. BADA TYP,GENERUJE KOD,
+C ZDEJMUJE ZE STOSU.
+C
+C ##### OUTPUT CODE : 188 .
+C
+C ##### DETECTED ERROR(S) : 477
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+cdsw&ail
+ common /stacks/ btsins, btstem
+C
+ INTEGER ELEM
+C.........
+ CALL SVALUE
+ IF(STACK(VALTOP).EQ.0)RETURN
+ IF(STACK(VALTOP-3).GT.0)GO TO 500
+ ELEM=STACK(VALTOP-4)
+ ELEM=IAND(IPMEM(ELEM),15)
+ IF(ELEM.GT.7 .AND. ELEM.LT.13 .OR. ELEM.EQ.2)GO TO 500
+ ELEM=STACK(VALTOP-2)
+C ATTACH( NONE ) ?
+cdsw&ail IF(STACK(VALTOP).EQ.1)ELEM=LMEM-3
+ if (stack(valtop).eq.1) elem = btstem-3
+C = ATS NONE
+ CALL QUADR2(188,ELEM)
+ RETURN
+C NIEPOPRAWNY TYP ARGUMENTU ATTACH
+ 500 CALL SERROR(477)
+ RETURN
+ END
+
+ SUBROUTINE SCASE
+C--------------------------------------------------------------------------
+C
+C OBSLUGUJE POCZATEK INSTRUKCJI "CASE".
+C CZUBEK STOSU ZAWIERA WARTOSC WYRAZENIA CASE,NASTEPNY SYMBOL
+C WEJSCIOWY JEST NUMEREM ETYKIETY BAZOWEJ.
+C WKLADA NA STOS W TABLICY LAB OPIS NOWEJ INSTRUKCJI CASE,
+C PRZY CZYM : JESLI ZAGNIEZDZENIE = 4 , WYSYLA OPIS POPRZEDNICH
+C 3 CASE-OW NA DYSK JAKO REKORD O NUMERZE IOP(2),USTAWIAJAC OVER=6,
+C JESLI JEDNAK ZAGNIEZDZENIE > 6 , ZWIEKSZA JEDYNIE LICZNIK NADMIAROWYCH
+C ZAGNIEZDZEN.
+C
+C OGRANICZENIA : ZAGNIEZDZENIE MUSI BYC < 7 ,
+C ROZNICA MIEDZY NAJWIEKSZA A NAJMNIEJSZA ETYKIETA < 160 .
+C
+C GENERUJE :
+C < CASE , ATS WYRAZENIA , ETYKIETA BAZOWA -1 , OPTCSC+OPTCSF >
+C
+C
+C ##### OUTPUT CODE : 189 .
+C
+C ##### DETECTED ERROR(S) : 402 , 405 .
+C
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
+C
+C
+ COMMON/CASE/DEEP,OVER
+ INTEGER LAB(5000)
+ EQUIVALENCE(LAB(1),IPMEM(1))
+C
+cdsw DATA OVER/0/
+#if WSIZE == 4
+ DATA MAXINTEGER,MININTEGER / x'7FFFFFFF' , x'80000000' /
+#else
+ DATA MAXINTEGER,MININTEGER / x'7fff', -x'7fff' /
+#endif
+C
+C LAB ZAWIERA OPISY ZAGNIEZDZONYCH INSTRUKCJI CASE.
+C WYKORZYSTYWANYCH JEST 256 SLOW W TABLICY IPMEM :
+C OD LMEM-515 DO LMEM-260 .
+C POSTAC OPISU :
+C SLOWO 0 : TYP WYRAZENIA CASE
+C +1 : NUMER ETYKIETY BAZOWEJ
+C +2 : MINIMALNA WARTOSC ETYKIETY
+C +3 : MAKSYMALNA WARTOSC ETYKIETY
+C +4 : LICZBA ETYKIET
+C +5..+84 : 160 BAJTOW NA WZGLEDNY NUMER ETYKIETY
+C OPIS BIEZACEJ INSTRUKCJI CASE WSKAZANY JEST PRZEZ ZMIENNA DEEP
+C PRZYJMUJACA WARTOSCI : LMEM-600 PRZY BRAKU "CASE",
+C LMEM-515 PRZY ZAGNIEZDZENIU = 1
+C LMEM-430 PRZY ZAGNIEZDZENIU = 2
+C LMEM-345 PRZY ZAGNIEZDZENIU = 3
+C LMEM-260 PRZY PRZEPELNIENIU
+C PRZY ZAGNIEZDZENIU 4..6 OPIS PIERWSZYCH 3 CASE-OW JEST WYSYLANY
+C NA DYSK JAKO REKORD O NUMERZE IOP(2), OVER PRZYJMUJE WTEDY WARTOSC 6.
+C PRZY ZAGNIEZDZENIACH > 6 UTRZYMYWANA JEST WARTOSC DEEP=LMEM-260 ,
+C OPISY NOWYCH CASE-OW SA JEDYNIE ZLICZANE NA ZMIENNEJ OVER / 7,8,.../.
+C LAB(LMEM-260) = NRUNIV I JEST WYKORZYSTYWANE DLA UNIKNIECIA SYGNALIZACJI
+C NIEZGODNOSCI TYPOW ETYKIET PRZY ZBYT ZAGNIEZDZONYCH CASE-ACH.
+C DLA ETYKIETY O WARTOSCI N DO BAJTU O NUMERZE /NUMERACJA 0..159/
+C ( N MODE 160 ) WSTAWIANA JEST ROZNICA MIEDZY ODPOWIADAJACYM
+C JEJ NUMEREM ETYKIETY Z PARSERA A ETYKIETA BAZOWA.
+C
+C
+C
+ CALL SVALUE
+ CALL SNEXT
+C TERAZ WB = NUMER ETYKIETY BAZOWEJ
+ IF(STACK(VALTOP).EQ.0)GO TO 150
+C ... ZBADAJ TYP
+ IF(STACK(VALTOP-3).GT.0)GO TO 100
+ IF(STACK(VALTOP-4).EQ.NRRE)CALL SVINT(VALTOP)
+ ELEM=STACK(VALTOP-4)
+C = TYP WYRAZENIA CASE /PO EWENT. KONWERSJI REAL->INTEGER /
+ IF(ELEM.EQ.NRINT .OR. ELEM.EQ.NRCHR)GO TO 200
+C NIELEGALNY TYP WYRAZENIA CASE
+ 100 CALL SERROR(405)
+ 150 ELEM=NRUNIV
+C.....DODAJ NOWY OPIS DO STOSU INSTRUKCJI CASE
+ 200 DEEP=DEEP+85
+ IF(DEEP.LT.LMEM-260)GO TO 500
+C PELNY STOS. BUFOR NA DYSKU JUZ UZYTY ?
+ IF(OVER.GT.0)GO TO 1000
+C JESZCZE NIE.
+ OVER=6
+ DEEP=LMEM-515
+ CALL SEEK(IBUF3,IOP(2))
+ CALL PUT(IBUF3,LAB(DEEP))
+C
+C.....WSTAW OPIS
+ 500 LAB(DEEP)=ELEM
+ LAB(DEEP+1)=WB
+ LAB(DEEP+2)=MAXINTEGER
+ LAB(DEEP+3)=MININTEGER
+ LAB(DEEP+4)=0
+C JAKO MINIMALNA I MAKSYMALNA ETYKIETA POCZATKOWO NAJWIEKSZA I NAJMNIEJSZA
+C LICZBA ---> POTEM KONIECZNE JEST POROWNANIE KAZDEJ ETYKIETY ZAROWNO
+C Z MINIMALNA JAK I MAKSYMALNA.
+ DO 600 I=5,84
+ N=DEEP+I
+ 600 LAB(N)=0
+C BAJT ROWNY ZERO OZNACZA, ZE NIE WYSTAPILA ETYKIETA O WARTOSCI
+C WYZNACZAJACEJ TEN BAJT.
+C
+C ... JESLI STALA - WSTAW
+ ELEM=STACK(VALTOP-2)
+ IF(STACK(VALTOP).EQ.1)ELEM=SCONST(ELEM)
+C ... GENERUJ SKOK DO MIEJSCA WYBRANIA WLASCIWEJ INSTRUKCJI
+ CALL QUADR4(189,ELEM,WB-1,OPTCSC+OPTCSF)
+ RETURN
+C.....PRZEPELNIENIE : ZAGNIEZDZENIE PRZEKRACZA 6 .
+C NIE SYGNALIZUJ BLEDU DLA DALSZYCH ZAGNIEZDZEN
+ 1000 IF(OVER.EQ.6)CALL MERR(402,0)
+ OVER=OVER+1
+ DEEP=LMEM-260
+ LAB(DEEP)=NRUNIV
+ RETURN
+ END
+ SUBROUTINE SCSLAB
+C-------------------------------------------------------------------------
+C
+C OBSLUGUJE ETYKIETE DLA INSTRUKCJI CASE.
+C CZUBEK STOSU POWINIEN ZAWIERAC WARTOSC ETYKIETY,NASTEPNY SYMBOL
+C TO NUMER ETYKIETY WYGENEROWANEJ PRZEZ PARSER.
+C PROCEDURA SPRAWDZA,CZY CZUBEK STOSU ZAWIERA STALA TYPU ZGODNEGO
+C Z TYPEM WYRAZENIA CASE I CZY WARTOSC TA JUZ NIE WYSTAPILA
+C LUB CZY ROZNICA MIEDZY MAKS. I MIN. ETYKIETA < 160.
+C WYZNACZA NOWA WARTOSC ETYKIETY MAKS. I MIN. ORAZ DO BAJTU
+C WYZNACZONEGO PRZEZ WARTOSC ETYKIETY WSTAWIA ROZNICE MIEDZY
+C NUMEREM ODPOWIADAJACEJ ETYKIETY A ETYKIETA BAZOWA.
+C ZWIEKSZA LICZNIK ETYKIET.
+C W PRZYPADKU, GDY ROZPIETOSC ETYKIET PRZEKRACZA 160,ZMIENIA
+C ETYKIETE BAZOWA NA -1 /DLA UNIKNIECIA DALSZEJ SYGNALIZACJI
+C TEGO BLEDU/.
+C
+C
+C ##### DETECTED ERROR(S) : 401 , 403 , 404 , 406 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/CASE/DEEP,OVER
+ INTEGER LAB(5000)
+ EQUIVALENCE(LAB(1),IPMEM(1))
+C
+C
+C TRICK FOR HAVING 2 RIGHTMOST BYTES ADDRESSABLE
+cdsw INTEGER BYTES
+cdsw BYTE BYTE(4)
+cdsw EQUIVALENCE ( BYTES , BYTE(1) )
+C
+C
+C
+ CALL SNEXT
+C WB = NUMER ETYKIETY Z PARSERA. SPRAWDZ, CZY NA STOSIE JEST STALA
+ N=STACK(VALTOP)
+ IF(N.EQ.0)RETURN
+ IF(N.EQ.1)GO TO 100
+C ... JAKO ETYKIETA W "CASE" WYSTAPIL OBIEKT ROZNY OD STALEJ
+ CALL SERROR(401)
+ RETURN
+C
+C.....ZBADAJ ZGODNOSC TYPOW /JESLI NIE BYLO PRZEPELNIENIA/
+ 100 IF(STACK(VALTOP-4).EQ.LAB(DEEP))GO TO 200
+C NIEZGODNOSC TYPOW ETYKIETY I WYRAZENIA "CASE"
+ IF(LAB(DEEP).NE.NRUNIV)CALL SERROR(406)
+ RETURN
+C
+C.....USTAL NOWE WARTOSCI ETYKIET : MINIMALNA I MAKSYMALNA.
+C /UWAGA: ZE WZGLEDU NA INICJALIZACJE KONIECZNE OBA POROWNANIA/
+ 200 N=STACK(VALTOP-2)
+ IF(N.LT.LAB(DEEP+2))LAB(DEEP+2)=N
+ IF(N.GT.LAB(DEEP+3))LAB(DEEP+3)=N
+ IF(LAB(DEEP+3)-LAB(DEEP+2).LT.160)GO TO 300
+C ROZPIETOSC WARTOSCI ETYKIET PRZEKRACZA 160
+ IF(LAB(DEEP+1).EQ.-1)RETURN
+ CALL SERROR(403)
+ LAB(DEEP+1)=-1
+ RETURN
+C.....WYZNACZ NUMER BAJTU
+ 300 N=MOD(N,160)
+ IF(N.LT.0)N=N+160
+ L=N/2+DEEP+5
+C = NUMER SLOWA W LAB
+ m = lab(l)
+C = WARTOSC TEGO SLOWA
+ WB=WB-LAB(DEEP+1)
+C ZWIEKSZ LICZNIK ETYKIET
+ LAB(DEEP+4)=LAB(DEEP+4)+1
+C PARZYSTY BAJT ?
+ IF(IAND(N,1).EQ.0)GO TO 500
+C ... NIEPARZYSTY, PRAWY BAJT. ETYKIETA JUZ WYSTAPILA ?
+ if(iand(m,x'00ff').eq.0) go to 400
+C ... POWTORNE WYSTAPIENIE TEJ SAMEJ ETYKIETY
+ 350 CALL SERROR(404)
+ RETURN
+C WSTAW ROZNICE : NUMER ETYKIETY - ETYKIETA BAZOWA
+ 400 lab(l) = ior(m,wb)
+ RETURN
+C ... PARZYSTY, LEWY BAJT
+ 500 if(iand(ishft(m,-8),x'00ff').ne.0) go to 350
+ lab(l) = ior(ishft(wb,8),m)
+ return
+ END
+ SUBROUTINE SOTHER
+C--------------------------------------------------------------------------
+C
+C WOLANA PO WYSTAPIENIU "OTHERWISE" W INSTRUKCJI "CASE" .
+C WYPISUJE ETYKIETY /POPRZEZ SCSOUT/ I ZAZNACZA TO POPRZEZ ZMIANE
+C SLOWA 0 OPISU CASE NA NRUNIV.
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/CASE/DEEP,OVER
+ INTEGER LAB(5000)
+ EQUIVALENCE(LAB(1),IPMEM(1))
+C
+C
+ IF(LAB(DEEP).EQ.NRUNIV)RETURN
+C WYPISZ ETYKIETY I ZAZNACZ TO
+ CALL SCSOUT
+ LAB(DEEP)=NRUNIV
+ RETURN
+ END
+ SUBROUTINE SCSOUT
+C----------------------------------------------------------------------------
+C
+C
+C WOLANA : PRZED "OTHERWISE" /JESLI WYSTAPILO/ LUB PRZY "ESAC" .
+C
+C WYPISUJE ETYKIETY DLA "CASE".
+C POSTAC : "ESAC" / =190 /
+C LICZBA ETYKIET
+C NUMER ETYKIETY BAZOWEJ
+C WARTOSC ETYKIETY MINIMALNEJ
+C DLA KAZDEJ ETYKIETY SLOWO ZAWIERAJACE :
+C LEWY BAJT = ETYKIETA - ET.MINIMALNA
+C PRAWY BAJT = ODLEGLOSC OD ETYKIETY BAZOWEJ
+C - W KOLEJNOSCI OD ETYKIETY MINIMALNEJ DO MAKSYMALNEJ.
+C
+C NA KONCU DOPISUJE ETYKIETE DLA "OTHERWISE" /BAZOWA/ ,NIEZALEZNIE
+C OD TEGO,CZY "OTHERWISE" WYSTAPILO.
+C
+C
+C ##### OUTPUT CODE : 181 , 190 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C
+ COMMON/CASE/DEEP,OVER
+ INTEGER LAB(5000)
+ EQUIVALENCE(LAB(1),IPMEM(1))
+C
+C TRICK FOR HAVING 2 RIGHTMOST BYTES ADDRESSABLE
+cdsw INTEGER BYTES,OBYTES
+cdsw BYTE BYTE(4),OBYTE(4)
+cdsw EQUIVALENCE ( BYTES , BYTE(1) ) , ( OBYTES , OBYTE(1) )
+C
+ INTEGER N,NR,DIFF,L,BOUND
+C
+C
+ IF(ERRFLG)RETURN
+ N=LAB(DEEP+2)
+C = ETYKIETA MINIMALNA
+ NR=LAB(DEEP+4)
+C = LICZBA ETYKIET
+C WYPISZ "ESAC",LICZBA ETYKIET,ETYKIETA BAZOWA I MINIMALNA
+ CALL QUADR4(190,NR,LAB(DEEP+1),N)
+C
+C.....WYPISZ DLA KAZDEJ ETYKIETY 2 BAJTY :
+C LEWY = ET. - ET.MIN. , PRAWY = NUMER - ETYKIETA BAZOWA
+C
+C DALEJ :
+C DALEJ :
+C DIFF = BIEZACA ETYKIETA - ET.MINIMALNA
+C L = NUMER SLOWA DLA KOLEJNEJ ETYKIETY
+C K = WARTOSC SLOWA
+C NR = LICZBA ETYKIET DO WYPISANIA
+C BOUND = NUMER PIERWSZEGO SLOWA ZA OPISEM "CASE"
+C
+ BOUND=DEEP+85
+ N=MOD(N,160)
+ IF(N.LT.0)N=N+160
+C = NUMER BAJTU DLA ETYKIETY MINIMALNEJ , 0..159
+ DIFF=-1
+ L=DEEP+5+N/2
+C = NUMER SLOWA
+cdsw OBYTES=0
+ BYTES=LAB(L)
+C PARZYSTA ?
+ IF(IAND(N,1).NE.0)GO TO 300
+C ... PARZYSTY,LEWY BAJT
+ 200 DIFF=DIFF+1
+C WEZ LEWY BAJT
+ byte = iand(ishft(bytes,-8),X'00ff')
+ if(byte.eq.0) go to 300
+C WYPISZ PARE DLA TEJ ETYKIETY
+ call quadr1(ior(byte,ishft(diff,8)))
+ NR=NR-1
+ IF(NR.EQ.0)GO TO 1000
+C ... NIEPARZYSTY,PRAWY BAJT
+ 300 DIFF=DIFF+1
+C WEZ PRAWY BAJT
+ byte = iand(bytes,X'00ff')
+ if(byte.eq.0) go to 400
+C WYPISZ PARE DLA TEJ ETYKIETY
+ call quadr1(ior(ishft(diff,8),byte))
+ NR=NR-1
+ IF(NR.EQ.0)GO TO 1000
+C ... ZWIEKSZ NUMER SLOWA/ ZWAZAJAC NA GRANICE / I WCZYTAJ TO SLOWO
+ 400 L=L+1
+ IF(L.EQ.BOUND)L=L-80
+ BYTES=LAB(L)
+ GO TO 200
+C.....WYPISZ ETYKIETE DLA "OTHERWISE"
+ 1000 CALL QUADR2(181,LAB(DEEP+1))
+ RETURN
+ END
+ SUBROUTINE SESAC
+C----------------------------------------------------------------------------
+C
+C OBSLUGUJE ZAKONCZENIE INSTRUKCJI "CASE".
+C OBNIZA STOS INSTRUKCJI CASE.
+C JESLI NIE WYSTAPILO "OTHERWISE" I NIE BYLO PRZEPELNIENIA
+C WYPISUJE ETYKIETY /PRZEZ SCSOUT/
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
+C
+C
+ COMMON/CASE/DEEP,OVER
+ INTEGER LAB(5000)
+ EQUIVALENCE(LAB(1),IPMEM(1))
+C
+C
+C.....WYPISZ ETYKIETY / O ILE NIE WYSTAPILO "OTHERWISE" LUB PRZEPELNIENIE/
+ IF(LAB(DEEP).NE.NRUNIV)CALL SCSOUT
+ IF(OVER.GT.6)GO TO 500
+ DEEP=DEEP-85
+ IF(DEEP.GT.LMEM-600)RETURN
+C POBRAC OPIS Z DYSKU ?
+ IF(OVER.EQ.0)RETURN
+ CALL SEEK(IBUF3,IOP(2))
+ CALL GET(IBUF3,LAB(LMEM-515))
+ OVER=0
+ DEEP=LMEM-345
+ RETURN
+C.....PRZEPELNIENIE.
+ 500 OVER=OVER-1
+ RETURN
+ END
+ SUBROUTINE SEND
+C-------------------------------------------------------------------------
+C
+C WOLANA PRZY END MODULU.
+C JESLI TRZEBA, DOPISUJE LAST-WILL.
+C WYPISUJE ZAKONCZENIE LAST-WILL.
+C
+C ##### OUTPUT CODE : 175 , 185 , 193 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C.....BYLO LAST-WILL ?
+ IF(LSTWILL)GO TO 1000
+C NIE. ZAKONCZ INSTRUKCJE MODULU
+ CALL SFIN
+C I DOPISZ LAST-WILL
+ CALL SLWILL
+C
+C.....WYPISZ ZAKONCZENIE LAST-WILL: SKOK ZA LAST-WILL PREFIKSU
+C LUB BACK
+ 1000 IF(UNIT.LE.2)GO TO 2000
+ IDL=IPMEM(P+21)
+C JESLI NIE MA PREFIKSU - BACK
+ IF(IDL.EQ.0)GO TO 2000
+C PREFIKSOWANY. CZY W CIAGU PREFIKSOWYM BYLO LAST-WILL ?
+C /TAK, GDY SLOWO +8 PREFIKSU <> 0 /
+ IDL=IPMEM(IDL+8)
+ IF(IDL.EQ.0)GO TO 2000
+C SKOK ZA LAST-WILL W SEKWENCJI PREFIKSOWEJ
+ CALL QUADR2(175,IDL)
+ GO TO 3000
+C.....BACK
+cdsw 2000 CALL QUADR1(193)
+cdsw ---------------------------------------
+c jesli coroutina/process to FIN (194)
+2000 n = iand(ipmem(p),15)
+c pole = t
+ if(n.eq.5.or.n.eq.7) go to 2100
+ call quadr1(193)
+ go to 3000
+c coroutina/ process
+2100 call quadr1(194)
+cdsw ----------------------------------------
+C
+C.....WYPISZ ZNACZNIK KONCA MODULU
+ 3000 CALL QUADR1(185)
+ RETURN
+ END
+ SUBROUTINE SFIN
+C-------------------------------------------------------------------
+C
+C OBSLUGUJE KONIEC INSTRUKCJI MODULU / LAST-WILL LUB END,
+C JESLI LAST-WILL NIE WYSTAPILO/
+C KOLEJNE DWA SYMBOLE TO : NUMER ETYKIETY, NUMER LINII.
+C
+C JESLI TRZEBA,DOPISUJE INNER.
+C DOPISUJE ETYKIETE ORAZ NUMER LINII PRZED END.
+C DLA MODULOW PREFIKSOWANYCH GENERUJE SKOK ZA INNER,DLA POZOSTALYCH
+C END BLOKU /BACKBL/ LUB END PROCEDURY,FUNKCJI /BACKPR/ LUB
+C END KLASY,COROUTINY /FIN/ LUB END HANDLERA /TERMINATE/.
+C
+C ##### OUTPUT CODE : 172 , 177 , 178 , 181 , 183 ,
+C 191 , 192 , 194 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+ INTEGER AUX(6)
+ DATA AUX/191,172,194,192,192,194/
+C POWROTY Z MODULU: BACKBL,TERMINATE,FIN,BACKPR,BACKPR,FIN .
+C
+C.....DOPISAC INNER?
+ IF(INNER.NE.0)GO TO 10
+ CALL QUADR2(178,IPMEM(P+23))
+C ZAZNACZ BRAK INSTRUKCJI PO INNER /CHYBA,ZE Z PREFIKSU/
+ IPMEM(P-7)=0
+ IDL=IPMEM(P+21)
+C IDL=PREFIKS LUB 0
+ IF(IDL.NE.0)IPMEM(P-7)=IPMEM(IDL-7)
+C.....DOPISZ ETYKIETE O NUMERZE WB
+ 10 CALL SNEXT
+ CALL QUADR2(181,WB)
+C ... DOPISZ NUMER LINII
+ CALL SNEXT
+ IF(.NOT.OPTTRC)WB=-WB
+ CALL QUADR2(177,WB)
+ IF(UNIT.GT.2)GO TO 200
+C ... BLOK LUB HANDLER
+ 100 CALL QUADR1(AUX(UNIT))
+ RETURN
+C ... PREFIKSOWANY ?
+ 200 IDL=IPMEM(P+21)
+ IF(IDL.EQ.0)GO TO 100
+C TAK. CZY SA INSTRUKCJE PO INNER ?
+ IDL=IPMEM(IDL-7)
+ IF(IDL.EQ.0)GO TO 100
+C ... SKOK ZA INNER PREFIKSU
+ CALL QUADR2(183,IDL)
+ RETURN
+ END
+ SUBROUTINE SLWILL
+C----------------------------------------------------------------------
+C
+C WYPISUJE ETYKKIETE LAST-WILL.
+C DLA KLASY WPISUJE DO SLOWA +8 INFORMACJE O LAST-WILL:
+C NUMER NAJBLIZSZEGO MODULU W CIAGU PREFIKSOWYM /Z BIEZACYM
+C MODULEM WLACZNIE/ MAJACEGO LAST-WILL LUB ZERO,JESLI
+C W CALYM CIAGU PREFIKSOWYM LAST-WILL NIE WYSTAPILO.
+C
+C ##### OUTPUT CODE : 174 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C.....WYPISZ ETYKIETE LAST-WILL
+ CALL QUADR1(174)
+ IF(UNIT.NE.6)RETURN
+C ... KLASA
+ IDR=0
+C JESLI JEST PREFIKS - SKOPIUJ Z PREFIKSU
+ IDL=IPMEM(P+21)
+ IF(IDL.NE.0)IDR=IPMEM(IDL+8)
+C JESLI W TYM MODULE WYSTAPILO LAST-WILL, TO WPISZ NUMER BIEZACEGO
+C MODULU
+ IF(LSTWILL)IDR=P
+ IPMEM(P+8)=IDR
+ RETURN
+ END
+ SUBROUTINE SRETURN
+C-----------------------------------------------------------------
+C
+C DLA WYSTAPIENIA "RETURN" GENERUJE :
+C DLA PROCEDUR,FUNKCJI BEZ PREFIKSU BACKPR, DLA PREFIKSOWANYCH
+C LUB KLAS,COROUTIN BACK, DLA BLOKOW BACKBL, DLA HANDLERA BACKHD.
+C
+C
+C ##### OUTPUT CODE : 180 , 191 , 192 , 193 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER AUX(6)
+ DATA AUX/191,180,193,192,192,193/
+C POWROTY Z MODULU : BACKBL,BACKHD,BACK,BACKPR,BACKPR,BACK
+C
+C
+ IDL=AUX(UNIT)
+cbc added concurrent statements
+ call snext
+c check if procedure or function
+ if (unit .ne. 4 .and. unit .ne. 5) goto 100
+c generate BACKRPC
+ call quadr1(227)
+10 op = wb
+ if (op .ne. 91 .and. op .ne. 92) goto 40
+c process next ENABLE/DISABLE list
+20 call snext
+ if (wb .ne. 28) goto 10
+c process next identifier
+ call snext
+ ind = mident(wb)
+ elem = swhat(ind)
+c check if procedure or function
+ if (elem .ne. 11 .and. elem .ne. 12) goto 30
+ if (op .eq. 92) ind = -ind
+ call quadr1(ind)
+ goto 20
+30 call serror(478)
+ goto 20
+40 call quadr1(0)
+ call snext
+ return
+c
+Cbc JESLI MODUL PREFIKSOWANY TO BACK
+cbc IF(UNIT.GT.2 .AND. IPMEM(P+21).NE.0)IDL=193
+100 CALL QUADR1(IDL)
+ RETURN
+ END
+ SUBROUTINE SFORTO(UP,STEP)
+C-----------------------------------------------------------------------------
+C
+C OBSLUGUJE POCZATEK PETLI FOR.
+C WOLANA PO WYSTAPIENIU SYMBOLU "TO" LUB "DOWNTO".
+C UP = TRUE ,JESLI BYLO "TO"
+C STEP = TRUE ,JESLI WYSTAPILO "STEP"
+C STOS ZAWIERA: ZMIENNA STERUJACA,WARTOSC POCZATKOWA,KROK/JESLI BYL/,
+C WARTOSC KONCOWA.
+C NASTEPNE 2 SYMBOLE WEJSCIOWE TO NUMERY ETYKIET POCZATKU PETLI I ZA PETLA
+C WCZYTUJE OBA NUMERY,ZASTEPUJE 4 LUB 3 GORNE ELEMENTY STOSU PRZEZ
+C OPIS PETLI FOR.
+C JESLI KROK LUB WARTOSC KONCOWA NIE SA STALE, PRZYDZIELA IM ATRYBUTY
+C ROBOCZE ZYWE PO WYJSCIU Z BLOKU BAZOWEGO ORAZ GENERUJE MOVE&SAFE
+C DLA NICH.
+C
+C GENERUJE KOD :
+C WSTAWIENIE WARTOSCI POCZATKOWEJ DO R5 ,
+C ETYKIETA POCZATKU PETLI ,
+C PODSTAWIENIE WARTOSCI Z R5 NA ZMIENNA STERUJACA ,
+C RELACJA I SKOK WARUNKOWY /WYJSCIE Z PETLI/
+C
+C
+C
+C ##### OUTPUT CODE : 13 , 60 , 90 , 92 , 108 , 110 ,
+C 139 , 152 , 181 , 208 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+cdsw DATA SFTHEX1,SFTHEX2,SFTHEX3 /Z8000,Z4000,Z2000 /
+C
+ LOGICAL UP,STEP,END1
+C TRUE,JESLI: BYLO "TO", BYLO "STEP" , WARTOSC KONCOWA ROZNA OD STALEJ
+ INTEGER END2,STEP1,STEP2
+C ATS LUB WARTOSC STALEJ DLA WARTOSCI KONCOWEJ,RODZAJ KROKU
+C /1 JESLI STALY/, ATS LUB WARTOSC KROKU.
+C
+cdsw ------------------------------------------------
+ data sfthx2, sfthx3 / x'4000', x'2000' /
+ sfthx1 = ishft(1,15)
+cdsw ------------------------------------------------
+C
+C.....WARTOSC KONCOWA
+ CALL SINDTYP
+ END1=STACK(VALTOP).NE.1
+ END2=STACK(VALTOP-2)
+ CALL SPOP
+C JESLI TRZEBA - ZABEZPIECZ WARTOSC KONCOWA
+ IF(.NOT.END1)GO TO 100
+C ZABEZPIECZ
+ CALL QUADR3(208,TEMPNR+6,END2)
+ END2=TEMPNR+6
+C
+C.....BYLO "STEP" ?
+ 100 IF(STEP)GO TO 200
+C NIE. WSTAW KROK=1
+ STEP1=1
+ STEP2=1
+ GO TO 300
+C TAK.
+ 200 STEP1=STACK(VALTOP)
+ STEP2=STACK(VALTOP-2)
+ CALL SPOP
+C STALY KROK? JESLI NIE - ZABEZPIECZ
+ IF(STEP1.EQ.1)GO TO 300
+ CALL QUADR3(208,TEMPNR+3,STEP2)
+ STEP2=TEMPNR+3
+C
+C.....WARTOSC POCZATKOWA. WPISZ DO "R5"
+ 300 N=SVATS(VALTOP)
+ K=STACK(VLPREV-2)
+C K = ATS ZMIENNEJ STERUJACEJ
+ CALL SPOP
+C ZDEJMIJ TEZ ZMIENNA STERUJACA
+ CALL SPOP
+ LSTLSE=0
+C WPISZ WARTOSC POCZATKOWA DO R5 ( REJESTR = 4 )
+ CALL QUADR3(139,N,4)
+C
+C
+C.....WSTAW OPIS PETLI NA STOS
+C
+C POSTAC OPISU : SLOWO -1 = ATS ZMIENNEJ STERUJACEJ
+C SLOWO -2 = WARTOSC LUB ATS KROKU
+C SLOWO -3 : BIT 0 = 0 --> "TO",= 1 --> "DOWNTO"
+C BIT 1 = 0 --> STALY KROK,= 1 --> WYLICZONY
+C BIT 2 = 0 --> STALA WARTOSC KONCOWA,
+C = 1 --> WYLICZONA
+C
+ CALL SPUSH(6)
+ LSTFOR=VALTOP
+ STACK(VALTOP-1)=K
+ STACK(VALTOP-2)=STEP2
+ N=0
+C = "TO" , STALY KROK , STALA WARTOSC KONCOWA
+ IF(.NOT.UP)N=IOR(N,SFTHX1)
+ IF(STEP1.NE.1)N=IOR(N,SFTHX2)
+ IF(END1)N=IOR(N,SFTHX3)
+ STACK(VALTOP-3)=N
+C
+C
+C.....POCZATEK PETLI.
+ CALL SNEXT
+C WB=NUMER ETYKIETY POCZATKU. GENERUJ ETYKIETE.
+ CALL QUADR2(181,WB)
+ CALL SNEXT
+C WB=NUMER ETYKIETY ZA PETLA
+C
+C ... PODSTAW WARTOSC Z R5 NA ZMIENNA STERUJACA
+ L=TSTEMP(1)
+C 4 --> R5
+ CALL QUADR3(13,L,4)
+ CALL QUADR3(60,K,L)
+C
+C ... GENERUJ POROWNANIE
+ STEP1=TSTEMP(1)
+ N=110
+C ="GT INTEGER"
+C STALA WARTOSC KONCOWA?
+ IF(END1)GO TO 500
+C TAK
+ N=92
+C = "GT CONST"
+C
+C.....POROWNANIE I WYSKOK ZA PETLE
+ 500 IF(.NOT.UP)N=N-2
+C OPKOD "LT" = OPKOD "GT" -2 .
+ CALL QUADR4(N,STEP1,K,END2)
+ CALL QUADR3(152,STEP1,WB)
+ RETURN
+ END
+ SUBROUTINE SFOREND
+C----------------------------------------------------------------------------
+C
+C OBSLUGUJE ZAKONCZENIE PETLI FOR
+C ZWIEKSZA ZMIENNA STERUJACA O KROK /ZMNIEJSZA DLA "DOWNTO"/
+C I WKLADA DO "R5".
+C ZMNIEJSZA LSTFOR,TEMPNR.
+C JESLI KROK LUB WARTOSC KONCOWA NIE BYLY STALE, ZWALNIA
+C ZAJMOWANE PRZEZ NIE ZMIENNE ROBOCZE /GENERUJE "RELEASE"/
+C
+C GENERUJE KOD :
+C WSTAWIENIE DO R5 WARTOSCI ZMIENNEJ STERUJACEJ POWIEKSZONEJ
+C O KROK / POMNIEJSZONEJ DLA DOWNTO / ,
+C SKOK NA POCZATEK PETLI
+C
+C
+C ##### OUTPUT CODE : 37 , 113 , 114 , 139 , 141 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER N,STEP,ATS,OPKOD,K
+C
+cdsw DATA SFEHEX1,SFEHEX2,SFEHEX3 /Z8000,Z4000, Z2000 /
+C
+cdsw ---------------------------------------------------
+ data sfehx2, sfehx3 /x'4000', x'2000'/
+ sfehx1 = ishft(1,15)
+cdsw -----------------------------------------------
+C..............
+ N=STACK(VALTOP-3)
+ STEP=STACK(VALTOP-2)
+ ATS=STACK(VALTOP-1)
+ K=TSTEMP(1)
+C "DOWNTO" ?
+ IF(IAND(N,SFEHX1).NE.0)GO TO 600
+C....."TO"
+ OPKOD=113
+C =" + INTEGER"
+C STALY KROK? TAK,JESLI BIT 1 = 0
+ IF(IAND(N,SFEHX2).NE.0)GO TO 400
+C TAK.
+ 200 OPKOD=37
+C =" + CONST"
+C
+ 400 CALL QUADR4(OPKOD,K,ATS,STEP)
+C WSTAW DO "R5" ( REJESTR = 4 )
+ CALL QUADR3(139,K,4)
+ LSTFOR=VLPREV
+C.....ZWOLNIJ ZMIENNE ROBOCZE,JESLI:
+C WARTOSC KONCOWA ROZNA OD STALEJ /BIT 2 = 1/
+ IF(IAND(N,SFEHX3).NE.0)CALL QUADR2(141,TEMPNR+6)
+C KROK ROZNY OD STALEJ /BIT 1 = 1/
+ IF(IAND(N,SFEHX2).NE.0)CALL QUADR2(141,TEMPNR+3)
+C
+C ZWOLNIJ NUMERY ATRYBUTOW ROBOCZYCH REZERWOWANE DLA PETLI FOR
+ TEMPNR=TEMPNR+6
+ RETURN
+C
+C....."DOWNTO". STALY KROK?
+ 600 OPKOD=114
+C =" - INTEGER"
+ IF(IAND(N,SFEHX2).NE.0)GO TO 400
+C TAK
+ STEP=-STEP
+ GO TO 200
+ END
+ SUBROUTINE SKILL
+C---------------------------------------------------------------
+C
+C NA CZUBKU JEST ARGUMENT KILL. BADA TYP,GENERUJE KOD.
+C
+C
+C ##### OUTPUT CODE : 143 , 146 .
+C
+C ##### DETECTED ERROR(S) : 415 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ CALL SVALUE
+C JESLI UNIWERSALNY-POMIN
+ IF(STACK(VALTOP).EQ.0)RETURN
+C POMIN TAKZE NONE LUB TYP UNIWERSALNY
+ IDL=STACK(VALTOP-4)
+ IF(IDL.EQ.NRNONE .OR. IDL.EQ.NRUNIV)RETURN
+ IDR=143
+C OPKOD KILL DLA TABLICY,REKORDU
+C TABLICA?
+ IF(STACK(VALTOP-3).GT.0)GO TO 50
+C NIE. CZY TYP PIERWOTNY?
+ DO 20 I=1,6
+ IF(IDL.EQ.CONSNR(I))GO TO 90
+ 20 CONTINUE
+C..... O.K. REKORD? /POLE T=2/
+ IF(IAND(IPMEM(IDL),15) .NE.2)IDR=146
+C OPKOD UNIWERSALNEGO KILL
+ 50 CALL QUADR2(IDR,STACK(VALTOP-2))
+ RETURN
+ 90 CALL SERROR(415)
+ END
+ SUBROUTINE SOPTION
+C------------------------------------------------------
+C
+C OBSLUGUJE ZMIANE OPCJI
+C
+C NASTEPNY SYMBOL TO + , - NUMER OPCJI.
+C
+C NUMER I NAZWA OPCJI * ZMIENNA * WARTOSC DLA + * DLA - * ZNACZENIE DLA +
+C
+C M 2 MEMBER CONTROL * OPTMEM * 0 * 1 * WYMAGANA KONTROLA
+C O 3 OPTIMIZATION * OPTOPT * TRUE * FALSE * WOLNO OPTYMALIZOWAC
+C I 4 INDEX CONTROL * OPTIND * 0 * 2 * WYMAGANA KONTROLA
+C T 5 TYPE CONTROL * OPTTYP * FALSE * TRUE * WYMAGANA KONTROLA
+C D 6 TRACE * OPTTRC * TRUE * FALSE * WYMAGANY SLAD
+C C 7 CASE CONTROL * OPTCSC * 0 * 1 * WYMAGANA KONTROLA
+C F 8 FAST CASE * OPTCSF * 0 * 2 * SZYBKI CASE
+C
+C
+C OPCJA 1 - LISTING - JEST UZYWANA TYLKO PRZEZ PARSER
+C
+C
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+ INTEGER OPTION(7),PLUS(7),MINUS(7)
+ LOGICAL LPLUS(7),LMINUS(7)
+ EQUIVALENCE (OPTION(1),OPTMEM)
+ EQUIVALENCE (PLUS,LPLUS)
+ EQUIVALENCE (MINUS,LMINUS)
+C PLUS,LPLUS - WARTOSCI ODPOWIEDNICH ZMIENNYCH DLA ZAPALONEJ OPCJI
+C MINUS,LMINUS - " " " " ZGASZONEJ OPCJI
+C
+ DATA PLUS(1),PLUS(3),PLUS(6),PLUS(7)/4*0/
+ DATA LPLUS(2),LPLUS(4),LPLUS(5)/.TRUE.,.FALSE.,.TRUE./
+ DATA MINUS(1),MINUS(3),MINUS(6),MINUS(7)/1,2,1,2/
+ DATA LMINUS(2),LMINUS(4),LMINUS(5)/.FALSE.,.TRUE.,.FALSE./
+C
+C
+C.....WCZYTAJ NUMER OPCJI
+ CALL SNEXT
+C ZGASZONA ?
+ IF(WB.GT.0)GO TO 100
+C ... TAK
+ WB=-WB-1
+ N=MINUS(WB)
+ GO TO 200
+C ... ZAPALONA
+ 100 WB=WB-1
+ N=PLUS(WB)
+ 200 OPTION(WB)=N
+ RETURN
+ END
+cdsw subroutine sread(*,*)
+ SUBROUTINE SREAD(where)
+C-----------------------------------------------------------------------
+cdsw where=1 - return1, where=2 - return2
+C
+C OBSLUGUJE OPERACJE CZYTANIA.
+C NA CZUBKU STOSU ZNAJDUJE SIE ARGUMENT LUB ADRES PLIKU
+C
+C WRACA DO ETYKIETY 30 LUB 40 W SDPDA
+C
+C KORZYSTA Z /BEZPARAMETROWYCH/ STANDARDOWYCH FUNKCJI
+C O NUMERACH :
+C 43,44 - READCHAR
+C 45,46 - READINT
+C 47,48 - READREAL
+C
+C
+C ##### OUTPUT CODE : 23 , 132 .
+C
+C ##### DETECTED ERROR(S) : 420 , 443 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+C
+ ELEM=STACK(VALTOP)
+ IF(ELEM.EQ.0)GO TO 500
+ K=STACK(VALTOP-4)
+C PIERWSZY ARGUMENT ?
+ IF(FLARGS.GT.0)GO TO 100
+C TAK. FUNKCJA ?
+ IF(ELEM.EQ.12)GO TO 50
+C NIE. ADRES PLIKU ?
+ IF(STACK(VALTOP-3).GT.0)GO TO 200
+ IF(IAND(IPMEM(K),15).NE.11)GO TO 100
+C TAK. PRZEKAZ ADRES PLIKU
+ 50 CALL SVALUE
+ K=STACK(VALTOP-4)
+ IF(STACK(VALTOP-3).GT.0)GO TO 200
+ IF(IAND(IPMEM(K),15).NE.11)GO TO 100
+ FLMODF=0
+ FILE=VALTOP
+ CALL SFLADR
+ FLARGS=1
+C GO TO 40
+cdsw RETURN2
+cdsw ------------------
+ where=2
+ return
+cdsw ------------------
+C POWROT DO PETLI W SDPDA
+C
+C
+C.....ARGUMENT. ZMIENNA ?
+ 100 IF(ELEM.LT.3 .OR. ELEM.GT.5)CALL SERROR(420)
+C WPISZ ADRES PLIKU
+ CALL SFLADR
+C ZBADAJ TYP, TABLICOWY ?
+ IF(STACK(VALTOP-3).GT.0)GO TO 200
+C N=NUMER FUNKCJI STANDARDOWEJ ,L=APETYT, K=TYP
+ N=46
+ L=1
+C INTEGER?
+ IF(K.EQ.NRINT)GO TO 300
+C CHAR?
+ N=44
+ IF(K.EQ.NRCHR)GO TO 300
+C REAL?
+ N=48
+#if WSIZE == 4
+ L = 1
+#else
+ L = 2
+#endif
+ IF(K.EQ.NRRE)GO TO 300
+C.....ZATEM NIEPOPRAWNY TYP ZMIENNEJ W INSTRUKCJI READ
+ 200 CALL SERROR(443)
+ GO TO 500
+C
+C.....OK PRZEKAZ STEROWANIE DO FUNKCJI STANDARDOWEJ
+ 300 N=N-FLMODF
+ CALL QUADR2(132,N)
+C ODCZYTAJ WARTOSC
+ K=TSTEMP(L)
+ CALL QUADR4(23,K,N,0)
+C WPISZ WARTOSC
+ CALL SSTORE(VALTOP,K)
+ 500 FLARGS=2
+C POWROT DO ETYKIETY 30 W SDPDA
+C GO TO 30
+cdsw RETURN1
+cdsw ----------------
+ where=1
+ return
+cdsw -----------------
+ END
+cdsw SUBROUTINE SWRITE(*,*)
+ subroutine swrite(where)
+C------------------------------------------------------------------------
+cdsw where = 1 - return1, where = 2 - return2
+C
+C OBSLUGUJE OPERACJE PISANIA.
+C NA STOSIE JEST ADRES PLIKU LUB WARTOSC DO WYPISANIA, A NAD NIA 0,1 LUB 2
+C WARTOSCI OKRESLAJACE FORMAT.
+C NASTEPNY SYMBOL = LICZBA WARTOSCI OKRESLAJACYCH FORMAT /0..2/
+C ZDEJMUJE TE WARTOSCI ZE STOSU.
+C
+C WRACA DO ETYKIETY 30 LUB 40 W SDPDA
+C
+C UZYWA PROCEDUR STANDARDOWYCH :
+C 60,61 - WRITECHAR ( ZNAK )
+C 62,63 - WRITEINT ( LICZBA , SZEROKOSC POLA )
+C 64,65 - WRITEREAL ( LICZBA , LICZBA ZNAKOW PRZED KROPKA , PO KROPCE )
+C = WRFLT. =
+C 66,67 - WRITEREAL = WRFLE. =
+C 68,69 - WRITEREAL = WRFLF. =
+C 70,71 - WRITESTRING ( ADRES TEKSTU , SZEROKOSC POLA LUB -1 )
+C
+C DOZWOLONE FORMATY :
+C INTEGER - 0 LUB 1 , DEFAULT = 6
+C CHAR - 0
+C TEXT - 0 LUB 1 , DEFAULT = -1 /=CALY TEKST/
+C REAL - 0 , 1 LUB 2 , DEFAULT = 12 . 4 /=17/
+C
+C UWAGA : PARAMETRY / W TYM WARTOSC FUNKCJI / SA NUMEROWANE OD ZERA .
+C
+C ##### OUTPUT CODE : 132 , 145 .
+C
+C ##### DETECTED ERROR(S) : 441 , 442 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER FORMAT(2),I,K,N
+C
+C
+ CALL SNEXT
+C WB=LICZBA WYRAZEN OKRESLAJACYCH FORMAT
+C.....WSTAW DO TABLICY FORMAT ATS-Y FORMATOW
+C
+ I=WB
+ 100 IF(I.EQ.0)GO TO 200
+ CALL SINDTYP
+ FORMAT(I)=SVATS(VALTOP)
+ CALL SPOP
+ I=I-1
+ GO TO 100
+C
+C.....TERAZ CZUBEK ZAWIERA WARTOSC DO WYPISANIA LUB ADRES PLIKU
+ 200 CALL SVALUE
+ IF(STACK(VALTOP).EQ.0)GO TO 1000
+ K=SVATS(VALTOP)
+C ZBADAJ TYP
+ IF(STACK(VALTOP-3).NE.0)GO TO 400
+ I=STACK(VALTOP-4)
+C PIERWSZY ARGUMENT ?
+ IF(FLARGS.GT.0)GO TO 300
+C TAK. ADRES PLIKU ?
+ IF(IAND(IPMEM(I),15).NE.11)GO TO 300
+C TAK. WYSTAPIL FORMAT ?
+ IF(WB.NE.0)CALL SERROR(441)
+ FLMODF=0
+ FILE=VALTOP
+ FLARGS=1
+ CALL SFLADR
+C GO TO 40
+cdsw RETURN2
+cdsw -------------------
+ where = 2
+ return
+cdsw --------------------
+C POWROT DO PETLI W SDPDA
+C
+C.....ARGUMENT
+ 300 CALL SFLADR
+ IF(I.EQ.NRRE)GO TO 800
+C ZATEM CHAR,INTEGER,TEXT
+ IF(I.EQ.NRINT)GO TO 500
+ IF(I.EQ.NRTEXT)GO TO 600
+ IF(I.EQ.NRCHR)GO TO 700
+C
+C.....ZATEM NIELEGALNY TYP ARGUMENTU INSTRUKCJI WRITE
+ 400 I=442
+ 410 CALL SERROR(I)
+ GO TO 1000
+C
+C....NIELEGALNY FORMAT
+ 420 I=441
+ GO TO 410
+C
+C
+C.....INTEGER. DEFAULT : 6 ZNAKOW
+ 500 IF(WB.EQ.2)GO TO 420
+ IF(WB.EQ.0)FORMAT(1)=SCONST(6)
+ N=62+FLMODF
+ GO TO 920
+C
+C....TEXT. -1 JESLI BRAK FORMATU
+ 600 IF(WB.EQ.2)GO TO 420
+ IF(WB.EQ.0)FORMAT(1)=SCONST(-1)
+ N=70+FLMODF
+ GO TO 920
+C
+C.....CHAR
+ 700 IF(WB.NE.0)GO TO 420
+ N=60+FLMODF
+ GO TO 930
+C
+C.....REAL. DEFAULT : 12 ZNAKOW PRZED KROPKA , 4 PO KROPCE.
+ 800 N=64+2*WB+FLMODF
+ WB=WB+1
+ GO TO (810,820,830),WB
+C ... BEZ FORMATU , DEFAULT 12.4 , "WRFLT." = 8
+ 810 FORMAT(1)=SCONST(12)
+ FORMAT(2)=SCONST(4)
+ GO TO 900
+C ... FORMAT = SZEROKOSC POLA , 5 ZNAKOW PO KROPCE, "WRFLE." = 10
+ 820 FORMAT(2)=SCONST(5)
+C
+C ... FORMAT = SZEROKOSC POLA,LICZBA ZNAKOW PO KROPCE, "WRFLF." = 11
+ 830 CONTINUE
+C.....WSTAWIANIE PARAMETROW : N = NUMER PROCEDURY STANDARDOWEJ
+C K = ATS WARTOSCI
+C WSTAW PRAWY FORMAT DLA REAL
+ 900 CALL QUADR4(145,FORMAT(2),N,2)
+C WSTAW /LEWY/ FORMAT
+ 920 CALL QUADR4(145,FORMAT(1),N,1)
+C WSTAW WARTOSC
+ 930 CALL QUADR4(145,K,N,0)
+C PRZEKAZ STEROWANIE
+ CALL QUADR2(132,N)
+ 1000 FLARGS=2
+C POWROT DO ETYKIETY 30 W SDPDA
+cdsw RETURN1
+cdsw -----------------
+ where=1
+ return
+cdsw -----------------
+ END
+ SUBROUTINE SFTEST
+C---------------------------------------------------------
+C
+C SPRAWDZA, CZY ELEMENT Z CZUBKA STOSU (UNIW.,STALA,
+C WARTOSC,ZMIENNA,TABL.STAT.,ELEM.TABL.) JEST TYPU FILE .
+C 'NONE' NIE JEST AKCEPTOWANE
+C
+C ##### DETECTED ERROR(S) : 413 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ N=STACK(VALTOP-4)
+ IF(STACK(VALTOP-3).GT.0 .OR. (N.NE.NRUNIV.AND.
+ X IAND(IPMEM(N),15).NE.11))CALL SERROR(413)
+ RETURN
+ END
+ SUBROUTINE SFLADR
+C---------------------------------------------------------
+C
+C ZAPEWNIA, ZE (R6-12) ZAWIERA ADRES PLIKU
+C - DLA OPERACJI NA PLIKU WSKAZYWANYM
+C
+C ##### OUTPUT CODE : 139 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ IF(FILE.EQ.0 .OR. FLREADY)RETURN
+ CALL QUADR3(139,STACK(FILE-2),-45)
+C -45 --> (R6-12)
+ FLREADY=.TRUE.
+ RETURN
+ END
+cdsw SUBROUTINE SPUT(*,*)
+ subroutine sput(where)
+C---------------------------------------------------------
+cdsw where = 1 - return1, where = 2 - return2
+C
+C OBSLUGUJE 'PUT' .
+C CZUBEK STOSU ZAWIERA ADRES PLIKU LUB ARGUMENT.
+C
+C WRACA BEZPOSREDNIO DO ETYKIETY 30 LUB 40 W SDPDA.
+C
+C ##### OUTPUT CODE : 132 , 145 .
+C
+C ##### DETECTED ERROR(S) : 445 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ CALL SVALUE
+C ADRES PLIKU JUZ WYSTAPIL ?
+ IF(FLARGS.GT.0)GO TO 100
+C JESZCZE NIE
+ CALL SFTEST
+ FILE=VALTOP
+ FLARGS=1
+ FLMODF=0
+ CALL SFLADR
+C GO TO 40
+cdsw RETURN2
+cdsw ------------------
+ where = 2
+ return
+cdsw ------------------
+C POWROT DO SDPDA
+C
+C.....ARGUMENT
+ 100 FLARGS=2
+ CALL SFLADR
+ N=STACK(VALTOP-4)
+C SEMAPHORE ?
+ if(iand(ipmem(n),15).eq.9) go to 799
+ if(stack(valtop-3).gt.0) go to 799
+ IF(N.EQ.NRINT)GO TO 400
+ IF(N.EQ.NRCHR)GO TO 300
+ IF(N.EQ.NRRE )GO TO 500
+ if(n.eq.nrtext) go to 799
+C ZATEM REFERENCJA lub nielegealny typ
+ go to 799
+CPS 600 N=56 dziwne, ta etykieta nie jest uzywana !
+CPS GO TO 1000
+ 300 N=53
+ GO TO 1000
+ 400 N=54
+ GO TO 1000
+ 500 N=55
+ GO TO 1000
+C
+ 1000 CALL QUADR4(145,SVATS(VALTOP),N,0)
+ CALL QUADR2(132,N)
+C GO TO 30
+cdsw RETURN1
+cdsw ------------------
+ where = 1
+ return
+cdsw ------------------
+C POWROT DO SDPDA
+ 799 call serror(445)
+ where = 1
+ return
+ END
+cdsw SUBROUTINE SGET(*,*)
+ subroutine sget(where)
+C---------------------------------------------------------
+cdsw where = 1 - return1 , where = 2 - return2
+C
+C OBSLUGUJE 'GET'
+C CZUBEK STOSU ZAWIERA ARGUMENT LUB ADRES PLIKU.
+C
+C WRACA DO ETYKIETY 30 LUB 40 W SDPDA.
+C
+C ##### OUTPUT CODE : 23 , 132 , 145 .
+C
+C ##### DETECTED ERROR(S) : 420 , 446 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER ELEM,N,ATS
+C
+C ADRES PLIKU JUZ WYSTAPIL ?
+ IF(FLARGS.GT.0)GO TO 100
+C JESZCZE NIE
+ CALL SVALUE
+ CALL SFTEST
+ FILE=VALTOP
+ FLARGS=1
+ FLMODF=0
+ CALL SFLADR
+C GO TO 40
+cdsw RETURN2
+cdsw ------------------------
+ where = 2
+ return
+cdsw ------------------------
+C POWROT DO SDPDA
+C
+C.....ARGUMENT. ZMIENNA ?
+ 100 FLARGS=2
+ CALL SFLADR
+ ELEM=STACK(VALTOP)
+ N=STACK(VALTOP-4)
+C SEMAPHORE ?
+ IF(IAND(IPMEM(N),15).EQ.9)GO TO 9000
+ if(stack(valtop-3).gt.0) go to 9000
+ IF(N.EQ.NRINT)GO TO 1000
+ IF(N.EQ.NRCHR)GO TO 1200
+ IF(N.EQ.NRRE )GO TO 1100
+ IF(N.EQ.NRTEXT)GO TO 9000
+C ZATEM REFERENCJA.lub nielegalny typ
+ go to 9000
+C POWROT DO PETLI W SDPDA
+C
+C ... INTEGER
+ 1000 N=50
+ GO TO 1500
+C ... REAL
+ 1100 N=51
+#if WSIZE == 4
+ ats = tstemp(1)
+#else
+ ats = tstemp(2)
+#endif
+ GO TO 2000
+C ... CHAR
+ 1200 N=49
+C
+C
+ 1500 ATS=TSTEMP(1)
+C ZMIENNA ?
+ 2000 IF(ELEM.LT.3 .OR. ELEM.GT.5)CALL SERROR(420)
+ CALL QUADR2(132,N)
+ CALL QUADR4(23,ATS,N,0)
+ CALL SSTORE(VALTOP,ATS)
+C GO TO 30
+cdsw RETURN1
+cdsw ----------------
+ where = 1
+ return
+cdsw ----------------
+C POWROT DO SDPDA
+C.....NIELEGALNY TYP ARGUMENTU
+ 9000 CALL SERROR(446)
+C GO TO 30
+cdsw RETURN1
+cdsw ----------------
+ where = 1
+ return
+cdsw -----------------
+ end
+ SUBROUTINE SEOF(N)
+C--------------------------------------------------------------
+cdsw procedura zostala podzielona na dwie - seof i seof0
+C
+C OBSLUGUJE OPERATORY 'EOF' I 'EOLN'.
+C WSTAWIA NA STOS ODCZYTANA WARTOSC FUNKCJI.
+C
+C WEJSCIE SEOF0 ODPOWIADA BEZPARAMETROWYM EOF, EOLN.
+C WEJSCIE SEOF ODPOWIADA EOF, EOLN Z PODANYM (NA CZUBKU STOSU)
+C ADRESEM PLIKU (JEST USUWANY).
+C N = NUMER ODPOWIEDNIEJ FUNKCJI STANDARDOWEJ
+C (39, 40 DLA EOF, 74, 75 DLA EOLN)
+C
+C
+C ###### GENEROWANY KOD : 23 , 132 , 139 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+C......CZUBEK STOSU ZAWIERA ADRES PLIKU
+ CALL SVALUE
+ CALL SFTEST
+C PRZEKAZ ADRES PLIKU DO (R6-12)
+ CALL QUADR3(139,STACK(VALTOP-2),-45)
+ CALL SPOP
+C DALEJ JAK DLA BEZPARAMETROWYCH EOF, EOLN
+C
+ call seof0(n)
+ return
+ end
+ SUBROUTINE SEOF0(N)
+C--------------------------------------------------------------
+cdsw procedura zostala podzielona na dwie - seof i seof0
+C
+C OBSLUGUJE OPERATORY 'EOF' I 'EOLN'.
+C WSTAWIA NA STOS ODCZYTANA WARTOSC FUNKCJI.
+C
+C WEJSCIE SEOF0 ODPOWIADA BEZPARAMETROWYM EOF, EOLN.
+C WEJSCIE SEOF ODPOWIADA EOF, EOLN Z PODANYM (NA CZUBKU STOSU)
+C ADRESEM PLIKU (JEST USUWANY).
+C N = NUMER ODPOWIEDNIEJ FUNKCJI STANDARDOWEJ
+C (39, 40 DLA EOF, 74, 75 DLA EOLN)
+C
+C
+C ###### GENEROWANY KOD : 23 , 132 , 139 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER ATS
+C...................BEZPARAMETROWE EOF , EOLN
+C
+C WYWOLAJ FUNKCJE
+ CALL QUADR2(132,N)
+ ATS=TSTEMP(1)
+C PODCZYTAJ WARTOSC ( PARAMETR 0 )
+ CALL QUADR4(23,ATS,N,0)
+C WSTAW NA STOS ODCZYTANA WARTOSC
+ CALL SPUSH(2)
+ STACK(VALTOP-1)=0
+ STACK(VALTOP-2)=ATS
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=NRBOOL
+ STACK(VALTOP-5)=0
+ RETURN
+ END
+ INTEGER FUNCTION SVATS(ELEM)
+C--------------------------------------------------------------
+C
+C ZWRACA ATS WARTOSCI Z MIEJSCA ELEM STOSU .
+C (UNIWERSALNY,STALA,WARTOSC)
+C DLA STALEJ GENERUJE NOWY ATS.
+C
+#include "stos.h"
+#include "blank.h"
+
+cdsw&ail
+ common /stacks/ btsins, btstem
+C
+ SVATS=STACK(ELEM-2)
+ IF(STACK(ELEM).NE.1)RETURN
+C STALA
+ N=STACK(ELEM-4)
+ IF(N.EQ.NRRE)GO TO 100
+ IF(N.EQ.NRNONE)GO TO 200
+C ZATEM : INTEGER,CHAR,BOOLEAN,TEXT
+ SVATS=SCONST(SVATS)
+ RETURN
+C ... STALA REAL
+ 100 SVATS=SCREAL(SVATS)
+ RETURN
+C ... STALA NONE
+cdsw&ail 200 SVATS=LMEM-3
+ 200 svats = btstem - 3
+ RETURN
+ END
+C
+ SUBROUTINE SAVEVAR(ELEM)
+C-------------------------------------------------------
+C
+C ZABEZPIECZA ADRES ZMIENNEJ (UOGOLNIONEJ) Z MIEJSCA
+C ELEM STOSU.
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ N=STACK(ELEM)-2
+ GO TO (300,400,500),N
+C.....ZMIENNA
+C ADRES PRZED KROPKA :
+ 300 CALL SAFE(STACK(ELEM-7))
+ RETURN
+C.....ELEMENT TABLICY
+C ADRES TABLICY :
+ 400 CALL SAFE(STACK(ELEM-2))
+C I INDEKS, JESLI ROZNY OD STALEJ :
+ IF(STACK(ELEM-2).GT.0)GO TO 300
+cdsw added - bug!
+ return
+C.....TABLICA STATYCZNA
+ 500 GO TO 300
+ END
+ SUBROUTINE SCHECK(ERROR,TYP)
+C--------------------------------------------------------
+C
+C POMOCNICZA. JESLI CZUBEK STOSU NIE JEST TYPU PROSTEGO
+C TYP LUB UNIWERSALNEGO - SYGNALIZUJE BLAD ERROR.
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER ERROR,TYP
+ I=STACK(VALTOP-4)
+ IF(STACK(VALTOP-3).NE.0 .OR. (I.NE.NRUNIV .AND. I.NE.TYP))
+ X CALL SERROR(ERROR)
+ RETURN
+ END
+ SUBROUTINE SNOT
+C-----------------------------------------------------------------
+C
+C OBSLUGUJE OPERATOR NOT. ARGUMENT JEST NA CZUBKU .
+C
+C
+C ##### OUTPUT CODE : 42 .
+C
+C ##### DETECTED ERROR(S) : 417 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ CALL SNEXT
+ CALL SVALUE
+C JESLI UNIWERSALNY-POMIN
+ IF(STACK(VALTOP).EQ.0)RETURN
+C SPRAWDZ TYP
+ CALL SCHECK(417,NRBOOL)
+C..... CZY STALA?
+ IF(STACK(VALTOP).EQ.1)GO TO 51
+C NIE. CZY WB= IF.FALSE LUB IF.TRUE ?
+ IF(WB.EQ.29 .OR. WB.EQ.30)GO TO 60
+C.....NIE, WYKONAJ NOT.
+ IDL=TSTEMP(1)
+ CALL QUADR3(42,IDL,STACK(VALTOP-2))
+ STACK(VALTOP)=2
+ STACK(VALTOP-2)=IDL
+ RETURN
+C.....STALA, ZMIEN WARTOSC.
+ 51 STACK(VALTOP-2)=-1-STACK(VALTOP-2)
+ RETURN
+C.....NOT PRZED SKOKIEM WARUNKOWYM,ZMIEN RODZAJ SKOKU
+ 60 WB=59-WB
+ RETURN
+ END
+ SUBROUTINE SARITH
+C--------------------------------------------------------------------------
+C
+C 1982.09.15
+C
+C OBSLUGUJE 1 LUB 2 - ARGUMENTOWE OPERACJE ARYTMETYCZNE.
+C WB=NUMER OPERACJI, 1..8 OZNACZaJA:
+C ABS,MINUS UNARNY,+,-,*,/,DIV,MODE
+C ARGUMENT LUB 2 ARGUMENTY SA NA CZUBKU STOSU.
+C ARGUMENTY ZASTEPUJE PRZEZ WYNIK OPERACJI /UNIWERSALNY,STALA,WARTOSC/
+C
+C WYROZNIA PRZYPADKI:
+C OBA ARGUMENTY STALE,
+C DODAWANIE,ODEJMOWANIE STALEJ
+C MNOZENIE PRZEZ STALE 0..10,
+C DZIELENIE PRZEZ 0,1,2,4,8.
+C
+C
+C ##### OUTPUT CODE : 37 , 48 , 49 , 50 , 51 , 64 , 65 , 66 ,
+C 67 , 68 , 69 , 70 , 71 , 72 , 73 , 74 ,
+C 75 , 113 , 114 , 115 , 117 , 118 , 119 ,
+C 120 , 121 , 122 , 140 .
+C
+C ##### DETECTED ERROR(S) : 460 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+cdsw&bc
+ real y
+ integer*2 m(2)
+ equivalence (y, m(1))
+CCCCCCCCCCCCCCC
+C ROBOCZE
+ INTEGER ELEM,OPKOD
+C
+ REAL XREAL,YREAL
+C
+C
+ INTEGER CREAL
+C
+C
+C........................
+C
+C TERAZ WB=NUMER OPERACJI
+C WYLICZ WARTOSC
+ CALL SVALUE
+C I WSTAW TYP PRAWEGO ARGUMENTU
+ TRDIM=STACK(VALTOP-3)
+ TRBAS=STACK(VALTOP-4)
+ IDR=STACK(VALTOP-1)
+C.....PRZESKOCZ,JESLI OPERACJA 2-ARGUMENTOWA
+ IF(WB.GT.2)GO TO 1000
+C.....ABS LUB MINUS UNARNY
+ IF(STACK(VALTOP).EQ.0)RETURN
+C ZBADAJ TYP
+ TLDIM=TRDIM
+ TLBAS=TRBAS
+ IDL=IDR
+ CALL MARITH(1)
+C CZY STALA?
+ IF(STACK(VALTOP).EQ.1)GO TO 200
+C NIE. INTEGER?
+ IF(STACK(VALTOP-4).EQ.NRINT)GO TO 150
+C ZATEM ZMIENNA,WARTOSC TYPU REAL
+#if WSIZE == 4
+ result = tstemp(1)
+#else
+ result = tstemp(2)
+#endif
+ 100 CALL QUADR3(49+WB,RESULT,STACK(VALTOP-2))
+C ZASTAP PRZEZ "WARTOSC" Z NOWYM RESULT
+ STACK(VALTOP)=2
+ STACK(VALTOP-2)=RESULT
+ RETURN
+C ZMIENNA,WARTOSC TYPU INTEGER
+ 150 RESULT=TSTEMP(1)
+ WB=WB-2
+ GO TO 100
+C STALA JAKO ARGUMENT ABS LUB MINUSA UNARNEGO
+ 200 IF(STACK(VALTOP-4).EQ.NRRE)GO TO 250
+ IF((WB.EQ.1 .AND. STACK(VALTOP-2).LT.0).OR.(WB.EQ.2))
+ X STACK(VALTOP-2)= -STACK(VALTOP-2)
+ RETURN
+C STALA REAL
+ 250 RESULT=STACK(VALTOP-2)
+cdsw&bc XREAL=STALER(RESULT)
+#if WSIZE == 4
+ xreal=staler(result)
+#else
+ n1 = result*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ xreal = y
+#endif
+c
+ IF((WB.EQ.1 .AND. XREAL.LT.0.0).OR.(WB.EQ.2))
+ X STACK(VALTOP-2)=CREAL(-XREAL)
+ RETURN
+C
+C................ OPERACJE 2-ARGUMENTOWE.......................
+C
+C ROZROZNIA PRZYPADKI : OBA ARGUMENTY STALE , JEDEN ARGUMENT STALY,
+C MNOZENIE LUB DZIELENIE PRZEZ WYROZNIONE STALE
+C /0,1,2,3,4,5,6,7,8,9,10 LUB 0,1,2,4,8/
+C
+ 1000 CALL SVALU2
+ ELEM=0
+C JESLI JEDEN Z ARGUMENTOW UNIWERSALNY-ZASTAP OBA PRZEZ UNIWERSALNY
+ IF(STACK(VALTOP)*STACK(VLPREV).EQ.0)GO TO 1400
+C WSTAW TYP I NAZWE LEWEGO ,SPRAWDZ TYPY
+ TLDIM=STACK(VLPREV-3)
+ TLBAS=STACK(VLPREV-4)
+ IDL=STACK(VLPREV-1)
+ ELEM=2
+C ELEM="WARTOSC",UZYWANE PO SKOKU DO 1400.
+ OPKOD=1
+ IF(WB.GT.6)OPKOD=2
+ IF(WB.EQ.6)OPKOD=3
+ CALL MARITH(OPKOD)
+C WYKONAJ EWENTUALNA KONWERSJE
+ IF(CONVR.EQ.1)CALL SVREAL(VALTOP)
+ IF(CONVL.EQ.1)CALL SVREAL(VLPREV)
+ IDL=STACK(VLPREV-2)
+ IDR=STACK(VALTOP-2)
+C IDL,IDR = WARTOSC LUB NUMER STALEJ LUB ATS LEWEGO,PRAWEGO ARGUMENTU.
+C DLA JEDNEGO ARG.STALEGO - IDR=STALA
+C
+C
+C..........STALE ARGUMENTY?
+ CALL SARGMT
+ GO TO (2000,4000,1600,1050),ARG
+C
+C..........OBA ROZNE OD STALYCH
+C
+1050 IF(TRESLT.EQ.NRRE)GO TO 1500
+C
+C
+C INTEGER
+ 1100 RESULT=TSTEMP(1)
+ 1200 OPKOD=113-3
+C GENERUJ OPERACJE
+ 1300 CALL QUADR4(OPKOD+WB,RESULT,IDL,IDR)
+C
+C
+C.....ZASTAP OBA PRZEZ "WARTOSC" TYPU TRESLT
+C
+ 1400 CALL SRESULT(ELEM)
+ RETURN
+C
+C
+C REAL
+ 1500 OPKOD=119-3
+#if WSIZE == 4
+ result = tstemp(1)
+#else
+ result = tstemp(2)
+#endif
+ GO TO 1300
+C
+C.....PRAWY ARGUMENT STALY,LEWY NIE /DLA + , * ROWNIEZ ODWROTNIE/
+C JESLI REAL - WSTAW STALA I DALEJ JAK DLA OBU ROZNYCH OD STALYCH
+ 1600 IF(TRESLT.NE.NRRE)GO TO 4100
+C
+C TUTAJ ROZSZERZENIE O ARGUMENT 0.0 LUB 1.0
+C
+ IDR=SCREAL(IDR)
+ GO TO 1500
+C
+C
+C.............OBA ARGUMENTY STALE. OBLICZ WYNIK.
+C
+ 2000 ELEM=1
+ WB=WB-2
+ IF(TRESLT.NE.NRINT)GO TO 3000
+C
+C.....OPERACJA NA 2 STALYCH INTEGER
+ GO TO(2100,2200,2300,2400,2400,2500),WB
+C +
+ 2100 RESULT=IDL+IDR
+ GO TO 1400
+C -
+ 2200 RESULT=IDL-IDR
+ GO TO 1400
+C *
+ 2300 RESULT=IDL*IDR
+ GO TO 1400
+C / , DIV
+ 2400 IF(IDR.EQ.0)GO TO 4800
+ RESULT=IDL/IDR
+ GO TO 1400
+C MODE
+ 2500 RESULT=MOD(IDL,IDR)
+ GO TO 1400
+C
+C.....OPERACJA NA 2 STALYCH TYPU REAL
+ 3000 continue
+cdsw&bc XREAL=STALER(IDR)
+cdsw&bc YREAL=STALER(IDL)
+#if WSIZE == 4
+ xreal=staler(idr)
+ yreal=staler(idl)
+#else
+ n1 = idr*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ xreal = y
+ n1 = idl*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ yreal = y
+#endif
+C XREAL,YREAL = WARTOSC PRAWEGO,LEWEGO ARGUMENTU
+ GO TO (3100,3200,3300,3400),WB
+C +
+ 3100 XREAL=YREAL+XREAL
+ GO TO 3500
+C -
+ 3200 XREAL=YREAL-XREAL
+ GO TO 3500
+C *
+ 3300 XREAL=YREAL*XREAL
+ GO TO 3500
+C /
+cailvax and all other computers: 3400 IF(YREAL.EQ. 0.0)GO TO 4800
+ 3400 if(xreal .eq. 0.0)go to 4800
+ XREAL=YREAL/XREAL
+C WSTAW XREAL DO SLOWNIKA STALYCH REAL
+ 3500 RESULT=CREAL(XREAL)
+ GO TO 1400
+C
+C.....LEWY ARGUMENT STALY,PRAWY NIE.
+C
+C OPERACJA SYMETRYCZNA?
+ 4000 IF(WB.EQ.3 .OR. WB.EQ.5)GO TO 4050
+C OPERACJA NIESYMETRYCZNA
+ IF(TRESLT.EQ.NRRE)GO TO 4030
+ IDL=SCONST(IDL)
+ GO TO 1100
+ 4030 IDL=SCREAL(IDL)
+C
+C TUTAJ ROZSZERZENIE O LEWY ARGUMENT 0.0 DLA - , / .
+C
+ GO TO 1500
+C
+C OPERACJA SYMETRYCZNA: + , * .ZAMIEN IDL,IDR
+ 4050 TRDIM=IDL
+ IDL=IDR
+ IDR=TRDIM
+ GO TO 1600
+C
+C.....WSPOLNA AKCJA. PRAWY ARG.STALY LUB OP.SYM. I LEWY STALY
+C IDL = ATS ROZNEGO OD STALEJ ARG.,IDR=STALA
+C OBA ARGUMENTY TYPU INTEGER.
+C
+ 4100 RESULT=TSTEMP(1)
+ GO TO (4150,4150,4300,4200,4400,4700,4700,4720),WB
+ 4150 CONTINUE
+C
+C...........
+C - . ZMIEN ZNAK STALEJ
+ 4200 IDR= -IDR
+C
+C...........
+C + , - . +0 ?
+ 4300 IF(IDR.EQ.0)GO TO 4810
+ CALL QUADR4(37,RESULT,IDL,IDR)
+ GO TO 1400
+C
+C..........
+C * . JAKA TO STALA?
+ 4400 IF(IDR.LT.0 .OR. IDR.GT.10)GO TO 4720
+C ZATEM STALA 0..10
+ IF(IDR-1) 4805 , 4810 , 4500
+C ... MNOZENIE PRZEZ STALA 2..10 /REALIZOWANE PRZEZ SHIFT/
+ 4500 OPKOD=62+IDR
+ 4600 CALL QUADR3(OPKOD,RESULT,IDL)
+ GO TO 1400
+C
+C...........
+C DIVE
+ 4700 IF(IDR.GE.0 .AND. IDR.LE.8)GO TO 4750
+C WSTAW STALA
+ 4720 IDR=SCONST(IDR)
+ GO TO 1200
+C ... DZIELENIE PRZEZ STALE 0..8 . WYROZNIJ 0,1,2,4,8
+ 4750 N=IDR+1
+ GO TO (4800,4810,4820,4720,4840,4720,4720,4720,4880),N
+C
+C.....DZIELENIE PRZEZ ZERO
+ 4800 CALL SERROR(460)
+C ZASTAP PRZEZ STALA ZERO / DLA MNOZENIA LUB DZIELENIA PRZEZ ZERO /
+ 4805 ELEM=1
+ IF(.NOT.OPTOPT)CALL QUADR2(140,IDL)
+ RESULT=IDR
+ GO TO 1400
+C ... ZASTAP PRZEZ ARGUMENT ROZNY OD STALEJ / MNOZENIE,DZIELENIE
+C PRZEZ 1 LUB DODAWANIE,ODEJMOWANIE 0 /
+ 4810 RESULT=IDL
+ GO TO 1400
+C
+C ... DIVE 2
+ 4820 OPKOD=75
+ GO TO 4600
+C ... DIVE 4
+ 4840 OPKOD=74
+ GO TO 4600
+C ... DIVE 8
+ 4880 OPKOD=73
+ GO TO 4600
+C
+ END
+ SUBROUTINE SRELAT
+C-----------------------------------------------------------------------------
+C
+C DWA GORNE ELEMENTY STOSU ZAWIERAJA ARGUMENTY RELACJI :
+C IS , IN DLA WB= 1,2 LUB
+C = , <> , < , <= , > , >= . WB=NUMER RELACJI /3..8/
+C GENERUJE KOD WYZNACZAJACY WARTOSC RELACJI.
+C WYROZNIA PRZYPADKI : OBA ARGUMENTY STALE,
+C POROWNANIE ZE STALA INTEGER
+C POROWNANIE Z ZEREM / 0 LUB 0.0 /
+C POROWNANIE Z NONE .
+C
+C
+C ##### OUTPUT CODE : 55 , 56 , 76 , 77 , 78 , 79 , 80 , 81 ,
+C 82 , 83 , 88 , 89 , 90 , 91 , 92 , 93 ,
+C 106 , 107 , 108 , 109 , 110 , 111 ,
+C 123 , 124 ,
+C 125 , 126 , 127 , 128 , 129 , 130 .
+C
+C ##### DETECTED ERROR(S) : 475 , 476 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+CCCCCCCCCCCCCCCCCCCCCCCC
+ INTEGER REL(6),RELCONV(6),RLCASE,ELEM
+C REL - TABLICA WYZNACZAJACA WYNIKI POROWNANIA DLA 6 RELACJI,
+C BITY 15,14,13 =0 JESLI DLA L<P , L=P , L>P WYNIK JEST FALSE
+C RELCONV - TABLICA ZAMIANY POROWNAN PRZY ZAMIANIE ARGUMENTOW
+C RLCASE - TYP POROWNANIA: 1,3,4-INTEGER,2-REAL,5,6-REFERENCYJNY
+C ELEM - RODZAJ ELEMENTU
+ REAL X
+cdsw&bc
+ real y, yy
+ integer*2 m(2)
+ equivalence (y, m(1))
+c
+ common/stream/ errflg,line,ibuf2(265),ibuf3(7),junk(260)
+C
+ DATA RELCONV/3,4,7,8,5,6/,REL/2,5,1,3,4,6/
+C..........
+ ELEM=0
+ CALL SVALU2
+C WSTAW TYP I NAZWE LEWEGO ARGUMENTU
+ TLDIM=STACK(VLPREV-3)
+ TLBAS=STACK(VLPREV-4)
+ IDL=STACK(VLPREV-1)
+C IS,IN ?
+ IF(WB.LT.3)GO TO 7000
+ CALL SVALUE
+ IF(STACK(VALTOP)*STACK(VLPREV).EQ.0)GO TO 3200
+C WSTAW TYPY ARGUMENTOW
+ TRDIM=STACK(VALTOP-3)
+ TRBAS=STACK(VALTOP-4)
+ IDR=STACK(VALTOP-1)
+ ELEM=2
+C JAKA RELACJA?
+ IF(WB.LE.4)GO TO 200
+C < , <= , > , >=
+ CALL MARITH(1)
+ RLCASE=1
+ IF(TRESLT.EQ.NRRE)RLCASE=2
+ GO TO 300
+C = , <>
+C WSTAW INFORMACJE O DOSTEPNOSCI TYPOW FORMALNYCH
+ 200 OBJL=STACK(VLPREV-6)
+ OBJR=STACK(VALTOP-6)
+ CALL MEQUAL(RLCASE)
+C
+C RLCASE OKRESLA TYP POROWNANIA: 1,3,4-INTEGER,2-REAL,5,6-REFERENCYJNE
+ 300 IF(CONVL.EQ.1)CALL SVREAL(VLPREV)
+ IF(CONVR.EQ.1)CALL SVREAL(VALTOP)
+ IDL=STACK(VLPREV-2)
+ IDR=STACK(VALTOP-2)
+C IDL,IDR=WARTOSC LUB NUMER STALEJ LUB ATS LEWEGO,PRAWEGO ARGUMENTU
+ CALL SARGMT
+C WYBIERZ TYP POROWNANIA: INTEGER,REAL,REFERENCYJNY
+ GO TO (1000,3000,1000,1000,5000,5000),RLCASE
+C
+C..........INTEGER
+C
+C
+C STALE ARGUMENTY?
+ 1000 GO TO (1050,1200,1500,1300),ARG
+C.....OBA STALE,WYZNACZ WARTOSC RELACJI
+ 1050 X=FLOAT(IDL-IDR)
+ GO TO 3100
+C.....LEWY STALY,PRAWY NIE. ZAMIEN.
+ 1200 OBJL=IDL
+ IDL=IDR
+ IDR=OBJL
+ WB=RELCONV(WB-2)
+ GO TO 1500
+C.....LEWY ROZNY OD STALEJ.
+C POROWNANIE
+ 1300 RLCASE=103
+C ="POROWNANIE INTEGER"-3
+ GO TO 1800
+C.....PRAWY STALY,LEWY NIE.
+ 1500 RLCASE=85
+C ="POROWNANIE ZE STALA"-3
+C CZY Z ZEREM?
+ IF(IDR.EQ.0)GO TO 3400
+C NIE
+C
+C.....GENERUJ POROWNANIE 2-ARG.
+ 1800 RESULT=TSTEMP(1)
+ CALL QUADR4(RLCASE+WB,RESULT,IDL,IDR)
+ GO TO 3200
+C
+C
+C..........POROWNANIE 2 ARGUMENTOW REAL
+C
+ 3000 RLCASE=122
+C ="POROWNANIE REAL"-3
+cdsw GO TO (3050,3300,4000,1800),ARG
+cdsw --------------------------
+ go to (3050,3700,4000,1800),arg
+cdsw --------------------------
+C.....OBA STALE. WYZNACZ WARTOSC RELACJI
+cdsw&bc 3050 X=STALER(IDL)-STALER(IDR)
+#if WSIZE == 4
+ 3050 x=staler(idl)-staler(idr)
+#else
+ 3050 n1 = idl*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ yy = y
+ n1 = idr*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ x = yy-y
+#endif
+c
+ 3100 IF ( X ) 3110,3120,3130
+C LEWY < PRAWY
+ 3110 RESULT=IAND(REL(WB-2),1)
+ GO TO 3150
+C LEWY = PRAWY
+ 3120 RESULT=IAND(REL(WB-2),2)
+ GO TO 3150
+C LEWY > PRAWY
+ 3130 RESULT=IAND(REL(WB-2),4)
+ 3150 IF(RESULT.NE.0)RESULT=-1
+C RESULT ZAWIERA REPREZENTACJE TRUE LUB FALSE
+ ELEM=1
+C
+C
+C.....ZASTAP OBA ARGUMENTY PRZEZ WYNIK TYPU BOOLEAN
+C
+C
+ 3200 TRESLT=NRBOOL
+ CALL SRESULT(ELEM)
+ RETURN
+C
+C
+C.....LEWY STALY,PRAWY NIE. LEWY = 0.0 ?
+cdsw3300 IF(STALER(IDL).NE. 0.0)GO TO 3700
+C LEWY=0.0, ZAMIEN POROWNANIA
+cdsw WB=RELCONV(WB-2)
+cdsw IDL=IDR
+C.....GENERUJ POROWNANIE 1-ARG.
+ 3400 RESULT=TSTEMP(1)
+ CALL QUADR3(73+WB,RESULT,IDL)
+C ZASTAP PRZEZ WARTOSC
+ GO TO 3200
+C.....LEWY ARG. STALY<>0.0 ,WSTAW STALA
+ 3700 IDL=SCREAL(IDL)
+ GO TO 1800
+C.....PRAWY STALY,LEWY NIE. PRAWY = 0.0 ?
+cdsw 4000 IF(STALER(IDR).EQ. 0.0)GO TO 3400
+C NIE 0.0 , WSTAW STALA
+cdsw ---------- added -------
+4000 continue
+cdsw ------------------------
+ IDR=SCREAL(IDR)
+ GO TO 1800
+C
+C
+C
+C
+C..........REFERENCYJNE.
+ 5000 GO TO (5050,5200,5300,5600),ARG
+C OBA NONE ,WSTAW TRUE DLA = , FALSE DLA <> / -1 LUB 0 /
+ 5050 ELEM=1
+ RESULT=WB-4
+ GO TO 3200
+C.....LEWY NONE,PRAWY NIE. ZAMIEN
+ 5200 IDL=IDR
+C.....PRAWY NONE,LEWY NIE
+ 5300 WB=WB+6
+ GO TO 3400
+C.....OBA ROZNE OD NONE. ### BEZ DYNAMICZNEJ KONTROLI TYPOW #####
+ 5600 RLCASE=120
+C ="EQ REF"-3
+ GO TO 1800
+C
+C.....RELACJA IS , IN
+C
+C ZBADAJ TYP LEWEGO
+ 7000 IF(STACK(VLPREV).EQ.0)GO TO 7100
+ TLBAS=IAND(IPMEM(TLBAS),15)
+ IF((TLBAS.GT.7 .AND. TLBAS.LT.13).OR.TLDIM.GT.0)CALL MERR(475,IDL)
+C ZBADAJ PRAWY : REKORD,KLASA?
+ 7100 IDL=STACK(VALTOP)
+ IF(IDL.EQ.0)GO TO 3200
+ IF(IDL.EQ.8.OR.IDL.EQ.9)GO TO 7200
+ CALL SERROR(476)
+ GO TO 3200
+C O.K. LEWY=NONE ?
+ 7200 IF(STACK(VLPREV).EQ.1)GO TO 7300
+ ELEM=2
+ RESULT=TSTEMP(1)
+ CALL QUADR4(54+WB,RESULT,STACK(VLPREV-2),STACK(VALTOP-4))
+ GO TO 3200
+C LEWY=NONE : NONE IS -> FALSE , NONE IN -> TRUE
+ 7300 ELEM=1
+ RESULT=1-WB
+ GO TO 3200
+ END
+ SUBROUTINE SNEWARR
+C-----------------------------------------------------------------------------
+C
+C OBSLUGUJE GENERACJE TABLICY.
+C GORNE 3 ELEMENTY STOSU TO: ZMIENNA TABLICOWA,DOLNA GRANICA /UNIWERSALNY,
+C STALA,WARTOSC/,GORNA GRANICA /NA CZUBKU/.
+C ZDEJMUJE ZE STOSU 2 GORNE /1 ZOSTAWIA/,NIE WOLA SNEXT
+C
+C
+C ##### OUTPUT CODE : 23 , 132 ,145 .
+C
+C ##### DETECTED ERROR(S) : 433 , 435 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER AUX(4)
+C RUNNING-SYSTEM IDENTIFIERS OF ARRAY ELEMENTS : INTEGER,REAL,--,REFERENCE
+C
+ INTEGER I,N
+ DATA AUX / -1 , -3 , 0 , -2 /
+C
+C.....
+ CALL SINDTYP
+C STALE GRANICE?
+ IF(STACK(VALTOP).NE.1 .OR. STACK(VLPREV).NE.1)GO TO 60
+C TAK. DOLNA < GORNA ?
+ IF(STACK(VLPREV-2).GT.STACK(VALTOP-2))
+ X CALL SERRO2(433,VLPREV-9)
+C NAZWA 3-GO OD GORY,2-GI MA APETYT 8 /STALA/
+ 60 CONTINUE
+C WSTAW GRANICE GORNA,DOLNA
+ DO 100 I=1,2
+ CALL QUADR4(145,SVATS(VALTOP),1,I-1)
+C WSTAW WARTOSC I-TEGO PARAMETRU
+C PROCEDRA STANDARDOWA GENERACJI TABLICY MA NUMER 1 I PARAMETRY:
+C 0 - UPPER ,1 - LOWER,2 - APETYT,3 - ADRES VIRT.NOWEJ TABLICY
+ CALL SPOP
+ 100 CONTINUE
+C OBIE GRANICE WSTAWIONE. NA CZUBKU ZMIENNA.TABLICOWA?
+ LSTLSE=0
+C IF(STACK(VALTOP).EQ.0)GO TO 30 NO GLOBAL JUMPS
+ IF(STACK(VALTOP).EQ.0)RETURN
+ N=STACK(VALTOP-3)
+ IF(N.EQ.0)GO TO 300
+C O.K. WSTAW APETYT
+ N=SAPET(N-1,STACK(VALTOP-4))
+ N=AUX(N)
+ CALL QUADR4(145,SCONST(N),1,2)
+ CALL QUADR2(132,1)
+C WYGENEROWANA NOWA TABLICA.ODCZYTAJ I WPISZ JEJ ADRES
+ N=TSTEMP(4)
+ CALL QUADR4(23,N,1,3)
+ CALL SSTORE(VALTOP,N)
+ RETURN
+C.....ERROR: ZMIENNA NIE JEST TYPU TABLICOWEGO
+ 300 CALL SERROR(435)
+ RETURN
+ END
+ SUBROUTINE SRESULT(ELEM)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA. ZASTEPUJE 2 GORNE ELEMENTY STOSU PRZEZ ELEMENT
+C BEZ NAZWY TYPU ELEM.
+C JESLI TO NIE UNIWERSALNY,TO WSTAWIA TYP /0,TRESLT/,
+C ZERUJE SLOWO -5,DO SLOWA -2 WSTAWIA RESULT
+C UZYWANA DLA ZASTAPIENIA 2 ARGUMENTOW PRZEZ WYNIK /WARTOSC/ OPERACJI.
+C
+#include "stos.h"
+#include "blank.h"
+
+ CALL SPOP
+ CALL SPOP
+ CALL SPUSH(ELEM)
+ STACK(VALTOP-1)=0
+ IF(ELEM.EQ.0)RETURN
+ STACK(VALTOP-2)=RESULT
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=TRESLT
+ STACK(VALTOP-5)=0
+ RETURN
+ END
+ SUBROUTINE SRESLT1(TYPE)
+C-----------------------------------------------------------------------
+C
+C ZASTEPUJE CZUBEK STOSU PRZEZ WARTOSC TYPU <0,TYPE> ,
+C BEZ NAZWY, DO SLOWA -2 WSTAWIA RESULT, ZERUJE SLOWA -5,-6
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ CALL SPOP
+ CALL SPUSH(2)
+ STACK(VALTOP-1)=0
+ STACK(VALTOP-2)=RESULT
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-4)=TYPE
+ STACK(VALTOP-5)=0
+ STACK(VALTOP-6)=0
+ RETURN
+ END
+ SUBROUTINE SVARADR
+C----------------------------------------------------------------------
+C
+C SPRAWDZA,CZY CZUBEK STOSU ZAWIERA ZMIENNA /ZMIENNA PROSTA,
+C ELEMENT TABLICY,TABLICA STATYCZNA/.
+C JESLI NIE, TO SYGNALIZUJE BLAD I ZASTEPUJE PRZEZ UNIWERSALNY.
+C GENERUJE KOD WYLICZAJACY ADRES FIZYCZNY ZMIENNEJ.
+C ATS WYLICZONEGO ADRESU ZWRACA NA ZMIENNA RESULT.
+C
+C ##### OUTPUT CODE : 29 , 30 .
+C
+C ##### DETECTED ERROR(S) : 420.
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ IDL=STACK(VALTOP)
+C = RODZAJ ELEMENTU
+ IF(IDL.EQ.0)RETURN
+ IF(IDL.GT.5)GO TO 1000
+ GO TO (1000,1000,300,400,500),IDL
+C.....ZMIENNA
+ 300 N=STACK(VALTOP-2)
+ RESULT=TSTEMP(1)
+C PRZEZ KROPKE ?
+ IF(STACK(VALTOP-7).EQ.0)GO TO 350
+C ... ZMIENNA PRZEZ KROPKE
+ CALL QUADR4(29,RESULT,SMEMBER(VALTOP),N)
+ RETURN
+C ... ZMIENNA WIDOCZNA
+ 350 CALL QUADR3(30,RESULT,N)
+ RETURN
+C.....ELEMENT TABLICY
+ 400 RESULT=SARRAY(VALTOP)
+ RETURN
+C.....TABLICA STATYCZNA
+ 500 CONTINUE
+C B R A K
+C.....NIE ZMIENNA
+ 1000 CALL SERROR(420)
+C ZASTAP PRZEZ UNIWERSALNY
+ CALL SPOP
+ CALL SPUSH(0)
+ STACK(VALTOP-1)=0
+ RETURN
+ END
+ SUBROUTINE SBOOLEX(N)
+C-----------------------------------------------------------------------------
+C
+C OBSLUGUJE 2-ARGUMENTOWE OPERACJE BOOLOWSKIE /N=1 --> AND,
+C =0 --> OR /
+C 2 GORNE ELEMENTY STOSU SA ARGUMENTAMI.
+C
+C
+C ##### OUTPUT CODE : 100 , 101 , 140 .
+C
+C ##### DETECTED ERROR(S) : 417 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+CCCCCCCCCCCCCCCCCCCCCCC
+ INTEGER ELEM,ANDOPR
+C SKOPIUJ PARAMETR
+ ANDOPR=N
+ CALL SVALU2
+ CALL SVALUE
+C.....USTAW TYP WYNIKU
+ TRESLT=NRBOOL
+C ZBADAJ TYPY,NAJPIERW PRAWEGO.
+ IF(STACK(VALTOP).NE.0) CALL SCHECK(417,NRBOOL)
+C SPRAWDZ LEWY ARGUMENT
+ ELEM=0
+ IF(STACK(VLPREV).EQ.0)GO TO 120
+ IDR=VALTOP
+ VALTOP=VLPREV
+C TRICK
+ CALL SCHECK(417,NRBOOL)
+ VALTOP=IDR
+ IF(STACK(VALTOP).EQ.0)GO TO 120
+C.....ZATEM OBA ARGUMENTY O.K. ARGUMENY STALE?
+ CALL SARGMT
+ GO TO (170,130,160,100),ARG
+C GENERUJ ZMIENNA ROBOCZA.
+ 100 RESULT=TSTEMP(1)
+ CALL QUADR4(100+ANDOPR,RESULT,STACK(VLPREV-2),STACK(VALTOP-2))
+C
+ 119 ELEM=2
+C
+C.....ZASTAP PRZEZ WYNIK
+C
+ 120 CALL SRESULT(ELEM)
+ RETURN
+C
+C
+C.....LEWY ARGUMENT STALY,PRAWY NIE.
+C DALEJ BEDZIE: ELEM=ATS WARTOSCI LUB ZMIENNEJ, RESULT=WARTOSC STALEJ.
+ 130 RESULT=STACK(VLPREV-2)
+ ELEM=STACK(VALTOP-2)
+C.....WSPOLNA AKCJA DLA 1 ARGUMENTU STALEGO. ELEM,RESULT - JAK WYZEJ.
+ 140 IF(ANDOPR.EQ.1 .AND. RESULT.EQ.-1 .OR.
+ X ANDOPR.EQ.0 .AND. RESULT.EQ.0)GO TO 150
+C.....AND,FALSE LUB OR,TRUE .
+C ZASTAP OBA WARTOSCIA RESULT, EWENT. GENERUJ NOP.
+ IF(.NOT.OPTOPT)CALL QUADR2(140,ELEM)
+ ELEM=1
+ GO TO 120
+C.....AND,TRUE LUB OR,FALSE. ZASTAP OBA PRZEZ ROZNY OD STALEJ ARGUMENT.
+ 150 RESULT=ELEM
+ GO TO 119
+C.....PRAWY STALY,LEWY NIE.
+ 160 ELEM=STACK(VLPREV-2)
+ RESULT=STACK(VALTOP-2)
+ GO TO 140
+C.....0BA STALE
+ 170 RESULT=0
+ ELEM=STACK(VALTOP-2)+STACK(VLPREV-2)
+ IF(ANDOPR.EQ.1 .AND. ELEM.EQ.-2 .OR.
+ X ANDOPR.EQ.0 .AND. ELEM.NE.0) RESULT=-1
+ ELEM=1
+ GO TO 120
+ END
+ SUBROUTINE SARGMT
+C-----------------------------------------------------------------------
+C
+C POMOCNICZA. BADA,CZY 2 GORNE ELEMENTY STOSU SA STALYMI.
+C NADAJE ZMIENNEJ ARG WARTOSC :
+C 1 - OBA STALE
+C 2 - LEWY STALY,PRAWY NIE
+C 3 - LEWY NIE,PRAWY STALY
+C 4 - OBA ROZNE OD STALYCH
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ ARG=1
+ IF(STACK(VALTOP).NE.1)ARG=2
+ IF(STACK(VLPREV).NE.1)ARG=ARG+2
+ RETURN
+ END
+ SUBROUTINE SINDEX
+C-----------------------------------------------------------------------------
+C
+C OBSLUGUJE KOLEJNY INDEKS DLA TABLICY DYNAMICZNEJ.
+C WOLANA PO WYSTAPIENIU "," LUB ")"
+C CZUBEK STOSU ZAWIERA INDEKS .
+C PONIZEJ ADRES TABLICY .
+C ZASTEPUJE 2 GORNE ELEMENTY STOSU PRZEZ "ELEM.TABLICY" .
+C
+C
+C
+C ##### DETECTED ERROR(S) : 431 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+ common/stream/ errflg,line,ibuf2(265),ibuf3(7),junk(260)
+C..................
+ CALL SVALU2
+C SPRAWDZ TYP INDEKSU
+ CALL SINDTYP
+ IF(STACK(VLPREV-3).GT.0)GO TO 200
+C ZA DUZO INDEKSOW
+ CALL SERRO2(431,VLPREV)
+ GO TO 300
+C O.K.
+ 200 STACK(VLPREV-3)=STACK(VLPREV-3)-1
+C ZASTAP PRZEZ "ELEM.TABLICY"
+ 300 STACK(VLPREV)=4
+ STACK(VLPREV-7)= STACK(VALTOP-2)
+C WARTOSC INDEKSU. STALY?
+ IF(STACK(VALTOP).EQ.1)STACK(VLPREV-2)= - STACK(VLPREV-2)
+ RETURN
+ END
+ SUBROUTINE SINDTYP
+C----------------------------------------------------------------------
+C
+C POMOCNICZA. SPRAWDZA,CZY CZUBEK STOSU ZAWIERA ELEMENT
+C SPROWADZALNY DO WARTOSCI TYPU INTEGER.
+C WYLICZA WARTOSC CZUBKA STOSU,DOKONUJE EWENTUALNEJ KONWERSJI DO INTEGER
+C WOLANA PRZEZ PROCEDURY SINDEX,SINDXS DLA KONTROLI INDEKSU
+C
+C ##### DETECTED ERROR(S) : 412 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ CALL SVALUE
+ IF(STACK(VALTOP).EQ.0)RETURN
+C NIE UNIWERSALNY,SPRAWDZ TYP
+ N=STACK(VALTOP-4)
+ IF(STACK(VALTOP-3).GT.0 .OR. (N.NE.NRUNIV .AND. N.NE.NRINT
+ X .AND. N.NE.NRRE) )GO TO 500
+C O.K.
+ IF(N.EQ.NRRE)CALL SVINT(VALTOP)
+ RETURN
+C.....NIEPOPRAWNY TYP INDEKSU
+ 500 CALL SERROR(412)
+ RETURN
+ END
+ SUBROUTINE SASSIGN
+C-----------------------------------------------------------------------------
+C
+C WERSJA 1982.02.12
+C
+C PROCEDURA OBSLUGUJE WIELOKROTNE PODSTAWIENIE.
+C WOLANA PRZEZ SDPDA PO POJAWIENIU SIE ASSIGN.
+C DOKONUJE KONTROLI TYPOW, GENERUJE KOD DYNAMICZNEJ KONTROLI
+C TYPOW I KONWERSJI ORAZ KOD NADAJACY WARTOSCI LEWYM STRONOM PODSTAWIENIA.
+C CZUBEK STOSU ZAWIERA PRAWA STRONE PODSTAWIENIA
+C PONIZEJ ,OD LSTFOR+1 DO LSTLSE ZNAJDUJA SIE LEWE STRONY PODSTAWIENIA
+C /UNIWERSALNY,ZMIENNA -MOZE BYC PRZEZ KROPKE-,ELEMTABLICY,TABL.STATYCZNA/.
+C WYROZNIA PRZYPADEK PODSTAWIENIA STALEJ REPREZENTOWANEJ PRZEZ ZERA.
+C
+C OBNIZA STOS , USTAWIA LSTLSE.
+C
+C
+C ##### OUTPUT CODE : 150 , 170 .
+C
+C
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+CCCCCCCCCCCCCCCCCCCCC
+ INTEGER TYPL,TYPR
+C TYPL,TYPR - ATS-Y TYPOW LEWEJ,PRAWEJ STRONY /DLA KONTROLI DYNAMICZNEJ/
+ INTEGER VALUE,J,LSE
+C VALUE=ATS PRAWEJ STRONY LUB 0,GDY TO STALA REPREZENTOWANA PRZEZ ZERA
+C LSE=KOLEJNA LEWA STRONA
+C
+C............................................
+ CALL SVALUE
+C JESLI BRAK LEWYCH STRON LUB CZUBEK UNIWERSALNY-OBNIZ STOS
+ IF(STACK(VALTOP).EQ.0 .OR. LSTLSE.LE.LSTFOR)GO TO 1000
+C CZUBEK NIE JEST UNIWERSALNY,SA LEWE STRONY.
+C
+C.....OBEJRZYJ PRAWA STRONE PODSTAWIENIA
+ TYPR=STACK(VALTOP-5)
+ TYPL=0
+ VALUE=SVATS(VALTOP)
+C
+C................ KONIEC PRZYGOTOWAN. WYKONAJ W PETLI PODSTAWIENIE.
+C
+ 400 LSE=VLPREV
+C
+C....................POCZATEK PETLI DLA KOLEJNYCH LEWYCH STRON
+C LSE WSKAZUJE KOLEJNA LEWA STRONE
+ 500 IF(STACK(LSE).EQ.0)GO TO 900
+C
+C ZBADAJ POPRAWNOSC PODSTAWIENIA
+ TLDIM=STACK(LSE-3)
+ TLBAS=STACK(LSE-4)
+ OBJL=STACK(LSE-6)
+ IDL=STACK(LSE-1)
+ TRDIM=STACK(VALTOP-3)
+ TRBAS=STACK(VALTOP-4)
+ OBJR=STACK(VALTOP-6)
+ J=1+MSUBST(1)
+C KONTROLA DYNAMICZNA?
+ IF(J.GE.4 .AND. OPTTYP)GO TO 800
+C KONWERSJA LUB KONTROLA DYNAMICZNA
+ GO TO (800,610,620,630,640,650,660),J
+C
+C.....INTEGER:=REAL
+ 610 CALL SVINT(VALTOP)
+ VALUE=STACK(VALTOP-2)
+C JESLI STALA - WSTAW DO TABLICY SYMBOLI
+ IF(STACK(VALTOP).EQ.1)VALUE=SCONST(VALUE)
+ GO TO 800
+C
+C.....REAL:=INTEGER
+ 620 CALL SVREAL(VALTOP)
+ VALUE=STACK(VALTOP-2)
+C JESLI STALA - WSTAW DO TABLICY SYMBOLI
+ IF(STACK(VALTOP).EQ.1)VALUE=SCREAL(VALUE)
+ GO TO 800
+C
+C.....OBIE STRONY ZNANEGO TYPU
+ 630 CALL QUADR3(150,VALUE,STACK(LSE-4))
+ GO TO 800
+C
+C.....TYP LEWEJ FORMALNY,PRAWEJ ZNANY
+ 640 IF(TYPR.EQ.0)TYPR=STYPST(VALTOP)
+ GO TO 660
+C
+C.....TYP LEWEJ ZNANY,PRAWEJ FORMALNY
+ 650 TYPL=STYPST(LSE)
+ GO TO 700
+C
+C.....TYPY OBYDWU STRON FORMALNE
+ 660 TYPL=STYPFT(LSE)
+ GO TO 700
+C
+C
+C..........KONTROLA DYNAMICZNA: TYPL,TYPR - TYPY LEWEJ,PRAWEJ STRONY
+ 700 CALL QUADR4(170,TYPL,VALUE,TYPR)
+C
+C.....WPISZ WARTOSC
+C
+ 800 CALL SSTORE(LSE,VALUE)
+C....................ZAKONCZENIE PETLI:
+C CZY JEST KOLEJNE LSE?
+ 900 J=STACK(LSE)
+ LSE=LSE-STCKAP(J)
+ IF(LSE.GT.LSTFOR)GO TO 500
+C.................... OBNIZANIE STOSU
+ 1000 CONTINUE
+ 1020 CALL SPOP
+ IF(VALTOP.GT.LSTFOR)GO TO 1020
+ LSTLSE=0
+ RETURN
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE SPARAM
+C-----------------------------------------------------------------------------
+C
+C WERSJA 1982.09.16
+C
+C OBSLUGUJE TRANSMISJE I KONTROLE PARAMETRU AKTUALNEGO.
+C NA CZUBKU STOSU JEST PARAMETR AKTUALNY, PONIZEJ WOLANA FUNKCJA,
+C PROCEDURA,KLASA,REKORD,BLOK PREFIKSOWANY.
+C PO OBSLUZENIU PARAMETRU ZDEJMUJE GO ZE STOSU.
+C NIE WOLA SNEXT.
+C
+C UZYWANA ROWNIEZ DLA PROCEDUR I FUNKCJI STANDARDOWYCH.
+C / TYLKO PARAMETRY INPUT, OUTPUT, IN-OUT / .
+C
+C
+C KOLEJNOSC OBSLUGI PARAMETRU :
+C 1) WOLA MPKIND OKRESLAJACE RODZAJ PARAMETRU :
+C 0 - UNIWERSALNY
+C 1 - INPUT
+C 2 - OUTPUT
+C 3 - TYPE
+C 4 - FUNKCJA
+C 5 - PROCEDURA
+C 6 - IN-OUT
+C I PRZYPISUJE PARAM ADRES OPISU PAR.FORMALNEGO W IPMEM
+C
+C 2) JESLI PAR.FORMALNY JEST UNIWERSALNY LUB PAR.AKTUALNY JEST
+C UNIWERSALNY LUB NIEWLASCIWEGO RODZAJU, A PAR.FORM. <> "TYPE" -
+C NIE ROBI NIC /POZA SYGNALIZACJA BLEDU/
+C
+C 3) DLA PAR. INPUT : WOLA MPARIO /BADA ZGODNOSC TYPOW/ ,GENERUJE KOD
+C EWENT. KONWERSJI LUB KONTROLI DYNAMICZNEJ I WPISUJE WARTOSC PAR.
+C AKTUALNEGO DO GENEROWANEGO POLA DANYCH /DLA STALYCH REPREZENTO-
+C WANYCH PRZEZ ZERA NIE WPISUJE NICZEGO/.
+C DLA PROCEDURY,FUNKCJI STANDARDOWEJ NIE WPISUJE WARTOSCI
+C PARAMETRU, LECZ ZAMIENIA NA STOSIE PARAMETR I PROCEDURE
+C /FUNKCJE/ MIEJSCAMI, DZIEKI CZEMU PROCEDURA JEST NA STOSIE
+C NAD WSZYTKIMI JUZ PRZETWORZONYMI PARAMETRAMI INPUT.
+C
+C
+C DLA PAR. OUTPUT : WOLA MPARIO,ZABEZPIECZA ADRES ZMIENNEJ /ADR.
+C TABLICY I INDEKS,ADR. PRZED KROPKA/ I TYP FORMALNY,WPISUJE
+C OPIS PARAMETRU NA STOS I ZWIEKSZA LICZNIK PARAMETROW OUTPUT
+C /JESLI BRAK MIEJSCA NA OPIS - NIE ZWIEKSZA/
+C
+C DLA PAR. TYPE : WOLA MPARTP / ZAWSZE! ,DLA PAR.AKT. NIEPOPRAWNEGO
+C LUB UNIWERSALNEGO PODAJE NRUNIV/ I WPISUJE TYP DO POLA DANYCH
+C
+C DLA PAR. FUNCTION,PROCEDURE : WOLA MPARPF ,
+C USTAWIA KIND , WOLA SPRFLD /GENERUJACA PROTOTYP
+C WRAZ Z OTOCZENIEM/
+C WPISUJE PROTOTYP I OTOCZENIE PAR.AKTUALNEGO DO POLA DANYCH,
+C EW. GENERUJE DYNAMICZNA KONTROLE ZGODNOSCI NAGLOWKOW.
+C
+C DLA PAR. IN-OUT : NAJPIERW OBSLUGUJE GO JAK PAR. OUTPUT,
+C A NASTEPNIE JAK PAR.INPUT
+C
+C UZYWA: PHADR , NRPAR
+C
+C
+C # OUTPUT CODE : 43 , 52 , 144 , 150 , 161 , 162 , 163 ,
+C 164 , 165 , 166 , 170 .
+C
+C ##### DETECTED ERROR(S) : 470 , 471 , 472 , 473 , 474 , 478 , 550 .
+C
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+CCCCCCCCCCCCCCCCCCCCCC
+ INTEGER PARAM,APET,CONTRL,ATS,LNRPAR,PARKIND,ELEM
+C PARAM = ADRES W IPMEM OPISU PARAMETRU FORMALNEGO
+C APET = LICZBA SLOW NA PARAMETR FORMALNY
+C CONTRL = INFORMACJA O KONWERSJI LUB KONTROLI DYNAMICZNEJ
+C ATS = ATS WARTOSCI PAR. LUB ADR.FIZYCZNY DLA NIEZNANEGO OFFSETU
+C PARKIND = RODZAJ PAR.FORMALNEGO, 1..7 ,=MPKIND( )+1
+C ELEM = RODZAJ ELEMNTU Z CZUBKA STOSU
+C
+ LOGICAL DCONTR
+ DATA SPARAHEX /x'0800'/
+C =.TRUE. JESLI KONIECZNA DYNAMICZNA KONTROLA NAGLOWKOW PROC.,FUNC.
+C
+C...............
+ DCONTR=.FALSE.
+C RODZAJ PAR.AKTUALNEGO ?
+ ELEM=STACK(VALTOP)
+C RODZAJ PAR.FORMALNEGO ?
+ PARKIND=MPKIND(PARAM)+1
+C JESLI PAR.AKTUALNY UNIWERSALNY-POMIN
+ IF(ELEM.EQ.0.AND. PARKIND.NE.4)GO TO 9905
+ GO TO(9905,1000,2000,3000,4000,4000,2000),PARKIND
+C
+C
+C
+C- - - - - - - - - - PAR. I N - O U T - - - - - - -
+C
+C ZMIEN KWALIFIKACJE NA INPUT /KOD ODCZYTUJACY WARTOSC JUZ WYGENEROWANY/
+C
+ 990 PARKIND=2
+C
+C
+C-------------------- PAR. I N P U T ------------
+C CZY POPRAWNY PAR. AKTUALNY?
+ 1000 IF(ELEM.LT.6 .OR. ELEM.EQ.12)GO TO 1003
+C NIEPOPRAWNY PAR. AKTUALNY
+ PARAM=470
+ GO TO 9600
+ 1003 LNRPAR=NRPAR
+C PRZECHOWAJ NUMER PARAMETRU: NA CZUBKU MOZE BYC FUNKCJA BEZPARAMETROWA,
+C ODCZYT JEJ WARTOSCI MOZE ZNISZCZYC NRPAR
+ CALL SVALUE
+ NRPAR=LNRPAR
+C SPRAWDZ ZGODNOSC TYPOW
+ CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
+ X STACK(VALTOP-6))
+ APET=SAPET(IPMEM(PARAM-4),IPMEM(PARAM-3))
+ IF(CONTRL.EQ.1)CALL SVINT(VALTOP)
+ IF(CONTRL.EQ.2)CALL SVREAL(VALTOP)
+ ATS=STACK(VALTOP-2)
+C ATS WARTOSCI PARAMETRU
+C.....FUNKCJA,PROCEDURA STANDARDOWA ?
+ IF(STACK(VLPREV-4).LT.LPMSYS)GO TO 1800
+C NIE.
+ CALL SPHADR(VLPREV)
+C CZY PAR.AKTUALNY JEST STALA?
+ IF(ELEM.EQ.1)GO TO (1007,1008,9905,9905),APET
+C
+C PARAMETR NIE JEST STALA
+ APET=APETYT(APET)
+ GO TO 1050
+C
+C
+C.....PAR.AKTUALNY JEST STALA. JESLI REPREZENTOWANA PRZEZ ZERA - NIC NIE
+C ROB /INICJALIZACJA POLA WPISALA ZERA/
+C ... APETYT 1 ( INTEGER,BOOLEAN,CHAR,STRING )
+ 1007 IF(ATS.EQ.0)GO TO 9905
+C WSTAW STALA INTEGER,SKOCZ DO WPISANIA WARTOSCI PARAMETRU
+ ATS=SCONST(ATS)
+ GO TO 9750
+C ... APETYT 2 ( REAL - TYP FORMALNY TU NIE WYSTAPI )
+cdsw&bc 1008 IF(STALER(ATS).EQ. 0.0)GO TO 9905
+ 1008 continue
+c
+C WSTAW STALA REAL, SKOCZ DO WPISANIA WARTOSCI
+ ATS=SCREAL(ATS)
+ GO TO 9750
+C
+C
+C.....JESLI NIEPOTRZEBNA KONTROLA DYNAMICZNA - WPISZ WARTOSC
+ 1050 IF(CONTRL.LT.3 .OR. OPTTYP)GO TO 9750
+ CONTRL=CONTRL-2
+C
+ IDR=STACK(VALTOP-5)
+C IDR = ZMODYFIKOWANY TYP FORMALNY PARAMETRU AKTUALNEGO LUB ZERO
+C
+C CZY ZNANY OFFSET? /NIE,JESLI TO VIRTUAL LUB PARAMETR/
+ IF(STACK(VLPREV-3).GE.16384)GO TO 1500
+C
+C
+C.....ZNANY OFFSET PARAMETRU.
+C
+ GO TO(1100,1200,1300,1400),CONTRL
+C.....KONTROLA DYNAMICZNA, OBA TYPY ZNANE
+ 1100 CALL QUADR3(150,ATS,IPMEM(PARAM-3))
+ GO TO 9800
+C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST FORMALNY,AKTUALNEGO ZNANY
+ 1200 IDR=STYPST(VALTOP)
+ GO TO 1400
+C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST ZNANY,AKTUALNEGO FORMALNY
+ 1300 N=SPARST(PARAM)
+ GO TO 1450
+C.....KONTROLA DYN.,TYPY PAR.FORMALNEGO I AKTUALNEGO SA FORMALNE
+cdsw 1400 N=SPARFT(PARAM)
+cdsw -----------------------
+ 1400 n = sparft(param,1)
+cdsw ------------------------
+ 1450 CALL QUADR4(170,N,ATS,IDR)
+ GO TO 9800
+C
+C
+C..............NIEZNANY OFFSET PARAMETRU.
+C - TYP PAR.FORMALNEGO TRZEBA ODCZYTAC
+C IDL,IDR = TYPY PAR.FORMALNEGO I AKTUALNEGO
+ 1500 CALL SPHADR(VLPREV)
+ IF(CONTRL.LT.3)IDR=STYPST(VALTOP)
+ CALL QUADR4(170,SFPRST(NRPAR),ATS,IDR)
+ GO TO 9700
+C
+C.........PARAMETR INPUT PROCEDURY, FUNKCJI STANDARDOWEJ.
+C ZAMIEN MIEJSCAMI OPISY PARAMETRU I FUNKCJI, TAK , BY FUNKCJA
+C BYLA NAD SWOIMI ARGUMENTAMI. / OBA OPISY ZAJMUJA PO 8 SLOW /
+C
+ 1800 DO 1810 K=0,7
+ IDR=VALTOP-K
+ IDL=VLPREV-K
+ N=STACK(IDR)
+ STACK(IDR)=STACK(IDL)
+ STACK(IDL)=N
+ 1810 CONTINUE
+C NA CZUBKU JEST FUNKCJA,PROCEDURA STANDARDOWA
+C ZWIEKSZ LICZNIK PARAMETROW INPUT /SLOWO -2/
+ STACK(VALTOP-2)=STACK(VALTOP-2)+1
+C WPISZ NUMER PARAMETRU DO SLOWA -1
+ STACK(VLPREV-1)=NRPAR
+ RETURN
+C
+C
+C-------------------- PAR. O U T P U T ---------------
+C
+C CZY PAR. AKTUALNY TO LSE?
+ 2000 IF(ELEM.GT.2 .AND. ELEM.LT.6)GO TO 2005
+C NIEPOPRAWNY PARAMETR /AKTUALNY/ OUTPUT
+ PARAM=471
+ GO TO 9600
+C O.K. SPRAWDZ ZGODNOSC TYPOW
+ 2005 CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
+ X STACK(VALTOP-6))
+C ZABEZPIECZ ADRES ZMIENNEJ
+ CALL SAVEVAR(VALTOP)
+C.....WPISZ OPIS PARAMETRU AKTUALNEGO. CZY JEST MIEJSCE?
+ IF(FSTOUT-VALTOP.GE.11)GO TO 2110
+C BRAK MIEJSCA NA STOSIE NA DODATKOWE INFORMACJE O PARAMETRZE.
+ PARAM=550
+ GO TO 9600
+C O.K. JEST MIEJSCE
+ 2110 CONTINUE
+C ZWIEKSZ LICZNIK PARAMETROW OUTPUT
+ STACK(VLPREV-3)=STACK(VLPREV-3)+1
+C POSTAC OPISU PARAMETRU OUTPUT:
+C OPIS ZAJMUJE 11 SLOW, OZNACZONYCH -9,..,0,+1
+C SLOWA -9..0 ZAWIERAJA PRZEPISANY PAR.AKTUALNY
+C /DLA ZMIENNEJ I ELEM.TABLICY SLOWA -9,-8 POZOSTAJA
+C NIEWYKORZYSTANE/
+C SLOWO -1 ZAMIAST NAZWY ZAWIERA ADRES W IPMEM OPISU PARAMETRU
+C FORMALNEGO
+C SLOWO +1 = NUMER PARAMETRU /NRPAR/
+C SLOWO 0 W BITACH 9-11 INFORMACJE O KONTROLI /MPARIO(..)/
+C
+C WPISZ NUMER PARAMETRU
+ STACK(FSTOUT-1)=NRPAR
+C WPISZ RODZAJ ELEMENTU Z INFORMACJA O KONTROLI W BITACH 9-11
+ STACK(FSTOUT-2)=ELEM+CONTRL*16
+C WPISZ ADRES OPISU PAR.FORMALNEGO
+ STACK(FSTOUT-3)=PARAM
+C PRZEPISZ POZOSTALE 8 SLOW /BYC MOZE OSTATNIE 2 TO SMIECIE/
+C APET,CONTRL = DOLNY,GORNY INDEKS
+ APET=VALTOP-2
+ CONTRL=FSTOUT-4
+ 2115 STACK(CONTRL)=STACK(APET)
+ APET=APET-1
+ CONTRL=CONTRL-1
+ IF(CONTRL.GT.FSTOUT-12)GO TO 2115
+C SLOWA VALTOP-0,..,VALTOP-9 PRZEPISANE NA MIEJSCA FSTOUT-2,..,FSTOUT-11.
+C
+ FSTOUT=FSTOUT-11
+ GO TO 9905
+
+C
+C-------------------- PAR. T Y P E ---------------------
+C
+C CZY PAR.AKTUALNY TO NAZWA TYPU,REKORD,KLASA?
+ 3000 IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 3800
+C O.K.
+ CALL MPARTP(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-6),
+ X STACK(VALTOP-1))
+C POBIERZ TYP
+ ATS=STACK(VALTOP-2)
+C =0 : KLASA,REKORD,TYP PIERWOTNY
+C >0 : ATS WARTOSCI PAR.TYPE LUB PARAMETRU TYPE
+ IF(ATS.EQ.0)ATS=STYPST(VALTOP)
+ APET=2
+ GO TO 9750
+C
+C.....UNIWERSALNY LUB NIEPOPRAWNY PARAMETR TYPE
+ 3800 CALL MPARTP(0,NRUNIV,0,STACK(VALTOP-1))
+ IF(ELEM.EQ.0)GO TO 9905
+ PARAM=472
+ GO TO 9600
+C
+C------------- PAR. F U N C T I O N , P R O C E D U R E ------
+C
+C CZY PAR.AKTUALNY JEST FUNKCJA LUB PROCEDURA?
+ 4000 IF(ELEM.EQ.11 .OR. ELEM.EQ.12)GO TO 4010
+C NIEPOPRAWNY PAR. AKTUALNY
+ PARAM=479-PARKIND
+C = 473 LUB 474
+ GO TO 9600
+C FUNKCJA LUB PROCEDURA.
+ 4010 APET=STACK(VALTOP-4)
+C = ADRES OPISU FUNKCJI,PROCEDURY
+C CZY PAR.AKTUALNY JEST FUNKCJA,PROCEDURA STANDARDOWA ?
+ IF(APET.GE.LPMSYS)GO TO 4020
+C NIESTETY, TAK.
+ PARAM=478
+ GO TO 9600
+ 4020 CALL MPARPF(APET,STACK(VALTOP-1),STACK(VALTOP-6),DCONTR)
+C JAKIEGO RODZAJU?
+ KIND=0
+C WEZ ZEROWE SLOWO OPISU
+ APET=IPMEM(APET)
+C VIRTUALNA,JESLI BIT 4 = 1
+ IF(IAND(APET,SPARAHEX).NE.0)KIND=1
+C LUB FORMALNA , JESLI BITY 8..11 = 2 LUB 3. WEZ TE BITY
+ APET=IAND(ISHFT(APET,-4),15)
+ IF(APET.EQ.2 .OR. APET.EQ.3)KIND=2
+C WYLICZ NUMER PROTOTYPU I OJCA SYNTAKTYCZNEGO PARAMETRU
+ ATS=SPRFLD(.TRUE.)
+ APET=3
+ GO TO 9750
+C
+C
+C
+C-------------------------------
+C
+C
+C.....WSPOLNA SYGNALIZACJA BLEDU.
+C PARAM= NUMER BLEDU
+ 9600 CALL SERROR(PARAM)
+ GO TO 9905
+C
+C
+C.....WPISANIE WARTOSCI PARAMETRU Z NIEZNANYM OFFSETEM
+ 9700 CONTRL=TSTEMP(1)
+ CALL SPHADR(VLPREV)
+C WEZ ADRES FIZYCZNY PARAMETRU
+ CALL QUADR4(52,CONTRL,PHADR,NRPAR)
+C WPISZ WARTOSC POD TEN ADRES
+ CALL QUADR3(160+APET,CONTRL,ATS)
+ GO TO 9900
+C
+C.....WPISANIE WARTOSCI. CZY ZNANY OFFSET?
+ 9750 IF(STACK(VLPREV-3).GE.16384)GO TO 9700
+C
+C.....WPISANIE WARTOSCI PARAMETRU ZE ZNANYM OFFSETEM
+ 9800 CONTINUE
+ CALL SPHADR(VLPREV)
+ CALL QUADR4(163+APET,PHADR,ATS,PARAM)
+C WPISZ APET-SLOW DO POLA WSKAZANEGO PRZEZ ADRES FIZYCZNY PHADR
+C
+C
+C.....JUZ PO WSZYSTKIM-LUB PARAMETR UNIWERSALNY.
+C CZY DYNAMICZNA KONTROLA NAGLOWKOW?
+ 9900 IF(.NOT.DCONTR)GO TO 9905
+C TAK. ODTWORZ PELNY ADRES VIRTUALNY Z AH
+ APET=TSTEMP(4)
+ CALL QUADR3(43,APET,STACK(VLPREV-2))
+ STACK(VLPREV-2)=APET
+ CALL QUADR3(144,APET,NRPAR)
+ PHADR=0
+C
+C
+C ... JESLI TO IN-OUT ,TO POTRAKTUJ GO TERAZ JAK INPUT
+ 9905 IF(PARKIND.EQ.7)GO TO 990
+ CALL SPOP
+C
+ RETURN
+ END
+ SUBROUTINE SVALU2
+C-----------------------------------------------------------------------------
+cdsw procedura podzielona na svalue i svalue2 - entry usuniete
+C
+C ENTRY SVALUE
+C
+C
+C SPRAWDZA,CZY ELEMENT Z CZUBKA STOSU /SVALUE/ LUB PONIZEJ /SVALU2/
+C REPREZENTUJE WARTOSC I WYLICZA TE WARTOSC.
+C "UNIWERSALNY","STALA","WARTOSC" ZOSTAWIA BEZ ZMIAN.
+C "ZMIENNA","ELEMTABLICY","TABLICA STATYCZNA","FUNKCJA"/BEZPARAMETROWA/
+C ZASTEPUJE PRZEZ "WARTOSC" I JESLI SA TYPU FORMALNEGO TO POBIERA
+C TEN TYP. NIE MODYFIKUJE GO O LICZBE ARRAY-OF.
+C POZOSTALE ZASTEPUJE PRZEZ "UNIWERSALNY" SYGNALIZUJAC BLAD.
+C
+C WEJSCIE SVALUE - DLA CZUBKA STOSU
+C WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
+C
+C ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
+C
+C ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
+C
+#include "stos.h"
+#include "blank.h"
+CCCCCCCCCCCCCCCCCCCC
+ INTEGER ER(8)
+C NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
+C
+ INTEGER ATS,ELEM,APET
+ DATA ER/452,451,451,0,450,0,453,454/
+C
+ K=VLPREV
+ 100 ELEM=STACK(K)-2
+C JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
+ IF(ELEM.LE.0)RETURN
+C
+C JESLI TYPU FORMALNEGO - WEZ TEN TYP
+ IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
+C
+C ZMIENNA PROSTA?
+ IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
+ IF(ELEM.GT.3)GO TO 600
+C
+C WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
+ APET=SAPET2(K)
+
+#if WSIZE == 4
+cvax changed because of real appettite = 1
+ dswap = apet
+ if (dswap .eq. 2) dswap = 1
+ ats = tstemp(dswap)
+#else
+ ATS=TSTEMP(APET)
+#endif
+
+ APET=APETYT(APET)
+ GO TO (300,400,500),ELEM
+C.....ZMIENNA PRZEZ KROPKE. ODCZYTAJ APET-SLOW.
+ 300 CALL QUADR4(83+APET,ATS,SMEMBER(K),STACK(K-2))
+C ZASTAP PRZEZ WARTOSC
+ 340 STACK(K-2)=ATS
+ 350 STACK(K)=2
+ RETURN
+C
+C.....ELEM. TABLICY
+ 400 CALL QUADR3(60+APET,ATS,SARRAY(K))
+ GO TO 340
+C
+C.....TABLICA STATYCZNA
+ 500 CONTINUE
+C B R A K
+C...........
+C JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
+ 600 IF(ELEM.NE.10)GO TO 3000
+C FUNKCJA. /BEZPARAMETROWA/
+ CALL SCALLB
+C I TO WSZYSTKO.
+ RETURN
+C
+C.....OBSLUGA BLEDOW
+ 3000 ELEM=ER(ELEM-4)
+ CALL SERRO2(ELEM,K)
+C ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
+ STACK(K)=0
+ RETURN
+ END
+ SUBROUTINE SVALUE
+C-----------------------------------------------------------------------------
+cdsw procedura podzielona na svalue i svalue2 - entry usuniete
+C
+C ENTRY SVALUE
+C
+C
+C SPRAWDZA,CZY ELEMENT Z CZUBKA STOSU /SVALUE/ LUB PONIZEJ /SVALU2/
+C REPREZENTUJE WARTOSC I WYLICZA TE WARTOSC.
+C "UNIWERSALNY","STALA","WARTOSC" ZOSTAWIA BEZ ZMIAN.
+C "ZMIENNA","ELEMTABLICY","TABLICA STATYCZNA","FUNKCJA"/BEZPARAMETROWA/
+C ZASTEPUJE PRZEZ "WARTOSC" I JESLI SA TYPU FORMALNEGO TO POBIERA
+C TEN TYP. NIE MODYFIKUJE GO O LICZBE ARRAY-OF.
+C POZOSTALE ZASTEPUJE PRZEZ "UNIWERSALNY" SYGNALIZUJAC BLAD.
+C
+C WEJSCIE SVALUE - DLA CZUBKA STOSU
+C WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
+C
+C ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
+C
+C ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
+C
+#include "stos.h"
+#include "blank.h"
+CCCCCCCCCCCCCCCCCCCC
+ INTEGER ER(8)
+C NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
+C
+ INTEGER ATS,ELEM,APET
+ DATA ER/452,451,451,0,450,0,453,454/
+ K=VALTOP
+ 100 ELEM=STACK(K)-2
+C JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
+ IF(ELEM.LE.0)RETURN
+C
+C JESLI TYPU FORMALNEGO - WEZ TEN TYP
+ IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
+C
+C ZMIENNA PROSTA?
+ IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
+ IF(ELEM.GT.3)GO TO 600
+C
+C WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
+ APET=SAPET2(K)
+
+#if WSIZE == 4
+cvax changed with real appetite = 1
+ dswap = apet
+ if (dswap .eq. 2) dswap = 1
+ ats = tstemp(dswap)
+#else
+ ATS=TSTEMP(APET)
+#endif
+
+ APET=APETYT(APET)
+ GO TO (300,400,500),ELEM
+C.....ZMIENNA PRZEZ KROPKE. ODCZYTAJ APET-SLOW.
+ 300 CALL QUADR4(83+APET,ATS,SMEMBER(K),STACK(K-2))
+C ZASTAP PRZEZ WARTOSC
+ 340 STACK(K-2)=ATS
+ 350 STACK(K)=2
+ RETURN
+C
+C.....ELEM. TABLICY
+ 400 CALL QUADR3(60+APET,ATS,SARRAY(K))
+ GO TO 340
+C
+C.....TABLICA STATYCZNA
+ 500 CONTINUE
+C B R A K
+C...........
+C JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
+ 600 IF(ELEM.NE.10)GO TO 3000
+C FUNKCJA. /BEZPARAMETROWA/
+ CALL SCALLB
+C I TO WSZYSTKO.
+ RETURN
+C
+C.....OBSLUGA BLEDOW
+ 3000 ELEM=ER(ELEM-4)
+ CALL SERRO2(ELEM,K)
+C ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
+ STACK(K)=0
+ RETURN
+ END
+ SUBROUTINE SVINT(ELEM)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA. ZASTEPUJE ELEMENT Z MIEJSCA ELEM STOSU /STALA,
+C WARTOSC,ZMIENNA/ TYPU REAL PRZEZ STALA LUB WARTOSC TYPU INTEGER.
+C GENERUJE KOD KONWERSJI.
+C W PRZYPADKU STALEJ REAL O WARTOSCI WYKRACZAJACEJ POZA ZAKRES LICZB
+C CALKOWITYCH SYGNALIZUJE ERROR 408 I ZASTEPUJE PRZEZ STALA INTEGER
+C O TYM SAMYM ZNAKU I NAJWIEKSZYM MOZLIWYM MODULE.
+C
+C ##### OUTPUT CODE : 58 .
+C
+C ##### DETECTED ERROR(S) : 408 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ REAL X
+ real y
+ integer*2 m(2)
+ equivalence (y, m(1))
+C
+#if WSIZE == 4
+ DATA MAXINTEGER,MININTEGER / x'7FFFFFFF', x'80000000' /
+#else
+ DATA MAXINTEGER,MININTEGER / x'7FFF', -x'7FFF' /
+#endif
+C
+C
+C.....
+ STACK(ELEM-4)=NRINT
+C CZY STALA?
+ IF(STACK(ELEM).NE.1)GO TO 100
+C TAK
+ N=STACK(ELEM-2)
+C SPRAWDZ WARTOSC STALEJ
+#if WSIZE == 4
+ X=STALER(N)
+#else
+ n1 = n*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+ x = y
+#endif
+c
+ IF(X.LT.FLOAT(MININTEGER) .OR. X.GT.FLOAT(MAXINTEGER))GO TO 200
+CJF STACK(ELEM-2)=IFIX(X)
+cdsw STACK(ELEM-2)= IIDINT(X)
+ stack(elem-2) = ifix(x)
+ RETURN
+C WARTOSC LUB ZMIENNA; GENERUJ KONWERSJE
+ 100 N=TSTEMP(1)
+ CALL QUADR3(58,N,STACK(ELEM-2))
+ STACK(ELEM-2)=N
+ STACK(ELEM)=2
+ RETURN
+C STALA REAL O WARTOSCI POZA ZAKRESEM LICZB CALKOWITYCH
+ 200 CALL SERRO2(408,ELEM)
+C ZASTAP PRZEZ NAJWIEKSZA LICZBE CALKOWITA
+ N=MAXINTEGER
+ IF(X.LT.0.0)N=MININTEGER
+ STACK(ELEM-2)=N
+ RETURN
+ END
+ SUBROUTINE SVREAL(ELEM)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA. ZASTEPUJE ELEMENT /STALA,WARTOSC,ZMIENNA/ Z MIEJSCA
+C ELEM STOSU TYPU INTEGER PRZEZ STALA LUB WARTOSC TYPU REAL.
+C
+C ##### OUTPUT CODE : 59 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ STACK(ELEM-4)=NRRE
+C CZY TO STALA?
+ IF(STACK(ELEM).NE.1)GO TO 100
+C TAK
+ STACK(ELEM-2)=CREAL(FLOAT(STACK(ELEM-2)))
+ RETURN
+C WARTOSC,ZMIENNA; GENERUJ KONWERSJE
+#if WSIZE == 4
+100 n = tstemp(1)
+#else
+100 n = tstemp(2)
+#endif
+ CALL QUADR3(59,N,STACK(ELEM-2))
+ STACK(ELEM-2)=N
+ STACK(ELEM)=2
+ RETURN
+ END
+ SUBROUTINE SPUSH(ELEM)
+C------------------------------------------------------------------------
+C
+C WSTAWIA NA STOS ELEMENT TYPU ELEM. USTAWIA VALTOP,VLPREV.
+C
+C PRZY PRZEPELNIENIU STOSU PRZERYWA KOMPILACJE !!!
+C
+C ( NA SKUTEK BRAKU NIELOKALNYCH SKOKOW NIE JEST MOZLIWY )
+C ( SKOK DO ETYKIETY 2000 W SPASS2 I KOMPILACJA KOLEJNYCH )
+C ( MODULOW. )
+C
+C
+C ##### DETECTED ERROR(S) : 550. /PRZEPELNIENIE STOSU /
+C
+C
+#include "stos.h"
+#include "blank.h"
+ VLPREV=VALTOP
+ VALTOP=VALTOP+STCKAP(ELEM)
+ IF(VALTOP.GE.FSTOUT)GO TO 100
+ STACK(VALTOP)=ELEM
+ RETURN
+C.....PRZEPELNIENIE STOSU
+ 100 CALL MERR(550,0)
+C GO TO 2000 CHANGED TO COMMENT DUE TO A.I.L./P.G. 15.05.84
+ call ffexit
+C FOR STACK BEING OVERLOADED STOP THE COMPILATION
+C ' FATAL ERROR '
+ END
+ SUBROUTINE SPOP
+C--------------------------------------------------------------------------
+C
+C ZDEJMUJE 1 ELEMENT Z CZUBKA STOSU. USTAWIA VALTOP, VLPREV.
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/SUMMARY/FREE
+C
+C
+ N=FSTOUT-VALTOP-1
+ IF(N.LT.FREE)FREE=N
+C
+ VALTOP=VLPREV
+ IF(VALTOP.LT.LSTSAF)LSTSAF=VALTOP
+ VLPREV=STACK(VALTOP)
+ VLPREV=STCKAP(VLPREV)
+C =APETYT NOWEGO CZUBKA STOSU
+ VLPREV=VALTOP-VLPREV
+ RETURN
+ END
+ INTEGER FUNCTION SCONST(N)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA.
+C ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA O WARTOSCI N.
+C
+C ##### OUTPUT CODE : 199 .
+C
+C
+#include "stos.h"
+C
+C.....
+ LSTEMP=LSTEMP-3
+ SCONST=LSTEMP
+ CALL QUADR3(199,SCONST,N)
+ IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
+ RETURN
+ END
+ INTEGER FUNCTION CREAL(X)
+C----------------------------------------------------------------
+C
+C ZWRACA ADRES STALEJ X TYPU REAL W TABLICY STALYCH
+C
+C ##### DETECTED ERROR(S) : 554 .
+C
+ IMPLICIT INTEGER (A-Z)
+#include "blank.h"
+C
+C
+ REAL X
+
+#if WSIZE == 4
+cvax data realsize/1/
+cvax the size of real numbers on vax is 4 bytes ( = the size of integer)
+ i = lpmem+1
+100 if (staler(i) .eq.x) goto 200
+ i = i+1
+cail if (i .lt. irecn) goto 100
+ if (i .le. irecn) goto 100
+Cail constant not found, i=irenc+1, append if enough room
+ if (irecn+1 .gt. ipmem(lmem)) goto 300
+ irecn = irecn + 1
+ staler(i) = x
+200 creal = i
+#else
+ real y
+ integer*2 m(2)
+ equivalence (y, m(1))
+ INTEGER REALSIZE
+ DATA REALSIZE/2/
+ y = x
+ i = lpmem + 1
+ 100 if (ipmem(i) .eq. m(1) .and. ipmem(i+1) .eq. m(2)) goto 200
+ i = i + 2
+ if (i .lt. irecn) goto 100
+ if (irecn + 2 .gt. ipmem(lmem)) goto 300
+ irecn = irecn + 2
+ ipmem(i ) = m(1)
+ ipmem(i+1) = m(2)
+ 200 creal = (i+1) / 2
+ n1 = creal*2-1
+ m(1) = ipmem(n1)
+ m(2) = ipmem(n1+1)
+#endif
+
+cdsw&bc C = SIZE OF REAL VALUE (NUMBER OF WORDS)
+cdsw&bc C LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
+cdsw&bc C IRECN=INDEKS OSTATNIEGO SLOWA ZAJETEGO PRZEZ STALE REAL
+cdsw&bc N=(IRECN / REALSIZE)+1
+cdsw&bc C = INDEKS PIERWSZEGO WOLNEGO MIEJSCA W STALER
+cdsw&bc CREAL=(LPMEM+REALSIZE-1)/REALSIZE+1
+cdsw&bc C = INDEKS PIERWSZEJ STALEJ W STALER
+cdsw&bc C USTAW WARTOWNIKA
+cdsw&bc STALER(N)=X
+cdsw&bc 100 IF(STALER(CREAL).EQ.X)GO TO 200
+cdsw&bc CREAL=CREAL+1
+cdsw&bc GO TO 100
+cdsw&bc C JEST?
+cdsw&bc 200 IF(CREAL.LT.N)RETURN
+cdsw&bc IF(IRECN+REALSIZE .GT. IPMEM(LMEM))GO TO 300
+cdsw&bc IRECN=IRECN+REALSIZE
+ RETURN
+ 300 CALL SERRO2(554,0)
+ RETURN
+ END
+ INTEGER FUNCTION SCREAL(N)
+C----------------------------------------------------------------------------
+
+C POMOCNICZA.
+C ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA REAL O NUMERZE N
+C
+C ##### OUTPUT CODE : 197 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+#if WSIZE == 4
+ data realsize /1/
+#else
+ data realsize /2/
+#endif
+
+C = SIZE OF REAL VALUE (NUMBER OF WORDS)
+C LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
+C.....
+ LSTEMP=LSTEMP-3
+ SCREAL=LSTEMP
+ K=(LPMEM+REALSIZE-1)/REALSIZE+1
+C K=INDEKS PIERWSZEJ STALEJ W STALER
+ K=REALSIZE*(N-K)
+C = OFFSET WZGLEDEM ETYKIETY "RECON" RUN-TIME-U.
+ CALL QUADR3(197,SCREAL,K)
+ IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
+ RETURN
+ END
+
+ INTEGER FUNCTION SWHAT(IND)
+C----------------------------------------------------------------------------
+C
+C
+C IND WSKAZUJE ZEROWE SLOWO OPISU ATRYBUTU /IND=MIDENT(NAZWA)/.
+C FUNKCJA ROZPOZNAJE RODZAJ ATRYBUTU I ZWRACA JAKO WYNIK :
+C 0 - "UNIWERSALNY"
+C 1 - "STALA"
+C 3 - "ZMIENNA"
+C 5 - "TABLICA STATYCZNA"
+C 7 - "TYP FORMALNY" / "NAZWA TYPU"/
+C 8 - "REKORD"
+C 9 - "KLASA"
+C 11 - "PROCEDURA"
+C 12 - "FUNKCJA"
+C 13 - "SYGNAL"
+C 14 - "OPERATOR"
+C
+C W PRZYPADKU NIEPOPRAWNEGO OPISU ZWRACA UNIWERSALNY.
+C.....
+ IMPLICIT INTEGER (A-Z)
+#include "blank.h"
+C
+C
+CCCCCCCCCCCCCCCCCCCCCCCCC
+ INTEGER TT(35),TT0(36)
+ EQUIVALENCE (TT0(2),TT(1))
+ DATA TT0/0,0,8,9,0,9,7,9,8*0,
+ X 3,3,3,1,3,14,13,13,4*0,
+ X 0,10,12,12,11,11,10,13/
+C = RODZAJ ATRYBUTU :
+C ELEMENTY 0..15 ODPOWIADAJA WARTOSCIOM 0..15 POLA "T"
+C " 16..27 " " 5..16 POLA "ZP"
+C " 28..35 " " 0..7 POLA "S"
+C
+C............
+ N=IPMEM(IND)
+C ... ODCZYTAJ POLE "T" , BITY 12..15
+ K=IAND(N,15)
+ IF(K.NE.1)GO TO 200
+C ... NIE TYP. POLE "ZP" , BITY 8..11
+ L=IAND(ISHFT(N,-4),15)
+ IF(L.GT.4)GO TO 150
+C ... PROCEDURA,FUNKCJA, POLE "S" , BITY 5..7
+ L=IAND(ISHFT(N,-8),7)+17
+ 150 K=L+11
+ 200 SWHAT=TT(K)
+ RETURN
+ END
+ SUBROUTINE SCALLB
+C-----------------------------------------
+C
+C WERSJA 1983.04.26
+C
+C POCZATEK WYWOLANIA. CZUBEK STOSU ZAWIERA REKORD,KLASE,FUNKCJE,
+C PROCEDURE,BLOK PREF,SYGNAL.
+C JESLI NA STOSIE JEST MODUL BEZ PELNEGO ADR.VIRTUALNEGO
+C /TYLKO ADR.POSREDNI , GDY LASTPR <> 0 / , TO ZASTEPUJE TEN ADRES
+C PRZEZ PELNY ADR.VIRTUALNY.
+C OTWIERA POLE DANYCH /PO WYZNACZENIU DYNAMICZNEGO PROTOTYPU WRAZ Z
+C OTOCZENIEM/ - O ILE NIE JEST TO PROCEDURA,FUNKCJA STANDARDOWA
+C PRZY BRAKU PARAMETROW FORMALNYCH / WB<>"(" / PRZECHODZI DO ZAKONCZENIA
+C WYWOLANIA /WOLA SCALLE/. UWAGA: DLA FUNKCJI BEZPARAMETROWEJ WOLA
+C SCALLE NAWET DLA WB="(".
+C
+C USTAWIA BITY 0-2 SLOWA -3 :
+C 000 = ZWYKLY,LOKALNY MODUL BEZ PREFIKSU,
+C 001 = NIELOKALNY LUB PREFIKSOWANY,ALE ZNANE OFFSETY,
+C 010 = NIEZNANE OFFSETY PARAMETROW /VIRTUAL LUB PARAMETR/
+C INFORMACJA TA JEST UZYWANA PRZEZ SPARAM,SCALLE .
+C
+C WOLANA PRZEZ SDPDA: DLA NAZWY LUB NAZWY PO KROPCE KLASY,REKORDU,
+C FUNKCJI,PROCEDURY,SYGNALU ORAZ DLA BLOKU PREF.
+C WOLANA PRZEZ SVALUE: GDY NAZWA LUB NAZWA PO KROPCE KLASY,REKORDU,FUNKCJI
+C WYSTAPILA PRZED "," LUB ")" .
+C
+C DLA FUNKCJI (NIE-STANDARDOWEJ) GASI FLREADY.
+C
+C ##### OUTPUT CODE : 1 , 3 , 4 , 5 , 43 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER ELEM,IND,OPKOD,ADR,PROT,BT
+cdsw DATA SCALBHX1,SCALBHX2 /Z2000, Z4000 /
+ data schx1, schx2 / x'2000', x'4000' /
+C RODZAJ ELEMENTU,ADRES PROTOTYPU W IPMEM
+C................
+ ELEM=STACK(VALTOP)
+ IND=STACK(VALTOP-4)
+ PROT=IND
+C
+C..... ROZPOCZNIJ KONTROLE PARAMETROW
+ CALL MCALLO(IND,STACK(VALTOP-1),STACK(VALTOP-6),KIND)
+cbc moved check for virtual address before check for standard procedure
+C CZY JEST NA STOSIE WYWOLANIE WYMAGAJACE ZABEZPIECZENIA ADR. WIRTUALNEGO
+ IF(LASTPR.EQ.0)GO TO 200
+C TAK. WEZ PELNY ADRES VIRTUALNY
+ N=TSTEMP(4)
+ CALL QUADR3(43,N,STACK(LASTPR-2))
+ STACK(LASTPR-2)=N
+200 continue
+C.....FUNKCJA,PROCEDURA STANDARDOWA ?
+ IF(IND.LT.LPMSYS)GO TO 1000
+C NIE.
+ FLREADY=.FALSE.
+cbc
+ LASTPR=VALTOP
+ PHADR=TSTEMP(1)
+ N=ELEM-7
+C =RODZAJ ELEMENTU, 1..7 ZAMIAST 8..14
+ BT=schx1
+C = BITY 0-1 KOPIOWANE DO SLOWA -1 , = ZNANE OFFSETY,NIELOKALNY LUB PREF.
+ GO TO (220,260,350,240,240,230),N
+C - OPERATOR TU NIE WYSTAPI
+C
+C.....REKORD
+ 220 ADR=TSTEMP(4)
+ OPKOD=1
+ GO TO 400
+C.....SYGNAL
+ 230 OPKOD=3
+ PROT=IPMEM(PROT+1)
+C = NUMER SYGNALU
+ GO TO 380
+C.....PROCEDURA,FUNKCJA. VIRTUAL LUB PARAMETR ?
+ 240 IF(KIND.EQ.0)GO TO 260
+ BT=schx2
+C CZYLI NIEZNANE OFFSETY
+ GO TO 270
+C.....KLASA, CD. PROCEDURY,FUNKCJI
+C LOKALNY BEZ PREFIKSU ?
+ 260 IF(LOCAL.EQ.2 .AND. IPMEM(PROT+21).EQ.0 .AND. STACK(VALTOP-7)
+ X .EQ.0) BT=0
+ 270 IF(KIND.NE.2 .AND. STACK(VALTOP-7).EQ.0)GO TO 350
+ OPKOD=5
+ GO TO 360
+C.....BLOK PREFIKSOWANY
+ 350 OPKOD=4
+ 360 PROT=SPRFLD(.FALSE.)
+C = WYZNACZONY DYNAMICZNIE PROTOTYP /BYC MOZE WRAZ Z OTOCZENIEM/
+ 380 ADR=TSTEMP(1)
+C.....WSPOLNE OTWARCIE POLA DANYCH : OPENRC,RAISE,OPEN,SLOPEN
+C /OPKOD = 1,3,4,5/
+ 400 CALL QUADR4(OPKOD,ADR,PHADR,PROT)
+ STACK(VALTOP-2)=ADR
+ STACK(VALTOP-3)=BT
+C OTWARCIE POLA DANYCH DOSTARCZA AH I ADR.FIZYCZNEGO
+C.....CZY SA PARAMETRY AKTUALNE ?
+ 500 IF(WB.EQ.36)GO TO 550
+C BRAK PAR.AKTUALNYCH, KONCZ WYWOLANIE
+ 510 CALL SCALLE
+ RETURN
+C DLA FUNKCJI BEZPARAMETROWEJ TEZ KONCZ WYWOLANIE
+ 550 IF(ELEM.EQ.12 .AND. IPMEM(IND+4).EQ.1)GO TO 510
+ RETURN
+C.....PROCEDURA,FUNKCJA STANDARDOWA
+ 1000 STACK(VALTOP-2)=0
+ STACK(VALTOP-3)=0
+C WYZEROWANE LICZNIKI PAR. INPUT I OUTPUT
+ GO TO 500
+ END
+ SUBROUTINE SCALLE
+C-------------------------------------------------------------------------
+C
+C WERSJA 1984.04.10
+C
+C OBSLUGUJE ZAKONCZENIE WYWOLANIA REKORDU,KLASY,BLOKU PREF.,
+C PROCEDURY,FUNKCJI,SYGNALU.
+C
+C WOLANA : PRZY BRAKU PARAMETROW AKTUALNYCH PRZEZ SCALLB LUB
+C PO WYSTAPIENIU ")" PRZEZ SDPDA.
+C
+C WOLA MCALLC.
+C ZABEZPIECZA STOS.
+C PRZEKAZUJE STEROWANIE.
+C ODCZYTUJE PARAMETRY OUTPUT I WARTOSC FUNKCJI.
+C SPRAWDZA DLA PROCEDURY ISTNIENIE "CALL" I ZJADA. /JESLI BRAK "CALL"
+C - ZASTEPUJE PRZEZ UNIWERSALNY/
+C DLA SYGNALU SPRAWDZA ISTNIENIE "RAISE" I ZJADA /JESLI BRAK "RAISE"
+C - ZASTEPUJE PRZEZ UNIWERSALNY.
+C REKORD,KLASE ZASTEPUJE PRZEZ WARTOSC / LUB ZDEJMUJE ZE STOSU
+C JESLI WB = ZNACZNIK KONCA INSTRUKCJI LUB ETYKIETA /.
+C FUNKCJE ZASTEPUJE PRZEZ WARTOSC.
+C DLA BLOKU PREF.,PROCEDURY,SYGNALU OBNIZA STOS.
+C DLA FUNKCJI,PROCEDURY,SYGNALU,BLOKU PREF. USUWA POLE DANYCH.
+C
+C
+C DLA PROCEDURY,FUNKCJI STANDARDOWEJ GENERUJE :
+C PRZEKAZANIE WARTOSCI PARAMETROW INPUT /OPKOD 145/ ,
+C PRZEKAZANIE STEROWANIA /OPKOD 132/ ,
+C ODCZYT PAR. OUTPUT I WARTOSCI FUNKCJI /OPKOD 23/
+C PRZEKAZANIE ODCZYTANYCH WARTOSCI PARAMETROW NA PAR.AKTUALNE
+C ORAZ ZDEJMUJE ZE STOSU PARAMETRY INPUT LEZACE POD FUNKCJA,PROCEDURA.
+C DODATKOWO, FUNKCJE ZASTEPUJE PRZEZ WARTOSC.
+C
+C
+C
+C ##### OUTPUT CODE : 2 , 21 , 54 , 58 , 59 , 132 , 143 , 145 ,
+C 150 , 153 , 159 , 160 , 170 .
+C
+C ##### DETECTED ERROR(S) : 450 , 453 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND
+ *, MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
+C MHAND - WZORZEC DLA HANDLERA
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCC
+ INTEGER OPKOD,N,ELEM,CONTRL,IND,ATS,M
+ LOGICAL STANDARD
+ DATA SCALEHEX / x'1FFF' /
+C ELEM - WSKAZUJE 0-SLOWO OPISU PARAMETRU NA STOSIE
+C CONTRL - INFORMACJA O KONTROLI /MPARIO(..)+1/
+C IND - ADRES W IPMEM OPISU PAR.FORMALNEGO
+C ATS - ATS WARTOSCI PAR.FORMALNEGO LUB WARTOSCI FUNKCJI
+C STANDARD - .TRUE. DLA PROCEDURY,FUNKCJI STANDARDOWEJ
+C
+C......
+ CALL MCALLC
+ KIND=0
+C.....FUNKCJA,PROCEDURA STANDARDOWA ?
+ STANDARD=( STACK(VALTOP-4) .LT. LPMSYS )
+ IF(STANDARD)GO TO 2000
+C NIE.
+C JESLI REKORD - PRZESKOCZ
+ IF(STACK(VALTOP).EQ.8)GO TO 50
+C.....ZABEZPIECZ STOS
+ CALL SAFEST
+C.....PRZEKAZ STEROWANIE
+ CALL SPHADR(VALTOP)
+ OPKOD=160
+ IF(STACK(VALTOP-3).GT.8191)OPKOD=159
+C GOLOCAL LUB GO
+C PRZEKAZ STEROWANIE Z ADRESEM FIZYCZNYM I AH NOWEGO OBIEKTU
+ CALL QUADR3(OPKOD,PHADR,STACK(VALTOP-2))
+C
+C
+C PO POWROCIE Z GENEROWANEGO OBIEKTU:
+C
+C
+ PHADR=TSTEMP(1)
+ ATS=TSTEMP(4)
+ STACK(VALTOP-2)=ATS
+C NOWE ATS-Y NA ADR.FIZ. I VIRTUALNY
+ CALL QUADR3(2,ATS,PHADR)
+C
+C
+C CZY PROC. VIRTUALNA LUB FORMALNA? TAK,JESLI BIT 1 =1 W SLOWIE -3
+ IF(STACK(VALTOP-3).GE.16384)KIND=1
+C -OBOJETNE: FORMALNA CZY VIRTUALNA /CZY ZNANE OFFSETY/
+C
+C
+C
+C.....JESLI SA PARAMETRY OUTPUT-ODCZYTAJ WARTOSCI
+ 50 M=IAND(STACK(VALTOP-3),SCALEHEX)
+C M=LICZBA PARAMETROW OUTPUT
+ IF(M.EQ.0)GO TO 500
+C DLA PROCEDURY STANDARDOWEJ NAJPIERW ODCZYTAJ WARTOSCI WSZYSTKICH
+C PARAMETROW
+ IF(.NOT.STANDARD)GO TO 100
+ ELEM=FSTOUT-2
+ DO 90 N=1,M
+C ODCZYTAJ WARTOSC N-TEGO PAR.OUTPUT PROC.STANDARDOWEJ
+C I WPISZ ATS TEJ WARTOSCI DO SLOWA -8
+ ELEM=ELEM+11
+ IND=STACK(ELEM-1)
+ NRPAR=STACK(ELEM+1)
+ 90 STACK(ELEM-8)=SGETPAR(IND,VALTOP)
+C
+ 100 CONTINUE
+C
+ DO 400 N=1,M
+C OBSLUZ N-TY PARAMETR OUTPUT /OD PRAWEJ DO LEWEJ/
+ FSTOUT=FSTOUT+11
+ ELEM=FSTOUT-2
+ CONTRL=IAND(ISHFT(STACK(ELEM),-4),7)+1
+ STACK(ELEM)=IAND(STACK(ELEM),15)
+C ODCZYTANE I WYZEROWANE BITY 9-11
+ IND=STACK(ELEM-1)
+ NRPAR=STACK(ELEM+1)
+ IF(STANDARD)GO TO 102
+C ODCZYTAJ WARTOSC PARAMETRU OUTPUT
+ ATS=SGETPAR(IND,VALTOP)
+ GO TO 103
+ 102 ATS=STACK(ELEM-8)
+C
+C KONWERSJA LUB DYNAMICZNA KONTROLA
+ 103 IF(CONTRL.GT.3 .AND.OPTTYP)GO TO 300
+C
+ IDR=STACK(ELEM-5)
+ IF(IDR.EQ.0)GO TO 105
+ IDR=STYPFT(ELEM)
+C IDR = TYP FORMALNY PAR.AKT. LUB ZERO
+C
+ 105 GO TO (300,110,120,130,140,150,160),CONTRL
+C
+C KONWERSJA DO INTEGER
+ 110 OPKOD=TSTEMP(1)
+ CALL QUADR3(58,OPKOD,ATS)
+ ATS=OPKOD
+ GO TO 300
+C
+C KONWERSJA DO REAL
+#if WSIZE == 4
+120 opkod = tstemp(1)
+#else
+120 opkod = tstemp(2)
+#endif
+ CALL QUADR3(59,OPKOD,ATS)
+ ATS=OPKOD
+ GO TO 300
+C
+C KONTROLA DYN.,OBA TYPY STATYCZNE
+ 130 CALL QUADR3(150,ATS,STACK(ELEM-4))
+ GO TO 300
+C
+C.....ZNANY OFFSET?
+ 140 IF(KIND.NE.0)GO TO 165
+ OPKOD=TSTEMP(2)
+ CALL QUADR4(21,OPKOD,IPMEM(IND-4),IPMEM(IND-3))
+ GO TO 200
+C WSTAW TYP STATYCZNY PAR.AKTUALNEGO
+ 150 IDR=STYPST(ELEM)
+C ZNANY OFFSET?
+ 160 IF(KIND.EQ.0)GO TO 170
+C NIEZNANY. ODCZYTAJ TYP PAR.FORMALNEGO
+ 165 OPKOD=SFPRST(NRPAR)
+ GO TO 200
+C ZNANY OFFSET
+cdsw 170 OPKOD=SPARF2(IND)
+cdsw ----------------------------
+ 170 opkod = sparft(ind,2)
+cdsw -----------------------------
+C
+C OPKOD=ATS ODCZYTANEGO TYPU FORMALNEGO PAR.FORMALNEGO.
+ 200 CALL QUADR4(170,IDR,ATS,OPKOD)
+C ZAKONCZONA KONTROLA LUB KONWERSJA.
+C PODSTAW WARTOSC PAR.OUTPUT NA PAR.AKTUALNY
+ 300 CALL SSTORE(ELEM,ATS)
+C ZAKONCZONA OBSLUGA KOLEJNEGO PARAMETRU OUTPUT
+C
+ 400 CONTINUE
+C
+C
+ 500 ELEM=STACK(VALTOP)-7
+C = RODZAJ ELEMENTU : 1..6 ZAMIAST 8..13 /OPERATOR TU NIE WYSTAPI/
+ GO TO (600,600,800,700,900,650),ELEM
+C.....KLASA,REKORD. ZASTAP PRZEZ WARTOSC
+ 600 STACK(VALTOP)=2
+ STACK(VALTOP-3)=0
+ STACK(VALTOP-5)=0
+cbc kill template after return from process (opcode 222 LKILLTEMP)
+ prot = ipmem(stack(valtop-4))
+ if (iand(prot, mtp) .eq. mproces) call quadr1(222)
+cbc
+C JESLI NA WEJSCIU JEST POCZATEK INSTRUKCJI LUB ETYKIETA - ZDEJMIJ
+C ZE STOSU
+ IF(WB.EQ.32 .OR. WB.EQ.35 .OR. WB.EQ.44)CALL SPOP
+ GO TO 1000
+C.....SYGNAL. CZY JEST "RAISE" ?
+ 650 IF(WB.EQ.71)GO TO 670
+C BRAK RAISE - NIELEGALNE WYSTAPIENIE SYGNALU.ZASTAP PRZEZ UNIWERSALNY
+ CALL SERROR(453)
+ GO TO 720
+C ETYKIETA I USUNIECIE POLA DANYCH HANDLERA
+ 670 CALL SNEXT
+ IDL=153
+ GO TO 810
+C.....PROCEDURA. CZY JEST CALL?
+ 700 IF(WB.EQ.7)GO TO 750
+C BRAK CALL - NIELEGALNE WYSTAPIENIE PROCEDURY. ZASTAP PRZEZ UNIWERSALNY
+ CALL SERROR(450)
+ 720 STACK(VALTOP)=0
+ GO TO 1000
+C
+ 750 CALL SNEXT
+C PROCEDURA STANDARDOWA ?
+ IF(STACK(VALTOP-4).LT.LPMSYS)GO TO 3000
+C NIE.
+C.....BLOK PREFIKSOWANY. OBNIZ STOS,USUN POLE DANYCH
+ 800 IDL=143
+ 810 CALL QUADR2(IDL,STACK(VALTOP-2))
+ CALL SPOP
+ GO TO 1000
+C.....FUNKCJA. ZASTAP PRZEZ WARTOSC
+C WEZ DLA RESULT: NUMER JAKO PARAMETRU, ADRES OPISU JAKO ATRYBUTU
+ 900 N=STACK(VALTOP-4)
+C N=ADRES OPISU FUNKCJI W IPMEM
+C PARAMETRY SA NUMEROWANE OD ZERA, RESULT WYSTEPUJE JAKO OSTATNI.
+ NRPAR=IPMEM(N+4)-1
+ IND=IPMEM(N-5)
+ RESULT=SGETPAR(IND,VALTOP)
+C = ATS ODCZYTANEJ WARTOSCI FUNKCJI
+C FUNKCJA STANDARDOWA ?
+ IF(N.LT.LPMSYS)GO TO 4000
+C NIE.
+C WSTAW TYP WARTOSCI
+ STACK(VALTOP-3)=IPMEM(N-4)
+ STACK(VALTOP-4)=IPMEM(N-3)
+C CZY TYPU FORMALNEGO?
+ STACK(VALTOP-5)=0
+ IF(IAND(IPMEM(N),4096).EQ.0)GO TO 950
+C A WIEC FUNKCJA TYPU FORMALNEGO. ZWYKLA ?
+ IF(KIND.EQ.1) GO TO 930
+C TAK. IDAC PO SL-ACH OD POLA DANYCH ODCZYTAJ TEN TYP
+ N=TSTEMP(2)
+ CALL QUADR4(54,N,STACK(VALTOP-2),STACK(VALTOP-4))
+ GO TO 940
+C FUNKCJA FORMALNA LUB WIRTUALNA TYPU FORMALNEGO. ODCZYTAJ TEN TYP>
+ 930 N=SFPRST(NRPAR)
+ 940 STACK(VALTOP-5)=N
+C
+C ZASTAP PRZEZ WARTOSC
+ 950 STACK(VALTOP)=2
+C USUN POLE DANYCH
+ CALL QUADR2(143,STACK(VALTOP-2))
+ STACK(VALTOP-2)=RESULT
+C
+C...............WSPOLNE ZAKONCZENIE..............
+ 1000 PHADR=0
+ LASTPR=0
+ RETURN
+C
+C.....FUNKCJA,PROCEDURA STANDARDOWA.
+C WPISZ WARTOSCI PARAMETROW INPUT.
+ 2000 OPKOD=STACK(VALTOP-4)
+ OPKOD=IPMEM(OPKOD+2)
+C = NUMER FUNKCJI STANDARDOWEJ
+C WYMAGA SPECJALNEGO TRAKTOWANIA ?
+ IF(OPKOD.GT.0)GO TO 2100
+C TAK
+ CALL SPECIAL
+ RETURN
+C ... NORMALNIE OBSLUGIWANA
+ 2100 M=VALTOP-8*STACK(VALTOP-2)
+C = ADRES PIERWSZEGO PAR.INPUT
+C CZY SA / JESZCZE / PARAMETRY INPUT ?
+ 2200 IF(M.GE.VALTOP)GO TO 2400
+C WPISZ WARTOSC PARAMETRU
+ CALL QUADR4(145,SVATS(M),OPKOD,STACK(M-1))
+ M=M+8
+ GO TO 2200
+C
+C ... PRZEKAZ STEROWANIE
+ 2400 CALL QUADR2(132,OPKOD)
+ GO TO 50
+C
+C.....ZAKONCZENIE DLA PROCEDURY STANDARDOWEJ.
+C ZDEJMIJ ZE STOSU WRAZ Z PARAMETRAMI INPUT
+ 3000 OPKOD=STACK(VALTOP-2)+1
+ IF (OPKOD.LT.1)GO TO 3150
+ DO 3100 M=1,OPKOD
+ CALL SPOP
+ 3100 CONTINUE
+cbc 3150 RETURN
+ 3150 goto 1000
+cbc
+C
+C.....ZAKONCZENIE DLA FUNKCJI STANDARDOWEJ.
+C ZASTAP FUNKCJE WRAZ Z PARAMETRAMI INPUT PRZEZ WARTOSC
+ 4000 OPKOD=STACK(VALTOP-2)
+ IF (OPKOD.LT.1)GO TO 4150
+ DO 4100 M=1,OPKOD
+ CALL SPOP
+ 4100 CONTINUE
+ 4150 CALL SRESLT1(IPMEM(N-3))
+ STACK(VALTOP-3)=IPMEM(N-4)
+cbc RETURN
+ goto 1000
+cbc
+ END
+ SUBROUTINE SPECIAL
+C----------------------------------------------------------------------------
+C
+C OBSLUGUJE WYWOLANIE FUNKCJI STANDARDOWYCH WYMAGAJACYCH
+C SPECJALNEJ OBSLUGI :
+C
+C NUMERY :
+C -1 INOT
+C -2 IOR
+C -3 IAND
+C -4 ISHFT
+C -5 ORD
+C -6 CHR
+C -7 XOR
+C
+C NA CZUBKU STOSU ZNAJDUJE SIE FUNKCJA,POD NIA ARGUMENTY.
+C PROCEDURA GENERUJE KOD I ZASTEPUJE NA STOSIE FUNKCJE WRAZ
+C Z PARAMETRAMI PRZEZ JEJ WARTOSC.
+C
+C ##### OUTPUT CODE : 42 , 53 , 60 , 100 , 101 , 116 , 131 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER ARGS(7)
+C = LICZBA ARGUMENTOW
+ INTEGER OP(8)
+C = OPKOD DO WYPISANIA
+C
+ DATA ARGS/1,2,2,2,1,1,2/
+ DATA OP/42,100,101,116,60,60,131,53/
+C
+C
+ IND=STACK(VALTOP-4)
+C = ADRES OPISU FUNKCJI
+ N=STACK(VALTOP-2)
+C = LICZBA PAR. INPUT NA STOSIE , <= ARGS( .. )
+ NR=-IPMEM(IND+2)
+C = NUMER FUNKCJI, 1..7
+ IF(ARGS(NR).EQ.2)GO TO 2000
+C
+C.....JEDNOARGUMENTOWE. JEST ARGUMENT ?
+ IF(N.EQ.0)GO TO 1500
+ CALL SPOP
+C STALA?
+ IF(STACK(VALTOP).EQ.1)GO TO 1700
+C NIE
+ RESULT=TSTEMP(1)
+ CALL QUADR3(OP(NR),RESULT,STACK(VALTOP-2))
+C ... ZASTAP CZUBEK PRZEZ WARTOSC TEJ FUNKCJI
+ 1500 STACK(VALTOP)=2
+ 1510 STACK(VALTOP-2)=RESULT
+ 1520 STACK(VALTOP-1)=0
+ STACK(VALTOP-3)=IPMEM(IND-4)
+ STACK(VALTOP-4)=IPMEM(IND-3)
+ STACK(VALTOP-5)=0
+ STACK(VALTOP-6)=0
+ RETURN
+C ... STALY ARGUMENT
+ 1700 IF(NR.NE.1)GO TO 1520
+ RESULT=NOT(STACK(VALTOP-2))
+ GO TO 1510
+C
+C
+C.....DWUARGUMENTOWE. CZY SA OBA ARGUMENTY ?
+ 2000 TRESLT=IPMEM(IND-3)
+ IF(N.EQ.2)GO TO 2200
+C NIE, 1 LUB 0
+ IF(N.EQ.1)CALL SPOP
+ GO TO 1500
+C O.K.
+ 2200 CALL SPOP
+ CALL SARGMT
+ IDL=STACK(VLPREV-2)
+ IDR=STACK(VALTOP-2)
+C = ATS-Y PIERWSZEGO I DRUGIEGO ARGUMENTU
+ GO TO (2300,2400,2500,2450),ARG
+C ... OBA STALE
+ 2300 GO TO (2320,2320,2330,2340,2301,2301,2370),NR
+ 2301 CONTINUE
+C IOR
+ 2320 RESULT=IOR(IDL,IDR)
+ GO TO 2350
+C IAND
+ 2330 RESULT=IAND(IDL,IDR)
+ GO TO 2350
+C ISHFT
+ 2340 RESULT=ISHFT(IDL,IDR)
+C
+ 2350 CALL SRESULT(1)
+ RETURN
+C XOR
+ 2370 RESULT=IEOR(IDL,IDR)
+ GO TO 2350
+C
+C ... LEWY STALY,PRAWY NIE
+ 2400 IDL=SCONST(IDL)
+ 2450 RESULT=TSTEMP(1)
+ CALL QUADR4(OP(NR),RESULT,IDL,IDR)
+ 2460 CALL SRESULT(2)
+ RETURN
+C
+C ... PRAWY STALY,LEWY NIE
+ 2500 IF(NR.EQ.4)GO TO 2600
+C IOR,IAND,XOR
+ IDR=SCONST(IDR)
+ GO TO 2450
+C ... ISHFT( .. , CONST )
+ 2600 NR=8
+cbc IDR=IAND(IDR,31)
+ IF(IDR.NE.0)GO TO 2450
+ RESULT=IDL
+ GO TO 2460
+ END
+ INTEGER FUNCTION STYPST(ELEM)
+C-----------------------------------------------------------------
+C POMOCNICZA.
+C ZWRACA /NOWY/ ATS TYPU STATYCZNEGO ELEMENTU Z MIEJSCA ELEM STOSU
+C I WSTAWIA TEN TYP
+C
+C ##### OUTPUT CODE : 21 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C.....
+ STYPST=TSTEMP(2)
+ N=STACK(ELEM-3)
+ K=STACK(ELEM-4)
+ CALL QUADR4(21,STYPST,N,K)
+ RETURN
+ END
+ SUBROUTINE SPHADR(ELEM)
+C----------------------------------------------------------------------
+C
+C POMOCNICZA.
+C GWARANTUJE,ZE PHADR ZAWIERA ADR.FIZYCZNY GENEROWANEGO OBIEKTU.
+C JESLI PHADR=0,TO ODTWARZA ADR.FIZ. Z ADR.VIRT. ZE SLOWA -2 ELEMENTU
+C ELEM STOSU.
+C
+C ##### OUTPUT CODE : 47 .
+C
+C
+#include "stos.h"
+#include "blank.h"
+C.....
+ IF(PHADR.NE.0)RETURN
+C ZATEM TRZEBA ODTWORZYC ADRES FIZYCZNY
+ PHADR=TSTEMP(1)
+ CALL QUADR3(47,PHADR,STACK(ELEM-2))
+C ODCZYTAJ ADR.FIZYCZNY Z VIRTUALNEGO BEZ MEMBER
+ RETURN
+ END
+C
+ integer function sparft(ind, numdsw)
+C-----------------------------------------------------------------------------
+cdsw dodatkowy parametr numdsw = 1 - wejscie sparft, = 2 - wejscie sparf2
+C
+C ENTRY SPARF2
+C
+C POMOCNICZA.
+C DLA WOLANEGO MODULU /ZNANE OFFSETY/ ZWRACA ATS ZMODYFIKOWANEGO
+C TYPU FORMALNEGO PARAMETRU.
+C
+C WEJSCIE SPARF2 : WOLANY MODUL JEST NA CZUBKU STOSU /Z SCALLE/
+C WEJSCIE SPARFT : WOLANY MODUL JEST PONIZEJ CZUBKA /Z SPARAM/
+C
+C IND - ADRES OPISU PAR. FORMALNEGO W IPMEM
+C
+C ##### OUTPUT CODE : 54 , 85 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ LOGICAL MLOCTP
+C.....
+ ELEM=VLPREV
+cdsw GO TO 1
+cdsw ------------------------
+ if(numdsw.eq.1) go to 1
+cdsw ------------------------
+C
+C-----------------------
+cdsw ENTRY SPARF2(IND)
+ ELEM=VALTOP
+ 1 SPARFT=TSTEMP(2)
+C CZY TEN TYP FORMALNY JEST ATRYBUTEM LOKALNYM?
+ L=IPMEM(IND-3)
+ IF(MLOCTP(L,STACK(ELEM-4)))GO TO 100
+C NIE.ODCZYTAJ IDAC PO SL-ACH
+ CALL QUADR4(54,SPARFT,STACK(ELEM-2),L)
+ GO TO 200
+C ATRYBUT LOKALNY
+ 100 CALL QUADR4(85,SPARFT,PHADR,IND)
+C.....ZMODYFIKUJ TYP
+ 200 CALL SMODIFY(SPARFT,IPMEM(IND-4))
+cdsw SPARF2=SPARFT
+ RETURN
+ END
+ INTEGER FUNCTION SGETPAR(IND,ELEM)
+C-------------------------------------------------------------------------
+C
+C POMOCNICZA.
+C ODCZYTUJE WARTOSC FUNKCJI LUB PARAMETRU OUTPUT /IND=ADRES OPISU
+C W IPMEM/ I ZWRACA /NOWY/ ATS TEJ WARTOSCI.
+C UZYWANA ROWNIEZ DLA ODCZYTU PAR.OUTPUT LUB WARTOSCI FUNKCJI
+C DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
+C ELEM-MIEJSCE STOSU Z WOLANYM MODULEM
+C UZYWA NRPAR,PHADR.
+C
+C ##### OUTPUT CODE : 23 , 52 , 61 , 62 , 63 , 84 , 85 , 86 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER APET,K
+C.....
+ APET=SAPET(IPMEM(IND-4),IPMEM(IND-3))
+
+#if WSIZE == 4
+cvax changed because of real appetite = 1
+ dswap = apet
+ if (dswap .eq. 2) dswap = 1
+ sgetpar = tstemp(dswap)
+#else
+ SGETPAR=TSTEMP(APET)
+#endif
+
+ APET=APETYT(APET)
+C STANDARDOWA?
+ IF(STACK(ELEM-4).LT.LPMSYS)GO TO 300
+C.....NIE
+C CZY ZNANY OFFSET? TAK,JESLI W SLOWIE -3 BIT 1 =0.
+ IF(STACK(ELEM-3).GE.16384)GO TO 200
+C ZNANY OFFSET. ODCZYTAJ APET-SLOW
+ CALL QUADR4(83+APET,SGETPAR,PHADR,IND)
+ RETURN
+C NIEZNANY OFFSET. WEZ ADRES FIZYCZNY PARAMETRU.
+ 200 K=TSTEMP(1)
+ CALL QUADR4(52,K,PHADR,NRPAR)
+C ODCZYTAJ APET-SLOW
+ CALL QUADR3(60+APET,SGETPAR,K)
+ RETURN
+C.....PROCEDURA,FUNKCJA STANDARDOWA
+ 300 APET=STACK(ELEM-4)
+ CALL QUADR4(23,SGETPAR,IPMEM(APET+2),NRPAR)
+ RETURN
+ END
+ INTEGER FUNCTION STYPFT(ELEM)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA.
+C WYLICZA TYP FORMALNY ELEMENTU Z MIEJSCA ELEM STOSU /WARTOSC,ZMIENNA,
+C ELEM.TABLICY,TABL.STATYCZNA,FUNKCJA/ I ZWRACA ATS TEGO TYPU.
+C JESLI WB <> "(" MODYFIKUJE TEN TYP /ZWRACA ZMODYFIKOWANY/
+C
+C ##### OUTPUT CODE : 15 , 22 , 54 , 85 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER N,OPKOD
+ LOGICAL MLOCTP
+C.....
+ N=STACK(ELEM)-1
+ GO TO (200,300,200,300,199,199,199,199,199,199,300),N
+ 199 CONTINUE
+C
+C.....WARTOSC LUB ELEMENT TABLICY. TYP JUZ JEST WYLICZONY
+ 200 STYPFT=STACK(ELEM-5)
+ GO TO 335
+C
+C.....ZMIENNA LUB TABLICA STATYCZNA. CZY PRZEZ KROPKE?
+ 300 IF(STACK(ELEM-7).EQ.0)GO TO 340
+C PRZEZ KROPKE. CZY TYP FORMALNY JEST ATRYBUTEM TEGO POLA?
+ IF(STACK(ELEM-5).LE.0)GO TO 310
+C ZATEM TO ATRYBUT LOKALNY.WEZ JEGO ADR.FIZYCZNY
+ N=SMEMBER(ELEM)
+ OPKOD=85
+C ="ODCZYTAJ 2 SLOWA"
+ GO TO 330
+C ODSZUKAJ TYP IDAC PO SL-ACH
+ 310 N=STACK(ELEM-7)
+ 320 OPKOD=54
+C ="ODCZYTAJ TYP FORMALNY IDAC PO SL-ACH"
+ 330 STYPFT=TSTEMP(2)
+ CALL QUADR4(OPKOD,STYPFT,N,STACK(ELEM-4))
+C
+C.....JESLI WB <> "(" ZMODYFIKUJ TYP
+ 335 IF(WB.NE.36)CALL SMODIFY(STYPFT,STACK(ELEM-3))
+ RETURN
+C
+C PRZEZ DISPLAY. CZY TYP MOZNA ODCZYTAC PRZEZ DISPLAY?
+ 340 IF(STACK(ELEM-5).GT.0)GO TO 350
+C ZATEM TRZEBA ISC PO SL-ACH OD MIEJSCA DEKLARACJI ZMIENNEJ
+C SLOWO -5 = - SL TEJ ZMIENNEJ
+ N=TSTEMP(4)
+ CALL QUADR3(15,N,-STACK(ELEM-5))
+C N = ADR.VIRTUALNY POBRANY Z DISPLAYA
+ GO TO 320
+C TYP FORMALNY MOZNA ODCZYTAC POPRZEZ DISPLAY Z WARSTWY= STACK(ELEM-5)
+ 350 STYPFT=STACK(ELEM-4)
+ OPKOD=22
+ N=STACK(ELEM-5)
+C CZY TYP JEST ATRYBUTEM LOKALNYM?
+ IF(.NOT.MLOCTP(STYPFT,P))GO TO 330
+C TAK
+ STYPFT=TSINSE(STYPFT,2)
+ GO TO 335
+ END
+ SUBROUTINE SMODIFY(N,L)
+C---------------------------------------------------------------
+C
+C POMOCNICZA.
+C N=ATS TYPU FORMALNEGO , L=LICZBA ARRAY OF
+C MODYFIKUJE TEN TYP O WLASCIWA LICZBE ARRAY-OF I ATS WYNIKOWEGO
+C TYPU PODSTAWIA NA N.
+C
+C ##### OUTPUT CODE : 87 .
+C
+ INTEGER TSTEMP
+ IF(L.EQ.0)RETURN
+C A WIEC TRZEBA MODYFIKOWAC
+ K=TSTEMP(2)
+ CALL QUADR4(87,K,N,L)
+ N=K
+ RETURN
+ END
+ SUBROUTINE SSTORE(ELEM,ATS)
+C-----------------------------------------------------------------------------
+C
+C GENERUJE PRZESLANIE WARTOSCI O ADRESIE ATS W TABLICY SYMBOLI NA
+C ELEMENT /ZMIENNA,ELEM.TABLICY,TABL.STATYCZNA/ Z MIEJSCA ELEM STOSU.
+C NIE DOKONUJE ZADNEJ KONTROLI.
+C NIE ZMIENIA STOSU.
+C LICZBA PRZESYLANYCH SLOW ZALEZY OD TYPU WARTOSCI ELEMENTU STOSU
+C
+C ##### OUTPUT CODE : 60 , 161 , 162 , 163 , 164 , 165 , 166 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+ INTEGER APET,ADRES,N
+C.....
+ N=STACK(ELEM)-2
+ ADRES=STACK(ELEM-2)
+C WYLICZ APETYT
+ APET=SAPET2(ELEM)
+ APET=APETYT(APET)
+ GO TO (300,400,500),N
+C
+C ZMIENNA. CZY PRZEZ KROPKE?
+ 300 IF(STACK(ELEM-7).EQ.0)GO TO 350
+C TAK.
+ CALL QUADR4(163+APET,SMEMBER(ELEM),ATS,ADRES)
+ CALL SCANCEL(ADRES)
+ RETURN
+C ZMIENNA PRZEZ DISPLAY.
+ 350 CALL QUADR3(60,ADRES,ATS)
+C "MOVE"
+ RETURN
+C
+C.....ELEM.TABLICY
+C WPISZ APET-SLOW POD ADRES FIZYCZNY ELEMENTU TABLICY
+ 400 CALL QUADR3(160+APET,SARRAY(ELEM),ATS)
+C
+C TABLICA STATYCZNA
+ 500 CONTINUE
+C B R A K
+ RETURN
+ END
+ INTEGER FUNCTION SARRAY(ELEM)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA.
+C ZWRACA ATS ADRESU FIZYCZNEGO ELEMENTU TABLICY Z MIEJSCA ELEM STOSU
+C USUWA EWENTUALNY MINUS W SLOWIE -2
+C
+C ##### OUTPUT CODE : 64 , 65 , 102 , 103 , 104 , 105 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+ INTEGER N,K
+C.....
+ SARRAY=TSTEMP(1)
+ N=SAPET2(ELEM)
+ K=APETYT(N)
+ N=STACK(ELEM-7)
+C CZY INDEKS JEST STALA?
+ IF(STACK(ELEM-2).LT.0)GO TO 100
+C.....NIE.
+ IF(K.EQ.1)GO TO 50
+C POMNOZ INDEKS PRZEZ 2 LUB 3
+ N=TSTEMP(1)
+ CALL QUADR3(62+K,N,STACK(ELEM-7))
+ 50 CALL QUADR4(102+OPTIND+OPTMEM,SARRAY,STACK(ELEM-2),N)
+ RETURN
+C.....INDEKS JEST STALA
+ 100 N=SCONST(K*N)
+ STACK(ELEM-2)= - STACK(ELEM-2)
+ GO TO 50
+ END
+ INTEGER FUNCTION SAPET2(ELEM)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA. ZWRACA APETYT /1,3,4/ DLA STALEJ,ZMIENNEJ,WARTOSCI
+C Z MIEJSCA ELEM STOSU.
+C
+#include "stos.h"
+#include "blank.h"
+C
+ N=STACK(ELEM-3)
+ K=STACK(ELEM-4)
+ SAPET2=SAPET(N,K)
+ RETURN
+ END
+ INTEGER FUNCTION SAPET(K,N)
+C-----------------------------------------------------------------------------
+C
+C POMOCNICZA. ZWRACA APETYT/1,2,4/ DLA WARTOSCI TYPU (K,N)
+C 1 - INTEGER,BOOLEAN,STRING,CHAR
+C 2 - REAL
+C 4 - DOWOLNY TYP REFERENCYJNY
+C
+C
+ IMPLICIT INTEGER (A-Z)
+#include "blank.h"
+C
+C
+C TABLICOWY?
+ IF(K.GT.0)GO TO 100
+C = 1 ?
+ SAPET=1
+ IF(N.EQ.NRINT)RETURN
+ IF(N.EQ.NRBOOL)RETURN
+ IF(N.EQ.NRCHR)RETURN
+ IF(N.EQ.NRTEXT)RETURN
+C REAL?
+ SAPET=2
+ IF(N.EQ.NRRE)RETURN
+C REFERENCYJNY
+ 100 SAPET=4
+ RETURN
+ END
+ INTEGER FUNCTION SMEMBER(ELEM)
+C---------------------------------------------------------------------------
+C
+C POMOCNICZA: ZWRACA /NOWY/ ATS ADRESU FIZYCZNEGO Z ADR.VIRT. ELEMENTU
+C Z MIEJSCA ELEM STOSU.
+C
+C ##### OUTPUT CODE : 46 , 47 .
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+C
+C
+ SMEMBER=TSTEMP(1)
+ N=STACK(ELEM-7)
+ CALL QUADR3(46+OPTMEM,SMEMBER,N)
+ RETURN
+ END
+ INTEGER FUNCTION SPRFLD(PARAM)
+C----------------------------------------------------------------------------
+C
+C ZWRACA /NOWY/ATS NUMERU PROTOTYPU LUB OJCA SYNT. I NUMERU PROTOTYPU.
+C PARAM=.TRUE. -UZYWANE PRZY PRZEKAZYWANIU PARAMETRU AKTUALNEGO
+C /NA CZUBKU NA PEWNO FUNKCJA,PROCEDURA/
+C DOSTARCZA OJCA SYNTAKTYCZNEGO I PROTOTYPU/SKLEJONE W 1 ARG./
+C WOLANA PRZEZ SPARAM.
+C PARAM=.FALSE. -UZYWANE PRZY GENEROWANIU OBIEKTU KLASY,PROCEDURY,FUNKCJI
+C LUB BLOKU PREF. DOSTARCZA NUMERU PROTOTYPU /DLA PARAMETRU LUB
+C DOSTEPU PRZEZ KROPKE-ROWNIEZ OJCA SYNT./.
+C CZUBEK STOSU ZAWIERA KLASE,BLOK PREF,PROCEDURE,FUNKCJE.
+C WOLANA PRZEZ SCALLB.
+C
+C NIE UZYWANA DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
+C
+C ##### OUTPUT CODE : 15 , 16, 20 , 44 , 45 , 86 , 112 .
+C
+C
+#include "stos.h"
+#include "option.h"
+#include "blank.h"
+CCCCCCCCCCCCCCCC
+ LOGICAL PARAM
+C
+ INTEGER OPKOD,IND,ATS,N
+C
+C.................
+ SPRFLD=TSTEMP(1)
+ IND=STACK(VALTOP-4)
+C IND=ADRES PROTOTYPU
+C.....CZY TO PARAMETR,VIRTUAL CZY "ZWYKLY" PROTOTYP?
+ N=KIND+1
+ GO TO (100,200,300),N
+C.....ZWYKLY PROTOTYP.WSTAW JEGO NUMER.
+ 100 CALL QUADR3(16,SPRFLD,STACK(VALTOP-4))
+C DLA BLOKU PREF. TO JUZ WSZYSTKO
+ IF(STACK(VALTOP).EQ.10)RETURN
+C CZY PRZEZ KROPKE?
+ IF(STACK(VALTOP-7).EQ.0)GO TO 150
+C TAK.
+ 125 ATS=STACK(VALTOP-7)
+C.....SKLEJ ADRES VIRTUALNY /ATS/ I NUMER PROTOTYPU /SPRFLD/ W 1 ARGUMENT.
+ 130 OPKOD=112
+C OPKOD="SKLEJ W 1 ARG."
+ N=SPRFLD
+ 135 SPRFLD=TSTEMP(3)
+ CALL QUADR4(OPKOD,SPRFLD,ATS,N)
+ RETURN
+C.....ZWYKLY PROTOTYP NIE PRZEZ KROPKE.JESLI NIE PARAMETR-KONIEC.
+ 150 IF(.NOT.PARAM)RETURN
+C ZATEM PARAMETR.WEZ ADRES Z DISPLAYA.
+ ATS=TSTEMP(4)
+ CALL QUADR3(15,ATS,IPMEM(IND-1))
+ GO TO 130
+C.....PROCEDURA,FUNKCJA VIRTUALNA.
+ 200 IF(STACK(VALTOP-7).EQ.0)GO TO 250
+C WYZNACZ PRZEZ KROPKE PROTOTYP VIRTUALA
+cbc split opcode 44,45 into 228 (LASKPROT) and 44,45 (LVIRTDOT)
+cbc in order to call virtual from process properly
+cbc CALL QUADR4(44+OPTMEM,SPRFLD,STACK(VALTOP-7),IPMEM(IND+27))
+ call quadr2(228, stack(valtop-7))
+ call quadr3(44+optmem, sprfld, ipmem(ind+27))
+cbc
+ GO TO 125
+C WYZNACZ PRZEZ DISPLAY PROTOTYP VIRTUALA
+ 250 CALL QUADR4(20,SPRFLD,IPMEM(IND-1),IPMEM(IND+27))
+ GO TO 150
+C.....PARAMETR. ODCZYTAJ
+ 300 IF(STACK(VALTOP-7).EQ.0)GO TO 350
+C A WIEC PRZEZ KROPKE.WEZ ADRES FIZYCZNY POLA.
+ ATS=SMEMBER(VALTOP)
+ N=IND
+ OPKOD=86
+C OPKOD="WCZYTAJ 3 SLOWA Z POLA O ADR.FIZYCZNYM..."
+C ATS=ADR.FIZYCZNY,SPRFLD=ATS PARAMETRU
+ GO TO 135
+C PARAMETR PRZEZ DISPLAY
+ 350 SPRFLD=TSINSE(IND,LOCAL)
+ RETURN
+ END
+ INTEGER FUNCTION SFPRST(N)
+C----------------------------------------------------
+C
+C POMOCNICZA. N=NUMER PARAMETRU. ODCZYTUJE TYP
+C /NIEZNANY W CZASIE KOMPILACJI/ N-TEGO PARAMETRU
+C PROCEDURY,FUNKCJI VIRTUALNEJ LUB FORMALNEJ,ZWRACA JEGO ATS.
+C
+C ##### OUTPUT CODE : 40 .
+C
+#include "stos.h"
+C
+C
+C
+ SFPRST=TSTEMP(2)
+ CALL QUADR4(40,SFPRST,PHADR,N)
+ RETURN
+ END
+ INTEGER FUNCTION SPARST(N)
+C-----------------------------------------------------------------------
+C
+C POMOCNICZA.WSTAWIA TYP STATYCZNY PARAMETRU FORMALNEGO.
+C N=ADRES OPISU PARAMETRU W IPMEM
+C
+C ##### OUTPUT CODE : 21 .
+C
+ IMPLICIT INTEGER (A-Z)
+#include "blank.h"
+C
+C
+ SPARST=TSTEMP(2)
+ CALL QUADR4(21,SPARST,IPMEM(N-4),IPMEM(N-3))
+ RETURN
+ END
+ SUBROUTINE SAFE(N)
+C---------------------------------------------------------------------
+C
+C N = ADRES W TABLICY SYMBOLI LUB 0.
+C JESLI N <> 0 ,GENERUJE NOWY ATRYBUT ROBOCZY I ZASTEPUJE NIM
+C PARAMETR AKTUALNY,ZACHOWUJAC ZNAK.
+C GENERUJE OPKOD MOVE&SAFE - NOWY ATRYBUT Z WARTOSCIA I APETYTEM
+C STAREGO,WARTOSC W ZMIENNEJ ROBOCZEJ.
+C
+C ##### OUTPUT CODE : 195 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ IF(N.EQ.0)RETURN
+ LSTEMP=LSTEMP-3
+ K=LSTEMP
+C ABY ZACHOWAC EWENTUALNY MINUS
+ IF(N.GT.0) GO TO 100
+ K= - K
+ N= - N
+ 100 CALL QUADR3(195,LSTEMP,N)
+ N=K
+ RETURN
+ END
+ INTEGER FUNCTION TSTEMP(N)
+C------------------------------------------------------------------------
+C
+C
+C ##### OUTPUT CODE : 201 , 202 , 203 , 204 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ LSTEMP=LSTEMP-3
+ TSTEMP=LSTEMP
+ CALL QUADR2(200+N,TSTEMP)
+ IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
+ RETURN
+ END
+ INTEGER FUNCTION TSINSE(K,N)
+C-------------------------------------------------------------------------
+C
+C K = ADRES OPISU ATRYBUTU W IPMEM
+C N = WIDZIALNOSC : 0 - GLOBALNY,1 - PRZEZ DISPLAY,2 - LOKALNY ATRYBUT
+C
+C WYZNACZA ADRES OPISU ATRYBUTU W TABLICY SYMBOLI.
+C UZYWA POMOCNICZEGO SLOWNIKA ZAWIERAJACEGO TYLKO ATRYBUTY UZYTE
+C W BIEZACYM MODULE.
+C
+C ELEMENTY SLOWNIKA:
+C SLOWO 0 = P /BIEZACY PROTOTYP/ ORAZ
+C SLOWO +1 = ADRES OPISU ATRYBUTU W IPMEM
+C <=> ATRYBUT JEST W SLOWNIKU.
+C - I WTEDY SLOWO +1 OPISU
+C ATRYBUTU ZAWIERA ADRES TEGO ELEMENTU SLOWNIKA
+C
+C SLOWO +2 = ADRES W TABLICY SYMBOLI
+C
+C JESLI SLOWO 0 <> P LUB SLOWO +1 <> ADRESU ATRYBUTU
+C TO ATRYBUTU JESZCZE NIE MA W SLOWNIKU
+C ELEMENTY SLOWNIKA DOPISYWANE SA NA LEWO OD LMEM
+C IPMEM(LMEM) = INDEKS PIERWSZEGO OD PRAWEJ WOLNEGO
+C
+C
+C
+C ##### OUTPUT CODE : 205 , 206 , 207 .
+C
+C ##### DETECTED ERROR(S) : 553 , 554 . ( PRZEPELNIENIA )
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+C
+C
+ TSINSE=IPMEM(K+1)
+C UZYTY JUZ W TYM MODULE?
+ IF(IPMEM(TSINSE).NE.P)GO TO 100
+ IF(IPMEM(TSINSE+1).NE.K)GO TO 100
+C.....TAK.
+ TSINSE=IPMEM(TSINSE+2)
+ RETURN
+C.....JESZCZE NIE. WYZNACZ NOWY ADRES W TABLICY SYMBOLI
+ 100 J=IPMEM(LMEM)-3
+ IF(IRECN.GT.J)GO TO 200
+ IPMEM(LMEM)=J
+ TSINSE=J+1
+ IPMEM(TSINSE)=P
+ IPMEM(TSINSE+1)=K
+ IPMEM(TSINSE+2)=FRSTTS
+ IPMEM(K+1)=TSINSE
+ TSINSE=FRSTTS
+ FRSTTS=FRSTTS+3
+ CALL QUADR3(205+N,TSINSE,K)
+ IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
+ RETURN
+C.....PRZEPELNIENIE TABLICY SYMBOLI LUB SLOWNIKA STALYCH REAL
+ 200 CALL SERRO2(504,0)
+ RETURN
+ END
+ SUBROUTINE SCANCEL(ADR)
+C-----------------------------------------------------------------------------
+C
+C JESLI ATRYBUT WSKAZANY PRZEZ ADR BYL UZYTY /JEST W TABLICY
+C SYMBOLI/ - PROCEDURA WYPISUJE OPKOD "CANCEL" , INACZEJ
+C NIC NIE ROBI.
+C
+C UZYWANA PRZY ZMIANIE WARTOSCI ATRYBUTU DOSTEPNEGO PRZEZ KROPKE,
+C DLA ZABEZPIECZENIA NASTEPNEGO PRZEBIEGU PRZED TRZYMANIEM
+C INFORMACJI "WARTOSC ATRYBUTU W REJESTRZE" POMIMO /NIEJAWNEJ/
+C ZMIANY WARTOSCI TEGO ATRYBUTU PRZY UZYCIU DOSTEPU KROPKOWANEGO.
+C
+C ##### OUTPUT CODE : 158 .
+C
+C
+ IMPLICIT INTEGER (A-Z)
+#include "blank.h"
+C
+C
+C
+C.....JEST W TABLICY SYMBOLI?
+ N=IPMEM(ADR+1)
+ IF(IPMEM(N).NE.P)RETURN
+ IF(IPMEM(N+1).NE.ADR)RETURN
+C TAK
+ CALL QUADR2(158,IPMEM(N+2))
+ RETURN
+ END
+ SUBROUTINE SAFEST
+C-------------------------------------------------------------------------
+C
+C ZABEZPIECZA ELEMENTY STOSU PRZY GENERACJI NOWEGO MODULU:
+C DLA ELEMENTOW BEDACYCH LSE ZABEZPIECZA ADRES TJ. WARTOSC WYRAZENIA
+C PRZED KROPKA DLA ZMIENNEJ I TABLICY STATYCZNEJ, ADRES TABLICY DLA
+C ELEMENTU TABLICY I WARTOSC INDEKSU - JESLI NIE STALA - DLA TABLIC.
+C
+C DLA ELEMENTOW POWYZEJ LSTLSE ZABEZPIECZA WARTOSC ZMIENNYCH.
+C
+C ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ INTEGER K,ELEM,N,L
+C......ZACZNIJ OD POPRZEDNIEGO
+ K=VLPREV
+C CZY JEST COS NIEZABEZPIECZONEGO NAD OPISAMI PETLI FOR?
+ 100 IF(K.GT.LSTFOR .AND. K.GT.LSTSAF)GO TO 120
+C NIE
+ LSTSAF=VLPREV
+ RETURN
+C TAK.
+ 120 ELEM=STACK(K)
+C ELEM=RODZAJ ELEMENTU
+ IF(ELEM.LT.2 .OR. ELEM.GT.5)GO TO 1000
+C LSE?
+ IF(K.LE.LSTLSE)GO TO 200
+C.....A WIEC POWYZEJ LSE : WARTOSC,ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
+C ZASTAP PRZEZ WARTOSC.
+ IF(ELEM.EQ.2)GO TO 150
+ IF(ELEM.EQ.4)GO TO 160
+C B R A K DLA TABLICY STATYCZNEJ
+C ... ZMIENNA. PRZEZ KROPKE?
+ IF(STACK(K-7).EQ.0)GO TO 140
+C TAK.ODCZYTAJ WARTOSC
+ N=SAPET2(K)
+C N=RODZAJ APETYTU ZMIENNEJ
+#if WSIZE == 4
+cvax changed because of real appetite = 1
+ dswap = n
+ if (dswap .eq.2) dswap = 1
+ l = tstemp(dswap)
+#else
+ L=TSTEMP(N)
+#endif
+
+ N=APETYT(N)
+ CALL QUADR4(83+N,L,SMEMBER(K),STACK(K-2))
+ 135 STACK(K-2)=L
+C WPISZ 'WARTOSC'
+ 140 STACK(K)=2
+ 150 CALL SAFE(STACK(K-2))
+ GO TO 1000
+C ... ELEM.TABLICY. ODCZYTAJ WARTOSC
+ 160 N=SAPET2(K)
+#if WSIZE == 4
+cvax changed because of real appetite = 1
+ dswap = n
+ if (dswap .eq.2) dswap = 1
+ l = tstemp(dswap)
+#else
+ L=TSTEMP(N)
+#endif
+
+ N=APETYT(N)
+ CALL QUADR3(60+N,L,SARRAY(K))
+ GO TO 135
+C.....LSE : ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
+ 200 CALL SAVEVAR(K)
+C
+C.....WEZ POPRZEDNI ELEMENT
+ 1000 K=K-STCKAP(ELEM)
+ GO TO 100
+ END
+ SUBROUTINE SINDXS
+C MAKIETA
+ RETURN
+ END
+ SUBROUTINE QUADR4(N1,N2,N3,N4)
+C------------------------------------------------------------
+C
+C WYPISUJE GENEROWANY KOD POSREDNI
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+ common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
+C
+C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
+
+ IPMEM(LSTWRD+1)=N1
+ IPMEM(LSTWRD+2)=N2
+ IPMEM(LSTWRD+3)=N3
+ IPMEM(LSTWRD+4)=N4
+
+ IF(.NOT.TESTC) GOTO 1000
+ call ffputcs(13,' *******************')
+ call ffputi (13,N1,8)
+ call ffputi (13,N2,8)
+ call ffputi (13,N3,8)
+ call ffputi (13,N4,8)
+ call ffputnl(13)
+1000 CONTINUE
+
+ LSTWRD=LSTWRD+4
+ IF(LSTWRD.GE.LMEM-4)CALL QDROUT
+ RETURN
+ END
+ SUBROUTINE QUADR3(N1,N2,N3)
+C------------------------------------------------------------
+C
+C WYPISUJE GENEROWANY KOD POSREDNI
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+ common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
+C
+C
+C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
+ IPMEM(LSTWRD+1)=N1
+ IPMEM(LSTWRD+2)=N2
+ IPMEM(LSTWRD+3)=N3
+
+ IF(.NOT.TESTC) GOTO 1000
+ call ffputcs(13,' *******************')
+ call ffputi (13,N1,8)
+ call ffputi (13,N2,8)
+ call ffputi (13,N3,8)
+ call ffputnl(13)
+1000 CONTINUE
+
+ LSTWRD=LSTWRD+3
+ IF(LSTWRD.GE.LMEM-4)CALL QDROUT
+ RETURN
+ END
+ SUBROUTINE QUADR2(N1,N2)
+C------------------------------------------------------------
+C
+C WYPISUJE GENEROWANY KOD POSREDNI
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+ common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
+C
+C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
+ IPMEM(LSTWRD+1)=N1
+ IPMEM(LSTWRD+2)=N2
+
+ IF(.NOT.TESTC) GOTO 1000
+ call ffputcs(13,' *******************')
+ call ffputi (13,N1,8)
+ call ffputi (13,N2,8)
+ call ffputnl(13)
+1000 CONTINUE
+
+ LSTWRD=LSTWRD+2
+ IF(LSTWRD.GE.LMEM-4)CALL QDROUT
+ RETURN
+ END
+ SUBROUTINE QUADR1(N1)
+C------------------------------------------------------------
+C
+C WYPISUJE GENEROWANY KOD POSREDNI
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+ common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
+C
+C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
+ LSTWRD=LSTWRD+1
+ IPMEM(LSTWRD)=N1
+
+ IF(.NOT.TESTC) GOTO 1000
+ call ffputcs(13,' *******************')
+ call ffputi (13,N1,8)
+ call ffputnl(13)
+1000 CONTINUE
+
+ IF(LSTWRD.GE.LMEM-4)CALL QDROUT
+ RETURN
+ END
+ SUBROUTINE QDROUT
+C-----------------------------------------------------------------------------
+C
+C OPROZNIA BUFOR IPMEM Z GENEROWANYM KODEM POSREDNIM.
+C PRZEPISUJE OSTATNIE 3 LICZBY NA POCZATEK,USTAWIA LSTWRD.
+C JESLI ERRFLG=.TRUE. - NIE WYPISUJE NIC.
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C
+C.....
+ IF(ERRFLG)GO TO 100
+C WEZ NOWY NUMER REKORDU
+ call ffwrite_ints(18, ipmem(lmem-259), 256)
+
+cbc
+cdsw *********************************
+C PRZEPISZ OSTATNIE 3 SLOWA NA POCZATEK
+ N=LMEM-259
+ M=LMEM-3
+ IPMEM(N)=IPMEM(M)
+ IPMEM(N+1)=IPMEM(M+1)
+ IPMEM(N+2)=IPMEM(M+2)
+ 100 LSTWRD=LSTWRD-256
+ RETURN
+ END
+ SUBROUTINE SERROR(NUMER)
+C------------------------------------------------------------------------
+cdsw procedura podzielona na serror i serro2
+C
+C SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
+C DLA 'UNIWERSALNEGO' NIE ROBI NIC.
+C
+C
+C ENTRY SERRO2
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+C
+C
+ ELEM=VALTOP
+ 100 IF(STACK(ELEM).EQ.0)RETURN
+ NAZWA=STACK(ELEM-1)
+
+ IF(.NOT.TESTC) GOTO 1000
+ call ffputcs(13,' ERROR')
+ call ffputi (13,NUMER,6)
+ call ffputi (13,NAZWA,8)
+ call ffputnl(13)
+1000 CONTINUE
+
+ CALL MERR(NUMER,NAZWA)
+ RETURN
+ END
+ SUBROUTINE SERRO2(NUMER,elem)
+C------------------------------------------------------------------------
+cdsw procedura podzielona na serror i serro2
+C
+C SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
+C DLA 'UNIWERSALNEGO' NIE ROBI NIC.
+C
+C
+C ENTRY SERRO2
+C
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+C
+C
+ 100 IF(STACK(ELEM).EQ.0)RETURN
+ NAZWA=STACK(ELEM-1)
+
+ IF(.NOT.TESTC) GOTO 1000
+ call ffputcs(13,' ERROR')
+ call ffputi (13,NUMER,6)
+ call ffputi (13,NAZWA,8)
+ call ffputnl(13)
+1000 CONTINUE
+
+ CALL MERR(NUMER,NAZWA)
+ RETURN
+ END
+ SUBROUTINE SSTOVF
+C---------------------------------------------------------------------------
+C
+C SYGNALIZUJE PRZEPELNIENIE TABLICY SYMBOLI - BLAD 553
+C I CZYSCI JA
+C
+C
+#include "stos.h"
+#include "blank.h"
+cdsw&bc
+ common /stacks/ btsins, btstem
+C
+C
+C
+C
+C....PRZEPELNIENIE TABLICY SYMBOLI
+ CALL MERR(553,0)
+C OPROZNIJ TABLICE SYMBOLI
+cdsw&bc FRSTTS=LPMEM+1
+c TEMPNR=LMEM-3
+ frstts = btsins
+ tempnr = btstem-3
+c
+cdsw ---------- added -----------
+ lstemp = tempnr
+cdsw ------------------------------
+ IPMEM(LMEM)=BOTTOM-1
+ RETURN
+ END
+
+
+ SUBROUTINE STEST
+C---------------------------------------------------------------------
+C
+C READ TESTING OPTIONS
+#include "stos.h"
+C
+C
+ COMMON/TEST/TESTC,TESTS,TESTH
+ LOGICAL TESTC,TESTS,TESTH
+C
+cdsw BYTE CHARS(80)
+cdsw BYTE HN,HNS,HY,HYS,HC,HS,HH
+cdsw ---------------------------------
+ character chars(80)
+ character hn,hns,hy,hys,hc,hs,hh
+cdsw ---------------------------------
+ DATA HN,HNS,HY,HYS,HC,HS,HH /'n','n','y','y','c','s','h'/
+C
+C
+ TEST=.FALSE.
+ TESTC=.FALSE.
+ TESTS=.FALSE.
+ TESTH=.FALSE.
+ ATLINE=0
+ RETURN
+
+100 call ffputcs(0,' TESTING ? Y/N:')
+ call ffgets (0,CHARS,80)
+
+ IF(CHARS(1).EQ.HN .OR. CHARS(1).EQ.HNS)RETURN
+ IF(CHARS(1).NE.HY .AND. CHARS(1).NE.HYS) GO TO 100
+ TEST=.TRUE.
+
+ call ffputcs(0,' OPTIONS : C - code , S - stack , H - halt')
+ call ffputnl(0)
+
+ call ffgets (0,CHARS,80)
+
+ DO 200 N=1,80
+ IF(CHARS(N).EQ.HC)TESTC=.TRUE.
+ IF(CHARS(N).EQ.HS)TESTS=.TRUE.
+ IF(CHARS(N).EQ.HH)TESTH=.TRUE.
+ 200 CONTINUE
+cdsw IF(TESTH) CALL STOPAT
+ RETURN
+ END
+ SUBROUTINE SABORT
+ RETURN
+ END
+ SUBROUTINE SRCVOFF
+ RETURN
+ END
+
+
+ SUBROUTINE SLCSTOUT
+C---------------------------------------------------------------------
+C
+C WYPISUJE NA PLIK 15 HEKSADECYMALNA REPREZENTACJE
+C TABLICY SYMBOLI I L-KODU.
+C
+#include "stos.h"
+#include "blank.h"
+C
+C
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ LOGICAL ERRFLG
+C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
+C
+C
+ INTEGER BL(302)
+ EQUIVALENCE ( BL(1),IOP(1) )
+
+ integer*4 offset
+ integer*2 bigbuf
+ integer buf1(1)
+ common /combuf/ ind, length, bigbuf(16000)
+cvax equivalence (bigbuf(1), buf1(1))
+ character bufc(32000)
+ equivalence (bigbuf(1), buf1(1), bufc(1))
+
+cdsw&ail
+ common /stacks/ btsins, btstem
+
+cbc
+C
+C.....SYMBOL TABLE
+cdsw&ail
+c adres stalej none jest przekazany na zmiennej LOCAL ( numer 300 )
+ LOCAL = btstem-3
+ call ffwrite_ints(15, bl(1), 302)
+#if WSIZE == 4
+CPS tu bylo porownanie z 50000, co dla LPMEM=48000 dalo maximun
+CPS 2000 slow na stale rzeczywiste - nie rozumiem skad to ograniczenie
+CPS dlatego nie zmienilem go
+ if (irecn .gt. LPMEMSIZE+2000 ) call mdrop(0)
+#endif
+ call ffwrite_ints(15, ipmem(1), irecn)
+C.....L-CODE
+ offset=0
+ call ffseek(18,offset)
+3000 len=31744
+ call ffread(18,buf1(1),len)
+ if (len .eq. 0) goto 3010
+ wlen = len
+ call ffwrite(15,buf1(1),wlen)
+ if (len .eq. 31744) goto 3000
+3010 continue
+ RETURN
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+*DECK MPARPF
+ SUBROUTINE MPARPF (PAPROT, PAID, PAOB, DCONTR)
+C-------------BADA ZGODNOSC PARAMETRU AKTUALNEGO (FUNKCJI/PROCEDURY)
+C I PARAMETRU FORMALNEGO.
+C PAPROT - NUMER PROTOTYPU AKTUALNEGO
+C PAID - JEGO IDENTYFIKATOR ZE SCANNERA
+C PAOB - DOSTEPNOSC PRZEZ DISPLAY
+C DCONTR - NADAWANA JEST WARTOSC .TRUE., GDY KONIECZNA JEST
+C KONTROLA DYNAMICZNA
+C SYGNALIZOWANE BLEDY
+C 626 - NIEZGODNOSC RODZAJOW PARAMETROW FORMALNEGO I AKTUAL-
+C NEGO (FUNKCJA<->PROCEDURA)
+C NIEZGODNE NAGLOWKI
+C 627 - NIEZGODNE RODZAJE PARAMETROW
+C 628 - TYPY PARAMETROW SA NIEZGODNEGO RODZAJU
+C 629 - TYPY PARAMETROW MAJA ROZLACZNE SEKWENCJE PREFIKSOWE
+C 630 - NIEZGODNE DLUGOSCI LIST
+C INNE
+C 631 - NIEZGODNE TYPY FUNKCJI AKTUALNEJ I FORMALNEJ
+C 632 - PARAMETR AKTUALNY NIE JEST FUNKCJA ANI PROCEDURA
+C 635 - PARAMETR AKTUALNY JEST FUNKCJA LUB PROCEDURA
+C STANDARDOWA
+C
+C OPIS W DOKUMENTACJI: ?3.7.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 807
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL DCONTR,BTEST
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C *CALL MPI2
+C......BLOK KOMUNIKACJI PROCEDUR MPARPF ORAZ MPIO2
+ LOGICAL DCLASS, AFORM
+ COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS,
+ X AFORM
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14 !!
+C
+ APROT = PAPROT
+ AID = PAID
+ AOB = PAOB
+C
+ DCONTR = .TRUE.
+C
+C SPRAWDZENIE, CZY BEDZIE KONTROLA STATYCZNA
+ IF (UNICLL) RETURN
+ IF ( IPMEM(CLLREC+7) .EQ. 0) RETURN
+ IF (APROT .EQ. NRUNIV) RETURN
+C
+C------ KONTROLA ZGODNOSCI RODZAJOW
+C PF - OPIS PARAMETRU FORMALNEGO
+ PF = IPMEM(CLLREC+5)
+ PF = IPMEM(PF)
+ ZW = IPMEM(APROT)
+ ZW = IAND ( ISHFT(ZW, -8), 7) + 1
+C ZW - POLE S SLOWA ZEROWEGO PROTOTYPU AKTUALNEGO
+ GOTO (100, 100, 200, 100, 300, 100, 100, 100), ZW
+C
+C------ TO NIE JEST ANI FUNKCJA, ANI PROCEDURA
+ 100 CALL MERR(632, AID)
+ RETURN
+C
+C...... PARAMETR AKTUALNY JEST FUNKCJA
+ 200 PALGTH = -1
+C PALGTH - BEDZIE DLUGOSCIA LISTY PF DLA PROTOTYPU AKTUALNEGO
+ IF (IPMEM(CLLREC+7) .EQ. 4) GOTO 1000
+ GOTO 900
+C
+C...... PARAMETR AKTUALNY JEST PROCEDURA
+ 300 PALGTH = 0
+ IF (IPMEM(CLLREC+7) .EQ. 5) GOTO 2000
+C
+C------ NIEZGODNOSC RODZAJOW
+ 900 CALL MERR(626, AID)
+ GOTO 2000
+C
+C
+C***** PARAMETRY SA FUNKCJAMI
+ 1000 CONTINUE
+C--- ZBADANIE, CZY PF NIE JEST FUNKCJA DRUGIEGO RZEDU JESLI TAK
+C TO KONIECZNA JEST KONTROLA DYNAMICZNA
+ DCONTR = .TRUE.
+ IF (IPMEM(CLLREC+2) .EQ. 2) RETURN
+ DCONTR = .FALSE.
+C--- ZBADANIE ZGODNOSCI TYPOW FUNKCJI FORMALNEJ I AKTUALNEJ
+ CALL MFUNEQ (APROT, AID, AOB, PF, DCONTR)
+ GOTO 3000
+C
+C***** PARAMETRY SA PROCEDURAMI
+ 2000 DCONTR = .TRUE.
+ IF (IPMEM(CLLREC+2) .EQ. 2) RETURN
+ DCONTR = .FALSE.
+C
+C
+C*************************************************************************
+C WSPOLNA DLA FUNKCJI I PROCEDUR KONTROLA ZGODNOSCI LIST
+C
+ 3000 CONTINUE
+ IF (APROT .GT. LPMSYS) GOTO 3010
+C --UZYTY MODUL STANDARDOWY
+ CALL MERR(635, AID)
+C TWORZONY JEST MALY REKORD ZAMIANY TYPOW (W CZESCI PRZEZNACZONEJ
+C NA PROTOTYPY UZYTKOWNIKA
+ 3010 OLPMF = LPMF
+ DCONTR = .FALSE.
+ AFORM = .FALSE.
+ IF (BTEST(IPMEM(APROT),11)) DCLASS = .TRUE.
+ IF (IAND(ISHFT(IPMEM(APROT),-4),15) .NE. 0) AFORM = .TRUE.
+ DCLASS = DCLASS .OR. AFORM
+C...... INICJALIZACJA
+ PFEL = IPMEM(PF+3)
+C ELEMENT LISTY PF FUN/PROC FORMALNEJ
+ PFLGTH = IPMEM(PF+4)
+ IF (IPMEM(CLLREC+7) .EQ. 4) PFLGTH = PFLGTH-1
+ PAEL = IPMEM(APROT+3)
+C ELEMENT LISTY PF FUN/PROC AKTUALNEJ
+ PALGTH = PALGTH + IPMEM(APROT+4)
+C
+C*************
+C------ SPRAWDZENIE CZY SA JESZCZE PARAMETRY W OBYDWU LISTACH
+ IF ( (PALGTH .EQ. 0) .OR. (PFLGTH .EQ. 0) ) GOTO 6000
+C --- SKOK DO POROWNANIA DLUGOSCI LIST
+C*********************************
+C***** POBRANIE I PRZETWARZANIE KOLEJNYCH PARAMETROW
+C
+ 4000 PFPF = IPMEM(PFEL)
+ PFPA = IPMEM(PAEL)
+C -PFPF - PARAMETR FORMALNY FUN/PROC FORMALNEJ
+C -PFPA - PARAMETR FORMALNY FUN/PROC AKTUALNEJ
+ KINDPF = IPMEM(PFPF)
+ KINDPF = IAND (ISHFT(KINDPF, -4), 15) + 1
+ KINDPA = IPMEM(PFPA)
+ KINDPA = IAND(ISHFT(KINDPA, -4), 15) + 1
+ GOTO (5000, 4100, 4200, 4200, 5000, 4300, 4300, 5000,
+ X 5000, 4300), KINDPF
+C
+C......PFPF JEST TYPEM FORMALNYM
+C PFPA TEZ MUSI BYC TYPEM FORMALNYM (LUB PARAMETREM
+C UNIWERSALNYM)
+C WSTAWIENIE PARY DO MALEGO REKORDU
+ 4100 KINDPF = MGETM(2,0)
+ IPMEM(KINDPF) = PFPF
+ IPMEM(KINDPF+1) = PFPA
+ IF (KINDPA .EQ. 2) GOTO 5000
+ IPMEM(KINDPF+1) = NRUNIV
+ IF (KINDPA .EQ. 1) GOTO 5000
+C SKOK DO SYGNALIZACJI BLEDU
+ GOTO 4900
+C
+C......PFPF JEST FUNKCJA LUB PROCEDURA
+C KONTROLA POLEGA JEDYNIE NA POROWNANIU RODZAJOW, GDYZ FUNKCJE I
+C PROCEDURY FORMALNE 2 RZEDU NIE NIOSA ZADNEJ INFORMACJI
+ 4200 IF (KINDPA .EQ. KINDPF) GOTO 5000
+ GOTO 4900
+C
+C......PFPF JEST PARAMETREM INPUT/OUTPUT/INOUT
+C WYWOLANIE PROCEDURY KONTROLUJACEJ ZGODNOSC TYPOW
+ 4300 IF (KINDPA .LE. 5 ) GOTO 4900
+ CALL MPIO2 (DCONTR)
+ IF (KINDPF .EQ. KINDPA) GOTO 5000
+C
+C......NIEZGODNE RODZAJE PFPF I PFPA
+ 4900 CALL MERR(627, AID)
+C*****PRZESUNIECIE LIST PARAMETROW
+ 5000 PFEL = PFEL + 1
+ PAEL = PAEL + 1
+ PFLGTH = PFLGTH - 1
+ PALGTH = PALGTH - 1
+ IF ( (PFLGTH .NE. 0) .AND. (PALGTH .NE. 0) ) GOTO 4000
+C***************************************
+C
+C******************
+C-------ZBADANIE ZGODNOSCI DLUGOSCI LIST PF
+C ZNISZCZENIE MALEGO REKORDU
+ 6000 LPMF = OLPMF
+ IF (PFLGTH .EQ. PALGTH) GOTO 6300
+ IF (PFLGTH .LT. PALGTH) GOTO 6100
+C LISTA AKTUALNA JEST KROTSZA, POWINNA BYC USZKODZONA BY NIE BYLO
+C SYGNALIZACJI BLEDU
+C ZW - POLE S PROTOTYPU APROT
+ IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6)) RETURN
+ GOTO 6200
+C TU: LISTA PF JEST KROTSZA, TA POWINNA BYC USZKODZONA BY NIE BYLO
+C SYGNALIZACJI BLEDU
+ 6100 ZW = IPMEM(PF)
+ ZW = IAND(ISHFT(ZW, -8), 7) + 1
+ IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6)) RETURN
+C --- SYGNALIZACJA ROZNYCH DLUGOSCI LIST
+ 6200 CALL MERR (630, AID)
+ RETURN
+C ---LISTY ROWNYCH DLUGOSCI, SYGNALIZACJA BLEDOW GDY (TYLKO) JEDNA Z NICH
+C JEST USZKODZONA
+ 6300 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6) ) GOTO 6100
+C ---LISTA PARAMETROW MODULU AKTUALNEGO NIE JEST USZKODZONA, FORMALNEGO
+C ---TEZ NIE POWINNA BYC
+ ZW = IPMEM(PF)
+ ZW = IAND (ISHFT(ZW, -8), 7) + 1
+ IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6) ) GOTO 6200
+C ---WSZYSTKO JEST W PORZADKU
+ RETURN
+ END
+*DECK MFUNEQ
+ SUBROUTINE MFUNEQ (PA, AID, AOB, PF, DCONTR)
+C--------------PROCEDURA POMOCNICZA BADAJACA ZGODNOSC TYPOW FUNKCJI
+C AKTUALNEJ(PA) I FORMALNEJ (PF).
+C POZOSTALE PARAMETRY JAK W MPARPF.
+C W RAZIE POTRZEBY NADAJE WARTOSC ZMIENNEJ DCONTR.
+C SYGNALIZOWANE BLEDY:
+C 631 - NIEZGODNE TYPY FUNKCJI AKTUALNEJ I FORMALNEJ
+C 633 - TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY NIZ TYP
+C FUNKCJI FORMALNEJ
+C OPIS W DOKUMENTACJI: ?3.7.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 663
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL DCONTR
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C *CALL MTPC
+C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
+ COMMON /MTPC/ PRFXR, PRFXL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
+C
+C.....POBRANIE TYPU FUNKCJI AKTUALNEJ
+ TRDIM = IPMEM(PA-4)
+ TRBAS = IPMEM(PA-3)
+C.....POBRANIE TYPU FUNKCJI FORMALNEJ
+ TLDIM = IPMEM(PF-4)
+ TLBAS = IPMEM(PF-3)
+C.....MODYFIKACJA TYPU FUNKCJI FORMALNEJ W OPARCIU O REKORD KONTROLI
+ OBJL = IPMEM(CLLREC+3)
+ CALL MREPTP (TLDIM, TLBAS, OBJL)
+C.....POBRANIE SLOW ZEROWYCH TYPOW BAZOWYCH - POLA T
+ AZW = IAND (IPMEM(TRBAS), 15)
+ FZW = IAND (IPMEM(TLBAS), 15)
+C*****************************
+ IF ( (TLDIM .GT. 0) .OR. (TRDIM .GT. 0) ) GOTO 2000
+C*******************
+C TYPY NIETABLICOWE
+C
+C.....ROZPOZNANIE PRZYPADKU TYPOW PIERWOTNYCH
+ IF (AZW .GE. 8) GOTO 100
+ IF (FZW .GE. 8) GOTO 200
+ GOTO 1000
+C --SKOK, GDY ZADEN TYP NIE JEST PIERWOTNY
+C*****TYPY PIERWOTNE
+C.....TRBAS (FUNKCJA AKTUALNA) JEST PIERWOTNY
+ 100 IF (TLBAS .EQ. NRUNIV) RETURN
+ IF (TLBAS .EQ. TRBAS) RETURN
+ GOTO 9100
+C --SKOK GDY TYPY SA NIEZGODNE
+C.....TLBAS (FUNKCJA FORMALNA) JEST PIERWOTNY
+ 200 IF (TRBAS .EQ. NRUNIV) RETURN
+C GOTO 9100
+C
+C*****TYPY ZLOZONE NIETABLICOWE
+ 1000 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN
+C.....OBYDWA TYPY SA KLASOWE, SYSTEMOWE LUB FORMALNE
+ IF (FZW .EQ. 6) GOTO 1100
+ IF (AZW .EQ. 6) GOTO 9200
+C --TEN SKOK GDY TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY -
+C SYGNALIZACJA BLEDU
+C.....OBYDWA TYPY SA KLASOWE LUB SYSTEMOWE
+C TYP FUNKCJI FORMALNEJ MUSI PREFIKSOWAC TYP FUNKCJI AKTUALNEJ
+ IF (MPRFSQ (TLBAS, TRBAS) .NE. 0) GOTO 9000
+C --SKOK GDY TAK NIE JEST
+C ...DODATKOWA KONTROLA DYNAMICZNA JEST POTRZEBNA, GDY WYWOLYWANY MODUL
+C JEST WIRTUALNY
+ IF (IPMEM(CLLREC+2) .NE. 2) DCONTR = .TRUE.
+ RETURN
+C
+C.....TYP TLBAS FUNKCJI FORMALNEJ JEST FORMALNY
+ 1100 IF (AZW .EQ. 6) GOTO 1200
+C ...TU TYP TLBAS JEST FORMALNY, TRBAS NIE - ZAWSZE POTRZEBNA KONTROLA
+C DYNAMICZNA
+ DCONTR = .TRUE.
+ RETURN
+C.....OBYDWA TYPY SA FORMALNE
+C - GDY WYWOLYWANY PROTOTYP JEST WIRTUALNY POTRZBNA KONTROLA DYNAMICZNA
+C - W PRZECIWNYM PRZYPADKU ORAZ GDY TYPY ZAWSZE POCHODZA Z TEGO SAMEGO
+C NIE MA KONTROLI DYNAMICZNEJ
+ 1200 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 1250
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .EQ. 1) RETURN
+C ...POTRZEBNA KONTROLA DYNAMICZNA
+ 1250 DCONTR = .TRUE.
+ RETURN
+C
+C
+C********************
+C TYPY ZLOZONE TABLICOWE (CO NAJMNIEJ JEDEN)
+ 2000 IF (TLDIM-TRDIM) 2100, 2200, 2300
+C
+C.....TLDIM<TRDIM (ZAWSZE KONTROLA DYNAMICZNA)
+C POPRAWNE WOWCZAS, GDY TLBAS JEST FORMALNY LUB UNIWERSALNY
+C - GDY OBA SA TYM SAMYM TYPEM FORMALNYM, TO POPRAWNE GDY
+C - POCHODZA Z ROZNYCH OBIEKTOW
+C - PROTOTYP WYWOLYWANY JEST WIRTUALNY
+ 2100 IF (TLBAS .EQ. NRUNIV) RETURN
+ IF (FZW .NE. 6) GOTO 9100
+ DCONTR = .TRUE.
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .NE. 1) RETURN
+ IF (IPMEM(CLLREC+2) .NE. 0) RETURN
+ GOTO 9100
+C
+C.....TLDIM=TRDIM
+C POPRAWNE GDY
+C - OBA TYPY BAZOWE SA ROWNE
+C - TYP TLBAS JEST FORMALNY
+C - TLBAS LUB TRBAS JEST UNIWERSALNY
+ 2200 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN
+ IF (FZW .EQ. 6) GOTO 2250
+ IF (AZW .EQ. 6) GOTO 9200
+C --SKOK DO SYGNALIZACJI TYPU SLABIEJ OKRESLONEGO
+ IF (TLBAS .EQ. TRBAS) RETURN
+ GOTO 9100
+C
+ 2250 PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .NE. 1) DCONTR = .TRUE.
+ IF (IPMEM (CLLREC+2) .EQ. 1) DCONTR = .TRUE.
+ RETURN
+C
+C.....TLDIM>TRDIM
+C POPRAWNE JEDYNIE, GDY OBA TYPY SA FORMALNE LUB UNIWERSALNE
+ 2300 IF (TRBAS .EQ. NRUNIV) RETURN
+ IF (AZW .NE. 6) GOTO 9100
+ IF (TLBAS .EQ. NRUNIV) RETURN
+ IF (FZW .NE. 6) GOTO 9200
+C ...OBYDWA SA FORMALNE
+ DCONTR = .TRUE.
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .NE. 1) RETURN
+ IF (IPMEM(CLLREC+2) .NE. 0) RETURN
+ GOTO 9100
+C
+C***********************************
+C SYGNALIZACJE BLEDOW
+C BADANIE OKRESLONOSCI TYPOW
+ 9000 IF ( (AZW .EQ. 6) .AND. (FZW .NE. 6)) GOTO 9200
+ IF ( (TLBAS .NE. NRCOR) .AND.
+ X ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC) ) )
+ X GOTO 9200
+C
+C.....TYPY NIEZGODNE
+ 9100 CALL MERR(631, AID)
+ RETURN
+C.....TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY
+ 9200 CALL MERR(633, AID)
+ RETURN
+ END
+*DECK MPIO2
+ SUBROUTINE MPIO2 (DCONTR)
+C--------------PROCEDURA POMOCNICZA KONTROLUJACA ZGODNOSC TYPOW
+C PARAMETROW FORMALNYCH 'INPUT'/'OUTPUT' DRUGIEGO
+C RZEDU - TO ZNACZY WYSTEPUJACYCH W LISTACH ODPO-
+C WIADAJACEJ MODULOWI FORMALNEMU (PF) ORAZ ODPO-
+C WIADAJACEJ MODULOWI AKTUALNEMU (APROT)
+C PFPF, PFPA - OPISY UZGADNIANYCH PARAMETROW
+C /EWENTUALNA NIEZGODNOSC RODZAJOW PARAMETROW SYGNA-
+C LIZOWANA JEST PRZEZ PROCEDURE MPARPF
+C SYGNALIZOWANE BLEDY:
+C 628 - NIEUZGODNIONE NAGLOWKI - TYPY PARAMETROW SA
+C NIEZGODNYCH RODZAJOW
+C 629 - NIEUZGODNIONE NAGLOWKI - TYPY PARAMETROW MAJA
+C ROZLACZNE SEKWENCJE PREFIKSOWE
+C 634 - NIEUZGODNIONE NAGLOWKI - TYP PARAMETRU W LISCIE
+C AKTUALNEJ JEST SLABIEJ OKRESLONY
+C
+C OPIS W DOKUMENTACJI: ?3.7.3.5
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 974
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL DCONTR,BTEST
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C *CALL MTPC
+C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
+ COMMON /MTPC/ PRFXR, PRFXL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
+C *CALL MPI2
+C......BLOK KOMUNIKACJI PROCEDUR MPARPF ORAZ MPIO2
+ LOGICAL DCLASS, AFORM
+ COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS,
+ X AFORM
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14 !!
+C
+C.....POBRANIE TYPOW PARAMETROW PFPF I PFPA
+ TRDIM = IPMEM(PFPA-4)
+ TRBAS = IPMEM(PFPA-3)
+ AZW = IAND (IPMEM(TRBAS), 15)
+ TLDIM = IPMEM(PFPF-4)
+ TLBAS = IPMEM(PFPF-3)
+ OBJL = IPMEM(CLLREC+3)
+C.....ODDZIELENIE PRZYPADKU, GDY KTORYS Z TYPOW SAM JEST PARAMETREM PF
+C LUB APROT
+ IF (IPMEM(TLBAS-1) .EQ. PF) GOTO 1000
+C --SKOK GDY TYP W MODULE FORMALNYM JEST WLASNYM PARAMETREM TEGO MODULU
+ IF (AZW .NE. 6) GOTO 2000
+C --SKOK GDY TYP W MODULE AKTUALNYM NIE JEST FORMALNY
+ IF (IPMEM(TRBAS-1) .EQ. APROT) GOTO 1000
+ IF (AFORM) GOTO 2000
+ IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .EQ. 1) GOTO 1000
+C --SKOK GDY TYP W MODULE AKTUALNYM JEST WLASNYM PARAMETREM MODULU
+ GOTO 2000
+C
+C*****************************
+C W CO NAJMNIEJ JEDNYM MODULE TYP JEST WLASNY W DRUGIM TEZ POWINIEN
+C BYC WLASNYM PARAMETREM I OBA POWINNY SOBIE ODPOWIADAC
+ 1000 IF (TLBAS .NE. NRUNIV) GOTO 1100
+ IF (TLDIM .LE. TRDIM) RETURN
+ GOTO 9100
+ 1100 IF (TRBAS .NE. NRUNIV) GOTO 1200
+ IF (TLDIM .GE. TRDIM) RETURN
+ GOTO 9100
+C.....ZADEN TYP NIE JEST UNIWERSALNY, OBYDWA POWINNY BYC WLASNE I SOBIE
+C ODPOWIADAJACE
+ 1200 IF (AZW .NE. 6) GOTO 9100
+ IF (IPMEM(TRBAS-1) .EQ. APROT) GOTO 1300
+ IF (AFORM) GOTO 9100
+ IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .NE. 1) GOTO 9100
+ IF (IPMEM(TLBAS-1) .NE. PF) GOTO 9100
+ IF (TLDIM .NE. TRDIM) GOTO 9100
+C.....OBYDWA TYPY SA WLASNE I MAJA ROWNE WYMIARY,
+C SPRAWDZENIE ODPOWIEDNIOSCI
+ AZW = LPMF+1
+ 1300 IF (IPMEM(AZW) .EQ. TLBAS) GOTO 1400
+ AZW = AZW+2
+ GOTO 1300
+ 1400 TLBAS = IPMEM(AZW+1)
+ IF (TLBAS .EQ. TRBAS) RETURN
+ GOTO 9100
+C
+C****************************************************
+C*******TYPY NIE SA WLASNYMI PARAMETRAMI MODULOW
+C.....EWENTUALNA MODYFIKACJA TLBAS W OPARCIU O DUZY REKORD KONTROLI
+ 2000 CALL MREPTP (TLDIM, TLBAS, OBJL)
+ FZW = IAND(IPMEM(TLBAS), 15)
+ IF ( (TLDIM .NE. 0) .OR. (TRDIM .NE. 0) ) GOTO 3000
+C
+C*********************
+C TYPY NIETABLICOWE
+ IF ( (TRBAS .EQ. NRUNIV) .OR. (TLBAS .EQ. NRUNIV) ) RETURN
+C.....ODDZIELENIE TYPOW PRYMITYWNYCH
+ IF (FZW .GE. 8) GOTO 2200
+ IF (AZW .GE. 8) GOTO 2200
+C.....ZADEN TYP NIE JEST PRYMITYWNY
+C.....ODDZILENIE TYPOW FORMALNYCH
+ IF (FZW .EQ. 6) GOTO 2300
+ IF (AZW .EQ. 6) GOTO 9300
+C --TEN SKOK GDY TYP W MODULE FORMALNYM JEST STATYCZNIE OKRESLONY,
+C NATOMIAST W MODULE AKTUALNYM JEST FORMALNY
+C **OBYDWA TYPY SA STATYCZNIE OKRESLONE - KLASOWE LUB SYSTEMOWE
+ IF (TLBAS .EQ. TRBAS) GOTO 2100
+ IF (MPRFSQ (TLBAS, TRBAS) .EQ. -1) GOTO 9200
+C --TYPY MAJA ROZLACZNE SEKWENCJE PREFIKSOWE - SKOK DO
+C SYGNALIZACJI BLEDU
+ IF (DCLASS) DCONTR = .TRUE.
+ IF (IPMEM(CLLREC+2) .NE. 0) DCONTR = .TRUE.
+ RETURN
+C DODATKOWA KONTROLA JEST POTRZEBNA GDY MODUL AKTUALNY NIE JEST
+C RZECZYWISTY
+ 2100 IF ((IPMEM(CLLREC+2) .NE. 0) .AND. DCLASS) DCONTR = .TRUE.
+C TYPY BYLY ROWNE - DODATKOWA KONTROLA DYNAMICZNA JEST
+C POTRZEBNA GDY JEDNOCZESNIE MODUL WYWOLYWANY BYL WIRTUALNY
+C ORAZ MODUL AKTUALNY NIE BYL RZECZYWISTY
+ RETURN
+C
+C **CO NAJMNIEJ JEDEN TYP JEST PRYMITYWNY, DRUGI POWINIEN BYC MU ROWNY
+ 2200 IF(TLBAS .EQ. TRBAS) RETURN
+ GOTO 9100
+C
+C **CO NAJMNIEJ TYP TLBAS JEST FORMALNY
+C TRBAS MOZE BYC WOWCZAS KLASOWY, SYSTEMOWY LUB FORMALNY
+ 2300 IF (AZW .EQ. 6) GOTO 2400
+C ...TYLKO TLBAS JEST FORMALNY - POTRZEBNA KONTROLA DYNAMICZNA
+ 2350 DCONTR = .TRUE.
+ RETURN
+C ...OBYDWA TYPY SA FORMALNE
+C KONTROLA DYNAMICZNA JEST ZAWSZE KONIECZNA, GDY WYWOLYWANY MODUL JEST
+C WIRTUALEM
+ 2400 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 2350
+C ...KONTROLI DYNAMICZNEJ NIE MA, GDY TYP JEST TEN SAM I ZAWSZE
+C POCHODZI Z TEGO SAMEGO OBIEKTU
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .EQ. 1) RETURN
+ DCONTR = .TRUE.
+ RETURN
+C
+C
+C****************************************
+C TYPY TABLICOWE
+ 3000 IF (TLDIM - TRDIM) 3100, 3200, 3300
+C
+C.....TLDIM<TRDIM
+C MOZE BYC POPRAWNE JEDYNIE GDY TLBAS JEST FORMALNY LUB UNIWERSALNY
+C GDY TYPY SA TYM SAYM TYPEM FORMALNYM, TO POPRAWNE GDY POCHODZA Z
+C ROZNYCH OBIEKTOW LUB APROT ALBO PROTOTYP WYWOLYWANY SA WIRTUALNE
+ 3100 IF (TLBAS .EQ. NRUNIV) RETURN
+ IF (FZW .NE. 6) GOTO 9100
+ IF (IPMEM(CLLREC+2) .NE. 0) GOTO 3150
+ IF (BTEST(IPMEM(APROT),11)) GOTO 3150
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .EQ. 1) GOTO 9100
+ 3150 DCONTR = .TRUE.
+ RETURN
+C
+C.....TLDIM=TRDIM
+C POPRAWNE, GDY OBYDWA TYPY SA STATYCZNIE OKRESLONE I ROWNE LUB
+C TLBAS JEST FORMALNY LUB
+C TLBAS, TRBAS JEST UNIWERSALNY LUB
+C OBYDWA SA FORMALNE - WTEDY GDY PROTOTYP WYWOLYWANY NIE JEST WIRTUALNY
+C ANI MODUL AKTUALNY NIE JEST WIRTUALNY, TO KONTROLA DYNAMICZNA NIE JEST
+C POTRZEBNA O ILE TYPY SA ROWNE I ZAWSZE POCHODZA Z TEGO SAMEGO OBIEKTU
+ 3200 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN
+ IF (FZW .EQ. 6) GOTO 3210
+ IF (TLBAS .EQ. TRBAS) RETURN
+ IF (AZW .EQ. 6) GOTO 9300
+ GOTO 9100
+C ...TYP TLBAS JEST FORMALNY
+ 3210 IF (AZW .EQ. 6) GOTO 3230
+ 3220 DCONTR = .TRUE.
+ RETURN
+C ...OBYDWA TYPY SA FORMALNE
+ 3230 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 3220
+ IF (BTEST(IPMEM(APROT), 11)) GOTO 3220
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON (Z) .NE. 1) GOTO 3220
+ RETURN
+C
+C.....TLDIM>TRDIMCPOPRAWNE JEDYNIE, GDY OBYDWA TYPY SA FORMALNE LUB
+C UNIWERSALNE
+ 3300 IF (TRBAS .EQ. NRUNIV) RETURN
+ IF (AZW .NE. 6) GOTO 9100
+ IF (TLBAS .EQ. NRUNIV) RETURN
+ IF (FZW .NE. 6) GOTO 9300
+C ...OBYDWA TYPY SA FORMALNE
+ DCONTR = .TRUE.
+ PRFXR = AOB
+ PRFXL = OBJL
+ IF (MTPCON(Z) .NE. 1) RETURN
+ IF (IPMEM(CLLREC+2) .NE. 0) RETURN
+ IF (BTEST(IPMEM(APROT), 11)) RETURN
+ GOTO 9100
+C
+C***************************************
+C SYGNALIZACJE BLEDOW
+ 9100 CALL MERR(628, AID)
+ RETURN
+C BADANIE OKRESLONOSCI TYPOW
+ 9200 IF ( (TLBAS .NE. NRCOR) .AND.
+ X ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC))) GOTO 9300
+ CALL MERR (629, AID)
+ RETURN
+ 9300 CALL MERR(634, AID)
+ RETURN
+ END
+*DECK MPARIO
+ INTEGER FUNCTION MPARIO (ATDIM, ATBASE, ID, AOB)
+C-------------BADA ZGODNOSC TYPU PARAMETRU AKTUALNEGO (ATDIM, ATBASE)
+C Z TYPEM PARAMETRU FORMALNEGO (INPUT/OUTPUT).
+C ID - IDENTYFIKATOR UZYWANY W SYGNALIZACJI BLEDOW (NP. NAZWA
+C ZMIENNEJ, FUNKCJI)
+C AOB - OBIEKT W CIAGU SL, Z KTOREGO BRANY JEST PARAMETR
+C AKTUALNY, LUB 0 - GDY NIE JEST DOSTEPNY PRZEZ
+C DISPLAY
+C / WARTOSC FUNKCJI INFORMUJE O KONWERSJI LUB KONTROLI
+C DYNAMICZNEJ - TAK JAK W MSUBST.
+C ODPOWIEDNIOSC JEST NASTEPUJACA:
+C - PARAMETR INPUT
+C LEWA STRONA - PARAMETR FORMALNY
+C PRAWA STRONA - PARAMETR AKTUALNY
+C - PARAMETR OUTPUT
+C LEWA STRONA - PARAMETR AKTUALNY
+C PRAWA STRONA - PARAMETR FORMALNY
+C DODATKOWE UWAGI KONTEKSTOWE:
+C - W PRZYPADKU FUNKCJI I PROCEDUR WIRTUALNYCH - TYPY FOR-
+C MALNE SA ZAWSZE ZGODNE (ROZNICA W DZIALANIU MSUBST),
+C WYMAGANA JEST JEDNAK ZAWSZE KONTROLA DYNAMICZNA
+C - GDY FUN/PROC JEST WIRTULNA LUB FORMALNA - TYPY KLASOWE SA
+C ZGODNE JESLI SA WE WSPOLNEJ SEKWENCJI PREFIKSOWEJ- KONTRO-
+C LA DYNAMICZNA ROWNIEZ ZAWSZE POTRZEBNA
+C
+C SYGNALIZOWANE BLEDY
+C Z PROCEDURY MSUBST
+C 609 - NIEZGODNE TYPY
+C 610 - ROZLACZNE SEKWENCJE PREFIKSOWE
+C
+C OPIS W DOKUMENTACJI: ?3.6.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 519
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL FNFORM
+C FNFORM MA WARTOSC .TRUE. GDY PARAMETR FORMALNY NIE JEST
+C TYPU FORMALNEGO
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C
+C
+ FNFORM = .TRUE.
+ MPARIO = 0
+C...... KONTROLA WYWOLANIA UNIWERSALNEGO
+ IF (UNICLL) RETURN
+ IF (IPMEM(CLLREC+7) .EQ. 0) RETURN
+C
+C------POBRANIE TYPU PARAMETRU FORMALNEGO
+ PF = IPMEM(CLLREC+5)
+ PF = IPMEM(PF)
+C ... PF OPIS PARAMETRU FORMALNEGO
+ FDIM = IPMEM(PF-4)
+ FBAS = IPMEM(PF-3)
+C ...FDIM, FBAS - NIEZMODYFIKOWANY TYP PARAMETRU FORM.
+C
+ FOB = IPMEM(CLLREC+3)
+C PARAMETR FORMALNY "POCHODZI" Z TEGO SAMEGO OBIEKTU, CO OBIEKT
+C WYWOLYWANY
+C
+C------BADANIE RODZAJU OBIEKTU WYWOLYWANEGO
+C
+ IF (IPMEM(CLLREC+2) .NE. 0) GOTO 1000
+C
+C------ WYWOLYWANY ZWYKLY OBIEKT
+C...... MODYFIKACJA TYPU PARAMETRU FORMALNEGO
+ IF ( IAND( IPMEM(FBAS), 15) .EQ. 6) FNFORM = .FALSE.
+ CALL MREPTP(FDIM, FBAS, FOB)
+C......BADANIE RODZAJU PARAMETRU FORMALNEGO
+ IF (IPMEM(CLLREC+7) .EQ. 6) GOTO 95
+ IF (IPMEM(CLLREC+7) .EQ. 2) GOTO 100
+C --- KONTROLA PARAMETRU INPUT
+ TLDIM = FDIM
+ TLBAS = FBAS
+ OBJL = FOB
+ IDL = ID
+ TRDIM = ATDIM
+ TRBAS = ATBASE
+ IDR = ID
+ OBJR = AOB
+C
+ MPARIO = MSUBST (Z)
+C Z - SLEPY PARAMETR
+ IF (FNFORM) RETURN
+C....ZMIANA INFORMACJI O KONTROLI DYNAMICZNEJ GDY PARAMETR
+C FORMALNY JEST TYPU FORMALNEGO
+ 90 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 5) ) MPARIO =
+ X MPARIO + 1
+ RETURN
+C ---KONTROLA 'INOUT' - JAK OUTPUT PRZY PIERWSZYM WYWOLANIU, INPUT PRZY
+C DRUGIM
+ 95 IPMEM(CLLREC+7) = -6
+C --- KONTROLA PARAMETRU OUTPUT
+ 100 TLDIM = ATDIM
+ TLBAS = ATBASE
+ IDL = ID
+ OBJL = AOB
+ TRBAS = FBAS
+ TRDIM = FDIM
+ IDR = ID
+ OBJR = FOB
+C
+ MPARIO = MSUBST(Z)
+ IF (FNFORM) RETURN
+ 110 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 4) ) MPARIO =
+ X MPARIO + 2
+ RETURN
+C
+C------ OBIEKTY FORMALNE I WIRTUALNE
+C ---UWAGA: OBIEKTY WIRTUALNE NIGDY NIE SA DOSTEPNE PRZEZ DISPLAY
+ 1000 IF (IPMEM(CLLREC+2) .EQ. 1) FOB = 0
+C...... MODYFIKACJA TYPU PARAMETRU FORMALNEGO
+ IF ( IAND( IPMEM(FBAS), 15) .EQ. 6) FNFORM = .FALSE.
+ CALL MREPTP(FDIM, FBAS, FOB)
+C...... BADANIE RODZAJU PARAMETRU FORMALNEGO
+ IF (IPMEM(CLLREC+7) .EQ. 2) GOTO 1100
+C --- KONTROLA PARAMETRU INPUT
+ TLDIM = FDIM
+ TLBAS = FBAS
+ IDL = ID
+ OBJL = FOB
+ TRDIM = ATDIM
+ TRBAS = ATBASE
+ IDR = ID
+ OBJR = AOB
+C
+ MPARIO = MSUBST (Z)
+ IF (FNFORM) GOTO 1200
+ GOTO 90
+C --- KONTROLA PARAMETRU OUTPUT
+ 1100 TLDIM = ATDIM
+ TLBAS = ATBASE
+ IDL = ID
+ OBJL = AOB
+ TRDIM = FDIM
+ TRBAS = FBAS
+ IDR = ID
+ OBJR = FOB
+C
+ MPARIO = MSUBST (Z)
+C...... SPRAWDZENIE, CZY NIE SA TO TYPY KLASOWE- DLA NICH ZAWSZE
+C KONTROLA DYNAMICZNA
+ IF ( .NOT. FNFORM) GOTO 110
+ 1200 IF(MPARIO .NE. 0) RETURN
+C ... PF - OPIS PARAMETRU FORMALNEGO
+ IF (IPMEM(PF-4).NE.0) RETURN
+ PF = IPMEM(PF-3)
+C ..PF - OPIS TYPU PARAMETRU
+ PF = IAND (IPMEM(PF), 15)
+ IF (PF .GE. 8) RETURN
+ MPARIO = 3
+ RETURN
+ END
+*DECK MSUBST
+ INTEGER FUNCTION MSUBST (X)
+C X - SLEPY PARAMETR
+C
+C-------------PROCEDURA BADA POPRAWNOSC INSTRUKCJI PODSTAWIENIA.
+C JEST ROWNIEZ WYWOLYWANA W PROCEDURZE KONTROLI
+C TYPOW PARAMETROW FORMALNYCH I AKTUALNYCH.
+C ZNACZENIE :
+C - TLDIM, TLBAS - TYP LEWEJ STRONY INSTRUKCJI PODSTAWIENIA,
+C OBJL - PROTOTYP, Z KTOREGO POCHODZI, LUB 0 - NIEDOSTEPNA
+C PRZEZ DISPLAY
+C IDL - IDENTYFIKATOR LEWEJ STRONY (DO SYGNALIZACJI
+C BLEDOW),
+C - ANALOGICZNIE DLA PRAWEJ STRONY - TRDIM, TRBAS,
+C OBJR .
+C // WARTOSC FUNKCJI OKRESLA RODZAJ KONWERSJI LUB KONTROLI
+C DYNAMICZNEJ :
+C 0 - OBIE STRONY SA TEGO SAMEGO TYPU,
+C 1 - INTEGER := REAL
+C 2 - REAL := INTEGER
+C DYNAMICZNA KONTROLA TYPOW
+C 3 - OBA TYPY OKRESLONE (STATYCZNIE)
+C 4 - TYP LEWEJ STRONY FORMALNY, PRAWEJ OKRESLONY
+C 5 - TYP LEWEJ STRONY OKRESLONY, PRAWEJ FORMALNY
+C 6 - TYPY OBYDWU STRON FORMALNE
+C ----SYGNALIZOWANE BLEDY
+C 609 - NIEZGODNE TYPY W PODSTAWIENIU
+C 610 - TYPY W PODSTAWIENIU MAJA ROZLACZNE SEKWENCJE PREFI-
+C KSOWE
+C 636 - NIEDOZWOLONE UZYCIE SEMAFORA
+C
+C OPIS W DOKUMENTACJI: ?2.7
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 617
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL MTPC
+C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
+ COMMON /MTPC/ PRFXR, PRFXL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
+C
+C INICJOWANA WARTOSC MSUBST - 3 ODPOWIADAJACA KONTROLI DYNAMICZNEJ
+ MSUBST = 3
+ IF ( (TLDIM .EQ. 0) .AND. (TLBAS .EQ. NRUNIV) ) RETURN
+ IF ( (TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRUNIV) ) RETURN
+C POWROTY - GDY JEDEN Z TYPOW JEST UNIWERSALNY
+C
+ TPL = IAND (IPMEM(TLBAS), 15)
+ TPR = IAND(IPMEM(TRBAS), 15)
+C TPL I TPR - POLA T Z OPISU TYPOW TLBAS I TRBAS
+ IF ( (TLDIM .NE. 0) .OR. (TRDIM .NE. 0) ) GOTO 1000
+C SKOK DO BADANIA PODSTAWIEN DLA TYPOW TABLICOWYCH
+C------ TYPY NIETABLICOWE - ZADEN Z NICH NIE JEST JUZ UNIWERSALNY
+C
+ GOTO (9000, 100, 100, 9500, 100, 200, 100, 300, 9100, 400, 500,
+ X 400, 9000, 9000), TPL
+C
+C...... TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM
+ 100 GOTO (9000, 110, 110, 9500, 110, 150, 110, 9000, 9100, 9000,
+ X 9000, 9000, 9000, 130), TPR
+C ... TPR JEST ROWNIEZ TYPEM KLASOWYM LUB SYSTEMOWYM
+C SPRAWDZENIE PREFIKSOWANIA
+ 110 IF ( MPRFSQ(TLBAS, TRBAS) ) 120, 130, 140
+C SEKWENCJE PREFIKSOWE ROZLACZNE - PODSTAWIENIE MOZE BYC POPRAW-
+C NE JEDYNIE GDY JEDEN Z TYPOW JEST SYSTEMOWY
+ 120 IF ( (TRBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRCOR) ) RETURN
+ IF ( (TRBAS .EQ. NRPROC) .OR. (TLBAS .EQ. NRPROC) ) RETURN
+ CALL MERR(610, IDL)
+ RETURN
+C
+C TPL JEST PREFIKSEM TPR - KONTROLA DYNAMICZNA NIE JEST
+C POTRZEBNA, TPR MOZE BYC ROWNIEZ NONE
+ 130 MSUBST = 0
+ RETURN
+C
+C TPR JEST PREFIKSEM TPL - KONTROLA DYNAMICZNA JEST POTRZEBNA
+C KONTEKSTOWO SYTUACJA JEST POPRAWNA
+ 140 RETURN
+C ... TPR JEST FORMALNY
+ 150 MSUBST = 5
+ RETURN
+C
+C
+C...... TPL JEST TYPEM FORMALNYM - TPR MUSI BYC TYPEM FORMALNYM, KLASO-
+C WYM, SYSTEMOWYM LUB NONE
+ 200 MSUBST = 4
+ GOTO (9000, 210, 210, 9500, 210, 220, 210, 9000, 9100, 9000,
+ X 9000, 9000, 9000, 210) , TPR
+C ...TPR - KLASOWY, SYSTEMOWY LUB NONE
+ 210 RETURN
+C ... TPR - FORMALNY
+ 220 MSUBST = 6
+ PRFXR = OBJR
+ PRFXL = OBJL
+ IF ( MTPCON(Z) .EQ. 1) MSUBST = 0
+ RETURN
+C
+C
+C...... TPL JEST ARYTMETYCZNY, TPR TEZ MUSI BYC ARYTMETYCZNY
+ 300 IF ( (TRBAS .NE. NRINT) .AND. (TRBAS .NE. NRRE) ) GOTO 9000
+ MSUBST = 0
+ IF (TLBAS .EQ. TRBAS) RETURN
+C TU - TYPY ROZNE - POTRZEBNA KONWERSJA
+ MSUBST = 2
+ IF (TLBAS .EQ. NRINT) MSUBST = 1
+ RETURN
+C
+C...... TPL - INNY PRYMITYWNY, TPR MUSI BYC MU ROWNE
+ 400 MSUBST = 0
+ IF (TLBAS .EQ. TRBAS) RETURN
+ GOTO 9000
+C.......TPL - FILE, TPR MUSI BYC FILE LUB NONE
+ 500 MSUBST = 0
+ IF ((TLBAS .EQ. TRBAS) .OR. (TRBAS .EQ. NRNONE)) RETURN
+ GOTO 9000
+C
+C
+C------ CO NAJMNIEJ JEDEN TYP JEST TABLICOWY
+C
+ 1000 IF (TLDIM - TRDIM) 2000, 3000, 4000
+C...... PRZYPADEK TLDIM < TRDIM
+C WOWCZAS PODSTAWIENIE JEST POPRAWNE JEDYNIE, GDY TLBAS JEST FOR-
+C MALNY LUB UNIWERSALNY. W PRZYPADKU, GDY OBA TYPY SA TYM SAMYM
+C TYPEM FORMALNYM - MUSZA POCHODZIC Z ROZNYCH OBIEKTOW.
+ 2000 IF (TPL .EQ. 4) RETURN
+C POWROT DLA TYPU UNIWERSALNEGO
+ IF (TPL .NE. 6) GOTO 9000
+C SKOK DO SYGNALIZACJI BLEDU DLA TYPU NIEFORMALNEGO
+ MSUBST = 4
+ IF (TPR .EQ. 6) MSUBST = 6
+ GOTO 8000
+C
+C......PRZYPADEK TLDIM = TRDIM
+C POPRAWNE, GDY
+C - OBA TYPY BAZOWE SA ROWNE
+C - CO NAJMNIEJ JEDEN JEST FORMALNY LUB UNIWERSALNY
+ 3000 IF ( (TPL .EQ. 4) .OR. (TPR .EQ. 4) ) RETURN
+C POWROT - GDY JEDEN Z TYPOW JEST UNIWERSALNY
+C
+ IF ( (TPL .EQ. 6) .AND. (TPR .EQ. 6) ) GOTO 3300
+ IF (TPL .EQ. 6) GOTO 3100
+ IF (TPR .EQ. 6) GOTO 3200
+C SKOKI ROZDZIELAJACE PRZYPADKI TYPOW FORMALNYCH
+C ... PRZYPADEK, GDY TYPY NIE SA FORMALNE
+ MSUBST = 0
+ IF (TLBAS .EQ. TRBAS) RETURN
+C TU - NIEROWNE TYPY NIEFORMALNE - SKOK DO SYGNALIZACJI BLEDOW
+ GOTO 9000
+C
+C ... TLBAS JEST FORMALNY, TRBAS NIE
+ 3100 MSUBST = 4
+ RETURN
+C ... TRBAS JEST FORMALNY, TLBAS NIE
+ 3200 MSUBST = 5
+ RETURN
+C ... TLBAS I TRBAS SA FORMALNE, SPRAWDZENIE,CZY SA ROWNE I LOKALNE
+C (WTEDY NIE MA KONTROLI DYNAMICZNEJ)
+ 3300 MSUBST = 6
+ PRFXR = OBJR
+ PRFXL = OBJL
+ IF ( MTPCON(Z) .EQ. 1) MSUBST = 0
+ RETURN
+C
+C...... PRZYPADEK TLDIM > TRDIM
+C POPRAWNE,GDY:
+C - TYP NONE Z PRAWEJ STRONY
+C - TRBAS JEST FORMALNY LUB UNIWERSALNY, W PRZYPADKU GDY OBA
+C TYPY SA TYM SAMYM TYPEM FORMALNYM CO NAJMNIEJ JEDEN Z NICH
+C MUSI BYC NIELOKALNY
+ 4000 MSUBST = 0
+ IF (TPR .EQ. 4) RETURN
+C POWROT DLA TYPU UNIWERSALNEGO Z PRAWEJ STRONY
+ IF ( (TPR .EQ. 14) .AND. (TRDIM .EQ. 0) ) RETURN
+C POWROT DLA STALEJ NONE
+ IF (TPR .NE. 6) GOTO 9000
+C SKOK DO SYGNALIZACJI BLEDU DLA TYPU NIEFORMALNEGO
+ MSUBST = 5
+ IF (TPL .EQ. 6) MSUBST = 6
+C GOTO 8000 - PRZEJSCIE DO BADANIA TYPOW TABLICOWYCH
+C
+C
+C------ BADANIE ZGODNOSCI FORMALNYCH TYPOW TABLICOWYCH
+C
+ 8000 PRFXR = OBJR
+ PRFXL = OBJL
+ IF ( MTPCON(Z) .EQ. 1) GOTO 9000
+ RETURN
+C
+C
+C
+C------SYGNALZACJA BLEDOW
+ 9000 IF (TPR .EQ. 9) GOTO 9100
+ CALL MERR(609, IDL)
+ 9500 RETURN
+ 9100 IF (TPL .EQ. 9) CALL MERR(636, IDL)
+ IF (TPR .EQ. 9) CALL MERR(636, IDR)
+ RETURN
+ END
+*DECK MEQUAL
+ SUBROUTINE MEQUAL (CASE)
+C-------------PROCEDURA BADA ZGODNOSC ARGUMENTOW RELACJI = I =/= .
+C TYPY PRAWEGO I LEWEGO ARGUMENTU PRZEKAZANE SA PRZEZ
+C BLOK /SEMANT/ , SA TO :
+C TLDIM, TLBAS - DLA LEWEGO ARGUMENTU
+C TRDIM, TRBAS - DLA PRAWEGO ARGUMENTU.
+C ZMIENNE OBJL, OBJR - NUMERY PROTOTYPOW OBIEKTOW, KTORYCH
+C ATRYBUTAMI SA ODPOWIEDNIO LEWY I PRAWY ARGUMENT OPERACJI.
+C SA ONE ROWNE ZERU, GDY ARGUMENTY NIE SA DOSTEPNE PRZEZ
+C DISPLAY.
+C ZMIENNE IDL ORAZ IDR SLUZA DO IDENTYFIKACJI BLEDOW - SA
+C TO IDENTYFIKATORY LEWEGO I PRAWEGO ARGUMENTU.
+C // WARTOSCI PARAMETRU CASE PRZY WYJSCIU OKRESLAJA :
+C 1 - OBA ARGUMENTY SA INTEGER
+C 2 - CO NAJMNIEJ JEDEN ARGUMENT JEST TYPU REAL, DRUGI
+C MUSI BYC ARYTMETYCZNY. ZMIENNE CONVL I CONVR OKRE-
+C SLAJA EWENTUALNA KONWERSJE
+C 3 - OBA ARGUMENTY SA BOOLOWSKIE
+C 4 - OBA ARGUMENTY SA TYPU CHAR
+C 5 - OBA ARGUMENTY SA TYPU REFERENCYJNEGO (ROWNIEZ
+C TABLICOWEGO, TEGO SAMEGO FORMALNEGO I PLIKOWEGO)
+C - ZGODNE STATYCZNIE
+C 6 - J.W. - CO NAJMNIEJ JEDEN JEST FORMALNY I WYMAGANA
+C DYNAMICZNA KONTROLA ZGODNOSCI
+C ----SYGNALIZOWANE BLEDY:
+C 606 - RODZAJE TYPOW WYSTEPUJACYCH W POROWNANIU SA NIEZGO-
+C DNE
+C 607 - W POROWNANIU BIORA UDZIAL TYPY KLASOWE Z ROZLACZNA
+C SEKWENCJA PREFIKSOWA
+C 608 - POROWNYWANY JEST TYP STRING
+C 636 - NIEDOZWOLONE UZYCIE SEMAFORA
+C
+C OPIS W DOKUMENTACJI: ?2.6
+C WERSJA Z DNIA: 13.05.83 (FRIDAY)
+C DLUGOSC KODU: 664
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL MTPC
+C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
+ COMMON /MTPC/ PRFXR, PRFXL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
+C
+ CONVL = 0
+ CONVR = 0
+ TPL = IAND( IPMEM(TLBAS), 15)
+ TPR = IAND (IPMEM(TRBAS), 15)
+C TPL,TPR - POLA T TYPOW BAZOWYCH LEWEJ I PRAWEJ STRONY
+ IF ((TLDIM .NE. 0) .OR. (TRDIM .NE. 0)) GOTO 1000
+C SKOK DO POROWNYWANIA TYPOW TABLICOWYCH
+C
+ GOTO (9000, 100, 100, 200, 100, 300, 100, 400, 9100, 500,
+ X 800, 700, 9000, 300), TPL
+C
+C-----TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM
+ 100 CASE = 5
+ GOTO (9000, 110, 110, 120, 110, 130, 110, 9000, 9100, 9000,
+ X 9000, 9000, 9000, 120), TPR
+C....... TPR JEST TEZ TYPEM KLASOWYM LUB SYSTEMOWYM
+ 110 IF ((TRBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRCOR)) RETURN
+ IF ((TRBAS .EQ. NRPROC) .OR. (TLBAS .EQ. NRPROC)) RETURN
+C PRZYPADEK, GDY OBA TYPY SA TYPAMI KLASOWYMI - WOWCZAS ICH
+C SEKWENCJE PREFIKSOWE NIE MOGA BYC ROZLACZNE
+ IF ( MPRFSQ(TRBAS,TLBAS) .GE. 0) RETURN
+C ROZLACZNE SEKWENCJE PREFIKSOWE PONIZEJ
+ CALL MERR(607, IDL)
+ RETURN
+C
+C....... TPR JEST TYPEM UNIWERSALNYM LUB TYPEM NONE
+ 120 RETURN
+C
+C....... TPR JEST TYPEM FORMALNYM
+ 130 CASE = 6
+ RETURN
+C
+C
+C----- TPL JEST TYPEM UNIWERSALNYM, WTEDY POROWNANIE JEST ZAWSZE
+C POPRAWNE - O ILE TPR NIE JEST TYPEM TEKSTOWYM
+ 200 CASE = 5
+ IF (TRBAS .EQ. NRTEXT) GOTO 700
+ RETURN
+C
+C----- TPL JEST TYPEM FORMALNYM LUB TYPEM NONE - BY ZACHODZILA ZGODNOSC
+C TO TPR MUSI BYC TYPEM FORMALNYM, KLASOWYM, SYSTEMOWYM, UNIWER-
+C SALNYM LUB NONE
+ 300 CASE = 6
+ IF ( (TPL .EQ. 14) .OR. (TPR .EQ. 14) ) CASE = 5
+C-----JESLI POROWNANIE NONE Z FILE
+ IF ((TPL .EQ. 14) .AND. (TPR .EQ. 11)) RETURN
+ IF (TPR .GE. 13) RETURN
+ IF (TPR .GE. 8) GOTO 9000
+ IF (TPR .EQ. 6) GOTO 8000
+ IF (TPR .GE. 1) RETURN
+ GOTO 9000
+C
+C----- TPL JEST TYPEM ARYTMETYCZNYM, WTEDY TPR TEZ MUSI BYC ARYTMETYCZNE
+C (LUB UNIWERSALNE)
+ 400 IF ((TRBAS .NE. NRINT) .AND.
+ X (TRBAS .NE. NRRE) .AND.
+ X (TRBAS .NE. NRUNIV)) GOTO 9000
+ CASE = 2
+cdsw IF ((TPR .EQ.TPL) .AND. (TRBAS .EQ.NRINT)) CASE = 1
+ IF ((trbas .EQ. tlbas) .AND. (TRBAS .EQ. NRINT) ) CASE = 1
+ CONVL = 0
+ CONVR = 0
+ IF (CASE .EQ. 1) RETURN
+ IF (TLBAS .EQ. NRINT) CONVL = 1
+ IF (TRBAS .EQ. NRINT) CONVR = 1
+ RETURN
+C
+C-----TPL JEST TYPEM BOOLEAN LUB CHARACTER, WTEDY TPR MUSI BYC ROWNIEZ
+C BOOLEAN LUB CHARACTER (LUB UNIWERSALNY)
+ 500 IF ((TRBAS .EQ. NRCHR) .OR. (TLBAS .EQ. NRCHR)) GOTO 600
+ CASE = 3
+ IF ((TRBAS .EQ. NRBOOL) .OR. (TRBAS .EQ. NRUNIV)) RETURN
+ GOTO 9000
+C
+C-----TPL JEST TYPEM CHAR, WTEDY TPR MUSI BYC BADZ CHAR BADZ UNIWER-
+C SALNY
+ 600 CASE = 4
+ IF ((TRBAS .EQ. NRCHR) .OR. (TRBAS .EQ. NRUNIV)) RETURN
+ GOTO 9000
+C
+C-----TPL JEST TYPEM TEKSTOWYM, NIEZALEZNIE OD TPR JEST TO BLAD
+ 700 CASE = 5
+ CALL MERR(608, IDL)
+ IF (TRBAS .EQ. NRTEXT) CALL MERR(608, IDR)
+ RETURN
+C
+C-----TPL - FILE. TPR MUSI BYC FILE LUB UNIWERSALNY LUB NONE
+ 800 CASE = 5
+ IF ((TPR .EQ. 11) .OR. (TRBAS .EQ. NRUNIV)
+ X .OR. (TRBAS .EQ. NRNONE)) RETURN
+ GOTO 9000
+C
+C
+C----- POROWNYWANIE TYPOW TABLICOWYCH
+ 1000 CASE = 5
+ IF (TLDIM-TRDIM) 2000, 3000, 4000
+C...... PRZYPADEK TLDIM < TRDIM
+C WOWCZAS POPRAWNE JEDYNIE, GDY TLBAS JEST FORMALNY, UNIWERSALNY
+C LUB NONE
+C W PRZYPADKU, GDY OBA TYPY SA TYM SAMYM TYPEM FORMALNYM MUSZA
+C POCHODZIC Z ROZNYCH OBIEKTOW
+ 2000 IF ((TPL .EQ. 4) .OR. (TPL .EQ. 14)) RETURN
+ IF (TPL .NE. 6) GOTO 9000
+C KONTROLA, GDY CO NAJMNIEJ JEDENz JEST FORMALNY
+ GOTO 8500
+C
+C...... PRZYPADEK TLDIM = TRDIM
+C POPRAWNE, GDY :
+C - OBA TYPY BAZOWE SA ROWNE
+C LUB - CO NAJMNIEJ JEDEN Z NICH JEST FORMALNY LUB UNIWERSALNY
+ 3000 IF ( (TPR .EQ. 4) .OR. (TPL .EQ. 4) ) RETURN
+ IF ( (TPR .EQ. 6) .OR. (TPL .EQ. 6) ) GOTO 8000
+C SKOK, GDY CO NAJMNIEJ JEDEN TYP BAZOWY JEST FORMALNY
+ IF (TRBAS .EQ. TLBAS) RETURN
+ GOTO 9000
+C
+C...... PRZYPADEK TLDIM > TRDIM
+C POPRAWNE GDY TRBAS JEST FORMALNY, UNIWERSALNY LUB NONE -
+C DALSZE UWAGI JAK PRZY TLDIM < TRDIM
+ 4000 IF ((TPR .EQ. 4) .OR. (TPR .EQ. 14)) RETURN
+ IF (TPR .NE. 6) GOTO 9000
+ GOTO 8500
+C
+C
+C------ USTALENIE RODZAJU ZGODNOSCI TYPOW REFERENCYJNYCH, GDY CO
+C NAJMNIEJ JEDEN Z NICH JEST TYPEM FORMALNYM
+C
+ 8000 CASE = 6
+ PRFXR = OBJR
+ PRFXL = OBJL
+ IF ( MTPCON(Z) ) 8200, 8200, 8100
+C MTPCON PRZYJMUJE NASTEPUJACE WARTOSCI
+C -1 - TYP TEN SAM Z ROZNYCH OBIEKTOW
+C 0 - TYPY ROZNE
+C +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU
+C
+ 8100 CASE = 5
+ 8200 RETURN
+C
+C...... UZTALENIE ZGODNOSCI TYPOW TABLICOWYCH - JEDEN Z NICH
+C JEST FORMALNY
+C
+ 8500 CASE = 6
+ PRFXR = OBJR
+ PRFXL = OBJL
+ IF ( MTPCON(Z) .NE. 1) RETURN
+C WPP - SYGNALIZACJA BLEDOW - NIE MA PODSTAWIENIA UNIFIKU-
+C JACEGO
+C
+C
+C
+C------ SYGNALIZOWANIE BLEDOW
+ 9000 CASE = 5
+ IF (TPR .EQ. 9) GOTO 9100
+ IF ((TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRTEXT)) CALL MERR(608,
+ X IDR)
+ CALL MERR(606, IDL)
+ RETURN
+C --- SYGNALIZACJA BLEDOW - NIEDOZWOLONE UZYCIE SEMAFORA
+ 9100 CASE = 5
+ IF (TPL .EQ. 9) CALL MERR(636, IDL)
+ IF (TPR .EQ. 9) CALL MERR(636, IDR)
+ RETURN
+ END
+*DECK MPKIND
+ INTEGER FUNCTION MPKIND (ATTRAD)
+C-------------FUNKCJA OKRESLAJACA RODZAJ KOLEJNEGO PARAMETRU
+C FORMALNEGO
+C / WARTOSCIA PARAMETRU ATTRAD JEST IDENTYFIKATOR
+C (INDEKS W IPMEM) OPISU TEGO PARAMETRU
+C / ZMIENNA NRPAR (Z BLOKU /SEMANT/) MA WARTOSC ROWNA
+C NUMEROWI PARAMETRU WEWNATRZ LISTY PARAMETROW FORMAL-
+C NYCH (0,1,2,...)
+C / WARTOSC FUNKCJI OKRESLA RODZAJ PARAMETRU FORMALNEGO
+C 0 - UNIWERSALNY
+C 1 - INPUT
+C 2 - OUTPUT
+C 3 - TYP
+C 4 - FUNKCJA
+C 5 - PROCEDURA
+C // FUNKCJA KORZYSTA Z PROCEDURY MNOPF
+C SYGNALIZOWANY BLAD
+C 622 (Z MNOPF) - ZA KROTKA LISTA PF
+C
+C OPIS W DOKUMENTACJI: ?3.4.3.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 141
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL MNOPF
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C
+C
+ MPKIND = 0
+ ATTRAD = NRUNIV
+ IF (MNOPF(0)) RETURN
+C
+C*****************************************************************************
+C PARAMETR ZOSTAL POBRANY
+ ATTRAD = IPMEM(CLLREC+5)
+ ATTRAD = IPMEM(ATTRAD)
+ NRPAR = IPMEM(CLLREC+4)
+C------ ROZPOZNANIE BIEZACEGO PARAMETRU
+C ZW - SLOWO ZEROWE OPISU PARAMETRU
+ ZW = IPMEM(ATTRAD)
+ ZW = IAND (ISHFT(ZW, -4), 15) +1
+ GOTO (1000, 100, 200, 300, 1000, 400, 500, 1000,
+ X 1000, 600), ZW
+C
+C...... TYP FORMALNY
+ 100 MPKIND = 3
+ GOTO 1000
+C
+C...... FUNKCJA
+ 200 MPKIND = 4
+ GOTO 1000
+C
+C...... PROCEDURA
+ 300 MPKIND = 5
+ GOTO 1000
+C
+C...... INPUT
+ 400 MPKIND = 1
+ GOTO 1000
+C
+C...... OUTPUT
+ 500 MPKIND = 2
+ GOTO 1000
+C
+C.....INOUT
+ 600 MPKIND = 6
+C
+C*****************************************************************************
+C------ ZAKONCZENIE
+ 1000 IPMEM(CLLREC+7) = MPKIND
+ RETURN
+ END
+*DECK MPARTP
+ SUBROUTINE MPARTP (ATDIM, ATBASE, OB, IDBASE)
+C-------------PRZETWARZANIE PARAMETRU AKTUALNEGO BEDACEGO TYPEM
+C DO REKORDU KONTROLI WPISUJE SIE INFORMACJE O TYPIE
+C AKTUALNYM ZASTEPUJACYM TYP-PARAMETR FORMALNY.
+C ATDIM, ATBASE - LICZBA ARRAY OF I TYP BAZOWY AKTUALNY
+C OB - NUMER OBIEKTU Z CIAGU SL, Z KTOREGO JEST POBIERANY
+C LUB ZERO, GDY NIE JEST DOSTEPNY PRZEZ DISPLAY
+C IDBASE - NAZWA ZE SCANNERA TYPU BAZOWEGO (DO SYGNALIZACJI
+C BLEDOW)
+C
+C SYGNALIZOWANE BLEDY
+C 624 - TYP AKTUALNY NIE JEST REFERENCYJNY
+C 625 - ATBASE NIE JEST TYPEM
+C 637 - 'SEMAPHORE' NIE MOZE BYC TYPEM AKTUALNYM
+C
+C /PROCEDURA TWORZY NOWA CZWORKE TYPOW DO MODYFIKACJI
+C
+C OPIS W DOKUMENTACJI: ?3.5
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 207
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C
+C
+C...... POWROTY DLA WYWOLANIA NIEKONTROLOWANEGO
+ IF (UNICLL) RETURN
+ IF (IPMEM(CLLREC+7) .EQ. 0) RETURN
+C
+C------UTWORZENIE NOWEJ CZWORKI W REKORDZIE KONTROLI
+ INSYS = .TRUE.
+ K = MGETM(4, 0)
+ INSYS = .FALSE.
+C...... ZAPIS NUMERU TYPU FORMALNEGO
+ PF = IPMEM(CLLREC+5)
+ IPMEM(K) = IPMEM(PF)
+C...... ZAPIS INFORMACJI O TYPIE AKTUALNYM
+ IPMEM(K+1) = ATDIM
+ IPMEM(K+2) = ATBASE
+ IPMEM(K+3) = OB
+C...... KONTROLA, CZY TYP AKTUALNY JEST DOPUSZCZALNY
+ 100 PF = IPMEM(ATBASE)
+ PF = IAND(PF, 15)
+C PF - POLE T Z OPISU TYPU ATBASE
+ IF (PF .EQ. 1) GOTO 200
+C ... ATBASE NIE JEST TYPEM
+ IF (PF .EQ. 9) GOTO 210
+ IF (ATDIM .NE. 0) RETURN
+C ---TYPY TABLICOWE SA REFERENCYJNE
+ IF (PF .LE. 7) RETURN
+C ---POWROT DLA POZOSTALYCH TYPOW REFERENCYJNYCH
+C
+C------SYGNALIZACJA BLEDU - TYP AKTUALNY NIE JEST REFERENCYJNY
+ CALL MERR(624, IDBASE)
+ IPMEM(K+2) = NRUNIV
+ RETURN
+C------SYGNALIZACJA BLEDU- PARAMETR ATBASE NIE JEST TYPEM
+ 200 CALL MERR(625, IDBASE)
+ 205 IPMEM(K+1) = 0
+ IPMEM(K+2) = NRUNIV
+ RETURN
+C-----PARAMETREM JEST TYP 'SEMAPHORE' - BLAD
+ 210 CALL MERR(637, 0)
+ GOTO 205
+ END
+*DECK MREPTP
+ SUBROUTINE MREPTP (TDIM, TBAS, OB)
+C-------------PROCEDURA MODYFIKUJE TYP (TDIM, TBAS) PRZEZ
+C ZASTAPIENIE EWENTUALNEGO TYPU FORMALNEGO TYPEM AKTUALNYM
+C JEMU ODPOWIADAJACYM.
+C TDIM, TBAS - OKRESLA ROWNIEZ TYP PO MODYFIKACJI
+C DANE DOTYCZACE DOSTEPNOSCI : OB
+C /PROCEDURA UZYWANA JEDYNIE, GDY WYWOLANIE JEST KONTROLO-
+C WANE
+C
+C OPIS W DOKUMENTACJI: ?3.6.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 112
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C
+C K - INDEKS PIERWSZEJ PIATKI TYPOW ZASTEPOWANYCH
+C L - INDEKS OSTATNIEJ PIATKI TYPOW ZASTEPOWANYCH
+ L = LPML - 4
+ K = CLLREC + 8
+C...... SPRAWDZENIE, CZY LISTA TYPOW NIE JEST PUSTA
+ IF (K .GT. L) RETURN
+C------ SZUKANIE W NIEPUSTEJ LISCIE
+C
+ 10 IF (IPMEM(K) .EQ. TBAS) GOTO 20
+C ---SKOK, GDY TYP JEST ODNALEZIONY
+ IF (K .EQ. L) RETURN
+C ---POWROT, GDY TYP NIE WYSTEPUJE W LISCIE
+ K = K+4
+ GOTO 10
+C
+C------ TYP ODNALEZIONY
+ 20 TDIM = TDIM + IPMEM(K+1)
+ TBAS = IPMEM(K+2)
+ OB = IPMEM(K+3)
+ RETURN
+ END
+*DECK MCALLO
+ SUBROUTINE MCALLO (NRPROT, IDPROT, OB, KIND)
+C-------------PROCEDURA OTWIERA REKORD KONTROLI STATYCZNEJ NOWEGO
+C WYWOLANIA (WKLADAJAC NA STOS), INICJUJE TEN REKORD
+C PARAMETRY WEJSCIOWE
+C NRPROT - NUMER WYWOLYWANEGO PROTOTYPU
+C IDPROT - NAZWA ZE SCANNERA WYWOLYWANEGO PROTOTYPU
+C OB - NUMER OBIEKTU Z CIAGU SL, Z KTOREGO WYWOLYWANY
+C PROTOTYP POCHODZI
+C PARAMETR WYJSCIOWY
+C KIND - WARTOSCI
+C = 0 ZWYKLY PROTOTYP
+C = 1 WIRTUALNY
+C = 2 FORMALNY
+C
+C OPIS W DOKUMENTACJI: ?3.4.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 262
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BTEST
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+*CALL MID
+ COMMON /MID/ PSTART, CHECKS
+C
+C------ UTWORZENIE REKORDU DLA WYWOLANIA UNIWERSALNEGO
+ KIND = 0
+ UNICLL = .TRUE.
+ CHECKS = CHECKS+1
+ INSYS = .TRUE.
+ RECORD = MGETM(2, 0)
+ IPMEM(RECORD) = CLLREC
+ CLLREC = RECORD+1
+ INSYS = .FALSE.
+ IF (NRPROT .EQ. NRUNIV) RETURN
+C------ UTWORZENIE REKORDU DLA WYWOLANIA KONTROLOWANEGO
+ INSYS = .TRUE.
+ UNICLL = .FALSE.
+ RECORD = MGETM(7, 0)
+ INSYS = .FALSE.
+C...... INICJALIZACJA SLOW REKORDU
+C RECORD - ZEROWE SLOWO WYWOLYWANEGO REKORDU
+ RECORD = IPMEM(NRPROT)
+ IPMEM(CLLREC) = NRPROT
+ IPMEM(CLLREC+1) = IDPROT
+C...... ZBADANIE, CZY TO JEST PROTOTYP WIRTUALNY
+ KIND = 1
+ IF (BTEST(RECORD, 11) ) GOTO 100
+C...... ZBADANIE, CZY TO PROTOTYP FORMALNY
+C (PRZY POMOCY POLA ZP)
+ KIND = 0
+ ZP = IAND(ISHFT(RECORD, -4), 15)
+ IF ( ZP .NE. 0) KIND = 2
+C --- ZBADANIE, CZY TO NIE JEST SYGNAL
+ IF (ZP .EQ. 11) KIND = 0
+ 100 IPMEM(CLLREC+2) = KIND
+C...... INICJALIZACJA DALSZYCH SLOW
+ IPMEM(CLLREC+3) = OB
+C...... WYPELNIENIE INFORMACJI O LISCIE PARAMETROW
+ IPMEM(CLLREC+4) = -1
+ IPMEM(CLLREC+5) = IPMEM(NRPROT+3) - 1
+ IPMEM(CLLREC+6) = IPMEM(CLLREC+5) + IPMEM(NRPROT+4)
+C...... SKROCENIE LISTY PF DLA FUNKCJI - OSTATNI ELEMENT JEST
+C ZMIENNA RESULT
+ RECORD = IAND( ISHFT(RECORD, -8), 7)
+ IF (RECORD .EQ. 2) IPMEM(CLLREC+6) =
+ X IPMEM(CLLREC+6)-1
+ RETURN
+ END
+*DECK MCALLC
+ SUBROUTINE MCALLC
+C-------------ZAKONCZENIE KONTROLI WYWOLANIA, ZBADANIE
+C ZGODNOSCI LICZBY PARAMETROW FORMALNYCH I PARAME-
+C TROW AKTUALNYCH
+C ZDJECIE REKORDU KONTROLI ZE STOSU
+C SYGNALIZOWANY BLAD
+C 623 - LISTA PF JEST DLUZSZA OD LISTY PARAMETROW
+C AKTUALNYCH
+C
+C OPIS W DOKUMENTACJI: ?3.4.4.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 89
+C.............................................................................
+C
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+*CALL MID
+ COMMON /MID/ PSTART, CHECKS
+C
+C
+ CHECKS = CHECKS - 1
+ IF (UNICLL) GOTO 1000
+C
+C****** KONTROLA DLUGOSCI LIST PF I PA
+ IF (IPMEM(CLLREC+5) .EQ. IPMEM(CLLREC+6) ) GOTO 1000
+C --- SYGNALIZACJA BLEDU
+ CALL MERR(623, IPMEM(CLLREC+1) )
+C
+C****** ZDJECIE REKORDU ZE SZCZYTU STOSU
+ 1000 LPML = CLLREC-1
+ CLLREC = IPMEM(CLLREC-1)
+ UNICLL = .FALSE.
+ IF (IPMEM(CLLREC) .EQ. 0) UNICLL = .TRUE.
+ RETURN
+ END
+*DECK MNOPF
+ LOGICAL FUNCTION MNOPF (X)
+C-------------FUNKCJA SLUZY DO POBRANIA NOWEGO PARAMETRU
+C KONTROLUJE, CZY JEST TO MOZLIWE
+C //PRZYJMUJE WARTOSC .TRUE. GDY LISTA PF JEST PUSTA,
+C SYGNALIZUJE WOWCZAS (O ILE WYWOLYWANY PROTOTYP NIE
+C MIAL USZKODZONEJ LISTY) BLAD
+C ZMIENIA WYWOLANIE NA NIEKONTROLOWANE
+C //GDY LISTA PF NIE JEST PUSTA
+C AKTUALIZUJE SLOWA 5 I 6 W REKORDZIE KONTROLI
+C //// X - PARAMETR NIEISTOTNY
+C SYGNALIZOWANY BLAD
+C 622 - LISTA PF KROTSZA OD LISTY PARAMETROW AKTUALNYCH
+C
+C OPIS W DOKUMENTACJI: ?3.4.3.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 168
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BTEST
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C
+ MNOPF = .TRUE.
+ IF (UNICLL) RETURN
+ MNOPF = .FALSE.
+C
+C****** MODYFIKACJA NUMEROW PARAMETRU FORMALNEGO I ELEMENTU LISTY
+ IPMEM(CLLREC+4) = IPMEM(CLLREC+4) + 1
+ IPMEM(CLLREC+5) = IPMEM(CLLREC+5) + 1
+C------ KONTROLA DLUGOSCI LISTY PF I PA
+ IF (IPMEM(CLLREC+5) .LE. IPMEM(CLLREC+6) ) RETURN
+C
+C****** PRZYPADEK, GDY NIE MA JUZ POTRZEBNEGO PF
+C -SYGNALIZACJA BLEDU, GDY WYWOLYWANY PROTOTYP NIE JEST
+C USZKODZONY
+C -SKROCENIE REKORDU KONTROLI STATYCZNEJ DO WYWOLANIA UNIWERSAL-
+C NEGO
+C
+ MNOPF = .TRUE.
+C
+C ZW - SLOWO ZEROWE PROTOTYPU
+ ZW = IPMEM(CLLREC)
+ ZW = IPMEM(ZW)
+C ---SKOK DLA USZKODZONEJ LISTY
+ IF (BTEST(ZW, 13)) GOTO 100
+C
+C------ SYGNALIZACJA BLEDU
+ CALL MERR(622, IPMEM(CLLREC+1))
+C------ SKROCENIE REKORDU KONTROLI
+ 100 CALL MUNICL
+ RETURN
+ END
+*DECK MUNICL
+ SUBROUTINE MUNICL
+C-------------PROCEDURA ZASTEPUJACA WYWOLANIE KONTROLOWANE
+C WYWOLANIEM OBIEKTU UNIWERSALNEGO
+C / JEST WYKONYWANA, GDY W WYWOLANIU BYLY BLEDY UNIE-
+C MOZLIWIAJACE DALSZA POPRAWNA ANALIZE
+C
+C OPIS W DOKUMENTACJI: ?3.4.4.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 31
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL STCON
+C......
+ LOGICAL UNICLL
+ COMMON /MCALLS/ CLLREC, UNICLL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
+C
+ LPML = CLLREC+1
+ UNICLL = .TRUE.
+ IPMEM(CLLREC) = 0
+ RETURN
+ END
+*DECK MTPCON
+ INTEGER FUNCTION MTPCON (X)
+C X - "SLEPY" PARAMETR
+C-------------POMOCNICZA FUNKCJA DO KONTROLI TYPOW FORMALNYCH.
+C OKRESLA, CZY TYPY TRBAS I TLBAS ATRYBUTOW POCHODZACYCH
+C Z OBIEKTOW/WARSTW PRFXR I PRFXL (DOSTEPNYCH PRZEZ DISPLAY
+C ODPOWIEDNIO TE WARTOSCI SA WIEKSZE OD ZERA) SA TYM SAMYM
+C TYPEM FORMALNYM.
+C /WARTOSCI :
+C -1 - TYP TEN SAM, Z ROZNYCH OBIEKTOW
+C 0 - TYPY ROZNE
+C +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU
+C
+C OPIS W DOKUMENTACJI: ?2.2.3
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 362
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL MTPC
+C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
+ COMMON /MTPC/ PRFXR, PRFXL
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
+C *CALL MOB
+C......KOMUNIKACJA Z PROCEDURA MOBJFD
+ LOGICAL WCL1,WCL2
+ COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !!
+C
+C*******************************************
+C WARUNKI DOSTATECZNE NA TO BY TYP POCHODZIL Z TEGO
+C SAMEGO OBIEKTU:
+C - OBYDWA ATRYBUTY SA DOSTEPNE PRZEZ DISPLAY
+C ORAZ JEDEN Z PONIZSZYCH
+C (A) POCHODZA Z TEJ SAMEJ WARSTWY (TEN SAM NUMER
+C W DISPLAY-U)
+C (B) OBIEKTY W CIAGU SL DLA PROTOTYPU AKTUALNEGO,
+C Z KTORYCH POCHODZA TYPY, SA ROWNE DLA OBYDWU
+C ATRYBUTOW ORAZ W LANCUCHU SL OD PROTOTYPU
+C AKTUALNEGO DO TEGO OBIEKTU NIE WYSTEPUJA ZADNE
+C KLASY (NATOMIAST SAME OBIEKTY MOGA BYC KLASAMI)
+C (C) WYSTARCZY, BY ATRYBUTY BYLY WLASNE W OBIEKTACH
+C W CIAGU SL DLA PROTOTYPU AKTUALNEGO ORAZ POMIEDZY
+C TYMI OBIEKTAMI NIE WYSTEPUJA ZADNE KLASY ( ORAZ
+C OBIEKT Z TYPEM JEST TEN SAM)
+C (D) ATRYBUTY SA LOKALNE W PROTOTYPIE AKTUALNYM
+C (E) TYP NIE JEST ATRYBUTEM KLASY
+C********************************************
+C
+ MTPCON = 0
+ IF (TRBAS .NE. TLBAS) RETURN
+ MTPCON = -1
+ IF ( (PRFXR .LE. 0) .OR. (PRFXL .LE. 0) ) RETURN
+C********************************************
+C BADANIE WARUNKOW (A) - (E)
+ MTPCON = 1
+ IF (PRFXR .EQ. PRFXL) RETURN
+C --POWROT DLA PRZYPADKU (A)
+ SLOBR = IPMEM(TRBAS - 1)
+ IF (IPMEM(SLOBR) .GT. 15) RETURN
+C --POWROT DLA PRZYPADKU (E)
+C......ODNALEZIENIE W LANCUCHU SL DLA PROTOTYPU AKTUALNEGO
+C P OBIEKTOW "PREFIKSOWANYCH" PRZEZ PROTOTYPY PRFXL I
+C PRFXR
+ STOB = P
+ PRFX1 = PRFXR
+ PRFX2 = PRFXL
+ CALL MOBJFD
+ SLOBR = SLOB1
+ SLOBL = SLOB2
+C SLOB - OBIEKTY W LANCUCHU SL
+C WCL1 = .TRUE. GDY POMIEDZY P A DRUGIM Z TYCH OBIEKTOW
+C WYSTEPUJE KLASA
+C WCL2 = .TRUE. GDY POMIEDZY TYMI OBIEKTAMI WYSTEPUJE
+C KLASA
+ IF ( (SLOBR .EQ. P) .AND. (SLOBL .EQ. P) ) RETURN
+C --POWROT DLA PRZYPADKU (D)
+C
+ MTPCON = -1
+ IF (WCL2) RETURN
+C --POMIEDZY OBIEKTAMI WYSTAPILA KLASA
+C
+C......TESTOWANIE PRZYPADKU (C)
+ IF ( (PRFXR .NE. SLOBR) .OR. (PRFXL .NE. SLOBL) )
+ X GOTO 100
+ STOB = SLOBR
+ PRFX1 = IPMEM(TRBAS-1)
+ PRFX2 = 0
+ CALL MOBJFD
+ OBTPR = SLOB1
+C
+ STOB = SLOBL
+ PRFX1 = IPMEM(TLBAS-1)
+ PRFX2 = 0
+ CALL MOBJFD
+ OBTPL = SLOB1
+ IF (OBTPR .NE. OBTPL) RETURN
+ MTPCON = 1
+ RETURN
+C......TESTOWANIE PRZYPADKU (B)
+C ODSZUKANIE OBIEKTOW, Z KTORYCH BRANY JEST TYP, GDY
+C OTOCZENIAMI SA SLOB
+ 100 IF (WCL1) RETURN
+ IF (IAND(IPMEM(P), 15) .NE. 1) RETURN
+C BY TYP NA PEWNO POCHODZIL Z TEGO SAMEGO OBIEKTU - P NIE MOZE BYC
+C KLASA
+ STOB = SLOBR
+ PRFX1 = IPMEM(TRBAS-1)
+ PRFX2 = 0
+ CALL MOBJFD
+ OBTPR = SLOB1
+ IF (WCL1 .AND. (SLOBR .NE. OBTPR) ) RETURN
+ STOB = SLOBL
+ PRFX1 = IPMEM(TLBAS-1)
+ PRFX2 = 0
+ CALL MOBJFD
+ OBTPL = SLOB1
+ IF (WCL1 .AND. (SLOBL .NE. OBTPL) ) RETURN
+ IF (OBTPL .NE. OBTPR) RETURN
+C --TYP BRANY Z ROZNYCH OBIEKTOW
+ MTPCON = 1
+ RETURN
+ END
+*DECK MDISTP
+ LOGICAL FUNCTION MDISTP (VSL, NRPROT, NRDIS)
+C-------------FUNKCJA SPRAWDZA, CZY TYP FORMALNY OBIEKTU DOSTEPNEGO
+C PRZEZ DISPLAY Z PROTOTYPU AKTUALNEGO JEST ROWNIEZ
+C DOSTEPNY PRZEZ DISPLAY
+C VSL - NUMER PROTOTYPU Z DEKLARACJA OBIEKTU
+C NRPROT - NUMER PROTOTYPU TYPU FORMALNEGO
+C /WYNIKI : NRDIS IDENTYFIKATOR PROTOTYPU, KTOREGO
+C NUMER W DISPLAY-U TWORZY ADRES NRPROT
+C /WARTOSCI
+C - .TRUE. - TYP ZAWSZE DOSTEPNY PRZEZ DISPLAY
+C - .FALSE. - TYP NIE JEST LUB NIE ZAWSZE JEST DOSTEPNY
+C PRZEZ DISPLAY
+C
+C OPIS W DOKUMENTACJI: ?1.4.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 314
+C.............................................................................
+C
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BPREF
+ LOGICAL WCL, VWCL
+cdsw DATA MDISTPHX /Z0FFF/
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL MOB
+C......KOMUNIKACJA Z PROCEDURA MOBJFD
+ LOGICAL WCL1,WCL2
+ COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !!
+C
+cdsw ---------------------
+ data mdishx / x'0fff'/
+cdsw -----------------------
+ TPSL = IPMEM(NRPROT - 1)
+ NRDIS = TPSL
+C WARSTWA, Z KTOREJ POCHODZI TYP NRPROT
+ MDISTP = .TRUE.
+ IF (VSL .EQ. TPSL) RETURN
+ IF (IAND(IPMEM(TPSL), mdishx ) .GT. 15) RETURN
+C OBYDWIE WIELKOSCI POCHODZA Z TEJ SAMEJ WARSTWY LUB TYP NIE
+C JEST ATRYBUTEM KLASY
+ MDISTP = .FALSE.
+C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO
+C OBIEKTU Z WARSTWA VSL
+ STOB = P
+ PRFX1 = VSL
+ PRFX2 = 0
+ CALL MOBJFD
+ VOB = SLOB1
+ VWCL = WCL2
+C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO
+C OBIEKTU Z WARSTWA TPSL
+ STOB = P
+ PRFX1 = TPSL
+ CALL MOBJFD
+ TOB = SLOB1
+ WCL = WCL2
+ IF (TOB .EQ. VOB) GOTO 100
+ IF (VWCL) RETURN
+ IF (WCL) RETURN
+C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU VOB OBIEKTU
+C Z WARSTWA TPSL
+ STOB = VOB
+ PRFX1 = TPSL
+ CALL MOBJFD
+ TOBPR = SLOB1
+ WCL = WCL2
+ IF ( TOB .NE. TOBPR) GOTO 300
+ IF ( .NOT. WCL) GOTO 200
+ NRDIS = VOB
+ IF (VOB .NE. TOB) RETURN
+ MDISTP = .TRUE.
+ RETURN
+ 100 MDISTP = .TRUE.
+ NRDIS = VSL
+ RETURN
+ 200 NRDIS = TOBPR
+ MDISTP = .TRUE.
+ RETURN
+ 300 IF (IAND(IPMEM(VOB),15) .NE. 1) RETURN
+ IF (WCL) RETURN
+ IF (IAND(IPMEM(P), 15) .NE. 1) RETURN
+ IF (IAND(IPMEM(TOBPR), 15) .EQ. 1) GOTO 200
+ IF (BPREF(TOB, IPMEM(TOBPR-6))) RETURN
+ GOTO 200
+C JESLI P I VOB NIE SA KLASAMI ORAZ TOB NIE JEST ROWN TOBPR A TALZE
+C POMIEDZY VOB A TOBPR NIE MA KLAS - TYP JEST WIDOCZNY PRZEZ DISPLAY
+C DODATKOWY WARUNEK: TOB NIE MOZE BYC PREFIKSOWANE PRZEZ TOBPR
+ END
+*DECK MOBJFD
+ SUBROUTINE MOBJFD
+C POMOCNICZA PROCEDURA PRZY KONTROLI TYPOW.
+C WYSZUKUJE W LANCUCHU SL OBIEKTU STOB OBIEKTY
+C "PREFIKSOWANE" (LUB ROWNE) PRZEZ PRFX1 I PRFX2
+C (JESLI PRFX2=0 TO TYLKO PRFX1)
+C SLOB1 - OBIEKT ZAWIERAJACY WARSTWE PRFX1
+C SLOB2 - OBIEKT ZAWIERAJACY WARSTWE PRFX2
+C WCL1 = .TRUE. JESLI POMIEDZY STOB A TYMI OBIEKTAMI
+C WYSTEPUJE KLASA
+C WCL2 = .TRUE. JESLI POMIEDZY TYMI OBIEKTAMI WYSTE-
+C PUJE KLASA
+C
+C OPIS W DOKUMENTACJI: ?1.4.3
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 548
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL WCLPR, NOCL1, NOCL2, BPREF
+cdsw DATA MOBJFDHX /Z0FFF/
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C *CALL MOB
+C......KOMUNIKACJA Z PROCEDURA MOBJFD
+ LOGICAL WCL1,WCL2
+ COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !!
+C
+cdsw -------------------
+ data mobjhx / x'0fff'/
+cdsw ---------------------
+C......INICJALIZACJA
+ ACTOB = STOB
+C -OBIEKT AKTUALNY W LANCUCHU SL
+ WCL1 = .FALSE.
+ WCL2 = .FALSE.
+ WCLPR = .FALSE.
+C......SPRAWDZENIE, CZY PRFX SA KLASAMI JESLI TAK TO POBRANIE
+C ICH NUMEROW W SENSIE ZBIOROW PREFIKSOW
+ NOCL1 = .TRUE.
+ NOCL2 = .TRUE.
+ ZWORD = IAND(IPMEM(PRFX1), 15)
+ IF ( (ZWORD .GE. 15) .OR. (ZWORD .EQ. 1) )
+ X GOTO 100
+ NOCL1 = .FALSE.
+ PRFN1 = IPMEM(PRFX1-6)
+C --PRFN1 - NUMER W SENSIE PREFXSET
+C
+ 100 IF (PRFX2 .EQ. 0) GOTO 3000
+C --SKOK DO WYSZUKIWANIA PROTOTYPU Z WARSTWA PRFX1
+C
+C
+ IF ( (IPMEM(PRFX2) .GE. 15) .OR. (IPMEM(PRFX2) .EQ. 1) )
+ X GOTO 200
+ NOCL2 = .FALSE.
+ PRFN2 = IPMEM(PRFX2-6)
+C
+ 200 CONTINUE
+ IF (PRFX1 .EQ. PRFX2) GOTO 3100
+C
+C************WYSZUKIWANIE BLIZSZEGO OBIEKTU
+ 1000 IF (ACTOB .EQ. PRFX1) GOTO 2000
+ IF (ACTOB .EQ. PRFX2) GOTO 3000
+ IF (IPMEM(ACTOB) .EQ. 1) GOTO 1600
+ IF ( IAND(ISHFT(IPMEM(ACTOB), -8), 7) .EQ. 7) GOTO 1600
+C --OMINIECIE BLOKU ZWYKLEGO I HANDLERA
+ IF (NOCL1) GOTO 1100
+ IF (BPREF(ACTOB,PRFN1)) GOTO 2000
+ 1100 IF (NOCL2) GOTO 1500
+ IF (BPREF(ACTOB,PRFN2)) GOTO 3000
+C......POBRANIE KOLEJNEGO OBIEKTU Z LANCUCHA SL (PRZY
+C JEDNOCZESNYM SPRAWDZENIU, CZY NIE JEST TO KLASA)
+ 1500 IF (ACTOB .EQ. STOB) GOTO 1600
+ IF ( IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL1 = .TRUE.
+ 1600 ACTOB = IPMEM(ACTOB-1)
+ GOTO 1000
+C
+C
+C******WYSZUKIWANIE DRUGIEGO OBIEKTU, W PRZYPADKU GDY
+C PIERWSZYM JEST ODPOWIADAJACY PRFX1
+ 2000 SLOB1 = ACTOB
+ IF ( (IPMEM(ACTOB) .LE. 15) .AND. (IPMEM(ACTOB) .NE. 1) )
+ X WCLPR = .TRUE.
+C ***BADANIE KOLEJNYCH OBIEKTOW
+ 2100 CONTINUE
+ IF (ACTOB .EQ. PRFX2) GOTO 2500
+ IF (IPMEM(ACTOB) .EQ. 1) GOTO 2300
+ IF (IAND(ISHFT(IPMEM(ACTOB), -8), 7) .EQ. 7) GOTO 2300
+ IF (NOCL2) GOTO 2200
+ IF (BPREF(ACTOB, PRFN2)) GOTO 2500
+ 2200 IF (ACTOB .EQ. SLOB1) GOTO 2300
+ IF (IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL2 = .TRUE.
+ 2300 ACTOB = IPMEM(ACTOB-1)
+ GOTO 2100
+C
+C
+C ***OBIEKT DRUGI ODNALEZIONY
+ 2500 SLOB2 = ACTOB
+ IF ( SLOB1 .EQ. SLOB2) RETURN
+ WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR)
+ RETURN
+C
+C
+C******WYSZUKIWANIE DRUGIEGO OBIEKTU W PRZYPADKU, GDY PIERWSZYM
+C JEST ODPOWIADAJACY PRFX2 (ROWNIEZ, GDY SZUKAMY JEDNEGO
+C OBIEKTU)
+ 3000 SLOB2 = ACTOB
+ ZWORD = IAND(IPMEM(ACTOB), mobjhx )
+ IF ( (ZWORD .LE. 15) .AND. (ZWORD .NE. 1) )
+ X WCLPR = .TRUE.
+C ***BADANIE KOLEJNYCH OBIEKTOW W CIAGU SL
+ 3100 CONTINUE
+ IF (ACTOB .EQ. PRFX1) GOTO 3500
+ IF (IPMEM(ACTOB) .EQ. 1) GOTO 3300
+ IF (NOCL1) GOTO 3200
+ IF (BPREF(ACTOB, PRFN1)) GOTO 3500
+ 3200 IF (ACTOB .EQ. SLOB2) GOTO 3300
+ IF (IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL2 = .TRUE.
+ 3300 ACTOB = IPMEM(ACTOB-1)
+ GOTO 3100
+C
+C
+C ***ODNALEZIONY DRUGI OBIEKT
+ 3500 SLOB1 = ACTOB
+ IF (PRFX1 .NE. PRFX2) GOTO 3600
+ WCL2 = .FALSE.
+ SLOB2 = ACTOB
+ 3600 CONTINUE
+ IF (SLOB1 .EQ. SLOB2) RETURN
+C GDY OBA PREFIKSY PREFIKSUJA PIERWSZA NAPOTKANA
+C KLASE TO NIE TRAKTUJEMY JEJ JAKO KLASY (TZN.
+C WCL1 I WCL2 SA .FALSE.
+ WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR)
+ RETURN
+ END
+*DECK MARITH
+ SUBROUTINE MARITH ( OP )
+C-------------PROCEDURA BADA POPRAWNOSC ARGUMENTOW OPERACJI ARYTME-
+C TYCZNYCH.
+C TYPY LEWEGO I PRAWEGO ARGUMENTU DANE SA W BLOKU /SEMANT/
+C PRZEZ ZMIENNE TLDIM, TLBAS ORAZ TRDIM,TRBAS .
+C ZMIENNE IDL I IDR (W /SEMANT/) SA IDENTYFIKATORAMI LEWE-
+C GO I PRAWEGO ARGUMENTU (DO SYGNALIZACJI BLEDOW).
+C PARAMETR OP OKRESLA RODZAJ OPERACJI:
+C OP = 1 - DLA +,-,* ORAZ RELACJI <,>,<=,>=
+C OP = 2 - DLA DIV I MOD
+C OP = 3 - DLA / (WYNIK ZAWSZE REAL)
+C NA ZMIENNA TRESLT W /SEMANT/ PODSTAWIANY JEST TYP
+C WYNIKU OPERACJI .
+C PROCEDURA PRZEKAZUJE INFORMACJE O KONWERSJI LEWEGO (CONVL)
+C I PRAWEGO (CONVR) ARGUMENTU. WARTOSCI TYCH ZMIENNYCH
+C OZNACZAJA :
+C 0 - BEZ KONWERSJI
+C 1 - INTEGER DO REAL
+C ----SYGNALIZOWANE BLEDY :
+C 604 - TYP ARGUMENTU OPERACJI LUB RELACJI NIE JEST ARYTME-
+C TYCZNY,
+C 605 - TYP ARGUMENTU DIV LUB MOD NIE JEST INTEGER
+C
+C OPIS W DOKUMENTACJI: ?2.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 295
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C
+C
+C------ KONTROLA TYPU LEWEGO ARGUMENTU
+ TL = TLBAS
+ IF (TLDIM .NE. 0) GOTO 100
+C SKOK - GDY JEST TO TYP TABLICOWY
+ IF ((TLBAS .EQ. NRINT) .OR. (TLBAS .EQ. NRRE) .OR.
+ X (TLBAS .EQ. NRUNIV) ) GOTO 200
+C
+C...... TYP LEWEJ STRONY NIE JEST ARYTMETYCZNY
+ 100 TL = NRUNIV
+ CALL MERR(604, IDL)
+C
+C------KONTROLA TYPU PRAWEJ STRONY
+ 200 TR = TRBAS
+ IF (TRDIM .NE. 0) GOTO 300
+ IF ((TRBAS .EQ. NRINT) .OR. (TRBAS .EQ. NRRE) .OR.
+ X (TRBAS .EQ. NRUNIV) ) GOTO 400
+C
+C......TYP PRAWEJ STRONY NIE JEST ARYTMETYCZNY
+ 300 TR = NRUNIV
+ CALL MERR(604, IDR)
+C
+C
+C------ SPRAWDZENIE ZALEZNE OD RODZAJU OPERACJI, USTALENIE KONWERSJI
+ 400 IF (OP-2) 500, 600, 700
+C
+C..... OP = 1 - OPERACJE +,-,* ORAZ RELACJE
+ 500 TRESLT = NRRE
+C TYP REAL JEST SILNIEJSZY OD INTEGER. PRZYJMUJE WIEC, ZE JEST
+C TO TYP WYNIKU.
+ IF (TL .EQ. TR) TRESLT = TL
+ IF ((TR .EQ. NRUNIV) .OR. (TL .EQ. NRUNIV)) TRESLT = NRUNIV
+C TYP WYNIKU JEST JUZ USTALONY
+C PODANIE INFORMACJI O KONWERSJI
+ CONVL = 0
+ IF (TL .NE. TRESLT) CONVL = 1
+ CONVR = 0
+ IF (TR .NE. TRESLT) CONVR = 1
+ RETURN
+C
+C..... OP = 2 - OPERACJE DIV I MOD
+ 600 TRESLT = NRINT
+ CONVL = 0
+ CONVR = 0
+C SPRAWDZENIE, CZY TYPY ARGUMENTOW NIE SA REAL
+ IF (TL .EQ. NRRE) CALL MERR(605, IDL)
+ IF (TR .EQ. NRRE) CALL MERR(605, IDR)
+ RETURN
+C
+C...... OP = 3 - OPERACJA /
+C WYNIK MUSI BYC TYPU REAL, ARGUMENTY PODLEGAJA EWENTUALNEJ
+C KONWERSJI
+ 700 TRESLT = NRRE
+ CONVL = 0
+ CONVR = 0
+ IF (TL .EQ. NRINT) CONVL = 1
+ IF (TR .EQ. NRINT) CONVR = 1
+ RETURN
+ END
+*DECK MLOCTP
+ LOGICAL FUNCTION MLOCTP (TP, PROT)
+C-------------FUNKCJA SPRAWDZA, CZY TYP TP JEST LOKALNYM ATRYBUTEM
+C PROTOTYPU PROT
+C
+C OPIS W DOKUMENTACJI: ?1.4.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 107
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BPREF
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+ MLOCTP = .TRUE.
+C
+ SLTP = IPMEM(TP - 1)
+C SLTP - MIEJSCE DEKLARACJI TP
+ IF (SLTP .EQ. PROT) RETURN
+ MLOCTP = .FALSE.
+ IF ( IAND( IPMEM(SLTP), 15) .EQ. 1) RETURN
+C POWROT Z WARTOSCIA .FALSE. O ILE SLTP NIE MOZE PREFIKSOWAC
+C PROTOTYPU PROT
+ IF ( IPMEM(PROT) .EQ. 1) RETURN
+ IF ( IAND(ISHFT(IPMEM(PROT), -8), 7) .EQ. 7) RETURN
+C --HANDLER
+ IF ( BPREF (PROT, IPMEM(SLTP - 6) ) ) MLOCTP = .TRUE.
+ RETURN
+ END
+*DECK MAQUAB
+ INTEGER FUNCTION MAQUAB ( IDB )
+C-------------FUNKCJA BADA POPRAWNOSC KONSTRUKCJI QUA IDB .
+C TLDIM I TLBAS OKRESLAJA TYP WYRAZENIA PRZED QUA. IDL JEST
+C NAZWA TEGO WYRAZENIA UZYWANA PRZY SYGNALIZACJI BLEDOW.
+C IDB JEST NAZWA ZE SCANNERA WYSTEPUJACA PO QUA .
+C // WARTOSCIA FUNKCJI JEST PROTOTYP ODPOWIADAJACY IDB
+C LUB NRUNIV W PRZYPADKU BLEDOW.
+C NAZWA IDB JEST WYSZUKIWANA W OTOCZENIU PROTOTYPU
+C AKTUALNEGO (P Z BLOKU /SEMANT/).
+C ----SYGNALIZOWANE BLEDY
+C 600 (Z PROCEDURY MIDENT) - NIEDOSTEPNY IDENTYFIKATOR IDB
+C PODOBNIE 619 I 620
+C 615 - TYP PRZED QUA NIE JEST KLASA UOGOLNIONA ANI TYPEM
+C FORMALNYM
+C 616 - IDENTYFIKATOR PO QUA NIE JEST TYPEM
+C 617 - IDENTYFIKATOR PO QUA NIE JEST TYPEM KLASOWYM
+C 618 - TYP PO QUA NIE JEST W SEKWENCJI PREFIKSOWEJ Z TLBAS
+C
+C
+C OPIS W DOKUMENTACJI: ?1.5.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 238
+C.............................................................................
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C
+C ODSZUKIWANIE IDENTYFIKATORA
+ MAQUAB = MIDENT (IDB)
+C
+C......SPRAWDZENIE, CZY IDB JEST TYPEM KLASOWYM
+ IGT = IAND ( IPMEM(MAQUAB), 15)
+ GOTO (1000, 100, 100, 2000, 100, 200, 100, 200, 200, 200,
+ X 200, 200, 200, 200), IGT
+C
+C ...IDB JEST KLASA LUB TYPEM SYSTEMOWYM - GDY TO TYP SYSTEMOWY
+C TO BLAD
+ 100 IF ( (MAQUAB .NE. NRCOR) .AND. (MAQUAB .NE. NRPROC) )
+ X GOTO 2000
+C SKOK - GDY JEST TO ZWYKLY TYP KLASOWY
+C
+C ...IDB NIE JEST TYPEM KLASOWYM
+ 200 CALL MERR(617, IDB)
+ MAQUAB = NRUNIV
+ GOTO 2000
+C
+C ...IDB NIE JEST TYPEM
+ 1000 CALL MERR(616, IDB)
+ MAQUAB = NRUNIV
+C
+C......BADANIE TYPU PRZED QUA
+ 2000 IF (TLDIM .NE. 0) GOTO 3000
+C SKOK - GDY PRZED QUA TYP TABLICOWY
+ IGT = IAND( IPMEM(TLBAS), 15)
+ GOTO (3000, 2100, 2100, 4000, 2100, 2200, 2100, 3000, 3000,
+ X 3000, 3000, 3000, 3000, 3000), IGT
+C
+C ...PRZED QUA TYP KLASOWY LUB SYSTEMOWY
+ 2100 IF (MAQUAB .EQ. NRUNIV) RETURN
+ IF ( (TLBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRPROC) ) RETURN
+ IF (MPRFSQ (TLBAS, MAQUAB) .GE. 0) RETURN
+C TU - GDY SEKWENCJE PREFIKSOWE TYPOW KLASOWYCH SA ROZLACZNE
+ CALL MERR(618, IDB)
+ MAQUAB = NRUNIV
+ RETURN
+C
+C ...TYP PRZED QUA JEST FORMALNY
+ 2200 RETURN
+C
+C ...TYP PRZED QUA NIE JEST ODPOWIEDNI
+ 3000 CALL MERR(615, IDL)
+ MAQUAB = NRUNIV
+ 4000 RETURN
+ END
+*DECK MTHIS
+ INTEGER FUNCTION MTHIS (ID)
+C-------------FUNKCJA BADA POPRAWNOSC KONSTRUKCJI THIS ID, GDZIE
+C ID JEST NAZWA ZE SCANNERA. KONSTRUKCJA WYSTEPUJE W MODU-
+C LE O PROTOTYPIE AKTUALNYM P (Z BLOKU /SEMANT/).
+C // WARTOSCIA FUNKCJI JEST PROTOTYP ID
+C W PRZYPADKU BLEDU - WARTOSCIA JEST PROTOTYP UNIWERSALNY.
+C ----SYGNALIZOWANE BLEDY
+C 600 (Z PROCEDURY MIDENT) - NIEDOSTEPNY IDENTYFIKATOR ID
+C PODOBNIE 619 I 620
+C 612 - ID NIE WYSTEPUJE W SEKWENCJI PREFIKSOWEJ ZADNEGO
+C MODULU OBEJMUJACEGO P
+C 613 - ID NIE JEST NAZWA KLASY UOGOLNIONEJ
+C 614 - ID NIE JEST NAZWA TYPU
+C
+C OPIS W DOKUMENTACJI: ?1.5.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 182
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BPREF
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C
+C
+ MTHIS = MIDENT (ID)
+ IF (MTHIS .EQ. NRUNIV) RETURN
+C
+ IGT = IAND (IPMEM(MTHIS), 15)
+ GOTO (9000, 100, 100, 9000, 100, 8000, 100, 8000, 8000,
+ X 8000, 8000, 8000, 8000, 8000), IGT
+C
+C-----PRZYPADEK, GDY ID JEST NAZWA TYPU KLASOWEGO LUB SYSTEMOWEGO
+C PRZEJSCIE PO SL-ACH W POSZUKIWANIU MODULU PREFIKSOWANEGO
+C PRZEZ ID
+C PROT - PROTOTYP BADANY
+ 100 PROT = P
+ NRPRF = IPMEM(MTHIS - 6)
+C NRPRF - NUMER PROTOTYPU W SENSIE ZBIORU PREFIKSOW
+ 200 ZWORD = IPMEM(PROT)
+C ZWORD - SLOWO ZEROWE PROTOTYPU PROT - DO KONTROLI, CZY NIE
+C JEST TO BLOK ZWYKLY, W POZOSTALYCH PRZYPADKACH BADAMY WARUNEK
+C PREFIKSOWANIA
+ IF (ZWORD .EQ. 1) GOTO 250
+C SKOK - OMIJA BLOK ZWYKLY
+ IF (IAND(ISHFT(ZWORD, -8), 7) .EQ. 7) GOTO 250
+C SKOK - OMIJA PROTOTYP HANDLERA
+ IF (BPREF(PROT, NRPRF) ) RETURN
+C POWROT JESLI PROT JEST PREFIKSOWANY PRZEZ ID
+ 250 PROT = IPMEM(PROT-1)
+ IF (PROT .NE. NBLSYS) GOTO 200
+C ITEROWANIE - GDY NIE DOSZLISMY DO BLOKU SYSTEMOWEGO
+C.....ID NIE WYSTAPILO W SEKWENCJI PREFIKSOWEJ
+ CALL MERR(612, ID)
+ MTHIS = NRUNIV
+ RETURN
+C.....ID WYSTAPILO JAKO PREFIKS PROTOTYPU PROT
+C
+C-----ID NIE JEST NAZWA KLASY UOGOLNIONEJ
+ 8000 CALL MERR(613, ID)
+ MTHIS = NRUNIV
+ RETURN
+C
+C
+C-----ID NIE JEST TYPEM
+ 9000 CALL MERR(614, ID)
+ MTHIS = NRUNIV
+ RETURN
+ END
+*DECK MDOT
+ INTEGER FUNCTION MDOT(TDIM, TBAS, IDA, ID)
+C-------------FUNKCJA BADAJACA POPRAWNOSC WYRAZENIA KROPKOWANEGO
+C TDIM, TBAS - TYP WYRAZENIA PRZED KROPKA,
+C IDA - IDENTYFIKATOR WYRAZENIA PRZED KROPKA (DO SYGNALIZA-
+C CJI BLEDOW),
+C ID - NAZWA ZE SCANNERA IDENTYFIKATORA PO KROPCE.
+C JESLI ATRYBUT JEST DOSTEPNY - WARTOSCIA MDOT JEST JEGO
+C OPIS.
+C JESLI ATRYBUT JEST NIEDOSTEPNY (NIEZADEKLAROWANY LUB
+C "CLOSE") - WARTOSCIA (PO ZASYGNALIZOWANIU BLEDU) JEST
+C ATRYBUT UNIWERSALNY. JESLI ATRYBUT BYL NIEZADEKLAROWANY
+C - JEST ON WPROWADZANY.
+C ----SYGNALIZOWANE BLEDY
+C 601 - BLEDNY TYP PRZED KROPKA (PRYMITYWNY, FORMALNY,
+C SYSTEMOWY LUB TABLICOWY),
+C 602 - IDENTYFIKATOR PO KROPCE JEST "CLOSE", HIDDEN LUB NIE JEST
+C TAKEN,
+C 603 - IDENTYFIKATOR PO KROPCE NIE JEST ZADEKLAROWANY,
+C 611 - PO KROPCE WYSTEPUJE IDENTYFIKATOR STALEJ "CONST".
+C 621 - PO KROPCE WYSTEPUJE IDENTYFIKATOR HIDDEN LUB SPOZA
+C LISTY TAKEN
+C
+C OPIS W DOKUMENTACJI: ?1.6.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 382
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL MINSCP
+C FUNKCJA POMOCNICZA DO BADANIA, CZY JESTESMY W ZASIEGU DEKLARACJI
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C *CALL MEM
+C.....
+C KOMUNIKACJA Z PROCEDURA MEMPRF
+ COMMON /MEM/ NM, NH
+C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
+C
+C
+ IF (TDIM .NE. 0) GOTO 1000
+C
+C------ TU TYPY NIETABLICOWE
+ TP = IAND(IPMEM(TBAS), 15)
+C TP - POLE T Z OPISU TYPU TBAS
+C
+ GOTO (1000, 100, 100, 500, 400, 1000, 400, 1000, 1000, 1000,
+ X 1000, 1000, 1000, 1000, 1000), TP
+C
+C------ TYPY POSIADAJACE ATRYBUTY (TZN. TYPY KLASOWE)
+ 100 NM = ID
+ NH = IAND ( ISHFT(NM, -1), 7) + 1
+ MDOT = MEMPRF (TBAS)
+ IF (MDOT .NE. 0) GOTO 200
+C------ TU - IDENTYFIKATOR NIEZADEKLAROWANY
+ CALL MERR(603, ID)
+ MDOT = INSERT(ID, IPMEM(TBAS+10), 0)
+ MDOT = NRUNIV
+ RETURN
+C------ TU - GDY IDENTYFIKATOR WYSTEPUJE (LUB BYL DODEKLAROWANY)
+ 200 IF (IPMEM(MDOT+1) .EQ. 0) GOTO 220
+C SKOK - IDENTYFIKATOR JEST DOSTEPNY I NIE JEST CHRONIONY
+ IF ( IPMEM(MDOT+1) .EQ. 1 ) GOTO 300
+C SKOK - JESLI IDENTYFIKATOR JEST "CLOSE"
+ IF (IPMEM(MDOT+1) .EQ. 4) GOTO 250
+C SKOK - JESLI IDENTYFIKATOR JEST 'NOT TAKEN'
+C ---TU IDENTYFIKATOR JEST 'HIDDEN'
+ IF (.NOT. OWN) GOTO 250
+C ---TERAZ NALEZY SPRAWDZIC, CZY IDENTYFIKATOR NIE BYL 'CLOSE' JUZ
+C W PREFIKSIE
+ IF (IPMEM(TBAS+19) .EQ. 0) GOTO 210
+C ---TBAS JEST NIEPREFIKSOWANY
+ PRID = MEMPRF (TBAS+19)
+ IF (PRID .EQ. 0) GOTO 210
+ IF (IPMEM(PRID+2) .NE. IPMEM(MDOT+2)) GOTO 210
+C ---IDENTYFIKATOR NIE BYL DEKLAROWANY W PREFIKSIE
+ IF (IPMEM(PRID+1) .EQ. 1) GOTO 250
+C ---SKOK - IDENTYFIKATOR BYL 'CLOSE' JUZ W PREFIKSIE
+C---SPRAWDZENIE, CZY JESTESMY W ZASIEGU DEKLARACJI MODULU CHRONIACEGO ATRYBUT
+ 210 IF (.NOT. MINSCP(TBAS)) GOTO 250
+ 220 MDOT = IPMEM(MDOT+2)
+ RETURN
+C
+C------ TU IDENTYFIKATORY "HIDDEN" LUB "NOT TAKEN"
+ 250 CALL MERR(621, ID)
+ IF (.NOT. OWN) NRE = INSERT(ID, IPMEM(TBAS+10), 0)
+ IF (OWN .AND. (IPMEM(MDOT+1) .LT. 4) ) GOTO 255
+ IPMEM(MDOT+1) = 0
+ IPMEM(MDOT+2) = NRUNIV
+ 255 MDOT = NRUNIV
+ RETURN
+C
+C
+C------ TU IDENTYFIKATORY "CLOSE" LUB STALE "CONST"
+ 300 NRE = 602
+ NM = IPMEM(MDOT+2)
+ IF (NM .EQ. NRUNIV) GOTO 350
+C --BADANIE, CZY TO STALA 'CONST'
+ NM = ISHFT( IPMEM(NM), -4)
+ NM = IAND(NM, 15)
+ IF (NM .NE. 8) GOTO 350
+ NRE = 611
+ GOTO 360
+ 350 IF (.NOT. OWN) GOTO 360
+ IF (MINSCP(TBAS)) GOTO 220
+ 360 CALL MERR(NRE, ID)
+ IF (.NOT. OWN) NRE = INSERT(ID, IPMEM(TBAS+10), 0)
+ MDOT = NRUNIV
+ RETURN
+
+C
+C------OBIEKTY COROUTINE LUB PROCESS
+ 400 IF ((TBAS .NE. NRCOR) .AND. (TBAS .NE. NRPROC)) GOTO 100
+C
+C------NIEPOPRAWNY TYP PRZED KROPKA
+ 1000 CALL MERR(601, IDA)
+C------ TYP PRZED KROPKA JEST UNIWERSALNY
+ 500 MDOT = NRUNIV
+ RETURN
+ END
+*DECK MINSCP
+ LOGICAL FUNCTION MINSCP (T)
+C-----------------FUNKCJA BADA,CZY PROTOTYP AKTUALNY JEST WEWENATRZ
+C DEKLARACJI MODULU T, TZN. CZY T LEZY W LANCUCHU SL
+C PROTOTYPU P
+C
+C....................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C
+ MINSCP = .TRUE.
+ PR = P
+ 100 IF (PR .EQ. T) RETURN
+ IF (PR .EQ. NBLSYS) GOTO 200
+ PR = IPMEM(PR-1)
+ GOTO 100
+ 200 MINSCP = .FALSE.
+ RETURN
+ END
+*DECK MPROTO
+ SUBROUTINE MPROTO
+C---------------------------------PROCEDURA POMOCNICZA - OTWIERA POMOCNICZA
+C STRUKTURE DANYCH PRZY WEJSCIU DO INSTRUKCJI NOWEGO
+C PROTOTYPU
+C
+C............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+*CALL MID
+ COMMON /MID/ PSTART, CHECKS
+C
+C
+ CHECKS = 0
+ INSYS = .TRUE.
+ PSTART = MGETM(8,0)
+ INSYS = .FALSE.
+ RETURN
+ END
+*DECK MPROTC
+ SUBROUTINE MPROTC
+C---------------------------------PROCEDURA POMOCNICZA - ZAMYKA POMOCNICZA
+C STRUKTURE DANYCH PRZY WYJSCIU Z PROTOTYPU
+C
+C........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+*CALL MID
+ COMMON /MID/ PSTART, CHECKS
+C
+C
+ LPML = PSTART
+ RETURN
+ END
+*DECK MIDENT
+ INTEGER FUNCTION MIDENT(ID)
+C-------------------------------FUNKCJA WYSZUKUJE W PROTOTYPIE AKTUALNYM P
+C I JEGO OTOTCZENIU NAZWE ID (HASH ZE SCANNERA).
+C WYSZUKIWANIE ODBYWA SIE NAJPIERW W STRUKTURZE
+C POMOCNICZEJ
+C
+C.............................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+*CALL MID
+ COMMON /MID/ PSTART, CHECKS
+C
+C
+C *****SZUKANIE NAZWY W LOKALNEJ STRUKTURZE DANYCH
+ MIDENT = MEMBER(ID, IPMEM(PSTART))
+ IF (MIDENT .EQ. 0) GOTO 100
+C ----NAZWA ODNALEZIONA - NA PEWNO JEST POPRAWNA, NIE TRZEBA SYGNALIZOWAC
+C ZADNYCH BLEDOW
+C NALEZY JEDYNIE USTAWIC ZMIENNE INFORMUJACE O DOSTEPIE
+ OBJECT = IPMEM(MIDENT+1)
+ LOCAL = IPMEM(MIDENT+4)
+ MIDENT = IPMEM(MIDENT+2)
+ OWN = (LOCAL .LT. 0)
+ IF (OWN) LOCAL = -LOCAL-1
+ RETURN
+C ----NAZWA NIE ZOSTALA ODNALEZIONA - SZUKANIE PRZY POMOCY MIDB
+ 100 MIDENT = MIDB(ID)
+C ----JESLI MOZEMY WSTAWIAC DO LISTY POMOCNICZEJ, TO WSTAWIAMY, WPP POWROT
+ IF ((LPML+5) .GT. LPMF) CHECKS = CHECKS+1
+ IF (CHECKS .GT. 0) GOTO 200
+ INSYS = .TRUE.
+ NADR = MGETM(5,0)
+ INSYS = .FALSE.
+ MIDENT = IPMEM(MIDENT+2)
+ IPMEM(NADR) = ID
+ IPMEM(NADR+1) = OBJECT
+ IPMEM(NADR+2) = MIDENT
+ IPMEM(NADR+4) = LOCAL
+ IF (OWN) IPMEM(NADR+4) = -(LOCAL+1)
+ NH = IAND(ISHFT(ID, -1), 7) + PSTART
+ IPMEM(NADR+3) = IPMEM(NH)
+ IPMEM(NH) = NADR
+ RETURN
+ 200 MIDENT = IPMEM(MIDENT+2)
+ RETURN
+ END
+*DECK MIDB
+ INTEGER FUNCTION MIDB (ID)
+C-------------FUNKCJA WYSZUKUJE W PROTOTYPIE AKTUALNYM P ( /SEMANT/)
+C I JEGO OTOCZENIU NAZWE ID (HASH ZE SCANNERA).
+C (.) JESLI NAZWA TA JEST DOSTEPNA, TO :
+C -NADAJE ZMIENNEJ LOCAL WARTOSC
+C WYSTAPIENIA IDENTYFIKATORA),
+C -WARTOSCIA FUNKCJI JEST INDEKS OPISU TEGO IDENTYFIKA-
+C TORA .
+C (.) JESLI NAZWA NIE JEST DOSTEPNA LUB JEST NIEZADEKLAROWA-
+C NA - DODEKLAROWUJE JA, SYGNALIZUJE BLAD I NADAJE WAR-
+C TOSC ATRYBUTU UNIWERSALNEGO.
+C ----SYGNALIZOWANE BLEDY:
+C 600 - NIEZADEKLAROWANY (LUB NIEDOSTEPNY) IDENTYFIKATOR
+C 619 - UZYCIE IDENTYFIKATORA HIDDEN
+C 620 - UZYCIE IDENTYFIKATORA SPOZA LISTY TAKEN
+C
+C
+C OPIS W DOKUMENTACJI: ?1.4.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 155
+C.............................................................................
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANKSEM
+C.....
+#include "blank.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
+C
+C
+ MIDB = MEMSL (ID, P)
+C MEMSL MA WARTOSC ZERO, JESLI NAZWA NIE ZOSTALA ODNALEZIONA
+C LUB JEST INDEKSEM W LISCIE HASH-U.
+C OWN MA WARTOSC .TRUE. - GDY IDENTYFIKATOR ZOSTAL ZNALEZIONY
+C BEZPOREDNIOW PROTOTYPIE (A NIE JEGO PREFIKSIE) - MOZE BYC
+C WTEDY HIDDEN .
+ IF (MIDB .EQ. 0) GOTO 1000
+C------TU PRZYPADEK NAZWY ODNALEZIONEJ
+C...... SPRAWDZENIE DOSTEPNOSCI IDENTYFIKATORA
+ IF ( IPMEM(MIDB + 1) .GE. 4 ) GOTO 1200
+C IDENTYFIKATOR NIE JEST NA LISCIE TAKEN
+ IF ( (IPMEM(MIDB+1) .GE. 2) .AND. (.NOT. OWN) ) GOTO 1300
+C IDENTYFIKATOR JEST HIDDEN W KTORYMS Z PREFIKSOW
+ RETURN
+C
+C------TU PRZYPADEK NAZWY NIEODNALEZIONEJ
+ 1000 CALL MERR(600, ID)
+C DODEKLAROWANIE NAZWY - ELEMENTU LISTY HASH-U
+ 1100 MIDB = INSERT(ID, IPMEM(P+10), 0)
+ LOCAL = 2
+ RETURN
+C
+C...... SYGNALIZACJE BLEDOW DLA NIEDOSTEPNYCH ATRYBUTOW
+ 1200 CALL MERR(620, ID)
+ IF (.NOT. OWN) GOTO 1100
+ IPMEM(MIDB+1) = 0
+ IPMEM(MIDB+2) = NRUNIV
+ RETURN
+ 1300 CALL MERR(619, ID)
+ GOTO 1100
+C
+ END
+*NEWDECK MEMSL
+ INTEGER FUNCTION MEMSL (NAME, IDPROT)
+C-------------WYSZUKUJE NAZWE NAME W PROTOTYPIE IDENTYFIKOWANYM PRZEZ
+C IDPROT ORAZ JEGO OTOCZENIU (PO SL-ACH). WARTOSCIA JEST
+C ELEMENT LISTY HASH-U Z TA NAZWA LUB 0 - GDY TEJ NAZWY
+C NIE BYLO.
+C / JESLI NAZWA WYSTAPILA BEZPOSREDNIO W IDPROT LUB JEGO
+C PREFIKSACH - WARTOSCIA
+C ZMIENNEJ LOCAL Z BLOKU // JEST 2, WPP 0 LUB 1
+C / PO ODNALEZIENIU NAZWY ELEMENT PRZESUWANY NA POCZATEK
+C LISTY HASH-U.
+C / OWN MA WARTOSC .TRUE. JESLI NAZWA ODNALEZIONA JEST
+C BEZPOSREDNIO W PROTOTYPIE A NIE W PREFIKSIE.
+C TO ZNACZY TAM WYSTEPUJE W LISCIE - DO KONTROLI PROTEKCJI.
+C /OBJECT - PROTOTYP OBIEKTU, W KTORYM ODNALEZIONO ATRYBUT O
+C NAZWIE NAME
+C
+C OPIS W DOKUMENTACJI: B.III.2.4
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 117
+C.......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C *CALL MEM
+C.....
+C KOMUNIKACJA Z PROCEDURA MEMPRF
+ COMMON /MEM/ NM, NH
+C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
+C
+ NM = NAME
+ NH = IAND( ISHFT(NAME, -1), 7) + 1
+C NH - WARTOSC FUNKCJI HASZUJACEJ DLA SZUKANEJ NAZWY
+C
+ LOCAL = 2
+ ISL = IDPROT
+C ISL - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW
+C
+C *****
+C
+C WYSZUKUJEMY W PREFIKSACH PROTOTYPU ISL
+ 10 MEMSL = MEMPRF(ISL)
+ IF (MEMSL .NE. 0) GOTO 20
+C POWROT, GDY NAZWA JUZ ODNALEZIONA
+C
+C ..... NAZWA NIEODNALEZIONA W PROTOTYPIE ISL - POBRANIE NOWEGO PROTOTY-
+C PU
+ IF (ISL .EQ. NBLSYS) GOTO 1000
+C SKOK - JESLI DOSZLISMY DO BLOKU SYSTEMOWEGO NIE ZNAJDUJAC
+C NAZWY - BEDZIE TO POWROT
+ ISL = IPMEM(ISL-1)
+ LOCAL = 1
+ GOTO 10
+C *****
+C .... NAZWA ODNALEZIONA
+ 20 IF (ISL .EQ. NBLUS) LOCAL = 0
+ RETURN
+C
+C .... NAZWA NIEODNALEZIONA
+ 1000 MEMSL =0
+ RETURN
+ END
+*DECK MEMPRF
+ INTEGER FUNCTION MEMPRF ( IDPROT)
+C-------------WYSZUKUJE NAZWE NM W PROTOTYPIE IDENTYFIKOWANYM PRZEZ
+C IDPROT ORAZ JEGO PREFIKSACH. WARTOSCIA JEST
+C ELEMENT LISTY HASH-U Z TA NAZWA LUB 0 - GDY TEJ NAZWY
+C NIE BYLO.
+C / JESLI NAZWA WYSTAPILA BEZPOSREDNIO W IDPROT WARTOSCIA
+C / ZMIENNEJ OWN JEST .TRUE., JESLI W PREFIKSACH - .FALSE.
+C //PO ODNALEZIENIU NAZWY ELEMENT PRZESUWANY NA POCZATEK
+C LISTY HASH-U.
+C OPIS W DOKUMENTACJI: B.III.2.3
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 261
+C.......................................................................
+C
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C *CALL MEM
+C.....
+C KOMUNIKACJA Z PROCEDURA MEMPRF
+ COMMON /MEM/ NM, NH
+C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
+C
+C
+ IPR = IDPROT
+ OBJECT = IDPROT
+ OWN = .TRUE.
+C IPR - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW
+C
+ IF (IPMEM(IPR) .EQ. 1) GOTO 500
+ IF (IAND( ISHFT(IPMEM(IPR), -4), 15) .NE. 0) GOTO 500
+C SKOK, GDY BYL TO ZWYKLY BLOK LUB PROTOTYP FORMALNY, NIE MA
+C WTEDY PRZEJSCIA PO PREFIKSACH
+ IF (IAND(ISHFT(IPMEM(IPR), -8), 7) .EQ. 7) GOTO 500
+C SKOK - GDY BYL TO PROTOTYP HANDLERA, NIE MA PRZEJSCIA PO PREFIKSACH
+C I,J - WSKAZNIKI PRZECHODZENIA PO LISCIE HASH-U - J AKTUALNY,
+C I POPRZEDNI
+C *****
+ 10 J = IPR+ NH+ 9
+ J = IPMEM(J)
+ I = -1
+C ..... SZUKANIE W PROTOTYPIE IPR
+ 20 IF (J.EQ.0) GOTO 25
+C SKOK - NAZWA NIEODNALEZIONA - POBIERAMY KOLEJNY PROTOTYP
+C
+ IF (IPMEM(J).EQ. NM) GOTO 100
+C SKOK - NAZWA ODNALEZIONA
+C
+ I =J
+ J = IPMEM (J+3)
+ GOTO 20
+C .....
+C NAZWA NIEODNALEZIONA W PREFIKSIE IPR - POBRANIE NOWEGO
+C PREFIKSU
+C
+ 25 OWN = .FALSE.
+C PRZEJSCIE DO PREFIKSU
+ IPR = IPMEM(IPR+21)
+ IF (IPR .NE. 0) GOTO 10
+ GOTO 1000
+C
+C *****
+C
+C ..... NAZWA ODNALEZIONA
+ 100 MEMPRF = J
+ OBJECT = IPMEM(J+2)
+C MIEJSCE DEKLARACJI
+ OBJECT = IPMEM(OBJECT-1)
+ IF (I.NE.-1) GOTO 110
+ RETURN
+C PRZESUNIECIE ELEMENTU NA POCZATEK LISTY
+ 110 IPMEM(I+3) = IPMEM (J+3)
+ I = IPR+ NH + 9
+ IPMEM(J+3) = IPMEM(I)
+ IPMEM(I) = J
+ RETURN
+C
+C.....BLOKI ZWYKLE, HANDLERY I PROTOTYPY FORMALNE
+ 500 MEMPRF = MEMBER(NM, IPMEM(IPR+10))
+ RETURN
+C
+C
+C .... NAZWA NIEODNALEZIONA
+ 1000 MEMPRF =0
+ RETURN
+ END
+*DECK INSERT
+ INTEGER FUNCTION INSERT (NAME, THASH, NROVF)
+C-------------WPROWADZA NOWY ELEMENT O KLUCZU NAME DO TABLICY HASH-U
+C THASH. DZIALA POPRAWNIE POD WARUNKIEM, ZE W TABLICY ELE-
+C MENT TAKI JESZCZE NIE WYSTAPIL.
+C WARTOSCIA INSERT JEST IDENTYFIKATOR TEGO ELEMENTU.
+C / WARTOSCI POCZATKOWE UTWORZONEGO ELEMENTU
+C POLE NAZWY - NAME
+C BITY HIDDEN, CLOSE, NOT TAKEN - 0
+C IDENTYFIKATOR ATRYBUTU - NRUNIV
+C / NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
+C
+C OPIS W DOKUMENTACJI: B.III.2.1
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 95
+C.......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ INTEGER THASH(8)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C
+C ..... REZERWACJA PAMIECI NA ELEMENT LISTY HASH-U
+ INSERT = MGETM(4, NROVF)
+C
+C ..... NADANIE WARTOSCI POCZATKOWYCH I DOLACZENIE DO LISTY HASH-1
+ IPMEM(INSERT) = NAME
+ IPMEM(INSERT +2) = NRUNIV
+ NH = IAND( ISHFT(NAME, -1), 7) + 1
+ IPMEM(INSERT+3) = THASH (NH)
+ THASH(NH) = INSERT
+ RETURN
+ END
+*DECK MEMBER
+ INTEGER FUNCTION MEMBER (NAME, THASH)
+C-------------SPRAWDZA, CZY W TABLICY HASH-U THASH WYSTEPUJE NAZWA
+C NAME. JESLI TAK - WARTOSCIA JEST IDENTYFIKATOR ELEMENTU
+C LISTY HASH-U Z TA NAZWA. JESLI NIE - WARTOSCIA JEST 0 .
+C / JESLI NAZWA WYSTAPILA - ELEMENT JEJ ODPOWIADAJACY JEST
+C PRZESUWANY NA POCZATEK LISTY.
+C
+C OPIS W DOKUMENTACJI: B.III.2.2
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 155
+C......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ INTEGER THASH (8)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+ NH = IAND( ISHFT(NAME, -1), 7) + 1
+C NH - WARTOSC FUNKCJI HASZUJACEJ - INDEKS W TABLICY THASH SLOWA
+C ZAWIERAJACEGO POCZATEK LISTY
+C
+C I,J - WSKAZNIKI PORUSZANIA SIE PO LISCIE
+C J - WSKAZNIK AKTUALNY, I - POPRZEDNI
+ I=-1
+ J = THASH(NH)
+C
+ 10 IF (J.EQ.0) GOTO 200
+C SKOK - JESLI ATRYBUT NIE ZOSTAL ODNALEZIONY
+C
+ IF (IPMEM(J) .EQ. NAME ) GOTO 100
+C SKOK - JESLI ATRYBUT ODNALEZIONY
+ I = J
+ J = IPMEM(J+3)
+ GOTO 10
+C
+C ..... NAZWA ODNALEZIONA
+ 100 MEMBER = J
+ IF (I.NE. -1) GOTO 110
+ RETURN
+C PRZESUNIECIE ELEMENTU LISTY NA POCZATEK LISTY
+ 110 IPMEM(I+3) = IPMEM(J+3)
+ IPMEM(J+3) = THASH(NH)
+ THASH(NH) = J
+ RETURN
+C
+C ..... NAZWA NIEODNALEZIONA
+ 200 MEMBER = 0
+ RETURN
+ END
+*DECK MGETM
+ INTEGER FUNCTION MGETM(ISIZE, NROVF)
+C-------------REZERWUJE W PAMIECI IPMEM ISIZE KOMOREK. WAROSCIA MGETM
+C JEST INDEKS PIERWSZEJ Z TYCH KOMOREK.
+C REZERWACJA JEST DOKONYWANA W CZESCI SYSTEMOWEJ JESLI WAR-
+C TOSC ZMIENNEJ INSYS (BLOK //) JEST .TRUE., W PRZE-
+C CIWNYM PRZYPADKU - W CZESCI UZYTKOWNIKA.
+C /// GDY REZERWACJA TA NIE JEST MOZLIWA - WYWOLYWANA JEST
+C PROCEDURA MDROP PRZERYWAJACA PROCES KOMPILACJI
+C NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
+C
+C OPIS W DOKUMENTACJI: B.III.1
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 145
+C...........................................................................
+C
+C ZAREZERWOWANA PAMIEC JEST WYZEROWANA
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C
+ IF ( (LPML+ISIZE) .GT. LPMF) GOTO 1000
+C SKOK - GDY WOLNY OBSZAR JEST ZA MALY
+ IF (INSYS) GOTO 100
+C
+C ..... PRZYDZIAL PAMIECI W CZESCI UZYTKOWNIKA
+ LPMF = LPMF - ISIZE
+ DO 50 I = 1, ISIZE
+ J = LPMF + I
+ IPMEM(J) = 0
+ 50 CONTINUE
+ MGETM = LPMF + 1
+ GOTO 500
+C
+C ..... PRZYDZIAL PAMIECI W CZESCI SYSTEMOWEJ
+ 100 MGETM = LPML
+ DO 150 I = 1, ISIZE
+ J = LPML + I
+ IPMEM(J - 1) = 0
+ 150 CONTINUE
+ LPML = LPML + ISIZE
+C.....SPRAWDZENIE WYKORZYSTANIA PAMIECI
+ 500 X = LPMF-LPML
+ IF (X .LT. COM(4)) COM(4) = X
+ RETURN
+C
+C
+C ..... BRAK MIEJSCA W PAMIECI
+ 1000 CALL MDROP(NROVF)
+C
+ END
+*DECK MPRFSQ
+ INTEGER FUNCTION MPRFSQ (IDPR1, IDPR2)
+C-------------BADA RODZAJ PREFIKSOWANIA TYPOW IDPR1 I IDPR2
+C WARTOSCI
+C -1 - ROZLACZNE SEKWENCJE PREFIKSOWE
+C 0 - IDPR1 PREFIKSUJE IPR2
+C +1 - IDPR2 PREFIKSUJE IDPR1
+C OBA TYPY MOGA BYC TYPAMI UNIWERSALNYMI
+C
+C OPIS W DOKUMENTACJI: B.III.4.3
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 79
+C........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BPREF
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C
+ K1 = IPMEM(IDPR1-6)
+ K2 = IPMEM(IDPR2-6)
+C K1,K2 - NUMERY TYPOW W SENSIE PREFIXSET
+ IF (BPREF(IDPR2, K1)) GOTO 20
+ IF (BPREF(IDPR1, K2)) GOTO 30
+C
+C ..... ROZLACZNE SEKWENCJE PREFIKSOWE
+ MPRFSQ = -1
+ RETURN
+C ..... IDPR1 PREFIKSUJE IDPR2
+ 20 MPRFSQ = 0
+ RETURN
+C ..... IDPR2 PREFIKSUJE IDPR1
+ 30 MPRFSQ = +1
+ RETURN
+C
+ END
+*DECK BPREF
+ LOGICAL FUNCTION BPREF (IDPROT, NRPREF)
+C-------------BPREF SPRAWDZA, CZY TYP IDENTYFIKOWANY PRZEZ IDPROT JEST
+C PREFIKSOWANY PRZEZ KLASE, KTOREJ NUMER W SENSIE PREFIXSET
+C JEST ROWNY NRPREF.
+C WARTOSC .TRUE. - JEST PREFIKSOWANY
+C
+C
+C OPIS W DOKUMENTACJI: B.III.4.1
+C WERSJA Z DNIA: 19.03.82 (MJL)
+C DLUGOSC KODU: 255
+C.........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL BTEST
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C
+ IF (NRPREF .GT. 47) GOTO 300
+ K=NRPREF/16
+ IF ( IAND(IPMEM(IDPROT), 15) .NE. 1) GOTO 100
+ BPREF = .FALSE.
+ IF (IPMEM(IDPROT+21) .EQ. 0 ) RETURN
+ K = IPMEM(IDPROT+21) -3-K
+ GOTO 200
+ 100 K=IDPROT-3-K
+ 200 K=IPMEM(K)
+C K SLOWO W PREFIXSET, W KTORYM NALEZY ZBADAC BIT ODPOWIADAJACY
+C NRPREF
+C
+ L=IAND(NRPREF,15)
+C L - NUMER TESTOWANEGO BITU - L = IMOD(NRPREF,16)
+C
+ BPREF = BTEST (K,L)
+ RETURN
+ 300 BPREF = .TRUE.
+ IPR = IDPROT
+ IF (IAND(IPMEM(IPR), 15) .EQ. 1) IPR = IPMEM(IPR+21)
+ IF (IPR .EQ. 0) GOTO 500
+ IF (IPR .EQ. NRUNIV) RETURN
+ IDL = IPMEM(IPR+23)
+ IPR = IPMEM(IPR+22)
+ 400 PRFX= IPMEM(IPR)
+ IF (IPMEM(PRFX-6) .EQ. NRPREF) RETURN
+ IDL = IDL-1
+ IPR = IPR+1
+ IF (IDL .NE. 0) GOTO 400
+ 500 BPREF = .FALSE.
+ RETURN
+ END
+
+ SUBROUTINE MDROP(NROVFL)
+C-------------PROCEDURA PRZERYWA DZIALANIE MODULU.
+C WYWOLYWANA JEST W PRZYPADKU PRZEPELNIEN JAKIEJKOLWIEK TAB-
+C LICY KOMPILATORA.
+C NROVFL - NUMER PRZEPELNIENIA (INFORMACJA O TABLICY)
+C //WYWOLUJE PROCEDURE MERR , BUFORY STRUMIENI PRZESYLA DO
+C OBSZARU KOMUNIKACYJNEGO W BLOKU //.
+C USTAWIA FLAGE "DROPOWANIA".
+C
+C OPIS W DOKUMENTACJI: B.I.2
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 101
+C......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C.....
+#include "blank3.h"
+ LOGICAL ERRFLG
+C
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C ERRFLG - FLAGA BLEDOW
+C
+C SYGNALIZOWANIE BLEDU
+ LINE = 9999
+ CALL MERR(NROVFL, 0)
+C
+ DROPFG = .TRUE.
+C ERRFG = .TRUE.
+ IOP(1) = IOP(1)+7
+ CALL MESS
+ CALL ML2
+ RETURN
+ END
+
+ SUBROUTINE MERR(NRE, ID)
+C--------------PROCEDURA WPISUJACA SYGNALIZACJE BLEDOW NA STRUMIEN 2
+C NRE - NUMER BLEDU
+C ID - IDENTYFIKACJA BLEDU, TO ZNACZY
+C -IDENTYFIKATOR ZE SCANNERA,
+C -ZANEGOWANY ZNAK W PRAWYM BAJCIE,
+C -ZERO OZNACZAJACE BRAK IDENTYFIKATORA.
+C //PROCEDURA W RAZIE POTRZEBY NISZCZY DOTYCHCZASOWY
+C ZAPIS ZNAJDUJACY SIE NA STRUMIENIU SO (KOD DLA ASSEMBLERA)
+C ORAZ USTAWIA FLAGE BLEDOW ERRFLG.
+C
+C OPIS W DOKUMENTACJI: B.I.1
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 146
+C.................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL STREAM
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C ERRFLG - FLAGA BLEDOW
+C !!!!!! END OF SUBSTITUTION OF COMDECK STREAM FROM LOGLAN.14 !!
+C *CALL MJLMSG
+ COMMON /MJLMSG/ IERC, MSG
+C !!!!!! END OF SUBSTITUTION OF COMDECK MJLMSG FROM LOGLAN.14 !!
+
+cdeb --------------------- added =----------------
+ common /debug/deb,breakt(500),brnr,maxbr
+ logical deb
+cdeb ---------------------------------------
+C
+C
+C----- ZBADANIE, CZY JEST TO PIERWSZY SYGNALIZOWANY BLAD
+ IF (ERRFLG) GOTO 100
+
+C..... PRZYPADEK, GDY BLAD JEST SYGNALIZOWANY PO RAZ PIERWSZY
+ ERRFLG = .TRUE.
+C --- L-CODE WRITTEN DIRECTLY IN THE SIEMENS VERSION
+C --- IN THE SIEMENS VERSION OF THE COMPILER IBUF2 IS USED ONLY
+C --- TO LOCATE THERE INFORMATION ABOUT ERRORS. SO NOW IT IS THE
+C --- PROPER TIME TO OPEN IT
+cdeb
+ deb = .false.
+cdeb
+
+c --- unit 19 (ibuf2) - do bledow (direct)
+ CALL OPENF(IBUF2,19)
+C OD TEJ PORY BUFOR ZACZYNA ODPOWIADAC STRUMIENIOWI O DOSTEPIE
+C BEZPOSREDNIM . JEGO BUDOWA:
+C SLOWA 1-7 -BUFOR DLA PROCEDUR ZAPISU I ODCZYTU (OPIS STRUMIENIA)
+C SLOWO 8 -NUMER AKTUALNIE ZAPISYWANEGO BLOKU
+C SLOWO 9 -INDEKS PIERWSZEJ WOLNEJ POZYCJI BLOKU AKTUALNIE TWORZO-
+C NEGO
+C SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU
+C SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO-
+C WA 11)
+C
+ IBUF2(8) = 0
+ IBUF2(9) = 11
+C
+C-----WPISANIE SYGNALIZACJI BLEDU
+ 100 IERC = IERC+1
+ POZ = IBUF2(9)
+C POZ - AKTUALNA POZYCJA DO WYPELNIENIA
+C ZAPISANIE NUMERU LINII, NUMERU BLEDU I IDENTYFIKACJI
+ IBUF2(POZ) = LINE
+ IBUF2(POZ+1) = NRE
+ IBUF2(POZ+2) = ID
+C MODYFIKACJA BUFORA
+ POZ = POZ+3
+ IBUF2(9) = POZ
+ IF (POZ .LE. 263) RETURN
+C ..... JESLI BLOK ZOSTAL ZAPELNIONY, ZAPISANIE GO NA DYSK
+ IBUF2(8) = IBUF2(8) + 1
+ IBUF2(9) = 11
+ IBUF2(10) = 85
+ CALL PUT(IBUF2, IBUF2(10))
+ RETURN
+ END
+
+ SUBROUTINE MADATR (IDATR, IDPROT, NROVF)
+C-------------WPROWADZA ATRYBUT O IDENTYFIKATORZE IDATR DO LISTY ATRYBU-
+C TOW PROTOTYPU IDPROT. W OPISIE ATRYBUTU NADAJE WARTOSC
+C POLOM DECLPLACE/SL ORAZ NUMERU ATRYBUTU
+C // NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
+C
+C OPIS W DOKUMENTACJI: B.III.3
+C WERSJA Z DNIA: 19.01.82 (MJL)
+C DLUGOSC KODU: 99
+C.........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C
+ IACT = MGETM(2, NROVF)
+ IPMEM(IACT) = IDATR
+ IOST = IPMEM(IDPROT+7)
+C IOST - OSTATNI ELEMENT LISTY ATRYBUTOW
+C ..... DOLACZENIE IACT DO LISTY ATRYBUTOW
+ IPMEM(IOST+1) = IACT
+ IPMEM(IDPROT+7) = IACT
+C ..... NADANIE WARTOSCI SL ORAZ NUMERU ATRYBUTU
+ IOST = IPMEM(IOST)
+C IOST - OSTATNI ATRYBUT - INDEKS OPISU
+ IPMEM(IDATR-1) = IDPROT
+ IPMEM(IDATR-2) = IPMEM(IOST-2) + 1
+ RETURN
+ END
+ SUBROUTINE MSETB (IDPROT, NRPREF)
+C-------------W ZBIORZE PREFIXSET TYPU IDENTYFIKOWANEGO PRZEZ IDPROT
+C USTAWIA BIT NRPREF NA 1
+C
+C OPIS W DOKUMENTACJI: B.III.4.2
+C WERSJA Z DNIA: 19.03.82 (MJL)
+C DLUGOSC KODU: 87
+C.......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C *CALL BLANK
+C.....
+#include "blank2.h"
+C
+C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
+C
+ IF (NRPREF .GT. 47) RETURN
+ K= NRPREF/16
+ K= IDPROT-3-K
+C K - INDEKS MODYFIKOWANEGO ELEMENTU PREFIXSET
+C
+ L= IAND(NRPREF,15)
+C L - NUMER ZAPALANEGO BITU
+ L= ISHFT(1,L)
+C
+ IPMEM(K) = IOR ( IPMEM(K), L)
+ RETURN
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+c
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
+C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
+C NRRE - REAL
+C NRBOOL - BOOLEAN
+C NRCHR - CHARACTER
+C NRCOR - COROUTINE
+C NRPROC - PROCESS
+C NRTEXT - STRING (TEXT)
+C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
+C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
+C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
+C REFERENCYJNY)
+C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
+C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
+C
+C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
+C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
+C MOWEJ
+C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
+C BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
+C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
+C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
+C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
+C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
+C
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+C
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ IOP(4),
+ X P,
+ X TLDIM, TLBAS, IDL, OBJL,
+ X TRDIM, TRBAS, IDR, OBJR,
+ X TRESLT,
+ X CONVL, CONVR,
+ X NRPAR,
+ X IX (261),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL, OWN, OBJECT,
+ X IPMEM(5000)
+ REAL STALER(100)
+ INTEGER STACK(5000)
+ EQUIVALENCE(STALER(1),IPMEM(1))
+ EQUIVALENCE(STACK(1),IPMEM(1))
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ LOGICAL ERRFG, DROPFG
+ COMMON /BLANK/ IOP(4),
+ X ERRFG, DROPFG, ISBUF2(265), ISBUF3(7),
+ X IX(5024)
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ subroutine ts1
+ implicit integer(a-z)
+c wolana po it1
+c wpisuje do tablicy prs nazwe i numer linii prototypu
+c prs(2*i-1) = nazwa, prs(2*i) = numer linii prototypu i
+c prototypy liczone od isfin do lpmem
+ common /debpr/ prs(600)
+ common /BLANK/ com(278),
+ x lmem,lpmem,irecn,isfin,
+ x com1(20),
+ x mem(5000)
+
+ do 100 i=isfin,lpmem
+ k = mem(i)
+ p = mem(k)
+c k - adres slowa zerowego prototypu o numerze i
+ j = i-isfin+1
+c nazwa
+ prs(2*j-1) = -100
+c blok i handler nie maja nazwy
+ if(p.ne.1.and.p.ne.8) prs(2*j-1) = mem(k+10)
+c numer linii
+ prs(2*j) = mem(k+9)
+100 continue
+ call dsw
+ return
+ end
+
+ subroutine TS2
+ implicit integer(a-z)
+c przebieg wolany po DSW
+c wypelnia prototypy debuggera prawie do konca
+c DISPNR(3) i dla zmiennych OFFSET (3) = adres prototypu kompilacjnego
+c
+c -----------------------------------------------------
+c BUDOWA PROTOTYPOW
+c
+c -1 nazwa modulu ( hash ze scannera)
+c 0 case
+c 1 SL - numer prot. debuggera w IDICT
+c 2 numer linii z poczatkien definicji
+c 3 dispnr
+c 4 prefiks - numer prot. debuggera w IDICT
+c 5 mala tablica hash nazw atrybutow
+c . (jak w DSW)
+c 12
+c 13 elementy listy hash i prototypy zmiennych
+c . i stalych
+c .
+c ----------------------------------------------------
+c
+c ZMIENNA
+c
+c 0 case
+c 1 liczba array of
+c 2 typ - numer prototypu debuggera w IDICT
+c 3 offset
+c 4 SL - numer prototypu debuggera w IDICT
+c
+c UWAGA: typ: typ formalny = -10, typ prymitywny = -typ kompilacyjny
+c typ uniwersalny = 0, typ process/coroutine = -typ komp.
+c
+c ---------------------------------------------------
+c
+c STALA
+c
+c 0 case
+c 1 typ - numer prototypu ( dla typu prymitywnego = -typ komp.)
+c 2 adres stalej w tablicy stalych
+c
+c UWAGA: procedura, funkcja i typ formalny nie maja prototypow, ale
+c wystepuja w tablicy hash (malej)
+c
+c --------------------------------------------------
+c
+c CASE: 1 - block, 2 - klasa, 3 - procedura, 4 - funkcja
+c 5 - zmienna
+c 7 - funkcja form., 8 - proc. form,
+c 9 - stala
+c 10 - process, 11 - coroutina, 12 - rekord
+c 14 - handler, 15 - sygnal
+c
+c --------------------------------------------------
+c
+c ELEMENT LISTY HASH
+c
+c 0 nazwa ze scannera
+c 1 NT/H/C - 3 bity
+c 2 numer prototypu debuggera: dla unitow - w IDICT, dla zmiennych
+c i stalych = -adres bezp. protrotypu
+c proc/fun/typ formalny = -7,-8,-10
+c
+c ----------------------------------------------------
+
+c-------------------------------------------------------
+c budowa pliku 21:
+c hash(8000), idict(500), ind,prot(ind)
+c-------------------------------------------------------
+
+ common /BLANK/ com(8000)
+ call deb2
+ call AL1
+ return
+ end
+
+ subroutine deb2
+c glowna procedura tworzaca prototypy debuggera
+ implicit integer (a-z)
+ logical btest
+ common /BLANK/ com(278),
+ x lmem,lpmem,irecn,isfin,
+ x com2(7),
+ x nrcor, nrproc,
+ x com3(5),
+ x nblus,
+ x com1(5),
+ x mem(8000)
+
+ common /pr/ prot(5000),ind
+c prot - tablica na prototypy debuggera
+c ind - ostatnie zajete miejsce w tablicy
+
+ common/debpr/prs(600)
+c prs zawiera nazwy i numery linii kolejnych prototypow
+c prs(2*i-1) = nazwa, prs(2*i) = nr. linii prot. i-tego
+c prototypy liczone sa od isfin do lpmem
+
+ dimension idict(500),chang(500)
+cps dimension idict(300),chang(300)
+c idict(i) - adres w prot prototypu o numerze disp. i-1
+c chang(i) - numer z parsera prototypu o numerze w idict=i
+
+ data idict/500*0/
+cps data idict/300*0/
+
+c curr - pierwsze wolne miejsce w tablicy prot
+c zw - miejsce slowa zerowego biezacego prototypu
+
+ ind = 0
+ curr = 1
+c przepelnienie ?
+ if(lpmem-isfin+1 .gt. 500) call mdrop(199)
+cps if(lpmem-isfin+1 .gt. 300) call mdrop(199)
+
+c------- budowa tablicy chang
+ p = nblus
+ i = 1
+10 continue
+ k = mem(p)
+c pomijamy formalne i sygnaly
+ if(btest(k,4).or.btest(k,5)) go to 11
+ if(btest(k,7)) go to 11
+ chang(i) = findnr(p)
+ i = i+1
+ 11 p = mem(p+2)
+ if(p.ne.0) go to 10
+c-----------
+
+ k = nblus
+ i = 1
+c----------- glowna petla
+5000 continue
+c k - adres slowa zerowego prototypu kompilacyjnego
+ call zerow(k,case1)
+c sygnal nie ma prototypu
+ if(case1.eq.15) go to 5001
+c formalne tez nie maja prototypow
+ if(case1.eq.7.or.case1.eq.8.or.case1.eq.-10) go to 5001
+ zw = curr+1
+ idict(i) = zw
+ call getm(4)
+c wypelnienie pierwszych 4-ech slow opisu
+c nazwa
+ j = chang(i)
+ prot(curr) = prs(2*j-1)
+c case
+ prot(zw) = case1
+c SL
+ p = mem(k-1)
+ prot(zw+1) = findsc(p)-1
+c numer linii
+ prot(zw+2) = prs(2*j)
+ call getm(10)
+ curr = curr+14
+ if(case1.eq.14) go to 12
+c handler nie ma prefiksu
+ id = mem(k+21)
+ j = findsc(id)
+ if(j.eq.0) go to 12
+ prot(zw+4) = j-1
+ 12 prot(zw+3) = k
+c k - ident. opisu wstawiany w miejsce przyszlego dispnr
+c wypelniamy tablice hash'u
+c curr - teraz bedzie oznaczlo pierwsze wolne miejsce do tworzenia
+c elementow listy
+
+ curr1 = curr
+ do 101 j=5,12
+ prot(zw+j) = curr
+ t = k+j+5
+ l = mem(t)
+ 102 if(l.eq.0) go to 151
+c miejsce na element listy
+ curr = curr+3
+ call getm(3)
+ l = mem(l+3)
+ go to 102
+ 151 call getm(1)
+ curr = curr+1
+ 101 continue
+
+c teraz beda wypelniane elementy listy i tworzone nowe prototypy
+c curr - pierwsze wolne miejsce do tworzenia prototypow
+c curr1 - wskaznik do chodzenia po elementach listy
+
+ do 100 j=5,12
+ t = k+j+5
+ l = mem(t)
+ 30 if(l.eq.0) go to 150
+c l - poiter do nastepnego elementu listy
+c element listy hash'u
+c nazwa ze scannera
+ prot(curr1) = mem(l)
+c NT/H/C
+ prot(curr1+1) = mem(l+1)
+ id = mem(l+2)
+c id opisu w ipmem
+ call zerow(id,case)
+ if(case.eq.7.or.case.eq.8.or.case.eq.-10.or.case.eq.15) goto 250
+ if(case.eq.5) go to 200
+ if(case.eq.9) go to 400
+
+c unit - nie bedzie nowego opisu
+ prot(curr1+2) = findsc(id)-1
+ go to 90
+
+c zmienna
+ 200 t = mem(l+1)
+ if(btest(t,2)) go to 300
+c nowy opis zmiennej
+ prot(curr1+2) = -curr
+c adres bezposredni prototypu debuggera
+ call getm(5)
+c wpisanie numeru opisu do mem(l+1)
+ mem(l+1) = curr*8
+c case
+ prot(curr) = case
+ prot(curr+1) = mem(id-4)
+c process/ coroutine systemowe ?
+ p = mem(id-3)
+ t = -p
+ if(p.eq.nrproc.or.p.eq.nrcor) go to 240
+ call zerow(p,t)
+ if(t.ne.2.and.t.lt.10) go to 240
+c typ klasowy - nie prymitywny i nie formalny
+ t = findsc(mem(id-3))-1
+ 240 prot(curr+2) = t
+c id prototypu w ipmem zamiast offsetu
+ prot(curr+3) = id
+c sl
+ prot(curr+4) = findsc(mem(id-1))-1
+ curr = curr+5
+ go to 90
+c zmienna not taken
+300 t = ishft(t,-8)
+ prot(curr1+2) = -t
+ go to 90
+
+c stala - nowy opis
+ 400 call getm(3)
+ prot(curr1+2) = -curr
+c -adres bezposredni prototypu debuggera
+ prot(curr) = case
+c typ prymitywny
+ call zerow(mem(id-3),t)
+ prot(curr+1) = t
+c ident. stalej w tablicy stalych
+ prot(curr+2) = mem(id-1)
+ curr = curr+3
+ go to 90
+
+c proc/fun/typ formalne - nie ma prototypu
+ 250 if(case.ne.-10) case = -case
+ prot(curr1+2) = case
+
+c nastepny element listy
+ 90 curr1 = curr1+3
+ l = mem(l+3)
+ go to 30
+c straznik
+ 150 curr1 = curr1+1
+ 100 continue
+
+ i = i+1
+5001 continue
+ k = mem(k+2)
+ if(k.ne.0) go to 5000
+c-------------------- koniec wypelniania prototypow
+
+c skasowanie zapamietanej uprzednio w MEM informacji dla zmiennych
+
+ id = X'0007'
+ do 111 i = isfin, lpmem
+ k = mem(i)
+ do 112 j = 1,8
+ t = k+j+9
+ l = mem(t)
+ 110 if(l.eq.0) go to 112
+c wyzerowanie bitow 3-15
+ mem(l+1) = iand(mem(l+1),id)
+ l = mem(l+3)
+ go to 110
+ 112 continue
+ 111 continue
+
+c wypisanie idict
+ call out(idict,500)
+cps call out(idict,300)
+c wypisanie ind - ostatnie zajete miejsce w prot
+ call out(ind,1)
+c wypisanie prot do miejsca ind
+ call out(prot,ind)
+ return
+ end
+
+ subroutine getm(n)
+ implicit integer(a-z)
+ common /pr/ prot(5000), ind
+c sprawdza, czy jest jeszcze miejsce w PROT
+c ind - ostatnie zajete
+ ind = ind+n
+ if(ind.le.5000) return
+c przepelnienie - za duzo prototypow
+ call mdrop(41)
+ return
+ end
+
+ subroutine out(tab,n)
+ implicit integer(a-z)
+ dimension tab(n)
+ call ffwrite_ints(21, tab, n)
+ return
+ end
+
+ subroutine zerow(kk,id)
+ implicit integer(a-z)
+ logical btest
+ common /BLANK/ com(302), mem(6890)
+c odkodowuje slowo zerowe o adresie kk, wynik na id (case)
+c dla typow prymitywnych wynik = -kk
+c dlA typu uniwersalnego wynik = 0
+
+ k = mem(kk)
+c uniwersalny ?
+ if(k.eq.4) go to 300
+c prymitywny ?
+ if(btest(k,3)) go to 5
+ if(btest(k,1).and..not.btest(k,2)) go to 10
+ if(btest(k,2).and..not.btest(k,1).and..not.btest(k,0)) go to 100
+ if(btest(k,2).and.btest(k,0).and..not.btest(k,1)) go to 30
+ if(btest(k,1).and.btest(k,2).and.btest(k,0)) go to 40
+ if(btest(k,2).and.btest(k,1).and..not.btest(k,0)) go to 90
+ if(.not.btest(k,2).and..not.btest(k,1).and.btest(k,0)) go to 100
+
+c typ prymitywny
+5 id = -kk
+ return
+c klasa lub rekord
+ 10 id = 12
+ if(btest(k,0)) id = 2
+ return
+c process
+ 30 id = 10
+ return
+c coroutine
+ 40 id = 11
+ return
+c typ formalny
+ 90 id = -10
+ return
+c stala
+ 150 id = 9
+ return
+c zmienna
+ 140 id = 5
+ return
+c block
+ 160 id = 1
+ return
+c funkcja formalna
+ 110 id = 7
+ return
+c proc. formalna
+ 120 id = 8
+ return
+c funkcja
+ 170 id = 4
+ return
+c procedura
+ 180 id = 3
+ return
+c handler
+ 190 id = 14
+ return
+c sygnal
+ 155 id = 15
+ return
+c nie typ
+100 continue
+ if(btest(k,7).and..not.btest(K,6).and..not.btest(k,5).and.
+ x btest(k,4))go to 140
+ if(btest(k,7)) go to 200
+ if(btest(k,6)) go to 140
+ if(btest(k,5).and..not.btest(k,4)) go to 110
+ if(btest(k,5).and.btest(k,4)) go to 120
+ if(.not.btest(k,5)) go to 220
+c stala/signal
+ 200 continue
+ if(.not.btest(k,6).and..not.btest(k,5).and..not.btest(k,4))
+ x go to 150
+ if(.not.btest(k,6).and.btest(k,5).and.btest(k,4)) go to 155
+c procedura/funkcja/blok
+ 220 continue
+ if(.not.btest(k,10).and..not.btest(k,9)) go to 160
+ if(.not.btest(k,10).and.btest(k,9)) go to 170
+ if(btest(k,10).and..not.btest(k,9).and..not.btest(k,8))
+ x go to 180
+ if(btest(k,10).and.btest(k,9).and.btest(k,8)) go to 190
+c typ uniwersalny
+300 id=0
+ return
+ end
+
+ integer function findnr(id)
+ implicit integer(a-z)
+ common /BLANK/ com(278),
+ x lmem,lpmem,irecn,isfin,
+ x com1(20),
+ x mem(7890)
+ if(id.eq.0) go to 1010
+ do 1000 i = isfin,lpmem
+ k = mem(i)
+c adres slowa zerowego
+ if(k.ne.id) go to 1000
+ findnr = i-isfin+1
+ return
+1000 continue
+1010 findnr = 0
+ return
+ end
+
+ integer function findsc(id)
+ implicit integer(a-z)
+ common /BLANK/ com(278),
+ x com2(18),
+ x nblus,
+ x com1(5),
+ x mem(7890)
+ logical btest
+ p = nblus
+ i = 1
+ 100 continue
+ if(p.eq.0) go to 120
+ k = mem(p)
+c formalne i sygnaly sa pomijane w numeracji
+c formalne
+ if(btest(k,4).or.btest(k,5)) go to 111
+c sygnal
+ if(btest(k,7)) go to 111
+ if(id.eq.p) go to 110
+ i = i+1
+111 p = mem(p+2)
+ go to 100
+120 findsc = 0
+ return
+110 findsc = i
+ return
+ end
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE DSW
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C ( BYLY ) PROGRAM GLOWNY
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER (A - Z )
+C
+C
+ COMMON /MJLMSG/ IERC,MSG
+ integer*4 msg
+C
+C
+C BUFORY
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+C.....
+c$include:'blank.for'
+
+cdeb --------------------- added -------------------
+ common /debug/ deb, breakt(500),brnr,maxbr
+ logical deb
+cdeb ------------------------------------------------
+C
+ IERC=0
+ msg = 'dsw '
+C
+C
+ CALL INITMK
+C SUBROUTINE INIT RENAMED TO INITMK 03.01.84 **********************
+ CALL DPASS
+C
+C
+C
+ CALL MESS
+cdeb CALL AL1
+cdeb ------------- added --------------
+ if(deb.and..not.errflg) go to 1000
+ call al1
+ return
+1000 call ts2
+cdeb ----------------------------------
+ END
+
+ BLOCK DATA BLKD
+ IMPLICIT INTEGER (A-Z)
+C
+cdeb
+ common /pr/ prot(5000),ind
+c prot - tablica na prototypy debuggera
+c ind - ostatnie zajete miejsce w tablicy
+cdeb
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW, INOUT
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEc SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- -- --- ZMIENNEJ INOUT
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND
+ *, MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
+C MHAND - WZORZEC DLA HANDLERA
+C
+C
+cdeb------------------------------------------
+cdeb COMMON /NAMES/ RESNM,MAINM
+ common /names/ resnm,mainm,brenam
+cdeb------------------------------------------
+C
+C NAZWY ZE SCANNERA
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+C
+C COMMON / WYDR / KD(8), KSP(4)
+C REAL KD,KSP
+C
+C BLOK UZYWANY W PROCEDURYCH DRUKUJACYCH.
+C KD(KIND+1) - ODPOWIEDNI TEKST DLA PROTOTYPU RODZAJU KIND
+C KSP(KSPEC+1) - ODPOWIEDNI TEKST DLA PROTOTYPU RODZAJU KSPEC.
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C
+C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C RODZAJE PROTOTYPOW:
+C 1 - BLOK, 2 - REKORD, 3 - PROCEDURA, 4 - FUNKCJA, 5 - PROC. Z BLEDNA PF
+C 6 - FUNKCJA Z BLEDNA LISTA PF, 7 - KLASA Z BLEDNA LISTA PF
+C 8 - BLOK PREFIKSOWANY, 9 - PROCEDURA VIRTUALNA, 10 I FUNKCJA VIRTUALNA
+C 11 - PROC. VIRTUALNA Z BLEDNA PF, 12 - FUNKCJA VIRTUALNA Z BLEDNA PF
+C 13 - PROCEDURA FORMALNA, 14 - FUNKCJA FORMALNA, 15 - PROC. FORMALNA
+C Z BLEDNA LISTA PF, 16 - FUNKCJA FORMALNA Z BLEDNA LISTA PF,
+C 17 - TYP FORMALNY, 18 - PROCEDURA FORMALNA II-GO RZEDU,
+C 19 - FUNKCJA FORMALNA II-GO RZEDU
+C 20 - TYP FORMALNY II-GO RZEDU
+C 21 - SYGNAL, 22 - SYGNAL Z USZKODZONA LISTA PF, 23 - HANDLER
+C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+C
+ DATA SIZEPR/23,33,28,31,28,31,33,28,30,33,30,33,20,23,20,23,
+ * 5,5,7,5,19, 19, 21/
+ DATA NULLPOZ/2,7,2,5,2,5,7,2,2,5,2,5,2,5,2,5,2,2,4,2,1,1,2/
+ DATA CONSTWD,VARWD,VARPOM,INPFW,OUTPFW / 129,113,65,81,97 /
+ DATA INOUT /145/
+ DATA NOTTP,MPROCES,MCOR,MBLOCK /1,5,7,0 /
+C DATA KD(1) /5HTYP F/
+C DATA KD(2)/4HKLAS/
+C DATA KD(3) / 4HFUN /
+C DATA KD(4) / 4HPROC/
+C DATA KD(5) / 4HBLOK/
+C DATA KD(6) /4HBLPR/
+C DATA KD(7) /6HSIGNAL/
+C DATA KD(8) /5HHANDL/
+C DATA KSP(1) /4HREK /
+C DATA KSP(2) / 4HKLAS/
+C DATA KSP(3) / 4HPRSS/
+C DATA KSP(4) / 4HCORO/
+ DATA RESNM,MAINM / 2769,819 /
+cdeb ------------- added ---------------
+ data brenam /7797/
+cdeb ----------------------------------
+ DATA NULLWD / 1,2,1025,513,9217,8705,8194,257,3073,2561,11265,
+ * 10753,1073,545,9265,8737,22,1073,545,22,177,8369,1793/
+cdeb
+ data prot /5000*-100/
+cdeb
+ END
+ SUBROUTINE DPASS
+C
+C * * * * * * * * * * * * * * * * * * ** * * * * * * * * * * * *
+C PODPROGRAM REALIZUUACY PRZETWARZANIE PROTOTYPOW
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT iNTEGER (A-Z)
+C
+ COMMON / QUEUE / BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
+cdsw INTEGER BQUEUE, EQUEUE
+ LOGICAL EMPTY
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
+C BQUEUE - POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
+C EQUEUE - KONIEC -- -- -- -- --
+C IFIRST - PIERWSZY ELEMENT KOLEJKI
+C LAST - OSTATNI ELEMENT KOLEJKI
+C EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
+C
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEc SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- -- -- --- ZMIENNEJ INOUT
+C
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
+C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
+C NRRE - REAL
+C NRBOOL - BOOLEAN
+C NRCHR - CHARACTER
+C NRCOR - COROUTINE
+C NRPROC - PROCESS
+C NRTEXT - STRING (TEXT)
+C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
+C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
+C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
+C REFERENCYJNY)
+C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
+C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
+C
+C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
+C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
+C MOWEJ
+C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
+C BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
+C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
+C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
+C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
+C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
+C
+C
+
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W IDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+cdeb COMMON/NAMES/RESNM,MAINM
+cdeb -------------------------------------
+ common /names/ resnm, mainm, brenam
+cdeb ------------------------------------
+C NAZWY ZE SCANNERA
+C
+C
+ COMMON /PREFS/ LPREFS
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C LPREFS - OSTATNIO PRZYDZIELONY NUMER W PREFIXSET
+C
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+
+c system class prototypes:
+ common /syspro/ prgraph, prmouse
+C
+C
+C UTWORZENIE PROTOTYPU BLOKU GLOWNEGO
+ I=IPMEM(LPMEM)
+ LINE = IPMEM(I+9)
+ LASTPR = NBLSYS
+ NBLUS=INITPR(1,0)
+C USTAWIENIE SL BLOKU GLOWNEGO NA SYSTEMOWY
+ IPMEM(NBLUS-1) = NBLSYS
+cdsw
+ ipmem(nblus+2) = prgraph
+ ipmem(prgraph+2) = prmouse
+ lastpr = prmouse
+
+C DOLACZENIE NAZWY I ATRYBUTU MAIN
+ I=MGETM(6,41)+4
+ IPMEM(I)=VARWD
+ IPMEM(I+1)=1
+ CALL MADATR(I,NBLUS,41)
+ IPMEM(I-3)=NRPROC
+ IPMEM(I)=IAP(I)
+ K=IDPUT(MAINM,IPMEM(NBLUS+10))
+ IPMEM(K+2)=I
+ CALL DPUTQ(LPMEM,NBLUS)
+ 100 IF(EMPTY) GO TO 300
+ CALL DGETQ
+ CALL PROTP1
+ CALL PROTP2
+ GO TO 100
+ 300 CONTINUE
+C KONIEC PRZETWARZANIA PROTOTYPOW
+ IPMEM(NBLSYS+3) = LPREFS
+C ... PRZECHOWANIE INFORMACJI O LICZBIE KLAS
+ RETURN
+ END
+ SUBROUTINE INITMK
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C INICJALIZACJA LOKALNA
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C
+cdsw ------------------------------------------------
+ common/signs/nrsig,hliste
+cdsw -----------------------------------------------
+cdsw COMMON /SIGNALS/ NRSIG, HLISTE
+C
+C NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
+C HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
+C
+C
+C
+ COMMON / QUEUE / BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
+cdsw INTEGER BQUEUE, EQUEUE
+ LOGICAL EMPTY
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
+C BQUEUE - POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
+C EQUEUE - KONIEC -- -- -- -- --
+C IFIRST - PIERWSZY ELEMENT KOLEJKI
+C LAST - OSTATNI ELEMENT KOLEJKI
+C EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
+C
+C
+ COMMON /PREFS/ LPREFS
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C LPREFS - OSTATNIO PRZYDZIELONY NUMER W PREFIXSET
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND
+ *, MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C MNOTVIR - MASKA DO KASOWANIA BITU "VIRTUAL"
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW, INOUT
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEc SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- -- --- ZMIENNEJ INOUT
+C
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
+C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
+C NRRE - REAL
+C NRBOOL - BOOLEAN
+C NRCHR - CHARACTER
+C NRCOR - COROUTINE
+C NRPROC - PROCESS
+C NRTEXT - STRING (TEXT)
+C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
+C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
+C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
+C REFERENCYJNY)
+C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
+C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
+C
+C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
+C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
+C MOWEJ
+C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
+C BYL LOKALNY, 1 - JESLI POCHODZIL Z SL, 0 - GDY Z BL. GL.
+C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
+C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
+C
+C
+C
+C INICJALIZACJA ZMIENNYCH Z BLOKOW WSPOLNYCH, KTORE NIE SA
+C INICJALIZOWANE W BLOCK DATA
+C
+C COMMON /YNIT/
+C NADANIE APETYTOW DLA TYPOW FORMALNYCH
+C DLA TYPOW FORMALNYCH - BIT 14 JEST ZAPALONY
+ MTP = ISHFT (1,14)
+ NULLWD(17) = IOR ( NULLWD(17),MTP )
+ NULLWD(20) = IOR ( NULLWD(20),MTP )
+C DLA POCEDUR/FUNKCJI FORMALNYCH - BIT 15 JEST ZAPALONY
+ MTP = ISHFT (1,15)
+ NULLWD(13) = IOR (NULLWD(13),MTP )
+ NULLWD(14) = IOR (NULLWD(14),MTP )
+ NULLWD(15) = IOR ( NULLWD(15),MTP )
+ NULLWD(16) = IOR ( NULLWD(16),MTP )
+ NULLWD(18) = IOR ( NULLWD(18),MTP )
+ NULLWD(19) = IOR ( NULLWD(19),MTP )
+C
+C COMMON / QUEUE /
+ BQUEUE=MGETM(LMEM/50,341)
+ EQUEUE=LPML-1
+ EMPTY=.TRUE.
+ LAST=BQUEUE-2
+ IFIRST=BQUEUE
+C
+C COMMON / PREFS /
+cdsw LPREFS=IPMEM(NBLSYS+3)
+cdsw MAXPF=47
+C
+C COMMON / MASKS /
+ MTP=15
+ MSPR=7
+ MOTHERS=ISHFT(7,8)
+ MPAR=ISHFT(15,4)
+ MASKTP=NOT(MTP)
+ MNOTVIR=ISHFT(1,11)
+ MNOTVIR=NOT(MNOTVIR)
+ MHAND = ISHFT ( 7,8 )
+ MERPF = ISHFT (1,13)
+C
+C COMMON /SIGNALS/
+ NRSIG = 100
+C
+C INICJALIZACJA ZMIENNYCH GLOBALNYCH - CHWILOWA
+ INSYS=.FALSE.
+ RETURN
+ END
+ SUBROUTINE PROTP1
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C PODPROGRAM SLUZY DO PRZETWARZANIA(OSTATECZNEGO) PROTOTYPU,
+C RAZEM Z PRZETWARZANIEM ZEWNETRZNYM ( WSTEPNYM) JEGO ATRYBUTOW LOKALNYCH.
+C PROTOTYP JEST ZADANY PRZEZ ZMIENNE Z BLOKU /DGLOB/
+C PIERWSZA CZESC PRZETWARZANIA
+C ** ** ** ** ** ** ** ** ** ** * ** ** ** ** ** ** **
+C
+ IMPLICIT INTEGER (A-Z)
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- -- -- ZMIENNEJ INOUT
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+C
+C BUFORY
+C
+cdeb COMMON /NAMES/ RESNM, MAINM
+cdeb ----------------------------------
+ common /names/ resnm, mainm,brenam
+cdeb --------------------------------
+C
+C NAZWY ZE SCANNERA
+C
+C
+C
+C
+cbc
+ common /option/ opt
+cbc
+ LOGICAL POM, HAND
+C HAND - CZY TO JEST PROTOTYP HANDLERA
+C
+C
+C NADANIE WARTOSCI POZOSTALYM ZMIENNYM Z BLOKU /DGLOB/
+ INDSPR = IPMEM(INDICT)
+ IHBEG = INDPR+10
+ I=IPMEM(INDPR)
+ HAND = .FALSE.
+ IF ( IAND(I,MOTHERS) .EQ. MHAND ) HAND = .TRUE.
+ INDPREF = IPMEM(INDPR+21)
+C JESLI BLOK LUB HANDLER - TO ZERO
+ IF(IAND(I,MTP).EQ.NOTTP.AND.IAND(I,MOTHERS).EQ.MBLOCK.OR.HAND)
+ * INDPREF = 0
+C . . . .
+C PRZEPISANIE INFORMACJI DLA ANDRZEJA
+ IPMEM(INDPR+8)=IPMEM(INDSPR-3)
+ IPMEM(INDPR+9)=IPMEM(INDSPR-2)
+ IPMEM(INDPR+18)=IPMEM(INDSPR-1)
+C EWENTUALNE POPRAWIENIE SPECYFIKACJI - JESLI PREFIKS
+C NIE JEST REKORDEM
+ IF(INDPREF.EQ.0) GO TO 50
+ IF(BTEST(IPMEM(INDPREF),0)) CALL CHECK(INDPR)
+ GO TO 60
+C JESLI JEST LISTA TAKEN - TO BLAD
+ 50 I=IPMEM(INDSPR+7)
+ IF(I.EQ.0) GO TO 60
+ LINE=IPMEM(I+1)
+ CALL MERR(310,NEMPTY)
+ 60 INSYS=.FALSE.
+ IF(HAND) GO TO 70
+C
+C---- ---------------------------------------------------------------
+C PRZETWARZANIE NAGLOWKA
+ CALL HEADER
+C
+C ----------------------------------------------------------------
+C DLA PROCESU - SPRAWDZENIE, CZY NIE MA PF OUTPUT LUB INOUT
+C
+cbc check if parameters fit into one message
+c
+ I = IAND(IPMEM(INDPR),MTP)
+ IF(I.NE.MPROCES) GO TO 70
+C PROCES
+ I = IPMEM(INDPR+3)
+ K = IPMEM(INDPR+4)
+ IF(K.EQ.0) GO TO 76
+ K = K+I-1
+cbc check if first parameter is integer
+ j = ipmem(indpr+22)
+80 p = ipmem(j)
+ tp = iand(ipmem(p), mtp)
+ if (tp .eq. mproces) goto 81
+ j = j+1
+ goto 80
+c p = address of first process prototype in prefix sequence
+81 l = ipmem(p+4)
+ p = ipmem(p+21)
+ if (p .eq. 0) goto 82
+ if (l .eq. ipmem(p+4)) goto 76
+ i = i+ipmem(p+4)
+82 continue
+c i = address of first parameter of process
+ if (ipmem(ipmem(i)-3) .eq. nrint) goto 75
+ line = ipmem(indspr+9)
+ call merr(370, nempty)
+75 continue
+ i = ipmem(indpr+3)
+C
+cbc
+ apet = 0
+cbc
+ DO 77 J = I,K
+ NM = IPMEM(J)
+C NM - IDENTYFIKATOR PARAMETRU
+CBC
+c check for formal type
+ zp = ishft(iand(ipmem(nm), mpar), -4)
+ if (zp .eq. 1) goto 74
+c check for formal procedure
+ if (zp .eq. 3) goto 73
+c check if not array
+ if (ipmem(nm-4) .gt. 0) goto 74
+ tp = iand(ipmem(ipmem(nm-3)), mtp)
+c check if formal parameter type is process or int,real,char,bool,string
+cpat if (tp .eq. mproces .or. tp .eq. 8 .or. tp .eq. 10 .or.
+cpat * tp .eq. 12) goto 78
+ goto 78
+74 line = ipmem(indspr+9)
+ call merr(370 ,nempty)
+ goto 77
+78 continue
+c compute formal parameter appetite in bytes
+ if (zp .eq. 2) goto 73
+c variable
+ ap = sapet(0, ipmem(nm-3))
+ if (ap .eq. 4) ap = 2
+ goto 72
+c formal procedure or function
+73 ap = 3
+c sum up appetites
+72 apet = apet + ap
+cbc
+c NM = ISHFT(IAND(IPMEM(NM),MPAR),-4)
+c IF(NM.NE.6.AND.NM.NE.9) GO TO 77
+c BLAD - JEST PARAMETR OUTPUT LUB INOUT
+c LINE = IPMEM(INDSPR+9)
+c CALL MERR(370,NEMPTY)
+cbc
+c
+ 77 CONTINUE
+cbc
+ if (.not. btest(opt, 12)) maxap = 34
+ if ( btest(opt, 12)) maxap = 15
+ if (apet .le. maxap) goto 70
+ line = ipmem(indspr+9)
+ call merr(370, nempty)
+ goto 70
+ 76 line = ipmem(indspr+9)
+ call merr(370, nempty)
+c
+Cbc
+C -----------------------------------------------------------------
+C PRZETWARZANIE WSTEPNE LOKALNYCH PROTOTYPOW -- ETAP I
+C
+C POM = FALSE, GDY PRZETWARZAMY TYPY
+C POM = TRUE, GDY PRZETWARZAMY PROCEDURY/FUNKCJE/BLOKI/HANDLERY
+ 70 POM=.FALSE.
+ I=IPMEM(INDSPR+5)
+ 100 IF(I.EQ.0) GO TO 200
+ J=IPMEM(I)
+ J=IPMEM(J)
+C J - IDENTYFIKATOR PROTOTYPU LOKALNEGO W ISMEM
+C NM - NAZWA PROTOTYPU
+ NM=NEMPTY
+ IF(IPMEM(J).NE.1 .AND. IPMEM(J).NE.8) NM=IPMEM(J+10)
+C OKRESLENIE RODZAJU PROTOTYPU ( W SENSIE BLOKU INIT)
+ K=IPMEM(J)
+C WYKRYCIE HANDLERA
+ IF(K.EQ.8) K=K+15
+C WYKRYCIE BLOKU PREFIKSOWANEGO
+ IF(K.EQ.1.AND.IPMEM(J+2).NE.0) K=8
+C WYKRYCIE WIRTUALI
+ LINE = IPMEM(J+9)
+C INSERTION OF LAST STATEMENT DUE TO CORRECTION GIVEN TO ME IN WARSAW
+C IF(BTEST(IPMEM(J+8),15)) K=K+6
+C INSERTION OF THE FOLLOWING STATEMENTS DUE TO CORRECTIONS (SEE ABOVE)
+ IF (.NOT. BTEST(IPMEM(J+8),15) ) GOTO 110
+ IF (K.LT.3.OR.K.GT.6) GOTO 120
+ K=K+6
+ IF (INDPREF.NE.0) GOTO 110
+ IF (IAND(IPMEM(INDPR),MTP).NE.NOTTP) GOTO 110
+ CALL MERR(330,NM)
+ K=K-6
+ GOTO 110
+120 CALL MERR(329,NM)
+C END OF INSERTION OF STATEMENTS
+C WYWOLANIE INITPR
+C LINE=IPMEM(J+9)
+C DELETION OF PREVIOUS STATEMENT DUE TO CORRECTION
+C K=INITPR(K,NM)
+110 K=INITPR(K,NM)
+C INSERTION OF LABEL 110 DUE TO CORRECTIONS
+C W POLU SL PROTOTYPU (W ISMEM) ZAPAMIETUJEMY JEGO IDENTYFIKATOR
+C W IPMEM
+ IPMEM(J+1) = K
+C PRZEJSCIE DO NASTEPNEGO PROTOTYPU W LISCIE
+ I=IPMEM(I+1)
+ GO TO 100
+C PRZETWARZANIE BLOKOW, FUNKCJI I PROCEDUR
+ 200 IF(POM) GO TO 300
+ POM=.TRUE.
+ I=IPMEM(INDSPR+6)
+C JESLI PROTOTYP ZAWIERA BLOKI, FUNKCJE LUB PROCEDURY, TO ZMIENIAMY
+C MU KWALIFIKACJE NA PELNA KLASE
+ IF(I.NE.0) CALL CHECK(INDPR)
+ GO TO 100
+C
+C
+ 300 CONTINUE
+C
+C ------------------------------------------------------------------------
+C PRZETWARZANIE LISTY SYGNALOW
+C
+ I = IPMEM(INDSPR-4)
+ 350 IF (I.EQ.0) GO TO 500
+ NM = IPMEM(I+2)
+ LINE = IPMEM(I+1)
+ K = IPMEM(I) +12
+C UTWORZENIE PROTOTYPU
+ K=INITPR(K,NM)
+C ZAPAMIETANIE IDENTYFIKATORA PROTOTYPU SEMANTYCZNEGO
+ IPMEM(I) = K
+ I=IPMEM(I+3)
+ GO TO 350
+C
+C
+ 500 CONTINUE
+C
+C JESLI HANDLER TO KONIEC
+ IF ( HAND ) GO TO 1100
+C --- --- --- --- --- --- --- --- --- --- --- --- ---- -----
+C PRZETWARZANIE LISTY STALYCH
+C
+ I=IPMEM(INDSPR+4)
+ 600 IF(I.EQ.0) GO TO 700
+ J=MGETM(6,41)+4
+C J - IDENTYFIKATOR OPISU STALEJ
+ IPMEM(J)=CONSTWD
+C THIS AND THE NEXT 3 LINES ARE IRRELEVANT 8.5.84
+C SZUKAMY TYPU STALEJ - ZAKLADAMY POPRAWNOSC TYPU
+C ZERO OZNACZA STALA ZDEFINIOWANA PRZEZ WYRAZENIE
+ IF(IPMEM(I+2).EQ.0)GO TO 630
+C
+C TYLKO DLA STALEJ TEKSTOWEJ :
+ K=MEMBER(IPMEM(I+2),IPMEM(NBLSYS+10))
+C LAST STATEMENT CHANGED TO COMMENT DUE TO CORRECTIONS FROM WARSAW 8.5.84
+C THIS AND THE NEXT 2 LINES ARE IRRELEVANT 8.5.84
+ IPMEM(J-3)=IPMEM(K+2)
+C LAST STATEMENT CHANGED TO COMMENT DUE TO CORRECTIONS FROM WARSAW 8.5.84
+C PRZEPISANIE ADRESU STALEJ
+ 630 IPMEM(J-1)=IPMEM(I+4)
+C WSTAWIENIE STALEJ DO ZBIORU IDENTYFIKATOROW
+ LINE=IPMEM(I+1)
+ K=IDPUT(IPMEM(I),IPMEM(IHBEG))
+ IF(K.EQ.0) GO TO 650
+C NIE MA PODWOJNEJ DEKLARACJI
+ IPMEM(K+2) = J
+C USTAWINIE BITU CLOSE
+ IPMEM(K+1) = 1
+C PRZEJSCIE DO NASTEPNEGO ELEMENTU LISTY
+ 650 I=IPMEM(I+5)
+ GO TO 600
+C
+C
+ 700 CONTINUE
+C
+C ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
+C PRZETWARZANIE LISTY ZMIENNYCH
+C
+C
+ I=IPMEM(INDSPR+3)
+ 800 IF(I.EQ.0) GO TO 1000
+ J=MGETM(6,41)+4
+C J- IDENTYFIKATOR OPISU ZMIENNEJ
+ IPMEM(J) = VARWD
+C WSTAWIENIE DO ZBIORU IDENTYFIKATOROW
+ LINE=IPMEM(I+1)
+ K=IDPUT(IPMEM(I),IPMEM(IHBEG))
+ IF(K.EQ.0) GO TO 900
+C NIE MA PODWOJNEJ DEKLARACJI
+ IPMEM(K+2)=J
+C WSTAWIENIE DO LISTY ATRYBUTOW
+ 900 CALL MADATR(J,INDPR,41)
+C ZAPAMIETANIE 1 W POLU USED - DLA AIL
+ IPMEM(J+1)=1
+C ZAMIAST NAZWY ZMIENNEJ(W ISMEM) ZAPAMIETUJEMY JEJ IDENTYFIKATOR W IPMEM
+ IPMEM(I)=J
+C PRZEJSCIE DO NASTEPNEGO ELEMENTU LISTY
+ I=IPMEM(I+4)
+ GO TO 800
+C
+C
+ 1000 CONTINUE
+C
+C
+C DOLACZENIE DO ZBIORU IDENTYFIKATOROW ID. RESULT DLA FUNKCJI
+ I=ISHFT(IAND(IPMEM(INDPR),MOTHERS),-8)
+ IF(I.LT.2.OR.I.GT.3) GO TO 1050
+ J=MEMBER(RESNM,IPMEM(IHBEG))
+ IF(J.NE.0) GO TO 1050
+ J=INSERT(RESNM,IPMEM(IHBEG),41)
+ IPMEM(J+2)= IPMEM(INDPR-5)
+ 1050 CONTINUE
+C
+C
+C---- ---- ---- ----- ---- ----- ----- ---- ----- ----- ----- ----- --
+C TWORZENIE ZBIORU IDENTYFIKATOROW
+C
+C JESLI JEST PREFIKS, TO UZUPELNIAMY ZBIOR IDENTYFIKATOROW
+ IF(INDPREF.EQ.0) GO TO 1100
+ CALL MERGEID
+C
+C
+ 1100 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PROTP2
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C PODPROGRAM SLUZY DO PRZETWARZANIA(OSTATECZNEGO) PROTOTYPU,
+C RAZEM Z PRZETWARZANIEM ZEWNETRZNYM ( WSTEPNYM) JEGO ATRYBUTOW LOKALNYCH.
+C PROTOTYP JEST ZADANY PRZEZ ZMIENNE Z BLOKU /DGLOB/
+C DRUGA CZESC PRZETWARZANIA
+C ** ** ** ** ** ** ** ** ** ** * ** ** ** ** ** ** **
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL POM
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+C
+ COMMON / VIRT / LISTVB,LISTVE,OWNVIR
+ LOGICAL OWNVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ROBOCZY BLOK WSPOLNY.
+C LISTVB - POCZATEK ROBOCZEJ LISTY VIRTLIST
+C LISTVE - KONIEC ROBOCZEJ LISTY VIRTLIST
+C OWNVIR = TRUE, JESLI W PROTOTYPIE BYLY WLASNE VIRTUALE
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C
+C
+C.....
+C KOMUNIKACJA Z PROCEDURA MEMPRF
+ COMMON /MEM/ NME, NH
+C NME - SZUKANA NAZWA
+C NH - JEJ HASZ
+C
+C
+cdsw COMMON /SIGNALS/ NRSIG, HLISTE
+cdsw -------------------------------------------------
+ common /signs/ nrsig, hliste
+cdsw -------------------------------------------------
+C
+C NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
+C HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7) ,JUNK(260)
+C
+C
+C
+C ---- ------ ------ ------ ------- ------- ------- ------------
+C
+C WSTEPNE PRZETWARZANIE PROTOTYPOW LOKALNYCH -- ETAP II
+C
+C
+C ----- ------ ------ ----- ----- ----- ----- ----- ----- -----
+C PRZETWARZANIE SYGNALOW
+C
+ LN = 0
+ I=IPMEM(INDSPR-4)
+ 100 IF ( I.EQ.0 ) GO TO 500
+ CALL SIGNAL(I)
+ I = IPMEM(I+3)
+ GO TO 100
+C
+C
+ 500 CONTINUE
+C
+C ------ ------ ------ ------ ------ ------- ------ ----
+C PRZEPISANIE LISTY VIRTLIST Z PREFIKSU
+C
+ LISTVE=0
+ LISTVB=LPML
+ IF(INDPREF.EQ.0) GO TO 1200
+ I=IPMEM(INDPREF+25)
+C I - DLUGOSC LISTY WIRTLIST Z PREFIKSU
+ IF(I.EQ.0) GO TO 1200
+ IF(I.LT.0) I=-I
+C JEST LISTY WIRTLIST W PREFIKSIE
+ INSYS=.TRUE.
+ LISTVB=MGETM(I,41)
+ LISTVE=LPML-1
+ INSYS=.FALSE.
+C PRZEPISYWANIE
+ K=IPMEM(INDPREF+24)
+C K - POCZATEK LISTY VIRTLIST W PREFIKSIE
+ DO 1111 J=1,I
+ IJ1 = LISTVB+J-1
+ IJ2 = K+J-1
+ 1111 IPMEM(IJ1) = IPMEM(IJ2)
+ 1200 OWNVIR=.FALSE.
+C PUSTA LISTA LOKALNYCH HANDLEROW
+ HLISTE = 0
+C PRZETWARZANIE WSZYSTKICH PROTOTYP6W
+ POM=.FALSE.
+ I=IPMEM(INDSPR+5)
+C ZACZYNAMY OD TYPOW
+ 1300 IF(I.EQ.0) GO TO 1400
+ CALL BEGPROT(IPMEM(I))
+ I=IPMEM(I+1)
+ GO TO 1300
+ 1400 IF(POM) GO TO 1600
+ POM=.TRUE.
+C PROCEDURY, FUNKCJE I BLOKI
+ I=IPMEM(INDSPR+6)
+ GO TO 1300
+C
+1600 CONTINUE
+C JESLI HANDLER TO KONIEC
+ IF ( IAND(IPMEM(INDPR),MOTHERS).EQ.MHAND) GO TO 4000
+C
+C UTUPELNIENIE INFORMACJI I WIRTUALACH
+ IF(OWNVIR) GO TO 1700
+C NIE BYLO WLASNYCH WIRTUALI
+ IF(INDPREF.EQ.0) GO TO 1900
+C DOWIAZUJEMY SIE DO LISTY VIRTLIST Z PREFIKSU, ZMIENIAJAC DLUGOSC NA UJEMNA
+ IPMEM(INDPR+24) = IPMEM(INDPREF+24)
+ IPMEM(INDPR+25) = -IPMEM(INDPREF+25)
+ GO TO 1900
+C BYLY WLSNE WIRTUALE - PRZEPISUJEMY LISTE VIRTLIST
+ 1700 I=LISTVE-LISTVB+1
+ K = MGETM(I,41)
+ IPMEM(INDPR+24) = K
+ DO 1777 J=1,I
+ IJ1=K+J-1
+ IJ2=LISTVB+J-1
+ 1777 IPMEM(IJ1) = IPMEM(IJ2)
+ IPMEM(INDPR+25) = I
+C ZWALNIAMY PAMIEC PRZEZNACZONA NA VIRTLIST W CZESCI SYSTEMOWEJ
+ 1900 CONTINUE
+ LPML=LISTVB
+C
+C
+ 2000 CONTINUE
+C
+C ---- ----- ----- -------- ---------- ------- ---- ----- -------
+C NADAWANIE TYPOW ZMIENNYM
+C
+ I=IPMEM(INDSPR+3)
+ IF(I.EQ.0) GO TO 2400
+ 2100 J=IPMEM(I)
+C J - IDENTYFIKATOR OPISU ZMIENNEJ W IPMEM
+ NM=IPMEM(I+2)
+C NM - NAZWA TYPU
+ LINE=IPMEM(I+1)
+ K=IFTYPE(NM)
+ IPMEM(J-3) = K
+ IPMEM(J-4) = IPMEM(I+3)
+C NADANIE APETYTU ZMIENNEJ
+ IPMEM(J) = IAP(J)
+C JESLI TO JEST TYP FORMALNY, TO POPRAWIAMY SLOWO ZEROWE OPISU ZMIENNEJ
+ IF(IAND(IPMEM(K),MTP).NE.6) GO TO 2350
+ IPMEM(J) = IOR(IPMEM(J),ISHFT(1,12))
+C JESLI TYP FORMALNY JEST NIELOKALNY, TO ZMIENIAMY RODZAJ PROTOTYPU
+C NA KLASE PELNA
+ IF(LOCAL.EQ.2) GO TO 2350
+ CALL CHECK(INDPR)
+ 2350 I=IPMEM(I+4)
+ IF(I.NE.0) GO TO 2100
+C
+C
+ 2400 CONTINUE
+C
+C ---- ------ ----- --- ---- ------ ----- ------ ----------
+C SPRAWDZENIE POPRAWNOSCI LIST HIDDEN I CLOSE I UZUPELNIENIE INFORMACJI
+C
+C JESLI PROTOTYP NIE JEST KLASA TO PRZECHODZIMY DALEJ
+ IF(IPMEM(INDSPR).NE.2.AND.IPMEM(INDSPR).NE.7) GO TO 3000
+ I=IPMEM(INDSPR+12)
+C K = 0 -- CLOSE, K=1 -- HIDDEN
+ K=1
+ 2500 IF(I.EQ.0) GO TO 2700
+ NME=IPMEM(I)
+ LN=LINE
+ LINE=IPMEM(I+1)
+C NME - NAZWA W LISCIE HIDDEN(CLOSE)
+ NH=IAND(ISHFT(NME,-1),7)+1
+ J=MEMPRF(INDPR)
+ IF(J.EQ.0) GO TO 2600
+C NAZWA JEST ZADEKLAROWANA
+C JESLI NAZWA JEST HIDDEN LUB NOT TAKEN, TO BLAD
+ NM=IPMEM(J+1)
+ IF(BTEST(NM,2)) GO TO 2660
+ IF(OWN) GO TO 2550
+ IF(BTEST(NM,1)) GO TO 2650
+C NAZWA POCHODZI Z PREFIKSU
+ NM=INSERT(NME,IPMEM(IHBEG),41)
+ IPMEM(NM+2) = IPMEM(J+2)
+ IPMEM(NM+1)= IPMEM(J+1)
+ J=NM
+C USTAWIAMY BIT K W ELEMENCIE LISTY HASHU
+ 2550 IPMEM(J+1) = IOR(IPMEM(J+1),ISHFT(1,K))
+C PRZECHODZIMY DO NASTEPNEGO ELEMENTU LISTY
+ 2560 I=IPMEM(I+2)
+ GO TO 2500
+C NAZWA NIEZADEKLAROWANA
+ 2600 J=INSERT(NME,IPMEM(IHBEG),41)
+ CALL MERR(305,NME)
+ GO TO 2550
+C NAZWA HIDDEN - NIEDOSTEPNA
+ 2650 CALL MERR(319,NME)
+ GO TO 2560
+C NAZWA NOT TAKEN - NIEDOSTEPNA
+ 2660 CALL MERR(320,NME)
+ GO TO 2560
+ 2700 IF(K.EQ.0) GO TO 3000
+ K=0
+ I=IPMEM(INDSPR+13)
+ GO TO 2500
+C
+C
+ 3000 CONTINUE
+C
+C---- ------ ------ ------ ------- ------- -------- -------
+C KOMPATYBILNOSC VIRTUALI
+C
+ IF(.NOT.BTEST(IPMEM(INDPR),11)) GO TO 4000
+C PROTOTYP JEST VIRTUALEM
+C SPRAWDZAMY, CZY ISTNIEJE WYZSZY VIRTUAL
+ LINE=LN
+ IF(IPMEM(INDPR+26).EQ.0) GO TO 4000
+ CALL VIRTCOM
+C
+C
+ 4000 CONTINUE
+C
+C ------ ------ ------ ------ ------ ------ ------------- ---
+C ZAKONCZENIE - ZAPAMIETUJEMY IDENTYFIKATOR PROTOTYPU W SLOWNIKU
+C ISDICT
+C
+ IPMEM(INDICT) = INDPR
+C
+ RETURN
+ END
+ INTEGER FUNCTION IAP(IND)
+C
+C WYLICZA APETYT ATRYBUTU IND :
+C 0 (00) - INTEGER,BOOLEAN,CHAR,STRING
+C 1 (01) - REAL, FORMAL TYPE
+C 2 (10) - FORMAL PROCEDURE,FORMAL FUNCTION
+C 3 (11) - REFERENCE
+C W WYNIKU ZMIENIA SLOWO ZEROWE
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
+C
+C
+ J=IPMEM(IND-3)
+C J - IDENT TYPU
+ I=IAND(IPMEM(J),MTP)
+ IAP=0
+ IF(I.LT.8.OR.I.EQ.11) IAP = 3
+ IF(J.EQ.NRRE) IAP=1
+ IF(IPMEM(IND-4).NE.0) IAP=3
+C ZMIANA SLOWA ZEROWEGO
+ IAP=IOR(IPMEM(IND),ISHFT(IAP,14))
+ RETURN
+ END
+ SUBROUTINE BEGPROT(NRSDIC)
+C
+C * * * * * * * * * * * * * * * * * * *
+C PODPROGRAM SLUZY DO WSTEPNEGO PRZETWARZANIA PROTOTYPOW LOKALNYCH
+C W PROTOTYPIE IDENTYFIKOWANYM PRZEZ INDPR.
+C DLA KAZDEGO PROTOTYPU:
+C - ANALIZUJE JEGO PREFIKS
+C - UZUPELNIA INFORMACJE O RODZAJU PROTOTYPU
+C - JESLI PROTOTYP JEST PROCEDURA LUB FUNKCJA VIRTUALNA, TO SZUKA
+C BEZPOSREDNIO WYZSZEGO VIRTUALA I WSTAWIA IDENTYFIKATOR PROTOTYPU
+C DO LISTY VIRTLIST PROTOTYPU OBEJMUJACEGO.
+C - DLA FUNKCJI -- ZNAJDUJE JEJ TYP.
+C PODPROGRAM WSTAWIA PARE ( NRSDIC, IDENT. W IPMEM) DO KOLEJKI
+C PROTOTYPOW.
+C NRSDIC - INDEKS PROTOTYPU W IPMEM.
+C W IPMEM W POLU SL ZAPAMIETANY JEST IDENTYFIKATOR TEGO PROTOTYPU W
+C IPMEM.
+C * * * * * * * * * * * * * * * * *
+C
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C
+ LOGICAL IFCLASS,BPREF,ONLY
+C
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+ COMMON / VIRT / LISTVB,LISTVE,OWNVIR
+ LOGICAL OWNVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ROBOCZY BLOK WSPOLNY.
+C LISTVB - POCZATEK ROBOCZEJ LISTY VIRTLIST
+C LISTVE - KONIEC ROBOCZEJ LISTY VIRTLIST
+C OWNVIR = TRUE, JESLI W PROTOTYPIE BYLY WLASNE VIRTUALE
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND
+ *, MNOTVIR
+C
+C
+ COMMON /PREFS/ LPREFS
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C LPREFS - OSTATNIO PRZYDZIELONY NUMER W PREFIXSET
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+ COMMON / DONLY / IONLY,ONIL
+ LOGICAL ONIL
+C
+C ROBOCZY BLOK,UZYWANY PRZY TWORZENIU ZBIORU IDENTYFIKAROROW
+C IONLY - POCZATEK LISTY TAKEN
+C ONIL - TRUE, GDY JEST TAKEN NONE
+C
+C
+C
+C
+C * * * * * * * * * * * * *
+C NADANIE WARTOSCI ZMIENNYM.
+C IDSMEM - IDENTYFIKATOR W IPMEM PRZETWARZANEGO PROTOTYPU.
+C IDPMEM - IDENTYFIKATOR PROTOTYPU W IPMEM.
+C ISYS = 1 DLA COROUTINE, ISYS = 2 DLA PROCESS.
+C LINE - NR LINII DEKLARACJI PROTOTYPU.
+C * * * * * * * * * * * * *
+C
+C
+ IDSMEM = IPMEM(NRSDIC)
+ IDPMEM = IPMEM(IDSMEM+1)
+C JESLI HANDLER - TO DO PRZETWARZANIE HANDLERA
+ IF(IPMEM(IDSMEM).EQ.8) GO TO 2500
+ ISYS=IAND(IPMEM(IDSMEM+8),MSPR)
+ LINE = IPMEM(IDSMEM+9)
+C
+C
+C * * * * * * * * * * * * * * *
+C PRZETWARZANIE PREFIKSU
+C * * * * * * * * * * * * * *
+C
+C I - NAZWA PREFIKSU
+ I = IPMEM(IDSMEM+2)
+C IDPR - BEDZIE IDENTYFIKATOREM PREFIKSU
+ IDPR = 0
+ IF( I.EQ.0) GO TO 500
+C JEST PREFIKS
+ IDPR = MEMSL(I,INDPR)
+ IF(IDPR.NE.0) GO TO 50
+C PREFIKS JEST NIEZADEKLAROWANY
+ CALL MERR(308,I)
+ GO TO 500
+C BADAMY, CZY PREFIKS JEST DOSTEPNY
+ 50 IRODZ=IPMEM(IDPR+1)
+ IF(BTEST(IRODZ,2)) GO TO 60
+ IF(.NOT.BTEST(IRODZ,1) .OR.OWN)GO TO 100
+C NAZWA PROFIKSU JEST HIDDEN - BLAD
+ CALL MERR(322,I)
+ GO TO 150
+C NAZWA PREFIKSU JEST NOT-TAKEN
+ 60 CALL MERR(323,I)
+ GO TO 150
+C BADAMY, CZY PREFIKS JEST KLASA
+ 100 IDPR = IPMEM(IDPR+2)
+ IF(IDPR.EQ.NRUNIV) GO TO 150
+C IRODZ - CZESC T W SLOWIE ZEROWYM PREFIKSU
+ IRODZ=IAND(IPMEM(IDPR),MTP)
+ IF(IFCLASS(IRODZ)) GO TO 200
+C PREFIKS NIE JEST KLASA
+ CALL MERR(301,I)
+ 150 IDPR=0
+ GO TO 210
+C
+C PREFIKS JEST POPRAWNY
+ 200 CONTINUE
+C JESLI PREFIKS MIAL BLEDNA LISTE PF, TO POPRAWIAMY
+C SLOWO ZEROWE
+ IF(IAND(IPMEM(IDPR),MERPF).EQ.0) GO TO 250
+C POPRAWIAMY SLOWO ZEROWE
+ 210 IPMEM(IDPMEM) = IOR(IPMEM(IDPMEM),MERPF)
+ 250 CONTINUE
+ IF(IDPR.EQ.0) GO TO 500
+C WSTAWIAMY IDENTYFIKATOR BEZPOSREDMIEGO PREFIKSU DO OPISU PROTOTYPU
+ IPMEM(IDPMEM+21) = IDPR
+C PRZEPISANIE LISTY PREFIKSLIST Z PREFIKSU I DOLACZENIE SIEBIE
+C NA KONCU LISTY
+C I - DLUGOSC LISTY PREFIKSLIST Z PREFIKSU - 1
+C J - POCZATEK PREFIXLIST Z PREFIKSU
+C J1 - POCZATEK TWORZONEJ LISTY PREFIKSLIST
+ I=IPMEM(IDPR+23)
+ J = IPMEM(IDPR+22)
+ J1 = MGETM(I+1,41)
+ DO 222 II=1,I
+ IJ1=J1+II-1
+ IJ2=J+II-1
+ 222 IPMEM(IJ1) = IPMEM(IJ2)
+C DOLOCZAMY SIEBIE DO LISTY PREFIXLIST I WSTAWIAMY PREFIXLIST DO
+C OPISU PROTOTYPU
+ IJ1=J1+I
+ IPMEM(IJ1) = IDPMEM
+ IPMEM(IDPMEM+22)=J1
+ IPMEM(IDPMEM+23) = I+1
+C
+C SPRAWDZENIE POPRAWNOSCI PREFIKSOW SYSTEMOWYCH
+C TWORZENIE PREFIXSET
+C
+C
+C
+C I=1 JESLI PREFIKS JEST COROUTINA
+C I=2 JESLI PREFIKS JEST PRECESEM
+C I=0 W PRZECIWNYM PRZYPADKU
+ I=0
+ IF(BPREF(IDPR,IPMEM(NRCOR-6))) I=1
+ IF(BPREF(IDPR,IPMEM(NRPROC-6))) I=2
+C JESLI PROTOTYP NIE JEST KLASA, TO PRZECHODZIMY DO BADANIA POPRAWNOSCI
+C PREFIKSOWANIA
+ J=IAND(IPMEM(IDPMEM),MTP)
+ IF(J.EQ.NOTTP) GO TO 800
+C PRZEPISANIE PREFIXSET Z PREFIKSU
+ IPMEM(IDPMEM-3) = IPMEM(IDPR-3)
+ IPMEM(IDPMEM-4) = IPMEM(IDPR-4)
+ IPMEM(IDPMEM-5) = IPMEM(IDPR-5)
+C ROZPOZNAMIE RODZAJU PROTOTYPU
+ IF(ISYS.LT.I) ISYS=I
+ 300 IF(ISYS.EQ.0) GO TO 400
+C
+C PROTOTYP JEST COROUTINA LUB PROCESEM
+ CALL CHECK(INDPR)
+C USTAWIAMY ODPOWIEDNIE BITY W PREFIXSET
+ I=IPMEM(IDPMEM)
+ CALL MSETB(IDPMEM,IPMEM(NRCOR-6))
+ IF(ISYS.NE.2) GO TO 350
+ CALL MSETB(IDPMEM,IPMEM(NRPROC-6))
+C POPRAWIAMY SLOWO ZEROWE PROTOTYPU - TO JEST PROCES
+ IPMEM(IDPMEM) = IOR(IAND(I,MASKTP),MPROCES)
+ GO TO 400
+C POPRAWIAMY SLOWO ZEROWE - TO JEST COROUTINA
+ 350 IPMEM(IDPMEM) = IOR(IAND(I,MASKTP),MCOR)
+C PRZYDZIELENIE NUMERU W SENSIE PREFIXSET
+ 400 LPREFS = LPREFS+1
+ CALL MSETB(IDPMEM,LPREFS)
+ IPMEM(IDPMEM-6) = LPREFS
+C JESLI KLASA MA BLEDNA LISTE PF, TO POPRAWIAMY NA PELNA
+ IF(IAND(IPMEM(IDPMEM),MERPF).NE.0)
+ * CALL CHECK(IDPMEM)
+C JESLI W KLASIE BYLY INSTRUKCJE, TO POPRAWIAMY NA KLASE PELNA
+ IF(BTEST(IPMEM(IDSMEM+8),13)) CALL CHECK(IDPMEM)
+ GO TO 1000
+C
+C NIE BYLO PREFIKSU, LUB BYL BLEDNY PREFIKS.
+C JESLI PROTOTYP JEST BLOKIEM, TO KONCZYMY PRZETWARZANIE PREFIKSOW
+ 500 CONTINUE
+ J1 = IPMEM(IDPMEM)
+ IF(IAND(J1,MTP).EQ.NOTTP.AND.IAND(J1,MOTHERS).EQ.MBLOCK)
+ * GO TO 1000
+C DOLOCZAMY SIEBIE JAKO JEDYNY ELEMENT LISTY PREFIKSOW
+ J = MGETM(1,41)
+ IPMEM(J) = IDPMEM
+ IPMEM(IDPMEM+22) = J
+ IPMEM(IDPMEM+23) = 1
+C JESLI PROTOTYP NIE JEST KLASA, TO KONIEC PRZETWARZANIA PREFIKSOW
+ IF(IAND(J1,MTP).EQ.NOTTP) GO TO 1000
+C USTAWIAMY BIT 2 W PREFIKSSET NA 1 I PRZECHODZIMY DO USTALENIA RODZAJU
+C KLASY
+ CALL MSETB(IDPMEM,2)
+ GO TO 300
+C
+C SPRAWDZENIE POPRAWNOSCI PREFIKSOW SYSTEMOWYCH
+ 800 IF(I.EQ.0) GO TO 1000
+C COROUTINE LUB PROCES NIE PREFIKSUJE KLASY
+ CALL MERR(303,IPMEM(IDSMEM+2))
+C
+C
+C --- --- --- --- --- --- --- --- --- --- --- ---
+C PRZETWARZANIE INFORMACJI O WIRTUALACH
+C
+ 1000 CONTINUE
+C
+C JESLI TO NIE JEST WIRTUAL, TO PRZECHODZIMY DALEJ
+ IF(.NOT.BTEST(IPMEM(IDSMEM+8),15)) GO TO 2000
+C TO JEST WIRTUAL.
+C JESLI PROTOTYP OBEJMUJACY JEST BLOKIEM NIEPREFIKSOWANYM, TO KASUJEMY
+C WIRTUALE
+ IF(IPMEM(INDPR).NE.1) GO TO 1001
+ IPMEM(IDPMEM)=IAND(IPMEM(IDPMEM),MNOTVIR)
+ GO TO 2000
+C
+C BIT NR 11 W SLOWIE ZEROWYM JEST JUZ USTAWIONY PRZEZ PODPROGRAM INITPR
+C OWNVIR = .TRUE., JESLI W PROTOTYPIE INDPR SA WLASNE WIRTUALE
+C
+ 1001 OWNVIR=.TRUE.
+C CZUKA,Y BEZPOSREDNIO WYZSZEGO VIRTUALA
+ IF(INDPREF.EQ.0) GO TO 1300
+C PROTOTYP OBEJMUJACY MA PREFIKS
+C I - NAZWA VIRTUALA
+ I=IPMEM(IDSMEM+10)
+C SPRAWDZAMY,CZY WIRTUAL JEST NA LISCIE TAKEN Z PREFIKSU
+ IONLY=IPMEM(INDSPR+7)
+ ONIL=BTEST(IPMEM(INDSPR+8),14)
+ IF(.NOT.ONLY(I)) GO TO 1300
+ J=MEMSL(I,INDPREF)
+ IF(J.EQ.0) GO TO 1300
+ IF(LOCAL.NE.2.OR.BTEST(IPMEM(J+1),1)) GO TO 1300
+ IF(BTEST(IPMEM(J+1),2)) GO TO 1300
+ J = IPMEM(J+2)
+C SPRAWDZAMY,CZY TO JEST WIRTUAL
+ IF(.NOT.BTEST(IPMEM(J),11)) GO TO 1300
+C ZNALEZLISMY BEZPOSREDNIO WYZSZY WIRTUAL
+C J - IDENTYFIKATOR BEZPOSREDNIO WYZSZEGO WIRTUALA
+C I - NUMER WIRTUALNY
+ I = IPMEM(J+27)
+ IPMEM(IDPMEM+26) = J
+ IPMEM(IDPMEM+27) = I
+C WSTAWIAMY WIRTUAL DO VIRTLIST (ROBOCZEJ) PROTOTYPU OBEJMUJACEGO
+ IJ1=LISTVB+I
+ IPMEM(IJ1) = IDPMEM
+ GO TO 2000
+C
+C NIE BYLO BEZPOSREDNIO WYZSZEGO WIRTUALA
+ 1300 CONTINUE
+ INSYS = .TRUE.
+ LISTVE = MGETM(1,41)
+C DOKLADAMY NUMER WIRTUALNY
+ IPMEM(IDPMEM+27) = LISTVE-LISTVB
+ INSYS=.FALSE.
+ IPMEM(LISTVE)=IDPMEM
+C
+C
+C -- -- -- -- -- -- -- -- --- -- -- -- --- -- --
+C DLA FUNKCJI -- PRZETWARZANIE JEJ TYPU
+C
+ 2000 CONTINUE
+C
+C BADAMY, CZY PROTOTYP JEST FUNKCJA
+ I = ISHFT(IAND(IPMEM(IDPMEM),MOTHERS),-8)
+ IF(I.NE.2) GO TO 3000
+C SZUKAMY TYPU; J - NAZWA TYPU
+ J = IPMEM(IDSMEM+12)
+ I=IFTYPE(J)
+C SPRAWDZAMY, CZY TO JEST TYP FORMALNY
+C I - IDENTYFIKATOR TYPU
+ IF(IAND(IPMEM(I),MTP).NE.6) GO TO 2100
+C TO JEST TYP FORMALBY - ZMIANA SLOWA ZEROWEGO W PROTOTYPIE FUNKCJI
+ IPMEM(IDPMEM)= IOR(IPMEM(IDPMEM),ISHFT(1,12))
+C WSTAWIENIE TYPU
+ 2100 IPMEM(IDPMEM-3) = I
+ IPMEM(IDPMEM-4) = IPMEM(IDSMEM+13)
+ GO TO 3000
+C
+C
+ 2500 CONTINUE
+C
+C --- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
+C PRZETWARZANIE HANDLERA
+C
+ CALL HANDLER ( IDSMEM )
+C
+C
+C
+C ---- ---- ---- ---- ---- ---- ---- ----
+C WSTAWINEI PARY (NRSDIC,IDPMEM) DO KOLEJKI PROTOTYPIOW
+C
+ 3000 CONTINUE
+ CALL DPUTQ(NRSDIC,IDPMEM)
+ RETURN
+ END
+ LOGICAL FUNCTION IFCLASS(IX)
+
+C *****************
+C FUNKCJA DAJE ODPOWIEDZ, CZY DANY PROTOTYP JEST KLASA
+C IX - CZESC T ZE SLOWA ZEROWEGO PROTOTYPU
+C
+C ****************
+C
+ IFCLASS=IX.EQ.2 .OR. IX.EQ.3 .OR. IX.EQ.5 .OR. IX.EQ.7
+ RETURN
+ END
+ INTEGER FUNCTION INITPR(KIND,NAME)
+C
+C * * * * * * * * * * * * * * * * *
+C FUNKCJA WYKONUJE WSTEPNE CZYNNOSCI ( REZERWACJA MIEJSCA,USTAWIENIE
+C LISTY ATRYBUTOW I TABLICY HASHU ) DLA PROTOTYPU.
+C NAME - NAZWA PROTOTYPU
+C KIND - RODZAJ PROTOTYPU
+C WARTOSCIA FUNKCJI JEST IDENTYFIKATOR UTWORZONEGO PROTOTYPU.
+C * * * * * * * * * * * * * * * * *
+C
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- -- -- ZMIENNEJ INOUT
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C ..... ZMIENNE GLOBALNE
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+cdeb ----------- added ---------------------
+ common /names/ resnm, mainm, brenam
+c nazwy ze scannera
+
+ common /brid/ breaklid
+c numer w displayu (dla interpretera) prototypu breakl
+cdeb ---------------------------------------
+C
+C
+C REZERWACJA MIEJSCA I USTAWIENIE SLOWA ZEROWEGO
+ IF(KIND.GE.13 .AND.KIND.LE. 16) INSYS=.TRUE.
+ INITPR = MGETM(SIZEPR(KIND),341)
+ INSYS=.FALSE.
+ INITPR=INITPR+NULLPOZ(KIND)
+ IPMEM(INITPR) = NULLWD(KIND)
+C DOLACZENIE DO LISTY NEXTDECL
+ IPMEM(LASTPR+2) = INITPR
+ LASTPR = INITPR
+cdeb ----------- added --------------------
+ if(name.ne.brenam) go to 82
+c przekazanie na zmiennej breaklid numeru prototypu
+c procedury breakl
+c obliczenie numeru prototypu
+ i = nblus
+ breaklid = 0
+ 80 k = ipmem(i)
+c formaLNE i sygnaly sa pomijane
+ if(iand(ishft(k,-4),15).ne.0) go to 81
+ if(i.eq.lastpr) go to 82
+ breaklid = breaklid+1
+ 81 i = ipmem(i+2)
+ if(i.ne.0) go to 80
+ 82 continue
+cdeb ---------------------------------------
+ IF ( KIND .GE.17.AND.KIND.LE.20) GO TO 100
+C INICJALIZACJA LISTY ATRYBUTOW
+ IPMEM(INITPR+7) = INITPR+5
+ IPMEM(INITPR+5) = NATTR
+C USTAWIENIE SL
+ 100 IPMEM(INITPR-1) = INDPR
+C WSTAWIENIE 1 DO POLA USED - DLA AIL
+ IPMEM(INITPR+1) = 1
+C DLA BLOKOW I HANDLEROW - KONIEC
+ IF(KIND.EQ.1.OR. KIND.EQ.8 .OR. KIND.EQ.23) RETURN
+C WSTAWIENIE NAZWY PROTOTYPU DO TABLICY HASH'U
+C JESLI TO JEST PROTOTYP FORMALNY II-GO RZEDU, TO ELEMENTY LISTY HASH'U SA
+C TWORZONE W CZESCI SYSTEMOWEJ
+ IF( KIND.GE.18 .AND. KIND.LE.20 ) INSYS = .TRUE.
+ IF( NAME .EQ.NEMPTY) GO TO 200
+ I = IDPUT(NAME,IPMEM(IHBEG))
+ IF ( I.EQ.0) GO TO 200
+ IPMEM(I+2) = INITPR
+C DLA SYGNALOW - KONIEC
+ 200 IF ( KIND.GE.21 ) RETURN
+C WSTAWIENIE DO LISTY ATRYBUTOW ( PROTOTYPU INDPR )
+C JESLI INDPR JEST FORMALNY, TO LISTA ATRYBUTOW JEST TWORZONA
+C W CZESCI SYSTEMOWEJ
+ CALL MADATR(INITPR,INDPR,41)
+ INSYS = .FALSE.
+ RETURN
+ END
+ SUBROUTINE MERGEID
+C
+C * * * * * * * * * * * * * * * * *
+C PODPROGRAM DOKLADA DO ZBIORU IDENTYFIKATOROW PROTOTYPU INDPR
+C IDENTYFIKATORY Z PREFIKSU TAKIE,ZE:
+C - JESZCZE ICH NIE MA
+C - NIE MA ICH NA LISCIE TAKEN
+C PODPROGRAM JEST WYWOLYWANY O ILE BYL PREFIKS.
+C * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER (A-Z)
+C
+ LOGICAL ONLY
+C
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+ LOGICAL ERRFLG
+ COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
+ COMMON/MEM/NM,NH
+ COMMON/DONLY/IONLY,ONIL
+ LOGICAL ONIL
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ROBOCZY BLOK, UZYWANY PRZY TWORZENIU ZBIORU IDENTYFIKATOROW
+C IONLY - POCZATEK LISTY TAKEN W ISMEM
+C ONIL=TRUE, GDY JEST TAKEN NIL
+C
+C
+C
+C SPRAWDZAMY, CZY BYLO TAKEN NIL
+ ONIL=BTEST(IPMEM(INDSPR+8),14)
+ IF(ONIL) GO TO 500
+C
+C * * * * * *
+C SPRAWDZENIE POPRAWNOSCI LISTY TAKEN
+C * * * * * *
+C
+C IHBEGP -- POCZATEK LISTY IDENTYFIKATOROW W PREFIKSIE
+ IHBEGP=INDPREF+10
+ IONLY=IPMEM(INDSPR+7)
+ IF(IONLY .EQ.0) GO TO 500
+C J - POPRZEDNI ELEMENT LISTY
+C I - BIEZACY ELEMENT LISTY
+ J=0
+ I=IONLY
+ 100 NM=IPMEM(I)
+ LINE=IPMEM(I+1)
+ NH=IAND(ISHFT(NM,-1),7)+1
+ M=MEMPRF(INDPREF)
+C M - ELEMENT LISTY HASHU, JESLI NAZWA NM JEST ZADEKLAROWANA W PREFIKSACH
+ IF(M .EQ. 0) GO TO 400
+C SPRAWDZAMY, CZY NAZWA JEST HIDDEN
+ IF(BTEST(IPMEM(M+1),1)) GO TO 300
+C SPRAWDZAMY,CZY NAZWA JEST NOT TAKEN
+ IF(BTEST(IPMEM(M+1),2)) GO TO 250
+C POPRAWNY ELEMENT LISTY TAKEN
+ J=I
+ 200 I=IPMEM(I+2)
+ IF(I.NE.0) GO TO 100
+ GO TO 500
+C NAZWA JEST NOT TAKEN - USUWAMY Z LISTY TAKEN
+ 250 CALL MERR(321,NM)
+ GO TO 200
+C NAZWA JEST HIDDEN
+ 300 CALL MERR(304,NM)
+ GO TO 200
+C NAZWA NIEZADEKLAROWANA
+ 400 CALL MERR(305,NM)
+C DOKLADAMY NAZWE DO ZBIORU IDENTYFIKATOROW
+ M = MEMBER(NM,IPMEM(IHBEG))
+ IF(M.NE.0) GO TO 200
+ M=INSERT(NM,IPMEM(IHBEG),341)
+ GO TO 200
+C
+C * * * * * *
+C LACZENIE ZBIOROW IDENTYFIKATOROW
+C * * * * * *
+C
+ 500 CONTINUE
+C PRZEGLADAMY KOLEJNE PREFIKSY
+ IDP= INDPREF
+ 800 CONTINUE
+C IE - KONIEC TABLICY IDENTYFIKATOROW W PREFIKSIE
+ IE= IDP+17
+C IHBEGP - POCZATEK LISTY IDENTYFIKATOROW W PREFIKSIE
+ IHBEGP=IDP+10
+ DO 555 I=IHBEGP,IE,1
+C I - INDEKS KOLEJNEGO ELEMENTU TABLICY HASHU
+C J - ELEMENT TABLICY HASHU
+ J=IPMEM(I)
+ IF(J.EQ.0) GO TO 555
+ 600 CONTINUE
+C JESLI NAZWA JEST HIDDEN - TO DALEJ
+ IF(BTEST(IPMEM(J+1),1)) GO TO 700
+C JESLI NAZWA JEST NOT TAKEN - TO DALEJ
+ IF(BTEST(IPMEM(J+1),2)) GO TO 700
+ NM=IPMEM(J)
+ IF(ONLY(NM)) GO TO 700
+C NAZWY NIE MA NA LISCIE TAKEN
+ NH=IAND(ISHFT(NM,-1),7)+1
+C SZUKAMY NAZWY OD INDPR PO PREFIKSACH
+ IND = INDPR
+ 610 M = IND+9+NH
+ M = IPMEM(M)
+ 620 IF(M.EQ.0) GO TO 650
+ IF(IPMEM(M).EQ.NM) GO TO 670
+ M = IPMEM(M+3)
+ GO TO 620
+ 650 IND = IPMEM(IND+21)
+ GO TO 610
+C NAZWA MUSI ZOSTAC ZNALEZIONA
+C JESLI NAZWA BYLA ZNALEZIONA PONIZEJ IDP, TO
+C ALBO BYLA JUZ ROZPATRYWANA, ALBO BYLA JUZ NOT TAKEN,
+C ALBO JEST LOKALNA W INDPR
+ 670 IF(IND.NE.IDP) GO TO 700
+C NAZWE TRZEBA DOSTAWIC
+ M=INSERT(NM,IPMEM(IHBEG),341)
+ IPMEM(M+1) = 4
+ IPMEM(M+2) = IPMEM(J+2)
+ 700 J=IPMEM(J+3)
+ IF(J.NE.0) GO TO 600
+ 555 CONTINUE
+C PRZECHODZIMY DO NATEPNEGO PREFIKSU
+ IDP=IPMEM(IDP+21)
+ IF(IDP.NE.0) GO TO 800
+ RETURN
+ END
+ LOGICAL FUNCTION ONLY(NAME)
+C
+C * * * * * * * * * * * * * * * * * * * * * *
+C FUNKCJA SPRAWDZA, CZY NAZWA NAME JEST NA LISCIE TAKEN
+C POCZATEK LISTY TAKEN - IONLY
+C * * * * * * * * * * * * * * * * *
+C
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C
+ COMMON / DONLY / IONLY,ONIL
+ LOGICAL ONIL
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ROBOCZY BLOK, UZYWANY PRZY TWORZENIU ZBIORU IDENTYFIKATOROW
+C IONLY - POCZATEK LISTY TAKEN W ISMEM
+C ONIL=TRUE, GDY JEST TAKEN NIL
+
+C
+C JESLI LISTA TAKEN JEST PUSTA, TO ZAKLADAMY, ZE SA W NIEJ WSZYSTKIE
+C NAZWY
+C
+ ONLY=.FALSE.
+ IF(ONIL) RETURN
+ IF(IONLY.EQ.0) GO TO 200
+ I=IONLY
+ 100 IF(IPMEM(I).EQ.NAME) GO TO 200
+ I=IPMEM(I+2)
+ IF(I.NE.0) GO TO 100
+C NAZWY NIE MA NA LISCIE TAKEN
+ RETURN
+C NAZWA JEST NA LISCIE TAKEN
+ 200 ONLY=.TRUE.
+ RETURN
+ END
+ SUBROUTINE CHECK ( IND )
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C POPRAWIA BIT OZNACZAJACY PELNA KLASE POCZAWSZY OD PROTOTYPU IND
+C KONCZY, JESLI TEN BIT JEST 1
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ J=IND
+ 100 I=IPMEM(J)
+ IF(BTEST(I,0)) RETURN
+ IPMEM(J) = IOR(I,1)
+ J=IPMEM(J-1)
+ GO TO 100
+ END
+ INTEGER FUNCTION IDPUT(NAME,THASH)
+C
+C * * * * * * * * * * * * * * * * *
+C FUNKCJA WSTAWIA NAZWE NAME DO TABLICY THASH UPRZEDNIO SPRWDZAJAC,
+C CZY NAZWA JUZ TAM JEST.
+C JESLI JEST, TO WARTOSCIA FUNKCJI JEST 0 I WYKONYWANE SA REAKCJE NA BLAD
+C ( BLAD NIE JEST SYGNALIZOWANY )
+C JESLI NIE MA , TO WARTOSCIA FUNKCJI JEST WSTAWIANY ELEMENT
+C LISTY HASHU.
+C * * * * * * * * * * * * * * * * *
+C
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+cdsw INTEGER THASH(8)
+ dimension thash(8)
+C
+C
+C SPRAWDZENIE, CZY NAZWA JEST W TABLICY
+ I=MEMBER(NAME,THASH)
+ IF(I.NE.0) GO TO 100
+C NAZWY NIE MA - WSTAWIAMY
+ IDPUT = INSERT ( NAME,THASH,341)
+ RETURN
+C
+C NAZWA JEST - PODWOJNA DEKLARACJA
+ 100 IDPUT = 0
+ CALL MERR(309,NAME)
+C SKASOWANIE W ELEMENCIE LISTY HASHU INFORMACJI O HIDDEN I CLOSE
+ IPMEM(I+1) = 0
+C DOWIAZANIE NAZWY DO OBIEKTU UNIVERSAL
+ IPMEM(I+2) = NRUNIV
+ RETURN
+ END
+ INTEGER FUNCTION IFTYPE ( NAME)
+C
+C * * * * * * * * * * * * * * * * *
+C FUNKCJA ZNAJDUJE NAZWE NAME W PROTOTYPIE O IDENTYFIKATORZE INDPR
+C I DALEJ O SL-ACH. SPRAWDZA,CZY JEST TO NAZWA TYPU.
+C IFTYPE = IDENTYFIKATOR TYPU, JESLI TYP JEST POPRAWNY
+C IFTYPE = NRUNIV, GDY TYP JEST NIEZADEKLAROWANY LUB NIEDOSTEPNY
+C * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+C
+ IFTYPE=MEMSL(NAME,INDPR)
+ IF(IFTYPE.EQ.0) GO TO 200
+ I=IPMEM(IFTYPE+1)
+ IF(BTEST(I,2)) GO TO 100
+ IF(.NOT.BTEST(I,1) .OR. OWN) GO TO 400
+C NAZWA JEST HIDDEN
+ CALL MERR(317,NAME)
+ GO TO 150
+C NAZWA JEST NOT TAKEN
+ 100 CALL MERR(318,NAME)
+ 150 IFTYPE=NRUNIV
+ RETURN
+C NAZWA JEST ZADEKLAROWANA
+ 400 IFTYPE = IPMEM(IFTYPE + 2)
+C SPRAWDZENIE, CZY TO JEST NAZWA TYPU
+ IF(IAND(IPMEM(IFTYPE),MTP).NE.NOTTP) RETURN
+C TO NIE JEST NAZWA TYPU
+ IFTYPE = NRUNIV
+ CALL MERR(307,NAME)
+ RETURN
+C NAZWA JEST NIEZADEKLAROWANA - DKLADAMY JA DO BIEZACEGO PROTOTYPU
+ 200 CALL MERR(306,NAME)
+ IFTYPE = INSERT(NAME,IPMEM(IHBEG),341)
+ IFTYPE = NRUNIV
+ RETURN
+ END
+ SUBROUTINE DPUTQ (NSDIC,IDPMEM)
+C
+C * * * * * * * * * * * * * * * * *
+C PODPROGRAM WSTAWIA PARE (NSDIC,IDPMEM) DO KOLEJKI PROTOTYPOW
+C * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C
+ COMMON / QUEUE / BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
+cdsw INTEGER BQUEUE, EQUEUE
+ LOGICAL EMPTY
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
+C BQUEUE - POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
+C EQUEUE - KONIEC -- -- -- -- --
+C IFIRST - PIERWSZY ELEMENT KOLEJKI
+C LAST - OSTATNI ELEMENT KOLEJKI
+C EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+C JESLI DOSZLISMY DO KONCA OBSZARU PRZEZNACZONEGO NA KOLJKE, TO
+C ZACZYNAMY OD POCZATKU
+ IF ( LAST.EQ.EQUEUE-1) LAST=BQUEUE-2
+ IF(LAST.EQ.IFIRST-2.AND..NOT.EMPTY) GO TO 100
+C JEST MIEJSCE NA DOSTAWIANIE ELEMENTU DO KOLEJKI
+ EMPTY=.FALSE.
+ LAST = LAST+2
+ IPMEM(LAST) = NSDIC
+ IPMEM(LAST+1) = IDPMEM
+ RETURN
+C
+C PRZEPELNIENIE OBSZARU PRZEZNACZONEGO NA KOLEJKE
+C PRZERWANIE KOMPILACJI
+ 100 CALL MDROP(343)
+ RETURN
+ END
+ SUBROUTINE DGETQ
+C
+C
+C * * * * * * * * * * * * * * * * *
+C PODPROGRAM POBIERA PIERWSZY ELEMENT Z KOLEJKI PROTOTYPOW I
+C WSTAWIA NA ZMIENNE INDICT I INDPR Z BLOKU DGLOB.
+C NIE SPRAWDZA, CZY KOLEJKA JEST PUSTA.
+C JESLI NA SKUTEK WYKONANIA OPERACJI KOLEJKA BEDZIE PUSTA, TO ZMIENNA
+C EMPTY DOSTAJE WARTOSC TRUE .
+C * * * * * * * * * * * * * * * * *
+C
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / QUEUE / BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
+cdsw INTEGER BQUEUE, EQUEUE
+ LOGICAL EMPTY
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
+C BQUEUE - POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
+C EQUEUE - KONIEC -- -- -- -- --
+C IFIRST - PIERWSZY ELEMENT KOLEJKI
+C LAST - OSTATNI ELEMENT KOLEJKI
+C EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+ INDICT = IPMEM(IFIRST)
+ INDPR = IPMEM(IFIRST+1)
+ IF(LAST.EQ.IFIRST) GO TO 100
+C KOLEJKA MA CO NAJMNIEJ 2 ELEMENTY
+ IF(IFIRST.EQ.EQUEUE-1) GO TO 50
+ IFIRST = IFIRST+2
+ RETURN
+ 50 IFIRST = BQUEUE
+ RETURN
+C
+C KOLEJKA BEDZIE PUSTA
+ 100 EMPTY = .TRUE.
+ IFIRST=BQUEUE
+ LAST=BQUEUE-2
+ RETURN
+ END
+ SUBROUTINE HEADER
+C
+C
+C**********************************************C
+C PODPROGRAM PRZETWARZA LISTE PARAMETROW FORMALNYCH
+C PROTOTYPU INDPR
+C **********************************************
+C
+ IMPLICIT INTEGER(A-Z)
+ LOGICAL PQ,ISTPF,FORM2
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYGN = TRUE, GDY SA TO PARAMETRY SYGNALU
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW/
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C MNOTVIR - WZORZEC DO KASOWANIA BITU "WIRTUAL"
+C MHAND - MASKA DLA HANDLERA
+C
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - --- -- -- --- ZMIENNEJ INOUT
+C
+C - - - - - - - - - - - - - - - -
+C
+C SPRAWDZENIE,CZY TYP FORMALNY NIE WYSTEPUJE PO UZYCIU
+C JESLI BLOK - TO IDZIEMY DALEJ
+ IF(IPMEM(INDSPR).EQ.1) GO TO 1000
+ SYGN = ISHFT(IAND(IPMEM(INDPR),MPAR),-4).EQ.11
+ IDPAR = IPMEM(INDSPR+11)
+ IF(SYGN) IDPAR = IPMEM(INDSPR+4)
+ FORM2=.FALSE.
+ 100 IF(IDPAR.EQ.0) GO TO 1000
+ K=IPMEM(IDPAR)
+ 150 IF (FORM2) GO TO 350
+ IF(K.EQ.7) GO TO 900
+ IF(K.EQ.3.OR.K.EQ.5) GO TO 200
+ I1=IDPAR+5
+ IF(K.GE.8) I1=IDPAR+4
+ I=IPMEM(I1)
+C I - NAZWA TYPU PARAMETRU
+C SPRAWDZAMY,CZY TEN TYP JEST POZNIEJ W LISCIE PARAMETROW
+C OD IDPAR DO KONCA LISTY
+ PQ=ISTPF(I,.TRUE.)
+ IF(PQ) IPMEM(I1)=NEMPTY
+ IF(K.GE.8) GO TO 900
+C TERAZ SPRAWDZAMY PARAMETRY II-GO RZEDU
+ 200 LFORMB=IDPAR
+ FORM2=.TRUE.
+ IDPAR=IPMEM(LFORMB+4)
+ 300 IF(IDPAR.EQ.0) GO TO 800
+ K=IPMEM(IDPAR)
+ GO TO 150
+ 350 IF(K.LT.8) GO TO 700
+ I=IPMEM(IDPAR+4)
+C SZUKAMY TYPU OD IDPAR DO KONCA LISTY II-GO RZEDU
+ PQ=ISTPF(I,.TRUE.)
+ IF(.NOT.PQ) GO TO 400
+ IPMEM(IDPAR+4) = NEMPTY
+ GO TO 700
+C SZUKAMY TYPU WCZESNIEJ W LISCIE II-GO RZEDU BEZ
+C SYGNALIZACJI BLEDU
+ 400 PQ = ISTPF(I,.FALSE.)
+ IF( PQ ) GO TO 700
+C SZUKAMY W ZEWNETRZNEJ LISCIE PF OD PRZERABIANEJ
+C PROCEDURY/FUNKCJI DO KONCA
+ K=IDPAR
+ IDPAR=LFORMB
+ PQ = ISTPF(I,.TRUE.)
+ IF(PQ) IPMEM(K+4) = NEMPTY
+ IDPAR=K
+ 700 IDPAR = IPMEM(IDPAR+3)
+ GO TO 300
+ 800 FORM2=.FALSE.
+ IDPAR=LFORMB
+ 900 IDPAR = IPMEM(IDPAR+3)
+ GO TO 100
+C
+C - - - - - - - - - - - - - - - - -
+C
+C PRZETWARZANIE PARAMETROW
+C
+ 1000 CONTINUE
+C
+C PRZYGOTOWANIA DO PRZETWARZANIA LISTY PF
+ BEGM=LPML
+ INSYS=.TRUE.
+ LFORMB=MGETM(2,341)
+ LFORME=LFORMB
+ FORM2=.FALSE.
+ INSYS=.FALSE.
+C JESLI BLOK TO NIE POSIADA PARAMETROW
+ IF(IPMEM(INDSPR).EQ.1) GO TO 1500
+C
+C PRZETWARZANIE PARAMETROW
+ IDPAR=IPMEM(INDSPR+11)
+ IF(SYGN) IDPAR = IPMEM(INDSPR+4)
+ 1100 IF(IDPAR.EQ.0) GO TO 1500
+ K=IPMEM(IDPAR)
+ IF(K.EQ.7) GO TO 1200
+ IF(K.GE.8) GO TO 1300
+C PROCEDURA / FUNKCJA FORMALNA
+ CALL CHECK(INDPR)
+ CALL PROCFUN
+ GO TO 1400
+C TYP FORMALNY
+ 1200 CALL TYPEF
+ GO TO 1400
+C ZMIENNA
+ 1300 CALL VARIAB
+ 1400 IDPAR=IPMEM(IDPAR+3)
+ GO TO 1100
+C
+ 1500 CONTINUE
+C DOLACZENIE RESULT
+C JESLI TO JEST FUNKCJA
+C UWAGA - NAZWA RESULT DOLACZANA W PROTP1
+ IF(IPMEM(INDSPR).NE.4.AND.IPMEM(INDSPR).NE.6) GO TO 2000
+ I=MGETM(6,341) + 4
+ IPMEM(I) = OUTPFW
+ CALL PUTPF(I)
+ CALL MADATR(I,INDPR,341)
+C ZAPAMIETANIE 1 W POLU USED - DLA AIL
+ IPMEM(I+1)=1
+ IPMEM(INDPR-5) = I
+C DOLACZENIE TYPU
+ IPMEM(I-4) = IPMEM(INDPR-4)
+ IPMEM(I-3) = IPMEM(INDPR-3)
+C WYLICZENIE APETYTU RESULT
+ IPMEM(I) = IAP(I)
+C JESLI TO BYL TYP FORMALNY, TO ZMIANA SLOWA ZEROWEGO
+ IF(BTEST(IPMEM(INDPR),12))
+ * IPMEM(I) = IOR(IPMEM(I),ISHFT(1,12 ))
+C
+C
+ 2000 CONTINUE
+ FORM2=.FALSE.
+ IF(INDPREF.EQ.0) GO TO 1700
+C JESLI PREFIKS MIAL BLEDNA LISTE PF, TO NIE DOKLADAMY WLASNEJ
+ IF (IAND(IPMEM(INDPREF),MERPF).NE.0) GO TO 1850
+C DOPISANIE SWOJEJ LISTY PF
+ 1700 CALL COPY
+C DOLACZENIE LISTY PF Z PREFIKSU
+ IF(INDPREF.EQ.0) GO TO 3000
+ 1850 I=IPMEM(INDPREF+3)
+ J=IPMEM(INDPREF+4)
+ IF(J.EQ.0) GO TO 3000
+ K=MGETM(J,341)
+ DO 1666 I1=1,J
+ I2=K+I1-1
+ I3=I+I1-1
+ 1666 IPMEM(I2) = IPMEM(I3)
+ IPMEM(INDPR+3) = K
+ IPMEM(INDPR+4) = IPMEM(INDPR+4)+J
+ 3000 CONTINUE
+C ZAKONCZENIE
+ LPML=BEGM
+ RETURN
+ END
+ LOGICAL FUNCTION ISTPF(NM,PQ)
+C
+C * * * * * * * * * * * * * * * * * * * * * * * *
+C FUNKCJA SPRAWDZA,CZY TYP O NAZWIE NM WYSTEPUJE JAKO
+C FORMALNY W LISCIE PARAMETROW.
+C JESLI PQ=.TRUE., TO SZUKAMY OD IDPAR DO KONCA LISTY
+C I W RAZIE ZNALEZIENIA SYGNALIZUJEMY BLAD.
+C JESLI PQ=.FALSE., TO SZUKAMY OD POCZATKU LOKALNEJ LISTY
+C PARAMETROW(LFORMAB) DO IDPAR I NIE SYBNALIZUJEMY BLEDU.
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+ LOGICAL PQ
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W IPMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYNG = TRUE, GDY SA TO PARAMETRY SYGNALU
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+C
+C
+ K=0
+ IF(.NOT. PQ) K=IDPAR
+ I=IPMEM(IDPAR+3)
+ IF(.NOT.PQ) I=IPMEM(LFORMB+4)
+ ISTPF=.FALSE.
+ 100 IF(I.EQ.K) RETURN
+ IF(IPMEM(I).NE.7) GO TO 200
+C TYP FORMALNY
+ IF(IPMEM(I+2) .EQ. NM) GO TO 400
+ 200 I=IPMEM(I+3)
+ GO TO 100
+C ZNALEZIONY TYP
+ 400 ISTPF=.TRUE.
+ IF(.NOT.PQ)RETURN
+ LINE=IPMEM(IDPAR+1)
+ CALL MERR(316,NM)
+ RETURN
+ END
+ SUBROUTINE PUTPF(ID)
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * *
+C WSTAWIA PARAMETR O IDENTYFIKATORZE ID DO LISTY PF
+C * * * * * * * * * * * * * * * * * * * * * * * ***
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
+C
+C
+C
+C
+ INSYS=.TRUE.
+ K=MGETM(2,341)
+ IPMEM(K) = ID
+ IPMEM(LFORME+1) = K
+ LFORME=K
+ INSYS=.FALSE.
+ RETURN
+ END
+ SUBROUTINE COPY
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * *
+C KOPIUJE LISTE PF DO PAMIECI UZYTKOWNIKA
+C I DOWIAZUJE DO PROTOTYPU INDPR
+C * * * * * * * * * * * * * * * * * * * ** * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYN = TRUE, GDY TO SA PARAMETRY SYGNALU
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+C
+ I=IPMEM(LFORMB+1)
+ K=0
+ L=0
+ J=0
+ IF(I.EQ.0) GO TO 400
+ L=MGETM(1,341)
+ J=L
+ 100 X=IPMEM(I)
+ IPMEM(J) = X
+C JESLI TO SA PARAMETRY II-GO RZEDU,TO POPRAWIAMY SL NA INDPR
+ IF(FORM2) IPMEM(X-1) = INDPR
+ I=IPMEM(I+1)
+ K=K+1
+ IF(I.EQ.0) GO TO 200
+ J=MGETM(1,341)
+ GO TO 100
+ 200 CONTINUE
+C L - PIERWSZY PARAMETR
+C J - OSTATNI PARAMETR
+C TRZEBA ZAMIENIC ICH KOLEJNOSC
+ I1=J
+ I2=L
+ 300 IF (I1.GE.I2) GO TO 400
+ X=IPMEM(I1)
+ IPMEM(I1)=IPMEM(I2)
+ IPMEM(I2)=X
+ I1=I1+1
+ I2=I2-1
+ GO TO 300
+ 400 IPMEM(INDPR+3) = J
+ IPMEM(INDPR+4) = K
+ RETURN
+ END
+ SUBROUTINE TYPEF
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C PRZETWARZA TYP FORMALNY.
+C INFORMACJE O PARAMETRZE - W BLOKU DWORK
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
+C
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+C UTWORZENIE OPISU
+ LINE=IPMEM(IDPAR+1)
+ KIND=17
+ IF(FORM2) KIND=20
+ ID=INITPR(KIND,IPMEM(IDPAR+2))
+C WSTAWIENIE DO LISTY PF
+ CALL PUTPF(ID)
+ RETURN
+ END
+ SUBROUTINE VARIAB
+C
+C * * * * * * * * * * * * * * * * * * * * * * ** * * * *
+C PRZETWARZA PARAMETR BEDACY ZMIENNA
+C INFORMACJE O PARAMETRZE - W BLOKU DWORK
+C * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- --- -- ZMIENNEJ INOUT
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+ LINE = IPMEM(IDPAR+1)
+ NM=IPMEM(IDPAR+2)
+C . . .
+C UTWORZENIE OBIEKTU
+ ID=MGETM(6,341)+4
+ IPMEM(ID) = INPFW
+ IF(IPMEM(IDPAR).EQ.9) IPMEM(ID)=OUTPFW
+ IF(IPMEM(IDPAR).EQ.10) IPMEM(ID)=INOUT
+C WSTAWIENIE DO ZBIORU IDENTYFIKATOROW
+ IF(FORM2) INSYS=.TRUE.
+ K=IDPUT(NM,IPMEM(IHBEG))
+ IF(K.EQ.0) GO TO 200
+ IPMEM(K+2) = ID
+C WSTAWIENIE DO LISTY ATRYBUTOW
+ 200 CALL MADATR(ID,INDPR,341)
+C ZAPAMIETANIE 1 W POLU USED - DLA AIL
+ IPMEM(ID+1)=1
+C WSTAWIENIE DO LISTY PF
+ CALL PUTPF(ID)
+C
+C ROZPOZNANIE TYPU
+ NM=IPMEM(IDPAR+4)
+ K=IFTYPE(NM)
+ IPMEM(ID-3) = K
+ IPMEM(ID-4) = IPMEM(IDPAR+5)
+C WSTAWIENIE APETYTU
+ IPMEM(ID) = IAP(ID)
+C JESLI TYP JEST FORMALNY, TO POPRAWIAMY SLOWO ZEROWE
+ IF(IAND(IPMEM(K),MTP) .NE. 6) RETURN
+ IPMEM(ID) = IOR(IPMEM(ID),ISHFT(1,12))
+C JESLI TYP FORMALNY JEST NIELOKALNY, TO POPRAWIAMY SPECYFIKACJE
+C PROTOTYPU
+ IF(LOCAL.EQ.2) RETURN
+ IF(FORM2) GO TO 300
+ CALL CHECK(INDPR)
+C JESLI SYGNAL - TO BLAD
+ 250 IF(SYGN) CALL MERR(361,NM)
+ RETURN
+C JESLI TYP POCHODZI Z TEJ SAMEJ LISTY PARAMETROW CO PROCEDUURA FORMALNA,
+C TO DOBRZE
+ 300 IF(IPMEM(K-1).EQ.IPMEM(INDPR-1)) RETURN
+ GO TO 250
+ END
+ SUBROUTINE PROCFUN
+C
+C * * * * * * ** * * * * * * * * * * * * * * * * * * * * *
+C PRZETWARZA PROCEDURE LUB FUNKCJE FORMALNA I-GO RZEDU
+C INFORMACJE O PARAMETRZE W BLOKU DWORK
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
+C
+C
+ COMMON /DCOPIES/ INDPRC,IHBEGC, IDPARC,LFBC,LFEC
+C
+C * * * * * * * * * * * * * * * * * * * * * *
+C KOPIE ZMIENNYCH Z DGLOB I DWORK
+C INDPRC - KOPIA INDPR
+C IHBEGC - KOPIA IHBEG
+C IDPARC - KOPIA IDPAR
+C LFBC - KOPIA LFORMB
+C LFEC - KOPIA LFORME
+C
+C
+ COMMON / YNIT / NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
+ * VARWD,VARPOM,INPFW,OUTPFW, INOUT
+cdsw INTEGER SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C NULLWD(I) - WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
+C SIZEPR(I) - ROZMIAR POLA W IPMEM -- -- --
+C NULLPOZ(I) - POZYCJA SLOWA ZEROWEGO -- -- --
+C CONSTWD - WZORZEC SLOWA ZEROWEGO DLA CONST
+C VARWD - -- -- -- -- DLA ZMIENNEJ
+C VARPOM - -- -- -- -- ZMIENNEJ POMOCNICZEJ
+C INPFW - -- -- -- -- ZMIEMNEJ INPUT
+C OUTPFW - -- -- -- -- ZMIENNEJ OUTPUT
+C INOUT - -- -- -- --- ZMIENNEJ INOUT
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+C
+C
+ NM=IPMEM(IDPAR+2)
+ LN=IPMEM(IDPAR+1)
+ LINE=LN
+C . . .
+C BEGM - POCZATEK WOLNEGO POLA W PAMIECI SYSTEMOWEJ
+ BEGM=LPML
+ LP=LASTPR
+C UTWORZENIE OPISU PARAMETRU
+ K=IPMEM(IDPAR) + 10
+ I=INITPR(K,NM)
+C ZAPAMIETANIE KOPII
+ INDPRC=INDPR
+ IHBEGC=IHBEG
+ IDPARC=IDPAR
+ LFBC=LFORMB
+ LFEC=LFORME
+C ZAMIANA ZMIENNYCH OKRESLAJACYCH PRZETWARZANY PROTOTYP
+ INDPR=I
+ IHBEG=I+10
+ INSYS=.TRUE.
+ LFORMB=MGETM(2,341)
+ LFORME=LFORMB
+ FORM2=.TRUE.
+C
+C - - - - - - - - - - - - - - - - - - -
+C PRZETWARZANIE LISTY PF II-GO RZEDU
+C
+C
+ INSYS=.FALSE.
+ IDPAR=IPMEM(IDPAR+4)
+ 100 IF(IDPAR.EQ.0) GO TO 500
+ KD=IPMEM(IDPAR)
+ IF(KD.EQ.7) GO TO 200
+ IF(KD.GE.8) GO TO 300
+C PROCEDURA/FUNKCJA II-GO RZEDU
+ CALL PROCF2
+ GO TO 400
+C TYP FORMALNY
+ 200 CALL TYPEF
+ GO TO 400
+C ZMIENNA
+ 300 CALL VARIAB
+ 400 IDPAR = IPMEM(IDPAR+3)
+ GO TO 100
+C
+ 500 CONTINUE
+C
+C - - - - - - - - - - - - - - - - -
+C CZYNNOSCI ORGANIZACYJNE(PAMIEC) I ZAKONCZENIE
+C PRZETWARZANIA PROCEDURY/FUNKCJI
+C
+ LINE=LN
+C DOLACZENIE RESULT - JESLI TO JEST FUNKCJA
+ IF(K.EQ.13.OR.K.EQ.15) GO TO 700
+ I=MGETM(6,341) +4
+ IPMEM(I) = OUTPFW
+ CALL MADATR(I,INDPR,341)
+ CALL PUTPF(I)
+C ZAPAMIETANIE IDENTYFIKATORA RESULT
+ IPMEM(INDPR-5)=I
+C UWAGA - NAZWY RESULT NIE TRZEBA ZAPAMIETYWAC
+ 700 CONTINUE
+C PRZEPISANIE PROTOTYPU DO CZESCI UZYTKOWNIKA
+ IF(K.EQ.14 .OR. K.EQ.16) GO TO 750
+ I=INDPR-2
+ J=7
+ KD=MGETM(7,341)
+ INDPR=KD+2
+ GO TO 800
+ 750 I=INDPR-5
+ J=10
+ KD=MGETM(10,341)
+ INDPR=KD+5
+ 800 CONTINUE
+ DO 888 II=1,J
+ I1=KD+II-1
+ I2=I+II-1
+ 888 IPMEM(I1) = IPMEM(I2)
+C ZMIANA DOWIAZANIA NEXTDECL W PROTOTYPIE POPRZEDZAJACYM ( LP )
+ IPMEM(LP+2) = INDPR
+ IF(IPMEM(INDPR+2).EQ.0) LASTPR = INDPR
+C PRZEPISANIE LISTY PF
+ CALL COPY
+C POPRAWIENIE ID PROTOTY@PU W TABLICY HASH
+ I=MEMBER(NM,IPMEM(IHBEGC))
+ IPMEM(I+2) = INDPR
+C POPRAWIENIE ID PROTOTYPU W LISCIE ATRYBUTOW
+ I=IPMEM(INDPR-2)
+C I - NUMER ATRYBUTU
+ KD=IPMEM(INDPRC+6)
+ 920 J=IPMEM(KD)
+ IF(IPMEM(J-2).EQ.I) GO TO 950
+ KD=IPMEM(KD+1)
+ GO TO 920
+C KD - ATRYBUT
+ 950 IPMEM(KD) = INDPR
+C COFNIECIE PAMIECI SYSTEMOWEJ
+ LPML=BEGM
+C COFNIECIE ZMIENNYCH Z DWORK
+ LFORMB=LFBC
+ LFORME=LFEC
+ IDPAR=IDPARC
+ FORM2=.FALSE.
+C DOLACZENIE SIEBIE DO LISTY PF
+ CALL PUTPF(INDPR)
+C COFNIECIE ZMIENNYCH Z DGLOB
+ I=INDPR
+ INDPR=INDPRC
+ IHBEG=IHBEGC
+C
+C JESLI FUNKCJA - TO NADANIE TYPU
+ IF(K.EQ.13 .OR. K.EQ.15) GO TO 1000
+ NM=IPMEM(IDPAR+5)
+ J=IFTYPE(NM)
+ IPMEM(I-3) = J
+ IPMEM(I-4) = IPMEM(IDPAR+6)
+ K=IPMEM(I-5)
+ IPMEM(K-4) = IPMEM(I-4)
+ IPMEM(K-3) = J
+C JESLI TO JEST TYP FORMALNY, TO POPRAWIAMY SLOWO ZEROWE
+ IF(IAND(IPMEM(J),MTP).NE.6) GO TO 1000
+ IPMEM(I) = IOR(IPMEM(I),ISHFT(1,12))
+ IPMEM(K) = IOR(IPMEM(K),ISHFT(1,12))
+C JESLI TYP FORMALNY JEST NIELOKALNY, TO ZLE DLA SYGNALU
+ IF(LOCAL.EQ.2 .OR. .NOT.SYGN) GO TO 1000
+ CALL MERR(361,NM)
+ 1000 CONTINUE
+C WYPISUJEMY INFORMACJE O PARAMETRACH II-GO RZEDU
+C K=IPMEM(I+3)
+C IF(IPMEM(I+4).EQ.0)RETURN
+C J=IPMEM(I+4)+K-1
+C DO 1111 II=K,J
+C I=IPMEM(II)
+C NM=ISHFT(IAND(IPMEM(I),MPAR),-4)
+C IF(NM.GE.4) GO TO 1112
+C CALL ffwrite(BO(2),"IDENTYFIKATOR =",17)
+C CALL ffwrint(BO(2),I)
+C CALL WRITEPR(I)
+C GO TO 1111
+C1112 CALL WATTR(I)
+C1111 CONTINUE
+C . . .
+ RETURN
+ END
+ SUBROUTINE PROCF2
+C
+C ** ** ** ** * * * * * * * * * * * * * * * * *
+C PRZETWARZA PROCEDURE/FUNKCJE FORMALNA II-GO RZEDU
+C PARAMETR DANY PRZEZ ZMIENNE Z BLOKU DWORK
+C * * * * * * * * * * * * * * * * * * * * * * *** *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+C
+ COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
+ LOGICAL FORM2, SYGN
+C
+C * * * * * * * * * * * * * * * * * * * *
+C IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
+C LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
+C FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
+C SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+ LINE=IPMEM(IDPAR+1)
+ NM=IPMEM(IDPAR+2)
+C DOLACZENIE DO LISTY PF ATRYBUTU DODATKOWEGO(BRAK)
+C UTWORZENIE PROTOTYPU
+ K=IPMEM(IDPAR)+15
+ I=INITPR(K,NM)
+C DOLACZENIE DO LISTY PF
+ CALL PUTPF(I)
+C EWENTUALNIE TYP FUNKCJI - BRAK
+ IF(K.EQ.18) RETURN
+ IPMEM(I-3)=NRUNIV
+ RETURN
+ END
+ SUBROUTINE VIRTCOM
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C SPRAWDZA KOMPATYBILNOSC WIRTUALI
+
+C * * * * * * * * * * * * * * * * * ** * * * * * * * * * * *
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL PARCOM,P
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+ COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
+ LOGICAL FORM2,TPVI
+C
+C ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
+C ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
+C NM - NAZWA WIRTUALA
+C INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
+C FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
+C TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
+C INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
+C FORMALNYCH
+C
+C
+ TPVI=.FALSE.
+ FORM2=.FALSE.
+ INDV=IPMEM(INDPR+26)
+ NM=IPMEM(INDSPR+10)
+ LINE=IPMEM(INDSPR+9)
+C KONTROLA RODZAJOW WIRTUALI
+ IRU=ISHFT(IAND(IPMEM(INDV),MOTHERS),-8)
+ IRL=ISHFT(IAND(IPMEM(INDPR),MOTHERS),-8)
+ IF (IRU.EQ.IRL) GO TO 50
+C BLAD RODZAJOW
+ CALL MERR(331,NM)
+C JESLI TO SA FUNKCJE - TO SPRAWDZAMY TYPY
+ 50 IF(IRL.EQ.4 .OR. IRU.EQ.4) GO TO 100
+ TPVI=.TRUE.
+ CALL TYPECOM(INDV,INDPR)
+ TPVI = .FALSE.
+ 100 I=IPMEM(INDPR+3)
+ IL=IPMEM(INDPR+4)
+C DLA FUNKCJI TRZEBA POMINAC RESULT
+ IF(IRL.EQ.2) IL=IL-1
+ J=IPMEM(INDV+3)
+ JU=IPMEM(INDV+4)
+ IF(IRU.EQ.2) JU=JU-1
+C I,IL - POCZATEK I DLUGOSC LISTY PF DLA INDPR
+C J,JU - POCZATEK I DLUGOSC LISTY PF DLA INDV
+ IF(IL+JU.EQ.0) GO TO 1000
+ IF(IL.NE.JU) GO TO 800
+C ZGODNA LICZBA PARAMETROW
+ 200 IL=IL+I-1
+ JU=JU+J-1
+ NM=NEMPTY
+C SPRAWDZENIE ZGODNOSCI PARAMETROW
+C PROCEDURA PARCOM DAJE TRUE, GDY TRZEBA
+C DALEJ SPRAWDZAC ZGODNOSC PF II-GO RZEDU
+C (TZN. SA TO PROCEDURY/FUNKCJE)
+ 300 IF(.NOT.PARCOM(IPMEM(J),IPMEM(I))) GO TO 700
+C SPRAWDZAMY ZGODNOSC PF II-GO RZEDU
+ FORM2=.TRUE.
+ INDPR1=IPMEM(I)
+ INDV1=IPMEM(J)
+ IRL1=ISHFT(IAND(IPMEM(INDPR1),MOTHERS),-8)
+ IRU1=ISHFT(IAND(IPMEM(INDV1),MOTHERS),-8)
+ I1=IPMEM(INDPR1+3)
+ IL1=IPMEM(INDPR1+4)
+C DLA FUNKCJI - POMIJAMY RESULT
+ IF(IRL1.EQ.2) IL1 = IL1-1
+ J1=IPMEM(INDV1+3)
+ JU1=IPMEM(INDV1+4)
+ IF(IRU1.EQ.2) JU1 = JU1-1
+ IF(IL1+JU1.EQ.0) GO TO 600
+ IF(IL1.NE.JU1) GO TO 500
+ 350 IL1=IL1+I1-1
+ JU1=JU1+J1-1
+C SPRAWDZANIE ZGODNOSCI PARAMETROW II-GO RZEDU
+ 400 P=PARCOM(IPMEM(J1),IPMEM(I1))
+ I1=I1+1
+ J1=J1+1
+ IF(I1.LE.IL1.AND.J1.LE.JU1) GO TO 400
+ GO TO 600
+C NIEZGODNA LICZBA PARAMETROW
+ 500 CONTINUE
+ IF(IL1.LT.JU1) GO TO 530
+C SPRAWDZAMY,CZY LISTA KROTSZA JEST BLEDNA
+ IF(IAND(IPMEM(INDV1),MERPF).NE.0) GO TO 550
+ CALL MERR(336,NM)
+ GO TO 550
+ 530 IF(IAND(IPMEM(INDPR1),MERPF).NE.0) GO TO 550
+ CALL MERR(336,NM)
+ 550 IF(IL1*JU1.NE.0) GO TO 350
+ 600 CONTINUE
+C KONIEC SPRAWDZANIA PARAMETROW II-GO RZEDU
+ FORM2=.FALSE.
+ 700 I=I+1
+ J=J+1
+ IF(I.LE.IL.AND.J.LE.JU) GO TO 300
+C KONIEC PARAMETROW
+ GO TO 1000
+C NIEZGODNA LICZBA PARAMETROW
+ 800 IF(IL.LT.JU) GO TO 850
+ IF(IAND(IPMEM(INDV),MERPF).NE.0) GO TO 900
+C KROTSZA LISTA PF NIE JEST BLEDNA
+ CALL MERR(333,NM)
+ GO TO 900
+ 850 IF(IAND(IPMEM(INDPR),MERPF).NE.0) GO TO 900
+ CALL MERR(333,NM)
+ 900 IF(IL*JU.NE.0) GO TO 200
+C
+ 1000 CONTINUE
+C ZAKONCZENIE
+ RETURN
+ END
+ LOGICAL FUNCTION PARCOM(PARU,PARL)
+C
+C * * * * * * * * * * * * * * * * * * * * * * ** * * * * * * * * * *
+C SPRAWDZA ZGODNOSCI PARAMETROW O IDENTYFIKATORACH PARU I PARL
+C PARCOM=.TRUE., GDY OBA PARAMETRY SA PROCEDURA LUB FUNKCJA
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
+ LOGICAL FORM2,TPVI
+C
+C ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
+C ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
+C NM - NAZWA WIRTUALA
+C INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
+C FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
+C TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
+C INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
+C FORMALNYCH
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO ROZPOZNANIA BLEDNYCH LIST PF
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+ IDU=ISHFT(IAND(IPMEM(PARU),MPAR),-4)
+ IDL=ISHFT(IAND(IPMEM(PARL),MPAR),-4)
+ PARCOM=.FALSE.
+C . . .
+C KONTROLA RODZAJOW
+ IF(IDU.EQ.IDL) GO TO 100
+C NIEZGODNE RODZAJE
+ I=334
+ IF (FORM2) I=337
+ CALL MERR(I,NM)
+C JESLI OBA PARAMETRY SA ZMIENNYMI, TO KONTROLA TYPOW
+ 100 IF((IDU.EQ.5.OR.IDU.EQ.6.OR.IDU.EQ.9)
+ * .AND. (IDL.EQ.5.OR.IDL.EQ.6.OR.IDL.EQ.9)) GO TO 300
+ IF(IDU.NE.2.AND.IDU.NE.3 .OR. IDL.NE.2.AND.IDL.NE.3)
+ * RETURN
+ PARCOM=.TRUE.
+C JESLI OBIE FUNKCJE I-GO RZEDU - TO KONTROLA TYPOW
+ IF(IDU.NE.2.OR.IDL.NE.2) RETURN
+ IF(FORM2) RETURN
+C KONTROLA TYPOW
+ 300 CALL TYPECOM(PARU,PARL)
+ RETURN
+ END
+ SUBROUTINE TYPECOM (TPU,TPL)
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C KONTROLA ZGODNOSCI TYPOW
+C TPU,TPL - IDENTYFIKATORY ZMIENNYCH(FUNKCJI)
+C TPVI=.TRUE., GDY TO SA TYPY FUNKCJI VIRTUALNYCH
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ IMPLICIT INTEGER(A-Z)
+ LOGICAL POMU,POML,BPREF
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+
+C MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+ COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
+ LOGICAL FORM2,TPVI
+C
+C ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
+C ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
+C NM - NAZWA WIRTUALA
+C INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
+C FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
+C TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
+C INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
+C FORMALNYCH
+C
+C
+C
+C U - TYP WYZSZY
+C IARU,IARL - ILOSC ARRAY OF
+C ITU,ITL - IDENTYFIKATORY TYPOW
+C IDENU,IDNEL - WARTOSCI MTP ZE SLOWA ZEROWEGO TYPOW
+ ITU=IPMEM(TPU-3)
+ ITL=IPMEM(TPL-3)
+ IARU=IPMEM(TPU-4)
+ IARL=IPMEM(TPL-4)
+C JESLI TYPY SA IDENTYCZNE, TO DOBRZE
+ IF(IARU.EQ.IARL.AND.ITL.EQ.ITU) RETURN
+C JESLI JEDEN Z TYPOW JEST UNIWERSALNY, TO DOBRZE
+ IF(ITL.EQ.NRUNIV.OR.ITU.EQ.NRUNIV) RETURN
+C JESLI TYPY ROZNIA SIE TYLKO ARRAY OF , TO ZLE
+ IF(IARU.NE.IARL.AND.ITL.EQ.ITU) GO TO 999
+ IDENU=IAND(IPMEM(ITU),MTP)
+ IDENL=IAND(IPMEM(ITL),MTP)
+ IF(IDENU.EQ.6) GO TO 500
+C TYP WYZSZY NIE JEST FORMALNY
+C JESLI NIE ZGADZA SIE ARRAY OF , TO BLAD
+ IF(IARU.NE.IARL) GO TO 999
+C JESLI SA TABLICOWE, TO MUSZA BYC ROWNE
+ IF(IARU.NE.0.AND.ITU.NE.ITL) GO TO 999
+C JESLI JESZCZE SA TU TYPY PRYMITYWNE, TO BLAD(MUSZA BYC ROWNE)
+ IF(IDENU.GE.8 .AND. IDENU.LT.13) GO TO 999
+ IF(IDENL .GE. 8 .AND. IDENL .LT. 13) GO TO 999
+ IF(ITU.EQ.NRCOR) GO TO 200
+ IF(ITU.EQ.NRPROC) GO TO 300
+C TYP WYZSZY JEST KLASOWY
+C TYPY MAJA BYC W SEKWENCJI PREFIKSOWEJ
+ IF(IDENL.EQ.6) GO TO 999
+ I=IPMEM(ITU-6)
+ J=IPMEM(ITL-6 )
+ IF(BPREF(ITL,I)) RETURN
+ IF(TPVI) GO TO 999
+ IF(BPREF(ITU,J)) RETURN
+ GO TO 999
+C WYZSZY - SAMA COROUTINA
+ 200 IF(IDENL.EQ.5 .OR. IDENL.EQ.7) RETURN
+ IF(BPREF(ITL,IPMEM(NRCOR-6))) RETURN
+ IF(BPREF(ITL,IPMEM(NRPROC-6))) RETURN
+ GO TO 999
+C WYZSZY - SAM PROCESS
+ 300 IF(IDENL.EQ.5) RETURN
+ IF(BPREF(ITL,IPMEM(NRPROC-6))) RETURN
+ GO TO 999
+C
+C WYZSZY - TYP FORMALNY
+ 500 CONTINUE
+ I=NRPAR(ITU,.TRUE.)
+ J=NRPAR(ITL,.FALSE.)
+C I,J - NUMERY TYPOW W LISCIE INDV(INDPR)
+C JESLI TO SA PARAMETRY II-GO RZEDU, TO TAKZE
+C W LISCIE PF INDV1(INDPR1)
+ IF(I+J.EQ.0) GO TO 700
+ IF(I.NE.J) GO TO 999
+ IF(IARU.NE.IARL) GO TO 999
+C TRZEBA SPARWDZIC, CZY OBA TYPY SA PARAMETRAMI
+C TEGO SAMEGO RZEDU
+ I=IPMEM(ITU-1)
+ J=IPMEM(ITL-1)
+C I,J - SLE
+ POMU=IAND(IPMEM(I),MPAR).NE.0
+ POML=IAND(IPMEM(J),MPAR).NE.0
+ IF(POMU.AND.POML.OR..NOT.(POMU.OR.POML))RETURN
+ GO TO 999
+C
+C TO NIE JEST WLASNY PARAMETR
+ 700 CONTINUE
+ IF(IARU.NE.0) GO TO 800
+C JESLI WYZSZY NIE JEST TABLICOWY, TO ZLE, GDY
+C NIZSZY JEST PRYMITYWNY NIETABLICOWY
+ IF(IARL.NE.0) RETURN
+ IF(IDENL.GE.8.AND.IDENL.LT.13) GO TO 999
+ RETURN
+C WYZSZY JEST TYPEM TABLICOWYM
+ 800 IF(IDENL.EQ.6) RETURN
+ IF(IARU.LE.IARL) RETURN
+C SYGNALIZACJA BLEDOW
+ 999 I=335
+ IF (TPVI) I=332
+ IF(FORM2) I=338
+ CALL MERR(I,NM)
+ RETURN
+ END
+ INTEGER FUNCTION NRPAR(IDT,UP)
+C
+C * * * * * * *** * * * * * * * * * * * * * * * * * * * * *
+C SPRAWDZA,CZY TYP IDT JEST PARAMETREM INDPR(INDV)
+C UP=.TRUE. - CHODZI O WIRTUAL WYZSZY (INDV)
+C NRPAR - NUMER IDT JAKO PARAMETRU ( LUB 0)
+C JESLI FORM2=.TRUE., TO BADA TEZ, CZY TYP JEST PARAMETREM/
+C INDV1(ODP. INDPR1)
+C * * * * * * * * * * * * * * * * * * * * * * * * * ** * * *
+C
+ IMPLICIT INTEGER(A-Z)
+ LOGICAL UP,BPREF
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+ COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
+ LOGICAL FORM2,TPVI
+C
+C ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
+C ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
+C NM - NAZWA WIRTUALA
+C INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
+C FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
+C TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
+C INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
+C FORMALNYCH
+C
+C
+C
+C
+ NRPAR=0
+C JESLI TYP NIE JEST FORMALNY, TO KONIEC
+ I=IAND(IPMEM(IDT),MTP)
+ IF(I.NE.6) RETURN
+C IND - TU SZUKAMY PARAMETRU
+ IF(FORM2) GO TO 500
+ 300 IND=INDPR
+ IF(UP) IND=INDV
+ IS=IPMEM(IDT-1)
+C IS - SL TYPU
+C SPRAWDZAMY, CZY I=IND LUB JEGO PREFIKS
+ IF(IS.EQ.IND) GO TO 100
+C JESLI IS NIE JEST KLASA, TO KONIEC
+ IF(IAND(IPMEM(IS),MTP).EQ.1) RETURN
+ IF(.NOT.BPREF(IND,IPMEM(IS-6))) RETURN
+C TO JEST PARAMETR
+ 100 I=IPMEM(IND+3)
+ 200 NRPAR=NRPAR+1
+ IF(IPMEM(I).EQ.IDT) RETURN
+ I=I+1
+ GO TO 200
+C SZUKAMY W LISCIE II-GO RZEDU
+ 500 IND=INDPR1
+ IF(UP) IND=INDV1
+ IF(IS.NE.IND) GO TO 300
+ GO TO 100
+ END
+ SUBROUTINE SIGNAL ( IDSIG )
+C
+ IMPLICIT INTEGER (A-Z)
+C
+C * * * * * * ** * * * * * * * * * * ** * * * * * * * * * * * * * * * * *
+C PRZETWARZA SYGNAL O IDENTYFIKATORZE ( SYNTAKTYCZNYM ) IDSIG
+C TWORZY DLA NIEGO KOMPLETNY PROTOTYP
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+cdsw COMMON /SIGNALS/ NRSIG, HLISTE
+cdsw -----------------------------------------------------
+ common /signs/ nrsig, hliste
+cdsw -----------------------------------------------------
+C
+C NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
+C HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C . . .
+C
+C NRPR - NUMER PROTOTYPU SEMANTYCZNEGO
+ NRPR = IPMEM(IDSIG)
+ NM = IPMEM(IDSIG+2)
+ LINE = IPMEM(IDSIG+1)
+C USTAWIENIE BITU CLOSE
+ I = MEMSL (NM, INDPR )
+ IPMEM(I+1) = 1
+C PRZYDZIELENIE NUMERU SYGNALU
+ NRSIG = NRSIG+1
+ IPMEM(NRPR+1) = NRSIG
+C ZAPAMIETANIE SYNTAKTYCZNEJ LISTY PARAMETROW W PROTOTYIE SYGNALU (KONTROLA)
+ IPMEM(NRPR+8) = IPMEM(IDSIG+4)
+C
+C PRZETWARZANIE NAGLOWKA
+C ZAPAMIETANIE KOPII ZMIENNYZCH OKRESLAJACYCH PRZETWARZANY PROTOTYP
+ INDC = INDSPR
+ INDPRC = INDPR
+ PREFC = INDPREF
+ IHBEGC = IHBEG
+C NADANIE NOWYCH WARTOSCI
+ INDPR = NRPR
+ INDSPR = IDSIG
+ IHBEG = INDPR+10
+ INDPREF = 0
+C PRZETWARZANIE NAGLOWKA
+ CALL HEADER
+C PRZYWROCENIE WARTOSCI ZMIENNYM
+ INDPR = INDPRC
+ INDSPR = INDC
+ IHBEG = IHBEGC
+ INDPREF = PREFC
+C . . .
+ RETURN
+ END
+ SUBROUTINE HANDLER ( IDSMEM )
+C
+ IMPLICIT INTEGER ( A-Z )
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C
+C ** * * * * ** * * * * * * * * * ** * * * * * ** ** ** * ** * * *** * **
+C PRZETWARZA PROTOTYP HANDLERA
+C IDSMEM - IDENTYFIKATOR PROTOTYPU SYNTAKTYCZNEGO
+C * * * * * * * * * * * * * * * * *** * * * * * * * * * *** * * * * * *
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+cdsw COMMON /SIGNALS/ NRSIG, HLISTE
+cdsw ----------------------------------------------------------
+ common /signs/ nrsig, hliste
+cdsw ----------------------------------------------------------
+C
+C NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
+C HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
+C
+C
+ COMMON /COPSIG/ BEGADR, IDHAND
+C
+C BLOK SLUZACY DO KOMUNIKACJI Z PROCEDURA KOPIUJACA POSZCZEGOLNE PROTOTYPY
+C IDHAND - IDENTYFIKATOR HANDLERA
+C BEGADR - PIERWSZY ELEMENT SLOWNIKA ZAMIANY STARYCH ADRESOW NA NOWE
+C KAZDY ELEMENT SLOWNIKA ZAJMUJE 2 SLOWA: STARY ADRES, NOWY ADRES.
+C OSTATNI ELEMENT SLOWNIKA - LPML-2
+C
+C
+C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+C
+C
+C
+ IDHAND = IPMEM(IDSMEM+1)
+ LINE = IPMEM(IDSMEM+9)
+C
+C PRZEJSCIE PO LISCIE NAZW SYGNALOW
+C ODNALEZIENIE SYGNALOW, SPRAWDZENIE ICH POPRAWNOSCI, UTWORZENIE LISTY
+C HANDLEROW
+C LS - KOLEJNY ELEMENT LISTY
+C POR - ELEMENT LISTY Z KTORYM BEDZIEMY POROWNYWAC
+C NAGLOWKI KOLEJNYCH SYGNALOW
+ LS = IPMEM(IDSMEM+10)
+ I = 0
+ IF(LS.EQ.0) GO TO 810
+C TO NIE JEST HANDLER OTHERS
+ POR = LS
+ 50 NM = IPMEM(LS)
+C . . .
+ I = MEMSL(NM, INDPR)
+ IF (I.EQ.0) GO TO 100
+ IF ( BTEST(IPMEM(I+1),2)) GO TO 150
+ IF ( .NOT. BTEST(IPMEM(I+1),1) .OR. OWN ) GO TO 300
+C NAZWA JEST HIDDEN
+ CALL MERR(351,NM)
+ GO TO 200
+C NAZWA JEST NOT TAKEN
+ 150 CALL MERR (352, NM)
+ GO TO 200
+C NAZWA NIEZADEKLAROWANA
+ 100 CALL MERR (350, NM)
+C JESLI TO JEST ELEMENT, Z KTORYM MAMY POROWNYWAC, TO GO PRZESUWAMY
+ 200 IF(POR.EQ.LS) POR = IPMEM(LS+1)
+ GO TO 1000
+C
+C NAZWA JEST ZADEKLAROWANA
+C SPRAWDZAMY, CZY TO JEST NAZWA SYGNALU
+ 300 IDSIG = IPMEM(I+2)
+ J = IPMEM(IDSIG)
+ J = ISHFT(IAND(J,MPAR),-4)
+ IF(J.NE.11) GO TO 250
+C TO JEST PROTOTYP SYGNALU
+C JESLI TO JEST PIERWSZY, TO PRZECHODZIMY DO NASTEPNEGO
+ IF(LS.EQ.IPMEM(IDSMEM+10)) GO TO 800
+ IF(LS.EQ.POR) GO TO 800
+C SPRAWDZAMY ZGODNOSC PARAMETROW
+ IF(IAND(IPMEM(IDSIG),MERPF).NE.0) GO TO 400
+C JESLI LS MA DOBRA LISTE PARAMETROW, A POR ZLA - TO ZMIENIAMY POR
+ J = IPMEM(POR)
+ IF(IAND(IPMEM(J),MERPF).EQ.0) GO TO 400
+ POR = LS
+ GO TO 800
+C TO NIE JEST PROTOTYP SYGNALU
+ 250 CALL MERR ( 353,NM )
+ GO TO 200
+C
+C SPRAWDZAMY ZGODNOSC LISTY PARAMETROW
+ 400 CALL SPRPAR ( IDSIG, IPMEM(POR), NM)
+C DOLACZAMY DO LISTY HANDLEROW
+ 800 I = IPMEM(IDSIG+1)
+C SPRAWDZAMY, CZY HANDLER SI NIE POWTARZA
+ 810 IF(HLISTE.EQ.0) GO TO 830
+ J=IPMEM(INDPR+20)
+ 820 IF(IPMEM(J).NE.I) GO TO 840
+ CALL MERR(362,NM)
+ GO TO 950
+ 840 J=IPMEM(J+2)
+ IF(J.NE.0) GO TO 820
+ 830 J = MGETM(3,341)
+ IPMEM(J) = I
+ IPMEM(J+1) = IDHAND
+C . . .
+ IF(HLISTE.EQ.0) GO TO 850
+ IPMEM(HLISTE+2)=J
+ GO TO 900
+ 850 IPMEM(INDPR+20) = J
+ 900 HLISTE = J
+ IPMEM(INDPR+19) = IPMEM(INDPR+19) + 1
+C JESLI HANDLER OTHERS, TO KONIEC
+ IF(I.EQ.0) RETURN
+C ZAPAMIETUJEMY IDENTYFIKATOR PROTOTYPU W POLU NAZWY
+ 950 IPMEM(LS) = IDSIG
+ 1000 LS = IPMEM(LS+1)
+ IF(LS.NE.0) GO TO 50
+C
+C KOPIOWANIE ATRYBUTOW
+C POR - Z TEGO SIE KOPIUJE DO HANDLERA
+C POR = 0 - NIE BYLO ANI JEDNEGO POPRAWNEGO SYGNALU
+ IF(POR.EQ.0) RETURN
+ BEGADR = LPML
+ IDSIG = IPMEM(POR)
+C WSTAWIENIE DO HANDLERA DOWIAZANIA DO SYGNALU
+ IPMEM(IDHAND+3) = IDSIG
+C
+C KOPIOWANIE LISTY ATRYBUTOW RAZEM Z KOPIOWANIEM PROTOTYPOW
+ I = IPMEM(IDSIG+6)
+ J = IDHAND+5
+C I - KOLEJNY ELEMENT LISTY ATRYBUTOW PROTOTYPU IDSIG
+C J - OSTATNIO SKOPIOWANY ELEMENT LISTY PROTOTYPU IDHAND
+ IF(I.EQ.0) RETURN
+ 1100 IPMEM(J+1) = MGETM(2,341)
+ J = IPMEM(J+1)
+ IPMEM(J) = ICPROT(IPMEM(I))
+ I = IPMEM(I+1)
+ IF(I.NE.0) GO TO 1100
+C USTAWIENIE OSTATNIEGO ATRYBUTU PROTOTYPU IDHAND
+ IPMEM(IDHAND+7) = J
+C
+C KOPIOWANIE TABLICY HASH'U
+ LPML = LPML-2
+C LPML - OSTATNI ELEMENT SLOWNIKA ZAMIANY ADRESOW
+ IHSIG = IDSIG+9
+ IHHAND = IDHAND+9
+C
+ DO 1500 I=1,8
+C I - KOLEJNY ELEMENT TABLICY HASH'U PROTOTYPU IDSIG
+ J = IHSIG+I
+ J = IPMEM(J)
+C J - KOLEJNY ELEMENT LISTY HASH'U PROTOTYPU IDSIG
+ IF(J.EQ.0) GO TO 1500
+ K = IHHAND+I-3
+C K - OSTATNIO SKOPIOWANY ELEMENT LISTY HASH'U PROTOTYPU IDHAND
+ 1200 IPMEM(K+3) = MGETM(4,341)
+ K = IPMEM(K+3)
+ IPMEM(K) = IPMEM(J)
+ IPMEM(K+1) = IPMEM(J+1)
+C SZUKANIE ODPOWIEDNIEGO ADRESU
+ II = IPMEM(J+2)
+ DO 1300 IJ = BEGADR, LPML, 2
+ IF(IPMEM(IJ).EQ.II) GO TO 1400
+ 1300 CONTINUE
+ 1400 IPMEM(K+2) = IPMEM(IJ+1)
+ J = IPMEM(J+3)
+ IF(J.NE.0) GO TO 1200
+ 1500 CONTINUE
+C
+C KONIEC KOPIOWANIA - ZWALNIAMY PAMIEC PRZEZNACZONA NA SLOWNIK
+ LPML = BEGADR
+ RETURN
+ END
+ SUBROUTINE SPRPAR ( EL, ELPOR, NM )
+C
+C * * * * * * * * * ** * * * * ** * * * * * * * * * * * * * * * * * * * *
+C POROWNUJE LISTY PARAMETROW SYGNALU O IDENTYFIKATORZE EL I SYGNALU
+C O ODENTYFIKATORZE ELPOR
+C ELPOR - WZORCOWY SYGNAL DO POOWNYWANIA
+C NM - NAZWA SYGNALU EL
+C * * * * * * * * * * * * **** * * * * * ** * * * ** * * * * * * ** ***
+C
+ IMPLICIT INTEGER ( A - Z )
+C
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK, MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
+C
+C
+C
+C LISTE - LISTA PARAMETROW ( SYNTAKTYCZNA! ) SYGNALU EL
+C LPOR - LISTA PARAMETROW SYGNALU ELPOR
+C LISTY SA PRZECHOWANE W SLOWIE +8 PROTOTYPU SYGNALU
+C
+ LISTE = IPMEM(EL+8)
+ LPOR = IPMEM(ELPOR+8)
+ 50 IF ( LISTE + LPOR .EQ.0 ) RETURN
+ IF ( LISTE*LPOR.EQ.0) GO TO 900
+C POROWNYWANIE
+ KIND = IPMEM(LPOR)
+ KD = IPMEM(LISTE)
+ NMP = IPMEM(LISTE+2)
+C NMP - NAZWA PARAMETRU LISTE
+C KONTROLA RODZAJOW
+ IF(KD.EQ.KIND) GO TO 70
+C MOZE SA NIEZGODNE RODZAJE
+ IF ( KIND.GE.7 .OR. KD.GE.7 ) GO TO 100
+C SPRAWDZAMY, CZY RODZAJE SA ZGODNE Z DOKLADNOSCIA DO BLEDNYCH LIST PF
+ IF(IABS(KIND-KD).NE.2) GO TO 100
+C KONTROLA NAZW
+ 70 IF ( NMP.NE.IPMEM(LPOR+2) ) GO TO 200
+ IF (KIND.LE.6) GO TO 300
+ IF (KIND.EQ.7) GO TO 400
+C ZMIENNE - POROWNUJEMY TYPY
+ IF(IPMEM(LISTE+4).NE.IPMEM(LPOR+4)) GO TO 250
+ IF(IPMEM(LISTE+5).NE.IPMEM(LPOR+5)) GO TO 250
+C NIE MA BLEDU - NASTEPNY ELEMENT LISTY
+ 400 LISTE = IPMEM(LISTE+3)
+ LPOR = IPMEM(LPOR+3)
+ GO TO 50
+C
+C NIEZGODNE RODZAJE
+ 100 CALL MERR (355,NMP)
+ GO TO 400
+C ROZNE NAZWY
+ 200 CALL MERR (356,NMP)
+ GO TO 400
+C ROZNE TYPY
+ 250 CALL MERR(354,NMP)
+ GO TO 400
+C
+C PROCEDURY/FUNKCJE
+C SPRAWDZAMY PARAMETRY II-GO RZEDU
+ 300 I = IPMEM(LISTE+4)
+ K = IPMEM(LPOR+4)
+C I - ELEMENTY LISTY II-GO RZEDU PARAMETRU LISTE
+C K - ELEMENTY LISTY II-GO RZEDU PARAMETRU LPOR
+ 350 IF ( I+K.EQ.0) GO TO 800
+ IF ( I*K.EQ.0 ) GO TO 700
+C KONTROLA
+ IF ( IPMEM(I).NE.IPMEM(K) ) GO TO 500
+C NIE KONTROLUJE SIE NAZW
+ IF ( IPMEM(I).LE.7 ) GO TO 600
+C KONTROLA TYPOW
+ IF ( IPMEM(I+4).NE.IPMEM(K+4) ) GO TO 550
+ IF ( IPMEM(I+5).NE.IPMEM(K+5) ) GO TO 550
+C NIE MA BLEDOW
+ 600 I = IPMEM(I+3)
+ K = IPMEM(K+3)
+ GO TO 350
+C NIEZGODNE RODZAJE
+ 500 CALL MERR ( 357,IPMEM(I+2) )
+ GO TO 600
+C ROZNE TYPY
+ 550 CALL MERR ( 358, IPMEM(I+2) )
+ GO TO 600
+C ROZNE DLUGOSCI LIST PARAMETROW II-GO RZEDU
+C JESLI KROTSZA LISTA JEST BLEDNA, TO NIE MA SYGNALIZACJI
+ 700 IF ( I.EQ.0 ) GO TO 750
+C K - KROTSZA
+ KD = IPMEM(LPOR)
+ 710 IF ( KD.EQ.5.OR.KD.EQ.6) GO TO 800
+ CALL MERR(359,NMP)
+ GO TO 800
+ 750 KD = IPMEM(LISTE)
+ GO TO 710
+C
+C KONIE LIST II-GO RZEDU
+C KONTROLA TYPOW - JESLI FUNKCJE
+ 800 IF ( KIND.EQ.3 .OR. KIND.EQ.5 ) GO TO 400
+ IF(IPMEM(LISTE+5).NE.IPMEM(LPOR+5)) GO TO 250
+ IF(IPMEM(LISTE+6).NE.IPMEM(LPOR+6)) GO TO 250
+ GO TO 400
+C
+C NIEZGODNE DLUGOSCI LIST PARAMETROW I-GO RZEDU
+C JESLI LISTA KROTSZA JEST BLEDNA, TO NIE MA SYGNALIZACJI
+ 900 IF ( LISTE.EQ.0 ) GO TO 950
+ IF(IAND(IPMEM(ELPOR),MERPF).EQ.0) CALL MERR(360,NM)
+ RETURN
+ 950 IF(IAND(IPMEM(EL),MERPF).EQ.0) CALL MERR(360,NM)
+ RETURN
+ END
+ INTEGER FUNCTION ICPROT ( IDPR )
+C
+C ** * * * * * * * ** *** ** * * * * * * * * * * ** * * * * * * *
+C KOPIUJE PROTOTYP IDPR ( PROTOTYP PARAMETRU FORMALNEGO).
+C UAKTUALNIA SLOWNIK ZAMIANY ADRESOW PROTOTYPOW.
+C WYNIKIEM FUNKCJI JEST IDENTYFIKATOR UTWORZONEGO PROTOTYPU.
+C * * * * * * * * * ** * * * * * * * * * ** * * * * * * * * * * *
+C
+ IMPLICIT INTEGER ( A - Z )
+C
+C
+C ..... ZMIENNE GLOBALNE
+C
+C.....
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C
+C
+ COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
+C
+C ** ** ** ** *** ** ** ** ** ** ** ** ** ** ** ** **
+C BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
+C INDICT - INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
+C INDSPR - IDENTYFIKATOR PROTOTYPU W ISMEM
+C INDPR - IDENTYFIKATOR PROTOTYPU W IPMEM
+C IHBEG - ADRES PIERWSZEGO SLOWA TABLICY HASHU
+C IDPREF - IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
+C PROTOTYPU
+C LASTPR - IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
+C
+C
+C
+ COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
+ * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
+C
+C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
+C MASKI I WZORCE:
+C MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
+C MOTHERS - -- -- -- -- -- INNYCH PROTOTYPOW
+C MPAR - -- -- -- -- -- -- ZMIENNYCH I PARAMETROW
+C MSPR - MASKA DLA SYSPREF ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
+C MASKTP - ZAPRZECZENIE MASKI MTP
+C NOTTP - WZORZEC DLA NIE-TYPU ( 1 )
+C MPROCES - WZORZEC DLA PROCESU ( 5 )
+C MCOR - WZORZEC DLA COROUTINY (7)
+C MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
+C MBLOCK - WZORZEC DLA BLOKU ( 0 PRZY PRZECIECIU Z MOTHERS )
+C
+C
+C
+ COMMON /COPSIG/ BEGADR, IDHAND
+C
+C BLOK SLUZACY DO KOMUNIKACJI Z PROCEDURA KOPIUJACA POSZCZEGOLNE PROTOTYPY
+C IDHAND - IDENTYFIKATOR HANDLERA
+C BEGADR - PIERWSZY ELEMENT SLOWNIKA ZAMIANY STARYCH ADRESOW NA NOWE
+C KAZDY ELEMENT SLOWNIKA ZAJMUJE 2 SLOWA: STARY ADRES, NOWY ADRES.
+C OSTATNI ELEMENT SLOWNIKA - LPML-2
+C
+C
+C
+ KIND = ISHFT ( IAND(IPMEM(IDPR),MPAR),-4)
+ IF(KIND.GT.3) GO TO 400
+ GO TO (100,200,300), KIND
+C
+C TYP FORMALNY
+ 100 ICPROT = MGETM(5,341) + 2
+C DOLACZENIE DO LISTY NEXTDECL
+ IPMEM(LASTPR+2) = ICPROT
+ LASTPR = ICPROT
+ GO TO 1000
+C
+C FUNKCJA FORMALNA
+ 200 ICPROT = MGETM(10,341) + 5
+ GO TO 500
+C
+C PROCEDURA FORMALNA
+ 300 ICPROT = MGETM(7,341) + 2
+C
+C KOPIOWAIE LISTY PARAMETROW II-GO RZEDU
+ 500 J = IPMEM(IDPR+4)
+ IPMEM(ICPROT+3) = MGETM(J,341)
+ IPMEM(ICPROT+4) = J
+ IF(J.EQ.0) GO TO 1000
+C
+ DO 700 K=1,J
+ II = IPMEM(IDPR+3) +K-1
+ II = IPMEM(II)
+C II - IDENTYFIKATOR STAREGO PARAMETRU
+C I - ROZMIAR PROTOTYPU
+ I = 6
+ IJ=4
+ KD=ISHFT(IAND(IPMEM(II),MPAR),-4)
+ IF(KD.GT.4) GO TO 520
+ IF(KD.EQ.2) GO TO 510
+C PROCEDURA LUB TYP
+ I=5
+ IJ=2
+ GO TO 520
+ 510 I=7
+C IJ - IDENTYFIKATOR NOWEGO PROTOTYPU
+ 520 IJ = MGETM(I,341) + IJ
+ IPMEM(IJ) = IPMEM(II)
+ IPMEM(IJ-1) = ICPROT
+ IPMEM(IJ-2) = IPMEM(II-2)
+ IPMEM(IJ+1) = IPMEM(II+1)
+ IF(KD.LT.5) GO TO 650
+C DLA ZMIENNEJ - WPISANIE TYPU
+ 550 I = IPMEM(II-3)
+ IPMEM(IJ-4) = IPMEM(II-4)
+ IPMEM(IJ-3) = I
+C SPRAWDZENIE, CZY JEST TO FORMALNY TYP LOKALNY
+ I2 = LPML-2
+ IF(I2.LT.BEGADR) GO TO 690
+ DO 600 I1 = BEGADR,I2,2
+ IF(IPMEM(I1).EQ.I) GO TO 610
+ 600 CONTINUE
+C NIE MA TYPU
+ GO TO 690
+ 610 IPMEM(IJ-3) = IPMEM(I1+1)
+ GO TO 690
+C DOLOZENIE ADRESU DO SLOWNIKA ( DLA ZMIENNEJ NIE WARTO )
+ 650 INSYS = .TRUE.
+ I1 = MGETM(2,341)
+ IPMEM(I1) = II
+ IPMEM(I1+1) = IJ
+ INSYS = .FALSE.
+C WSTAWIENIE ADRESU PROTOTYPU DO LISTY PARAMETROW
+ 690 I1 = IPMEM(ICPROT+3) +K-1
+ IPMEM(I1) = IJ
+ 700 CONTINUE
+C
+ IF(KIND.EQ.3) GO TO 1000
+C FUNKCJA - USTAWIENIE IDENTYFIKATORA RESULT
+ IPMEM(ICPROT-5) = IJ
+ GO TO 800
+C
+C ZMIENNE
+ 400 ICPROT = MGETM(6,341) + 4
+C KOPIOWANIE TYPU ZMIENNEJ LUB FUNKCJI
+ 800 IPMEM(ICPROT-4) = IPMEM(IDPR-4)
+ I = IPMEM(IDPR-3)
+ IPMEM(ICPROT-3) = I
+C SPRAWDZAMY, CZY TO JET TYP FORMALNY LOKALNY
+ K = LPML-2
+ IF(K.LT.BEGADR) GO TO 1000
+C JEST NIEPUSTY SLOWNIK ZAMIANY ADRESOW
+ DO 820 J=BEGADR, K,2
+ IF(IPMEM(J).EQ.I) GO TO 850
+ 820 CONTINUE
+C NIE MA TAKIEGO TYPU
+ GO TO 870
+ 850 IPMEM(ICPROT-3) = IPMEM(J+1)
+C JESLI ZMIENNA TO NIE WSTAWIAMY DO NEXTDECL
+ 870 IF(KIND.GE.5) GO TO 1000
+C DLA FUNKCJI - WSTAWIENIE TYPU DO ATRYBUTU RESULT
+ K = IPMEM(ICPROT-5)
+ IPMEM(K-4) = IPMEM(ICPROT-4)
+ IPMEM(K-3) = IPMEM(ICPROT-3)
+C
+C UZUPELNIENIE SLOWA ZEROWEGO, ADRESU ATRUBUTU I USED
+ 1000 IPMEM(ICPROT-2) = IPMEM(IDPR-2)
+ IPMEM(ICPROT-1) = IDHAND
+ IPMEM(ICPROT) = IPMEM(IDPR)
+ IPMEM(ICPROT+1) = IPMEM(IDPR+1)
+C
+C UZUPELNIENIE SLOWNIKA ZAMIANY ADRESOW
+ INSYS = .TRUE.
+ K = MGETM(2,341)
+ IPMEM(K) = IDPR
+ IPMEM(K+1) = ICPROT
+ INSYS = .FALSE.
+C
+ RETURN
+ END
+
--- /dev/null
+/* f2c.h -- Standard Fortran to C header file */
+
+/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
+
+ - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long flag;
+typedef long ftnlen;
+typedef long ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ shortint h;
+ integer i;
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+typedef long Long;
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ Long *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f; /* complex function */
+typedef VOID H_f; /* character function */
+typedef VOID Z_f; /* double complex function */
+typedef doublereal E_f; /* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE DATA2
+ IMPLICIT INTEGER (A-Z)
+C
+C INITIATES VARIABLES IN THE BLANK COMMON
+C
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, JK1, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT,JK2,NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEXT, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+
+C RESZTA = REMAINDER
+ REAL FRACT,NU
+
+ DO 10 I=1,8000
+ HASH(I)=0
+10 CONTINUE
+cdsw &bc
+c
+c hash table contains following unused tokens:
+c
+c ACCEPT 2053
+c ENABLE 2047
+c DISABLE 2041
+c QUIT 2033
+c
+cdsw db01op 7725
+
+ HASH ( 59 ) = 1038
+ HASH ( 60 ) = -2343
+ HASH ( 79 ) = 1048
+ HASH ( 81 ) = 2058
+ HASH ( 82 ) = -2691
+ HASH ( 85 ) = 1051
+ HASH ( 86 ) = -2271
+ HASH ( 95 ) = 2065
+ HASH ( 96 ) = -2689
+ HASH ( 97 ) = 2066
+ HASH ( 98 ) = -2639
+ HASH ( 115 ) = 2075
+ HASH ( 116 ) = -2681
+ HASH ( 179 ) = 1098
+ HASH ( 180 ) = -2669
+ HASH ( 189 ) = 1103
+ HASH ( 190 ) = -2285
+ HASH ( 195 ) = 1106
+ HASH ( 196 ) = -2865
+ HASH ( 209 ) = 1113
+ HASH ( 210 ) = -2289
+ HASH ( 237 ) = 2136
+ HASH ( 238 ) = -2485
+ HASH ( 307 ) = 1162
+ HASH ( 308 ) = -2607
+ HASH ( 317 ) = 1167
+ HASH ( 323 ) = 1170
+ HASH ( 324 ) = -7999
+ HASH ( 331 ) = 1174
+ HASH ( 332 ) = -2523
+ HASH ( 333 ) = 1175
+ HASH ( 334 ) = 2861
+ HASH ( 335 ) = 1176
+ HASH ( 336 ) = -2609
+ HASH ( 343 ) = 1180
+ HASH ( 344 ) = 2605
+ HASH ( 579 ) = 1298
+ HASH ( 580 ) = -2835
+ HASH ( 691 ) = 1354
+ HASH ( 692 ) = -2637
+ HASH ( 717 ) = 1367
+ HASH ( 719 ) = 1368
+ HASH ( 720 ) = -2833
+ HASH ( 819 ) = 1418
+ HASH ( 820 ) = -2831
+ HASH ( 827 ) = 1422
+ HASH ( 828 ) = -2327
+ HASH ( 835 ) = 1426
+ HASH ( 836 ) = -2395
+ HASH ( 847 ) = 1432
+ HASH ( 848 ) = -2829
+ HASH ( 955 ) = 1486
+ HASH ( 956 ) = -2827
+ HASH ( 975 ) = 1496
+ HASH ( 976 ) = -2825
+ HASH ( 987 ) = 1502
+ HASH ( 988 ) = -1989
+ HASH ( 1081 ) = 1549
+ HASH ( 1105 ) = 1561
+ HASH ( 1106 ) = -2363
+ HASH ( 1109 ) = 1563
+ HASH ( 1110 ) = 2819
+ HASH ( 1113 ) = 1565
+ HASH ( 1114 ) = -2815
+ HASH ( 1115 ) = 1566
+ HASH ( 1116 ) = -2807
+ HASH ( 1203 ) = 1610
+ HASH ( 1204 ) = -2493
+ HASH ( 1231 ) = 1624
+ HASH ( 1232 ) = -2241
+ HASH ( 1237 ) = 1627
+ HASH ( 1238 ) = -2797
+ HASH ( 1243 ) = 1630
+ HASH ( 1244 ) = -2341
+ HASH ( 1303 ) = 651
+ HASH ( 1304 ) = -2615
+ HASH ( 1305 ) = 652
+ HASH ( 1306 ) = -2305
+ HASH ( 1325 ) = 662
+ HASH ( 1326 ) = -2381
+ HASH ( 1327 ) = 663
+ HASH ( 1328 ) = -2999
+ HASH ( 1335 ) = 667
+ HASH ( 1336 ) = -2997
+ HASH ( 1337 ) = 668
+ HASH ( 1338 ) = -7839
+ HASH ( 1339 ) = 669
+ HASH ( 1340 ) = -2985
+ HASH ( 1371 ) = 1694
+ HASH ( 1372 ) = -2777
+ HASH ( 1437 ) = 718
+ HASH ( 1438 ) = -2973
+ HASH ( 1451 ) = 725
+ HASH ( 1452 ) = -2969
+ HASH ( 1457 ) = 728
+ HASH ( 1458 ) = -2965
+ HASH ( 1459 ) = 1738
+ HASH ( 1460 ) = -2659
+ HASH ( 1463 ) = 731
+ HASH ( 1464 ) = -2267
+ HASH ( 1467 ) = 1742
+ HASH ( 1468 ) = -2775
+ HASH ( 1487 ) = 1752
+ HASH ( 1488 ) = -2583
+ HASH ( 1557 ) = 778
+ HASH ( 1558 ) = -2955
+ HASH ( 1571 ) = 785
+ HASH ( 1572 ) = -2949
+ HASH ( 1573 ) = 786
+ HASH ( 1574 ) = -2103
+ HASH ( 1579 ) = 789
+ HASH ( 1580 ) = -2941
+ HASH ( 1585 ) = 792
+ HASH ( 1586 ) = -2927
+ HASH ( 1591 ) = 1804
+ HASH ( 1592 ) = -2189
+ HASH ( 1595 ) = 1806
+ HASH ( 1596 ) = -2751
+ HASH ( 1601 ) = 1809
+ HASH ( 1602 ) = -7981
+ HASH ( 1603 ) = 1810
+ HASH ( 1604 ) = -2663
+ HASH ( 1609 ) = 1813
+ HASH ( 1610 ) = -2463
+ HASH ( 1619 ) = 1818
+ HASH ( 1620 ) = -2591
+ HASH ( 1625 ) = 1821
+ HASH ( 1626 ) = -2743
+ HASH ( 1635 ) = 1826
+ HASH ( 1636 ) = -2003
+ HASH ( 1685 ) = 842
+ HASH ( 1686 ) = -2349
+ HASH ( 1687 ) = 843
+ HASH ( 1688 ) = -7835
+ HASH ( 1693 ) = 846
+ HASH ( 1694 ) = -2909
+ HASH ( 1701 ) = 850
+ HASH ( 1702 ) = -2905
+ HASH ( 1713 ) = 856
+ HASH ( 1714 ) = 2899
+ HASH ( 1715 ) = 1866
+ HASH ( 1716 ) = -2731
+ HASH ( 1719 ) = 859
+ HASH ( 1720 ) = -2283
+ HASH ( 1723 ) = 1870
+ HASH ( 1724 ) = -2647
+ HASH ( 1729 ) = 1873
+ HASH ( 1730 ) = -2727
+ HASH ( 1731 ) = 1874
+ HASH ( 1732 ) = -2593
+ HASH ( 1743 ) = 1880
+ HASH ( 1749 ) = 1883
+ HASH ( 1750 ) = -2721
+ HASH ( 1751 ) = 1884
+ HASH ( 1752 ) = 2425
+ HASH ( 1763 ) = 1890
+ HASH ( 1764 ) = -2719
+ HASH ( 1829 ) = 1367
+ HASH ( 1830 ) = 2253
+ HASH ( 1831 ) = 653
+ HASH ( 1832 ) = -1829
+ HASH ( 1833 ) = 1742
+ HASH ( 1834 ) = -1831
+ HASH ( 1835 ) = 917
+ HASH ( 1836 ) = -2893
+ HASH ( 1837 ) = 918
+ HASH ( 1838 ) = -2399
+ HASH ( 1839 ) = 919
+ HASH ( 1840 ) = -2891
+ HASH ( 1841 ) = 920
+ HASH ( 1842 ) = -2617
+ HASH ( 1849 ) = 924
+ HASH ( 1850 ) = -2889
+ HASH ( 1859 ) = 929
+ HASH ( 1860 ) = -2887
+ HASH ( 1869 ) = 1943
+ HASH ( 1870 ) = -2717
+ HASH ( 1873 ) = 1945
+ HASH ( 1874 ) = -2709
+ HASH ( 1941 ) = 970
+ HASH ( 1942 ) = -2877
+ HASH ( 1957 ) = 978
+ HASH ( 1958 ) = 2339
+ HASH ( 1969 ) = 984
+ HASH ( 1970 ) = -2873
+ HASH ( 1971 ) = 1994
+ HASH ( 1972 ) = -2699
+ HASH ( 1981 ) = 990
+ HASH ( 1982 ) = -2871
+ HASH ( 1987 ) = 2002
+ HASH ( 1988 ) = -2697
+ HASH ( 1989 ) = 1422
+ HASH ( 1990 ) = -1991
+ HASH ( 1991 ) = 1755
+ HASH ( 1992 ) = -1993
+ HASH ( 1993 ) = 1563
+ HASH ( 1995 ) = 1890
+ HASH ( 1996 ) = -1997
+ HASH ( 1997 ) = 1614
+ HASH ( 1998 ) = -1999
+ HASH ( 1999 ) = 1755
+ HASH ( 2000 ) = -2001
+ HASH ( 2001 ) = 1563
+ HASH ( 2003 ) = 1806
+ HASH ( 2004 ) = -2005
+ HASH ( 2005 ) = 1755
+ HASH ( 2006 ) = -2007
+ HASH ( 2007 ) = 1563
+ HASH ( 2017 ) = 1559
+ HASH ( 2019 ) = 1874
+ HASH ( 2020 ) = -2017
+ HASH ( 2021 ) = 1810
+ HASH ( 2022 ) = -2019
+ HASH ( 2023 ) = 1624
+ HASH ( 2024 ) = -2021
+ HASH ( 2025 ) = 1741
+ HASH ( 2027 ) = 778
+ HASH ( 2028 ) = -2025
+ HASH ( 2029 ) = 1496
+ HASH ( 2030 ) = -2027
+ HASH ( 2031 ) = 1181
+ HASH ( 2033 ) = 1694
+ HASH ( 2034 ) = -2031
+ HASH ( 2035 ) = 14
+ HASH ( 2037 ) = 725
+ HASH ( 2038 ) = -2035
+ HASH ( 2039 ) = 1802
+ HASH ( 2040 ) = -2037
+ HASH ( 2041 ) = 850
+ HASH ( 2042 ) = -2039
+ HASH ( 2043 ) = 1358
+ HASH ( 2045 ) = 651
+ HASH ( 2046 ) = -2043
+ HASH ( 2047 ) = 919
+ HASH ( 2048 ) = -2045
+ HASH ( 2049 ) = 1629
+ HASH ( 2051 ) = 782
+ HASH ( 2052 ) = -2049
+ HASH ( 2053 ) = 652
+ HASH ( 2054 ) = -2051
+ HASH ( 2055 ) = 2254
+ HASH ( 2056 ) = 7827
+ HASH ( 2057 ) = 1810
+ HASH ( 2058 ) = -2055
+ HASH ( 2059 ) = 661
+ HASH ( 2060 ) = -2057
+ HASH ( 2061 ) = 1742
+ HASH ( 2062 ) = -2059
+ HASH ( 2063 ) = 14
+ HASH ( 2064 ) = 7985
+ HASH ( 2065 ) = 1187
+ HASH ( 2066 ) = -2063
+ HASH ( 2067 ) = 1884
+ HASH ( 2068 ) = -2065
+ HASH ( 2069 ) = 1175
+ HASH ( 2070 ) = -2067
+ HASH ( 2071 ) = 908
+ HASH ( 2073 ) = 1883
+ HASH ( 2074 ) = -2071
+ HASH ( 2075 ) = 1630
+ HASH ( 2076 ) = -2073
+ HASH ( 2077 ) = 908
+ HASH ( 2078 ) = 7945
+ HASH ( 2079 ) = 1883
+ HASH ( 2080 ) = -2077
+ HASH ( 2081 ) = 1038
+ HASH ( 2082 ) = -2079
+ HASH ( 2083 ) = 1492
+ HASH ( 2085 ) = 1362
+ HASH ( 2086 ) = -2083
+ HASH ( 2087 ) = 1943
+ HASH ( 2088 ) = -2085
+ HASH ( 2089 ) = 916
+ HASH ( 2090 ) = 7957
+ HASH ( 2091 ) = 1806
+ HASH ( 2092 ) = -2089
+ HASH ( 2093 ) = 797
+ HASH ( 2094 ) = 2041
+ HASH ( 2095 ) = 1742
+ HASH ( 2096 ) = -2093
+ HASH ( 2097 ) = 850
+ HASH ( 2098 ) = -2095
+ HASH ( 2099 ) = 908
+ HASH ( 2101 ) = 929
+ HASH ( 2102 ) = -2099
+ HASH ( 2103 ) = 1739
+ HASH ( 2105 ) = 16
+ HASH ( 2107 ) = 1175
+ HASH ( 2108 ) = -2105
+ HASH ( 2109 ) = 1883
+ HASH ( 2110 ) = -2107
+ HASH ( 2111 ) = 1884
+ HASH ( 2112 ) = -2109
+ HASH ( 2113 ) = 1566
+ HASH ( 2114 ) = -2111
+ HASH ( 2115 ) = 1864
+ HASH ( 2117 ) = 1559
+ HASH ( 2118 ) = -2115
+ HASH ( 2119 ) = 1103
+ HASH ( 2120 ) = -2117
+ HASH ( 2121 ) = 29
+ HASH ( 2122 ) = 2119
+ HASH ( 2123 ) = 1559
+ HASH ( 2124 ) = -2121
+ HASH ( 2125 ) = 1103
+ HASH ( 2126 ) = -2123
+ HASH ( 2127 ) = 20
+ HASH ( 2129 ) = 652
+ HASH ( 2130 ) = -2127
+ HASH ( 2131 ) = 1883
+ HASH ( 2132 ) = -2129
+ HASH ( 2133 ) = 665
+ HASH ( 2135 ) = 1750
+ HASH ( 2136 ) = -2133
+ HASH ( 2137 ) = 2136
+ HASH ( 2138 ) = -2135
+ HASH ( 2139 ) = 25
+ HASH ( 2141 ) = 1418
+ HASH ( 2142 ) = -2139
+ HASH ( 2143 ) = 1563
+ HASH ( 2144 ) = -2141
+ HASH ( 2145 ) = 665
+ HASH ( 2146 ) = 2075
+ HASH ( 2147 ) = 1878
+ HASH ( 2148 ) = -2145
+ HASH ( 2149 ) = 1630
+ HASH ( 2150 ) = -2147
+ HASH ( 2151 ) = 665
+ HASH ( 2152 ) = 2081
+ HASH ( 2153 ) = 1878
+ HASH ( 2154 ) = -2151
+ HASH ( 2155 ) = 1038
+ HASH ( 2156 ) = -2153
+ HASH ( 2157 ) = 33
+ HASH ( 2158 ) = 2069
+ HASH ( 2159 ) = 1618
+ HASH ( 2160 ) = -2157
+ HASH ( 2161 ) = 1175
+ HASH ( 2162 ) = -2159
+ HASH ( 2163 ) = 1564
+ HASH ( 2164 ) = 2161
+ HASH ( 2165 ) = 2201
+ HASH ( 2166 ) = -2163
+ HASH ( 2167 ) = 1175
+ HASH ( 2168 ) = -2165
+ HASH ( 2169 ) = 1564
+ HASH ( 2170 ) = 2167
+ HASH ( 2171 ) = 2137
+ HASH ( 2172 ) = -2169
+ HASH ( 2173 ) = 1175
+ HASH ( 2174 ) = -2171
+ HASH ( 2175 ) = 34
+ HASH ( 2176 ) = 2023
+ HASH ( 2177 ) = 1633
+ HASH ( 2178 ) = -2175
+ HASH ( 2179 ) = 1624
+ HASH ( 2180 ) = -2177
+ HASH ( 2181 ) = 2146
+ HASH ( 2182 ) = 2149
+ HASH ( 2183 ) = 1809
+ HASH ( 2184 ) = -2181
+ HASH ( 2185 ) = 1630
+ HASH ( 2186 ) = -2183
+ HASH ( 2187 ) = 919
+ HASH ( 2188 ) = 7785
+ HASH ( 2189 ) = 1742
+ HASH ( 2190 ) = -2187
+ HASH ( 2191 ) = 24
+ HASH ( 2193 ) = 846
+ HASH ( 2194 ) = -2191
+ HASH ( 2195 ) = 2002
+ HASH ( 2196 ) = -2193
+ HASH ( 2197 ) = 923
+ HASH ( 2199 ) = 1741
+ HASH ( 2200 ) = -2197
+ HASH ( 2201 ) = 728
+ HASH ( 2202 ) = -2199
+ HASH ( 2203 ) = 925
+ HASH ( 2205 ) = 1365
+ HASH ( 2206 ) = -2203
+ HASH ( 2207 ) = 1610
+ HASH ( 2208 ) = -2205
+ HASH ( 2209 ) = 1500
+ HASH ( 2210 ) = 2173
+ HASH ( 2211 ) = 1870
+ HASH ( 2212 ) = -2209
+ HASH ( 2213 ) = 1175
+ HASH ( 2214 ) = -2211
+ HASH ( 2215 ) = 1751
+ HASH ( 2216 ) = 2207
+ HASH ( 2217 ) = 1870
+ HASH ( 2218 ) = -2215
+ HASH ( 2219 ) = 1610
+ HASH ( 2220 ) = -2217
+ HASH ( 2221 ) = 14
+ HASH ( 2222 ) = 7963
+ HASH ( 2223 ) = 2197
+ HASH ( 2224 ) = -2221
+ HASH ( 2225 ) = 1821
+ HASH ( 2226 ) = -2223
+ HASH ( 2227 ) = 27
+ HASH ( 2229 ) = 1368
+ HASH ( 2230 ) = -2227
+ HASH ( 2231 ) = 792
+ HASH ( 2232 ) = -2229
+ HASH ( 2233 ) = 21
+ HASH ( 2235 ) = 1173
+ HASH ( 2236 ) = -2233
+ HASH ( 2237 ) = 1999
+ HASH ( 2238 ) = -2235
+ HASH ( 2239 ) = 29
+ HASH ( 2240 ) = 2179
+ HASH ( 2241 ) = 1175
+ HASH ( 2242 ) = -2239
+ HASH ( 2243 ) = 788
+ HASH ( 2244 ) = 2087
+ HASH ( 2245 ) = 1610
+ HASH ( 2246 ) = -2243
+ HASH ( 2247 ) = 1943
+ HASH ( 2248 ) = -2245
+ HASH ( 2249 ) = 1870
+ HASH ( 2250 ) = -2251
+ HASH ( 2251 ) = 2141
+ HASH ( 2253 ) = 1742
+ HASH ( 2254 ) = -2255
+ HASH ( 2255 ) = 1806
+ HASH ( 2256 ) = -2257
+ HASH ( 2257 ) = 29
+ HASH ( 2258 ) = 2259
+ HASH ( 2259 ) = 1742
+ HASH ( 2260 ) = -2261
+ HASH ( 2261 ) = 2075
+ HASH ( 2262 ) = -2263
+ HASH ( 2263 ) = 1181
+ HASH ( 2264 ) = -2265
+ HASH ( 2265 ) = 14
+ HASH ( 2266 ) = 2061
+ HASH ( 2267 ) = 906
+ HASH ( 2268 ) = -2269
+ HASH ( 2269 ) = 20
+ HASH ( 2270 ) = 7797
+ HASH ( 2271 ) = 1559
+ HASH ( 2272 ) = 2273
+ HASH ( 2273 ) = 1051
+ HASH ( 2274 ) = -2275
+ HASH ( 2275 ) = 1551
+ HASH ( 2276 ) = -2277
+ HASH ( 2277 ) = 15
+ HASH ( 2279 ) = 1432
+ HASH ( 2280 ) = -2281
+ HASH ( 2281 ) = 1998
+ HASH ( 2282 ) = 7991
+ HASH ( 2283 ) = 672
+ HASH ( 2285 ) = 1173
+ HASH ( 2286 ) = -2287
+ HASH ( 2287 ) = 21
+ HASH ( 2288 ) = 2125
+ HASH ( 2289 ) = 656
+ HASH ( 2290 ) = -2291
+ HASH ( 2291 ) = 14
+ HASH ( 2293 ) = 1098
+ HASH ( 2294 ) = -2295
+ HASH ( 2295 ) = 1804
+ HASH ( 2296 ) = -2297
+ HASH ( 2297 ) = 1170
+ HASH ( 2299 ) = 1175
+ HASH ( 2300 ) = -2301
+ HASH ( 2301 ) = 1294
+ HASH ( 2302 ) = -2303
+ HASH ( 2303 ) = 34
+ HASH ( 2304 ) = 2213
+ HASH ( 2305 ) = 782
+ HASH ( 2306 ) = -2307
+ HASH ( 2307 ) = 1755
+ HASH ( 2308 ) = -2309
+ HASH ( 2309 ) = 1563
+ HASH ( 2310 ) = 2053
+ HASH ( 2311 ) = 792
+ HASH ( 2312 ) = -2313
+ HASH ( 2313 ) = 1486
+ HASH ( 2314 ) = -2315
+ HASH ( 2315 ) = 1755
+ HASH ( 2316 ) = -2317
+ HASH ( 2317 ) = 1563
+ HASH ( 2318 ) = 2231
+ HASH ( 2319 ) = 1368
+ HASH ( 2320 ) = -2321
+ HASH ( 2321 ) = 1038
+ HASH ( 2322 ) = -2323
+ HASH ( 2323 ) = 1755
+ HASH ( 2324 ) = -2325
+ HASH ( 2325 ) = 1563
+ HASH ( 2327 ) = 1422
+ HASH ( 2328 ) = -2329
+ HASH ( 2329 ) = 1755
+ HASH ( 2330 ) = -2331
+ HASH ( 2331 ) = 1563
+ HASH ( 2332 ) = 7847
+ HASH ( 2333 ) = 28
+ HASH ( 2335 ) = 789
+ HASH ( 2336 ) = -2333
+ HASH ( 2337 ) = 1358
+ HASH ( 2339 ) = 978
+ HASH ( 2340 ) = -2337
+ HASH ( 2341 ) = 29
+ HASH ( 2342 ) = 2185
+ HASH ( 2343 ) = 29
+ HASH ( 2344 ) = 2155
+ HASH ( 2345 ) = 919
+ HASH ( 2347 ) = 1561
+ HASH ( 2348 ) = -2345
+ HASH ( 2349 ) = 1870
+ HASH ( 2351 ) = 27
+ HASH ( 2352 ) = 2101
+ HASH ( 2353 ) = 1610
+ HASH ( 2354 ) = -2351
+ HASH ( 2355 ) = 908
+ HASH ( 2356 ) = -2353
+ HASH ( 2357 ) = 929
+ HASH ( 2358 ) = -2355
+ HASH ( 2359 ) = 28
+ HASH ( 2360 ) = 2347
+ HASH ( 2361 ) = 1559
+ HASH ( 2362 ) = -2359
+ HASH ( 2363 ) = 1874
+ HASH ( 2364 ) = -2361
+ HASH ( 2365 ) = 20
+ HASH ( 2366 ) = 2335
+ HASH ( 2367 ) = 1548
+ HASH ( 2368 ) = -2365
+ HASH ( 2369 ) = 789
+ HASH ( 2370 ) = -2367
+ HASH ( 2371 ) = 925
+ HASH ( 2373 ) = 1500
+ HASH ( 2374 ) = -2371
+ HASH ( 2375 ) = 1738
+ HASH ( 2376 ) = -2373
+ HASH ( 2377 ) = 27
+ HASH ( 2379 ) = 718
+ HASH ( 2380 ) = -2377
+ HASH ( 2381 ) = 918
+ HASH ( 2382 ) = -2379
+ HASH ( 2383 ) = 1756
+ HASH ( 2385 ) = 1102
+ HASH ( 2386 ) = -2383
+ HASH ( 2387 ) = 1565
+ HASH ( 2388 ) = -2385
+ HASH ( 2389 ) = 1870
+ HASH ( 2390 ) = 7917
+ HASH ( 2391 ) = 1358
+ HASH ( 2392 ) = -2389
+ HASH ( 2393 ) = 846
+ HASH ( 2394 ) = -2391
+ HASH ( 2395 ) = 23
+ HASH ( 2397 ) = 34
+ HASH ( 2399 ) = 1629
+ HASH ( 2400 ) = -2397
+ HASH ( 2401 ) = 1757
+ HASH ( 2402 ) = 2299
+ HASH ( 2403 ) = 1806
+ HASH ( 2404 ) = -2401
+ HASH ( 2405 ) = 1175
+ HASH ( 2406 ) = -2403
+ HASH ( 2407 ) = 25
+ HASH ( 2408 ) = 2247
+ HASH ( 2409 ) = 788
+ HASH ( 2410 ) = -2407
+ HASH ( 2411 ) = 1368
+ HASH ( 2412 ) = -2409
+ HASH ( 2413 ) = 1943
+ HASH ( 2414 ) = -2411
+ HASH ( 2415 ) = 25
+ HASH ( 2416 ) = 2319
+ HASH ( 2417 ) = 788
+ HASH ( 2418 ) = -2415
+ HASH ( 2419 ) = 1368
+ HASH ( 2420 ) = -2417
+ HASH ( 2421 ) = 1945
+ HASH ( 2423 ) = 25
+ HASH ( 2425 ) = 1884
+ HASH ( 2426 ) = -2423
+ HASH ( 2427 ) = 23
+ HASH ( 2429 ) = 1181
+ HASH ( 2430 ) = -2427
+ HASH ( 2431 ) = 2058
+ HASH ( 2432 ) = -2429
+ HASH ( 2433 ) = 667
+ HASH ( 2434 ) = 2225
+ HASH ( 2435 ) = 1561
+ HASH ( 2436 ) = -2433
+ HASH ( 2437 ) = 1821
+ HASH ( 2438 ) = -2435
+ HASH ( 2439 ) = 25
+ HASH ( 2440 ) = 2431
+ HASH ( 2441 ) = 1181
+ HASH ( 2442 ) = -2439
+ HASH ( 2443 ) = 2058
+ HASH ( 2444 ) = -2441
+ HASH ( 2445 ) = 25
+ HASH ( 2446 ) = 2437
+ HASH ( 2447 ) = 1561
+ HASH ( 2448 ) = -2445
+ HASH ( 2449 ) = 1821
+ HASH ( 2450 ) = -2447
+ HASH ( 2451 ) = 25
+ HASH ( 2452 ) = 1833
+ HASH ( 2453 ) = 1422
+ HASH ( 2454 ) = -2451
+ HASH ( 2455 ) = 1822
+ HASH ( 2456 ) = -2453
+ HASH ( 2457 ) = 1742
+ HASH ( 2458 ) = -2455
+ HASH ( 2459 ) = 20
+ HASH ( 2461 ) = 1490
+ HASH ( 2462 ) = -2459
+ HASH ( 2463 ) = 1568
+ HASH ( 2464 ) = -2461
+ HASH ( 2465 ) = 924
+ HASH ( 2467 ) = 1548
+ HASH ( 2468 ) = -2465
+ HASH ( 2469 ) = 1627
+ HASH ( 2470 ) = -2467
+ HASH ( 2471 ) = 27
+ HASH ( 2472 ) = 2091
+ HASH ( 2473 ) = 984
+ HASH ( 2474 ) = -2471
+ HASH ( 2475 ) = 1418
+ HASH ( 2476 ) = -2473
+ HASH ( 2477 ) = 1806
+ HASH ( 2478 ) = -2475
+ HASH ( 2479 ) = 1943
+ HASH ( 2480 ) = 2047
+ HASH ( 2481 ) = 859
+ HASH ( 2482 ) = -2479
+ HASH ( 2483 ) = 919
+ HASH ( 2484 ) = -2481
+ HASH ( 2485 ) = 27
+ HASH ( 2486 ) = 2137
+ HASH ( 2487 ) = 28
+ HASH ( 2488 ) = 2219
+ HASH ( 2489 ) = 930
+ HASH ( 2490 ) = -2487
+ HASH ( 2491 ) = 1364
+ HASH ( 2492 ) = -2489
+ HASH ( 2493 ) = 1486
+ HASH ( 2494 ) = -2491
+ HASH ( 2495 ) = 1167
+ HASH ( 2497 ) = 878
+ HASH ( 2498 ) = -2495
+ HASH ( 2499 ) = 663
+ HASH ( 2500 ) = -2497
+ HASH ( 2501 ) = 15
+ HASH ( 2502 ) = 2499
+ HASH ( 2503 ) = 850
+ HASH ( 2504 ) = -2501
+ HASH ( 2505 ) = 663
+ HASH ( 2506 ) = -2503
+ HASH ( 2507 ) = 3
+ HASH ( 2509 ) = 673
+ HASH ( 2510 ) = -2507
+ HASH ( 2511 ) = 1174
+ HASH ( 2512 ) = -2509
+ HASH ( 2513 ) = 673
+ HASH ( 2514 ) = 2511
+ HASH ( 2515 ) = 1174
+ HASH ( 2516 ) = -2513
+ HASH ( 2517 ) = 3
+ HASH ( 2518 ) = 2515
+ HASH ( 2519 ) = 1175
+ HASH ( 2520 ) = -2517
+ HASH ( 2521 ) = 1174
+ HASH ( 2522 ) = -2519
+ HASH ( 2523 ) = 1175
+ HASH ( 2524 ) = 2521
+ HASH ( 2525 ) = 669
+ HASH ( 2526 ) = 2457
+ HASH ( 2527 ) = 1614
+ HASH ( 2528 ) = -2525
+ HASH ( 2529 ) = 1742
+ HASH ( 2530 ) = -2527
+ HASH ( 2531 ) = 1485
+ HASH ( 2532 ) = 2529
+ HASH ( 2533 ) = 2066
+ HASH ( 2534 ) = -2531
+ HASH ( 2535 ) = 1742
+ HASH ( 2536 ) = -2533
+ HASH ( 2537 ) = 14
+ HASH ( 2538 ) = 2483
+ HASH ( 2539 ) = 1173
+ HASH ( 2540 ) = -2537
+ HASH ( 2541 ) = 847
+ HASH ( 2542 ) = -2539
+ HASH ( 2543 ) = 919
+ HASH ( 2544 ) = -2541
+ HASH ( 2545 ) = 663
+ HASH ( 2547 ) = 669
+ HASH ( 2548 ) = -2545
+ HASH ( 2549 ) = 25
+ HASH ( 2550 ) = 2357
+ HASH ( 2551 ) = 929
+ HASH ( 2552 ) = -2549
+ HASH ( 2553 ) = 23
+ HASH ( 2555 ) = 1866
+ HASH ( 2556 ) = -2553
+ HASH ( 2557 ) = 28
+ HASH ( 2558 ) = 2311
+ HASH ( 2559 ) = 792
+ HASH ( 2560 ) = -2557
+ HASH ( 2561 ) = 23
+ HASH ( 2563 ) = 1810
+ HASH ( 2564 ) = -2561
+ HASH ( 2565 ) = 1047
+ HASH ( 2566 ) = 2563
+ HASH ( 2567 ) = 1810
+ HASH ( 2568 ) = -2565
+ HASH ( 2569 ) = 13
+ HASH ( 2570 ) = 2143
+ HASH ( 2571 ) = 1563
+ HASH ( 2572 ) = -2569
+ HASH ( 2573 ) = 27
+ HASH ( 2575 ) = 785
+ HASH ( 2576 ) = -2573
+ HASH ( 2577 ) = 1367
+ HASH ( 2579 ) = 920
+ HASH ( 2580 ) = -2577
+ HASH ( 2581 ) = 13
+ HASH ( 2583 ) = 1943
+ HASH ( 2584 ) = -2581
+ HASH ( 2585 ) = 923
+ HASH ( 2586 ) = 2543
+ HASH ( 2587 ) = 1874
+ HASH ( 2588 ) = -2585
+ HASH ( 2589 ) = 919
+ HASH ( 2590 ) = -2587
+ HASH ( 2591 ) = 1757
+ HASH ( 2593 ) = 1422
+ HASH ( 2595 ) = 1558
+ HASH ( 2596 ) = 2375
+ HASH ( 2597 ) = 1485
+ HASH ( 2598 ) = -2595
+ HASH ( 2599 ) = 1738
+ HASH ( 2600 ) = -2597
+ HASH ( 2601 ) = 29
+ HASH ( 2603 ) = 1103
+ HASH ( 2604 ) = -2601
+ HASH ( 2605 ) = 1180
+ HASH ( 2606 ) = -2603
+ HASH ( 2607 ) = 1485
+ HASH ( 2609 ) = 27
+ HASH ( 2611 ) = 1565
+ HASH ( 2612 ) = 2405
+ HASH ( 2613 ) = 1175
+ HASH ( 2614 ) = -2611
+ HASH ( 2615 ) = 28
+ HASH ( 2617 ) = 15
+ HASH ( 2618 ) = 2579
+ HASH ( 2619 ) = 665
+ HASH ( 2620 ) = 2131
+ HASH ( 2621 ) = 1883
+ HASH ( 2622 ) = -2619
+ HASH ( 2623 ) = 1365
+ HASH ( 2625 ) = 2066
+ HASH ( 2626 ) = -2623
+ HASH ( 2627 ) = 1821
+ HASH ( 2628 ) = -2625
+ HASH ( 2629 ) = 1354
+ HASH ( 2630 ) = -2627
+ HASH ( 2631 ) = 21
+ HASH ( 2632 ) = 2629
+ HASH ( 2633 ) = 1173
+ HASH ( 2634 ) = -2631
+ HASH ( 2635 ) = 2976
+ HASH ( 2636 ) = -2633
+ HASH ( 2637 ) = 1821
+ HASH ( 2638 ) = -2635
+ HASH ( 2639 ) = 1485
+ HASH ( 2640 ) = 7831
+ HASH ( 2641 ) = 14
+ HASH ( 2642 ) = 2249
+ HASH ( 2643 ) = 669
+ HASH ( 2644 ) = -2641
+ HASH ( 2645 ) = 1175
+ HASH ( 2646 ) = -2643
+ HASH ( 2647 ) = 1750
+ HASH ( 2648 ) = -2645
+ HASH ( 2649 ) = 1934
+ HASH ( 2650 ) = 2559
+ HASH ( 2651 ) = 1175
+ HASH ( 2652 ) = -2649
+ HASH ( 2653 ) = 1501
+ HASH ( 2654 ) = -2651
+ HASH ( 2655 ) = 792
+ HASH ( 2656 ) = -2653
+ HASH ( 2657 ) = 14
+ HASH ( 2658 ) = 2599
+ HASH ( 2659 ) = 1180
+ HASH ( 2660 ) = -2657
+ HASH ( 2661 ) = 661
+ HASH ( 2662 ) = 2567
+ HASH ( 2663 ) = 1047
+ HASH ( 2664 ) = -2661
+ HASH ( 2665 ) = 1756
+ HASH ( 2666 ) = 2293
+ HASH ( 2667 ) = 1358
+ HASH ( 2668 ) = -2665
+ HASH ( 2669 ) = 1485
+ HASH ( 2670 ) = -2667
+ HASH ( 2671 ) = 23
+ HASH ( 2673 ) = 917
+ HASH ( 2674 ) = -2671
+ HASH ( 2675 ) = 1181
+ HASH ( 2676 ) = -2673
+ HASH ( 2677 ) = 2075
+ HASH ( 2678 ) = -2675
+ HASH ( 2679 ) = 14
+ HASH ( 2680 ) = 2677
+ HASH ( 2681 ) = 1181
+ HASH ( 2682 ) = -2679
+ HASH ( 2683 ) = 14
+ HASH ( 2685 ) = 1173
+ HASH ( 2686 ) = -2683
+ HASH ( 2687 ) = 2065
+ HASH ( 2688 ) = -2685
+ HASH ( 2689 ) = 919
+ HASH ( 2690 ) = 2687
+ HASH ( 2691 ) = 1181
+ HASH ( 2692 ) = 2443
+ HASH ( 2693 ) = 21
+ HASH ( 2694 ) = 2195
+ HASH ( 2695 ) = 1930
+ HASH ( 2696 ) = -2693
+ HASH ( 2697 ) = 1757
+ HASH ( 2698 ) = -2695
+ HASH ( 2699 ) = 27
+ HASH ( 2701 ) = 27
+ HASH ( 2702 ) = 2419
+ HASH ( 2703 ) = 2062
+ HASH ( 2704 ) = -2701
+ HASH ( 2705 ) = 1368
+ HASH ( 2706 ) = -2703
+ HASH ( 2707 ) = 27
+ HASH ( 2708 ) = 2421
+ HASH ( 2709 ) = 1614
+ HASH ( 2710 ) = -2707
+ HASH ( 2711 ) = 788
+ HASH ( 2712 ) = 2413
+ HASH ( 2713 ) = 1368
+ HASH ( 2714 ) = -2711
+ HASH ( 2715 ) = 1943
+ HASH ( 2716 ) = -2713
+ HASH ( 2717 ) = 1181
+ HASH ( 2718 ) = 2715
+ HASH ( 2719 ) = 1614
+ HASH ( 2720 ) = 1995
+ HASH ( 2721 ) = 1934
+ HASH ( 2722 ) = 2621
+ HASH ( 2723 ) = 1180
+ HASH ( 2725 ) = 1873
+ HASH ( 2726 ) = -2723
+ HASH ( 2727 ) = 919
+ HASH ( 2728 ) = 2725
+ HASH ( 2729 ) = 23
+ HASH ( 2730 ) = 2555
+ HASH ( 2731 ) = 1294
+ HASH ( 2732 ) = -2729
+ HASH ( 2733 ) = 1488
+ HASH ( 2734 ) = 2447
+ HASH ( 2735 ) = 1746
+ HASH ( 2736 ) = -2733
+ HASH ( 2737 ) = 1821
+ HASH ( 2738 ) = -2735
+ HASH ( 2739 ) = 1561
+ HASH ( 2740 ) = 2737
+ HASH ( 2741 ) = 1821
+ HASH ( 2742 ) = -2739
+ HASH ( 2743 ) = 921
+ HASH ( 2744 ) = 2741
+ HASH ( 2745 ) = 14
+ HASH ( 2746 ) = 2477
+ HASH ( 2747 ) = 1563
+ HASH ( 2748 ) = -2745
+ HASH ( 2749 ) = 1617
+ HASH ( 2750 ) = -2747
+ HASH ( 2751 ) = 1418
+ HASH ( 2752 ) = -2749
+ HASH ( 2753 ) = 1751
+ HASH ( 2754 ) = 2535
+ HASH ( 2755 ) = 1886
+ HASH ( 2756 ) = -2753
+ HASH ( 2757 ) = 1742
+ HASH ( 2758 ) = -2755
+ HASH ( 2759 ) = 1422
+ HASH ( 2760 ) = 2757
+ HASH ( 2761 ) = 1822
+ HASH ( 2762 ) = -2759
+ HASH ( 2763 ) = 1742
+ HASH ( 2764 ) = -2761
+ HASH ( 2765 ) = 1373
+ HASH ( 2766 ) = 2763
+ HASH ( 2767 ) = 1822
+ HASH ( 2768 ) = -2765
+ HASH ( 2769 ) = 1742
+ HASH ( 2770 ) = -2767
+ HASH ( 2771 ) = 661
+ HASH ( 2772 ) = 2769
+ HASH ( 2773 ) = 1742
+ HASH ( 2774 ) = -2771
+ HASH ( 2775 ) = 653
+ HASH ( 2776 ) = 2773
+ HASH ( 2777 ) = 10
+ HASH ( 2778 ) = 2033
+ HASH ( 2779 ) = 28
+ HASH ( 2780 ) = 2469
+ HASH ( 2781 ) = 924
+ HASH ( 2782 ) = -2779
+ HASH ( 2783 ) = 1548
+ HASH ( 2784 ) = -2781
+ HASH ( 2785 ) = 1627
+ HASH ( 2786 ) = -2783
+ HASH ( 2787 ) = 14
+ HASH ( 2788 ) = 2785
+ HASH ( 2789 ) = 1947
+ HASH ( 2790 ) = -2787
+ HASH ( 2791 ) = 909
+ HASH ( 2792 ) = -2789
+ HASH ( 2793 ) = 1548
+ HASH ( 2794 ) = -2791
+ HASH ( 2795 ) = 1627
+ HASH ( 2796 ) = -2793
+ HASH ( 2797 ) = 911
+ HASH ( 2798 ) = 2795
+ HASH ( 2799 ) = 15
+ HASH ( 2800 ) = 2571
+ HASH ( 2801 ) = 2962
+ HASH ( 2802 ) = -2799
+ HASH ( 2803 ) = 1563
+ HASH ( 2804 ) = -2801
+ HASH ( 2805 ) = 1949
+ HASH ( 2806 ) = 2113
+ HASH ( 2807 ) = 1881
+ HASH ( 2808 ) = -2805
+ HASH ( 2809 ) = 14
+ HASH ( 2810 ) = 2387
+ HASH ( 2811 ) = 1180
+ HASH ( 2812 ) = -2809
+ HASH ( 2813 ) = 1760
+ HASH ( 2814 ) = -2811
+ HASH ( 2815 ) = 1102
+ HASH ( 2816 ) = -2813
+ HASH ( 2817 ) = 1167
+ HASH ( 2818 ) = 2803
+ HASH ( 2819 ) = 1563
+ HASH ( 2820 ) = -2817
+ HASH ( 2821 ) = 29
+ HASH ( 2822 ) = 2029
+ HASH ( 2823 ) = 1496
+ HASH ( 2824 ) = -2821
+ HASH ( 2825 ) = 1486
+ HASH ( 2826 ) = 2823
+ HASH ( 2827 ) = 32
+ HASH ( 2829 ) = 13
+ HASH ( 2830 ) = 2279
+ HASH ( 2831 ) = 1175
+ HASH ( 2832 ) = 7821
+ HASH ( 2833 ) = 788
+ HASH ( 2834 ) = 2705
+ HASH ( 2835 ) = 1365
+ HASH ( 2837 ) = 29
+ HASH ( 2838 ) = 2613
+ HASH ( 2839 ) = 1566
+ HASH ( 2840 ) = -2837
+ HASH ( 2841 ) = 1175
+ HASH ( 2842 ) = -2839
+ HASH ( 2843 ) = 27
+ HASH ( 2844 ) = 2841
+ HASH ( 2845 ) = 1038
+ HASH ( 2846 ) = -2843
+ HASH ( 2847 ) = 1870
+ HASH ( 2848 ) = -2845
+ HASH ( 2849 ) = 1175
+ HASH ( 2850 ) = -2847
+ HASH ( 2851 ) = 29
+ HASH ( 2852 ) = 2849
+ HASH ( 2853 ) = 1630
+ HASH ( 2854 ) = -2851
+ HASH ( 2855 ) = 1175
+ HASH ( 2856 ) = -2853
+ HASH ( 2857 ) = 27
+ HASH ( 2858 ) = 2855
+ HASH ( 2859 ) = 1486
+ HASH ( 2860 ) = -2857
+ HASH ( 2861 ) = 1175
+ HASH ( 2862 ) = -2859
+ HASH ( 2863 ) = 919
+ HASH ( 2864 ) = 7973
+ HASH ( 2865 ) = 845
+ HASH ( 2866 ) = -2863
+ HASH ( 2867 ) = 1559
+ HASH ( 2868 ) = 2237
+ HASH ( 2869 ) = 1874
+ HASH ( 2870 ) = -2867
+ HASH ( 2871 ) = 1484
+ HASH ( 2872 ) = -2869
+ HASH ( 2873 ) = 27
+ HASH ( 2875 ) = 14
+ HASH ( 2877 ) = 1372
+ HASH ( 2878 ) = -2875
+ HASH ( 2879 ) = 661
+ HASH ( 2880 ) = 2551
+ HASH ( 2881 ) = 1751
+ HASH ( 2882 ) = -2879
+ HASH ( 2883 ) = 1870
+ HASH ( 2884 ) = -2881
+ HASH ( 2885 ) = 929
+ HASH ( 2886 ) = -2883
+ HASH ( 2887 ) = 1181
+ HASH ( 2888 ) = 2885
+ HASH ( 2889 ) = 652
+ HASH ( 2891 ) = 13
+ HASH ( 2892 ) = 2589
+ HASH ( 2893 ) = 1806
+ HASH ( 2895 ) = 1880
+ HASH ( 2897 ) = 2071
+ HASH ( 2898 ) = -2895
+ HASH ( 2899 ) = 856
+ HASH ( 2900 ) = -2897
+ HASH ( 2901 ) = 31
+ HASH ( 2902 ) = 2097
+ HASH ( 2903 ) = 850
+ HASH ( 2904 ) = -2901
+ HASH ( 2905 ) = 22
+ HASH ( 2906 ) = 2903
+ HASH ( 2907 ) = 785
+ HASH ( 2908 ) = 2393
+ HASH ( 2909 ) = 1866
+ HASH ( 2910 ) = -2907
+ HASH ( 2911 ) = 14
+ HASH ( 2912 ) = 2655
+ HASH ( 2913 ) = 1175
+ HASH ( 2914 ) = -2911
+ HASH ( 2915 ) = 1949
+ HASH ( 2916 ) = -2913
+ HASH ( 2917 ) = 1752
+ HASH ( 2918 ) = -2915
+ HASH ( 2919 ) = 792
+ HASH ( 2920 ) = -2917
+ HASH ( 2921 ) = 1634
+ HASH ( 2922 ) = 2919
+ HASH ( 2923 ) = 792
+ HASH ( 2924 ) = -2921
+ HASH ( 2925 ) = 29
+ HASH ( 2926 ) = 2923
+ HASH ( 2927 ) = 1500
+ HASH ( 2928 ) = -2925
+ HASH ( 2929 ) = 667
+ HASH ( 2930 ) = 2575
+ HASH ( 2931 ) = 785
+ HASH ( 2932 ) = -2929
+ HASH ( 2933 ) = 14
+ HASH ( 2934 ) = 2369
+ HASH ( 2935 ) = 1564
+ HASH ( 2936 ) = -2933
+ HASH ( 2937 ) = 789
+ HASH ( 2938 ) = -2935
+ HASH ( 2939 ) = 28
+ HASH ( 2940 ) = 2937
+ HASH ( 2941 ) = 668
+ HASH ( 2942 ) = -2939
+ HASH ( 2943 ) = 27
+ HASH ( 2944 ) = 2931
+ HASH ( 2945 ) = 1870
+ HASH ( 2946 ) = -2943
+ HASH ( 2947 ) = 652
+ HASH ( 2948 ) = -2945
+ HASH ( 2949 ) = 667
+ HASH ( 2950 ) = -2947
+ HASH ( 2951 ) = 1806
+ HASH ( 2953 ) = 778
+ HASH ( 2954 ) = -2951
+ HASH ( 2955 ) = 1365
+ HASH ( 2956 ) = 2953
+ HASH ( 2957 ) = 1557
+ HASH ( 2958 ) = 2201
+ HASH ( 2959 ) = 728
+ HASH ( 2960 ) = -2957
+ HASH ( 2961 ) = 23
+ HASH ( 2962 ) = 2959
+ HASH ( 2963 ) = 906
+ HASH ( 2964 ) = -2961
+ HASH ( 2965 ) = 1557
+ HASH ( 2966 ) = -2963
+ HASH ( 2967 ) = 20
+ HASH ( 2969 ) = 1548
+ HASH ( 2970 ) = -2967
+ HASH ( 2971 ) = 23
+ HASH ( 2973 ) = 1042
+ HASH ( 2974 ) = -2971
+ HASH ( 2975 ) = 1551
+ HASH ( 2977 ) = 2222
+ HASH ( 2978 ) = -2975
+ HASH ( 2979 ) = 1738
+ HASH ( 2980 ) = -2977
+ HASH ( 2981 ) = 667
+ HASH ( 2982 ) = -2979
+ HASH ( 2983 ) = 785
+ HASH ( 2984 ) = 2547
+ HASH ( 2985 ) = 1866
+ HASH ( 2986 ) = -2983
+ HASH ( 2987 ) = 15
+ HASH ( 2988 ) = 2981
+ HASH ( 2989 ) = 2200
+ HASH ( 2990 ) = -2987
+ HASH ( 2991 ) = 1738
+ HASH ( 2992 ) = -2989
+ HASH ( 2993 ) = 667
+ HASH ( 2994 ) = -2991
+ HASH ( 2995 ) = 34
+ HASH ( 2996 ) = 2993
+ HASH ( 2997 ) = 1738
+ HASH ( 2998 ) = -2995
+ HASH ( 2999 ) = 13
+ HASH ( 3000 ) = 2505
+ HASH ( 7719 ) = 1742
+ HASH ( 7721 ) = 1561
+ HASH ( 7723 ) = 3841
+ HASH ( 7724 ) = -7721
+ HASH ( 7725 ) = 843
+ HASH ( 7726 ) = -7723
+ HASH ( 7727 ) = 1550
+ HASH ( 7728 ) = 7725
+ HASH ( 7729 ) = 3841
+ HASH ( 7730 ) = -7727
+ HASH ( 7731 ) = 843
+ HASH ( 7732 ) = -7729
+ HASH ( 7733 ) = 1569
+ HASH ( 7735 ) = 3841
+ HASH ( 7736 ) = -7733
+ HASH ( 7737 ) = 781
+ HASH ( 7738 ) = -7735
+ HASH ( 7739 ) = 1804
+ HASH ( 7740 ) = -7737
+ HASH ( 7741 ) = 1569
+ HASH ( 7742 ) = 7739
+ HASH ( 7743 ) = 3841
+ HASH ( 7744 ) = -7741
+ HASH ( 7745 ) = 1485
+ HASH ( 7746 ) = -7743
+ HASH ( 7747 ) = 1804
+ HASH ( 7748 ) = -7745
+ HASH ( 7749 ) = 1551
+ HASH ( 7750 ) = 7731
+ HASH ( 7751 ) = 3841
+ HASH ( 7752 ) = -7749
+ HASH ( 7753 ) = 843
+ HASH ( 7754 ) = -7751
+ HASH ( 7755 ) = 1569
+ HASH ( 7756 ) = 7753
+ HASH ( 7757 ) = 3841
+ HASH ( 7758 ) = -7755
+ HASH ( 7759 ) = 843
+ HASH ( 7760 ) = -7757
+ HASH ( 7761 ) = 1569
+ HASH ( 7762 ) = 7747
+ HASH ( 7763 ) = 1
+ HASH ( 7764 ) = -7761
+ HASH ( 7765 ) = 1485
+ HASH ( 7766 ) = -7763
+ HASH ( 7767 ) = 1804
+ HASH ( 7768 ) = -7765
+ HASH ( 7769 ) = 1569
+ HASH ( 7770 ) = 7767
+ HASH ( 7771 ) = 1
+ HASH ( 7772 ) = -7769
+ HASH ( 7773 ) = 781
+ HASH ( 7774 ) = -7771
+ HASH ( 7775 ) = 1804
+ HASH ( 7776 ) = -7773
+ HASH ( 7777 ) = 1804
+ HASH ( 7778 ) = 7775
+ HASH ( 7779 ) = 33
+ HASH ( 7780 ) = 7777
+ HASH ( 7781 ) = 1537
+ HASH ( 7782 ) = -7779
+ HASH ( 7783 ) = 781
+ HASH ( 7784 ) = -7781
+ HASH ( 7785 ) = 1804
+ HASH ( 7786 ) = -7783
+ HASH ( 7787 ) = 1551
+ HASH ( 7788 ) = 7759
+ HASH ( 7789 ) = 1
+ HASH ( 7790 ) = -7787
+ HASH ( 7791 ) = 843
+ HASH ( 7792 ) = -7789
+ HASH ( 7793 ) = 1301
+ HASH ( 7795 ) = 906
+ HASH ( 7796 ) = -7793
+ HASH ( 7797 ) = 731
+ HASH ( 7798 ) = -7795
+ HASH ( 7799 ) = 14
+ HASH ( 7801 ) = 1563
+ HASH ( 7802 ) = -7799
+ HASH ( 7803 ) = 1821
+ HASH ( 7804 ) = -7801
+ HASH ( 7805 ) = 1998
+ HASH ( 7806 ) = 7719
+ HASH ( 7807 ) = 1432
+ HASH ( 7808 ) = -7805
+ HASH ( 7809 ) = 1742
+ HASH ( 7810 ) = -7807
+ HASH ( 7811 ) = 14
+ HASH ( 7813 ) = 667
+ HASH ( 7814 ) = -7811
+ HASH ( 7815 ) = 789
+ HASH ( 7816 ) = -7813
+ HASH ( 7817 ) = 846
+ HASH ( 7818 ) = -7815
+ HASH ( 7819 ) = 1748
+ HASH ( 7821 ) = 1418
+ HASH ( 7822 ) = -7819
+ HASH ( 7823 ) = 1757
+ HASH ( 7824 ) = 7809
+ HASH ( 7825 ) = 1624
+ HASH ( 7826 ) = -7823
+ HASH ( 7827 ) = 1742
+ HASH ( 7828 ) = -7825
+ HASH ( 7829 ) = 1873
+ HASH ( 7831 ) = 2066
+ HASH ( 7832 ) = -7829
+ HASH ( 7833 ) = 1569
+ HASH ( 7834 ) = 7791
+ HASH ( 7835 ) = 1
+ HASH ( 7836 ) = -7833
+ HASH ( 7837 ) = 1047
+ HASH ( 7839 ) = 1810
+ HASH ( 7840 ) = -7837
+ HASH ( 7841 ) = 1173
+ HASH ( 7843 ) = 1994
+ HASH ( 7844 ) = -7841
+ HASH ( 7845 ) = 1418
+ HASH ( 7846 ) = -7843
+ HASH ( 7847 ) = 1422
+ HASH ( 7848 ) = -7845
+ HASH ( 7849 ) = 1501
+ HASH ( 7851 ) = 1998
+ HASH ( 7852 ) = -7849
+ HASH ( 7853 ) = 910
+ HASH ( 7854 ) = -7851
+ HASH ( 7855 ) = 1948
+ HASH ( 7856 ) = -7853
+ HASH ( 7857 ) = 1432
+ HASH ( 7858 ) = -7855
+ HASH ( 7859 ) = 1501
+ HASH ( 7861 ) = 1998
+ HASH ( 7862 ) = -7859
+ HASH ( 7863 ) = 1870
+ HASH ( 7864 ) = -7861
+ HASH ( 7865 ) = 1806
+ HASH ( 7866 ) = -7863
+ HASH ( 7867 ) = 1357
+ HASH ( 7868 ) = 7865
+ HASH ( 7869 ) = 1112
+ HASH ( 7870 ) = -7867
+ HASH ( 7871 ) = 924
+ HASH ( 7872 ) = -7869
+ HASH ( 7873 ) = 1115
+ HASH ( 7874 ) = -7871
+ HASH ( 7875 ) = 1885
+ HASH ( 7876 ) = -7873
+ HASH ( 7877 ) = 1806
+ HASH ( 7878 ) = -7875
+ HASH ( 7879 ) = 32
+ HASH ( 7880 ) = 7877
+ HASH ( 7881 ) = 856
+ HASH ( 7882 ) = -7879
+ HASH ( 7883 ) = 1175
+ HASH ( 7884 ) = -7881
+ HASH ( 7885 ) = 1888
+ HASH ( 7886 ) = -7883
+ HASH ( 7887 ) = 1806
+ HASH ( 7888 ) = -7885
+ HASH ( 7889 ) = 909
+ HASH ( 7890 ) = 7887
+ HASH ( 7891 ) = 1614
+ HASH ( 7892 ) = -7889
+ HASH ( 7893 ) = 1884
+ HASH ( 7894 ) = -7891
+ HASH ( 7895 ) = 1806
+ HASH ( 7896 ) = -7893
+ HASH ( 7897 ) = 29
+ HASH ( 7899 ) = 919
+ HASH ( 7900 ) = -7897
+ HASH ( 7901 ) = 918
+ HASH ( 7902 ) = -7899
+ HASH ( 7903 ) = 1567
+ HASH ( 7904 ) = -7901
+ HASH ( 7905 ) = 1878
+ HASH ( 7906 ) = -7903
+ HASH ( 7907 ) = 1038
+ HASH ( 7908 ) = -7905
+ HASH ( 7909 ) = 27
+ HASH ( 7910 ) = 7817
+ HASH ( 7911 ) = 1816
+ HASH ( 7912 ) = -7909
+ HASH ( 7913 ) = 1947
+ HASH ( 7914 ) = -7911
+ HASH ( 7915 ) = 972
+ HASH ( 7916 ) = -7913
+ HASH ( 7917 ) = 846
+ HASH ( 7918 ) = -7915
+ HASH ( 7919 ) = 1500
+ HASH ( 7920 ) = 7895
+ HASH ( 7921 ) = 1042
+ HASH ( 7922 ) = -7919
+ HASH ( 7923 ) = 667
+ HASH ( 7924 ) = -7921
+ HASH ( 7925 ) = 1878
+ HASH ( 7926 ) = -7923
+ HASH ( 7927 ) = 1806
+ HASH ( 7928 ) = -7925
+ HASH ( 7929 ) = 1806
+ HASH ( 7930 ) = 7907
+ HASH ( 7931 ) = 906
+ HASH ( 7932 ) = -7929
+ HASH ( 7933 ) = 917
+ HASH ( 7934 ) = -7931
+ HASH ( 7935 ) = 1883
+ HASH ( 7936 ) = -7933
+ HASH ( 7937 ) = 1038
+ HASH ( 7938 ) = -7935
+ HASH ( 7939 ) = 1820
+ HASH ( 7940 ) = 7937
+ HASH ( 7941 ) = 1742
+ HASH ( 7942 ) = -7939
+ HASH ( 7943 ) = 1881
+ HASH ( 7944 ) = -7941
+ HASH ( 7945 ) = 1038
+ HASH ( 7946 ) = -7943
+ HASH ( 7947 ) = 23
+ HASH ( 7948 ) = 7927
+ HASH ( 7949 ) = 1176
+ HASH ( 7950 ) = -7947
+ HASH ( 7951 ) = 1181
+ HASH ( 7952 ) = -7949
+ HASH ( 7953 ) = 1564
+ HASH ( 7954 ) = -7951
+ HASH ( 7955 ) = 1881
+ HASH ( 7956 ) = -7953
+ HASH ( 7957 ) = 1806
+ HASH ( 7958 ) = -7955
+ HASH ( 7959 ) = 1948
+ HASH ( 7960 ) = 7803
+ HASH ( 7961 ) = 669
+ HASH ( 7962 ) = -7959
+ HASH ( 7963 ) = 1821
+ HASH ( 7964 ) = -7961
+ HASH ( 7965 ) = 1563
+ HASH ( 7967 ) = 1756
+ HASH ( 7968 ) = -7965
+ HASH ( 7969 ) = 798
+ HASH ( 7970 ) = -7967
+ HASH ( 7971 ) = 846
+ HASH ( 7972 ) = -7969
+ HASH ( 7973 ) = 1106
+ HASH ( 7974 ) = -7971
+ HASH ( 7975 ) = 1563
+ HASH ( 7977 ) = 1756
+ HASH ( 7978 ) = -7975
+ HASH ( 7979 ) = 798
+ HASH ( 7980 ) = -7977
+ HASH ( 7981 ) = 1568
+ HASH ( 7982 ) = -7979
+ HASH ( 7983 ) = 1181
+ HASH ( 7985 ) = 1175
+ HASH ( 7986 ) = -7983
+ HASH ( 7987 ) = 14
+ HASH ( 7988 ) = 7857
+ HASH ( 7989 ) = 1948
+ HASH ( 7990 ) = -7987
+ HASH ( 7991 ) = 1432
+ HASH ( 7992 ) = -7989
+ HASH ( 7993 ) = 17
+ HASH ( 7995 ) = 665
+ HASH ( 7996 ) = -7993
+ HASH ( 7997 ) = 1051
+ HASH ( 7998 ) = -7995
+ HASH ( 7999 ) = 1952
+ HASH ( 8000 ) = -7997
+ COM(1) = 95
+ KEYS ( 1 ) = 168
+ KEYS ( 2 ) = 81
+ KEYS ( 3 ) = 872
+ KEYS ( 4 ) = 95
+ KEYS ( 5 ) = 217
+ KEYS ( 6 ) = 97
+ KEYS ( 7 ) = 152
+ KEYS ( 8 ) = 115
+ KEYS ( 9 ) = 440
+ KEYS ( 10 ) = 179
+ KEYS ( 11 ) = 696
+ KEYS ( 12 ) = 195
+ KEYS ( 13 ) = 16
+ KEYS ( 14 ) = 317
+ KEYS ( 15 ) = 409
+ KEYS ( 16 ) = 333
+ KEYS ( 17 ) = 408
+ KEYS ( 18 ) = 343
+ KEYS ( 19 ) = 80
+ KEYS ( 20 ) = 579
+ KEYS ( 21 ) = 224
+ KEYS ( 22 ) = 691
+ KEYS ( 23 ) = 56
+ KEYS ( 24 ) = 719
+ KEYS ( 25 ) = 768
+ KEYS ( 26 ) = 819
+ KEYS ( 27 ) = 407
+ KEYS ( 28 ) = 847
+ KEYS ( 29 ) = 192
+ KEYS ( 30 ) = 955
+ KEYS ( 31 ) = 8016
+ KEYS ( 32 ) = 975
+ KEYS ( 33 ) = 520
+ KEYS ( 34 ) = 1081
+ KEYS ( 35 ) = 544
+ KEYS ( 36 ) = 1109
+ KEYS ( 37 ) = 784
+ KEYS ( 38 ) = 1113
+ KEYS ( 39 ) = 761
+ KEYS ( 40 ) = 1115
+ KEYS ( 41 ) = 184
+ KEYS ( 42 ) = 1237
+ KEYS ( 43 ) = 400
+ KEYS ( 44 ) = 1303
+ KEYS ( 45 ) = 536
+ KEYS ( 46 ) = 1327
+ KEYS ( 47 ) = 144
+ KEYS ( 48 ) = 1335
+ KEYS ( 49 ) = 88
+ KEYS ( 50 ) = 1339
+ KEYS ( 51 ) = 608
+ KEYS ( 52 ) = 1371
+ KEYS ( 53 ) = 664
+ KEYS ( 54 ) = 1437
+ KEYS ( 55 ) = 176
+ KEYS ( 56 ) = 1451
+ KEYS ( 57 ) = 512
+ KEYS ( 58 ) = 1457
+ KEYS ( 59 ) = 208
+ KEYS ( 60 ) = 1459
+ KEYS ( 61 ) = 64
+ KEYS ( 62 ) = 1467
+ KEYS ( 63 ) = 72
+ KEYS ( 64 ) = 1557
+ KEYS ( 65 ) = 513
+ KEYS ( 66 ) = 1571
+ KEYS ( 67 ) = 688
+ KEYS ( 68 ) = 1579
+ KEYS ( 69 ) = 704
+ KEYS ( 70 ) = 1585
+ KEYS ( 71 ) = 792
+ KEYS ( 72 ) = 1595
+ KEYS ( 73 ) = 448
+ KEYS ( 74 ) = 1603
+ KEYS ( 75 ) = 816
+ KEYS ( 76 ) = 1625
+ KEYS ( 77 ) = 40
+ KEYS ( 78 ) = 1693
+ KEYS ( 79 ) = 712
+ KEYS ( 80 ) = 1701
+ KEYS ( 81 ) = 112
+ KEYS ( 82 ) = 1713
+ KEYS ( 83 ) = 824
+ KEYS ( 84 ) = 1715
+ KEYS ( 85 ) = 216
+ KEYS ( 86 ) = 1723
+ KEYS ( 87 ) = 488
+ KEYS ( 88 ) = 1729
+ KEYS ( 89 ) = 832
+ KEYS ( 90 ) = 1743
+ KEYS ( 91 ) = 8009
+ KEYS ( 92 ) = 1749
+ KEYS ( 93 ) = 840
+ KEYS ( 94 ) = 1763
+ KEYS ( 95 ) = 496
+ KEYS ( 96 ) = 1835
+ KEYS ( 97 ) = 640
+ KEYS ( 98 ) = 1839
+ KEYS ( 99 ) = 728
+ KEYS ( 100 ) = 1849
+ KEYS ( 101 ) = 120
+ KEYS ( 102 ) = 1859
+ KEYS ( 103 ) = 616
+ KEYS ( 104 ) = 1869
+ KEYS ( 105 ) = 633
+ KEYS ( 106 ) = 1873
+ KEYS ( 107 ) = 8008
+ KEYS ( 108 ) = 1941
+ KEYS ( 109 ) = 504
+ KEYS ( 110 ) = 1957
+ KEYS ( 111 ) = 136
+ KEYS ( 112 ) = 1969
+ KEYS ( 113 ) = 848
+ KEYS ( 114 ) = 1971
+ KEYS ( 115 ) = 744
+ KEYS ( 116 ) = 1981
+ KEYS ( 117 ) = 856
+ KEYS ( 118 ) = 1987
+ KEYS ( 119 ) = 456
+ KEYS ( 120 ) = 2387
+ KEYS ( 121 ) = 776
+ KEYS ( 122 ) = 2499
+ KEYS ( 123 ) = 776
+ KEYS ( 124 ) = 2505
+ KEYS ( 125 ) = 121
+ KEYS ( 126 ) = 2529
+ KEYS ( 127 ) = 464
+ KEYS ( 128 ) = 2567
+ KEYS ( 129 ) = 224
+ KEYS ( 130 ) = 2629
+ KEYS ( 131 ) = 160
+ KEYS ( 132 ) = 2677
+ KEYS ( 133 ) = 24
+ KEYS ( 134 ) = 2687
+ KEYS ( 135 ) = 632
+ KEYS ( 136 ) = 2705
+ KEYS ( 137 ) = 200
+ KEYS ( 138 ) = 2715
+ KEYS ( 139 ) = 592
+ KEYS ( 140 ) = 2725
+ KEYS ( 141 ) = 517
+ KEYS ( 142 ) = 2737
+ KEYS ( 143 ) = 104
+ KEYS ( 144 ) = 2741
+ KEYS ( 145 ) = 32
+ KEYS ( 146 ) = 2757
+ KEYS ( 147 ) = 96
+ KEYS ( 148 ) = 2763
+ KEYS ( 149 ) = 516
+ KEYS ( 150 ) = 2773
+ KEYS ( 151 ) = 625
+ KEYS ( 152 ) = 2785
+ KEYS ( 153 ) = 808
+ KEYS ( 154 ) = 2795
+ KEYS ( 155 ) = 777
+ KEYS ( 156 ) = 2803
+ KEYS ( 157 ) = 777
+ KEYS ( 158 ) = 2819
+ KEYS ( 159 ) = 528
+ KEYS ( 160 ) = 2823
+ KEYS ( 161 ) = 762
+ KEYS ( 162 ) = 2841
+ KEYS ( 163 ) = 514
+ KEYS ( 164 ) = 2849
+ KEYS ( 165 ) = 760
+ KEYS ( 166 ) = 2855
+ KEYS ( 167 ) = 48
+ KEYS ( 168 ) = 2861
+ KEYS ( 169 ) = 736
+ KEYS ( 170 ) = 2885
+ KEYS ( 171 ) = 720
+ KEYS ( 172 ) = 2899
+ KEYS ( 173 ) = 406
+ KEYS ( 174 ) = 2903
+ KEYS ( 175 ) = 624
+ KEYS ( 176 ) = 2919
+ KEYS ( 177 ) = 552
+ KEYS ( 178 ) = 2923
+ KEYS ( 179 ) = 513
+ KEYS ( 180 ) = 2931
+ KEYS ( 181 ) = 697
+ KEYS ( 182 ) = 2937
+ KEYS ( 183 ) = 128
+ KEYS ( 184 ) = 2953
+ KEYS ( 185 ) = 512
+ KEYS ( 186 ) = 2959
+ KEYS ( 187 ) = 648
+ KEYS ( 188 ) = 2981
+ KEYS ( 189 ) = 648
+ KEYS ( 190 ) = 2993
+ RETURN
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ integer function ibset(i,j)
+ integer i, j
+ ibset= or(i,lshift(1,j))
+ return
+ end
+
+ integer function ibclr(i,j)
+ integer i,j
+ ibclr = xor(i,and(i,lshift(1,j)))
+ return
+ end
+
+ logical function btest(i,j)
+ integer i,j
+ btest = and(i,lshift(1,j)) .ne. 0
+ return
+ end
+
+ integer function iand(i,j)
+ integer i,j
+ iand = and(i,j)
+ return
+ end
+
+ integer function ior(i,j)
+ integer i,j
+ ior = or(i,j)
+ return
+ end
+
+ integer function ieor(i,j)
+ integer i,j
+ ieor = xor(i,j)
+ return
+ end
+
+ integer function ishft(i,j)
+ integer i,j
+ if (j .eq. 0) goto 11
+ if (j .gt. 0) goto 10
+ i=and(i,X'7fffffff')
+ ishft = rshift(i,-j)
+ return
+ 10 ishft = lshift(i,j)
+ return
+ 11 ishft = i
+ return
+ end
+
+ character function int2char(i)
+ integer i
+ int2char=char(i)
+ return
+ end
+
+
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+c files used by compiler :
+c
+c unit file description
+c
+c 13 output sequential (F) listing (.LST) (ML2, )
+c 14 temporary direct (C) code after parser (WAN1, ML2)
+c 15 output sequential (C) L-code (.LCD) (WAN1, ML2)
+c 16 temporary sequential (C) listing (WAN1, ML2)
+c 17 input sequential (C) source (WAN1, ML2)
+c 18 temporary sequential (C) L-code (WAN1, AL11)
+c 19 temporary direct (C) errors (WAN2, ML2)
+c 21 output sequential (C) debugger (WAN1, ML2)
+c
+ subroutine LOGLAN(parlen,parbuf)
+ integer parlen
+ character parbuf(1)
+ IMPLICIT INTEGER (A-Z)
+c parlen - dlugosc linii z parametrami dla kompilatora
+c parbuf - bufor zawierajacy parametry dla kompilatora
+C======================================================================C
+C C
+C LOGLAN L-COMPILER C
+C ================= C
+C C
+C AUTHORS: C
+C C
+C DANKA SZCZEPANSKA-WASERSZTRUM C
+C MAREK J. LAO C
+C ANDRZEJ I. LITWINIUK C
+C WOJTEK A. NYKOWSKI C
+C C
+C IIUW, WARSZAWA, 1982 C
+C C
+C PORTED TO SIEMENS 7760 BS2000 BY: C
+C C
+C PAWEL K. GBURZYNSKI C
+C MANFRED KRAUSE C
+C ANDRZEJ I. LITWINIUK C
+C C
+C IIPMCAU, KIEL, MAY-JUNE 1984 C
+C C
+C PORTED TO IBM PC BY C
+C Danuta Szczepanska C
+C Boleslaw Ciesielski C
+C Teresa Przytycka C
+C C
+C PORTED TO VAX / VMS BY C
+C Danuta Szczepanska C
+C Andrzej Litwiniuk C
+C C
+C PORTED TO XENIX SCO BY C
+C Pawel Susicki C
+C C
+C PORTED TO UNIX SCO BY C
+C Pawel Susicki C
+C C
+C PORTED TO SUN SPARC BY C
+C Pawel Susicki C
+C C
+C======================================================================C
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ C0M(4) , S, ADRES , K
+ common /mjlmsg/ierc,msg
+ integer*4 msg
+C======================================================================C
+C THE FOLLOWING FILE UNITS ARE USED: C
+C C
+C 1 - INTERACTIVE INPUT FROM THE TERMINAL C
+C 2 - INTERACTIVE OUTPUT TO THE TERMINAL C
+C 13 - LISTING OUTPUT C
+C 14 - WORKING FILE SCRATCH C
+C 15 - L-CODE OUTPUT C
+C 16 - PARTIAL LISTING FROM PARSER C
+C 17 - SOURCE INPUT TO THE COMPILER C
+C 18 - AUXILIARY SOURCE INPUT C
+C 19 - SCRATCH FILE INCLUDING INFO ABOUT COMPILATION ERRORS C
+C======================================================================C
+cdsw byte jfname
+ character jfname, param
+
+ common /par/ param(256),dl, pozopt
+c param - line of program parameters
+c dl - length of program parameters
+c pozopt - options position in param
+
+ common /jf/jfname(72),jf
+
+ call ffputnl(0)
+ call ffputcs(0,' LOGLAN-82 UNIX Compiler, Version 2.1')
+ call ffputnl(0)
+ call ffputcs(0,' January 10, 1993')
+ call ffputnl(0)
+ call ffputcs(0,' (C)Copyright Institute of Informatics,')
+ call ffputcs(0,' University of Warsaw')
+ call ffputcs(0,' (C)Copyleft LITA Universite de Pau')
+ call ffputnl(0)
+
+ ierc = 0
+ msg = 'it0 '
+ do 10 jf=1,70
+10 jfname(jf) = ' '
+ do 15 i=1, parlen
+15 param(i)=parbuf(i)
+ dl=parlen
+ if(dl.ne.0) go to 100
+ pozopt = 0
+200 continue
+c prompt
+
+ call ffputcs(0,' File name: ')
+ call ffgets (0,param,70)
+
+ dl = 70
+c file name is in param
+100 continue
+ do 20 pozopt=1,dl
+ if(param(pozopt).ne.' ') go to 30
+ 20 continue
+ go to 200
+ 30 jf = 0
+50 if(param(pozopt).eq.' '.or.param(pozopt).eq.',' .or.
+ * param(pozopt).eq.';') go to 300
+ if (jf.ge.70) go to 40
+ jf = jf+1
+ jfname(jf) = param(pozopt)
+ 40 pozopt = pozopt+1
+ if(pozopt .le. dl) go to 50
+ 300 if (jf.eq.0) go to 200
+ 500 continue
+ CALL DATA3
+ CALL DATA
+ CALL DATA2
+ CALL MESS
+ CALL WAN
+ END
+
+
+ SUBROUTINE DATA3
+ IMPLICIT INTEGER (A-Z)
+C
+C INITIATES THE BLANK COMMON
+C FIXES DIVISION OF IPMEM INTO COMPILER TABLES
+C
+C
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ x IPMEM(5000)
+cdsw&bc X IPMEM(50000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=32000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
+C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
+C NRRE - REAL
+C NRBOOL - BOOLEAN
+C NRCHR - CHARACTER
+C NRCOR - COROUTINE
+C NRPROC - PROCESS
+C NRTEXT - STRING (TEXT)
+C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
+C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
+C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
+C REFERENCYJNY)
+C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
+C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
+C
+C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
+C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
+C MOWEJ
+C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
+C BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
+C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
+C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
+C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
+C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
+C
+C
+C IN THIS PLACE THE SIZE OF IPMEM MAY BE REDECLARED; THEN THE
+C VARIABLE LMEM (BELOW) SHOULD BE SET TO THE LENGTH OF IPMEM.
+C
+C
+C IPMEM - MAIN MEMORY AREA OF THE COMPILER
+C LPML - ADDRESS OF THE FIRST -
+C LPMF - ADDRESS OF THE LAST FREE WORD IN IPMEM
+C ISFIN - TOP OF THE DICTIONARY OF PROTOTYPES
+C LPMEM - DIVISION POINT OF IPMEM
+C LMEM - LENGTH OF IPMEM
+C
+ COM(1)=0
+
+ lmem = LMEMSIZE
+ lpmem = LPMEMSIZE+1
+
+ IF (LPMEM.GT.4550) GO TO 1
+C --- SIZE OF IPMEM TOO SMALL
+ call ffputcs(0,' Fatal Error: Memory overflow ')
+ call ffputnl(0)
+ call ffexit
+c--
+1 DO 10 I=3738,LMEM
+10 IPMEM(I)=0
+
+C --- 2 BELOW STANDS FOR THE SIZE OF REAL NUMBER EXPRESSED IN THE
+C --- NUMBER OF INTEGERS WHICH COVERS THIS SIZE.
+cvax the size of real numbers on vax is 4 bytes ( = the size of integer)
+cvax LPML=LPMEM+2
+cdsw lpml - first free place in real constants
+cdsw in the future - (lpmem+1) = 0.0, (lpmem+2) = 1.0
+ lpml = lpmem + WORDS_IN_REAL
+
+C
+C THE FIRST REAL CONSTANT IS 0.0
+C
+ LPMF=LMEM
+ ISFIN=LPMEM-1
+ RETURN
+ END
+
+ SUBROUTINE DATA
+ IMPLICIT INTEGER (A-Z)
+cdsw INTEGER DATAHEX1,DATAHEX2,DATAHEX3
+cdsw DATA DATAHEX1,DATAHEX2,DATAHEX3 /Z802F,Z0000,ZFFFF/
+
+C
+C INITIATES THE BLANK COMMON
+C
+ DIMENSION X(169),Y(169)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, JK1, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT,JK2,NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEXT, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+ REAL FRACT,NU
+ EQUIVALENCE (TRANS1(1,1),X(1))
+ EQUIVALENCE (TRANS2(1,1),Y(1))
+ LOGICAL OKEY
+C DATA M,HASH,NAME,NLAST,NL /1009,3000*0,10*0,3001,10/
+c #8027 zmienione na #002F - w zapisie uzupelnieniowym
+ dathx1 = X'002F'
+ dathx2 = X'0000'
+c #ffff zmienione na -#0001
+ dathx3 = -X'0001'
+ M=1009
+cdsw NLAST=3001
+ nlast =8001
+ NL=10
+cdsw DO 2 I=1,3000
+cdsw2 HASH(I)=0
+ DO 3 I=1,NL
+3 NAME(I)=0
+C DATA TRANS2 /1,3,5,8,3,10,10,16,18,1,10,10,20,2,1,1,8,1,14,14,16,
+C ,18,
+C ,1,14,1,20,1,3,1,9,11,14,14,16,18,1,14,14,20,1,3,6,8,12,14,14,16,
+C ,18,1,14,14,20,1,4,7,8,4,15,15,16,18,1,14,14,20,1,3,1,8,13,14,14,16
+C ,,18,1,14,14,20,1,4,7,8,4,15,15,16,18,1,14,14,20,1,3,7,8,3,14,14,16
+C ,,18,1,14,14,20,1,3,6,10,3,14,14,16,18,1,14,14,20,1,3,1,8,3,14,14,
+C ,16,
+C ,18,1,14,14,20,7*1,17,14*1,19,15*1,21/
+C DATA TRANS1 /1,1,9,5*1,16,17,1,1,1,2,4,4,2,4,2,2,2,16,17,2,4,2,1,5
+C ,,10,1,1,5,5,5,16,17,5,5,5,1,7,11,7,1,7,7,7,16,17,7,7,7,1,5,12,7,5,
+C ,15,1,7,16,17,7,7,7,1,6,13,7,1,6,6,6,16,17,6,6,6,1,6,12,7,6,15,1,7,
+C ,16,17,7,7,7,1,7,12,7,7,7,7,7,16,17,7,7,7,1,8,11,1,8,8,8,8,16,17,8,
+C ,8,8,1,6,14,6,6,6,6,6,16,17,6,6,6,7*3,1,3,3,3,3,3,8*1,17,1,1,1,1,
+C ,13*18/
+C DATA B0,B/10*2,4*1,4,21*1,0,0,3,6,5,10,10,7,12,10,11,8*10,9,3*10,
+C ,8,11*10/
+C DATA SKOK0,SKOK /47*6,1,2,3,4,4,5,18*6/
+C ---
+cdsw C0M(2)=DATAHEX1
+cdsw C0M(3)=DATAHEX2
+cdsw C0M(4)=DATAHEX3
+ c0m(2)=dathx1
+ c0m(3)=dathx2
+ c0m(4)=dathx3
+ CALL OPTDEF
+C ---
+ SKOK0=6
+ DO 4 I=1,70
+4 SKOK(I)=6
+ SKOK(47)=1
+ SKOK(48)=2
+ SKOK(49)=3
+ SKOK(50)=4
+ SKOK(51)=4
+ SKOK(52)=5
+ SIDENT=1
+ DO 5 I=1,200
+5 KEYS(I)=0
+C DATA S,ADRES,STAN,K,SY,AUX,EXP,SIGN,INTPART,FRAC /10*0/
+ S=0
+ ADRES=0
+ STAN=0
+ K=0
+ SY=0
+ AUX=0
+ EXP=0
+ SIGN=0
+ INTPART=0
+ FRAC=0
+C DATA OKEY,NU /.FALSE.,0.0/
+ OKEY=.FALSE.
+ NU=0.0
+ SCONST=1000
+ SEOF=70
+ SAND=67
+ SARRAY=18
+ SARROF=81
+ SATTACH=11
+ SBEGIN=83
+ SBLOCK=22
+ SBOOL=85
+ SCALL=9
+ SCASE=16
+ SCHAR=71
+ SCLASS=86
+ SCLOSE=87
+ SCONS=88
+ SCOPY=69
+ SCOROUT=78
+ SDETACH=5
+ SDIM=89
+ SDO=14
+ SDOWN=90
+ SELSE=62
+ SEND=80
+ SESAC=91
+ SEXIT=15
+ SEXTERN=92
+ SFI=63
+ SFOR=17
+ SFUNCT=93
+ SIF=2
+ SINNER=6
+ SINPUT=95
+ SINT=64
+ SKILL=10
+ SLOCK=7
+ SNEW=24
+ SNONE=1002
+ SNOT=66
+ SOD=65
+ SOR=68
+ SORIF=97
+ SOTHER=98
+ SOUTPUT=99
+ SPREF=23
+ SPRCD=101
+ SQUA=76
+ SREAD=8
+ SRESUME=12
+ SRETURN=4
+ STEP=102
+ STOP=13
+ STAKEN=103
+ STHEN=61
+ STHIS=74
+ STO=104
+ STRUE=1001
+ STYPE=105
+ SUNIT=77
+ SVAR=106
+ SVIRTUAL=107
+ SWAIT=21
+ SWHEN=109
+ SWHILE=3
+ SWRIT=19
+ SWRITLN=20
+ SCOMA=42
+ SDOT=38
+ SEMICOL=45
+ SCOLON=47
+ SLEFT=52
+ SRIGHT=53
+ SBECOME=54
+ STAR=50
+ SRELAT=51
+C DATA BYTE,TL,NB,TEXT /64,20,2,20*0/
+ BYTE=64
+ TL=132
+ NB=2
+CBC TEXT(1)=1
+ text(1)=2
+
+ B0=2
+ DO 7 I=1,9
+7 B(I)=2
+ DO 8 I=10,35
+8 B(I)=1
+ B(14)=4
+ B(36)=0
+ B(37)=0
+ B(38)=3
+ B(39)=6
+ B(40)=5
+ B(41)=10
+ B(42)=10
+ B(43)=7
+ B(44)=12
+ B(45)=10
+ B(46)=11
+ DO 9 I=47,54
+9 B(I)=10
+ B(55)=9
+ B(56)=10
+ B(57)=10
+ B(58)=10
+ B(59)=8
+ DO 10 I=60,70
+10 B(I)=10
+ CALL DAATA
+ RETURN
+ END
+
+ SUBROUTINE DAATA
+ IMPLICIT INTEGER (A-Z)
+ DIMENSION X(169),Y(169)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, JK1, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT,JK2,NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEXT, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+ REAL FRACT,NU
+ EQUIVALENCE(TRANS1(1,1),X(1))
+ EQUIVALENCE(TRANS2(1,1),Y(1))
+ X( 1)=1
+ X( 2)=1
+ X(3)=9
+ X(4)=1
+ X(5)=1
+ X(6)=1
+ X(7)=1
+ X(8)=1
+ X(9)=16
+ X(10)=17
+ X(11)=1
+ X(12)=1
+ X(13)=1
+ X(14)=2
+ X(15)=4
+ X(16)=4
+ X(17)=2
+ X(18)=4
+ X(19)=2
+ X(20)=2
+ X(21)=2
+ X(22)=16
+ X(23)=17
+ X(24)=2
+ X(25)=4
+ X(26)=2
+ X(27)=1
+ X(28)=5
+ X(29)=10
+ X(30)=1
+ X(31)=1
+ X(32)=5
+ X(33)=5
+ X(34)=5
+ X(35)=16
+ X(36)=17
+ X(37)=5
+ X(38)=5
+ X(39)=5
+ X(40)=1
+ X(41)=7
+ X(42)=11
+ X(43)=7
+ X(44)=1
+ X(45)=7
+ X(46)=7
+ X(47)=7
+ X(48)=16
+ X(49)=17
+ X(50)=7
+ X(51)=7
+ X(52)=7
+ X(53)=1
+ X(54)=5
+ X(55)=12
+ X(56)=7
+ X(57)=5
+ X(58)=15
+ X(59)=1
+ X(60)=7
+ X(61)=16
+ X(62)=17
+ X(63)=7
+ X(64)=7
+ X(65)=7
+ X(66)=1
+ X(67)=6
+ X(68)=13
+ X(69)=7
+ X(70)=1
+ X(71)=6
+ X(72)=6
+ X(73)=6
+ X(74)=16
+ X(75)=17
+ X(76)=6
+ X(77)=6
+ X(78)=6
+ X(79)=1
+ X(80)=6
+ X(81)=12
+ X(82)=7
+ X(83)=6
+ X(84)=15
+ X(85)=1
+ X(86)=7
+ X(87)=16
+ X(88)=17
+ X(89)=7
+ X(90)=7
+ X(91)=7
+ X(92)=1
+ X(93)=7
+ X(94)=12
+ X(95)=7
+ X(96)=7
+ X(97)=7
+ X(98)=7
+ X(99)=7
+ X(100)=16
+ X(101)=17
+ X(102)=7
+ X(103)=7
+ X(104)=7
+ X(105)=1
+ X(106)=8
+ X(107)=11
+ X(108)=1
+ X(109)=8
+ X(110)=8
+ X(111)=8
+ X(112)=8
+ X(113)=16
+ X(114)=17
+ X(115)=8
+ X(116)=8
+ X(117)=8
+ X(118)=1
+ X(119)=6
+ X(120)=14
+ X(121)=6
+ X(122)=6
+ X(123)=6
+ X(124)=6
+ X(125)=6
+ X(126)=16
+ X(127)=17
+ X(128)=6
+ X(129)=6
+ X(130)=6
+ DO 13 I=131,143
+13 X(I)=3
+ X(138)=1
+ DO 14 I=144,156
+14 X(I)=1
+ X(152)=17
+ DO 15 I=157,169
+15 X(I)=18
+ Y(1)=1
+ Y(2)=3
+ Y(3)=5
+ Y(4)=8
+ Y(5)=3
+ Y(6)=10
+ Y(7)=10
+ Y(8)=16
+ Y(9)=18
+ Y(10)=1
+ Y(11)=10
+ Y(12)=10
+ Y(13)=20
+ Y(14)=2
+ Y(15)=1
+ Y(16)=1
+ Y(17)=8
+ Y(18)=1
+ Y(19)=14
+ Y(20)=14
+ Y(21)=16
+ Y(22)=18
+ Y(23)=1
+ Y(24)=14
+ Y(25)=1
+ Y(26)=20
+ Y(27)=1
+ Y(28)=3
+ Y(29)=1
+ Y(30)=9
+ Y(31)=11
+ Y(32)=14
+ Y(33)=14
+ Y(34)=16
+ Y(35)=18
+ Y(36)=1
+ Y(37)=14
+ Y(38)=14
+ Y(39)=20
+ Y(40)=1
+ Y(41)=3
+ Y(42)=6
+ Y(43)=8
+ Y(44)=12
+ Y(45)=14
+ Y(46)=14
+ Y(47)=16
+ Y(48)=18
+ Y(49)=1
+ Y(50)=14
+ Y(51)=14
+ Y(52)=20
+ Y(53)=1
+ Y(54)=4
+ Y(55)=7
+ Y(56)=8
+ Y(57)=4
+ Y(58)=15
+ Y(59)=15
+ Y(60)=16
+ Y(61)=18
+ Y(62)=1
+ Y(63)=14
+ Y(64)=14
+ Y(65)=20
+ Y(66)=1
+ Y(67)=3
+ Y(68)=1
+ Y(69)=8
+ Y(70)=13
+ Y(71)=14
+ Y(72)=14
+ Y(73)=16
+ Y(74)=18
+ Y(75)=1
+ Y(76)=14
+ Y(77)=14
+ Y(78)=20
+ Y(79)=1
+ Y(80)=4
+ Y(81)=7
+ Y(82)=8
+ Y(83)=4
+ Y(84)=15
+ Y(85)=15
+ Y(86)=16
+ Y(87)=18
+ Y(88)=1
+ Y(89)=14
+ Y(90)=14
+ Y(91)=20
+ Y(92)=1
+ Y(93)=3
+ Y(94)=7
+ Y(95)=8
+ Y(96)=3
+ Y(97)=14
+ Y(98)=14
+ Y(99)=16
+ Y(100)=18
+ Y(101)=1
+ Y(102)=14
+ Y(103)=14
+ Y(104)=20
+ Y(105)=1
+ Y(106)=3
+ Y(107)=6
+ Y(108)=10
+ Y(109)=3
+ Y(110)=14
+ Y(111)=14
+ Y(112)=16
+ Y(113)=18
+ Y(114)=1
+ Y(115)=14
+ Y(116)=14
+ Y(117)=20
+ Y(118)=1
+ Y(119)=3
+ Y(120)=1
+ Y(121)=8
+ Y(122)=3
+ Y(123)=14
+ Y(124)=14
+ Y(125)=16
+ Y(126)=18
+ Y(127)=1
+ Y(128)=14
+ Y(129)=14
+ Y(130)=20
+ DO 50 I=131,168
+50 Y(I)=1
+ Y(138)=17
+ Y(153)=19
+ Y(169)=21
+ RETURN
+ END
+
+ SUBROUTINE OPTDEF
+ IMPLICIT INTEGER (A-Z)
+C --- READS INPUT PARAMETERS; APPROPRIATELY MODIFIES OPTION WORD
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT, NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEXT, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+
+ character param
+ common /par/ param(256),dl, pozopt
+c param - line of program parameters
+c dl - length of program parameters
+c pozopt - options position in param
+C
+C
+ ext = 0
+ if(pozopt .gt.dl .or. dl .eq. 0) go to 1000
+ 80 k = pozopt
+ do 101 pozopt = k,dl
+ if(param(pozopt).ne.' ') go to 102
+101 continue
+ go to 1000
+102 if ( ext .eq. 1) go to 105
+ ext = 1
+ if(param(pozopt).eq.';') go to 9999
+ if(param(pozopt) .ne.',') go to 105
+ pozopt = pozopt+1
+ go to 80
+105 i = 0
+ do 103 k = pozopt, dl
+ if(i.ge.70) go to 107
+ i = i+1
+ 103 skok(i) = ichar(param(k))
+ 107 i = i+1
+ do 112 k = i,70
+ 112 skok(k) = 0
+ go to 2000
+1000 continue
+
+cvax ------added
+cps write(*,1)
+cps1 format (
+cps * ' Specify compilation options : (default = D-S-L-O+T+M+I+)'$)
+
+cps 3 do 111 k=1,70
+cps111 skok(k) = 0
+cps read (*,2) skok
+cps2 format(70a1)
+ 2000 continue
+ K=1
+C
+10 znak = iand(X'ff', skok(k))
+ K=K+1
+ IF (ZNAK.EQ.ICHAR(' ')) GO TO 10
+ IF (ZNAK.EQ.ICHAR(',')) GO TO 10
+ IF (ZNAK.EQ.0) GOTO 9999
+C
+20 sign = iand(X'ff', skok(k))
+ K=K+1
+ IF (SIGN.EQ.ICHAR(' ')) GOTO 20
+ IF (SIGN.EQ.ICHAR('+')) GOTO 30
+ IF (SIGN.EQ.ICHAR('-')) GOTO 30
+C --- BAD OPTION
+29 call ffputcs(0,' Bad option - ignored')
+ call ffputnl(0)
+ go to 9999
+30 IF (ZNAK.GT.ICHAR('Z')) ZNAK = ZNAK-32
+C IF (ZNAK.EQ.ICHAR('C')) GOTO 670
+ IF (ZNAK.EQ.ICHAR('D')) GOTO 680
+C IF (ZNAK.EQ.ICHAR('F')) GOTO 700
+cdsw IF (ZNAK.EQ.ICHAR('I')) GOTO 730
+ IF (ZNAK.EQ.ICHAR('L')) GOTO 760
+cdsw IF (ZNAK.EQ.ICHAR('M')) GOTO 770
+ IF (ZNAK.EQ.ICHAR('O')) GOTO 790
+C --- IF (ZNAK.EQ.ICHAR('P')) GOTO 800
+cdeb
+ IF (ZNAK.EQ.ICHAR('S')) GOTO 830
+cdeb
+ IF (ZNAK.EQ.ICHAR('T')) GOTO 840
+ if (znak.eq.ichar('H')) go to 620
+ GOTO 29
+c opcja 'H' - duza pamiec
+c rozpoznano 'H'
+620 continue
+#if ! ( DISABLE_H == 1 )
+ if(sign.eq.ichar('+')) go to 625
+ c0m(4) = ibclr(c0m(4),12)
+ go to 10
+625 c0m(3) = ibset(c0m(3),12)
+#endif
+ go to 10
+C ROZPOZNANO 'C'
+C ****** "ROZPOZNANO" MEANS "RECOGNIZED"
+C 670 IF (SIGN.EQ.ICHAR('+')) GO TO 675
+C C0M(4)=IBCLR(C0M(4),5)
+C GOTO 10
+C 675 C0M(3)=IBSET(C0M(3),5)
+C GOTO 10
+C ROZPOZNANO 'D'
+680 IF (SIGN.EQ.ICHAR('+')) GO TO 685
+ C0M(4)=IBCLR(C0M(4),4)
+ GOTO 10
+685 C0M(3)=IBSET(C0M(3),4)
+ GOTO 10
+C ROZPOZNANO 'F'
+C 700 IF (SIGN.EQ.ICHAR('+')) GOTO 705
+C C0M(4)=IBCLR(C0M(4),6)
+C GOTO 10
+C 705 C0M(3)=IBSET(C0M(3),6)
+C GOTO 10
+C ROZPOZNANO 'I'
+C 730 IF (SIGN.EQ.ICHAR('+')) GOTO 735
+C C0M(4)=IBCLR(C0M(4),2)
+C GOTO 10
+C 735 C0M(3)=IBSET(C0M(3),2)
+C GOTO 10
+C ROZPOZNANO 'L'
+760 IF (SIGN.EQ.ICHAR('+')) GOTO 765
+ C0M(4)=IBCLR(C0M(4),15)
+ GOTO 10
+765 C0M(3)=IBSET(C0M(3),15)
+ GOTO 10
+C ROZPOZNANO 'M'
+C 770 IF (SIGN.EQ.ICHAR('+')) GOTO 775
+C C0M(4)=IBCLR(C0M(4),0)
+C GOTO 10
+C 775 C0M(3)=IBSET(C0M(3),0)
+C GOTO 10
+C ROZPOZNANO 'O'
+790 IF (SIGN.EQ.ICHAR('+')) GOTO 795
+ C0M(4)=IBCLR(C0M(4),1)
+ GOTO 10
+795 C0M(3)=IBSET(C0M(3),1)
+ GOTO 10
+C ROZPOZNANO 'P'
+C 800 IF (SIGN.EQ.ICHAR('+')) GOTO 805
+C C0M(4)=IBCLR(C0M(4),14)
+C GOTO 10
+C 805 C0M(3)=IBSET(C0M(3),14)
+C GOTO 10
+cdeb added
+C ROZPOZNANO 'S'
+ 830 IF (SIGN.EQ.ICHAR('+')) GOTO 835
+ C0M(4)=IBCLR(C0M(4),13)
+ GOTO 10
+ 835 C0M(3)=IBSET(C0M(3),13)
+ GOTO 10
+cdeb
+C ROZPOZNANO 'T'
+840 IF (SIGN.EQ.ICHAR('+')) GOTO 845
+ C0M(4)=IBCLR(C0M(4),3)
+ GOTO 10
+845 C0M(3)=IBSET(C0M(3),3)
+ GOTO 10
+9999 C0M(2)=IOR(C0M(3),IAND(C0M(4),C0M(2)))
+
+ call ffputnl(0)
+ call ffputcs(0,' Pass One')
+ call ffputnl(0)
+ call ffputnl(0)
+
+ RETURN
+ END
+
+ SUBROUTINE MESS
+C----------------DISPLAYS END-OF-PASS INFORMATION
+ IMPLICIT INTEGER (A-Z)
+C
+#include "blank.h"
+ COMMON /MJLMSG/ IERC, MSG
+ integer*4 msg
+C ---
+ IOP(1) = IOP(1)+1
+ IF (IERC .EQ. 0) RETURN
+C ---
+ IF (IOP(1).LE.7) RETURN
+C ---
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ subroutine it1
+C--------------LACZNIK 1-------------------------------
+C - PRZESYLA CZESC INFORMACJI ZE SCANNERA NA PLIKI
+C - INICJUJE ZMIENNE DLA POTRZEB ANALIZY DEKLARACJI
+C I POZNIEJSZYCH PRZEBIEGOW
+C - SORTUJE TOPOLOGICZNIE DEKLARACJE TYPOW
+C
+C OPIS W DOKUMENTACJI: D.I.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 116
+C...........................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C INSERTION OF
+ LOGICAL BTEST
+C BECAUSE OF TYPECONFLICT 03.01.84
+C+
+C-
+CALL STREAM
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+ integer*4 msg
+ COMMON /MJLMSG/ IERC, MSG
+CALL #
+ LOGICAL SYSPP
+cdsw COMMON /SYSPP/ SYSPP
+ common /sysppc/ syspp
+
+
+cdeb ----------- added ----------------------
+c new common blockfor the debugger
+ common /debug/ deb,breakt(500),brnr,maxbr
+ logical deb
+c deb = true - compilation with the debugger
+c breakt - array of static break points
+c brnr - index in breakt
+c maxbr - maximal number of static break points
+cdeb ----------------------------------------
+
+C
+cdsw DATA IDENT /4HIT1 /
+C
+ IERC = 0
+ MSG = 'it1 '
+C ---ZBADANIE, CZY MA BYC DZIALANIE W OTOCZENIU SYSPP
+ SYSPP = BTEST(COM(3), 14)
+C*********** SCIAGNIECIE BUFOROW PLIKOW
+C --- BUFFERS NEED NOT BE FETCHED IN THE 'ONE-OVERLAY' VERSION
+C CALL MGTBUF
+ NEMPTY = 0
+ CALL APARS
+C*********** INICJALIZACJA ZMIENNYCH GLOBALNYCH
+ IPMEM(ISFIN-8) = COM(2)
+ LPMF = ISFIN -9
+C
+ LPML = 1
+ COM(4) = LPMEM
+ INSYS = .TRUE.
+C*********** INICJALIZACJA PROTOTYPOW SYSTEMOWYCH
+ CALL INIT
+C*********** SORTOWANIE TOPOLOGICZNE TYPOW
+ I = LPMEM
+C...........POBRANIE ELEMENTU ZE SLOWNIKA
+ 100 PROT = IPMEM(I)
+C ... PROT - PROTOTYP, KTOREGO DEKLARACJE SA SORTOWANE
+ IF (PROT.NE. 0) CALL TORD(PROT)
+ I = I-1
+ IF (I .GE. ISFIN) GOTO 100
+C************ PRZESLANIE BUFOROW
+C --- BUFFERS NEED NOT BE SENT IN THE 'ONE-OVERLAY' VERSION
+C CALL MPTBUF
+ CALL MESS
+ IF (SYSPP) CALL MPPMES
+cdeb CALL DSW
+cdeb ------------- added ---------------
+ if(deb.and..not.errflg) go to 1000
+ call dsw
+ return
+1000 call ts1
+cdeb -----------------------------------
+ END
+
+
+ SUBROUTINE MPPMES
+C------------------DRUKUJE INFORMACJE O PRZYLACZENIU BIBLIOTEKI SYSPP
+ IMPLICIT INTEGER(A-Z)
+CALL STREAM
+CALL #
+ call ffputspaces(6,10)
+ call ffputcs(6,'-- SYSPP LIBRARY ADDED')
+ call ffputnl(6)
+ RETURN
+ END
+
+
+ SUBROUTINE APARS
+C---------------PRZESYLA TABLICE HASH-U SCANNERA NA STRUMIEN SC
+C DO POCZATKOWYCH BLOKOW
+C
+C OPIS W DOKUMENTACJI: D.I.3
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 338
+C.............................................................
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ x hash(8000)
+cdsw X IPMEM(5000)
+CALL STREAM
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+
+CALL #
+C
+C------PRZEWINIECIE STRUMIENIA SC
+ CALL SEEK(IBUF3, 0)
+C------PRZEPISANIE BLOKOW TWORZACYCH TABLICE HASH-U
+cdsw ----------------------
+c dodane przepisywanie tablicy hash2
+ do 100 i=1,8000,256
+ call put (ibuf3,hash(i))
+100 continue
+ RETURN
+ END
+ SUBROUTINE INIT
+C--------------INICJALIZACJA PROTOTYPOW SYSTEMOWYCH
+C
+C OPIS W DOKUMENTACJI: D.I.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 1079
+C...............................................................
+C
+ IMPLICIT INTEGER (A-Z)
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL #
+ logical btest
+ LOGICAL SYSPP
+cdsw COMMON /SYSPP/ SYSPP
+ common /sysppc/syspp
+C
+C.....NAZWY HASH-U ZE SCANNERA
+C#F
+ COMMON /HNAMES/ INTNM, RENM, BOOLNM, CHRNM, CORNM,
+ X PROCNM, TEXTNM, FILENM
+
+C
+ common /option/opt
+
+ common /prefs/lprefs
+c lprefs - ostatnio przydzielony numer w prefixset
+
+c grpref - numer prefiksu klasy IIUWGRAPH
+c mousepref - numer prefiksu klasy MOUSE
+
+c system class prototypes:
+ common /syspro/prgraph, prmouse
+c prgraph - prototype of IIUWGRAPH
+c prmouse - prototype of MOUSE
+
+cdsw DATA INTNM,RENM,BOOLNM,CHRNM,CORNM,PROCNM,TEXTNM,FILENM
+cdsw X /24,40,8,16,2919,2785,48,56/
+C NATTR - ATRYBUT "-1" (1 SLOWO, 2 DOMYSLNE)
+cdsw DATA INHEX1,INHEX2,INHEX3,INHEX4,INHEX5,INHEX6,INHEX7,INHEX8,
+cdsw XINHEX9,INHEX10,INHEX11,INHEX12,INHEX13,INHEX14,INHEX15,XX
+cdsw X/Z0008,Z8008,Z000A,Z000B,ZC007,ZC005,Z000C,Z0004,ZC00E,Z8051,
+cdsw X Z8061,Z0051,Z0061,ZC061,ZC051,Z0004/
+cdsw --------------------------------------------------------------
+c #8008 --> -#7ff8, #c007 --> -#3ff9, #c005 --> -#3ffb,
+c #c00e --> -#3ff2, #8051 --> -#7faf, #8061 --> -#7f9f,
+c #c061 --> -#3f9f, #c051 --> -#3faf
+ data inhex1,inhex2,inhex3,inhex4,inhex5,inhex6,inhex7,inhex8,
+ * inhex9,inhx10,inhx11,inhx12,inhx13,inhx14,inhx15,xx
+ */x'0008',-x'7ff8', x'000a',x'000b',
+ *-x'3ff9',-x'3ffb', x'000c',x'0004',
+ *-x'3ff2',-x'7faf',-x'7f9f',x'0051',
+ * x'0061',-x'3f9f',-x'3faf',x'0004'/
+cdeb ------------------- added ----------------
+ data inhx16, inhx17,inhx18 / x'0091', x'8091', x'c091' /
+cdeb ----------------------------------------
+
+ intnm=24
+ renm=40
+ boolnm = 8
+ chrnm = 16
+ cornm = 2919
+ procnm = 2785
+ textnm = 48
+ filenm = 56
+
+cdsw ----------------------------------------------------------------
+ NATTR = LPML+2
+ IPMEM(LPML) = -1
+ LPML = LPML+1
+C
+C NRINT
+ NRINT = MGETM(3, 41)
+ IPMEM(NRINT) = INHEX1
+C NRRE
+ NRRE = MGETM(3,41)
+ IPMEM(NRRE) = INHEX2
+C
+C NRBOOL
+ NRBOOL = MGETM(3, 41)
+ IPMEM(NRBOOL) = INHEX3
+C
+C NRCHR
+ NRCHR = MGETM (3, 41)
+ IPMEM(NRCHR) = INHEX3
+C#F
+C
+C NRFILE
+ NRFILE = MGETM(3, 41)
+ IPMEM(NRFILE) = INHEX4
+C
+C NRCOR
+ NRCOR = MGETM(9, 41) + 7
+ IPMEM(NRCOR) = INHEX5
+C NUMER W ZBIORZE PREFIKSOW ORAZ SLOWO Z TEGO ZBIORU
+ IPMEM(NRCOR-1) = 0
+ CALL MSETB(NRCOR, 0)
+ CALL MSETB(NRCOR, 2)
+C
+C NRPROC
+ NRPROC = MGETM(9, 41) + 7
+ IPMEM(NRPROC) = INHEX6
+ IPMEM(NRPROC-6) = 1
+ CALL MSETB(NRPROC, 0)
+ CALL MSETB(NRPROC, 1)
+ CALL MSETB(NRPROC, 2)
+C
+C NRTEXT
+ NRTEXT = MGETM(3, 41)
+ IPMEM(NRTEXT) = INHEX7
+C
+C NRUNIV
+ NRUNIV = MGETM(9, 41) + 7
+ IPMEM(NRUNIV) = INHEX8
+ IPMEM(NRUNIV-6) = 2
+ IPMEM(NRUNIV-5) = XX
+ IPMEM(NRUNIV-4) = XX
+ IPMEM(NRUNIV-3) = XX
+C
+C NRNONE
+ NRNONE = MGETM(9, 41) + 7
+ IPMEM(NRNONE) = INHEX9
+ IPMEM(NRNONE-6) = 2
+ CALL MSETB(NRNONE, 2)
+C
+cdsw
+c stala intsize
+ wrds1 = mgetm(6, 41)+4
+ ipmem(wrds1-3) = nrint
+ ipmem(wrds1+1) = 1
+ ipmem(wrds1) = X'0081'
+#if ( WSIZE == 4 )
+ i = 4
+#else
+ i = 2
+#endif
+ if( btest(opt,12) ) i = 4
+ ipmem(wrds1-1) = i
+c stala realsize
+ wrds2 = mgetm(6, 41)+4
+ ipmem(wrds2-3) = nrint
+ ipmem(wrds2+1) = 1
+ ipmem(wrds2) = X'0081'
+ i = 4
+ if( btest(opt,12) ) i = 8
+ ipmem(wrds2-1) = i
+
+C
+C......INICJALIZACJA BLOKU SYSTEMOWEGO
+ NBLSYS = MGETM(21, 41) + 2
+ IPMEM(NBLSYS) = 1
+ IPMEM(NBLSYS+3) = 2
+C USTAWIENIE SL DLA COROUTINE I PROCESS
+ IPMEM(NRCOR-1) = NBLSYS
+ IPMEM(NRPROC-1) = NBLSYS
+
+C inicjalizacja lprefs
+ lprefs = 2
+C
+C......INICJALIZACJA FUNKCJI I PROCEDUR STANDARDOWYCH
+C ...PARAMETRY - ICH OPISY
+C INPR - INPUT REAL
+ INPR = MGETM(6,41)+4
+ IPMEM(INPR-3) = NRRE
+ IPMEM(INPR+1) = 1
+ IPMEM(INPR) = INHX10
+C OUTPR - OUTPUT REAL (I RESULT)
+ OUTPR = MGETM(6,41)+4
+ IPMEM(OUTPR-3) = NRRE
+ IPMEM(OUTPR+1) = 1
+ IPMEM(OUTPR) = INHX11
+C INPI - INPUT INTEGER
+ INPI = MGETM(6, 41) +4
+ IPMEM(INPI-3) = NRINT
+ IPMEM(INPI+1) = 1
+ IPMEM(INPI) = INHX12
+C OUTPI - OUTPUT INTEGER (I RESULT)
+ OUTPI = MGETM(6, 41) +4
+ IPMEM(OUTPI-3) = NRINT
+ IPMEM(OUTPI+1) = 1
+ IPMEM(OUTPI) = INHX13
+C INPCH - INPUT CHARACTER
+ INPCH = MGETM(6, 41) +4
+ IPMEM(INPCH-3) = NRCHR
+ IPMEM(INPCH+1) = 1
+ IPMEM(INPCH) = INHX12
+C OUTPCH - OUTPUT CHARACTER (I RESULT)
+ OUTPCH = MGETM(6, 41) +4
+ IPMEM(OUTPCH-3) = NRCHR
+ IPMEM(OUTPCH+1) = 1
+ IPMEM(OUTPCH) = INHX13
+C OUTPB - OUTPUT BOOLEAN (I RESULT)
+ OUTPB = MGETM(6, 41) +4
+ IPMEM(OUTPB-3) = NRBOOL
+ IPMEM(OUTPB+1) = 1
+ IPMEM(OUTPB) = INHX13
+C OUTACH - OUTPUT ARRAYOF CHAR (I RESULT)
+ OUTACH = MGETM(6, 41) +4
+ IPMEM(OUTACH-4) = 1
+ IPMEM(OUTACH-3) = NRCHR
+ IPMEM(OUTACH+1) = 1
+ IPMEM(OUTACH) = INHX14
+C#F NOWE OPISY PARAMETROW DLA PLIKOW
+C INPF - INPUT FILE
+ INPF = MGETM(6, 41) + 4
+ IPMEM(INPF - 3) = NRFILE
+ IPMEM(INPF+1) = 1
+ IPMEM(INPF) = INHX15
+C INPTX - INPUT TEXT (=STRING)
+ INPTX = MGETM(6, 41) + 4
+ IPMEM(INPTX-3) = NRTEXT
+ IPMEM(INPTX+1) = 1
+ IPMEM(INPTX) = INHX12
+C INPARI - INPUT ARRAYOF INTEGER
+ INPARI = MGETM(6, 41) + 4
+ IPMEM(INPARI-4) = 1
+ IPMEM(INPARI-3) = NRINT
+ IPMEM(INPARI+1) = 1
+ IPMEM(INPARI) = INHX15
+cdsw --------------- for exec---
+c inparch - input arrayof char
+ inparch = mgetm(6,41)+4
+ ipmem(inparch) = inhx15
+ ipmem(inparch+1) = 1
+ ipmem(inparch-3) = nrchr
+ ipmem(inparch-4) = 1
+c
+c
+cdeb --------------- added ------------
+c inoui - inout integer
+ inoui = mgetm(6,41)+4
+ ipmem(inoui-3) = nrint
+ ipmem(inoui+1) = 1
+ ipmem(inoui) = inhx16
+
+c inour - inout real
+ inour = mgetm(6,41)+4
+ ipmem(inour-3) = nrre
+ ipmem(inour+1) = 1
+ ipmem(inour) = inhx17
+
+c inouari - inout arrayof integer
+ inouari = mgetm(6,41)+4
+ ipmem(inouari-4) = 1
+ ipmem(inouari-3) = nrint
+ ipmem(inouari+1) = 1
+ ipmem(inouari) = inhx18
+cdeb -------------------------------
+C
+C ...LISTY PARAMETROW FORMALNYCH
+C FPL1 - (INPUT REAL): REAL
+ FPL1 = MGETM(2, 41)
+ IPMEM(FPL1) = INPR
+ IPMEM(FPL1+1) = OUTPR
+C FPL2 - (INPUT INTEGER, INPUT INTEGER, INPUT INTEGER): INTEGER
+ FPL2 = MGETM(4, 41)
+ IPMEM(FPL2) = INPI
+ IPMEM(FPL2+1) = INPI
+ IPMEM(FPL2+2) = INPI
+ IPMEM(FPL2+3) = OUTPI
+C FPL3 - (INPUT REAL): INTEGER
+ FPL3 = MGETM(2, 41)
+ IPMEM(FPL3) = INPR
+ IPMEM(FPL3+1) = OUTPI
+C FPL4 - :BOOLEAN
+ FPL4 = MGETM(1, 41)
+ IPMEM(FPL4) = OUTPB
+C
+C FPL5 - (INPUT INTEGER): CHARACTER
+ FPL5 = MGETM(2, 41)
+ IPMEM(FPL5) = INPI
+ IPMEM(FPL5+1) = OUTPCH
+C
+C FPL6 - (INPUT CHARACTER): INTEGER
+ FPL6 = MGETM(2, 41)
+ IPMEM(FPL6) = INPCH
+ IPMEM(FPL6+1) = OUTPI
+C
+C FPL7 - (OUTPUT INTEGER, INTEGER, INTEGER)
+ FPL7 = MGETM(3, 41)
+ IPMEM(FPL7) = OUTPI
+ IPMEM(FPL7+1) = OUTPI
+ IPMEM(FPL7+2) = OUTPI
+C FPL8 - (INPUT TEXT, OUTPUT ARRAY OF CHAR)
+ FPL8 = MGETM(2, 41)
+ IPMEM(FPL8) = INPTX
+ IPMEM(FPL8+1) = OUTACH
+C#F NOWE LISTY DLA PLIKOW
+C
+C FPL9 - (INPUT FILE, INPUT INTEGER, INPUT ARRAYOF INTEGER)
+ FPL9 = MGETM(3, 41)
+ IPMEM(FPL9) = INPF
+ IPMEM(FPL9+1) = INPI
+ IPMEM(FPL9+2) = INPARI
+C
+C FPL10 - (INPUT FILE, INPUT TEXT)
+ FPL10 = MGETM(2, 41)
+ IPMEM(FPL10) = INPF
+ IPMEM(FPL10+1) = INPTX
+
+cdeb ------------ added --------------
+c fpl11 - (input integer, inout arrayof integer, integer,
+c arrayof integer, real, integer)
+ fpl11 = mgetm(6,41)
+ ipmem(fpl11) = inpi
+ ipmem(fpl11+1) = inouari
+ ipmem(fpl11+2) = inoui
+ ipmem(fpl11+3) = inouari
+ ipmem(fpl11+4) = inour
+ ipmem(fpl11+5) = inoui
+
+c fpl12 - (input integer, inout integer, integer,arrayof integer)
+ fpl12 = mgetm(4,41)
+ ipmem(fpl12) = inpi
+ ipmem(fpl12+1) = inoui
+ ipmem(fpl12+2) = inoui
+ ipmem(fpl12+3) = inouari
+
+c fpl18 - (input file,file)
+ fpl18 = mgetm(2,41)
+ ipmem(fpl18) = inpf
+ ipmem(fpl18+1) = inpf
+cdeb --------------------------------
+cdsw ---------- for exec ------
+c fpl13 - (input arrayof char, input arrayof char):integer
+ fpl13 = mgetm(2,41)
+ ipmem(fpl13) = inparch
+ ipmem(fpl13+1) = outpi
+c fpl14 - input file, input integer, input integer
+ fpl14 = mgetm(3,41)
+ ipmem(fpl14) = inpf
+ ipmem(fpl14+1) = inpi
+ ipmem(fpl14+2) = inpi
+c fpl15 - input integer, input integer, input integer, input integer
+ fpl15 = mgetm(4,41)
+ ipmem(fpl15) = inpi
+ ipmem(fpl15+1) = inpi
+ ipmem(fpl15+2) = inpi
+ ipmem(fpl15+3) = inpi
+c fpl16 - input file, output integer
+ fpl16 = mgetm(2,41)
+ ipmem(fpl16) = inpf
+#if ( WSIZE == 4 )
+ ipmem(fpl16+1) = outpi
+#else
+CPS - pozycja w pliku : REAL ??? !
+ ipmem(fpl16+1) = outpr
+#endif
+
+
+C ...PROTOTYPY FUNKCJI STANDARDOWYCH I ICH WLACZENIE DO LISTY HASHU
+C INOT: FUNCTION(INPUT X: INTEGER) : INTEGER
+ CALL MSTAFP(2613, FPL2+2, 2, 0, NRINT, OUTPI, -1, nblsys)
+C IOR: FUNCTION (INPUT X: INTEGER INPUT Y: INTEGER): INTEGER
+ CALL MSTAFP(335, FPL2+1, 3, 0, NRINT, OUTPI, -2, nblsys)
+C IAND: FUNCTION (INPUT X: INTEGER INPUT Y: INTEGER): INTEGER
+ CALL MSTAFP(307, FPL2+1, 3, 0, NRINT, OUTPI, -3, nblsys)
+C ISHFT: FUNCTION (INPUT X: INTEGER INPUT Y: INTEGER): INTEGER
+ CALL MSTAFP(2605, FPL2+1, 3, 0, NRINT, OUTPI, -4, nblsys)
+C EOF: FUNCTION: BOOLEAN
+cfile CALL MSTAFP(1841, FPL4, 1, 0, NRBOOL, OUTPB, 39, nblsys)
+C ENTIER: FUNCTION (INPUT X: REAL): INTEGER
+ CALL MSTAFP(2589, FPL3, 2, 0, NRINT, OUTPI, 15, nblsys)
+C RANDOM: FUNCTION: REAL
+ CALL MSTAFP(2599, FPL1+1, 1, 0, NRRE, OUTPR, 12, nblsys)
+C TIME: FUNCTION: INTEGER
+ CALL MSTAFP(1731, FPL3+1, 1, 0, NRINT, OUTPI, 13, nblsys)
+C SQRT: FUNCTION (INPUT X: REAL): REAL
+ CALL MSTAFP(1619, FPL1, 2, 0, NRRE, OUTPR, 14, nblsys)
+C ROUND: FUNCTION (INPUT X: REAL): INTEGER
+ CALL MSTAFP(1487, FPL3, 2, 0, NRINT, OUTPI, 16, nblsys)
+C EOLN: FUNCTION: BOOLEAN
+cfile CALL MSTAFP(2579, FPL4, 1, 0, NRBOOL, OUTPB, 74, nblsys)
+C ORD: FUNCTION(INPUT X: CHARACTER): INTEGER
+ CALL MSTAFP(2571, FPL6, 2, 0, NRINT, OUTPI, -5, nblsys)
+C CHR: FUNCTION(INPUT X: INTEGER): CHARACTER
+ CALL MSTAFP(2575, FPL5, 2, 0, NRCHR, OUTPCH, -6, nblsys)
+C SIN: FUNCTION(INPUT REAL): REAL
+ CALL MSTAFP(2563, FPL1, 2, 0, NRRE, OUTPR, 23, nblsys)
+C COS: FUNCTION(INPUT REAL): REAL
+ CALL MSTAFP(2559, FPL1, 2, 0, NRRE, OUTPR, 24, nblsys)
+C TAN: FUNCTION (INPUT REAL): REAL
+ CALL MSTAFP(2555, FPL1, 2, 0, NRRE, OUTPR, 25, nblsys)
+C EXP: FUNCTION (INPUT REAL): REAL
+ CALL MSTAFP(2551, FPL1, 2, 0, NRRE, OUTPR, 26, nblsys)
+C LN: FUNCTION (INPUT REAL): REAL
+ CALL MSTAFP(717, FPL1, 2, 0, NRRE, OUTPR, 27, nblsys)
+C ATAN: FUNCTION (INPUT REAL): REAL
+ CALL MSTAFP(2547, FPL1, 2, 0, NRRE, OUTPR, 28, nblsys)
+C IMIN: FUNCTION (INUT INTEGER, INPUT INTEGER): INTEGER
+ CALL MSTAFP(331, FPL2+1, 3, 0, NRINT, OUTPI, 19, nblsys)
+C IMIN3: FUNCTION (INPUT INTEGER, INPUT INTEGER, INPUT INTEGER): INTEGER
+ CALL MSTAFP(2521, FPL2, 4, 0, NRINT, OUTPI, 21, nblsys)
+C IMAX: FUNCTION (INPUT INTEGER, INPUT INTEGER): INTEGER
+ CALL MSTAFP(2515, FPL2+1, 3, 0, NRINT, OUTPI, 20, nblsys)
+C IMAX3: FUNCTION (INPUT INTEGER, INPUT INTEGER, INPUT INTEGER): INTEGER
+ CALL MSTAFP(2511, FPL2, 4, 0, NRINT, OUTPI, 22, nblsys)
+C XOR: FUNCTION(INPUT X,Y: INTEGER): INTEGER
+ CALL MSTAFP(237, FPL2+1, 3, 0, NRINT, OUTPI, -7, nblsys)
+C PANELKEYS: FUNCTION: INTEGER
+ CALL MSTAFP (1203, FPL3+1, 1, 0, NRINT, OUTPI, 18, nblsys)
+C ENDRUN : PROCEDURE
+ CALL MSTAFP(2483, 0, 0, 0, 0, 0, 29, nblsys)
+C RANSET: PROCEDURE(INPUT X: REAL)
+ CALL MSTAFP(2375, FPL1, 1, 0, 0, 0, 30, nblsys)
+C CLOCK: PROCEDURE(OUTPUT H,M,S: INTEGER)
+ CALL MSTAFP(2369, FPL7, 3, 0, 0, 0, 31, nblsys)
+C OPTIONS: FUNCTION: INTEGER
+ CALL MSTAFP(1105, FPL3+1, 1, 0, NRINT, OUTPI, 32, nblsys)
+C DATE: PROCEDURE (OUTPUT Y,M,D: INTEGER)
+ CALL MSTAFP(1685, FPL7, 3, 0, 0, 0, 36, nblsys)
+C EXECPAR: FUNCTION: ARRAYOF CHAR
+ CALL MSTAFP(2357, FPL8+1, 1, 1, NRCHR, OUTACH, 37, nblsys)
+C UNPACK: FUNCTION( INPUT TEXT): ARRAYOF CHAR
+ CALL MSTAFP(2247, FPL8, 2, 1, NRCHR, OUTACH, 11, nblsys)
+cdsw --- removed ------
+C#F NOWE PROCEDURY DLA PLIKOW
+C REW: PROCEDURE(INPUT FILE)
+cdsw CALL MSTAFP(2339, FPL9, 1, 0, 0, 0, 2, nblsys)
+C AVF: PROCEDURE(INPUT FILE, INPUT INTEGER)
+cdsw CALL MSTAFP(1343, FPL9, 2, 0, 0, 0, 3, nblsys)
+C BVF: PROCEDURE(INPUT FILE, INPUT INTEGER)
+cdsw CALL MSTAFP(1471, FPL9, 2, 0, 0, 0, 4, nblsys)
+C WEO: PROCEDURE(INPUT FILE)
+cdsw CALL MSTAFP( 89, FPL9, 1, 0, 0, 0, 5, nblsys)
+C PUtREC: PROCEDURE(INPUT FILE, INPUT INTEGER, INPUT ARRAYOF INTEGER)
+cdsw CALL MSTAFP(1243, FPL9, 3, 0, 0, 0, 6, nblsys)
+C GETREC: PROCEDURE(INPUT FILE, INPUT INTEGER, INPUT ARRAYOF INTEGER)
+cdsw CALL MSTAFP( 59, FPL9, 3, 0, 0, 0, 7, nblsys)
+C ASS: PROCEDURE(INPUT FILE, INPUT TEXT)
+cdsw CALL MSTAFP(2335, FPL10, 2, 0, 0, 0, 8, nblsys)
+C ASSIN: PROCEDURE(INPUT STRING)
+cdsw CALL MSTAFP(2241, FPL10+1, 1, 0, 0, 0, 9, nblsys)
+C ASSOUT: PROCEDURE(INPUT STRING)
+cdsw CALL MSTAFP(2235, FPL10+1, 1, 0, 0, 0, 10, nblsys)
+cfile --------------- added ----------------------
+c reset: procedure(input file)
+ call mstafp(2253,fpl9,1,0,0,0,78, nblsys)
+c rewrite:procedure(input file)
+ call mstafp(2259,fpl9,1,0,0,0,79, nblsys)
+c unlink:procedure(input file)
+ call mstafp(2087,fpl9,1,0,0,0,80, nblsys)
+c seek:procedure(input file,input integer, input integer)
+ call mstafp(2091,fpl14,3,0,0,0,81, nblsys)
+c position : function(input file):integer
+#if ( WSIZE == 4 )
+ call mstafp(2023, fpl16, 2, 0, nrint, outpi, 84, nblsys)
+#else
+ call mstafp(2023, fpl16, 2, 0, nrre, outpr, 84, nblsys)
+#endif
+c memavail : function:integer
+ call mstafp(7847, fpl2+3, 1, 0, nrint, outpi, 98, nblsys)
+c exec:function(input arrayof char):integer
+ call mstafp(2101,fpl13,2,0,nrint,outpi,99, nblsys)
+C
+cdeb ------------ debugger ------------
+c db01ox:procedure(nr:integer; inout ref1:arrayof integer,
+c offset:integer, ref2:arrayof integer, realval:real,
+c intval:integer );
+ call mstafp(7759,fpl11,6,0,0,0,150, nblsys)
+
+c sccd01ox : procedure(nr:integer; inout max,lp:integer, bufor:arrayof int );
+ call mstafp(7739,fpl12,4,0,0,0,151, nblsys)
+
+c scnd01ox:procedure(output s,k,adres:integer);
+ call mstafp(7747,fpl7,3,0,0,0,152, nblsys)
+
+c db01of : procedure(input f1,f2:file);
+ call mstafp(7753,fpl18,2,0,0,0,153, nblsys)
+
+c db01oe : procedure;
+ call mstafp(7731,0,0,0,0,0, 154, nblsys)
+cdeb -------------------------------------------
+
+cgr ------------- grafika ------------------
+
+c utworzenie klasy IIUWGRAPH
+ prgraph = mstacl(323, nblsys)
+ grpref = lprefs
+
+ outari = mgetm(6,41)+4
+ ipmem(outari-4) = 1
+ ipmem(outari-3) = nrint
+ ipmem(outari+1) = 1
+ ipmem(outari) = inhx14
+
+ toto = mgetm(6,41)
+ ipmem(toto) = inpi
+ ipmem(toto+1) = inpi
+ ipmem(toto+2) = inpi
+ ipmem(toto+3) = inpi
+ ipmem(toto+4) = inpi
+ ipmem(toto+5) = inpi
+
+ toto2 = mgetm(5,41)
+ ipmem(toto2) = inpi
+ ipmem(toto2+1) = inpi
+ ipmem(toto2+2) = inpi
+ ipmem(toto2+3) = inpi
+ ipmem(toto2+4) = inpi
+
+ toto3 = mgetm(10,41)
+ ipmem(toto3) = inpi
+ ipmem(toto3+1) = inpi
+ ipmem(toto3+2) = inpi
+ ipmem(toto3+3) = inpi
+ ipmem(toto3+4) = inpi
+ ipmem(toto3+5) = inpi
+ ipmem(toto3+6) = inpi
+ ipmem(toto3+7) = inpi
+ ipmem(toto3+8) = inpi
+ ipmem(toto3+9) = outpi
+
+ fpl22 = mgetm(9,41)
+ ipmem(fpl22) = inpi
+ ipmem(fpl22+1) = inpi
+ ipmem(fpl22+2) = inpi
+ ipmem(fpl22+3) = inpr
+ ipmem(fpl22+4) = inpr
+ ipmem(fpl22+5) = inpi
+ ipmem(fpl22+6) = inpi
+ ipmem(fpl22+7) = inpi
+ ipmem(fpl22+8) = inpi
+
+ fpl23 = mgetm(3,41)
+ ipmem(fpl23) = inpi
+ ipmem(fpl23+1) = inpi
+ ipmem(fpl23+2) = outari
+
+ toto5 = mgetm(9,41)
+ ipmem(toto5) = inpi
+ ipmem(toto5+1) = inpi
+ ipmem(toto5+2) = inpi
+ ipmem(toto5+3) = inpi
+ ipmem(toto5+4) = inptx
+ ipmem(toto5+5) = inpi
+ ipmem(toto5+6) = inpi
+ ipmem(toto5+7) = inpi
+ ipmem(toto5+8) = outach
+
+ toto6 = mgetm(5,41)
+ ipmem(toto6) = inpi
+ ipmem(toto6+1) = inpi
+ ipmem(toto6+2) = inptx
+ ipmem(toto6+3) = inpi
+ ipmem(toto6+4) = inpi
+
+ toto7 = mgetm(5,41)
+ ipmem(toto7) = inpi
+ ipmem(toto7+1) = inpari
+ ipmem(toto7+2) = inpari
+ ipmem(toto7+3) = inpi
+ ipmem(toto7+4) = inpi
+
+ toto8 = mgetm(8,41)
+ ipmem(toto8) = inpi
+ ipmem(toto8+1) = inpi
+ ipmem(toto8+2) = inpi
+ ipmem(toto8+3) = inpi
+ ipmem(toto8+4) = inpi
+ ipmem(toto8+5) = inpi
+ ipmem(toto8+6) = inpi
+ ipmem(toto8+7) = inpi
+
+c gron:procedure(input integer)
+ call mstafp(85,fpl2,1,0,0,0,100, prgraph)
+
+c groff: procedure
+ call mstafp(2273,0,0,0,0,0,101, prgraph)
+
+c cls: procedure
+ call mstafp(2335,0,0,0,0,0,102, prgraph)
+
+c point: procedure(input integer, input integer)
+ call mstafp(1231,fpl2,2,0,0,0,103, prgraph)
+
+c move: procedure(input integer, input integer)
+ call mstafp(2279,fpl2,2,0,0,0,104, prgraph)
+
+c draw: procedure(input integer, input integer)
+ call mstafp(1719,fpl2,2,0,0,0,105, prgraph)
+
+c hfill: procedure(input integer)
+ call mstafp(189,fpl2,1,0,0,0,106, prgraph)
+
+c vfill: procedure(input integer)
+ call mstafp(2237,fpl2,1,0,0,0,107, prgraph)
+
+c color: procedure(input integer)
+ call mstafp(2231,fpl2,1,0,0,0,108, prgraph)
+
+c style: procedure(input integer)
+ call mstafp(2225,fpl2,1,0,0,0,109, prgraph)
+
+c patern: procedure(input integer,input integer,input integer,input integer,
+c input integer,input boolean)
+ call mstafp(2219,toto,6,0,0,0,110, prgraph)
+
+c intens: procedure(input integer,arrayof int,arrayof int,int,int)
+ call mstafp(2213,toto7,5,0,0,0,111, prgraph)
+
+c pallet: procedure(input integer)
+ call mstafp(2207,fpl2,1,0,0,0,112, prgraph)
+
+c border: procedure(input integer)
+ call mstafp(2201,fpl2,1,0,0,0,113, prgraph)
+
+c video: procedure(input array of integer)
+ call mstafp(2195,fpl9+2,1,0,0,0,114, prgraph)
+
+c hpage: procedure(input integer, input integer, input integer)
+ call mstafp(209,fpl2,3,0,0,0,115, prgraph)
+
+c nocard: function: integer
+ call mstafp(2029,fpl2+3,1,0,nrint,outpi,116, prgraph)
+
+c pushxy: procedure
+ call mstafp(2185,0,0,0,0,0,117, prgraph)
+
+c popxy: procedure
+ call mstafp(2179,0,0,0,0,0,118, prgraph)
+
+c inxpos: function: integer
+ call mstafp(2173,fpl2+3,1,0,nrint,outpi,119, prgraph)
+
+c inypos: function: integer
+ call mstafp(2167,fpl2+3,1,0,nrint,outpi,120, prgraph)
+
+c inpix: function(input integer, input integer): integer
+ call mstafp(2161,fpl2+1,3,0,nrint,outpi,121, prgraph)
+
+c getmap: function(input integer, input integer): array of integer
+ call mstafp(2155,fpl23,3,1,nrint,outari,122, prgraph)
+
+c putmap: procedure(input array of integer)
+ call mstafp(2149,fpl9+2,1,0,0,0,123, prgraph)
+
+c ormap: procedure(input array of integer)
+ call mstafp(2143,fpl9+2,1,0,0,0,124, prgraph)
+
+c xormap: procedure(input array of integer)
+ call mstafp(2137,fpl9+2,1,0,0,0,125, prgraph)
+
+c track: procedure(input integer, input integer,input integer,input integer)
+ call mstafp(2131,toto2,5,0,0,0,126, prgraph)
+
+c inkey: function: integer
+ call mstafp(2299,fpl2+3,1,0,nrint,outpi,127, prgraph)
+
+c hascii: procedure(input integer)
+ call mstafp(2293,fpl2,1,0,0,0,128, prgraph)
+
+c hfont: function(input integer,input integer,input integer,input integer)
+c (intput integer,input integer,input integer,input integer,input integer):
+c integer new name : gscnum
+ call mstafp(2125,toto3,10,0,nrint,outpi,129, prgraph)
+
+c hfont8: function(input int, input int,input int,input int,input string
+c intput int,input int,input int) : arrayof char
+ call mstafp(2119,toto5,9,1,nrchr,outari,130, prgraph)
+
+c outstring: procedure(input int,input int,input string,input int,input int)
+ call mstafp(2113,toto6,5,0,0,0,131, prgraph)
+
+c cirb: procedure(input x,y,rx,ry,start,end,c,motif :integer)
+ call mstafp(1573,toto8,8,0,0,0,132, prgraph)
+
+cdsw -------------- mouse ------------------------
+ prmouse = mstacl(7991, nblsys)
+ mousepref = lprefs
+
+c fpl30 - output int, output bool
+ fpl30 = mgetm(2,41)
+ ipmem(fpl30) = outpi
+ ipmem(fpl30+1) = outpb
+
+c fpl31 - input integer, output integerl, output integer, output integer,
+c output integer, output integer, output integer
+ fpl31 = mgetm(7, 41)
+ ipmem(fpl31) = outpi
+ ipmem(fpl31+1) = outpi
+ ipmem(fpl31+2) = outpi
+ ipmem(fpl31+3) = outpi
+ ipmem(fpl31+4) = outpi
+ ipmem(fpl31+5) = outpi
+ ipmem(fpl31+6) = outpb
+
+ toto4 = mgetm(2, 41)
+ ipmem(toto4) = inpi
+ ipmem(toto4+1) = inpi
+
+
+c init : procedure(mouse,keyboard:integer);
+ call mstafp(7985, toto4, 2, 0, 0, 0,200,prmouse)
+
+c showcursor : procedure;
+ call mstafp(1601, 0, 0, 0, 0, 0, 201, prmouse)
+
+c hidecursor : procedure;
+ call mstafp(7973, 0, 0, 0, 0, 0, 202, prmouse)
+
+c status : procedure(output h,v:integer, l, r, c:boolean)
+ call mstafp(7963, fpl31+2, 5, 0, 0, 0, 203, prmouse)
+
+c setposition : procedure(h,v:integer);
+ call mstafp(7957, fpl2, 2, 0, 0, 0, 204, prmouse)
+
+c getpress : function( output h,v,p,l,r,c : integer) : boolean
+ call mstafp(7945, fpl31, 7, 0, nrbool, outpb, 205, prmouse)
+
+c getrelease : function( output h,v,p,l,r,c : integer) : boolean
+ call mstafp(7937, fpl31, 7, 0, nrbool, outpb, 206, prmouse)
+
+c setwindow : procedure ( l,r,t,b:integer)
+ call mstafp(7887, fpl15, 4, 0, 0, 0, 207, prmouse)
+
+c defcursor : procedure (select, x, y:integer)
+ call mstafp(7917, fpl2, 3, 0, 0, 0, 210, prmouse)
+
+c getmovement : procedure ( input mo,ke:integer)
+ call mstafp(7907, toto4, 2, 0, 0, 0, 211, prmouse)
+
+c setevent : procedure( m:integer )
+c call mstafp(7865 , fpl2, 1, 0, 0, 0, 212, prmouse)
+
+c setspeed : procedure ( speed:integer)
+ call mstafp(7895, fpl2, 1, 0, 0, 0, 215, prmouse)
+
+c setmargins : procedure( l, r, t, b : integer)
+ call mstafp(7927, fpl15, 4, 0, 0, 0, 216, prmouse)
+
+c setthreshold : procedure(t:integer)
+ call mstafp(7877, fpl2, 1, 0, 0, 0, 219, prmouse)
+
+c signal mouseevent
+c call mstasg(7857 , 70, prmouse)
+
+
+C
+C.........UTWORZENIE I WSTAWIENIE DO TABLICY HASHU BLOKU GLOWNEGO
+C PROTOTYPOW SYGNALOW STANDARDOWYCH
+C
+C NUMERROR
+ CALL MSTASG( 987, 1, nblsys)
+C SYSERROR
+ CALL MSTASG(1635, 2, nblsys)
+C LOGERROR
+ CALL MSTASG(2319, 20, nblsys)
+C ACCERROR
+ CALL MSTASG(1305, 21, nblsys)
+C MEMERROR
+ CALL MSTASG( 827, 22, nblsys)
+C CONERROR
+ CALL MSTASG(2311, 23, nblsys)
+C TYPERROR
+ CALL MSTASG(1995, 24, nblsys)
+C
+
+ i = nblsys+10
+C.......UZUPELNIENIE TABLICY HASHU BLOKU GLOWNEGO O TYPY STANDARDOWE
+ XX = INSERT(INTNM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRINT
+ XX = INSERT(RENM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRRE
+ XX = INSERT(BOOLNM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRBOOL
+ XX = INSERT(CHRNM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRCHR
+C#F
+ XX = INSERT(FILENM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRFILE
+ XX = INSERT(CORNM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRCOR
+ XX = INSERT(PROCNM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRPROC
+ XX = INSERT(TEXTNM, IPMEM(I), 41)
+ IPMEM(XX+2) = NRTEXT
+ XX = INSERT(NEMPTY, IPMEM(I), 41)
+ IPMEM(XX+2) = NRUNIV
+cdsw
+c stala intsize
+ xx = insert(2069,ipmem(i),41)
+ ipmem(xx+2) = wrds1
+c stala realsize
+ xx = insert(2061,ipmem(i),41)
+ ipmem(xx+2) = wrds2
+
+
+C
+C
+ LPMSYS = LPML
+C
+C*******INICJALIZACJA SYSPP - W RAZIE POTRZEBY
+ IF (SYSPP) CALL MLSPP
+ RETURN
+ END
+
+cdsw SUBROUTINE MSTASG( HNAME, NRSIG)
+ subroutine mstasg( hname, nrsig, sl)
+C------------- TWORZENIE PROTOTYPU SYGNALU STANDARDOWEGO
+C JEST ON SKROCONY I NIE POSIADA TABLICY HASHU
+C NAZW ATRYBUTOW. OSTATNIM SLOWEM JEST +7.
+C PROCEDURA WYWOLYWANA JEDYNIE Z INIT
+C WERSJA Z DN. 16 05 83
+
+ IMPLICIT INTEGER(A-Z)
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL #
+ data msthex /x'00b1'/
+
+C GENERACJA I INICJLIZACJA PROTOTYPU
+ IPROT = MGETM(9, 41) + 1
+cdsw IPMEM(IPROT-1) = NBLSYS
+ ipmem(iprot-1) = sl
+ IPMEM(IPROT) = MSTHEX
+ IPMEM(IPROT+1) = NRSIG
+C
+C DODANIE NQZWY SYGNALU DO TBLICY HASHU W NBLYS
+cdsw XX = INSERT(HNAME, IPMEM(NBLSYS+10), 41)
+ xx = insert(hname, ipmem(sl+10), 41)
+C NAZWA SYGNALU JEST CLOSED
+ IPMEM(XX+1) = 1
+ IPMEM(XX+2) = IPROT
+ RETURN
+ END
+
+ SUBROUTINE MSTAFP( HNAME, FPLIST, FPLENG, NDIM, NTYPE, NRESLT,
+ x nrfp, sl)
+cdsw X NRFP)
+C----------------PROCEDURA TWORZY PROTOTYP FUNKCJI STANDARDOWEJ
+C I PROCEDURY STANDARDOWEJ - WTEDY NTYPE=0
+C HNAME - NAZWA ZE SCANNERA TWORZONEJ FUNKCJI
+C FPLIST, FPLENG - INDEKS LISTY PAR. FORM. I JEJ DLUGOSC
+C NDIM, NTYPE - TYP FUNKCJI
+C NRESLT - OPIS ATRYBUTU RESULT
+C NRFP - ROZROZNIENIE FUNKCJI - WARTOSC DLA GENERATORA KODU
+c sl - adres prototypu obejmujacego
+C
+C WERSJA Z DNIA: 19.01.82
+C (DLA PROCEDURY INIT)
+C DLUGOSC KODU: 157
+C..................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL #
+C
+C
+CDSW DATA MAFPHEX1,MAFPHEX2 /Z0201,Z0401/
+ data mafhx1, mafhx2 / x'0201',x'0401'/
+
+
+cdsw I = NBLSYS+10
+ i = sl+10
+C
+ IF (NTYPE .EQ. 0) GOTO 100
+C-----FUNKCJA
+ IPROT = MGETM(10, 41) + 5
+ IPMEM(IPROT-5) = NRESLT
+ IPMEM(IPROT-4) = NDIM
+ IPMEM(IPROT-3) = NTYPE
+ IPMEM(IPROT) = mafhx1
+ GOTO 200
+C-----PROCEDURA
+ 100 IPROT = MGETM(7, 41) + 2
+ IPMEM(IPROT) = mafhx2
+C-----OBYDWIE RAZEM
+cdsw 200 IPMEM(IPROT-1) = NBLSYS
+ 200 ipmem(iprot-1) = sl
+ IPMEM(IPROT+1) = 1
+ IPMEM(IPROT+2) = NRFP
+ IPMEM(IPROT+3) = FPLIST
+ IPMEM(IPROT+4) = FPLENG
+ XX = INSERT(HNAME, IPMEM(I), 41)
+ IPMEM(XX+2) = IPROT
+ RETURN
+ END
+
+cdsw new procedure
+
+ integer function mstacl ( hname, sl)
+ implicit integer (a-z)
+
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+
+ common /prefs/lprefs
+c lprefs - ostatnio przydzielony numer w prefixset
+
+ insys = .false.
+ prot = mgetm(33,41) + 7
+ ipmem(prot) = 3
+ ipmem(prot-1) = sl
+ ipmem(prot+9) = 0
+ xx = insert(hname, ipmem(sl+10), 41)
+ ipmem(xx+2) = prot
+c ustawienie prefixset i prefixlist
+ i = mgetm(1,41)
+ ipmem(i) = prot
+ ipmem(prot+22) = i
+ ipmem(prot+23) = 1
+ call msetb(prot,2)
+ lprefs = lprefs+1
+ call msetb(prot,lprefs)
+ ipmem(prot-6) = lprefs
+c inicjalizacja listy atrybutow
+ ipmem(prot+7 ) = prot+5
+ ipmem(prot+5) = nattr
+ mstacl = prot
+ insys = .true.
+ return
+ end
+
+ SUBROUTINE MLSPP
+C-----------------------INICJUJE PROTOTYPY ANALIZY SEMANTYCZNEJ DLA
+C KLASY SYSPP
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+cdsw DATA MLSPHEX1,MLSPHEX2,MLSPHEX3 /ZC007,ZC061,ZC051/
+c #c007 --> -#3ff9, #c061 --> -#3f9f, #c051 --> -#3faf
+ data mlphx1, mlphx2, mlphx3 / -x'3ff9', -x'3f9f',-x'3faf' /
+CALL #
+C
+C----------POPRAWIENIE SLOW +3 I +4 W BLOKU SYSTEMOWYM
+C +4 - JEST SYSPP
+ IPMEM(NBLSYS+4) = 1
+C +3 - OSTATNIO UZYTY NUMER W SENSIE PREFIXSET
+ IPMEM(NBLSYS+3) = IPMEM(NBLSYS+3)+4
+C
+C **** UTWORZENIE KLASY SYSPP
+ SYSPP = MLINCL (2, 3, NBLSYS, NBLSYS)
+ IPMEM(NBLSYS+8) = SYSPP
+C **** UTWORZENIE KLASY PROCES
+ PPROC = MLINCL(2469, 4, SYSPP, SYSPP)
+C --POPRAWIENIE NA COROUTINE
+ CALL MSETB(PPROC, 0)
+ IPMEM(PPROC) = mlphx1
+C **** UTWORZENIE KLASY SLOWNIK
+ SLOW = MLINCL(1609, 5, SYSPP, PPROC)
+C **** UTWORZENIE KLASY SEMAFOR
+ SEM = MLINCL(2477, 6, SYSPP, SLOW)
+C
+C****** WNETRZE KLASY PROCES
+C ----WAITN: FUNCTION: PROCES
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ PROT = MLINFP(2431, PFL, 1, 0, PPROC, PPROC, SEM)
+ PREV = PROT
+C --OPIS PARAMETRU
+ PAR = MLPAR(0, PPROC, 2, mlphx2 , PROT)
+ IPMEM(PROT-5) = PAR
+ IPMEM(PFL) = PAR
+C ----STOPAR: PROCEDURE(INPUT Z: SEMAFOR)
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ PROT = MLINFP(2437, PFL, 1, 0, 0, PPROC, PREV)
+ PREV = PROT
+C --OPIS PF
+ IPMEM(PFL) = MLPAR(0, SEM, 2, mlphx3 , PROT)
+C ----WAITP: FUNCTION(INPUT Y:PROCES): PROCES
+C --LISTA PF
+ PFL = MGETM(2, 41)
+C PROTOTYP
+ PROT = MLINFP(2443, PFL, 2, 0, PPROC, PPROC, PREV)
+ PREV = PROT
+C --OPISY PF
+ IPMEM(PFL) = MLPAR(0, PPROC, 2, mlphx3 , PROT)
+ PAR = MLPAR(0, PPROC, 4, mlphx2 , PROT)
+ IPMEM(PFL+1) = PAR
+ IPMEM(PROT-5) = PAR
+C ----STOPP: PROCEDURE
+ PROT = MLINFP(2449, 0, 0, 0, 0, PPROC, PREV)
+ PREV = PROT
+C ----RESUMEP: PROCEDURE(INPUT X: PROCES)
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ DUPA = DUPA
+C BEZ TEJ DUPY FTS DAJE ZLY KOD WYNIKOWY
+ PROT = MLINFP(2457, PFL, 1, 0, 0, PPROC, PREV)
+ PREV = PROT
+C --OPIS PF
+ IPMEM(PFL) = MLPAR(0, PPROC, 2, mlphx3 , PROT)
+C
+C ***** WNETRZE SLOWNIK (KLASA LINK JEST NIEWIDOCZNA!!!)
+C ----AMEMBER: FUNCTION: PROCES
+C --LISTA PF
+ PFL = MGETM (1, 41)
+C --PROTOTYP
+ PROT = MLINFP(1325, PFL, 1, 0, PPROC, SLOW, PREV)
+ PREV = PROT
+C --OPIS PF
+ PAR = MLPAR(0, PPROC, 2, mlphx2 , PROT)
+ IPMEM(PFL) = PAR
+ IPMEM(PROT-5) = PAR
+C ----DELETE: PROCEDURE(INPUT X: PROCES)
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ PROT = MLINFP(2393, PFL, 1, 0, 0, SLOW, PREV)
+ PREV = PROT
+C --OPIS PF
+ IPMEM(PFL) = MLPAR(0, PPROC, 3, Mlphx3 , PROT)
+C ----MIN: FUNCTION: PROCES
+C --LISTA PF
+ PFL =MGETM(1, 41)
+C --PROTOTYP
+ PROT = MLINFP(835, PFL, 1, 0, PPROC, SLOW, PREV)
+ PREV = PROT
+C --OPIS PF
+ PAR = MLPAR(0, PPROC, 2, MLphx2 , PROT)
+ IPMEM(PFL) = PAR
+ IPMEM(PROT-5) = PAR
+C ----EMPTY: FUNCTION: BOOLEAN
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ PROT = MLINFP(1837, PFL, 1, 0, NRBOOL, SLOW, PREV)
+ PREV = PROT
+C --OPIS PF
+ PAR = MLPAR(0, NRBOOL, 2,mlphx2 , PROT)
+ IPMEM(PFL) = PAR
+ IPMEM(PROT-5) = PAR
+C ----INSERT: PROCEDURE(INPUT X: PROCES)
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ PROT = MLINFP(2405, PFL, 1, 0, 0, SLOW, PREV)
+ PREV = PROT
+C --OPIS PF
+ IPMEM(PFL) = MLPAR(0, PPROC, 2, mlphx3 , PROT)
+C
+C ***** WNETRZE SEMAFOR
+C ----UNLOCKP: PROCEDURE
+C --PROTOTYP
+ PROT = MLINFP(2413, 0, 0, 0, 0, SEM, PREV)
+ PREV = PROT
+C ----LOCKP: PROCEDURE
+C --PROTOTYP
+ PROT = MLINFP(2419, 0, 0, 0, 0, SEM, PREV)
+ PREV = PROT
+C ----UP: PROCEDURE
+C --PROTOTYP
+ PROT = MLINFP(2421, 0, 0, 0, 0, SEM, PREV)
+ PREV = PROT
+C ----TSP: FUNCTION: BOOLEAN
+C --LISTA PF
+ PFL = MGETM(1, 41)
+C --PROTOTYP
+ PROT =MLINFP(2425, PFL, 1, 0, NRBOOL, SEM, PREV)
+C --OPIS PF
+ PAR = MLPAR(0, NRBOOL, 2, mlphx2 , PROT)
+ IPMEM(PFL) = PAR
+ IPMEM(PROT-5) = PAR
+C
+C******I TO JUZ KONIEC INICJALIZACJI
+ RETURN
+ END
+ INTEGER FUNCTION MLINCL(HNAME, PREFNR, SL, PREV)
+C---------------------INICJUJE PROTOTYPY KLAS BIBLIOTECZNYCH Z SYSPP
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+cdsw DATA MLCLHEX1,MLCLHEX2,MLCLHEX3 /ZC003,ZA021,Z8000/
+c #c003 --> -#3ffd, #a021 --> -#5fdf, #8000 --> undef
+ data mlchx1, mlchx2 /-x'3ffd', -x'5fdf' /
+ mlchx2 = ishft(X'0001',15)
+CALL #
+C
+ MLINCL = MGETM(33, 41)+7
+ PREFL = MGETM(1, 41)
+ IPMEM(PREFL) = MLINCL
+ IPMEM(MLINCL-6) = PREFNR
+ IPMEM(MLINCL-3) = 4
+ CALL MSETB(MLINCL, PREFNR)
+ IPMEM(MLINCL-1) = SL
+ IPMEM(MLINCL) = mlchx1
+ IPMEM(MLINCL+1) = mlchx2
+ IPMEM(MLINCL+9) = mlchx3
+ IPMEM(MLINCL+22) = PREFL
+ IPMEM(MLINCL+23) = 1
+C----DOLACZENIE DO LISTY NEXTDECL
+ IPMEM(PREV+2) = MLINCL
+ XX = INSERT(HNAME, IPMEM(SL+10), 41)
+ IPMEM(XX+2) = MLINCL
+ RETURN
+ END
+ INTEGER FUNCTION MLINFP (HNAME, FPLIST, FPLENG, NDIM, NTYPE,
+ X SL, PREV)
+C-----------------------INICJUJE PROTOTYPY FUNKCJI I PROCEDUR Z SYSPP
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+cdsw DATA MLFPHEX1,MLFPHEX2/Z0201,Z0401/
+ data mlfhx1, mlfhx2/x'0201',x'0401'/
+CALL #
+C
+ I = SL+10
+ IF (NTYPE .EQ. 0) GOTO 100
+C-----FUNCKJA
+ MLINFP = MGETM(29, 41)+5
+ IPMEM(MLINFP-4) = NDIM
+ IPMEM(MLINFP-3) = NTYPE
+C ---OPIS ATRYBUTU RESULT POWINIEN BYC WSTAWIONY NA ZEWNATRZ
+ IPMEM(MLINFP) = mlfhx1
+ GOTO 200
+C-----PROCEDURA
+ 100 MLINFP = MGETM(26, 41)+2
+ IPMEM(MLINFP) = mlfhx2
+C-----OBYDWIE
+ 200 IPMEM(MLINFP-1) = SL
+ IPMEM(MLINFP+1) = 1
+ IPMEM(MLINFP+3) = FPLIST
+ IPMEM(MLINFP+4) = FPLENG
+C----DOLACZENIE DO NEXTDECL
+ IPMEM(PREV+2) = MLINFP
+ XX = INSERT(HNAME, IPMEM(I), 41)
+ IPMEM(XX+2) = MLINFP
+ RETURN
+ END
+ INTEGER FUNCTION MLPAR (NDIM, NTYPE, OFF, ZERWRD, SL)
+C----------------WPROWADZA OPIS PARAMETRU FORMALNEGO WRAZ Z OFFSETEM
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL #
+C
+ MLPAR = MGETM(6, 41)+4
+ IPMEM(MLPAR-4) = NDIM
+ IPMEM(MLPAR-3) = NTYPE
+ IPMEM(MLPAR-1) = SL
+ IPMEM(MLPAR) = ZERWRD
+ IPMEM(MLPAR+1) = OFF
+ RETURN
+ END
+ SUBROUTINE TORD (PRNR)
+C--------------PROCEDURA PORZADKUJACA TYPY KLASOWE DEKLAROWANE W PROTO-
+C TYPIE O ADRESIE PRNR . SORTOWANIE TOPOLOGICZNE ODBYWA SIE
+C ZE WZGLEDU NA PREFIKSOWANIE.
+C WYJSCIEM Z PROCEDURY JEST UPORZADKOWANA (W PROTOTYPIE PRNR)
+C LISTA TYPOW W KOLEJNOSCI OBROBKI DEKLARACJI. EWENTUALNE CYKLE
+C SA ROZERWANE.
+C SYGNALIZOWANY BLAD:
+C 399 - TYPY KLASOWE TWORZA CYKL ZE WZGLEDU NA PREFIKSOWANIE
+C (PROCEDURA TSORT)
+C 398 - PREFIKS I TYP PREFIKSOWANY JEST TEN SAM
+C
+C-----------------------------------------------------------------------------
+C POMOCNICZE STRUKTURY DANYCH
+C
+C W CZASIE TWORZENIA GRAFU DO SORTOWANIA UZYWANA JEST LOKALNA TABLICA
+C HASH'U THASH. ELEMENT LISTY HASH'U BEDACY JEDNOCZESNIE ELEMENTEM
+C DO SORTOWANIA MA NASTEPUJACA BUDOWE:
+C --> 0 - NAZWA MODULU
+C +1 - LICZNIK ODWOLAN W CZSIE SORTOWANIA
+C +2 - POCZATEK LISTY NASTEPNIKOW, TZN. ELEMENTOW PREFIKSOWANYCH
+C PRZEZ DANA KLASE
+C +3 - NASTEPNY ELEMENT W LISCIE HASH-U
+C W CZASIE SORTOWANIA - FLAGA "PROCESSED"= 1 GDY ELEMENT JEST
+C JUZ WSORTOWANY
+C +4 - NUMER PROTOTYPU W SLOWNIKU ISDICT,
+C 0 - GDY NAZWA OPISUJE PROTOTYP NIEZADEKLAROWANY W PRNR
+C -1 - GDY TYP DEKLAROWANY BYL WIELOKROTNIE
+C +5 - NEXTZERO - INDEKS NASTEPNEGO ELEMENTU Z ZEROWYM LICZNIKIEM
+C PO WSORTOWANIU - INDEKS ELEMENTU NASTEPNEGO W UTWORZONYM
+C PORZADKU LINIOWYM
+C +6 - INDEKS NASTEPNEGO ELEMENTU W LISCIE DO SORTOWANIA
+C (UZYWANY DO WYKRYCIA CYKLI)
+C +7 - ELEMENT DO SORTOWANIA ODPOWIADAJACY BEZPOSREDNIEMU
+C PREFIKSOWI (UZYWANY PRZY ROZRYWANIU CYKLI)
+C
+C ELEMENT LISTY NASTEPNIKOW (WSKAZYWANEJ PRZEZ SLOWO +2) MA POSTAC
+C --> 0 - ELEMENT DO SORTOWANIA ODPOWIADAJACY TYPOWI PREFIKSOWANEMU,
+C 0 - GDY TEN NASTEPNIK ZOSTAL USUNIETY (ROZERWANY CYKL)
+C +1 - NASTEPNY ELEMENT LISTY
+C
+C ELEMENTY WIELOKROTNIE DEKLAROWANE TWORZA POMOCNICZA LISTE WSKAZY-
+C WANA PRZEZ ZMIENNA ELIST POSTACI:
+C --> 0 - NUMER PROTOTYPU W SLOWNIKU ISDICT
+C +1 - NASTEPNY ELEMENT LISTY
+C
+C
+C TE STRUKTURY PRZECHOWYWANE SA W IPMEM ZA CZESCIA PRZEZNACZONA
+C NA PROROTYPY SYSTEMOWE. REZERWACJA PAMIECI JEST WYKONYWANA PRZEZ
+C PROCEDURE MGETM .
+C
+C-----------------------------------------------------------------------------
+C
+C
+C
+C OPIS W DOKUMENTACJI: D.II.4.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 220
+C..........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL STREAM
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL TC
+ COMMON /TC/ SLIST, ELIST, SNUMB, ILT, ZFIRST, INORD, OUTORD
+CALL #
+C.............................................................................
+C WSTEPNE ZBADANIE PROTOTYPU PRNR
+C SORTOWANIE NIE JEST WYKONYWANE, GDY LISTA TYPOW ZAWIERA MNIEJ NIZ
+C DWA ELEMENTY
+C
+ ILT = IPMEM(PRNR+5)
+ IF (ILT .EQ. 0) RETURN
+ IF ( IPMEM(ILT+1) .EQ. 0) GOTO 300
+C
+C.............................................................................
+C
+C INICJALIZACJA ZMIENNYCH
+ SLIST = 0
+ ELIST = 0
+ SNUMB = 0
+ OLPML = LPML
+ INORD = MGETM(8,0)
+ OUTORD = INORD
+ ZFIRST = 0
+C
+C*******************************************
+C UTWORZENIE GRAFU POWIAZAN ORAZ LIST TYPOW DO SORTOWANIA
+C
+ CALL TGRAPH
+C
+C*******************************************
+C SORTOWANIE TOPOLOGICZNE
+C
+ IF (SNUMB .EQ. 0) GOTO 200
+C --LISTA DO SORTOWANIA JEST PUSTA
+C
+ CALL TZLINK
+C -- LACZENIE W LISTE ELEMENTOW Z ZEROWYM LICZNIKIEM
+C
+ 100 CALL TSORT
+ IF (SNUMB .EQ. 0) GOTO 200
+C -- GDY SNUMB JEST ROZNE OD ZERA, TO ISTNIEJE CYKL. WOWCZAS
+C ROZERWANIE CYKLU I MODYFIKACJA GRAFU ORAZ LISTY ELEMENTOW
+C Z ZEROWYM LICZNIKIEM I PONOWNE SORTOWANIE
+C
+ CALL TSPLIT
+ GOTO 100
+C
+C********************************************
+C ODTWORZENIE LISTY TYPOW W KOLEJNOSCI DO OBROBKI
+C DEKLARACJI
+C
+ 200 CALL TORDER(PRNR)
+ LPML = OLPML
+ RETURN
+C
+C************************************************
+C SPRAWDZENIE, CZY TYP DO SORTOWANIA NIE JEST PREFIKSOWANY
+C PRZEZ SAMEGO SIEBIE
+ 300 ILT = IPMEM(ILT)
+C ILT - NUMER W ISDICT PROTOTYPU SORTOWANEGO
+ ILT = IPMEM(ILT)
+C ILT - PROTOTYP SORTOWANY
+ IF ( IPMEM(ILT+2) .EQ. NEMPTY) RETURN
+C PROTOTYP NIE JEST PREFIKSOWANY - POWROT
+ NAME = IPMEM(ILT+10)
+ IF ( NAME .NE. IPMEM(ILT+2) ) RETURN
+C NAZWY SA ROZNE - POWROT
+C ...SYGNALIZACJA BLEDU
+ LINE = IPMEM(ILT+9)
+ CALL MERR(398, NAME)
+ IPMEM(ILT+2) = NEMPTY
+ IPMEM(ILT) = 7
+C ZAMARKOWANIE USZKODZONEJ LISTY PARAMETROW
+ RETURN
+ END
+ SUBROUTINE TGRAPH
+C--------------UTWORZENIE GRAFU POWIAZAN, LIST TYPOW DO SORTOWANIA
+C ORAZ WIELOKROTNIE DEKLAROWANYCH
+C
+C OPIS W DOKUMENTACJI: D.II.4.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 590
+C......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+cdsw INTEGER THASH(8)
+ dimension thash(8)
+C POMOCNICZA TABLICA HASH-U
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL TC
+ COMMON /TC/ SLIST, ELIST, SNUMB, ILT, ZFIRST, INORD, OUTORD
+CALL STREAM
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+CALL #
+C ZNACZENIE ZMIENNYCH
+C ILT - ELEMENT LISTY DEKLAROWANYCH TYPOW
+C DICTN - NUMER PROTOTYPU W SLOWNIKU ISDICT
+C PRAD - ADRES PROTOTYPU W IPMEM
+C NAME - NAZWA TYPU
+C IHT - ELEMENT LISTY HASH-U
+C
+C
+ DO 10 I=1,8
+ THASH(I) = 0
+ 10 CONTINUE
+C
+C*****************************************************************************
+C PRZETWARZANIE ELEMENTU ILT Z LISTY TYPOW
+C
+ 1000 DICTN = IPMEM(ILT)
+ PRAD = IPMEM(DICTN)
+ NAME = IPMEM(PRAD+10)
+ IF (NAME .EQ. NEMPTY) GOTO 2500
+C NAZWA PUSTA - SKOK DO WPISANIA TYPU DO LISTY TYPOW ZLE
+C ZADEKLAROWANYCH
+C---------------------------------------------------------------------------
+C SPRAWDZENIE, CZY TYP NIE JEST PREFIKSOWANY SAM SOBA
+ IF ( NAME .NE. IPMEM(PRAD+2) ) GOTO 1050
+ LINE = IPMEM(PRAD+9)
+ CALL MERR(398, NAME)
+ IPMEM(PRAD+2) = NEMPTY
+ IPMEM(PRAD) = 7
+ 1050 CONTINUE
+C-----------------------------------------------------------------------------
+C ODSZUKANIE NAZWY
+ IHT = MEMBER(NAME, THASH)
+ IF (IHT .EQ. 0) GOTO 1100
+C.....TU - NAZWA JUZ WYSTEPUJE W LISCIE HASH-U
+C SPRAWDZENIE ,CZY POPRZEDNIE WYSTAPIENIE NIE BYLO DEKLARACJA NAZWY,
+C JESLI TAK -TO BLAD
+ IF ( IPMEM(IHT+4) .NE. 0) GOTO 2000
+C BYLA WCZESNIEJ DEKLAROWANA, SKOK DO ZLE ZADEKLAROWANEGO TYPU
+ GOTO 1200
+C
+C-----------------------------------------------------------------------------
+C TWORZENIE NOWEGO ELEMENTU LISTY DO SORTOWANIA
+ 1100 IHT = MGETM(8,0)
+ IPMEM(IHT) = NAME
+ I = IAND (ISHFT(NAME,-1), 7) + 1
+ IPMEM(IHT+3) = THASH(I)
+ THASH(I) = IHT
+C WLACZENIE DO LISTY TYPOW DO SORTOWANIA
+ IPMEM(IHT+6) = SLIST
+ SLIST = IHT
+ SNUMB = SNUMB+1
+C WPISANIE NUMERU PROTOTYPU
+ 1200 IPMEM(IHT+4) = DICTN
+C
+C-----------------------------------------------------------------------------
+C SPRAWDZENIE PREFIKSOWANIA
+C INP - NAZWA BEZPOSREDNIEGO PREFIKSU
+ INP = IPMEM(PRAD+2)
+ IF (INP .EQ. 0) GOTO 5000
+C TYP NIE JEST PREFIKSOWANY - SKOK DO POBRANIA NASTEPNEGO
+C ELEMENTU LISTY TYPOW
+C-----------------------------------------------------------------------------
+C WYSZUKANIE NAZWY PREFIKSU
+C PRAD - ELEMENT DO SORTOWANIA ODPOWIADAJACY PREFIKSOWI
+ PRAD = MEMBER (INP, THASH)
+ IF (PRAD .NE. 0) GOTO 1300
+C SKOK, GDY ELEMENT ODPOWIADAJACY PREFIKSOWI JEST JUZ
+C W LISCIE DO SORTOWANIA
+C WPROWADZENIE NOWEGO OPISU
+ PRAD = MGETM(8, 0)
+ IPMEM(PRAD) = INP
+ I = IAND (ISHFT(INP,-1), 7) + 1
+ IPMEM(PRAD+3) = THASH(I)
+ THASH(I) = PRAD
+ IPMEM(PRAD+6) = SLIST
+ SLIST = PRAD
+ SNUMB = SNUMB + 1
+C--------UTWORZENIE POWIAZANIA
+ 1300 I = MGETM(2,0)
+ IPMEM(I) = IHT
+ IPMEM(I+1) = IPMEM(PRAD+2)
+ IPMEM(PRAD+2) = I
+ IPMEM(IHT+7) = PRAD
+ IPMEM(IHT+1) = 1
+C-------PRZEJSCIE DO POBIERANIA NASTEPNEGO ELEMENTU LISTY TYPOW
+ GOTO 5000
+C
+C-----------------------------------------------------------------------------
+C TYPY ZLE ZADEKLAROWANE
+C
+C------TYPY DEKLAROWANE WIELOKROTNIE
+ 2000 IF ( IPMEM(IHT+4) .EQ. -1) GOTO 2500
+C-------PRZESUNIECIE TYPU WCZESNIEJ DEKLAROWANEGO DO LISTY TYPOW
+C ZLE ZADEKLAROWANYCH
+ INP = IHT
+ I = IPMEM(INP+4)
+ IPMEM(INP+4) = -1
+ IHT = MGETM(2,0)
+ IPMEM(IHT) = I
+ IPMEM(IHT+1) = ELIST
+ ELIST = IHT
+C-------USUNIECIE KRAWEDZI W PREFIKSIE TEGO TYPU
+ IHT = IPMEM(INP+7)
+C IHT - GDY ROZNE OD ZERA JEST OPISEM ELEMENTU ODPOWIADAJACEGO
+C PREFIKSOWI
+ IF (IHT .EQ. 0) GOTO 2500
+C.....USUNIECIE KRAWEDZI W LISCIE NASTEPNIKOW PREFIKSU
+ IHT = IPMEM(IHT+2)
+C IHT - ELEMENT LISTY NASTEPNIKOW
+ 2100 IF (IHT .EQ. 0) GOTO 2500
+ IF ( IPMEM(IHT) .EQ. INP) GOTO 2200
+C TO BYL ELEMENT ODPOWIADAJACY POLACZENIU
+ IHT = IPMEM(IHT+1)
+ GOTO 2100
+ 2200 IPMEM(IHT) = 0
+ IPMEM(INP+1) = 0
+C------DOLACZENIE AKTUALNEGO TYPU DO LISTY TYPOW ZLE ADEKLAROWANYCH
+ 2500 IHT = MGETM(2,0)
+ IPMEM(IHT) = DICTN
+ IPMEM(IHT+1) = ELIST
+ ELIST = IHT
+C-----------------------------------------------------------------------------
+C POBRANIE NASTEPNEGO ELEMENTU LISTY TYPOW
+ 5000 ILT = IPMEM(ILT+1)
+ IF (ILT .NE. 0) GOTO 1000
+C*****************************************************************************
+ RETURN
+ END
+ SUBROUTINE TZLINK
+C--------------LACZENIE W LISTE ROZPOCZYNAJACA SIE OD ZFIRST
+C ELEMENTOW Z ZEROWYM LICZNIKIEM.
+C ///PRZY OKAZJI USUNIECIE W PROTOTYPACH PREFIKSOW ODPOWIADAJACYCH
+C TYPOM WIELOKROTNIE DEKLAROWANYM
+C
+C OPIS W DOKUMENTACJI: D.II.4.3
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 135
+C........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL TC
+ COMMON /TC/ SLIST, ELIST, SNUMB, ILT, ZFIRST, INORD, OUTORD
+CALL #
+C
+ I = SLIST
+C*****************************************************************************
+ 1000 IPR = IPMEM(I+7)
+ IF ( IPMEM(IPR+4) .NE. -1) GOTO 1100
+C--------USUNIECIE PREFIKSU Z PROTOTYPU , GDY PREFIKS
+C BYL TYPEM ZLE ZADEKLAROWANYM
+ IPR = IPMEM(I+4)
+ IPR = IPMEM(IPR)
+ IPMEM(IPR+2) = NEMPTY
+ IPMEM(IPR) = 7
+C ZAMARKOWANIE BLEDNEJ LISTY PARAMETROW
+ IPMEM(I+1) = 0
+ 1100 IF (IPMEM(I+1) .NE. 0) GOTO 1500
+ IPMEM(I+5) = ZFIRST
+ ZFIRST = I
+ 1500 IPMEM(I+3) = 0
+C USTAWIENIE FLAGI "PROCESSED"
+C------POBRANIE NASTEPNEGO ELEMENTU LISTY DO SORTOWANIA
+ I = IPMEM(I+6)
+ IF (I .NE. 0) GOTO 1000
+C*****************************************************************************
+ RETURN
+ END
+ SUBROUTINE TSORT
+C--------------SORTOWANIE TOPOLOGICZNE - CZESC WLASCIWA
+C
+C OPIS W DOKUMENTACJI: D.II.4.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 146
+C...................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL TC
+ COMMON /TC/ SLIST, ELIST, SNUMB, ILT, ZFIRST, INORD, OUTORD
+CALL #
+C
+C ILT - ROZPATRYWANY ELEMENT Z ZEROWYM LICZNIKIEM
+ 1000 ILT = ZFIRST
+ IF (ILT .EQ. 0) RETURN
+ ZFIRST = IPMEM(ILT + 5)
+ IPMEM(OUTORD+5) = ILT
+ OUTORD = ILT
+ SNUMB = SNUMB - 1
+C USTAWIENIE FLAGI "PROCESSED"
+ IPMEM(ILT+3) = 1
+C ZMNIEJSZENIE LICZNIKOW ELEMENTOM PREFIKSOWANYM
+C PRZEZ ILT
+C ....SPRAWDZENIE, CZY SORTOWANY PROTOTYP NIE JEST PROTOTYPEM
+C ZLYCH DEKLARACJI - DLA NIEGO NIE MA ELEMENTOW PREFIKSOWANYCH
+ IF (IPMEM(ILT+4) .EQ. -1) GOTO 1500
+C INE - ELEMENT LISTY NASTEPNIKOW
+ INE = IPMEM(ILT+2)
+ 1100 IF (INE .EQ. 0) GOTO 1500
+ I = IPMEM(INE)
+ IF (I .EQ. 0) GOTO 1200
+C SKOK, GDY POLACZENIE JEST OMINIETE
+C I -ELEMENT ODPOWIADAJACY TYPOWI PREFIKSOWANEMU
+ IPMEM(I+1) = 0
+ IPMEM(I+5) = ZFIRST
+ ZFIRST = I
+C POBRANIE NASTEPNEGO ELEMENTU LISTY NASTEPNIKOW
+ 1200 INE = IPMEM(INE+1)
+ GOTO 1100
+C-------POBRANIE NASTEPNEGO ELEMENTUU DO SORTOWANIA
+ 1500 GOTO 1000
+ END
+ SUBROUTINE TSPLIT
+C--------------PROCEDURA ROZRYWANIA CYKLI W LISCIE TYPOW DO
+C PRZETWORZENIA.
+C ZNAJDUJE TYP NAJWCZESNIEJ DEKLAROWANY, USUWA MU PREFIKS
+C I MODYFIKUJE GRAF DO SORTOWANIA
+C SYGNALIZOWANY BLAD:
+C 399 - WYSTAPIENIE CYKLU W PREFIKSOWANIU
+C
+C OPIS W DOKUMENTACJI: D.II.4.5
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 287
+C..................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+CALL STREAM
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL TC
+ COMMON /TC/ SLIST, ELIST, SNUMB, ILT, ZFIRST, INORD, OUTORD
+CALL #
+C
+C ILT - ELEMENT LISTY DO SORTOWANIA ODPOWIADAJACY NAJWCZESNIEJ
+C DEKLAROWANEMU PROTOTYPOWI
+C LMIN - NUMER NAJWCZESNIEJSZEJ LINII
+C IE - AKTUALNY ELEMENT LISTY DO SORTOWANIA
+C
+ IE = SLIST
+ LMIN = 32767
+C NAJWIEKSZA STALA CALKOWITA
+C*****************************************************************************
+ 1000 CONTINUE
+ IF (IPMEM(IE+3) .EQ. 1) GOTO 1500
+C SKOK, GDY TEN TYP JEST JUZ PRZETWORZONY
+ IPR = IPMEM(IE+4)
+ IPR = IPMEM(IPR)
+C IPR - PROTOTYP TYPU ODPOWIADAJACEGO IE
+ LINE = IPMEM(IPR+9)
+ IF (LINE .GT. LMIN) GOTO 1500
+C....TU POTENCJALNY KANDYDAT NA USUNIECIE CYKLU
+C SPRAWDZENIE, CZY TEN ELEMENT WYSTEPUJE W CYKLU
+ ILOOP = IE
+C MARKOWANIE CYKLU
+ 1100 IPMEM(ILOOP+3) = -1
+ ILOOP = IPMEM(ILOOP+7)
+C TO JEST PREFIKS ILOOP
+ IF (IPMEM(ILOOP+3) .NE. -1) GOTO 1100
+ IF (ILOOP .NE. IE) GOTO 1200
+C --WYSTAPIL W CYKLU
+ LMIN = LINE
+ ILT = IE
+C --PRZYWROCENIE STAREGO MARKOWANIA CYKLU
+ 1200 ILOOP = IE
+ 1300 IPMEM(ILOOP+3) = 0
+ ILOOP = IPMEM(ILOOP+7)
+ IF (IPMEM(ILOOP+3) .NE. 0) GOTO 1300
+C---------POBRANIE NASTEPNEGO ELEMENTU LISTY DO SORTOWANIA
+ 1500 IE = IPMEM(IE+6)
+ IF (IE .NE. 0) GOTO 1000
+C
+C*****************************************************************************
+C ILT JEST PROTOTYPEM TYPU NAJWCZESNIEJ DEKLAROWANEGO
+ IPR = IPMEM(ILT+4)
+ IPR = IPMEM(IPR)
+ NAME = IPMEM(IPR+10)
+ LINE = LMIN
+C ...SYGNALIZACJA BLEDU
+ CALL MERR(399, NAME)
+C......USUNIECIE PREFIKSU
+ IPMEM(IPR+2) = 0
+C......"USZKODZENIE" LISTY PARAMETROW
+ IPMEM(IPR) = 7
+C.....WSTAWIENIE DO LISTY ELEMENTOW Z ZEROWYM LICZNIKIEM
+ ZFIRST = ILT
+C------USUNIECIE POWIAZANIA Z PREFIKSEM
+ IPR = IPMEM(ILT+7)
+C IPR - ELEMENT LISTY DO SORTOWANIA ODPOWIADAJACY PREFIKSOWI
+ IPR = IPMEM(IPR+2)
+C LISTA NASTEPNIKOW PREFIKSU
+ 2000 IF (IPMEM(IPR) .EQ. ILT) GOTO 2100
+ IPR = IPMEM(IPR+1)
+ GOTO 2000
+ 2100 IPMEM(IPR) = 0
+ RETURN
+ END
+ SUBROUTINE TORDER (PRNR)
+C------------WPISANIE DO LISTY TYPOW PRNR TYPOW TAM DEKLAROWANYCH
+C W KOLEJNOSCI OBROBKI DEKLARACJI
+C
+C OPIS W DOKUMENTACJI: D.II.4.6
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 117
+C.........................................................................
+C
+C
+ IMPLICIT INTEGER(A-Z)
+C
+CALL BLANK
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+CALL TC
+ COMMON /TC/ SLIST, ELIST, SNUMB, ILT, ZFIRST, INORD, OUTORD
+CALL #
+C
+ ILT = IPMEM(PRNR+5)
+C ILT - ELEMENT LISTY TYPOW DEKLAROWANYCH
+C
+C*****************************************************************************
+C WPISANIE TYPOW Z LISTY INORD (NA POCZATKU JEST STRAZNIK)
+ 1000 INORD = IPMEM(INORD+5)
+ IF (INORD .EQ. 0) GOTO 2000
+ IF (IPMEM(INORD+4) .LE. 0) GOTO 1000
+C -OMINIECIE TYPOW NIELOKALNYCH
+ IPMEM(ILT) = IPMEM(INORD+4)
+ ILT = IPMEM(ILT+1)
+ GOTO 1000
+C*****************************************************************************
+C WPISANIE TYPOW Z LISTY TYPOW ZLE ZADEKLAROWANYCH
+ 2000 IF (ELIST .EQ. 0) RETURN
+ IPMEM(ILT) = IPMEM(ELIST)
+ ELIST = IPMEM(ELIST+1)
+ ILT = IPMEM(ILT+1)
+ GOTO 2000
+ END
+
+
--- /dev/null
+program pr;
+(*********************************************************************)
+(* *)
+(* L O G D E B *)
+(* *)
+
+(*$D-*)
+(*$L-*)
+
+UNIT logdeb : CLASS;
+
+(*====================================================================*)
+(* *)
+(* L O G D E B *)
+(* *)
+(* D E B U G G E R F O R L O G L A N *)
+(* *)
+(* WERSJA 2 ( 1985 ) *)
+(* *)
+(* TERESA PRZYTYCKA *)
+(* *)
+(*====================================================================*)
+
+(*====================================================================*)
+(* *)
+(* Adapted to the Loglan interpreter. *)
+(* Uses special standard procedures DB01OX, SCCD01OX, SCND01OX, *)
+(* DB01OF for communication with the interpreter. *)
+(* Uses auxilliary files name.deb (name - file name of the source *)
+(* loglan program) and temp.deb. *)
+(* The copy of output is printed to the file debug.ech *)
+(* *)
+(* June 1986, D.Szczepanska *)
+(*====================================================================*)
+
+(*============================================*)
+(* WYDRUKI KOTROLNE : STRUMIEN LO *)
+(* +i - PRZED INSTRUKCJA *)
+(* ++i - PO INSTRUKCJI *)
+(* i - szczegolowosc wydrukow kontrolnych *)
+(*============================================*)
+
+
+VAR LINENR:INTEGER, (* NR LINII MIEJSCA WYSTAPIENA PZETWANIA *)
+ LINENR1:INTEGER, (* NR LINII Z OSTATNIM PRZERWANIEM *)
+ linenr2:integer, (* nr linii do ktorej ciagnie sie "do" *)
+ DISPNR :INTEGER, (* DISPNR OBIEKTU,KTOREGO WYKONYWANIE ZOSTALO *)
+ UNITCASE : INTEGER,(* TYP JEDNOSTKI SYNTAKTYCZNEJ PUNKTU *)
+ (* OBSERWACJI *)
+ (* PRZERWANE A POZNIEJ ZMIENNA ROBOCZA DO *)
+ (* PRZECHOWYWANIA WYNIKU Z PROCEDURY FIND *)
+ BREAKT (* TABLICA Z NUMERAMI LINII PUNKTUW LAMIACYCH *)
+ :ARRAYOF INTEGER,
+
+ BREAKTL:ARRAYOF BR, (* TABLICA INFORMACJI O PUNKTACH LAMIACYCH *)
+ (* ODPOWIADAJACA TABLICY BREAKT *)
+ MOV :MOVEL, (* POCZATEK LISTY ZMIAN PONKTOW OBSERWACJI *)
+ CADR, (* ADRES OBIEKTU, KTOREG OBLICZENIA *)
+ (* ZOSTALY PRZERWANE *)
+ OBSADR, (* ADRES OBIEKTU BEDACEGO PUNKTEM *)
+ (* OBSERWACJI *)
+ (* PRZERWANE *)
+ CCOR : ARRAYOF INTEGER, (* AKTYWNA COROUTINA *)
+ ctxt : arrayof integer, (* bufor na biezaca lnie wejsciowa *)
+ protf :FILE , (* PLIK O DOSTEPIE sekwencyjnym,binarny *)
+ (* zawierajacy breakt i prototypy debuggera *)
+ CO :FILE , (* PLIK NA KTORY WYSYLA WYNKI DEBUGGER *)
+ LO :FILE , (* KOPIA WYNIKOW PRZY WLACZONYM ECHU *)
+ PROTNR :INTEGER , (* NR PROTOTYPU OBIEKTU BEDACEGO *)
+ (* PUNKTEM OBSERWACJI *)
+ SINGLESTEP:boolean, (* CZY PRZERWANIE JEST GENEROWANE PO KAZDEJ *)
+ (* INSTRUKCJI LOGLANOWEJ *)
+ GGO :integer, (* GO = TRUE POWODUJE WYKONYWANIE PROGRAMU *)
+ (* BEZ PRZERWAN, JEDYNIE Z SYGNALIZACJA *)
+ (* PUNKTOW LAMIACYCH W POSTACI SLADU *)
+ ECHO : BOOLEAN, (* CZY JEST PISANA KOPIA WYNKOW NA LO *)
+ CBR :BR , (* PUNKT LAMIACY OBSLUGIWANY W BIEZACYM *)
+ (* PRZERWANIU *)
+ CIND : INTEGER, (* INDEKS W TABLICY BIEZACEGO PRZERWANIA *)
+ (* STRUKTURU DANYCH DO KOMUNIKACJI Z BAZA *)
+ (* DANYCH PROTOTYPOW *)
+ IDICT , (* slownik prototypow debuggera *)
+ prot (* tablica zawierajaca prototypy debuggera *)
+ : arrayof integer,
+
+ GOTXT : ARRAYOF INTEGER, (* TEKST INSTRUKCJI GO *)
+
+ first:boolean, (* true for the first interrupt *)
+ lastbr:integer, (* last used in breakt *)
+ DECL : DEC ; (* LISTA BANKOW INSTRUKCJI *)
+
+
+CONST MAXBR=500, (* MAKSYMALNA LICZBA PUNKTOW LAMIACYCH *)
+ MAXIDICT = 499; (* ROZMIAR TABLICY IDICT *)
+VAR I:INTEGER ; (* GLOBaLNA POMOCNICZA *)
+var glovirt:arrayof integer, gloreal:real; (*globalne pomocnicze *)
+var maxprot:integer; (* rozmiar tablicy PROT *)
+
+(*=====================================================================*)
+(* S T R U K T U R Y D A N Y C H *)
+(*=====================================================================*)
+
+UNIT INSTR : CLASS ; (* ELEMENT LISY INSTRUKCJI *)
+VAR MARK:INTEGER,
+ TXT :ARRAYOF INTEGER,
+ NEXT :INSTR;
+END;
+
+UNIT KILLI :PROCEDURE(INOUT I:INSTR);
+VAR J :INSTR;
+BEGIN
+ J:=I;
+ WHILE J=/= NONE DO J:=J.NEXT;KILL(I.TXT);KILL(I);I:=J OD;
+END;
+
+(*---------------------------------------------------------------------*)
+
+UNIT BR : CLASS ; (* OPIS PUNKTU PRZERYWAJACEGO *)
+VAR MARK : INTEGER,
+ CONDTXT : ARRAYOF INTEGER,
+ INS : INSTR ;
+END;
+
+UNIT KILLB :PROCEDURE(INOUT B:BR);
+BEGIN
+ KILL(B.CONDTXT);CALL KILLI(B.INS) ; KILL(B)
+END;
+
+(*-------------------------------------------------------------------*)
+
+UNIT DEC :CLASS; (* ELEMENT LIST BANKOW INSTRUKCJI *)
+VAR ID :INTEGER,
+ INS : INSTR,
+ NEXT : DEC;
+END;
+
+(*----------------------------------------------------------------*)
+
+UNIT MOVEL : CLASS(MARK,PROT :INTEGER,ADR,COR : ARRAYOF INTEGER);
+
+(* ELEMENT LISTY ZMIAN PUNKTOW OBSERWACJI *)
+(* ZNACZENIE ATRYBUTOW : MARK - ETYKIETA INSTRUKCJI MOVE *)
+(* PROT - NR PROTOTUPU PUNKTU OBSERWACJI *)
+(* ADR - ADRES PUNKTU OPSERWACJI *)
+(* COR - OBSERWOWANA COROUTINA *)
+VAR NEXT :MOVEL;
+END;
+(*------------------------------------------------------------------*)
+
+(*===================================================================*)
+(* CONTROL - PREFIX DLA COROUTIN UZYTKOWNIKA, KTORE MOGA BYC *)
+(* OBSERWOWANE PO EWENTUALNYN BLEDZIE WYKONANIA *)
+(*===================================================================*)
+
+(*===================================================================*)
+(* *)
+(* S T R I N G S *)
+(* *)
+(*===================================================================*)
+
+const
+ t1 = " RUNERROR",
+ T2 = " CONERROR",
+ T3 = " LOGERROR",
+ T4 = " TYPERROR",
+ T5 = " SYSERROR",
+ T6 = " NUMERROR",
+ T7 = " MEMERROR",
+ T8 = " UNHANDLED",
+ T9 = " BREAK POINT : ",
+ T10 = " INSTANCE OF ",
+ T11 = " BLOCK",
+ T12 = " HANDLER",
+ T13 = " DECLARED IN LINE",
+ T14 = " --- END OF LIST ---",
+ T15 = " NOT IMPLEMENTED",
+ T16 = " ARRAY OF",
+ T17 = " OF ",
+ T18 = " FORMAL TYPE",
+ T19 = " NONE VALUE OF FORMAL TYPE",
+ T20 = " INTEGER",
+ T21 = " BOOL",
+ T22 = " CHAR",
+ T23 = " REAL",
+ T24 = " STRING",
+ T25 = " TRUE",
+ T26 = " FALSE",
+ T27 = " !!! ERROR NR",
+ T28 = " LINENR :",
+ t29 = " OBSERVATION POINT:";
+
+
+(*============================================================*)
+(* CONTROL - prefix for user's coroutines *)
+(*============================================================*)
+
+UNIT CONTROL:CLASS;
+
+HANDLERS
+WHEN ACCERROR : writeln(co,t1); call runerror;
+WHEN CONERROR : writeln(co,t2); call runerror;
+WHEN LOGERROR : writeln(co,t3); call runerror;
+WHEN TYPERROR : writeln(co,t4); call runerror;
+WHEN SYSERROR : writeln(co,t5); call runerror;
+WHEN NUMERROR : writeln(co,t6); call runerror;
+WHEN MEMERROR : writeln(co,t7); call runerror;
+OTHERS : WRITELN(CO,t8);CALL RUNERROR;
+END HANDLERS;
+BEGIN END;
+
+(*=====================================================================*)
+
+(*******************************************************************)
+(* *)
+(* B R E A K L *)
+(* *)
+(*-----------------------------------------------------------------*)
+(* PROCEDURA WYWOLYWANA PRZEZ PROCEDURE RUNING SYSTEMU :TRACE *)
+(* SPRAWDZA CZY W DANEJ LINI WYKONYWANEGO PROGRAMU JEST *)
+(* ZADEKLAROWANY BREAK POINT.JESLI TAK WYWOLUJE PROCEDURE INTERPR *)
+(*******************************************************************)
+
+UNIT BREAKL:PROCEDURE;
+
+VAR BREAKP: BOOLEAN,
+ K:INTEGER;
+
+BEGIN
+ (* linenr := line of the break point, dispnr := number of interrupted
+ object, cadr := address of interrupted object *)
+ call db01ox(28,glovirt, linenr, cadr, gloreal, dispnr);
+if ggo=4 then call endrun fi;
+if ggo=/=3 then
+ cind := 0; cbr := none;
+(*+ WRITELN(LO," LINENR",LINENR," LINENR1",LINENR1); ++*)
+ if linenr1=0 then first:=true; fi;
+ IF SINGLESTEP OR LINENR1=0 THEN BREAKP:=TRUE
+ ELSE
+ IF LINENR =/= LINENR1 THEN
+ K:=0;
+ FOR I:=1 TO lastbr DO
+ IF BREAKT(I)=LINENR THEN K:=LINENR ; CIND:=I;EXIT FI;
+ OD;
+ IF K =/= 0 THEN CBR:=BREAKTL(CIND);
+ BREAKP:=TRUE
+ FI
+ FI;
+ FI;
+ LINENR1:=LINENR;
+ IF BREAKP THEN (* jest przerwanie w lnii linenr *)
+ if ggo=1 andif linenr > linenr2 then ggo := 0 fi;
+ if ggo = 0 then
+ (* ccor - address of an active coroutine head *)
+ call db01ox (0,ccor,i,glovirt,gloreal,i);
+ CALL INTERPR;
+ else
+ writeln(co,t9,linenr);
+ if echo then writeln(lo,t9,linenr) fi;
+ FI;
+ FI;
+fi;
+END;(* BREAKL *)
+
+
+(************************************************************)
+(* *)
+(* I N I C B R *)
+(* *)
+(*----------------------------------------------------------*)
+(* PROCEDURA INICJALIZUJACA DZIALANIE DEBUGGERA. *)
+(* WYKONUJE KOLEJNO NASTEPUJACE KROKI : *)
+(* 1.ZNAJDUJE ADRES PROTOTYPU INSTRUKCJI BREAKL *)
+(* I EXPORTUJE GO DLA PROCEDURY RAN. SYS. TRACE *)
+(* 2.KOPIUJE ZE STRUMIENIA SC TABLICE HASHU, *)
+(* OTWIERA STRUMIEN SC DLA PROCEDUR LOGLANOWYCH, *)
+(* OTWIERA STRUMIEN CI ,INICJALIZUJE ZMIENNE SCANERA *)
+(* 3.INICJALIZUJE TABLICE BREAKT I DISPT, *)
+(* OTWIERA STRUMIENI SC ORAZ CO *)
+(************************************************************)
+
+UNIT INICBR:PROCEDURE;
+ var i, brnr : integer;
+BEGIN
+ (* files openning *)
+ open(protf,integer, unpack("debug.tmp"));
+ call reset(protf);
+ (* copy of the debugger output *)
+ open(lo,text,unpack( "debug.ech"));
+ call rewrite(lo);
+ open (co,text,unpack("SYS$OUTPUT")); (* output of the debugger *)
+ call rewrite(co);
+ (* breakt *)
+ array breakt dim (1:maxbr);
+ get (protf, brnr);
+ array breaktl dim (1:maxbr);
+ for i:=1 to brnr do
+ get (protf, breakt(i));
+ od;
+ for i := brnr+1 to maxbr do
+ breakt(i) := 0;
+ od;
+ (* initialization of lastbr *)
+ lastbr := 1;
+ while lastbr <= maxbr do
+ if breakt(lastbr) = 0 then exit fi;
+ lastbr := lastbr+1;
+ od;
+ lastbr := lastbr-1;
+ (* idict *)
+ array idict dim (0:maxidict);
+ for i:=0 to maxidict do
+ get(protf,idict(i));
+ od;
+ (* maxprot *)
+ get(protf,maxprot);
+ (* prot *)
+ array prot dim (1:maxprot);
+ for i:=1 to maxprot do
+ get(protf,prot(i));
+ od;
+ (* protf must be removed from directory *)
+ (* killing of protf and transferring the variable lo to the interpreter *)
+ call db01of(protf,lo);
+end inicbr ;
+
+(*********** PROCEDURY TESTUJACE ***************************)
+
+UNIT TEST1:PROCEDURE (INPUT T:ARRAYOF INTEGER );
+
+(* PROCEDURA DRUKUJE ZAWARTOSC TABLICY T *)
+
+VAR I,J:INTEGER;
+BEGIN
+J:=0;
+WRITELN(LO);
+FOR I:=LOWER(T) TO UPPER(T) DO
+ IF J=10 THEN WRITELN(LO); J:=0 FI;
+ WRITE (LO,T(I));
+ J:=J+1;
+OD;
+WRITELN(LO);
+END (* TEST1 *) ;
+
+UNIT OUTREF:PROCEDURE(ADRES:ARRAYOF INTEGER);
+VAR I,J:INTEGER;
+BEGIN
+ (* (i,j) := virtual address refval *)
+ call db01ox(30,adres,i,glovirt,gloreal,j);
+(*+ writeln(lo,"refval",i,j); ++*)
+END;
+
+(************************************************************)
+(* *)
+(* I N T E R P R *)
+(* *)
+(*----------------------------------------------------------*)
+(* PROCEDURA CZYTA I INTERPROTUJE INSTRUKCJE WYSYLANE PRZEZ *)
+(* UZYTKOWNIKA DO DEBUGGERA . *)
+(* WYJSCIE DLA INSTRUKCJI - STRUMIEN CI *)
+(* WYNIKI - STRUMIEN CO *)
+(* EWENTUALNA KOPIA - STRUMIEN LO *)
+(************************************************************)
+
+UNIT INTERPR :PROCEDURE ;
+
+SIGNAL DEBERROR(NR :INTEGER);
+
+VAR S,K,ADRES : INTEGER , (* ZMIENNE NA WYNIKI PROCEDURY SCAN *)
+ STP : BOOLEAN, (* CZY NAPOTKANO INSTRUKCJE GO *)
+ (* BUFORY DLA WARTASCI ZMIENNYCH *)
+ (* 1 -DLA WYNIKOW CZESCIWYCH PRZY ASSIGN *)
+ INTVAL,INTVAL1 : INTEGER,
+ RELVAL,RELVAL1 : REAL ,
+ CHAVAL,CHAVAL1 : CHAR ,
+ REFVAL,REFVAL1 : ARRAYOF INTEGER,
+ R,R1 : INTEGER, (* BUFORY NA LICZBE ARRAYOF *)
+ REFFVAL : ARRAYOF INTEGER,
+ PROTDEB,PROTDEB1,OFFSET1,OFFSET,MODE,MODE1:INTEGER,
+
+ HELP:INSTR,
+ MA:INTEGER; (* MARKER INTERPRETOWANEJ INSTRUKCJI *)
+
+(*------ TYPY PREDEFINIOWANE -----------------*)
+
+CONST INTT = -2,
+ BOOLT =-8,
+ RELT =-5,
+ CHT =-11,
+ STRT =-35,
+ NONT = -12,
+ FORT =-10,
+ filt = -14,
+ cortt = -24,
+ proctt = -33;
+
+(* TYPY JEDNOSTEK SYNTAKTYCZNYCH *)
+
+CONST VART = 5 , (* ZMIENNA *)
+ CORT = 11 , (* COROUTINA *)
+ RECT = 12 , (* REKORD *)
+ BLCT= 1 , (* BLOCK *)
+ HANT = 14 ; (* HANDLER *)
+
+(* KODY ZNAKOW *)
+CONST ELN=13,
+ bl = 32,
+ SR =59;
+
+
+(* S T A L E S C A N E R A *)
+
+(* IDENTYFIKATORY : S=1,ADRES = *)
+CONST ADELETE = 2393,
+ ASTORE = 7803,
+ AGO = 79 ,
+ AREMOVE = 7809,
+ ASSIGN = 1337,
+ AMOVE = 2279,
+ ADECLARE= 7817,
+ AMARK = 7821,
+ AWITH = 7831,
+ AREPORT = 7827;
+const
+(* SLOWA KLUCZOWE S = *)
+ sident = 1,
+ SOUTPUT = 95,
+ SOR = 68,
+ SAND = 67,
+ SNOT = 66,
+ STO = 104,
+ SWHEN = 109,
+ SWRITE = 19,
+ SBREAK = 33,
+ SRETURN = 4 ,
+ SSTEP =102,
+ SDO = 14,
+ SCALL = 9 ,
+ SEND = 80,
+ SEOF = 70,
+ SNONE = 1002,
+ SBOL = 1001, (* ADRES = 1 DLA FALSE 2 TRUE *)
+ SCOLON = 47,
+ SEMICOL = 45,
+ SLPAR = 52,
+ SART = 51,
+ adlt = 5,
+ adle = 6,
+ adeq = 3,
+ adne = 4,
+ adgt = 7,
+ adge = 8,
+ SRPAR = 53,
+ SCOM = 42,
+ SDOT = 38,
+ SAST = 50, (* *-ADRES= ,- -ADRES=4*)
+ adast = 5,
+ admin = 4,
+ adadd = 3,
+ SCONST =1000,
+ kint = 3,
+ kch = 6;
+
+(*==================================================================*)
+(* KOMUNIKACJA Z UZYTKOWNIKIEM *)
+(* ---------------------------- *)
+(* ODBYWA SIE LINIAMI ZA POSREDNICTWEM BUFORA SCANNERA *)
+(*==================================================================*)
+
+UNIT INTEX : PROCEDURE (OUTPUT TX:ARRAYOF INTEGER);
+(* PROCEDURA CZYTA LINE Z BUFORA SCANNERA DO TABLICY TX *)
+VAR CH,MAX:INTEGER;
+BEGIN
+(*+ WRITELN(LO); ++*)
+(*+ WRITELN(LO," INTEX"); ++*);
+ (* max := max from scanner *)
+ call sccd01ox(0,max,i,tx);
+ARRAY TX DIM(1:MAX+1);
+ (* TX := bufor from scanner *)
+ call sccd01ox(1,max,max,tx);
+(*+ for i:=1 to max do ++*)
+(*+ IF(I MOD 10) =1 THEN WRITELN(LO);WRITE(LO," "); FI;++*)
+(*+ WRITE(LO,TX(I));++*)
+(*+ od; ++*)
+ ch := 0; i := 1;
+ do
+ if i >= max then exit fi;
+ if tx(i) = eln then exit fi;
+ ch := tx(i); i := I+1
+ od;
+ if ch=/=sr then
+ tx(i) := sr; i := i+1;
+ fi;
+ tx(i) := eln;
+ I:=I+1;
+ WHILE I<MAX DO tx(i) := bl;I:=I+1 OD;
+END(* INTEX*);
+
+UNIT OUTEX : PROCEDURE (TX:ARRAYOF INTEGER);
+(* PROCEDURA WPISUJE ZAWARTOSC TABLICY TX DO BUFORA SCANERA *)
+ var pom:integer;
+BEGIN
+(*+ WRITELN(LO) ++*);
+(*+ WRITELN(LO," OUTEX"); ++*);
+ (* bufor from scanner:=tx, max form scanner:=upper(tx),lp from scanner:=1 *)
+ i := 1; pom := upper(tx);
+ call sccd01ox(2,pom,i,tx);
+(*+FOR I:=1 TO UPPER(TX) DO ++*)
+(*+ IF (I MOD 10)=1 THEN WRITELN(LO);WRITE(LO," ") FI; ++*)
+(*+ WRITE(LO,TX(I)) ++*);
+(*+ OD;++*)
+END(* OUTEX *);
+
+(*---------------------------------------------------------*)
+(* S C A N *)
+(* WYWOLUJE PROCEDURE ASSEMBLERA SCAN . WYNIK NA ZMIENNYCH *)
+(* GLOBALNYCH S,K,ADRES *)
+(* W PRZYPADKU BLEDU S OTRZYMYJE WARTOSC -1 A K -NUMER *)
+(* BLEDU SYGNALIZOWANY PRZEZ SCANER *)
+(*---------------------------------------------------------*)
+
+UNIT SCAN :PROCEDURE;
+ begin
+ call scnd01ox(s,k,adres);
+(*+ WRITELN(LO," S= ",S," K= ",K," ADRES=",ADRES);++*)
+IF S < 0 THEN RAISE DEBERROR(0) FI;
+END (**** SCAN ******);
+
+UNIT NEWLIN :PROCEDURE;
+(* PRZEJSCIE DO NOWEJ LINII *)
+BEGIN
+ (* scanner variables: sy1:=45; k1:=6; okey:=false;lp:=max+1 *)
+ call sccd01ox(4,i,i,refval);
+END;
+
+(*-----------------------------------------------------------*)
+(* WRID ,WRCH ,WRLIN *)
+(*-----------------------------------------------------------*)
+UNIT WRID:PROCEDURE (I:INTEGER; num : integer);
+
+(* WYPISANIE IDENTYFIKATORA *)
+(* I- ADRES IDENTYFIKATORA W TABLICY HASH *)
+(* num - na tylu miejsach ma byc wypisany identyfikator *)
+
+VAR J,L,K:INTEGER;
+BEGIN
+j := 0;
+DO
+ (* k, l := hash(i), hash(i+1) *)
+ call sccd01ox(3,i,k,refval );
+ i := i+1;
+ call sccd01ox(3,i,l,refval);
+ CALL WRCH(K);
+ IF L<0 THEN I:=-L;J:=J+2;REPEAT FI;
+ EXIT
+OD;
+FOR I:=J+2 TO num DO WRITE(CO," ");
+ IF ECHO THEN WRITE(LO," ") FI;
+ OD;
+END wrid;
+
+UNIT WRCH:PROCEDURE(I:INTEGER);
+(* I- SLOWO ZAWIERAJACE DWA ZNAKI DO WYPISANIA *)
+VAR K:INTEGER,
+ BOO:BOOL;
+BEGIN
+K:=I DIV 64;
+DO
+ CASE K
+ WHEN 0:IF BOO THEN WRITE(CO,"0");
+ IF ECHO THEN WRITE(LO,"0") FI FI;
+ WHEN 60:IF NOT BOO THEN WRITE(CO,"0");
+ IF ECHO THEN WRITE(LO,"0") FI FI;
+ WHEN 46:WRITE(CO," "); IF ECHO THEN WRITE(LO," ") FI;
+ WHEN 1,2,3,4,5,6,7,8,9:WRITE(CO,CHR(48+K));
+ IF ECHO THEN WRITE(LO,CHR(48+K)) FI;
+ OTHERWISE WRITE(CO,CHR(55+K));IF ECHO THEN WRITE(LO,CHR(55+K)) FI;
+ ESAC;
+ IF BOO THEN EXIT FI;
+ K:=I MOD 64;
+ BOO:=TRUE
+OD;
+END wrch;
+
+UNIT WRLIN:PROCEDURE (TXT:ARRAYOF INTEGER);
+VAR J:INTEGER;
+BEGIN WRITE(CO," ");
+IF ECHO THEN WRITE(LO," ") FI;
+I:=1;
+WHILE TXT(I)=/=eln DO
+ WRITE(CO,CHR(TXT(I)));
+ IF ECHO THEN WRITE(LO,CHR(TXT(I))) FI;
+ I:=I+1;
+OD;
+WRITELN(CO) ;IF ECHO THEN WRITELN(LO) FI;
+END wrlin;
+
+(*-----------------------------------------------------------*)
+(* T A K E *)
+(* *)
+(* GRUPA PROCEDUR UMAZLIWIAJACA ODCZYRANIE WARTOSCI OKRESLO- *)
+(* TYPU PRZY OKRESLONYM SPOSOBIE ADRESOWANIA. *)
+(* WYNIKI NA ZMINNYCH INTVAL,RELVAL,CHVAL,REFVAL ODPOWIEDNIO *)
+(* DO TYPU ( BOOL NA INTVAL 0 LUB -1 ) *)
+(*-----------------------------------------------------------*)
+
+
+UNIT TAKEREF :PROCEDURE(OFFSET,TYP : INTEGER );
+
+(* ODCZYTUJE WARTSC O DANYM OFFSECIE W OBIEKCIE WSKAZYWANYM PREZ REF *)
+(* relval/chaval/intval/refval - value from memory *)
+(* refval,offset - address in the memory *)
+BEGIN
+IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
+CASE TYP
+
+WHEN RELT:
+ (* relval := value of the address (refval,offset) *)
+ call db01ox(1,refval,offset,glovirt,relval,intval);
+(*+ WRITELN(LO," TAKEREF RELVAL ",RELVAL)++*);
+
+WHEN BOOLT,INTT :
+ (* intval := value of the address (refval,offset) *)
+ call db01ox(2,refval,offset,glovirt,relval,intval );
+
+WHEN CHT:
+ (* chaval := value of the address (refval,offset ) *)
+ call db01ox(3,refval,offset,glovirt, relval, i);
+ chaval := chr(i);
+(*+ WRITELN(LO," TAKEREF CHAVAL ",CHAVAL)++*);
+
+ WHEN STRT : WRITELN(CO,t15);
+
+OTHERWISE
+ (* refval := value of the address (refval,offset) *)
+ call db01ox(4,refval,offset,glovirt,relval, intval);
+(*+ WRITELN(LO," TAKEREF REFVAL ")++*)
+ESAC
+END takeref;
+
+(*-------------------------------------------------------------*)
+UNIT TAKEARR :PROCEDURE(IND,TYP : INTEGER );
+(* TO CO TAKEREF ALE DLA TABLIC *)
+(* refval/intval/relval/chaval := value of an array element *)
+(* ind - real offset in an array object, refval - address of the array *)
+VAR AP,I :INTEGER;
+BEGIN
+IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
+CASE TYP
+ WHEN RELT : IND:=IND*2;I:=2;
+ WHEN INTT,BOOLT,CHT,STRT :I:=1;
+ OTHERWISE IND:=IND*2;I:=2;
+ESAC;
+(* ind - offset, i - appetite of an array element *)
+(* ap := appetite of the array object, intval := lower*element appetite -3 *)
+ call db01ox(5,refval,intval,glovirt,relval, ap);
+INTVAL:=INTVAL+3; (* LOWER*APPETITE *)
+IF IND < INTVAL OR IND >AP-3+I-INTVAL THEN RAISE DEBERROR(33) FI;
+
+CASE TYP
+WHEN RELT:
+ (* relval := array element *)
+ call db01ox(6,refval,ind,glovirt,relval,intval);
+(*+ WRITELN(LO," TAKEARR IND RELVAL",IND,RELVAL)++*);
+
+WHEN INTT,BOOLT :
+ (* intval := array element *)
+ call db01ox(7,refval,ind,glovirt,relval,intval);
+(*+ WRITELN(LO,"TAKEARR IND, INTVAL ",IND,INTVAL )++*);
+
+WHEN CHT:
+ (* chaval := array element *)
+ call db01ox(8,refval,ind,glovirt,relval,i);
+ chaval := chr(i);
+(*+ WRITELN(LO," TAKEARR IND ,CHAVAL",IND,CHAVAL )++*);
+
+ WHEN STRT :WRITELN(CO,t15);
+
+OTHERWISE
+ (* refval := array element *)
+ call db01ox(9,refval,ind,glovirt,relval,intval);
+(*+ WRITELN(LO," TAKEARR REFVAL ")++*);
+ESAC;
+END (* TAKEARR *);
+
+
+(*-----------------------------------------------------------*)
+(* E N D P R O C E D U R T A K E ... *)
+(*-----------------------------------------------------------*)
+
+(*================ I N F ==================================*)
+
+UNIT INF:PROCEDURE;
+BEGIN
+ WRITE(CO,t10);IF ECHO THEN WRITE(LO,t10) FI;
+ i := idict(protnr);
+ unitcase := prot(i);
+ IF UNITCASE=BLCT (* BLOCK *) THEN WRITE(CO,t11);
+ IF ECHO THEN WRITE(LO,t11) FI;
+ ELSE
+ IF UNITCASE=HANT THEN WRITE(CO, t12);
+ IF ECHO THEN WRITE(LO,t12) FI
+ ELSE
+ CALL WRID(prot(I-1), 10);
+ FI
+ FI;
+ WRITE(CO,t13);IF ECHO THEN WRITE(LO,t13) FI;
+ I:=I+2;
+ WRITELN(CO,prot(I));IF ECHO THEN WRITELN(LO,prot(I)) FI;
+END inf;
+
+(*===========================================================*)
+
+(* ----------------------------------------------------------*)
+(* *)
+(* F I N D L I N *)
+(* reads line number, label or dot *)
+(* returns index (in breakt) of the line identified by the *)
+(* given symbol *)
+(*-----------------------------------------------------------*)
+
+ unit findlin:function:integer;
+ var i:integer;
+ begin
+ if s=sdot then result:=cind
+ else
+ if s=sident then
+ for i:=1 to lastbr do
+ if breakt(i)=/=0 andif breaktl(i)=/=none andif
+ breaktl(i).mark = adres then result := i;
+ exit;
+ fi;
+ od
+ else
+ if s=/=sconst or k=/=kint then raise deberror(1) fi;
+ (* searching for the index in breakt *)
+ for i:=1 to lastbr do
+ if breakt(i) = adres then exit fi;
+ od;
+ if i<=lastbr andif breakt(i) = adres then result := i fi;
+ fi
+ fi;
+ if result=0 then raise deberror(18) fi;
+ (*+ writeln(lo," findlin :", result); ++*)
+ end findlin;
+
+(*-----------------------------------------------------------*)
+(* *)
+(* D E L (DELETE ) *)
+(* *)
+(* PROCEDURA USUWA PUNKT PRZERYWAJACY OKRESLAONY PRZEZ *)
+(* ETYKIETE LUB NUMER LINII *)
+(*-----------------------------------------------------------*)
+
+UNIT DEL : PROCEDURE;
+VAR I:INTEGER;
+BEGIN
+ CALL SCAN;
+ i := findlin;
+ if i=cind then raise deberror(39) fi;
+ if breaktl(i) =/= none then call killb(breaktl(i)) fi;
+ breakt(i) := breakt(lastbr);
+ if cind = lastbr then cind := i fi;
+ breaktl(i) := breaktl(lastbr);
+ lastbr := lastbr-1;
+END (* DEL *)
+
+(*-------------------------------------------------------------*)
+(* *)
+(* B R E (BREAK) *)
+(* *)
+(* DEKLARACJA PUNKTU PRZERYWAJECEGO. PUNKT TEM MOZE BYC *)
+(* OZNACZONY ETYKIETA. MOZE BYC TO WARUNKOWY PUNKT PRZERYWAJACY*)
+(*-------------------------------------------------------------*)
+
+UNIT BRE : PROCEDURE;
+VAR I:INTEGER;
+BEGIN
+ CALL SCAN; (* CZYTAMY NR LINII *)
+ IF S =/= SCONST or K<>kint THEN RAISE DEBERROR(1) FI;
+ FOR I:=1 TO lastbr DO IF BREAKT(I)=ADRES THEN RAISE DEBERROR(17) FI OD;
+ IF lastbr = maxbr THEN RAISE DEBERROR(16) fi;
+ (* NO SPACE IN BREAK POINTS TABLE *)
+ lastbr := lastbr+1;
+ BREAKT(lastbr):=ADRES;
+ BREAKTL(lastbr):=NEW BR;
+ if adres = linenr then cind := lastbr fi;
+ CALL SCAN; (* CZY JEST TO WARUNKOWY PUNKT ? *)
+ IF S=SWHEN THEN CALL INTEX(BREAKTL(lastbr).CONDTXT); (* TAK-ZAPAMIETUJEMY *)
+ (* TEKST Z WARUNKIEM *)
+ (* PRZESKAKUJEMY TEKST WARUNKU *)
+ WHILE S=/=SEMICOL AND NOT(S=sident AND ADRES=AWITH) DO CALL SCAN OD
+ FI;
+ IF S=sident AND ADRES = AWITH THEN CALL SCAN; (* BEDZIE ETYKIETA *)
+ IF S=/=sident THEN RAISE DEBERROR(1) (*IDENTIFIER EXPECTED *) FI;
+ BREAKTL(lastbr).MARK:=ADRES;
+ call scan;
+ FI;
+END (* BRE *);
+
+(*--------------------------------------------------------------------*)
+(* *)
+(* M A R K *)
+(* *)
+(*--------------------------------------------------------------------*)
+
+ unit mark:procedure;
+ (* marks the given break point *)
+ begin
+ call scan;
+ i := findlin;
+ call scan;
+ if s=/= sident then raise deberror(1) fi;
+ if breaktl(i)=none then breaktl(i):=new br fi;
+ breaktl(i).mark:=adres;
+ end mark;
+
+(*--------------------------------------------------------------------*)
+(* *)
+(* G O O *)
+(* *)
+(* return to user program execution *)
+(* - without parameters - standard execution *)
+(* - * - execution with trace, without breaks *)
+(* - line number - execution with traceand without breaks *)
+(* up to the given line, then standard execution *)
+(* - + - execution without trace and without breaks *)
+(* - - - abort *)
+(*--------------------------------------------------------------------*)
+
+ unit goo:procedure;
+ var pom:movel;
+ begin
+ stp := true; (* stop ! *)
+ call scan;
+ if s=sconst and k=3 then
+ ggo:=1; linenr2:=adres
+ else
+ if s=sast then
+ case adres
+ when adast: ggo:=2 (* * *);
+ when adadd: ggo:=3 (* + *);
+ when admin: ggo:=4 (* - *);
+ otherwise raise deberror(34)
+ esac
+ else
+ if s=/= semicol then raise deberror(10) fi
+ fi
+ fi;
+ (* deallocation *)
+ pom := mov.next;
+ while pom=/=none do
+ kill(mov); mov:=pom; pom:=pom.next
+ od;
+ kill (mov)
+ end goo;
+
+(*--------------------------------------------------------------------*)
+(* *)
+(* R E P O R T *)
+(* *)
+(*--------------------------------------------------------------------*)
+UNIT REPORT : PROCEDURE;
+VAR POM:INSTR,
+ P2:DEC,
+ M,I,K1:INTEGER;
+BEGIN
+CALL SCAN;
+IF S=SBREAK THEN (* REPORT BREAK *)
+ CALL SCAN;
+ IF S=SAST THEN (* REPORT BREAK * *)
+ writeln(co);
+ WRITELN(CO," LIST OF BREAK POINTS");
+ WRITELN(CO," LINE NR / MARKER / INSTR. LIST ");
+ FOR I:=1 TO lastbr DO
+ IF BREAKT(I)=/=0 THEN
+ WRITELN(CO," ");WRITE(CO,BREAKT(I):8); write(co, " ");
+ IF BREAKTL(I)=/=NONE THEN
+ IF BREAKTL(I).MARK=/=0 THEN
+ WRITE(CO," ");
+ CALL WRID(BREAKTL(I).MARK, 17)
+ ELSE WRITE(CO," ") FI;
+ IF BREAKTL(I).INS=/=NONE THEN WRITE(CO," YES")
+ ELSE WRITE(CO," NO") FI
+ ELSE WRITE(CO," NO") FI
+ FI
+ OD;
+ WRITELN(CO," ");
+ WRITELN(CO, " ");
+ ELSE (* REPORT BREAK - IDENTYFIKATOR , NR LINII lub kropka *)
+ i := findlin;
+ if i=0 then raise deberror(18) fi; (* break point doesn't exist *)
+ if breaktl(i)=/=none then m:=breaktl(i).mark fi;
+ writeln(co);
+ write(co," BREAK POINT - LINE :", breakt(i));
+ if m=/=0 then write(co," MARKER :"); call wrid(m, 10) fi;
+ writeln(co);
+ if breaktl(i) =/= none then
+ pom := breaktl(i).ins;
+ while pom=/=none do
+ call wrlin(pom.txt);
+ pom := pom.next;
+ od;
+ fi;
+ writeln(co)
+ fi;
+ call scan
+ ELSE (* OCZEKUJEMY REPORT DECLARE *)
+IF ADRES=ADECLARE THEN
+ CALL SCAN;P2 := DECL;
+ IF S =/= sident THEN
+ IF S = SAST THEN (* LISTA WSZYSTKICH BANKOW INSTRUKCJI *)
+ WRITELN(CO," LIST OF DELCARED BANKS :");
+ WHILE P2 =/= NONE DO
+ WRITE(CO," ");CALL WRID(P2.ID, 10);WRITELN(CO);
+ P2 := P2.NEXT;
+ OD;
+ WRITELN(CO)
+ ELSE RAISE DEBERROR(1)
+ FI
+ ELSE (* LISTA INSTRUKCJI BANKU O PODANUM IDENTYFIKATORZE *)
+ WHILE P2=/=NONE DO
+ IF P2.ID = ADRES THEN EXIT FI;P2:=P2.NEXT;
+ OD;
+ IF P2=NONE THEN RAISE DEBERROR(13)
+ ELSE
+ POM := P2.INS;
+ WHILE POM =/= NONE DO
+ CALL WRLIN(POM.TXT);
+ POM := POM.NEXT
+ OD;
+ WRITELN(CO);
+ FI
+ FI;
+ call scan
+else
+ if s=semicol then (* report; *)
+ writeln(co,t9,linenr);write(co,t29);
+ if echo then writeln(lo,t9,linenr); write(lo,t29) fi;
+ call inf;
+ ELSE RAISE DEBERROR(14) FI
+FI
+fi;
+END report;
+
+(*----------------------------------------------------------*)
+(* *)
+(* S T O R E *)
+(* *)
+(* ZWIAZANIE listy INSTRUKCJI Z podanym PUNKTEM *)
+(* przerywajacym *)
+(*----------------------------------------------------------*)
+
+UNIT STORE :PROCEDURE;
+VAR POM,POM1:INSTR,
+ lin : integer;
+BEGIN
+CALL SCAN;
+lin := findlin;
+call scan;
+if s =/= semicol then raise deberror(10) fi;
+if breaktl(lin)=none then breaktl(lin) := new br fi;
+pom,pom1 := breaktl(lin).ins;
+while pom=/=none do pom1:=pom; pom:=pom.next od;
+do
+ call newlin;
+ call scan;
+ if s = send then exit fi;
+ pom := new instr;
+ call intex(pom.txt);
+ if s=sident then pom.mark:=adres fi;
+ if pom1=none then breaktl(lin).ins:=pom
+ else pom1.next:=pom fi;
+ pom1 := pom
+ od
+end store;
+
+(*----------------------------------------------------------*)
+(* *)
+(* R E M O V E *)
+(* *)
+(* USUNIECIE INSTRUKCJI ZWIAZANEJ Z AKTUALNYM PUNKTEM *)
+(* PRZERYWAJECYM. (PODAJE SIE ETYKIETE USUWANEJ INSTRUKCJI) *)
+(*----------------------------------------------------------*)
+
+UNIT REMOVE :PROCEDURE;
+VAR POM,POM1:INSTR;
+var ok:boolean;
+BEGIN
+ CALL SCAN;
+ i := findlin;
+ call scan;
+ if i=0 then raise deberror(18) fi;
+ (* ODCZYTALISMY ETYKIETE ,SZUKAMY INSTRUKCJI DO USUNECIA *)
+ IF BREAKTL(i)=NONE THEN POM:=NONE
+ ELSE POM:=BREAKTL(i).INS
+ FI;
+ pom1 := pom;
+ WHILE POM =/= NONE DO
+ (*+ writeln(lo," marker :", pom.mark); ++*)
+ IF POM.MARK = ADRES THEN (* ZNALEZLISMY, KOPIUJEMY *)
+ ok := true;
+ if pom.next=/= none then
+ if pom = pom1 then
+ (* element jest na poczatku listy *)
+ breaktl(i).ins:=pom.next
+ else
+ pom1.next:=pom.next
+ fi;
+ pom.next := none;
+ fi;
+ CALL KILLI (POM)
+ ELSE POM1:=POM;POM:=POM.NEXT
+ FI
+ OD;
+ if not ok then raise deberror(38) fi;
+END;
+
+(*---------------------------------------------------*)
+(* *)
+(* D E C L A R E *)
+(* *)
+(* DEKLARACJA BANKU INSTRUKCJI *)
+(*---------------------------------------------------*)
+
+UNIT DECLARE :PROCEDURE;
+VAR POM : DEC,
+ P1,P2 : INSTR;
+BEGIN
+ CALL SCAN;
+ IF S =/= sident THEN RAISE DEBERROR(1) FI;
+ (* PRZECZYTALISMY IDENTYFIKATOR PRZYSZLEGO BANKU *)
+ POM := NEW DEC;
+ POM.ID := ADRES;
+ POM.NEXT:=DECL;
+ (* DOLACZYLISMY INFORMACJE O NOWYM BANKU DO LISTY BANKOW *)
+ DECL := POM; CALL NEWLIN;CALL SCAN;
+ WHILE S =/= SEND DO
+ (* KOPIUJEMY INSTRUKCJE *)
+ P1 := NEW INSTR;
+ CALL INTEX(P1.TXT);
+ CALL NEWLIN;
+ IF P2 = NONE THEN POM.INS := P1
+ ELSE P2.NEXT := P1 FI;
+ p2 := p1;
+ CALL SCAN
+ OD
+END declare;
+
+(*----------------------------------------------*)
+(* *)
+(* C A L *)
+(* *)
+(* WYKONANIE INSTRUKCJI Z BANKU INSTRUKCJI *)
+(*----------------------------------------------*)
+
+UNIT CAL : PROCEDURE;
+VAR POM : DEC,
+ MC : INTEGER,
+ P2 :INSTR;
+BEGIN
+ MC := MA;
+ CALL INTEX(ctxt);
+ (* PRZECHOWANIE BUFORA SCANERA *)
+ CALL SCAN ;IF S =/= sident THEN RAISE DEBERROR(1) FI;
+ POM := DECL;
+ WHILE POM =/= NONE DO
+ IF POM.ID = ADRES THEN EXIT FI;
+ POM := POM.NEXT;
+ OD;
+ IF POM = NONE THEN RAISE DEBERROR(13)
+ ELSE
+ P2 := POM.INS;
+ WHILE P2 =/= NONE DO
+ CALL OUTEX(P2.TXT);
+ CALL WRLIN(P2.TXT);
+ CALL SCAN;
+ CALL INTLIN;
+ P2 := P2.NEXT
+ OD;
+ FI;
+ MA :=MC;
+ CALL NEWLIN;
+END cal;
+
+(*---------------------------------------------------------*)
+(* *)
+(* A S S I G N *)
+(* *)
+(* INTERPRERACJA INSTRUKCJI PODSTAWIENIA *)
+(*---------------------------------------------------------*)
+
+UNIT ASSIG :PROCEDURE;
+BEGIN
+ CALL SCAN;
+ CALL FIND(FALSE);
+ (* ODCZYTANE WARTOSCI prawej STRONY PODSTAWIENIA *)
+ MODE1:=MODE; PROTDEB1:=PROTDEB; INTVAL1:= INTVAL;
+ (* ZAPAMIETANIE WAROTSCI WYNIKOW PROCEDURY FIND *)
+ REFVAL1:=REFVAL; RELVAL1:= RELVAL; CHAVAL1:= CHAVAL;
+ (*+ WRITELN(LO," ",MODE,PROTDEB,INTVAL,RELVAL); ++*)
+ IF S=/= STO THEN RAISE DEBERROR(11) FI;
+ CALL SCAN;
+ CALL FIND(TRUE);
+ (* ODCZYTANIE PRAWEJ STRONY WYRAZENIA *)
+ (*+ WRITELN(LO," ",MODE,PROTDEB,INTVAL,RELVAL,OFFSET); ++*)
+ IF PROTDEB1=INTT AND PROTDEB=RELT THEN RELVAL1:=INTVAL1 FI;
+ IF PROTDEB1=RELT AND PROTDEB=INTT THEN INTVAL1:=RELVAL1 FI;
+ IF PROTDEB1*PROTDEB<0 THEN RAISE DEBERROR(19) FI;
+ IF PROTDEB=NONT THEN RAISE DEBERROR(15) FI;
+ IF PROTDEB1=NONT THEN PROTDEB1:=1 FI;
+ (*+WRITELN(LO," ",MODE,RELVAL1,INTVAL1);++*)
+ IF MODE1>3 THEN IF MODE<3 THEN RAISE DEBERROR(19) FI FI;
+ CALL OUTREF(REFFVAL);
+ CALL OUTREF(REFVAL);
+ CALL OUTREF(REFVAL1);
+
+CASE MODE
+(* PODSTAWIENIE WARTOSCI PRZEBIEGA ROZNIE W ZALEZNOSCI *)
+(* OD SPOSOBU ADRESACJI I TYPU ZMIENNEJ *)
+ WHEN 1,2,5,6 : (* assign an object attribute *)
+ IF REFFVAL=NONE THEN RAISE DEBERROR(15) FI;
+ IF MODE1>3 OR PROTDEB>0 THEN
+ (* refval1 --> address (refval,offset) *)
+ call db01ox(10,refval,offset,refval1,relval,intval);
+ ELSE
+
+ case protdeb
+ WHEN INTT,BOOLT:
+ (* intval1 --> address(refval,offset) *)
+ call db01ox(11,refval,offset,glovirt,relval,intval1);
+ WHEN CHT :
+ (* chaval1 --> address (refval,offset) *)
+ i := ord(chaval1);
+ call db01ox(12,refval,offset,glovirt,relval,i);
+ WHEN RELT :
+ (* relval1 --> address (refval,offset) *)
+ call db01ox(13,refval,offset,glovirt,relval1,intval);
+ esac
+ FI;
+
+ WHEN 3,4: (* assign an array element *)
+ IF REFFVAL = NONE THEN RAISE DEBERROR(15) FI;
+ IF MODE1>3 OR PROTDEB>0 THEN
+ OFFSET:=OFFSET*2;
+ (* refval1 ---> array element of an address (refval,offset) *)
+ call db01ox(14,refval,offset,refval1,relval,intval);
+
+ ELSE CASE PROTDEB
+ WHEN INTT,BOOLT :
+ (* intval1 --> array element *)
+ call db01ox(15,refval,offset,glovirt,relval,intval1);
+ WHEN CHT :
+ (* chaval1 --> array element *)
+ i := ord(chaval1);
+ call db01ox(16,refval,offset,glovirt,relval,i);
+ WHEN RELT :
+ (* relval1 --> array element *)
+ OFFSET:=OFFSET*3;
+ call db01ox(17,refval,offset,glovirt,relval1,intval);
+ ESAC
+ FI
+ESAC
+END assig;
+
+(*========================================================*)
+(* *)
+(* O U T P ( OUTPUT ) *)
+(* *)
+(* WYPISANIE WARTOSCI WYRAZENIA LUB JEGO TYPU *)
+(*========================================================*)
+
+UNIT OUTP : PROCEDURE;
+ var i,j:integer;
+BEGIN
+CALL SCAN;
+CALL FIND(FALSE);
+IF S=SAST AND ADRES=adast then
+(* WYPISANIE TYPU WYRAZENIA *)
+ IF R=/=0 THEN
+ WRITE(CO,t16,R,t17);
+ IF ECHO THEN WRITE(LO,t16,R,t17) FI;
+ IF PROTDEB=FORT THEN WRITELN(CO,t18);
+ IF ECHO THEN WRITELN(LO,t18) FI;RETURN
+ FI;
+ FI;
+IF PROTDEB=FORT or protdeb =cortt or protdeb = proctt THEN
+ IF REFVAL=NONE THEN WRITELN(CO,t19);
+ IF ECHO THEN WRITELN(LO,t19) FI; RETURN FI;
+(* protdeb := dispnr of the object refval *)
+ call db01ox(18,refval,i,glovirt,gloreal,protdeb);
+FI;
+ IF PROTDEB<0 THEN
+ CASE -PROTDEB
+ WHEN 2:WRITE(CO,t20); IF ECHO THEN WRITE(LO,t20) FI;
+ WHEN 8:WRITE(CO,t21);IF ECHO THEN WRITE(LO,t21) FI;
+ WHEN 11:WRITE(CO,t22);IF ECHO THEN WRITE(LO,t22) FI;
+ WHEN 5:WRITE(CO,t23);IF ECHO THEN WRITE(LO,t23) FI;
+ WHEN 35:WRITE(CO,t24);IF ECHO THEN WRITE(LO,t24) FI;
+ OTHERWISE ;
+ ESAC;
+ ELSE
+ i := idict(protdeb);
+ WRITE(CO," "); IF ECHO THEN WRITE(LO," ") FI;
+ CALL WRID(prot(I-1), 10)
+ FI;
+ WRITELN(CO); IF ECHO THEN WRITELN(LO) FI;
+ call scan;
+ELSE
+(* WYPISANIE WARTOSCI WYRAZENIA *)
+IF S=/=SEMICOL THEN RAISE DEBERROR(10) FI;
+IF MODE >= 4 THEN RAISE DEBERROR(20) FI;
+IF PROTDEB=INTT THEN WRITELN(CO," ",INTVAL);
+ IF ECHO THEN WRITELN(LO," ",INTVAL) FI;
+ELSE
+IF PROTDEB=RELT THEN WRITELN (CO," ",RELVAL);
+ IF ECHO THEN WRITELN(LO," ",RELVAL) FI
+ELSE
+IF PROTDEB=CHT THEN WRITELN(CO," ",CHAVAL);
+ IF ECHO THEN WRITE(LO," ",CHAVAL) FI
+ELSE
+IF PROTDEB=BOOLT THEN IF INTVAL = -1 THEN WRITELN(CO,t25);
+ IF ECHO THEN WRITELN(LO,t25) FI;
+ ELSE WRITELN(CO,t26);
+ IF ECHO THEN WRITELN(LO,t26) FI
+ FI
+ELSE
+ call db01ox(30,refval,i,glovirt,gloreal,j);
+ writeln(co, " virtual address ",i,j);
+ if echo then writeln(lo," virtual address ",i,j) fi;
+FI FI FI FI
+FI
+END;
+
+(*-----------------------------------------------*)
+(* *)
+(* M O V E *)
+(* *)
+(* ZMIANA PUNKTU OBSERWACJI *)
+(*-----------------------------------------------*)
+
+UNIT MOVE :PROCEDURE;
+VAR M:MOVEL, C:ARRAYOF INTEGER;
+
+BEGIN
+CALL SCAN;C:=MOV.COR;
+i := idict(protnr);
+(*+ CALL OUTREF(MOV.ADR); CALL OUTREF(C); ++*)
+IF S=SAST AND ADRES=adast THEN
+ (* IDZIEMY PO PREFIKSIE *)
+ IF PROTNR<0 THEN RAISE DEBERROR(31) FI;
+ CALL SCAN;IF S=/=SART OR ADRES=/=adgt THEN RAISE DEBERROR (28) FI;
+ I:=I+4; (* ADRES numeru PROTOTYPU PREFIKSU *)
+ PROTDEB:=prot(I);
+ (* protdeb - adres prototypu prefiksu *)
+ (* ODCZYTANIE PROTOTYPU DEBUGGERA PREFIKSU *)
+ IF PROTDEB=0 (* NIE MA PREFIKSU *) THEN RAISE DEBERROR(31) FI;
+ M:=NEW MOVEL(MA,PROTDEB,MOV.ADR,MOV.COR);
+ M.NEXT:=MOV ; MOV:=M; PROTNR:=PROTDEB; CALL INF;
+ call scan; (* przeczytanie ';' *)
+ RETURN
+FI;
+if s=/= 1 then (* poruSZAMY SIE PO SL LUB DL LUB CL *)
+ IF UNITCASE=RECT THEN RAISE DEBERROR(35) FI;
+ IF S=SART AND ADRES=adeq THEN (* = *) (* SL *)
+ IF PROTNR=0 THEN RAISE DEBERROR(30) FI; (* main block *)
+ CALL SCAN;
+ IF S=/=SART OR ADRES=/=7 THEN RAISE DEBERROR(28) FI;
+ I:=I+1; PROTDEB:=prot(I);(* SL *)
+ (* ODCZYTANIE ADRESU OBIEKTU WSKAZYWANEGO PRZEZ SL *)
+ (* refval := address of the SL of mov.adr *)
+ call db01ox(19,mov.adr,offset,refval,relval,intval);
+ C:=FINDCR(REFVAL);
+ call scan; (* wczytanie ';' *)
+ ELSE
+ IF S=SAST AND ADRES= admin THEN (* - *) (* DL *)
+ IF PROTNR=0 THEN RAISE DEBERROR(30) FI; (* main block *)
+ IF UNITCASE=CORT (* COROUTINE *) THEN RAISE DEBERROR(32) FI;
+ CALL SCAN;
+ IF S=/=SART OR ADRES=/=adgt THEN RAISE DEBERROR(28) FI;
+ (* ODCZYTENIE OBIEKTU WSKAZYWNEGO PRZEZ DL *)
+ (* refval := address of the DL of the object mov.adr *)
+ call db01ox(20,mov.adr,offset,refval,relval,intval);
+ IF MOV.ADR=REFVAL THEN RAISE DEBERROR(36) FI;
+ call scan; (* wczytanie srednika *)
+ (* MOVE DL W IBIEKCIE STERMINOWANYM *)
+ ELSE (* CL *)
+ IF S=/=SART OR ADRES =/= adgt THEN RAISE DEBERROR(28) FI;
+ CALL SCAN;
+ IF S =/= SART OR ADRES =/= adgt THEN RAISE DEBERROR(28) FI;
+ (* ODCZYTUJEMY CL *)
+ IF MOV.COR=NONE THEN RAISE DEBERROR(37) FI;
+ (* JESTESMY W OBIEKCIE NALEZACYM DO LANCUCHA COROUTINY *)
+ (* refval := address of the CL of the object mov.cor *)
+ call db01ox(21,mov.cor,offset,refval,relval,intval);
+ C:=REFVAL;
+ IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
+ IF CCOR=REFVAL THEN (* WRACAMY DO AKTYWNEJ COROUTINY *)
+ REFVAL:=CADR;
+ ELSE (* ODCZYTUJEMY ADRES OBJEKTU WSKAZYWANEGO PRZEZ DL GLOWY *)
+ (* refval := address of DL of the object C *)
+ call db01ox(22,c,offset,refval,relval,intval);
+ FI;
+ call scan; (* wczytanie srednika *)
+ FI;
+ (*+ CALL OUTREF(REFVAL); ++*)
+ IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
+ (* ODCZYTUJEMY DISPNR NOWEGO PUNKTU OBSERWACJI *)
+ (* protdeb := dispnr of the object refval *)
+ call db01ox(23,refval,offset,glovirt,relval,protdeb);
+ (*+ WRITELN(LO," PR=",PROTDEB)++*);
+FI
+ELSE
+(* MOVE DO OBIEKTU OKRESLONEGO PRZEZ WYRAZENIE *)
+(*+ WRITELN(LO," MOVE DO OBIEKTU"); ++*)
+CALL FIND(TRUE);
+if refval=none then raise deberror(15) fi;
+IF PROTDEB<0 THEN RAISE DEBERROR(21) FI;
+i := idict(protdeb); UNITCASE:=prot(I);
+IF UNITCASE=/=RECT THEN C:=FINDCR(REFVAL) ELSE C:=NONE FI;
+FI;
+PROTNR:=PROTDEB;
+(* UAKTUALNIENIE LISTY BREAKL *)
+M:=NEW MOVEL(MA,PROTDEB,REFVAL,C); M.NEXT:=MOV; MOV:=M;
+(*+ WRITELN(LO," NOWY PUNKT OBSERWACJI"); ++*)
+(*+ CALL OUTREF(REFVAL); ++*)
+OBSADR:=REFVAL; (* adres obiektu bedacego punktem obserwacji *)
+CALL INF;
+END move;
+
+
+(*--------------------------------------------------*)
+(* *)
+(* R E T (RETURN) *)
+(* *)
+(* POWROT DO POPRZEDNIEGO PUNKTU OBSERWACJI *)
+(*--------------------------------------------------*)
+
+UNIT RET :PROCEDURE;
+VAR P1,POM :MOVEL;
+BEGIN
+CALL SCAN;
+(*+ CALL OUTREF(MOV.ADR); ++*)
+POM:= MOV;
+IF S=SAST and adres = adast THEN (* KASUJ WSZYSTKIE ZMIANY *)
+ WHILE POM.NEXT=/=NONE DO MOV:=MOV.NEXT; KILL(POM); POM:=MOV OD;
+ call scan
+ELSE IF S=SEMICOL THEN (* COFAMY SIE JEDEN KROK *)
+ IF MOV.NEXT=NONE THEN RAISE DEBERROR(22) FI;
+ MOV:=MOV.NEXT; KILL (POM)
+ ELSE (* COFAMY SIE DO PUNKTU OBSERWACJI, KTORY OBOWIAZYWAL *)
+ (* PRZED INSTRUKCJA MOVE O ETYKIECI = ADRES *)
+ IF S=/=sident THEN RAISE DEBERROR(1) FI;
+ WHILE POM=/=NONE DO
+ IF POM.MARK=ADRES THEN EXIT FI;
+ POM:=POM.NEXT;
+ OD;
+ IF POM=NONE THEN RAISE DEBERROR(22) FI;
+ P1:=MOV;
+ WHILE MOV=/=POM DO MOV:=MOV.NEXT; KILL(P1); P1:=MOV OD;
+ MOV:=MOV.NEXT; KILL (P1);
+ call scan;
+ FI
+FI;
+(* AKTUALIZUJEMY PUNKT OBSERWACJI *)
+OBSADR:=MOV.ADR;
+PROTNR:=MOV.PROT;
+i := idict(protnr); unitcase := prot(i);
+CALL INF;
+END;
+
+(*--------------------------------------------------------------------*)
+(* *)
+(* F I N D *)
+(* *)
+(*--------------------------------------------------------------------*)
+(* PROCEDURA ODCZYTUJE WARTOSC ZMIENNEJ A DLA LEXPR ROWNIEZ JEJ ADRES *)
+(* WYNIKI ZWRACA NA ZMIENNYCH GLOBALNYCH protdeb,DISPNR,OFFSET,R *)
+(* (LICZBA ARRAY OF ) I MODE - SPOSOB ADRESOWANIA *)
+(* WARTOSCI LICZBOWE NA INTVAL ,REFVAL ,CHAVAL,RELVAL W ZALEZNOSCI *)
+(* OD TYPU WARTOSCI *)
+(*--------------------------------------------------------------------*)
+
+UNIT FIND : PROCEDURE (LEXPR :BOOLEAN);
+
+(* mode = 0 - nie zmienna (stala) *)
+(* 1 - zmienna czytana jako offset w obiekcie *)
+(* 2 - j.w. *)
+(* 3 - zmienna czytana jako element tablicy *)
+(* 4 - tablica czytana jako element tablicy *)
+(* 5 - tablica czytana jako element w obiekcie *)
+(* 6 - tablica czytana jako offset w obiekcie *)
+
+
+UNIT SZUKATR:PROCEDURE(ADRES:INTEGER;INOUT ADRPROT:INTEGER;
+ OUTPUT OFFSET,R:INTEGER;OUTPUT TAK:BOOLEAN);
+
+(* SZUKA W PROTOTYPIE O ADRESIE ADRPROT ZMIENNEJ O ADRESIE *)
+(* W TABLICY HASH ROWNYM ADRes *)
+(* WYNIK: OFFSET-OFFSET ZMIENNEJ,R-LICZBA ARRAYOF TYPU ZMIENNEJ,TAK-WSKAZUJE*)
+(* CZY ZNALEZIONO ZMIENNA,ADRPROT- JEST TYPEM ZMIENNEJ*)
+
+VAR L,ADR,PROTDEB:INTEGER;
+
+BEGIN
+(*+WRITELN(LO," SZUATR ADRES=",ADRES,"ADRPROT = ",ADRPROT)++*);
+OFFSET:=(ADRES-1)/2;(*+WRITELN(LO," L1",OFFSET)++*);
+OFFSET:=OFFSET MOD 8;
+(*+ WRITELN(LO," L2",OFFSET)++*);
+OFFSET:=OFFSET+5;
+L:=ADRPROT+OFFSET;
+(*+ WRITELN(LO," L3",L)++*);
+ADR:=prot(L);
+(*+ WRITELN(LO," ADR",ADR)++*);
+ (* ADR-POCZATEK LISTY HASHU*)
+DO
+ r := prot(adr);
+ (* r - kolejny element listy *)
+ IF R = -100 THEN EXIT FI;
+ IF ADRES = R THEN (*TO JEST NASZA ZMIENNA*)
+ ADR:=ADR+2;
+ adrprot := -prot(adr);
+ if adrprot <= 15 then (* to nie jest zmienna *)
+ raise deberror(29) fi;
+ (* zmienna lub stala *)
+ EXIT
+ ELSE ADR:=ADR+3
+ FI
+OD;
+IF R =/= -100 THEN (* ZNALEZLISMY PROTOTYP ZMIENNEJ*)
+ TAK:=TRUE;
+ IF prot(ADRPROT)=VART THEN (*JEST TO ZMIENNA LUB PARAMETR*)
+ ADR:=ADRPROT+1;
+ R:= prot(ADR); (* R:= LICZBA ARRAY OF *)
+ ADR:=ADR +1;
+ ADRPROT:=prot(ADR);
+ ADR:=ADR+1;
+ OFFSET:=prot(ADR);
+ ELSE (*CASE=/=5*) RAISE DEBERROR(29) FI;
+ELSE (* NIE ZNALEZLISMY ZMIENNEJ*)
+TAK:=FALSE
+FI;
+END SZUKATR;
+
+UNIT SEP :FUNCTION:BOOLEAN;
+(* SPREWDZA CZY PRZECZYTANY PRZEZ SCANER SYMBOL JEST SEPERATOREM *)
+(* DLA WYRAZENIA *)
+BEGIN RESULT:= S=SEMICOL OR S=STO OR S=SRPAR OR S=SLPAR OR S=SCOM
+ OR S=SART OR S=SAST AND ADRES=adast OR S=SOR OR S=SAND OR S=SNOT
+ OR S=SWHEN OR (S=1 AND ADRES=AWITH)
+ OR PROTDEB<0 AND PROTDEB =/=FORT and protdeb <> cortt and protdeb <> proctt
+END sep;
+
+VAR ADRPROT,A,LINDEKSOW : INTEGER,
+ BOL,SL,POKROPCE:BOOLEAN,
+ CURADR : ARRAYOF INTEGER,
+ MIN : INTEGER;
+
+BEGIN (* of find *)
+MIN:=1;
+(* ZAKLADAMY ,ZE JEST PRZECZYTANY SYMBOL *)
+(*PROTNR-NR PROTOTYPU DEBUGGERA AKTUALNEGO OBIEKTU*)
+IF S=/=sident THEN MODE:=0;
+ IF LEXPR THEN RAISE DEBERROR(1) FI;
+ IF S=SNONE THEN PROTDEB:=NONT;CALL SCAN;REFVAL:=NONE ;RETURN FI;
+ IF S=SBOL THEN PROTDEB:=BOOLT;
+ IF ADRES=1 THEN INTVAL:=0 ELSE INTVAL:=-1 FI;
+ CALL SCAN; RETURN FI;
+ IF S=SAST AND ADRES=admin THEN(* MINUS*) MIN:=-1;CALL SCAN FI;
+ IF S=/=SCONST THEN RAISE DEBERROR(1) FI;
+ CASE K
+ WHEN kint : PROTDEB:=INTT;INTVAL:=ADRES*MIN;
+ WHEN 4,5 :RAISE DEBERROR(23);
+ WHEN kch : PROTDEB:=CHT;
+ chaval := chr(adres);
+ ESAC;
+ CALL SCAN;
+ RETURN;
+FI;
+A,PROTDEB:=PROTNR;
+CURADR:=OBSADR;
+DO
+(*+WRITELN(LO," OUTP IN DO ")++*);
+adrprot := idict(protdeb);
+IF SL THEN A:=PROTDEB FI; (*A JEST PROTOTYPEM ZMIENIAJACYM SIE TYLKO DLA
+ MODULOW PO SL*)
+SL:=FALSE;
+I:=ADRPROT+3; DISPNR:=prot(I);
+(*+WRITELN(LO," DISPNR = ",DISPNR," ADRPROT = ",ADRPROT)++*);
+(* ODCZYTANIE NR DISPLAYA Z PROTOTYPU AKT OBIEKTU*)
+CALL SZUKATR(ADRES, ADRPROT, OFFSET, R, BOL);
+ (*PO WYWOLANIU ADRPROT JEST NR TYPU PIERWOTNEGO LUB NR PROTOTYPU *)
+ (*O ILE ZNALEZIONO ZMIENNA *)
+ (* W P.P. ADRPROT SIE NIE ZMIENIA*)
+IF BOL THEN (*ZNALEZLISMY ZMIENNA*)
+ POKROPCE:=FALSE;
+ DO (*PETLA DO WYPISANIA ZMIENNEJ a wlasciwie do rozpoznania wyr. do konca*)
+ LINDEKSOW:=0;
+ PROTDEB:=ADRPROT;
+ IF R=0 AND NOT POKROPCE THEN (*JEST TO ZMIENNA NIEABLICOWA BEZ KROPKI*)
+ (*+WRITELN(LO," ***LICZYMY WARTOSC PIERWSZEGO IDENT")++*);
+ REFFVAL,REFVAL:=CURADR;
+ CALL TAKEREF(OFFSET,ADRPROT);
+ PROTDEB:=ADRPROT;
+ MODE:=1;CALL SCAN;
+ FI;
+ IF R=0 AND POKROPCE THEN (*REFVAL JEST ADRESEM OBIEKTU PRZED KROPKA*)
+ (*+WRITELN(LO," ***LICZYMY WARTOSC IDENT PO KROPCE")++*);
+ REFFVAL:=REFVAL;
+ CALL TAKEREF(OFFSET,ADRPROT);PROTDEB:=ADRPROT;
+ MODE:=2;
+ CALL SCAN;
+ FI;
+ IF R=/=0 AND NOT POKROPCE AND LINDEKSOW=0 THEN (* PIERWSZY INDEKS *)
+ (*+WRITELN(LO," ***LICZYMY WARTOSC ZMIENNEJ INDEKSOWANEJ")++*);
+ REFFVAL,REFVAL:=CURADR;
+ CALL TAKEREF(OFFSET,1);
+ MODE:=5;
+ CALL SCAN;
+ IF S=/=SLPAR THEN EXIT EXIT
+ ELSE
+ CALL SCAN; (*CZYTA INDEKS,TO MUSI BYC STALA*)
+ MIN:=1;
+ IF S=SAST AND ADRES=admin THEN MIN:=-1;CALL SCAN FI;
+ (*+ WRITELN(LO," ***CZYTA INDEKS")++*);
+ IF S=SCONST AND K=3 THEN LINDEKSOW:=1;
+ (*+WRITELN(LO," ***LICZY WARTOSC TABLICY")++*);
+ REFFVAL:=REFVAL;
+ IF R=1 THEN CALL TAKEARR(ADRES*MIN,ADRPROT)
+ ELSE CALL TAKEARR(ADRES*MIN,1) FI;
+ OFFSET:=ADRES;MODE:=4;
+ (*+ WRITELN(LO," ***WARTOSC ZMIENNEJ INDEKSOWANEJ") ++*);
+ ELSE RAISE DEBERROR(1) (*INDEKS NIE JEST STALA*)
+ FI;
+ CALL SCAN; (* OGRANICZNIKI LUB ")"*)
+ IF S=/=SRPAR THEN (*S=/=")"*)
+ IF S =/=SCOM THEN RAISE DEBERROR(5) FI;
+ ELSE (*S=")" *)
+ (*+WRITELN(LO," ***PRZECZYTALISMY PRAWY NAWIAS")++*);
+ IF R=1 THEN MODE:=3 FI;
+ CALL SCAN;
+ IF SEP THEN R:=R-LINDEKSOW FI;
+ FI
+ FI; (*S=/=52 0R ADRES=/=3 *)
+FI;
+
+IF R>1 OR R=1 AND POKROPCE THEN
+DO (*PETLA OBSLUGUJE ZMIENNE TABLICOWE PO KROPCE LUB O WIECEJ NIZ
+ JEDNYM INDEKSIE*)
+ (*S- WARTOSC INDEKSU*)
+ CALL SCAN;
+ MIN:=1;
+ IF S=SAST AND ADRES=admin (*MINUS*) THEN MIN:=-1; CALL SCAN FI;
+ IF S=SCONST AND K=kint THEN LINDEKSOW := LINDEKSOW+1;
+ IF LINDEKSOW=R THEN
+ REFFVAL:=REFVAL;CALL TAKEARR(ADRES,ADRPROT);
+ MODE:=4;OFFSET:=ADRES;
+ ELSE
+ REFFVAL:=REFVAL;
+ CALL TAKEARR(ADRES, 1); (*ADRES=WARTOSC(S)*)
+ MODE:=3;
+ (* TYP DANY JAKO 1 OZNACZA TYP REFERENC.*)
+ FI;
+ ELSE RAISE DEBERROR(1) (*INDEKS NIE JEST STALA*)
+ FI;
+ CALL SCAN; (*OGRANICZNIKI*)
+ IF S=SRPAR THEN IF R=LINDEKSOW THEN MODE:=3 FI;
+ CALL SCAN ; IF SEP THEN R:=R-LINDEKSOW;EXIT FI;
+ ELSE
+ IF LINDEKSOW < R THEN
+ IF S =/= SCOM THEN RAISE DEBERROR(5) FI
+ ELSE RAISE DEBERROR(6); (*ZA DLUGIE WYRAZENIE INDEKSOWE *)
+ FI
+ FI;
+if lindeksow=r then exit fi;
+OD;
+FI;
+ if protdeb > 0 or protdeb = fort or protdeb = proctt or protdeb = cortt then
+ (* TRZEBA ZNALESC PROTOTYP TYPU AKTUALNEGO *)
+ IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
+ (* protdeb := protnumber of the actual type *)
+ call db01ox(24,refval,offset,glovirt,relval,protdeb);
+ (*+ WRITELN(LO," PROTDEB =",PROTDEB);++*)
+ fi;
+IF SEP THEN EXIT EXIT FI;
+IF S=SDOT THEN
+IF R=/=0 AND LINDEKSOW=/=R OR PROTDEB <0 THEN RAISE DEBERROR(24) FI;
+ (*+ WRITELN(LO," ***CZYTAMY KROPKE") ++*);
+ POKROPCE:=TRUE;
+ CALL SCAN; (*CZYTA ZMIENNA PO KROPCE*)
+ (*+ WRITELN (LO," ***CZYTAMY IDENT PO KROPCE")++*);
+ adrprot := idict(protdeb);
+ CALL SZUKATR(ADRES,ADRPROT,OFFSET,R,BOL);
+ (*ZNAJDUJE ZMIENNA ZAPISANA W ADRES I BEDACA
+ ATRYBUTEM PROTOTYPU ADRPROT*)
+ IF NOT BOL THEN RAISE DEBERROR(7) FI;
+ IF R=/=0 THEN (* ATRYBUTEM JEST TABLICA *)
+ CALL SCAN;
+ IF S=/=SLPAR THEN
+ IF S=/=SEMICOL and S=/=STO THEN RAISE DEBERROR(10) FI;
+ MODE:=6;EXIT EXIT;
+ FI;
+ REFFVAL:=REFVAL;
+ CALL TAKEREF(OFFSET,1);
+ MODE:=4;
+ FI;
+FI
+OD
+ELSE (*NIE ZNALEZLISMY ZMIENNEJ, TRZEBA ISC DO PREFIKSU*)
+ adrprot := idict(protdeb);
+ I:=ADRPROT+4; (* ADRPROT+4 =ADRES PROTOTYPU PREFIKSU *)
+ PROTDEB:=prot(I);
+ (*+WRITELN(LO," **** PROTDEB",PROTDEB)++*);
+ IF PROTDEB<=0 (*NIE MA PREFIKSU WIEC IDZIEMY PO SL*) THEN
+ IF A=0 THEN (* MODUL GLOWNY *) RAISE DEBERROR(9) FI;
+ SL:=TRUE;
+ (*+WRITELN(LO," A =",A)++*);
+ adrprot := idict(a);
+ I:=ADRPROT+1; (* BUFFP(I) = NUMER PROTUTYPU SL *)
+ IF UNITCASE=RECT THEN RAISE DEBERROR(9) FI;
+ (* SZUKAMY DALEJ TYLKO WTEDY, GDY NIE JEST TO REKORD *)
+ PROTDEB:=prot(I);
+ (* curadr := address of SL of the object curadr *)
+ glovirt := curadr;
+ call db01ox(25,glovirt,offset,curadr,relval,intval);
+ (*+WRITELN(LO," +++ PROTDEB",PROTDEB)++*);
+FI
+FI
+OD;
+END FIND;
+
+(* ------------------------------------------------------------------- *)
+
+UNIT FINDCR:FUNCTION( INPUT C1:ARRAYOF INTEGER):ARRAYOF INTEGER;
+(* SZUKA GLOWY COROUTINY DLA INSTANCJI O ADRESIE C1 *)
+VAR J:INTEGER;
+BEGIN
+ (*+WRITELN(LO," FINDCR");++*)
+DO
+ IF C1=NONE THEN EXIT FI;;
+ (*+ CALL OUTREF(C1); ++*)
+ RESULT:=C1;
+ (* i := dispnr of the object c1 *)
+ call db01ox(26,c1,offset,refval,relval,i);
+ (*+ WRITELN(LO," I=",I); ++*)
+ IF I=0 THEN EXIT FI;
+ J:=I;
+ DO (* SZUKAMY W CIAGU PREFIKSOWYM COROUTINY *)
+ j := idict(j);
+ (*+ WRITELN(LO," J=",J); ++*)
+ IF prot(J)=11 THEN EXIT EXIT FI;
+ J:=J+4; J:=prot(J);
+ (*+ WRITELN(LO," J=",J); ++*)
+ IF J<=0 THEN EXIT FI;
+ OD;
+ (* PORUSZAMY SIE PO DL *)
+ (* c1 := DL of the object c1 *)
+ glovirt := c1;
+ call db01ox(27,glovirt,offset,c1,relval,intval);
+ IF RESULT=C1 THEN RESULT:=NONE ; EXIT FI;
+ (* ZAPETLENIE DL WSKAZUJE NA OBIEKT STERMINOWANY *)
+OD;
+END;
+
+(*-------------------------------------------------------*)
+(* *)
+(* C O N D *)
+(* *)
+(* SPRAWDZENIE WARUNKU BOOLOWSKIEGO PRZY WARUNKOWYM *)
+(* PUNKCIE PRZERYWAJACYM *)
+(*-------------------------------------------------------*)
+UNIT COND :FUNCTION:BOOLEAN;
+VAR BL:BOOLEAN;
+BEGIN
+CALL SCAN;WHILE S=/=SWHEN DO CALL SCAN OD;
+(* ROZPOCZYNAMY INTERPRETACJE WARUNKU *)
+RESULT:=TRUE;
+DO (* PETLA PO "AND" *)
+ CALL SCAN;
+ IF S = SNOT THEN CALL SCAN;RESULT:=NOT COND1 AND RESULT
+ ELSE IF S=/=SLPAR THEN RESULT:=COND1 AND RESULT
+ ELSE
+ (* PETLA PO "OR" *)
+ DO BL:=FALSE;CALL SCAN;
+ IF S= SNOT THEN CALL SCAN;BL:=BL OR NOT COND1
+ ELSE BL:=BL OR COND1 FI;
+ IF S=SRPAR THEN CALL SCAN; EXIT FI;
+ IF S =/= SOR THEN RAISE DEBERROR(25) FI;
+ OD;
+ RESULT:=RESULT AND BL;
+ FI
+ FI;
+ IF ADRES=AWITH OR S=SEMICOL THEN EXIT FI;
+ IF S =/= SAND THEN RAISE DEBERROR(26) FI;
+ IF NOT RESULT THEN EXIT FI;
+OD
+END cond;
+
+UNIT COND1 : FUNCTION:BOOLEAN;
+(* WARUNEK - WYRAZENIE *)
+VAR OPER :INTEGER;
+BEGIN
+CALL FIND(FALSE);
+(* ZAKLADAMY ,ZE JEST PRZECZYTANY SYMBOL *)
+(*+WRITELN(LO," ",PROTDEB,INTVAL,RELVAL,CHAVAL,MODE) ++*);
+IF S=/=SART THEN
+ IF PROTDEB=BOOLT THEN RESULT:=INTVAL=/=0
+ ELSE RAISE DEBERROR(8) FI
+ELSE OPER:=ADRES;PROTDEB1:=PROTDEB;MODE1:=MODE;REFVAL1:=REFVAL;
+ INTVAL1:=INTVAL;CHAVAL1:=CHAVAL;RELVAL1:=RELVAL;
+ CALL SCAN;
+ CALL FIND(FALSE);
+ (*+WRITELN(LO," ",PROTDEB,INTVAL,RELVAL,CHAVAL,MODE) ++*);
+ IF (PROTDEB=INTT OR PROTDEB=RELT) AND MODE<4 AND
+ (PROTDEB1=INTT OR PROTDEB1=RELT) AND MODE1<4 THEN
+ IF PROTDEB=INTT THEN RELVAL:=INTVAL FI;
+ IF PROTDEB1=INTT THEN RELVAL1:=INTVAL1 FI;
+ CASE OPER
+ WHEN adeq :RESULT:=RELVAL1=RELVAL;
+ WHEN adne :RESULT:=RELVAL1=/=RELVAL;
+ WHEN adgt :RESULT:=RELVAL1>RELVAL ;
+ WHEN adge :RESULT:=RELVAL1>=RELVAL ;
+ WHEN adlt :RESULT:=RELVAL1<RELVAL;
+ WHEN adle :RESULT:=RELVAL1<=RELVAL;
+ ESAC
+ ELSE
+ IF (PROTDEB=NONT OR PROTDEB>0 OR MODE>4) AND
+ (PROTDEB1=NONT OR PROTDEB1>0 OR MODE1>4)
+ OR PROTDEB1=PROTDEB AND MODE1<4 AND MODE<4 THEN
+ IF PROTDEB=BOOLT THEN
+ CASE OPER
+ WHEN adeq: RESULT:=INTVAL1=INTVAL;
+ WHEN adne: RESULT:=INTVAL1=/=INTVAL;
+ OTHERWISE RAISE DEBERROR(8)
+ ESAC
+ ELSE
+ IF PROTDEB=CHT THEN
+ CASE OPER
+ WHEN adeq:RESULT:=CHAVAL1=CHAVAL;
+ WHEN adne:RESULT:=CHAVAL1=/=CHAVAL;
+ OTHERWISE RAISE DEBERROR(8)
+ ESAC
+ ELSE
+ CASE OPER
+ WHEN adeq:RESULT:=REFVAL1=REFVAL;
+ WHEN adne:RESULT:=REFVAL1=/=REFVAL;
+ OTHERWISE RAISE DEBERROR(8)
+ ESAC
+ FI
+ FI
+ ELSE RAISE DEBERROR(8) FI
+ FI
+FI
+END COND1;
+
+
+(*===========================================*)
+UNIT INTLIN :PROCEDURE;
+
+(* INTERPRETACJA LINII *)
+
+VAR POM: MOVEL;
+
+BEGIN
+MA := 0;
+DO
+IF S= SEMICOL THEN CALL SCAN FI;
+IF S=sident THEN (* IDENTYFIKATOR *)
+ IF ADRES=AGO THEN call goo; exit else
+ IF ADRES=AREPORT THEN CALL REPORT ;EXIT ELSE
+ IF ADRES=AREMOVE THEN CALL REMOVE ;call scan;EXIT ELSE
+ IF ADRES=ASTORE THEN CALL STORE ;call scan;EXIT ELSE
+ IF ADRES=AMOVE THEN CALL MOVE;EXIT ELSE
+ IF ADRES=ASSIGN THEN CALL ASSIG;EXIT ELSE
+ IF ADRES=ADELETE THEN CALL DEL ;call scan;EXIT ELSE
+ IF ADRES=ADECLARE THEN CALL DECLARE;call scan;EXIT ELSE
+ IF ADRES=AMARK THEN call mark;call scan; exit else
+MA :=ADRES; CALL SCAN;
+IF S=/= SCOLON THEN RAISE DEBERROR(4)
+FI;CALL SCAN;
+FI FI FI FI FI FI FI FI FI
+ELSE (* SLOWO KLUCZOWE *)
+ CASE S
+ WHEN SOUTPUT : CALL OUTP ; EXIT ;
+ WHEN SWRITE : ECHO:=NOT ECHO ;call scan;EXIT;
+ WHEN SBREAK : CALL BRE ;EXIT;
+ WHEN SRETURN: CALL RET; EXIT ;
+ WHEN SCALL : CALL CAL ;EXIT;
+ WHEN SSTEP : call scan;
+ SINGLESTEP:=NOT SINGLESTEP;EXIT ;
+ OTHERWISE RAISE DEBERROR(3); EXIT
+ ESAC
+FI;
+OD;
+END;
+
+HANDLERS
+WHEN DEBERROR :
+ if nr<>0 then
+ WRITE(CO," !!! ERROR NR ",NR, " - ");
+ case nr
+ when 1: writeln(co,"IDENTIFIER EXPECTED");
+ when 2: writeln(co,"INTEGER CONSTANT EXPECTED");
+ when 3: writeln(co,"INCORRECT INSTRUCTION NAME");
+ when 4: writeln(co,"':' EXPECTED");
+ when 5: writeln(co,"',' EXPECTED");
+ when 6: writeln(co,"TOO MANY INDICES");
+ when 7: writeln(co,"IDENTIFIER AFTER '.' MUST BE AN ATTRIBUTE");
+ when 8: writeln(co,"INCORRECT CONDITION");
+ when 9: writeln(co,"UNDECLARED IDENTIFIER");
+ when 10: writeln(co,"';' EXPECTED");
+ when 11: writeln(co,"'TO' EXPECTED");
+ when 12: writeln(co,"UNRECOGNIZED INSTRUCTION");
+ when 13: writeln(co,"UNRECOGNIZED BANK");
+ when 14: writeln(co,"ERROR IN REPORT PARAMETER");
+ when 15: writeln(co,"REFERENCE TO NONE");
+ when 16: writeln(co,"TOO MANY BREAK POINTS");
+ when 17: writeln(co,"BREAK POINT DECLARED TWICE");
+ when 18: writeln(co,"UNRECOGNIZED BREAK POINT");
+ when 19: writeln(co,"INCOMPATIBLE TYPES IN ASSIGN STATEMENT");
+ when 20: writeln(co,"TRY TO OUTPUT A REFERENCE TYPE VARIABLE");
+ when 21: writeln(co,"MOVE ARGUMENT IS NOT OF A REFERENCE TYPE");
+ when 22: writeln(co,"UNRECOGNIZED MOVE INSTRUCTION");
+ when 23: writeln(co,"REAL AND STRING CONSTANTS ARE FORBIDDEN");
+ when 24: writeln(co,"'.' AFTER AN ARRAY");
+ when 25: writeln(co,"'OR' EXPECTED");
+ when 26: writeln(co,"'AND' EXPECTED");
+ WHEN 27: WRITELN(co,"';' OR '*' OR IDENTIFIER EXPECTED");
+ when 28: writeln(co,"'->' OR '=>' OR '>>' OR '*>' EXPECTED");
+ when 29: writeln(co,"VARIABLE EXPECTED");
+ when 30: writeln(co,"TRY TO GO OUTSIDE THE MAIN BLOCK");
+ when 31: writeln(co,"EMPTY PREFIX");
+ when 32: writeln(co,"MOVE -> IN COROUTINE HEAD");
+ when 33: writeln(co,"INDEX OUT OF RANGE");
+ when 34: writeln(co,"WRONG PARAMETER OF GO");
+ when 35: writeln(co,"MOVE IN RECORD OBJECT");
+ when 36: writeln(co,"MOVE '->' IN TERMINATED OBJECT");
+ when 37: writeln(co,"THIS IS NOT A COROUTINE");
+ when 38: writeln(co,"WRONG MARK");
+ when 39: writeln(co,"TRY TO DELETE CURRENT BREAK POINT");
+ esac;
+ fi;
+
+ CALL NEWLIN;
+ WIND;
+END HANDLERS;
+
+
+(*=============================================*)
+BEGIN (***** INTERPR ******)
+PROTNR:=dispnr;
+(*+CALL OUTREF(CADR);++*)
+OBSADR:=CADR;
+IF CBR=NONE THEN HELP:=NONE
+ELSE
+ if cbr.condtxt =/= none then call outex(cbr.condtxt);
+ if not cond then return fi;
+ fi;
+ help := cbr.ins;
+ IF CBR.MARK =/=0 THEN WRITE(CO," ");
+ IF ECHO THEN WRITE(LO," ") FI;
+ CALL WRID(CBR.MARK, 10)
+ FI;
+FI;
+if first then (* first interrupt *)
+ writeln(co,' ');
+ writeln(co," LOGLAN DEBUGGER ");
+ writeln(co,' ');
+if echo then writeln(lo,' ');
+ writeln(lo," LOGLAN DEBUGGER ");
+ writeln(lo,' '); fi;
+ first := false;
+ writeln(co,"INITIAL BREAK AT LINE ",linenr)
+else
+ writeln(co,t9,linenr);
+ if echo then writeln(lo,t9,linenr) fi;
+fi;
+
+mov := new movel(0,protnr,cadr,findcr(cadr));
+(*+WRITELN(LO," DISPNR :",DISPNR)++*);
+CALL INF;
+CALL NEWLIN;
+(* SCANER CZYTA TEREAZ TEREAZ OD NOWEJ LINII *)
+WHILE NOT STP DO
+IF HELP =/= NONE THEN (* WYKONANIE INSTRUKCJI ZWIAZANYCH *)
+ CALL OUTEX(HELP.TXT);
+ CALL WRLIN(HELP.TXT);
+ CALL SCAN;
+ CALL INTLIN;
+ (* NASTEPNA INSTRUKCJA Z LISTY *)
+ HELP:=HELP.NEXT
+ELSE
+ call sccd01ox(5,i,i,ctxt); (* prompt *)
+ CALL SCAN;WHILE S=SEMICOL DO
+ call sccd01ox(5,i,i,ctxt);
+ call scan
+ od;
+ CALL INTEX(ctxt);
+ IF ECHO THEN CALL WRLIN(ctxt) FI; CALL INTLIN;
+FI;
+OD;
+
+END (***** INTERPR ******);
+
+UNIT RUNERROR :PROCEDURE;
+BEGIN
+(* ODTWARZMY SRODOWISKO MODULU W KTORYM WYSTAPIL BLAD *)
+(* OBIEKT TEN JEST WSKAZYWANY PRZEZ DL HANDLERA *)
+ (* dispnr := number of interrupted object,
+ obsadr := address of interrupted object *)
+ call db01ox(29,glovirt,linenr,obsadr,gloreal,dispnr);
+ cadr := obsadr;
+ (* ccor - address of an active coroutine head *)
+ call db01ox(0,ccor,dispnr,glovirt,gloreal,dispnr);
+(* linenr = line of the last break = (sometimes) line of the error occurrence *)
+ write(co,t28,linenr);
+ if echo then write(lo,t28,linenr) fi;
+ cind := 0;
+ call interpr;
+ call endrun
+END runerror;
+
+HANDLERS
+WHEN ACCERROR : writeln(co,t1); call runerror;
+WHEN CONERROR : writeln(co,t2); call runerror;
+WHEN LOGERROR : writeln(co,t3); call runerror;
+WHEN TYPERROR : writeln(co,t4); call runerror;
+WHEN SYSERROR : writeln(co,t5); call runerror;
+WHEN NUMERROR : writeln(co,t6); call runerror;
+WHEN MEMERROR : writeln(co,t7); call runerror;
+OTHERS : WRITELN(CO,t8);CALL RUNERROR;
+END HANDLERS;
+
+BEGIN (**** MAIN DEBUGGER *****)
+ CALL INICBR;
+(*+WRITELN(LO," RETURN AFTER INICBR ")++*);
+ inner;
+ call db01oe; (* end of block prefixed by LOGDEB *)
+END logdeb;
+(*******************************************************************)
+begin
+ pref logdeb
+(*$d+*)
+(*$l+*)
+ block
+ var ix : integer;
+ begin
+ ix := 100;
+ break;
+ writeln(" ok ");
+ end;
+end
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#if WSIZE==4
+ typedef long word;
+#elif WSIZE==2
+ typedef short word;
+#else
+ Define WSIZE to 2 or 4 !
+#endif
+
+char blank_[ (unsigned long)( 302 + LMEMSIZE ) * WSIZE ]; /* whole memory of compiler */
+
+
+#include "stdio.h"
+#include "signal.h"
+
+#ifndef SIGIOT
+#ifdef SIGTRAP
+#define SIGIOT SIGTRAP
+#else
+#define SIGIOT SIGILL
+#endif
+#endif
+
+
+static void sigdie(s, kill) register char *s; int kill; {
+ /* print error message, then clear buffers */
+ fflush(stdout);
+ fflush(stderr);
+ fprintf(stderr, "%s\n", s);
+ fflush(stderr);
+
+ if(kill) {
+ /* now get a core */
+ signal(SIGIOT, 0);
+ abort();
+ }
+ else
+ exit(1);
+}
+
+static void sigfdie(n){ sigdie("Floating Exception", 1);}
+static void sigidie(n){ sigdie("IOT Trap", 1); }
+static void sigqdie(n){ sigdie("Quit signal", 1); }
+static void signdie(n){sigdie("Interrupt", 0); }
+static void sigtdie(n){ sigdie("Killed", 0); }
+
+
+int main(argc, argv) int argc; char **argv; {
+
+ word parlen, i;
+ char parbuf[128];
+
+ signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
+ signal(SIGIOT, sigidie);
+#ifdef SIGQUIT
+ if( (int)signal(SIGQUIT,sigqdie) & 01) signal(SIGQUIT, SIG_IGN);
+#endif
+ if( (int)signal(SIGINT, signdie) & 01) signal(SIGINT, SIG_IGN);
+ signal(SIGTERM,sigtdie);
+
+#ifdef pdp11
+ ldfps(01200); /* detect overflow as an exception */
+#endif
+
+ parbuf[ 0 ] = '\0';
+ for (i = 1; i < argc; i++)
+ {
+ strcat( parbuf, " " );
+ strcat( parbuf, argv[i] );
+ }
+ parlen = strlen(parbuf);
+ loglan_( &parlen, parbuf );
+
+ return 0;
+}
+
+
--- /dev/null
+#############################################################################
+
+WSIZE=4 # 2 for 16-bit system, 4 for 32-bit system
+
+#CPPMEM=-DLMEMSIZE=32000 -DLPMEMSIZE=22000 # 16-bit version
+CPPMEM=-DLMEMSIZE=70000 -DLPMEMSIZE=48000 # 32-bit VAX & MSDOS GCC
+#CPPMEM=-DLMEMSIZE=100000 -DLPMEMSIZE=70000 # 32-bit UNIX
+
+WORDS_IN_REAL=1 # 2 on 16-bit, 1 on 32-bit
+DISABLE_H=1 # 0=enable H option on 16-bit, 1=disable on 32-bit
+
+# MSC version
+#CPP=cl -EP
+#CC=cl -AH -Oelsgc -Fo$*.o
+
+# GCC under MSDOS version i.e. DJ GNU C++
+CPP=cpp -P
+CC=gcc -O
+
+# UNIX version
+#CPP=gcc -x c -E -P # GNU cpp
+#CPP=/lib/cpp -P # MICROSOFT cpp
+#CC=cc -I. -Oactl -CSON # UNIX SCO
+#CC=cc -I. -Od # UNIX SCO - with respect to
+# # MICROSOFT compiler
+#CC=cc -I. +Np650 -DNO_PROTOTYPES # UNIX HP
+#CC=cc -I. -DNO_PROTOTYPES # SUN SPARC
+#CC=gcc -O # GCC
+
+
+target : loglan32.exe
+
+
+#############################################################################
+
+
+
+.SUFFIXES:
+.SUFFIXES: .o .ff
+.SUFFIXES: .o .f
+.SUFFIXES: .o .c
+
+SHELL=/bin/sh
+
+OBJ=al11.o al12.o al13.o \
+ debug.o dsw.o hash.o ifun.o it0.o it1.o \
+ memfil.o resume.o scan.o spgrec.o \
+ wan1.o wan2.o wan3.o \
+ ml2.o ml3.o \
+ main.o stdio.o
+
+F2C=f2c -I$(WSIZE) -NL400
+CCPARS=-I. -DWSIZE=$(WSIZE)
+
+
+
+loglan16.exe : $(OBJ)
+ link /e /farcalls @msdos.lnk
+
+loglan32.exe : $(OBJ)
+ $(CC) -o loglan.out @unix.lnk
+ strip loglan.out
+ aout2exe loglan.out
+ rm loglan.out
+
+loglan : $(OBJ)
+ $(CC) $(OBJ) -o loglan
+ strip loglan
+ mv loglan $(HOME)/bin
+
+
+.ff.o :
+ $(CPP) $(CCPARS) $(CPPMEM) -DWORDS_IN_REAL=$(WORDS_IN_REAL) -DDISABLE_H=$(DISABLE_H) $*.ff > $*.f
+ $(F2C) $*.f
+ rm $*.f
+ $(CC) $(CCPARS) -c $*.c
+ rm $*.c
+
+.f.o :
+ $(F2C) $*.f
+ $(CC) $(CCPARS) -c $*.c
+ rm $*.c
+
+.c.o :
+ $(CC) $(CPPMEM) $(CCPARS) -c $*.c
+
+clean:
+ -rm -f *.o
+ -rm -f loglan.exe
+ -rm -f loglan.out
+ -rm -f state.rst
+
+al11.o : al11.ff blank.h blank2.h option.h stos.h
+al12.o : al12.ff blank.h blank2.h option.h stos.h
+al13.o : al13.ff blank.h blank2.h option.h stos.h
+it0.o : it0.ff blank.h blank2.h option.h stos.h
+
--- /dev/null
+#############################################################################
+
+WSIZE=4 # 2 for 16-bit system, 4 for 32-bit system
+
+#CPPMEM=-DLMEMSIZE=32000 -DLPMEMSIZE=22000 # 16-bit version
+CPPMEM= -DLMEMSIZE=70000 -DLPMEMSIZE=48000 # 32-bit VAX & MSDOS GCC
+#CPPMEM=-DLMEMSIZE=100000 -DLPMEMSIZE=70000 # 32-bit UNIX
+
+WORDS_IN_REAL=1 # 2 on 16-bit, 1 on 32-bit
+DISABLE_H=1 # 0=enable H option on 16-bit, 1=disable on 32-bit
+
+# MSC version
+#CPP=cl -EP
+#CC=cl -AH -Oelsgc -Fo$*.o
+
+# GCC under MSDOS version i.e. DJ GNU C++
+#CPP=cpp -P
+#CC=gcc -O -m486
+
+# UNIX version
+CPP=gcc -x c -E -P # GNU cpp
+#CPP=/lib/cpp -P # MICROSOFT cpp
+#CC=cc -I. -Oactl -CSON # UNIX SCO
+#CC=cc -I. -Od # UNIX SCO - with respect to
+# # MICROSOFT compiler
+#CC=cc -I. +Np650 -DNO_PROTOTYPES # UNIX HP
+#CC=cc -I. -DNO_PROTOTYPES # SUN SPARC
+CC=gcc -O # GCC
+
+
+target : loglan
+
+
+#############################################################################
+
+
+
+.SUFFIXES:
+.SUFFIXES: .o .ff
+.SUFFIXES: .o .f
+.SUFFIXES: .o .c
+
+SHELL=/bin/sh
+
+OBJ=al11.o al12.o al13.o \
+ debug.o dsw.o hash.o ifun.o it0.o it1.o \
+ memfil.o resume.o scan.o spgrec.o \
+ wan1.o wan2.o wan3.o \
+ ml2.o ml3.o \
+ main.o stdio.o
+
+F2C=f2c -I$(WSIZE) -NL400
+
+#F2C=f2c -I$(WSIZE)
+CCPARS=-I. -DWSIZE=$(WSIZE)
+
+
+
+loglan16.exe : $(OBJ)
+ link /e /farcalls @msdos.lnk
+
+loglan32.exe : $(OBJ)
+ $(CC) -o loglan.out @unix.lnk
+ strip loglan.out
+ aout2exe loglan.out
+ rm loglan.out
+
+loglan : $(OBJ)
+ $(CC) $(OBJ) -o loglan
+ strip loglan
+# mv loglan $(HOME)/bin
+
+
+.ff.o :
+ $(CPP) $(CCPARS) $(CPPMEM) -DWORDS_IN_REAL=$(WORDS_IN_REAL) -DDISABLE_H=$(DISABLE_H) $*.ff > $*.f
+ $(F2C) $*.f
+ rm $*.f
+ $(CC) $(CCPARS) -c $*.c
+ rm $*.c
+
+.f.o :
+ $(F2C) $*.f
+ $(CC) $(CCPARS) -c $*.c
+ rm $*.c
+
+.c.o :
+ $(CC) $(CPPMEM) $(CCPARS) -c $*.c
+
+clean:
+ -rm -f *.o
+ -rm -f loglan.exe
+ -rm -f loglan.out
+ -rm -f state.rst
+
+al11.o : al11.ff blank.h blank2.h option.h stos.h
+al12.o : al12.ff blank.h blank2.h option.h stos.h
+al13.o : al13.ff blank.h blank2.h option.h stos.h
+it0.o : it0.ff blank.h blank2.h option.h stos.h
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+/*****************************************************************
+ * *
+ * Package of the I/O routines to be called from FORTRAN, VAX *
+ * according to the Standard of VAX-11 Procedure Calls. *
+ * For the LOGLAN-82 VAX/VMS Compiler *
+ * *
+ * (C) Andrzej I. Litwiniuk (AIL) *
+ * Institute of Informatics *
+ * University of Warsaw *
+ * *
+ * Version 1988.10.17 *
+ * *
+ *****************************************************************/
+
+#if WSIZE==4
+ typedef long word;
+#elif WSIZE==2
+ typedef short word;
+#else
+ Define WSIZE to 2 or 4 !
+#endif
+
+#include <stdio.h>
+#include <string.h>
+#include <malloc.h>
+#include "f2c.h"
+
+FILE *file_arr[30]={NULL};
+static char *file_names[30]={NULL};
+
+void ffopen_(stream,name,one) /* open file for binary reading */
+word *stream;
+char *name;
+long one;
+{
+ FILE *f=fopen(name,"rb"); /* read binary */
+ if (f == NULL) { printf("file %s cannot be opened\n",name); exit(1); }
+ file_arr[*stream]=f;
+}
+
+void ffcreat_(stream,name,one) /* open a new file for binary writing */
+word *stream;
+char *name;
+long one;
+{
+ FILE *f=fopen(name,"wb"); /* write binary */
+ if (f == NULL) { printf("file %s cannot be opened\n",name); exit(1); }
+ file_arr[*stream]=f;
+ if( file_names[*stream] != NULL ) free( file_names[*stream] );
+ file_names[*stream]=(char *)malloc( strlen(name)+1 );
+ strcpy( file_names[*stream], name );
+}
+
+static int tmp_files[10];
+static int tmp_cnt=0;
+static void clean_tmp()
+{
+ int i;
+ for( i=0; i<tmp_cnt; i++ ){
+ fclose( file_arr[ tmp_files[i] ] );
+ unlink( file_names[ tmp_files[i] ] );
+ }
+}
+
+void ffcrtmp_(stream) /* open a temporary file for binary writing */
+word *stream;
+{
+ extern char *tempnam();
+ char *tmp=tempnam(NULL,"logl");
+ FILE *f=fopen(tmp,"w+b");
+/* FILE *f=tmpfile(); /* temporary file opened for update */
+ if (f == NULL) { perror("temporary file cannot be opened"); exit(1); }
+ file_arr[*stream]=f;
+ file_names[*stream]=strdup(tmp);
+ tmp_files[ tmp_cnt++ ] = *stream;
+/* unlink(tmp);*/
+/* A.S. 18-03-94 atexit( clean_tmp ); */
+}
+
+void ffclose_(stream) word *stream; {
+ if(file_arr[*stream]!=NULL) fclose(file_arr[*stream]);
+}
+void ffunlink_(stream) word *stream; {
+ if( file_names[*stream] != NULL )
+ unlink( file_names[*stream] );
+}
+
+void ffseek_(stream,offset) word *stream,*offset; {
+ fseek(file_arr[*stream],(long)(*offset),0);
+}
+
+void ffread_(stream,mloc,bytes) word *stream,*mloc,*bytes; {
+ *bytes=fread((char *)mloc,1,(int)(*bytes),file_arr[*stream]);
+}
+
+void fferror_(code) word *code;{
+ fprintf(stderr," I/O Error number %d\n",(int)(*code));
+ abort();
+}
+
+void ffwrite_ints__(stream,mloc,ints) word *stream,*mloc,*ints;{
+ word l=31;
+ if( fwrite((char *)mloc,sizeof(word),(int)(*ints),file_arr[*stream]) != (int)(*ints) )
+ fferror_(&l);
+}
+
+void ffwrite_(stream,mloc,bytes) word *stream,*mloc,*bytes; {
+ word l=30;
+ if( fwrite((char *)mloc,1,(int)(*bytes),file_arr[*stream]) != (int)(*bytes) )
+ fferror_(&l);
+}
+
+void ffwrite_char__(stream,mloc,chars)
+ word *stream;
+ char *mloc;
+ long chars;
+{
+ word l=29;
+ if( fwrite(mloc,1,(int)chars,file_arr[*stream]) != (int)chars)
+ fferror_(&l);
+}
+
+void ffwrint_(unit,item) word *unit,*item;{
+ word l=28;
+ if(file_arr[*unit]==NULL) fferror_(&l);
+ fprintf(file_arr[*unit],"%6.6d",(int)(*item));
+}
+
+void ffwrhex_(unit,item) word *unit,*item;{
+ word l=27;
+ if(file_arr[*unit]==NULL) fferror_(&l);
+ fprintf(file_arr[*unit],"%04.4x",(int)(*item));
+}
+
+void nextch_(unit,ch) word *unit,*ch;{
+ FILE *f=file_arr[*unit];
+ *ch=(word)getc(f);
+ if(*ch == EOF ) *ch = 2;
+ if(*ch == 26 ) *ch = 2;
+ if(*ch == '\n') *ch = 1;
+/* if(*ch == '\r') *ch = 1; */
+ if(*ch == '\r') *ch = ' ';
+}
+
+void frdchr_(unit,c,count) word *unit; char *c; long count;{
+ FILE *f=file_arr[*unit];
+ int i;
+ skip_nl:
+ i=getc(f);
+ if(i== EOF) i = 2;
+ if(i== 26) i = 2;
+ if(i=='\r') i = 1;
+ if(i=='\n') goto skip_nl;
+ *c=(char)i;
+}
+
+static int reclen=512;
+
+void openf_(itab,ident) word *itab,*ident;{
+ itab[0]=0;
+ itab[1]=*ident;
+ ffcrtmp_(ident);
+ reclen=256*sizeof(word);
+}
+
+void get_(itab,item) word *itab,*item;{
+ word recnr,offset,len;
+ itab[0]++;
+ recnr=itab[0]-1;
+ offset=recnr*reclen;
+ ffseek_(itab+1,&offset);
+ len = reclen;
+ ffread_(itab+1,item,&len);
+ if(len!=reclen){
+ len=30;
+ fferror_(&len);
+ }
+}
+
+void seek_(itab,number) word *itab,*number;{
+ itab[0]=*number;
+}
+
+void closf_(itab) int *itab;{
+ ffclose_(itab+1);
+}
+
+void put_(itab,item) word *itab,*item;{
+ word recnr,offset;
+ itab[0]++;
+ recnr=itab[0]-1;
+ offset=recnr*reclen;
+ ffseek_(itab+1,&offset);
+ ffwrite_(itab+1,item,&reclen);
+}
+
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE ML2
+C*****************************************************************************
+C ETAP KONCZACY KOMPILACJE
+C ZADANIA:
+C -PRZESORTOWANIE SYGNALIZACJI BLEDOW
+C -LISTING PROGRAMU ZRODLOWEGO Z WSTAWIONYMI SYGNALIZACJAMI
+C -W PRZYPADKU BLEDOW : ABORTOWANIE KOMPILATORA
+C
+C*****************************************************************************
+C
+C OPIS W DOKUMENTACJI: J.I.3
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 615
+C..........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+ INTEGER*2 ERRSGN
+ COMMON /ERRS/ ERRSGN(3, 426)
+C
+ COMMON /MSTA/ MLFREE, WNFREE, WNSTK, AL1BLK, AL1STK,
+ X AL2BLK, AL2SYM, AL2OTH, WNBLK, TLP, TLM,
+ X WNSUS, TOTMEM
+C
+ LOGICAL BTEST
+ dimension dig(4)
+cdsw BYTE JFNAME
+ COMMON /JF/JFNAME(72),JF
+cbc
+ integer*2 bigbuf
+ common /combuf/ ind, length, bigbuf(16000)
+cbc
+ integer*4 offset
+ character ch
+ character jfname
+ character*72 nam
+ equivalence(jfname(1),nam)
+
+cdeb --------------------- added =----------------
+ common /debug/deb,breakt(500),brnr,maxbr
+ logical deb
+cdeb ---------------------------------------
+
+ pagesz = 60
+ pagenr = 0
+ linpg = 60
+C------ PRZYGOTOWANIE WYDRUKOW STATYSTYK
+ TOTMEM = LMEM+302
+ TOTMEM = IAND(ISHFT(TOTMEM, -10), 63)
+ MLFREE = IOP(4)+1
+ WNFREE = IPMEM(ISFIN-2)
+ WNSTK = IPMEM(ISFIN-1)
+ WNSUS = (LPMEM-ISFIN) + WNSTK + 9
+ WNBLK = IPMEM(ISFIN-8)
+ AL1BLK = IPMEM(ISFIN-3)
+ AL1STK = IPMEM(ISFIN-4)
+C AL2BLK = IPMEM(ISFIN-5)
+C AL2SYM = IPMEM(ISFIN-6)
+C AL2OTH = IPMEM(ISFIN-7)
+ TLP = LPMEM
+ TLM = LMEM
+
+ offset = 0
+ call ffseek(16,offset)
+ length = 0
+ ind = 1
+
+ do 117 i=1,4
+ call frdchr(16, ch)
+117 dig(i) = ichar(ch)
+ call dec(i,dig)
+ LUN = 0
+ IF(.NOT.(BTEST(I,15))) GOTO 9999
+ LUN = 13
+ jfname(jf+1) = 'l'
+ jfname(jf+2) = 's'
+ jfname(jf+3) = 't'
+
+c unit 13 - listing (sequential)
+ call ffcreat(13,nam)
+C ---
+9999 IF(ERRFLG)GO TO 1000
+C*******GDY PROGRAM JEST POPRAWNY
+C ---
+ IF (LUN.EQ.0) GOTO 2500
+C ---
+ LPMF = 1
+C WSTAWIENIE STRAZNIKA DO TABLICY SYGNALIZACJI BLEDOW
+cdsw&bc ERRSGN(1,1) = 10000
+ ERRSGN(1,1) = 32000
+c
+ LPML = 1
+ GOTO 2000
+C
+C*******GDY PROGRAM NIEPOPRAWNY
+C -PRZYGOTOWANIE DO LACZENIA LISTINGU I SYGNALIZACJI BLEDOW
+ 1000 LPMF = 1
+ DO 100 I =1, 425
+cdsw&bc ERRSGN(1, I) = 10000
+ ERRSGN(1, I) = 32000
+ 100 CONTINUE
+ LPML = 0
+C ... SCIAGNIECIE TABLICY HASH'U
+ CALL MGHASH
+C ... SCIAGNIECIE I POSORTOWANIE SYGNALIZACJI BLEDOW
+ CALL MGERR
+C ... SKLEJENIE SYGNALIZACJI PARSERA ODWOLUJACYCH SIE DO TEJ
+C SAMEJ LINII
+ CALL MFLTR
+C
+C*************** LISTOWANIE PROGRAMU
+2000 CALL MLSTSC
+C------ PRZYGOTOWANIE ZAKONCZENIA KOMPILACJI
+2500 CONTINUE
+C------ PROGRAM POPRAWNY
+ IF (.NOT. ERRFLG) GOTO 7770
+C------ PROGRAM NIEPOPRAWNY
+3000 IF (ERRCNT .EQ. 0) GOTO 3100
+ call ffputnl(0)
+ call ffputi (0,ERRCNT,4)
+ call ffputcs(0,' error(s) detected')
+ call ffputnl(0)
+3100 IF (IOP(1) .LE. 7) GOTO 3200
+ call ffputcs(0,' Fatal Error: Source program abandoned')
+ call ffputnl(0)
+3200 CONTINUE
+7770 CONTINUE
+
+ call closf(ibuf3)
+
+ call ffclose(15)
+ if (errflg) call ffunlink(15)
+ call ffclose(16)
+C 16 is temporary file and will be automatically deleted after exit, but ...
+ call ffunlink(16)
+ call ffclose(17)
+cdeb ------------------ added --------------
+c deletion of the file 21 (for debugger )
+ if(.not.deb) go to 10
+ deb = .false.
+ call ffclose(21)
+ if (errflg) call ffunlink(21)
+10 continue
+cdeb
+cvax STOP
+ END
+
+cdsw ------------ added -------------------------------
+ subroutine dec(num,dig)
+ implicit integer (a-z)
+ dimension dig(4)
+c zamienia 4 cyfry hexadecymalne wpisane w dig na liczbe num
+c
+ do 10 i=1,4
+ a = iand(dig(i),X'00ff')
+ if(a.ge.ichar('a').and. a.le.ichar('f') ) go to 100
+ if(a.ge.ichar('A').and.a.le.ichar('F')) go to 99
+ a = a-ichar('0')
+ go to 110
+ 100 a = a-ichar('a')+10
+ go to 110
+ 99 a = a-ichar('A')+10
+ 110 dig(i) = a
+ 10 continue
+ num = dig(4)
+ num = ior(num,ishft(dig(1),12))
+ num = ior(num,ishft(dig(2),8))
+ num = ior(num,ishft(dig(3),4))
+ return
+ end
+
+
+
+ SUBROUTINE MLSTSC
+C--------------PROCEDURA LISTUJACA TEKST ZRODLOWY (SOURCE) I
+C WSTAWIAJACA DO NIEGO SYGNALIZACJE BLEDOW
+C
+C OPIS W DOKUMENTACJI: J.III.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 420
+C..........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL MREADLN, MREADSG
+ LOGICAL PRINT1, PRINT2
+C PRINT1, PRINT2 - FLAGI DRUKOWANIA LINII W BUFORACH BUFLN
+C
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+ INTEGER*2 ERRSGN
+ COMMON /ERRS/ ERRSGN(3, 426)
+C
+C-------------
+ ERRLINE = ERRSGN(1, LPMF)
+ NR = ERRSGN(2, LPMF)
+ ID = ERRSGN(3, LPMF)
+C......WCZYTANIE PIERWSZEJ LINII LISTINGU
+ PRINT2 = MREADLN(PRINT1)
+ LN1 = LN2
+ LGTH1 = LGTH2
+ DO 100 I=1, (LGTH1+3)/4
+ BUFLN1(I) = BUFLN2(I)
+ 100 CONTINUE
+C********************************
+C WCZYTYWANIE KOLEJNYCH LINII
+ 1000 IF (MREADLN(PRINT2) ) GOTO 5000
+C --SKOK, GDY SKONCZYL SIE TEKST ZRODLOWY, W BUFLN1 JEST JEGO
+C OSTATNIA LINIA
+C --- SPRAWDZENIE, CZY LINIA W BUFLN2 NIE ZAWIERA LINII Z SYGNALI-
+C ZACJA BLEDU Z PARSERA
+ IF (LN1 .NE. LN2) GOTO 2000
+C ---DRUKOWANIE LINII Z BUFLN1 Z INFORMACJA O TYM, ZE ZA NIA
+C BEDA SYGNALIZACJE BLEDOW
+C (W CZASIE DRUKOWANIA BUFLN2 JEST PRZEPISYWANY DO BUFLN1)
+ CALL PSLINE(.TRUE.)
+ PRINT1 = PRINT2
+C ---CZYTANIE I KOMPRESJA LINII Z SYGNALIZACJAMI BLEDOW Z PARSERA
+C - PIERWSZA LINIA ZNAJDUJE SIE W BUFLN1
+ IF (MREADSG(PRINT2)) GOTO 5000
+C W BUFLN1 JEST SKOMPRESOWANA LINIA Z SYGNALIZACJAMI
+C O ILE NIE MA SKOKU - W BUFLN2 JEST NOWA LINIA TEKSTU ZRODLOWEGO
+C SKOK - GDY SKONCZYL SIE TEKST ZRODLOWY
+C WYDRUKOWANIE OSTATNIEJ LINII Z SYGNALIZACJA BLEDOW PARSERA
+ CALL PSLINE (.FALSE.)
+ GOTO 3100
+C
+ 2000 IF (LN2 .GT. ERRLINE) GOTO 3000
+C ---NOWA LINIA POPRZEDZA SYGNALIZACJE BLEDOW
+ IF (PRINT1) CALL PSLINE(.FALSE.)
+ IF (PRINT1) GOTO 2500
+C ...SKOPIOWANIE BUFORA (NIE MUSI BYC W PSLINE)
+ LN1 = LN2
+ LGTH1 = LGTH2
+ DO 2100 I=1, (LGTH1+3)/4
+ BUFLN1(I) = BUFLN2(I)
+ 2100 CONTINUE
+ 2500 PRINT1 = PRINT2
+ GOTO 1000
+C ---NOWA LINIA WYSTEPUJE ZA SYGNALIZACJA BLEDOW
+ 3000 CALL PSLINE(.TRUE.)
+ PRINT1 = PRINT2
+C ---WYPISANIE SYGNALIZACJI BLEDOW ODNOSZACYCH SIE DO WYDRUKOWANEJ
+C LINII
+ 3100 CALL PERSGN(ERRLINE, NR, ID)
+ 3150 LPMF = LPMF+1
+ ERRLINE = ERRSGN(1, LPMF)
+cdsw&bc added check for guard - ERRLINE = 32000
+ if (errline .eq. 32000) goto 8000
+c
+ NR = ERRSGN(2, LPMF)
+ ID = ERRSGN(3, LPMF)
+ IF (NR .EQ. -1) GOTO 3150
+C SKOK - GDY TA SYGNALIZACJA ZOSTALA POMINIETA PRZEZ FILTROWANIE
+ IF (ERRLINE .LT. LN1) GOTO 3100
+C SKOK GDY NASTEPNA SYGNALIZACJA ODNOSI SIE DO LINII JUZ WYDRUKOWANEJ
+C ...LINIA ZA SYGNALIZACJA BLEDOW TEZ MUSI BYC DRUKOWANA
+ PRINT1 = .TRUE.
+ GOTO 1000
+C-----------------------------
+C ZAKONCZENIE LISTINGU - W BUFLN1 JEST OSTATNIA LINIA
+cdsw&bc 5000 IF (ERRLINE .EQ. 10000) GOTO 7000
+ 5000 IF (ERRLINE .EQ. 32000) GOTO 7000
+C --JEST TO PSEUDOSYGNALIZACJA (STRAZNIK)
+ CALL PSLINE(.TRUE.)
+C ---WYPISANIE RESZTY SYGNALIZACJI BLEDOW
+ 6000 IF (NR .NE. -1) CALL PERSGN(ERRLINE, NR, ID)
+ LPMF = LPMF+1
+ ERRLINE = ERRSGN(1, LPMF)
+cdsw&bc IF (ERRLINE .EQ. 10000) GOTO 8000
+ IF (ERRLINE .EQ. 32000) GOTO 8000
+ NR = ERRSGN(2, LPMF)
+ ID = ERRSGN(3, LPMF)
+ GOTO 6000
+C ---WYPISANIE OSTATNIEJ LINII Z LISTINGU, GDY ZA NIA NIE MA
+C SYGNALIZACJI BLEDOW
+ 7000 IF (PRINT1) CALL PSLINE(.FALSE.)
+ 8000 RETURN
+ END
+
+ SUBROUTINE PERSGN(LINE, NR, ID)
+C--------------PROCEDURA DRUKUJACA SYGNALIZACJE BLEDOW
+C LINE - NUMER LINII Z BLEDEM
+C NR - NUMER BLEDU
+C ID - IDENTYFIKATOR
+C
+C OPIS W DOKUMENTACJI: J.III.6
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 4865
+C.....................................................................
+C !!!!!! UWAGA !!!!!!
+C PO FORTRANIE (PRZED ASSEMBLACJA) DOLACZYC
+C ZAWARTOSC DECKU MPERSGNASS PRZED 'END'
+C -- ZAWIERA ON INICJALIZACJE TABLIC SYGNALIZACJI
+C BLEDOW
+C
+ IMPLICIT INTEGER (A-Z)
+ character itab(8)
+ equivalence (itab(1),nameid(1))
+
+ LOGICAL BTEST
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+
+ DIMENSION NAMEID(2)
+ integer*4 nameid
+
+ DO 201 I=1,8
+201 ITAB(I)=' '
+
+ LINPG = LINPG + 1
+ IF (LINPG .GT. PAGESZ) CALL PGINIT
+
+C ---DRUKOWANIE SYGNALIZACJI
+202 IF (ID .EQ. 0) GOTO 400
+ IF (ID .LT. 0) GOTO 300
+C ---ODKODOWANIE NAZWY
+ IF (.NOT. BTEST(ID, 0)) GOTO 400
+C -- W TYM PRZYPADKU NIE JEST TO IDENTYFIKATOR LECZ SLOWO KLUCZOWE
+ call naswa(id,itab)
+ GOTO 400
+
+C ---ODKODOWANIE ZNAKU
+300 nameid(1) = -id-1
+400 continue
+
+ CALL listing_error_line( lun, line, nr, NR, nameid(1) )
+ RETURN
+ END
+
+
+ SUBROUTINE MFLTR
+C-----------------PROCEDURA FILTRUJE SYGNALIZACJE BLEDOW - SKLEJA
+C SYGNALIZACJE O TYM SAMYM NUMERZE POCHODZACE Z
+C PARSERA I ODNOSZACE SIE DO TEJ SAMEJ LINII TEKSTU
+C ZRODLOWEGO
+C
+C OPIS W DOKUMENTACJI: J.II.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 202
+C........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+ INTEGER*2 ERRSGN
+ COMMON /ERRS/ ERRSGN(3, 426)
+C
+C
+C IER100 - ZAWIERA OSTATNIE LINIE TEKSTU W
+C KTORYCH SYGNALIZOWANO BLAD Z PRZEDZIALU
+C 101-143
+C IER200 - ANALOGICZNIE DLA PRZEDZIALU 201-212
+ INTEGER*2 IER100(43), IER200(12)
+ DATA IER100 /43*0/, IER200 /12*0/
+C
+C
+ DO 1000 I=LPMF,LPML
+C ...NRERR - NUMER BLEDU
+ NRERR = ERRSGN(2,I)
+ IF(NRERR .LE. 100) GOTO 1000
+ IF (NRERR .GE. 213) GOTO 1000
+ IF ( (NRERR .GE. 144) .AND. (NRERR .LE. 200) ) GOTO 1000
+C TE SYGNALIZACJE NIE PODLEGAJA SKLEJANIU
+C ...NRLINE - NUMER LINII
+ NRLINE = ERRSGN(1,I)
+ IF (NRERR .GT. 200) GOTO 500
+C ---TU BLAD Z PRZEDZIALU 101-143
+ NRERR = NRERR-100
+ IF (IER100(NRERR) .NE. NRLINE) GOTO 100
+C BLAD JUZ SYGNALIZOWANY
+ ERRSGN(2,I) = -1
+ GOTO 1000
+C ZAPAMIETANIE LINII Z TA SYGNALIZACJA
+ 100 IER100(NRERR) = NRLINE
+ GOTO 1000
+C ---TU BLAD Z PRZEDZIALU 201-212
+ 500 NRERR= NRERR-200
+ IF (IER200(NRERR) .NE. NRLINE) GOTO 600
+C BLAD JUZ SYGNALIZOWANY
+ ERRSGN(2,I) = -1
+ GOTO 1000
+C ZAPAMIETANIE LINII
+ 600 IER200(NRERR) = NRLINE
+C
+ 1000 CONTINUE
+ RETURN
+ END
+ LOGICAL FUNCTION MREADSG(PRINTER)
+C----------------------FUNKCJA CZYTA ORAZ WYKONUJE KOMPRESJE LINII
+C ZAWIERAJACYCH SYGNALIZACJE BLEDOW PARSERA.
+C WARUNEK WEJSCIOWY: BUFLN1 ZAWIERA OSTATNIA
+C LINIE (PIERWSZA Z SYGNALIZACJA BLEDOW PAR-
+C SERA)
+C BUFLN2 JEST PUSTY
+C WARUNEK WYJSCIOWY: BUFLN1 ZAWIERA OSTATNIA
+C SKOMPRESOWANA LINIE Z SYGNALIZACJAMI
+C BUFLN2 KOLEJNA LINIE TEKSTU ZRODLOWEGO
+C LUB JEST PUSTY (GDY TEKST SIE SKONCZYL)
+C WARTOSC FUNKCJI .TRUE. OZNACZA ZE TEKST
+C ZRODLOWY SIE SKONCZYL
+C
+C
+C OPIS W DOKUMENTACJI: J.III.5
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 402
+C..........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL MREADLN
+ LOGICAL PRINTER
+C PRINTER FLAGA DRUKOWANIA LINII Z BUFLN2
+C
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+C ---
+ character bln1(120), bln2(120)
+ EQUIVALENCE (BLN1(1),BUFLN1(1)),(BLN2(1),BUFLN2(1))
+C ---
+C
+C
+C
+ MREADSG = .TRUE.
+ 1000 CONTINUE
+ DO 1 I=LGTH1-2,LGTH1
+ BLN1(I-3) = BLN1(I)
+1 CONTINUE
+ LGTH1 = LGTH1 - 3
+ BLN1(LGTH1+1)= ' '
+ BLN1(LGTH1+2)=' '
+ BLN1(LGTH1+3)=' '
+C-----LINIA W BUFLN1 JEST SKOMPRESOWANA
+C WCZYTANIE KOLEJNEJ LINII DO BUFLN2
+ IF (MREADLN(PRINTER)) RETURN
+C POWROT, GDY BYLA TO OSTATNIA LINIA (MREADSG = .TRUE.)
+ IF (LN1 .NE. LN2) GOTO 9000
+C --LINIA W BUFLN2 NIE JEST SYGNALIZACJA BLEDU - SKOK
+C ---NOWA LINIA Z SYGNALIZACJA BLEDU
+C SPRAWDZENIE, CZY ? W BUFLN2 JEST DALEJ NIZ WYNOSI
+C DLUGOSC LINII W BUFLN1, TZN. CZY LINIE MOGA BYC SKLEJONE
+ IF (LGTH1 .LT. (LGTH2-6)) GOTO 3000
+C ----TU LINIE NIE MOGA BYC SKLEJONE
+C WYDRUKOWANIE LINII Z BUFLN1 Z PRZESLANIEM ZAWARTOSCI BUFORA
+C BUFLN2 DO BUFLN1 I PRZEJSCIE DO KOMPRESJI NOWEJ SYGNALIZACJI
+ CALL PSLINE(.FALSE.)
+ GOTO 1000
+C ---DOKLEJANIE LINII Z BUFLN2 DO BUFLN1
+3000 DO 3200 I=LGTH1+1,LGTH2
+ BLN1(I) = BLN2(I)
+ 3200 CONTINUE
+ LGTH1 = LGTH2
+ GOTO 1000
+C------ZAKONCZENIE
+ 9000 MREADSG = .FALSE.
+ RETURN
+ END
+
+
+ SUBROUTINE NASWA(L,ITAB)
+C
+C PARAMETR L - NUMER IDENTYFIKATORA Z TABLICY HASH
+C
+C OPIS W DOKUMENTACJI: J.III.6
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 120
+C.....................................................................
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ COM(302),HASH(8000),M,I,K
+
+ character itab(8)
+ I=L
+ J=1
+ IF (HASH(I).LE.0) RETURN
+5 IF (HASH(I).LT.61) GOTO 10
+C DWA ZNAKI W SLOWIE
+ K=ISHFT(HASH(I),-6)
+ itab(j) = char(snak(k))
+ J=J+1
+C JEDEN ZNAK
+10 K=IAND(HASH(I),63)
+ itab(j) = char(snak(k))
+ J=J+1
+ I=HASH(I+1)
+ IF (I.GE.0) RETURN
+ I=-I
+ GOTO 5
+ END
+
+
+ INTEGER FUNCTION SNAK(K)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+ IF (K.EQ.60) K=0
+ IF (K.GT.9) GOTO 10
+C CYFRA - KOD MIEDZY 0 A 9
+ SNAK = K + ICHAR('0')
+ RETURN
+10 IF (K.GT.35) GOTO 20
+C LITERA - KOD MIEDZY 10 A 35
+ SNAK = ICHAR('A') + K - 10
+ RETURN
+C LACZNIK - UNDERSCORE
+20 SNAK = ICHAR('_')
+ RETURN
+ END
+ SUBROUTINE MGHASH
+C--------------SCIAGNIECIE TABLICY NAZW (HASH'U) SCANNERA DO
+C SYGNALIZACJI BLEDOW
+C
+C OPIS W DOKUMENTACJI: J.II.1
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 330
+C......................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ x hash(8000)
+cdsw X IPMEM(5000)
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+C
+ CALL SEEK(IBUF3, 0)
+ do 100 i=1,8000,256
+ call get(ibuf3,hash(i))
+ 100 CONTINUE
+ RETURN
+ END
+
+
+ SUBROUTINE PSLINE (WSIGN)
+C--------------DRUKUJE LINIE TEKSTU ZRODLOWEGO PRZECHOWYWANA
+C W BUFLN1.
+C WSIGN - .TRUE. - OZNACZA, ZE DO LINII BEDZIE ODNO-
+C SILA SIE ROWNIEZ INFORMACJA O BLEDZIE, W ZWIAZKU Z TYM
+C LINIA TA NIE POWINNA BYC OSTATNIA LINIA NA STRONIE
+C
+C OPIS W DOKUMENTACJI: J.III.3
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 153
+C.....................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL WSIGN
+C
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+cailvax
+c Maximal record length for the printer is 132 characters (VAX).
+c Hence only 114 characters remain for the source line.
+ character buf(114)
+ equivalence (buf(1),bufln1(1))
+
+ LINPG = LINPG + 1
+ IF (LINPG .GT. PAGESZ) GOTO 2000
+C --SKONCZYLA SIE STRONA
+ IF (WSIGN .AND. (LINPG .EQ. PAGESZ) ) GOTO 2000
+C --NA STRONIE NIE ZMIESCI SIE LINIA RAZEM Z SYGNA-
+C LIZACJA, ROZPOCZECIE NOWEJ STRONY
+
+1000 k = lgth1
+ if (k .gt. 114) k = 114
+
+cailvax that's a pity those 6 characters are truncated
+cvax ---------- added
+
+ call ffputcs(lun,' ')
+ call ffputi (lun,ln1,6)
+ call ffputcs(lun,' ')
+ call ffputs (lun,buf,k)
+ call ffputnl(lun)
+
+ LN1 = LN2
+ LGTH1 = LGTH2
+ LGTH2 = (LGTH2+3)/4
+ DO 1100 I=1, LGTH2
+ BUFLN1(I) = BUFLN2(I)
+ 1100 CONTINUE
+ RETURN
+ 2000 CALL PGINIT
+ GOTO 1000
+ END
+
+
+
+ SUBROUTINE PGINIT
+C--------------ROZPOCZECIE NOWEJ STRONY LISTINGU
+C
+C OPIS W DOKUMENTACJI: J.III.2
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 162
+C.......................................................................
+
+ IMPLICIT INTEGER (A-Z)
+
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+
+ COMMON /BLANK/ IP(1)
+
+ IF (LUN.EQ.2) RETURN
+ PAGENR = PAGENR + 1
+ LINPG = 1
+
+ call ffputnl(LUN)
+ call ffputff(LUN)
+ call ffputcs(LUN,' IIUW LOGLAN-82')
+ call ffputcs(LUN,' UNIX Compiler - Ver. Oct 88')
+ call ffputspaces(LUN,15)
+ call ffputcs(LUN,'PAGE ')
+ call ffputi (LUN,PAGENR,7)
+ call ffputnl(LUN)
+
+ RETURN
+ END
+
+
+
+ SUBROUTINE MGERR
+C--------------SCIAGNIECIE ZE STRUMIENIA 2 SYGNALIZACJI BLEDOW,
+C POSORTOWANIE ICH WZGLEDEM NUMEROW LINII W TEKSCIE
+C ZRODLOWYM (PROCEDURA MSERR)
+C POSORTOWANE SYGNALIACJE ZNAJDUJA SIE W TABLICY
+C ERRSGN (COMMON /ERRS/) OD MIEJSCA LPMF DO LPML
+C DOPUSZCZALNA LICZBA SYGNALIZACJI 425 - INACZEJ PRZE-
+C PELNIENIE 10
+C
+C ZMIENIONE (WSZYSTKO BYLO DO DUPY) P.G.
+C ========= =======
+C
+C........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+C
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+ INTEGER*2 ERRSGN
+ COMMON /ERRS/ ERRSGN(3, 426)
+C
+C BUDOWA STRUMIENIA 2
+C SLOWA 1-7 -BUFOR DLA PROCEDUR ZAPISU I ODCZYTU (OPIS STRUMIENIA)
+C SLOWO 8 -NUMER AKTUALNIE ZAPISYWANEGO BLOKU
+C SLOWO 9 -INDEKS PIERWSZEJ WOLNEJ POZYCJI BLOKU AKTUALNIE TWORZO-
+C NEGO
+C SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU
+C SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO-
+C WA 11)
+C
+ LPMF = IBUF2(8)*85
+ ERRCNT = LPMF + (IBUF2(9) - 11)/3
+C ERRCNT - LICZBA SYGNALIZACJI BLEDOW
+ LPML = ERRCNT
+ IF (ERRCNT .GT. 425) GOTO 2000
+C --SKOK GDY LICZBA SYGNALIZACJI BLEDOW PRZEKRACZA
+C DOPUSZCZALNA
+C
+C --- SYTUACJA NORMALNA - LICZBA SYGNALIZACJI BLEDOW JEST DOPUSZCZALNA
+ IF (ERRCNT .EQ. LPMF) GOTO 200
+C ... PRZEPISANIE TROJEK SYGNALIZACJI BLEDOW Z BUFORA IBUF2
+C DO TABLICY ERRSGN
+ K = IBUF2(9) - 1
+ DO 100 I=11, K, 3
+ LPMF = LPMF+1
+ ERRSGN(1, LPMF) = IBUF2(I)
+ ERRSGN(2, LPMF) = IBUF2(I+1)
+ ERRSGN(3, LPMF) = IBUF2(I+2)
+ 100 CONTINUE
+C
+C...WCZYTANIE SYGNALIZACJI BLEDOW ZE STRUMIENIA 2
+ 200 CALL SEEK(IBUF2, 0)
+ K = IBUF2(8)
+C ... K LICZBA BLOKOW
+ IF (K .EQ. 0) GOTO 5000
+ 1000 LPMF = 0
+ DO 1200 I=1, K
+ CALL GET(IBUF2, IBUF2(10) )
+ DO 1100 J=11, 265, 3
+ LPMF = LPMF+1
+ ERRSGN(1, LPMF) = IBUF2(J)
+ ERRSGN(2, LPMF) = IBUF2(J+1)
+ ERRSGN(3, LPMF) = IBUF2(J+2)
+ 1100 CONTINUE
+ 1200 CONTINUE
+C ... PRZEJSCIE DO CZESCI SORTUJACEJ
+ GOTO 5000
+C
+C
+C-----SYTUACJA PRZEKROCZENIA DOPUSZCZALNEJ LICZBY SYGNALIZACJI
+C -WCZYTANIE PIERWSZYCH 425 SYGNALIZACJI, TJ. 8 BLOKOW
+C SYG. 500 BEDZIE OPISYWAC PRZEKROCZENIE TABLICY SYGNALIZACJI
+C
+ 2000 IOP(1) = 1
+ K = IBUF2(8)
+ CALL SEEK(IBUF2, K)
+ CALL PUT(IBUF2, IBUF2(10) )
+ CALL SEEK(IBUF2, 0)
+ LPMF = 0
+ DO 2200 I=1,5
+ CALL GET(IBUF2, IBUF2(10))
+ DO 2100 J=11, 265, 3
+ LPMF = LPMF+1
+ ERRSGN(1,LPMF) = IBUF2(J)
+ ERRSGN(2, LPMF) = IBUF2(J+1)
+ ERRSGN(3, LPMF) = IBUF2(J+2)
+ 2100 CONTINUE
+ 2200 CONTINUE
+ ERRSGN(1, 425) = 9999
+ ERRSGN(2, 425) = 10
+ ERRSGN(3, 425) = 0
+ LPML = 425
+C
+C
+C*******SORTOWANIE SYGNALIZACJI BLEDOW
+ 5000 CALL MSERR
+cdsw&bc ERRSGN(1,LPML+1) = 10000
+ ERRSGN(1,LPML+1) = 32000
+ CALL CLOSF(IBUF2)
+ RETURN
+ END
+
+
+
+ LOGICAL FUNCTION MREADLN (PRINTF)
+C--------------PROCEDURA WCZYTUJE LINIE WSTEPNIE UTWORZONEGO
+C LISTINGU (ZE STRUMIENIA 1) DO BUFORA BUFLN2
+C PRINTF - FLAGA LISTOWANIA LINII, MA WARTOSC
+C .TRUE. GDY LINIE NALEZY WYDRUKOWAC
+C //DODATKOWO MREADLN MA WARTOSC .TRUE., GDY NAPOTKANY
+C JEST KONIEC PLIKU
+C
+C OPIS W DOKUMENTACJI: J.III.4
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 225
+C..........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL PRINTF
+C
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+C
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+ character bufln3(120)
+ equivalence (bufln2(1), bufln3(1))
+ character ch
+ character bln2(4)
+ integer*4 bufelem
+ dimension dig(4)
+ EQUIVALENCE(BUFELEM,BLN2(1))
+
+ DATA BS / ' ' /
+
+ MREADLN = .FALSE.
+ do 118 i=1,4
+ call frdchr(16, ch)
+ dig(i) = ichar(ch)
+ if (dig(i) .eq. 2) goto 1000
+118 continue
+ call dec(ln2,dig)
+ call frdchr(16, ch)
+ pfg = ichar(ch)-48
+ do 119 i=1,120
+ call frdchr(16, bufln3(i))
+ if (ichar(bufln3(i)) .eq. 1) goto 121
+119 continue
+121 continue
+ do 122 j=i, 120
+122 bufln3(j) = ' '
+cdsw&bc
+ LGTH2 = 1
+ DO 2 I=2,30
+ IF (BUFLN2(I).NE.BS) LGTH2 = I
+2 CONTINUE
+ PRINTF = (PFG.NE.0) .AND. (LUN.EQ.13)
+ BUFELEM = BUFLN2(LGTH2)
+ LGTH2 = 4*LGTH2
+ DO 10 I=4,1,-1
+ IF(BLN2(I).NE.' ')RETURN
+10 LGTH2 = LGTH2-1
+ RETURN
+C---------KONIEC TEKSTU ZRODLOWEGO
+ 1000 MREADLN = .TRUE.
+ RETURN
+ END
+
+
+
+ SUBROUTINE MSERR
+C--------------PROCEDURA SORTOWANIA SYGNALIZACJI BLEDOW.
+C ALGORYTM:
+C - SORTOWANIE PRZEZ WTLACZANIE BLOKOW ZAWIERAJACYCH
+C - (GOWNO - ZWYKLY BUBBLE SORT) P.G.
+C
+C.....................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+ INTEGER*2 ERRSGN
+ COMMON /ERRS/ ERRSGN(3, 426)
+C
+ A=LPML-1
+ LPMF=1
+ IF(A.LE.0)RETURN
+ DO 1000 I=1,A
+ MAX=19999
+ DO 999 J=I,LPML
+ IF(ERRSGN(1,J).GT.MAX)GO TO 999
+ MAX=ERRSGN(1,J)
+ IMAX=J
+999 CONTINUE
+ J=ERRSGN(1,I)
+ ERRSGN(1,I)=ERRSGN(1,IMAX)
+ ERRSGN(1,IMAX)=J
+ J=ERRSGN(2,I)
+ ERRSGN(2,I)=ERRSGN(2,IMAX)
+ ERRSGN(2,IMAX)=J
+ J=ERRSGN(3,I)
+ ERRSGN(3,I)=ERRSGN(3,IMAX)
+ ERRSGN(3,IMAX)=J
+1000 CONTINUE
+ RETURN
+ END
+
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include <stdio.h>
+
+#if WSIZE==4
+ typedef long word;
+#elif WSIZE==2
+ typedef short word;
+#else
+ Define WSIZE to 2 or 4 !
+#endif
+
+extern FILE *file_arr[];
+
+
+#ifndef NO_PROTOTYPES
+static char *find_msg( int );
+#else
+static char *find_msg();
+#endif
+
+
+void listing_error_line__( lun, line, nr, errno, nameid )
+ word *lun,*line,*nr,*errno;
+ char *nameid;
+{
+ FILE *f=stdout;
+ if( *lun != 0L ) f=file_arr[*lun];
+ fprintf(f,"*** %6d ERROR %6d %s %8.8s\n",(int)(*line),(int)(*nr),find_msg((int)(*errno)),nameid);
+}
+
+
+
+static char declaration_part_overloaded[]={"***DECLARATION PART OVERLOADED"};
+static char class_identifier_expected[]={"CLASS IDENTIFIER EXPECTED"};
+static char null_program[]={"NULL PROGRAM"};
+static char too_many_prototypes[]={"***TOO MANY PROTOTYPES"};
+static char undeclared_identifier[]={"UNDECLARED IDENTIFIER"};
+static char diff_lengths[]={"DIFFERENT LENGTHS OF THE 2ND PARAMETERS LISTS"};
+static char incompat_kinds[]={"INCOMPATIBLE KINDS OF THE 2ND LEVEL PARAMETERS"};
+
+
+static struct { int errno; char *errmsg; } err_tab[]={
+
+{ 0,declaration_part_overloaded },
+{ 10,"***TOO MANY ERRORS" },
+{ 41,declaration_part_overloaded },
+{ 101,"\":=\" EXPECTED" },
+{ 102,"\";\" EXPECTED" },
+{ 103,"\"THEN\" EXPECTED" },
+{ 104,"\"FI\"/\"ELSE\" EXPECTED" },
+{ 105,"\"OD\" EXPECTED" },
+{ 106,"\"(\" EXPECTED" },
+{ 107,"\")\" EXPECTED" },
+{ 108,"\"DO\" EXPECTED" },
+{ 109,"IDENTIFIER EXPECTED" },
+{ 110,"TOO MANY EXITS" },
+{ 111,"ILLEGAL CHARACTER" },
+{ 112,"WRONG STRUCTURE OF \"IF\"-STATEMENT" },
+{ 113,"\"END\" MISSING" },
+{ 114,"\".\" EXPECTED" },
+{ 115,"ILLEGAL CONSTANT IN EXPRESSION" },
+{ 116,"\"=\" EXPECTED" },
+{ 117,"CONSTANT EXPEXCTED" },
+{ 118,"\":\" EXPECTED" },
+{ 119,"UNIT KIND SPECIFICATION EXPECTED" },
+{ 120,"\"HIDDEN\" OR \"CLOSE\" OCCURRED TWICE" },
+{ 121,"HIDDEN OR CLOSE OUT OF A CLASS" },
+{ 122,"\"BLOCK\" EXPECTED" },
+{ 123,"OBJECT EXPRESSION IS NOT A GENERATOR" },
+{ 124,"\"DIM\" EXPECTED" },
+{ 125,"\"TO\"/\"DOWNTO\" EXPECTED" },
+{ 126,"ILLEGAL ARITHMETIC OPERATOR" },
+{ 127,"DECLARATION PART EXPECTED" },
+{ 128,"INCORRECT IDENTIFIER AT \"END\"" },
+{ 129,"WRONG STRUCTURE OF \"CASE\"-STATEMENT" },
+{ 130,"WRONG STRUCTURE OF \"DO\"-STATEMENT" },
+{ 131,"ILLEGAL USE OF \"MAIN\"" },
+{ 132,"\"WHEN\" EXPECTED" },
+{ 133,"TOO MANY BRANCHES IN \"CASE\"-STATEMENT" },
+{ 134,"\"BEGIN\" MISSING" },
+{ 135,"BAD OPTION" },
+{ 136,"IS IT REALLY A LOGLAN PROGRAM ???" },
+{ 137,"\"BLOCK\" MISSING -PARSING BEGAN" },
+{ 138,"\"REPEAT\" OUT OF A LOOP" },
+{ 139,"THERE IS NO PATH TO THIS STATEMENT" },
+{ 140,"\"ANDIF\"/\"ORIF\" MIXED" },
+{ 141,"ARRAY OF \"SEMAPHORE\" IS ILLEGAL" },
+{ 142,"WRONG HANDLER END" },
+{ 143,"LASTWILL INSIDE A STRUCTURED STATEMENT" },
+{ 144,"REPEATED LASTWILL" },
+{ 145,"NO PARAMETER SPECIFICATION" },
+{ 146,"WRONG REGISTER SPECIFICATION" },
+{ 147,"\",\" EXPECTED" },
+{ 191,null_program },
+{ 196,"***TOO MANY IDENTIFIERS" },
+{ 197,"***TOO MANY FORMAL PARAMETERS" },
+{ 198,"***PARSER STACK OVERLOADED" },
+{ 199,too_many_prototypes },
+{ 201,"WRONG REAL CONSTANT" },
+{ 202,"WRONG COMMENT" },
+{ 203,"WRONG CHARACTER CONSTANT" },
+{ 204,"WRONG INTEGER CONSTANT" },
+{ 205,"INTEGER OVERFLOW" },
+{ 206,"REAL OVERFLOW" },
+{ 211,"IDENTIFIER TOO LONG" },
+{ 212,"STRING TOO LONG" },
+{ 301,"PREFIX IS NOT A CLASS" },
+{ 303,"COROUTINE/PROCESS ILLEGAL HERE AS PREFIX" },
+{ 304,"HIDDEN IDENTIFIER CANNOT BE TAKEN" },
+{ 305,undeclared_identifier },
+{ 306,"UNDECLARED TYPE IDENTIFIER" },
+{ 307,"TYPE IDENTIFIER EXPECTED" },
+{ 308,"UNDECLARED PREFIX IDENTIFIER" },
+{ 309,"DECLARED MORE THAN ONCE" },
+{ 310,"TAKEN LIST IN UNPREFIXED UNIT" },
+{ 316,"FORMAL TYPE SPECIFICATION AFTER USING" },
+{ 317,"HIDDEN TYPE IDENTIFIER" },
+{ 318,"TYPE IDENTIFIER NOT TAKEN" },
+{ 319,"HIDDEN IDENTIFIER IN THE LIST" },
+{ 320,"IDENTIFIER IN THE LIST NOT TAKEN" },
+{ 321,"IDENTIFIER CANNOT BE TAKEN" },
+{ 322,"HIDDEN PREFIX IDENTIFIER" },
+{ 323,"PREFIX IDENTIFIER NOT TAKEN" },
+{ 329,"ONLY PROCEDURE AND FUNCTION MAY BE VIRTUAL" },
+{ 330,"VIRTUAL IN UNPREFIXED BLOCK/PROCEDURE/FUNCTION" },
+{ 331,"INCOMPATIBLE KINDS OF VIRTULS" },
+{ 332,"INCOMPATIBLE TYPES OF VIRTUALS" },
+{ 333,"DIFFERENT LENGTH OF FORM. PARAM. LISTS IN VIRTUALS" },
+{ 334,"INCOMPATIBLE KINDS OF THE 1ST LEVEL PARAMETERS" },
+{ 335,"INCOMPATIBLE TYPES OF THE 1ST LEVEL PARAMETERS" },
+{ 336,diff_lengths },
+{ 337,incompat_kinds },
+{ 338,"INCOMPATIBLE TYPES OF THE 2ND LEVEL PARAMETERS" },
+{ 341,"***DECLARATION PART OVERLOADED" },
+{ 342,"***TOO MANY CLASSES DECLARED" },
+{ 343,too_many_prototypes },
+{ 350,"UNDECLARED SIGNAL IDENTIFIER" },
+{ 351,"HIDDEN SIGNAL IDENTIFIER" },
+{ 352,"SIGNAL IDENTIFIER NOT TAKEN" },
+{ 353,"SIGNAL IDENTIFIER EXPECTED" },
+{ 354,"DIFFERENT TYPES OF PARAMETERS" },
+{ 355,"INCOMPATIBLE KINDS OF THE PARAMETERS" },
+{ 356,"DIFFERENT IDENTIFIERS OF PARAMETERS" },
+{ 357,incompat_kinds },
+{ 358,"DIFFERENT TYPES OF THE 2ND LEVEL PARAMETERS" },
+{ 359,diff_lengths },
+{ 360,"DIFFERENT LENGTHS OF FORM. PARAM. LISTS IN SIGNALS" },
+{ 361,"NON-LOCAL FORMAL TYPE CANNOT BE USED" },
+{ 362,"REPEATED HANDLER FOR SIGNAL" },
+{ 370,"ONLY \"INPUT\" IS LEGAL HERE" },
+{ 398,"CLASS PREFIXED BY ITSELF" },
+{ 399,"CYCLE IN PREFIX SEQUENCE" },
+{ 401,"WRONG LABEL IN \"CASE\"" },
+{ 402,"\"CASE\"-STATEMENT NESTED TOO DEEPLY" },
+{ 403,"TOO LONG SPAN OF \"CASE\" LABELS" },
+{ 404,"REPEATED LABEL IN \"CASE\"-STATEMENT" },
+{ 405,"ILLEGAL TYPE OF \"CASE\" EXPRESSION" },
+{ 406,"DIFFERENT TYPES OF LABELS AND \"CASE\" EXPRESSION" },
+{ 407,"NON-LOGICAL EXPRESSION AFTER \"IF\"/\"WHILE\"" },
+{ 408,"REAL CONSTANT OUT OF INTEGER RANGE" },
+{ 410,"SIMPLE VARIABLE EXPECTED" },
+{ 411,"NON-INTEGER CONTROL VARIABLE" },
+{ 412,"NON-INTEGER EXPRESSION" },
+{ 413,"FILE EXPRESSION EXPECTED" },
+{ 414,"STRING EXPRESSION EXPECTED" },
+{ 415,"REFERENCE EXPRESSION EXPECTED" },
+{ 416,"ARRAY EXPRESSION EXPECTED" },
+{ 417,"BOOLEAN EXPRESSION EXPECTED" },
+{ 418,"SEMAPHORE VARIABLE EXPECTED" },
+{ 419,"ILLEGAL TYPE IN \"OPEN\"" },
+{ 420,"VARIABLE EXPECTED" },
+{ 421,"CLASS IDENTIFIER AFTER \"NEW\" EXPECTED" },
+{ 422,"PROCEDURE IDENTIFIER AFTER \"CALL\" EXPECTED" },
+{ 423,"\"NEW\" MISSING" },
+{ 424,"\"CALL\" MISSING" },
+{ 425,"\"INNER\" OUT OF A CLASS" },
+{ 426,"\"INNER\" OCCURRED MORE THAN ONCE" },
+{ 427,"\"WIND\"/\"TERMINATE\" OUT OF A HANDLER" },
+{ 428,"\"INNER\" INSIDE LASTWILL" },
+{ 429,"DEFINITION CANNOT BE REDUCED TO CONSTANT" },
+{ 430,"UNDEFINED CONSTANT IN THE DEFINITION" },
+{ 431,"WRONG NUMBER OF INDICES" },
+{ 432,"INDEX OUT OF RANGE" },
+{ 433,"UPPER BOUND LESS THAN LOWER BOUND" },
+{ 434,"TOO MANY SUBSCRIPTS" },
+{ 435,"VARIABLE IS NOT ARRAY" },
+{ 440,"TYPE IDENTIFIER EXPECTED AFTER \"ARRAYOF\"" },
+{ 441,"INCORRECT FORMAT IN \"WRITE\"" },
+{ 442,"ILLEGAL EXPRESSION IN \"WRITE\"" },
+{ 443,"ILLEGAL TYPE OF VARIABLE IN \"READ\"" },
+{ 444,"NO DATA FOR I/O TRANSFER" },
+{ 445,"ILLEGAL EXPRESSION IN \"PUT\"" },
+{ 446,"ILLEGAL TYPE OF VARIABLE IN \"GET\"" },
+{ 448,"\"RAISE\" MISSING" },
+{ 449,"SIGNAL IDENTIFIER AFTER \"RAISE\" EXPECTED" },
+{ 450,"ILLEGAL PROCEDURE OCCURRENCE" },
+{ 451,"ILLEGAL CLASS OCCURRENCE" },
+{ 452,"ILLEGAL TYPE OCCURRENCE" },
+{ 453,"ILLEGAL SIGNAL OCCURRENCE" },
+{ 454,"ILLEGAL OPERATOR OCCURRENCE" },
+{ 455,"WRONG NUMBER OF OPERANDS" },
+{ 460,"DIVIDED BY ZERO" },
+{ 469,"WRONG REGISTER NUMBER" },
+{ 470,"ILLEGAL INPUT PARAMETER" },
+{ 471,"ILLEGAL OUTPUT PARAMETER" },
+{ 472,"ILLEGAL TYPE PARAMETER" },
+{ 473,"ILLEGAL PROCEDURE PARAMETER" },
+{ 474,"ILLEGAL FUNCTION PARAMETER" },
+{ 475,"ILLEGAL LEFT SIDE OF \"IS\"/\"IN\"" },
+{ 476,"ILLEGAL RIGHT SIDE OF \"IS\"/\"IN\"" },
+{ 477,"ILLEGAL PARAMETER OF \"ATTACH\"" },
+{ 478,"ILLEGAL TYPE OF EXPRESSION" },
+{ 479,"NEGATIVE STEP VALUE" },
+{ 500,"***PROGRAM UNEXPECTEDLY HARD" },
+{ 550,"***STACK OVERLOADED" },
+{ 551,"***TOO MANY AUXILIARY VARIABLES NEEDED" },
+{ 552,"***TOO MANY AUXILIARY REFERENCE VARIABLES NEEDED" },
+{ 553,"***STATEMENT SEQUENCE TOO LONG OR TOO COMPLICATED" },
+{ 554,"***REAL CONSTANTS DICTIONARY OVERFOW" },
+{ 600,undeclared_identifier },
+{ 601,"ILLEGAL TYPE BEFORE \".\"" },
+{ 602,"CLOSE IDENTIFIER AFTER \".\"" },
+{ 603,"UNDECLARED IDENTIFIER AFTER \".\"" },
+{ 604,"ILLEGAL OPERAND TYPE" },
+{ 605,"ILLEGAL TYPE IN \"DIV\"/\"MOD\" TERM" },
+{ 606,"INCOMPATIBLE TYPES IN COMPARISON" },
+{ 607,"UNRELATED CLASS TYPES IN COMPARISON" },
+{ 608,"STRINGS CANNOT BE COMPARED" },
+{ 609,"INCOMPATIBLE TYPES IN ASSIGNMENT/TRANSMISSION" },
+{ 610,"UNRELATED CLASS TYPES IN ASSIGNMENT/TRANSMISSION" },
+{ 611,"CONSTANT AFTER \".\"" },
+{ 612,"THIS CLASS DOES NOT OCCUR IN SL-CHAIN" },
+{ 613,class_identifier_expected },
+{ 614,class_identifier_expected },
+{ 615,"ILLEGAL TYPE BEFORE \"QUA\"" },
+{ 616,"ILLEGAL TYPE AFTER \"QUA\"" },
+{ 617,"ILLEGAL TYPE AFTER \"QUA\"" },
+{ 618,"UNRELATED TYPES IN \"QUA\"-EXPRESSION" },
+{ 619,"HIDDEN IDENTIFIER" },
+{ 620,"NON-TAKEN IDENTIFIER" },
+{ 621,"INVISIBLE IDENTIFIER AFTER \".\"" },
+{ 622,"FORMAL PARAMETER LIST SHORTER" },
+{ 623,"FORMAL PARAMETER LIST LONGER" },
+{ 624,"ACTUAL PARAMETER IS NOT A REFERENCE TYPE" },
+{ 625,"ACTUAL PARAMETER IS NOT A TYPE" },
+{ 626,"PROCEDURE-FUNCTION CONFLICT BETWEEN PARAMETERS" },
+{ 627,"UNMATCHED HEADS - WRONG KINDS OF PARAMETERS" },
+{ 628,"UNMATCHED HEADS-INCOMPATIBLE TYPES IN LISTS" },
+{ 629,"UNMATCHED HEADS-UNRELATED CLASS TYPES IN LISTS" },
+{ 630,"UNMATCHED HEADS-DIFFERENT NUMBERS OF PARAMETERS" },
+{ 631,"INCOMPATIBLE TYPES OF FUNCTION PARAMETERS" },
+{ 632,"FUNCTION/PROCEDURE EXPECTED" },
+{ 633,null_program },
+{ 634,"UNMATCHED HEADS-TOO WEAK TYPE IN ACTUAL LIST" },
+{ 635,"STANDARD FUNCTION/PROCEDURE CANNOT BE ACTUAL PAR." },
+{ 636,"ILLEGAL USE OF SEMAPHORE" },
+{ 637,"\"SEMAPHORE\" TYPE CANNOT BE USED" }
+
+};
+
+
+static char *find_msg( errno ) int errno;{
+ int l=0;
+ int u=sizeof(err_tab)/sizeof(err_tab[0]);
+ while( l!=u ){
+ int m= ( l+u )/2 ;
+ if( errno > err_tab[m].errno ) l=m;
+ else
+ if( errno < err_tab[m].errno ) u=m;
+ else
+ l=u=m;
+ }
+ if( err_tab[l].errno != errno )
+ return "UNKNOWN ERROR MESSAGE NUBER - INTERNAL COMPILER ERROR";
+ return err_tab[l].errmsg;
+}
+
--- /dev/null
+it0+
+(hash)+
+(wan1+wan2+wan3+scan)+
+(it1+dsw)+
+(al11+al12+resume+spgrec)+
+al13+
+(ml2)+
+debug+memfil+main+ifun+stdio+ml3
+loglan
+
+
+
+
--- /dev/null
+program doctext(input,output,infile,outfile);\r
+const ff = 12;\r
+ lf = 10;\r
+ cr = 13;\r
+var c:char;\r
+ infile,outfile:file of char;\r
+begin\r
+ reset(infile); rewrite(outfile);\r
+ read(infile,c);\r
+ if c <> '1' then write(outfile,c);\r
+ while not eof(infile) do\r
+ begin\r
+ read(infile,c);\r
+ if ord(c) = lf then\r
+ begin\r
+ if not eof(infile) then\r
+ begin\r
+ read(infile,c);\r
+ if c = '1' then write(outfile,chr(ff)) else\r
+ if c <> '+' then write(outfile,chr(lf));\r
+ end else write(outfile,chr(lf));\r
+ end else write(outfile,c);\r
+ end\r
+ end.
\ No newline at end of file
--- /dev/null
+module execprog[];\r
+(*CBC B.Ciesielski *)\r
+(* PASCAL routines for EXEC standard function *)\r
+\r
+var\r
+ pspdd : word;\r
+ defdsdd : word;\r
+ envdd : word;\r
+ cesxqq [external] : word; ! ES register from Pascal\r
+ addr_ptr : ads of word;\r
+ ax,bx,cx,dx,si,di : word; ! General Registers\r
+ ds,es : word; ! Segment Registers\r
+ errcode : word; ! Error code returned from DOS\r
+\r
+procedure dos(var ax,bx,cx,dx,si,di,ds,es,errcode : word); external;\r
+\r
+procedure initdd(var ax,bx,cx,dx,si,di,ds,es : word);\r
+{INITDD Initialize registers for call to DOS.}\r
+ begin {initdd}\r
+ ds := defdsdd; ! Program Data Segment\r
+ es := ds;\r
+ si := 0;\r
+ di := 0;\r
+ ax := 0;\r
+ bx := 0;\r
+ cx := 0;\r
+ dx := 0\r
+ end; {initdd}\r
+\r
+procedure asciizdd(const lstr : lstring; var astr : string);\r
+{ASCIIZDD This procedure converts a lstring variable to a ASCIIZ string.\r
+ An asciiz string is terminated by a byte of zeroes.}\r
+ var\r
+ len,alen : byte;\r
+ begin {asciizdd}\r
+ len := lstr.len;\r
+ alen := wrd(upper(astr));\r
+ if (len >= alen) then\r
+ len := alen - 1;\r
+ movel(adr lstr[1],adr astr[1],len);\r
+ astr[len + 1] := chr(0)\r
+ end; {asciizdd}\r
+\r
+procedure initsup;\r
+(* initialize system pointers *)\r
+ begin\r
+ pspdd := cesxqq; ! Program segment prefix\r
+ addr_ptr := ads cesxqq;\r
+ defdsdd := addr_ptr.s; ! Default data segment\r
+ addr_ptr.s := pspdd; ! Program environment address\r
+ addr_ptr.r := #2c; ! is at offset #2c in PSP.\r
+ envdd := addr_ptr^\r
+ end; {initsup}\r
+\r
+procedure setblkmm(blkseg,blksize : word; var block,ercode : word);\r
+{SETBLKMM Modifies Allocated Blocks. The memory block pointed to by\r
+ blkseg is modified to the size (in paragraphs) of blksize. The\r
+ block increases or decreases in size to that specified in blksize.\r
+ If the block cannot grow to blksize, the largest possible expansion\r
+ is made, and new block size is returned in block. The values for\r
+ the returned error code are:\r
+\r
+ 0 - Successful reallocation. The new block size\r
+ (in paragraphs) is in block.\r
+ 1 - Memory control blocks destroyed\r
+ 2 - Insufficient memory on a grow request. The\r
+ new block size is in block.\r
+ 3 - The pointer in blkseg points to a block which\r
+ has not been allocated.\r
+ >99 - Unidentified error. }\r
+\r
+ begin {setblkmm}\r
+\r
+ initdd(ax,bx,cx,dx,si,di,ds,es); ! Initialize registers\r
+ ax := byword(#4a,0); ! DOS Function 4ah\r
+ es := blkseg;\r
+ bx := blksize;\r
+\r
+ dos(ax,bx,cx,dx,si,di,ds,es,errcode);\r
+\r
+ block := bx;\r
+ case errcode of\r
+ 0 : ercode := 0;\r
+ 7 : begin ! Destroyed control blocks\r
+ block := 0;\r
+ ercode := 1\r
+ end;\r
+ 8 : ercode := 2; ! Not enough memory\r
+ 9 : begin\r
+ block := 0; ! Illegal block request\r
+ ercode := 3\r
+ end\r
+ otherwise\r
+ block := 0;\r
+ ercode := 100 + errcode\r
+ end {case}\r
+\r
+ end; {setblkmm}\r
+\r
+procedure shrinkmm(var ercode : word);\r
+{SHRINKMM Release all memory not needed by the executing program. This\r
+ procedure makes a call to SETBLKMM to release all memory which has\r
+ been allocated, but which is not needed. DOS normally allocates all\r
+ memory to a program, so memory must be released before other calls to\r
+ ALLOCMM are made. The required memory is calculated as the code size\r
+ plus the data space. The code size is essentially the default data\r
+ segment minus the program segment prefix. The data space is the mini-\r
+ mum of #1000 paragraphs (64K bytes) or the remainder of memory. The\r
+ value of the error code returned is that returned by SETBLKMM.}\r
+\r
+ var\r
+ topmem_ptr : ads of word; ! Pointer to word containing\r
+ topmem : word; ! top of memory.\r
+ data_seg : word; ! data segment start\r
+ code_size : word;\r
+ data_space : word;\r
+ blksize : word; ! Total block size needed\r
+\r
+ begin {shrinkmm}\r
+\r
+ topmem_ptr.s := pspdd;\r
+ topmem_ptr.r := 2; ! At offset 2 in PSP\r
+ topmem := topmem_ptr^;\r
+ data_seg := defdsdd; ! Default data segment\r
+ if (data_seg < pspdd) then ! data_seg can be "negative"\r
+ data_seg := topmem - (pspdd - data_seg);\r
+ code_size := data_seg - pspdd;\r
+ data_space := topmem - data_seg;\r
+ if (data_space < #1000) then\r
+ blksize := code_size + data_space\r
+ else\r
+ blksize := code_size + #1000;\r
+\r
+ setblkmm(pspdd,blksize,blksize,ercode)\r
+\r
+ end; {shrinkmm}\r
+\r
+procedure execmm (const proc_name, cmd_line : lstring;\r
+ var ercode : word) [public];\r
+{EXECMM Load and execute a program. This procedure loads and executes\r
+ another program. The program path name is given in proc_name; the\r
+ command line is given in cmd_line. The specified program will be\r
+ loaded and executed as if invoked from DOS with the given command\r
+ line. The spawned program returns control to the calling procedure\r
+ when execution ends, either normally or using a Ctrl/Break sequence.\r
+ The values of the returned error code are:\r
+\r
+ 0 - Successful execution and return.\r
+ (*) 1 - Memory control blocks destroyed when trying\r
+ to reserve memory.\r
+ (*) 2 - Insufficient memory when trying to reserve\r
+ memory.\r
+ (*) 3 - Illegal block change request when trying to\r
+ reserve memory.\r
+ 4 - Executable file not found.\r
+ 5 - Access denied. The file does not allow read\r
+ access.\r
+ 6 - Insufficient memory to load the new procedure.\r
+ (*) 7 - Invalid environment created in the called\r
+ program.\r
+ (*) 8 - Invalid format in the environment.\r
+ 9 - Invalid Path Name. Probably illegal characters\r
+ are present in the proc_name parameter.\r
+ >99 - Unidentified error\r
+\r
+ Errors marked with (*) are internal errors and should not\r
+ normally occur. Errors 1 - 3 indicate problems with the\r
+ SHRINKMM procedure, and errors 7 & 8 are internal errors\r
+ within EXECMM (the construction of the parameter block).}\r
+\r
+ type\r
+ parm_block = record ! Parameter block\r
+ env_sadd : word; ! Segment address of environment\r
+ cmd_addr : adsmem; ! Address of command line\r
+ fb1_addr : adsmem; ! Address of first FCB\r
+ fb2_addr : adsmem ! Address of second FCB\r
+ end;\r
+ var\r
+ procz : string(255); ! ASCIIZ procedure name\r
+ block_val : parm_block; ! Constructed parameter block\r
+\r
+ begin {execmm}\r
+ initsup;\r
+ shrinkmm(ercode); ! Release available memory\r
+\r
+ if (ercode = 0) then ! Now load the program\r
+ begin\r
+ with block_val do\r
+ begin\r
+ env_sadd := envdd; ! Copy parent's environment\r
+ cmd_addr := ads cmd_line[0];\r
+ fb1_addr.s := pspdd;\r
+ fb1_addr.r := #5c;\r
+ fb2_addr.s := pspdd;\r
+ fb2_addr.r := #6c\r
+ end;\r
+ initdd(ax,bx,cx,dx,si,di,ds,es);\r
+ ax := byword(#4b,0); ! DOS function 4bh\r
+ bx := wrd(adr block_val);\r
+ cx := 0;\r
+ asciizdd(proc_name,procz);\r
+ dx := wrd(adr procz); ! Path name as an asciiz string\r
+\r
+ dos(ax,bx,cx,dx,si,di,ds,es,errcode);\r
+\r
+ case errcode of\r
+ 0 : ercode := 0;\r
+ 1 : ercode := 9; ! Invalid path name\r
+ 2 : ercode := 4; ! File not found\r
+ 5 : ercode := 5; ! Access denied\r
+ 8 : ercode := 6; ! Insufficient memory\r
+ 10 : ercode := 7; ! Invalid environoment\r
+ 11 : ercode := 8; ! Invalid format\r
+ otherwise\r
+ ercode := 100 + errcode\r
+ end {case}\r
+\r
+ end\r
+\r
+ end; {execmm}\r
+\r
+end.\r
--- /dev/null
+write\r
+begin\r
+end\r
+if\r
+then\r
+else\r
+put\r
+box\r
+iiuwgraph\r
+mouse\r
+case\r
+esac\r
--- /dev/null
+program nazwy(input,output,names,result,fhash);\r
+(* program czyta ciag identyfikatorow z pliku names *)\r
+(* na plik result wypisuje pary (nazwa, numer z hash'u ) *)\r
+(* na plik fhash wypisuje ciag podstawien tworzacy zmodyfikowana tablice hash *)\r
+const dl = 10;\r
+type tname = array[1..10] of integer;\r
+ thash = array[1..8000] of integer;\r
+var name:tname;\r
+ hash : thash;\r
+ nlast : integer;\r
+ a1,b1,i,j,n:integer;\r
+ a,b:char;\r
+ names,fhash,result:text;\r
+ str:lstring(20);\r
+function search(vars k:integer; vars name:tname; vars hash:thash; \r
+ vars nlast:integer):integer [fortran];extern; \r
+procedure init(vars hash:thash) [fortran];extern;\r
+begin\r
+ (* inicjalizacja *) \r
+ reset(names);\r
+ rewrite(result);\r
+ rewrite(fhash);\r
+ for i := 1 to 8000 do hash[i] := 0;\r
+ nlast := 8001;\r
+ (* inicjalizacja tablicy hash *)\r
+ init(hash);\r
+ writeln(' koniec inicjalizacji tablicy hash ');\r
+ \r
+ while not eof(names) do\r
+ begin\r
+ i := 0;\r
+ j := 0;\r
+ str.len := wrd(20);\r
+ while not eoln(names) do\r
+ begin\r
+ read(names,a);\r
+ j := j+1;\r
+ str[j] := a;\r
+ if a<'a'then a1 := ord(a) - ord('0') else\r
+ a1 := ord(a) - ord('a')+10;\r
+ if not eoln(names) then\r
+ begin\r
+ read(names,b);\r
+ j := j+1;\r
+ str[j] := b;\r
+ i := i+1;\r
+ if b<'a' then b1 := ord(b) - ord('0') else\r
+ b1 := ord(b) - ord('a')+10;\r
+ if a1 = 0 then a1 := 60; \r
+ name[i] := a1*64+b1;\r
+ end else\r
+ begin\r
+ i := i+1;\r
+ name[i] := a1;\r
+ end;\r
+ end;\r
+ (* koniec nazwy *)\r
+ n := search(i,name,hash,nlast);\r
+ str.len := wrd(j);\r
+ writeln(result,' ',str, ' ',n);\r
+ readln(names);\r
+ end;\r
+ \r
+ (* wypisanie tablicy hash *)\r
+ for i := 1 to 8000 do\r
+ begin\r
+ if hash[i] <> 0 then\r
+ writeln(fhash,' ','HASH (',i:6,' ) =',hash[i]:6);\r
+ end;\r
+ end. \r
+ \r
+ \r
--- /dev/null
+procedure printmem;\r
+var i,j,k:integer;\r
+begin\r
+ writeln; writeln(' ================ zmienne ============================');\r
+ writeln; writeln;\r
+ writeln(' strings ', strings);\r
+ writeln(' ipradr ', ipradr);\r
+ writeln(' display(fiz) ', display);\r
+ writeln(' display2 ', display2);\r
+ writeln(' temporary ',temporary);\r
+ writeln(' main ', main);\r
+ writeln(' lower ', lower);\r
+ writeln(' upper ', upper);\r
+ writeln(' free ', free);\r
+ writeln(' freeitem ', freeitem);\r
+ writeln(' lastused ', lastused);\r
+ writeln(' headk ', headk);\r
+ writeln(' headk2 ', headk2);\r
+ writeln; writeln;\r
+ writeln(' element slownika dla none ', m^[0],' ', m^[1]);\r
+ writeln; writeln;\r
+ writeln('================= opisy typow pierwotnych i listy ===============');\r
+ j := 0;\r
+ for i := ipradr to display-1 do\r
+ begin\r
+ if j mod 5 = 0 then\r
+ begin\r
+ writeln;\r
+ write(' ',i:7,'***');\r
+ end;\r
+ j := j+1;\r
+ write(m^[i]:9);\r
+ end;\r
+ writeln; writeln;\r
+ writeln('======================= display ===============');\r
+ writeln; writeln;\r
+ for i := 0 to lastprot do\r
+ begin\r
+ write(' ',display+i:7,display2+i:7, '(',i:5,')',m^[display+i], m^[display2+i]);\r
+ writeln;\r
+ end;\r
+ writeln; writeln;\r
+ writeln(' ================= obiekt main ================');\r
+ i := m^[main];\r
+ j := 0;\r
+ for k := main to main+i-1 do\r
+ begin\r
+ if j mod 5 = 0 then\r
+ begin\r
+ writeln;\r
+ write(' ',k:7,'***');\r
+ end;\r
+ j := j+1;\r
+ write(m^[k]:9);\r
+ end;\r
+ writeln; writeln;\r
+ writeln('===================== obiekty (lower to latused) ==========');\r
+ writeln; writeln;\r
+ j :=0;\r
+ for i := lower to lastused do\r
+ begin\r
+ if j mod 5 = 0 then\r
+ begin\r
+ writeln;\r
+ write(' ',i:7,'***');\r
+ end;\r
+ j := j+1;\r
+ write(m^[i]:9);\r
+ end;\r
+ writeln; writeln;\r
+ writeln('======================= tablica H (upper downto lastitem) =====');\r
+ writeln; writeln;\r
+ i := upper-1;\r
+ while i>= lastitem do\r
+ begin\r
+ writeln(' ',i:7,'***',m^[i]:9, m^[i+1]:9);\r
+ i:=i-2;\r
+ end;\r
+ writeln; writeln;\r
+ writeln('=================================================================');\r
+end (* printmem *);\r
+ \r
+\r
+ procedure printkind(kind:protkind);\r
+ begin\r
+ case kind of\r
+ class : writeln(' class');\r
+ lrecord: writeln(' record');\r
+ coroutine: writeln(' coroutine');\r
+ process: writeln(' process);\r
+ block : writeln(' block');\r
+ prefblock: writeln(' prefblock');\r
+ lfunction: writeln(' function');\r
+ lprocedure: writeln(' procedure');\r
+ handler: writeln(' handler');\r
+ end;\r
+ end; \r
+ \r
+procedure printprot;\r
+var i:integer;\r
+begin\r
+ writeln; writeln; \r
+ writeln('================ prototypes ============== ');\r
+ writeln(' lastprot ', lastprot);\r
+ for i := mainblock to lastprot do\r
+ with prototype[i]^ do\r
+ begin\r
+ writeln; writeln;\r
+ write(' prototyp nr ',i);printkind(kind);\r
+ writeln(' SL ', slprototype);\r
+ writeln(' codeaddr ', codeaddr);\r
+ writeln(' appetite ', appetite);\r
+ writeln(' span ', span);\r
+ writeln(' reflist ', reflist, lthreflist);\r
+ writeln(' parlist ', parlist,lthparlist);\r
+ writeln(' preflist ',preflist, lthpreflist);\r
+ writeln(' virtlist ', virtlist);\r
+ if (kind = lfunction) or (kind = lprocedure) then\r
+ begin\r
+ writeln(' pardescr ', pfdescr);\r
+ if kind = lfunction then \r
+ writeln(' type ', finaltype);\r
+ end;\r
+ end; \r
+ end (* printprot *); \r
+
\ No newline at end of file
--- /dev/null
+ subroutine init(hash)\r
+ implicit integer*2 (a-z)\r
+ dimension hash(8000)\r
+ HASH ( 59 ) = 1038\r
+ HASH ( 60 ) = -2343\r
+ HASH ( 81 ) = 2058\r
+ HASH ( 82 ) = -2691\r
+ HASH ( 85 ) = 1051\r
+ HASH ( 86 ) = -2271\r
+ HASH ( 95 ) = 2065\r
+ HASH ( 96 ) = -2689\r
+ HASH ( 97 ) = 2066\r
+ HASH ( 98 ) = -2639\r
+ HASH ( 115 ) = 2075\r
+ HASH ( 116 ) = -2681\r
+ HASH ( 179 ) = 1098\r
+ HASH ( 180 ) = -2669\r
+ HASH ( 189 ) = 1103\r
+ HASH ( 190 ) = -2285\r
+ HASH ( 195 ) = 1106\r
+ HASH ( 196 ) = -2865\r
+ HASH ( 209 ) = 1113\r
+ HASH ( 210 ) = -2289\r
+ HASH ( 237 ) = 2136\r
+ HASH ( 238 ) = -2485\r
+ HASH ( 307 ) = 1162\r
+ HASH ( 308 ) = -2607\r
+ HASH ( 317 ) = 1167\r
+ HASH ( 331 ) = 1174\r
+ HASH ( 332 ) = -2523\r
+ HASH ( 333 ) = 1175\r
+ HASH ( 334 ) = 2861\r
+ HASH ( 335 ) = 1176\r
+ HASH ( 336 ) = -2609\r
+ HASH ( 343 ) = 1180\r
+ HASH ( 344 ) = 2605\r
+ HASH ( 579 ) = 1298\r
+ HASH ( 580 ) = -2835\r
+ HASH ( 691 ) = 1354\r
+ HASH ( 692 ) = -2637\r
+ HASH ( 717 ) = 1367\r
+ HASH ( 719 ) = 1368\r
+ HASH ( 720 ) = -2833\r
+ HASH ( 819 ) = 1418\r
+ HASH ( 820 ) = -2831\r
+ HASH ( 827 ) = 1422\r
+ HASH ( 828 ) = -2327\r
+ HASH ( 835 ) = 1426\r
+ HASH ( 836 ) = -2395\r
+ HASH ( 847 ) = 1432\r
+ HASH ( 848 ) = -2829\r
+ HASH ( 955 ) = 1486\r
+ HASH ( 956 ) = -2827\r
+ HASH ( 975 ) = 1496\r
+ HASH ( 976 ) = -2825\r
+ HASH ( 987 ) = 1502\r
+ HASH ( 988 ) = -1989\r
+ HASH ( 1081 ) = 1549\r
+ HASH ( 1105 ) = 1561\r
+ HASH ( 1106 ) = -2363\r
+ HASH ( 1109 ) = 1563\r
+ HASH ( 1110 ) = 2819\r
+ HASH ( 1113 ) = 1565\r
+ HASH ( 1114 ) = -2815\r
+ HASH ( 1115 ) = 1566\r
+ HASH ( 1116 ) = -2807\r
+ HASH ( 1203 ) = 1610\r
+ HASH ( 1204 ) = -2493\r
+ HASH ( 1231 ) = 1624\r
+ HASH ( 1232 ) = -2241\r
+ HASH ( 1237 ) = 1627\r
+ HASH ( 1238 ) = -2797\r
+ HASH ( 1243 ) = 1630\r
+ HASH ( 1244 ) = -2341\r
+ HASH ( 1303 ) = 651\r
+ HASH ( 1304 ) = -2615\r
+ HASH ( 1305 ) = 652\r
+ HASH ( 1306 ) = -2305\r
+ HASH ( 1325 ) = 662\r
+ HASH ( 1326 ) = -2381\r
+ HASH ( 1327 ) = 663\r
+ HASH ( 1328 ) = -2999\r
+ HASH ( 1335 ) = 667\r
+ HASH ( 1336 ) = -2997\r
+ HASH ( 1339 ) = 669\r
+ HASH ( 1340 ) = -2985\r
+ HASH ( 1371 ) = 1694\r
+ HASH ( 1372 ) = -2777\r
+ HASH ( 1437 ) = 718\r
+ HASH ( 1438 ) = -2973\r
+ HASH ( 1451 ) = 725\r
+ HASH ( 1452 ) = -2969\r
+ HASH ( 1457 ) = 728\r
+ HASH ( 1458 ) = -2965\r
+ HASH ( 1459 ) = 1738\r
+ HASH ( 1460 ) = -2659\r
+ HASH ( 1463 ) = 731\r
+ HASH ( 1464 ) = -2267\r
+ HASH ( 1467 ) = 1742\r
+ HASH ( 1468 ) = -2775\r
+ HASH ( 1487 ) = 1752\r
+ HASH ( 1488 ) = -2583\r
+ HASH ( 1557 ) = 778\r
+ HASH ( 1558 ) = -2955\r
+ HASH ( 1571 ) = 785\r
+ HASH ( 1572 ) = -2949\r
+ HASH ( 1573 ) = 786\r
+ HASH ( 1574 ) = -2103\r
+ HASH ( 1579 ) = 789\r
+ HASH ( 1580 ) = -2941\r
+ HASH ( 1585 ) = 792\r
+ HASH ( 1586 ) = -2927\r
+ HASH ( 1591 ) = 1804\r
+ HASH ( 1592 ) = -2189\r
+ HASH ( 1595 ) = 1806\r
+ HASH ( 1596 ) = -2751\r
+ HASH ( 1603 ) = 1810\r
+ HASH ( 1604 ) = -2663\r
+ HASH ( 1609 ) = 1813\r
+ HASH ( 1610 ) = -2463\r
+ HASH ( 1619 ) = 1818\r
+ HASH ( 1620 ) = -2591\r
+ HASH ( 1625 ) = 1821\r
+ HASH ( 1626 ) = -2743\r
+ HASH ( 1635 ) = 1826\r
+ HASH ( 1636 ) = -2003\r
+ HASH ( 1685 ) = 842\r
+ HASH ( 1686 ) = -2349\r
+ HASH ( 1693 ) = 846\r
+ HASH ( 1694 ) = -2909\r
+ HASH ( 1701 ) = 850\r
+ HASH ( 1702 ) = -2905\r
+ HASH ( 1713 ) = 856\r
+ HASH ( 1714 ) = 2899\r
+ HASH ( 1715 ) = 1866\r
+ HASH ( 1716 ) = -2731\r
+ HASH ( 1719 ) = 859\r
+ HASH ( 1720 ) = -2283\r
+ HASH ( 1723 ) = 1870\r
+ HASH ( 1724 ) = -2647\r
+ HASH ( 1729 ) = 1873\r
+ HASH ( 1730 ) = -2727\r
+ HASH ( 1731 ) = 1874\r
+ HASH ( 1732 ) = -2593\r
+ HASH ( 1743 ) = 1880\r
+ HASH ( 1749 ) = 1883\r
+ HASH ( 1750 ) = -2721\r
+ HASH ( 1751 ) = 1884\r
+ HASH ( 1752 ) = 2425\r
+ HASH ( 1763 ) = 1890\r
+ HASH ( 1764 ) = -2719\r
+ HASH ( 1829 ) = 1367\r
+ HASH ( 1830 ) = 2253\r
+ HASH ( 1831 ) = 653\r
+ HASH ( 1832 ) = -1829\r
+ HASH ( 1833 ) = 1742\r
+ HASH ( 1834 ) = -1831\r
+ HASH ( 1835 ) = 917\r
+ HASH ( 1836 ) = -2893\r
+ HASH ( 1837 ) = 918\r
+ HASH ( 1838 ) = -2399\r
+ HASH ( 1839 ) = 919\r
+ HASH ( 1840 ) = -2891\r
+ HASH ( 1841 ) = 920\r
+ HASH ( 1842 ) = -2617\r
+ HASH ( 1849 ) = 924\r
+ HASH ( 1850 ) = -2889\r
+ HASH ( 1859 ) = 929\r
+ HASH ( 1860 ) = -2887\r
+ HASH ( 1869 ) = 1943\r
+ HASH ( 1870 ) = -2717\r
+ HASH ( 1873 ) = 1945\r
+ HASH ( 1874 ) = -2709\r
+ HASH ( 1941 ) = 970\r
+ HASH ( 1942 ) = -2877\r
+ HASH ( 1957 ) = 978\r
+ HASH ( 1958 ) = 2339\r
+ HASH ( 1969 ) = 984\r
+ HASH ( 1970 ) = -2873\r
+ HASH ( 1971 ) = 1994\r
+ HASH ( 1972 ) = -2699\r
+ HASH ( 1981 ) = 990\r
+ HASH ( 1982 ) = -2871\r
+ HASH ( 1987 ) = 2002\r
+ HASH ( 1988 ) = -2697\r
+ HASH ( 1989 ) = 1422\r
+ HASH ( 1990 ) = -1991\r
+ HASH ( 1991 ) = 1755\r
+ HASH ( 1992 ) = -1993\r
+ HASH ( 1993 ) = 1563\r
+ HASH ( 1995 ) = 1890\r
+ HASH ( 1996 ) = -1997\r
+ HASH ( 1997 ) = 1614\r
+ HASH ( 1998 ) = -1999\r
+ HASH ( 1999 ) = 1755\r
+ HASH ( 2000 ) = -2001\r
+ HASH ( 2001 ) = 1563\r
+ HASH ( 2003 ) = 1806\r
+ HASH ( 2004 ) = -2005\r
+ HASH ( 2005 ) = 1755\r
+ HASH ( 2006 ) = -2007\r
+ HASH ( 2007 ) = 1563\r
+ HASH ( 2017 ) = 1559\r
+ HASH ( 2019 ) = 1874\r
+ HASH ( 2020 ) = -2017\r
+ HASH ( 2021 ) = 1810\r
+ HASH ( 2022 ) = -2019\r
+ HASH ( 2023 ) = 1624\r
+ HASH ( 2024 ) = -2021\r
+ HASH ( 2025 ) = 1741\r
+ HASH ( 2027 ) = 778\r
+ HASH ( 2028 ) = -2025\r
+ HASH ( 2029 ) = 1496\r
+ HASH ( 2030 ) = -2027\r
+ HASH ( 2031 ) = 1181\r
+ HASH ( 2033 ) = 1694\r
+ HASH ( 2034 ) = -2031\r
+ HASH ( 2035 ) = 14\r
+ HASH ( 2037 ) = 725\r
+ HASH ( 2038 ) = -2035\r
+ HASH ( 2039 ) = 1802\r
+ HASH ( 2040 ) = -2037\r
+ HASH ( 2041 ) = 850\r
+ HASH ( 2042 ) = -2039\r
+ HASH ( 2043 ) = 1358\r
+ HASH ( 2045 ) = 651\r
+ HASH ( 2046 ) = -2043\r
+ HASH ( 2047 ) = 919\r
+ HASH ( 2048 ) = -2045\r
+ HASH ( 2049 ) = 1629\r
+ HASH ( 2051 ) = 782\r
+ HASH ( 2052 ) = -2049\r
+ HASH ( 2053 ) = 652\r
+ HASH ( 2054 ) = -2051\r
+ HASH ( 2055 ) = 2254\r
+ HASH ( 2057 ) = 1810\r
+ HASH ( 2058 ) = -2055\r
+ HASH ( 2059 ) = 661\r
+ HASH ( 2060 ) = -2057\r
+ HASH ( 2061 ) = 1742\r
+ HASH ( 2062 ) = -2059\r
+ HASH ( 2063 ) = 14\r
+ HASH ( 2065 ) = 1187\r
+ HASH ( 2066 ) = -2063\r
+ HASH ( 2067 ) = 1884\r
+ HASH ( 2068 ) = -2065\r
+ HASH ( 2069 ) = 1175\r
+ HASH ( 2070 ) = -2067\r
+ HASH ( 2071 ) = 908\r
+ HASH ( 2073 ) = 1883\r
+ HASH ( 2074 ) = -2071\r
+ HASH ( 2075 ) = 1630\r
+ HASH ( 2076 ) = -2073\r
+ HASH ( 2077 ) = 908\r
+ HASH ( 2079 ) = 1883\r
+ HASH ( 2080 ) = -2077\r
+ HASH ( 2081 ) = 1038\r
+ HASH ( 2082 ) = -2079\r
+ HASH ( 2083 ) = 1492\r
+ HASH ( 2085 ) = 1362\r
+ HASH ( 2086 ) = -2083\r
+ HASH ( 2087 ) = 1943\r
+ HASH ( 2088 ) = -2085\r
+ HASH ( 2089 ) = 916\r
+ HASH ( 2091 ) = 1806\r
+ HASH ( 2092 ) = -2089\r
+ HASH ( 2093 ) = 797\r
+ HASH ( 2094 ) = 2041\r
+ HASH ( 2095 ) = 1742\r
+ HASH ( 2096 ) = -2093\r
+ HASH ( 2097 ) = 850\r
+ HASH ( 2098 ) = -2095\r
+ HASH ( 2099 ) = 908\r
+ HASH ( 2101 ) = 929\r
+ HASH ( 2102 ) = -2099\r
+ HASH ( 2103 ) = 1739\r
+ HASH ( 2105 ) = 16\r
+ HASH ( 2107 ) = 1175\r
+ HASH ( 2108 ) = -2105\r
+ HASH ( 2109 ) = 1883\r
+ HASH ( 2110 ) = -2107\r
+ HASH ( 2111 ) = 1884\r
+ HASH ( 2112 ) = -2109\r
+ HASH ( 2113 ) = 1566\r
+ HASH ( 2114 ) = -2111\r
+ HASH ( 2115 ) = 1864\r
+ HASH ( 2117 ) = 1559\r
+ HASH ( 2118 ) = -2115\r
+ HASH ( 2119 ) = 1103\r
+ HASH ( 2120 ) = -2117\r
+ HASH ( 2121 ) = 29\r
+ HASH ( 2122 ) = 2119\r
+ HASH ( 2123 ) = 1559\r
+ HASH ( 2124 ) = -2121\r
+ HASH ( 2125 ) = 1103\r
+ HASH ( 2126 ) = -2123\r
+ HASH ( 2127 ) = 20\r
+ HASH ( 2129 ) = 652\r
+ HASH ( 2130 ) = -2127\r
+ HASH ( 2131 ) = 1883\r
+ HASH ( 2132 ) = -2129\r
+ HASH ( 2133 ) = 665\r
+ HASH ( 2135 ) = 1750\r
+ HASH ( 2136 ) = -2133\r
+ HASH ( 2137 ) = 2136\r
+ HASH ( 2138 ) = -2135\r
+ HASH ( 2139 ) = 25\r
+ HASH ( 2141 ) = 1418\r
+ HASH ( 2142 ) = -2139\r
+ HASH ( 2143 ) = 1563\r
+ HASH ( 2144 ) = -2141\r
+ HASH ( 2145 ) = 665\r
+ HASH ( 2146 ) = 2075\r
+ HASH ( 2147 ) = 1878\r
+ HASH ( 2148 ) = -2145\r
+ HASH ( 2149 ) = 1630\r
+ HASH ( 2150 ) = -2147\r
+ HASH ( 2151 ) = 665\r
+ HASH ( 2152 ) = 2081\r
+ HASH ( 2153 ) = 1878\r
+ HASH ( 2154 ) = -2151\r
+ HASH ( 2155 ) = 1038\r
+ HASH ( 2156 ) = -2153\r
+ HASH ( 2157 ) = 33\r
+ HASH ( 2158 ) = 2069\r
+ HASH ( 2159 ) = 1618\r
+ HASH ( 2160 ) = -2157\r
+ HASH ( 2161 ) = 1175\r
+ HASH ( 2162 ) = -2159\r
+ HASH ( 2163 ) = 1564\r
+ HASH ( 2164 ) = 2161\r
+ HASH ( 2165 ) = 2201\r
+ HASH ( 2166 ) = -2163\r
+ HASH ( 2167 ) = 1175\r
+ HASH ( 2168 ) = -2165\r
+ HASH ( 2169 ) = 1564\r
+ HASH ( 2170 ) = 2167\r
+ HASH ( 2171 ) = 2137\r
+ HASH ( 2172 ) = -2169\r
+ HASH ( 2173 ) = 1175\r
+ HASH ( 2174 ) = -2171\r
+ HASH ( 2175 ) = 34\r
+ HASH ( 2176 ) = 2023\r
+ HASH ( 2177 ) = 1633\r
+ HASH ( 2178 ) = -2175\r
+ HASH ( 2179 ) = 1624\r
+ HASH ( 2180 ) = -2177\r
+ HASH ( 2181 ) = 2146\r
+ HASH ( 2182 ) = 2149\r
+ HASH ( 2183 ) = 1809\r
+ HASH ( 2184 ) = -2181\r
+ HASH ( 2185 ) = 1630\r
+ HASH ( 2186 ) = -2183\r
+ HASH ( 2187 ) = 919\r
+ HASH ( 2189 ) = 1742\r
+ HASH ( 2190 ) = -2187\r
+ HASH ( 2191 ) = 24\r
+ HASH ( 2193 ) = 846\r
+ HASH ( 2194 ) = -2191\r
+ HASH ( 2195 ) = 2002\r
+ HASH ( 2196 ) = -2193\r
+ HASH ( 2197 ) = 923\r
+ HASH ( 2199 ) = 1741\r
+ HASH ( 2200 ) = -2197\r
+ HASH ( 2201 ) = 728\r
+ HASH ( 2202 ) = -2199\r
+ HASH ( 2203 ) = 925\r
+ HASH ( 2205 ) = 1365\r
+ HASH ( 2206 ) = -2203\r
+ HASH ( 2207 ) = 1610\r
+ HASH ( 2208 ) = -2205\r
+ HASH ( 2209 ) = 1500\r
+ HASH ( 2210 ) = 2173\r
+ HASH ( 2211 ) = 1870\r
+ HASH ( 2212 ) = -2209\r
+ HASH ( 2213 ) = 1175\r
+ HASH ( 2214 ) = -2211\r
+ HASH ( 2215 ) = 1751\r
+ HASH ( 2216 ) = 2207\r
+ HASH ( 2217 ) = 1870\r
+ HASH ( 2218 ) = -2215\r
+ HASH ( 2219 ) = 1610\r
+ HASH ( 2220 ) = -2217\r
+ HASH ( 2221 ) = 14\r
+ HASH ( 2223 ) = 2197\r
+ HASH ( 2224 ) = -2221\r
+ HASH ( 2225 ) = 1821\r
+ HASH ( 2226 ) = -2223\r
+ HASH ( 2227 ) = 27\r
+ HASH ( 2229 ) = 1368\r
+ HASH ( 2230 ) = -2227\r
+ HASH ( 2231 ) = 792\r
+ HASH ( 2232 ) = -2229\r
+ HASH ( 2233 ) = 21\r
+ HASH ( 2235 ) = 1173\r
+ HASH ( 2236 ) = -2233\r
+ HASH ( 2237 ) = 1999\r
+ HASH ( 2238 ) = -2235\r
+ HASH ( 2239 ) = 29\r
+ HASH ( 2240 ) = 2179\r
+ HASH ( 2241 ) = 1175\r
+ HASH ( 2242 ) = -2239\r
+ HASH ( 2243 ) = 788\r
+ HASH ( 2244 ) = 2087\r
+ HASH ( 2245 ) = 1610\r
+ HASH ( 2246 ) = -2243\r
+ HASH ( 2247 ) = 1943\r
+ HASH ( 2248 ) = -2245\r
+ HASH ( 2249 ) = 1870\r
+ HASH ( 2250 ) = -2251\r
+ HASH ( 2251 ) = 2141\r
+ HASH ( 2253 ) = 1742\r
+ HASH ( 2254 ) = -2255\r
+ HASH ( 2255 ) = 1806\r
+ HASH ( 2256 ) = -2257\r
+ HASH ( 2257 ) = 29\r
+ HASH ( 2258 ) = 2259\r
+ HASH ( 2259 ) = 1742\r
+ HASH ( 2260 ) = -2261\r
+ HASH ( 2261 ) = 2075\r
+ HASH ( 2262 ) = -2263\r
+ HASH ( 2263 ) = 1181\r
+ HASH ( 2264 ) = -2265\r
+ HASH ( 2265 ) = 14\r
+ HASH ( 2266 ) = 2061\r
+ HASH ( 2267 ) = 906\r
+ HASH ( 2268 ) = -2269\r
+ HASH ( 2269 ) = 20\r
+ HASH ( 2271 ) = 1559\r
+ HASH ( 2272 ) = 2273\r
+ HASH ( 2273 ) = 1051\r
+ HASH ( 2274 ) = -2275\r
+ HASH ( 2275 ) = 1551\r
+ HASH ( 2276 ) = -2277\r
+ HASH ( 2277 ) = 15\r
+ HASH ( 2279 ) = 1432\r
+ HASH ( 2280 ) = -2281\r
+ HASH ( 2281 ) = 1998\r
+ HASH ( 2283 ) = 672\r
+ HASH ( 2285 ) = 1173\r
+ HASH ( 2286 ) = -2287\r
+ HASH ( 2287 ) = 21\r
+ HASH ( 2288 ) = 2125\r
+ HASH ( 2289 ) = 656\r
+ HASH ( 2290 ) = -2291\r
+ HASH ( 2291 ) = 14\r
+ HASH ( 2293 ) = 1098\r
+ HASH ( 2294 ) = -2295\r
+ HASH ( 2295 ) = 1804\r
+ HASH ( 2296 ) = -2297\r
+ HASH ( 2297 ) = 1170\r
+ HASH ( 2299 ) = 1175\r
+ HASH ( 2300 ) = -2301\r
+ HASH ( 2301 ) = 1294\r
+ HASH ( 2302 ) = -2303\r
+ HASH ( 2303 ) = 34\r
+ HASH ( 2304 ) = 2213\r
+ HASH ( 2305 ) = 782\r
+ HASH ( 2306 ) = -2307\r
+ HASH ( 2307 ) = 1755\r
+ HASH ( 2308 ) = -2309\r
+ HASH ( 2309 ) = 1563\r
+ HASH ( 2310 ) = 2053\r
+ HASH ( 2311 ) = 792\r
+ HASH ( 2312 ) = -2313\r
+ HASH ( 2313 ) = 1486\r
+ HASH ( 2314 ) = -2315\r
+ HASH ( 2315 ) = 1755\r
+ HASH ( 2316 ) = -2317\r
+ HASH ( 2317 ) = 1563\r
+ HASH ( 2318 ) = 2231\r
+ HASH ( 2319 ) = 1368\r
+ HASH ( 2320 ) = -2321\r
+ HASH ( 2321 ) = 1038\r
+ HASH ( 2322 ) = -2323\r
+ HASH ( 2323 ) = 1755\r
+ HASH ( 2324 ) = -2325\r
+ HASH ( 2325 ) = 1563\r
+ HASH ( 2327 ) = 1422\r
+ HASH ( 2328 ) = -2329\r
+ HASH ( 2329 ) = 1755\r
+ HASH ( 2330 ) = -2331\r
+ HASH ( 2331 ) = 1563\r
+ HASH ( 2333 ) = 28\r
+ HASH ( 2335 ) = 789\r
+ HASH ( 2336 ) = -2333\r
+ HASH ( 2337 ) = 1358\r
+ HASH ( 2339 ) = 978\r
+ HASH ( 2340 ) = -2337\r
+ HASH ( 2341 ) = 29\r
+ HASH ( 2342 ) = 2185\r
+ HASH ( 2343 ) = 29\r
+ HASH ( 2344 ) = 2155\r
+ HASH ( 2345 ) = 919\r
+ HASH ( 2347 ) = 1561\r
+ HASH ( 2348 ) = -2345\r
+ HASH ( 2349 ) = 1870\r
+ HASH ( 2351 ) = 27\r
+ HASH ( 2352 ) = 2101\r
+ HASH ( 2353 ) = 1610\r
+ HASH ( 2354 ) = -2351\r
+ HASH ( 2355 ) = 908\r
+ HASH ( 2356 ) = -2353\r
+ HASH ( 2357 ) = 929\r
+ HASH ( 2358 ) = -2355\r
+ HASH ( 2359 ) = 28\r
+ HASH ( 2360 ) = 2347\r
+ HASH ( 2361 ) = 1559\r
+ HASH ( 2362 ) = -2359\r
+ HASH ( 2363 ) = 1874\r
+ HASH ( 2364 ) = -2361\r
+ HASH ( 2365 ) = 20\r
+ HASH ( 2366 ) = 2335\r
+ HASH ( 2367 ) = 1548\r
+ HASH ( 2368 ) = -2365\r
+ HASH ( 2369 ) = 789\r
+ HASH ( 2370 ) = -2367\r
+ HASH ( 2371 ) = 925\r
+ HASH ( 2373 ) = 1500\r
+ HASH ( 2374 ) = -2371\r
+ HASH ( 2375 ) = 1738\r
+ HASH ( 2376 ) = -2373\r
+ HASH ( 2377 ) = 27\r
+ HASH ( 2379 ) = 718\r
+ HASH ( 2380 ) = -2377\r
+ HASH ( 2381 ) = 918\r
+ HASH ( 2382 ) = -2379\r
+ HASH ( 2383 ) = 1756\r
+ HASH ( 2385 ) = 1102\r
+ HASH ( 2386 ) = -2383\r
+ HASH ( 2387 ) = 1565\r
+ HASH ( 2388 ) = -2385\r
+ HASH ( 2389 ) = 1870\r
+ HASH ( 2391 ) = 1358\r
+ HASH ( 2392 ) = -2389\r
+ HASH ( 2393 ) = 846\r
+ HASH ( 2394 ) = -2391\r
+ HASH ( 2395 ) = 23\r
+ HASH ( 2397 ) = 34\r
+ HASH ( 2399 ) = 1629\r
+ HASH ( 2400 ) = -2397\r
+ HASH ( 2401 ) = 1757\r
+ HASH ( 2402 ) = 2299\r
+ HASH ( 2403 ) = 1806\r
+ HASH ( 2404 ) = -2401\r
+ HASH ( 2405 ) = 1175\r
+ HASH ( 2406 ) = -2403\r
+ HASH ( 2407 ) = 25\r
+ HASH ( 2408 ) = 2247\r
+ HASH ( 2409 ) = 788\r
+ HASH ( 2410 ) = -2407\r
+ HASH ( 2411 ) = 1368\r
+ HASH ( 2412 ) = -2409\r
+ HASH ( 2413 ) = 1943\r
+ HASH ( 2414 ) = -2411\r
+ HASH ( 2415 ) = 25\r
+ HASH ( 2416 ) = 2319\r
+ HASH ( 2417 ) = 788\r
+ HASH ( 2418 ) = -2415\r
+ HASH ( 2419 ) = 1368\r
+ HASH ( 2420 ) = -2417\r
+ HASH ( 2421 ) = 1945\r
+ HASH ( 2423 ) = 25\r
+ HASH ( 2425 ) = 1884\r
+ HASH ( 2426 ) = -2423\r
+ HASH ( 2427 ) = 23\r
+ HASH ( 2429 ) = 1181\r
+ HASH ( 2430 ) = -2427\r
+ HASH ( 2431 ) = 2058\r
+ HASH ( 2432 ) = -2429\r
+ HASH ( 2433 ) = 667\r
+ HASH ( 2434 ) = 2225\r
+ HASH ( 2435 ) = 1561\r
+ HASH ( 2436 ) = -2433\r
+ HASH ( 2437 ) = 1821\r
+ HASH ( 2438 ) = -2435\r
+ HASH ( 2439 ) = 25\r
+ HASH ( 2440 ) = 2431\r
+ HASH ( 2441 ) = 1181\r
+ HASH ( 2442 ) = -2439\r
+ HASH ( 2443 ) = 2058\r
+ HASH ( 2444 ) = -2441\r
+ HASH ( 2445 ) = 25\r
+ HASH ( 2446 ) = 2437\r
+ HASH ( 2447 ) = 1561\r
+ HASH ( 2448 ) = -2445\r
+ HASH ( 2449 ) = 1821\r
+ HASH ( 2450 ) = -2447\r
+ HASH ( 2451 ) = 25\r
+ HASH ( 2452 ) = 1833\r
+ HASH ( 2453 ) = 1422\r
+ HASH ( 2454 ) = -2451\r
+ HASH ( 2455 ) = 1822\r
+ HASH ( 2456 ) = -2453\r
+ HASH ( 2457 ) = 1742\r
+ HASH ( 2458 ) = -2455\r
+ HASH ( 2459 ) = 20\r
+ HASH ( 2461 ) = 1490\r
+ HASH ( 2462 ) = -2459\r
+ HASH ( 2463 ) = 1568\r
+ HASH ( 2464 ) = -2461\r
+ HASH ( 2465 ) = 924\r
+ HASH ( 2467 ) = 1548\r
+ HASH ( 2468 ) = -2465\r
+ HASH ( 2469 ) = 1627\r
+ HASH ( 2470 ) = -2467\r
+ HASH ( 2471 ) = 27\r
+ HASH ( 2472 ) = 2091\r
+ HASH ( 2473 ) = 984\r
+ HASH ( 2474 ) = -2471\r
+ HASH ( 2475 ) = 1418\r
+ HASH ( 2476 ) = -2473\r
+ HASH ( 2477 ) = 1806\r
+ HASH ( 2478 ) = -2475\r
+ HASH ( 2479 ) = 1943\r
+ HASH ( 2480 ) = 2047\r
+ HASH ( 2481 ) = 859\r
+ HASH ( 2482 ) = -2479\r
+ HASH ( 2483 ) = 919\r
+ HASH ( 2484 ) = -2481\r
+ HASH ( 2485 ) = 27\r
+ HASH ( 2486 ) = 2137\r
+ HASH ( 2487 ) = 28\r
+ HASH ( 2488 ) = 2219\r
+ HASH ( 2489 ) = 930\r
+ HASH ( 2490 ) = -2487\r
+ HASH ( 2491 ) = 1364\r
+ HASH ( 2492 ) = -2489\r
+ HASH ( 2493 ) = 1486\r
+ HASH ( 2494 ) = -2491\r
+ HASH ( 2495 ) = 1167\r
+ HASH ( 2497 ) = 878\r
+ HASH ( 2498 ) = -2495\r
+ HASH ( 2499 ) = 663\r
+ HASH ( 2500 ) = -2497\r
+ HASH ( 2501 ) = 15\r
+ HASH ( 2502 ) = 2499\r
+ HASH ( 2503 ) = 850\r
+ HASH ( 2504 ) = -2501\r
+ HASH ( 2505 ) = 663\r
+ HASH ( 2506 ) = -2503\r
+ HASH ( 2507 ) = 3\r
+ HASH ( 2509 ) = 673\r
+ HASH ( 2510 ) = -2507\r
+ HASH ( 2511 ) = 1174\r
+ HASH ( 2512 ) = -2509\r
+ HASH ( 2513 ) = 673\r
+ HASH ( 2514 ) = 2511\r
+ HASH ( 2515 ) = 1174\r
+ HASH ( 2516 ) = -2513\r
+ HASH ( 2517 ) = 3\r
+ HASH ( 2518 ) = 2515\r
+ HASH ( 2519 ) = 1175\r
+ HASH ( 2520 ) = -2517\r
+ HASH ( 2521 ) = 1174\r
+ HASH ( 2522 ) = -2519\r
+ HASH ( 2523 ) = 1175\r
+ HASH ( 2524 ) = 2521\r
+ HASH ( 2525 ) = 669\r
+ HASH ( 2526 ) = 2457\r
+ HASH ( 2527 ) = 1614\r
+ HASH ( 2528 ) = -2525\r
+ HASH ( 2529 ) = 1742\r
+ HASH ( 2530 ) = -2527\r
+ HASH ( 2531 ) = 1485\r
+ HASH ( 2532 ) = 2529\r
+ HASH ( 2533 ) = 2066\r
+ HASH ( 2534 ) = -2531\r
+ HASH ( 2535 ) = 1742\r
+ HASH ( 2536 ) = -2533\r
+ HASH ( 2537 ) = 14\r
+ HASH ( 2538 ) = 2483\r
+ HASH ( 2539 ) = 1173\r
+ HASH ( 2540 ) = -2537\r
+ HASH ( 2541 ) = 847\r
+ HASH ( 2542 ) = -2539\r
+ HASH ( 2543 ) = 919\r
+ HASH ( 2544 ) = -2541\r
+ HASH ( 2545 ) = 663\r
+ HASH ( 2547 ) = 669\r
+ HASH ( 2548 ) = -2545\r
+ HASH ( 2549 ) = 25\r
+ HASH ( 2550 ) = 2357\r
+ HASH ( 2551 ) = 929\r
+ HASH ( 2552 ) = -2549\r
+ HASH ( 2553 ) = 23\r
+ HASH ( 2555 ) = 1866\r
+ HASH ( 2556 ) = -2553\r
+ HASH ( 2557 ) = 28\r
+ HASH ( 2558 ) = 2311\r
+ HASH ( 2559 ) = 792\r
+ HASH ( 2560 ) = -2557\r
+ HASH ( 2561 ) = 23\r
+ HASH ( 2563 ) = 1810\r
+ HASH ( 2564 ) = -2561\r
+ HASH ( 2565 ) = 1047\r
+ HASH ( 2566 ) = 2563\r
+ HASH ( 2567 ) = 1810\r
+ HASH ( 2568 ) = -2565\r
+ HASH ( 2569 ) = 13\r
+ HASH ( 2570 ) = 2143\r
+ HASH ( 2571 ) = 1563\r
+ HASH ( 2572 ) = -2569\r
+ HASH ( 2573 ) = 27\r
+ HASH ( 2575 ) = 785\r
+ HASH ( 2576 ) = -2573\r
+ HASH ( 2577 ) = 1367\r
+ HASH ( 2579 ) = 920\r
+ HASH ( 2580 ) = -2577\r
+ HASH ( 2581 ) = 13\r
+ HASH ( 2583 ) = 1943\r
+ HASH ( 2584 ) = -2581\r
+ HASH ( 2585 ) = 923\r
+ HASH ( 2586 ) = 2543\r
+ HASH ( 2587 ) = 1874\r
+ HASH ( 2588 ) = -2585\r
+ HASH ( 2589 ) = 919\r
+ HASH ( 2590 ) = -2587\r
+ HASH ( 2591 ) = 1757\r
+ HASH ( 2593 ) = 1422\r
+ HASH ( 2595 ) = 1558\r
+ HASH ( 2596 ) = 2375\r
+ HASH ( 2597 ) = 1485\r
+ HASH ( 2598 ) = -2595\r
+ HASH ( 2599 ) = 1738\r
+ HASH ( 2600 ) = -2597\r
+ HASH ( 2601 ) = 29\r
+ HASH ( 2603 ) = 1103\r
+ HASH ( 2604 ) = -2601\r
+ HASH ( 2605 ) = 1180\r
+ HASH ( 2606 ) = -2603\r
+ HASH ( 2607 ) = 1485\r
+ HASH ( 2609 ) = 27\r
+ HASH ( 2611 ) = 1565\r
+ HASH ( 2612 ) = 2405\r
+ HASH ( 2613 ) = 1175\r
+ HASH ( 2614 ) = -2611\r
+ HASH ( 2615 ) = 28\r
+ HASH ( 2617 ) = 15\r
+ HASH ( 2618 ) = 2579\r
+ HASH ( 2619 ) = 665\r
+ HASH ( 2620 ) = 2131\r
+ HASH ( 2621 ) = 1883\r
+ HASH ( 2622 ) = -2619\r
+ HASH ( 2623 ) = 1365\r
+ HASH ( 2625 ) = 2066\r
+ HASH ( 2626 ) = -2623\r
+ HASH ( 2627 ) = 1821\r
+ HASH ( 2628 ) = -2625\r
+ HASH ( 2629 ) = 1354\r
+ HASH ( 2630 ) = -2627\r
+ HASH ( 2631 ) = 21\r
+ HASH ( 2632 ) = 2629\r
+ HASH ( 2633 ) = 1173\r
+ HASH ( 2634 ) = -2631\r
+ HASH ( 2635 ) = 2976\r
+ HASH ( 2636 ) = -2633\r
+ HASH ( 2637 ) = 1821\r
+ HASH ( 2638 ) = -2635\r
+ HASH ( 2639 ) = 1485\r
+ HASH ( 2641 ) = 14\r
+ HASH ( 2642 ) = 2249\r
+ HASH ( 2643 ) = 669\r
+ HASH ( 2644 ) = -2641\r
+ HASH ( 2645 ) = 1175\r
+ HASH ( 2646 ) = -2643\r
+ HASH ( 2647 ) = 1750\r
+ HASH ( 2648 ) = -2645\r
+ HASH ( 2649 ) = 1934\r
+ HASH ( 2650 ) = 2559\r
+ HASH ( 2651 ) = 1175\r
+ HASH ( 2652 ) = -2649\r
+ HASH ( 2653 ) = 1501\r
+ HASH ( 2654 ) = -2651\r
+ HASH ( 2655 ) = 792\r
+ HASH ( 2656 ) = -2653\r
+ HASH ( 2657 ) = 14\r
+ HASH ( 2658 ) = 2599\r
+ HASH ( 2659 ) = 1180\r
+ HASH ( 2660 ) = -2657\r
+ HASH ( 2661 ) = 661\r
+ HASH ( 2662 ) = 2567\r
+ HASH ( 2663 ) = 1047\r
+ HASH ( 2664 ) = -2661\r
+ HASH ( 2665 ) = 1756\r
+ HASH ( 2666 ) = 2293\r
+ HASH ( 2667 ) = 1358\r
+ HASH ( 2668 ) = -2665\r
+ HASH ( 2669 ) = 1485\r
+ HASH ( 2670 ) = -2667\r
+ HASH ( 2671 ) = 23\r
+ HASH ( 2673 ) = 917\r
+ HASH ( 2674 ) = -2671\r
+ HASH ( 2675 ) = 1181\r
+ HASH ( 2676 ) = -2673\r
+ HASH ( 2677 ) = 2075\r
+ HASH ( 2678 ) = -2675\r
+ HASH ( 2679 ) = 14\r
+ HASH ( 2680 ) = 2677\r
+ HASH ( 2681 ) = 1181\r
+ HASH ( 2682 ) = -2679\r
+ HASH ( 2683 ) = 14\r
+ HASH ( 2685 ) = 1173\r
+ HASH ( 2686 ) = -2683\r
+ HASH ( 2687 ) = 2065\r
+ HASH ( 2688 ) = -2685\r
+ HASH ( 2689 ) = 919\r
+ HASH ( 2690 ) = 2687\r
+ HASH ( 2691 ) = 1181\r
+ HASH ( 2692 ) = 2443\r
+ HASH ( 2693 ) = 21\r
+ HASH ( 2694 ) = 2195\r
+ HASH ( 2695 ) = 1930\r
+ HASH ( 2696 ) = -2693\r
+ HASH ( 2697 ) = 1757\r
+ HASH ( 2698 ) = -2695\r
+ HASH ( 2699 ) = 27\r
+ HASH ( 2701 ) = 27\r
+ HASH ( 2702 ) = 2419\r
+ HASH ( 2703 ) = 2062\r
+ HASH ( 2704 ) = -2701\r
+ HASH ( 2705 ) = 1368\r
+ HASH ( 2706 ) = -2703\r
+ HASH ( 2707 ) = 27\r
+ HASH ( 2708 ) = 2421\r
+ HASH ( 2709 ) = 1614\r
+ HASH ( 2710 ) = -2707\r
+ HASH ( 2711 ) = 788\r
+ HASH ( 2712 ) = 2413\r
+ HASH ( 2713 ) = 1368\r
+ HASH ( 2714 ) = -2711\r
+ HASH ( 2715 ) = 1943\r
+ HASH ( 2716 ) = -2713\r
+ HASH ( 2717 ) = 1181\r
+ HASH ( 2718 ) = 2715\r
+ HASH ( 2719 ) = 1614\r
+ HASH ( 2720 ) = 1995\r
+ HASH ( 2721 ) = 1934\r
+ HASH ( 2722 ) = 2621\r
+ HASH ( 2723 ) = 1180\r
+ HASH ( 2725 ) = 1873\r
+ HASH ( 2726 ) = -2723\r
+ HASH ( 2727 ) = 919\r
+ HASH ( 2728 ) = 2725\r
+ HASH ( 2729 ) = 23\r
+ HASH ( 2730 ) = 2555\r
+ HASH ( 2731 ) = 1294\r
+ HASH ( 2732 ) = -2729\r
+ HASH ( 2733 ) = 1488\r
+ HASH ( 2734 ) = 2447\r
+ HASH ( 2735 ) = 1746\r
+ HASH ( 2736 ) = -2733\r
+ HASH ( 2737 ) = 1821\r
+ HASH ( 2738 ) = -2735\r
+ HASH ( 2739 ) = 1561\r
+ HASH ( 2740 ) = 2737\r
+ HASH ( 2741 ) = 1821\r
+ HASH ( 2742 ) = -2739\r
+ HASH ( 2743 ) = 921\r
+ HASH ( 2744 ) = 2741\r
+ HASH ( 2745 ) = 14\r
+ HASH ( 2746 ) = 2477\r
+ HASH ( 2747 ) = 1563\r
+ HASH ( 2748 ) = -2745\r
+ HASH ( 2749 ) = 1617\r
+ HASH ( 2750 ) = -2747\r
+ HASH ( 2751 ) = 1418\r
+ HASH ( 2752 ) = -2749\r
+ HASH ( 2753 ) = 1751\r
+ HASH ( 2754 ) = 2535\r
+ HASH ( 2755 ) = 1886\r
+ HASH ( 2756 ) = -2753\r
+ HASH ( 2757 ) = 1742\r
+ HASH ( 2758 ) = -2755\r
+ HASH ( 2759 ) = 1422\r
+ HASH ( 2760 ) = 2757\r
+ HASH ( 2761 ) = 1822\r
+ HASH ( 2762 ) = -2759\r
+ HASH ( 2763 ) = 1742\r
+ HASH ( 2764 ) = -2761\r
+ HASH ( 2765 ) = 1373\r
+ HASH ( 2766 ) = 2763\r
+ HASH ( 2767 ) = 1822\r
+ HASH ( 2768 ) = -2765\r
+ HASH ( 2769 ) = 1742\r
+ HASH ( 2770 ) = -2767\r
+ HASH ( 2771 ) = 661\r
+ HASH ( 2772 ) = 2769\r
+ HASH ( 2773 ) = 1742\r
+ HASH ( 2774 ) = -2771\r
+ HASH ( 2775 ) = 653\r
+ HASH ( 2776 ) = 2773\r
+ HASH ( 2777 ) = 10\r
+ HASH ( 2778 ) = 2033\r
+ HASH ( 2779 ) = 28\r
+ HASH ( 2780 ) = 2469\r
+ HASH ( 2781 ) = 924\r
+ HASH ( 2782 ) = -2779\r
+ HASH ( 2783 ) = 1548\r
+ HASH ( 2784 ) = -2781\r
+ HASH ( 2785 ) = 1627\r
+ HASH ( 2786 ) = -2783\r
+ HASH ( 2787 ) = 14\r
+ HASH ( 2788 ) = 2785\r
+ HASH ( 2789 ) = 1947\r
+ HASH ( 2790 ) = -2787\r
+ HASH ( 2791 ) = 909\r
+ HASH ( 2792 ) = -2789\r
+ HASH ( 2793 ) = 1548\r
+ HASH ( 2794 ) = -2791\r
+ HASH ( 2795 ) = 1627\r
+ HASH ( 2796 ) = -2793\r
+ HASH ( 2797 ) = 911\r
+ HASH ( 2798 ) = 2795\r
+ HASH ( 2799 ) = 15\r
+ HASH ( 2800 ) = 2571\r
+ HASH ( 2801 ) = 2962\r
+ HASH ( 2802 ) = -2799\r
+ HASH ( 2803 ) = 1563\r
+ HASH ( 2804 ) = -2801\r
+ HASH ( 2805 ) = 1949\r
+ HASH ( 2806 ) = 2113\r
+ HASH ( 2807 ) = 1881\r
+ HASH ( 2808 ) = -2805\r
+ HASH ( 2809 ) = 14\r
+ HASH ( 2810 ) = 2387\r
+ HASH ( 2811 ) = 1180\r
+ HASH ( 2812 ) = -2809\r
+ HASH ( 2813 ) = 1760\r
+ HASH ( 2814 ) = -2811\r
+ HASH ( 2815 ) = 1102\r
+ HASH ( 2816 ) = -2813\r
+ HASH ( 2817 ) = 1167\r
+ HASH ( 2818 ) = 2803\r
+ HASH ( 2819 ) = 1563\r
+ HASH ( 2820 ) = -2817\r
+ HASH ( 2821 ) = 29\r
+ HASH ( 2822 ) = 2029\r
+ HASH ( 2823 ) = 1496\r
+ HASH ( 2824 ) = -2821\r
+ HASH ( 2825 ) = 1486\r
+ HASH ( 2826 ) = 2823\r
+ HASH ( 2827 ) = 32\r
+ HASH ( 2829 ) = 13\r
+ HASH ( 2830 ) = 2279\r
+ HASH ( 2831 ) = 1175\r
+ HASH ( 2833 ) = 788\r
+ HASH ( 2834 ) = 2705\r
+ HASH ( 2835 ) = 1365\r
+ HASH ( 2837 ) = 29\r
+ HASH ( 2838 ) = 2613\r
+ HASH ( 2839 ) = 1566\r
+ HASH ( 2840 ) = -2837\r
+ HASH ( 2841 ) = 1175\r
+ HASH ( 2842 ) = -2839\r
+ HASH ( 2843 ) = 27\r
+ HASH ( 2844 ) = 2841\r
+ HASH ( 2845 ) = 1038\r
+ HASH ( 2846 ) = -2843\r
+ HASH ( 2847 ) = 1870\r
+ HASH ( 2848 ) = -2845\r
+ HASH ( 2849 ) = 1175\r
+ HASH ( 2850 ) = -2847\r
+ HASH ( 2851 ) = 29\r
+ HASH ( 2852 ) = 2849\r
+ HASH ( 2853 ) = 1630\r
+ HASH ( 2854 ) = -2851\r
+ HASH ( 2855 ) = 1175\r
+ HASH ( 2856 ) = -2853\r
+ HASH ( 2857 ) = 27\r
+ HASH ( 2858 ) = 2855\r
+ HASH ( 2859 ) = 1486\r
+ HASH ( 2860 ) = -2857\r
+ HASH ( 2861 ) = 1175\r
+ HASH ( 2862 ) = -2859\r
+ HASH ( 2863 ) = 919\r
+ HASH ( 2865 ) = 845\r
+ HASH ( 2866 ) = -2863\r
+ HASH ( 2867 ) = 1559\r
+ HASH ( 2868 ) = 2237\r
+ HASH ( 2869 ) = 1874\r
+ HASH ( 2870 ) = -2867\r
+ HASH ( 2871 ) = 1484\r
+ HASH ( 2872 ) = -2869\r
+ HASH ( 2873 ) = 27\r
+ HASH ( 2875 ) = 14\r
+ HASH ( 2877 ) = 1372\r
+ HASH ( 2878 ) = -2875\r
+ HASH ( 2879 ) = 661\r
+ HASH ( 2880 ) = 2551\r
+ HASH ( 2881 ) = 1751\r
+ HASH ( 2882 ) = -2879\r
+ HASH ( 2883 ) = 1870\r
+ HASH ( 2884 ) = -2881\r
+ HASH ( 2885 ) = 929\r
+ HASH ( 2886 ) = -2883\r
+ HASH ( 2887 ) = 1181\r
+ HASH ( 2888 ) = 2885\r
+ HASH ( 2889 ) = 652\r
+ HASH ( 2891 ) = 13\r
+ HASH ( 2892 ) = 2589\r
+ HASH ( 2893 ) = 1806\r
+ HASH ( 2895 ) = 1880\r
+ HASH ( 2897 ) = 2071\r
+ HASH ( 2898 ) = -2895\r
+ HASH ( 2899 ) = 856\r
+ HASH ( 2900 ) = -2897\r
+ HASH ( 2901 ) = 31\r
+ HASH ( 2902 ) = 2097\r
+ HASH ( 2903 ) = 850\r
+ HASH ( 2904 ) = -2901\r
+ HASH ( 2905 ) = 22\r
+ HASH ( 2906 ) = 2903\r
+ HASH ( 2907 ) = 785\r
+ HASH ( 2908 ) = 2393\r
+ HASH ( 2909 ) = 1866\r
+ HASH ( 2910 ) = -2907\r
+ HASH ( 2911 ) = 14\r
+ HASH ( 2912 ) = 2655\r
+ HASH ( 2913 ) = 1175\r
+ HASH ( 2914 ) = -2911\r
+ HASH ( 2915 ) = 1949\r
+ HASH ( 2916 ) = -2913\r
+ HASH ( 2917 ) = 1752\r
+ HASH ( 2918 ) = -2915\r
+ HASH ( 2919 ) = 792\r
+ HASH ( 2920 ) = -2917\r
+ HASH ( 2921 ) = 1634\r
+ HASH ( 2922 ) = 2919\r
+ HASH ( 2923 ) = 792\r
+ HASH ( 2924 ) = -2921\r
+ HASH ( 2925 ) = 29\r
+ HASH ( 2926 ) = 2923\r
+ HASH ( 2927 ) = 1500\r
+ HASH ( 2928 ) = -2925\r
+ HASH ( 2929 ) = 667\r
+ HASH ( 2930 ) = 2575\r
+ HASH ( 2931 ) = 785\r
+ HASH ( 2932 ) = -2929\r
+ HASH ( 2933 ) = 14\r
+ HASH ( 2934 ) = 2369\r
+ HASH ( 2935 ) = 1564\r
+ HASH ( 2936 ) = -2933\r
+ HASH ( 2937 ) = 789\r
+ HASH ( 2938 ) = -2935\r
+ HASH ( 2939 ) = 28\r
+ HASH ( 2940 ) = 2937\r
+ HASH ( 2941 ) = 668\r
+ HASH ( 2942 ) = -2939\r
+ HASH ( 2943 ) = 27\r
+ HASH ( 2944 ) = 2931\r
+ HASH ( 2945 ) = 1870\r
+ HASH ( 2946 ) = -2943\r
+ HASH ( 2947 ) = 652\r
+ HASH ( 2948 ) = -2945\r
+ HASH ( 2949 ) = 667\r
+ HASH ( 2950 ) = -2947\r
+ HASH ( 2951 ) = 1806\r
+ HASH ( 2953 ) = 778\r
+ HASH ( 2954 ) = -2951\r
+ HASH ( 2955 ) = 1365\r
+ HASH ( 2956 ) = 2953\r
+ HASH ( 2957 ) = 1557\r
+ HASH ( 2958 ) = 2201\r
+ HASH ( 2959 ) = 728\r
+ HASH ( 2960 ) = -2957\r
+ HASH ( 2961 ) = 23\r
+ HASH ( 2962 ) = 2959\r
+ HASH ( 2963 ) = 906\r
+ HASH ( 2964 ) = -2961\r
+ HASH ( 2965 ) = 1557\r
+ HASH ( 2966 ) = -2963\r
+ HASH ( 2967 ) = 20\r
+ HASH ( 2969 ) = 1548\r
+ HASH ( 2970 ) = -2967\r
+ HASH ( 2971 ) = 23\r
+ HASH ( 2973 ) = 1042\r
+ HASH ( 2974 ) = -2971\r
+ HASH ( 2975 ) = 1551\r
+ HASH ( 2977 ) = 2222\r
+ HASH ( 2978 ) = -2975\r
+ HASH ( 2979 ) = 1738\r
+ HASH ( 2980 ) = -2977\r
+ HASH ( 2981 ) = 667\r
+ HASH ( 2982 ) = -2979\r
+ HASH ( 2983 ) = 785\r
+ HASH ( 2984 ) = 2547\r
+ HASH ( 2985 ) = 1866\r
+ HASH ( 2986 ) = -2983\r
+ HASH ( 2987 ) = 15\r
+ HASH ( 2988 ) = 2981\r
+ HASH ( 2989 ) = 2200\r
+ HASH ( 2990 ) = -2987\r
+ HASH ( 2991 ) = 1738\r
+ HASH ( 2992 ) = -2989\r
+ HASH ( 2993 ) = 667\r
+ HASH ( 2994 ) = -2991\r
+ HASH ( 2995 ) = 34\r
+ HASH ( 2996 ) = 2993\r
+ HASH ( 2997 ) = 1738\r
+ HASH ( 2998 ) = -2995\r
+ HASH ( 2999 ) = 13\r
+ HASH ( 3000 ) = 2505\r
+ \r
+ return\r
+ end\r
+ \r
+ \r
+ INTEGER*2 FUNCTION SEARCH(K,name,hash,nlast)\r
+ IMPLICIT INTEGER*2 (A-Z)\r
+ dimension hash(8000), name(10)\r
+ \r
+ m = 1009\r
+ NAME1=NAME(1)\r
+ I=MOD(NAME1,M)\r
+ I=I*2+1\r
+ IF (HASH(I).NE.0) GOTO 3\r
+ SEARCH=I\r
+ HASH(I)=NAME1\r
+ GOTO 11\r
+1 IF (I.NE.0) GOTO 3\r
+2 NLAST=NLAST-2\r
+ IF (NLAST.LT.0) write(*,99)\r
+ 99 format(' przepelnienie') \r
+ IF (HASH(NLAST).NE.0) GOTO 2\r
+ SEARCH=NLAST\r
+ HASH(NLAST)=NAME(1)\r
+ HASH(J+1)=NLAST\r
+ I=NLAST\r
+ GOTO 11\r
+3 IF (HASH(I).EQ.NAME1) GOTO 4\r
+ J=I\r
+ I=HASH(J+1)\r
+ GOTO 10\r
+4 IF ((K.NE.1).OR.(HASH(I+1).LT.0)) GOTO 5\r
+ SEARCH=I\r
+ RETURN\r
+5 J=I\r
+ P=1\r
+6 T=HASH(J+1)\r
+ P=P+1\r
+ IF (P.LE.K) GOTO 8\r
+ IF (T.LT.0) GOTO 7\r
+ SEARCH=I\r
+ RETURN\r
+7 J=-T\r
+ I=HASH(J+1)\r
+ GOTO 10\r
+8 IF (T.LT.0) GOTO 9\r
+ I=T\r
+ GOTO 1\r
+9 J=-T\r
+ IF (NAME(P).EQ.HASH(J)) GOTO 6\r
+ I=HASH(J+1)\r
+10 IF (I.GE.0) GOTO 1\r
+ J=-I\r
+ I=HASH(J+1)\r
+ GOTO 10\r
+11 P=2\r
+12 IF (P.GT.K) RETURN\r
+13 NLAST=NLAST-2\r
+ IF (NLAST.LT.0) write(*,99)\r
+ IF (HASH(NLAST).NE.0) GOTO 13\r
+ HASH(NLAST)=NAME(P)\r
+ HASH(I+1)=-NLAST\r
+ I=NLAST\r
+ P=P+1\r
+ GOTO 12\r
+ END\r
--- /dev/null
+C
+ COMMON/OPTION/OPTMEM,OPTOPT,OPTIND,OPTTYP,OPTTRC,OPTCSC,OPTCSF
+ LOGICAL OPTOPT,OPTTYP,OPTTRC
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+CBC B.Ciesielski added concurrent statements
+CBC 1987.04.15 1. RESUME same as ATTACH, opcode 220
+CBC 1987.04.24 2. added missing STORAGE:2 metacommand
+CBC 1987.11.18 3. added procedure SCONC
+C
+ SUBROUTINE SRESUM
+C------------------------------------------------------
+C
+C NA CZUBKU JEST ARGUMENT RESUME. BADA TYP,GENERUJE KOD,
+C ZDEJMUJE ZE STOSU.
+C
+C ##### OUTPUT CODE : 220 .
+C
+C ##### DETECTED ERROR(S) : 477
+C
+C............. /STOS/ .....
+ IMPLICIT INTEGER (A-Z)
+ COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
+ X APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
+ X CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
+ X RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
+ X FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
+ LOGICAL LSTWILL,FLREADY,TEST
+C
+ COMMON/OPTION/OPTMEM,OPTOPT,OPTIND,OPTTYP,OPTTRC,OPTCSC,OPTCSF
+ LOGICAL OPTOPT,OPTTYP,OPTTRC
+C
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ IOP(4),
+ X P,
+ X TLDIM, TLBAS, IDL, OBJL,
+ X TRDIM, TRBAS, IDR, OBJR,
+ X TRESLT,
+ X CONVL, CONVR,
+ X NRPAR,
+ X IX (261),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL, OWN, OBJECT,
+ X IPMEM(5000)
+ REAL STALER(100)
+ INTEGER STACK(5000)
+ EQUIVALENCE(STALER(1),IPMEM(1) )
+ EQUIVALENCE(STACK(1),IPMEM(1))
+C
+C
+ INTEGER ELEM
+C.........
+ CALL SVALUE
+ IF(STACK(VALTOP).EQ.0)RETURN
+ IF(STACK(VALTOP-3).GT.0)GO TO 500
+ ELEM=STACK(VALTOP-4)
+ ELEM=IAND(IPMEM(ELEM),15)
+ IF(ELEM.GT.7 .AND. ELEM.LT.13 .OR. ELEM.EQ.2)GO TO 500
+ ELEM=STACK(VALTOP-2)
+C RESUME( NONE ) ?
+ IF(STACK(VALTOP).EQ.1)ELEM=LMEM-3
+C = ATS NONE
+ CALL QUADR2(220,ELEM)
+ RETURN
+C NIEPOPRAWNY TYP ARGUMENTU RESUME
+ 500 CALL SERROR(477)
+ RETURN
+ END
+
+ subroutine sconc(action)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
+ X APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
+ X CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
+ X RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
+ X FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
+ LOGICAL LSTWILL,FLREADY,TEST
+C
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ IOP(4),
+ X P,
+ X TLDIM, TLBAS, IDL, OBJL,
+ X TRDIM, TRBAS, IDR, OBJR,
+ X TRESLT,
+ X CONVL, CONVR,
+ X NRPAR,
+ X IX (261),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL, OWN, OBJECT,
+ X IPMEM(5000)
+ REAL STALER(100)
+ INTEGER STACK(5000)
+ EQUIVALENCE(STALER(1),IPMEM(1) )
+ EQUIVALENCE(STACK(1),IPMEM(1))
+c
+c generate proper opcode
+ call quadr1(action)
+c process next identifier
+100 call snext
+ if (wb .ne. 28) goto 200
+ call snext
+c check if procedure or function
+ ind = mident(wb)
+ elem = swhat(ind)
+ if (elem .ne. 11 .and. elem .ne. 12) goto 110
+c output prototype address
+ call quadr1(ind)
+ goto 100
+110 call serror(478)
+ goto 100
+c end of identifier list
+200 call quadr1(0)
+c generate ACCEPT2 if necessary
+ if (action .eq. 225) call quadr1(226)
+ return
+ end
+
--- /dev/null
+@echo off\r
+:begin\r
+if "%1" == "" goto :end\r
+echo %1\r
+del %1\r
+shift\r
+goto :begin\r
+:end\r
+\r
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE SCAN
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, JK1, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT,JK2,NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEXT, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+
+ REAL FRACT,NU
+cdsw&bc
+ logical overfl
+ LOGICAL OK,OKEY
+ INTEGER SD,SE,SL,SR,SS,ST
+ data sd,se,sl,sr,ss,st /2,61,40,41,47,42/
+ DATA SCANHEX /x'7FFF'/
+C
+ overfl = .FALSE.
+ OK=.FALSE.
+ IF (.NOT.OKEY) GOTO 111
+ K=K1
+ IF (SY.EQ.70) GOTO 3001
+C INSERTED DUE TO T.SZCZEPANEK
+ SY=SY1
+ OKEY=.FALSE.
+ GOTO 2000
+101 CALL ERROR(111)
+ LP=LP+1
+111 IF (LP.LT.MAX) GOTO 1
+ CALL READIN
+1 IF (BUFOR(1).EQ.SD) GOTO 3001
+ Z=BUFOR(LP)
+ ZNAK=ORD(Z)
+C ZNAK MEANS CHARACTER
+ IF (STAN.LT.10) GOTO 10
+C WITHIN COMMENT - COMPOUND SYMBOLS ARE NOT PICKED UP
+C THE SAME FOR TEXT AND CHARACTER CONSTANTS
+ IF (STAN.EQ.11) GOTO 11
+ GOTO 8
+10 IF (ZNAK.EQ.63) GOTO 101
+11 I=SKOK(ZNAK)
+ GOTO (2,3,4,5,6,8),I
+2 IF (BUFOR(LP+1).NE.SE) GOTO 8
+ GOTO 7
+3 IF (BUFOR(LP+1).NE.SR) GOTO 8
+ GOTO 7
+4 IF (BUFOR(LP+1).NE.SS) GOTO 8
+ IF (BUFOR(LP+2).NE.SE) GOTO 8
+ LP=LP+1
+ GOTO 7
+C --- ALLOW FOR "<>" TO STAND FOR "NON EQUAL"
+5 IF (ZNAK.NE.50) GO TO 5055
+ IF (BUFOR(LP+1) .NE. ICHAR('>')) GO TO 5055
+ ZNAK = 49
+ GO TO 7
+C ---
+5055 IF (BUFOR(LP+1).NE.SE) GOTO 8
+ GOTO 7
+6 IF (BUFOR(LP+1).NE.ST) GOTO 8
+C BEGINNING OF COMMENT HAS BEEN RECOGNIZED '(*'. CHECK FOR A LISTING
+C CONTROL OPTION FOLLOWING THE COMMENT ANNOUNCEMENT. IF ONE OCCURRS
+C THEN THE LISTING CONTROL VARIABLE IS TO BE SET PROPERLY
+ IF (BUFOR(LP+2).NE.ICHAR('$')) GOTO 7
+ LP=LP+3
+ CALL OPTSET
+7 LP=LP+1
+ ZNAK=ZNAK+7
+8 LP=LP+1
+C END OF DETECTING COMPOUND SYMBOLS
+C THE AUTOMATON - PART I
+ J=B(ZNAK)+1
+ I=TRANS1(J,STAN+1)
+ GOTO (190,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,170,
+ ,180),I
+20 SY=SEARCH(MM)
+ K=0
+ KLUCZ=KEY(SY)
+ IF (KLUCZ.EQ.(SIDENT*8)) K=2
+ K=K/2
+ OK=.TRUE.
+ GOTO 190
+30 IF (KK.LT.NB) GOTO 31
+ IF (MM.LT.TL) GOTO 32
+ CALL ERROR(212)
+ GOTO 190
+31 KK=KK+1
+cbc COM(MM)=ISHFT(COM(MM),8)+Z
+ com(mm)=ior(ishft(z, 8), com(mm))
+cbc
+ GOTO 190
+32 KK=1
+ MM=MM+1
+ com(MM)=Z
+ GOTO 190
+40 IF (KK.LT.NB) GOTO 41
+ IF (MM.LT.NL) GOTO 42
+ CALL ERROR(211)
+ GOTO 190
+41 KK=KK+1
+ NAME(MM)=NAME(MM)*BYTE+ZNAK
+ GOTO 190
+42 KK=1
+ MM=MM+1
+ NAME(MM)=ZNAK
+ IF (ZNAK.EQ.0) NAME(MM)=60
+ GOTO 190
+50 K=2
+cdsw&bc IF (INTPART.LT.0) GOTO 52
+ if (overfl) goto 52
+ SY=INTPART
+ GOTO 53
+52 SY=SCANHEX
+ CALL ERROR(205)
+53 INTPART=0
+ OK=.TRUE.
+ GOTO 190
+70 CALL ERROR(201)
+60 IF (SIGN.EQ.1) EXP=-EXP
+ EXP=EXP-FRAC
+cdsw&bc IF (INTPART.LT.0) GOTO 191
+ if (overfl) goto 191
+ FRACT=INTPART
+ GOTO 192
+191 FRACT=NU
+192 IF (EXP) 200,210,193
+193 DO 195 J=1,EXP
+CJF IF (FRACT.GT.0.7237005E75) GOTO 207
+195 FRACT=FRACT*10.0
+ GOTO 210
+CJF 207 CALL ERROR(206)
+CJF GOTO 210
+200 EXP=-EXP
+ DO 205 J=1,EXP
+CJF IF (FRACT.GT.0.AND.FRACT.LT.0.5397605E-77) GOTO 207
+205 FRACT=FRACT*0.1
+210 K=4
+ NU=FRACT
+ OK=.TRUE.
+ SIGN=0
+ EXP=0
+ INTPART=0
+ FRAC=0
+ GOTO 190
+80 K=6
+ SY=38
+ OK=.TRUE.
+ GOTO 190
+90 INTPART=ZNAK
+ GOTO 190
+110 FRAC=0
+130 FRAC=FRAC+1
+cdsw&bc 100 IF (INTPART.LT.0) GOTO 102
+100 if (overfl) goto 102
+ NU=INTPART
+cdsw&bc check for overflow
+#if ( WSIZE == 4 )
+cailvaxC max. integer on VAX is 2147483647
+ if ( (intpart .gt. 214748364) .or. ((intpart .eq. 214748364)
+ C .and. (znak .gt. 7)) ) overfl = .TRUE.
+ if (overfl) goto 102
+#else
+ if (intpart .gt. 3275) overfl = .TRUE.
+#endif
+ INTPART=INTPART*10+ZNAK
+cdsw&bc IF (INTPART.GE.0) GOTO 190
+#if ( WSIZE == 4 )
+cailvaxC overfl is .FALSE. here
+ goto 190
+#else
+ if (.not. overfl) goto 190
+#endif
+102 NU=NU*10.0+ZNAK
+ GOTO 190
+120 EXP=ZNAK
+ GOTO 190
+140 EXP=EXP*10+ZNAK
+ GOTO 190
+150 SIGN=1
+ GOTO 190
+160 STAN1=STAN
+ GOTO 190
+170 CALL ERROR(202)
+ GOTO 190
+180 IF (EXP.LT.0) GOTO 181
+ IF (ZNAK.EQ.44) GOTO 190
+ ZNAK=36
+ STAN=0
+cdsw&bc
+ exp = 0
+c
+ CALL ERROR(203)
+ GOTO 190
+181 EXP=Z
+ ZNAK=0
+190 CONTINUE
+C THE AUTOMATON - PART II
+1000 J=B(ZNAK)+1
+ I=TRANS2(J,STAN+1)
+ GOTO (1300,1020,1030,1040,1050,1060,1070,1080,1090,1100,1110,1120,
+ ,1130,1140,1150,1160,1170,1180,1190,1200,1210),I
+1020 STAN=0
+ GOTO 1300
+1030 KK=1
+ MM=1
+ NAME(1)=ZNAK
+ STAN=1
+ GOTO 1300
+1040 KK=2
+ MM=1
+ NAME(1)=14*BYTE+ZNAK
+ STAN=1
+ GOTO 1300
+1050 STAN=2
+ GOTO 1300
+1060 STAN=5
+ GOTO 1300
+1070 STAN=9
+ GOTO 1300
+1080 STAN=8
+ GOTO 1300
+1090 STAN=3
+ GOTO 1300
+1100 SY=ZNAK
+ GOTO 2070
+1110 STAN=4
+ GOTO 1300
+1120 CALL ERROR(204)
+1130 STAN=6
+ GOTO 1300
+1140 IF (OK) GOTO 1145
+ STAN=0
+ SY=ZNAK
+ GOTO 2070
+1145 K1=6
+ SY1=ZNAK
+ STAN=0
+ OKEY=.TRUE.
+ GOTO 1300
+1150 STAN=7
+ GOTO 1300
+1160 KK=2
+ MM=1
+cdsw&bc
+ com(2) = 0
+c
+ STAN=10
+ GOTO 1300
+1170 STAN=0
+ K=4
+ S=SCONST
+ CALL TINSER
+ GOTO 3000
+1180 STAN=11
+ GOTO 1300
+1190 STAN=STAN1
+ GOTO 1300
+1200 STAN=12
+ EXP=-1
+ GOTO 1300
+1210 K=6
+ STAN=0
+ S=SCONST
+ ADRES=EXP
+ EXP=0
+ GOTO 3000
+1300 CONTINUE
+C END OF THE SECOND PHASE
+ IF (.NOT.OK) GOTO 111
+2000 K=K+1
+ GOTO (2010,2020,2030,2040,2050,2060,2070),K
+2010 K=KLUCZ
+ S=K/8
+ ADRES=1+MOD(K,8)
+ K=SY
+ GOTO 3000
+2020 S=SIDENT
+ ADRES=SY
+ GOTO 3000
+2030 S=SCONST
+C INTEGER CONSTANT RECOGNIZED
+ ADRES=SY
+cdsw
+ sy = 0
+ GOTO 3000
+2040 S=SCONST
+ CALL TINSER
+ GOTO 3000
+2050 S=SCONST
+ ADRES=EMBEDE(NU)
+ GOTO 3000
+2060 S=SCONST
+ ADRES=EXP
+ GOTO 3000
+2070 K=SY-37
+ GOTO (2150,2102,2103,2104,2150,2150,2150,2150,2150,2150,2105,2106,
+ ,2107,2108,2150,2150,2150,2150,2109,2110,2111),K
+2102 S=STAR
+ ADRES=3
+ GOTO 3000
+2103 S=STAR
+ ADRES=4
+ GOTO 3000
+2104 S=STAR
+ ADRES=6
+ GOTO 3000
+2105 S=STAR
+ ADRES=5
+ GOTO 3000
+2106 S=SRELAT
+ ADRES=3
+ GOTO 3000
+2107 S=SRELAT
+ ADRES=5
+ GOTO 3000
+2108 S=SRELAT
+ ADRES=7
+ GOTO 3000
+2109 S=SRELAT
+ ADRES=4
+ GOTO 3000
+2110 S=SRELAT
+ ADRES=6
+ GOTO 3000
+2111 S=SRELAT
+ ADRES=8
+ GOTO 3000
+2150 S=SY
+3000 CONTINUE
+ RETURN
+3001 K=6
+ S=70
+ OKEY=.TRUE.
+ SY1=70
+C THE LAST TWO STATEMENT ARE INSERTED DUE TO T.SZCZEPANEK
+ RETURN
+ END
+
+ SUBROUTINE READIN
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
+C
+C POSTR - BUFFER FOR AUXILIARY INPUT FILE
+C VARIABLE STATUS DESCRIBES THE STATUS OF INPUT:
+C 1 - SOURCE TEXT IS READ FROM THE AUXILIARY INPUT
+C 0 - SOURCE TEXT IS READ FROM THE STANDARD INPUT
+C -1 - SOURCE TEXT HAS BEEN READ UNTIL THE LAST END. NOW THE STANDARD
+C INPUT IS BEING SKIPPED UNTIL EOF
+C
+ COMMON /LISTING/ OUTSTR(265)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
+ COMMON /BLANK/ C0M(4)
+ LOGICAL BTEST
+ character*1 bufor1(85)
+ character int2char
+ integer bufor2(43)
+ equivalence (bufor1(1), bufor2(1))
+
+ I=1
+ LP=1
+ GOTO 2
+C NOW ONE LINE IS READ FROM THE INPUT FILE
+1 LN=LN+1
+ call ffwrhex(16, ln)
+c
+ IF (BTEST(C0M(2),15)) GOTO 1001
+ call ffwrite_char(16, '0')
+c
+ GOTO 1002
+1001 call ffwrite_char(16, '1')
+c
+1002 CONTINUE
+c end of line - write CR/LF
+ call ffwrite_char(16, int2char(13))
+ call ffwrite_char(16, int2char(10))
+2 call nextch(17, bufor(1))
+ bufor(1) = iand(X'FF',bufor(1))
+ IF (BUFOR(1).EQ.1) GOTO 1
+ IF (BUFOR(1).EQ.2) RETURN
+3 I=I+1
+ call nextch(17, bufor(i))
+ bufor(i) = iand(X'FF',bufor(i))
+ if (bufor(i) .eq. 1) goto 90
+ if (i .lt. 84) goto 3
+ max = i
+ goto 100
+90 max = i-1
+100 continue
+ LN=LN+1
+ call ffwrhex(16, ln)
+c
+ IF (BTEST(C0M(2),15)) GOTO 110
+ call ffwrite_char(16, '0')
+c
+ GOTO 115
+110 call ffwrite_char(16, '1')
+c
+115 CONTINUE
+ BUFOR(max+1)=1
+ do 120 i=1,max
+120 bufor1(i) = char(bufor(i))
+ call ffwrite(16, bufor2(1), max)
+c
+ call ffwrite_char(16, int2char(13) )
+ call ffwrite_char(16, int2char(10) )
+ DO 140 I=MAX+1,85
+140 BUFOR(I)=ICHAR(' ')
+ MAX=MAX+2
+ RETURN
+ END
+
+ SUBROUTINE ERROR(K)
+C LIS OF THE ERRORS DIAGNOSED BY THE PARSER
+C
+C 101 - := EXPECTED
+C 102 - ; "
+C 103 - 'THEN' "
+C 104 - 'FI', 'ELSE' "
+C 105 - 'OD' "
+C 106 - ( "
+C 107 - ) "
+C 108 - 'DO' "
+C 109 - IDENTIFIER "
+C 110 - TOO MANY EXIT-S
+C 111 - ILLEGAL CHARACTER
+C 112 - STRUCTURE ERROR IN 'IF THEN ELSE FI'
+C 113 - ????????????????????????????????????????????????
+C 114 - DOT MISSING
+C 115 - WRONG OCCURRENCE OF A CONSTANT IN EXPRESSION
+C 116 - = MISSING
+C 117 - CONSTANT MISSING
+C 118 - DELIMITER MISSING
+C 119 - CLASS/ PROCEDURE / FUNCTION EXPECTED
+C 120 - 'HIDDEN HIDDEN' OR 'CLOSE CLOSE'
+C 121 - HIDDEN OUTSIDE CLASS
+C 122 - 'BLOCK' MISSING
+C 123 - OBJECTEXPRESSION IS NOT A GENERATOR
+C 124 - 'DIM' MISSING
+C 125 - 'TO' / 'DOWNTO' MISSING
+C 126 - ILLEGAL OCCURRENCE OF AN ARITHMETIC OPERATOR
+C 127 - DECLARATIONS EXPECTED (UNIT, VAR, CONST)
+C 128 - THE NAME OCCURRING AFTER 'END' DOESN-T MATCH THE UNIT NAME
+C 129 - CASE...ESAC STRUCTURE ERROR
+C 130 - DO...OD STRUCTURE ERROR
+C 131 - ILLEGAL OCCURRENCE OF MAIN
+C 132 - WHEN EXPECTED
+C 133 - TOO MANY CASES IN 'CASE' (UPPER LIMIT = 127)
+C 134 - 'BEGIN' MISSING
+C 135 - ERROR IN OPTION DEFINITON IN COMMENT
+C 136 - NULL PROGRAM
+C 137 - WRONG HEADER OF THE SOURCE PROGRAM (BLOCK/PROGRAM MISSING)
+C 138 - TOO MANY REPEAT STATEMENTS
+C 139 - UNREACHABLE INSTRUCTIONS AFTER EXIT
+C 140 - ANDIF'S AND ORIF'S INTERLEAVE
+C 141 - SEMAPHORE TYPE PRECEDED BY ARRAYOF
+C 142 - HANDLER IMPROPERLY ENDED
+C 143 - LASTWILL OCCURRS WITHIN A COMPOUND STATEMENT OR WITHIN A HANDLER
+C 144 - LASTWILL OCURRS TWICE
+C 145 - NO PARAMETER SPECIFICATION
+C 146 - WRONG REGISTER SPECIFICATION (IMPOSSIBLE IN THE PORTABLE VERSION)
+C 147 -
+C OVERFLOW-TYPE ERRORS: SCANNING STOPS ON ANY OF THEM
+C 191 - NULL PROGRAM - THE INPUT FILE IS EMPTY
+C 196 - HASH TABLE OVERFLOW
+C 197 - VARIABLE OR FORMAL PARAMETER LIST TOO LONG (LENGTH>132)
+C 198 - PARSER STACK OVERFLOW
+C 199 - IPMEM TABLE OVERFLOW - NO ROOM FOR MORE PROTOTYPES
+C SCANNER ERRORS:
+C 201 - ERROR IN REAL CONSTANT
+C 202 - COMMENT STRUCTURE ERROR
+C 203 - ERROR IN CHARACTER CONSTANT
+C 204 - ERROR IN CONSTANT
+C 205 - VALUE OF A INTEGER CONSTANT EXCEEDS MACHINE ARITHMETIC
+C 206 - REAL
+C 211 - IDENTIFIER TOO LONG (INITIAL 20 CHARACTERS ARE SIGNIFICANT)
+C 212 - TEXT TOO LONG (INITIAL 264 CHARACTERS ARE SIGNIFICANT)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /LISTING/ OUTSTR(265)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
+ COMMON /BLANK/ C0M(4) , S , ADRES , KA , RESZTA(8185)
+ LOGICAL BTEST
+ character int2char
+ DATA EL,EP /0,0/
+
+ IF ((EL.EQ.LN).AND.(EP.GE.LP-1)) GOTO 15
+ call ffwrhex(16, ln)
+c
+ IF (BTEST(C0M(2),15)) GOTO 1
+ call ffwrite_char(16, '0')
+c
+ GOTO 2
+1 call ffwrite_char(16, '1')
+c
+2 CONTINUE
+ IF (LP.LT.3) GO TO 6
+ DO 5 I=3,LP
+5 call ffwrite_char(16, ' ')
+6 CONTINUE
+ call ffwrite_char(16, '?')
+ call ffwrint(16, k)
+c end of line - write CR/LF
+ call ffwrite_char(16, int2char(13) )
+ call ffwrite_char(16, int2char(10) )
+c
+ LINE=LN
+ IF ((K.GT.190).AND.(K.LT.200)) CALL OVERF(K)
+ CALL MERR(K,0)
+15 EP=LP
+ EL=LN
+ RETURN
+ END
+
+ INTEGER FUNCTION ORD(X)
+ IMPLICIT INTEGER (A-Z)
+cdsw BYTE TAB(122)
+ dimension tab(122)
+C --- ORIGINAL TABLE (FOR ISO-7 CODE) CHANGED TO WORK FOR EBCDIC
+ DATA TAB /8*63,36,3*63,37,19*36,63,43,4*63,44,52,53,48,39,
+ ,42,40,38,41,0,1,2,3,4,5,6,7,8,9,47,45,50,49,51,63,63,
+ ,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,
+ ,30,31,32,33,34,35,4*63,46,
+ ,63,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,
+ ,30,31,32,33,34,35/
+ Z=X
+ IF (Z.GT.122) GOTO 10
+ ORD=TAB(Z)
+ RETURN
+10 ORD = 63
+ RETURN
+ END
+
+ INTEGER FUNCTION SEARCH(K)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ COM(302),
+ 1 HASH(8000), M, NAME(10), NLAST, NL,
+ 2 KEYS(200),
+ 3 SCANER(522), STOS(503), RESZTA(3652)
+
+ NAME1=NAME(1)
+ I=MOD(NAME1,M)
+ I=I*2+1
+ IF (HASH(I).NE.0) GOTO 3
+ SEARCH=I
+ HASH(I)=NAME1
+ GOTO 11
+1 IF (I.NE.0) GOTO 3
+2 NLAST=NLAST-2
+ IF (NLAST.LT.0) CALL ERROR(196)
+ IF (HASH(NLAST).NE.0) GOTO 2
+ SEARCH=NLAST
+ HASH(NLAST)=NAME(1)
+ HASH(J+1)=NLAST
+ I=NLAST
+ GOTO 11
+3 IF (HASH(I).EQ.NAME1) GOTO 4
+ J=I
+ I=HASH(J+1)
+ GOTO 10
+4 IF ((K.NE.1).OR.(HASH(I+1).LT.0)) GOTO 5
+ SEARCH=I
+ RETURN
+5 J=I
+ P=1
+6 T=HASH(J+1)
+ P=P+1
+ IF (P.LE.K) GOTO 8
+ IF (T.LT.0) GOTO 7
+ SEARCH=I
+ RETURN
+7 J=-T
+ I=HASH(J+1)
+ GOTO 10
+8 IF (T.LT.0) GOTO 9
+ I=T
+ GOTO 1
+9 J=-T
+ IF (NAME(P).EQ.HASH(J)) GOTO 6
+ I=HASH(J+1)
+10 IF (I.GE.0) GOTO 1
+ J=-I
+ I=HASH(J+1)
+ GOTO 10
+11 P=2
+12 IF (P.GT.K) RETURN
+13 NLAST=NLAST-2
+ IF (NLAST.LT.0) CALL ERROR(196)
+ IF (HASH(NLAST).NE.0) GOTO 13
+ HASH(NLAST)=NAME(P)
+ HASH(I+1)=-NLAST
+ I=NLAST
+ P=P+1
+ GOTO 12
+ END
+
+ INTEGER FUNCTION EMBEDE(X)
+C --- NAME CHANGED TO AVOID CONFLICTS IN THE 'ONE-PROGRAM' VERSION
+C --- OF THE COMPILER
+ IMPLICIT INTEGER(A-Z)
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ x ipmem(12890)
+cdsw X IPMEM(7890)
+ LOGICAL INSYS, LOCAL, OWN
+C IPMEM - MAIN MEMORY
+C ISFIN - TOP OF THE PROTOTYPE DICTIONARY STACK
+C LPMEM - DIVISION POINT OF IPMEM
+ REAL X, STALE(200)
+ EQUIVALENCE (IPMEM(1), STALE(1))
+
+#if ! ( WSIZE == 4 )
+ real y
+ integer*2 m(2)
+ equivalence (y, m(1))
+#endif
+
+ EMBEDE = 1
+
+#if ( WSIZE == 4 )
+cvax one real constant in one ipmem element (4 bytes)
+ i = lpmem-1
+ goto 10
+5 i = i+1
+ if (stale(i).eq.x) goto 20
+10 if (i+1.lt.lpml) goto 5
+ if (lpml+1.gt.lpmf) goto 300
+ i = lpml
+ lpml=lpml+1
+ stale(i) = x
+20 embede = i
+#else
+C --- LENGTH OF REALS ON SIEMENS IS 2
+ y = x
+ i = lpmem-2
+ goto 10
+5 i = i + 2
+ if (ipmem(i) .eq. m(1) .and. ipmem(i+1) .eq. m(2)) go to 20
+10 if (i+2 .lt. lpml) go to 5
+ if (lpml+2 .gt. lpmf) go to 300
+ i = lpml
+ lpml = lpml + 2
+ ipmem(i ) = m(1)
+ ipmem(i+1) = m(2)
+20 embede = (i+1) / 2
+#endif
+ return
+
+300 CALL ERROR(199)
+ RETURN
+ END
+
+
+ SUBROUTINE TINSER
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, JK1, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT,JK2,NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEXT, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+ REAL FRACT,NU
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEKST
+ LOGICAL ERRFLG
+ logical btest
+ character int2char
+
+ integer zero(2)
+ character stringbuffer(2)
+ integer istringbuffer(1)
+ equivalence (stringbuffer(1),istringbuffer(1))
+cvax
+ character zeroc(8)
+ equivalence (zero(1), zeroc(1))
+c
+ data zero /0, 0/
+cbc
+ ADRES=0
+ IF (ERRFLG) RETURN
+ IF (COM(2).EQ.0) RETURN
+ ADRES=TEXT(1)
+ LENGTH=2*MM-2
+ IF (COM(MM).LT.256) LENGTH=LENGTH-1
+c write string length (in bytes)
+ call ffwrite_ints(15, length, 1)
+c write string itself without any padding
+ l = length / 2
+cdsw - poprawka na wszelki wypadek
+ if (l.eq.0) goto 101
+c
+ do 100 i = 1, l
+ stringbuffer(1)=int2char(iand(com(1+i),X'FF'))
+ stringbuffer(2)=int2char(ishft(com(1+i),-8))
+100 call ffwrite(15,istringbuffer(1),2)
+101 continue
+ if (mod(length, 2) .ne. 1) goto 102
+ stringbuffer(1)=int2char(iand(com(2+l),X'FF'))
+ call ffwrite(15, istringbuffer(1), 1)
+102 continue
+
+c compute the number of trailing zero bytes
+#if ( WSIZE == 4 )
+ wrdsiz = 4
+#else
+ wrdsiz=2
+ if (btest(c0m(2), 12)) wrdsiz=4
+#endif
+
+ fill=wrdsiz-mod(length, wrdsiz)
+c and write them
+ call ffwrite(15, zero, fill)
+c compute next string address
+ text(1) = text(1) + 1 + (length+fill)/wrdsiz
+ RETURN
+ END
+
+ INTEGER FUNCTION KEY ( ADR )
+
+C
+C COMPUTES KEY OF THE ENCOUNTERED WORD. IT-S ADDRESS IS PASSED THRU
+C ADR.
+C
+C STRUCTURE OF KEY TABLE:
+C
+C KEYS(2*N) - ADDRESS OF A KEYWORD
+C KEYS(2*N-1) - KEY OF THIS WORD
+C
+C NOTE: FOR THE WORDS THAT DO NOT OCCUR IN THE DICTIONARY
+C THE FUNCTION RETURNS IDENTIFIER KEYS
+C
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ C0M(146),COM(132),XX(8037),KEYS(200),RESZTA(4677)
+C --- SPECIAL CHECK IS MADE HERE FOR THE ENTRIES WHICH ARE MISSING
+C --- IN THE HASH TABLE AND IN 'KEYS'
+C
+C --- READLN
+ IF (ADR.NE.1833) GO TO 9999
+ KEY = 256
+ RETURN
+C --- END OF CHECK FOR MISSING KEYS
+c get
+9999 if(adr.ne.59) go to 9998
+ key = 249
+ return
+c put
+9998 if(adr.ne.1243) go to 9997
+ key = 248
+ return
+c file
+9997 if(adr.ne.2339) go to 9996
+ key = 518
+ return
+c open
+9996 if(adr.ne.2347) go to 9995
+ key = 240
+ return
+c eof
+9995 if(adr.ne. 1841) go to 9994
+ key = 480
+ return
+c eoln
+9994 if(adr.ne.2579) go to 9993
+ key = 481
+ return
+c text - key jak dla string
+9993 if(adr.ne.2249) go to 9992
+ key = 517
+ return
+c direct - klasa 64/7 - jak dla typow pierwotnych
+9992 if (adr .ne. 2097) goto 8888
+ key = 519
+ return
+c putrec - klasa 34/0
+8888 if (adr .ne. 2075) goto 8889
+ key = 272
+ return
+c getrec - klasa 34/1
+8889 if (adr .ne. 2081) go to 8890
+ key = 273
+ return
+cbc ----- added concurrent statements
+c enable - klasa 35/0
+8890 if (adr .ne. 2047) goto 8891
+ key = 280
+ return
+c disable - klasa 35/1
+8891 if (adr .ne. 2041) goto 8892
+ key = 281
+ return
+c accept - klasa 36/0
+8892 if (adr .ne. 2053) goto 8893
+ key = 288
+ return
+cbc ----------- end
+c break
+8893 if(adr.ne.1463) go to 9991
+ key = 264
+ return
+9991 CONTINUE
+ KEY=1*8
+ LEFT=1
+ RIGHT=COM(1)
+ IF (KEYS(2*LEFT)-ADR) 30,20,10
+10 RETURN
+20 POINT=LEFT
+ GOTO 200
+30 IF (KEYS(2*RIGHT)-ADR) 10,40,50
+40 POINT=RIGHT
+ GOTO 200
+50 POINT=(LEFT+RIGHT)/2
+ IF (KEYS(2*POINT)-ADR) 100,200,300
+100 IF (LEFT.EQ.POINT) RETURN
+ LEFT=POINT
+ GOTO 50
+200 KEY=KEYS(2*POINT-1)
+ RETURN
+300 RIGHT=POINT
+ GOTO 50
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ subroutine spgrec(action)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
+ X APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
+ X CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
+ X RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
+ X FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
+ LOGICAL LSTWILL,FLREADY,TEST
+C
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ IOP(4),
+ X P,
+ X TLDIM, TLBAS, IDL, OBJL,
+ X TRDIM, TRBAS, IDR, OBJR,
+ X TRESLT,
+ X CONVL, CONVR,
+ X NRPAR,
+ X IX (261),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL, OWN, OBJECT,
+ X IPMEM(5000)
+ REAL STALER(100)
+ INTEGER STACK(5000)
+ EQUIVALENCE(STALER(1),IPMEM(1) )
+ EQUIVALENCE(STACK(1),IPMEM(1))
+ logical conv
+c
+c second parameter - buffer array
+ flargs = 2
+ call svalu2
+c check if one-dimensional array
+ if (stack(vlprev-3) .ne. 1) goto 30
+c check if primitive type
+ n = stack(vlprev-4)
+ if (n .ne. nrint .and. n .ne. nrre .and. n .ne. nrbool .and.
+ * n .ne. nrchr) goto 40
+ call quadr4(145, svats(vlprev), action, 0)
+c third parameter - byte count
+c duplicate stack top
+200 conv = .FALSE.
+ elem = stack(valtop)
+ call spush(elem)
+ do 100 i=1, stckap(elem)
+ stack(valtop-i+1)=stack(vlprev-i+1)
+100 continue
+ call svalue
+c check if not array
+ if (stack(valtop-3) .gt. 0) goto 20
+c check if integer
+ if (stack(valtop-4) .eq. nrint) goto 300
+c not integer, check if real
+ if (stack(valtop-4) .ne. nrre) goto 20
+c real, convert to integer
+ conv = .TRUE.
+ call svint(valtop)
+300 continue
+ call quadr4(145, svats(valtop), action, 1)
+ call spop
+c check if variable or array element
+ n = stack(valtop)
+ if (n .ne. 3 .and. n .ne. 4) goto 10
+ ats = tstemp(1)
+c generate LCALLPROCSTAND
+ call quadr2(132, action)
+c read output parameter
+ call quadr4(23, ats, action, 1)
+ if ( .not. conv) go to 400
+c convert to real
+ ats1 = tstemp(2)
+ call quadr3(59, ats1, ats)
+ ats = ats1
+400 continue
+ call sstore(valtop, ats)
+ call spop
+ return
+c error recovery
+10 call serror(420)
+ call spop
+ return
+20 call serror(478)
+ call spop
+ call spop
+ return
+30 call serror(416)
+ goto 200
+40 call serror(478)
+ goto 200
+ end
+
--- /dev/null
+ SUBROUTINE MSTAT
+C----------------DRUKOWANIE STATYSTYK KOMPILATORA
+C
+C BEZ OPISU W DOKUMENTACJI (CZESC ML2)
+C WERSJA Z DNIA: 19.01.82
+C DLUGOSC KODU: 751
+C...........................................................................
+C
+ IMPLICIT INTEGER (A-Z)
+ REAL USED, TOTAL
+C
+ COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
+ X COM(272),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X XFIL(17),
+ X IPMEM(5000)
+ COMMON /LYST/ PAGESZ, PAGENR, LINPG,
+ X LN1, LGTH1, BUFLN1(30),
+ X LN2, LGTH2, BUFLN2(30),
+ X LUN
+ integer*4 bufln1, bufln2
+C
+ COMMON /MSTA/ MLFREE, WNFREE, WNSTK, AL1BLK, AL1STK,
+ X AL2BLK, AL2SYM, AL2OTH, WNBLK, TLP, TLM,
+ X WNSUS, TOTMEM
+C
+ IF (IOP(1) .EQ. 9) RETURN
+C --POWROT GDYZ WYABORTOWANY ZOSTAL PARSER
+ CALL PGINIT
+
+ call ffputspaces(lun,22)
+ call ffputcs(lun,'- STATISTICS')
+ call ffputnl(lun)
+ call ffputspaces(lun,24)
+ call ffputcs(lun,'STORAGE')
+ call ffputi (lun,TOTMEM,6)
+ call ffputcs(lun,'K WORDS')
+ call ffputnl(lun)
+ call ffputcs(lun,'PARSER')
+ call ffputnl(lun)
+
+ IUS = TLM-TLP
+ TOTAL = IUS
+ IUS = IUS-WNFREE
+ USED = IUS
+ TOTAL = USED/TOTAL
+ TOTAL = TOTAL*100.0
+ IUS = TOTAL
+
+ call ffputspaces(lun,30)
+ call ffputcs(lun,'DECL. PART')
+ call ffputi (lun,WNFREE,6)
+ call ffputcs(lun,'WORDS LEFT')
+ call ffputi (lun,IUS,6)
+ call ffputcs(lun,'% USED')
+ call ffputnl(lun)
+
+ USED = WNSUS
+ IUS = TLP-3738
+ TOTAL = IUS
+ TOTAL = USED/TOTAL
+ TOTAL = TOTAL*100.0
+ IUS = TOTAL
+
+ call ffputspaces(lun,30)
+ call ffputcs(lun,'STACK')
+ call ffputspaces(lun,5)
+ call ffputi (lun,WNSTK,6)
+ call ffputcs(lun,' WORDS USED')
+ call ffputi (lun,IUS,6)
+ call ffputcs(lun,'% USED')
+ call ffputnl(lun)
+
+ WNBLK=WNBLK-12
+
+ call ffputspaces(lun,37)
+ call ffputi (lun,WNBLK,6)
+ call ffputcs(lun,'+12 BLOCK(S) WRITTEN')
+ call ffputnl(lun)
+
+ call ffputspaces(lun,24)
+ call ffputcs(lun,'SEMANTIC ANALISIS')
+ call ffputnl(lun)
+
+ TOTAL = TLP
+ IUS = TLP-MLFREE
+ USED = IUS
+ TOTAL = USED/TOTAL
+ TOTAL = TOTAL*100.0
+ IUS = TOTAL
+
+ call ffputspaces(lun,30)
+ call ffputcs(lun,'DECL. PART')
+ call ffputi (lun,MLFREE,6)
+ call ffputcs(lun,' WORDS LEFT')
+ call ffputi (lun,IUS,6)
+ call ffputcs(lun,'% USED')
+ call ffputnl(lun)
+
+ IF ((IOP(1) .GE. 10) .AND. (IOP(1) .LE. 12)) RETURN
+
+ call ffputspaces(lun,30)
+ call ffputcs(lun,'STACK')
+ call ffputspaces(lun,22)
+ call ffputi (lun,AL1STK,6)
+ call ffputcs(lun,'% USED')
+ call ffputnl(lun)
+
+ AL1BLK = AL1BLK+1
+
+ call ffputspaces(lun,40)
+ call ffputi (lun,AL1BLK,6)
+ call ffputcs(lun,' BLOCK(S) WRITTEN')
+ call ffputnl(lun)
+
+ RETURN
+ END
--- /dev/null
+ /* Loglan82 Compiler&Interpreter
+ Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+
+=======================================================================
+*/
+
+#include <stdio.h>
+
+#if WSIZE==4
+ typedef long word;
+#elif WSIZE==2
+ typedef short word;
+#else
+ Define WSIZE to 2 or 4 !
+#endif
+
+
+extern FILE *file_arr[];
+
+
+#define sunit FILE *f=stdout; if((int)(*unit)!=0L) f=file_arr[*unit];
+
+
+void ffputnl_(unit) word *unit;{
+ sunit
+ fprintf(f,"\n");
+}
+void ffputff_(unit) word *unit;{
+ sunit
+ fprintf(f,"\f");
+}
+void ffputspaces_(unit,count) word *unit,*count;{
+ sunit
+ fprintf(f,"%*s",(int)(*count),"");
+}
+void ffputi_(unit,i,count) word *unit,*i,*count;{
+ sunit
+ fprintf(f,"%*d",(int)(*count),(int)(*i));
+}
+void ffputcs_(unit,s,count) word *unit; long count; char *s;{
+ sunit
+ fprintf(f,"%*.*s",(int)count,(int)count,s);
+}
+void ffputs_(unit,s,count,one) word *unit,*count; char *s; long one;{
+ sunit
+ fprintf(f,"%*.*s",(int)(*count),(int)(*count),s);
+}
+void ffgets_(unit,s,count,one) word *unit,*count; char *s; long one;{
+ FILE *f=stdin; if((int)(*unit)!=0) f=file_arr[*unit];
+ fgets(s,(int)(*count),f);
+}
+void ffexit_(){ exit(0); }
+
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+C............. /STOS/ .....
+ IMPLICIT INTEGER (A-Z)
+ COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
+ X APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
+ X CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
+ X RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
+ X FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
+ LOGICAL LSTWILL,FLREADY,TEST
+
--- /dev/null
+stdio.o memfil.o al11.o al12.o al13.o debug.o dsw.o hash.o ifun.o it0.o it1.o resume.o scan.o spgrec.o wan1.o wan2.o wan3.o ml2.o ml3.o main.o
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+
+ SUBROUTINE WAN
+ IMPLICIT INTEGER (A-Z)
+ LOGICAL INSYS, OWN
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(5000)
+C
+C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
+C LMEM - (=32000) ROZMIAR CALEJ PAMIECI GLOWNEJ
+C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
+C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
+C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
+C
+C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
+C NACZONEGO NA PROTOTYPY SYSTEMOWE
+C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
+C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
+C
+C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
+C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
+C NRRE - REAL
+C NRBOOL - BOOLEAN
+C NRCHR - CHARACTER
+C NRCOR - COROUTINE
+C NRPROC - PROCESS
+C NRTEXT - STRING (TEXT)
+C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
+C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
+C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
+C REFERENCYJNY)
+C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
+C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
+C
+C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
+C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
+C MOWEJ
+C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
+C BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
+C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
+C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
+C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
+C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
+C
+
+cdeb ----------- added ----------------------
+c new common blockfor the debugger
+ common /debug/ deb,breakt(500),brnr,maxbr
+ logical deb
+c deb = true - compilation with the debugger
+c breakt - array of static break points
+c brnr - index in breakt
+c maxbr - maximal number of static break points
+cdeb ----------------------------------------
+
+ COMMON /MJLMSG/IERC,MSG
+
+ common /option/opt
+ integer*4 msg
+
+cdsw DATA IDENT /4HWAN /
+
+cdsw MSG = IDENT
+ msg = 'wan '
+ IERC = 0
+ CALL DATA1
+cdeb
+ if(deb) call inbr
+cdeb
+ CALL E0
+ opt = com(2)
+ CALL END
+cdeb
+ if(deb) call endbr
+cdeb
+ CALL MESS
+ CALL IT1
+ END
+
+ SUBROUTINE DATA1
+ IMPLICIT INTEGER (A-Z)
+ character jfname(72)
+ common /jf/jfname(72),jf
+ integer*2 bigbuf
+ common /combuf/ ind, length, bigbuf(16000)
+C
+C OPENS FILES
+C
+ LOGICAL ERRFLG
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEXT
+ COMMON /LISTING/ OUTSTR(265)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ S HASH(8000), M, NAME(10), NLAST, NL,
+ T KEYS(200),
+ U TRANS1(13,13), TRANS2(13,13), B0, B(70),
+ V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
+ W AUX, K1, SY, SY1, NU, EXP,
+ X SIGN, INTPART, FRAC, OKEY, FRACT, NB,
+ Y TL, BYTE, TEXT(20),
+ Z TOP, IN, NEKST, STACK(500)
+
+ common /BLANK/
+ * RESZTA(3652)
+
+cdsw error !!!!
+ real fract, nu
+c
+ logical btest
+ character int2char
+
+cdeb ----------- added ----------------------
+c new common blockfor the debugger
+ common /debug/ deb,breakt(500),brnr,maxbr
+ logical deb
+c deb = true - compilation with the debugger
+c breakt - array of static break points
+c brnr - index in breakt
+c maxbr - maximal number of static break points
+
+cdeb ----------------------------------------
+
+
+ DIMENSION W(63)
+ EQUIVALENCE (W(1),WAND)
+
+cdsw kod spacji ascii
+ data data1hex /x'2020'/
+
+
+cdeb
+c nadanie wartosci zmiennej deb - czy zapalona opcja S
+ deb = .false.
+ if(btest(c0m(2),13)) deb = .true.
+cdeb
+
+ DO 10 I=1,63
+10 W(I)=I
+ UNICAL = 3
+C ---
+c unit 16 - roboczy listing (sequential )
+ call ffcrtmp(16)
+C --- WRITE LISTING OPTION FLAG
+ call ffwrhex(16, c0m(2))
+C ---
+ ERRFLG = .FALSE.
+
+cdsw *********** new file **************
+c unit 18 - roboczy,sekwencyjny do kodu posredniego
+ call ffcrtmp(18)
+
+c ------ unit 14 (buf) - kod posredni (direct)
+ CALL OPENF(BUF,14)
+ POSIT=1
+cdsw RECNR=12
+cdsw NEXT=13
+ recnr = 32
+ next = 33
+ call seek(buf,recnr)
+C DATA BUFOR,LN,LP,MAX /85*4Z2020,0,81,81/
+ LN=0
+ LP=81
+ MAX=81
+
+ do 9997 jf=1,70
+ if (jfname(jf).eq.'.') go to 9998
+ if (jfname(jf).eq.' ') goto 9996
+9997 continue
+9996 if(jf+4.gt.70) goto 9991
+ jfname(jf) = '.'
+ jfname(jf+1) = 'l'
+ jfname(jf+2) = 'o'
+ jfname(jf+3) = 'g'
+9998 continue
+ jfname(jf+4) = int2char(0)
+9991 jfname(70) = int2char(0)
+c unit 17 - input (sequential)
+ call ffopen(17,jfname(1))
+ length = 0
+ ind = 1
+
+ jfname(jf+1)='l'
+ jfname(jf+2)='c'
+ jfname(jf+3)='d'
+ jfname(jf+4)=int2char(0)
+ call ffcreat(15, jfname(1))
+
+ STATUS=0
+ DO 1 I=1,85
+1 BUFOR(I)=DATA1HEX
+ ON=49
+ BEGIN=1
+ IEND=0
+800 CALL READIN
+ I=1
+900 if(ord(bufor(i)).ne.ord(ichar(' '))) goto 1000
+ I=I+1
+ IF (I.GT.MAX) GOTO 800
+ GOTO 900
+1000 IF (BUFOR(I ).NE.ICHAR('P').AND.BUFOR(I).NE.ICHAR('p'))
+ X GOTO 2500
+ IF (BUFOR(I+1).NE.ICHAR('R').AND.BUFOR(I+1).NE.ICHAR('r'))
+ X GOTO 2500
+ IF (BUFOR(I+2).NE.ICHAR('O').AND.BUFOR(I+2).NE.ICHAR('o'))
+ X GOTO 2500
+ IF (BUFOR(I+3).NE.ICHAR('G').AND.BUFOR(I+3).NE.ICHAR('g'))
+ X GOTO 2500
+ IF (BUFOR(I+4).NE.ICHAR('R').AND.BUFOR(I+4).NE.ICHAR('r'))
+ X GOTO 2500
+ IF (BUFOR(I+5).NE.ICHAR('A').AND.BUFOR(I+5).NE.ICHAR('a'))
+ X GOTO 2500
+ IF (BUFOR(I+6).NE.ICHAR('M').AND.BUFOR(I+6).NE.ICHAR('m'))
+ X GOTO 2500
+ IF (BUFOR(I+7).EQ.1) GOTO 1100
+ if(ord(bufor(i+7)) .ne. ord(ichar(' '))) goto 2500
+1100 I=I+8
+ IF (I.LT.MAX) GOTO 1200
+1150 CALL READIN
+ I=1
+1200 if(ord(bufor(i)).ne.ord(ichar(' '))) goto 1300
+ I=I+1
+ IF (I.GT.MAX) GOTO 1150
+ GOTO 1200
+1300 BEGIN=I
+ IEND=I-1
+1350 IF ((ORD(BUFOR(I)).LT.10).OR.(ORD(BUFOR(I)).GT.35)) GOTO 1500
+1400 I=I+1
+ IF (BUFOR(I).GE.ICHAR('0').AND.BUFOR(I).LE.ICHAR('9')) GOTO 1400
+ GOTO 1350
+1500 IEND=I-1
+C
+C INITIALIZE STRINGS OUTPUT TO LFILE WITH EMPTY STRING
+C
+
+2500 continue
+
+C write length of empty string
+ call ffwrite_ints(15, 0, 1)
+C write empty string itself
+ call ffwrite_ints(15, 0, 1)
+
+#if ! ( WSIZE == 4 )
+C if H+
+ if (btest(c0m(2), 12)) call ffwrite_ints(15, 0, 1)
+#endif
+cbc
+C
+C INITIATE THE TABLE OF REAL CONSTANTS
+C THE TWO INITIAL CONSTANTS, WHICH ALWAYS RESIDE IN THE TABLE ARE
+C 0.0 AND 1.0
+C
+ EXP=EMBEDE(0.0)
+ EXP=EMBEDE(1.0)
+ LP=IEND+1
+ I=0
+ IF (IEND.LT.BEGIN) GOTO 3500
+ S=SBLOCK
+ GOTO 4000
+3500 IF (S.EQ.70) CALL ERROR(191)
+3550 CALL SCAN
+3600 IF (S.EQ.SBLOCK) GOTO 4000
+ I=1
+ IF (S.EQ.SBEGIN) GOTO 4000
+ IF (S.EQ.SUNIT) GOTO 4000
+ IF (S.EQ.SVAR) GOTO 4000
+ IF (S.EQ.SCONS) GOTO 4000
+ IF (S.EQ.SEND) GOTO 4000
+ IF (S.EQ.SPRCD) GOTO 4000
+ IF (S.EQ.SFUNCT) GOTO 4000
+ IF (S.EQ.SCLASS) GOTO 4000
+ IF (S.EQ.SIDENT) GOTO 3550
+ IF (S.EQ.STAKEN) GOTO 4000
+ IF (S.EQ.SCLOSE) GOTO 4000
+ IF (S.LT.25) GOTO 4000
+ IF (S.NE.70) GOTO 3550
+ CALL ERROR(136)
+4000 IF (I.EQ.1) CALL ERROR(137)
+ RETURN
+ END
+
+cdeb new procedures
+
+ subroutine inbr
+ implicit integer(a-z)
+
+cdeb ----------- added ----------------------
+c new common blockfor the debugger
+ common /debug/ deb,breakt(500),brnr,maxbr
+ logical deb
+c deb = true - compilation with the debugger
+c breakt - array of static break points
+c brnr - index in breakt
+c maxbr - maximal number of static break points
+cdeb ----------------------------------------
+
+ character jfname
+ character int2char
+ common /jf/ jfname(72), jf
+
+ brnr = 0
+ maxbr = 500
+ do 10 i=1,maxbr
+ 10 breakt(i) = 0
+c file na hash, breakt, keys
+ jfname(jf+1) = 'd'
+ jfname(jf+2) = 'e'
+ jfname(jf+3) = 'b'
+ jfname(jf+4) = int2char(0)
+ call ffcreat(21, jfname(1))
+ return
+ end
+
+ subroutine addbr(l)
+ implicit integer(a-z)
+
+cdeb ----------- added ----------------------
+c new common blockfor the debugger
+ common /debug/ deb,breakt(500),brnr,maxbr
+ logical deb
+c deb = true - compilation with the debugger
+c breakt - array of static break points
+c brnr - index in breakt
+c maxbr - maximal number of static break points
+cdeb ----------------------------------------
+
+c wstawia do breakt linie o numerze l
+
+ if(.not. deb) return
+ do 100 i=1,brnr
+c czy juz jest
+ if(l.eq.breakt(i)) return
+100 continue
+c nowy punkt lamiacy
+ if(brnr.ge.maxbr) return
+c nadmiarowe punkty lamiace sa ignorowane
+ brnr = brnr+1
+ breakt(brnr) = l
+ return
+ end
+
+ subroutine endbr
+ implicit integer(a-z)
+ common /BLANK/ com(302),
+ x hash(8000), dow(13), keys(200),
+ x rest(2000)
+
+cdeb ----------- added ----------------------
+c new common blockfor the debugger
+ common /debug/ deb,breakt(500),brnr,maxbr
+ logical deb
+c deb = true - compilation with the debugger
+c breakt - array of static break points
+c brnr - index in breakt
+c maxbr - maximal number of static break points
+cdeb ----------------------------------------
+
+c wypisuje na plik 21 tablice hash
+ call ffwrite_ints(21, hash, 8000)
+cps call ffwrite_ints(21, keys, 200)
+cps call ffwrite_ints(21, brnr, 1)
+cps call ffwrite_ints(21, breakt, brnr)
+ return
+ end
+
+cdeb
+
+
+ SUBROUTINE PEND
+ IMPLICIT INTEGER (A-Z)
+ logical errflg
+ integer endmsg(20)
+ character*40 endms1
+ equivalence (endmsg(1), endms1)
+ COMMON /LISTING/ OUTSTR(265)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /BLANK/ C0M(4)
+ LOGICAL BTEST
+ character int2char
+ data endms1 /'end of parsing -------------------------'/
+ LN=LN+1
+ call ffwrhex(16, ln)
+c
+ IF (BTEST(C0M(2),15)) GOTO 1
+ call ffwrite_char(16, '0')
+c
+ GOTO 2
+1 call ffwrite_char(16, '1')
+c
+2 CONTINUE
+ call ffwrite(16, endmsg(1), 40)
+c end of line - write CR/LF
+ call ffwrite_char(16, int2char(13))
+ call ffwrite_char(16, int2char(10))
+3 IF (BUFOR(1).EQ.2) RETURN
+ CALL READIN
+ GOTO 3
+ END
+
+
+
+
+ SUBROUTINE E0
+C ORGANIZATION OF THE STACK:
+C STACK(TOP) - STACK TOP FOR THE INVOKING MODULE
+C STACK(TOP+1) - NUMBER OF THE INVOKING MODULEY
+C STACK(TOP+2) - NUMBER OF THE RETURN POINT TO THE INVOKING MODULE
+C THE LOCAL VARIABLES, IF ANY ARE USED IN THE MODULE, ARE ALLOCATED ON THE
+C STACK STARTING FROM TOP+3 UP.
+C AN INVOKING MODULE HAS TO APPROPRIATELY INCREMENT THE TOP OF THE STACK
+C RESPECTING ITS LOCAL VARIABLES, THEN STORE ITS NUMBER AND RETURN POINT
+C ON THE STACK AND TRANSFER THE CONTROL TO THE SUPERVISING PROGRAM (RETURN).
+C AFTER RETURN FROM THE CALLED PROGRAM THE STACK TOP IS APPROPRIATELY
+C RESET BY THE SUPERVISING PROGRAM.
+C THE PATTERN OF TRANSFERRING CONTROL:
+C NEXT= N - CONTROL TO BE PASSED TO THE MODULE NUMBER N;
+C NEXT= 0 - RETURN TO THE CALLER.
+C UPON ENTRY TO A SUBPROGRAM
+C PARAMETER - KEEPS THE NUMBER OF PLACE FROM WHICH THE COMPUTATIONS HAVE TO
+C BE CONTINUED
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+ STACK(1)=0
+ STACK(2)=0
+ STACK(3)=0
+ TOP=1
+C NOTE: THE FIRST CALL OF E11, I.E. FOR THE MAIN BLOCK, IS NON-STANDARD.
+C IN IS ASSIGNED VALUE 5 INSTEAD OF STANDARD (1). THIS FACILITATES
+C THE TEXT ANALYSIS OF A PROGRAM WHICH DOESN-T START WITH 'BLOCK'.
+ IN = 5
+ NEXT=11
+ IF (S.EQ.70) GOTO 10025
+ IF (S.NE.SBLOCK) CALL ERROR(122)
+ CALL OUTPUT(WBLOCK,ISFIN)
+ STACK(TOP+4)=0
+ GOTO 110
+C E11 IS CALLED WITH THE PARAMETER (TOP+4)=0, WHICH MEANS THAT NO PREFIX
+C IS SPECIFIED. E11 ANALYSES THE ENTIRE SYNTACTICAL UNIT.
+10 CALL E1
+ GOTO 1000
+20 CALL E2
+ GOTO 1000
+30 CALL E3
+ GOTO 1000
+40 CALL E4
+ GOTO 1000
+50 CALL E5
+ GOTO 1000
+60 CALL E6
+ GOTO 1000
+70 CALL E7
+ GOTO 1000
+80 CALL E8
+ GOTO 1000
+90 CALL E9
+ GOTO 1000
+100 CALL E10
+ GOTO 1000
+110 CALL E11
+ GOTO 1000
+120 CALL E12
+ GOTO 1000
+130 CALL E13
+1000 IN = 1
+ IF (NEXT.EQ.0) GOTO 1002
+1001 CONTINUE
+ GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130),NEXT
+1002 IN = STACK(TOP+2)
+ NEXT = STACK(TOP+1)
+ TOP = STACK(TOP)
+ IF (TOP.GT.0) GOTO 1001
+10025 CALL PEND
+ RETURN
+ END
+
+ SUBROUTINE E1
+C E1 - RECOGNIZES BOOLEAN EXPRESSION
+C LOCAL VARIABLES:
+C STACK(TOP+3) - NUMBER OF RECOGNIZED AND-S
+C STACK(TOP+4) - NUMBER OF RECOGNIZED OR-S
+C STACK(TOP+5) - RELATION CODE
+C STACK(TOP+6) - 1 IFF 'NOT' HAS BEEN ENCOUNTERED, 0 IN THE OPPOSITE CASE
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735)
+
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+cdsw INTEGER WEOF0,WEOF1,WEOLN0,WEOLN1
+cdsw DATA WEOF0,WEOF1,WEOLN0,WEOLN1/79,80,85,86/
+ DATA SEOFSI/60/
+ GOTO (10,20,30,40),IN
+10 STACK(TOP+4)=0
+411 STACK(TOP+4)=STACK(TOP+4)+1
+ IF (STACK(TOP+4).GT.1) CALL SCAN
+ STACK(TOP+3)=0
+420 STACK(TOP+3)=STACK(TOP+3)+1
+ IF (STACK(TOP+3).GT.1) CALL SCAN
+ STACK(TOP+6)=0
+ IF (S.NE.SNOT) GOTO 400
+ STACK(TOP+6)=1
+ CALL SCAN
+400 IF (S.NE.STRUE) GOTO 401
+C A BOOLEAN CONSTANT HAS BEEN ENCOUNTERED. ITS WRITING OUT IS SPLIT
+C INTO TWO STAGES BECAUSE THE VALUE TRUE (-1) CANNOT STAND FOR THE
+C SECOND PARAMETER OF THE WRITING PROCEDURE (OUTPUT).
+ CALL OUTPUT(WCNSTB,-1)
+ CALL OUTPUT(1-ADRES,-1)
+ CALL SCAN
+ GOTO 300
+401 IF (S.NE.SEOFSI) GOTO 402
+ IF (ADRES.NE.1) ADRES=7
+C 79+7-1=85
+ STACK(TOP+5)=SEOFSI+18+ADRES
+ CALL SCAN
+ IF (S.NE.SLEFT) GOTO 444
+ STACK(TOP+5)=STACK(TOP+5)+1
+ CALL SCAN
+ CALL SLAD(4,1,4)
+ NEXT=3
+ RETURN
+C CALL OBJECTEXPRESSION /E3/
+40 IF (S.EQ.SRIGHT) GOTO 430
+ CALL ERROR(107)
+ GOTO 444
+430 CALL SCAN
+444 CALL OUTPUT(STACK(TOP+5),-1)
+ GOTO 300
+C
+402 CALL SLAD(4,1,2)
+ NEXT=2
+C CALL E2 - ARITHMETIC EXPRESSION
+ RETURN
+20 IF (S.NE.SRELAT) GOTO 300
+ IF (ADRES.GT.2) GOTO 22
+C RECOGNIZED RELATION IS OR IN
+ STACK(TOP+5)=ADRES
+ CALL SCAN
+ IF (S.EQ.SCOROUT) GOTO 205
+ IF (S.EQ.SIDENT) GOTO 21
+ CALL ERROR(109)
+ ADRES=0
+ GOTO 21
+205 CALL OUTPUT(WIDENT,K)
+C FOR "PROCESS", "COROUTINE" THE HASH ADDRESS IS PASSED BY K
+ GOTO 215
+21 CALL OUTPUT(WIDENT,ADRES)
+215 CALL SCAN
+ CALL OUTPUT(WRELAT,STACK(TOP+5))
+ GOTO 300
+22 STACK(TOP+5)=ADRES
+ CALL SCAN
+ CALL SLAD(4,1,3)
+ NEXT=2
+C NEXT CALL FOR E2 - ARITHMETIC EXPRESSION
+ RETURN
+30 CALL OUTPUT(WRELAT,STACK(TOP+5))
+300 IF (STACK(TOP+6).EQ.1) CALL OUTPUT(WNOT,-1)
+ IF (STACK(TOP+3).GT.1) CALL OUTPUT(WAND,-1)
+ IF (S.EQ.SAND) GOTO 420
+ IF (STACK(TOP+4).GT.1) CALL OUTPUT(WOR,-1)
+ IF (S.EQ.SOR) GOTO 411
+ NEXT=0
+ RETURN
+ END
+ SUBROUTINE E2
+C
+C E2 - RECOGNIZES ARITHMETIC EXPRESSION
+C LOKAL VARIABLES:
+C STACK(TOP+3) - MULTIPLICATIVE (HIGHER PRIORITY) OPERATOR
+C STACK(TOP+4) - ADDITIVE (LOWER PRIORITY) OPERATOR
+C STACK(TOP+5) - CONTAINS 1 IF SIGN CHANGE IS REQUIRED, 0 IF NOT,
+C STACK(TOP+6) - CONTAINS 1 IF "ABS" HAS OCCURRED,
+C STACK(TOP+7) - KEEPS LOWER/UPPER OPERATOR KIND,
+C STACK(TOP+8) - INCLUDES 1 IF THE VARIABLE AFTER LOWER/UPPER IS IN
+C PARANTHESES.
+C NOTE: THE LAST TWO FIELDS ARE ONLY USED IF THE PERTINET
+C OPERATOR HAS BEEN ENCOUNTERED. THUS THIS PROCEDURE MAY
+C BE INVOKED WITH DIFFERENT SIZES OF THE AREA FOR LOCAL
+C VARIABLES, DEPENDING ON THE CONTENTS.
+C
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+ EQUIVALENCE (WEOF,WSIGN)
+ DATA SLOWUP,WLOWER /79,64/
+ DATA SIGN/58/
+C**********************************************************************
+C****** SLOWUP, WLOWER, WUPPER SHOUD BE PUT INTO BLANK
+C****** COMMON AT THE NEAREST OPPORTUNITY.
+C****** *********** 13.01.1982 *************
+C**********************************************************************
+ GOTO (10,20,30,40,50),IN
+C
+C INITIALIZE LOCAL VARIABLES
+C
+10 STACK(TOP+4)=0
+ STACK(TOP+5)=0
+ STACK(TOP+6)=0
+C
+C CHECK FOR MINUS (-)
+C
+ IF (S.NE.STAR) GOTO 100
+ IF (ADRES.GT.4) GOTO 80
+ GOTO (100,100,70,75),ADRES
+C
+C THERE WAS MINUS
+C
+75 STACK(TOP+5)=1
+ GOTO 90
+C
+C PLUS (+) ENCOUNTERED
+C
+70 CALL SCAN
+ GOTO 100
+C
+C THE EXPRESSION STARTS WITH * , / , DIV , MOD
+C
+80 CALL ERROR(126)
+90 CALL SCAN
+100 STACK(TOP+3)=0
+C
+C START OF ANALYSING A SUM COMPONENT
+C
+110 IF (STACK(TOP+4).NE.0) CALL SCAN
+C
+C START OF ANALYSING A MULTIPLICATIVE COMPONENT
+C
+120 IF (STACK(TOP+3).NE.0) CALL SCAN
+C
+C CHECK FOR ABS
+C
+ IF (S.NE.STAR) GOTO 122
+ IF (ADRES.NE.1) GOTO 122
+C
+C ABS ENCOUNTERED
+C
+ STACK(TOP+6)=1
+ CALL SCAN
+C
+C CHECK FOR A CONSTANT, IF AFFIRMATIVE THEN RECOGNIZE ITS TYPE
+C
+122 IF (S.NE.SCONST) GOTO 130
+ GOTO (210,210,125,127,123,128),K
+C
+C REAL CONSTANT
+C
+123 CALL OUTPUT(WCNSTR,ADRES)
+ CALL SCAN
+ GOTO 180
+C
+C INTEGER CONSTANT
+C
+125 CALL OUTPUT(WCNSTI,ADRES)
+ CALL SCAN
+ GOTO 180
+C
+C STRING CONSTANT
+C
+127 CALL OUTPUT(WCNST,ADRES)
+ GOTO 129
+C
+C CHARACTER CONSTANT
+C
+128 CALL OUTPUT(WCNSTC,ADRES)
+129 CALL SCAN
+C
+C CHECK AGAINST AN OCCURRENCE OF A STRING/CHAR CONSTANT WITHIN AN EXPRESSION
+C
+ IF (STACK(TOP+3)+STACK(TOP+4)+STACK(TOP+5)+STACK(TOP+6).NE.0)
+ X CALL ERROR(115)
+ GOTO 210
+C
+C CHECK IF THE MULTIPLICATIVE COMPONENT IS AN EXPRESSION
+C
+130 IF (S.NE.SLEFT) GOTO 160
+ CALL SCAN
+ CALL SLAD(4,2,2)
+ NEXT=1
+ RETURN
+C
+C CALL E1 - BOOLEAN EXPRESSION
+C AFTER RETURN CHECK IF THE EXPRESSION IS TERMINATED BY THEW RIGHT
+C PARANTHESIS
+C
+20 IF (S.EQ.SRIGHT) GOTO 140
+ CALL ERROR(101)
+ GOTO 180
+140 CALL SCAN
+ GOTO 180
+160 IF (S.EQ.SLOWUP) GOTO 170
+ IF (S.EQ.SIGN) GOTO 165
+ CALL SLAD(4,2,3)
+ NEXT=3
+C
+C CALL E3 - OBJECTEXPRESSION TO ANALYSE THE VARIABLE
+C RETURN TO LABEL 30 BELOW - JUMP OPTIMIZATION
+C
+ RETURN
+C
+C "SIGN" ENCOUNTERED, ARITHMETIC EXPRESSION SHOULD FOLOW.
+C
+165 CALL SCAN
+ CALL SLAD(5,2,5)
+ NEXT=1
+ RETURN
+C
+C CALL E1 TO ANALYSE THE EXPRESSION
+C
+50 CALL OUTPUT(WSIGN,-1)
+ GOTO 180
+C
+C LOWER/UPPER HAS BEEN ENCOUNTERED. WE HAVE TO REMEMBER WHICH ONE AND CALL
+C OBJECTEXPRESSION TO ANALYSE THE VARIABLE. THE LOCAL VARIABLE FIELD IS
+C INCREASED TO 5 VARIABLES.
+C
+170 STACK(TOP+7)=ADRES
+ CALL SCAN
+ STACK(TOP+8)=0
+ IF (S.NE.SLEFT) GOTO 172
+C THERE WAS A LEFT PARANTHESIS
+ STACK(TOP+8)=1
+ CALL SCAN
+172 CALL SLAD(6,2,4)
+ NEXT=3
+ RETURN
+C CALL E3 - OBJECT EXPRESSION, AFTER RETURN THE OPERATOR TYPE
+C (LOWER/UPPER) IS TO BE WRITTEN
+40 CALL OUTPUT(WLOWER+STACK(TOP+7)-1,-1)
+ IF (STACK(TOP+8).EQ.0) GOTO 30
+ IF (S.EQ.SRIGHT) GOTO 44
+C NO MATCHING RIGHT PARANTHESIS
+ CALL ERROR(101)
+ GOTO 30
+44 CALL SCAN
+30 CONTINUE
+180 IF (STACK(TOP+6).NE.1) GOTO 185
+C
+C ABS BEFORE THE MULTIPLICATIVE COMPONENT
+C
+ CALL OUTPUT(WOPERAT,1)
+ STACK(TOP+6)=0
+185 IF (STACK(TOP+5).NE.1) GOTO 190
+C
+C MINUS BEFORE THE MULTIPLICATIVE COMPONENT
+C
+ CALL OUTPUT(WOPERAT,2)
+ STACK(TOP+5)=0
+190 IF (STACK(TOP+3).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+3))
+ STACK(TOP+3)=0
+C
+C AND OF THE ANALYSIS OF THE COMPONENT, CHECK WHETHER MORE COMPONENTS ARE
+C EXPECTED, E.G. IF THERE OCCURRS * , / , DIV , MOD
+C
+ IF (S.NE.STAR) GOTO 200
+ IF (ADRES.LT.5) GOTO 200
+ STACK(TOP+3)=ADRES
+ GOTO 120
+C
+C END OF MULTIPLICATIVE SEQUENCE
+C
+200 IF (STACK(TOP+4).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+4))
+ STACK(TOP+4)=0
+C
+C END OF AN ADDITIVE COMPONENT, CHECK FOR MORE (+,-)
+C
+ IF (S.NE.STAR) GOTO 210
+ IF (ADRES.LT.3) GOTO 210
+ STACK(TOP+4)=ADRES
+ GOTO 110
+C
+C END OF ADDITIVE SEQUENCE
+C
+210 NEXT=0
+ RETURN
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ subroutine e3
+C E3 - RECOGNIZES OBJECTEXPRESSION
+C NO LOCAL VARIABLES
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ GOTO (10,20,30,40),IN
+10 IF (S.NE.SIDENT) GOTO 200
+ CALL SLAD(0,3,2)
+ STACK(TOP+4)=0
+C PARAMETER VALUE IS ASSIGNED: THERE IS NO "NEW"
+ NEXT=5
+C E5 - FUNCTION
+ RETURN
+C RETURN TO LABEL 20, RESULTING FROM JUMP OPTIMIZATION.
+200 IF (S.NE.STHIS) GOTO 250
+ CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 210
+ CALL ERROR(109)
+ GOTO 300
+210 CALL OUTPUT(WTHIS,ADRES)
+ CALL SCAN
+ GOTO 300
+250 IF (S.EQ.SNEW) GOTO 270
+ IF (S.NE.SNONE) GOTO 255
+ CALL OUTPUT(WCNSTN,-1)
+ CALL SCAN
+ GOTO 1000
+255 CALL ERROR(109)
+ CALL OUTPUT(WIDENT,0)
+ GOTO 300
+270 STACK(TOP+7)=ADRES
+ CALL SCAN
+ IF (S.NE.SIDENT) GOTO 280
+ CALL SLAD(0,3,3)
+ NEXT=5
+C E5 - FUNCTION
+ RETURN
+280 CALL ERROR(109)
+ CALL OUTPUT(WIDENT,0)
+20 CONTINUE
+30 CONTINUE
+40 CONTINUE
+300 IF (S.EQ.SDOT) GOTO 350
+ IF (S.NE.SQUA) GOTO 1000
+C QUA
+ CALL SCAN
+ IF (S.NE.SIDENT) GOTO 260
+ CALL OUTPUT(WQUA,ADRES)
+ CALL SCAN
+ IF (S.EQ.SDOT) GOTO 350
+ CALL ERROR(114)
+ GOTO 351
+260 CALL ERROR(109)
+ GOTO 250
+C DOT
+350 CALL SCAN
+351 STACK(TOP+7)=0
+ IF (S.NE.SNEW) GOTO 380
+ STACK(TOP+7)=ADRES
+ CALL SCAN
+380 IF (S.EQ.SIDENT) GOTO 390
+ CALL ERROR(109)
+ GOTO 250
+390 CALL OUTPUT(WDOT,-1)
+ CALL SLAD(0,3,4)
+C RETURN INTO SOME OTHER PLACE
+ NEXT=5
+ RETURN
+C E5 - FUNCTION
+1000 NEXT=0
+ RETURN
+ END
+
+ SUBROUTINE E4
+C E4 - RECOGNIZES EXPRESSION
+C STACK(TOP+3) - NUMBER OF ARRAYOF'S ENCOUNTERED
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ GOTO (10,20),IN
+10 STACK(TOP+3)=0
+ IF (S.NE.SARROF) GOTO 13
+11 STACK(TOP+3)=STACK(TOP+3)+1
+ CALL SCAN
+ IF (S.EQ.SARROF) GOTO 11
+13 IF (S.EQ.SCOROUT) GOTO 15
+ IF (S.EQ.SINT) GOTO 16
+ NEXT=1
+ IF (STACK(TOP+3).GT.0) NEXT=3
+ CALL SLAD(1,4,2)
+ RETURN
+C CALL E1 - BOOLEXPRESSION
+C OR E3 - OBJECTEXPRESSION
+15 CALL OUTPUT(WIDENT,K)
+C COROUTINE OR PROCESS ENCOUNTERED
+ GOTO 19
+16 CALL OUTPUT(WPRIM,ADRES)
+19 CALL SCAN
+20 IF (STACK(TOP+3).NE.0) CALL OUTPUT(WARRAY,STACK(TOP+3))
+ NEXT=0
+ RETURN
+ END
+
+ SUBROUTINE E5
+C E5 - FUNCTION
+C STACK(TOP+3) - COUNTS NUMBER OF EXTERNAL PARANTHESES PAIRS
+C STACK(TOP+4) - PARAMETR - 0 THERE WAS NO NEW/START
+C 1 NEW
+C 2 START
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ GOTO (10,20,30),IN
+10 STACK(TOP+3)=0
+ CALL OUTPUT(WIDENT,ADRES)
+ CALL SCAN
+ IF (STACK(TOP+4)-1) 15,13,12
+12 CALL OUTPUT(WSTART,-1)
+ GOTO 15
+13 CALL OUTPUT(WNEW,-1)
+15 IF (S.NE.SLEFT) GOTO 1000
+ IF (STACK(TOP+3).GE.2) GOTO 1000
+C ANALYSIS OF THE ACTUAL PARAMETER
+ CALL OUTPUT(WLEFT,-1)
+ CALL SCAN
+ CALL SLAD(2,5,2)
+ NEXT=4
+ RETURN
+C CALL E4 - EXPRESSION
+20 IF (S.NE.SCOMA) GOTO 28
+22 CALL SCAN
+ CALL OUTPUT(WCOMA,-1)
+ CALL SLAD(2,5,3)
+ NEXT=4
+ RETURN
+C NEXT CALL FOR E4
+30 IF (S.EQ.SCOMA) GOTO 22
+28 IF (S.NE.SRIGHT) CALL ERROR(107)
+ IF (S.EQ.SRIGHT) CALL SCAN
+ CALL OUTPUT(WRIGHT,-1)
+ STACK(TOP+3)=STACK(TOP+3)+1
+ GOTO 15
+1000 NEXT=0
+ RETURN
+ END
+
+ SUBROUTINE E6
+C RECOGNIZES THE SEQUENCE V1,V2,V3,. . . ,VN:= EXPR
+C OR V1,V2, . . . ,VN := COPY ( OBJECT EXPR. )
+C GENERATES WLSE V1 WLSE . . . WLSE EXPR /WCOPY/ WASSIGN
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ GOTO (10,20,30,40),IN
+10 CALL OUTPUT(WLSE,-1)
+ IF (S.NE.SCOMA) GOTO 120
+100 CALL SCAN
+ CALL SLAD(0,6,2)
+ NEXT=3
+C CALL OBJECTEXPRESSION
+ RETURN
+20 CALL OUTPUT(WLSE,-1)
+ IF (S.EQ.SCOMA) GOTO 100
+120 IF (S.NE.SBECOME) CALL ERROR(109)
+ CALL SCAN
+ IF (S.NE.SCOPY) GOTO 130
+ CALL SCAN
+ IF (S.NE.SLEFT) GOTO 110
+ CALL SCAN
+ GOTO 111
+110 CALL ERROR(106)
+111 CALL SLAD(0,6,3)
+ NEXT=3
+ RETURN
+C CALL OBJECTEXPRESSION /E3/
+30 IF (S.NE.SRIGHT) GOTO 112
+ CALL SCAN
+ GOTO 113
+112 CALL ERROR(107)
+113 CALL OUTPUT(WCOPY,WASSIGN)
+ NEXT=0
+ RETURN
+130 CALL SLAD(0,6,4)
+ NEXT=1
+C CALL BOOLEXPRESSION
+ RETURN
+40 CONTINUE
+ CALL OUTPUT(WASSIGN,-1)
+ NEXT=0
+ RETURN
+ END
+
+ SUBROUTINE E7
+ IMPLICIT INTEGER (A-Z)
+C
+C RECOGNIZES AN ARITHMETIC EXPRESSION COMPOSED OF CONSTANTS
+C
+C LOCAL VARIABLES:
+C STACK(TOP+3) - MULTIPLICATIVE OPERATOR,
+C STACK(TOP+4) - ADDITIVE OPERATOR,
+C STACK(TOP+5) - 1 = UNARY MINUS FLAG.
+C
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ GOTO (10,20),IN
+10 STACK(TOP+3)=0
+ STACK(TOP+4)=0
+ STACK(TOP+5)=0
+ IF (S.NE.STAR) GOTO 100
+ IF (ADRES.EQ.4) GOTO 82
+ IF (ADRES.EQ.3) GOTO 85
+C MOD, DIV, * ALBO /
+ CALL ERROR(126)
+C MINUS (-) OCCURRS BEFORE EXPRESSION
+82 STACK(TOP+5)=1
+C PLUS (+) BEFORE EXPRESSION - IGNORE IT
+85 CALL SCAN
+C MAIN LOOP
+100 IF (S.EQ.SLEFT) GOTO 120
+ IF (S.EQ.SIDENT) GOTO 110
+ IF (S.NE.SCONST) GOTO 1000
+C CONSTANT - TYPE STILL UNKNOWN
+ GOTO (1000,1000,101,102,103,102),K
+C INTEGER (K=3)
+101 CALL OUTPUT(WCNSTI,ADRES)
+ GOTO 179
+C TEXT (K=4) OR CHAR (K=6)
+102 CALL ERROR(115)
+ CALL OUTPUT(WCNSTI,0)
+ GOTO 179
+C REAL (K=5)
+103 CALL OUTPUT(WCNSTR,ADRES)
+ GOTO 179
+C IDENTIFIER ENCOUNTERED
+110 CALL OUTPUT(WIDENT,ADRES)
+ GOTO 179
+C LEFT PARANTHESIS ENCOUNTERED (RECURRENCE)
+120 CALL SCAN
+ CALL SLAD(3,7,2)
+ NEXT=12
+ RETURN
+C RECURSIVE CALL OF E12 TO ANALYSE THE
+C SUBEXPRESSION
+20 IF (S.EQ.SRIGHT) GOTO 179
+ CALL ERROR(107)
+ GOTO 1000
+C------------- END OF THE MAIN LOOP
+179 CALL SCAN
+180 IF (STACK(TOP+5).EQ.0) GOTO 185
+C MINUS BEFORE EXCPRESSION
+ CALL OUTPUT(WOPERAT,2)
+ STACK(TOP+5)=0
+185 IF (STACK(TOP+3).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+3))
+ STACK(TOP+3)=0
+ IF (S.NE.STAR) GOTO 190
+ IF (ADRES.LT.5) GOTO 190
+C MOD, DIV, * OR / - NEXT FACTOR EXPECTED
+ STACK(TOP+3)=ADRES
+ GOTO 85
+190 IF (STACK(TOP+4).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+4))
+ STACK(TOP+4)=0
+ IF (S.NE.STAR) GOTO 1000
+ IF (ADRES.LT.2) GOTO 1000
+C + OR - (MINUS) - NEXT COMPONENT EXPECTED
+ STACK(TOP+4)=ADRES
+ GOTO 85
+1000 NEXT=0
+ RETURN
+ END
+
+ SUBROUTINE E8
+C
+C RECOGNIZES THE SEQUENCE OF INSTRUCTIONS UNTIL A TERMINAL SYMBOL
+C THE PARAMETER IS PASSED BY STACK(TOP+7)
+C
+C STACK(TOP+3)
+C STACK(TOP+4) - NUMBERS OF THE GENERATED LABELS
+C . . . OTHERS
+C STACK(TOP+7) - A INPUT PARAMETER WHICH DETERMINES THE SET OF THE
+C TERMINAL SYMBOLS
+C MEANING:
+C 1 - INSTRUCTIONS UNTIL WHEN/OTHERS/END
+C 2 - .................. ELSE/FI
+C 3 - .................. FI
+C 4 - .................. OD
+C 5 - .................. END
+C 6 - .................. WHEN/OTHERWISE/ESAC
+C 7 - .................. ESAC
+C
+ IMPLICIT INTEGER (A-Z)
+ logical errflg
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEKST
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+cdsw EQUIVALENCE (AUX,SCANER(3698))
+ EQUIVALENCE (AUX,SCANER(8698))
+ EQUIVALENCE (WSTART,WUNLOCK)
+C*******************************************************************
+C*** NOTE **********************************************************
+C*** SMAIN HAS TO BE INSERTED INTO THE BLANK COMMON ON OCCASION ***
+C*** OF SOME OTHER CHANGES *********************** 10/11/1981 ******
+C*** WSTART SHOULD BE CHANGED TO WUNLOCK ***************************
+C*******************************************************************
+ smain = 96
+ wind = 69
+ wwlock = 66
+ wwunlock = 67
+ sothrs = 57
+ wwread = 73
+ wreadl = 74
+ wioend = 50
+ wopen1 = 77
+ wopen2 = 78
+ wput = 75
+ wget = 76
+ wparin = 81
+ wassem = 84
+ wputrec = 89
+ wgetrec = 90
+cbc added concurrent statements
+ wenab = 91
+ wdisab = 92
+ waccep = 93
+ wprend = 94
+ senab = 35
+cbc
+
+ GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,
+ X170,180,190,200,210,220,230,240,250,260,270,280,290,300,310,
+ x320,330,340,350,360,370,380),in
+cdsw x320,330,340,350),in
+cfileX320,330,340),IN
+C CHECK WHETHER SYMBOL S MAY START AN INSTRUCTION
+6 CALL ERROR(102)
+8 CALL SCAN
+cbc 10 if(s.gt.34) go to 1111
+10 if (s .gt. 36) goto 1111
+ IF (S.GT.0) GOTO 15
+ CALL ERROR(102)
+ GOTO 999
+15 IF (AUX.NE.0) CALL SELOPT
+ CALL OUTPUT(WINSTREND,LN)
+ GOTO (101,201,301,401,501,601,701,801,901,1001,1101,1201,1301
+ 1,1401,1501,1601,1701,1801,1901,2001,2101,2201,2301,101,2501
+ 2,2601,2701,2801,2901,3001,3101,3201,3301,3401,3501,3601),s
+cbc 2,2601,2701,2801,2901,3001,3101,3201,3301,3401),s
+C----- S = SIDENT - ASSIGNMENT STATEMENT OR OBJECT GENERATOR
+101 CONTINUE
+ CALL SLAD(5,8,12)
+ NEXT=3
+C CALL OBJECT EXPRESSION /E3/ TO ANALYSE THE VARIABLE
+ GO TO 7766
+120 CONTINUE
+ IF (S.EQ.SEMICOL) GOTO 125
+ IF (S.EQ.SBECOME) GOTO 111
+ IF (S.EQ.SCOMA) GOTO 111
+ GOTO 1111
+C INITIAL FRAGMENT OF AN ASSIGNMENT STATEMENT HAS BEEN RECOGNIZED
+111 CALL SLAD(5,8,2)
+ NEXT=6
+ GO TO 7766
+C CALL ASSIGNMENT /E6/
+C RETURN TO LABEL 20 BELOW
+C /JUMP OPTIMIZATION/
+C
+C < VARIABLE > ; IS RECOGNIZED
+C CHECK FOR A PENDING NEW OR START
+125 IF (STACK(TOP+15).EQ.0) CALL ERROR(123)
+ GOTO 1000
+C----- S = IF INSTRUCTION: IF EXPR. THEN INSTR. ( ELSE INSTR. ) FI
+C STACK(TOP+5)=0 THERT WAS NO ORIF/ANDIF
+C =1 THERE WAS ANDIF
+C =2 THERE WAS ORIF
+C STACK(TOP+4) - LABEL BEHIND THEN OR ELSE
+C DEPENDING ON THE CONTENTS OF STACK(TOP+5)
+C STACK(TOP+3) - USED TO COUN EXITS FOR THE SEQUENCES:I IF EXPR. THEN EXIT..
+201 STACK(TOP+5)=0
+ STACK(TOP+4)=UNICAL
+ UNICAL=UNICAL+1
+202 CALL SCAN
+ CALL SLAD(5,8,3)
+ NEXT=1
+ GO TO 7766
+C CAL BOOLEXPRESSION /E1/
+30 IF (S.EQ.SORIF) GOTO 203
+ IF (S.EQ.STHEN) GOTO 204
+ CALL ERROR(103)
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+ GOTO 1000
+C CALL ORIF
+203 IF (STACK(TOP+5).EQ.0) STACK(TOP+5)=ADRES
+ IF (STACK(TOP+5).NE.ADRES) CALL ERROR(140)
+ CALL OUTPUT(WIDENT+ADRES,STACK(TOP+4))
+C IF ANDIF THEN ADRES=1 & WIDENT+ADRES=WIFFALS
+C IF ORIF THEN ADRES=2 & WIDENT+ADRES=WIFTRUE
+ GOTO 202
+204 CALL SCAN
+C THEN ENCOUNTERED, CHECK IF THERE WAS ORIF OR ANDIF
+ IF (STACK(TOP+5).EQ.2) GOTO 215
+ IF (STACK(TOP+5).EQ.1) GOTO 214
+ STACK(TOP+3)=0
+205 IF (S.NE.SEXIT) GOTO 207
+C EXIT/REPEAT ENCOUNTERED
+ STACK(TOP+3)=STACK(TOP+3)+1
+ IF (ADRES.EQ.2) GOTO 206
+ CALL SCAN
+ GOTO 205
+C (EXIT)+ REPEAT ENCOUNTERED
+206 CALL OUTPUT(WIFTRUE,EXYT(STACK(TOP+3),0))
+ CALL SCAN
+ GOTO 208
+C S =/= EXIT
+207 IF (STACK(TOP+3).EQ.0) GOTO 214
+ CALL OUTPUT(WIFTRUE,EXYT(STACK(TOP+3),1))
+C IF EXPR. THEN (EXIT)+ REPEAT
+208 IF (S.EQ.SFI) GOTO 999
+ IF (S.EQ.SELSE) GOTO 211
+ IF (S.NE.SEMICOL) GOTO 209
+ CALL SCAN
+ GOTO 208
+C THERE ARE INSTRUCTIONS BEHIND EXIT
+209 CALL ERROR(139)
+ CALL SLAD(5,8,29)
+ NEXT=8
+ STACK(TOP+7)=2
+ GO TO 7766
+C CALL E8 TO ANALYSE A SEQUENCE OF STATEMENTS ENDED BY ELSE OR FI
+290 IF (S.NE.SELSE) GOTO 999
+211 CALL SCAN
+ CALL SLAD(5,8,30)
+ NEXT=8
+ STACK(TOP+7)=3
+ GO TO 7766
+C CALL E8 TO ANALYSE INMSTRUCTIONS AFTER ELSE
+300 IF (S.EQ.SFI) GOTO 999
+C A MISSING "FI" IS DIAGNOSED IN SOME OTHER PLACE. HERE WE JUMP TO 1000
+C TO AVOID READING OF THE NEXT INPUT SYMBOL
+ GOTO 1000
+C
+C ANALYSIS FOR IF EXPR. THEN ......
+214 STACK(TOP+3)=STACK(TOP+4)
+ CALL OUTPUT(WIFFALS,STACK(TOP+3))
+ GOTO 217
+C ORIF OCCURRED, A LABEL (FOR ELSE OR FI) HAS TO BE RESERVED
+215 STACK(TOP+3)=UNICAL
+ UNICAL=UNICAL+1
+ CALL OUTPUT(WIFFALS,STACK(TOP+3))
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+217 CALL SLAD(5,8,4)
+ NEXT=8
+ STACK(TOP+7)=2
+C A VALUE IS ASSIGNED TO THE PARAMETER OF E8
+ GO TO 7766
+C ANALYSIS AFTER THEN
+40 IF (S.EQ.SELSE) GOTO 241
+ IF (S.NE.SFI) GOTO 271
+C A "FI" UNPRECEDED BY "ELSE"
+221 CALL OUTPUT(WLABEL,STACK(TOP+3))
+ GOTO 999
+C ELSE ENCOUNTERED, WE SHOULD RESERVE A LABEL TO JUMP BEHIND FI
+241 STACK(TOP+4)=UNICAL
+ UNICAL=UNICAL+1
+ CALL SCAN
+ CALL OUTPUT(WJUMP,STACK(TOP+4))
+ CALL OUTPUT(WLABEL,STACK(TOP+3))
+ CALL SLAD (5,8,5)
+ NEXT=8
+ STACK(TOP+7)=3
+C PARAMETER FOR E8
+ GO TO 7766
+C ANALYSIS OF INSTRUCTIONS AFTER ELSE
+50 IF (S.NE.SFI) GOTO 271
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+ GOTO 999
+271 CALL ERROR(104)
+ GOTO 1000
+C----- S = WHILE
+301 STACK(TOP+3)=UNICAL
+ STACK(TOP+4)=UNICAL+1
+C RESERVATION OF LABELS:
+C STACK(TOP+3) - BEGINNING OF THE LOOP (THE BOOLEAN CONDITION)
+C STACK(TOP+4) - END OF THE LOOP
+ UNICAL=UNICAL+2
+ CALL SCAN
+ CALL OUTPUT(WLABEL,STACK(TOP+3))
+ CALL OUTPUT(WINSTREND,LN)
+ CALL SLAD(5,8,6)
+ NEXT=1
+ GO TO 7766
+C CALL BOOLEXPRESSION /E1/
+60 CALL OUTPUT(WIFFALS,STACK(TOP+4))
+C CONDITIONAL JUMP BEHIND DO
+ IF (S.EQ.SDO) GOTO 307
+ CALL ERROR(108)
+ GOTO 309
+307 CALL SCAN
+309 CONTINUE
+ CALL SLAD(5,8,7)
+ NEXT=8
+ STACK(TOP+7)=4
+C PARAMETER PASSING
+ GO TO 7766
+C ANALYSIS OF THE INTERIOR OF THE DO LOOP /E8/
+70 CALL OUTPUT(WJUMP,STACK(TOP+3))
+C JUMP TO THE BEGINNING OF THE LOOP
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+ IF (S.EQ.SOD) GOTO 999
+ CALL ERROR(105)
+ GOTO 1000
+C----- S = RETURN
+401 CALL OUTPUT(WRETURN,-1)
+cbc added enable/disable option
+ call scan
+405 if (s .ne. senab) goto 415
+ call output(wenab+adres-1, -1)
+410 call scan
+ if (s .ne. sident) goto 420
+ call output(wident, adres)
+ call scan
+ if (s .eq. scoma) goto 410
+ goto 405
+415 call output(wprend, -1)
+ goto 1000
+420 call error(109)
+ goto 1000
+cbc end
+C----- S = DETACH
+501 CALL OUTPUT(WDETACH,-1)
+ GOTO 999
+C----- S = INNER
+601 CALL OUTPUT(WINNER,-1)
+ GOTO 999
+C----- S = LOCK
+701 STACK(TOP+3)=6
+C FURTHER ANALYSIS AS FOR KILL, RESUME, ETC.
+ GOTO 1302
+C----- S = READ
+801 CALL SCAN
+ STACK(TOP+3)=0
+C STACK(TOP+3)= 0 - READ
+C 1 - READLN
+ IF (S.EQ.SLEFT) GOTO 803
+ CALL ERROR(106)
+ GOTO 804
+803 CALL SCAN
+804 CALL SLAD(5,8,9)
+ NEXT=3
+ GO TO 7766
+C CALL OBJECTEXPRESSION FOR READ( VARIABLE, . . . ,VARIABLE )
+90 CALL OUTPUT(WWREAD,-1)
+C CHECK IF END OF THE READ LIST
+ IF (S.EQ.SCOMA) GOTO 803
+808 IF (S.EQ.SRIGHT) GOTO 810
+ CALL ERROR(107)
+ GOTO 812
+810 CALL SCAN
+812 IF (STACK(TOP+3).GT.0) CALL OUTPUT(WREADL,-1)
+ CALL OUTPUT(WIOEND,-1)
+ GOTO 1000
+C----- S= CALL
+901 CALL SCAN
+ STACK(TOP+3)=0
+C
+C STACK(TOP+3) - 0 - CALL
+C 1 - RAISE
+C
+C --- ADDED CHECK FOR STHIS AND SNEW
+ IF (S.EQ.SIDENT.OR.S.EQ.STHIS.OR.S.EQ.SNEW) GOTO 905
+C ---
+ CALL ERROR(109)
+ GOTO 1000
+905 CALL SLAD(5,8,10)
+ NEXT=3
+ GO TO 7766
+C CALL OBJECTEXPRESSION TO ANALYSE THE EXPRESSION
+C WRITE WCALL OR WRAISE DEPENDING ON THE CONTENTS OF STACK(TOP+3)
+100 CALL OUTPUT(WCALL+STACK(TOP+3)*64,-1)
+ GOTO 1000
+C----- S = KILL
+1001 STACK(TOP+3)=1
+ GOTO 1302
+C----- S = ATTACH
+1101 STACK(TOP+3)=2
+ GOTO 1302
+C----- S = RESUME
+1201 STACK(TOP+3)=3
+ GOTO 1302
+C----- S = STOP
+1301 STACK(TOP+3)=4
+C THE MEANING OF STACK(TOP+3):
+C 1 - KILL
+C 2 - ATTACH
+C 3 - RESUME
+C 4 - STOP
+C 5 - WAIT
+C 6 - LOCK
+C 7 - UNLOCK
+ CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 1303
+C STOP WITHOUT PARAMETER
+ CALL OUTPUT(WSTOP,-1)
+ GOTO 1000
+1302 CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 1303
+ CALL ERROR(106)
+ GOTO 1304
+1303 CALL SCAN
+1304 IF (S.EQ.SMAIN) GOTO 1320
+ CALL SLAD(5,8,11)
+ NEXT=3
+ GO TO 7766
+C CALL OBJECTEXPRESSION. /E3/ TO ANALYSE THE EXPRESSION AFTER
+C KILL, ATTACH, RESUME, STOP, WAIT, LOCK
+110 IF (S.EQ.SRIGHT) GOTO 1305
+ CALL ERROR(107)
+ GOTO 1306
+1305 CALL SCAN
+C JUMP ACCORDING TO THE PREVIOUSLY RECOGNIZED STATEMENT TYPE
+1306 K=STACK(TOP+3)
+ GOTO (1307,1308,1309,1310,1311,1312,1313),K
+1307 CALL OUTPUT(WKILL,-1)
+ GOTO 1000
+1308 CALL OUTPUT(WATTACH,-1)
+ GOTO 1000
+1309 CALL OUTPUT(WRESUME,-1)
+ GOTO 1000
+1310 CALL OUTPUT(WSTOP,-1)
+ GOTO 1000
+1311 CALL OUTPUT(WAIT,-1)
+ GOTO 1000
+1312 CALL OUTPUT(WWLOCK,-1)
+ GOTO 1000
+1313 CALL OUTPUT(WWUNLOCK,-1)
+ GOTO 1000
+C MAIN ENCOUNTERED, CHECK IF THE CONTEXT IS RESUME/ATTACH
+1320 IF (STACK(TOP+3).EQ.2) GOTO 1330
+ IF (STACK(TOP+3).EQ.3) GOTO 1340
+ CALL ERROR(131)
+ GOTO 1345
+C RECOGNIZED ATTACH(MAIN)
+1330 CALL OUTPUT(WIDENT,K)
+ CALL OUTPUT(WATTACH,-1)
+ GOTO 1345
+1340 CALL OUTPUT(WIDENT,K)
+ CALL OUTPUT(WRESUME,-1)
+1345 CALL SCAN
+ IF (S.EQ.SRIGHT) GOTO 999
+ CALL ERROR(107)
+ GOTO 1000
+C----- S = DO
+C STACK(TOP+3) - LABEL OF THE BEGINNING OF THE LOOP BODY
+C STACK(TOP+4) - LABEL OF THE FIRST STATEMENT BEHIND THE LOOP BODY
+1401 STACK(TOP+3)=UNICAL
+ STACK(TOP+4)=UNICAL+1
+ UNICAL=UNICAL+2
+ CALL SCAN
+ CALL OUTPUT(WLABEL,STACK(TOP+3))
+ CALL SLAD(5,8,13)
+ STACK(TOP+7)=4
+ NEXT = 8
+ GO TO 7766
+C CALL E8 (INSTRUCTION) WITH PARAMETER 4
+130 CALL OUTPUT(WINSTREND,LN)
+ CALL OUTPUT(WJUMP,STACK(TOP+3))
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+ IF (S.EQ.SOD) GOTO 999
+ CALL ERROR(105)
+ GOTO 1000
+C----- S = EXIT
+1501 STACK(TOP+3)=0
+1505 STACK(TOP+3)=STACK(TOP+3)+1
+ IF (ADRES.EQ.2) GOTO 1550
+ CALL SCAN
+ IF (S.EQ.SEXIT) GOTO 1505
+ CALL OUTPUT(WJUMP,EXYT(STACK(TOP+3),1))
+ GOTO 1000
+1550 CALL OUTPUT(WJUMP,EXYT(STACK(TOP+3),0))
+ GOTO 999
+C----- S = CASE
+1601 STACK(TOP+3)=UNICAL+1
+ STACK(TOP+4)=UNICAL+162
+ STACK(TOP+5)=1
+ STACK(TOP+6)=1
+ UNICAL=UNICAL+163
+C
+C STACK(TOP+3) - BASIC CASE LABEL, NOT USED
+C STACK(TOP+4) - END LABEL OF THE CASE STATEMENT
+C STACK(TOP+5) - COUNTER OF WHEN'S (NUMBER OF WHEN'S LIMITED BY 160)
+C STACK(TOP+6) - 0 = OVERFLOW FLAG (TOO MANY WHEN'S)
+C NOTE: THE BASIC LABEL IS RESERVED ESPECIALLY FOR AIL, NOT USED IN HERE.
+C LABELS FOR WHEN'S ARE OF THE FORM: BASIS + I , WHERE I = 1 .. 160
+C TOTAL NUMBER OF RESERVED LABELS IS 163.
+C
+ CALL SCAN
+ CALL SLAD(5,8,26)
+ NEXT=2
+ GO TO 7766
+C CALL E2 - ARITHEXPRESSION TO ANALYSE THE EXPRESSION AFTER CASE
+260 CALL OUTPUT(WCASE,STACK(TOP+3))
+ IF (S.EQ.SWHEN) GOTO 1605
+ CALL ERROR(132)
+ GOTO 1607
+1605 CALL SCAN
+C RECOGNITION OF THE SELECTION LABEL
+1607 IF (STACK(TOP+6).EQ.0) GOTO 1621
+ IF (S.EQ.SIDENT) GOTO 1610
+ IF (S.EQ.SCONST) GOTO 1615
+1608 CALL ERROR(117)
+ CALL OUTPUT(WIDENT,0)
+ GOTO 1620
+C IDENTIFIER RECOGNIZED
+1610 CALL OUTPUT(WIDENT,ADRES)
+ GOTO 1620
+C CONSTANT RECOGNIZED
+1615 IF (K.EQ.6) GOTO 1618
+ IF (K.NE.3) GOTO 1608
+C INTEGER CONSTANT
+ CALL OUTPUT(WCNSTI,ADRES)
+ GOTO 1620
+C CHARACTER CONSTANT
+1618 CALL OUTPUT(WCNSTC,ADRES)
+1620 CALL OUTPUT(WCASEL,STACK(TOP+3)+STACK(TOP+5))
+1621 CALL SCAN
+ IF (S.EQ.SCOLON) GOTO 1625
+ IF (S.NE.SCOMA) GOTO 1623
+C COMA ENCOUNTERED - FURTHER LABEL LIST EXPECTED
+ CALL SCAN
+ GOTO 1607
+C NEITHER SEMICOLON NOR COMMA (ERROR AND WE CONTINUE AS FOR
+C SEMICOLON - INSTRUCTIONS)
+1623 CALL ERROR(118)
+ GOTO 1626
+C SEMICOLON ENCOUNTERED - INSTRUCTIONS ARE TO BE ANALYSED
+1625 CALL SCAN
+1626 IF (STACK(TOP+5).NE.161) GOTO 1627
+C TO MANY WHEN'S
+ CALL ERROR(133)
+ STACK(TOP+6)=0
+ GOTO 1628
+1627 CALL OUTPUT(WLABEL,STACK(TOP+3)+STACK(TOP+5))
+ STACK(TOP+5)=STACK(TOP+5)+1
+1628 CALL SLAD(5,8,27)
+ NEXT=8
+ STACK(TOP+7)=6
+ GO TO 7766
+C CALL E8 TO ANALYSE THE INSTRUCTION LIST ENDED BY WHEN, OTHERWISE
+C OR ESAC (PARAMETER = 6)
+270 CALL OUTPUT(WJUMP,STACK(TOP+4))
+ IF (S.EQ.SWHEN) GOTO 1605
+ IF (S.NE.SOTHER) GOTO 1655
+C OTHERWISE ENCOUNTERED
+ CALL OUTPUT(WOTHER,-1)
+ CALL SCAN
+ CALL SLAD (5,8,28)
+ NEXT=8
+ STACK(TOP+7)=7
+ GO TO 7766
+C CALL E8 TO ANALYSE THE INSTRUCTION SEQUENCE ENDED BY ESAC (PARAMETER=7)
+C AFTER RETURN JUMP BEHIND CASE IS NOT TO BE GENERATED
+280 CONTINUE
+C ESAC ENCOUNTERED (A MISSING ESAC IS DIAGNOSED ON SOME OTHER LEVEL).
+C HERE, TO PROVIDE CODE CONSISTENCY, WE ASSUME THAT AN ESAC HAS OCCURRED
+C ANYWAY.
+1655 CALL OUTPUT(WESAC,-1)
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+ IF (S.EQ.SESAC) GOTO 999
+ CALL ERROR(129)
+ GOTO 1000
+C----- S = FOR
+1701 CALL SCAN
+ CALL SLAD(5,8,21)
+ NEXT=3
+ GO TO 7766
+C CALL E3 T OANALYSE THE VARIABLE
+210 CALL OUTPUT(WFORVAR,-1)
+ IF (S.EQ.SBECOME) GOTO 1703
+ CALL ERROR(101)
+ GOTO 1000
+1703 CALL SCAN
+ CALL SLAD(5,8,22)
+ NEXT=2
+ GO TO 7766
+C CALL E2 - ARITHEXPRESSION TO ANALYSE BOUNDS
+220 CALL OUTPUT(WFROM,-1)
+ IF (S.NE.STEP) GOTO 1705
+ CALL SCAN
+ CALL SLAD(5,8,23)
+ NEXT=2
+ GO TO 7766
+C CALL E2 TO ANALYZE THE STEP
+230 CALL OUTPUT(WSTEP,-1)
+1705 IF (S.EQ.STO) GOTO 1707
+ IF (S.EQ.SDOWN) GOTO 1709
+ CALL ERROR(125)
+ GOTO 1000
+C STACK(TOP+3)=0 IFF "TO" ENCOUNTERED, OTHERWISE -1 STANDS FOR "DOWNTO"
+1707 STACK(TOP+3)=0
+ GOTO 1711
+1709 STACK(TOP+3)=1
+1711 CALL SCAN
+ CALL SLAD(5,8,24)
+ NEXT=2
+ GO TO 7766
+C CALL E2 TO ANALYSE BOUNDS OF THE FOR LOOP
+240 IF (STACK(TOP+3).EQ.1) GOTO 1713
+ CALL OUTPUT(WTO,-1)
+ GOTO 1715
+1713 CALL OUTPUT(WDOWNTO,-1)
+C STACK(TOP+3) LABEL OF THE END OF THE LOOP (BEFORE OD!)
+C STACK(TOP+4) LABEL OF THE FIRST INSTRUCTION BEHIND THE LOOP
+C STACK(TOP+5) LABEL OF THE BEGINNING OF THE LOOP
+1715 STACK(TOP+3)=UNICAL
+ STACK(TOP+4)=UNICAL+1
+ STACK(TOP+5)=UNICAL+2
+ UNICAL=UNICAL+3
+ CALL OUTPUT(STACK(TOP+5),STACK(TOP+4))
+ IF (S.EQ.SDO) GOTO 1717
+ CALL ERROR(108)
+ GOTO 1000
+1717 CALL SCAN
+ CALL SLAD(5,8,25)
+ STACK(TOP+7)=4
+ NEXT=8
+ GO TO 7766
+C CALL E8 TO ANALYSE THE INSTRUCTION SEQUENCE
+C WITH PARAMETER = 4, I.E. "OD" IS THE TERMINAL SYMBOL
+250 CALL OUTPUT(WLABEL,STACK(TOP+3))
+ CALL OUTPUT(WFOREND,-1)
+ CALL OUTPUT(WJUMP,STACK(TOP+5))
+ CALL OUTPUT(WLABEL,STACK(TOP+4))
+ IF (S.EQ.SOD) GOTO 999
+ CALL ERROR(105)
+ GOTO 1000
+C----- S = ARRAY
+1801 CALL SCAN
+ CALL SLAD(5,8,18)
+ NEXT=3
+ GO TO 7766
+C CALL E3 TO ANALYSE THE VARIABLE
+180 IF (S.EQ.SDIM) GOTO 1810
+ CALL ERROR(124)
+ GOTO 1000
+1810 CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 1820
+ CALL ERROR(106)
+ GOTO 1000
+1820 CALL OUTPUT(WLSE,-1)
+ CALL SCAN
+ CALL SLAD(5,8,19)
+ NEXT=2
+ GO TO 7766
+C CALL E2 - ARITHEXPRESSION TO ANALYSE BOUNDS OF THE "FOR"
+190 CALL OUTPUT(WLOW,-1)
+ IF (S.EQ.SCOLON) GOTO 1830
+ CALL ERROR(118)
+ GOTO 1000
+1830 CALL SCAN
+ CALL SLAD(5,8,20)
+ NEXT=2
+ GO TO 7766
+C CALL E2 - ARITHEXPRESSION
+200 CALL OUTPUT(WNEWARRAY,-1)
+ IF (S.EQ.SRIGHT) GOTO 999
+ CALL ERROR(107)
+ GOTO 1000
+C----- S = WRITE
+1901 STACK(TOP+6)=0
+ CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 2003
+ CALL ERROR(106)
+ GOTO 1000
+C----- S = WRITELN
+2001 STACK(TOP+6)=1
+C STACK(TOP+6) - 0 - THERE WAS WRITE, 1 - THERE WAS WRITELN
+ CALL SCAN
+C CHECK IF THERE ARE PARAMETERS OF WRITELN
+ IF (S.EQ.SLEFT) GOTO 2003
+ CALL OUTPUT(WRITELN,WIOEND)
+ GOTO 1000
+2003 CALL SCAN
+ CALL SLAD(5,8,16)
+ NEXT=4
+ GO TO 7766
+C CALL E4 - EXPRESSION TO ANALYSE PARAMETERS OF WRITE(LN)N
+C STACK(TOP+5) - INCLUDES NUMBER OF THE EXPRESSIONS USED TO DESCRIBE
+C THE OUTPUT FORMAT
+160 STACK(TOP+5)=0
+170 IF (S.NE.SCOLON) GOTO 2010
+ STACK(TOP+5)=STACK(TOP+5)+1
+ IF (STACK(TOP+5).GT.2) GOTO 2015
+ CALL SCAN
+ CALL SLAD(5,8,17)
+ NEXT=2
+ GO TO 7766
+C CALL ARITHEXPRESSION TO ANALYSE FORMATS
+C RETURN TO LABEL 170 (OPTIMIZATION)
+2010 CALL OUTPUT(WRITE,STACK(TOP+5))
+C CHECK FOR END OF WRITE / WRITELN
+ IF (S.EQ.SCOMA) GOTO 2003
+ IF (S.EQ.SRIGHT) GOTO 2020
+2015 CALL ERROR(107)
+ GOTO 1000
+C WRITE INFORMATION ABOUT THE OCCURRENCE OF WRITELN
+2020 IF (STACK(TOP+6).EQ.1) CALL OUTPUT(WRITELN,-1)
+ CALL OUTPUT(WIOEND,-1)
+ GOTO 999
+C----- S = WAIT
+2101 STACK(TOP+3)=5
+C ANALYSIS OF WAIT AS FOR KIL, RESUME, AND SO ON.
+ GOTO 1302
+C----- S = BLOCK
+2201 STACK(TOP+5)=0
+ CALL OUTPUT(WBLOCK,ISFIN)
+C STACK(TOP+5) INCLUDES PREFIX ADDRESS, HERE 0 FOR REGULAR BLOCK,
+C JUMP OUT - FURTHER ANALYSIS AS FOR A PREFIXED BLOCK
+ GOTO 2310
+C----- S = PREF
+2301 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 2302
+ CALL ERROR(109)
+ GOTO 1000
+C PREFIX ENCOUNTERED - STORE ITS ADDRESS INTO STACK(TOP+5)
+2302 STACK(TOP+5)=ADRES
+ CALL OUTPUT(WPREF,ISFIN)
+ CALL SCAN
+ IF (S.EQ.SBLOCK) GOTO 2310
+ IF (S.EQ.SLEFT) GOTO 2303
+ CALL ERROR(122)
+ GOTO 1000
+C ANALYSIS OF THE PARAMETERS OF THE PREFIX
+2303 CALL OUTPUT(WLEFT,-1)
+2304 CALL SCAN
+ CALL SLAD(5,8,14)
+ NEXT=4
+ GO TO 7766
+C CALL E4 - EXPRESSION TO ANALYSE THE ACTUAL PARAMETERS
+C OF THE PREFIX
+140 IF (S.EQ.SCOMA) GOTO 2305
+ IF (S.EQ.SRIGHT)GOTO 2306
+ CALL ERROR(107)
+ GOTO 1000
+2305 CALL OUTPUT(WCOMA,-1)
+ GOTO 2304
+2306 CALL SCAN
+ CALL OUTPUT(WRIGHT,-1)
+C COMMON ANALYSIS FOR ALL BLOCKS
+C POSITIONS ARE STORED INTO THE INTERMEDIATE CODE
+2310 CALL MARK(STACK(TOP+3),STACK(TOP+4))
+ STACK(TOP+6)=UNICAL
+ NEXT=STACK(TOP+5)
+ CALL SLAD(5,8,15)
+ STACK(TOP+4)=NEXT
+C ASSIGNMENT OF THE PARAMETER'S VALUE - BLOCK PREFIX
+ NEXT=11
+ GO TO 7766
+C CALL E11 TO ANALYSE THE ENTIRE BLOCK
+C AFTER RETURN WE RECLAIM THE PLACE FROM WHICH THE INTERMEDIATE CODE FOR
+C THE GIVEN BLOCK IS TO BE CONTINUED
+150 CALL FIND(STACK(TOP+3),STACK(TOP+4))
+ UNICAL=STACK(TOP+6)
+ CALL OPTOUT
+ GOTO 1000
+C----- S = UNLOCK
+2501 STACK(TOP+3)=7
+C FURTHER ANALYSIS AS FOR KILL, RESUME, ETC.
+ GOTO 1302
+C----- S = RAISE
+2601 STACK(TOP+3)=1
+ CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 905
+C FURTHER ANALYSIS AS FOR CALL (BUT STACK(TOP+3)=1)
+ CALL ERROR(109)
+ GOTO 1000
+C----- S = WIND, TERMINATE
+2701 CALL OUTPUT(WIND+ADRES-1,-1)
+ GOTO 999
+C----- S = LASTWILL
+2801 IF (STACK(TOP+7).EQ.5) GOTO 1114
+ CALL ERROR(143)
+ GOTO 999
+C----- S = ASSEMBLER
+C --- ASSEMBLER INSERTIONS NOT IMPLEMENTED
+2901 CALL ERROR(106)
+2904 IF (S.EQ.SEND) GOTO 999
+ CALL SCAN
+ GOTO 2904
+330 CALL ERROR(118)
+ GO TO 2904
+C----- S = OPEN
+3001 CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 3010
+ CALL ERROR(106)
+ GOTO 1000
+3010 CALL SCAN
+ CALL SLAD(5,8,31)
+ NEXT=3
+ GO TO 7766
+C CALL E3 - OBJECTEXPRESSION TO ANALYSE THE VARIABLE
+310 STACK(TOP+3)=WOPEN1
+cfile ----------- added ---------------------------
+ if(s.ne.scoma) go to 3013
+ call scan
+ call slad(5,8,35)
+ next = 4
+ go to 7766
+c call expression to analyse the second parameter
+cfile --------------------------------------------
+350 IF (S.EQ.SRIGHT) GOTO 3025
+ IF (S.EQ.SCOMA) GOTO 3015
+3013 CALL ERROR(107)
+3014 IF (S.EQ.SEND) GOTO 1000
+ CALL SCAN
+ GOTO 3014
+3015 CALL SCAN
+ CALL SLAD(5,8,34)
+ NEXT=4
+ GO TO 7766
+C CALL EXPRESSION TO ANALYSE THE THIRD PARAMETER
+340 STACK(TOP+3)=WOPEN2
+3025 CALL OUTPUT(STACK(TOP+3),-1)
+ IF (S.NE.SRIGHT) GOTO 3013
+ GOTO 999
+C----- S = PUT/GET
+3101 STACK(TOP+3)=WPUT+ADRES-1
+C STACK(TOP+3) - WPUT ALBO WGET
+ CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 3110
+ CALL ERROR(106)
+ GOTO 1000
+3110 CALL SCAN
+cdsw CALL SLAD(2,8,32)
+ call slad(5,8,32)
+ NEXT=3
+ GO TO 7766
+C CALL E3 (OBJECTEXPRESSION) TO ANALYSE THE PARAMETER OF PUT/GET
+320 CALL OUTPUT(STACK(TOP+3),-1)
+ IF (S.EQ.SRIGHT) GOTO 3140
+ IF (S.EQ.SCOMA) GOTO 3120
+ CALL ERROR(107)
+ GOTO 3180
+3120 CALL SCAN
+ CALL SLAD(5,8,32)
+ NEXT=4
+ GO TO 7766
+C CALL EXPRESSION TO ANALYSE THE PARAMETER OF PUT/GET
+C NOTE: RETURN INTO NON-STANDARD PLACE
+3140 CALL SCAN
+3180 CALL OUTPUT(WIOEND,-1)
+ GOTO 1000
+C----- S = READLN
+3201 STACK(TOP+3)=1
+ CALL SCAN
+ IF (S.EQ.SLEFT) GOTO 803
+ GOTO 812
+cdeb ----------- added --------------
+c------- s = break
+3301 call addbr(ln)
+ go to 999
+cdeb ----------------------------------
+cdsw -- added:
+c ----- s = putrec/getrec
+3401 addr = adres
+ stack(top+3) = wput+addr-1
+ call scan
+ if (s .eq. sleft) goto 3410
+ call error(106)
+ goto 1000
+3410 call scan
+ call slad(5, 8, 36)
+ next = 3
+ goto 7766
+360 if (s .ne. scoma) goto 3420
+ call output(stack(top+3), -1)
+ stack(top+3) = wputrec+addr-1
+ call scan
+ call slad(5, 8, 37)
+ next = 4
+ goto 7766
+370 if (s .ne. scoma) goto 3420
+ call scan
+ call slad(5, 8, 38)
+ next = 4
+ goto 7766
+380 if (s .ne. sright) goto 3013
+ call output(stack(top+3), -1)
+ call output(wioend, -1)
+ goto 999
+3420 call error(147)
+ goto 1000
+cdsw -- end
+cbc added concurrent statements
+c ----- s = enable/disable
+3501 call output(wenab+adres-1, -1)
+3510 call scan
+ if (s .ne. sident) goto 3520
+ call output(wident, adres)
+ call scan
+ if (s .eq. scoma) goto 3510
+ call output(wprend, -1)
+ goto 1000
+3520 call error(109)
+ goto 1000
+c ----- s = accept
+3601 call output(waccep, -1)
+ call scan
+ if (s .ne. sident) goto 3620
+ call output(wident, adres)
+ call scan
+ if (s .eq. scoma) goto 3510
+3620 call output(wprend, -1)
+ goto 1000
+cbc end
+C ----- END OF INSTRUCTIONS ----------------------------------
+999 CALL SCAN
+20 CONTINUE
+C RETURN FROM ASSIGNMENT /JUMP OPTIMIZATION/
+80 CONTINUE
+C LABEL 80 (A GARBAGE FROM THE OLD VERSION OF THE PARSER)
+C RETAINED TO PRESERVE THE CONTINUITY OF THE REMAINING LABEL NUMBERS
+C (USED TO MARK RETURN POINTS FROM RECURSIVE CALLS)
+1000 CONTINUE
+C INSTRUCTIONS RECOGNIZED
+C CHECK FOR A TERMINAL SYMBOL
+1111 IF (S.EQ.SEMICOL) GOTO 8
+ IF (S.EQ.SELSE) GOTO 1116
+ IF (S.EQ.SFI) GOTO 1115
+ IF (S.EQ.SOD) GOTO 1117
+ IF (S.EQ.SEND) GOTO 1114
+ IF (S.EQ.SOTHER) GOTO 1119
+ IF (S.EQ.SOTHRS) GOTO 1120
+ IF (S.EQ.SWHEN) GOTO 1119
+ IF (S.EQ.SESAC) GOTO 1118
+ IF (S.EQ.SVAR) GOTO 1113
+ IF (S.EQ.SUNIT) GOTO 1113
+ IF (S.EQ.SCONS) GOTO 1113
+ IF (S.NE.SEOF) GOTO 6
+1113 CALL ERROR(113)
+1114 NEXT=0
+ GO TO 7766
+1115 IF (STACK(TOP+7).EQ.3) GOTO 1114
+1116 IF (STACK(TOP+7).EQ.2) GOTO 1114
+ CALL ERROR(112)
+ GOTO 8
+1117 IF (STACK(TOP+7).EQ.4) GOTO 1114
+ CALL ERROR(130)
+ GOTO 8
+1118 IF (STACK(TOP+7).EQ.7) GOTO 1114
+ IF (STACK(TOP+7).EQ.6) GOTO 1114
+ CALL ERROR(129)
+ GOTO 8
+1119 IF (STACK(TOP+7).EQ.6) GOTO 1114
+ IF (STACK(TOP+7).EQ.1) GOTO 1114
+ CALL ERROR(129)
+ GOTO 8
+1120 IF (STACK(TOP+7).EQ.1) GOTO 1114
+ CALL ERROR(129)
+ GOTO 8
+7766 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE E9
+C
+C AUGMENTS THE PROTOTYPE BY THE STARTING PLACE OF THE INTERMEDIATE
+C CODE FOR THE PARSED SYNTACTICAL UNIT
+C
+C STACK(TOP+3) - ENTRY: PROTOTYPE ADDRESS
+C CONT.: ENDUNIT LABEL
+C STACK(TOP+4) - COPY OF THE PROTOTYPE ADRESS
+C
+ IMPLICIT INTEGER(A-Z)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEKST
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+ DIMENSION IPMEM(7890)
+ EQUIVALENCE (SCANER(1),IPMEM(1))
+ DATA SLASTW/28/
+ DATA WLASTW/72/
+
+ GOTO (10,20,30),IN
+10 STACK(TOP+4)=STACK(TOP+3)
+ UNICAL=1
+ NRRE=STACK(TOP+4)
+C PROTOTYPE ADDRESS IS MOVED TO VARIABLE NRRE TO SPARE SOME CODE
+C CHECK IF ANYTHING HAS BEEN SENT TO THE INTERMEDIATE CODE
+ IF (IPMEM(NRRE-3).NE.0) GOTO 15
+ IPMEM(NRRE-3)=RECNR
+ IPMEM(NRRE-2)=POSIT
+15 STACK(TOP+3)=UNICAL
+ UNICAL=UNICAL+1
+ CALL OUTPUT(WFIRST,LN)
+ IF (S.EQ.SBEGIN) CALL SCAN
+ CALL OPTOUT
+ IF (S.EQ.SEND) GOTO 22
+ CALL SLAD(2,9,2)
+ NEXT=8
+ STACK(TOP+7)=5
+ RETURN
+C CALL E8 - INSTRUCTIONS
+C PARAMETER = 5 /AN INSTRUCTION SEQUENCE
+C TERMINATED BY END /
+20 IF (S.NE.SLASTW) GOTO 22
+C LASTWILL OCCURRED - END OF CODE SHOULD BE ASSUMED AND THE PARSING SHOULD
+C CONTINUE. END-LABEL IS TO BE CHANGED!
+ CALL OUTPUT(WLASTW,STACK(TOP+3))
+ CALL OUTPUT(LN,-1)
+ STACK(TOP+3)=UNICAL
+ UNICAL=UNICAL+1
+21 CALL SCAN
+ IF (S.EQ.SCOLON) CALL SCAN
+ CALL SLAD(2,9,3)
+ NEXT=8
+ STACK(TOP+7)=5
+ RETURN
+C CALL E8 TO ANALYSE INSTRUCTIONS AFTER LASTWILL
+30 IF (S.EQ.SLASTW) GOTO 32
+22 CALL OUTPUT(WFIN,STACK(TOP+3))
+ CALL OUTPUT(LN,-1)
+ NEXT = 0
+ RETURN
+32 CALL ERROR(144)
+ GOTO 21
+ END
+
+ SUBROUTINE E10
+ IMPLICIT INTEGER (A-Z)
+C
+C RECOGNIZES SEQUENCE OF DECLARATIONS
+C UPDATES THE PROTOTYPE WHOSE ADDRESS IS PASSED BY
+C BY STACK(TOP+3)
+C CREATES LISTS OF CONSTANTS; FOR ENUMERATION CONSTANTS CREATES DESCRIPTIONS
+C INCLUDING NAMES OF THE CONSTANTS AND THE NUMBERS OF THEIR DECLARATION LINES.
+C STACK(TOP+4) - STACK(TOP+5) - DESCRIBE THE PLACE IN THE INTERMEDIATE
+C CODE IN THE CASE WHEN THE SUBMODULE INSTRUCTIONS HAVE TO BE WRITTEN
+C AFTER AN OCCURRENCE OF ENUMERATION CONSTANTS.
+C N O T E: THE MEANING OF THE PROTOTYPE WORD #-1 IS CHANGED. IT INCLUDES:
+C 0 - THERE ARE NO ENUMERATION CONSTANTS
+C -1 - CONSTANTS ARE WRITTEN INTO, WORKING FILE LEFT OK
+C 1 - THE CONSTANTS ARE FOLLOWED BY THE CODE FOR SUBMODULES
+C
+C
+C-------------------------------------------------------------------
+C CONSTANT LIST ITEM:
+C
+C 0 ! NAME
+C ---+------------------------
+C +1 ! DECL. LINE NUMBERA
+C ---+------------------------
+C +2 ! TYPE NUMBER
+C ---+------------------------
+C +3 ! 0 (ZERO)
+C ---+------------------------
+C +4 ! ADDRESS IN DICTIONARY OR VALUE
+C ---+------------------------
+C +5 ! THE NEXT ITEM
+C ---+------------------------
+C
+C------------------------------------------------------------------------
+C SIGNAL LIST ITEM::
+C
+C ----+-------------------
+C 0 ! KIND
+C ----+-------------------
+C +1 ! LINE NUMBER IN THE SOURCE TEXT
+C ----+-------------------
+C +2 ! NAME
+C ----+-------------------
+C +3 ! THE NEXT ITEM IN THE LIST
+C ----+-------------------
+C +4 ! FORMAL PARAMETER LIST
+C ----+-------------------
+C
+C WHERE KIND =
+C 9 - SIGNAL CONSTRUCTED PROPERLY
+C 10 - SIGNAL WITH A FAULTY PARAMETER LIST
+C
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+cdsw INTEGER IPMEM(1000)
+ dimension ipmem(7890)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEKST
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ EQUIVALENCE (SCANER(1),IPMEM(1))
+ DATA SIGNAL/56/
+ DATA SHANDL/55/
+
+C RECOGNITION OF DECLARATIONS
+ GOTO (10,20,30),IN
+30 CONTINUE
+10 IF (S.EQ.SCONS) GOTO 200
+ IF (S.EQ.SVAR) GOTO 110
+ IF (S.EQ.SUNIT) GOTO 125
+ IF (S.EQ.SIGNAL) GOTO 500
+ IF (S.EQ.SHANDL) GOTO 1000
+ IF (S.EQ.SBEGIN) GOTO 1000
+ IF (S.EQ.SEND) GOTO 1000
+ IF (S.EQ.70) GOTO 1000
+ IF ((S.GT.1).AND.(S.LT.25)) GOTO 1000
+ IF (S.NE.SEMICOL) CALL ERROR(127)
+ IF (S.EQ.SBECOME) GOTO 1000
+15 CALL SCAN
+ GOTO 10
+C CHECK FOR FURTHER CONSTANT DECLARATIONS (COMMA)
+C---------- VARIABLES
+110 I=1
+ J=0
+111 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 112
+ CALL ERROR(109)
+ GOTO 10
+112 J=J+1
+ K=I+J
+ IF (K.GT.132) CALL ERROR(197)
+C THE IDENTIFIER IS APPENDED TO THE LIST OF VARIABLES IN ARRAY COM.
+C THE LIMIT FOR THE LENGTH OF THAT LIST IS 132. EXCEEDING THIS LIMIT
+C CAUSES PARSER ERROR 137.
+ COM(K)=ADRES
+C NOTE: K IS USED ABOVE
+ CALL SCAN
+ IF (S.EQ.SCOMA) GOTO 111
+ IF (S.EQ.SCOLON) GOTO 113
+ CALL ERROR(118)
+ GOTO 10
+113 CALL SCAN
+ CALL ADDVAR(COM(2),J)
+
+C CHECK FOR MORE DECLARATIONS OF VARIABLES (COMMA)
+ IF (S.EQ.SCOMA) GOTO 110
+ IF (S.EQ.SBEGIN) GOTO 1000
+ IF (S.EQ.SEND) GOTO 1000
+ IF (S.EQ.SEMICOL) GOTO 15
+ CALL ERROR(102)
+ GOTO 10
+C---------- SUBMODULE
+125 NRRE=STACK(TOP+3)-1
+ IF (IPMEM(NRRE).GE.0) GOTO 128
+C ENUMERATION CONSTANTS ARE ALREADY WRTITTEN INTO THE INTERMEDIATE CODE
+ IPMEM(NRRE)=1
+ CALL MARK(STACK(TOP+4),STACK(TOP+5))
+128 CALL SLAD(3,10,3)
+ CALL SCAN
+ NEXT=11
+ RETURN
+C CALL E11 - SYNTACTIC UNIT - MODULE
+C RETURN TO THE BEGINNING (JUMP OPTIMIZATION)
+C---------- CONSTANT
+200 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 202
+ CALL ERROR(109)
+ GOTO 10
+202 STACK(TOP+6)=ADRES
+ CALL SCAN
+ IF ((S.EQ.SRELAT).AND.(ADRES.EQ.3)) GOTO 205
+ CALL ERROR(116)
+ GOTO 10
+C "CONST IDENT =" ENCOUNTERED
+205 CALL SCAN
+C RESERVATION OF IPMEM SPACE FOR THE CONSTANT DESCRIPTION
+ LPMF=LPMF-6
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=STACK(TOP+6)
+ IPMEM(LPMF+2)=LN
+ NRRE=STACK(TOP+3)+4
+ IPMEM(LPMF+6)=IPMEM(NRRE)
+ IPMEM(NRRE)=LPMF+1
+C RECOGNITION OF THE TYPE
+ IF (S.EQ.STRUE) GOTO 300
+ IF (S.NE.SCONST) GOTO 300
+ IF (K.EQ.4) GOTO 250
+ IF (K.NE.6) GOTO 300
+C CHARACTER CONSTANT (K=6)
+ IPMEM(LPMF+3)=16
+ GOTO 260
+C TEXT CONSTANT (K=4)
+250 IPMEM(LPMF+3)=48
+260 IPMEM(LPMF+5)=ADRES
+ CALL SCAN
+ GOTO 350
+C EXPRESSION ??
+300 NRRE=STACK(TOP+3)-1
+ IF (IPMEM(NRRE).EQ.0) GOTO 310
+C ANYTHING WRITTEN INTO INTERMEDIATE CODE ?
+ IF (IPMEM(NRRE).EQ.-1) GOTO 325
+C YES BUT A SUBMODULE HAS BEEN WRITTEN
+ CALL FIND(STACK(TOP+4),STACK(TOP+5))
+C THE PLACE IN THE INTERTMEDIATE CODE HAS BEEN FOUND
+ IPMEM(NRRE)=-1
+ GOTO 325
+C THE INITIAL INSTRUCTIONS OF THE INTERMEDIATE CODE
+310 IPMEM(NRRE)=-1
+ IPMEM(NRRE-1)=POSIT
+ IPMEM(NRRE-2)=RECNR
+325 CALL OUTPUT(WINSTREND,LN)
+ CALL OUTPUT(WIDENT,STACK(TOP+6))
+ CALL OUTPUT(WLSE,-1)
+ CALL SLAD(3,10,2)
+ NEXT=12
+ RETURN
+C CALL E12 TO ANALYSE THE EXPRESSION
+20 CALL OUTPUT(WASSCON,-1)
+350 IF (S.EQ.SCOMA) GOTO 200
+ IF (S.EQ.SBEGIN) GOTO 1000
+ IF (S.EQ.SEND) GOTO 1000
+ IF (S.EQ.SEMICOL) GOTO 15
+ CALL ERROR(102)
+ GOTO 10
+1000 NRRE=STACK(TOP+3)-1
+
+ IF (IPMEM(NRRE).LE.0) GOTO 1010
+C SUBMODULES WERE PRECEDED BY ENUMERATION CONSTANTS - THE BEGINNING
+C OF CODE HAS TO BE FOUND
+ CALL FIND(STACK(TOP+4),STACK(TOP+5))
+1010 NEXT=0
+ RETURN
+C---------- SIGNAL DECLARATION
+500 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 505
+ CALL ERROR(109)
+ GOTO 10
+C CREATION OF THE SIGNAL DESCRIPTION
+505 LPMF=LPMF-5
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=9
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=ADRES
+C THE SYNTACTIC FATHER IS APPENDED TO THE LIST OF SIGNALS (PROTOTYPE WORD #4)
+ NRCOR=STACK(TOP+3)-4
+ NRCHAR=IPMEM(NRCOR)
+ IPMEM(NRCOR)=LPMF+1
+ IPMEM(LPMF+4)=NRCHAR
+C THE SIGNAL DESCRIPTION IS CREATED AND APPENDED
+ CALL SCAN
+ IF (S.EQ.SCOMA) GOTO 500
+ IF (S.EQ.SEMICOL) GOTO 15
+ IF (S.EQ.SLEFT) GOTO 508
+ CALL ERROR(102)
+ GOTO 10
+c
+cdsw&bc 508 STACK(TOP+5)=LPMF+1
+c CALL ADDPAR(STACK(TOP+5)+4,STACK(TOP+5))
+508 continue
+ call addpar(lpmf+5, lpmf+1)
+cdsw&bc
+ IF (S.EQ.SRIGHT) GOTO 510
+ CALL ERROR(107)
+ GOTO 10
+510 CALL SCAN
+ IF (S.EQ.SCOMA) GOTO 500
+ IF (S.EQ.SEMICOL) GOTO 15
+ CALL ERROR(102)
+ GOTO 10
+ END
+
--- /dev/null
+C Loglan82 Compiler&Interpreter
+C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
+C Copyright (C) 1993, 1994 LITA, Pau
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details. File: LICENSE.GNU
+C ===============================================================
+
+ SUBROUTINE E11
+ IMPLICIT INTEGER (A-Z)
+C
+C RECOGNIZES SYNTACTICAL UNIT - CREATES THE PROTOTYPE
+C STACK(TOP+3) - ADDRESS OF THE CURRENT PROTOTYPE
+C INITIALLY 1 FOR VIRTUAL, 0 OTHERWISE
+C STACK(TOP+4) - UNIT NAME
+C FOR A BLOCK - ITS PREFIX SEND FROM E8
+C STACK(TOP+5) - PREFIX (IF ONE OCCURRED)
+C STACK(TOP+6) - PROTOTYPE NUMBER
+C
+C----------------------------------------------------------------------
+C PROTOTYPE - STRUCTURE:
+C
+C -5 ! NOT USED
+C ----+------------------------
+C -4 ! SIGNAL LIST
+C ----+------------------------
+C -3 ! INTERMEDIATE CODE BLOCK NUMBER
+C ----+------------------------
+C -2 ! INTERMEDIATE CODE WORD NUMBER IN A BLOCK
+C ----+------------------------
+C -1 ! 0 = NO ENUMERATION CONSTANTS
+C ----+------------------------
+C 0 ! KIND
+C ----+------------------------
+C +1 ! SL - NUMBER IN ISDICT
+C ----+------------------------
+C +2 ! PREFIX - NAME
+C ----+------------------------
+C +3 ! VARIABLE LIST
+C ----+------------------------
+C +4 ! CONSTANT LIST
+C ----+------------------------
+C +5 ! CLASS LIST
+C ----+------------------------
+C +6 ! THE LIST OF BLOCKS, FUNCTIONS AND PROCEDURES
+C ----+------------------------
+C +7 ! TAKEN LIST
+C ----+------------------------
+C +8 ! SYSTEM PREFIX
+C ----+------------------------
+C +9 ! SOURCE TEXT LINE NUMBER
+C ----+------------------------
+C REMAINDER FOR FUNCTIONS, PROCEDURES AND CLASSES
+C ----+------------------------
+C +10 ! NAME
+C ----+------------------------
+C +11 ! FORMAL PARAMETER LIST
+C ----+------------------------
+C REMAINDER FOR FUNCTIONS REMAINDER FOR CLASSES
+C ----+------------------------ ----+-----------------
+C +12 ! NAME OF RESULT TYPE +12 ! HIDDEN LIST
+C ----+------------------------ ----+-----------------
+C +13 ! NUMBER OF ARRAYOF'S +13 ! CLOSE LIST
+C ----+------------------------ ----+-----------------
+C
+C WHERE KIND =
+C 1 - BLOCK
+C 2 - CLASS/COROUTINE/PROCESS
+C 3 - PROCEDURE
+C 4 - FUNCTION
+C 5 - "3" WITH ERRONEOUS PARAMETER LIST
+C 6 - "4" " " " "
+C 7 - "2" " " " "
+C SYSTEM PREFIX =
+C 2 - PROCESS
+C 1 - COROUTINE
+C 0 - OTHER
+C THE SYSTEM PREFIX IS AUGMENTED BY
+C 2**13 - IF INSTRUCTIONS ARE PRESENT
+C 2**14 - FOR SPECIFICATION TAKEN NONE
+C 2**15 - FOR SPECIFICATION VIRTUAL
+C
+C LIST ITEM FOR TAKEN, CLOSE, HIDDEN:
+C
+C 0 ! NAME
+C ---+--------------------------
+C +1 ! OCCURRENCE LINE NUMBER IN THE SOURCE TEXT
+C ---+--------------------------
+C +2 ! THE NEXT ITEM
+C ---+--------------------------
+C
+C SUBMODULE LIST ITEM:
+C
+C 0 ! PROTOTYPE NUMBER IN THE DICTIONARY
+C ---+--------------------------
+C +1 ! THE NEXT ELEMENT
+C
+C
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER (3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ DIMENSION IPMEM(7890)
+ EQUIVALENCE (IPMEM(1),SCANER(1))
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+C NOTE: FOR THE MAIN BLOCK THE ENTRY IS NON-STANDARD - IN=4 JUMP TO
+C LABEL 1
+ LOGICAL BTEST
+ DATA SHANDL/55/
+
+C ORIGINAL GOTO-STATEMENT ***********************************************
+C GOTO (1,200,300,400,0),IN ************************ 03.01.84
+C CHANGED TO ***********************************************
+ GOTO (1,200,300,400,1),IN
+C BECAUSE LABEL 0 IS UNDEFINED ***********************************************
+1 STACK(TOP+3)=0
+ STACK(TOP+5)=0
+ STACK(TOP+6)=ISFIN
+ ISFIN=ISFIN-1
+C CHECK FOR THE MAIN BLOCK (I.E. IF IN = 5)
+ IF (IN.EQ.5) GOTO 1460
+ IF (S.EQ.SBLOCK) GOTO 15
+C UNIT
+ IF (S.NE.SVIRTUAL) GOTO 3
+ STACK(TOP+3)=1
+ CALL SCAN
+3 IF (S.NE.SIDENT) GOTO 3010
+ STACK(TOP+4)=ADRES
+ CALL SCAN
+ GOTO 3030
+C NAME MISSING
+3010 CALL ERROR(109)
+ STACK(TOP+4)=0
+3030 IF (S.NE.SCOLON) GOTO 3050
+ CALL SCAN
+ GOTO 3080
+C COLON MISSING
+3050 CALL ERROR(118)
+3080 IF (S.NE.SIDENT) GOTO 5
+C PREFIX PRESENT
+ STACK(TOP+5)=ADRES
+ CALL SCAN
+C RECOGNITION OF THE UNIT KIND
+5 IF (S.EQ.SFUNCT) GOTO 10
+ IF (S.EQ.SPRCD) GOTO 12
+ IF (S.EQ.SCLASS) GOTO 14
+ IF (S.EQ.SCOROUT) GOTO 16
+ CALL ERROR(119)
+C UNKNOWN KIND
+C IF NAME WAS PRESENT ASSUME PROCEDURE
+ IF (STACK(TOP+4).NE.0) GOTO 12
+207 NEXT=0
+ RETURN
+10 LPMF=LPMF-19
+ IPMEM(LPMF+6)=4
+ GOTO 20
+12 LPMF=LPMF-17
+ IPMEM(LPMF+6)=3
+ GOTO 20
+14 LPMF=LPMF-19
+ IPMEM(LPMF+6)=2
+ IPMEM(LPMF+14)=0
+ GOTO 20
+1460 IF (S.NE.SEMICOL) GOTO 1480
+ CALL SCAN
+ GOTO 1460
+1480 IF (BTEST(C0M(2),14)) GOTO 2795
+15 LPMF=LPMF-15
+ IF (STACK(TOP+1).EQ.10) CALL ERROR(119)
+ IPMEM(LPMF+6)=1
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ STACK(TOP+3)=LPMF+6
+ NEXT=STACK(TOP+3)
+C A LOCAL USAGE OF VARIABLE NEXT
+ IPMEM(NEXT+9)=LN
+ IPMEM(NEXT+2)=STACK(TOP+4)
+C PREFIX SENT FROM E8
+ GOTO 262
+16 LPMF=LPMF-19
+ IPMEM(LPMF+6)=2
+ IPMEM(LPMF+14)=ADRES
+C THE PROTOTYPE IS ALREADY CREATED
+20 CONTINUE
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IF (STACK(TOP+3).EQ.1)
+ * IPMEM(LPMF+14)=IBSET(IPMEM(LPMF+14),15)
+C STARTING FROM THIS POINT STACK(TOP+3)
+C INCLUDES PROTOTYPE ADDRESS
+ STACK(TOP+3)=LPMF+6
+ NEXT=STACK(TOP+3)
+C A LOCAL USAGE OF VARIABLE NEXT
+ IPMEM(NEXT+9)=LN
+ IPMEM(NEXT+10)=STACK(TOP+4)
+ IPMEM(NEXT+2)=STACK(TOP+5)
+ CALL SCAN
+C
+C ANALYSIS OF THE FORMAL PARAMETERS
+C
+ IF (S.NE.SLEFT) GOTO 2050
+ CALL ADDPAR(STACK(TOP+3)+11,STACK(TOP+3))
+ IF (S.EQ.SRIGHT) CALL SCAN
+2050 NEXT=STACK(TOP+3)
+C NEXT LOCAL USAGE OF VARIABLE NEXT
+C JUMP OUT IF NOT A FUNCTION
+ IF (IPMEM(NEXT).NE.4) GOTO 25
+ IF (S.NE.SCOLON) GOTO 2080
+ CALL SCAN
+ GOTO 2090
+C COLON MISSING - ERROR
+2080 CALL ERROR(118)
+2090 STACK(TOP+4)=0
+ IF (S.NE.SARROF) GOTO 22
+21 STACK(TOP+4)=STACK(TOP+4)+1
+ CALL SCAN
+ IF (S.EQ.SARROF) GOTO 21
+C FUNCTION TYPE ?
+22 IPMEM(NEXT+13)=STACK(TOP+4)
+ IF (S.EQ.SINT) IPMEM(NEXT+12)=ADRES*8
+ IF (S.EQ.SCOROUT) IPMEM(NEXT+12)=K
+ IF (S.EQ.SIDENT) IPMEM(NEXT+12)=ADRES
+ IF (IPMEM(NEXT+12).EQ.0) GOTO 2250
+ CALL SCAN
+ GOTO 25
+C TYPE MISSING - ERROR
+2250 CALL ERROR(109)
+25 IF (S.EQ.SEMICOL) GOTO 262
+ CALL ERROR(102)
+C SEMICOLON EXPECTED
+262 NRRE=STACK(TOP+6)
+ IPMEM(NRRE)=NEXT
+C PROTOTYPE ADDRESS IS PUT INTO THE DICTIONARY
+ IN=TOP
+265 IN=STACK(IN)
+C JUMP OUT FOR THE MAIN BLOCK
+ IF (IN.EQ.0) GOTO 275
+ IF (STACK(IN+1).EQ.13) GOTO 266
+ IF (STACK(IN+1).NE.11) GOTO 265
+C AN E11 (SYNTACTIC UNIT) OR E13 (HANDLER) OBJECT BEING THE SYNTACTIC FATHER
+C OF THE CURRENT OBJECT HAS BEEN FOUND WITHIN THE DL-CHAIN.
+C E11 - MOVE PROTOTYPE ADDRESS TO STACK('PERTINENT' TOP + 3)
+ IN = STACK(IN)
+ NRRE = STACK(IN+3)+6
+ GOTO 267
+C E13 - MOVE PROTOTYPE ADDRESS TO STACK('PERTINENT' TOP + 4)
+266 IN=STACK(IN)
+ NRRE = STACK(IN+4)+6
+267 IPMEM(NEXT+1)=STACK(IN+6)
+ LPMF=LPMF-2
+C UPDATE THE SUBMODULE LIST FOR THE FATHER
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IF ((IPMEM(NEXT).EQ.2).OR.(IPMEM(NEXT).EQ.7)) NRRE=NRRE-1
+ IPMEM(LPMF+2)=IPMEM(NRRE)
+ IPMEM(NRRE)=LPMF+1
+ IPMEM(LPMF+1)=STACK(TOP+6)
+ GOTO 285
+275 IPMEM(NEXT+1)=0
+ IF (S.NE.SBLOCK) GOTO 287
+285 CALL SCAN
+287 IF (S.NE.STAKEN) GOTO 35
+ CALL SCAN
+ IF (S.EQ.SEMICOL) GOTO 29
+27 IF (S.NE.SIDENT) GOTO 2805
+ LPMF=LPMF-3
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=ADRES
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=IPMEM(NEXT+7)
+ IPMEM(NEXT+7)=LPMF+1
+ CALL SCAN
+ IF (S.NE.SCOMA) GOTO 28
+ CALL SCAN
+ GOTO 27
+C ADD THE SYSPP SYSTEM PREFIX
+2795 CONTINUE
+ STACK(TOP+3)=LPMF+23
+ STACK(TOP+6)=ISFIN+1
+ CALL SCAN
+ GOTO 36
+28 IF (S.EQ.SEMICOL) GOTO 30
+2805 CALL ERROR(102)
+ GOTO 35
+29 IPMEM(NEXT+8)=IBSET(IPMEM(NEXT+8),14)
+30 CALL SCAN
+35 IF (S.EQ.SCLOSE) GOTO 350
+36 NEXT=STACK(TOP+3)
+ CALL SLAD(4,11,2)
+ STACK(TOP+3)=NEXT
+ NEXT=10
+ RETURN
+C CALL E10 TO ANALYSE THE DECLARATION SEQUENCE
+200 IF (S.EQ.SHANDL) GOTO 380
+203 NEXT=STACK(TOP+3)
+ IF (S.EQ.SBEGIN) GOTO 210
+ IF (S.EQ.SEND) GOTO 212
+ IF (S.LT.1) GOTO 205
+ IF (S.GT.24) GOTO 205
+ CALL ERROR(134)
+ GOTO 210
+205 IF (S.EQ.SBECOME) GOTO 210
+ IF (IPMEM(NEXT-1).EQ.0) GOTO 209
+C ENUMERATION CONSTANTS OCCURRED - END CODE
+ CALL OUTPUT(WFIRST,LN)
+ CALL OUTPUT(WFIN,1)
+ CALL OUTPUT(LN,-1)
+209 CALL ERROR(113)
+ GOTO 207
+210 IPMEM(NEXT+8)=IBSET(IPMEM(NEXT+8),13)
+212 CALL SLAD(4,11,3)
+ STACK(TOP+3)=NEXT
+ NEXT=9
+ RETURN
+C CALL E9 TO ANALYSE THE INSTRUCTION SEQUENCE
+C E9 FILLS UP WORDS -1,-2,-3 FOR THE PROTOTYPE WHOSE
+C ADDRESS IS PASSED THROUGH STACK(TOP+3)
+C
+300 IF (TOP.EQ.1) GOTO 207
+C
+C IF IT WAS THE MAIN BLOCK JUMP OUT TO 207
+C
+ CALL SCAN
+ NEXT=STACK(TOP+3)
+C
+C A LOCAL USAGE OF VARIABLE NEXT - IT INCLUDES THE PROTOTYPE ADDRESS.
+C CHECK IF THE PARSED UNIT WAS A BLOCK. IF SO THEN JUMP OUT AND TERMINATE
+C PARSING. OTHERWISE CHECK WHETHER "END" IS FOLLOWED BY AN IDENTIFIER
+C
+ IF (IPMEM(NEXT).EQ.1) GOTO 207
+ IF (S.NE.SIDENT) GOTO 207
+C
+C "END" IS FOLLOWED BY AN IDENTIFIER. WE HAVE TO CHECK WHETHER
+C IT MATCHES THE IDENTIFIER FROM THE PROTOTYPE.
+C
+ NEXT=NEXT+10
+ IF (ADRES.EQ.IPMEM(NEXT)) GOTO 308
+ CALL ERROR(128)
+ GOTO 207
+C NAME IS OK
+308 CALL SCAN
+ GOTO 207
+3460 CALL ERROR(102)
+ GOTO 3485
+3470 CALL ERROR(109)
+ GOTO 3485
+3480 CALL ERROR(121)
+ CALL SCAN
+C LOOK FOR A REASONABLE SYMBOL
+3485 IF (S.EQ.SBEGIN) GOTO 200
+ IF (S.EQ.SEND) GOTO 212
+ IF (S.EQ.SUNIT) GOTO 35
+ IF (S.EQ.SVAR) GOTO 35
+ IF (S.EQ.SCONS) GOTO 35
+ IF (S.EQ.SCLOSE) GOTO 350
+ IF (S.EQ.70) GOTO 207
+ IF (S.EQ.1) GOTO 3488
+ IF (S.LT.25) GOTO 200
+3488 CALL SCAN
+ GOTO 3485
+350 NRRE=STACK(TOP+3)
+ IF ((IPMEM(NRRE).NE.2).AND.(IPMEM(NRRE).NE.7)) GOTO 3480
+351 STACK(TOP+4)=ADRES
+ CALL SCAN
+ IF (S.NE.SCLOSE) GOTO 355
+ IF (ADRES.EQ.STACK(TOP+4)) CALL ERROR(120)
+ GOTO 365
+C HIDDEN OR PROTECTED ENCOUNTERED
+355 IF (S.NE.SIDENT) GOTO 3470
+ LPMF=LPMF-3
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=ADRES
+ IPMEM(LPMF+2)=LN
+ NEXT=STACK(TOP+3)+STACK(TOP+4)+11
+ IPMEM(LPMF+3)=IPMEM(NEXT)
+ IPMEM(NEXT)=LPMF+1
+ CALL SCAN
+ IF (S.EQ.SEMICOL) GOTO 30
+ IF (S.NE.SCOMA) GOTO 3460
+ CALL SCAN
+ GOTO 355
+C HIDDEN PROTECTED ENCOUNTERED
+365 CALL SCAN
+ IF (S.NE.SIDENT) GOTO 3470
+ LPMF=LPMF-6
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=ADRES
+ IPMEM(LPMF+4)=ADRES
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+5)=LN
+ NEXT=STACK(TOP+3)+12
+ IPMEM(LPMF+3)=IPMEM(NEXT)
+ IPMEM(NEXT)=LPMF+1
+ IPMEM(LPMF+6)=IPMEM(NEXT+1)
+ IPMEM(NEXT+1)=LPMF+4
+ CALL SCAN
+ IF (S.EQ.SEMICOL) GOTO 30
+ IF (S.NE.SCOMA) GOTO 3460
+ GOTO 365
+C HANDLER ENCOUNTERED
+380 NEXT=STACK(TOP+3)
+C PROTOTYPE ADDRESS IS SAVED
+ IF (IPMEM(NEXT-1).NE.0) CALL MARK(STACK(TOP+4),STACK(TOP+5))
+ CALL SLAD(4,11,4)
+ NEXT=13
+ RETURN
+C CALL E13 TO ANALYSE THE HANDLER
+400 NEXT=STACK(TOP+3)
+ IF (IPMEM(NEXT-1).NE.0) CALL FIND(STACK(TOP+4),STACK(TOP+5))
+ CALL SCAN
+C SKIP THE SEQUENCE "END HANDLERS(;)"
+C END HANDLERS (;)
+ IF (S.EQ.SHANDL) CALL SCAN
+ IF (S.EQ.SEMICOL) CALL SCAN
+ GOTO 203
+ END
+
+ SUBROUTINE E12
+ IMPLICIT INTEGER (A-Z)
+C
+C RECOGNIZES BOOLEAN EXPRESSIONS BUILT UP OF CONSTANTS
+C
+C LOCAL VARIABLES:
+C STACK(TOP+3) - INCLUDES 1 WHEN "AND" IS TO BE WRITTEN
+C STACK(TOP+4) - ........ 1 .... "OR" .. .. .. .......
+C STACK(TOP+5) - ........ 1 .... "NOT" .. .. .. .......
+C STACK(TOP+6) - INCLUDES RELATION CODE (SOMETIMES)
+C
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ GOTO (10,20,30),IN
+10 STACK(TOP+3)=0
+ STACK(TOP+4)=0
+ STACK(TOP+5)=0
+80 IF (S.NE.SNOT) GOTO 100
+C NOT OCCURRED
+ STACK(TOP+5)=1
+85 CALL SCAN
+C MAIN LOOP
+100 IF (S.EQ.STRUE) GOTO 130
+C THERE SHOULD BE AN IDENTIFIER
+ CALL SLAD(4,12,2)
+ NEXT=7
+ RETURN
+C CALL E7 - TO ANALYSE ARITHEXPRESSION
+20 IF (S.NE.SRELAT) GOTO 200
+C '=' OCCURRED (OR SOMETHING ALIKE)
+C IT SHOULD BE STORED IN STACK (TOP+6)
+115 STACK(TOP+6)=ADRES
+ CALL SCAN
+ CALL SLAD(4,12,3)
+ NEXT=7
+ RETURN
+C ARTITHEXPRESSION CALLED AGAIN
+30 CALL OUTPUT(WOPERAT,STACK(TOP+6))
+ GOTO 200
+C LOGICAL CONSTANT
+130 CALL OUTPUT(WCNSTB,-1)
+ CALL OUTPUT(1-ADRES,-1)
+C END OF MAIN LOOP
+195 CALL SCAN
+200 IF (STACK(TOP+5).EQ.0) GOTO 205
+ CALL OUTPUT(WNOT,-1)
+ STACK(TOP+5)=0
+205 IF (STACK(TOP+3).EQ.0) GOTO 210
+ CALL OUTPUT(WAND,-1)
+ STACK(TOP+3)=0
+210 IF (S.NE.SAND) GOTO 220
+ STACK(TOP+3)=1
+ CALL SCAN
+ GOTO 80
+220 IF (STACK(TOP+4).EQ.0) GOTO 230
+ CALL OUTPUT(WOR,-1)
+ STACK(TOP+4)=0
+230 IF (S.NE.SOR) GOTO 1000
+ STACK(TOP+4)=1
+ CALL SCAN
+ GOTO 80
+1000 NEXT=0
+ RETURN
+ END
+
+ SUBROUTINE E13
+ IMPLICIT INTEGER (A-Z)
+C RECOGNIZES HANDLER, BUILDS UP ITS PROTOTYPE
+C LOKAL VARIABLES:
+C STACK(TOP+3) - END-OF-CODE LABEL
+C STACK(TOP+4) - HANDLER PROTOTYPE ADDRESS
+C STACK(TOP+5) - INCLUDES 1 IF "OTHERS" OCCURRED
+C STACK(TOP+6) - PROTOTYPE NUMBER
+C THE FOLLOWING BLANK-COMMON VARIABLES ARE USED AS LOCAL ONES:
+C NRCHAR - HEAD OF THE CREATED LIST OF NAMES
+C NRCOR
+C NRRE
+C NRBLUS
+C
+C----------------------------------------------------------------------
+C HANDLER PROTOTYPE:
+C
+C ----+-------------------
+C -5 ! NOT USED
+C ----+-------------------
+C -4 ! NOT USED
+C ----+-------------------
+C -3 ! SCRATCH FILE CODE RECORD NUMBER
+C ----+-------------------
+C -2 ! NUMBER OF WORD IN THE CODE RECORD
+C ----+-------------------
+C -1 ! NOT USED
+C ----+-------------------
+C 0 ! KIND = 8
+C ----+-------------------
+C +1 ! SL - NUMBER IN ISDICT
+C ----+-------------------
+C +2 ! NOT USED
+C ----+-------------------
+C +3 ! NOT USED
+C ----+-------------------
+C +4 ! NOT USED
+C ----+-------------------
+C +5 ! NOT USED
+C ----+-------------------
+C +6 ! SUBBLOCK LIST
+C ----+-------------------
+C +7 ! NOT USED
+C ----+-------------------
+C +8 ! NOT USED
+C ----+-------------------
+C +9 ! SOURCE TEXT LINE NUMBER
+C ----+-------------------
+C +10 ! LIST OF NAMES
+C ----+-------------------
+C
+C NAME LIST ITEM:
+C
+C ----+-------------------
+C 0 ! NAME
+C ----+-------------------
+C +1 ! NEXT ITEM POINTER
+C ----+-------------------
+C
+C NOTE ! EMPTY LIST OF NAMES CORRESPONDS TO THE PROTOTYPE OF A HANDLER
+C FOR "OTHERS"
+C
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEKST
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ DIMENSION IPMEM(1000)
+ EQUIVALENCE (IPMEM(1),SCANER(1))
+cdsw EQUIVALENCE (AUX,SCANER(3698))
+ EQUIVALENCE (AUX,SCANER(8698))
+ EQUIVALENCE (WSTART,WUNLOCK)
+ DATA SOTHRS/57/
+
+ GOTO (10,20),IN
+10 NRCHAR=0
+ STACK(TOP+5)=0
+ CALL SCAN
+ IF (S.EQ.SWHEN) GOTO 100
+ IF (S.EQ.SOTHRS) GOTO 200
+ CALL ERROR(132)
+90 NEXT=0
+ RETURN
+C IS THERE AN IDENTIFIER?
+100 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 110
+ CALL ERROR(108)
+ GOTO 90
+C THERE IS
+110 LPMF=LPMF-2
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+C CREATE AN ENTRY TO THE NAME LIST
+ IPMEM(LPMF+2)=NRCHAR
+ NRCHAR=LPMF+1
+ IPMEM(NRCHAR)=ADRES
+ CALL SCAN
+C END OF LIST?
+ IF (S.EQ.SCOLON) GOTO 118
+C CONTINUATION?
+ IF (S.EQ.SCOMA) GOTO 100
+C NONE OF ABOVE - ERROR
+ CALL ERROR(118)
+ GOTO 90
+118 CALL SCAN
+120 LPMF=LPMF-17
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+C SLOT FOR THE PROTOTYPE AND HANDLER
+C DESCRIPTION FOR THE SYNTACTIC FATHER
+ NRCOR=LPMF+7
+ STACK(TOP+4)=NRCOR
+ STACK(TOP+6)=ISFIN
+ IPMEM(ISFIN)=NRCOR
+ ISFIN=ISFIN-1
+ IPMEM(NRCOR+ 0)=8
+ IPMEM(NRCOR+ 9)=LN
+ IPMEM(NRCOR+10)=NRCHAR
+C UPDATE FATHER'S SUBMODULE LIST
+ NRRE=STACK(TOP)
+ IPMEM(NRCOR+ 1)=STACK(NRRE+6)
+ NRBLUS=STACK(NRRE+3)
+ IPMEM(LPMF+1)=STACK(TOP+6)
+ IPMEM(LPMF+2)=IPMEM(NRBLUS+6)
+ IPMEM(NRBLUS+6)=LPMF+1
+C PREPARE THE INTERMEDIATE CODE
+ IPMEM(NRCOR- 2)= POSIT
+ IPMEM(NRCOR- 3)= RECNR
+ CALL OUTPUT(WFIRST,LN)
+ CALL OPTOUT
+ UNICAL=2
+ STACK(TOP+3)=1
+ CALL SLAD(4,13,2)
+ NEXT=8
+ STACK(TOP+7)=1
+ RETURN
+C CALL E8 TO ANALYSE STATEMENT-LIST
+C PARAMETER = 1
+20 CALL OUTPUT(WFIN,STACK(TOP+3))
+ CALL OUTPUT(LN,-1)
+ NRCHAR=0
+ IF (S.EQ.SWHEN) GOTO 100
+ IF (S.EQ.SOTHRS) GOTO 200
+ IF (S.EQ.SEND) GOTO 90
+C WRONG END OF HANDLER
+ CALL ERROR(142)
+ GOTO 90
+C OTHERS OCCURRED
+200 IF (STACK(TOP+5).NE.0) CALL ERROR(129)
+ STACK(TOP+5)=1
+ CALL SCAN
+ IF (S.EQ.SCOLON) CALL SCAN
+ GOTO 120
+ END
+
+ INTEGER FUNCTION EXYT(K,L)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ com(9037), top, in, next, stack(500), reszta(3652)
+C
+C THIS FUNCTION RETURNS THE NUMBER OF THE PERTINENT LABEL
+C DEPENDING ON THE VALUE OF THE SECOND PARAMETER, WE CHOOSE
+C THE STARTING LOOP LABEL /FOR L = 0/ OR THE ENDING ONE /L=1/
+C
+ Z=TOP
+ A=K
+ GOTO 2
+1 Z=STACK(Z)
+2 IF (STACK(Z+1).EQ.8) GOTO 10
+ IF (STACK(Z+1).EQ.13) GOTO 3
+ IF (STACK(Z+1).NE.9) GOTO 1
+C
+C EXIT IS MADE TO THE END OF THE SYNTACTIC UNIT (E9)
+C OR HANDLER (E13)
+C
+3 IF (A.GT.1) CALL ERROR(110)
+ IF (L.EQ.0) CALL ERROR(138)
+ Z=STACK(Z)
+ EXYT=STACK(Z+3)
+ RETURN
+C
+C DO . . . OD - TYPE LOOP DETECTED
+C
+10 IF (STACK(Z+2).EQ.13) GOTO 15
+ IF (STACK(Z+2).EQ.7) GOTO 15
+ IF (STACK(Z+2).NE.25) GOTO 1
+15 CONTINUE
+C
+C FOR... AND WHILE... ARE ALSO ADMITTED..
+C
+ A=A-1
+ IF (A.GT.0) GOTO 1
+C JUMP OUT IF THE NUMBER OF LOOPS IS LESS THAN THE NUMBER OF
+C EXITS
+ Z=STACK(Z)
+ A=Z+L+3
+ EXYT=STACK(A)
+ RETURN
+ END
+
+ SUBROUTINE MARK(A,B)
+ IMPLICIT INTEGER(A-Z)
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEXT
+C
+C MARKS THE CURRENT LOCATION OF THE SCRATCH FILE
+C MEANING OF PARAMETERS (EXIT ONLY):
+C A - RECORD NUMBER
+C B - POSITION (WORD NUMBER) IN THE RECORD
+C
+ A=RECNR
+ B=POSIT
+ CALL PUT(BUF,BUFOUT)
+ IF (RECNR.NE.NEXT-1) CALL SEEK(BUF,NEXT)
+ RECNR=NEXT
+ NEXT=NEXT+1
+ POSIT=1
+ RETURN
+ END
+
+ SUBROUTINE FIND (A,B)
+ IMPLICIT INTEGER (A-Z)
+C
+C THIS PROCEDURE RESETS THE POSITION OF THE SCRATCH FILE ACCORDING TO
+C THE PARAMETERS: A - RECORD NUMBER
+C B - WORD NUMBER
+C
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEXT
+ CALL PUT(BUF,BUFOUT)
+ CALL SEEK(BUF,A)
+ CALL GET(BUF,BUFOUT)
+ CALL SEEK(BUF,A)
+ RECNR=A
+ POSIT=B
+ RETURN
+ END
+
+ SUBROUTINE OPTOUT
+ IMPLICIT INTEGER(A-Z)
+C WRITES TO THE INTERMEDIATE CODE INFORMATION ABOUT ALL OPTIONS
+C (WORD C0M(2)) WITHOUT L-OPTION. CLEARS AUX.
+ COMMON /BLANK/ c0m(4), blank0(121), wopt, blank1(8873), aux
+
+ DO 100 I=2,8
+ CALL OUTPUT(WOPT,I*(-1+2*IAND(1,ISHFT(C0M(2),2-I))))
+100 CONTINUE
+ AUX=0
+ RETURN
+ END
+
+ SUBROUTINE SELOPT
+ IMPLICIT INTEGER (A-Z)
+C WRITES TO THE INTERMEDIATE CODE INFORMATIONS ABOUT ALL OPTIONS FOR WHICH
+C THE CORRESPONDING BITS IN WORD AUX ARE SET.
+C CLEARS AUX.
+ COMMON /BLANK/ C0M(4),BLANK0(121),WOPT,BLANK1(8873),AUX
+
+ LOGICAL BTEST
+ DO 100 I=2,8
+ IF (BTEST(AUX,I-2))
+ X CALL OUTPUT(WOPT,I*(-1+2*IAND(1,ISHFT(C0M(2),2-I))))
+100 CONTINUE
+ AUX=0
+ RETURN
+ END
+
+ SUBROUTINE OUTPUT(A,B)
+ IMPLICIT INTEGER (A-Z)
+C
+C WRITES INTERMEDIATE CODE TO THE SCRATCH FILE
+C
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEXT
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
+ IF (B.NE.-1) GOTO 100
+ BUFOUT(POSIT)=A
+ IF (POSIT.EQ.255) GOTO 50
+ POSIT=POSIT+1
+ RETURN
+50 BUFOUT(256)=NEXT
+ POSIT=1
+ CALL PUT(BUF,BUFOUT)
+ IF (RECNR.NE.NEXT-1) CALL SEEK(BUF,NEXT)
+ RECNR=NEXT
+ NEXT=NEXT+1
+ RETURN
+100 IF (POSIT.LT.255) GOTO 150
+ BUFOUT(255)=A
+ BUFOUT(256)=NEXT
+ POSIT=2
+ CALL PUT(BUF,BUFOUT)
+ IF (RECNR.NE.NEXT-1) CALL SEEK(BUF,NEXT)
+ RECNR=NEXT
+ NEXT=NEXT+1
+ BUFOUT(1)=B
+ RETURN
+150 BUFOUT(POSIT)=A
+ BUFOUT(POSIT+1)=B
+ POSIT=POSIT+2
+ IF (POSIT.EQ.256) GOTO 50
+ RETURN
+ END
+
+ SUBROUTINE END
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ COM(278),
+ X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
+ X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
+ X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
+ X LOCAL , OWN , OBJECT,
+ X IPMEM(7890)
+ LOGICAL INSYS, LOCAL, OWN
+C IPMEM - MAIN MEMORY
+C LPML - ADDRESS OF THE FIRST -
+C LPMF - ADDRESS OF THE LAST - FREE WORD IN IPMEM
+C ISFIN - TOP OF THE PROTOTYPE DICTIONARY STACK
+C LPMEM - DIVISION POINT FOR IPMEM
+ COMMON /LISTING/ OUTSTR(265)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEXT
+ LOGICAL ERRFLG
+CPS character auxc(4)
+CPS equivalence (auxc(1), aux)
+CPS data aux /-1/
+ character int2char
+
+ IPMEM(ISFIN-1)=LPMF-LPML+1
+ NATTR=ISFIN-1
+10 NATTR=NATTR-1
+ IF (IPMEM(NATTR).EQ.0) GOTO 10
+cdsw IPMEM(ISFIN)=NATTR-3738
+ IPMEM(ISFIN)=NATTR-8738
+ ISFIN=ISFIN+1
+ LPMEM=LPMEM-1
+ IRECN=LPML-1
+ IF (LPMF.EQ.LMEM) CALL ERROR(191)
+ NATTR=IPMEM(LPMEM)
+C CHECK IF THE PROTOTYPE DICTIONARY INCLUDES ANY ADDRESS
+C OR IF THE FIRST PROTOTYPE IS BUILT CORRECTLY
+ IF (IPMEM(LPMEM).EQ.0) CALL ERROR(191)
+ IF (IPMEM(NATTR).EQ.0) CALL ERROR(191)
+cdsw CALL CLOSF(OUTSTR)
+cdsw CALL CLOSF(INSTR)
+ CALL PUT(BUF,BUFOUT(1))
+ COM(2)=NEXT
+ IF (ERRFLG) GOTO 1
+cdsw znacznik konca stringow
+cbc WRITE(15) -1
+ call ffwrite_ints( 15, -1, 1 )
+cbc
+1 CONTINUE
+c end of file 16
+ call ffwrite_char(16, int2char(26))
+C --- MPTBUF SEEMS NOT NECESSARY IN THE 'ONE-OVERLAY' VERSION
+C CALL MPTBUF
+ RETURN
+ END
+
+ SUBROUTINE SLAD(NROFVAR,NR,MIEJSCE)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /BLANK/ COM(9037), TOP, IN, NEXT, STACK(500), RESZTA(3652)
+C PREPARES STACK FOR CALL OF ANOTHER PROCEDURE
+C PARAMETERS:
+C NROFVAR - NUMBER OF THE LOCAL VARIABLES ALLOCATED ON THE STACK
+C NR - NUMBER OF THE CALLING PROCEDURE
+C SLAD - NUMBER OF THE RETURN POINT
+ EQUIVALENCE(COM(282),ISFIN)
+cdsw IF (TOP+3748.GT.ISFIN) CALL ERROR(198)
+ IF (TOP+8748.GT.ISFIN) CALL ERROR(198)
+C CHECK IF THE STACK ISN'T TOO LONG
+ Z=TOP
+ TOP=TOP+NROFVAR+3
+ STACK(TOP)=Z
+ STACK(TOP+1)=NR
+ STACK(TOP+2)=MIEJSCE
+ IN=1
+ RETURN
+ END
+
+ SUBROUTINE ADDPAR(LHEAD,MFIELD)
+ IMPLICIT INTEGER (A-Z)
+C
+C APPENDS PARAMETERS TO THE CREATED PROTOTYPE
+C PARAMETERS: LHEAD - BEGINNING OF THE PARAMETER LIST
+C MFIELD - ADDRESS OF THE PLACE TO BE CHANGED IN CASE OF
+C ERRONEOUS LIST
+C MODIFICATION FUNCTION:
+C CONVERT: [1..10] ------> [1,7,5,6,5,6,7,8,10,10]
+C THE FOLLOWING BLANK-COMMON VARIABLES ARE USED:
+C OBJECT - LAST ELEMENT ON THE PARAMETER LIST (LINK FIELD)
+C KIND - A LOCAL VARIABLE
+C NRRE - COUNTS NUMBER OF OCCURRENCES OF ARRAYOF'S
+C NATTR - KEEPS THE RECOGNIZED TYPE
+C NRCHR - A LOCAL VARIABLE (LOOP LIMIT)
+C NRCOR - AS ABOVE
+C NRTEXT - SAVES THE VALUE OF VARIABLE OBJECT
+C NRPROC - ADDRESS OF THE PLACE TO BE WVERWRITTEN
+C NBLUS - ANALYSIS LEVEL 1 - PARAMETER LIST
+C 2 - SIMPLIFIED LIST
+C---------------------------------------------------------------------
+C ITEM OF THE FORMAL PARAMETER LIST:
+C
+C 0 ! KIND
+C ---+------------------
+C -1 ! SOURCE TEXT LINE NUMBER
+C +--+------------------
+C -2 ! NAME
+C +--+------------------
+C +3 ! NEXT ITEM INDEX
+C REMAINDER FOR VARIABLES FOR PROCEDURES AND FUNCTIONS
+C ---+------------------------------------------------------------
+C +4 ! TYPE NUMBER ! +4 ! FORMAL PARAMETER LIST
+C ---+-----------------------+------------------------------------
+C +5 ! ARRAYOF COUNT ! +5 ! TYPE NAME (KIND = FUNCTION)
+C ----+------------------------------------
+C +6 ! NUMBER OF ARRAYOF'S (KIND = FUNCTION)
+C WHERE KIND:
+C 3 - PROCEDURE
+C 4 - FUNCTION
+C 5 - PROCEDURE WITH ERRONEOUS PARAMETER LIST
+C 6 - FUNCTION " " " "
+C 7 - TYPE
+C 8 - VARIABLE "INPUT"
+C 9 - VARIABLE "OUTPUT"
+C 10 - VARIABLE "INOUT"
+C
+ DIMENSION CONVERT(10)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ DIMENSION IPMEM(7890)
+ EQUIVALENCE (IPMEM(1),SCANER(1))
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ DATA CONVERT/1,7,5,6,5,6,7,8,10,10/
+
+ OBJECT=LHEAD
+ NBLUS=1
+10 CALL SCAN
+11 IF (S.EQ.SINPUT) GOTO 100
+ IF (S.EQ.SIDENT) GOTO 150
+ IF (S.EQ.STYPE) GOTO 300
+ IF (S.EQ.SFUNCT) GOTO 400
+ IF (S.EQ.SPRCD) GOTO 500
+C NO KEYWORDS HAVE BEEN FOUND WHICH COULD PROPERLY START THE PARAMETER LIST
+C NOW WE SHOULD FIND A PERTINENT DELIMITER-SYMBOL TO CONTINUE ANALYSIS
+C THE PROTOTYPE IS ALSO TO BE CHANGED
+ CALL ERROR(107)
+C LOCAL USAGE OF VARIABLES NRCHAR
+C AND NRCOR (CODE OPTIMIZATION)
+80 NRCHAR=MFIELD
+ NRCOR=IPMEM(NRCHAR)
+ IPMEM(NRCHAR)=CONVERT(NRCOR)
+81 IF (S.LT.25) GOTO 90
+ IF (S.EQ.SBECOME) GOTO 90
+ IF (S.EQ.SRIGHT) GOTO (90,550),NBLUS
+ IF (S.EQ.SEND) GOTO 90
+ IF (S.EQ.SBEGIN) GOTO 90
+ IF (S.EQ.SCONS) GOTO 90
+ IF (S.EQ.SUNIT) GOTO 90
+ IF (S.EQ.STAKEN) GOTO 90
+ IF (S.EQ.SCLOSE) GOTO 90
+ IF (S.EQ.SEOF) GOTO 90
+ IF (S.EQ.SINPUT) GOTO 100
+ IF (S.EQ.STYPE) GOTO 300
+ IF (S.EQ.SFUNCT) GOTO (400,600),NBLUS
+ IF (S.EQ.SPRCD) GOTO (500,700),NBLUS
+ IF (S.EQ.SRELAT) GOTO 90
+ IF (S.EQ.SAND) GOTO 90
+ CALL SCAN
+ GOTO 81
+CPS 85 CALL SCAN
+90 RETURN
+100 KIND=7+ADRES
+C KIND INCLUDES 8 - INPUT
+C 9 - OUTPUT
+C 10 - INOUT
+ GOTO 210
+150 KIND=8
+ J=1
+ GOTO 222
+210 J=1
+220 CALL SCAN
+222 J=J+1
+ IF (J.GT.132) CALL ERROR(197)
+ IF (S.EQ.SIDENT) GOTO 225
+ CALL ERROR(109)
+C ERROR IN SPECIFICATION OF INPUT/OUTPUT-TYPE PARAMETERS
+C THE TYPE OF THE VARIABLES IS UNDEFINED
+ COM(J)=0
+ NRRE=0
+ NATTR=0
+ GOTO 255
+225 COM(J)=ADRES
+ CALL SCAN
+ IF (S.EQ.SCOMA) GOTO 220
+ IF (S.EQ.SCOLON) GOTO 230
+ CALL ERROR(118)
+ GOTO 11
+230 NRRE=0
+240 CALL SCAN
+ IF (S.NE.SARROF) GOTO 250
+ NRRE=NRRE+1
+ GOTO 240
+250 NATTR=0
+ IF (S.EQ.SCOROUT) NATTR=K
+ IF (S.EQ.SINT) NATTR=ADRES*8
+ IF (S.EQ.SIDENT) NATTR=ADRES
+ IF (NATTR.EQ.0) CALL ERROR(109)
+255 NRCHAR=2
+ NRCOR=J
+ DO 260 J=NRCHAR,NRCOR
+ LPMF=LPMF-6
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=KIND
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=COM(J)
+ IPMEM(OBJECT)=LPMF+1
+ OBJECT=LPMF+4
+ IPMEM(LPMF+5)=NATTR
+ IPMEM(LPMF+6)=NRRE
+260 CONTINUE
+ IF (NATTR.EQ.0) GOTO 80
+ CALL SCAN
+ IF (S.EQ.SCOMA) GOTO 210
+ IF (S.EQ.SEMICOL) GOTO (10,541),NBLUS
+ IF (S.EQ.SRIGHT) GOTO (90,550),NBLUS
+ CALL ERROR(102)
+ GOTO (80,545),NBLUS
+300 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 310
+ CALL ERROR(109)
+ GOTO (80,545),NBLUS
+310 LPMF=LPMF-4
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=7
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=ADRES
+ IPMEM(OBJECT)=LPMF+1
+ OBJECT=LPMF+4
+ CALL SCAN
+ IF (S.EQ.SEMICOL) GOTO (10,541),NBLUS
+ IF (S.EQ.SRIGHT) GOTO (90,550),NBLUS
+ IF (S.EQ.SCOMA) GOTO 320
+ CALL ERROR(107)
+ GOTO (80,545),NBLUS
+320 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 310
+ CALL ERROR(109)
+ GOTO (80,545),NBLUS
+400 KIND=4
+ GOTO 510
+500 KIND=3
+510 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 520
+ CALL ERROR(109)
+ GOTO 80
+520 LPMF=LPMF+2*KIND-15
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=KIND
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=ADRES
+ IPMEM(OBJECT)=LPMF+1
+ OBJECT=LPMF+4
+ CALL SCAN
+ NRPROC=LPMF
+C THE POINTER TO THE CURRENT ELEMENT OF THE PARAMETER LIST IS SAVED
+ IF (S.EQ.SLEFT) GOTO 540
+ IF (KIND.EQ.4) GOTO 530
+ IF (S.EQ.SEMICOL) GOTO 10
+ IF (S.EQ.SRIGHT) RETURN
+ CALL ERROR(107)
+ GOTO 80
+530 NRRE=0
+ IF (S.EQ.SCOLON) GOTO 531
+ CALL ERROR(118)
+ GOTO 535
+531 CALL SCAN
+ IF (S.NE.SARROF) GOTO 535
+ NRRE=NRRE+1
+ GOTO 531
+535 NATTR=0
+ IF (S.EQ.SCOROUT) NATTR=K
+ IF (S.EQ.SINT) NATTR=ADRES*8
+ IF (S.EQ.SIDENT) NATTR=ADRES
+ IPMEM(NRPROC+6)=NATTR
+ IPMEM(NRPROC+7)=NRRE
+ IF (NATTR.EQ.0) GOTO 537
+ CALL SCAN
+ GOTO 538
+537 CALL ERROR(109)
+ GOTO 80
+538 IF (S.EQ.SRIGHT) RETURN
+ IF (S.EQ.SEMICOL) GOTO 10
+ CALL ERROR(107)
+ GOTO 80
+540 NRTEXT=OBJECT
+ OBJECT=OBJECT+1
+ NBLUS=2
+541 CALL SCAN
+ IF (S.EQ.SINPUT) GOTO 100
+ IF (S.EQ.SIDENT) GOTO 150
+ IF (S.EQ.STYPE) GOTO 300
+ IF (S.EQ.SFUNCT) GOTO 600
+ IF (S.EQ.SPRCD) GOTO 700
+ IF (S.EQ.SRIGHT) GOTO 550
+ CALL ERROR(107)
+545 IF (IPMEM(NRPROC+1).LT.5) IPMEM(NRPROC+1)=IPMEM(NRPROC+1)+2
+C ERRONEOUS PARAMETER LIST. WE SHOULD FIND A SYMBOL WHICH WOULD
+C ALLOW FOR A FURTHER (REASONABLE) ANALYSIS OF THE SOURCE TEXT.
+C THE SEARCHING IS COMMON FOR BOTH PARAMETER LEVELS.
+ GOTO 80
+550 NBLUS=1
+ OBJECT=NRTEXT
+ CALL SCAN
+ IF (IPMEM(OBJECT-3).EQ.4) GOTO 530
+ IF (S.EQ.SEMICOL) GOTO 10
+ IF (S.EQ.SRIGHT) RETURN
+ CALL ERROR(107)
+ GOTO 80
+600 KIND=4
+ GOTO 710
+700 KIND=3
+710 CALL SCAN
+ IF (S.EQ.SIDENT) GOTO 720
+ CALL ERROR(109)
+ GOTO 545
+720 LPMF=LPMF-4
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+ IPMEM(LPMF+1)=KIND
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=ADRES
+ IPMEM(OBJECT)=LPMF+1
+ OBJECT=LPMF+4
+ CALL SCAN
+ IF (S.EQ.SRIGHT) GOTO 550
+ IF (S.EQ.SEMICOL) GOTO 541
+ CALL ERROR(107)
+ GOTO 545
+ END
+
+ SUBROUTINE ADDVAR(SKAD,ILE)
+ IMPLICIT INTEGER (A-Z)
+C
+C APPENDS THE LIST OF VARIABLES TO THE LIST IN THE PROTOTYPE
+C RECOGNIZES TYPES OF VARIABLES
+C STACK(TOP+3) - PROTOTYPE ADDRESS
+C
+C ILE - LENGTH OF THE LIST OF VARIABLES
+C SKAD - BEGINNING OF THE LIST - VARIABLES ARE LOCATED IN CONSECUTIVE
+C WORDS
+C
+C--------------------------------------------------------------------
+C VARIABLE LIST ITEM:
+C 0 ! NAME OF THE VARIABLE
+C ---+------------------------
+C +1 ! DECLARATION LINE NUMBER IN THE SOURCE TEXT
+C ---+------------------------
+C +2 ! TYPE NAME
+C ---+------------------------
+C +3 ! NUMBER OF ARRAYOF'S
+C ---+------------------------
+C +4 ! NEXT ITEM POINTER
+C
+ DIMENSION SKAD(2)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /BLANK/
+ $ C0M(4),
+ O S, ADRES, K, SCOMA, SDOT, SEMICOL,
+ 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
+ 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
+ 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
+ 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
+ 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
+ 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
+ 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
+ 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
+ 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
+ O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
+ A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
+ B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
+ C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
+ D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
+ E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
+ F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
+ G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
+
+ common /BLANK/
+ H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
+ I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
+ J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
+ K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
+ L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
+ M WRITE, WRITELN, WBOUND, UNICAL,
+ N COM(132),
+ O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
+ P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
+ Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
+ R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
+ $ scaner(8735)
+cdsw $ SCANER(3735),
+ common /BLANK/
+ Z TOP, IN, NEXT, STACK(500),
+ * RESZTA(3652)
+
+ DIMENSION IPMEM(7890)
+ EQUIVALENCE (SCANER(1),IPMEM(1))
+ EQUIVALENCE (SOUTPUT,SEMAPH)
+
+C VARIABLE ARR COUNTS THE NUMBER OF ARRAYOF'S ENCOUNTERED
+ ARR=0
+ IF (S.NE.SARROF) GOTO 2
+1 ARR=ARR+1
+ CALL SCAN
+ IF (S.EQ.SARROF) GOTO 1
+C TYPE OF THE VARIABLE IS RECOGNIZED
+2 IF (S.EQ.SINT) GOTO 10
+ IF (S.EQ.SCOROUT) GOTO 8
+ IF (S.EQ.SIDENT) GOTO 6
+ IF (S.EQ.SEMAPH) GOTO 4
+C ERROR IN DECLARATION - UNIVERSAL TYPE (0) IS ASSUMED
+ ADRES=0
+ CALL ERROR(109)
+4 KIND=32
+ IF (ARR.EQ.0) GOTO 90
+ ARR=0
+ CALL ERROR(141)
+ GOTO 90
+6 KIND=ADRES
+ GOTO 90
+8 KIND=K
+C COROUTINE / PROCESS ARE TREATED AS IDENTIFIERS
+C VARIABLE K INCLUDES HASH TABLE ADDRESS
+ GOTO 90
+10 KIND=ADRES*8
+90 CALL SCAN
+C THE VARIABLE LIST IS COPIED INTO THE CREATED VARIABLE DESCRIPTIONS
+ DO 100 I=1,ILE
+ LPMF=LPMF-5
+ IF (LPMF.LT.LPML) CALL ERROR(199)
+C ERROR(199) - PARSER TABLE OVERFLOW
+ IPMEM(LPMF+1)=SKAD(I)
+ IPMEM(LPMF+2)=LN
+ IPMEM(LPMF+3)=KIND
+ IPMEM(LPMF+4)=ARR
+C THE NEW ELEMENT IS APPENDED TO THE VARIABLE LIST
+C NRRE - SCRATCH - BEGINNING OF THE LIST (TAKEN FROM THE PROTOTYPE)
+ NRRE=STACK(TOP+3)+3
+ IPMEM(LPMF+5)=IPMEM(NRRE)
+ IPMEM(NRRE)=LPMF+1
+100 CONTINUE
+ RETURN
+ END
+
+
+ SUBROUTINE OVERF(K)
+ IMPLICIT INTEGER (A-Z)
+ COMMON /LISTING/ OUTSTR(265)
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEXT
+1 IF (BUFOR(1).EQ.2) GOTO 2
+ CALL READIN
+ GOTO 1
+2 CALL APARS
+cdsw CALL CLOSF(OUTSTR)
+cdsw CALL CLOSF(INSTR)
+ CALL MDROP(K)
+ RETURN
+ END
+
+ SUBROUTINE OPTSET
+ IMPLICIT INTEGER (A-Z)
+C SETS UP THE OPTION WORD - C0M(2)
+CJF CALLED WHENEVER '(*[' IS ENCOUNTERED
+C CALLED WHENEVER '(*$' IS ENCOUNTERED
+CJF VARIABLE LP IS ASSUMED TO POINT TO THE FIRST CHARACTER FOLLOWING '['
+C VARIABLE LP IS ASSUMED TO POINT TO THE FIRST CHARACTER FOLLOWING '$'
+C IT IS ADVANCED BY OPTSET
+C
+C MEANING OF THE PARTICULAR BITS IC C0M(2)
+C BIT(S) MEANING
+C 0 - OPTION MEMBER-CONTROL ( 1 - ON, 0 - OFF ) M
+C 1 - OPTION OPTIMIZATION O
+C 2 - OPTION INDEX-CONTROL I
+C 3 - OPTION TYPE-CONTROL T
+C 4 - OPTION TRACE-CONTROL D
+C 5 - OPTION CASE-CONTROL (NOT USED IN THE L-COMPILER) C
+C 6 - OPTION FAST CASE " F
+C 7-12 NOT USED
+C 13 - OPTION FOR T.SZCZEPANEK " S
+C 14 - OPTION PSEUDO-PARALLEL " P
+C 15 - OPTION LISTING L
+C
+C NOTE: PARTICULAR BITS IN AUX (0-12) CORRESPOND TO THE CHANGES IN
+C C0M(2). THEY ARE SET UP WHEN THE CORRESPONDING OPTIONS ARE SELECTED
+C
+C NOTE: THE NUMBERS OF OPTIONS WRITTEN TO THE INTERMEDIATE CODE RESULT
+C FROM ADDING 2 TO THE CORRESPONDING BIT NUMBERS.
+C
+C WORDS C0M(3) AND C0M(4) ARE USED TO FORCE EXTERNAL SETTING OF OPTIONS.
+C EXTERNAL SETTING (VIA RESPONSE TO THE COMPILER PROMPT) TAKES PRECEDENCE.
+C OPTION 'P' (14) CAN BE SET ONLY EXTERNALLY.
+C INITIAL VALUES:
+C C0M(2) - X'802F'
+C C0M(3) - X'0000'
+C COM(4) - X'FFFF'
+C
+ COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
+ X POSIT,RECNR,NEKST
+ COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
+ COMMON /BLANK/ C0M(4),BLANK(8995),AUX,BLANK1(4192)
+
+C RECOGNIZE THE OPTION
+cdsw ------------ changed to lower-case or upper case letters -----
+10 continue
+ x = ord(bufor(lp))
+ if(x.ne.ord(ichar('l'))) goto 100
+cdsw10 IF (BUFOR(LP).NE.ICHAR('L')) GOTO 100
+cdsw -------------------------------------------
+C 'L' RECOGNIZED
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 50
+ IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 30
+ CALL ERROR(135)
+30 C0M(2)=IBSET(C0M(2),15)
+ GOTO 80
+50 C0M(2)=IBCLR(C0M(2),15)
+C MASK UP THE OPTIONS WHICH HAVE BEEN DECLARED EXTERNALLY
+cdsw&bc 80 C0M(2)=IOR(C0M(3),IAND(C0M(4),C0M(2)))
+80 continue
+c
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw ---------------- changed -------------
+100 if(x.ne.ord(ichar('m')))goto 200
+cdsw100 IF (BUFOR(LP).NE.ICHAR('M')) GOTO 200
+cdsw--------------------------------------------
+C 'M' RECOGNIZED - MEMBER-CONTROL
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 150
+ IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 130
+ CALL ERROR(135)
+130 C0M(2)=IBSET(C0M(2),0)
+ GOTO 180
+150 C0M(2)=IBCLR(C0M(2),0)
+180 AUX=IBSET(AUX,0)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw ---------------- changed ---------------
+200 if(x.ne.ord(ichar('o'))) go to 300
+cdsw200 IF (BUFOR(LP).NE.ICHAR('O')) GOTO 300
+cdsw -----------------------------------------
+C 'O' RECOGNIZED - OPTIMIZATION
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 250
+ IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 230
+ CALL ERROR(135)
+230 C0M(2)=IBSET(C0M(2),1)
+ GOTO 280
+250 C0M(2)=IBCLR(C0M(2),1)
+280 AUX=IBSET(AUX,1)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw ------------------- changed ---------
+300 if(x.ne.ord(ichar('i'))) go to 400
+cdsw300 IF (BUFOR(LP).NE.ICHAR('I')) GOTO 400
+cdsw ----------------------------------------
+C 'I' RECOGNIZED - INDEX-CONTROL
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 350
+ IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 330
+ CALL ERROR(135)
+330 C0M(2)=IBSET(C0M(2),2)
+ GOTO 380
+350 C0M(2)=IBCLR(C0M(2),2)
+380 AUX=IBSET(AUX,2)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw ------------ changed -----------------
+400 if(x.ne.ord(ichar('t'))) go to 500
+cdsw400 IF (BUFOR(LP).NE.ICHAR('T')) GOTO 500
+cdsw -------------------------------------
+C 'T' RECOGNIZED - TYPE-CONTROL
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 450
+ IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 430
+ CALL ERROR(135)
+430 C0M(2)=IBSET(C0M(2),3)
+ GOTO 480
+450 C0M(2)=IBCLR(C0M(2),3)
+480 AUX=IBSET(AUX,3)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw ------------- changed ----------------
+500 if(x.ne.ord(ichar('d'))) go to 600
+cdsw500 IF (BUFOR(LP).NE.ICHAR('D')) GOTO 600
+cdsw ---------------------------------------
+C 'D' RECOGNIZED - TRACE-CONTROL
+ C0M(2)=IBCLR(C0M(2),4)
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 550
+ IF (BUFOR(LP+1).NE.ICHAR('+')) CALL ERROR(135)
+530 C0M(2)=IBSET(C0M(2),4)
+550 AUX=IBSET(AUX,4)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw --------------- changed ----------------------
+600 if(x.ne.ord(ichar('c'))) go to 700
+cdsw600 IF (BUFOR(LP).NE.ICHAR('C')) GOTO 700
+cdsw ----------------------------------------------
+C 'C' RECOGNIZED - CASE-CONTROL
+ C0M(2)=IBSET(C0M(2),5)
+ IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 630
+ IF (BUFOR(LP+1).NE.ICHAR('+')) CALL ERROR(135)
+ GOTO 650
+630 C0M(2)=IBCLR(C0M(2),5)
+650 AUX=IBSET(AUX,5)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+cdsw --------- changed ------------------------
+700 if(x.ne.ord(ichar('f'))) go to 800
+cdsw700 IF (BUFOR(LP).NE.ICHAR('F')) GOTO 800
+cdsw -----------------------------------------
+C 'F' RECOGNIZED - FAST CASE
+ C0M(2)=IBCLR(C0M(2),6)
+ IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 730
+ IF (BUFOR(LP+1).NE.ICHAR('-')) CALL ERROR(135)
+ GOTO 650
+730 C0M(2)=IBSET(C0M(2),6)
+750 AUX=IBSET(AUX,6)
+ IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
+ LP=LP+3
+ GOTO 10
+800 LP=LP-3
+C NO VALID OPTION HAS BEEN RECOGNIZED
+ CALL ERROR(135)
+cdsw&bc 9999 C0M(2)=IOR(C0M(3),IAND(C0M(4),C0M(2)))
+9999 continue
+c
+ RETURN
+ END
+
--- /dev/null
+Here you have the sources. \r
+ They are in Unix format. Use unix2dos to read them in DOS.\r
+\r
+Unix users:\r
+ You should build\r
+ 1. the crosscompiler F2C used by make to construct loglan\r
+ 2. loglan i.e. pass1\r
+ 3. gen i.e. pass2\r
+ 4. int i.e. the executor\r
+You have four directories. In each directory locate the file \r
+ makefile\r
+- do a copy of it\r
+- modify the makefile in accordance to your equipment and needs\r
+- execute:\r
+ make\r
+- store the resulting executable where you wish to keep executables\r
+\r
+Attention!\r
+ in INT you should build "int" and "herc"\r
+do:\r
+ make --in order to make int\r
+ make herc --in order to make herc a graphic partner of int\r
+__________________________\r
+New: new version "xint" of int and "xiuwgraf" are available. Not integrated yet.\r
+ 25 October 1993\r
+\r
+=============================================================================\r
+RESEARCH.\r
+\r
+We are in train of constructing new pass1 for the present Loglan82 as well \r
+as for new Loglan93.\r
+Should you feel interested in cooperation, contact\r
+ salwicki@infpc1.univ-pau.fr\r
+\r
--- /dev/null
+template("program","program",[txtfield(0,0,7,"program"),field("name",u,0,7,8,ref(0)," <name> ",0),txtfield(0,15,1,";"),tmpfield("body1",1,0)],5,14)\r
+template("program-block","program",[txtfield(0,0,5,"block"),tmpfield("body1",1,0)],5,14)\r
+template("block","block",[txtfield(0,0,5,"block"),tmpfield("body",1,0),txtfield(9,14,1,";")],6,15)\r
+template("pref...block","block",[txtfield(0,0,4,"pref"),field("prefix_id",ru,0,4,13,ref(0)," <prefix_id> ",0),field("actual_pars",ru,0,17,15,ref(0)," <actual_pars> ",0),txtfield(0,32,5,"block"),tmpfield("body",1,0),txtfield(9,14,1,";")],6,15)\r
+template("body1","aux",[field("declarations",rli,0,2,14,ref(0),"<declarations>",0),txtfield(1,0,5,"begin"),field("statements",rli,2,2,12,ref(0),"<statements>",0),txtfield(3,0,3,"end"),field("comment",ru,3,3,11,ref(0)," <comment> ",0)],4,14)\r
+template("body","aux",[field("declarations",rli,0,2,14,ref(0),"<declarations>",0),txtfield(1,0,5,"begin"),field("statements",rli,2,2,12,ref(0),"<statements>",0),field("lastwill",rt,3,2,10,ref(0),"<lastwill>",0),txtfield(4,0,3,"end"),field("comment",ru,4,3,11,ref(0)," <comment> ",0)],5,14)\r
+template("lastwill","lastwill",[txtfield(0,0,9,"lastwill:"),field("statements",rli,0,9,12,ref(0),"<statements>",0)],1,21)\r
+template("declarations","declaration",[txtfield(0,0,2," "),field("declaration",rem,0,2,13,ref(0),"<declaration>",0),txtfield(0,15,2," ")],1,17)\r
+template("constant","constant1",[txtfield(0,0,5,"const"),field("id",u,0,5,6,ref(0)," <id> ",0),txtfield(0,11,1,"="),field("value",u,0,12,9,ref(0)," <value> ",0),txtfield(0,21,1,";")],1,22)\r
+template("grouped_var","grouped_var1",[txtfield(0,0,3,"var"),field("id_list",u,0,3,14,ref(0)," <id> {,<id>} ",0),txtfield(0,17,1,":"),field("type",tm,0,18,6,ref(0),"<type>",0),txtfield(0,24,1,";")],1,25)\r
+template("primitive","primitive_type",[field("prim_id",m,0,0,16,ref(0),"<primitive_type>",0)],1,16)\r
+template("identifier","id_type",[field("id",u,0,0,11,ref(0)," <id_type> ",0)],1,11)\r
+template("class","class",[tmpfield("head",0,0),txtfield(0,26,5,"class"),field("parameters",rli,0,31,12,ref(0),"<parameters>",0),txtfield(0,43,1,";"),tmpfield("tch_body",1,0),txtfield(8,14,1,";")],9,15)\r
+template("function","function",[tmpfield("head",0,0),txtfield(0,26,8,"function"),field("parameters",rli,0,34,12,ref(0),"<parameters>",0),txtfield(0,46,1,":"),field("type",tm,0,47,6,ref(0),"<type>",0),txtfield(0,53,1,";"),field("taken",rt,1,2,7,ref(0),"<taken>",0),tmpfield("body",2,0),txtfield(6,14,1,";")],7,15)\r
+template("procedure","procedure",[tmpfield("head",0,0),txtfield(0,26,9,"procedure"),field("parameters",rli,0,35,12,ref(0),"<parameters>",0),txtfield(0,47,1,";"),field("taken",rt,1,2,7,ref(0),"<taken>",0),tmpfield("body",2,0),txtfield(6,14,1,";")],7,15)\r
+template("virt_function","virt_function",[tmpfield("virt_head",0,0),txtfield(0,34,8,"function"),field("parameters",rli,0,42,12,ref(0),"<parameters>",0),txtfield(0,54,1,":"),field("type",tm,0,55,6,ref(0),"<type>",0),txtfield(0,61,1,";"),field("taken",rt,1,2,7,ref(0),"<taken>",0),tmpfield("body",2,0),txtfield(6,14,1,";")],7,15)\r
+template("virt_procedure","virt_procedure",[tmpfield("virt_head",0,0),txtfield(0,34,9,"procedure"),field("parameters",rli,0,43,12,ref(0),"<parameters>",0),txtfield(0,55,1,";"),field("taken",rt,1,2,7,ref(0),"<taken>",0),tmpfield("body",2,0),txtfield(6,14,1,";")],7,15)\r
+template("coroutine","coroutine",[tmpfield("head",0,0),txtfield(0,26,9,"coroutine"),field("parameters",rli,0,35,12,ref(0),"<parameters>",0),txtfield(0,47,1,";"),tmpfield("tch_body",1,0),txtfield(8,14,1,";")],9,15)\r
+template("process","process",[tmpfield("head",0,0),txtfield(0,26,7,"process"),field("parameters",rli,0,33,12,ref(0),"<parameters>",0),txtfield(0,45,1,";"),tmpfield("tch_body",1,0),txtfield(8,14,1,";")],9,15)\r
+template("head","aux",[txtfield(0,0,4,"unit"),field("name",u,0,4,8,ref(0)," <name> ",0),txtfield(0,12,1,":"),field("prefix_id",ru,0,13,13,ref(0)," <prefix_id> ",0)],1,26)\r
+template("virt_head","aux",[txtfield(0,0,12,"unit virtual"),field("name",u,0,12,8,ref(0)," <name> ",0),txtfield(0,20,1,":"),field("prefix_id",ru,0,21,13,ref(0)," <prefix_id> ",0)],1,34)\r
+template("tch_body","aux",[field("taken",rt,0,2,7,ref(0),"<taken>",0),field("close",rt,1,2,7,ref(0),"<close>",0),field("hidden",rt,2,2,8,ref(0),"<hidden>",0),tmpfield("body",3,0)],7,14)\r
+template("taken","taken",[txtfield(0,0,5,"taken"),field("taken",ru,0,5,14,ref(0)," <id> {,<id>} ",0),txtfield(0,19,1,";")],1,20)\r
+template("close","close",[txtfield(0,0,5,"close"),field("close",ru,0,5,14,ref(0)," <id> {,<id>} ",0),txtfield(0,19,1,";")],1,20)\r
+template("hidden","hidden",[txtfield(0,0,6,"hidden"),field("hidden",ru,0,6,14,ref(0)," <id> {,<id>} ",0),txtfield(0,20,1,";")],1,21)\r
+template("signal","signal1",[txtfield(0,0,6,"signal"),field("id",u,0,6,6,ref(0)," <id> ",0),field("s_parameters",rli,0,12,12,ref(0),"<parameters>",0),txtfield(0,24,1,";")],1,25)\r
+template("s_parameters","parameter",[txtfield(0,0,1,"("),field("s_parameter",rem,0,1,11,ref(0),"<parameter>",0),txtfield(0,12,1,")")],1,13)\r
+template("input","input_par",[txtfield(0,0,5,"input"),tmpfield("io_rest",0,5)],1,30)\r
+template("output","output_par",[txtfield(0,0,6,"output"),tmpfield("io_rest",0,6)],1,31)\r
+template("inout","in_out_par",[txtfield(0,0,5,"inout"),tmpfield("io_rest",0,5)],1,30)\r
+template("io_rest","aux",[field("id_list",u,0,0,14,ref(0)," <id> {,<id>} ",0),txtfield(0,14,1,":"),field("type",tm,0,15,6,ref(0),"<type>",0),field("sep",rt,0,21,3,ref(0),"<;>",0),txtfield(0,24,1," ")],1,25)\r
+template("sep","sep",[txtfield(0,0,1,";")],1,1)\r
+template("type","type_par",[txtfield(0,0,4,"type"),field("id",u,0,4,6,ref(0)," <id> ",0),field("sep",rt,0,10,3,ref(0),"<;>",0),txtfield(0,13,1," ")],1,14)\r
+template("func_par","fun_par",[txtfield(0,0,8,"function"),field("id",u,0,8,6,ref(0)," <id> ",0),field("sep",rt,0,14,3,ref(0),"<;>",0),txtfield(0,17,1," ")],1,18)\r
+template("proc_par","proc_par",[txtfield(0,0,9,"procedure"),field("id",u,0,9,6,ref(0)," <id> ",0),field("sep",rt,0,15,3,ref(0),"<;>",0),txtfield(0,18,1," ")],1,19)\r
+template("parameters","parameter",[txtfield(0,0,1,"("),field("parameter",rem,0,1,11,ref(0),"<parameter>",0),txtfield(0,12,1,")")],1,13)\r
+template("fun_param","fun_param",[txtfield(0,0,8,"function"),field("s_parameters",rli,0,8,12,ref(0),"<parameters>",0),txtfield(0,20,1,":"),field("type",tm,0,21,6,ref(0),"<type>",0),field("sep",rt,0,27,3,ref(0),"<;>",0),txtfield(0,30,1," ")],1,31)\r
+template("proc_param","proc_param",[txtfield(0,0,9,"procedure"),field("s_parameters",rli,0,9,12,ref(0),"<parameters>",0),field("sep",rt,0,21,3,ref(0),"<;>",0),txtfield(0,24,1," ")],1,25)\r
+template("handlers","handlers",[txtfield(0,0,8,"handlers"),field("s_handlers",rli,1,1,12,ref(0),"<s_handlers>",0),field("others",rli,2,1,8,ref(0),"<others>",0),txtfield(3,0,3,"end")],4,3)\r
+template("s_handlers","handler",[txtfield(0,0,1," "),field("s_handler",re,0,1,11,ref(0),"<s_handler>",0),txtfield(0,12,1," ")],1,13)\r
+template("s_handler","handler1",[txtfield(0,0,4,"when"),field("id_list",u,0,4,14,ref(0)," <id> {,<id>} ",0),field("s_parameters",rli,0,18,12,ref(0),"<parameters>",0),txtfield(0,30,1,":"),field("statements",rli,1,1,12,ref(0),"<statements>",0)],2,13)\r
+template("others","block_stat",[txtfield(0,1,6,"others"),field("statement",rem,1,2,11,ref(0),"<statement>",0)],2,13)\r
+template("statements","statement",[txtfield(0,0,2," "),field("statement",rem,0,2,11,ref(0),"<statement>",0),txtfield(0,13,2," ")],1,15)\r
+template("ifthen","aux",[txtfield(0,0,2,"if"),field("if_cond",u,0,2,8,ref(0)," <cond> ",0),txtfield(0,10,4,"then"),field("then_statements",rli,1,4,12,ref(0),"<statements>",0)],2,16)\r
+template("then_statements","statement",[txtfield(0,0,1," "),field("statement",rem,0,1,11,ref(0),"<statement>",0),txtfield(0,12,1," ")],1,13)\r
+template("else_statements","statement",[txtfield(0,0,1," "),field("statement",rem,0,1,11,ref(0),"<statement>",0),txtfield(0,12,1," ")],1,13)\r
+template("if_then","if_then",[tmpfield("ifthen",0,0),txtfield(2,0,3,"fi;")],3,3)\r
+template("if_then_else","if_then_else",[tmpfield("ifthen",0,0),txtfield(2,2,4,"else"),field("else_statements",rli,3,4,12,ref(0),"<statements>",0),txtfield(4,0,3,"fi;")],5,3)\r
+template("do","do",[txtfield(0,0,2,"do"),field("statements",rli,1,2,12,ref(0),"<statements>",0),txtfield(2,0,3,"od;")],3,3)\r
+template("while","while",[txtfield(0,0,5,"while"),field("cond",u,0,5,8,ref(0)," <cond> ",0),tmpfield("do",1,2)],4,5)\r
+template("for","aux",[txtfield(0,0,3,"for"),field("id",u,0,3,6,ref(0)," <id> ",0),txtfield(0,9,2,":="),field("start_expr",u,0,11,14,ref(0)," <start_value> ",0)],1,25)\r
+template("for_to","for_to",[tmpfield("for",0,0),txtfield(0,25,2,"to"),field("stop_expr",u,0,27,13,ref(0)," <stop_expr> ",0),tmpfield("do",1,2)],4,5)\r
+template("for_step_to","for_step_to",[tmpfield("for",0,0),txtfield(0,25,4,"step"),field("step",u,0,29,8,ref(0)," <step> ",0),txtfield(0,37,2,"to"),field("stop_expr",u,0,39,13,ref(0)," <stop_expr> ",0),tmpfield("do",1,2)],4,5)\r
+template("for_downto","for_downto",[tmpfield("for",0,0),txtfield(0,25,6,"downto"),field("stop_expr",u,0,31,13,ref(0)," <stop_expr> ",0),tmpfield("do",1,2)],4,5)\r
+template("for_step_downto","for_step_downto",[tmpfield("for",0,0),txtfield(0,25,4,"step"),field("step",u,0,29,8,ref(0)," <step> ",0),txtfield(0,37,6,"downto"),field("stop_expr",u,0,43,13,ref(0)," <stop_expr> ",0),tmpfield("do",1,2)],4,5)\r
+template("case","case",[txtfield(0,0,4,"case"),field("ac_expr",u,0,4,8,ref(0)," <expr> ",0),field("selectors",rli,1,2,11,ref(0),"<selectors>",0),field("others",rli,2,2,8,ref(0),"<others>",0),txtfield(3,0,5,"esac;")],4,5)\r
+template("selectors","selector",[txtfield(0,0,1," "),field("selector",re,0,1,10,ref(0),"<selector>",0),txtfield(0,7,1," ")],1,8)\r
+template("selector","selector1",[txtfield(0,0,4,"when"),field("value_list",u,0,4,20,ref(0)," <value> {,<value>} ",0),txtfield(0,24,1,":"),field("statements",rli,1,2,12,ref(0),"<statements>",0)],2,14)\r
+template("read","read",[txtfield(0,0,6,"read ("),field("var_list",u,0,6,16,ref(0)," <var> {,<var>} ",0),txtfield(0,22,2,");")],1,24)\r
+template("write","write",[txtfield(0,0,7,"write ("),field("exf_list",u,0,7,18,ref(0)," <expr> {,<expr>} ",0),txtfield(0,25,2,");")],1,27)\r
+template("writeln(...)","writeln",[txtfield(0,0,9,"writeln ("),field("expr_list",u,0,9,18,ref(0)," <expr> {,<expr>} ",0),txtfield(0,2,2,");")],1,29)\r
+template("writeln","writeln",[txtfield(0,0,8,"writeln;")],1,8)\r
+template("assign","assign",[field("var_list",u,0,0,16,ref(0)," <var> {,<var>} ",0),txtfield(0,16,2,":="),field("expr",u,0,18,8,ref(0)," <expr> ",0),txtfield(0,26,1,";")],1,27)\r
+template("copy","copy",[field("var_list",u,0,0,16,ref(0)," <var> {,<var>} ",0),txtfield(0,16,9,":= copy ("),field("object_expr",u,0,25,15,ref(0)," <object_expr> ",0),txtfield(0,40,2,");")],1,42)\r
+template("call","call",[txtfield(0,0,4,"call"),field("procedure_expr",u,0,4,18,ref(0)," <procedure_expr> ",0),field("actual_pars",ru,0,22,15,ref(0)," <actual_pars> ",0),txtfield(0,37,1,";")],1,38)\r
+template("new_array","new_array",[txtfield(0,0,9,"new_array"),field("var",u,0,9,7,ref(0)," <var> ",0),txtfield(0,16,5,"dim ["),field("lower_bound",u,0,21,15,ref(0)," <lower_bound> ",0),txtfield(0,36,1,":"),field("upper_bound",u,0,37,15,ref(0)," <upper_bound> ",0),txtfield(0,52,2,"];")],1,54)\r
+template("kill","kill",[txtfield(0,0,6,"kill ("),field("object_expr",u,0,6,15,ref(0)," <object_expr> ",0),txtfield(0,21,2,");")],1,23)\r
+template("attach","attach",[txtfield(0,0,8,"attach ("),field("object_expr",u,0,8,15,ref(0)," <object_expr> ",0),txtfield(0,23,2,");")],1,25)\r
+template("detach","detach",[txtfield(0,0,7,"detach;")],1,7)\r
+template("lock","lock",[txtfield(0,0,6,"lock ("),field("var",u,0,6,7,ref(0)," <var> ",0),txtfield(0,13,2,");")],1,15)\r
+template("unlock","unlock",[txtfield(0,0,8,"unlock ("),field("var",u,0,8,7,ref(0)," <var> ",0),txtfield(0,15,2,");")],1,17)\r
+template("ts","ts",[txtfield(0,0,4,"lock ("),field("var",u,0,4,7,ref(0)," <var> ",0),txtfield(0,11,2,");")],1,13)\r
+template("stop(...)","stop",[txtfield(0,0,6,"stop ("),field("var",u,0,6,7,ref(0)," <var> ",0),txtfield(0,13,2,");")],1,15)\r
+template("stop","stop",[txtfield(0,0,5,"stop;")],1,5)\r
+template("resume","resume",[txtfield(0,0,8,"resume ("),field("object_expr",u,0,8,15,ref(0)," <object_expr> ",0),txtfield(0,23,2,");")],1,25)\r
+template("wait","wait",[txtfield(0,0,5,"wait;")],1,5)\r
+template("raise","raise",[txtfield(0,0,5,"raise"),field("id",u,0,5,6,ref(0)," <id> ",0),field("actual_pars",ru,0,11,15,ref(0)," <actual_pars> ",0),txtfield(0,26,1,";")],1,27)\r
+template("wind","wind",[txtfield(0,0,5,"wind;")],1,5)\r
+template("terminate","terminate",[txtfield(0,0,10,"terminate;")],1,10)\r
+template("repeat","repeat",[txtfield(0,0,7,"repeat;")],1,7)\r
+template("inner","inner",[txtfield(0,0,6,"inner;")],1,6)\r
+template("return","return",[txtfield(0,0,7,"return;")],1,7)\r
+menu_temp("program_unit",1,70,["program","program-block"])\r
+menu_temp("type",1,67,["primitive","identifier","array"])\r
+menu_temp("prim_id",1,68,["integer","real","boolean","character","string","semaphore","process","coroutine"])\r
+menu_temp("elem_id",1,66,[" integer"," real"," boolean"," character"," string"," semaphore"," process"," coroutine"," identifier"])\r
+menu_temp("declaration",1,63,["constant","grouped_var","signal","handlers","class","function","procedure","virt_function","virt_procedure","coroutine","process"])\r
+menu_temp("s_parameter",1,69,["input","output","inout","fun_par","proc_par","type"])\r
+menu_temp("parameter",1,67,["input","output","inout","fun_param","proc_param","type"])\r
+menu_temp("statement",1,53,["assign","copy","call","new_array","kill","exit","repeat","exit repeat","return","inner","block","pref...block","COMPOUND_STATEMENT","INPUT/OUTPUT_STATEMENT","COROUTINE_STATEMENT","PROCESS_STATEMENT","SIGNAL/HANDLER_STATEMENT","SEMAPHORE_STATEMENT"])\r
+menu_temp("COMPOUND_STATEMENT",1,62,["if_then","if_then_else","do","while","for_to","for_downto","for_step_to","for_step_downto","case"])\r
+menu_temp("INPUT/OUTPUT_STATEMENT",1,65,["read","write","writeln","writeln(...)"])\r
+menu_temp("COROUTINE_STATEMENT",1,71,["attach","detach"])\r
+menu_temp("PROCESS_STATEMENT",1,71,["attach","detach","resume","wait","stop","stop(...)"])\r
+menu_temp("SIGNAL/HANDLER_STATEMENT",1,68,["raise","return","terminate","wind"])\r
+menu_temp("SEMAPHORE_STATEMENT",1,68,["lock","unlock","ts","stop(...)"])\r
+windowsize(17,77)\r
+windowstart(0,0)\r
+mycursord(0,0)\r
+insmode\r
+keys([])\r
+fkeys([fkey(1),fkey(2)])\r
+arrows([right,left,up,down,pgup,pgdn,end,home,ctrlend,ctrlhome,esc])\r
+object(1)\r
+helpfile("edihelp0.hlp")\r
--- /dev/null
+helptext("scr1_help",112,7,"text operations",1,44,20,35,0)\r
+helptext("top_line_help",112,7,"top line menu operations",1,44,20,35,502)\r
+helptext("scr_help",112,7,"structure operations",1,44,20,35,729)\r
--- /dev/null
+h("Esc escape from the field \n (no changes are made)\nReturn end of typing\n (all correct changes are\n respected)\n<- move the cursor to the\n previous character \n-> move the cursor to the\n next character\nHome move the cursor to the\n first character\nEnd move the cursor to the\n last character\nIns change the typing mode\n (insert/overwrite)\nDel delete the given character\nBdel delete the previous charac\n ter")\r
+h("Edit activation of the struc-\n tural editing\nFiles enables operations on\n files\nSetup enables window resizing\n and changes of the actual\n directory\nQuit exit from the editor\n")\r
+h("F2 resize a window\nEsc escape to the main menu\nEnter develop the distinguished\n field (replace the nonter\n minal by a new value)\nAlt-a add a field of the same\n type after the distin-\n guished field\nAlt-b add a field of the same\n type before the distin-\n guished field\nAlt-d delete the distinguished\n field\nAlt-e extend the distinguished\n field to its super-struc\n ture\nAlt-f add the first field to\n the list containing\n the distinguished field\nAlt-l add the last field to\n the list containing\n the distinguished field\nAlt-m modify the distinguished\n field\nAlt-n narrow the distinguished\n field to its first sub-\n structure\nAlt-p prune the distinguished\n field (replace the field\n by a nonterminal)\n")\r
--- /dev/null
+\1cw\r
+\U1STANDARD\r
+\U2POLISH\r
+\U3ITALIC\r
+\U7BOLD\r
+\U8PLBOLD\r
+\U$ORATOR\r
+\U(LINEDRAW\r
+\FD\r
+\+\r
+\+\r
+\+\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \@\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\=\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \$EDYTOR STRUKTURALNY\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ JEZYKA LOGLAN\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \7Instrukcja u\8x\7ytkowania\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\+\r
+\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\+\r
+\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \1Jerzy Bartoszek\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ Pozna\2n\1, stycze\2n \11990\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\/\f\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ Spis tre\2s\1ci\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+1. Og\2o\1lna charakterystyka edytora........................3\,\r
+\-\r
+\+\r
+2. Menu g\2lo\1wne...........................................5\,\r
+\-\r
+\+\r
+3. Okienko edycyjne......................................7\,\r
+\-\r
+\+\r
+4. Okienko komunikacyjne................................10\,\r
+\-\r
+\+\r
+5. Okienko informacyjne.................................10\,\r
+\-\r
+\+\r
+6. Wywo\2l\1ywanie edy\2t\1o\2r\1a..................................10\,\r
+\-\r
+\+\r
+7. Literatura...........................................11\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\+\r
+\,\f\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ 1. Og\2o\1lna charakterystyka edytora\ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Edytor strukturalny \ u\2l\1atwia \ pisanie \ i modyfikowanie \r
+\-\r
+\+\r
+program\2o\1w w j\2e\1zyku Loglan. Wykorzystuj\2a\1c \ edytor \ u\2x\1ytkownik \r
+\-\r
+\+\r
+nie musi:\,\r
+\-\r
+\+\r
+ - wprowadza\2c \ \1tekstu \ ca\2l\1ego \ programu \ metod\2a \ \1"znak \ po \,\r
+\-\r
+\+\r
+ znaku", poniewa\2x \1s\2l\1owa kluczowe oraz niekt\2o\1re sk\2l\1adowe \r
+\-\r
+\+\r
+ "lukru syntaktycznego" s\2a \1generowane automatycznie;\,\r
+\-\r
+\+\r
+ - pami\2e\1ta\2c \ \1kszta\2l\1tu \ deklaracji \ i \ instrukcji, \ poniewa\2x \r
+\-\r
+\+\r
+ \1sugeruj\2a \1to szablony.\,\r
+\-\r
+\+\r
+ Szablony sk\2l\1adaj\2a \1si\2e \1z p\2o\1l sta\2l\1ych \ - \ odpowiadaj\2a\1cych \r
+\-\r
+\+\r
+terminalom \ gramatyki \ Loglanu \ oraz \ z \ p\2o\1l \ \ zmiennych \ \ - \r
+\-\r
+\+\r
+odpowiadaj\2a\1cych nieterminalom.\,\r
+\-\r
+\+\r
+ Tworzenie \ programu \ rozpoczyna \ si\2e \ \1od \ \ zastosowania \r
+\-\r
+\+\r
+szablonu \ ca\2l\1ego \ \ programu \ \ i \ \ polega \ \ na \ \ zast\2e\1powaniu \r
+\-\r
+\+\r
+(rozwijaniu) p\2o\1l \ zmiennych przez teksty \ lub \ szablony \ tak \r
+\-\r
+\+\r
+d\2l\1ugo, dop\2o\1ki w programie wyst\2e\1puj\2a \1nieterminale czyli \ pola \r
+\-\r
+\+\r
+nierozwini\2e\1te.\,\r
+\-\r
+\+\r
+ Pole rozwini\2e\1te mo\2x\1na zwin\2ac \1na powr\2o\1t do \ nieterminala \r
+\-\r
+\+\r
+lub usun\2ac\1, gdy gramatyka Loglanu na to pozwala.\,\r
+\-\r
+\+\r
+ Dob\2o\1r szablon\2o\1w wspomagany jest przez technik\2e \1wyboru z \r
+\-\r
+\+\r
+menu. \ Teksty \ wprowadzane \ \ przez \ \ u\2x\1ytkownika \ \ podlegaj\2a \r
+\-\r
+\+\r
+\1natychmiastowej weryfikacji sk\2l\1adniowej.\,\r
+\-\r
+\+\r
+ U\2x\1ytkownik wsp\2ol\1pracuje z edytorem poprzez \ klawiatur\2e \r
+\-\r
+\+\r
+\1i system okienek na monitorze ekranowym (rys. 1). Na ekranie \r
+\-\r
+\+\r
+wyr\2ox\1niono menu g\2lo\1wne i okienka: edycyjne, komunikacyjne i \r
+\-\r
+\+\r
+informacyjne.\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+ \,\r
+\- 0 1 79\r
+\+\r
+ \(u---------------------------------------------------o\,\r
+\- 1\r
+\+ 1\r
+ \10 \(1\ \ \1Edit File Setup Quit\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \(1\,\r
+\+ 1 1\r
+ 1\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 1\,\r
+\+ \11 \(1u-------------------- \1Editor \(---------------------o1\r
+ \,\r
+\- 11 11\r
+\+\r
+ 11\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 11\,\r
+\-\r
+\+ 11 11\r
+ \,\r
+\- 11 11\r
+\+\r
+ 11\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 11\,\r
+\- 1\r
+\+ 11 \1Okienko edycyjne \(11\r
+ \,\r
+\- 11 11\r
+\+\r
+ 11\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 11\,\r
+\-\r
+\+ 11 11\r
+ \,\r
+\- 11 11\r
+\+\r
+ 11\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 11\,\r
+\-\r
+\+ 11 11\r
+ \,\r
+\- \120 \(11 11\r
+\+ m-------------------------------------------------.1\r
+ 1\,\r
+\- \121 \(1u------------------- \1Messages \(--------------------o1\r
+\+\r
+ 11\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \1Okienko komunikacyjne\ \ \ \ \ \ \ \ \ \ \ \ \(11\,\r
+\-\r
+\+ 11 11\r
+ \123 \ \(m-------------------------------------------------.\,\r
+\- 1 1\r
+\+ \1Okienko informacyjne \(1\r
+ \124 \(1\,\r
+\- m---------------------------------------------------.\r
+\+\r
+\,\r
+\-\r
+\+\r
+\1Rys.1 Struktura ekranu.\,\r
+\-\r
+\+\r
+\r
+\-\r
+\+\r
+ Menu g\2lo\1wne wymienia us\2l\1ugi \2s\1wiadczone \ u\2x\1ytkownikowi. \r
+\-\r
+\+\r
+Niekt\2o\1re jego pozycje posiadaj\2a \1menu szczeg\2ol\1owe.\,\r
+\-\r
+\+\r
+ W okienku edycyjnym odbywa \ si\2e \ \1konstruowanie \ tekstu \r
+\-\r
+\+\r
+programu. \r
+\-\r
+\+\r
+ W okienku komunikacyjnym edytor wyprowadza komunikaty,\r
+\-\r
+\+\r
+pytania i polecenia kierowane do \ u\2x\1ytkownika.\r
+\-\r
+\+\r
+ Poprzez \ \ okienko \ \ informacyjne \ \ edytor \ \ \ instruuje \r
+\-\r
+\+\r
+u\2x\1ytkownika o \ dzia\2l\1aniach \ dopuszczalnych \ w \ danym \ stanie \r
+\-\r
+\+\r
+edycji. \ Szczeg\2ol\1y \ tych \ dzia\2l\1a\2n \ \1opisano \ \ w \ \ przewodniku \r
+\-\r
+\+\r
+(helpie) \ wywo\2l\1ywanym przez u\2x\1ytkownika przyciskiem \7F1\1.\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 2. Menu g\2lo\1wne\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Menu g\2lo\1wne (patrz rys.1) zawiera cztery pozycje: \7Edit\1, \r
+\-\r
+\+\r
+\7File\1, \7Setup \1i \7Quit\1.\,\r
+\-\r
+\+\r
+ Pozycja \7Edit \1inicjuje edycj\2e \1w okienku edycyjnym. Powr\2o\1t \r
+\-\r
+\+\r
+do menu g\2lo\1wnego z tego okienka wymusza przycisk \7Esc\1.\,\r
+\-\r
+\+\r
+ Pozycja \ \7File \ \1zwi\2a\1zana \ jest \ g\2lo\1wnie z \ operacjami \ na \r
+\-\r
+\+\r
+plikach. \ Zawiera \ ona \ menu \ szczeg\2ol\1owe \ przedstawione \ na \r
+\-\r
+\+\r
+rysunku 2.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+ ______________________\r
+ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \(o\,\r
+\- 1 1\r
+\- 1 \1Load structure \(1\r
+\+ 1\r
+\+ 1 \1Save structure\r
+\+ \(1\r
+\+ 1 \1save Text\r
+\+ \(1\r
+\+ 1 \1test Completness\r
+\+ \(1\r
+\+ 1 \1Operating system\r
+\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \(1\,\r
+\- 1\1_____________________\r
+\+ \(m .\r
+\,\r
+\-\r
+\-\r
+\-\r
+\+\r
+\1Rys. 2 Menu szczeg\2ol\1owe dla File\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Pozycja \7Load structure \1umo\2x\1liwia wczytanie \ do \ edytora \r
+\-\r
+\+\r
+struktury programu zapami\2e\1tanej w \ pliku. \ Wczytany \ program \r
+\-\r
+\+\r
+mo\2x\1e by\2c \1nast\2e\1pnie poddany edycji.\,\r
+\-\r
+\+\r
+ Wyb\2o\1r pozycji \ \7Save \ structure \ \1spowoduje \ zapami\2e\1tanie \r
+\-\r
+\+\r
+struktury aktualnie tworzonego programu.\,\r
+\-\r
+\+\r
+ Tekst tworzonego programu mo\2x\1na \ zapami\2e\1ta\2c \ \1wybieraj\2a\1c \r
+\-\r
+\+\r
+pozycj\2e \7save Text\1. Plik \ zawieraj\2a\1cy \ taki \ tekst \ mo\2x\1e \ by\2c \r
+\-\r
+\+\r
+\1nast\2e\1pnie drukowany za pomoc\2a \1standardowych polece\2n \ \1systemu \r
+\-\r
+\+\r
+DOS lub mo\2x\1e stanowi\2c \1dan\2a \1dla kompilatora.\,\r
+\-\r
+\+\r
+ Pozycja \7test Completness \1s\2l\1u\2x\1y \ do \ sprawdzania, \ czy \ w \r
+\-\r
+\+\r
+tworzonym programie s\2a \1jeszcze nieterminale.\,\r
+\-\r
+\+\r
+ Kr\2o\1tkotrwa\2l\1e wyj\2s\1cie z edytora do \ systemu \ operacyjnego \r
+\-\r
+\+\r
+zapewnia pozycja \ \7Operating \ system\1. \ Powr\2o\1t \ do \ edytora \ z \r
+\-\/\f\r
+\+\r
+systemu jest w\2o\1wczas \ mo\2x\1liwy \ poprzez \ systemowe \ polecenie \r
+\-\r
+\+\r
+\7exit\1.\,\r
+\-\r
+\+\r
+ Nazwy \ plik\2o\1w \ bior\2a\1cych \ udzia\2l \ \1w \ wy\2x\1ej \ wspomnianych \r
+\-\r
+\+\r
+operacjach podaje \ si\2e \ \1w \ specjalnym \ okienku. \ Okienko \ to \r
+\-\r
+\+\r
+pojawia si\2e \1po wybraniu danej pozycji z menu. Po \ pojawieniu \r
+\-\r
+\+\r
+si\2e \1okienka mo\2x\1na tak\2x\1e nacisn\2ac \1przycisk Enter. Wy\2s\1wietlone \r
+\-\r
+\+\r
+zostan\2a \1w\2o\1wczas \ wszystkie \ pliki \ z \ aktualnego \ katalogu, \r
+\-\r
+\+\r
+kt\2o\1re posiadaj\2a \ \1rozszerzenie \ podane \ w \ okienku. \ Stosuj\2a\1c \r
+\-\r
+\+\r
+przyciski ze strza\2l\1kami oraz Enter \ mo\2x\1na \ wybra\2c \ \1potrzebny \r
+\-\r
+\+\r
+plik.\,\r
+\-\r
+\+\r
+ Pozycja \ \7Setup \ \ \1u\2l\1atwia \ \ zmian\2e \ \ \1wielko\2s\1ci \ \ okienka \r
+\-\r
+\+\r
+edycyjnego \ \ i \ \ komunikacyjnego \ \ oraz \ \ zmian\2e \ \ \ \1katalogu \r
+\-\r
+\+\r
+aktualnego. Menu szczeg\2ol\1owe tej pozycji podaje rysunek 3.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\+\r
+\+\r
+\ \ \ \ \ \ \ \ \ _____________________\r
+\- \(o\r
+\- 1\r
+\- 1\r
+\- 1 \1Directory \(1\r
+\-\r
+\- 1 \1Edit_window size \(1\r
+\-\r
+\- 1 \1Message_window size\(1\r
+\-\r
+\- 1 1\r
+\- \1____________________\r
+\- \(m .\r
+\-\r
+\-\r
+\-\r
+\+\r
+\+\r
+\1Rys. 3 Menu szczeg\2ol\1owe dla Setup\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+Podczas \ zmiany \ wielko\2s\1ci \ okienek \ nale\2x\1y \ pos\2l\1ugiwa\2c \ \1si\2e \r
+\-\r
+\+\r
+\1przyciskami opisanymi w okienku informacyjnym.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Ostatni\2a \1pozycj\2a \1menu g\2lo\1wnego \ jest \ \7Quit\1. \ Jej \ wyb\2o\1r \r
+\-\r
+\+\r
+ko\2n\1czy prac\2e \1z edytorem.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 3. Okienko edycyjne\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ W okienku edycyjnym ma miejsce konstruowanie programu.\,\r
+\-\r
+\+\r
+Polego ono g\2lo\1wnie na zst\2e\1puj\2a\1cym rozwijaniu p\2o\1l.\,\r
+\-\r
+\+\r
+ W ka\2x\1dym stanie procesu edycji \ tekst \ programu \ sk\2l\1ada \r
+\-\r
+\+\r
+si\2e \1z p\2o\1l sta\2l\1ych i z \ \2po\1l \ zmiennych. \ \3Pole \ stale \ \1zawiera \r
+\-\r
+\+\r
+sta\2l\1y tekst ( s\2a \1to zazwyczaj \ s\2l\1owa \ kluczowe),kt\2o\1rego \ nie \r
+\-\r
+\+\r
+mo\2x\1na zmieni\2c\1. \3Pole zmienne \1mo\2x\1e b\2yc \3nierozwini\2e\3te \1- zawiera \r
+\-\r
+\+\r
+w\2o\1wczas nieterminal, albo \3rozwini\2e\3te\1. Pole \ rozwini\2e\1te \ mo\2x\1e \r
+\-\r
+\+\r
+b\2yc \1polem elementarnym lub strukturalnym.\,\r
+\-\r
+\+\r
+ \3Pole elementarne \ \1zawiera \ tekst \ wprowadzony \ "znak \ po \r
+\-\r
+\+\r
+znaku" albo wybrany z menu szczeg\2ol\1owego.\,\r
+\-\r
+\+\r
+ \3Pole \ strukturalne \ \1zawiera \ zestaw \ p\2o\1l \ utworzony \ za \r
+\-\r
+\+\r
+pomoc\2a \1szablonu \ reprezentuj\2a\1cego \ konstrukcj\2e \ \1strukturaln\2a \r
+\-\r
+\+\r
+\1j\2e\1zyka Loglan.\,\r
+\-\r
+\+\r
+ Pola zmienne sklasyfikowane s\2a \1zgodnie z nast\2e\1puj\2a\1cymi, \r
+\-\r
+\+\r
+niezale\2x\1nymi od siebie w\2l\1asno\2s\1ciami:\,\r
+\-\r
+\+\r
+a) usuwalno\2sc \1albo nieusuwalno\2sc \1pola,\,\r
+\-\r
+\+\r
+b) wype\2l\1nianie pola z wykorzystaniem menu albo bez menu,\,\r
+\-\r
+\+\r
+c) wype\2l\1nianie pola z \ wykorzystaniem \ szablonu \ albo \ przez \r
+\-\r
+\+\r
+ wpisanie tekstu,\,\r
+\-\r
+\+\r
+d) \ pole \ zwyk\2l\1e, \ listowe \ albo \ elementowe; \ pole listowe \r
+\-\r
+\+\r
+ reprezentuje list\2e \1sk\2l\1adaj\2a\1c\2a \1si\2e \1z dowolnej \ liczby \ p\2o\1l \r
+\-\r
+\+\r
+ elementowych; pole elementowe mo\2x\1na dopisywa\2c \1i usuwa\2c\1.\,\r
+\-\r
+\+\r
+ Zawsze jedno z \ p\2o\1l \ tekstu \ jest \ \3polem \ aktualnym\1. \ W \r
+\-\r
+\+\r
+okienku edycyjnym jest ono pod\2s\1wietlone\3. \ \1Operacje \ edycyjne \r
+\-\r
+\+\r
+powoduj\2a \ \1rozwijanie \ \ pola \ \ aktualnego, \ \ jego \ \ usuwanie, \r
+\-\r
+\+\r
+modyfikowanie,rozszerzanie, zaw\2ex\1anie \ lub \ zmian\2e \ \1na \ pole \r
+\-\r
+\+\r
+s\2a\1siednie. Stwarza to efekt przemieszczania si\2e \1po tek\2s\1cie w \r
+\-\r
+\+\r
+spos\2o\1b odpowiadaj\2a\1cy strukturze programu.\,\r
+\-\r
+\+\r
+ Pole zmienne, nierozwini\2e\1te mo\2x\1na \ rozwin\2ac \ \1naciskaj\2a\1c \r
+\-\/\f\r
+\+\r
+przycisk \7Enter\1. Zale\2x\1nie od rodzaju \ pola \ rozwini\2e\1cie \ mo\2x\1e \r
+\-\r
+\+\r
+polega\2c \1na:\,\r
+\-\r
+\+\r
+a) wpisaniu tekstu przez u\2x\1ytkownika;\,\r
+\-\r
+\+\r
+b) wybraniu z menu wariantu tekstu,\,\r
+\-\r
+\+\r
+c) rozwini\2e\1ciu pola wed\2l\1ug ustalonego szablonu,\,\r
+\-\r
+\+\r
+d) rozwini\2e\1ciu pola wed\2l\1ug szablonu wybranego z menu.\,\r
+\-\r
+\+\r
+ Wyboru z menu dokonuje si\2e \1za pomoc\2a \ \1przycisku \ \7Enter\1. \r
+\-\r
+\+\r
+U\2x\1ycie przycisku Esc powoduje opuszczenie \ danego \ menu \ bez \r
+\-\r
+\+\r
+dokonania jakiegokolwiek wyboru.Przyj\2e\1to, \ \2x\1e \ pozycje \ menu \r
+\-\r
+\+\r
+napisane du\2x\1ymi literami oznaczaj\2a \1grup\2e \1szablon\2o\1w zawart\2a \1w \r
+\-\r
+\+\r
+menu jeszcze bardzej szczeg\2ol\1owym.\,\r
+\-\r
+\+\r
+ Rozwijaj\2a\1c pole przez wpisywanie tekstu u\2x\1ytkownik mo\2x\1e \r
+\-\r
+\+\r
+wykorzystywa\2c \1nast\2e\1puj\2a\1ce przyciski: \(J- \1, \(-L \ \1, \ \7Del\1, \ \7Bdel\1, \r
+\-\r
+\+\r
+\7Ins\1, \7Home\1, \7End\1, \7Esc\1, \7Enter\1. Przyciski ze strza\2l\1kami s\2l\1u\2xa \1do \r
+\-\r
+\+\r
+przemieszczania si\2e \1po tek\2s\1cie. Przyciski \7Del \1i \7Bdel \1usuwaj\2a \r
+\-\r
+\+\r
+\1znaki z tekstu. \ \7Ins \ \1zmienia \ tryb \ wprowadzania \ znak\2o\1w \ z \r
+\-\r
+\+\r
+\3insert \1na \3overwrite \1i \ odwrotnie. \ \7Home \ \1i \ \7End \ \1umo\2x\1liwiaj\2a \r
+\-\r
+\+\r
+\1przemieszczenie si\2e \1na pocz\2a\1tek i \ koniec \ tekstu. \ Przycisk \r
+\-\r
+\+\r
+\7Esc \1powoduje przerwanie wprowadzania tekstu \ z \ r\2o\1wnoczesnym \r
+\-\r
+\+\r
+odtworzeniem \ jego \ kszta\2l\1tu \ poprzedniego. \ Przycisk \ \7Enter \r
+\-\r
+\+\r
+\1ko\2n\1czy wprowadzanie tekstu i jego akceptacj\2e\1, je\2s\1li jest \ on \r
+\-\r
+\+\r
+zgodny z gramatyk\2a \1j\2e\1zyka. Wprowadzony i zaakceptowany tekst \r
+\-\r
+\+\r
+mo\2x\1na modyfikowa\2c\3. \1Do tego celu s\2l\1u\2x\1y para przycisk\2o\1w \7Alt-m\1. \r
+\-\r
+\+\r
+W takcie modyfikacji tekstu \ stosuje \ si\2e \ \1te \ same \ zasady, \r
+\-\r
+\+\r
+kt\2o\1re obowi\2a\1zuj\2a \1przy jego wprowadzaniu.\,\r
+\-\r
+\+\r
+ Pole \ \ rozwini\2e\1te \ \ mo\2x\1na \ \ zwin\2ac \ \ \1do \ \ \ nieterminala \r
+\-\r
+\+\r
+r\2o\1wnocze\2s\1nie naciskaj\2a\1c \7Alt-p \1(operacja \3prune\1).\,\r
+\-\r
+\+\r
+ Je\2s\1li gramatyka \ Loglanu \ na to \ pozwala\7, \1pole \ zmienne \r
+\-\r
+\+\r
+(zar\2o\1wno rozwini\2e\1te jak \ i \ nierozwini\2e\1te) \ mo\2x\1na \ usun\2ac \ \1z \r
+\-\r
+\+\r
+tekstu programu. Do tego celu s\2l\1u\2x\1y \ para \ przycisk\2o\1w \ \7Alt-d \r
+\-\r
+\+\r
+\1(operacja \3delete\1).\,\r
+\-\/\f\r
+\+\r
+ Nowe \ pole \ \ aktualne \ \ mo\2x\1na \ \ wskaza\2c \ \ \1wykorzystuj\2a\1c \r
+\-\r
+\+\r
+przyciski \ \ ze \ \ strza\2l\1kami, \ \ \7Home\1, \ \ \7End\1, \ \ \7PgUp\1, \ \ \ \7PgDn\1, \r
+\-\r
+\+\r
+\7Ctrl-Home\1, \7Ctrl-End\1, \7Alt-e \1i \7Alt-n\1. W szceg\2o\1lno\2s\1ci \7Ctrl-Home \r
+\-\r
+\+\r
+\1wybiera pierwsze pole zmienne w ca\2l\1ym programie \ a \ \7Ctrl-End \r
+\-\r
+\+\r
+\1pole ostatnie. \7Alt-e \1powoduje rozszerzenie (operacja \3extend\1) \r
+\-\r
+\+\r
+pola aktywnego do najbli\2x\1szej nadstruktury programu\3, \1a \7Alt-n \r
+\-\r
+\+\r
+\1zaw\2ex\1enie pola aktywnego do pierwszej podstruktury \ zawartej \r
+\-\r
+\+\r
+w dotychczasowym polu aktywnym.\,\r
+\-\r
+\+\r
+ Na polach elementowych wchodz\2a\1cych w sk\2l\1ad \ list \ mo\2x\1na\r
+\-\r
+\+\r
+stosowa\2c \1dodatkowo operacje:\,\r
+\-\r
+\+\r
+a) dopisz nowe pole elementowe na pocz\2a\1tku listy - \7Alt-f\1,\,\r
+\-\r
+\+\r
+b) dopisz nowe pole elementowe na ko\2n\1cu listy - \7Alt-l\1,\,\r
+\-\r
+\+\r
+c) dopisz nowe \ pole \ elementowe \ przed \ (\3before\1) \ aktualnym \r
+\-\r
+\+\r
+ polem - \7Alt-b\1,\,\r
+\-\r
+\+\r
+d) dopisz nowe pole elementowe za (\3after\1) aktualnym polem \ - \r
+\-\r
+\+\r
+ \7Alt-a\1.\,\r
+\-\r
+\+\r
+Dopisywane \ \ pola \ \ s\2a \ \ \1zawsze \ \ \ polami \ \ \ nierozwini\2e\1tymi \r
+\-\r
+\+\r
+(nieterminalami).\,\r
+\-\r
+\+\r
+ Przyciski \7F1\1, \7F2 \1i \7Esc \ \1pe\2l\1ni\2a \ \1funkcje \ specjalne. \ \7F1 \r
+\-\r
+\+\r
+\1inicjuje wy\2s\1wietlanie przewodnik\2o\1w \ (help\2o\1w). \ \7F2 \ \1umo\2x\1liwia \r
+\-\r
+\+\r
+zmian\2e \ \1wielko\2s\1ci \ okienka \ edycyjnego, \ a \ \7Esc \ \1u\2x\1yte \ poza \r
+\-\r
+\+\r
+wprowadzanym lub modyfikowanym tekstem \ powoduje \ powr\2o\1t \ do \r
+\-\r
+\+\r
+menu g\2lo\1wnego.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\f\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 4. Okienko komunikacyjnee\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ W okienku komunikacyjnym wy\2s\1wietlane \ s\2a \ \1komunikaty \ o \r
+\-\r
+\+\r
+b\2le\1dach \ sk\2l\1adniowych \ \ w \ \ tekstach \ \ wprowadzanych \ \ przez \r
+\-\r
+\+\r
+u\2x\1ytkownika. W okienku tym u\2x\1ytkownik pytany jest r\2o\1wnie\2x \ \1o \r
+\-\r
+\+\r
+krotno\2sc \1wyst\2e\1powania pewnych konstrukcji \ (np. \ array_of \ i \r
+\-\r
+\+\r
+exit) w konstruowanym programie.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 5. Okienko informacyjne\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Jest ono umieszczone w ostatniej \ linii \ ekranu. \ Jego \r
+\-\r
+\+\r
+tre\2s\1ci\2a \1jest wykaz przycisk\2o\1w klawiatury dost\2e\1pnych w \ danym \r
+\-\r
+\+\r
+stanie edycji.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 6. Wywo\2l\1ywanie edytora\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Do \ \ poprawnego \ \ dzia\2l\1ania \ \ edytora \ \ pod \ \ \ systemem \r
+\-\r
+\+\r
+operacyjnym DOS niezb\2e\1dne s\2a \1nast\2e\1puj\2a\1ce pliki:\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+1) EDITOR0.EXE zawieraj\2a\1cy program edytora,\,\r
+\-\r
+\+\r
+2) EDIBASE0.DBA zawieraj\2a\1cy baz\2e \1danych edytora,\,\r
+\-\r
+\+\r
+3) EDIHELP0.DEF zawieraj\2a\1cy definicje przewodnik\2o\1w (help\2o\1w),\,\r
+\-\r
+\+\r
+4) EDIHELP0.HLP zawieraj\2a\1cy tre\2sc \1przewodnik\2o\1w (help\2o\1w).\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+ Edytor wywo\2l\1uje \ si\2e \ \1poleceniem \ EDITOR0. \ Na \ ekranie \r
+\-\r
+\+\r
+monitora \ powinno \ ukaza\2c \ \1si\2e \ \ \1w\2o\1wczas \ \ m.in. \ \ polecenie \r
+\-\r
+\+\r
+naci\2s\1ni\2e\1cia \ przycisku \ \7Enter\1. \ Wykonanie \ \ tego \ \ polecenia \r
+\-\r
+\+\r
+powoduje przj\2s\1cie do g\2lo\1wnego menu edytora.\,\r
+\-\/\f\r
+\+\r
+\^\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 7. Literatura\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \^\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\+\r
+[1] \ Bartol \ W.H. i inni: \ Report \ on \ the \ Loglan \ \ 82 \r
+\-\r
+\+\r
+ programming language. Institute of Informatics, \,\r
+\-\r
+\+\r
+ University of Warsaw, 1983.\,\r
+\-\r
+\+\r
+[2] Bartoszek \ J., \ Brzykcy \ G., \ Martinek \ J. \ System \ do \r
+\-\/\r
+\+\r
+ tworzenia \ \ \ \ edytor\2o\1w \ \ \ \ \ strukturalnych \ \ \ \ \ j\2e\1zyk\2o\1w \r
+\-\r
+\+\r
+ programowania, Studia z Automatyki, w druku.\,\r
+\-\r
+\+\r
+[3] Bartoszek \ J., \ Brzykcy \ \ G., \ \ Martinek \ \ J. \ \ Edytor \r
+\-\r
+\+\r
+ strukturalny j\2e\1zyka Loglan, Raport OI PP, Pozna\2n\1, 1988.\,\r
+\-\r
+\+\r
+[4] Bartoszek \ J., \ Brzykcy \ G., \ \ Martinek \ \ J., \ \ Edytor \r
+\-\r
+\+\r
+ strukturalny j\2e\1zyka Loglan. \ Analiza \ deklaracji.Raport \r
+\-\r
+\+\r
+ OI PP, Pozna\2n\1, 1989.\,\r
+\-\r
+\+\r
+[5] Bartoszek \ J. \ \ Brzykcy \ \ G., \ \ Martinek \ \ J. \ \ Edytor \r
+\-\r
+\+\r
+ strukturalny j\2e\1zyka Loglan. Analiza instrukcji, \ Raport \r
+\-\r
+\+\r
+ OI PP, Pozna\2n\1, 1989.\,\r
+\-\r
+\+\r
+\,\r
+\-\r
+\=\r
+\1a
\ No newline at end of file
--- /dev/null
+productions\r
+ID = id(STRING) -> id(STRING)\r
+ID_LIST = ID_LIST1 -> id_list(ID_LIST1)\r
+ID_LIST1 = ID+ separator comma\r
+\r
+VAR_LIST = VAR_LIST1 -> var_list(VAR_LIST1)\r
+VAR_LIST1 = VAR+ separator comma\r
+\r
+VAL_LIST = VAL_LIST1 -> val_list(VAL_LIST1)\r
+VAL_LIST1 = VAL+ separator comma\r
+\r
+AP_LIST = lpar AP_LIST1 rpar -> aplist(AP_LIST1)\r
+AP_LIST1 = APAR+ separator comma\r
+\r
+INDICES = A_EXPR+ separator comma\r
+\r
+EXF_LIST = WR_EXPR+ separator comma\r
+WR_EXPR = VAR_FUN WR_EXPR1 -> wr_exp(VAR_FUN,WR_EXPR1)\r
+WR_EXPR1 = colon A_EXPR WR_EXPR2 -> wr_exp1(A_EXPR,WR_EXPR2),\r
+ -> wr_exp11\r
+WR_EXPR2 = colon A_EXPR -> wr_exp2(A_EXPR),\r
+ -> wr_exp22\r
+ \r
+\r
+VAL = id(STRING) -> id(STRING),\r
+ int(INTEGER) -> int(INTEGER),\r
+ char(CHAR) -> char(CHAR)\r
+\r
+APAR = integer -> integer,\r
+ real -> real,\r
+ boolean -> boolean,\r
+ character -> character,\r
+ string -> string,\r
+ semaphore -> semaphore,\r
+ coroutine -> coroutine,\r
+ process -> process,\r
+ EXPR -> expr(EXPR)\r
+\r
+CS_TYPE = coroutine ->coroutine,\r
+ process -> process,\r
+ id(STRING) -> id(STRING)\r
+ \r
+A_EXPR = A_EXPR plus A_EXPR -> plus(A_EXPR,A_EXPR),\r
+ A_EXPR minus A_EXPR -> minus(A_EXPR,A_EXPR)\r
+ --\r
+ A_EXPR times A_EXPR -> times(A_EXPR,A_EXPR),\r
+ A_EXPR divides A_EXPR -> divides(A_EXPR,A_EXPR),\r
+ A_EXPR div A_EXPR -> div(A_EXPR,A_EXPR),\r
+ A_EXPR mod A_EXPR -> mod(A_EXPR,A_EXPR)\r
+ --\r
+ minus A_EXPR -> min(A_EXPR),\r
+ lpar A_EXPR rpar -> A_EXPR,\r
+ int(INTEGER) -> int(INTEGER),\r
+ r(REAL) -> r(REAL),\r
+ VAR_FUN -> var_fun(VAR_FUN)\r
+\r
+\r
+B_EXPR = B_EXPR or_ B_EXPR -> or_(B_EXPR,B_EXPR)\r
+ --\r
+ B_EXPR and_ B_EXPR -> and_(B_EXPR,B_EXPR)\r
+ --\r
+ ACO_EXPR nequal ACO_EXPR -> nequal(ACO_EXPR,ACO_EXPR),\r
+ ACO_EXPR equal ACO_EXPR -> equal(ACO_EXPR,ACO_EXPR),\r
+ A_EXPR lesseq A_EXPR -> lesseq(A_EXPR,A_EXPR),\r
+ A_EXPR less A_EXPR -> less(A_EXPR,A_EXPR),\r
+ A_EXPR greatereq A_EXPR -> greatereq(A_EXPR,A_EXPR),\r
+ A_EXPR greater A_EXPR -> greater(A_EXPR,A_EXPR),\r
+ O_EXPR is CS_TYPE -> is(O_EXPR,CS_TYPE),\r
+ O_EXPR in CS_TYPE -> in(O_EXPR,CS_TYPE)\r
+ --\r
+ not_ B_EXPR -> not_(B_EXPR),\r
+ lpar B_EXPR rpar -> B_EXPR,\r
+ ts lpar VAR rpar -> ts(VAR),\r
+ VAR_FUN -> var_fun(VAR_FUN),\r
+ true_ -> true_,\r
+ false_ -> false_\r
+ \r
+\r
+C_EXPR = VAR_FUN -> var_fun(VAR_FUN)\r
+ --\r
+ char(CHAR) -> char(CHAR)\r
+ \r
+O_EXPR = none -> none,\r
+ wait -> wait,\r
+ THIS dot O_EXPR1 -> dot(THIS,O_EXPR1),\r
+ this ID -> this(ID),\r
+ O_EXPR1 -> o_exp1(O_EXPR1)\r
+O_EXPR1 = O_EXPR2 dot O_EXPR1 -> dot(O_EXPR2,O_EXPR1),\r
+ O_EXPR3 -> o_exp3(O_EXPR3)\r
+O_EXPR2 = VAR_FUN2 qua ID -> qua(VAR_FUN2,ID),\r
+ O_EXPR3 -> o_exp3(O_EXPR3)\r
+O_EXPR3 = new ID lpar AP_LIST1 rpar ->new(ID,AP_LIST1),\r
+ new ID -> new1(ID),\r
+ VAR_FUN2 -> var_fun2(VAR_FUN2)\r
+\r
+AC_EXPR = A_EXPR -> a_exp(A_EXPR),\r
+ C_EXPR -> c_exp(C_EXPR)\r
+\r
+ACO_EXPR = A_EXPR -> a_exp(A_EXPR),\r
+ C_EXPR -> c_exp(C_EXPR),\r
+ O_EXPR -> o_exp(O_EXPR)\r
+\r
+EXPR = A_EXPR -> a_exp(A_EXPR),\r
+ B_EXPR -> b_exp(B_EXPR),\r
+ C_EXPR -> c_exp(C_EXPR),\r
+ O_EXPR -> o_exp(O_EXPR)\r
+\r
+THIS = this ID -> this(ID)\r
+\r
+VAR_FUN = THIS dot VAR_FUN1 -> dot(THIS,VAR_FUN1),\r
+ VAR_FUN1 -> var_fun1(VAR_FUN1)\r
+VAR_FUN1 = O_EXPR2 dot VAR_FUN1 -> dot(O_EXPR2,VAR_FUN1),\r
+ VAR_FUN2 -> var_fun2(VAR_FUN2)\r
+VAR_FUN2 = ID lpar AP_LIST1 rpar -> fcall(ID,AP_LIST1),\r
+ ID lbra INDICES rbra -> indvar(ID,INDICES),\r
+ id(STRING) -> id(STRING)\r
+ \r
+VAR = THIS dot VAR1 -> dot(THIS,VAR1),\r
+ VAR1 -> var1(VAR1)\r
+VAR1 = O_EXPR2 dot VAR1 -> dot(O_EXPR2,VAR1),\r
+ VAR2 -> var2(VAR2)\r
+VAR2 = ID lbra INDICES rbra -> indvar(ID,INDICES),\r
+ id(STRING) -> id(STRING)\r
+\r
+VAR_MAIN = main -> main,\r
+ VAR -> var(VAR)\r
+\r
+IF_B_EXPR = IF_B_EXPR orif IF_B_EXPR -> orif(IF_B_EXPR,IF_B_EXPR)\r
+ --\r
+ IF_B_EXPR andif IF_B_EXPR -> andif(IF_B_EXPR,IF_B_EXPR)\r
+ --\r
+ B_EXPR -> b_exp(B_EXPR)\r
+\r
+SIMP_EXPR = minus SIMP_EXPR1 -> min(SIMP_EXPR1),\r
+ int(INTEGER) -> int(INTEGER),\r
+ r(REAL) -> r(REAL),\r
+ id(STRING) -> id(STRING),\r
+ char(CHAR) -> char(CHAR),\r
+ str(STRING) -> str(STRING)\r
+\r
+SIMP_EXPR1 = int(INTEGER) -> int(INTEGER),\r
+ r(REAL) -> r(REAL),\r
+ id(STRING) -> id(STRING)\r
+\r
--- /dev/null
+ 1 Illegal character.\r
+ 3 Illegal keyword.\r
+ 4 Use the format CODE=dddd or TRAIL=dddd.\r
+ 5 This size must not exceed 64K.\r
+ 10 Illegal character.\r
+ 11 Character constants should be terminated by a '\r
+ 12 The comment is not terminated by */\r
+ 14 The name is too long. (max. 250 characters)\r
+ 15 The textstring is too long. (max. 250 characters)\r
+ 16 The textstring should be terminated with a " in the same line.\r
+ 17 Real constant is out of range.\r
+ 18 A hex digit is expected after a dollar sign.\r
+100 Undeclared domain (or mis-spelling).\r
+102 Standard domains must not be declared.\r
+103 This domain was declared previously.\r
+104 Syntax error: = or , expected.\r
+105 Name expected (either a domain or a functor).\r
+106 Alternatives in a list declaration are illegal.\r
+107 This functor has already been used in the domain declaration.\r
+108 Functor name expected.\r
+109 Domain name expected.\r
+110 Syntax error in domain declaration. ) or , expected.\r
+111 WARNING: Domain used as a functor. (F10=Ok, Esc=Abort).\r
+112 WARNING: Domain declaration with a single functor. (F10=Ok, Esc=Abort).\r
+200 Illegal start of domain declaration.\r
+201 This name is reserved for a standard predicate. \r
+202 This predicate is already declared.\r
+204 Domain name or ) expected.\r
+205 Undeclared domain or mis-spelling.\r
+206 Too many parameters used in this predicate.\r
+208 Syntax error in predicate declaration. ) or , expected.\r
+209 Illegal number of parameters.\r
+210 Only one database predicate declaration is allowed.\r
+211 This predicate is declared as a database predicate.\r
+220 Syntax error in declaration of global predicates: "-" expected.\r
+221 Syntax error. "(" expected.\r
+222 Syntax error in flowpattern. "i" or "o" expected\r
+223 Flowpattern has the wrong length.\r
+226 Syntax error. "predicates" or "domains" expected.\r
+227 Project name expected.\r
+228 At most one internal goal may be specified.\r
+229 The include file does not exist.\r
+230 Include files may not be used recursively. This file is already included.\r
+231 Too many include files. The maximum is 10.\r
+232 The include file is too big.\r
+233 "database" declarations must precede "predicates".\r
+234 Global predicates must be declared first.\r
+235 The FILE domain can not be a local domain.\r
+400 Syntax error. (Illegal start of predicate declaration).\r
+401 No clauses for this predicate.\r
+402 Syntax error. AND , or . expected.\r
+403 Predicate name expected.\r
+404 Undeclared predicate or mis-spelling.\r
+405 ( expected.\r
+406 ) or , expected.\r
+407 Illegal number of parameters: refer to declaration.\r
+408 This sign should be followed by a number.\r
+409 Syntax error - this token is misplaced.\r
+410 Variable expected.\r
+411 , expected.\r
+412 Syntax error.\r
+413 Syntax error. , | or ] expected.\r
+414 Number or variable expected.\r
+415 Clauses for the same predicate should be grouped.\r
+416 Comparison operator expected i.e. one of < <= >= >< <>. \r
+417 Text after . is prohibited here.\r
+418 Unexpected end of text.\r
+419 Syntax error in clause body.\r
+420 WARNING: The variable is only used once. ( F10=Ok, Esc=abort ).\r
+421 The parameter is missing.\r
+422 . :- or IF expected.\r
+423 , or ) expected.\r
+424 This facility is not implemented in this version.\r
+425 A list should be terminated by a ]\r
+426 Initializing a "database" is not allowed in a submodule.\r
+427 To generate an object module the program must contain a goal.\r
+428 The free variable in findall can only be used inside findall.\r
+429 The free variable in findall does not occur in the predicate.\r
+450 Syntax error.\r
+600 Too many domain names.\r
+601 Too many alternatives in the domain declaration.\r
+602 Too many predicate names.\r
+603 Too many parameters in this clause.\r
+604 Too many literals in this clause.\r
+605 Too many clauses.\r
+606 Too many arguments.\r
+607 Too many domain names on the left hand side of a domain declaration.\r
+608 Too many database predicates.\r
+610 Code array too small: use code=size to get more space.\r
+611 Trail array too small: use trail=size to get more space.\r
+612 Overflow: too many structures in clause.\r
+614 Object module too big. (split into smaller modules ).\r
+701 An internal system error has occurred. Please contact your dealer.\r
+1000 The parameters in makewindow are illegal.\r
+1001 The cursor values are illegal.\r
+1002 Stack overflow. Re-configure with Setup if necessary.\r
+1003 Heap overflow. Not enough memory or an endless loop.\r
+1004 Arithmetic overflow.\r
+1005 The window referred to is unknown.\r
+1006 There is not enough room in the editor for the text.\r
+1007 Heap overflow. Not enough memory or an endless loop.\r
+1008 Code overflow. Use code=size to get more space.\r
+1009 Trail overflow. Use trail=size to get more space.\r
+1010 Attempt to open a previously opened file.\r
+1011 Attempt to re-assign input device to a unopened file.\r
+1012 Attempt to re-assign output device to a unopened file.\r
+1013 'system' call tries to execute a program which is too big or resident.\r
+1014 Division by zero.\r
+1015 Illegal window number.\r
+1016 Maximun number of windows exceeded.\r
+1018 The file isn't open.\r
+1019 Illegal file mode. (Should be the range 0-1).\r
+1020 Free variables are not allowed here.\r
+1021 Negative values or Zero are not allowed as parameter to LOG and LN.\r
+1022 Negative values are not allowed as parameter to SQRT.\r
+1023 Overflow in real operation.\r
+2000 Not enough storage space for the text.\r
+2001 Can't execute a write operation.\r
+2002 Impossible to open : \r
+2003 Impossible to erase : \r
+2004 Illegal disk : \r
+2005 >>> Text buffer full <<<\r
+2006 Can't execute a read operation.\r
+2200 Type error.\r
+2201 Free variable in expression.\r
+2204 The variable will never become bound at this occurance.\r
+2205 Type error: Illegal variable type for this position.\r
+2206 Type error: The functor does not belong to the domain.\r
+2207 Type error: The compound object has the wrong number of arguments.\r
+2208 Expressions may not contain objects of this type.\r
+2209 Comparisons may only be made between standard types.\r
+2210 Objects from these domains cannot be compared.\r
+2211 There is no corresponding list domain.\r
+2212 Type error: This parameter can't handle compound objects.\r
+2213 Type error: This argument can't be a real.\r
+3001 Loop in the flow analysis. Don't use a compound flowpattern here.\r
+3002 WARNING: Composite flowpattern. (F10=ok, Esc=abort)\r
+3003 This flowpattern doesn't exist for the standard predicate.\r
+3004 Free variable in NOT.\r
+3005 Free variables are not allowed here.\r
+3006 The last variable in FINDALL must be free.\r
+3007 Free variable in expression.\r
+3008 WARNING: The variable is not bound in this clause. (F10=ok, Esc=abort)\r
+3009 WARNING: Two free variables in expression. (F10=ok, Esc=abort)\r
+3010 WARNING: Variable used twice with output flowpattern.(F10=ok, Esc=abort)\r
+3011 WARNING: this will create a free variable. ( F10=Ok, Esc=abort ).\r
+3012 The variable is not bound in this clause. ( Declare reference domain )\r
+3013 Two free variables in expression. ( Declare reference domain )\r
+3014 Variable used twice with output flowpattern. ( Declare reference domain )\r
+3015 This will create a free variable. ( Declare reference domain )\r
+3016 Occur check: A variabel can not contain itself.\r
+4001 WARNING: non deterministic clause. ( F10=Ok, Esc=abort ).\r
+4002 WARNING: non deterministic predicate. ( F10=Ok, Esc=abort ).\r
+5001 Error in reading symbol table.\r
+5003 Error in writing symbol table.\r
+5103 Use the graphics predicate to initialize the screen.\r
+5107 Illegal screen mode. (Should be in range 1-5).\r
--- /dev/null
+\r
+\r
+ EDYTOR STRUKTURALNY JEZYKA LOGLAN\r
+ wersja z listopada 1989 roku\r
+\r
+ Jerzy Bartoszek\r
+ Osrodek Informatyki Politechniki Poznanskiej\r
+ Pl. M.Sklodowskiej-Curie 5\r
+ 60-965 Poznan\r
+\r
+\r
+1.Do poprawnego dzialania edytora niezbedne sa\r
+ nastepujace pliki:\r
+ EDITOR0.EXE zawierajacy program edytora,\r
+ EDIBASE0.DBA zawierajacy baze danych,\r
+ EDIHELP0.DEF zawierajacy definicje helpow,\r
+ EDIHELP0.HLP zawierajacy tresc helpow.\r
+2.Plik EDYTRAP2.CHI zawiera instrukcje uzytkowania.\r
+ Podczas dzialania edytora jest dostepny\r
+ (za pomoca F1) help.\r
+3.Plik GRAMMAR0 zawiera gramatyke wyrazen wpisywanych\r
+ tekstowo przez uzytkownika. Postac tych wyrazen moze\r
+ nieznacznie odbiegac od standartu.\r
+4.Plik PROLOG.ERR zawiera teksty bledow prologowych.\r
+5.Edytor wywoluje sie poleceniem EDITOR0.\r
+ Jego dzialanie konczy Quit z glownego menu.\r
+\r
--- /dev/null
+ \r
+ Warsaw 1990, Michal Pakier\r
+ \r
+ Loglan Environment Manager \r
+ --------------------------\r
+ \r
+1:Program installation\r
+----------------------\r
+ Just run LOTEK.EXE - the system contains some additional files but you\r
+ need not know anything about that. \r
+ \r
+ The whole system comprises of the following files :\r
+ LOTEK.EXE - main program,\r
+ MPLOGED.EXE - editor,\r
+ LSTTEST.EXE - auxiliary file used during compilation,\r
+ LOTEK.HLP - help file text,\r
+ LOTEKINS.EXE - installation file. \r
+\r
+2:Text editor \r
+-------------\r
+ You may treat the whole program as a Loglan-oriented editor.\r
+ It supports the following facilities : \r
+ 1.Block operations \r
+ All common block operations, such as deleting, moving, copying,\r
+ indenting, unindenting, saving, loading, are implemented as well as some\r
+ sophisticated ones : moving and copying with whole block adjusting,\r
+ making a frame in comments for blocks (you may set such frame parameters\r
+ as width, pattern, text adjusting inside the block).\r
+ You may also copy or move a block into itself (while moving,the block\r
+ will be adjusted in such a way that the block beginning will be placed\r
+ at the cursor position).\r
+ 2.Find and replace word operations \r
+ You may find or find and replace given word or the word pointed\r
+ by the cursor. You may also change small letters into capital ones\r
+ (or the other way round) in Loglan keywords globally or locally.\r
+ There is a function that changes all the characters into small \r
+ or capital letters (globally, locally or in comments).\r
+ 3.Fast moving round the text \r
+ You may mark two positions in the text and go to that places \r
+ from anywhere. You may go to the text beginning or end, too. \r
+ 4.Help \r
+ You may always press the F1 key to get short review of all available \r
+ at the moment operations.\r
+ 5.Macro instructions\r
+ They really make writing programs much easier than when you have to get\r
+ round without them.\r
+ You may bind a macro instruction to every key from among [a..z,0..9,\r
+ F1..F10]. A macro is then called just by pressing the Alt key \r
+ with desired key.\r
+ A macro may be any sequence of characters. Using macros you may define\r
+ on-line some useful operarations, eg inserting a blank line, upcasing\r
+ words, marking blocks, ...\r
+ 6.File handling \r
+ The following operations are implemented :\r
+ loading a file from disc, \r
+ editing a file (unnamed new file has name 'noname.log'),\r
+ saving a file to disc,\r
+ changing a file name.\r
+ You may also choose a file for editing from among last ten used.\r
+ \r
+3:Windows\r
+---------\r
+ You may use three windows.\r
+ The first one is the main window, in which you may process everything that\r
+ is supported by the system. In the second window you cannot only compile\r
+ programs and process operations from window 'Execute'. The third window \r
+ does not let you edit but is used for viewing the database that contains\r
+ data about Loglan.\r
+ You may use up to two windows at the same time. The main window is always\r
+ visible so you cannot use both of the additional windows at the same time.\r
+ While being in the main window you may move or copy a block from another\r
+ visible window (all options are available).\r
+\r
+4:Compiling\r
+-----------\r
+ You may compile a file from the main window without returning to DOS.\r
+ You may execute the first, the second pass of compilation, run compiled\r
+ program, trace run program.\r
+ You do not have to remember which passes of compilation have been executed\r
+ or whether have they been executed at all - LOTEK will take care of it.\r
+ You may view found errors after the first pass of compilation. Information\r
+ about errors will displayed in the bottom line and the cursor will indicate\r
+ the position of its occurence.\r
+ \r
+5:Window 'Execute'\r
+------------------\r
+ You may define this window during the installation. It lets you call any DOS\r
+ function or any executable program. After this call you will find yourself\r
+ back in the editor as if you were doing nothing but editing. You may pass\r
+ command line parameters (name of edited file) to called programs, too.\r
+ \r
+6:Database\r
+----------\r
+ It is meant to be a database on Loglan but you may set any other database \r
+ instead (created by program MPH) during installation.\r
+ Such a database consists of maximum 6 windows, every of which may comprise\r
+ of maximum 22 lines. Every line is mapped to any length contents and every\r
+ contents line is mapped to any length text.\r
+ While viewing the database you may evoke some of the editor functions :\r
+ namely finding given word and marking a block. A marked block may be later on\r
+ moved to the main program.\r
+ It is possible to have the information from the database you are interested\r
+ in in one window and to edit your program in the main window.\r
+7:Using LOTEK\r
+--- ----------\r
+ Just run the program LOTEK.\r
+ There are displayed all the functions available at the moment at the bottom\r
+ of the screen. If you want to have more room for editing, just press the F10\r
+ key and this information will disappear. \r
+ LOTEK saves all the options on file MPLED.DAT before exit, so when you run\r
+ LOTEK once more you will find yourself in exactly the same conditions \r
+ (ie the same file, the same cursor position, the same options, ...) as you\r
+ were in when using LOTEK for the last time.\r
+ The editor has a built-in mechanism protecting the monitor - there will\r
+ appear a sky on the screen after two minutes during which you have not \r
+ pressed any key. The sky will vanish when you press any key.\r
+ LOTEK always saves the last but one version of the program, which is being\r
+ edited, so you have a copy of the program. This file's name is the same as\r
+ yours file but its extension is .BAK.\r
+ \r
+ \1a
\ No newline at end of file
--- /dev/null
+(* Loglanizator Tekstowy wersja 1.0 1990 Warszawa Michal Pakier *)\r
+===============REKORD 1=======================================|===============\r
++ 22 2\r
+ Using the editor LOTEK version 1.0\r
+ \r
+ ³F2..............Save File\r
+Scrolling text ³ cursor moves ³F3........File operations\r
+ by line: ³ one word ³F4..Errors of compilation\r
+^U.............up ³ relatively to ³F8.....Auxiliary programs\r
+^D...........down ³ the line above ³F9......Compilation & run\r
+ by page: ³^N........to right³F10...........Menu on/off\r
+PgDn.........down ³^P.........to left³F5................Windows\r
+PgUp...........up ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ-\r
+ Jump to ³^K.......block operations³^Y.....delete line\r
+^PgDn.....begin of³^Q.......replace & search³\r
+ text ³^J..........Jumps in text³ delete character\r
+^PgUp.......end of³^W....Windows operations ³BackSpace..to left\r
+ text ³^V.........Macrocommands ³Del.......to right\r
+^Home.....begin ofÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ-\r
+ window ³^A...............delete to the begin of line\r
+^End.......end of ³^S.................delete to the end of line\r
+ window ³F1........On line HELP;press when in trouble\r
+ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ-\r
+ \r
+ Help on HELP press <0>\r
+===============REKORD 2=======================================|===============\r
++ 11\r
+ HELP on HELP.\r
+ \r
+ In any moment you can press the key F1 and obtain an infor-\r
+mation on currently available actions. It may suggest further\r
+request of more detailed informations. In such a case press one\r
+of keys {0,1,2,3,4,5,6,7,8,9}, which is shown on screen in the\r
+angles e.g.<2>.\r
+ \r
+ \r
+ Esc leaving Help\r
+ F1 principal information of Help\r
+===============REKORD 3=======================================|===============\r
++ 8 4\r
+ Saving file on disk (F2,F3S)\r
+ \r
+It may happen that for some reason we cannot write file back to\r
+the directory from which it is read. In such a case press (F3L)\r
+and choose the directory in which we have all rights next you\r
+can write file using F3 W.\r
+ \r
+ More on file operations, press <0>\r
+===============REKORD 4=======================================|===============\r
++ 15 23 3 24 25 26 41\r
+ File operations (F3)\r
+ \r
+permit to load, write file or to begin a new file to edit\r
+ \r
+Your choices:\r
+ \r
+ L Loading a file from disk <0>\r
+ S Saving file on disk <1>\r
+ N New file edition <2>\r
+ W Write a file on disk <3>\r
+ P Pick one of the lastly used files <4>\r
+ O different Options <5>\r
+ G Information on the edited files and on\r
+ free memory\r
+ Q Quit the LOTEK environment\r
+===============REKORD 5=======================================|===============\r
++ 16\r
+ Correction of ERRORS\r
+ \r
+This option facilitates correction of errors in Loglan program.\r
+In the lowest line you see number of line with error and short\r
+description of the error. The cursor is placed on the error's\r
+occurrence. In certain cases it locates precisely the line and\r
+the column of error, if it is not the case then only line is\r
+shown and its first column. If you have menu bar (F10) then a\r
+submenu concerning errors' scrolling appears.\r
+You have the following choices:\r
+ Ctrl F5 - Move to the first error\r
+ Ctrl F6 - Move to the last error\r
+ Ctrl F8 - Show Next error\r
+ Ctrl F7 _ Show previous error\r
+ Ctrl F10 - Exit from the mode errors' corrrection\r
+Press F4 for exit from errors' correction.\r
+===============REKORD 6=======================================|===============\r
++ 8\r
+ CHANGING WINDOW\r
+ \r
+ You can open a new window or change the active one.\r
+ F Full screen all other windows are closed\r
+ H Help on Loglan here you can consult doc on Loglan\r
+ use Tab to move between documents\r
+ A Auxiliary window\r
+ M Main window\r
+===============REKORD 7=======================================|===============\r
++ 17 22\r
+ AUXILIARY PROGRAMS\r
+ \r
+You can execute programs which appear in this window without\r
+exiting LOTEK. This window may be defined by you (see lotek.pth\r
+and LOTEKINS.EXE). It enables, among others, certain operations\r
+on the file being edited, the name of the file is transmitted\r
+as parameter to the called program. As one of options you can\r
+put the LOTEKINS program which can facilitate modifications of\r
+the window. You can put a call of a program in this window in-\r
+to a macrocommand <0>.\r
+(Example: If we have a computer with two monitors and if you\r
+put instructions C COLOR (mode co80) and M MONO (mode mono)\r
+then macrocommand <AltH> @8M@5H@5F will allow to consult do-\r
+cumentation on the monitor controlled by Hercules card and\r
+macro <AltM> @8C@5M@5F will permit editing on a colour monitor,\r
+still having database on Loglan on white & black monitor.)\r
+ \r
+===============REKORD 8=======================================|===============\r
++ 11 36\r
+ COMPILING YOUR PROGRAM\r
+ \r
+Your choices are:\r
+ L: Pass 1 Compilation-first phase(program Loglan). During\r
+ this pass all syntax errors are detected.(Use F4)\r
+ G: Pass 2 Second or First and second phase of compilation\r
+ (program Gen).\r
+ R: Run Program execution (with compilation if needed).\r
+ D: Debuger First the program is executed and then you can\r
+ watch command after command its execution.\r
+ O: Options Different options of compilation <0>\r
+===============REKORD 9=======================================|===============\r
++ 17 27 28 29 30 31 32 33 34 35\r
+ OPERATIONS ON BLOCKS\r
+ \r
+Press Ctrl_K and then a key which corresponds to the desired\r
+action. If you do not know what to choose wait 2 secs. and\r
+a frame will appear with all options.\r
+ \r
+Your choices are:\r
+ \r
+ K,B,T,L - marking a block <0>\r
+ Y - deleting the marked block <1>\r
+ C,V - copying and moving the block <2>\r
+ S,M - copying and moving with indentation <3>\r
+ R,W - block to and from the disk <4>\r
+ U,I - shifting the block <5>\r
+ H - hiding the block <6>\r
+ F - framing a block (e.g. a comment) <7>\r
+ O - options <8>\r
+===============REKORD 10=======================================|===============\r
++ 13 37 38 39 40\r
+ GO TO INDICATED PLACE IN TEXT\r
+ \r
+Press Ctrl_J and then a key which corresponds to the desired\r
+action. If you do not know what to choose wait 2 secs. and\r
+a frame will appear with all options.\r
+ \r
+Your choices are:\r
+ \r
+ S - mark this place for return <0>\r
+ R - return to the marked place <1>\r
+ J - jump to the marked place <2>\r
+ L - jump to the given line\r
+ B,K - jump to the begin (resp. to the end) of block <3>\r
+===============REKORD 11=======================================|===============\r
++ 17 15 16 17 18 19 20\r
+ Search and replace operations\r
+ \r
+Press Ctrl_Q and then a key which corresponds to the desired\r
+action. If you do not know what to press wait 2 secs. and\r
+a frame with options will appear.\r
+ \r
+Your choices:\r
+ \r
+ F - find a word <0>\r
+ A - Alter find a word and replace <1>\r
+ C - replace character <2>\r
+ K - replace key words <3>\r
+ T - find another occurrence of the current word <4>\r
+ R - find and replace word currently pointed by cursor <5>\r
+ \r
+REMARK: Pressing Ctrl L you can repeat the lastly executed\r
+ action of searching/replacing.\r
+===============REKORD 12=======================================|===============\r
++ 13 14\r
+ Documentation on Loglan - Loglan's database\r
+ \r
+ Each line on the screen is a title of a section.\r
+ Press ENTER to see the highlighted section.\r
+ \r
+ Press Tab (& cursor left, right) to change (choose) a document\r
+ or a chapter.\r
+ cursor up - prevoius section,\r
+ cursor down - next section,\r
+ Ctrl PgUp - to the begin of list of sections,\r
+ Ctrl PgDn - to the end of list of sections,\r
+ PgUp,PgDn - previous (next) page of list of sections,\r
+ Ctrl_Q_F - searching a word.\r
+===============REKORD 13=======================================|===============\r
++ 11 12 14\r
+ Loglan's database - in a section\r
+ \r
+ Enter - return yo the list of sections <0>\r
+ Tab - change(choose) a document, a chapter <1>\r
+ Up,Down,Left,Right - moving the cursor\r
+ Home,End - to the begin (end) of line\r
+ Ctrl PgUp - to the begin of text\r
+ Ctrl PgDn - to the end of text\r
+ PgUp,PgDn - page up (page down)\r
+ Ctrl_K_B,K,L,T - marking a block\r
+ Ctrl_Q_F - searching a word\r
+===============REKORD 14=======================================|===============\r
++ 9\r
+ Loglan's database - CHOOSING A DOCUMENT\r
+ \r
+ On the screen you see names of documents to consult.\r
+Use cursor left & right to choose the type of document:\r
+ opisy=reports, funkcje=functions, tablice=tables.\r
+Use cursor up & down, or Home & End to choose a document.\r
+Press Enter to confirm your choice and to see the chosen doc.\r
+ \r
+ Press Esc to return to your last choice.\r
+===============REKORD 15=======================================|===============\r
++ 13\r
+ (F) Searching a word\r
+ \r
+Give a word you are looking for (Find :?).\r
+Next define the options. Then search is performed according to\r
+your choice of options. If word is found the cursor is located\r
+after it.\r
+You can choose the options:\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n.................................searching of n-th occurrence.\r
+ U.........................upper & lower case lettersidentified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+===============REKORD 16=======================================|===============\r
++ 16\r
+ (A) Replace a word (alter)\r
+ \r
+First, give a word to be replaced (Find :?)\r
+Second, give a word to be put into (Replace with :?)\r
+Third, define options.\r
+Search & replace action begins: if a searched word is found then\r
+at the top of the screen you see a demand of confirmation.\r
+ \r
+The options are :\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n..............................replacing up to n-th occurrence.\r
+ U.........................upper & lower case lettersidentified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+ N.......... .uNconditional replace (no confirmation required).\r
+===============REKORD 17=======================================|===============\r
++ 11\r
+ (C) Replace Characters\r
+ \r
+This functionality enable to exchange capital letters to small\r
+ones and viceversa:\r
+ D..........................................Put capital letters.\r
+ S............................................Put small letters.\r
+ G........Global replace from the begin or from the end of text.\r
+ B.............................................Backward replace.\r
+ L.........................Replace inside the highlighted block.\r
+ C.................................Replace inside comments only.\r
+ T..................................Replace inside program only.\r
+===============REKORD 18=======================================|===============\r
++ 10\r
+ (K) Replace keywords of Loglan\r
+ \r
+This function permits to put all the keywords of Loglan in the\r
+selected case (lower or upper).\r
+Your choices are:\r
+ D.......................................Put in capital letters.\r
+ S.........................................Put in small letters.\r
+ G........Global replace from the begin or from the end of text.\r
+ B.............................................Backward replace.\r
+ L............................Replace inside thehighlited block.\r
+===============REKORD 19=======================================|===============\r
++ 12\r
+ (T) Searching the word indicated by cursor\r
+ \r
+If word is found the cursor is located after it.\r
+You can choose the options:\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n.................................searching of n-th occurrence.\r
+ U........................upper & lower case letters identified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+===============REKORD 20=======================================|===============\r
++ 15\r
+ (R) Search andReplace the word indicated by cursor\r
+ \r
+Give a word to be put into (Replace with :?)\r
+Next, define options.\r
+Search & replace action begins: if a searched word is found then\r
+at the top of the screen you will see a demand of confirmation.\r
+ \r
+The options are :\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n.................................replacing up n-th occurrence.\r
+ U.........................upper & lower case lettersidentified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+ N.......... .uNconditional replace (no confirmation required).\r
+===============REKORD 21=======================================|===============\r
++ 13 29 30\r
+ Exchange block between windows and other operations\r
+ \r
+Press Ctrl_W and then a key which corresponds to the desired\r
+action. If you wait 2 secs. then a frame appears with choices\r
+suggested.\r
+ \r
+Options to choose:\r
+ C - copy the block from the second, visible on screen window,\r
+ V - move the block from the second, visible on screen window,\r
+ S - copy with indentation from the other window,\r
+ M - move with indentation from the other window.\r
+ \r
+More on C,V <0> More on S,M <1>\r
+===============REKORD 22=======================================|===============\r
++ 19\r
+ Defining macrocommands\r
+ \r
+You can create, store and apply your macrocommands i.e. the\r
+sequences of keys. A macrocommand can be associated with a let-\r
+ter, digit or an F key. A macrocommand is executed when you\r
+press simultaneously Alt+corresponding key.\r
+Definition of a macrocommand may contain usual characters ASCII\r
+and also the following combinations of keys:\r
+ ^.............denotes Ctrl + following key (A..Z and 0..9)\r
+ &..............denotes Alt + following key (A..Z and 0..9)\r
+ @........denotes a functional key. The next key may be :\r
+ 1..0 - F1..F10 ³ <>^v - cursor ³ H - Home ³ E - End ³\r
+ U - PgUp ³ D - PgDn ³ I - Insert ³ L - Delete ³\r
+ S - Esc ³ B - Backspace ³ ³ ³\r
+ C - Enter ³ ³ ³ ³\r
+ #......the next character is not interpreted e.g.## denotes #\r
+Braces permit to iterate the string inside them.\r
+E.g. the string {^C(* *)}12 will cause cration of 12 new lines\r
+containing the string "(* *)"\r
+===============REKORD 23=======================================|===============\r
++ 17\r
+ (L) Loading a file\r
+ \r
+You can enter a file name or a mask e.g. *.log defining a group\r
+of files. In the first case the file is loaded (or initialized)\r
+In the second case all names that correspond to the mask are\r
+shown.\r
+ \r
+>>>You can press:\r
+ Esc.........Return without loading anything\r
+ \r
+ \18 \19 < >......................Moving in window.\r
+ Enter.........If a file is indicated then it is loaded\r
+ If a directory is indicated then it is opened\r
+ \r
+ PgUp,PgDn......Previous or next page\r
+ (the window contains maximum 20 names).\r
+ F4............change directory\r
+===============REKORD 24=======================================|===============\r
++ 5\r
+ (N) New file editing\r
+ \r
+The scrren is emptied and an edition of the file NONAME.LOG\r
+begins. At saving time Lotek will propose to change the name\r
+of the file.\r
+===============REKORD 25=======================================|===============\r
++ 5\r
+ (W) Save the edited file as ...\r
+ \r
+It permits to change the name of the edited file and to save it\r
+in the current directory.(see L option for change of directory)\r
+ \r
+===============REKORD 26=======================================|===============\r
++ 4\r
+ (P) Pick up\r
+ \r
+you can choose a name among lastly edited files or Load (L)\r
+ \r
+===============REKORD 27=======================================|===============\r
++ 6\r
+ Marking a block\r
+ \r
+ B - mark begin of block,\r
+ K - mark end of block,\r
+ T - mark the word indicated by cursor as a block,\r
+ L - mark the line indicated by cursor as a block.\r
+===============REKORD 28=======================================|===============\r
++ 3\r
+ Deleting block\r
+ \r
+ You can delete the marked block.\r
+===============REKORD 29=======================================|===============\r
++ 15 30\r
+ (C,V) Copying or moving the highlighted block\r
+ \r
+Function.C. copies the highlighted block (Ctrl K + B,K,T,L)\r
+to the current position of cursor.\r
+Begin of the block will be positioned exactly on the cursor.\r
+Other lines are not shifted.\r
+ \r
+REMARK: One can copy the block into itself.\r
+ \r
+Function.V. moves the highlighted block (Ctrl K+ B,K,T,L)\r
+to the current position of cursor.\r
+The earlier occurrence of the block dissapears.\r
+Begin of the block will be positioned exactly on the cursor.\r
+Other lines are not shifted.\r
+ \r
+ ----> Ctrl K S,M <0>\r
+===============REKORD 30=======================================|===============\r
++ 18 29\r
+ (S,M) Copy or Move the block with indentation\r
+ \r
+Function.S. copies the highlighted block (Ctrl K + B,K,T,L)\r
+to the current position of cursor. It differs however from\r
+the function Ctrl K C. All lines of the block will begin in\r
+the position of cursor.\r
+ \r
+REMARK: One can copy the block into itself.\r
+ \r
+Function.M. moves the highlighted block (Ctrl K+ B,K,T,L)\r
+to the current position of cursor. It differs however from\r
+the function Ctrl K V. All lines of the block will begin in\r
+the position of cursor.\r
+The earlier occurrence of the block dissapears.\r
+ \r
+REMARK: If you move the block into itself it will result in\r
+shifting it horizontally, it will move to the cursor position.\r
+ -----> Ctrl K C,V <0>\r
+===============REKORD 31=======================================|===============\r
++ 10 23 25\r
+ (R,W) Reading and Writing a block\r
+ \r
+Function R enables inclusion of a file from the disk.\r
+The file is included in the current postion of the cursor\r
+without indentation (as Ctrl K C does).\r
+A window appears and you can choose the name of file\r
+ see F3 L <0>\r
+Function W enables saving of the block on disk.\r
+A window appears and you can choose the name of file\r
+ see F3 W <1>\r
+===============REKORD 32=======================================|===============\r
++ 8\r
+ (I,U) Shift the block to right or to left\r
+ \r
+Function.I.shifts all lines of the block one position to left.\r
+ It applies to the full first and last line of the block.\r
+ \r
+Function.U.shifts all lines of the block one position to right.\r
+ It applies to the full first and last line of the block.\r
+ \r
+===============REKORD 33=======================================|===============\r
++ 5\r
+ Hiding block\r
+ \r
+ You can unmark the marked block.\r
+If you repeat this action then the block is marked again.\r
+ \r
+===============REKORD 34=======================================|===============\r
++ 6 35\r
+ (F) Frame around a block\r
+ \r
+ If you selected a block then a frame can be put around it.\r
+Options permit to define parameters of the frame.\r
+Each line is enclosed in (* *) i.e. it is a comment.\r
+ -----> Ctrl K O <0>\r
+===============REKORD 35=======================================|===============\r
++ 19\r
+ (O) Parameters of frames\r
+ \r
+3 lines determine the pattern of frame\r
+ define 3 characters for top, inside and bottom lines of frame.\r
+ - top line: leftmost, inside, rightmost character;\r
+ - inside line: leftmost, inside, rightmost character;\r
+ - bottom line: leftmost, inside, rightmost character;\r
+ F............................Position of first column of frame.\r
+ - must be between 0..255,\r
+ - must be less then L, the last column of frame,\r
+ - 0 has a special meaning:frame will begin in the first\r
+ column of indicated text,\r
+ L.....................Position of the last column of the frame\r
+ - must be between 0..255\r
+ - must be greater then F, the first column of frame\r
+ - 0 has a special meaning: frame will end in the last column\r
+ of indicated text,\r
+ T.....Put text in the frame: to the LEFT, to the RIGHT, CENTER\r
+ in frame.\r
+===============REKORD 36=======================================|===============\r
++ 14\r
+ Compilation options\r
+ \r
+ \r
+ \r
+D: Debug info on/off Debug on causes: firstly - execution\r
+ of the program is recorded on special file, secondly - you can\r
+ watch the sequence of executed commands.\r
+ \r
+M: Memory ______ Divided by 4 amount of memory atributed\r
+ to our pogram. It may assume values from 16384 to 100000.\r
+ If you can select 16384 to accelerate the program.\r
+ \r
+C: Cursor on/off For amateurs only. It enables to hide\r
+ cursor during the program execution.\r
+===============REKORD 37=======================================|===============\r
++ 4\r
+ (S) Marking a place in the text\r
+ \r
+This function memorises the current position of the cursor.\r
+It is possible to reposition cursor quickly in this place.\r
+===============REKORD 38=======================================|===============\r
++ 5\r
+ (R) Go to the marked place and ...\r
+ \r
+The difference with respect to Ctrl J J lies in that befor we\r
+move to an earlier marked place, we mark the current position\r
+This enables a return with commands Ctrl J J/R.\r
+===============REKORD 39=======================================|===============\r
++ 4\r
+ (J) Go to an earlier marked place\r
+ \r
+Cursor is moved to the place which was earlier marked with the\r
+use of Ctrl J S command\r
+===============REKORD 40=======================================|===============\r
++ 4\r
+ Go to block\r
+ \r
+ B - go to the begin of the highlighted block\r
+ K - go to the end of the highlighted block\r
+===============REKORD 41=======================================|===============\r
++ 20\r
+ File options (F3O)\r
+ \r
+Your choices:\r
+ \r
+ S..it is the number of line dividing two windows of Lotek.\r
+ (e.g. between main file and auxiliary file or between\r
+ main file and Loglan's database),\r
+ B..backups? If your answer is yes then saving file on disk\r
+ causes that the previous version of the file is saved\r
+ with an extension .BAK\r
+ \r
+ D..Delay of idle time.\r
+ If no key is pressed during D time then the screen shows\r
+ a sky with stars blinking.\r
+ \r
+ W..delay of showing menus.\r
+ If you choose an action of editor say Ctrl+K then first\r
+ you see the headline of a menu window and the window\r
+ itself appear after W time.\r
+ \r
+=============KONIEC============================================|==============\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
--- /dev/null
+ \r
+ Warsaw 1990, Michal Pakier\r
+ \r
+ Loglan Environment Manager \r
+ --------------------------\r
+ \r
+1:Program installation\r
+----------------------\r
+ Just run LOTEK.EXE - the system contains some additional files but you\r
+ need not know anything about that. \r
+ \r
+ The whole system comprises of the following files :\r
+ LOTEK.EXE - main program,\r
+ MPLOGED.EXE - editor,\r
+ LSTTEST.EXE - auxiliary file used during compilation,\r
+ LOTEK.HLP - help file text,\r
+ LOTEKINS.EXE - installation file. \r
+\r
+2:Text editor \r
+-------------\r
+ You may treat the whole program as a Loglan-oriented editor.\r
+ It supports the following facilities : \r
+ 1.Block operations \r
+ All common block operations, such as deleting, moving, copying,\r
+ indenting, unindenting, saving, loading, are implemented as well as some\r
+ sophisticated ones : moving and copying with whole block adjusting,\r
+ making a frame in comments for blocks (you may set such frame parameters\r
+ as width, pattern, text adjusting inside the block).\r
+ You may also copy or move a block into itself (while moving,the block\r
+ will be adjusted in such a way that the block beginning will be placed\r
+ at the cursor position).\r
+ 2.Find and replace word operations \r
+ You may find or find and replace given word or the word pointed\r
+ by the cursor. You may also change small letters into capital ones\r
+ (or the other way round) in Loglan keywords globally or locally.\r
+ There is a function that changes all the characters into small \r
+ or capital letters (globally, locally or in comments).\r
+ 3.Fast moving round the text \r
+ You may mark two positions in the text and go to that places \r
+ from anywhere. You may go to the text beginning or end, too. \r
+ 4.Help \r
+ You may always press the F1 key to get short review of all available \r
+ at the moment operations.\r
+ 5.Macro instructions\r
+ They really make writing programs much easier than when you have to get\r
+ round without them.\r
+ You may bind a macro instruction to every key from among [a..z,0..9,\r
+ F1..F10]. A macro is then called just by pressing the Alt key \r
+ with desired key.\r
+ A macro may be any sequence of characters. Using macros you may define\r
+ on-line some useful operarations, eg inserting a blank line, upcasing\r
+ words, marking blocks, ...\r
+ 6.File handling \r
+ The following operations are implemented :\r
+ loading a file from disc, \r
+ editing a file (unnamed new file has name 'noname.log'),\r
+ saving a file to disc,\r
+ changing a file name.\r
+ You may also choose a file for editing from among last ten used.\r
+ \r
+3:Windows\r
+---------\r
+ You may use three windows.\r
+ The first one is the main window, in which you may process everything that\r
+ is supported by the system. In the second window you cannot only compile\r
+ programs and process operations from window 'Execute'. The third window \r
+ does not let you edit but is used for viewing the database that contains\r
+ data about Loglan.\r
+ You may use up to two windows at the same time. The main window is always\r
+ visible so you cannot use both of the additional windows at the same time.\r
+ While being in the main window you may move or copy a block from another\r
+ visible window (all options are available).\r
+\r
+4:Compiling\r
+-----------\r
+ You may compile a file from the main window without returning to DOS.\r
+ You may execute the first, the second pass of compilation, run compiled\r
+ program, trace run program.\r
+ You do not have to remember which passes of compilation have been executed\r
+ or whether have they been executed at all - LOTEK will take care of it.\r
+ You may view found errors after the first pass of compilation. Information\r
+ about errors will displayed in the bottom line and the cursor will indicate\r
+ the position of its occurence.\r
+ \r
+5:Window 'Execute'\r
+------------------\r
+ You may define this window during the installation. It lets you call any DOS\r
+ function or any executable program. After this call you will find yourself\r
+ back in the editor as if you were doing nothing but editing. You may pass\r
+ command line parameters (name of edited file) to called programs, too.\r
+ \r
+6:Database\r
+----------\r
+ It is meant to be a database on Loglan but you may set any other database \r
+ instead (created by program MPH) during installation.\r
+ Such a database consists of maximum 6 windows, every of which may comprise\r
+ of maximum 22 lines. Every line is mapped to any length contents and every\r
+ contents line is mapped to any length text.\r
+ While viewing the database you may evoke some of the editor functions :\r
+ namely finding given word and marking a block. A marked block may be later on\r
+ moved to the main program.\r
+ It is possible to have the information from the database you are interested\r
+ in in one window and to edit your program in the main window.\r
+7:Using LOTEK\r
+--- ----------\r
+ Just run the program LOTEK.\r
+ There are displayed all the functions available at the moment at the bottom\r
+ of the screen. If you want to have more room for editing, just press the F10\r
+ key and this information will disappear. \r
+ LOTEK saves all the options on file MPLED.DAT before exit, so when you run\r
+ LOTEK once more you will find yourself in exactly the same conditions \r
+ (ie the same file, the same cursor position, the same options, ...) as you\r
+ were in when using LOTEK for the last time.\r
+ The editor has a built-in mechanism protecting the monitor - there will\r
+ appear a sky on the screen after two minutes during which you have not \r
+ pressed any key. The sky will vanish when you press any key.\r
+ LOTEK always saves the last but one version of the program, which is being\r
+ edited, so you have a copy of the program. This file's name is the same as\r
+ yours file but its extension is .BAK.\r
+ \r
+ \1a
\ No newline at end of file
--- /dev/null
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ IIUWGRAF\r
+\r
+ biblioteczka podstawowych procedur graficznych\r
+\r
+ moze wspolpracowac z kompilatorami firmy Microsoft:\r
+\r
+ Fortran 77 wersja 3.31 i 4.00\r
+ Pascal wersja 3.31\r
+\r
+ oraz\r
+ \r
+ C (Lattice) wersja 3.10\r
+ Aztec C wersja 3.20d\r
+\r
+ \r
+\r
+ dla IBM PC/XT\r
+\r
+ obsluguje karty IBM color/graphics, Hercules II oraz EGA\r
+\r
+\r
+\r
+\r
+\r
+\r
+ wersja 2.2, grudzien 1987\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ Autorzy:\r
+\r
+ Piotr Carlson\r
+ Miroslawa Milkowska - procedury poziomu 1\r
+\r
+ Janina Jankowska\r
+ Michal Jankowski - procedury poziomu 2\r
+\r
+\r
+ Osrodek Obliczeniowy Instytutu Informatyki\r
+ Uniwersytet Warszawski\f\r
+\r
+\r
+ 2\r
+\r
+\r
+ \r
+ Spis tresci\r
+ \r
+ \r
+ Informacje ogolne 3\r
+ Procedury poziomu 1 4\r
+ Procedury ustawiania trybu 5\r
+ Procedury sterujace kolorami 8\r
+ Procedury ustawiania pozycji 11\r
+ Procedury obslugujace punkty 12\r
+ Procedury rysowania linii 13\r
+ Procedury operujace na fragmentach ekranu 15\r
+ Procedury wejscia/wyjscia dla pojedynczych znakow 16\r
+ Procedury wejscia/wyjscia dla linii 18\r
+ Procedury wejscia/wyjscia dla okienek 19\r
+ Procedury poziomu 2 20\r
+ Informacje dodatkowe 22\r
+ Procedury dodatkowe 22\r
+ \r
+ \r
+ \r
+ Dodatki\r
+ \r
+ A. Uzycie IIUWGRAFu z FORTRANem 77 23\r
+ B. Uzycie IIUWGRAFu z Pascalem 24\r
+ C. Uzycie IIUWGRAFu z Lattice C 25\r
+ D. Uzycie IIUWGRAFu z LOGLANem 26\r
+ E. Wykaz specyfikacji procedur IIUWGRAFu 27\r
+ F. Wartosci kodow klawiszy specjalnych 29\r
+ G. FEDIT - prosty program do edycji kroju znakow 30\r
+ H. Zmiany IIUWGRAFu w stosunku do poprzednich wersji 33\r
+ \f\r
+\r
+\r
+ 3\r
+\r
+\r
+ \r
+ Informacje ogolne\r
+ \r
+ \r
+\r
+ Rysunek jest tworzony na ekranie monitora za pomoca\r
+ szeregu wywolan procedur bibliotecznych IIUWGRAF. Modyfikuja\r
+ one zawartosc bufora mapy bitowej, ktora jest zwykle\r
+ bezposrednio wyswietlana na ekranie. Zmiany te sa wtedy\r
+ widoczne natychmiast. Umiejscowienie bufora roboczego moze\r
+ byc jednak zmienione, tak aby byl on zwiazany z obszarem\r
+ pamieci dostarczonym przez uzytkownika. W tym przypadku\r
+ zmiany jego zawartosci oczywiscie nie sa wyswietlane, a\r
+ nawet przestawienie monitora w tryb graficzny nie jest\r
+ konieczne. Rysunek moze byc wtedy skonstruowany w pamieci,\r
+ bez wyswietlania, przechowany na dysku w postaci binarnej i\r
+ odtworzony pozniej na ekranie. Omowiony tryb pracy jest\r
+ mozliwy jednak tylko dla karty Hercules II oraz karty IBM.\r
+ W opisie procedur slowo ekran, tam gdzie mowa o jego\r
+ zawartosci, nalezy rozumiec wlasnie jako bufor roboczy.\r
+\r
+ Karty Hercules II oraz EGA daja dodatkowa mozliwosc\r
+ blyskawicznego przelaczania pomiedzy dwiema\r
+ rownouprawnionymi stronami graficznymi.\r
+\r
+ W wersji podstawowej karta graficzna EGA posiada\r
+ 64K bajty pamieci. Pamiec ta moze byc zwiekszona do 128K\r
+ oraz 256K bajtow. Opisane ponizej procedury graficzne\r
+ dotycza w zasadzie karty EGA z pelna pamiecia 256K bajtow.\r
+ Tylko w tej wersji karty mozna bowiem uzywac 16 kolorow\r
+ ( z 64 istniejacych ) oraz dwoch stron graficznych. W obu\r
+ wersjach z mniejsza pamiecia istnieje tylko jedna strona\r
+ graficzna, a ponadto w wersji podstawowej uzytkownik ma\r
+ mozliwosc korzystania tylko z 4 kolorow (z 16 istniejacych).\r
+\r
+ Dostarczone sa cztery zestawy oddzielnych bibliotek\r
+ IIUWGRAF, kazda dla innego rodzaju ekranu:\r
+ \r
+ HGCMSF i HGCMSF4 dla karty Hercules\r
+ MGCMSF i MGCMSF4 dla karty IBM color/graphics\r
+ MGC64MSF i MGC64MF4 dla karty IBM w trybie mono\r
+ EGAMSF i EGAMSF4 dla karty EGA\r
+\r
+ Biblioteki HGCMSF, MGCMSF, MGC64MSF i EGAMSF zgodne\r
+ sa z konwencjami Fortranu ( wersja 3.31 ) i Pascala firmy\r
+ Microsoft. Natomiast biblioteki HGCMSF4, MGCMSF4, MGC64MF4 i\r
+ EGAMSF4 sa zgodne z konwencjami Fortranu ( wersja 4.00 )\r
+ firmy Microsoft. Dodatkowo, kazda biblioteka moze byc\r
+ dostarczona w konwencji Lattice C, oddzielnie dla czterech\r
+ modeli kodu S, P, D i L.\r
+\r
+ Programy uzytkowe komunikuja sie z IIUWGRAFem na\r
+ dwoch poziomach:\r
+ \r
+ poziom 1 - zarzadzanie ekranem na poziomie pixli,\r
+ przy uzyciu prawdziwych wspolrzednych na ekranie,\r
+ \r
+ poziom 2 - rysowanie punktow i linii we\r
+ wspolrzednych abstrakcyjnych.\r
+ \f\r
+\r
+\r
+ 4\r
+\r
+\r
+ \r
+ Procedury poziomu 1\r
+ \r
+ Wszystkie parametry bez podanej explicite\r
+ specyfikacji maja typ integer. Wszystkie parametry calkowite\r
+ powinny miec wartosci 16-bitowe (integer*2 w Fortranie,\r
+ integer w Pascalu, int w C)\r
+\r
+ \r
+ Zakresy wspolrzednych ekranu:\r
+ \r
+ 0 <= ix <= 719\r
+ 0 <= iy <= 347 dla karty Hercules\r
+ \r
+ 0 <= ix <= 319\r
+ 0 <= iy <= 199 dla karty IBM color/graphics\r
+ \r
+ 0 <= ix <= 639\r
+ 0 <= iy <= 199 dla karty IBM color/graphics\r
+ w trybie mono\r
+ 0 <= ix <= 639\r
+ 0 <= iy <= 349 dla karty EGA\r
+ \r
+ \r
+ \r
+ (0,0)-----------> (ix,0)\r
+ |\r
+ |\r
+ |\r
+ V\r
+ (0,iy)\r
+ \f\r
+\r
+\r
+ 5\r
+\r
+\r
+ \r
+ Procedury ustawiania trybu\r
+ \r
+ GRON(i)\r
+ \r
+ Procedura GRON ustawia monitor w graficznym trybie\r
+ pracy, czyszczac zawartosc jego ekranu, ktory jednoczesnie\r
+ staje sie buforem roboczym. Parametr i ma znaczenie jedynie\r
+ dla karty IBM w trybie 320*200: wartosc 1 wybiera normalne\r
+ kolory, wartosc 0 - kolory zmodyfikowane do pracy na\r
+ monitorach monochromatycznych. Dla kart Hercules, EGA oraz\r
+ karty IBM w trybie 640*200 wartosc parametru i jest\r
+ ignorowana. Przy przelaczaniu karty Hercules z trybu\r
+ tekstowego na graficzny i odwrotnie stosowane jest\r
+ programowo opoznienie ok. 3 sekund. Tryb karty IBM ustawiany\r
+ jest wprost, bez pomocy przerwania 10H, tak aby mozliwa byla\r
+ jednoczesna praca na monitorze kolorowym w trybie graficznym\r
+ z praca na monitorze monochromatycznym w trybie tekstowym.\r
+ Konsekwencja tego rozwiazania jest to, ze nie mozna\r
+ korzystac z komendy GRAPHICS. Natomiast tryb karty EGA jest\r
+ ustawiany wprost, za pomoca przerwania 10H.\r
+\r
+ \r
+ \r
+ NOCARD(ple)\r
+ \r
+ Funkcja NOCARD zwraca liczbe calkowita\r
+ identyfikujaca rodzaj monitora obslugiwanego przez biezaco\r
+ uzywana biblioteke:\r
+\r
+ 1 dla karty Hercules\r
+ 2 dla karty IBM w trybie kolor\r
+ 3 dla karty IBM w trybie mono 640*200\r
+ 4 dla karty IBM w trybie mono 320*200\r
+ 5 dla karty EGA\r
+\r
+ Funkcja NOCARD moze byc wywolana dopiero po\r
+ zainicjowaniu trybu graficznego za pomoca procedury GRON.\r
+ Parametr ple jest ignorowany.\r
+\r
+ \r
+ \r
+ GROFF\r
+ \r
+ Procedura GROFF przelacza monitor w tryb tekstowy,\r
+ wypelniajac zawartosc jego ekranu spacjami. Przed\r
+ zakonczeniem dzialania programu monitor, z ktorego byl\r
+ wywolany, nalezy zawsze ustawic z powrotem w tryb tekstowy.\r
+\r
+ \r
+ CLS\r
+ \r
+ Procedura CLS czysci ekran, wypelniajac go kolorem\r
+ 0. Czyszczenie odbywa sie bez wylaczania ekranu.\f\r
+\r
+\r
+ 6\r
+\r
+\r
+ \r
+ HPAGE(nr, tryb, zeruj)\r
+ \r
+ Procedura HPAGE ma zastosowanie jedynie dla kart\r
+ Hercules oraz EGA. Pozwala na dostep do drugiej strony\r
+ graficznej monitora. Wywolanie HPAGE wybiera strone o\r
+ numerze nr (0 lub 1), zeruje jej zawartosc, o ile parametr\r
+ zeruj ma wartosc <> 0, oraz ustawia jej tryb:\r
+\r
+ tryb = 0 wyswietla zawartosc strony alfanumerycznie\r
+ tryb = 1 wyswietla zawartosc strony graficznie\r
+ tryb =-1 przypisuje do tej strony bufor roboczy\r
+ \r
+\r
+ Przypisanie bufora roboczego trybem -1 nie zmienia\r
+ numeru ani sposobu wyswietlania biezacej strony. Tryb 0\r
+ wiaze bufor roboczy z wybrana wlasnie strona. Przelaczanie\r
+ stron odbywa sie bez opoznien, o ile nie ulega zmianie tryb\r
+ wyswietlania (alfanumeryka/grafika). Poza tym, wywolanie\r
+ HPAGE(0,1,1) jest ( tylko dla karty Hercules ) rownowazne\r
+ GRON(), a HPAGE(0,0,1) - wywolaniu GROFF.\r
+\r
+ Typowa petla animacyjna moze byc zatem rozwiazana na\r
+ przyklad tak:\r
+\r
+ VAR NR: INTEGER;\r
+ BEGIN\r
+ GRON(0);\r
+ NR := 1;\r
+ (* NARYSUJ PIERWOTNY OBRAZ *)\r
+ DRAW(...\r
+ ...\r
+ WHILE JESZCZE DO\r
+ HPAGE(1-NR,1,0); (* WYSWIETLANIE *)\r
+ HPAGE(NR,-1,1); (* BUFOROWANIE *)\r
+ (* NARYSUJ ZMODYFIKOWANY OBRAZ *)\r
+ DRAW(...\r
+ ...\r
+ NR := 1-NR\r
+ OD\r
+\r
+ \r
+ VIDEO(tablica)\r
+ \r
+ Procedura VIDEO przelacza bufor roboczy tak, aby\r
+ miescil sie on w tablicy podanej jako parametr jej\r
+ wywolania.\r
+ Samo wywolanie VIDEO nie zmienia zawartosci bufora. Obraz\r
+ wyswietlany na monitorze nie bedzie ulegal teraz zmianom\r
+ mimo wywolywania procedur modyfikujacych zawartosc ekranu.\r
+ Wszelkie odwolania do ekranu beda teraz dokonywane w\r
+ tablicy. Gotowy obraz moze byc przeniesiony na rzeczywisty\r
+ ekran za pomoca procedur GETMAP/PUTMAP lub zapisany binarnie\r
+ na dysku w celu pozniejszego odtworzenia. Tablica powinna\r
+ miec 16K bajtow przy wspolpracy z karta IBM i 32K bajtow\r
+ przy wspolpracy z karta Hercules.\r
+ Procedury VIDEO nie mozna stosowac dla karty EGA.\f\r
+\r
+\r
+ 7\r
+\r
+\r
+ Przyklad:\r
+\r
+ VAR BOK: ARRAY[1..32K] OF BYTE;\r
+ FRAGM: ARRAY[1..MAX] OF BYTE;\r
+ BEGIN\r
+ GRON(1);\r
+ (* NARYSUJ STRONE TYTULOWA *)\r
+ DRAW(...\r
+ ...\r
+ (* SKONSTRUUJ RYSUNEK "NA BOKU" *)\r
+ VIDEO(BOK);\r
+ DRAW(...\r
+ ...\r
+ (* ZAPAMIETAJ FRAGMENT GOTOWEGO RYSUNKU *)\r
+ MOVE(MINX,MINY);\r
+ GETMAP(MAXX,MAXY,FRAGM);\r
+ (* PRZYPISZ Z POWROTEM EKRAN DO MONITORA *)\r
+ GRON(1); (* NIESTETY, CZYSCI EKRAN *)\r
+ MOVE(MINX,MINY);\r
+ PUTMAP(FRAGM);\r
+ ...\r
+\r
+ Uwaga:\r
+ W przypadku wywolania VIDEO(tablica(adres)), wartosc\r
+ wyrazenia adres musi byc postaci 1+k*16, gdzie k=0,1,2,...\r
+ \f\r
+\r
+\r
+ 8\r
+\r
+\r
+ \r
+ Procedury sterujace kolorami\r
+ \r
+ \r
+ COLOR(kolor)\r
+ \r
+ Procedura COLOR ustawia biezacy kolor. W tym\r
+ kolorze beda odtad dokonywane zmiany zawartosci ekranu. Na\r
+ monitorach monochromatycznych kolor 0 oznacza czarny (pixel\r
+ wygaszony), kolor <> 0 oznacza bialy (pixel zapalony).\r
+ Na monitorach kolorowych, dla karty IBM color/graphics,\r
+ kolory maja nastepujace numery:\r
+ \r
+ 0 - tlo (czarny lub ustalony wywolaniem BORDER)\r
+ 1 - zielony lub turkusowy - cyan ( zaleznie od wyboru\r
+ palety)\r
+ 2 - czerwony lub purpurowy - magenta\r
+ 3 - zolty lub bialy\r
+ \r
+ Kolorem ustawionym poczatkowo jest 1.\r
+ \r
+\r
+ Dla karty EGA kolor moze przyjmowac wartosci od 0\r
+ do 15. Znaczenie tego parametru jest okreslone poprzez wybor\r
+ palety ( przyporzadkowanie kazdemu z 16 identyfikatorow\r
+ koloru dowolnego koloru z 64 istniejacych ), dokonywany za\r
+ pomoca procedury PALLET.\r
+ Kolorem ustawionym poczatkowo jest 7.\r
+\r
+ \r
+ STYLE(styl)\r
+ \r
+ Procedura STYLE ustawia biezacy styl, czyli\r
+ kombinacje kolorow uzywana do rysowania odcinkow (DRAW) i\r
+ wypelniania obszarow (HFILL,VFILL). Styl wybiera jeden z\r
+ szesciu nastepujacych sposobow mieszania tla (.) i biezacego\r
+ koloru (*):\r
+\r
+ 0 - ....\r
+ 1 - ****\r
+ 2 - ***.\r
+ 3 - **..\r
+ 4 - *.*.\r
+ 5 - *...\r
+\r
+ Przy rysowaniu odcinkow kolejne pixle beda mialy\r
+ kolor wyznaczony cyklicznie wzorcem stylu. Pierwszy i\r
+ ostatni pixel odcinka bedzie zawsze mial biezacy kolor.\r
+ Przy wypelnianiu, podany wzorzec dotyczy linii poziomych\r
+ (pionowych) ekranu o parzystej wspolrzednej y (x). Wzorzec\r
+ dla linii o wspolrzednych nieparzystych dobierany jest\r
+ automatycznie.\r
+ Inne sposoby mieszania, dopuszczajace uzycie wiekszej liczby\r
+ kolorow sa dostepne za pomoca procedury PATERN.\f\r
+\r
+\r
+ 9\r
+\r
+\r
+ PATERN(par,par1,par2,par3)\r
+ \r
+ Procedura PATERN pozwala rysowac odcinki i\r
+ wypelniac obszary dowolna kombinacja kolorow. Przy rysowaniu\r
+ odcinkow brany jest pod uwage tylko par. Przy wypelnianiu,\r
+ par oraz par2 dotycza linii poziomych (pionowych) o\r
+ wspolrzednych y (x) parzystych, par1 oraz par3 - linii o\r
+ wspolrzednych nieparzystych ( na zmiane kolejno par/par2\r
+ oraz par1/par3 ). Wartosci par,...,par3 przedstawione jako\r
+ czterocyfrowe liczby szesnastkowe daja wzorce mieszania\r
+ numerow kolorow. 0 oznacza tlo, inne cyfry - zob. opis\r
+ procedury COLOR.\r
+\r
+ Przyklad:\r
+\r
+ PATERN(#1100,#0011,#1100,#0011);\r
+ ODPOWIADA: COLOR(1); STYLE(3);\r
+\r
+ natomiast efekt:\r
+\r
+ PATERN(#1212,#0303,#2121,#3030);\r
+ NIE MOzE BYC UZYSKANY INACZEJ\r
+\r
+ \r
+ BORDER(kolor)\r
+ \r
+ Procedura BORDER ustawia biezacy kolor tla.\r
+ \r
+ kolor kolor\r
+ \r
+ 0 czarny\r
+ 1 niebieski\r
+ 2 zielony\r
+ 3 turkusowy - cyan (niebiesko-zielony)\r
+ 4 czerwony\r
+ 5 karmazynowy - magenta (czerwono-niebieski)\r
+ 6 zolty\r
+ 7 jasno szary\r
+ \r
+ Kolory 8 - 15 to jasniejsze odcienie kolorow 0 - 7, przy\r
+ czym kolor bialy ma numer 15.\r
+\r
+ Przedstawione powyzej kolory dotycza tylko karty IBM, dla\r
+ karty EGA natomiast parametr kolor moze przyjmowac wartosci\r
+ od 0 do 63.\r
+ \r
+ \r
+ PALLET(nr)\r
+ \r
+ Dla karty IBM color/graphics :\r
+ \r
+ procedura PALLET wybiera biezaca palete z dwu\r
+ mozliwych\r
+ \r
+\r
+ nr kolory\r
+ \r
+ 0 turkusowy,karmazynowy,bialy\r
+ 1 zielony,czerwony,zolty\r
+ \f\r
+\r
+\r
+ 10\r
+\r
+\r
+ Domyslna paleta jest paleta nr 0.\r
+\r
+ Dla karty EGA natomiast procedura PALLET sluzy do\r
+ wyboru dowolnych 16 kolorow z 64 ogolnie dostepnych.\r
+ Parametr nr powinien byc postaci\r
+ kolor16 * 256 + kolor64,\r
+ gdzie\r
+ kolor16 oznacza identyfikator koloru ( uzywany\r
+ przez procedure COLOR ), mogacy przyjmowac wartosci 0 - 15,\r
+ kolor64 oznacza wybrany kolor.\r
+ \r
+\r
+ Standardowa paleta ( przyjmowana domyslnie )\r
+ zawiera nastepujace kolory :\r
+ \r
+ identyfikator kolor numer koloru\r
+ \r
+ 0 czarny 0\r
+ 1 niebieski 1\r
+ 2 zielony 2\r
+ 3 turkusowy 3\r
+ 4 czerwony 4\r
+ 5 karmazynowy 5\r
+ 6 zolty 6\r
+ 7 bialy 7\r
+ 8 szary 56\r
+ 9 jasno-niebieski 57\r
+ 10 jasno-zielony 58\r
+ 11 jasno-turkusowy 59\r
+ 12 jasno-czerwony 60\r
+ 13 jasno-karmazynowy 61\r
+ 14 jasno-zolty 62\r
+ 15 intensywny bialy 63\r
+ \r
+\r
+ Wszystkie dostepne kolory mozna obejrzec oraz\r
+ poznac ich numery za pomoca programu demonstracyjnego\r
+ EGADEMO.EXE.\r
+\r
+ Procedura PALLET nie ma zastosowania dla karty\r
+ Hercules.\r
+\r
+ \r
+ \r
+ INTENS(i)\r
+ \r
+ Procedura INTENS wybiera intensywnosc kolorow.\r
+ Dla i rownego 0 intensywnosc jest wieksza, dla i rownego 1\r
+ mniejsza.\r
+ Domyslnie intensywnosc jest ustawiona na poziomie 0.\r
+ \r
+ Procedura INTENS ma zastosowanie tylko dla karty IBM.\f\r
+\r
+\r
+ 11\r
+\r
+\r
+ \r
+ Procedury ustawiania pozycji\r
+ \r
+ \r
+ MOVE(x,y)\r
+ \r
+ Procedura MOVE ustawia biezaca pozycje na ekranie\r
+ na pixel o wspolrzednych (x {kolumna}, y {wiersz}).\r
+\r
+ \r
+ INXPOS(ple), INYPOS(ple)\r
+ \r
+ Funkcje calkowite INXPOS i INYPOS zwracaja\r
+ odpowiednio wspolrzedne x i y biezacej pozycji. Parametr ple\r
+ jest ignorowany.\r
+\r
+ \r
+ PUSHXY\r
+ \r
+ Procedura PUSHXY powoduje przechowanie biezacej\r
+ pozycji, koloru i stylu na wierzcholku wewnetrznego stosu\r
+ IIUWGRAFu. Parametry te nie ulegaja przy tym zmianie.\r
+ Maksymalna glebokosc stosu wynosi 16.\r
+\r
+ \r
+ POPXY\r
+ \r
+ Procedura POPXY odtwarza biezacy styl, kolor i\r
+ pozycje z wierzcholka wewnetrznego stosu IIUWGRAFu.\r
+ Glebokosc stosu zmniejsza sie o 1.\r
+\r
+ \r
+ \r
+ Przyklad:\r
+ \r
+\r
+ PROCEDURE SKOS;\r
+ VAR IX,IY:INTEGER;\r
+ BEGIN\r
+ PUSHXY;\r
+ IX := INXPOS(0);\r
+ IY := INYPOS(0);\r
+ DRAW(IX+10,IY+10);\r
+ POPXY;\r
+ END;\f\r
+\r
+\r
+ 12\r
+\r
+\r
+ \r
+ TRACK(x,y)\r
+ \r
+ Procedura TRACK wyswietla na ekranie wskaznik w\r
+ ksztalcie malej (8*8 pixli) strzalki, skierowanej na punkt o\r
+ wspolrzednych (x,y). Wskaznik ten moze byc przesuwany po\r
+ ekranie za pomoca klawiszy kierunkowych. Nacisniecie\r
+ klawisza powoduje przesuniecie wskaznika o 5 pixli.\r
+ Nacisniecie odpowiedniego klawisza w trybie numerycznym\r
+ przesuwa wskaznik o 1 pixel. Klawisz "home" powoduje powrot\r
+ wskaznika do pozycji (x,y). Klawisz "End" usuwa wskaznik z\r
+ ekranu i powoduje powrot z procedury, pozostawiajac biezaca\r
+ pozycje w tym miejscu. Moze byc ona teraz odczytana za\r
+ pomoca funkcji INXPOS i INYPOS.\r
+\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ Procedury obslugujace punkty\r
+ \r
+ \r
+ POINT(x,y)\r
+ \r
+ Procedura POINT ustawia biezaca pozycje w punkcie\r
+ (x,y) i zmienia jego kolor na biezacy.\r
+\r
+ \r
+ INPIX(x,y)\r
+ \r
+ Funkcja INPIX ustawia biezaca pozycje w punkcie\r
+ (x,y) i zwraca jego kolor.\f\r
+\r
+\r
+ 13\r
+\r
+\r
+ \r
+ Procedury rysowania linii\r
+ \r
+ \r
+ DRAW(x,y)\r
+ \r
+ Procedura DRAW rysuje odcinek od biezacej pozycji\r
+ do pozycji o wspolrzednych (x,y). Rysowanie polega na\r
+ zmianie koloru pixli nalezacych, wedlug algorytmu\r
+ Bresenhama, do odcinka. Pixle te przyjmuja nowy stan\r
+ zaleznie od biezacego koloru i stylu.\r
+\r
+ \r
+ \r
+ CIRB(x,y,r,alfa,beta,kolb,wwyp,p,q)\r
+ \r
+ Procedura CIRB rysuje na ekranie wycinek okregu\r
+ lub elipsy, zaleznie od podanych wartosci p i q,\r
+ okreslajacych aspekt. Aspekt wyznaczony jest stosunkiem p/q.\r
+ Dla wartosci aspektu rownej 1 zostanie narysowany idealny\r
+ okrag. Srodek bedzie umieszczony w punkcie (x,y), promien\r
+ poziomy bedzie mial wielkosc r pixli, alfa i beta okreslaja,\r
+ odpowiednio kat poczatkowy i koncowy rysowanego wycinka. Dla\r
+ alfa = beta zostanie narysowany pelny okrag (lub elipsa).\r
+ Wartosci alfa i beta sa wyrazane w radianach, w zwyklym\r
+ ukladzie. Brzeg wycinka i jego promienie zostana narysowane\r
+ kolorem kolb, niezaleznie od stylu. Jesli wwyp <> 0, wnetrze\r
+ wycinka zostanie wypelnione biezacym kolorem i stylem.\r
+\r
+ \r
+ HFILL(x)\r
+ \r
+ Procedura HFILL rysuje, w biezacym kolorze i stylu,\r
+ odcinek poziomy od biezacej pozycji do punktu o\r
+ wspolrzednych\r
+ \r
+ (x,inypos(0))\r
+ \r
+ OSTROZNIE: HFILL nie zmienia biezacej pozycji.\r
+\r
+ Uzycie HFILL jest zalecane przy wypelnianiu\r
+ obszarow, gdyz dziala znacznie szybciej niz odpowiedni DRAW.\r
+ Rowniez mieszajac kolory w danym stylu, HFILL, w\r
+ przeciwienstwie do DRAW nie bierze pod uwage poczatkowego\r
+ punktu odcinka, co pozwala na uzyskanie substytutu\r
+ dodatkowych kolorow.\r
+\r
+ \f\r
+\r
+\r
+ 14\r
+\r
+\r
+ VFILL(y)\r
+ \r
+ \r
+ Procedura VFILL rysuje, w biezacym kolorze i stylu,\r
+ odcinek pionowy od biezacej pozycji do punktu o\r
+ wspolrzednych\r
+ \r
+ (inxpos(0),y)\r
+ \r
+ OSTROZNIE: VFILL nie zmienia biezacej pozycji.\f\r
+\r
+\r
+ 15\r
+\r
+\r
+ \r
+ Procedury operujace na fragmentach ekranu\r
+ \r
+ \r
+ GETMAP(x,y,tablica)\r
+ \r
+ Procedura GETMAP zapamietuje prostokatny obszar\r
+ ekranu pomiedzy biezaca pozycja jako lewym gornym rogiem a\r
+ punktem (x,y) jako prawym dolnym rogiem w tablicy. GETMAP\r
+ nie zmienia przy tym biezacej pozycji. Tablica powinna miec\r
+ co najmniej 4 + w*sufit(k/8)*kol bajtow, gdzie w i k sa,\r
+ odpowiednio, liczba wierszy i kolumn zapamietywanego\r
+ obszaru, natomiast wartosc wspolczynnika kol zalezy od\r
+ rodzaju karty graficznej i wynosi 1 dla karty Hercules,\r
+ 2 dla karty IBM oraz 4 dla karty EGA.\r
+\r
+ Przyklad: zapamietanie obszaru 101*101 polozonego w lewym\r
+ gornym rogu ekranu.\r
+\r
+ VAR OKNO: ARRAY[1..700] OF INTEGER;\r
+ \r
+ ...\r
+ MOVE(0,0);\r
+ GETMAP(100,100,OKNO);\r
+ ...\r
+ \r
+\r
+ \r
+ PUTMAP(tablica)\r
+ \r
+ Procedura PUTMAP ustawia prostokatny obszar ekranu\r
+ o lewym gornym rogu znajdujacym sie w biezacej pozycji\r
+ zgodnie z zawartoscia tablicy, w ktorej uprzednio\r
+ zapamietano fragment ekranu za pomoca procedury GETMAP.\r
+ Biezaca pozycja nie ulega zmianie. Odtworzeniu podlega caly\r
+ zapamietany obszar, ktory jest kopiowany w nowe miejsce.\r
+\r
+ \r
+ ORMAP(tablica)\r
+ \r
+ Procedura ORMAP dziala podobnie jak PUTMAP, lecz o\r
+ nowej zawartosci ekranu decyduje wynik zastosowania funkcji\r
+ or do elementow tablicy i ekranu.\r
+\r
+ \r
+ XORMAP(tablica)\r
+ \r
+ Procedura XORMAP dziala podobnie jak PUTMAP, lecz o\r
+ nowej zawartosci ekranu decyduje wynik zastosowania funkcji\r
+ xor do elementow tablicy i ekranu.\f\r
+\r
+\r
+ 16\r
+\r
+\r
+ \r
+ Procedury wejscia/wyjscia dla pojedynczych znakow\r
+ \r
+ \r
+ INKEY(ple)\r
+ \r
+ Funkcja calkowita INKEY podaje i usuwa nastepny\r
+ znak z bufora klawiatury. Czytanie odbywa sie bez echa.\r
+ Jesli bufor jest pusty, wynikiem jest 0. Klawisze specjalne\r
+ kodowane sa jako liczby ujemne wedlug zalaczonej tablicy.\r
+ Metoda ALT-NUM moze byc uzyta do wprowadzenia z klawiatury\r
+ kodow powyzej 127 jako zwyklych znakow. Uniemozliwia to,\r
+ niestety, korzystanie ze znakow specjalnych o kodach od 128\r
+ do 132.\r
+\r
+ Przyklad: zaczekaj na klawisz End.\r
+\r
+ PROCEDURE WAIT_FOR_END;\r
+ BEGIN\r
+ WHILE INKEY(0)<>-79 DO;\r
+ END;\r
+\r
+ Wartosci kodow klawiszy specjalnych podane sa w Dodatku F.\r
+ \r
+ \r
+ HASCII(kod)\r
+ \r
+ Procedura HASCII rysuje na ekranie znak\r
+ alfanumeryczny. Znak wpisany jest w raster 8*8. Gorny lewy\r
+ rog rastra umieszczony bedzie w biezacej pozycji, ktora\r
+ jednoczesnie przesunie sie o 8 pixli w prawo. Uzyta funkcja\r
+ rysujaca jest xor. Kroj znakow pobierany jest z tablicy\r
+ znajdujacej sie w ROM BIOS standardowo pod adresem\r
+ F000:FA6E. W przypadku niestandardowego ROM BIOSu obraz\r
+ znaku alfanumerycznego bedzie zly. Uzycie procedur HFONT i\r
+ HFONT8 pozwala uniezaleznic sie od wersji BIOSu a takze\r
+ korzystac z innych, rowniez wlasnorecznie zaprojektowanych\r
+ krojow znakow. Kod znaku 0 powoduje tylko wyczyszczenie\r
+ miejsca przeznaczonego na znak, bez zmiany biezacej pozycji.\r
+ Wszystkie kody maja tylko interpretacje graficzna, bez\r
+ funkcji sterujacych (NL, CR etc.).\r
+\r
+ Przyklad: napisanie slowa "oh" na gwarantowanie czystym tle.\r
+ \r
+\r
+ HASCII(0); HASCII('o'); HASCII(0); HASCII('h');\r
+\r
+ Uwaga:\r
+ Parametr procedury HASCII moze byc typu integer lub\r
+ znakowego ( character w Fortranie, char w Pascalu i C ).\r
+ \f\r
+\r
+\r
+ 17\r
+\r
+\r
+ \r
+ HFONT(segment,offset)\r
+ \r
+ Wywolanie procedury HFONT przelacza adres wzorca\r
+ znakow alfanumerycznych na segment:offset. Bez uzycia HFONT\r
+ uzywa sie adresu F000:FA6E.\r
+\r
+ \r
+ HFONT8(segment,offset)\r
+ \r
+ Uzycie procedury HFONT8 dolacza do programu\r
+ uzytkowego kopie tablicy kroju znakow z ROM BIOS i zwraca\r
+ adres tej kopii jako segment:offset (parametry wyjsciowe).\r
+\r
+ \f\r
+\r
+\r
+ 18\r
+\r
+\r
+ \r
+ Procedury wejscia/wyjscia dla linii\r
+ \r
+ \r
+ OUTHLINE(dlugosc,bufor)\r
+ \r
+ Procedura OUTHLINE wywoluje HASCII dlugosc razy,\r
+ wypisujac na ekran znaki, ktorych kody zawarte sa w buforze.\r
+ Przed narysowaniem kazdego znaku wywolywane jest HASCII(0).\r
+\r
+ \r
+ INHLINE(dlugosc,bufor)\r
+ \r
+ Procedura INHLINE wczytuje z klawiatury linie\r
+ zlozona z co najwyzej dlugosci znakow i umieszcza je w\r
+ buforze. Do wczytywania uzyta jest procedura INKEY.\r
+ Wyswietlane jest echo. Migajacy wskaznik oznacza oczekiwanie\r
+ na nacisniecie klawisza. Klawisz BACKSPACE dziala tak, jak\r
+ mozna tego oczekiwac. Linia moze byc zakonczona klawiszem CR\r
+ albo wyczerpaniem jej dlugosci. Znak CR konczacy linie nie\r
+ jest umieszczany w buforze. Przed rozpoczeciem czytania\r
+ bufor jest wypelniany spacjami. Po zakonczeniu czytania\r
+ parametr dlugosc zwraca liczbe wczytanych znakow.\r
+ Migajacy wskaznik jest zawsze rysowany kolorem numer 1,\r
+ wyswietlane znaki natomiast biezacym kolorem.\r
+\r
+ \r
+ Przyklad: echo wczytanej linii.\r
+\r
+ VAR LINIA: ARRAY[1:40] OF INTEGER;\r
+ N: INTEGER;\r
+ BEGIN\r
+ N:=80;\r
+ INHLINE(N,LINIA);\r
+ IF N=0 THEN MOVE(INXPOS(0),INYPOS(0)+10)\r
+ ELSE OUTHLINE(N,LINIA);\r
+ ...\r
+\r
+ \f\r
+\r
+\r
+ 19\r
+\r
+\r
+ \r
+ Procedury wejscia/wyjscia dla okienek\r
+ \r
+ \r
+ MKWNDW(x,y,kolumn,wierszy,okienko,rozmiar,ramka)\r
+ \r
+ Procedura MKWNDW urzadza na ekranie prostokatne\r
+ okienko do konwersacji. Lewy gorny rog okienka znajdzie sie\r
+ w punkcie (x,y). Zmiesci ono zadana liczbe kolumn i wierszy\r
+ tekstu alfanumerycznego. Opis okienka bedzie przechowany w\r
+ dostarczonej przez uzytkownika tablicy okienko. Parametr\r
+ rozmiar jest na razie ignorowany, a tablica powinna miec co\r
+ najmniej 20 bajtow, lub duzo wiecej, jesli okienko ma byc\r
+ zaslaniane i odslaniane ( patrz opis procedury BURY ). Jesli\r
+ parametr ramka ma wartosc rozna od 0, obszar okienka bedzie\r
+ obwiedziony ramka, co uczyni je nieco wiekszym.\r
+\r
+ \r
+ BURY(okienko)\r
+ \r
+ Wywolanie BURY usuwa okienko z ekranu, przechowujac\r
+ jego obraz w dalszej czesci tablicy okienko tak, aby moc\r
+ odtworzyc je pozniej za pomoca EXPOSE. Tablica okienko musi\r
+ miec odpowiednia wielkosc, aby GETMAP obszaru okienka\r
+ pozostawilo w niej jeszcze co najmniej 20 bajtow.\r
+\r
+ \r
+ EXPOSE(okienko,x,y)\r
+ \r
+ Wywolanie EXPOSE odtwarza okienko przechowane za\r
+ pomoca BURY umieszczajac jego gorny lewy rog w punkcie\r
+ (x,y).\r
+\r
+ \r
+ OUTWLINE(okienko,dlugosc,bufor)\r
+ \r
+ Procedura OUTWLINE dziala podobnie jak OUTHLINE,\r
+ wyswietlajac linie w ramach podanego okienka. Bufor o\r
+ dlugosci wiekszej niz rozmiar okienka wyswietli sie w kilku\r
+ liniach.\r
+\r
+ \r
+ INWLINE(okienko,dlugosc,bufor)\r
+ \r
+ Procedura INWLINE, podobnie jak INHLINE, wczytuje z\r
+ klawiatury linie tekstu. W przypadku INWLINE okienko\r
+ wskazuje na obszar ekranu, w ktorym ma pojawiac sie echo.\r
+ Jesli dlugosc bufora jest wieksza niz rozmiar okienka echo\r
+ moze zajac w nim kilka linii. Poprawianie wprowadzanego\r
+ tekstu przy uzyciu BACKSPACE jest mozliwe tylko w ostatniej\r
+ czesci linii. Dlugosc jako parametr wyjsciowy zwraca liczbe\r
+ wczytanych znakow, bez konczacego CR.\f\r
+\r
+\r
+ 20\r
+\r
+\r
+ \r
+ Procedury poziomu 2\r
+ \r
+ \r
+ Procedury te operuja wspolrzednymi wyrazonymi\r
+ liczbami rzeczywistymi odnoszacymi sie do abstrakcyjnego\r
+ okna o dowolnych rozmiarach.\r
+\r
+ \r
+ \r
+ Definiowanie okna\r
+ \r
+ \r
+ SWINDOW(rxy,ixy,skalowanie)\r
+ \r
+ Procedura SWINDOW urzadza na ekranie prostokatne\r
+ okno umieszczone pomiedzy punktami naroznikowymi podanymi w\r
+ tablicy ixy jako calkowite wspolrzedne prawdziwych pixli.\r
+ Program uzytkowy tworzacy rysunek w tym obszarze bedzie\r
+ okreslal polozenie punktow w sposob abstrakcyjny we\r
+ wspolrzednych rzeczywistych. Tablica rxy podaje zakresy tych\r
+ wspolrzednych. Jesli parametr skalowanie ma wartosc 0,\r
+ abstrakcyjny prostokat bedzie po prostu odwzorowany na\r
+ wskazana czesc ekranu bez zachowania proporcji miedzy\r
+ skalowaniem w pionie i w poziomie. Jesli natomiast parametr\r
+ skalowanie bedzie rozny od zera, wykorzystana zostanie\r
+ jedynie srodkowa czesc obszaru ekranu tak, aby zachowac\r
+ rzeczywiste proporcje rysunku, niezaleznie od aspektu danego\r
+ monitora.\r
+ Odwzorowanie stosowane przez IIUWGRAF odwraca tez kierunek\r
+ wzrastania wspolrzednej y do naturalnego ukladu:\r
+ \r
+ \r
+ (ixy(1),ixy(3))\r
+ /\r
+ (rxy(1),rxy(4))\r
+ ^\r
+ |\r
+ |\r
+ |\r
+ | (ixy(1),ixy(4)) (ixy(2),ixy(4))\r
+ | / /\r
+ (rxy(1),rxy(3))--------------------->(rxy(2),rxy(3))\r
+ \r
+ \r
+ Przyklad: przygotowanie rysunku sinusoidy w gornej polowie\r
+ ekranu Herculesa.\r
+\r
+\r
+ VAR RW:ARRAY [1:4] OF REAL INIT (0.,6.29,-1.,1.);\r
+ IW:ARRAY [1:4] OF INTEGER INIT (0,719,0,173);\r
+ BEGIN\r
+ SWINDOW(RW,IW,0);\r
+ \f\r
+\r
+\r
+ 21\r
+\r
+\r
+ RWINDOW(rxy,skalowanie)\r
+\r
+ Procedura RWINDOW jest skrotem wywolania SWINDOW\r
+ dla odwzorowania obejmujacego caly ekran.\r
+\r
+ \r
+ \r
+ RINXPOS(ple),RINYPOS(ple)\r
+ \r
+ Funkcje rzeczywiste RINXPOS i RINYPOS zwracaja,\r
+ odpowiednio wspolrzedne x i y biezacej pozycji w\r
+ abstrakcyjnym oknie urzadzonym przez ostatnie wywolanie\r
+ RWINDOW lub SWINDOW. Biezaca pozycja jest zawsze zaokraglana\r
+ do najblizszego pixla.\r
+\r
+ \r
+ \r
+ RMOVE(rx,ry)\r
+ \r
+ Wywolanie procedury RMOVE ustawia biezaca pozycje w\r
+ punkcie (rx,ry) w ostatnio urzadzonym oknie. Pozycja ta jest\r
+ zaokraglona do najblizszego pixla.\r
+\r
+ \r
+ \r
+ RDRAW(rx,ry)\r
+ \r
+ Wywolanie procedury RDRAW powoduje narysowanie w\r
+ biezacym kolorze i stylu odcinka od biezacej pozycji do\r
+ pixla najblizszego punktowi (rx,ry) w ostatnio urzadzonym\r
+ oknie.\r
+\r
+ \r
+ \r
+ RCIRB(rx,ry,rr,alfa,beta,kolb,wwyp,p,q)\r
+ \r
+ Procedura RCIRB odpowiada procedurze CIRB z poziomu\r
+ 1, z tym, ze wspolrzedne srodka (rx,ry) i promien rr\r
+ wyrazane sa, jako liczby rzeczywiste, w oknie urzadzonym\r
+ przez ostatnie wywolanie RWINDOW lub SWINDOW. Pozostale\r
+ parametry maja znaczenie takie, jak w CIRB.\f\r
+\r
+\r
+ 22\r
+\r
+\r
+ \r
+ Informacje dodatkowe\r
+ \r
+ \r
+ Pakiet IIUWGRAF zawiera dodatkowo dwa programy\r
+ HGCPRINT.EXE oraz MGCPRINT.EXE. Umozliwiaja one drukowanie\r
+ tworzonych obrazow graficznych na powszechnie dostepnych\r
+ drukarkach ( np. typu STAR GEMINI, EPSON ). W przypadku\r
+ uzywania karty Hercules nalezy stosowac program HGCPRINT, a\r
+ dla karty IBM color/graphics program MGCPRINT.\r
+\r
+ Programow tych powinno uzywac sie w nastepujacy\r
+ sposob :\r
+ przed zaladowaniem wlasnego programu nalezy wykonac\r
+ program HGCPRINT lub MGCPRINT, w zaleznosci od rodzaju\r
+ uzywanej karty graficznej. Kazdy z tych programow ustawia\r
+ znaczenie klawisza PrtSc. Kazdorazowe pozniejsze nacisniecie\r
+ klawisza PrtSc powoduje wydrukowanie graficznej zawartosci\r
+ ekranu.\r
+ \r
+ Uwaga. W przypadku karty Hercules drukowana jest\r
+ zawartosc pierwszej strony graficznej, niezaleznie od tego,\r
+ ktora strona jest aktualnie wyswietlana.\r
+ W przypadku karty IBM color/graphics klawisz PrtSc\r
+ zaklada, ze jest ustawiony tryb kolor 320*200. Wydruk obrazu\r
+ graficznego utworzonego w trybie mono 640*200 jest mozliwe\r
+ poprzez uzycie procedury PRTSCR.\r
+\r
+ Mozliwosc drukowania obrazu graficznego nie\r
+ istnieje dla karty EGA.\r
+\r
+ Autorem programow HGCPRINT oraz MGCPRINT jest\r
+ Krzysztof Studzinski.\r
+\r
+ \r
+ \r
+ \r
+ Procedury dodatkowe\r
+ \r
+ \r
+ PRTSCR(nr)\r
+ \r
+ Procedura PRTSCR umozliwia drukowanie obrazow\r
+ graficznych tworzonych na ekranie monitora pod kontrola\r
+ programu. Parametr nr okresla numer strony graficznej\r
+ (0 lub 1), ktorej zawartosc ma byc wydrukowana.\r
+\r
+ Wywolanie procedury PRTSCR z parametrem nr rownym\r
+ zeru jest rownowazne nacisnieciu klawisza PrtSc.\r
+\r
+ W celu poprawnego dzialania tej procedury nalezy,\r
+ analogicznie jak w przypadku klawisza PrtSc, uprzednio\r
+ wykonac dolaczony program :\r
+ - HGCPRINT.EXE w przypadku uzywania karty\r
+ Hercules lub\r
+ - MGCPRINT.EXE dla karty IBM.\r
+\r
+ Procedura PRTSCR nie dziala dla karty EGA.\r
+\r
+ \f\r
+\r
+\r
+ 23\r
+\r
+\r
+ \r
+\r
+ DODATEK A\r
+\r
+ Uzycie IIUWGRAFu z FORTRANem 77.\r
+ \r
+ \r
+ 1) Procedury IN?LINE i OUT?LINE dokonuja jedynie\r
+ transmisji tekstu, bez zadnej konwersji pomiedzy postacia\r
+ binarna i tekstowa. Aby takiej konwersji dokonac, mozna\r
+ posluzyc sie instrukcjami formatowanego wejscia/wyjscia\r
+ w polaczeniu z tzw. plikami wewnetrznymi (internal file).\r
+\r
+ Przyklad:\r
+\r
+\r
+ INTEGER*2 I,J,SUM,W(10)\r
+ CHARACTER*20 LINE\r
+ CHARACTER LINEL(20)\r
+ EQUIVALENCE (LINE,LINEL(1))\r
+ \r
+ ...\r
+ CALL MKWNDW(10,10,21,4,W,20,1)\r
+ CALL OUTWLINE(W,20,'PODAJ 2 LICZBY (2I3)')\r
+ CALL INWLINE(W,20,LINEL)\r
+ READ (LINE,'(2I3)') I,J\r
+ SUM=I+J\r
+ WRITE (LINE,'(8H SUMA = I4)') SUM\r
+ CALL OUTWLINE(W,12,LINEL) \f\r
+\r
+\r
+ 24\r
+\r
+\r
+\r
+ \r
+\r
+ DODATEK B\r
+\r
+ Uzycie IIUWGRAFu z PASCALem.\r
+ \r
+ \r
+ 1) Microsoft Pascal dopuszcza jedynie 6 znakow w nazwie\r
+ podprogramu, zatem nazwy: INHLIN(E), INWLIN(E), OUTHLI(NE),\r
+ OUTWLI(NE), RWINDO(W), SWINDO(W), RINXPO(S), RINYPO(S) musza\r
+ byc uzywane w skroconej postaci.\r
+ \r
+ 2) Niektore procedury IIUWGRAFu sa napisane w FORTRANie.\r
+ Przy linkowaniu LINK moze domagac sie dostarczenia\r
+ biblioteki FORTRAN.LIB. Zadanie to nalezy zignorowac.\r
+ \r
+ 3) Do linkowania nalezy uzywac LINK w wersji co najmniej\r
+ 3.04, do kompilacji Pascal w wersji co najmniej 3.31.\f\r
+\r
+\r
+ 25\r
+\r
+\r
+ \r
+\r
+ DODATEK C\r
+\r
+ Uzycie IIUWGRAFu z Lattice C.\r
+ \r
+ \r
+ 1) Nalezy unikac konfliktow z nazwami globalnych zmiennych\r
+ roboczych IIUWGRAFu. Zmienne te maja nazwy rozpoczynajace\r
+ sie od liter WIR... i PQASP...\r
+ \r
+ 2) W przypadku procedur majacych parametry wyjsciowe ( w\r
+ dodatku E sa one zaznaczone jako vars ) nalezy przy ich\r
+ wywolaniu przekazywac adres odpowiedniego parametru\r
+ aktualnego.\r
+ \r
+ Przyklad:\r
+ \r
+\r
+ CHAR LENGTH;\r
+ CHAR *TEXT;\r
+ ...\r
+ INHLINE(&LENGTH,TEXT)\r
+ \r
+\r
+\r
+ 3) Adresy parametrow aktualnych nalezy przekazywac rowniez\r
+ w przypadku parametrow bedacych tablicami znakowymi.\r
+\r
+\r
+ Przyklad:\r
+\r
+\r
+ INT LENGTH;\r
+ CHAR *TEXT; /* LUB NP. CHAR TEXT[40]; */\r
+ ...\r
+ OUTHLINE(LENGTH, &TEXT[3]);\r
+ /* WYPISZ ZNAKI Z TABLICY 'TEXT', ROZPOCZYNAJAC OD\r
+ CZWARTEGO */\r
+ \f\r
+\r
+\r
+ 26\r
+\r
+\r
+ \r
+\r
+ DODATEK D\r
+\r
+ Uzycie IIUWGRAFu z LOGLANem.\r
+ \r
+ \r
+ 1) W biezacej wersji LOGLANu dostepnych jest jedynie 7\r
+ podstawowych procedur: GRON, GROFF, MOVE, DRAW, HASCII,\r
+ HPAGE, INKEY obslugujacych wylacznie karte Hercules.\r
+ \r
+ 2) System okienek do konwersacji nie bedzie w LOGLANie\r
+ dostepny w postaci procedur standardowych. Podobnie okienka\r
+ o wspolrzednych rzeczywistych.\r
+ \r
+ 3) Niektore podprogramy dostepne jako funkcje standardowe\r
+ LOGLANu musza miec zmienione specyfikacje parametrow w\r
+ stosunku do oryginalnego IIUWGRAFu:\r
+ \r
+ IIUWGRAF LOGLAN\r
+ \r
+ GETMAP GETMAP:function:array of ?\r
+ INKEY INKEY:integer function; (* bez parametrow *)\r
+ INXPOS INXPOS:integer function;(* bez parametrow *)\r
+ INYPOS INYPOS:integer function;(* bez parametrow *)\r
+ \f\r
+\r
+\r
+ 27\r
+\r
+\r
+ \r
+\r
+ DODATEK E\r
+\r
+ Wykaz specyfikacji procedur IIUWGRAFu.\r
+ \r
+ \r
+ proc BORDER(consts b: integer);\r
+ L proc BURY(window: buffer);\r
+ proc CIRB(consts ix,iy,ir: integer;\r
+ consts alfa, beta: real;\r
+ consts cbord, bcint, p, q: integer);\r
+ proc CLS;\r
+ proc COLOR(consts c: integer);\r
+ proc DRAW(consts ix,iy: integer);\r
+ L proc EXPOSE(window: buffer; consts x,y: integer);\r
+ L proc GETMAP(consts x,y: integer; ekran: buffer);\r
+ L proc GROFF;\r
+ proc GRON(consts imode: integer);\r
+ proc HASCII(consts ic: integer);\r
+ proc HFILL(consts maxx: integer);\r
+ proc HFONT(consts seg, offs: integer);\r
+ proc HFONT8(vars seg, offs: integer);\r
+ proc HPAGE(consts page, mode, clear: integer);\r
+ P proc INHLINE(vars n:integer; line: tekst);\r
+ L func INKEY(consts idummy: integer): integer;\r
+ func INPIX(consts x,y: integer): integer;\r
+ proc INTENS(consts i: integer);\r
+ PL proc INWLINE(window: buffer; vars n: integer;\r
+ line: tekst);\r
+ L func INXPOS(consts idummy: integer): integer;\r
+ L func INYPOS(consts idummy: integer): integer;\r
+ L proc MKWNDW(consts x,y,icols,ilines: integer;\r
+ window: buffer;\r
+ consts iwndwsize,iborder: integer);\r
+ proc MOVE(consts ix,iy: integer);\r
+ L func NOCARD(consts idummy: integer): integer;\r
+ proc ORMAP(ekran: buffer);\r
+ PL proc OUTHLINE(consts n:integer; line: tekst);\r
+ PL proc OUTWLINE(window: buffer; consts n: integer;\r
+ line: tekst);\r
+ proc PALLET(consts p: integer);\r
+ proc PATERN(consts p1, p2, p3, p4: integer);\r
+ proc POINT(consts ix,iy: integer);\r
+ proc POPXY;\r
+ proc PRTSCR(consts nr: integer);\r
+ proc PUSHXY;\r
+ proc PUTMAP(ekran: buffer);\r
+ L proc RCIRB(consts ix,iy,ir: real;\r
+ consts alfa, beta: real;\r
+ consts cbord, bcint, p, q: integer);\r
+ L proc RDRAW(consts rx,ry: real);\r
+ PL func RINXPOS(consts dummy: real): real;\r
+ PL func RINYPOS(consts dummy: real): real;\r
+ L proc RMOVE(consts rx,ry: real);\r
+ PL proc RWINDOW(rw: array [1:4] of real;\r
+ consts s: integer);\r
+ proc STYLE(consts s: integer);\f\r
+\r
+\r
+ 28\r
+\r
+\r
+ PL proc SWINDOW(rw: array [1:4] of real;\r
+ iw: array [1:4] of integer;\r
+ consts s: integer);\r
+ proc TRACK(consts x,y: integer);\r
+ proc VFILL(consts maxy: integer);\r
+ proc VIDEO(ekran: buffer);\r
+ proc XORMAP(ekran: buffer);\r
+ \r
+ Uzyto notacji semi-pascalowej.\r
+ Specyfikacja consts oznacza parametr przekazywany przez\r
+ wartosc (tylko wejsciowy), vars - przez zmienna (wejsciowo-\r
+ wyjsciowy).\r
+ Typ buffer oznacza tablice bajtowa sluzaca do przechowania\r
+ zawartosci okreslonego obszaru ekranu ( rozmiar jej zalezy\r
+ od wielkosci tego obszaru ), typ tekst natomiast oznacza\r
+ tablice znakowa.\r
+ Litery w pierwszej kolumnie sugeruja dodatkowe wazne\r
+ informacje (roznice) w kontekscie konkretnych jezykow\r
+ (Fortran, Pascal, C, Loglan).\f\r
+\r
+\r
+ 29\r
+\r
+\r
+\r
+ DODATEK F\r
+\r
+ Wartosci kodow klawiszy specjalnych:\r
+ \r
+ \r
+ 3 - ctrl-2\r
+ 15 - back tab (shift-tab)\r
+ 16-25 - ALT-Q az do ALT-P\r
+ 30-38 - ALT-A az do ALT-L\r
+ 44-50 - ALT-Z az do ALT-M\r
+ 59-68 - F1 az do F10\r
+ 71 - Home\r
+ 72 - Cursor-Up\r
+ 73 - PgUp\r
+ 75 - Cursor-Left\r
+ 77 - Cursor-Right\r
+ 79 - End\r
+ 80 - Cursor-Down\r
+ 81 - PgDn\r
+ 82 - Ins\r
+ 83 - Del\r
+ 84-93 - Shift-F1 az do Shift-F10\r
+ 94-103 - Ctrl-F1 az do Ctrl-F10\r
+ 104-113 - Alt-F1 az do Alt-F10\r
+ 114 - Ctrl-PrtSc\r
+ 115 - Ctrl-Cursor-Left\r
+ 116 - Ctrl-Cursor-Right\r
+ 117 - Ctrl-End\r
+ 118 - Ctrl-PgDn\r
+ 119 - Ctrl-Home\r
+ 120-131 - Alt-1 az do Alt-=\r
+ 132 - Ctrl-PgUp\f\r
+\r
+\r
+ 30\r
+\r
+\r
+ \r
+\r
+ DODATEK G\r
+\r
+ FEDIT\r
+ \r
+ Prosty program do edycji kroju znakow.\r
+ Dodatek do biblioteki graficznej IIUWGRAF.\r
+ \r
+ FEDIT pozwala komponowac i modyfikowac uklady pixli o\r
+ wymiarze 8*8. Takie uklady moga byc wyswietlane razem z\r
+ grafika za pomoca procedury HASCII.\r
+ \r
+ FEDIT produkuje opisy tablic kroju znakow w dwoch\r
+ postaciach:\r
+ \r
+ - jako podprogram dostarczajacy adres tablicy kroju\r
+ w postaci odpowiedniej do przekazania procedurze HFONT,\r
+ \r
+ - jako niezalezny program umieszczajacy wskaznik do\r
+ tablicy kroju w wektorze przerwania 14H.\r
+ \r
+ Pierwszy format moze byc uzyty do zastapienia standardowego\r
+ zestawu znakow zwykle znajdujacego sie w ROM BIOS pod\r
+ adresem F000:FA6E. Jest on uzywany przez procedure HASCII do\r
+ rysowania znakow o kodach od 0 do 127. Stad jego nazwa :\r
+ "format 0".\r
+ \r
+ Podprogram wygenerowany przez FEDIT ma nazwe HFONT8. Po\r
+ przetlumaczeniu przez MACROASSEMBLER musi byc on linkowany\r
+ razem z programem uzytkowym. Jesli zajdzie potrzeba zmiany\r
+ nazwy (np. w celu dynamicznego przelaczania pomiedzy kilkoma\r
+ krojami znakow), nazwa moze byc zmieniona recznie w tekscie\r
+ zrodlowym.\r
+ \r
+ Drugi format jest uzywany do rysowania znakow z\r
+ rozszerzonego zakresu znakow o kodach od 128 do 255. Stad\r
+ nazwa:\r
+ "format 128".\r
+ \r
+ Opis zestawu znakow w tym formacie musi byc zaladowany do\r
+ pamieci przed rozpoczeciem wykonania programu, ktory z niego\r
+ korzysta. Wskaznik do tablicy kroju musi byc wpisany w\r
+ wektor przerwania 14H. Robi to program wygenerowany przez\r
+ FEDIT, ktory nastepnie zawiesza sie za pomoca przerwania 27H\r
+ (terminate but stay resident). W tym przypadku tekst\r
+ zrodlowy po przetlumaczeniu przez MACROASSEMBLER musi byc\r
+ zlinkowany (bez zadnych bibliotek) do postaci .EXE.\r
+ IIUWGRAF i FEDIT nie daja mozliwosci dynamicznego\r
+ przelaczania tablic znakow rozszerzonego zakresu.\r
+ \f\r
+\r
+\r
+ 31\r
+\r
+\r
+ Przyklad:\r
+ \r
+ VAR ISEG, IOFFS: INTEGER;\r
+ BEGIN\r
+ HFONT8(ISEG,IOFFS); (* ADRES TABLICY FORMATU 0 *)\r
+ ...\r
+ HASCII(45); (* UZYWA ROM BIOS *)\r
+ HASCII(145); (* UZYWA ROZSZERZONEGO ZESTAWU *)\r
+ ...\r
+ HFONT(ISEG,IOFFS);\r
+ HASCII(45); (* UZYWA TABLICY FORMATU 0 *)\r
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)\r
+ ...\r
+ HFONT(16#F000,16#FA6E);\r
+ HASCII(45); (* ZNOWU ROM BIOS *)\r
+ HASCII(145); (* TEN SAM ROZSZERZONY ZESTAW *)\r
+ \r
+ \r
+ FEDIT jest prostym programem konwersacyjnym o kilku\r
+ zaledwie rozkazach. Tablica kroju znakow zawiera wzorce\r
+ ukladow pixli rozmiaru 8*8. Wzorzec pojedynczego znaku moze\r
+ byc wyjety z tej tablicy w celu jego edycji i zapamietany z\r
+ powrotem, byc moze w innym miejscu tablicy. Sa dwie tablice\r
+ znakow: jedna dla kodow od 0 do 127, druga dla kodow od 128\r
+ do 255. Pierwsza z nich nie moze byc modyfikowana. Druga z\r
+ nich moze poczatkowo zawierac zaladowany wczesniej\r
+ rozszerzony zestaw lub zostac wyczyszczona. Mozna tez\r
+ wczytac do niej zestaw zawarty w pliku wygenerowanym\r
+ wczesniej przez FEDIT. Po dokonaniu modyfikacji, zawartosc\r
+ tej drugiej tablicy moze byc uzyta do generacji badz\r
+ "formatu 0" badz "128".\r
+ \r
+\r
+ Rozkazy FEDITu.\r
+\r
+ \r
+ Rozkazy FEDITu sa wprowadzane jako pojedyncze litery\r
+ wybierajace czynnosci wymienione w jadlospisie wyswietlonym\r
+ u gory ekranu. Dodatkowe parametry podaje sie po\r
+ przynagleniu przez FEDIT.\r
+ \r
+ Komendy FEDITu:\r
+ \r
+ < low odswieza tablice "0 do 127"\r
+ \r
+ > high odswieza tablice "128 do 255"\r
+ \r
+ i init inicjalizuje zerami tablice "128 do 255"\r
+ \r
+ l load laduje tablice "128 do 255" z pliku\r
+ dodatkowy parametr:\r
+ - nazwa pliku (musi istniec)\f\r
+\r
+\r
+ 32\r
+\r
+\r
+ \r
+ d dump wypisuje zawartosc tablicy "128 do 255"\r
+ na plik; dodatkowe parametry:\r
+ - nazwa pliku (bedzie zapisany)\r
+ - baza ( 0 albo 128),\r
+ zaleznie od formatu\r
+ - jezyk:\r
+ f - MS Fortran, MS Pascal\r
+ s - Lattice C, model S\r
+ p - Lattice C, model P\r
+ d - Lattice C, model D\r
+ l - Lattice C, model L\r
+ \r
+ e edit wyjmuje z tablicy pojedynczy znak\r
+ i umieszcza go w obszarze roboczym.\r
+ dodatkowy parametr:\r
+ - kod znaku (dziesietnie)\r
+ Po obszarze roboczym mozna poruszac sie\r
+ za pomoca klawiszy kierunkowych. Pixel\r
+ zapala klawisz Ins, gasi klawisz Del.\r
+ Klawisz End powoduje wyjscie z tego trybu.\r
+ \r
+ t text wyswietla tekst pomocny przy ocenie\r
+ jakosci ksztaltu znakow. Tekst, nie dluzszy\r
+ niz 40 znakow jest wprowadzany przez uzytkow-\r
+ nika. Dodatkowe parametry:\r
+ - vspace,\r
+ - hspace - odpowiednio, pionowy i poziomy\r
+ odstep w pixlach pomiedzy znakami. Normalnie,\r
+ vspace wynosi 2, hspace - 0.\r
+ \r
+ p put przechowuje wzorzec z obszaru roboczego pod\r
+ wskazanym kodem. Dodatkowy parametr:\r
+ - kod pozycji (dziesietnie),\r
+ powinien byc miedzy 128 a 255\r
+ \r
+ q quit konczy dzialanie FEDIT\r
+ \r
+ \r
+ Z FEDITem nalezy obchodzic sie ostroznie. Posiada on jedynie\r
+ minimalne wbudowane zabezpieczenia i np. bez ostrzezenia\r
+ zapisze nowa, nie wykonczona jeszcze wersje kroju znakow na\r
+ pliku zawierajacym jedyny egzemplarz poprzedniej, bardzo\r
+ potrzebnej wersji.\f\r
+\r
+\r
+ 33\r
+\r
+\r
+ \r
+ DODATEK H\r
+ \r
+ Zmiany IIUWGRAFu w stosunku do poprzednich wersji\r
+ \r
+ \r
+ \r
+ Zmiany IIUWGRAFu w stosunku do wersji 1.1\r
+ \r
+ \r
+ 1) Rozszerzenie zestawu obslugiwanych kart graficznych o\r
+ karte EGA ( IBM Enhanced Graphics Adapter ).\r
+ \r
+ 2) Niewielkie modyfikacje procedur IIUWGRAFu :\r
+ \r
+ - dodanie procedury PRTSCR,\r
+ - modyfikacja procedury PATERN polegajaca na :\r
+ zwiekszeniu liczby parametrow ( wzorcow ) z\r
+ dwoch do czterech oraz\r
+ zmianie postaci tych parametrow ( zamiast\r
+ liczb dziesietnych liczby szesnastkowe ),\r
+ ( rozszerzenie wzorcow oczywiscie oznacza rownoczesnie\r
+ modyfikacje procedur HFILL oraz VFILL ),\r
+ - zmiany nazw procedur GRAPH, TEXT, SCREEN\r
+ odpowiednio na GRON, GROFF, NOCARD.\r
+ \r
+ \r
+ \r
+ \r
+ Zmiany IIUWGRAFu w stosunku do wersji 2.1\r
+ \r
+ \r
+ 1) Udostepnienie procedur CIRB oraz RCIRB dla C.\r
+ \f
\ No newline at end of file
--- /dev/null
+ 103 156 ³ Informacje ogolne\r
+ 166 193 ³ Procedury poziomu 1\r
+ 203 345 ³ Procedury ustawiania trybu\r
+ 356 527 ³ Procedury sterujace kolorami\r
+ 537 596 ³ Procedury ustawiania pozycji\r
+ 607 616 ³ Procedury obslugujace punkty\r
+ 626 684 ³ Procedury rysowania linii\r
+ 694 739 ³ Procedury operujace na fragmentach ekranu\r
+ 749 813 ³ Procedury wejscia/wyjscia dla pojedynczych znakow\r
+ 825 857 ³ Procedury wejscia/wyjscia dla linii\r
+ 869 916 ³ Procedury wejscia/wyjscia dla okienek\r
+ 926 928 ³ Procedury poziomu 2\r
+ 935 1021 ³ Definiowanie okna\r
+ 1031 1059 ³ Informacje dodatkowe\r
+ 1067 1084 ³ Procedury dodatkowe\r
+ 1099 1120 ³ Uzycie IIUWGRAFu z FORTRANem 77.\r
+ 1134 1144 ³ Uzycie IIUWGRAFu z PASCALem.\r
+ 1157 1188 ³ Uzycie IIUWGRAFu z Lattice C.\r
+ 1202 1219 ³ Uzycie IIUWGRAFu z LOGLANem.\r
+ 1233 1307 ³ Wykaz specyfikacji procedur IIUWGRAFu.\r
+ 1357 1507 ³ FEDIT\r
+ 1520 1545 ³ Zmiany IIUWGRAFu w stosunku do poprzednich wersj\r
+ 197 222 ³ List of symbols\r
+ 226 444 ³ 1. Preface\r
+ 3 89 ³ 2. The basic characteristics of LOGLAN-82\r
+ 451 597 ³ 2.1. Control structure\r
+ 601 690 ³ 2.2. Block structure\r
+ 694 734 ³ 2.3. Procedures and functions\r
+ 738 789 ³ 2.4. Classes\r
+ 793 885 ³ 2.5. Prefixing\r
+ 889 932 ³ 2.6. Object deallocator\r
+ 936 975 ³ 2.7. Arrays\r
+ 980 1032 ³ 2.8. Parameters\r
+ 1036 1076 ³ 2.9. Coroutines\r
+ 1081 1132 ³ 2.10. Processes\r
+ 1136 1168 ³ 2.11. Other important features\r
+ 1172 1297 ³ 3. Lexical and textual structure\r
+ 1301 1341 ³ 4. Types\r
+ 1345 1391 ³ 4.1. Primitive types\r
+ 1395 1441 ³ 4.2. System types\r
+ 1445 1456 ³ 4.3. Compound types and objects\r
+ 1457 1498 ³ 4.3.1. Array type\r
+ 1502 1528 ³ 4.3.2. Class type\r
+ 1532 1556 ³ 4.4. Formal types\r
+ 1560 1591 ³ 5.Declarations\r
+ 1594 1619 ³ 5.1. Constant declaration\r
+ 1623 1672 ³ 5.2. Variable declaration\r
+ 1677 1690 ³ 5.3. Unit declaration\r
+ 1691 1731 ³ 5.3.1. Class declaration (introduction)\r
+ 1735 1806 ³ 5.3.2. Subprogram declaration (introduction)\r
+ 1810 1843 ³ 5.3.3. Block\r
+ 1847 1879 ³ 5.3.4. Prefixing\r
+ 1883 2015 ³ 5.3.5. Formal parameters\r
+ 2019 2112 ³ 5.3.6. Unit body\r
+ 2116 2133 ³ 6. Static and dynamic locations\r
+ 2135 2164 ³ 6.1. Unit attributes\r
+ 2168 2177 ³ 6.2. Protected attributes\r
+ 2179 2206 ³ 6.2.1. Hidden attributes\r
+ 2210 2223 ³ 6.2.2. Taken attributes\r
+ 2226 2249 ³ 6.2.3. Legal and illegal identifiers\r
+ 2253 2304 ³ 6.2.4. Close attributes\r
+ 2308 2390 ³ 6.3. Static location\r
+ 2394 2427 ³ 6.4. Objects\r
+ 2431 2564 ³ 6.4.1. Virtual attributes\r
+ 2568 2663 ³ 6.4.2. Valuation of virtuals\r
+ 2667 2720 ³ 6.5. Dynamic location\r
+ 2724 2783 ³ 7. Consistency of types\r
+ 2787 2835 ³ 8. Expressions\r
+ 2839 2864 ³ 8.1. Constant\r
+ 2868 2889 ³ 8.2. Variable\r
+ 2893 2927 ³ 8.2.1. Simple variable\r
+ 2931 2971 ³ 8.2.2. Subscripted variable\r
+ 2975 3018 ³ 8.2.3. Dotted variable\r
+ 3022 3059 ³ 8.2.4. System variable\r
+ 3063 3176 ³ 8.3. Arithmetic expression\r
+ 3180 3359 ³ 8.4. Boolean expression\r
+ 3363 3406 ³ 8.5. Character expression\r
+ 3410 3453 ³ 8.6. String expression\r
+ 3457 3525 ³ 8.7. Object expression\r
+ 3529 3551 ³ 9. Sequential statements.\r
+ 3558 3585 ³ 9.1. Sequential primitive statements\r
+ 3590 3737 ³ 9.1.1. Evaluation statement\r
+ 3741 3758 ³ 9.1.2. Configuration statement\r
+ 3761 4133 ³ 9.1.2.1. Allocation statement\r
+ 4137 4201 ³ 9.1.2.2. Deallocation statement\r
+ 4205 4291 ³ 9.1.3. Simple control statement\r
+ 4295 4348 ³ 9.1.4. Coroutine statement\r
+ 4352 4368 ³ 9.2. Compound statements\r
+ 4373 4439 ³ 9.2.1. Conditional statement\r
+ 4443 4499 ³ 9.2.2. Case statement\r
+ 4506 4799 ³ 9.2.3. Iteration statement\r
+ 4803 4819 ³ 10. Exception handling\r
+ 4822 4844 ³ 10.1. Signal specification\r
+ 4848 4898 ³ 10.2. Signal handlers\r
+ 4902 5046 ³ 10.3. Signal raising\r
+ 5050 5145 ³ 10.4. Handler execution\r
+ 5149 5183 ³ 10.5. System signals\r
+ 5187 5269 ³ 11. Processes\r
+ 5274 5403 ³ 11.1. Transition state statement\r
+ 5407 5588 ³ 11.2. Primitive synchronizing statement\r
+ 5592 5760 ³ 11.3. Monitors (compound synchronization facilities)\r
+ 5765 5862 ³ 12. Separate compilation of units\r
+ 5866 5920 ³ 12.1. Library items\r
+ 5924 6084 ³ 12.1.1. Interface\r
+ 6088 6140 ³ 12.1.2. Using languages\r
+ 6144 6151 ³ 12.1.3. Using externals\r
+ 6155 6198 ³ 12.1.4. Using sl-virtuals\r
+ 6202 6224 ³ 12.2. Linking library items\r
+ 6227 6373 ³ 12.2.1. Connecting the interface\r
+ 6377 6419 ³ 12.3. Binary items\r
+ 6423 6425 ³ 12.4. Processing libraries\r
+ 6427 6452 ³ 12.4.1. Recompilation\r
+ 6456 6482 ³ 12.4.2. Insertions and deletions\r
+ 3 89 ³ 13. File processing\r
+ 6490 6524 ³ 13.1. External and internal files\r
+ 6528 6608 ³ 13.2. File generation and deallocation\r
+ 6612 6663 ³ 13.3. Binary input-output\r
+ 6667 6723 ³ 13.4. Other predefined operations\r
+ 6727 6817 ³ 13.5. Text input-output\r
+ 6821 6880 ³ 13.6. Example of high-level file processing\r
+ 6884 6973 ³ Bibliography\r
+ 19 100 ³Wstep\r
+ 105 349 ³1. Compound statements\r
+ 354 443 ³2. Modularity\r
+ 449 637 ³3. Procedures and functions\r
+ 642 829 ³4. Classes\r
+ 834 975 ³5. Adjustable arrays\r
+ 981 1158 ³6. Coroutines and semicoroutines\r
+ 1164 1490 ³7. Prefixing\r
+ 1496 1548 ³8. Formal types\r
+ 1554 1591 ³9. Protection techniques\r
+ 1597 1691 ³10. Programmed deallocation\r
+ 1697 1781 ³11. Exception handling\r
+ 1785 1788 ³12. Separate compilation (this section does not apply to PC vers\r
+ 1793 1999 ³13. Processes\r
+ 2005 2009 ³References.\r
+ 20 29 ³Wstep\r
+ 110 118 ³0. Preface\r
+ 123 141 ³1. Using Loglan-82 system\r
+ 146 184 ³ 1.1. Compilation\r
+ 187 216 ³ 1.2. Compiler switches\r
+ 220 245 ³ 1.3. Code generation\r
+ 249 294 ³ 1.4. Program interpretation\r
+ 296 327 ³ 1.5. Compile time error\r
+ 332 341 ³ 1.6. Run-time errors\r
+ 346 359 ³2. Compiler options\r
+ 362 371 ³ 2.1. Option format\r
+ 378 403 ³ 2.2. Options list\r
+ 408 410 ³3. Loglan implementation specification\r
+ 411 419 ³ 3.1. Implemented subset of Loglan\r
+ 422 432 ³ 3.2. Non-standard language elements\r
+ 437 442 ³ 3.3. File system\r
+ 445 461 ³ 3.3.1. File variables\r
+ 465 501 ³ 3.3.2. File generation\r
+ 504 508 ³ 3.3.3. File deallocation\r
+ 512 530 ³ 3.3.4. General file operations\r
+ 535 556 ³ 3.3.5. Text files\r
+ 560 577 ³ 3.3.6. Binary sequential files\r
+ 581 630 ³ 3.3.7. Direct access binary files\r
+ 635 644 ³ 3.4. Concurrency\r
+ 647 676 ³ 3.4.1. Invoking the LOGLAN interpreter for concurrent pro\r
+ 679 753 ³ 3.4.2. Restrictions and differences from the report\r
+ 756 841 ³ 3.4.3. Communication mechanism\r
+ 846 865 ³ 3.5. System signals\r
+ 870 910 ³ 3.6. Implementation restrictions\r
+ 913 922 ³A. Standard constants\r
+ 928 1077 ³B. Standard classes\r
+ 931 972 ³ IIUWGRAPH\r
+ 976 1077 ³ MOUSE\r
+ 1082 1196 ³C. Standard procedures and functions\r
+ 1202 1755 ³D. Error codes\r
+ 1758 1833 ³E. Loglan runtime errors\r
+ 1835 1914 ³F. Character set\r
+ 1919 1923 ³Bibliography\r
+ 435 455 ³ proc BORDER(consts b: integer);\r
+ 883 889 ³ L proc BURY(window: buffer);\r
+ 636 649 ³ proc CIRB(consts ix,iy,ir: integer;\r
+ 636 649 ³ consts alfa, beta: real;\r
+ 636 649 ³ consts cbord, bcint, p, q: integer);\r
+ 250 253 ³ proc CLS;\r
+ 356 379 ³ proc COLOR(consts c: integer);\r
+ 626 632 ³ proc DRAW(consts ix,iy: integer);\r
+ 892 896 ³ L proc EXPOSE(window: buffer; consts x,y: integer)\r
+ 694 714 ³ L proc GETMAP(consts x,y: integer; ekran: buffer);\r
+ 242 247 ³ L proc GROFF;\r
+ 203 220 ³ proc GRON(consts imode: integer);\r
+ 770 794 ³ proc HASCII(consts ic: integer);\r
+ 652 667 ³ proc HFILL(consts maxx: integer);\r
+ 802 806 ³ proc HFONT(consts seg, offs: integer);\r
+ 809 813 ³ proc HFONT8(vars seg, offs: integer);\r
+ 260 298 ³ proc HPAGE(consts page, mode, clear: integer);\r
+ 832 857 ³ P proc INHLINE(vars n:integer; line: tekst);\r
+ 520 527 ³ proc INTENS(consts i: integer);\r
+ 907 916 ³ PL proc INWLINE(window: buffer; vars n: integer;\r
+ 907 916 ³ line: tekst);\r
+ 869 880 ³ L proc MKWNDW(consts x,y,icols,ilines: integer;\r
+ 869 880 ³ window: buffer;\r
+ 869 880 ³ consts iwndwsize,iborder: integer);\r
+ 537 547 ³ proc MOVE(consts ix,iy: integer);\r
+ 728 732 ³ proc ORMAP(ekran: buffer);\r
+ 825 829 ³ PL proc OUTHLINE(consts n:integer; line: tekst);\r
+ 899 904 ³ PL proc OUTWLINE(window: buffer; consts n: integer;\r
+ 899 904 ³ line: tekst);\r
+ 458 516 ³ proc PALLET(consts p: integer);\r
+ 411 432 ³ proc PATERN(consts p1, p2, p3, p4: integer);\r
+ 607 610 ³ proc POINT(consts ix,iy: integer);\r
+ 558 577 ³ proc POPXY;\r
+ 1067 1084 ³ proc PRTSCR(consts nr: integer);\r
+ 550 555 ³ proc PUSHXY;\r
+ 718 725 ³ proc PUTMAP(ekran: buffer);\r
+ 1015 1021 ³ L proc RCIRB(consts ix,iy,ir: real;\r
+ 1015 1021 ³ consts alfa, beta: real;\r
+ 1015 1021 ³ consts cbord, bcint, p, q: integer);\r
+ 1006 1011 ³ L proc RDRAW(consts rx,ry: real);\r
+ 998 1002 ³ L proc RMOVE(consts rx,ry: real);\r
+ 981 984 ³ PL proc RWINDOW(rw: array [1:4] of real;\r
+ 981 984 ³ consts s: integer);\r
+ 382 405 ³ proc STYLE(consts s: integer);\f\r
+ 935 974 ³ PL proc SWINDOW(rw: array [1:4] of real;\r
+ 935 974 ³ iw: array [1:4] of integer;\r
+ 935 974 ³ consts s: integer);\r
+ 584 596 ³ proc TRACK(consts x,y: integer);\r
+ 675 684 ³ proc VFILL(consts maxy: integer);\r
+ 301 345 ³ proc VIDEO(ekran: buffer);\r
+ 735 739 ³ proc XORMAP(ekran: buffer);\r
+ 979 982 ³MOUSE\r
+ 989 993 ³showcursor:procedure\r
+ 995 999 ³hidecursor:procedure\r
+ 1001 1007 ³status:procedure(output h, v:integer, l, r, c:boolean)\r
+ 1009 1014 ³setposition:procedure(h, v:integer)\r
+ 1016 1022 ³getpress:procedure(b:integer; output h, v, p:integer, l, r, c:boo\r
+ 1024 1030 ³getrelease:procedure(b:integer; output h, v, p:integer, l, r, c:b\r
+ 1032 1036 ³setwindow:procedure(l, r, t, b:integer)\r
+ 1039 1054 ³defcursor:procedure(s, x, y:integer)\r
+ 1056 1058 ³getmovement:procedure(output h, v:integer)\r
+ 1060 1069 ³setspeed:procedure(h, v:integer)\r
+ 1071 1077 ³setthreshold:procedure(s:integer)\r
+ 1085 1086 ³ ENDRUN:procedure;\r
+ 1088 1089 ³ RANSET:procedure(x:real);\r
+ 1180 1182 ³ RESET:procedure(f:file);\r
+ 1184 1187 ³ REWRITE:procedure(f:file);\r
+ 1189 1190 ³ UNLINK:procedure(f:file);\r
+ 1192 1193 ³ SEEK:procedure(f:file; offset, base:integer);\r
+ 749 765 ³ L func INKEY(consts idummy: integer): integer;\r
+ 613 616 ³ func INPIX(consts x,y: integer): integer;\r
+ 543 547 ³ L func INXPOS(consts idummy: integer): integer;\r
+ 543 547 ³ L func INYPOS(consts idummy: integer): integer;\r
+ 224 238 ³ L func NOCARD(consts idummy: integer): integer;\r
+ 988 994 ³ PL func RINXPOS(consts dummy: real): real;\r
+ 988 994 ³ PL func RINYPOS(consts dummy: real): real;\r
+ 976 982 ³MOUSE\r
+ 984 987 ³init:function(output b:integer):boolean\r
+ 1091 1093 ³ RANDOM:function:real;\r
+ 1095 1096 ³ SQRT:function(x:real):real;\r
+ 1098 1099 ³ SIN:function(x:real):real;\r
+ 1101 1102 ³ COS:function(x:real):real;\r
+ 1104 1105 ³ TAN:function(x:real):real;\r
+ 1107 1108 ³ EXP:function(x:real):real;\r
+ 1110 1111 ³ LN:function(x:real):real;\r
+ 1113 1114 ³ ATAN:function(x:real):real;\r
+ 1116 1117 ³ ENTIER:function(x:real):integer;\r
+ 1119 1121 ³ ROUND:function(x:real):integer;\r
+ 1123 1124 ³ IMIN:function(x, y:integer):integer;\r
+ 1126 1127 ³ IMAX:function(x, y:integer):integer;\r
+ 1129 1130 ³ IMIN3:function(x, y, z:integer):integer;\r
+ 1132 1133 ³ IMAX3:function(x, y, z:integer):integer;\r
+ 1135 1137 ³ ISHFT:function(x, k:integer):integer;\r
+ 1139 1140 ³ IAND:function(n, k:integer):integer;\r
+ 1142 1143 ³ IOR:function(n, k:integer):integer;\r
+ 1145 1146 ³ XOR:function(n, k:integer):integer;\r
+ 1148 1150 ³ INOT:function(n:integer):integer;\r
+ 1152 1156 ³ ORD:function(c:char):integer;\r
+ 1158 1160 ³ CHR:function(n:integer):char;\r
+ 1162 1164 ³ UNPACK:function(s:string):arrayof char;\r
+ 1166 1168 ³ MEMAVAIL:function:integer;\r
+ 1170 1173 ³ EXEC:function(cmd:arrayof char):integer;\r
+ 1175 1178 ³ TIME:function: integer;\r
+ 1195 1196 ³ POSITION:function(f:file):real;\r
+ 1319 1345 ³ Wartosci kodow klawiszy specjalnych:\r
+ 1206 1213 ³ 0 - ***declaration part overloaded\r
+ 1214 1217 ³ 10 - ***too many errors\r
+ 1218 1219 ³ 41 - ***declaration part overloaded\r
+ 1220 1220 ³ 101 - ':=' expected\r
+ 1221 1221 ³ 102 - ';' expected\r
+ 1222 1222 ³ 103 - 'then' expected\r
+ 1223 1223 ³ 104 - 'fi'/'else' expected\r
+ 1224 1224 ³ 105 - 'od' expected\r
+ 1225 1225 ³ 106 - '(' expected\r
+ 1226 1226 ³ 107 - ')' expected\r
+ 1227 1227 ³ 108 - 'do' expected\r
+ 1228 1228 ³ 109 - identifier expected\r
+ 1229 1231 ³ 110 - too many exits found\r
+ 1232 1232 ³ 111 - illegal character\r
+ 1233 1233 ³ 112 - wrong structure of 'if'-statement\r
+ 1234 1234 ³ 113 - 'end' missing\r
+ 1235 1235 ³ 114 - '.' expected\r
+ 1236 1238 ³ 115 - illegal constant in expression\r
+ 1239 1239 ³ 116 - '=' expected\r
+ 1240 1240 ³ 117 - constant expected\r
+ 1241 1241 ³ 118 - ':' expected\r
+ 1242 1244 ³ 119 - unit kind specification expected\r
+ 1245 1245 ³ 120 - 'hidden' or 'close' occurred twice\r
+ 1246 1246 ³ 121 - 'hidden' or 'close' out of a class\r
+ 1247 1247 ³ 122 - 'block' expected\r
+ 1248 1250 ³ 123 - object expression is not a generator\r
+ 1251 1251 ³ 124 - 'dim' expected\r
+ 1252 1252 ³ 125 - 'to'/'downto' expected\r
+ 1253 1253 ³ 126 - illegal arithmetic operator\r
+ 1254 1254 ³ 127 - declaration part expected\r
+ 1255 1257 ³ 128 - incorrect identifier at 'end'\r
+ 1258 1258 ³ 129 - wrong structure of 'case'-statement\r
+ 1259 1259 ³ 130 - wrong structure of 'do'-statement\r
+ 1260 1262 ³ 131 - illegal use of 'main'\r
+ 1263 1263 ³ 132 - 'when' expected\r
+ 1264 1266 ³ 133 - too many branches in 'case'-statement\r
+ 1267 1267 ³ 134 - 'begin' missed\r
+ 1268 1268 ³ 135 - bad option\r
+ 1269 1271 ³ 136 - is it really a loglan program???\r
+ 1272 1276 ³ 137 - 'block' missed - parsing began\r
+ 1277 1279 ³ 138 - 'repeat' out of a loop\r
+ 1280 1280 ³ 139 - there is no path to this statement\r
+ 1281 1281 ³ 140 - 'andif'/'orif' mixed\r
+ 1282 1282 ³ 141 - array of 'semaphore' is illegal\r
+ 1283 1285 ³ 142 - wrong handler end\r
+ 1286 1286 ³ 143 - lastwill inside a structured statement\r
+ 1287 1289 ³ 144 - repeated lastwill\r
+ 1290 1290 ³ 145 - no parameter specification\r
+ 1291 1291 ³ 146 - wrong register specification\r
+ 1292 1292 ³ 147 - "," expected\r
+ 1293 1296 ³ 191 - ***null program\r
+ 1297 1300 ³ 196 - ***too many identifiers\r
+ 1301 1304 ³ 197 - ***too many formal parameters\r
+ 1305 1307 ³ 198 - ***parsing stack overloaded\r
+ 1308 1311 ³ 199 - ***too many prototypes\r
+ 1312 1312 ³ 201 - wrong real constant\r
+ 1313 1313 ³ 202 - wrong comment\r
+ 1314 1314 ³ 203 - wrong character constant\r
+ 1315 1315 ³ 204 - wrong integer constant\r
+ 1316 1317 ³ 205 - integer overflow\r
+ 1318 1319 ³ 206 - real overflow\r
+ 1320 1322 ³ 211 - identifier too long\r
+ 1323 1325 ³ 212 - string too long\r
+ 1326 1329 ³ 301 - prefix is not a class id\r
+ 1330 1332 ³ 303 - coroutine/process illegal here as prefix id\r
+ 1333 1335 ³ 304 - hidden identifier cannot be taken id\r
+ 1336 1336 ³ 305 - undeclared identifier id\r
+ 1337 1337 ³ 306 - undeclared type identifier id\r
+ 1338 1342 ³ 307 - type identifier expected id\r
+ 1343 1343 ³ 308 - undeclared prefix identifier id\r
+ 1344 1344 ³ 309 - declared more than once id\r
+ 1345 1345 ³ 310 - taken list in unprefixed unit\r
+ 1346 1349 ³ 316 - formal type specification after use id\r
+ 1350 1353 ³ 317 - hidden type identifier id\r
+ 1354 1356 ³ 318 - type identifier not taken id\r
+ 1357 1359 ³ 319 - hidden identifier in the list id\r
+ 1360 1363 ³ 320 - identifier in the list not taken id\r
+ 1364 1366 ³ 321 - identifier cannot be taken id\r
+ 1367 1368 ³ 322 - hidden prefix identifier id\r
+ 1369 1370 ³ 323 - prefix identifier not taken id\r
+ 1371 1373 ³ 329 - only procedure and function may be virtual\r
+ 1374 1374 ³ 330 - virtual in unprefixed block/procedure/function\r
+ 1375 1378 ³ 331 - incompatible kinds of virtuals id\r
+ 1379 1381 ³ 332 - incompatible types of virtuals id\r
+ 1382 1384 ³ 333 - different lengths of form.param.lists in virtuals\r
+ 1385 1390 ³ 334 - conflict kinds of the 1st level parameters\r
+ 1391 1395 ³ 335 - incompatible types of the 1st level parameters\r
+ 1396 1400 ³ 336 - different lengths of the 2nd level params lists\r
+ 1401 1405 ³ 337 - incompatible kinds of the 2nd level parameters i\r
+ 1406 1410 ³ 338 - incompatible types of the 2nd level parameters i\r
+ 1411 1412 ³ 341 - ***declaration part overloaded\r
+ 1413 1413 ³ 342 - ***too many classes declared\r
+ 1414 1415 ³ 343 - ***too many prototypes\r
+ 1416 1416 ³ 350 - undeclared signal identifier id\r
+ 1417 1418 ³ 351 - hidden signal identifier id\r
+ 1419 1420 ³ 352 - signal identifier not taken id\r
+ 1421 1423 ³ 353 - signal identifier expected id\r
+ 1424 1428 ³ 354 - different types of parameters id\r
+ 1429 1432 ³ 355 - incompatible kinds of parameters id\r
+ 1433 1436 ³ 356 - different identifiers of parameters id\r
+ 1437 1438 ³ 357 - incompatible kinds of the 2nd level parameters i\r
+ 1439 1440 ³ 358 - different types of the 2nd level parameters\r
+ 1441 1446 ³ 359 - different lengths of the 2nd level params lists\r
+ 1447 1450 ³ 360 - different lengths of form. param. lists in signal\r
+ 1451 1453 ³ 361 - non-local formal type cannot be used id\r
+ 1454 1456 ³ 362 - repeated handler for signal id\r
+ 1457 1459 ³ 370 - only 'input' is legal here\r
+ 1460 1473 ³ 398 - class prefixed by itself id\r
+ 1474 1476 ³ 404 - repeated label in 'case'-statement id\r
+ 1477 1479 ³ 405 - illegal type of 'case' expression id\r
+ 1480 1480 ³ 406 - different types of labels and 'case' expression\r
+ 1481 1481 ³ 407 - non-logical expression after 'if'/'while' i\r
+ 1482 1484 ³ 408 - real constant out of integer range\r
+ 1485 1487 ³ 410 - simple variable expected id\r
+ 1488 1490 ³ 411 - non-integer control variable id\r
+ 1491 1495 ³ 412 - non-integer expression id\r
+ 1496 1496 ³ 413 - file expression expected id\r
+ 1497 1497 ³ 414 - string expression expected id\r
+ 1498 1501 ³ 415 - reference expression expected id\r
+ 1502 1502 ³ 416 - array expression expected id\r
+ 1503 1503 ³ 417 - boolean expression expected id\r
+ 1504 1504 ³ 418 - semaphore variable expected\r
+ 1505 1507 ³ 419 - illegal type in 'open'\r
+ 1508 1511 ³ 420 - variable expected id\r
+ 1512 1514 ³ 421 - class identifier after 'new' expected id\r
+ 1515 1515 ³ 422 - procedure identifier after 'call' expected\r
+ 1516 1518 ³ 423 - 'new' missing id\r
+ 1519 1521 ³ 424 - 'call' missing id\r
+ 1522 1522 ³ 425 - 'inner' out of a class\r
+ 1523 1523 ³ 426 - 'inner' occurred more than once\r
+ 1524 1524 ³ 427 - 'wind'/'terminate' out of a handler\r
+ 1525 1525 ³ 428 - 'inner' inside lastwill\r
+ 1526 1528 ³ 429 - definition cannot be reduced to constant id\r
+ 1529 1529 ³ 430 - undefined constant in the definition id\r
+ 1530 1532 ³ 431 - wrong number of indices id\r
+ 1533 1533 ³ 432 - index out of range id\r
+ 1534 1534 ³ 433 - upper bound less than lower bound id\r
+ 1535 1536 ³ 434 - too many subscripts id\r
+ 1537 1537 ³ 435 - variable is not array id\r
+ 1538 1541 ³ 440 - type identifier expected after 'arrayof' id\r
+ 1542 1545 ³ 441 - incorrect format in 'write'\r
+ 1546 1548 ³ 442 - illegal expression in 'write'\r
+ 1549 1551 ³ 443 - illegal type of variable in 'read' id\r
+ 1552 1553 ³ 444 - no data for i/o transfer\r
+ 1554 1554 ³ 445 - illegal expression in 'put'\r
+ 1555 1555 ³ 446 - illegal expression in 'get'\r
+ 1556 1558 ³ 448 - 'raise' missing id\r
+ 1559 1561 ³ 449 - signal identifier expected id\r
+ 1562 1563 ³ 450 - illegal procedure occurrence id\r
+ 1564 1565 ³ 451 - illegal class occurrence id\r
+ 1566 1567 ³ 452 - illegal type occurrence id\r
+ 1568 1569 ³ 453 - illegal signal occurrence id\r
+ 1570 1570 ³ 454 - illegal operator occurence\r
+ 1571 1571 ³ 455 - wrong number of operands\r
+ 1572 1572 ³ 460 - divided by zero\r
+ 1573 1576 ³ 470 - illegal input parameter id\r
+ 1577 1579 ³ 471 - illegal output parameter id\r
+ 1580 1582 ³ 472 - illegal type parameter id\r
+ 1583 1585 ³ 473 - illegal procedure parameter id\r
+ 1586 1588 ³ 474 - illegal function parameter id\r
+ 1589 1591 ³ 475 - illegal left side of 'is'/'in' id\r
+ 1592 1594 ³ 476 - illegal right side od 'is'/'in' id\r
+ 1595 1597 ³ 477 - illegal parameter of 'attach' id\r
+ 1598 1598 ³ 478 - illegal type of expression\r
+ 1599 1599 ³ 479 - negative step value\r
+ 1600 1606 ³ 550 - ***stack overloaded\r
+ 1607 1610 ³ 551 - ***too many auxiliary variables needed\r
+ 1611 1612 ³ 552 - ***too many auxiliary reference variable needed\r
+ 1613 1617 ³ 553 - ***statement sequence too long or too complicated\r
+ 1618 1621 ³ 554 - ***real constants dictionary overflow\r
+ 1622 1622 ³ 600 - undeclared identifier id\r
+ 1623 1625 ³ 601 - illegal type before '.' id\r
+ 1626 1629 ³ 602 - close identifier after '.' id\r
+ 1630 1634 ³ 603 - undeclared identifier after '.' id\r
+ 1635 1637 ³ 604 - illegal operand type id\r
+ 1638 1640 ³ 605 - illegal type in 'div/'mod' term id\r
+ 1641 1642 ³ 606 - incompatible types in comparison id\r
+ 1643 1646 ³ 607 - unrelated class types in comparison id\r
+ 1647 1648 ³ 608 - string cannot be compared id\r
+ 1649 1654 ³ 609 - incompatible types in assignment/transmission id\r
+ 1655 1656 ³ 610 - unrelated class types in assignment/transmission\r
+ 1657 1658 ³ 611 - constant after '.' id\r
+ 1659 1662 ³ 612 - this class does not occur in sl-chain id\r
+ 1663 1667 ³ 613,614 - class identifier expected id\r
+ 1668 1671 ³ 615 - illegal type before 'qua' id\r
+ 1672 1676 ³ 616,617 - illegal type after 'qua' id\r
+ 1677 1680 ³ 618 - unrelated types in 'qua'-expression id\r
+ 1681 1684 ³ 619 - hidden identifier id\r
+ 1685 1688 ³ 620 - not taken identifier id\r
+ 1689 1691 ³ 621 - invisible identifier after '.' id\r
+ 1692 1696 ³ 622 - formal parameter list is shorter id\r
+ 1697 1698 ³ 623 - formal parameter list is longer id\r
+ 1699 1702 ³ 624 - actual parameter is not a reference type id\r
+ 1703 1705 ³ 625 - actual parameter is not a type id\r
+ 1706 1710 ³ 626 - procedure-function conflict between parameters i\r
+ 1711 1716 ³ 627 - unmatched heads-wrong kinds of parameters i\r
+ 1717 1721 ³ 628 - unmatched heads-incompatible types in lists\r
+ 1722 1726 ³ 629 - unmatched heads-unrelated class types in lists i\r
+ 1727 1729 ³ 630 - unmatched heads-different numbers of parameters\r
+ 1730 1733 ³ 631 - incompatible types of function parameters\r
+ 1734 1737 ³ 632 - function/procedure expected id\r
+ 1738 1744 ³ 633 - actual function type defined weaker than formal\r
+ 1745 1750 ³ 634 - unmatched heads-too weak type in actual list\r
+ 1751 1753 ³ 635 - standard function/procedure cannot be actual par.\r
+ 1754 1754 ³ 636 - illegal use of semaphore id\r
+ 1755 1755 ³ 637 - 'semaphore' cannot be used id\r
+ 1760 1761 ³LOGLAN RUNTIME ERRORS\r
+ 1763 1764 ³ARRAY INDEX ERROR (CONERROR)\r
+ 1765 1765 ³NEGATIVE STEP VALUE (CONERROR)\r
+ 1766 1768 ³SL CHAIN CUT OFF (LOGERROR)\r
+ 1769 1771 ³ILLEGAL ATTACH (LOGERROR)\r
+ 1772 1774 ³ILLEGAL DETACH (LOGERROR)\r
+ 1775 1777 ³ILLEGAL RESUME (LOGERROR)\r
+ 1778 1779 ³TOO MANY PROCESSES ON ONE MACHINE (SYSERROR)\r
+ 1780 1782 ³INVALID NODE NUMBER (SYSERROR)\r
+ 1783 1786 ³IMPROPER QUA (LOGERROR)\r
+ 1787 1789 ³ILLEGAL ASSIGNMENT (TYPERROR)\r
+ 1790 1791 ³FORMAL TYPE MISSING (LOGERROR)\r
+ 1792 1793 ³ILLEGAL KILL (LOGERROR)\r
+ 1794 1797 ³ILLEGAL COPY (LOGERROR)\r
+ 1798 1800 ³REFERENCE TO NONE (ACCERROR)\r
+ 1801 1801 ³MEMORY OVERFLOW (MEMERROR)\r
+ 1802 1806 ³INCOMPATIBLE HEADERS (TYPERROR)\r
+ 1807 1809 ³INCORRECT ARRAY BOUNDS (CONERROR)\r
+ 1810 1810 ³DIVISION BY ZERO (NUMERROR)\r
+ 1811 1812 ³COROUTINE TERMINATED (LOGERROR)\r
+ 1813 1814 ³COROUTINE ACTIVE (LOGERROR)\r
+ 1815 1816 ³HANDLER NOT FOUND (LOGERROR)\r
+ 1817 1819 ³ILLEGAL RETURN (LOGERROR)\r
+ 1820 1821 ³UNIMPLEMENTED STANDARD PRC. (LOGERROR)\r
+ 1822 1823 ³FORMAL LIST TOO LONG (MEMERROR)\r
+ 1824 1826 ³ILLEGAL I/O OPERATION (SYSERROR)\r
+ 1827 1828 ³I/O ERROR (SYSERROR)\r
+ 1829 1829 ³CANNOT OPEN FILE (SYSERROR)\r
+ 1830 1830 ³INPUT DATA FORMAT BAD (SYSERROR)\r
+ 1831 1832 ³SYSTEM ERROR (SYSERROR)\r
+ 1833 1833 ³UNRECOGNIZED ERROR\r
+ 1838 1914 ³CHARACTER SET\r
--- /dev/null
+\r
+\r
+\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ A micro-manual\r
+ \r
+ of \r
+ \r
+ the programming language\r
+ \r
+ \r
+ L O G L A N - 82\r
+ ================\r
+ \r
+ \r
+ \r
+ Basic constructs and facilities\r
+ \r
+ \r
+ Author: Antoni Kreczmar\r
+ Institute of Informatics, Warsaw University\r
+ September 1982 \r
+\r
+\r
+ LOGLAN-82 is a universal programming language designed at the\r
+Institute of Informatics, University of Warsaw. Its syntax is\r
+patterned upon Pascal's. Its rich semantics includes the classical\r
+constructs and facilities offered by the Algol-family programming\r
+languages as well as more modern facilities, such as concurrency and\r
+exception handling.\r
+ The basic constructs and facilities of the LOGLAN-82 programming\r
+language include:\r
+ \r
+1) A convenient set of structured statements,\r
+ \r
+2) Modularity (with the possibility of module nesting and extending),\r
+ \r
+3) Procedures and functions (fully recursive; procedures and functions\r
+ can be used also as formal parameters),\r
+ \r
+4) Classes (as a generalization of records) which enable to define\r
+ complex structured types, data structures, packages, etc.,\r
+ \r
+5) Adjustable arrays whose bounds are determined at run-time in such a\r
+ way that multidimensional arrays may be of various shapes, e.g.\r
+ triangular, k-diagonal, streaked, etc.,\r
+ \r
+6) Coroutines and semi-coroutines,\r
+ \r
+7) Prefixing - the facility borrowed from Simula-67, substantially\r
+ generalized in LOGLAN-82 - which enables to build up hierarchies of\r
+ types and data structures, problem-oriented languages, etc.,\r
+ \r
+8) Formal types treated as a method of module parametrization,\r
+ \r
+9) Module protection and encapsulation techniques,\r
+ \r
+10) Programmed deallocator - a tool for efficient and secure garbage\r
+ collection, which allows the user to implement the optimal\r
+ strategy of storage management,\r
+ \r
+11) Exception handling which provides facilities for dealing with\r
+ run-time errors and other exceptional situations raised by the\r
+ user,\r
+ \r
+12) Separate compilation techniques,\r
+ \r
+13) Concurrency easily adaptable to any operating system kernel and\r
+ allowing parallel programming in a natural and efficient way.\r
+ \r
+ The language covers system programming, data processing, and\r
+numerical computations. Its constructs represent the state-of-art and\r
+are efficiently implementable. Large systems consisting of many\r
+cooperating modules are easily decomposed and assembled, due to the\r
+class concept and prefixing.\r
+ LOGLAN-82 constructs and facilities have appeared and evolved\r
+simultaneously with the experiments on the first pilot compiler\r
+(implemented on Mera-400 Polish minicomputer). The research on\r
+LOGLAN-82 implementation engendered with new algorithms for static\r
+semantics, context analysis, code generation, data structures for\r
+storage management etc.\r
+ The LOGLAN-82 compiler provides a keen analysis of syntactic and\r
+semantic errors at compilation as well as at run time. The object code\r
+is very efficient with respect to time and space. The completeness of\r
+error checking guarantees full security and ease of program debugging.\r
+\r
+1. Compound statements\r
+######################\r
+\r
+ Compound statements in LOGLAN-82 are built up from simple statements\r
+(like assignment statement e.g. x:=y+0.5, call statement e.g. callP(7,x+5) e\r
+ The syntax of conditional statement is as follows:\r
+ \r
+ if boolean expression\r
+ then \r
+ sequence of statements\r
+ else \r
+ sequence of statements\r
+ fi \r
+ \r
+where "else part" may be omitted:\r
+ \r
+ if boolean expression \r
+ then \r
+ sequence of statements\r
+ fi \r
+ \r
+ The semantics of conditional statement is standard. The keyword fi \r
+allows to nest conditional statements without appearence of "dangling\r
+else" ambiguity.\r
+ \r
+Example:\r
+--------\r
+ \r
+ if delta>0 if \r
+ then \r
+ x2:=sqrt(delta)/a/2;\r
+ if b=0 \r
+ then \r
+ x1:=x2\r
+ else \r
+ x1:=-b/a/2+x2; x2:=x1-2*x2\r
+ fi \r
+ else \r
+ if delta=0 \r
+ then \r
+ x1:=-b/a/2; x2:=x1\r
+ else \r
+ write(" no real roots")\r
+ fi \r
+ fi \r
+ \r
+ The statements in a sequence of statements are separated with\r
+semicolons (semicolon may end a sequence , and then, the last\r
+statement in the sequence is the empty statement).\r
+\r
+ The short circuit control forms are realized in LOGLAN-82 by the\r
+conditional statements with orif (or andif) list. A conditional \r
+statement with orif list has the form: orif \r
+ \r
+ if wb1 orif wb2 ... orif wbk \r
+ then \r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi \r
+ \r
+and corresponds somehow to a conditional statement:\r
+ \r
+ if wb1 or wb2 ... or wbk \r
+ then \r
+ sequence of statements\r
+ else \r
+ sequence of statements\r
+ fi \r
+ \r
+ The above conditional statement (without orif list) selects for \r
+execution one of two sequences of statements, depending on the truth\r
+value of the boolean expression:\r
+ \r
+ wb1 or wb2 or ... wbk \r
+ \r
+which is always evaluated till the end. For the execution of the\r
+conditional statement with orif list the specified conditons \r
+wb1,...,wbk are evaluated in succession, until the first one evaluates\r
+to true. Then the rest of the sequence wb1,...,wbk is abandoned and\r
+"then part" is executed. If none of the conditions wb1,...,wbk\r
+evaluates to true "else part" is executed (if any).\r
+ Conditional statements with orif list facilitate to program those \r
+conditions, which evaluation to the end may raise a run-time error.\r
+ \r
+Example:\r
+--------\r
+ The execution of the statement:\r
+ \r
+ if i>n or A(i)=0 then i:=i-1 else A(i):=1 fi \r
+ \r
+where the value of i is greater than n, and A is an array with upper\r
+bound n, will raise the run-time error. Then the user can write:\r
+ \r
+ if i>n orif A(i)=0 then i:=i-1 else A(i):=1 fi\r
+ \r
+what allows to avoid this run-time error and probably agrees with his\r
+intension. \r
+\r
+ Conditional statement with andif list has the form:\r
+ \r
+ if wb1 andif wb2 ... andif wbk\r
+ then \r
+ sequence of statements\r
+ else \r
+ sequence of statements\r
+ fi \r
+ \r
+ For the execution of this kind of statements, the conditions\r
+wb1,...,wbk are evaluated in succession, until the first one evaluates\r
+to false; then "else part" (if any) is executed. Otherwise "then part"\r
+is executed.\r
+ \r
+ Iteration statement in LOGLAN-82 has the form:\r
+ \r
+ do sequence of statements od\r
+ An iteration statement specifies repeated execution of the sequence\r
+of statements and terminates with the execution of the simple\r
+statement exit\r
+ \r
+Example:\r
+--------\r
+ \r
+ s:=1; t:=1; i:=1;\r
+ do \r
+ i:=i+1; t:=t*x/i;\r
+ if abs(t) < 1.0E-10 then exit fi; \r
+ s:=s+t\r
+ od; \r
+ \r
+ If two iteration statements are nested, then double exit in the \r
+inner one terminates both of them.\r
+ \r
+Example:\r
+--------\r
+ \r
+ r,x:=0;\r
+ do \r
+ s,t:=1; i:=1; x:=x+0.2;\r
+ do \r
+ i:=i+1; t:=t*x/i;\r
+ if i > n then exit exit fi; (* termination of both loops *) \r
+ if t < 1 then exit fi; (* termination of the inner loop *) \r
+ s:=s+t\r
+ od \r
+ od \r
+ \r
+ In the example above simultaneous assignment statements are\r
+illustrated (e.g. r,x:=0) and comments, which begin with a left\r
+parenthesis immediately followed by an asterisk and end with an\r
+asterisk immediately followed by a right parenthesis.\r
+ \r
+ Triple exit terminates three nested iteration statements, four exit \r
+terminates four nested iteration statements etc.\r
+\r
+ The iteration statement with while condition: w\r
+ \r
+ while boolean expression \r
+ do \r
+ sequence of statements\r
+ od \r
+ \r
+is equivalent to:\r
+ \r
+ do \r
+ if not boolean expression then exit fi; \r
+ sequence of statements\r
+ od \r
+ \r
+ The iteration statements with controlled variables (for statements) \r
+have the forms:\r
+ \r
+ for j:=wa1 step wa2 to wa3 \r
+ do \r
+ sequence of statements\r
+ od \r
+ \r
+or\r
+ \r
+ for j:=wa1 step wa2 downto wa3 \r
+ do \r
+ sequence of statements\r
+ od \r
+ \r
+ The type of the controlled variable j must be discrete. The value of\r
+this variable in the case of the for statement with to is increased, \r
+and in the case of the for statement with downto is decreased. The \r
+discrete range begins with the value of wa1 and changes with the step\r
+equal to the value of wa2. The execution of the for statement with to\r
+terminates when the value of j for the first time becomes greater than\r
+the value of wa3 (with downto when the value of j for the first time \r
+becomes less than the value of wa3). After the for statement \r
+termination the value of its controlled variable is determined and\r
+equal to the first value exceeding the specified discrete range. The\r
+values of expressions wa1, wa2 and wa3 are evaluated once, upon entry\r
+to the iteration statement. Default value of wa2 is equal 1 (when the\r
+keyword step and expression wa2 are omitted).\r
+ for or while statements may be combined with exit statement. \r
+ \r
+Example:\r
+--------\r
+ \r
+ for j:=1 to n\r
+ do \r
+ if x=A(j) then exit fi; \r
+ od \r
+ \r
+ The above iteration statement terminates either for the least j,\r
+1<=j<=n, such that x=A(j) or for j=n+1 when x=/=A(j), j=1,...,n.\r
+\r
+ To enhance the user's comfort, the simple statement repeat is\r
+provided. It may appear in an iteration statement and causes the\r
+current iteration to be finished and the next one to be continued\r
+(something like jump to CONTINUE in Fortran's DO statements).\r
+ \r
+Example:\r
+--------\r
+ \r
+ i:=0; s:=0;\r
+ do \r
+ i:=i+1;\r
+ if A(i) < 0 then repeat fi; (* jump to od, iterations are continued *)\r
+ if i > m then exit fi; (* iteration statement is terminated *) \r
+ s:=s+sqrt(A(i));\r
+ od; \r
+ \r
+ Just as exit, repeat may appear in for statement or while statement. \r
+Then the next iteration begins with either the evaluation of a new\r
+value of the controlled variable (for statement) or with the \r
+evaluation of the condition (while statement). \r
+ \r
+ Case statement in LOGLAN-82 has the form:\r
+ \r
+ case WA \r
+ when L1 : I1 \r
+ when L2 : I2 \r
+ ...\r
+ when Lk : Ik \r
+ otherwise I \r
+ esac \r
+ \r
+where WA is an expression , L1,...,Lk are constants and I1,..., Ik,I\r
+are sequences of statements.\r
+ A case statement selects for execution a sequence of statements Ij,\r
+1<=j<=k, where the value of WA equals Lj. The choice otherwise covers \r
+all values (possibly none) not given in the previous choices. The\r
+execution of a case statement chooses one and only one alternative\r
+(since the choices are to be exhaustive and mutually exclusive).\r
+\r
+2. Modularity\r
+#############\r
+ \r
+ Modular structure of the language is gained due to the large set of\r
+means for module nesting and extending. Program modules (units) are\r
+blocks, procedures, functions, classes, coroutines and processes.\r
+Block is the simplest kind of unit. Its syntax is the following:\r
+ \r
+ block \r
+ lists of declarations\r
+ begin \r
+ sequence of statements\r
+ end \r
+ \r
+ The sequence of statements commences with the keyword begin (it may \r
+be omitted when this sequence is empty). The lists of declarations\r
+define the syntactic entities (variables, constants, other units),\r
+whose scope is that block. The syntactic entities are identified in\r
+the sequence of statements by means of names (identifiers).\r
+ \r
+Example:\r
+--------\r
+ \r
+ block \r
+ const n=250; \r
+ var x,y:real, i,j,k: integer, b: boolean; \r
+ const m=n+1; \r
+ begin \r
+ read(i,j); (* read two integers *)\r
+ x,y:=n/(i+j); (* simultaneous assignment *)\r
+ read(c) ; (* read a character *)\r
+ b:= c = 'a'; (* 'a' a character *)\r
+ for k:= 1 to m \r
+ do \r
+ write(x+y/k:10:4); (* print the value of x+y/k\r
+ in the field of 10 characters, 4 digits after the point *)\r
+ od \r
+ end \r
+ \r
+ In the lists of declarations semicolons terminate the whole lists,\r
+not the lists elements. Any declaration list must begin with the\r
+pertinent keyword (var for variables, const for constants etc.). The \r
+value of an expression defining a constant must be determinable\r
+statically (at compilation time).\r
+ Program in LOGLAN-82 may be a block or alternatively may be of the\r
+following form:\r
+ \r
+ program name; \r
+ lists of declarations\r
+ begin \r
+ sequence of statements\r
+ end \r
+ \r
+Then the whole program can be identified by that name (the source as\r
+well as the object code).\r
+\r
+ A block can appear in the sequence of statements (of any unit), thus\r
+it is a statement. (Main block is assumed to appear as a statement of\r
+the given job control language.)\r
+ For the execution of a block statement the object of block is\r
+created in a computer memory, and then, the sequence of statements is\r
+performed. The syntactic entities declared in the block are allocated\r
+in its object. After a block's termination its object is automatically\r
+deallocated (and the corresponding space may be immediately reused).\r
+ The modular structure of the language works "in full steam" when not\r
+only blocks, but the other kinds of units are also used. They will be\r
+described closer in the following points.\r
+ Unit nesting allows to build up hierarchies of units and supports\r
+security of programming. It follows from the general visibility rules;\r
+namely, a syntactic entity declared in an outer unit is visible in an\r
+inner one (unless hidden by an inner declaration). On the other hand,\r
+a syntactic entity declared in an inner unit is not visible from an\r
+outer one.\r
+ \r
+Example:\r
+--------\r
+ \r
+ program test; \r
+ var a,b,c:real, i,j,k:integer; \r
+ begin \r
+ read(a,b,c,i);\r
+ block \r
+ var j,k:real; \r
+ begin \r
+ j:=a; k:=j+b; write(" this is the inner block ",j,k)\r
+ end; \r
+ write(" this is the outer block ",i,a:20)\r
+ end; \r
+ \r
+ In this program, first the main block statement is executed (with\r
+variables a,b,c,i,j,k). Next, after the read statement, the inner\r
+block statement is executed (with variables j,k). In the inner block\r
+the global variables j,k are hidden by the local ones.\r
+ \r
+\r
+3. Procedures and functions\r
+###########################\r
+ \r
+ Procedures and functions are well-known kinds of units. Their syntax\r
+is modelled on Pascal's, though with some slight modifications.\r
+Procedure (function) declaration consists of a specification part and\r
+a body.\r
+ \r
+ Example:\r
+ --------\r
+ unit Euclid: function(i,j:integer):integer; \r
+ var k:integer;\r
+ begin \r
+ do \r
+ if j=0 then exit fi; \r
+ k:=i mod j; i:=j; j:=k \r
+ od; \r
+ result:=i\r
+ end; \r
+ \r
+ Procedure or function specification begins with its identifier\r
+preceded by the keyword unit. (The same syntax concerns any other module \r
+named unit.) Then follows its kind declaration, its formal parameters\r
+(if any), and the type of the returned value (only for functions). A\r
+body consists of declaration lists for local entities and a sequence\r
+of statements. The keyword begin commences the sequence of statements \r
+, and is omitted , if this sequence is empty. The value returned by a\r
+function equals to the most recent value of the standard variable\r
+"result", implicitly declared in any function. This variable can be\r
+used as a local auxiliary variable as well.\r
+ \r
+ Example:\r
+ --------\r
+ unit Newton: function(n,m:integer):integer; \r
+ var i:integer; \r
+ begin \r
+ if m > n then return fi; \r
+ result:=n;\r
+ for i:=2 to m do result:=result*(n-i+1) div i od \r
+ end Newton;\r
+ The optional identifier at the end of a unit must repeat the\r
+identifier of a unit. It is suggested that the compilers check the\r
+order of unit nesting, so these optional occurrences of identifiers\r
+would facilitate program debugging.\r
+ All the local variables of a unit are initialized (real with 0.0,\r
+integer with 0, boolean with false etc.). Thus , for instance, the\r
+value of function Newton is 0 for m>n, since "result" is also\r
+initialized, as any other local variable.\r
+ \r
+ The return statement (return) completes the execution of a procedure \r
+(function) body,i.e. return is made to the caller. If return does not \r
+appear explicitly, return is made with the execution of the final end \r
+of a unit. Upon return to the caller the procedure (function) object\r
+is deallocated.\r
+ Functions are invoked in expressions with the corresponding list of\r
+actual parameters. Procedures are invoked by call statement (also with\r
+the corresponding list of actual parameters).\r
+\r
+ Example:\r
+ --------\r
+ i:=i*Euclid(k,105)-Newton(n,m+1);\r
+ call P(x,y+3); \r
+ \r
+ Formal parameters are of four categories: variable parameters,\r
+procedure parameters, function parameters and type parameters (cf\r
+p.8). Variable parameters are considered local variables to the unit.\r
+A variable parameter has one of three transmission modes: input,\r
+output or inout. If no mode is explicitly given the input mode is\r
+assumed. For instance in the unit declaration:\r
+ \r
+ unit P: procedure(x,y:real,b:boolean;output c:char,i:integer;inout j:integer);\r
+ \r
+x,y,b are input parameters , c,i are output parameters , and j is\r
+inout parameter.\r
+ \r
+ Input parameter acts as a local variable whose value is initialized\r
+by the value of the corresponding actual parameter. Output parameter\r
+acts as a local variable initialized in the standard manner (real with\r
+0.0, integer with 0, boolean with false etc.). Upon return its value\r
+is assigned to the corresponding actual parameter, in which case it\r
+must be a variable. However the address of such an actual parameter is\r
+determined upon entry to the body. Inout parameter acts as an input\r
+parameter and output parameter together.\r
+ \r
+ Example:\r
+ --------\r
+ unit squareeq: procedure(a,b,c:real;output xr,xi,yr,yi:real); \r
+ (* given a,b,c the procedure solves square equation : ax*x+bx+c=0.\r
+ xr,xi- real and imaginary part of the first root\r
+ yr,yi- real and imaginary part of the second root *)\r
+ var delta: real; \r
+ begin (*a=/=0*) \r
+ a:=2*a; c:=2*c; delta:=b*b-a*c;\r
+ if delta <= 0 \r
+ then \r
+ xr,yr:=-b/a;\r
+ if delta=0 then return fi; (*xi=yi=0 by default*) \r
+ delta:=sqrt(-delta);\r
+ xi:=delta/a; yi:=-xi;\r
+ return \r
+ fi; \r
+ delta:=sqrt(delta);\r
+ if b=0 \r
+ then \r
+ xr:=delta/a; yr:=-xr;\r
+ return \r
+ fi; \r
+ if b>0 then b:=b+delta else b:=b-delta fi;\r
+ xr:=-b/a; yr:=-c/b;\r
+ end squareeq;\r
+\r
+ A procedure call to the above unit may be the following:\r
+ \r
+ call squareeq(3.75*H,b+7,3.14,g,gi,h,hi); \r
+where g,h,gi,hi are real variables.\r
+ \r
+ \r
+ No restriction is imposed on the order of declarations. In\r
+particular, recursive procedures and functions can be declared without\r
+additional announcements (in contrast to Pascal).\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ For two recursive sequences defined as:\r
+ \r
+ a(n)=b(n-1)+n+2 n>0\r
+ b(n)=a(n-1)+(n-1)*n n>0\r
+ a(0)=b(0)=0\r
+ \r
+one can declare two functions:\r
+ \r
+ unit a: function(n:integer):integer;\r
+ begin \r
+ if n>0 then result:=b(n-1)+n+2 fi\r
+ end a; \r
+ unit b: function(n:integer):integer; \r
+ begin \r
+ if n>0 then result:=a(n-1)+(n-1)*n fi \r
+ end b; \r
+ \r
+and invoke them:\r
+ \r
+ k:=a(100)*b(50)+a(15);\r
+ \r
+ Functions and procedures can be formal parameters as well.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+unit Bisec: procedure(a,b,eps:real;output x:real;function f(x:real):real);\r
+(*this procedures searches for zero of continous function f in segment (a,b) *)\r
+var h:real,s:integer;\r
+begin\r
+ s:=sign(f(a));\r
+ if sign(f(b))=s then return fi; (* wrong segment *) \r
+ h:=b-a;\r
+ do \r
+ h:=h/2; x:=a+h;\r
+ if h < eps then return fi;\r
+ if sign(f(x))=s then a:=x else b:=x fi\r
+ od \r
+end Bisec;\r
+\r
+ In the above declaration, after the input variable parameters\r
+a,b,eps and the output variable parameter x, a function parameter f\r
+appears. Note that its specification part is complete. Thus the check\r
+of actual-formal parameter compatibility is possible at compilation\r
+time. Making use of this syntactic facility is not possible in\r
+general, if a formal procedure (function) is again a formal parameter\r
+of a formal procedure (function). The second degree of formal\r
+procedures (functions) nesting is rather scarce, but LOGLAN-82 admits\r
+such a construct. Then formal procedure (function) has no\r
+specification part and the full check of actual-formal parameter\r
+compatibility is left to be done at run time.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit P: procedure(j:integer;procedure G(i:integer;procedure H));\r
+ ...\r
+ begin \r
+ ...\r
+ call G(j,P);\r
+ end P; \r
+ \r
+ Procedure G is a first degree parameter, therefore it occurs with\r
+complete specification part. Procedure H is a second degree parameter\r
+and has no specification part. In this case a procedure call can be\r
+strongly recursive:\r
+ \r
+ call P(i+10,P); \r
+\r
+4. Classes\r
+##########\r
+ \r
+ Class is a facility which covers such programming constructs as\r
+structured type, package, access type, data structure etc. To begin\r
+with the presentation of this construct, let us consider a structured\r
+type assembled from primitive ones:\r
+ \r
+ unit bill: class;\r
+ var dollars :real, \r
+ not_paid :boolean,\r
+ year,month,day :integer;\r
+ end bill; \r
+ \r
+ The above class declaration has the attributes : dollars (real),\r
+not_paid (boolean), and year,month,day (integer). Wherever class bill\r
+is visibile one can declare variables of type bill:\r
+ \r
+ var x,y,z:bill;\r
+ \r
+ The values of variables x, y, z can be the addresses of objects of\r
+class bill. These variables are called reference variables. With\r
+reference variable one can create and operate the objects of reference\r
+variable type.\r
+ \r
+ An object of a class is created by the class generation statement\r
+(new), and thereafter, its attributes are accessed through dot \r
+notation.\r
+ \r
+ x:=new bill; (* a new object of class bill is created *) \r
+ x.dollars:=500.5; (* define amount *)\r
+ x.year:=1982; (* define year *)\r
+ x.month:=3; (* define month *)\r
+ x.day:=8; (* define day *)\r
+ y:=new bill; (* create a new object *) \r
+ y.not_paid:=true; (* bill not_paid *)\r
+ z:=y; (* variable z points the same object as variable y *)\r
+ \r
+ If an object of class bill has been created (new bill) and its \r
+address has been assigned to variable x (x:=new bill), then the \r
+attributes of that object are accessible through dot notation (remote\r
+access). The expression x.dollars gives , for instance, the remote\r
+access to attribute dollars of the object referenced by x.\r
+ All attributes of class objects are initialized as usual. For the\r
+above example the object referenced by x, after the execution of the\r
+specified sequence of statements, has the following structure:\r
+ \r
+ ---------------\r
+ | 500.5 | dollars\r
+ ---------------\r
+ | false | not_paid\r
+ ---------------\r
+ | 1982 | year\r
+ ---------------\r
+ | 3 | month\r
+ ---------------\r
+ | 8 | day\r
+ ---------------\r
+ \r
+ The object referenced by y and z has the following structure:\r
+ \r
+ ---------------\r
+ | 0 | dollars\r
+ ---------------\r
+ | true | not_paid\r
+ ---------------\r
+ | 0 | year\r
+ ---------------\r
+ | 0 | month\r
+ ---------------\r
+ | 0 | day\r
+ ---------------\r
+ \r
+ The value none is the default initial value of any reference \r
+variable and denotes no object. A remote access to an attribute of\r
+none raises a run time error. \r
+ Class may have also formal parameters (as procedures and functions).\r
+Kinds and transmission modes of formal parameters are the same as in\r
+the case of procedures.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit node: class (a:integer);\r
+ var left,right:node; \r
+ end node; \r
+ \r
+ Let , for instance, variables z1, z2, z3 be of type node. Then the\r
+sequence of statements:\r
+ \r
+ z1:=new node(5);\r
+ z2:=new node(3); \r
+ z3:=new node(7); \r
+ z1.left:=z2; z1.right:=z3;\r
+ \r
+ creates the structure:\r
+ \r
+ -----------\r
+ z1----> | 5 |\r
+ -----------\r
+ <---- | left |\r
+ | -----------\r
+ | | right | ------->\r
+ | ----------- |\r
+ | |\r
+ ------------ ------------\r
+z2---->| 3 | | 7 | <----z3\r
+ ------------ ------------\r
+ | none | | none | \r
+ ------------ ------------\r
+ | none | | none | \r
+ ------------ ------------\r
+\r
+ \r
+where arrows denote the values of the reference variables.\r
+ \r
+ Class may also have a sequence of statements (as any other unit).\r
+That sequence can initialize the attributes of the class objects.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit complex:class(re,im:real); \r
+ var module:real; \r
+ begin \r
+ module:=sqrt(re*re+im*im)\r
+ end complex; \r
+ \r
+ Attribute module is evaluated for any object generation of class\r
+complex:\r
+ \r
+ z1:=new complex(0,1); (* z1.module equals 1 *) \r
+ z2:=new complex(2,0); (* z2.module equals 2 *) \r
+ \r
+ For the execution of a class generator, first a class object is\r
+created, then the input parameters are transmitted , and finally, the\r
+sequence of statements (if any) is performed. Return is made with the\r
+execution of return statement or the final end of a unit. Upon return\r
+the output parameters are transmitted.\r
+ Procedure object is automatically deallocated when return is made to\r
+the caller. Class object is not deallocated , its address can be\r
+assigned to a reference variable, and its attributes can be thereafter\r
+accessed via this variable.\r
+ \r
+ The classes presented so far had only variable attributes. In\r
+general, class attributes may be also other syntactic entities, such\r
+as constants, procedures, functions, classes etc. Classes with\r
+procedure and function attributes provide a good facility to define\r
+data structures.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ A push_down memory of integers may be implemented in the following\r
+way:\r
+ \r
+ unit push_down :class; \r
+ unit elem:class(value:integer,next:elem);\r
+ (* elem - stack element *)\r
+ end elem; \r
+ var top:elem; \r
+ unit pop: function :integer; \r
+ begin \r
+ if top=/= none \r
+ then \r
+ result:=top.value; top:=top.next\r
+ fi; \r
+ end pop; \r
+ unit push:procedure(x:integer); (* x - pushed integer *) \r
+\r
+ begin \r
+ top:=new elem(x,top);\r
+ end push; \r
+ end push_down;\r
+\r
+ Assume that somewhere in a program reference variables of type\r
+push_down are declared (of course, in place where push_down is\r
+visibile):\r
+ \r
+ var s,t,z:push_down; \r
+ \r
+ Three different push_down memories may be now generated:\r
+ \r
+ s:=new push_down(100); t:=new push_down(911); z:=new push_down(5); \r
+ \r
+ One can use these push_down memories as follows:\r
+ \r
+ call s.push(7); (* push 7 to s *) \r
+ call t.push(1); (* push 1 to t *) \r
+ i:=z.pop; (* pop an element from z *)\r
+ etc.\r
+\r
+5. Adjustable arrays\r
+####################\r
+ \r
+ In LOGLAN-82 arrays are adjustable at run time. They may be treated\r
+as objects of specified standard type with index instead of identifier\r
+selecting an attribute. An adjustable array should be declare\r
+somewhere among the lists of declarations and then may be generated in\r
+the sequence of statements.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ block \r
+ var n,j:integer; \r
+ var A:arrayof integer; (* here is the declaration of A *) \r
+ begin \r
+ read(n);\r
+ new_array A dim (1:n); (* here is the generation of A *) \r
+ for i:=1 to n \r
+ do \r
+ read(A(i));\r
+ od; \r
+ (* etc.*)\r
+ end \r
+ \r
+ A variable A is an array variable. Its value should be the reference\r
+to an integer array, i.e. a composite object consisting of integer\r
+components each one defined by an integer index. Array generation\r
+statement:\r
+ \r
+ new_array A dim (1:n); \r
+ \r
+allocates a one-dimensional integer array with the index bounds 1,n ,\r
+and assigns its address to variable A. The figure below illustrates\r
+this situation:\r
+ \r
+ ---------- -----------\r
+ | | | A(1) |\r
+ | | -----------\r
+ | ... | | A(2) |\r
+ ---------- -----------\r
+ | n | | |\r
+ ---------- ...\r
+ | j | | |\r
+ ---------- -----------\r
+ | A | ---------> | A(n) |\r
+ ---------- -----------\r
+ Block object Array object\r
+ \r
+ A general case of array generation statement has the form:\r
+ \r
+ new_array A dim (lower:upper) \r
+ \r
+where lower and upper are arithmetic expressions which define the\r
+range of the array index.\r
+\r
+ Example:\r
+ --------\r
+ \r
+ Two-dimensional array declaration :\r
+ \r
+ var A: arrayof arrayof integer; \r
+ \r
+and generation:\r
+ \r
+ new_array A dim (1:n) \r
+ for i:=1 to n do new_array A(i) dim (1:m) od; \r
+ \r
+create the structure:\r
+ \r
+ ----------\r
+ | A(1,1) |\r
+ ----------\r
+ | |\r
+ ...\r
+ | |\r
+ ------------ ----------\r
+ | A(1) | ---------> | A(1,m) |\r
+ ------------ ----------\r
+ | |\r
+ ...\r
+ | |\r
+ ------------ ----------\r
+ | A(n) | ---------> | A(n,1) |\r
+ ------------ ----------\r
+ | |\r
+ ...\r
+ | |\r
+ ----------\r
+ | A(n,m) |\r
+ ----------\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ block \r
+ var i,j:integer, A,B: arrayof arrayof real, n:integer; \r
+ begin \r
+ read(n);\r
+ new_array A dim (1:n); \r
+ for i:=1 to n do new_array A(i) dim (1:n) od; \r
+ (* A is square array *)\r
+ new_array B dim (1:n); \r
+ for i:=1 to n do new_array B(i) dim(1:i) od; \r
+ (* B is lower triangular array *)\r
+ A(n,n):=B(n,n);\r
+ B(1):=A(1);\r
+ B(1):=copy(A(1)); \r
+ end \r
+\r
+ Array A is the square array n by n. Each element A(i) , 1<=i<=n\r
+contains the address of row A(i,j), 1<=j<=n. Array B is the\r
+lower-triangular array. Each element B(i), 1<=i<=n, contains the\r
+address of row B(i,j), 1<=j<=i. Thus an assignment statement\r
+A(n,n):=B(n,n) transmits real value B(n,n) to real variable A(n,n).\r
+Assignment B(1):=A(1) transmits the address of the first row of A to\r
+variable B(1). Finally assignment B(1):=copy (A(1)) creates a copy of \r
+the first row of A and assigns its address to B(1).\r
+ \r
+ Upper and lower bounds of an adjustable array A are determined by\r
+standard operators lower(A) and upper(A).\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit sort: procedure(A:arrayof integer); (* insertion sort *) \r
+ var n,i,j:integer; var x:integer; \r
+ begin \r
+ n:=upper(A); (* assume lower bound is 1 *)\r
+ for i:=2 to n \r
+ do \r
+ x:=A(i); j:=i-1;\r
+ do \r
+ if x >= A(j) then exit fi; \r
+ A(j+1):=A(j); j:=j-1;\r
+ if j=0 then exit fi;\r
+ od; \r
+ A(j+1):=x\r
+ od; \r
+ end sort; \r
+ \r
+ If an array variable A refers to no array its value is equal none \r
+(the standard default value of any array variable). An attempt to\r
+access an array element (e.g. A(i)) or a bound (e.g. lower(A)), where\r
+A is none, raises a run time error. - 24 - \r
+\r
+\r
+6. Coroutines and semicoroutines\r
+################################\r
+ \r
+ Coroutine is a generalization of class. A coroutine object is an\r
+object such that the execution of its sequence of statements can be\r
+suspended and reactivated in a programmed manner. Consider first a\r
+simple class with a sequence of statements such that after return some \r
+non-executed statements remain. The generation of its object\r
+terminates with the execution of return statement, although the object\r
+can be later reactivated. If such a class is declared as a coroutine,\r
+then its objects may be reactivated. This can be realized by attach \r
+statement:\r
+ \r
+ attach(X) \r
+ \r
+where X is a reference variable designating the activating coroutine\r
+object.\r
+ In general, since the moment of generation a coroutine object is\r
+either active or suspended. Any reactivation of a suspended coroutine\r
+object X (by attach(X)) causes the active coroutine object to be \r
+suspended and continues the execution of X from the statement\r
+following the last executed one.\r
+ Main program is also a coroutine. It is accessed through the\r
+standard variable main and may be reactivated (if suspended) by the \r
+statement attach(main). \r
+ \r
+ Example:\r
+ --------\r
+ \r
+ In the example below the cooperation of two coroutines is presented.\r
+One reads the real values from an input device, another prints these\r
+values in columns on a line-printer, n numbers in a line. The input\r
+stream ends with 0.\r
+ \r
+program prodcons;\r
+ var prod:producer,cons:consumer,n:integer,mag:real,last:bool; \r
+ unit producer: coroutine; \r
+ begin \r
+ return; \r
+ do \r
+ read(mag); (* mag- nonlocal variable, common store *)\r
+ if mag=0 \r
+ then (* end of data *) \r
+ last:=true;\r
+ exit \r
+ fi; \r
+ attach(cons); \r
+ od; \r
+ attach(cons) \r
+ end producer; \r
+\r
+ unit consumer: coroutine(n:integer); \r
+ var Buf:arrayof real; \r
+ var i,j:integer; \r
+ begin \r
+ new_array Buf dim(1:n); \r
+ return; \r
+ do \r
+ for i:=1 to n \r
+ do \r
+ Buf(i):=mag;\r
+ attach(prod); \r
+ if last then exit exit fi; \r
+ od; \r
+ for i:=1 to n \r
+ do (* print Buf *) \r
+ write(' ',Buf(i):10:2)\r
+ od; \r
+ writeln;\r
+ od; \r
+ (* print the rest of Buf *)\r
+ for j:=1 to i do write(' ',Buf(j):10:2) od; \r
+ writeln;\r
+ attach(main); \r
+ end consumer; \r
+ \r
+ begin \r
+ prod:=new producer; \r
+ read(n);\r
+ cons:=new consumer(n); \r
+ attach(prod); \r
+ writeln;\r
+ end prodcons; \r
+ \r
+ The above task could be programmed without coroutines at all. The\r
+presented solution is, however, strictly modular, i.e. one unit\r
+realizes the input process, another realizes the output process, and\r
+both are ready to cooperate with each other.\r
+ \r
+ LOGLAN-82 provides also a facility for the semi-coroutine\r
+operations. This is gained by the simple statement detach. If X is the \r
+active coroutine object, then detach reactivates that coroutine object \r
+at where the last attach(X) was executed. This statement meets the \r
+need for the asymetric coroutine cooperations. (by so it is called\r
+semi-coroutine operation). Operation attach requires a reactivated \r
+coroutine to be defined explicitly by the user as an actual parameter.\r
+Operation detach corresponds in some manner to return in procedures.\r
+It gives the control back to a coroutine object where the last\r
+attach(X) was executed, and that coroutine object need not be known\r
+explicitly in X. This mechanism is, however, not so secure as the\r
+normal control transfers during procedure calls and returns.\r
+ \r
+ In fact, the user is able to loop two coroutines traces by :\r
+ \r
+ attach(Y) in X \r
+ attach(X) in Y \r
+\r
+\r
+Then detach in X reactivates Y, detach in Y reactivates X. \r
+ \r
+ In the example below the application of detach statement is\r
+illustrated.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ program reader_writers; \r
+ (* In this example a single input stream consisting of blocks of\r
+ numbers, each ending with 0, is printed on two printers of\r
+ different width. The choice of the printer is determined by the\r
+ block header which indicates the desired number of print\r
+ columns. The input stream ends with a double 0. m1 - the width\r
+ of printer_1, m2 - the width of printer_2 *)\r
+ const m1=10,m2=20; \r
+ var reader:reading,printer_1,printer_2:writing; \r
+ var n:integer,new_sequence:boolean,mag:real; \r
+ \r
+ unit writing:coroutine(n:integer); \r
+ var Buf: arrayof real, i,j:integer; \r
+ begin \r
+ new_array Buf dim (1:n); (* array generation *) \r
+ return; (* return terminates coroutine initialization *) \r
+ do \r
+ attach(reader); (* reactivates coroutine reader *) \r
+ if new_sequence \r
+ then (* a new sequence causes buffer Buf to be cleared up *) \r
+ for j:=1 to i do write(' ',Buf(j):10:2) od; writeln; \r
+ i:=0; new_sequence:=false; attach(main) \r
+ else \r
+ i:=i+1; Buf(i):=mag;\r
+ if i=n \r
+ then \r
+ for j:=1 to n do write(' ',Buf(j):10:2) od; writeln;\r
+ i:=0;\r
+ fi \r
+ fi \r
+ od \r
+ end writing; \r
+ \r
+ unit reading: coroutine; \r
+ begin \r
+ return; \r
+ do \r
+ read(mag);\r
+ if mag=0 then new_sequence:=true; fi; \r
+ detach; (* detach returns control to printer_1 or \r
+ od \r
+ end reading; \r
+ \r
+\r
+ begin \r
+ reader:=new reading; \r
+ printer_1:=new writing(m1); printer_2:=new writing(m2);\r
+ do \r
+ read(n);\r
+ case n \r
+ when 0: exit \r
+ when m1: attach(printer_1) \r
+ when m2: attach(printer_2) \r
+ otherwise write(" wrong data"); exit \r
+ esac \r
+ od \r
+ end; \r
+ \r
+ Coroutines play the substantial role in process simulation. Class\r
+Simulation provided in Simula-67 makes use of coroutines at most\r
+degree. LOGLAN-82 provides for easy simulation as well. The LOGLAN-82\r
+class Simulation is implemented on a heap what gives lg(n) time cost\r
+(in contrast with O(n) cost of the original implementation). It covers\r
+also various simulation problems of large size and degree of\r
+complexity.\r
+\r
+\r
+7. Prefixing\r
+############\r
+ \r
+ Classes and prefixing are ingenius inventions of Simula-67 (cf [1]).\r
+Unfortunately they are hardly ever known and, perhaps, by this have\r
+not been introduced into any other programming language. Moreover,\r
+implementation constraints of Simula-67 bind prefixing and classes\r
+workableness to such a degree that both facilities cannot be used in\r
+all respects. We hope that LOGLAN-82, adopting merits and rooting up\r
+deficiencies of these constructs, will smooth their variations and\r
+vivify theirs usefulness.\r
+ What is prefixing ? First of all it is a method for unit extending.\r
+Consider the simplest example:\r
+ \r
+ unit bill: class; \r
+ var dollars :real,\r
+ not_paid :boolean,\r
+ year,month,day :integer;\r
+ end bill; \r
+ \r
+Assume the user desires to extend this class with new attributes.\r
+Instead of writing a completely new class, he may enlarge the existing\r
+one:\r
+ \r
+ unit gas_bill:bill class; \r
+ var cube_meters: real; \r
+ end gas_bill; \r
+ \r
+ Class gas_bill is prefixed by class bill. This new declaration may\r
+appear anywhere within the scope of declaration of class bill. (In\r
+Simula-67 such a prefixing is forbidden in nested units.) Class\r
+gas_bill has all the attributes of class bill and additionally its own\r
+attributes (in this case the only one: cube_meters). The generation\r
+statement of this class has the form:\r
+ \r
+ z:=new gas_bill; \r
+where z is a reference variable of type gas_bill. Remote access to the\r
+attributes of prefixed class is standard:\r
+ \r
+ z.dollars:=500.5; z.year:=1982; z.month:=3; z.day:=8;\r
+ z.cube_meters:=100000;\r
+ \r
+ Consider now the example of a class with parameters.\r
+ \r
+ Assume that in a program a class:\r
+ \r
+ unit id_card: class(name:string,age:integer); \r
+ end id_card; \r
+ \r
+and its extension:\r
+ \r
+ unit idf_card:id card class(first name:string); \r
+ end idf_card; \r
+ \r
+\r
+\r
+are declared.\r
+\r
+\r
+ Then for variable z of type id_card and variable t of type idf_card\r
+the corresponding generation statement may be the following:\r
+ \r
+ z:=new id_card("kreczmar",37); \r
+ t:=new idf_card("Kreczmar",37,"Qntoni"); \r
+ \r
+Thus the formal parameters of a class are concatenated with the formal\r
+parameters of its prefix.\r
+ One can still extend class idf_card. For instance:\r
+ \r
+ unit idr_card:idf_card class; \r
+ var children_number:integer; \r
+ var birth_place:string; \r
+ end idr_card; \r
+ \r
+ Prefixing allows to build up hierarchies of classes. Each one\r
+hierarchy has a tree structure. A root of such a tree is a class\r
+without prefix. One class is a successor of another class iff the\r
+first is prefixed by the latter one.\r
+ \r
+ Consider the prefix structure:\r
+ \r
+ A\r
+ . . .\r
+ . . .\r
+ . . .\r
+ B. .C .D\r
+ .\r
+ .\r
+ .E\r
+ .\r
+ .\r
+ .F\r
+ . .\r
+ . .\r
+ G. .H\r
+ \r
+ Class H has a prefix sequence A, B, E, F, H. Let a, b, ... , h\r
+denote the corresponding unique attributes of classes A, B, ... , H,\r
+respectively. The objects of these classes have the following forms:\r
+ \r
+ ------------ ------------ ------------ ------------\r
+ | a | | a | | a | | a |\r
+ ------------ ------------ ------------ ------------\r
+ object A | b | | c | | d |\r
+ ------------ ------------ ------------\r
+ object B object C object D\r
+\r
+\r
+\r
+ ------------ ------------ ------------ ------------\r
+ | a | | a | | a | | a |\r
+ ------------ ------------ ------------ ------------\r
+ | b | | b | | b | | b |\r
+ ------------ ------------ ------------ ------------\r
+ | e | | e | | e | | e |\r
+ ------------ ------------ ------------ ------------\r
+ object E | f | | f | | f |\r
+ ------------ ------------ ------------\r
+ object F | g | | h |\r
+ ------------ ------------\r
+ object G object H\r
+ \r
+ Let Ra, Rb,..., Rh denote reference variables of types A, B,..., H,\r
+respectively. Then the following expressions are correct:\r
+ \r
+ Ra.a, Rb.b, Rb.a, Rg.g, Rg.f, Rh.h, Rh.f, Rh.e, Rh.b, Rh.a etc.\r
+ \r
+ Variable Ra may designate the object of class B (or C,..., H), i.e.\r
+the statement:\r
+ \r
+ Ra:=new B \r
+ \r
+is legal. But then attribute b is not accessible through dot via Ra,\r
+i.e. Ra.b is incorrect. This follows from insecurity of such a remote\r
+access. In fact, variable Ra may point any object of a class prefixed\r
+by A, in particular, Ra may point the object of A itself, which has no\r
+attribute b. If Ra.b had been correct, a compiler should have\r
+distiguish the cases Ra points to the object of A or not. But this, of\r
+course, is undistinguishable at compilation time.\r
+ To allow, however, the user's access to attribute b (after instruc tion Ra:= n\r
+ \r
+ Ra qua B \r
+\r
+ The correctness of this expression is checked at run time. If Ra\r
+designates an object of B or prefixed ba B, the type of the expression\r
+is B. Otherwise the expression is erroneous. Thus, for instance, the\r
+expressions:\r
+ \r
+ Ra qua G.b, Ra qua G.e etc. \r
+enable remote access to the attributes b, c, ... via Ra.\r
+ \r
+ So far the question of attribute concatenation was merely discussed.\r
+However the sequences of statements can be also concatenated.\r
+ Consider class B prefixed with class A. In the sequence of\r
+statements of class A the keyword inner may occur anywhere, but only\r
+once. The sequence of statements of class B consists of the sequence\r
+of statements of class A with inner replaced by the sequence of \r
+statements of class B.\r
+ \r
+ unit A :class unit B:A class \r
+ ... ...\r
+ begin begin \r
+ ... |---...\r
+ | \r
+ |\r
+ ... |---...\r
+ end A; end B; \r
+\r
+\r
+ In this case inner in class B is equivalent to the empty statement. \r
+If class B prefixes another class, say C, then inner in B is replaced \r
+by the sequence of statements of class C, and so on.\r
+ If inner does not occur explicitly, an implicit occurrence of inner \r
+before the final end of a class is assumed. \r
+ \r
+ Example\r
+ -------\r
+ \r
+ Let class complex be declared as usual:\r
+ \r
+ unit complex: class(re,im:real); \r
+ end complex; \r
+ \r
+and assume one desires to declare a class mcomplex with the additional\r
+attribute module. In order the generation of class mcomplex define the\r
+value of attribute module, one can declare a class:\r
+ \r
+ unit mcomplex:complex class; \r
+ var module:real; \r
+ begin \r
+ module:=sqrt(re*re+im*im)\r
+ end mcomplex; \r
+ \r
+ Class mcomplex may be still extended:\r
+ \r
+ unit pcomplex:mcomplex class; \r
+ var alfa:real; \r
+ begin \r
+ alfa:=arccos(re/module)\r
+ end pcomplex; \r
+ \r
+ For these declarations each generation of class mcomplex defines the\r
+value of attribute module, each generation of class pcomplex defines\r
+the values of attributes module and alfa.\r
+ For reference variables z1, z2 z3 of type complex, the following\r
+sequence of statements illustrates the presented constructs:\r
+ \r
+ z1:=new complex(0,1); \r
+ z2:=new mcomplex(4,7); \r
+ z3:=new pcomplex(-10,12); \r
+ if z2 qua mcomplex.module > 1 \r
+ then \r
+ z1:=z2;\r
+ fi; \r
+ if z3 qua pcomplex.alfa < 3.14 \r
+ then \r
+ z3.re:=-z3.re; z3.alfa:=z3.alfa+3.14;\r
+ fi; \r
+ z1 qua mcomplex.module:= 0; \r
+ z1.re,z1.im:=0; \r
+\r
+\r
+ Example:\r
+ --------\r
+ Binary search tree (Bst) is a binary tree where for each node x the\r
+nodes in the left subtree are less than x, the nodes in the right\r
+subtree are greater than x. It is the well-known exercise to program\r
+the algorithms for the following operations on Bst:\r
+ member(x) = true iff x belongs to Bst\r
+ insert(x), enlarge Bst with x, if x does not yet belong to Bst\r
+ \r
+ We define both these operations in a class:\r
+ \r
+ unit Bst: class; \r
+ unit node: class(value:integer); (* tree node *) \r
+ var left,right:node; \r
+ end node; \r
+ var root:node; \r
+ unit help: class(x:integer); (* auxiliary class *) \r
+ var p,q:node; \r
+ begin \r
+ q:=root;\r
+ while q=/= none \r
+ do \r
+ if x < q.value \r
+ then \r
+ p:=q; q:=q.left;\r
+ repeat (* jump to the beginning of a loop *) \r
+ fi; \r
+ if q.value < x \r
+ then \r
+ p:=q; q:=q.right; repeat \r
+ fi; \r
+ exit \r
+ od; \r
+ inner (* virtual instruction to be \r
+ end help; \r
+ unit member:help function:boolean; \r
+ (* x is a formal parameter derived from the prefix help *)\r
+ begin \r
+ result:=q=/=none \r
+ end member; \r
+ unit insert:help procedure; \r
+ (* x is a formal parameter derived from the prefix help *)\r
+ begin \r
+ if q=/=none then return fi; \r
+ q:=new node(x); \r
+ if p=none then root:=q; return fi; \r
+ if p.value < x then p.right:=q else p.left:=q fi; \r
+ end insert; \r
+ begin \r
+ inner; \r
+ end Bst; \r
+ \r
+ In the example the common actions of member and insert are\r
+programmed in class help. Then it suffices to use class help as a\r
+prefix of function member and procedure insert, instead of redundant\r
+occurrences of the corresponding sequence of statements in both units. \r
+\r
+\r
+ Class Bst may be applied as follows:\r
+ \r
+ var X,Y:Bst; \r
+ begin \r
+ X:=new Bst; Y:=new Bst; \r
+ call X.insert(5); \r
+ if Y.member(-17) then .... \r
+ end \r
+ \r
+ As shown in the declaration of Bst, class may prefix not only other\r
+classes but also procedures and functions. Class may prefix blocks as\r
+well.\r
+ \r
+ Example:\r
+ --------\r
+ Let class push_down (p. 5) prefix a block:\r
+ \r
+ pref push_down(1000) block \r
+ var ... \r
+ begin \r
+ ...\r
+ call push(50); ... \r
+ i:=pop;\r
+ ...\r
+ end \r
+ \r
+ In the above block prefixed with class push_down one can use pop and\r
+push as local attributes. (They are local since the block is embedded\r
+in the prefix push down.)\r
+ \r
+ Example:\r
+ --------\r
+ pref push down(1000) block \r
+ begin \r
+ ...\r
+ pref Bst block \r
+ begin \r
+ (* in this block both structures push down and Bst are visible *)\r
+ call push(50); \r
+ call insert(13); \r
+ if member(10) then ... \r
+ i:=pop;\r
+ ...\r
+ end \r
+ end \r
+ \r
+ In place where classes push_down and Bst are visible together a\r
+block prefixed with Bst may be nested in a block prefixed with\r
+push_down (or vice versa). In the inner block both data structures are\r
+directly accessible. Note that this construct is illegal in Simula 67. \r
+\r
+\r
+8. Formal types\r
+###############\r
+ \r
+ Formal types serve for unit parametrization with respect to any\r
+non-primitive type.\r
+ \r
+ Example:\r
+ --------\r
+ \r
+ unit Gsort:procedure(type T; A:arrayof T; function less(x,y:T):boolean); \r
+ var n,i,j:integer; var x:T; \r
+ begin \r
+ n:=upper(A);\r
+ for i:=2 to n \r
+ do \r
+ x:=A(i); j:=i-1;\r
+ do \r
+ if less(A(j),x) then exit fi; exit fi \r
+ A(j+1):=A(j); j:=j-1;\r
+ if j=0 then exit fi;\r
+ od; \r
+ A(j+1):=x;\r
+ od \r
+ end Gsort; \r
+ \r
+ Procedure Gsort (the generalization of procedure sort from p.4) has\r
+type parameter T. A corresponding actual parameter may be an arbitrary\r
+non-primitive type. An actual parameter corresponding to A should be\r
+an array of elements of the actual type T. Function less should define\r
+the linear ordering on the domain T.\r
+ For instance, the array A of type bill (cf p.7) may be sorted with\r
+respect to attribute dollars , if the function:\r
+ \r
+ unit less: function(t,u:bill):boolean; \r
+ begin \r
+ result:=t.dollars <= u.dollars\r
+ end less; \r
+ \r
+is used as an actual parameter:\r
+ \r
+ call Gsort(bill,A,less); \r
+ \r
+ If the user desires to sort A with respect to date, it is sufficient\r
+to declare :\r
+ \r
+ unit earlier:function(t,u:bill):boolean; \r
+ begin \r
+ if t.year < u.year then result:= true; return fi; \r
+ if t.year=u.year \r
+ then \r
+ if t.month < u.month then result:=true; return fi; \r
+ if t.month=u.month then result:=t.day<=u.day fi \r
+ fi; \r
+ end earlier; \r
+ \r
+and to call: call Gsort(bill,A,earlier); \r
+\r
+\r
+9. Protection techniques\r
+########################\r
+ \r
+ Protection techniques ease secure programming. If a program is\r
+large, uses some system classes, is designed by a team etc., this is\r
+important (and non-trivial) to impose some restrictions on access to\r
+non-local attributes.\r
+ Let us consider a data structure declared as a class. Some of its\r
+attributes should be accessible for the class users , the others\r
+should not. For instance, in class Bst (p.7) the attributes member and\r
+insert are to be accessible. On the other hand the attributes root,\r
+node and help should not be accessible, even for a meddlesome user. An\r
+improper use of them may jeopardize the data structure invariants.\r
+ To forbid the access to some class attributes the three following\r
+protection mechanisms are provided:\r
+ \r
+ close, hidden, and taken. \r
+ \r
+ The protection close defined in a class forbids remote access to the \r
+specified attributes. For example, consider the class declaration:\r
+ \r
+ unit A: class; \r
+ close x,y,z; \r
+ var x: integer, y,z:real; \r
+ ....\r
+ end \r
+ \r
+ Remote access to the attributes x,y,z from outside of A is\r
+forbidden.\r
+ \r
+ The protection hidden (with akin syntax) does not allow to use the \r
+specified attributes form outside of A neither by the remote access\r
+nor in the units prefixed by A. The only way to use a hidden attribute\r
+is to use it within the body of class A.\r
+ Protection taken defines these attributes derived from prefix, which \r
+the user wishes to use in the prefixed unit. Consider a unit B\r
+prefixed by a class A. In unit B one may specify the attributes of A\r
+which are used in B. This protects the user against an unconscious use\r
+of an attribute of class A in unit B (because of identifier conflict).\r
+When taken list does not occur , then by default, all non-hidden\r
+attributes of class A are accessible in unit B. \r
+\r
+\r
+10. Programmed deallocation\r
+###########################\r
+ \r
+ The classical methods implemented to deallocate class objects are\r
+based on reference counters or garbage collection. Sometimes the both\r
+methods may be combined. A reference counter is a system attribute\r
+holding the number of references pointing to the given object. Hence\r
+any change of the value of a reference variable X is followed by a\r
+corresponding increase or decrease of the value of its reference\r
+counter. When the reference counter becomes equals 0, the object can\r
+be deallocated.\r
+ The deallocation of class objects may also occur during the process\r
+of garbage collection. During this process all unreferenced objects\r
+are found and removed (while memory may be compactified). In order to\r
+keep the garbage collector able to collect all the garbage, the user\r
+should clear all reference variables , i.e. set to None, whenever\r
+possible. This system has many disadvantages. First of all, the\r
+programmer is forced to clear all reference variables, even those\r
+which are of auxiliary character. Moreover, garbage collector is a\r
+very expensive mechanism and thus it can be used only in emergency\r
+cases.\r
+ In LOGLAN a dual operation to the object generator, the so-called\r
+object deallocator is provided. Its syntactic form is as follows:\r
+ \r
+ kill(X) \r
+ \r
+where X is a reference expression. If the value of X points to no\r
+object (none) then kill(X) is equivalent to an empty statement. If the \r
+value of X points to an object O, then after the execution of kill(X), \r
+the object O is deallocated. Moreover all reference variables which\r
+pointed to O are set to none. This deallocator provides full security, \r
+i.e. the attempt to access the deallocated object O is checked and\r
+results in a run-time error.\r
+ For example:\r
+ \r
+ Y:=X; kill(X); Y.W:=Z; \r
+ \r
+causes the same run-time error as:\r
+ \r
+ X:=none; X.W:=Z; \r
+ \r
+ The system of storage management is arranged in such a way that the\r
+frames of killed objects may be immediately reused without the\r
+necessity of calling the garbage collector, i.e. the relocation is\r
+performed automatically. There is nothing for it but to remember not\r
+to use remote access to a killed object. (Note that the same problem\r
+appears when remote access X.W is used and X=none). \r
+\r
+ Example:\r
+ --------\r
+ \r
+ Below a practical example of the programmed deallocation is\r
+presented. Consider class Bst (p.7). Let us define a procedure that\r
+deallocates the whole tree and is called with the termination of the\r
+class Bst.\r
+ \r
+ unit Bst:class; \r
+ (* standard declarations list of Bst *)\r
+ unit kill_all:procedure(p:node); \r
+ (* procedure kill_all deallocates a tree with root p *)\r
+ begin \r
+ if p= none then return fi; \r
+ call kill_all(p.left); \r
+ call kill_all(p.right); \r
+ kill(p) \r
+ end kill_all; \r
+ begin \r
+ inner; \r
+ call kill_all(root) \r
+ end Bst; \r
+ \r
+ Bst may be applied as a prefix:\r
+ \r
+ pref Bst block \r
+ ...\r
+ end \r
+ \r
+and automatically will cause the deallocation of the whole tree after\r
+return to call kill_all(root) from the prefixed block. \r
+ \r
+ To use properly this structure by remote accessing one must call\r
+kill_all by himself:\r
+ \r
+ unit var X,Y:Bst; \r
+ ...\r
+ begin \r
+ X:=new Bst; Y:=new Bst; \r
+ ...\r
+ (* after the structures' application *)\r
+ call X.kill_all(X.root); \r
+ kill(X); \r
+ call Y.kill_all(Y.root); \r
+ kill(Y); \r
+ ...\r
+ end \r
+ \r
+ Finally note that deallocator kill enables deallocation of array \r
+objects, and suspended coroutines and processes as well (cf p.13). \r
+\r
+\r
+11. Exception handling\r
+#######################\r
+ \r
+ Exceptions are events that cause interruption of normal program\r
+execution. One kind of exceptions are those which are raised as a\r
+result of some run time errors. For instance, when an attempt is made\r
+to access a killed object, when the result of numeric operation does\r
+not lie within the range, when the dynamic storage allocated to a\r
+program is exceeded etc.\r
+ Another kind of exceptions are those which are raised explicitly by\r
+a user (with the execution of the raise statement).\r
+ The response to exceptions (one or more) is defined by an exception\r
+handler. A handler may appear at the end of declarations of any unit.\r
+The corresponding actions are defined as sequences of statements\r
+preceded by keyword when and an exception identifier. \r
+ \r
+ Example:\r
+ --------\r
+ \r
+ In procedure squareeq (p.3) we wish to include the case when a=0. It\r
+may be treated as an exception (division by zero).\r
+ \r
+ unit squareeq(a,b,c:real;output xr,xi,yr,yi:real); \r
+ var delta:real; \r
+ handlers \r
+ when division_by_zero: \r
+ if b =/= 0 \r
+ then \r
+ xi,yr,yi:=0; xr:=-c/b; terminate \r
+ else \r
+ raise Wrong_data(" no roots") \r
+ fi; \r
+ end \r
+ begin \r
+ ...\r
+ end squareeq; \r
+ \r
+ The handler declared in that procedure handles the only one\r
+exception (division_by_zero).\r
+ When an exception is raised, the corresponding handler is searched\r
+for, starting from the active object and going through return traces.\r
+If there is no object containing the declaration of the handler, then\r
+the program (or the corresponding process) is terminated. Otherwise\r
+the control is transferred to the first found handler. \r
+\r
+\r
+\r
+ In our example the handler is declared within the unit itself, so\r
+control is passed to a sequence:\r
+ \r
+ if b=/=0 \r
+ ...\r
+ \r
+ Therefore, when b=/=0, the unique root of square equation will be\r
+determined and the procedure will be normally terminated (terminate). \r
+ In general, terminate causes that all the objects are terminated, \r
+starting from that one where the exception was raised and ending on\r
+that one where the handler was found. Then the computation is\r
+continued in a normal way.\r
+ In our example, when b=0, a new exception is raised by the user. For\r
+this kind of exceptions , the exception itself should be declared\r
+(because it is not predefined as a run time error). Its declaration\r
+may have parameters which are transmitted to a handler. The exception\r
+declaration need not be visible by the exception handler. However the\r
+way the handler is searched for does not differ from the standard one.\r
+ Consider an example:\r
+ \r
+ block\r
+ signal Wrong_data(t:string); \r
+ unit squareeq: \r
+ ...\r
+ end squareeq;\r
+ ...\r
+ begin \r
+ ...\r
+ end \r
+ \r
+ Exception Wrong_data may be raised wherever its declaration (signal \r
+Wrong_data) is visible. When its handler is found the specified\r
+sequence of actions is performed. In the example above different\r
+handlers may be defined in inner units to the main block where\r
+squereeq is called.\r
+ The case a=0 could be included , of course, in a normal way, i.e. by\r
+a corresponding conditional statement occurring in the procedure body.\r
+But the case a=0 was assumed to be exceptional (happens scarcely).\r
+Thus the evaluation of condition a=0 would be mostly unnecessary. As\r
+can be noticed thanks to exceptions the above problem can be solved\r
+with the minimal waste of run time. \r
+ \r
+\r
+\r
+12. Separate compilation (this section does not apply to PC version)\r
+########################\r
+ \r
+\r
+\r
+13. Processes\r
+#############\r
+ \r
+ The implementation of processes is different (May 1988) c.f. user's manual. \r
+\r
+ Process in LOGLAN-82 is a natural generalization of coroutine (cf\r
+p.6). Coroutines are units which once generated may operate\r
+independently, each one treated as a separate process. For coroutines,\r
+however, an essential assumption is established; namely, when one\r
+coroutine object is reactivated, the active one must be suspended\r
+(i.e. there which is onle one control is switched between coroutine\r
+objects). When processes are used, the activation of a new process\r
+does not require the active one to be suspended. So many objects may\r
+be simultaneously active.\r
+ The statement that reactivates a suspended process X (without\r
+suspention of the active one) has the form:\r
+ \r
+ resume(X) \r
+ \r
+ The main problem of parallel programming is, of course,\r
+synchronization. Elementary synchronization in LOGLAN-82 is achieved\r
+by two-valued semaphores and some number of simple statements\r
+operating on them.\r
+ A semaphore variable controls the entry to a critical region, i.e. a\r
+sequence of statements that may be executed by the one process only.\r
+When a semaphore is open, the corresponding critical region is free.\r
+When a semaphore is closed, it means the corresponding critical region\r
+is just executed by a certain process.\r
+ \r
+ These are the simple indivisible statements that operate on\r
+semaphores:\r
+ \r
+ lock(S) - If semaphore S is open, the given process enters \r
+ the critical region guarded by S , and\r
+ simultaneously, semaphore S becomes closed. If\r
+ semaphore S is already closed, the given process\r
+ waits until the critical region is open (by another\r
+ process).\r
+ unlock(S)- If semaphore S is closed, then it becomes open. \r
+ Otherwise the statement is empty.\r
+ stop(S) - The statement causes semaphore S to be open, and \r
+ simultaneously, it stops the given process\r
+ execution. The statement may be used without a\r
+ parameter, and then, it stops the given process\r
+ execution.\r
+ Moreover, only those three above statements may change the values of\r
+semaphore variables.\r
+ In general, several processes may wait for an entry to the same\r
+critical region. When the process executing this critical region opens\r
+the semaphore (by unlock or stop), one of the waiting processes is \r
+reactivated and enters the region. The way such a process is selected\r
+is not defined by the language. The user must assume that this\r
+selection is performed arbitrarily. \r
+\r
+\r
+\r
+ Example:\r
+ --------\r
+ \r
+ In the example an input stream of real numbers is copied. The\r
+copying process is parallelized in such a way that when process get\r
+reads the next number, the process put writes simultaneously the\r
+number read in the preceding step. The input stream ends with 0.\r
+ \r
+ block \r
+ var in_buf,out_buf:real, completed:boolean, sem:semaphore; \r
+ var counter:integer,get:get_type,put:put_type; \r
+ unit cobegin:procedure; (* called by the main program *) \r
+ begin \r
+ lock(sem); (* critical region *) \r
+ resume(get); (* activate reading *) \r
+ resume(put); (* activate writing *) \r
+ stop(sem); (* exit from critical region *) \r
+ end cobegin; \r
+ unit coend: procedure; \r
+ begin (* called by get and put *) \r
+ lock(sem); (* entry to critical region *) \r
+ if counter=0 \r
+ then (* one process entered *) \r
+ counter:=1\r
+ else (* two processes entered *) \r
+ counter:=0;\r
+ resume(main) (* reactivate main program *) \r
+ fi;\r
+ stop(sem) (* exit from critical region *) \r
+ end coend;\r
+ \r
+ unit get_type:process; \r
+ begin \r
+ return;\r
+ do \r
+ read(in_buf);\r
+ if in_buf=0 \r
+ then (* end of data *) \r
+ completed:=true\r
+ fi; \r
+ call coend \r
+ od \r
+ end get_type;\r
+ \r
+ unit put_type:process; \r
+ begin\r
+ return; \r
+ do \r
+ write(out_buf);\r
+ call coend; \r
+ od \r
+ end put_type; \r
+\r
+ begin (* main process *) \r
+ read(in_buf);\r
+ get:=new get_type; \r
+ put:=new put_type; \r
+ do \r
+ out_buf:=in_buf;\r
+ call cobegin; \r
+ if completed then exit fi; \r
+ od; \r
+ kill(get); \r
+ kill(put); \r
+ end; \r
+ \r
+ Two procedures cobegin and coend synchronize the execution of the\r
+main loop. Procedure cobegin implements fork operator, procedure coend\r
+called from processes put and get implements the end of fork operator.\r
+Variable count defines the number of processes that called procedure\r
+coend. By an easy modification one can generalize these procedures in\r
+order to implement the general k-fork and end of k-fork operators (if\r
+count can assume the values 0,1,...,k-1).\r
+ \r
+ Finally, let us present an example of a class that realizes Hoare's\r
+monitors (cf. [2]). Monitor is a structure that synchronizes the\r
+access to a common pool of data. The number and kinds of these data\r
+are defined by the user. Monitor task is only to give non-conflict\r
+access to it. The access to a monitor is realized by the so-called\r
+entry procedures. Entry procedure has a prefix entry which guarantees\r
+that only one such a procedure may enter the monitor.\r
+ In order to allow scheduling of processes that entered the monitor,\r
+two specialized procedures operating on the inner monitor queues are\r
+provided.\r
+ \r
+ delay(Q) - stops the execution of the process and puts it\r
+ into a queue Q, the entry to the monitor is free,\r
+ continue(Q) - resumes the execution of the first process from a\r
+ queue Q (if Q is non-empty, otherwise the entry to\r
+ the monitor is free).\r
+ \r
+ As can be easily seen, the correct use of these constructs is\r
+achieved when continue is called as the last statement of an entry\r
+procedure.\r
+ \r
+ The declaration of the class Monitor is as follows: \r
+\r
+\r
+unit Monitor : queue class; \r
+ hidden sem,queue; (* hidden protects attributes sem and queue *) \r
+ var sem:semaphore; (* sem is the semaphore guarding the monitor entry *) \r
+ \r
+ unit entry: class; (* all entry procedures must have prefix entry \r
+ which realized non-conflict access to Monitor *)\r
+ var busy:boolean; (* busy is true iff continue(Q) was executed \r
+ hidden busy; \r
+ unit delay: procedure(Q:queue); \r
+ begin \r
+ call Q.into(this process);\r
+ (* put the active process into queue Q *) \r
+ stop(sem) \r
+ (* free the monitor access, halt the active process *) \r
+ end delay; \r
+ unit continue:procedure(Q:queue); \r
+ (* continue can be called as the last statement of an entry procedure *)\r
+ begin \r
+ if not Q.empty \r
+ then \r
+ busy:=true\r
+ resume(Q.out); (* resume the next process from queue Q *) \r
+ fi; \r
+ end continue;\r
+ begin (* beginning of the prefix entry *) \r
+ lock(sem); (* entry to the critical region *) \r
+ inner; (* the virtual body of an entry procedure *) \r
+ if not busy \r
+ then \r
+ unlock(sem) (* free the monitor access, unless continue \r
+ fi; \r
+ end entry; \r
+end Monitor; \r
+\r
+\r
+ The mail-box structure which receives and sends the items of type T\r
+may be implemented as the following class prefixed by Monitor:\r
+ \r
+ unit Buffering:Monitor class(type T;size:integer); \r
+ var Pool:arrayof T,count,in_index,out_index:integer; \r
+ var readers_queue,writers_queue:queue; \r
+ unit writer:entry procedure(r:T); \r
+ begin\r
+ if count=size then call delay(writers_queue) fi; in_index\r
+ Pool(in_index):=r; call continue(readers_queue); \r
+ end writer; \r
+ unit reader:entry procedure(output r:T); \r
+ begin\r
+ if count=0 then call delay(readers_queue) fi; \r
+ out_index:=out_index mod size +1; count:=count-1; \r
+ r:=Pool(out_index); call continue(writers_queue); \r
+ end reader; \r
+ begin\r
+ new_array Pool dim (1:size); \r
+ readers_queue:=new queue; writers_queue:=new queue; \r
+ end Buffering; \r
+\r
+\r
+References.\r
+###########\r
+ \r
+ [1] Dahl O-J.,Myhrhaug B,Nygaard K.: Common Base Language . NCC\r
+S-22, October 1970\r
+ [2] Hoare C.A.R.: Monitors, an operating system structuring concept.\r
+CACM,vol.17,N.10,October 1974,pp.549-57\r
+ [3] LOGLAN-82 Report , Warsaw, 1982\r
+\1a
\ No newline at end of file
--- /dev/null
+(* Loglanizator Tekstowy wersja 1.0 1990 Warszawa Michal Pakier *)\r
+===============REKORD 1=======================================|===============\r
++ 22 2\r
+ Using the editor LOTEK version 1.0\r
+ \r
+ ³F2..............Save File\r
+Scrolling text ³ cursor moves ³F3........File operations\r
+ by line: ³ one word ³F4..Errors of compilation\r
+^U.............up ³ relatively to ³F8.....Auxiliary programs\r
+^D...........down ³ the line above ³F9......Compilation & run\r
+ by page: ³^N........to right³F10...........Menu on/off\r
+PgDn.........down ³^P.........to left³F5................Windows\r
+PgUp...........up ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ-\r
+ Jump to ³^K.......block operations³^Y.....delete line\r
+^PgDn.....begin of³^Q.......replace & search³\r
+ text ³^J..........Jumps in text³ delete character\r
+^PgUp.......end of³^W....Windows operations ³BackSpace..to left\r
+ text ³^V.........Macrocommands ³Del.......to right\r
+^Home.....begin ofÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ-\r
+ window ³^A...............delete to the begin of line\r
+^End.......end of ³^S.................delete to the end of line\r
+ window ³F1........On line HELP;press when in trouble\r
+ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ-\r
+ \r
+ Help on HELP press <0>\r
+===============REKORD 2=======================================|===============\r
++ 11\r
+ HELP on HELP.\r
+ \r
+ In any moment you can press the key F1 and obtain an infor-\r
+mation on currently available actions. It may suggest further\r
+request of more detailed informations. In such a case press one\r
+of keys {0,1,2,3,4,5,6,7,8,9}, which is shown on screen in the\r
+angles e.g.<2>.\r
+ \r
+ \r
+ Esc leaving Help\r
+ F1 principal information of Help\r
+===============REKORD 3=======================================|===============\r
++ 8 4\r
+ Saving file on disk (F2,F3S)\r
+ \r
+It may happen that for some reason we cannot write file back to\r
+the directory from which it is read. In such a case press (F3L)\r
+and choose the directory in which we have all rights next you\r
+can write file using F3 W.\r
+ \r
+ More on file operations, press <0>\r
+===============REKORD 4=======================================|===============\r
++ 15 23 3 24 25 26 41\r
+ File operations (F3)\r
+ \r
+permit to load, write file or to begin a new file to edit\r
+ \r
+Your choices:\r
+ \r
+ L Loading a file from disk <0>\r
+ S Saving file on disk <1>\r
+ N New file edition <2>\r
+ W Write a file on disk <3>\r
+ P Pick one of the lastly used files <4>\r
+ O different Options <5>\r
+ G Information on the edited files and on\r
+ free memory\r
+ Q Quit the LOTEK environment\r
+===============REKORD 5=======================================|===============\r
++ 16\r
+ Correction of ERRORS\r
+ \r
+This option facilitates correction of errors in Loglan program.\r
+In the lowest line you see number of line with error and short\r
+description of the error. The cursor is placed on the error's\r
+occurrence. In certain cases it locates precisely the line and\r
+the column of error, if it is not the case then only line is\r
+shown and its first column. If you have menu bar (F10) then a\r
+submenu concerning errors' scrolling appears.\r
+You have the following choices:\r
+ Ctrl F5 - Move to the first error\r
+ Ctrl F6 - Move to the last error\r
+ Ctrl F8 - Show Next error\r
+ Ctrl F7 _ Show previous error\r
+ Ctrl F10 - Exit from the mode errors' corrrection\r
+Press F4 for exit from errors' correction.\r
+===============REKORD 6=======================================|===============\r
++ 8\r
+ CHANGING WINDOW\r
+ \r
+ You can open a new window or change the active one.\r
+ F Full screen all other windows are closed\r
+ H Help on Loglan here you can consult doc on Loglan\r
+ use Tab to move between documents\r
+ A Auxiliary window\r
+ M Main window\r
+===============REKORD 7=======================================|===============\r
++ 17 22\r
+ AUXILIARY PROGRAMS\r
+ \r
+You can execute programs which appear in this window without\r
+exiting LOTEK. This window may be defined by you (see lotek.pth\r
+and LOTEKINS.EXE). It enables, among others, certain operations\r
+on the file being edited, the name of the file is transmitted\r
+as parameter to the called program. As one of options you can\r
+put the LOTEKINS program which can facilitate modifications of\r
+the window. You can put a call of a program in this window in-\r
+to a macrocommand <0>.\r
+(Example: If we have a computer with two monitors and if you\r
+put instructions C COLOR (mode co80) and M MONO (mode mono)\r
+then macrocommand <AltH> @8M@5H@5F will allow to consult do-\r
+cumentation on the monitor controlled by Hercules card and\r
+macro <AltM> @8C@5M@5F will permit editing on a colour monitor,\r
+still having database on Loglan on white & black monitor.)\r
+ \r
+===============REKORD 8=======================================|===============\r
++ 11 36\r
+ COMPILING YOUR PROGRAM\r
+ \r
+Your choices are:\r
+ L: Pass 1 Compilation-first phase(program Loglan). During\r
+ this pass all syntax errors are detected.(Use F4)\r
+ G: Pass 2 Second or First and second phase of compilation\r
+ (program Gen).\r
+ R: Run Program execution (with compilation if needed).\r
+ D: Debuger First the program is executed and then you can\r
+ watch command after command its execution.\r
+ O: Options Different options of compilation <0>\r
+===============REKORD 9=======================================|===============\r
++ 17 27 28 29 30 31 32 33 34 35\r
+ OPERATIONS ON BLOCKS\r
+ \r
+Press Ctrl_K and then a key which corresponds to the desired\r
+action. If you do not know what to choose wait 2 secs. and\r
+a frame will appear with all options.\r
+ \r
+Your choices are:\r
+ \r
+ K,B,T,L - marking a block <0>\r
+ Y - deleting the marked block <1>\r
+ C,V - copying and moving the block <2>\r
+ S,M - copying and moving with indentation <3>\r
+ R,W - block to and from the disk <4>\r
+ U,I - shifting the block <5>\r
+ H - hiding the block <6>\r
+ F - framing a block (e.g. a comment) <7>\r
+ O - options <8>\r
+===============REKORD 10=======================================|===============\r
++ 13 37 38 39 40\r
+ GO TO INDICATED PLACE IN TEXT\r
+ \r
+Press Ctrl_J and then a key which corresponds to the desired\r
+action. If you do not know what to choose wait 2 secs. and\r
+a frame will appear with all options.\r
+ \r
+Your choices are:\r
+ \r
+ S - mark this place for return <0>\r
+ R - return to the marked place <1>\r
+ J - jump to the marked place <2>\r
+ L - jump to the given line\r
+ B,K - jump to the begin (resp. to the end) of block <3>\r
+===============REKORD 11=======================================|===============\r
++ 17 15 16 17 18 19 20\r
+ Search and replace operations\r
+ \r
+Press Ctrl_Q and then a key which corresponds to the desired\r
+action. If you do not know what to press wait 2 secs. and\r
+a frame with options will appear.\r
+ \r
+Your choices:\r
+ \r
+ F - find a word <0>\r
+ A - Alter find a word and replace <1>\r
+ C - replace character <2>\r
+ K - replace key words <3>\r
+ T - find another occurrence of the current word <4>\r
+ R - find and replace word currently pointed by cursor <5>\r
+ \r
+REMARK: Pressing Ctrl L you can repeat the lastly executed\r
+ action of searching/replacing.\r
+===============REKORD 12=======================================|===============\r
++ 13 14\r
+ Documentation on Loglan - Loglan's database\r
+ \r
+ Each line on the screen is a title of a section.\r
+ Press ENTER to see the highlighted section.\r
+ \r
+ Press Tab (& cursor left, right) to change (choose) a document\r
+ or a chapter.\r
+ cursor up - prevoius section,\r
+ cursor down - next section,\r
+ Ctrl PgUp - to the begin of list of sections,\r
+ Ctrl PgDn - to the end of list of sections,\r
+ PgUp,PgDn - previous (next) page of list of sections,\r
+ Ctrl_Q_F - searching a word.\r
+===============REKORD 13=======================================|===============\r
++ 11 12 14\r
+ Loglan's database - in a section\r
+ \r
+ Enter - return yo the list of sections <0>\r
+ Tab - change(choose) a document, a chapter <1>\r
+ Up,Down,Left,Right - moving the cursor\r
+ Home,End - to the begin (end) of line\r
+ Ctrl PgUp - to the begin of text\r
+ Ctrl PgDn - to the end of text\r
+ PgUp,PgDn - page up (page down)\r
+ Ctrl_K_B,K,L,T - marking a block\r
+ Ctrl_Q_F - searching a word\r
+===============REKORD 14=======================================|===============\r
++ 9\r
+ Loglan's database - CHOOSING A DOCUMENT\r
+ \r
+ On the screen you see names of documents to consult.\r
+Use cursor left & right to choose the type of document:\r
+ opisy=reports, funkcje=functions, tablice=tables.\r
+Use cursor up & down, or Home & End to choose a document.\r
+Press Enter to confirm your choice and to see the chosen doc.\r
+ \r
+ Press Esc to return to your last choice.\r
+===============REKORD 15=======================================|===============\r
++ 13\r
+ (F) Searching a word\r
+ \r
+Give a word you are looking for (Find :?).\r
+Next define the options. Then search is performed according to\r
+your choice of options. If word is found the cursor is located\r
+after it.\r
+You can choose the options:\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n.................................searching of n-th occurrence.\r
+ U.........................upper & lower case lettersidentified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+===============REKORD 16=======================================|===============\r
++ 16\r
+ (A) Replace a word (alter)\r
+ \r
+First, give a word to be replaced (Find :?)\r
+Second, give a word to be put into (Replace with :?)\r
+Third, define options.\r
+Search & replace action begins: if a searched word is found then\r
+at the top of the screen you see a demand of confirmation.\r
+ \r
+The options are :\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n..............................replacing up to n-th occurrence.\r
+ U.........................upper & lower case lettersidentified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+ N.......... .uNconditional replace (no confirmation required).\r
+===============REKORD 17=======================================|===============\r
++ 11\r
+ (C) Replace Characters\r
+ \r
+This functionality enable to exchange capital letters to small\r
+ones and viceversa:\r
+ D..........................................Put capital letters.\r
+ S............................................Put small letters.\r
+ G........Global replace from the begin or from the end of text.\r
+ B.............................................Backward replace.\r
+ L.........................Replace inside the highlighted block.\r
+ C.................................Replace inside comments only.\r
+ T..................................Replace inside program only.\r
+===============REKORD 18=======================================|===============\r
++ 10\r
+ (K) Replace keywords of Loglan\r
+ \r
+This function permits to put all the keywords of Loglan in the\r
+selected case (lower or upper).\r
+Your choices are:\r
+ D.......................................Put in capital letters.\r
+ S.........................................Put in small letters.\r
+ G........Global replace from the begin or from the end of text.\r
+ B.............................................Backward replace.\r
+ L............................Replace inside thehighlited block.\r
+===============REKORD 19=======================================|===============\r
++ 12\r
+ (T) Searching the word indicated by cursor\r
+ \r
+If word is found the cursor is located after it.\r
+You can choose the options:\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n.................................searching of n-th occurrence.\r
+ U........................upper & lower case letters identified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+===============REKORD 20=======================================|===============\r
++ 15\r
+ (R) Search andReplace the word indicated by cursor\r
+ \r
+Give a word to be put into (Replace with :?)\r
+Next, define options.\r
+Search & replace action begins: if a searched word is found then\r
+at the top of the screen you will see a demand of confirmation.\r
+ \r
+The options are :\r
+ G.......global search, from the beginning (or the end) of text.\r
+ B..............................................backward search.\r
+ n.................................replacing up n-th occurrence.\r
+ U.........................upper & lower case lettersidentified.\r
+ W............................................whole word search.\r
+ L..............................searching inside a marked block.\r
+ N.......... .uNconditional replace (no confirmation required).\r
+===============REKORD 21=======================================|===============\r
++ 13 29 30\r
+ Exchange block between windows and other operations\r
+ \r
+Press Ctrl_W and then a key which corresponds to the desired\r
+action. If you wait 2 secs. then a frame appears with choices\r
+suggested.\r
+ \r
+Options to choose:\r
+ C - copy the block from the second, visible on screen window,\r
+ V - move the block from the second, visible on screen window,\r
+ S - copy with indentation from the other window,\r
+ M - move with indentation from the other window.\r
+ \r
+More on C,V <0> More on S,M <1>\r
+===============REKORD 22=======================================|===============\r
++ 19\r
+ Defining macrocommands\r
+ \r
+You can create, store and apply your macrocommands i.e. the\r
+sequences of keys. A macrocommand can be associated with a let-\r
+ter, digit or an F key. A macrocommand is executed when you\r
+press simultaneously Alt+corresponding key.\r
+Definition of a macrocommand may contain usual characters ASCII\r
+and also the following combinations of keys:\r
+ ^.............denotes Ctrl + following key (A..Z and 0..9)\r
+ &..............denotes Alt + following key (A..Z and 0..9)\r
+ @........denotes a functional key. The next key may be :\r
+ 1..0 - F1..F10 ³ <>^v - cursor ³ H - Home ³ E - End ³\r
+ U - PgUp ³ D - PgDn ³ I - Insert ³ L - Delete ³\r
+ S - Esc ³ B - Backspace ³ ³ ³\r
+ C - Enter ³ ³ ³ ³\r
+ #......the next character is not interpreted e.g.## denotes #\r
+Braces permit to iterate the string inside them.\r
+E.g. the string {^C(* *)}12 will cause cration of 12 new lines\r
+containing the string "(* *)"\r
+===============REKORD 23=======================================|===============\r
++ 17\r
+ (L) Loading a file\r
+ \r
+You can enter a file name or a mask e.g. *.log defining a group\r
+of files. In the first case the file is loaded (or initialized)\r
+In the second case all names that correspond to the mask are\r
+shown.\r
+ \r
+>>>You can press:\r
+ Esc.........Return without loading anything\r
+ \r
+ \18 \19 < >......................Moving in window.\r
+ Enter.........If a file is indicated then it is loaded\r
+ If a directory is indicated then it is opened\r
+ \r
+ PgUp,PgDn......Previous or next page\r
+ (the window contains maximum 20 names).\r
+ F4............change directory\r
+===============REKORD 24=======================================|===============\r
++ 5\r
+ (N) New file editing\r
+ \r
+The scrren is emptied and an edition of the file NONAME.LOG\r
+begins. At saving time Lotek will propose to change the name\r
+of the file.\r
+===============REKORD 25=======================================|===============\r
++ 5\r
+ (W) Save the edited file as ...\r
+ \r
+It permits to change the name of the edited file and to save it\r
+in the current directory.(see L option for change of directory)\r
+ \r
+===============REKORD 26=======================================|===============\r
++ 4\r
+ (P) Pick up\r
+ \r
+you can choose a name among lastly edited files or Load (L)\r
+ \r
+===============REKORD 27=======================================|===============\r
++ 6\r
+ Marking a block\r
+ \r
+ B - mark begin of block,\r
+ K - mark end of block,\r
+ T - mark the word indicated by cursor as a block,\r
+ L - mark the line indicated by cursor as a block.\r
+===============REKORD 28=======================================|===============\r
++ 3\r
+ Deleting block\r
+ \r
+ You can delete the marked block.\r
+===============REKORD 29=======================================|===============\r
++ 15 30\r
+ (C,V) Copying or moving the highlighted block\r
+ \r
+Function.C. copies the highlighted block (Ctrl K + B,K,T,L)\r
+to the current position of cursor.\r
+Begin of the block will be positioned exactly on the cursor.\r
+Other lines are not shifted.\r
+ \r
+REMARK: One can copy the block into itself.\r
+ \r
+Function.V. moves the highlighted block (Ctrl K+ B,K,T,L)\r
+to the current position of cursor.\r
+The earlier occurrence of the block dissapears.\r
+Begin of the block will be positioned exactly on the cursor.\r
+Other lines are not shifted.\r
+ \r
+ ----> Ctrl K S,M <0>\r
+===============REKORD 30=======================================|===============\r
++ 18 29\r
+ (S,M) Copy or Move the block with indentation\r
+ \r
+Function.S. copies the highlighted block (Ctrl K + B,K,T,L)\r
+to the current position of cursor. It differs however from\r
+the function Ctrl K C. All lines of the block will begin in\r
+the position of cursor.\r
+ \r
+REMARK: One can copy the block into itself.\r
+ \r
+Function.M. moves the highlighted block (Ctrl K+ B,K,T,L)\r
+to the current position of cursor. It differs however from\r
+the function Ctrl K V. All lines of the block will begin in\r
+the position of cursor.\r
+The earlier occurrence of the block dissapears.\r
+ \r
+REMARK: If you move the block into itself it will result in\r
+shifting it horizontally, it will move to the cursor position.\r
+ -----> Ctrl K C,V <0>\r
+===============REKORD 31=======================================|===============\r
++ 10 23 25\r
+ (R,W) Reading and Writing a block\r
+ \r
+Function R enables inclusion of a file from the disk.\r
+The file is included in the current postion of the cursor\r
+without indentation (as Ctrl K C does).\r
+A window appears and you can choose the name of file\r
+ see F3 L <0>\r
+Function W enables saving of the block on disk.\r
+A window appears and you can choose the name of file\r
+ see F3 W <1>\r
+===============REKORD 32=======================================|===============\r
++ 8\r
+ (I,U) Shift the block to right or to left\r
+ \r
+Function.I.shifts all lines of the block one position to left.\r
+ It applies to the full first and last line of the block.\r
+ \r
+Function.U.shifts all lines of the block one position to right.\r
+ It applies to the full first and last line of the block.\r
+ \r
+===============REKORD 33=======================================|===============\r
++ 5\r
+ Hiding block\r
+ \r
+ You can unmark the marked block.\r
+If you repeat this action then the block is marked again.\r
+ \r
+===============REKORD 34=======================================|===============\r
++ 6 35\r
+ (F) Frame around a block\r
+ \r
+ If you selected a block then a frame can be put around it.\r
+Options permit to define parameters of the frame.\r
+Each line is enclosed in (* *) i.e. it is a comment.\r
+ -----> Ctrl K O <0>\r
+===============REKORD 35=======================================|===============\r
++ 19\r
+ (O) Parameters of frames\r
+ \r
+3 lines determine the pattern of frame\r
+ define 3 characters for top, inside and bottom lines of frame.\r
+ - top line: leftmost, inside, rightmost character;\r
+ - inside line: leftmost, inside, rightmost character;\r
+ - bottom line: leftmost, inside, rightmost character;\r
+ F............................Position of first column of frame.\r
+ - must be between 0..255,\r
+ - must be less then L, the last column of frame,\r
+ - 0 has a special meaning:frame will begin in the first\r
+ column of indicated text,\r
+ L.....................Position of the last column of the frame\r
+ - must be between 0..255\r
+ - must be greater then F, the first column of frame\r
+ - 0 has a special meaning: frame will end in the last column\r
+ of indicated text,\r
+ T.....Put text in the frame: to the LEFT, to the RIGHT, CENTER\r
+ in frame.\r
+===============REKORD 36=======================================|===============\r
++ 14\r
+ Compilation options\r
+ \r
+ \r
+ \r
+D: Debug info on/off Debug on causes: firstly - execution\r
+ of the program is recorded on special file, secondly - you can\r
+ watch the sequence of executed commands.\r
+ \r
+M: Memory ______ Divided by 4 amount of memory atributed\r
+ to our pogram. It may assume values from 16384 to 100000.\r
+ If you can select 16384 to accelerate the program.\r
+ \r
+C: Cursor on/off For amateurs only. It enables to hide\r
+ cursor during the program execution.\r
+===============REKORD 37=======================================|===============\r
++ 4\r
+ (S) Marking a place in the text\r
+ \r
+This function memorises the current position of the cursor.\r
+It is possible to reposition cursor quickly in this place.\r
+===============REKORD 38=======================================|===============\r
++ 5\r
+ (R) Go to the marked place and ...\r
+ \r
+The difference with respect to Ctrl J J lies in that befor we\r
+move to an earlier marked place, we mark the current position\r
+This enables a return with commands Ctrl J J/R.\r
+===============REKORD 39=======================================|===============\r
++ 4\r
+ (J) Go to an earlier marked place\r
+ \r
+Cursor is moved to the place which was earlier marked with the\r
+use of Ctrl J S command\r
+===============REKORD 40=======================================|===============\r
++ 4\r
+ Go to block\r
+ \r
+ B - go to the begin of the highlighted block\r
+ K - go to the end of the highlighted block\r
+===============REKORD 41=======================================|===============\r
++ 20\r
+ File options (F3O)\r
+ \r
+Your choices:\r
+ \r
+ S..it is the number of line dividing two windows of Lotek.\r
+ (e.g. between main file and auxiliary file or between\r
+ main file and Loglan's database),\r
+ B..backups? If your answer is yes then saving file on disk\r
+ causes that the previous version of the file is saved\r
+ with an extension .BAK\r
+ \r
+ D..Delay of idle time.\r
+ If no key is pressed during D time then the screen shows\r
+ a sky with stars blinking.\r
+ \r
+ W..delay of showing menus.\r
+ If you choose an action of editor say Ctrl+K then first\r
+ you see the headline of a menu window and the window\r
+ itself appear after W time.\r
+ \r
+=============KONIEC============================================|==============\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
--- /dev/null
+f:\loglan\lotek\\r
+f:\loglan\lotek\\r
+F:\LOGLAN\LOTEK\LOGHELP.MPH\r
++ N Norton Commander \r
++ W Word to make doc \r
++ D to Draw \r
++ R Run \r
+c:\nc\nc\r
+C:\word !\r
+c:\draw !\r
+f:\loglan\exe\386\int !\r
+\r
+Plik instalacyjny edytora LOTEK\r
+Pierwsza linia jest nazwa katalogu,w ktorym znajduja sie programy:\r
+Lotek.hlp,MPLOGED.exe,lsttest.exe\r
+Druga linia jest nazwa katalogu,w ktorym znajduja sie programy:\r
+prep.exe,logdeb.exe\r
+Trzecia linia jest dokladna nazwa pliku z baza danych (*.hlp)\r
+UWAGA:Trzecia linia musi byc duzymi literami\r
+Nastepne linie sa kolejnymi liniami okienka EXEC\r
+Zaczynaja sie one znakiem +\r
+Trzeci znak w kazdej z tych linii to znak,ktorego nacisniecie bedzie\r
+wywolywac dana funkcje\r
+Po liniach z plusem wystepuja kolejno instrucje jakie maja byc\r
+wykonane po wybraniu tych funkcji.W kazdej z tych linii wykrzyknik\r
+bedzie zastapiony nazwa aktualnie edytowanego pliku\r
--- /dev/null
+ \r
+ Warszawa 1990 Michal Pakier\r
+ \r
+ Program zarzadzajacy srodowiskiem jezyka LOGLAN\r
+ -----------------------------------------------\r
+ \r
+1:Instalacja programu\r
+---------------------\r
+ W sklad systemu wchodza nastepujace pliki:\r
+ LOTEK.EXE zarzadzajacy wszystkim pozostalym\r
+ MPLOGED.EXE wlasciwy program\r
+ LSTTEST.EXE popmocniczy przy kompilacji\r
+ LOTEK.HLP tekst helpa\r
+ LOTEKINS.EXE program instalacyjny\r
+2:Edytor tekstow.\r
+-----------------\r
+ Caly program jest jakby edytorem tekstow ukierunkowanym na pisanie\r
+ programow w LOGLAN'ie.Oprocz podstawowych funkcji zwiera on takze\r
+ inne ciekawe mozliwosci ulatwiajace prace.\r
+ 1\Operacje blokowe\r
+ Oprocz zwyklych operacji na blokach,takich jak:kasowanie,przenosze-\r
+ nie,kopiowanie, przesuwanie w lewo i prawo oraz wgrywanie na dysk\r
+ i z dysku sa takze inne , uwzgledniajace specyficzna strukture pro-\r
+ gramow komputerowych. Sa to: przenoszenie i kopiowanie z wyrownywa-\r
+ niem (przesuwa w poziomie caly blok , a nie tylko pierwsza linie),\r
+ wstawianie bloku w ramke z komentarzy (mozna dowolnie ustawic para-\r
+ metry ramki:szerokosc,wzor,wyrownawanie tekstu wewnatrz).Edytor ten\r
+ pozwala kopiowac i przenosic blok do wnetrza jego samego (przeno-\r
+ szenie powoduje przesuniecie w bok, tak by poczatek byl w kolumnie\r
+ wskazywanej przez kursor).\r
+ 2\Operacje wyszukiwania i zamiany slow\r
+ Mozna znalezc lub znalezc i zamienic podane slowo lub wskazywane\r
+ przez kursor. Mozliwa jest tez zamiana wszystkich loglanowych slow\r
+ kluczowych na duze lub male litery(w calym tekscie lub jego wskaza-\r
+ nym fragmencie) .Jest tez funkcja zamieniajaca wszystkie znaki na\r
+ duze badz male litery (w wybranym fragmencie tekstu lub tylko w ko-\r
+ mentarzach lub tylko w tekscie).\r
+ 3\Operacje szybkiego poruszania sie po tekscie\r
+ Mozna zaznaczyc punkt w tekscie i nastepnie z dowolnego miejsca\r
+ skoczyc do niego. Sa dwa rodzaje skokow:skok normalny i z zaznacze-\r
+ niem aktualnego punktu. Wykonujac ten drugi mozemy skakac miedzy\r
+ dwoma miejscami w tekscie. Oczywiscie mozna tez skoczyc do poczatku\r
+ i konca zaznaczonego bloku.\r
+ 4\Help\r
+ W kazdym momencie po nacisnieciu klawisza F1 pojawia sie na ekranie\r
+ krotki opis wszystkich aktualnie dostepnych funkcji.\r
+ 5\Makroinstrukcje\r
+ Jest to cos co bardzo ulatwia pisanie programow. Dla kazdego klawi-\r
+ sza (a..z,0..9,F1..F10) mozna zdefiniowac makrorozkaz. Jest on poz-\r
+ niej wywolywany przez nacisniecie Alt+ <odpowiedni klawisz>.Makro-\r
+ instrukcja jest to ciag znakow wstawianych naraz do bufora klawia-\r
+ tury (mozna tez kazac aby jakas sekwencja byla wstawiona kilka ra-\r
+ zy). Z pomoca makrorozkazow mozna sobie na bierzaco definiowac roz-\r
+ ne pozyteczne funkcje np : linia oddzielajaca, zamienienie slowa na\r
+ duze litery,zaznaczenie trzech nastepnych linii jako blok,...\r
+ 6\Operacje plikowe\r
+ Sa dostepne nastepujace operacje : wgranie pliku z dysku (jesli nie\r
+ ma pliku o podanej nazwie to rozpoczynamy jego edycje) ,rozpoczecie\r
+ edycji nowego pliku (przyjmuje nazwe noname.log) , zgranie pliku na\r
+ dysk,zmiana nazwy edytowanego pliku (dokladnie nagranie w aktualnym\r
+ katalogu edytowanego pliku z nowa nazwa i rozpoczecie jego edycji).\r
+ Mozna takze wybrac do edycji plik z posrod dziesieciu ostatnio uzy-\r
+ wanych.\r
+3:Okna\r
+------\r
+ W programie mozemy kozystac jakby z trzech okien edycyjnych.Pierwsze to\r
+ okienko glowne ,w ktory mozemy wykonywac wszystkie mozliwe operacje. Dru-\r
+ gie to okienko dodatkowe, dla ktorego nie mozna jedynie wykonywac kompi-\r
+ lacji i operacji z okienka Execute. Trzecie okienko nie zezwala nam na\r
+ edycje czegokolwiek umozliwia ono podladanie bazy danych zawierajacej\r
+ wszelkie mozliwe informacje o loglanie. Na ekranie moga byc maksymalnie\r
+ dwa okienka :okienko Glowne i ktores z pozostalych. Bedac w okienku glow-\r
+ nym lub dodatkowym mozna przeniesc z drugiego widocznego okienka blok\r
+ (sa tu wszelkie odmiany przenoszenia blokow).\r
+4:Kompilacja\r
+------------\r
+ Program umozliwia skompilowanie (bez wychodzenia z edytora) pliku znajdu-\r
+ jacego sie w okienku glownym. Mozna wykonac pierwszy lub drugi przebieg\r
+ kompilacji, uruchomic skompilowany program a po powrocie przesledzic jego\r
+ wykonanie. Program automatycznie zapamietuje jakie operacje dla danego\r
+ pliku byly wykonywane i na przyklad jezeli wywolamy opcje RUN a byl tylko\r
+ pierwszy przebieg to zostanie wykonany tez drugi. Po wykonaniu pierwszego\r
+ przebiegu kompilacji mozna ogladac znalezione bledy. W dolnej linii wy-\r
+ swietla sie opis bledu a kursor wskazuje jego wystapienie w tekscie.\r
+5:Okienko Execute\r
+-----------------\r
+ To okienko kazdy uzytkownik moze sobie zdefiniowac sam podczas instalowa-\r
+ nia programu Pozwala ono na wywolanie dowolnych funkcji dosu,programow\r
+ lub plikow *.BAT a nastepnie na powrot do edytcji. Do wywolanego programu\r
+ mozna oczywiscie kazac automatycznie wstawiac nazwe edytowanego pliku\r
+ (w parametrze).\r
+6:Baza danych\r
+-------------\r
+ Jest to zasadniczo zbior informacji o Loglanie ale moze tu byc podczas\r
+ instalacji podlaczona dowolna inna baza danych (stworzona za pomoca pro-\r
+ gramu MPH ). Baza taka sklada sie z 6-ciu okienek po max. 22 linie.Kazdej\r
+ linii przyporzadkowany jest dowolnej dlugosci spis tresci a kazdej linii\r
+ spisu tresci dowolnej wielkosci tekst. Bedac w spisie tresci lub w te-\r
+ kscie mozna wywolac niektore funkcje edytora: Wyszukanie podanego slowa\r
+ i zaznaczenie bloku. Zaznaczony blok moze byc potem przeniesiony do pliku\r
+ glownego. Mozliwe jest wejscie do bazy danych wyszukanie interesujacego\r
+ nas tekstu, a nastepnie powrot do edycji bez utraty podgladu na wybrany\r
+ tekst.\r
+7:Praca w srodowisku LOTEK\r
+--------------------------\r
+ Prace rozpoczyna sie uruchamiajac program LOTEK.EXE.Na dole ekranu wypi-\r
+ sane sa wszsystkie funkcje, ktore sa aktualnie dostepne. Jesli ktos chce\r
+ miec o jedna linie wiecej dla edycji to moze spowodowac,ze linia informa-\r
+ cyjna bedzie niewidoczna. Po kazdym wyjsciu z programu na dysk nagrywane\r
+ sa wszelkie parametry (na pliku MPLED.DAT) i przy ponownym uruchomieniu\r
+ jestesmy w takim stanie jak wtedy, gdy skonczylismy. Edytor ma wbudowany\r
+ mechanizm zapobiegajacy wypaluniu sie monitora. Jesli przez 2 minuty nie\r
+ nacisniemy zadnego klawisza,to obraz znika i pojawia sie "niebo".Po naci-\r
+ snieciu dowolnego klawisza niebo znika. Zawsze przy nagrywaniu pliku na\r
+ dysk jest tworzona wersja bezpieczenstwa (.BAK)\r
+ \r
+ \r
+ \r
--- /dev/null
+ Ne2Lotek Warszawa 1990 Michal Pakier\r
+\r
+ Program sluzy do zamiany plikow z formatu tworzonego \r
+przez Norton Edytor na format zrozumialy przez edytor srodowiska\r
+loglanowego LOTEK. Norton Edytor zamienia kazde 8 spawcji wystepujacych \r
+po sobie na znak ascii o kodzie 9 . Program Ne2Lotek wykonuje czynnosc\r
+odwrotna.\r
+\r
+ Program wywoluje sie w nastepujacy sposob:\r
+\r
+NE2LOTEK par1\r
+\r
+ par1 - nazwa pliku , ktory ma byc poddany konwersji.\r
+\r
+ Pracujac w srodowisku LOTEK mozna wstawic program Ne2Lotek \r
+do okienka EXECUTE. Wtedy bedziemy mogli uszlachetniac pliki nie wychodzac\r
+z edytora. Robi sie to wpisujac w programie LOTEKINS w opcji tworzenia \r
+okienka w wybranej linii :\r
+\r
+ C Convert NE to LOTEK ³ ne2lotek !\r
+ \r
+ \r
--- /dev/null
+(* Loglanizator Tekstowy wersja 1.0 1990 Warszawa Michal Pakier *)\r
+===============REKORD 1=======================================|===============\r
++ 22\r
+ Obsluga edytora LOglanizator TEKstowy wersja 1.0\r
+ \r
+^v<>.RUCHY KURSORA|O JEDNO SLOWO |F2.NAGRANIE PLIKU NA DYSK\r
+PRZESUWANIE TEKSTU|^>.........W PRAWO|F3.ROZNE OPERACJE PLIKOWE\r
+ O LINIE : |^<..........W LEWO|F4....WYSZUKIWANIE BLEDOW\r
+^U..........W GORE| WZGLEDEM WYZSZEJ|F8....PROGRAMY POMOCNICZE\r
+^D...........W DOL| LINII|F9....KOMPILACJA PROGRAMU\r
+ O STRONE : |^N.........W PRAWO|F10..WLACZANIE/WYLACZANIE\r
+PgDn........W GORE|^P..........W LEWO| WYSWIETLANIA MENU\r
+PgUp.........W DOL|------------------+------+------------------\r
+ZMIANA LINII |^K.......OPERACJE BLOKOWE|Enter...NOWA LINIA\r
+^PgDn.....POCZATEK|^Q.WYSZUKIWANIE I ZAMIANA|^Y.KASOWANIE LINII\r
+ TEKSTU|^J....SKAKANIE PO TEKSCIE|KASOWANIE ZNAKU\r
+^PgUp.......KONIEC|^W.....OPERACJE NA OKNACH|BackSpace...W LEWO\r
+ TEKSTU|^V...........MAKROROZKAZY|Del........W PRAWO\r
+^Home.....POCZATEK|-------------------------+------------------\r
+ OKIENKA|^A....................KASOWANIE LINII W LEWO\r
+^End........KONIEC|^S...................KASOWANIE LINII W PRAWO\r
+ OKIENKA|F1..........ZAWSZE WYJASNIA CO MOZEMY ZROBIC\r
+------------------+--------------------------------------------\r
+Tab......PRZESTAWIA KURSOR POD NASTEPNE SLOWO,PRZESUWA TO CO ZA\r
+^T.........................KASUJE SLOWO WSKAZYWANE PRZEZ KURSOR\r
+===============REKORD 2=======================================|===============\r
++ 11\r
+ INFORMACJA O POSLUGIWANIU SIE HELPEM.\r
+ \r
+ W kazdej sytuacji po nacisnieciu klawisza F1 mozemy otrzymac\r
+informacje o aktualnie dostepnych opcjach. Na wyswietlonym\r
+czesto moze byc wspomniane o mozliwosci uzyskania dokladniej-\r
+szych informacji na podany temat. Uzyskuje sie ja przez nacis-\r
+niecie jednego z klawiszy {0,1,2,3,4,5,6,7,8,9},co jest przed-\r
+stawione na ekranie przez wypisanie nazwy danego klawisza w na-\r
+wiasach trujkatnych.\r
+ Esc opuszczenie helpa\r
+ F1 przejscie do glownego okienka helpa\r
+===============REKORD 3=======================================|===============\r
++ 8 4\r
+ Nagrywanie pliku na dysk (F2,F3S)\r
+ \r
+Moze sie zdarzyc, ze z jakiegos powodu nie mozna nagrac pliku\r
+w katalogu, z ktorego go wgralismy. Wtedy nalezy przejsc (F3 L)\r
+do katalogu,w ktorym mamy wszystkie prawa i tam zgrac nasz plik\r
+opcja F3 W.\r
+ \r
+Aby dowiedziec sie wiecej o operacjach plikowych nacisnij <0>\r
+===============REKORD 4=======================================|===============\r
++ 15 23 3 24 25 26 41\r
+ Operacje plikowe (F3)\r
+ \r
+Przy pomocy znajdujacych sie tu funkcji mozemy wybrac dowolny\r
+plik do edycji.\r
+Mamy do dyspozycji nastepujace funkcje:\r
+ \r
+ L Ladowanie pliku z dysku <0>\r
+ S Nagrywanie pliku na dysk <1>\r
+ N Rozpoczynanie edycji nowego pliku <2>\r
+ W Zmiana nazwy pliku <3>\r
+ P Ostatnio uzywane pliki <4>\r
+ O Rozne opcje <5>\r
+ G Informacje o edytowanych plikach i ilosci\r
+ wolnej pamieci.\r
+ Q Wyjscie z programu\r
+===============REKORD 5=======================================|===============\r
++ 16\r
+ POPRAWIANIE BLEDOW\r
+ \r
+Ta opcja ulatwia poprawianie bledow w programie. W najnizszej\r
+linii pojawia sie numer linii, w ktorej wystapil blad, numer\r
+bledu i krotki opis. Kursor automatycznie ustawia sie w miejscu\r
+wystapinia. Dla niektorych bledow wskazuje dokladnie wiersz\r
+i kolumne,dla innych tylko wiersz i wtedy ustawia sie w pierw-\r
+szej kolumnie. Jesli ustawilismy opcje wyswietlania menu (F10)\r
+to nad linia z opisem bledu pojawia sie sciagawka o sposobie\r
+przegladania bledow.Dostepne sa nastepujace funkcje:\r
+ Ctrl F5 - Przejscie do pierwszego bledu\r
+ Ctrl F6 - Przejscie do ostatniego bledu\r
+ Ctrl F8 - Przejscie do nastepnego bledu\r
+ Ctrl F7 _ Przejscie do poprzedniego bledu\r
+ Ctrl F10 - Koniec poprawiania bledow\r
+Ponowne wcisniecie F4 powoduje wyjscie z opcji.\r
+===============REKORD 6=======================================|===============\r
++ 8\r
+ ZMIANA AKTUALNEGO OKNA\r
+ \r
+ Dzieki tej funkcji mozemy zmienic okienko robocze.\r
+Mamy do wyboru nastepujace funkcje:\r
+ F Kasuje wszystkie inne okienka widoczne na ekranie.\r
+ H Przechodzimy do okienka z baza danych o Loglanie.\r
+ A Przechodzimy do okienka dodatkowego\r
+ M przechodzimy do okienka glownego.\r
+===============REKORD 7=======================================|===============\r
++ 17\r
+ PRZECHODZENIE DO PROGRAMOW POMOCNICZYCH\r
+ \r
+Ta opcja umozliwia wykonywanie pewnych programow, bez wycho-\r
+dzenia z tego prograwu do systemu.To okienko mozemy zdefiniowac\r
+sobie sami w czasie instalacji edytora.Umozliwia ono miedzy\r
+innymi wykonywanie pewnych operacjii na edytowanym pliku(nazwa\r
+pliku jest umieszczana w parametrach wywolanego programu).\r
+Jako jedna z opcji mozna umiescic program LOTEKINS co pozwala\r
+na zmiane tego okienka w trakcie pracy.Wywolanie opcji tego\r
+okienka moze byc umieszczone w makroinstrukcji\r
+(Przyklad: Jesli mamy komputer z dwoma monitorami i zdefiniuje-\r
+my instrukcje:C COLOR (mode co80) i M MONO (mode mono)\r
+to makroinstrukcja <AltH> @8M@5H@5F spowoduje,ze bedziemy mogli\r
+ogladac baze danych na moanitorze z karta Hercules.\r
+ <AltM> @8C@5M@5F spowoduje,ze bedziemy mogli\r
+edytowac plik glowny na ekranie kolorowy(ale baza danych nie\r
+zniknie z ekranu monochromatycznego)\r
+===============REKORD 8=======================================|===============\r
++ 11 36\r
+ KOMPILOWANIE PROGRAMU\r
+ \r
+Tutaj mamy nastepujace opcje:\r
+ L: Pass 1 Pierwszy przebieg kompilacji (program Loglan) tu\r
+ sa miedzy innymi wykrywane popelnione przez nas bledy (F4)\r
+ G: Pass 2 Drugi lub pierwszy i drugi przebieg kompilacji\r
+ (program Gen) tu jest generowany gotowy do wykonania program\r
+ R: Run Wykonywanie programu (lub takze kompilacja).\r
+ D: Debuger Najpierw wykonujemy program,a potem mozemy prze-\r
+ sledzic instrukcja po instrukcji jak przebiegalo to wykonanie\r
+ O: Options<0> Tu ustawia sie rozne opcje zwiazane z kompilacja\r
+===============REKORD 9=======================================|===============\r
++ 17 27 28 29 30 31 32 33 34 35\r
+ OPERACJE BLOKOWE\r
+ \r
+Po nacisnieciu Ctrl_K wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie zrobimy to\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+ \r
+Mamy do dyspozycji nastepujaca funkcje:\r
+ \r
+ K,B,T,L -zaznaczanie bloku <0>\r
+ Y -kasowanie bloku <1>\r
+ C,V -zwyczajne przenoszenie bloku <2>\r
+ S,M -przenoszenie z wyrownywaniem <3>\r
+ R,W -blok z dysku i na dysk <4>\r
+ U,I -przesuwanie bloku <5>\r
+ H -chowanie bloku <6>\r
+ F -blok w ramke <7>\r
+ O -opcje <8>\r
+===============REKORD 10=======================================|===============\r
++ 13 37 38 39 40\r
+ OPERACJE KONTROLOWANEGO PRZEMIESZCZANIA SIE PO TEKSCIE\r
+\r
+Po nacisnieciu Ctrl_J wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie z\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+\r
+Mamy do dyspozycji nastepujace funkcje:\r
+\r
+ S -ustawienie miejsca dla skoku <0>\r
+ R -powrot do ostatnio ustawionego miejsca <1>\r
+ J -skok do ostatnio ustawionego miejsca <2>\r
+ L -skok do podanej linii\r
+ B,K -skoki do poczatku i konca bloku <3>\r
+===============REKORD 11=======================================|===============\r
++ 17 15 16 17 18 19 20\r
+ OPERACJE WYSZUKIWANIA I ZAMIANY SLOW\r
+ \r
+Po nacisnieciu Ctrl_Q wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie zrobimy to\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+\r
+Mamy do dyspozycji nastepujace opcje:\r
+ \r
+ F -znajdz podane slowo <0>\r
+ A -znajdz slowo i zamien je na inne <1>\r
+ C -zamien znaki <2>\r
+ K -zamien slowa kluczowe <3>\r
+ T -znajdz slowo wskazywane przez kursor <4>\r
+ R -znajdz i zamien slowo wskazywane przez kursor <5>\r
+ \r
+UWAGA:Naciskajac Ctrl L mozesz powtorzyc ostatnio wykonywana\r
+ funkcje wyszukiwania i zamiany.\r
+===============REKORD 12=======================================|===============\r
++ 13 14\r
+ SPIS TRESCI WIADOMOSCI O LOGLANIE\r
+ \r
+ Kazda linia jaka widzisz na ekranie oznacza jakis tekst.\r
+Podkreslenie oznacza linie,ktora mozna aktualnie wybrac.\r
+ \r
+ Enter -wybranie aktualnie wskazywanej linii\r
+ kursor w gore -poprzenia linia\r
+ kursor w dol -nastepna linia\r
+ Ctrl PgUp -do poczatku spisu\r
+ Ctrl PgDn -do konca spisu\r
+ PgUp,PgDn -o strone w gore lub w dol\r
+ Tab -wybieranie roznych innych rozdzialow <0>\r
+ Ctrl_Q_F -wyszukiwanie podanego slowa\r
+===============REKORD 13=======================================|===============\r
++ 11 12 14\r
+ TRESC PODROZDZIALU\r
+ \r
+ Enter -powrot do spisu tresci <0>\r
+ Tab -wybieranie roznych innych rozdzialow <1>\r
+ Up,Down,Left,Right -przemieszczanie kursora\r
+ Home,End -do poczatku i konca linii\r
+ Ctrl PgUp -do poczatku tekstu\r
+ Ctrl PgDn -do konca tekstu\r
+ PgUp,PgDn -o strone w gore lub w dol\r
+ Ctrl_K_B,K,L,T -zaznaczanie bloku\r
+ Ctrl_Q_F -wyszukiwanie slowa\r
+===============REKORD 14=======================================|===============\r
++ 9\r
+ WYBOR ROZDZIALU INFORMACJI O LOGLANIE\r
+ \r
+ Na ekranie widzimy okienko z wypisanymi nazwami rozdzialow\r
+jakie z niego mozemy otrzymac.Kursorami w gore i w dol wedru-\r
+jemy po okienku Home i End przenosi nas na poczatek lub koniec.\r
+Enter pozwala wybrac wskazywany rozdzial i odrazu przechodzimy\r
+do niego.Kursorami w lewo i w prawo przechodzimy do sasiednich\r
+okienek z innymi rozdzialami.Esc powoduje powrot do ostatnio\r
+ogladanego rozdzialu.\r
+===============REKORD 15=======================================|===============\r
++ 13\r
+ (F) SZUKANIE SLOWA W TEKSCIE\r
+ \r
+Najpierw podajemy tresc slowa, ktore chcemy znalezc (Find :?).\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+nastepnej pozycji za nim.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n............................Szukanie az do n-tego wystapienie.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+===============REKORD 16=======================================|===============\r
++ 16\r
+ (A) ZAMIANA WYSTAPIEN PODANEGO SLOWA W TEKSCIE\r
+ \r
+Najpierw podajemy tresc slowa, ktore chcemy znalezc. (Find :?)\r
+Potem podajemy na co chcemy zamienic to slowo. (Replace with :?)\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+tym slowia a w najwyzszej linii ekranu pojawia sie pytanie, czy\r
+zamienic to slowo,czy tez nie.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n...............................Zamiana pierwszych n wystapien.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ N...........Zamiana bezwarunkowa (bez pytania za kazdym razem).\r
+===============REKORD 17=======================================|===============\r
++ 11\r
+ (C) ZAMIANA ZNAKOW\r
+ \r
+Ta funkcja umozliwia zamiane duzych liter na male lub odwrotnie\r
+Dzialaja nastepujace opcje :\r
+ D.......................................Zamiana na duze litery.\r
+ S.......................................Zamiana na male litery.\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ C............................Zamiana tylko wewnatrz komentarzy.\r
+ T......................................Zamiana tylko w tekscie.\r
+===============REKORD 18=======================================|===============\r
++ 10\r
+ (K) ZAMIANA SLOW KLUCZOWYCH\r
+ \r
+Ta funkcja umozliwia nam zamiane wszystkich slow kluczowych\r
+jezyka Loglan.\r
+Dzialaja nastepujace opcje :\r
+ D.......................................Zamiana na duze litery.\r
+ S.......................................Zamiana na male litery.\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+===============REKORD 19=======================================|===============\r
++ 12\r
+ (T) SZUKANIE SLOWA WSKAZYWANEGO PRZEZ KURSOR\r
+ \r
+Najpierw podajemy opcje , a potem nastepuje szukanie.\r
+Jesli znaleziono podane slowo to kursor ustawia sie na\r
+nastepnej pozycji za nim.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n............................Szukanie az do n-tego wystapienie.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+===============REKORD 20=======================================|===============\r
++ 15\r
+ (R) SZUKANIE I ZAMIANA SLOWA WSKAZYWANEGO PRZEZ KURSOR\r
+\r
+Najpierw podajemy na co chcemy zamienic to slowo.\r
+W nastepnej kolejnosci czytane sa opcje , a potem nastepuje\r
+szukanie.Jesli znaleziono podane slowo to kursor ustawia sie na\r
+tym slowia a w najwyzszej linii ekranu pojawia sie pytanie, czy\r
+zamienic to slowo,czy tez nie.\r
+Dzialaja nastepujace opcje :\r
+ G.........Szukanie rozpocznie sie na poczatku lub koncu tekstu.\r
+ B.........................................Przeszukiwanie w tyl.\r
+ n...............................Zamiana pierwszych n wystapien.\r
+ U...........................Utozsamianie duzych i malych liter.\r
+ W.........................................Szukanie calych slow.\r
+ L.........................Szukanie wewnatrz zaznaczonego bloku.\r
+ N...........Zamiana bezwarunkowa (bez pytania za kazdym razem).\r
+===============REKORD 21=======================================|===============\r
++ 13 29 30\r
+ OPERACJE WYMIANY BLOKOW MIEDZY OKNAMI TEKSTOWYMI I INNE\r
+ \r
+Po nacisnieciu Ctrl_W wybieramy klawisz odpowiadajacy intere-\r
+sujacej nas funkcji.Jesli przez 2 sek. tego nie z\r
+pojawi sie ramka z wypisanymi wszystkimi opcjami.\r
+\r
+Mamy do dyspozycji nastepujace funkcje:\r
+ C -przekopiowanie bloku z drugiego widocznego na ekranie okna\r
+ V -przeniesienie bloku z drugiego widocznego na ekranie okna\r
+ S -przekopiowanie z przesunieciem z drugiego okna\r
+ M -przeniesienie z przesunieciem z drugiego okna\r
+ \r
+Patrz C,V <0> S,M <1>\r
+===============REKORD 22=======================================|===============\r
++ 19\r
+ DEFINIOWANIE MAKROROZKAZOW\r
+ \r
+Kazdemu klawiszowi odpowiadajacemu literze,cyfrze lub klawiszo-\r
+wi funkcyjnemu mozemy przyporzadkowac makroinstrukcje.\r
+Makroinstrukcje sa uruchamiane przez jednoczesne nacisniecie Alt\r
+i odpowiedniego klawisza.\r
+W definicji makrorozkazu moga wystapic oprucz zwyczajnych znakow\r
+ASCII zastepujace symbole:\r
+ ^.............Oznacza Ctrl + nastepny klawisz (A..Z oraz 0..9)\r
+ &..............Oznacza Alt + nastepny klawisz (A..Z oraz 0..9)\r
+ @........Oznacza klawisz funkcyjny.Nastepnym znakiem moze byc:\r
+ 1..0 - F1..F10 ³ <>^v - kursor ³ H - Home ³ E - End ³\r
+ U - PgUp ³ D - PgDn ³ I - Insert ³ L - Delete ³\r
+ S - Esc ³ B - Backspace ³ ³ ³\r
+ C - Enter ³ ³ ³ ³\r
+ #..Nastepny znak po ty nie jest interpretowany np.## oznacza #\r
+Nawiasy klamrowe oznaczaja powtorzenie ich zawartosci pewna\r
+liczbe razy . Np. {^C(* *)}12 spowoduje utworzenie 12 nowych\r
+linii zawierajacych napis "(* *)"\r
+===============REKORD 23=======================================|===============\r
++ 17\r
+ (L) WGRYWANIE PLIKU Z DYSKU\r
+ \r
+Pojawia sie okienko,w ktorym mozemy podac nazwe pliku,lub maske\r
+opisujaca grupe plikow. Jezeli podamy nazwe to dany plik jest\r
+wgrywany ( jesli nie istnieje to rozpoczynamy jego edycje ).\r
+Jezeli podamy maske to pojawiaja sie wszystkie odpowiadajace\r
+jej nazwy plikow oraz podkatalogow.\r
+>>>Mamy dostepne nastepujace klawisze:\r
+ Esc.........Powrot,bez wczytania pliku.Zostajemy w aktualnie\r
+ ustawionym podkatalogu.\r
+ \18 \19 < >......................Przemieszczanie sie po okienku.\r
+ Enter.........Jesli wskazywana jest nazwa pliku to dany plik\r
+ jest wczytywany i mozemy rozpoczac jego edycje.\r
+ Jezeli wskazywany jest podkatalog to jest on\r
+ dodawany do aktualnej sciezki.\r
+ PgUp,PgDn......Przejscie do poprzedniej lub nastepnej strony\r
+ (w okienku miesci sie tylko 20 nazw).\r
+===============REKORD 24=======================================|===============\r
++ 5\r
+ (N) ROZPOCZECIE EDYCJI NOWEGO PLIKU\r
+ \r
+Czysci bufor tekstu i rozpoczyna edycje pliku o domyslnej\r
+nazwie NONAME.LOG .Przy nagrywaniu na dysk program bedzie pro-\r
+ponowal zmiane tej nazwy na inna.\r
+===============REKORD 25=======================================|===============\r
++ 8\r
+ (W) ZMIANA NAZWY AKTUALNEGO PLIKU\r
+ \r
+Zmienia nazwe aktualnie edytowanego pliku i nagrywa go na dysk\r
+w aktualnym katalogu (ustawianie aktualnego katalogu funkcja L)\r
+Jesli byl juz plik o takiej nazwie to pyta, czy go skasowac\r
+UWAGA: Mozemy podac od razu nazwe nowego pliku lub maske\r
+i wtedy zastepujemy aktualnie edytowanym plikiem jakis juz\r
+istiejacy na dysku (Wybieranie tak jak w opcji L).\r
+===============REKORD 26=======================================|===============\r
++ 4\r
+ (P) OSTATNIO UZYWANE PLIKI\r
+ \r
+Pojawia sie okienko z ostatnio wgrywanymi plikami ponumerowanymi\r
+od 0 do 9 mozemy wybrac jakis plik lub przejsc do opcji Load (L)\r
+===============REKORD 27=======================================|===============\r
++ 6\r
+ ZAZNACZANIE BLOKU\r
+ \r
+ B -zaznaczenie poczatku bloku\r
+ K -zaznaczenie konca bloku\r
+ T -zaznaczenie slowa,na ktorym stoi kursor jako bloku\r
+ L -zaznaczenie linii,na ktorej stoi kursor jako bloku\r
+===============REKORD 28=======================================|===============\r
++ 3\r
+ KASOWANIE ZAZNACZONEGO BLOKU\r
+ \r
+ Jezeli zaznaczyles blok to mozesz go skasowac.\r
+===============REKORD 29=======================================|===============\r
++ 15 30\r
+ (C,V) KOPIOWANIE LUB PRZENOSZENIE ZAZNACZONEGO BLOKU\r
+ \r
+ Funkcja.C.kopiuje zaznaczony przez nas blok (Ctrl K + B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+Pierwsza linia bloku bedzie przesunieta tak , aby jej poczatek\r
+znajdowal sie w pozycji kursora natomiast pozostale linie nie\r
+zostana przesuniete.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+ Funkcja.V.przenosi zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+W poprzednim miejscu blok bedzie skasowany.\r
+Pierwsza linia bloku bedzie przesunieta tak , aby jej poczatek\r
+znajdowal sie w pozycji kursora natomiast pozostale linie nie\r
+zostana przesuniete.\r
+ ----> Ctrl K S,M <0>\r
+===============REKORD 30=======================================|===============\r
++ 18 29\r
+ (S) KOPIOWANIE LUB PRZENOSZENIE BLOKU Z WYROWNYWANIEM\r
+ \r
+ Funkcja.S. kopiuje zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+Jest jednak inna niz funkcja Ctrl K C.\r
+Wszystkie linie bloku zostana przesuniete tak,aby poczatek\r
+pierwszej linii znajdowal sie w pozycji kursora.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+ Funkcja.M.przenosi zaznaczony przez nas blok (Ctrl K+ B,K,T,L)\r
+do miejsca w tekscie rozpoczynajacego sie pozycja kursora.\r
+W poprzednim miejscu blok bedzie skasowany.\r
+Jest jednak inna niz funkcja Ctrl K M.\r
+Wszystkie linie bloku zostana przesuniete tak,aby poczatek\r
+pierwszej linii znajdowal sie w pozycji kursora.\r
+UWAGA:Mozna przenosic blok do wnetrza jego samego.\r
+W tym przypadku spowoduje to, ze blok nie przesunie sie w pionie\r
+tylko w poziomie.Jego poczatek ustawi sie w kolumnie kursora.\r
+ -----> Ctrl K C,V <0>\r
+===============REKORD 31=======================================|===============\r
++ 10 23\r
+ (R,W) WCZYTANIE I ZGRYWANIE BLOKU Z DYSKU\r
+ \r
+ Funkcja.R. umozliwia dolaczenie do naszego tekstu dowolnego\r
+pliku z dysku.Plik jest dolaczany w miejscu wskazywanym przez\r
+kursor,bez wyrownywania (tak jak Ctrl K C).\r
+Pojawia sie okienko,w ktorym mozemy podac nazwe zbioru lub maske\r
+i wtedy wybieramy odpowiedni plik tak jak w funkcji F3 L <0>\r
+ Funkcja.W. umozliwia zgranie zaznaczonego bloku na dysk.\r
+Pojawia sie okienko,w ktorym mozemy podac nazwe zbioru lub maske\r
+i wtedy wybieramy odpowiedni plik tak jak w funkcji F3 L <0>\r
+===============REKORD 32=======================================|===============\r
++ 8\r
+ (I,U) PRZESUNIECIE BLOKU O JEDEN ZNAK W PRAWO LUB W LEWO\r
+ \r
+ Funkcja.I. przesuwa wszystkie linie zawierajace blok o jeden\r
+znak w prawo.Przesuwane jest takze to co jest przed blokiem\r
+w pierwszej linii bloku oraz za blokiem w ostatniej linii bloku\r
+ Funkcja.U. przesuwa wszystkie linie zawierajace blok o jeden\r
+znak w lewo.Przesuwane jest takze to co jest przed blokiem\r
+w pierwszej linii bloku oraz za blokiem w ostatniej linii bloku\r
+===============REKORD 33=======================================|===============\r
++ 5\r
+ CHOWANIE ZAZNACZONEGO BLOKU\r
+ \r
+ Wybranie tej funkcji powoduje,ze blok staje sie niewidoczny.\r
+Ponowne jej wybranie ustawia blok taki,jaki byl przed zaslo-\r
+nieciem.\r
+===============REKORD 34=======================================|===============\r
++ 6 35\r
+ (F) TWORZENIE RAMKI\r
+ \r
+ Dookola linii zawierajacych blok tworzona jest ramka.\r
+W opcjach mozemy sobie ustawic wszelkie mozliwe parametry\r
+ramki.\r
+ -----> Ctrl K O <0>\r
+===============REKORD 35=======================================|===============\r
++ 19\r
+ (O) ROZNE CIEKAWE PARAMETRY\r
+ \r
+Te opcje dotycza przede wszystkim ksztaltu ramki ale nie tylko\r
+ 3 nastepne linie to wzor ramki.\r
+ - lewy gorny , srodkowy gorny , prawy gorny\r
+ - lewy , srodkowy , prawy\r
+ - lewy dolny , srodkowy dolny , prawy dolny\r
+ F.......................................Pierwsza kolumna ramki.\r
+ - musi byc z przedzialu 0..255\r
+ - musi byc mniejsza niz ostatnia kolumna ramki\r
+ - 0 ma specjalne znaczenie : ramka zacznie sie tam,gdzie\r
+ zaczyna sie zaznaczony tekst.\r
+ L.......................................Ostatnia kolumna ramki.\r
+ - musi byc z przedzialu 0..255\r
+ - musi byc wieksza niz pierwsza kolumna ramki\r
+ - 0 ma specjalne znaczenie : ramka zkonczy sie tam,gdzie\r
+ zaczyna sie zaznaczony tekst.\r
+ T.....Wyrownywanie tekstu w ramce.Moze o n byc z lewej,z prawej\r
+ lub w srodku ramki.\r
+===============REKORD 36=======================================|===============\r
++ 14\r
+ OPCJE DLA KOMPILACJI\r
+ \r
+Tu mozna wplynac na pewne parametry kompilacji i wykonywania\r
+programu.\r
+D: Debug info on/off Wlaczenie powoduje,ze przy wykonywaniu\r
+ programu na specjalny plik sa wyprowadzane numery kolejno\r
+ wykonywanych instrukcji.Zwalnia to wykonywanie programu ale\r
+ umozliwia jego puzniejsze przesledzenie (patrz opcja DEBUGER)\r
+M: Memory ______ Jest to podzielona przez 4 ilosc\r
+ pamieci zarezerwowana dla naszego programu.Moze ona przyjac\r
+ wartosc od 16384 do 100000. Korzystnie jest ustawiac 16384\r
+ bo wtedy program szybciej sie wykonuje.\r
+C: Cursor on/off Jest to opcja dla koneserow.Wlaczenie\r
+ jej powoduje,ze na czas wykonywania programu znika kursor\r
+===============REKORD 37=======================================|===============\r
++ 4\r
+ (S) ZAZNACZANIE POZYCJI DLA SKOKOW\r
+ \r
+Ta funkcja zapamietuje aktualna pozycje kursora i umozliwia\r
+wykonanie w przyszlosci skoku do tego miejsca.\r
+===============REKORD 38=======================================|===============\r
++ 5\r
+ (R) POWROT DO ZAZNACZONEGO WCZESNIEJ MIEJSCA\r
+ \r
+Podobnie jak Ctrl J J skacze do zaznaczonego wczesniej miejsca\r
+z ta roznica,ze zanim skoczy zaznacza aktualna pozycje tak , aby\r
+potem mozna bylo do niej wrocic opcjami Ctrl J J/R.\r
+===============REKORD 39=======================================|===============\r
++ 4\r
+ (J) SKOK DO ZAZNACZONEGO PRZEDTEM MIEJSCA W TEKSCIE\r
+ \r
+Kursor jest przenoszony do miejsca,ktore wczesniej zaznaczylismy\r
+opcja Ctrl J S\r
+===============REKORD 40=======================================|===============\r
++ 4\r
+ SKOKI DO BLOKU\r
+ \r
+ B -skok do poczatku zaznaczonego bloku\r
+ K -skok do konca zaznaczonego bloku\r
+===============REKORD 41=======================================|===============\r
++ 20\r
+ OPCJE PLIKOWE (F3O)\r
+ \r
+Tutaj mozemy ustawiac rozne opcje wplywajace na dzialanie prog-\r
+ramu.\r
+ S..Jest to numer linii bedacej granica miedzy okienkami\r
+ (np. miedzy plikiem glownym i dodatkowym lub plikiem glownym\r
+ i baza danych)\r
+ B..Czy maja byc robione kopie bezpiczenstwa plikow.\r
+ Jesli jest wlaczone,to przy kazdym nagraniu pliku na dysk\r
+ poprzednia wersja tego pliku nie jest kasowana tylko dosta-\r
+ je rozszerzenie BAK\r
+ D..Opuznienie odswierzania ekranu.\r
+ Jesli przez jakis czas (ustawiony w tym miejscu) nie zosta-\r
+ nie wcisniety zaden klawisz to na ekranie pojawia sie mru-\r
+ gajace niebo.\r
+ W..Opuznienie pojawiania sie okienek.\r
+ Po wybraniu funkcji edytora pojawia sie najpierw sam naglo-\r
+ a dopiero po pewnym czasie jesli nie wybierzemy zadnej\r
+ opcji okienko menu.Tutaj mamy mozliwosc ustawic czas,jaki\r
+ minie od pojawienia sie naglowka do wyswietlenia okienka.\r
+=============KONIEC============================================|==============\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+\1a
\ No newline at end of file
--- /dev/null
+c:\loglan\lotek\\r
+c:\loglan\lotek\\r
+LOGHELP.MPH\r
++ N Norton Commander \r
++ C Compile \r
++ S Second Pass \r
++ R Run (execute) \r
+nc\r
+C:\loglan\exe\loglan !\r
+ c:\loglan\exe\cgen ! \r
+c:\loglan\exe\int !\r
+\r
+Plik instalacyjny edytora LOTEK\r
+Pierwsza linia jest nazwa katalogu,w ktorym znajduja sie programy:\r
+Lotek.hlp,MPLOGED.exe,lsttest.exe\r
+Druga linia jest nazwa katalogu,w ktorym znajduja sie programy:\r
+prep.exe,logdeb.exe\r
+Trzecia linia jest dokladna nazwa pliku z baza danych (*.hlp)\r
+UWAGA:Trzecia linia musi byc duzymi literami\r
+Nastepne linie sa kolejnymi liniami okienka EXEC\r
+Zaczynaja sie one znakiem +\r
+Trzeci znak w kazdej z tych linii to znak,ktorego nacisniecie bedzie\r
+wywolywac dana funkcje\r
+Po liniach z plusem wystepuja kolejno instrucje jakie maja byc\r
+wykonane po wybraniu tych funkcji.W kazdej z tych linii wykrzyknik\r
+bedzie zastapiony nazwa aktualnie edytowanego pliku\r
--- /dev/null
+ \r
+ Uwagi o uzytkowaniu programu LOTEK.\r
+ ----------------------------------\r
+ Program wywolujemy uruchamiajac program lotek.exe.(wczesniej musimy w danym\r
+podkatalogu dokonac instalacji lotekins.exe).\r
+ \r
+Do dzialania calego srodowiska loglanu potrzebne sa:\r
+ \r
+ loglan,hgen,cgen,int,hint - kompilator loglanu.Musza byc widoczne tak,jakby\r
+ byly w aktualnym katalogu.\r
+ \r
+ MPloged.exe,lsttest.exe,lotek.hlp - pliki srodowiska ,musza byc w jednym\r
+ podkatalogu.\r
+ \r
+ prep.exe,logdeb.exe - debuger,musza byc w jednym podkatalogu\r
+ \r
+ logrprt.hlp,loghlp.str - baza danych o loglanie,musza byc\r
+ w jednym katalogu\r
+ report.hlp - tekst raportu loglanu.Jest uzywany w bazie danych.\r
+ Musi znajdowac sie na dysku(ten egzemplarz,ktory\r
+ dolaczylem,poniewarz nie ma on niektorych linii\r
+ i uzywanie innego pliku z raportem spowoduje ble-\r
+ dne dzialanie bazy danych)\r
+ \r
+ lotek.exe - musi byc widoczny (ten program zarzadza wszystkimi\r
+ innymi).\r
+ lotek.pth - ten plik jest generowany podczas instalacji(lotekins).Musi on\r
+ byc w kazdym katalogu,z ktorego uruchamiamy program\r
+ \r
+W trakcie pracy generowane sa w aktualnym katalogu dwa pliki:\r
+ praca.bat - jest to plik pomocniczy i mozna na niego nie zwracac uwagi.\r
+ mpled.dat - tu jest zapisany aktualny stan programu.Nie nalezy tego pliku\r
+ kasowac,jesli chce sie w przyszlosci kontynuowac przerwana\r
+ prace\r
+ \r
+Dolaczona baza danych jest tylko przykladowa.Maksymalna wersja moze miec 6\r
+okienek po 22 linii (ta ma 1 okienko z 1 linia) i moze zarzadzac danymi\r
+ze 132 plikow tekstowych dowolnej wielkosci.(Jednoczesnie w pamieci siedzi\r
+tylko to co widac na ekranie).\r
+ \r
+Przyklady makroinstrukcji\r
+ \r
+begin@C@^@E{@<}5@vend; -wpisanie begin'a i w linii nizej end'a\r
+ \r
+(**)@<@< -narysowanie komentarza i ustawienie w srodku\r
+ kursora.\r
+ \r
+@H(*{*}74*} -wstawienie linii oddzielajacej z gwiazdek\r
+ \r
+^KT^QCdl@C^KK^KB -zamienienie slowa wskazywanego przez kursor\r
+ na duze litery.\r
+ \r
+ \r
+ \r
+ \r
+ \r
--- /dev/null
+ @echo off\r
+cd C:\LOGLAN\LOTEK\r
+c:\loglan\lotek\lsttest LISTFI3.LOG p\r
+loglan LISTFI3.LOG >LISTFI3.err\r
+c:\loglan\lotek\lsttest LISTFI3.LOG l\r
+if errorlevel 1 goto koniec\r
+c:\loglan\lotek\lsttest LISTFI3.LOG p\r
+c:\loglan\lotek\lsttest LISTFI3.LOG c\r
+cgen LISTFI3 >nul\r
+c:\loglan\lotek\lsttest LISTFI3.LOG s\r
+c:\loglan\lotek\lsttest wycurs r\r
+int LISTFI3.LOG\r
+pause\r
+:koniec\r
+cd C:\LOGLAN\LOTEK\r
--- /dev/null
+@echo off\r
+cd C:\LOGLAN\LOTEK\r
--- /dev/null
+1\r
+ \r
+ \r
+ INSTITUTE OF INFORMATICS, UNIVERSITY OF WARSAW\r
+ \r
+ \r
+ \r
+ \r
+ REPORT ON THE\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ # ###### ###### # ###### # # #### ####\r
+ # # # # # # # ## # # # # #\r
+ # # # # # # # # # # #### #\r
+ # # # # ## # ###### # # # # # #\r
+ # # # # # # # # # ## # # #\r
+ ###### ###### ###### ###### # # # # #### ######\r
+ \r
+ \r
+ \r
+ \r
+ PROGRAMMING LANGUAGE (*)\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ W.M.BARTOL, P.GBURZYNSKI, P.FINDEISEN, A.KRECZMAR, M.LAO, A.LITWINIUK\r
+ \r
+ T.MULDNER, W.NYKOWSKI, H.OKTABA, A.SALWICKI, D.SZCZEPANSKA-WASERSZTRUM\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ ---------------------------------------------------------\r
+ (*) Supported in part by Zjednoczenie "MERA", POLAND\r
+ \r
+ \r
+ \r
+1\r
+ \r
+ \r
+ FOREWORD\r
+ --------\r
+ \r
+ \r
+ \r
+ We submit to the reader the report of a language whose design is still in\r
+ progress. Therefore any remarks and comments are very desirable. They can\r
+ be sent to:\r
+ \r
+ \r
+ UNIVERSITY OF WARSAW\r
+ INSTITUTE OF INFORMATICS\r
+ PKIN 8TH FLOOR\r
+ 00-901 WARSAW\r
+ POLAND\r
+ \7f\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ The edition has been produced by using the editor program (prepared by\r
+ P.Gburzynski, University of Warsaw) on minicomputer MERA 400. This original\r
+ Polish minicomputer was used for the first implementation of LOGLAN-82.\r
+ \r
+ \r
+ \r
+ Warszawa, June, 1982\r
+1 - 1 -\r
+ \r
+ \r
+ CONTENTS.\r
+ #########\r
+ \r
+ List of symbols...................................................3\r
+ \r
+ 1. Preface........................................................4\r
+ \r
+ 2. The basic characteristics of LOGLAN-82.........................8\r
+ 2.1. Control structure.........................................8\r
+ 2.2. Block structure...........................................11\r
+ 2.3. Procedures and functions..................................13\r
+ 2.4. Classes...................................................14\r
+ 2.5. Prefixing.................................................15\r
+ 2.6. Object deallocator........................................17\r
+ 2.7. Arrays....................................................18\r
+ 2.8. Parameters................................................19\r
+ 2.9. Coroutines................................................20\r
+ 2.10. Processes.................................................21\r
+ 2.11. Other important features..................................22\r
+ \r
+ 3. Lexical and textual structure..................................23\r
+ \r
+ 4. Types..........................................................26\r
+ 4.1. Primitive types............................................27\r
+ 4.2. System types...............................................28\r
+ 4.3. Compound types and objects.................................29\r
+ 4.3.1. Array type.............................................29\r
+ 4.3.2. Class type.............................................30\r
+ 4.4. Formal types...............................................30\r
+ \r
+ 5.Declarations....................................................31\r
+ 5.1. Constant declaration.......................................31\r
+ 5.2. Variable declaration.......................................32\r
+ 5.3. Unit declaration...........................................33\r
+ 5.3.1. Class declaration (introduction).......................33\r
+ 5.3.2. Subprogram declaration (introduction)..................34\r
+ 5.3.3. Block..................................................35\r
+ 5.3.4. Prefixing..............................................36\r
+ 5.3.5. Formal parameters......................................37\r
+ 5.3.6. Unit body..............................................40\r
+ \r
+ 6. Static and dynamic locations . Visibility rules................42\r
+ 6.1. Unit attributes............................................42\r
+ 6.2. Protected attributes.......................................43\r
+ 6.2.1. Hidden attributes......................................43\r
+ 6.2.2. Taken attributes.......................................44\r
+ 6.2.3. Legal and illegal identifiers .........................44\r
+ 6.2.4. Close attributes.......................................45\r
+ 6.3. Static location............................................46\r
+ 6.4. Objects....................................................48\r
+ 6.4.1.ements..........................................71\r
+ 9.1. Sequential primitive statements............................71\r
+ 9.1.1. Evaluation statement...................................72\r
+ 9.1.2. Configuration statement................................75\r
+ 9.1.2.1. Allocation statement...............................75\r
+ 9.1.2.2. Deallocation statement.............................83\r
+ 9.1.3. Simple control statement...............................84\r
+ 9.1.4. Coroutine statement....................................86\r
+ 9.2. Compound statements.......................................87\r
+ 9.2.1. Conditional statement..................................87\r
+ 9.2.2. Case statement.........................................89\r
+1 - 2 -\r
+ \r
+ \r
+ 9.2.3. Iteration statement....................................90\r
+ \r
+ 10. Exception handling............................................96\r
+ 10.1. Signal specification.......................................96\r
+ 10.2. Signal handlers............................................97\r
+ 10.3. Signal raising.............................................98\r
+ 10.4. Handler execution.........................................101\r
+ 10.5. System signals............................................103\r
+ \r
+ 11. Processes....................................................104\r
+ 11.1. Transition state statement...............................106\r
+ 11.2. Primitive synchronizing statement........................109\r
+ 11.3. Monitors (compound synchronization facilities)...........112\r
+ \r
+ 12. Separate compilation of units................................115\r
+ 12.1. Library items............................................117\r
+ 12.1.1. Interface............................................118\r
+ 12.1.2. Using languages......................................121\r
+ 12.1.3. Using externals......................................122\r
+ 12.1.4. Using sl-virtuals....................................122\r
+ 12.2. Linking library items....................................123\r
+ 12.2.1. Connecting the interface.............................123\r
+ 12.3. Binary items.............................................126\r
+ 12.4. Processing libraries.....................................127\r
+ 12.4.1. Recompilation........................................127\r
+ 12.4.2. Insertions and deletions.............................128\r
+ \r
+ 13. File processing..............................................129\r
+ 13.1. External and internal files..............................129\r
+ 13.2. File generation and deallocation.........................130\r
+ 13.3. Binary input-output......................................132\r
+ 13.4. Other predefined operations..............................133\r
+ 13.5. Text input-output........................................134\r
+ 13.6. Example of high-level file processing....................136\r
+ \r
+ Bibliography.....................................................137\r
+ Index............................................................139\r
+1 - 3 -\r
+ \r
+ \r
+ List of symbols\r
+ ***************\r
+ \r
+ \r
+ \r
+ We shall use the following symbols (with indices if necessary):\r
+ \r
+ A - arithmetic expression,\r
+ B - boolean expression,\r
+ C - character expression,\r
+ D - string expression,\r
+ E - arbitrary expression,\r
+ F - function/procedure,\r
+ G, H - statement (or sequence of statements),\r
+ i, j, k, l, u - integer variable or index,\r
+ M, N, P, R, S, T - type or unit identifier,\r
+ O - object,\r
+ Q - constant,\r
+ V - valuation,\r
+ W - arbitrary identifier,\r
+ X - object expression,\r
+ Y - arbitrary variable,\r
+ Z - simple variable,\r
+ Pf - formal parameter,\r
+ Pa - actual parameter,\r
+ VE - the value of an expression E.\r
+1 - 4 -\r
+ \r
+ \r
+ 1. PREFACE\r
+ ###########\r
+ \r
+ LOGLAN-82 #) is a universal programming language designed at the\r
+ Institute of Informatics, University of Warsaw. The shortest, informal\r
+ characterization of the language would read as follows. LOGLAN-82 belongs\r
+ to the Algol family of programming languages. Its syntax, however, is\r
+ patterned upon Pascal's. Many ideas are borrowed from SIMULA-67 [3]. The\r
+ language includes also some modern facilities such as concurrency and\r
+ exception handling.\r
+ \r
+ The characteristic programming constructs and facilities of the language\r
+ are as follows:\r
+ \r
+ - a convenient set of structured statements,\r
+ - block structure,\r
+ - procedures an functions,\r
+ - classes,\r
+ - prefixing,\r
+ - programmed deallocation,\r
+ - adjustable arrays,\r
+ - formal types and formal procedures,\r
+ - coroutines,\r
+ - processes,\r
+ - encapsulation techniques,\r
+ - exception handling,\r
+ - separate compilation techniques,\r
+ - file processing.\r
+ \r
+ \r
+ LOGLAN-82 history\r
+ -----------------\r
+ \r
+ In the early seventies the Institute of Mathematical Machines "MERA"\r
+ (with two members of the present team of authors) and the Institute of\r
+ Informatics of Warsaw University initiated the design of a new high level\r
+ programming language. There were two main inspirations for taking up this\r
+ research. First the awareness that the SIMULA 67 programming language was a\r
+ substantial contribution to the software methodology and second that the\r
+ fast development of multiprocessor hardware will change the software\r
+ practice.\r
+ We began our work with analytical studies, seminars and lectures dealing\r
+ with the basic constructs and features of the known programming languages.\r
+ This helped us to establish the goals a new programming language should\r
+ reach. By then, however, we decided that the design of the programming\r
+ language would be a component of a broader software project, called LOGLAN.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ -------------------------------------------------------------------------\r
+ #) Recently we received information about another LOGLAN - an\r
+ esperanto-like language developed in US.\r
+1 - 5 -\r
+ \r
+ \r
+ There is no doubt that the environment in which our investigations have\r
+ been carried out has shed a new light on these goals. In particular, the\r
+ experience accumulated by a big part of our team in the field of\r
+ Algorithmic Logic [15] influenced the form of the solutions accepted.\r
+ The first step of our work was finished in 1977 with the report on the\r
+ LOGLAN programming language [12]. The report provides a general outline of\r
+ a universal programming language. Among its most important features let us\r
+ mention a new approach to arrays, assignments, parameter transmission and\r
+ parallel computations. This version was not implemented. It constituted the\r
+ base for the agreement between the University of Warsaw and the State\r
+ Industrial Trust MERA, signed a year later.\r
+ A careful analysis of the constructs suggested in the primary project\r
+ preceded an actual implementation. With the intention of attaining this,\r
+ the interpreter of the language was designed. At that stage a number of\r
+ important modifications were introduced to the proposed outline. They\r
+ resulted from experiments with the interpreter which proved the usefulness\r
+ of some constructs and the uselessness of some others.\r
+ At the next stage of research the language was implemented on the\r
+ original Polish two-processor minicomputer MERA 400. The design was\r
+ restricted in several points because of the implementation constraints.\r
+ Some constructs were rejected, the decision concerning some others was put\r
+ off until a more elaborate analysis was carried out.\r
+ The experience of the team in the field of abstract data types and\r
+ computational complexity helped us to solve one of the most fundamental\r
+ implementation problems - a proper structure for secure and fast storage\r
+ management. In consequence, the language is furnished with a programmed\r
+ deallocator which allows the user to design the best strategy of storage\r
+ management at run time.\r
+ The implementation of unrestricted prefixing needed a completely new\r
+ approach. The well-known mechanisms like Dijkstra's display do not allow us\r
+ to release the SIMULA restrictions (the most important forbids the use\r
+ prefixing at different levels of unit nesting). Such a solution was found\r
+ and the LOGLAN-82 users may apply prefixing at an arbitrary level of unit\r
+ nesting.\r
+ Of the results we have obtained so far let us mention paper [1], which\r
+ deals with the principles of an efficient implementation of programming\r
+ languages with prefixing at many levels. The paper introduces the\r
+ generalized display mechanism and proves the correctness of an\r
+ update-display algorithm. A new data structure for efficient and secure\r
+ storage management is also provided.\r
+ Paper [2] deals with the design and implementation of class Simulation\r
+ (improving that provided in SIMULA 67).\r
+ The concurency problems are described in the special mathematical model\r
+ [19]. The correctness of the monitor implementation is proved in [20]. The\r
+ semantics of an assignment statement for subscripted variables is defined\r
+ and carefully examined in [21]. Paper [16] describes the semantics of\r
+ allocation, deallocation and control statements.\r
+ A comprehensive survey about LOGLAN-82 and its applications is supplied\r
+ in [8]. Let us mention the close connections between the development of the\r
+ language itself and of Algorithmic Logic, see [15, 22, 23, 24, 25, 26].\r
+1 - 6 -\r
+ \r
+ \r
+ LOGLAN-82 high points\r
+ ---------------------\r
+ \r
+ \r
+ - An orderly and intellectually manageable fashion of program design.\r
+ \r
+ - Clean, modular extensibility (by means of the above mentioned\r
+ facilities, in particular by prefixing). An algorithm employing an\r
+ abstract data structure can be prefixed by a class realizing that\r
+ structure. The class may be programmed by the user himself or by\r
+ another user, taken from the system library etc. In this way,\r
+ programs may be developed by teams of programmers.\r
+ \r
+ - An environment for distributed and safe development of large\r
+ programs and systems with easy inter-communication between members\r
+ of software teams, i.e., different parts of the design are easy to\r
+ read, check and modify. The modifications do not entail unexpected\r
+ interactions.\r
+ \r
+ - Possibility of systematic debugging in a way which contributes to\r
+ confidence in the overall program correctness.\r
+ \r
+ - The separate compilation facility.\r
+ \r
+ - Type checking, especially of references to objects, which\r
+ substantially reduces the need for run-time checks and increases the\r
+ safety of handling pointers.\r
+ \r
+ - Efficient storage management by means of well-tailored allocation/\r
+ deallocation operations.\r
+ \r
+ - Clear visibility rules with the capability of unit encapsulation\r
+ techniques.\r
+ \r
+ - Concurrent computations in which several processes are\r
+ simultaneously and independently executed by any number of\r
+ processors. The concurrent multiprocessor computations were treated\r
+ with due care. We reached the necessary foundations for the\r
+ description of atomic operations for the concurrent statements. The\r
+ atomic operations may be efficiently implemented in any operating\r
+ system kernel. It is well known that concurrent computations have to\r
+ be synchronized and scheduled. We do not prejudge which facilities\r
+ are to be used for those purposes. In LOGLAN-82 all known\r
+ synchronization methods may be declared as predefined classes. For\r
+ example, let us mention that it is possible to define:\r
+ \r
+ - monitoring dialect similar to CONCURRENT PASCAL,\r
+ cf.[5], with the main notions: process, monitor, entry\r
+ procedure, delay, continue,\r
+ - tasking dialect similar to ADA's tasks, cf.[11], with\r
+ the main notions: task, accept, select, rendez-vous.\r
+ \r
+1 - 7 -\r
+ \r
+ \r
+ First implementation of LOGLAN-82\r
+ ---------------------------------\r
+ \r
+ \r
+ The first implementation of the language was finished in December 1981 on\r
+ the two processors Polish minicomputer MERA-400 (uni-bus architecture). The\r
+ whole compiler was programmed in FORTRAN IV Standard. The run-time system\r
+ and file processing were coded in the Mera Assembly Language GASS.\r
+ The implementation team was headed by Antoni Kreczmar (who is the author\r
+ of Running System) and included Pawel Gburzynski (File Processing), Marek\r
+ Lao (Semantic Analysis), Andrzej Litwiniuk (Code Generation), Wojtek\r
+ Nykowski (Parsing) and Danuta Szczepanska-Wasersztrum (Static Semantics).\r
+ \r
+ \r
+ \r
+ \r
+ Further work on LOGLAN-82\r
+ -------------------------\r
+ \r
+ Although we are convinced that LOGLAN-82 will prove to be useful for an\r
+ average user, we would like to stress that we were interested mainly in\r
+ finding answers to research questions. Our approach is more scientific than\r
+ commercial.\r
+ Among the studies that are planned for the nearest future, let us mention\r
+ further research on LOGLAN-82 itself and on its first compiler. The\r
+ portability of the compiler seems to be the main target of our team.\r
+ Moreover, LOGLAN-82 will be used in several applications. In this way the\r
+ language will be verified and its usefulness will be analyzed. We are\r
+ convinced that the new computer architecture and multiprocessor environment\r
+ should be taken into account. Therefore, we plan studies which could\r
+ support an efficient implementation of the language with richer semantics\r
+ are planned. It seems that the crucial point of the future hardware would\r
+ be the efficient implementation of the storage management.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ Acknowledgments\r
+ ---------------\r
+ \r
+ \r
+ We wish to express our gratitude to all institutions and persons who\r
+ supported us materially or morally. Thanks are due to the State Industrial\r
+ Trust "MERA" and to its deputy director A.Janicki for the arrangements that\r
+ enabled us to realize the LOGLAN-82 project.\r
+ The LOGLAN-82 team wishes to thank all colleagues in Warsaw for criticism\r
+ and helpful remarks. This report has been carefully read by a number of\r
+ people, including J.Deminet, F.Kluzniak, A.Janicki, J.Rudzinski,\r
+ W.M.Turski. Their critical comments helped us to avoid numerous mistakes.\r
+1 - 8 -\r
+ \r
+ \r
+ 2. The basic characteristics of LOGLAN-82\r
+ #########################################\r
+ \r
+ 2.1. Control structure\r
+ **********************\r
+ \r
+ \r
+ Compound statements in LOGLAN-82 are built up from simple statements\r
+ (like assignment or call statement) by means of conditional, iteration and\r
+ case statements.\r
+ \r
+ \r
+ The syntax of a conditional statement is as follows:\r
+ \r
+ if boolean expression\r
+ then\r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r
+ \r
+ The semantics of a conditional statement is standard. The keyword fi\r
+ allows us to nest conditional statements without the appearence of the\r
+ "dangling else" ambiguity. The "else" part in a conditional statement may\r
+ be omitted:\r
+ \r
+ if boolean expression\r
+ then\r
+ sequence of statements\r
+ fi\r
+ \r
+ Another version of a conditonal statement has the form:\r
+ \r
+ if B1 orif ... orif Bk\r
+ then\r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r
+ \r
+ For the execution of a conditional statement with the orif list the\r
+ specified conditions B1, ..., Bk are evaluated in succession, until the\r
+ first one evaluates to true. Then the rest of the sequence is abandoned and\r
+ the "then" part is executed. If none of the conditions evaluates to true,\r
+ the "else" part is executed (if any). The orif construction provides a good\r
+ method for a short circuit technique, since the boolean expression\r
+ controling the conditional statement execution need not be evaluated till\r
+ the end.\r
+1 - 9 -\r
+ \r
+ \r
+ Similarly, a conditional statement with the andif list has the form:\r
+ \r
+ if B1 andif ...andif Bk\r
+ then\r
+ sequence of statements\r
+ else\r
+ sequence of statements\r
+ fi\r
+ \r
+ For the execution of this kind of statement the conditions B1, ..., Bk\r
+ are evaluated in succession until the first one evaluates to false. Then\r
+ the "else" part is executed (if any). Otherwise the "then" part is\r
+ executed.\r
+ \r
+ \r
+ The basic form of an iteration statement in LOGLAN-82 is the following:\r
+ \r
+ do\r
+ sequence of statements\r
+ od;\r
+ \r
+ To terminate the iteration statement one can use the simple control\r
+ statement exit, which has the following syntactic form:\r
+ \r
+ exit ..... exit\r
+ \r
+ repeated an arbitrary number of times. It may occur in a nested loop\r
+ statement. The execution of exit.....exit (i - times) statement consists in\r
+ the control transfer to the statement immediately following the i-th od\r
+ after the exit statement, (where in counting the od's, the pairs do-od are\r
+ disregarded). In particular, when exit occurs in a simple loop the control\r
+ is transferred to the statement immediately following the od symbol, which\r
+ allows us to terminate the loop. Similarly, a double exit terminates two\r
+ nested loops, a triple exit terminates three nested loops etc. Moreover, a\r
+ LOGLAN-82 iteration statement allows us to place many loop exit points in\r
+ arbitrary configurations, e.g., exit may appear in nested conditional\r
+ statements, case statements, etc.\r
+ \r
+ Iteration statements with controlled variables (for statements) have the\r
+ forms:\r
+ \r
+ for j := A1 step A2 to (or downto) A3\r
+ do\r
+ sequence of statements\r
+ od;\r
+1 - 10 -\r
+ \r
+ \r
+ The type of the controlled variable j must be discrete. The value of this\r
+ variable in the case of the for statement with to is increased, and in the\r
+ case of the for statement with downto is decreased. The discrete range\r
+ begins with the value of A1 and changes with the step equal to the value of\r
+ A2. The execution of the for statement with to terminates when the value of\r
+ j becomes for the first time greater than A3 (with downto when the value of\r
+ j becomes for the first time less than A3). The values of the expressions\r
+ A1, A2, A3 are evaluated once, upon entry to the iteration statement. The\r
+ default value of A2 is equal to 1 (when the keyword step and A2 are\r
+ omitted).\r
+ \r
+ \r
+ An iteration statement with the while condition has the form:\r
+ \r
+ while boolean expression\r
+ do\r
+ sequence of statements\r
+ od;\r
+ \r
+ and is equivalent to\r
+ \r
+ do\r
+ if not boolean expression then exit fi;\r
+ sequence of statements\r
+ od;\r
+ \r
+ To enhance the users's comfort, the simple statement repeat is provided.\r
+ It may appear in an iteration statement and causes the current iteration to\r
+ be finished and the next one to be continued (something like jump to\r
+ CONTINUE in Fortran's DO statement). In general, this statement has the\r
+ form:\r
+ \r
+ exit ... exit repeat\r
+ \r
+ and causes the current iteration of the corresponding enclosing iteration\r
+ statement to be finished and the next one to be continued.\r
+ \r
+ A case statement in LOGLAN-82 has the form:\r
+ \r
+ case A\r
+ when Q1 : G1\r
+ when Q2 : G2\r
+ ...\r
+ when Qk : Gk\r
+ others G\r
+ esac\r
+ \r
+ where A is an arithmetic expression, Q1, ..., Qk are constants and G1, ...,\r
+ Gk are sequences of statements. A case statement selects for execution a\r
+ sequence Gj where the value of A equals Qj. The choice others covers all\r
+ values (possibly none) not given in the previous choices.\r
+1 - 11 -\r
+ \r
+ \r
+ 2.2. Block structure\r
+ ********************\r
+ \r
+ \r
+ \r
+ LOGLAN-82 adopts and extends the main semantic features of the ALGOL\r
+ family programming languages (ALGOL-60, ALGOL-68, SIMULA-67) i.e., the\r
+ block structure. The block concept of ALGOL-60 is a fundamental example of\r
+ this mechanism. The syntactic structure of a block is as follows:\r
+ \r
+ block\r
+ list of declarations\r
+ begin\r
+ sequence of statements\r
+ end\r
+ \r
+ The list of declarations defines some syntactic entities, e.g. constants,\r
+ variables, procedures, functions etc., whose scope is that block. The\r
+ syntactic entities occurring in the sequence of statements are identified\r
+ by means of identifiers which are introduced in the declaration lists. For\r
+ every identifier occurrence it must be possible to identify the\r
+ corresponding syntactic entity. This kind of correspondence between\r
+ occurrences of identifiers and syntactic entities is necessary to define\r
+ the semantics of a block statement. The block statement semantics may be\r
+ described as follows.\r
+ \r
+ When a block is entered, a dynamic instance of the block is generated. In\r
+ a computer, a block instance takes the form of a memory frame containing\r
+ syntactic entities declared in that block. All local syntactic entities of\r
+ an instance will be called its attributes .\r
+ \r
+ The frame of a block instance may be viewed as a box (with displayed\r
+ attributes when necessary).\r
+ \r
+ ------------------------\r
+ ! attribute k !\r
+ ------------------------\r
+ ! ... !\r
+ ------------------------\r
+ ! ... !\r
+ ------------------------\r
+ ! attribute 1 !\r
+ ------------------------\r
+ block instance\r
+1 - 12 -\r
+ \r
+ \r
+ A block is a statement, and so other blocks may occur in its sequence of\r
+ statement (i.e., blocks may be nested). Observe, that the occurrences of\r
+ identifiers in an inner block need not be local. They can refer to entities\r
+ declared in the outer block. For a non-local occurrence of identifier, the\r
+ corresponding attribute of a non-local instance should be identified. That\r
+ identification is possible thanks to an auxiliary notion of a syntactic\r
+ father.\r
+ \r
+ Consider the following block structure:\r
+ \r
+ --------------\r
+ ! block[1] !\r
+ ! !\r
+ ! -----------!\r
+ ! ! block[2]!!\r
+ ! -----------!\r
+ --------------\r
+ \r
+ \r
+ \r
+ \r
+ When the statements of block[2] are executed, the following two dynamic\r
+ block instances are created:\r
+ \r
+ \r
+ -------- --------\r
+ ! O[2] !=============>! O[1] !\r
+ -------- SL --------\r
+ \r
+ Here O[1] is an instance of the block[1], and O[2] is an instance of the\r
+ block[2].\r
+ \r
+ The instance O[1] is called the syntactic father of O[2] (or\r
+ alternatively the instance O[2] is syntactically linked by the SL-link with\r
+ the instance O[1]). During a program's execution the sequence of syntactic\r
+ fathers determined by an active instance forms a chain, called an SL-chain.\r
+ The instances forming the SL-chain correspond to the consequtive enclosing\r
+ units of the program, starting from the active one and ending on the main\r
+ block. Thus, this chain allows us to identify all non-local occurrences of\r
+ identifiers.\r
+ \r
+ A block statement terminates when the control reaches its final end, and\r
+ then its instance is automatically deallocated.\r
+1 - 13 -\r
+ \r
+ \r
+ 2.3. Procedures and functions\r
+ *****************************\r
+ \r
+ \r
+ A block is the simplest example of a unit. Blocks are syntactic units\r
+ generated by means of a block statement and deallocated automatically when\r
+ the end symbol is reached. Procedures and functions constitute the next\r
+ step of know-how in high level programming languages.\r
+ \r
+ The syntactic form of a procedure declaration is as follows:\r
+ \r
+ unit name: procedure(formal parameters);\r
+ list of declarations\r
+ begin\r
+ sequence of statements\r
+ end;\r
+ \r
+ A procedure is a named syntactic unit which may be invoked only via its\r
+ identifier by means of a call statement:\r
+ \r
+ call name (actual parameters);\r
+ \r
+ (Procedures differ from blocks also in that they can have parameters, but\r
+ this question will be discussed later.)\r
+ \r
+ When a procedure is called, its instance is created, as in the case of a\r
+ block. All local attributes are allocated in the new frame. A syntactic\r
+ father of such a newly generated instance is defined as usual, and allows\r
+ us to identify all non-local attributes.\r
+ \r
+ A procedure call is terminated when the control reaches return statement\r
+ or the final end. Then the control returns to the instance where the\r
+ procedure was called. That instance is referred to by another system\r
+ pointer (DL-link).\r
+ \r
+ After the termination of a procedure call there is no syntactic means to\r
+ access its local attributes, hence its instance is automatically\r
+ deallocated.\r
+ \r
+ Functions differ from procedures only in that they return a value and are\r
+ invoked in the expressions.\r
+1 - 14 -\r
+ \r
+ \r
+ 2.4. Classes\r
+ ************\r
+ \r
+ To meet the need for permanent data structures LOGLAN-82 introduces the\r
+ notion of class (cf [3]). Class is declared in a similar way to procedure.\r
+ It is named and may have parameters:\r
+ \r
+ unit M :class(formal parameters);\r
+ list of declarations\r
+ begin\r
+ sequence of statements\r
+ end;\r
+ \r
+ The main difference between classes and procedures consists in the way\r
+ the instances of these syntactic units are treated. (To distiguish class\r
+ instances from those of blocks, functions and procedures they will be\r
+ called class objects or simply objects). The class generation yields a\r
+ class object which is a permanent data unlike the vanishing procedure\r
+ (function, block) instance. The object O of class M is generated by the\r
+ object generator statement:\r
+ \r
+ new M\r
+ \r
+ This statement invokes the same sequence of actions as a procedure call,\r
+ i.e., it opens a new object, transmits parameters and executes the sequence\r
+ of statements of M. Return to the caller is made by the execution of a\r
+ return statement or when the final end is reached.\r
+ The access to such an object is then possible if its address is set to a\r
+ variable. The variables whose values point to class objects are called\r
+ reference variables.\r
+ A reference variable of type M is declared as follows:\r
+ \r
+ var X:M;\r
+ \r
+ and may point to any object of class M, for instance, the statement:\r
+ \r
+ X:=new M\r
+ \r
+ generates an object O of class M and assigns its address (reference) to X.\r
+ The default value of any reference variable is none, which denotes\r
+ fictitious non-existing object.\r
+ What is left behind is a structure of attributes which can be accessed by\r
+ means of dot-notation. These accessible attributes are either formal\r
+ parameters or local entities. If X is a reference variable of type M and W\r
+ is an attribute of class M, then the remote access to the attribute W has\r
+ the form:\r
+ \r
+ X.W\r
+ \r
+ The above remote access is correct if X points to an object O of class M.\r
+ Otherwise a run time error is raised (for instance when the value of X is\r
+ none).\r
+1 - 15 -\r
+ \r
+ \r
+ 2.5. Prefixing\r
+ ***************\r
+ \r
+ Prefixing is another important programming facility borrowed from\r
+ SIMULA-67. Its most important feature consists in the possibility of unit\r
+ extension. Consider the following example. Let M be a class:\r
+ \r
+ unit M: class;\r
+ list of declarations of M\r
+ begin\r
+ sequence of statements of M\r
+ end ;\r
+ \r
+ Now let N be a class:\r
+ \r
+ unit N: M class\r
+ list of declarations of N\r
+ begin\r
+ sequence of statements of N\r
+ end ;\r
+ \r
+ Class N is prefixed by class M. The name of the prefix is located\r
+ immediately before the symbol class. Class N is treated as an extension of\r
+ M, i.e., the object of class N has a compact frame consisting of the\r
+ attributes of N as well as the attributes of M:\r
+ \r
+ ---------------\r
+ ! !\r
+ ! ... ! M-attributes\r
+ ! !\r
+ --------------- - - - - - -\r
+ ! !\r
+ ! !\r
+ ! ... ! N-attributes\r
+ ! !\r
+ ---------------\r
+ \r
+ object of N\r
+ \r
+ The structure of such an object is determined by the class M as well as\r
+ by N (thus containing both M-attributes and N-attributes).\r
+ The statement\r
+ \r
+ X:=new N ,\r
+ \r
+ where X is a variable of type N, creates an object of class N.\r
+1 - 16 -\r
+ \r
+ \r
+ The sequences of statements of classes M and N are also concatenated. In\r
+ the sequence of statements of a class the keyword inner may occur anywhere,\r
+ but once only. The sequence of statements of N consists of the sequence of\r
+ statements of M with inner replaced by the sequence of statements of N\r
+ (inner in N is equivalent to an empty statement). If class N prefixes\r
+ another class P, then inner in N is replaced by the sequence of statements\r
+ of P, and so on. If inner does not occur explicitly, an implicit occurrence\r
+ of inner just before the final end of class is assumed.\r
+ \r
+ Prefixing allows the programmer to extend units. Assume, for instance,\r
+ that STACK is the data structure which defines a push-down memory:\r
+ \r
+ unit STACK :class;\r
+ ...\r
+ unit pop: function...\r
+ end;\r
+ ...\r
+ unit push: procedure...\r
+ end;\r
+ ...\r
+ begin\r
+ ...\r
+ end STACK;\r
+ \r
+ Any class prefixed by STACK inherits the operations on stack. For\r
+ instance, in a class declaration\r
+ \r
+ unit N: STACK class;\r
+ ...\r
+ begin\r
+ ...\r
+ call push;\r
+ ...\r
+ end ;\r
+ \r
+ the function pop and the procedure push may be used as any other local\r
+ attribute.\r
+ \r
+ A class may also be used to prefix blocks, procedures and functions. An\r
+ instance of a prefixed block is a compound object and is created upon entry\r
+ to the block and deallocated after its termination, as in the case of a\r
+ simple block. Similarly, an instance of a prefixed procedure (function) is\r
+ a compound object which is created when a procedure (function) is called\r
+ and deallocated after its termination.\r
+1 - 17 -\r
+ \r
+ \r
+ 2.6. Object deallocator\r
+ ***********************\r
+ \r
+ The classical methods used to deallocate class objects are based on\r
+ reference counters or garbage collection. Sometimes both methods may be\r
+ combined. The reference counter is a system attribute holding the number of\r
+ references pointing to the given object. Hence any change of the value of a\r
+ reference variable X is followed by a corresponding increase or decrease of\r
+ the value of its reference counter. When the reference counter becomes\r
+ equal to 0, the object can be deallocated.\r
+ \r
+ The deallocation of class objects may also occur during the process of\r
+ garbage collection. During this process all unreferenced objects are found\r
+ and removed (while memory may be compactified). In order to keep the\r
+ garbage collector able to collect all the garbage, the user should clear\r
+ all reference variables, i.e., set to none, whenever possible. This system\r
+ has many disadvantages. First of all, the programmer is forced to clear all\r
+ reference variables, even those which are of auxiliary character. Moreover,\r
+ the garbage collector is a very expensive mechanism and thus can be used\r
+ only in emergency cases.\r
+ \r
+ In LOGLAN-82 a dual operation to the object generator, the so-called\r
+ object deallocator is provided. Its syntactic form is as follows:\r
+ \r
+ kill(X)\r
+ \r
+ where X is a reference expression. If the value of X points to no object\r
+ (none) then kill(X) is equivalent to an empty statement. If the value of X\r
+ points to an object O, then after the execution of kill(X) the object O is\r
+ deallocated. Moreover, all reference variables which pointed to O are set\r
+ to none., This deallocator provides full security, i.e., the attempt to\r
+ access the deallocated object O is checked and results in a run-time error.\r
+ For example,\r
+ \r
+ Y:=X; kill(X); Y.W:=Z;\r
+ \r
+ causes the same run-time error as\r
+ \r
+ X:=none; X.W:=Z;\r
+ \r
+ The system of storage management is arranged in such a way that the\r
+ frames of killed objects may be immediately reused without the necessity of\r
+ calling the garbage collector, i.e., the relocation is performed\r
+ automatically.\r
+1 - 18 -\r
+ \r
+ \r
+ 2.7. Arrays\r
+ ***********\r
+ \r
+ LOGLAN-82's array is a kind of a class with indices instead of\r
+ identifiers selecting the attributes. A variable of an array type is a\r
+ reference variable pointing to an object which contains components of a\r
+ one-dimensional array. The components of such an array may also point to\r
+ one-dimensional arrays and so forth, hence multi-dimensional arrays may be\r
+ generated as well.\r
+ \r
+ The declaration of a variable Y of array type has the following form:\r
+ \r
+ var Y : array_of ... array_of T\r
+ \r
+ where the number of array_of defines the dimension of Y. The declaration of\r
+ a variable Y fixes its dimension, while the bound pairs are still\r
+ undetermined. The array generation statement has the form\r
+ \r
+ new_array Y dim (l : u)\r
+ \r
+ where l, u are arithmetic expressions determining the lower and upper\r
+ bounds of the first index. The object O of an array is generated and the\r
+ reference to O is assigned to Y.\r
+ \r
+ If Y is declared as a two-dimensional array, then one can generate a\r
+ two-dimensional array by means of the statements\r
+ \r
+ new_array Y dim (l:u);\r
+ \r
+ for i:=l to u\r
+ do\r
+ new_array Y(i) dim (li:ui)\r
+ od;\r
+ \r
+ where the shape of each row is determined by the bounds li, ui. Hence\r
+ triangular, tridiagonal, streaked arrays, etc. may be generated. Moreover,\r
+ the assignment statements allow us to interchange array references that are\r
+ of the same dimension and the same type, e.g. Y(i):=Y(j). In consequence,\r
+ the user may operate on array slices. The default value of any array\r
+ variable is none, as in the case of a reference variable.\r
+ \r
+1 - 19 -\r
+ \r
+ \r
+ 2.8. Parameters\r
+ ****************\r
+ \r
+ In LOGLAN-82 there are four categories of parameters: variable\r
+ parameters, procedure parameters, function parameters and type parameters.\r
+ \r
+ Variable parameters\r
+ -------------------\r
+ \r
+ Variable parameter transmission is simplified in comparison with ALGOL-60\r
+ and SIMULA-67. There are three transmission modes of variable parameters:\r
+ input mode, output mode and inout mode. In the syntactic unit which is a\r
+ procedure, a function or a class, the formal input parameters are preceded\r
+ by the symbol input, the formal output parameters are preceded by the\r
+ symbol output and the formal inout parameters are preceded by the symbol\r
+ inout. The default transmission mode is input. Input parameters are treated\r
+ as local variables initialized by the values of the corresponding actual\r
+ ones. Output parameters are treated as local variables initialized in the\r
+ standard manner (real with 0.0, integer with 0, reference with none, etc.).\r
+ Upon return their values are assigned to the corresponding actual\r
+ parameters, which in this case must be the variables. Inout parameters act\r
+ as input and output parameters together.\r
+ \r
+ Procedure and function parameters\r
+ ---------------------------------\r
+ \r
+ In LOGLAN-82 procedures and functions may also be formal parameters. This\r
+ category of parameters allows us to parametrize a unit with respect to some\r
+ operations. A formal procedure (function) has the full specification part,\r
+ i.e., the parameter list (and the function type), for instance :\r
+ \r
+ unit Bisec: procedure(function f(x: real): real; a, b, eps:real);\r
+ begin\r
+ ...\r
+ end;\r
+ \r
+ Type parameters\r
+ ---------------\r
+ \r
+ Types are also allowed to be transmitted as parameters. This kind of\r
+ parameters enables us to parametrize a unit with respect to some types. For\r
+ instance consider the following declaration:\r
+ \r
+ unit sort:procedure(type T;A:arrayof T; function less(x, y:T):boolean);\r
+ begin\r
+ ...\r
+ end\r
+ \r
+ The actual parameter corresponding to the formal T must be a\r
+ non-primitive type. The array A must be the array of elements of the actual\r
+ type.\r
+ If function less defines the ordering relation on the elements of the\r
+ actual type, then this procedure may be invoked to sort the array A.\r
+1 - 20 -\r
+ \r
+ \r
+ 2.9. Coroutines\r
+ ***************\r
+ \r
+ Coroutine is a generalization of class. A coroutine object is an object\r
+ whose sequence of statements can be suspended and reactivated in the\r
+ programmed manner. The generation of a coroutine object terminates with the\r
+ execution of the return statement (then the control is passed to the caller\r
+ as in the case of classes). A coroutine object after the execution of the\r
+ return statement is suspended. A suspended coroutine object may be\r
+ reactivated with the help of the attach statement:\r
+ \r
+ attach(X)\r
+ \r
+ where X is a reference variable designating the activating object.\r
+ \r
+ In general, from the moment of generation a coroutine object is either\r
+ active or suspended. Any reactivation of a suspended coroutine object O\r
+ causes the active coroutine object to be suspended and continues the\r
+ execution of O from the statement following the last executed one.\r
+ \r
+ During a coroutine execution some other unit instances may be generated.\r
+ They are dynamically dependent on that coroutine object. Thus, an active\r
+ coroutine (in particular the main program) can be illustrated by the\r
+ following chain:\r
+ \r
+ -------- -------- --------\r
+ ! O[k] ! ---> !O[k-1]! --->...---> ! O[1] !--->\r
+ -------- -------- --------\r
+ coroutine head\r
+ \r
+ where the arrows denote the DL-links.\r
+ \r
+ This DL-chain is transformed into the DL-cycle when the control is\r
+ transferred to another coroutine as the result of the attach statement.\r
+ \r
+ -------- -------- --------\r
+ ! O[k] ! ---> !O[k-1]! --->...---> ! O[1] !--->\r
+ -------- -------- -------- !\r
+ ! !\r
+ <----------------------------------------------!\r
+ \r
+ \r
+1 - 21 -\r
+ \r
+ \r
+ 2.10. Processes\r
+ ***************\r
+ \r
+ The concept of process in LOGLAN-82 is a natural extension of coroutine.\r
+ Coroutines are units which once generated may operate independently, each\r
+ one treated as a separate process. For coroutines, however, an essential\r
+ assumption is established; namely, when one coroutine object is activated,\r
+ the active one must be suspended. When processes are used, the activation\r
+ of a new process does not require the active one to be suspended. Thus\r
+ during a program's execution many processes may be active simultaneously.\r
+ Their statements are computed in parallel.\r
+ There are two operations, stop and resume, which concern the control of\r
+ processes.\r
+ \r
+ stop Operation which causes the active process to be\r
+ stopped.\r
+ resume(X) Operation which reactivates the process referenced by X.\r
+ \r
+ Synchronization and scheduling.\r
+ \r
+ Elementary synchronization in LOGLAN-82 is achieved by two-valued\r
+ semaphores and a number of simple indivisible statements operating on them.\r
+ These statements are the following (where Z denotes a variable of semaphore\r
+ type):\r
+ \r
+ \r
+ ts(Z) Test-and-set boolean function which closes semaphore Z\r
+ and returns the value true if Z was open and false if Z\r
+ was closed.\r
+ lock(Z) Operation which tests the value of the semaphore Z and\r
+ either enables the given process to enter the critical\r
+ region guarded by Z (if Z is open) or suspends the\r
+ process (in the opposite case) until another one opens\r
+ that critical region.\r
+ unlock(Z) Operation the execution of which opens the critical\r
+ region guarded by Z.\r
+ stop(Z) Operation that opens the critical region guarded by Z\r
+ and stops the execution of the given process.\r
+ \r
+ The above operations are implemented in the kernel of the operating\r
+ system. One can use them to define any complex synchronization facility,\r
+ e.g., monitors (cf. 11.3.). Once defined and stored in the library, the\r
+ facility can be used by any user. Moreover, using the high level\r
+ synchronizing tools, the user can cover the low level, primitive ones\r
+ (therefore the properties of high level tools cannot be disturbed).\r
+ \r
+ There is also a parameterless function wait. If wait is called in the\r
+ given process X, then process X waits for the termination of any of its son\r
+ (a son of X is a process which was generated in X). The returned value of\r
+ wait points to the first terminated son, and then, the computation of\r
+ process X is continued. If there is no such son, the returned value of wait\r
+ is none.\r
+1 - 22 -\r
+ \r
+ \r
+ 2.11. Other important features\r
+ ******************************\r
+ \r
+ In LOGLAN-82 the access control mechanism is enlarged so that it supports\r
+ the data encapsulation technique and the protection of attributes in\r
+ different environments. The mode of accessibility to attributes of a class\r
+ can be controlled by means of the specification hidden and close. On the\r
+ other hand, the mode of accessibility to attributes of a unit that are\r
+ inherited from its prefix can be controlled by means of the specifification\r
+ taken. This permits more flexible communication across the unit boundary as\r
+ well as defining of abstract behaviour with a hidden auxiliary structure.\r
+ (For details see 6).\r
+ \r
+ The language provides facilities for dealing with run time errors and\r
+ other exceptional situations raised by the user. These events are called\r
+ exceptions. So, the exceptions cause interruption of a normal program\r
+ execution. The response to an exception is defined by an exception handler.\r
+ The user is allowed to define the actions that should be raised when an\r
+ exception is encountered.\r
+ (For details see 10).\r
+ \r
+ Program units can be compiled separately. Two kinds of separately\r
+ compiled units are provided: binary items ready to be executed, and library\r
+ items. The purposes of separate compilation are the following: creating\r
+ user libraries, handling system and user libraries, compiling program\r
+ components during program testing, and program overlaying.\r
+ (For details see 12).\r
+ \r
+ Input-output facilities and file processing are defined by means of some\r
+ simple primitives. The user is able, however, to declare in the language\r
+ any class that provides high-level and secure file operations. Examples of\r
+ system classes that deal with high-level file operations are also given.\r
+ (For details see 13).\r
+1 - 23 -\r
+ \r
+ \r
+ 3. Lexical and textual structure\r
+ ################################\r
+ \r
+ \r
+ The basic character set consists of\r
+ \r
+ (a) 26 upper case letters:\r
+ \r
+ a b c d e f g h i j k l m n o p q r s t u v w x y z\r
+ \r
+ (b) 10 digits:\r
+ \r
+ 0 1 2 3 4 5 6 7 8 9\r
+ \r
+ (c) 16 auxiliary characters:\r
+ \r
+ . : , ; _ = / + - * < > ' " ( )\r
+ \r
+ (d) the space character\r
+ \r
+ This set can be extended with the following characters:\r
+ \r
+ (e) lower case letters\r
+ \r
+ (f) other special ASCII characters, e.g.:\r
+ \r
+ # $ ? % ^\r
+ \r
+ (lower case letters are equivalent to the corresponding upper case ones.)\r
+ \r
+ A finite sequence of characters is called a word. The words called\r
+ identifiers have a special meaning. They are composed of letters, digits,\r
+ and underscores and start with a letter:\r
+ \r
+ \r
+ \r
+ <identifier>:\r
+ \r
+ ----------> <letter> -------------------------->\r
+ ^ ^ !\r
+ ! ! !\r
+ !---> <digit> ----> ! !\r
+ ! !\r
+ ! !\r
+ !--- _ -----> !\r
+ ! ! !\r
+ <-------------------------------\r
+ \r
+ \r
+ \r
+1 - 24 -\r
+ \r
+ \r
+ Identifiers serve to identify program entities, i.e., constants, variables,\r
+ types, functions, procedures, classes, coroutines and processes. There are\r
+ a certain number of predefined system identifiers which have special\r
+ significance in the language. The following system identifiers are reserved\r
+ words (these identifiers cannot be declared by the programmer).\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ and_if detach if od taken\r
+ and dim in open terminate\r
+ array_of div inner or then\r
+ attach do input or_if this\r
+ downto inout others to\r
+ is output type\r
+ begin else\r
+ block end kill pref unit\r
+ esac procedure unlock\r
+ exit last_will process\r
+ lock put var\r
+ call fi virtual\r
+ case for main qua\r
+ class function mod wait\r
+ close raise wind\r
+ const get new read when\r
+ copy new_array repeat while\r
+ coroutine hidden none repeat write\r
+ handlers not return writeln\r
+ \r
+ signal\r
+ step\r
+ stop\r
+ \r
+ \r
+ \r
+1 - 25 -\r
+ \r
+ \r
+ The lexical entities are identifiers, numbers, strings and delimiters.\r
+ The delimiters from the basic character set are:\r
+ \r
+ , ; = / + - * > < . ( ) :\r
+ \r
+ and the compound symbols are :\r
+ \r
+ =/= >= <= :=\r
+ \r
+ Spaces play the role of separators, i.e., at least one space must\r
+ separate adjacent identifiers or numbers. The end of each line is\r
+ equivalent to a space.\r
+ \r
+ A comment starts with a left parenthesis and an asterisk and is\r
+ terminated by an asterisk and a right parenthesis. It may only appear\r
+ following a lexical unit or at the beginning or end of a program entity.\r
+ Comments have no effect on the meaning of a program and are used solely for\r
+ program documentation.\r
+ \r
+ By an identifier definition we mean a declaration or description in the\r
+ list of formal parameters.\r
+ \r
+ The notion of a unit is explained by the following diagram:\r
+ \r
+ \r
+ ---------------------- unit ----------------------\r
+ ! ! !\r
+ ! ! !\r
+ ! ! !\r
+ -----subprogram---- generalized class !\r
+ ! ! ! ! ! !\r
+ ! ! ! ! ! !\r
+ function procedure class coroutine process block\r
+1 - 26 -\r
+ \r
+ \r
+ 4. Types\r
+ ########\r
+ \r
+ \r
+ A type T determines a set !T! of values and a family of operations\r
+ applicable to the elements of the set. Three kinds of types are\r
+ distinguished: primitive types, system types and compound types. Variables\r
+ may be declared to be of type T. Depending on the kind of type T we have to\r
+ distinguish two cases.\r
+ \r
+ \r
+ a) T is a primitive type. The value assigned to a variable Y of type\r
+ T must belong to the set !T!.\r
+ \r
+ \r
+ b) T is a compound or system type. The value assigned to a variable\r
+ Y of type T must be a reference pointing to an object in the set\r
+ !T! (for the notion of reference cf 4.3. and 6.3.)\r
+ \r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <type identifier>:\r
+ \r
+ -----> <primitive type> ------>\r
+ ! ^\r
+ !-> <system type> ----->!\r
+ ! !\r
+ !-> <compound type> --->!\r
+ ! !\r
+ !-> <formal type> ----->!\r
+ ! !\r
+ !-> <file type> ------->!\r
+ \r
+ \r
+ \r
+ Primitive and system types are pre-defined, compound types are defined by\r
+ the user. For file type see section 13.\r
+1 - 27 -\r
+ \r
+ \r
+ 4.1. Primitive types\r
+ ********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <primitive type>:\r
+ \r
+ -----> integer -------->\r
+ ! ^\r
+ !---> real ---->!\r
+ ! !\r
+ !--> boolean -->!\r
+ ! !\r
+ !-> character -->!\r
+ ! !\r
+ !---> string -->!\r
+ ! !\r
+ !-> semaphore -->!\r
+ \r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ A primitive type determines a finite set of values which can be effectively\r
+ represented in a computer memory:\r
+ \r
+ !integer! - a subset of integers;\r
+ !real! - a subset of reals;\r
+ !boolean! - the set consisting of logical values T (true) and F (false);\r
+ !semaphore! - the set consisting of two values (closed and open);\r
+ !character! - a set of characters;\r
+ !string! - a subset of strings;\r
+ \r
+ These sets will be precisely defined in a concrete implementation. The\r
+ way in which the primitive type values are represented in a computer memory\r
+ is not essential for the description of semantics; however, the values of\r
+ integer and real types are differently represented. Namely, integers are\r
+ represented in the fixed-point form with a point after the last significant\r
+ digit, reals are represented in the floating-point form. So they will be\r
+ denoted differently, e.g., 2 and 2.0. Those values can be mutually\r
+ converted: the value of type integer is converted to type real by means of\r
+ conversion into the floating point form; the conversion into the opposite\r
+ direction truncates and transforms the real value into the fixed-point\r
+ form.\r
+1 - 28 -\r
+ \r
+ \r
+ 4.2. System types\r
+ #################\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <system type>:\r
+ \r
+ --------> coroutine -------->\r
+ ! ^\r
+ !----> process --->!\r
+ \r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The set !coroutine! is equal to the union of sets !T! for every type T\r
+ declared as:\r
+ \r
+ - unit T : coroutine\r
+ - unit T : process\r
+ - unit T : S class\r
+ where !S! is already a subset of the set !coroutine!.\r
+ \r
+ The set !process! is equal to the union of sets !T! for every type T\r
+ declared as:\r
+ \r
+ - unit T : process\r
+ - unit T : S class\r
+ where !S! is already a subset of the set !process!.\r
+ \r
+ The user may declare a variable of coroutine (process) type, e.g. of the\r
+ form\r
+ \r
+ var X : coroutine;\r
+ (var X : process;)\r
+ \r
+ and then to assign:\r
+ X:=new T\r
+ \r
+ where T belongs to the set !coroutine! (!process!).\r
+ \r
+ The main block belongs to both sets - !coroutine! and !process!. The\r
+ system variable main gives the reference to the main block. The variable\r
+ main may occur in the statements attach(main) and resume(main) only.\r
+1 - 29 -\r
+ \r
+ \r
+ 4.3. Compound types and objects\r
+ *******************************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <compound type>:\r
+ \r
+ --------> <array type> ---------->\r
+ ! ^\r
+ !----> <class type> --->!\r
+ \r
+ 4.3.1. Array type\r
+ *****************\r
+ \r
+ \r
+ Objects of array type will be called array objects or shortly arrays. An\r
+ array can be considered as a vector; the access to its components is\r
+ provided by means of indexing.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <array type>:\r
+ \r
+ ------> array_of -----> <type identifier> ---->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ LOGLAN-82 types can be uniformly denoted in the following way\r
+ \r
+ \r
+ !! array_of ... array_of T for i>0\r
+ !! i - times\r
+ (array_of)<i>T= !!\r
+ !!\r
+ !! T for i=0\r
+ \r
+ where T is a type identifier.\r
+ \r
+ For i>0, the set !(array_of)<i>T! consists of the array objects. Every\r
+ array object has the attributes accessed via indices l, l+1, ..., u where\r
+ l, u are the values of the lower and upper bounds, respectively, and l<=u.\r
+ The attributes with the indices l, ..., u are of type (array_of)<i-1>T.\r
+ \r
+ Let O be an arbitrary fixed array object and let Y be a variable whose\r
+ value points to O. The operations related to the object O are:\r
+ \r
+ - Y(j), where l<=j<=u, gives the j-th attribute of the object O,\r
+ - lower(Y) and upper(Y), which give the value l and u,\r
+ respectively.\r
+1 - 30 -\r
+ \r
+ \r
+ 4.3.2. Class type\r
+ *****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <class type>:\r
+ \r
+ -----> <class identifier> ----->\r
+ \r
+ \r
+ <class identifier>:\r
+ \r
+ ------> <identifier> ---------->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ A class T is a description of a data structure consisting of attributes\r
+ i.e., types, functions, procedures, variables, and a sequence of\r
+ statements. The family of admissible operations on the objects from the set\r
+ !T! contains the operations defined in the sequence of statements and those\r
+ defined in the declarations of functions and procedures. The other\r
+ operations are related to the notion of remote access. They allow us to\r
+ operate on the objects of type !T! from outside of them.\r
+ \r
+ \r
+ \r
+ 4.4. Formal types\r
+ *****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <formal type>:\r
+ \r
+ -----> <formal type identifier> ----->\r
+ \r
+ \r
+ <formal type identifier>:\r
+ \r
+ -----> <identifier> ------------------>\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ A formal type is a formal parameter of a unit and can be treated as the\r
+ name of an abstract data structure without any attribute. The corresponding\r
+ actual type must be a system type or a compound type. The set of objects of\r
+ the formal type T from a dynamic object O is equal to the set of objects of\r
+ the actual type which occurs in the actual parameter list of O.\r
+1 - 31 -\r
+ \r
+ \r
+ 5. Declarations\r
+ ###############\r
+ \r
+ \r
+ Every identifier which is to be used in a program must be defined. System\r
+ identifiers are pre-defined, other identifiers are pre-compiled, (see 12.)\r
+ or they are defined by means of a declaration or description in the formal\r
+ parameter list. LOGLAN-82 is not strongly typed in the sense that sometimes\r
+ the type of variable and function value cannot be determined at compilation\r
+ time. The user may balance the generality and convenience given by the\r
+ formal types mechanism and the risk of reduced efficiency of his program\r
+ execution. The compiler option, however, allows us to supress the run time\r
+ checking with respect to the type compatibility.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <declaration>:\r
+ \r
+ ------> <constant declaration> -------->\r
+ ! ^\r
+ !--> <variable declaration> -->!\r
+ ! !\r
+ !--> <unit declaration> ------>!\r
+ ! !\r
+ !--> <signal declaration> ---->!\r
+ ! !\r
+ !--> <linked item specific.>-->!\r
+ \r
+ \r
+ (For the definition of a signal declaration see 10.\r
+ For the definition of linked item specification see 12.)\r
+ \r
+ \r
+ 5.1. Constant declaration\r
+ *************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <constant declaration>:\r
+ \r
+ --> const ---> <identifier> ---> = ---> <expression> ------------------->\r
+ ! !\r
+ <------------------------ , ---------------------\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The expression defining the constant must be determinable at compilation\r
+ time. The type and the value of the constant is given by its declaration.\r
+ They are always primitive.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ const pi=3.1415926, pihalf=pi/2;\r
+ \r
+1 - 32 -\r
+ \r
+ \r
+ 5.2. Variable declaration\r
+ *************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <variable declaration>:\r
+ \r
+ ---> var ---><specification list>--->\r
+ \r
+ \r
+ <specification list>:\r
+ \r
+ ----> <identifier list> ---> : ---> <type identifier> ------>\r
+ ^ !\r
+ !<------------------ , <--------------------------------!\r
+ \r
+ \r
+ <identifier list>:\r
+ \r
+ -----> <identifier> ------->\r
+ ^ !\r
+ !<---- , <---------!\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ A variable is of a type given in a variable declaration. A declaration is\r
+ elaborated at the instant of generation of a unit object which contains\r
+ that declaration. An elaboration determines an initial value for every\r
+ variable. This value depends on the type identifier :\r
+ \r
+ integer - 0\r
+ real - 0.0\r
+ boolean - F\r
+ semaphore - open\r
+ character and string - defined in concrete implementation\r
+ any compound and system type- none\r
+ \r
+ The value of the variable may be modified by means of an assignment\r
+ statement (see 9.1.1.), but the variables of type T may only point to the\r
+ object from the set !T!.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ var left, right: node, counter: integer, cycle: array_of boolean;\r
+ \r
+ \r
+1 - 33 -\r
+ \r
+ \r
+ 5.3. Unit declaration\r
+ *********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <unit declaration>:\r
+ \r
+ ----> unit -------> <class declaration> ---------------------->\r
+ ! !\r
+ !----> <subprogram declaration> --->!\r
+ \r
+ \r
+ 5.3.1. Class declaration (introduction)\r
+ ***************************************\r
+ \r
+ \r
+ A class declaration is understood as a declaration of a class itself, as\r
+ well as a declaration of a coroutine or a process. The prefixing will be\r
+ described in 5.3.4..\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <class declaration>:\r
+ \r
+ ----------><class identifier> : ---> <prefix> -----> class ----->!\r
+ ! ^ !\r
+ ------------->!-><system type>->!\r
+ !\r
+ !<------------------------------------------------------------!\r
+ ! !\r
+ !-> <formal parameter list> ------------------------------->!\r
+ !\r
+ !<------------------------------ ; ----------!\r
+ !\r
+ !--> <class body> ----------------------------->\r
+ ! ^\r
+ !-> <class identifier> ->!\r
+ \r
+ \r
+ <prefix>:\r
+ \r
+ ----------------> <class identifier> ------>\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ unit complex: class(re, im:real);\r
+ var module:real;\r
+ begin\r
+ module:=sqrt(re*re+im*im)\r
+ end ;\r
+1 - 34 -\r
+ \r
+ \r
+ 5.3.2. Subprogram declaration (introduction)\r
+ ********************************************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <procedure declaration>:\r
+ \r
+ --> virtual --> <procedure identifier>--> : --><prefix> ---> procedure\r
+ ! ^ ! ^ !\r
+ !----------! !------------! !\r
+ !\r
+ <-------------------------------------------------------!\r
+ ! !\r
+ !--> <formal parameter list> -------------------------->!\r
+ !\r
+ <------------------------- ; ---------------------!\r
+ !\r
+ !--> <subprogram body> ------------------------------>\r
+ ! ^\r
+ !-> <procedure identifier>->!\r
+ \r
+ \r
+ \r
+ <procedure identifier> :\r
+ \r
+ ---- <identifier> ------->\r
+ \r
+ \r
+ <function declaration>:\r
+ \r
+ --> virtual --> <function identifier>--> : --> <prefix> --> function\r
+ ! ^ ! ^ !\r
+ !----------! !-----------! !\r
+ !\r
+ !<------------------------------------------------------------!\r
+ ! !\r
+ !-> <formal parameter list> ---------> : ----> <type identifier>->\r
+ !\r
+ !<-------------------- ; ----------------------------!\r
+ !\r
+ !-> <subprogram body> ------------------------------->\r
+ ! ^\r
+ !-> <function identifier>->!\r
+ \r
+ \r
+ \r
+ <function identifier>:\r
+ \r
+ -----> <identifier> ---------->\r
+ \r
+ \r
+ \r
+ \r
+ Class (function, procedure) identifier may optionally follow the end\r
+ symbol (and if present must match the unit name).\r
+1 - 35 -\r
+ \r
+ \r
+ Example.\r
+ --------\r
+ \r
+ unit Euclid: function(n, m:integer):integer;\r
+ var k:integer;\r
+ begin\r
+ do\r
+ k:=n mod m;\r
+ if k=0 then result:=m; return fi;\r
+ n:=m; m:=k;\r
+ od;\r
+ end Euclid;\r
+ \r
+ \r
+ \r
+ 5.3.3. Block\r
+ ************\r
+ \r
+ \r
+ In order to complete the description of LOGLAN-82 units the block syntax\r
+ is given here, however the occurrence of a block results in the execution\r
+ of its statements - see 9.1.2..\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <block>:\r
+ \r
+ --> pref --> <prefix> ---> <actual parameter list> ---> block ---->\r
+ ! ^ ^ !\r
+ !-------------------->!--------------------------->! !\r
+ !\r
+ !<------------------------------------------!\r
+ !\r
+ !--> <subprogram body>------>\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ block\r
+ var a, b, c, p, S:real;\r
+ begin\r
+ read(a, b, c);\r
+ p:=(a+b+c)/2;\r
+ S:=sqrt(p*(p-a)*(p-b)*(p-c));\r
+ write(S)\r
+ end\r
+1 - 36 -\r
+ \r
+ \r
+ 5.3.4. Prefixing\r
+ ****************\r
+ \r
+ \r
+ A unit which is a specialized form of a certain class (i.e., which has\r
+ all the properties of that class and some additional properties defined in\r
+ the unit) can be defined by means of prefixing. An identifier of the\r
+ prefixed unit may serve as a prefix for another unit, and so tree\r
+ structured hierarchies of units can be created. By a prefix sequence of a\r
+ unit M we mean a sequence M1, ..., Mk of units such that Mk = M, the unit\r
+ M1 has no prefix; for i = 1, ..., k-1, the unit Mi+1 is prefixed by Mi. Any\r
+ unit may be prefixed by a class without changing its character (e.g., a\r
+ prefixed procedure still remains a procedure). Procedures, functions, and\r
+ blocks cannot be used as prefixes. Process and coroutine, as special cases\r
+ of class, may also serve as prefixes, but not for procedures, functions or\r
+ blocks.\r
+ \r
+ If a coroutine (a process) occurs in a prefix sequence of a unit then\r
+ this unit is treated as a coroutine (a process), and so it has all the\r
+ properties of a coroutine (a process). Therefore, if a prefix sequence of a\r
+ unit M contains both a coroutine and a process then M has the properties of\r
+ a coroutine as well as those of a process.\r
+ \r
+ No unit is allowed to occur more than once in its prefix sequence.\r
+ \r
+ Put T pref* S if a unit T belongs to the prefix sequence of the unit S.\r
+ Unit S is called a subunit of unit T. As one can see from the definition of\r
+ object, any object of S has the attributes of the units S and T. Moreover,\r
+ the statements of that object come from the body of the unit T as well as\r
+ from that of the unit S.\r
+ \r
+ From the way of implementation it follows that prefixing is not a\r
+ macro-definition and so it does not require any pre-processing.\r
+1 - 37 -\r
+ \r
+ \r
+ 5.3.5. Formal parameters\r
+ ************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <formal parameter list>:\r
+ \r
+ ---> ( -----> <input parameters> ---------------> ) ---->\r
+ ^ ! ^ !\r
+ ! !--> <output parameters> -->! !\r
+ ! ! ! !\r
+ ! !--> <inout parameters> --->! !\r
+ ! ! ! !\r
+ ! !--> <type parameters> ---->! !\r
+ ! ! ! !\r
+ ! !--> <procedure parameter>->! !\r
+ ! ! ! !\r
+ ! !--> <function parameter> ->! !\r
+ ! !\r
+ !<----------- ; <------------------!\r
+ \r
+ \r
+ <input parameters>:\r
+ \r
+ ----> input -----> <specification list> ------->\r
+ ! ^\r
+ !----------->!\r
+ \r
+ \r
+ <output parameters>:\r
+ \r
+ ----> output ----> <specification list> ------->\r
+ \r
+ \r
+ <inout parameters>:\r
+ \r
+ ----> inout ----> <specification list> ------->\r
+ \r
+ \r
+ <type parameters>:\r
+ \r
+ ----> type ------> <identifier list> ----------->\r
+ \r
+ \r
+1 - 38 -\r
+ \r
+ \r
+ <procedure parameter>:\r
+ \r
+ ----> procedure ---> <procedure identifier> ---->!\r
+ !\r
+ !<-----------------------------------------!\r
+ !\r
+ !---> <formal parameter simp. list> ------>\r
+ ! ^\r
+ !----------------------------------->!\r
+ \r
+ <function parameter>:\r
+ \r
+ ---> function --> <function identifier> ------>!\r
+ !\r
+ !<----------------------------------------------!\r
+ !\r
+ !--> <formal parameter simp. list> --> : --> <type identifier> -->\r
+ ! ^\r
+ !-------------------------------->!\r
+ \r
+ \r
+ <formal parameter simp. list>:\r
+ \r
+ -------> ( --------> <input parameters> -----------------> ) ----->\r
+ ^ ! ^ !\r
+ ! !--> <output parameters> ->! !\r
+ ! ! ! !\r
+ ! !--> <inout parameters> -->! !\r
+ ! ! ! !\r
+ ! !--> <type parameters> --->! !\r
+ ! ! ! !\r
+ ! !-> <proc. simp. param.>-->! !\r
+ ! ! ! !\r
+ ! !--> <func. simp. param.>->! !\r
+ ! !\r
+ <----------------- ; <-------------------!\r
+ \r
+ \r
+ <procedure simp. parameter>:\r
+ \r
+ ----> procedure -----> <procedure identifier> ------>\r
+ \r
+ \r
+ <function simp. parameter>:\r
+ \r
+ ----> function -------> <function identifier> ------->\r
+1 - 39 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ \r
+ By a formal parameter list of a unit M we shall mean a concatenated list\r
+ of formal parameters of the bodies of all units M1, ...., Mk = M from the\r
+ prefix sequence of unit M (successively from 1 to k). The parameters\r
+ occurring in a unit declaration are called formal parameters to stress that\r
+ they constitute a pattern for parameters occurring in the unit body. At the\r
+ instant of object generation the actual parameters for this generation are\r
+ fixed. The relations between formal and actual parameters depend on the\r
+ transmission mode which is specified in the formal parameter list.\r
+ \r
+ Those relations make possible the communication between a unit and its\r
+ environment. The first mode of transmission rectricts the communication to\r
+ the input (as the beginning of the body) of the actual parameter value for\r
+ the corresponding formal parameter. The second mode restricts the\r
+ communication to the output (as the end of the body) of the formal\r
+ parameter value for the corresponding actual parameter. The third mode\r
+ possesses both possibilities of the input and output transmission modes. In\r
+ all three cases, the formal parameters are considered to be declared in the\r
+ unit body.\r
+ \r
+ The next two modes of transmission are designed for subprograms and\r
+ types. The occurrence of a formal subprogram/type in the unit body is\r
+ matched with the corresponding actual subprogram/type (which is assigned at\r
+ the beginning of the body execution). In the case of a formal subprogram, a\r
+ simplified description of its parameters is required.\r
+ \r
+ Hence a LOGLAN-82 unit may be parametrized and designates the union of\r
+ all units definable by assigning specific actual types to the formal ones.\r
+ The actual type cannot be a primitive one. Parametrized units make possible\r
+ the design of universal algorithms, which will be defined in detail at\r
+ lower levels of program nesting.\r
+1 - 40 -\r
+ \r
+ \r
+ 5.3.6. Unit body\r
+ ****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <class body>:\r
+ \r
+ ---> <inheritance list> ---> <protection list> ---> <body> ----->\r
+ ! ^ ! ^\r
+ !--------------------->! !------------------->!\r
+ \r
+ \r
+ <subprogram body>:\r
+ \r
+ ----> <inheritance list> ------> <body> ------>\r
+ ! ^\r
+ !---------------------->!\r
+ \r
+ \r
+ <inheritance list>:\r
+ \r
+ ----> taken -----> <identifier list> -----> ; ---->\r
+ ! ^\r
+ !-----------------------!\r
+ \r
+ \r
+ <protection list>:\r
+ \r
+ ------------> hidden -------------------> <identifier list> --> ; --->\r
+ ! ! !\r
+ !---------> close ------------>! !\r
+ ! !\r
+ !<--------------------------------------------------------------!\r
+ \r
+ \r
+ \r
+ <body>:\r
+ \r
+ ----> <declaration list> ---->!\r
+ ! !\r
+ <handlers' declaration> ---> begin --> <statement list> --> end -->\r
+ ! ^\r
+ !---------------------------!\r
+1 - 41 -\r
+ \r
+ \r
+ <declaration list>:\r
+ \r
+ !------------------------------------>!\r
+ ! !\r
+ --------> <declaration> -------> ; ---------------->\r
+ ^ !\r
+ !<------------------------------!\r
+ \r
+ \r
+ <statement list>:\r
+ \r
+ ------> <statement > ------->\r
+ ^ !\r
+ !<----- ; ------------!\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ In a unit body, a sequence of statements (if any) starts from the begin\r
+ symbol. Declarations/statements are separated by semicolons. An execution\r
+ of the unit body begins at the time of the generation of an object (of that\r
+ unit), see 9.1.2.. A declaration of a unit M is restricted at several\r
+ points :\r
+ \r
+ Restrictions\r
+ ------------\r
+ \r
+ (i) The least (textual) unit containing an occurrence of a\r
+ control statement inner (see 9.1.3.) must be a generalized\r
+ class. An inner statement may occur in the class body at\r
+ the most once. If it does not occur explicitly then the\r
+ body of unit M is assumed to contain the inner statement as\r
+ the last one (preceding the end symbol).\r
+ \r
+ (ii) All identifiers defined in the body of unit M are\r
+ different.\r
+ \r
+ (iii) The input/output formal parameters of unit M cannot be of a\r
+ type declared in unit M.\r
+ \r
+ (iv) If a type T is a formal parameter of unit M then its\r
+ occurrence in the list of parameters must precede the\r
+ occurrences of other parameters whose description makes use\r
+ of T;\r
+1 - 42 -\r
+ \r
+ \r
+ 6. Static and dynamic locations of identifiers. Visibility rules.\r
+ #################################################################\r
+ \r
+ \r
+ As noted before, a non-system identifier used in a program must be\r
+ defined in the program by a declaration or by a description in a formal\r
+ parameter list. An identifier need not correspond, however, to only one\r
+ syntactic entity. A program is composed of units, and so the user designing\r
+ a unit must pay attention to the relationship between a given unit and the\r
+ other ones. He should feel free to define his own attributes with the same\r
+ identifiers as those used in the other units as long as he is not\r
+ interested in the entities they describe. Therefore some strict rules of\r
+ correspondence between the identifier and the attribute as well as its\r
+ valuation are necessary. The first correspondence is called the static\r
+ location of an identifier, and the second is called the dynamic location.\r
+ The static location is determined by the syntactic structure of a program.\r
+ The dynamic location depends on the dynamic configuration of objects.\r
+ \r
+ \r
+ 6.1. Unit attributes\r
+ *********************\r
+ \r
+ \r
+ A set of attributes is assigned to each unit M. This set consists of all\r
+ syntactic entities defined in M and in the prefix sequence of M. Most of\r
+ them form the set of attributes which belong to each object of the unit,\r
+ i.e., they are dynamic. Virtual functions and procedures are attributes of\r
+ a very special kind. They are presented separately in 6.4.1. Some other\r
+ attributes, like constants, are static, i.e., they are not attrributes of\r
+ the objects of the unit but of the unit itself. Therefore static attributes\r
+ cannot be accessed by means of dot notation (cf 8.2.3.).\r
+ The user may protect attributes. The protection mechanisms are introduced\r
+ in the following sections and discussed in 8.2.3.\r
+ LOGLAN-82 identifiers cannot be overloaded, i.e., an identifier used in\r
+ the given unit corresponds to "exactly one" attribute determined by the\r
+ context. However, identifiers may be redefined. Therefore strict\r
+ correspondence between the occurrences of the identifiers and the\r
+ attributes must de defined.\r
+ Let W be a syntactic entity and M a syntactic unit. We say that W is\r
+ defined in M iff W is a formal parameter of M (but not of the prefix of M)\r
+ or W is declared in M. If W is defined in M, the entity it denotes is the\r
+ meaning of W. From now on we shall use interchangeably the notions of an\r
+ identifier and of an attribute.\r
+ Let W be an identifier and M a unit. If W is defined in M or in a unit\r
+ from M's prefix sequence, then W corresponds to an attribute of M. More\r
+ precisely, the corresponding attribute is the one defined in M, if it\r
+ exists, or the one defined in the prefix sequence. That means that the\r
+ redefinition of an identifier in a prefixed unit covers the attribute\r
+ corresponding to that identifier.\r
+1 - 43 -\r
+ \r
+ \r
+ 6.2. Protected attributes\r
+ *************************\r
+ \r
+ Let us consider a declaration of a prefixed unit. Let M be such a unit\r
+ and N its prefix. The attributes of N are visible in M (unless covered by\r
+ the local redefinition). The user, however, can restrict the use of N's\r
+ attributes in M. The protection may be specified already in unit N as well\r
+ as in M. The first way corresponds to the hidden specification while the\r
+ second to the taken specification.\r
+ \r
+ \r
+ 6.2.1. Hidden attributes\r
+ ************************\r
+ \r
+ \r
+ A list of hidden attributes is a filter from the prefixing unit. The user\r
+ may specify within prefix N the attributes whose occurrence is illegal in\r
+ any unit prefixed by N (unless the identifiers of these attributes are\r
+ covered by the redeclarations). Remote access to such attributes is\r
+ forbidden as well (cf 6.2). The absence of hidden specification denotes the\r
+ empty list.\r
+ Consider an example:\r
+ \r
+ unit N : class;\r
+ hidden x, y, z;\r
+ var x, y, z:integer;\r
+ ...\r
+ end N;\r
+ \r
+ unit M:N class;\r
+ hidden x, t;\r
+ var x, y, t:integer;\r
+ ...\r
+ end M;\r
+ \r
+ Variables x, y declared in N are redeclared in M, and so the identifiers\r
+ x, y in M refer to the local entities. Variable t is declared in M and is\r
+ hidden in the units prefixed by M. Variable z is hidden in N, hence it\r
+ cannot be used in M.\r
+1 - 44 -\r
+ \r
+ \r
+ 6.2.2. Taken attributes\r
+ ***********************\r
+ \r
+ \r
+ The list of taken attributes is a filter on the prefixed unit. In unit M\r
+ the user may specify explicitly the attributes from prefix N which are used\r
+ in M. Then in M the only attributes accessible from N are those from the\r
+ taken list. The occurrence of another attribute from N in M's body is\r
+ illegal. The absence of taken specification denotes the list of all (legal\r
+ and not hidden) identifiers from N. This means that the user is not\r
+ interested in the specification of this kind of filtering.\r
+ The identifiers in the taken list must be defined in the prefix sequence,\r
+ not in unit M. An exception is an identifier of a virtual attribute (cf\r
+ 6.4.).\r
+ \r
+ \r
+ 6.2.3. Legal and illegal identifiers\r
+ ************************************\r
+ \r
+ In this section we consider only identifiers corresponding to the\r
+ attributes of a given unit.\r
+ \r
+ All identifiers defined in a unit are legal in that unit. In particular,\r
+ all identifiers declared in a non-prefixed unit are legal.\r
+ \r
+ Now let M be a unit, N its prefix and W an identifier not defined in M.\r
+ Then W is a legal identifier corresponding to an attribute of M iff\r
+ \r
+ \r
+ - W is legal in N\r
+ - W does not occur in the hidden list in N\r
+ - W occurs in the taken list in M or this list is absent\r
+ \r
+ \r
+ All identifiers specified in every context in a unit must be legal in\r
+ that unit. All identifiers specified in the taken list must be legal in the\r
+ prefix.\r
+ \r
+ An identifier is illegal in a unit iff it denotes an attribute of the\r
+ unit (according to 6.1) and that attribute is not legal.\r
+1 - 45 -\r
+ \r
+ \r
+ 6.2.4. Close attributes\r
+ ***********************\r
+ \r
+ \r
+ Close attributes are not accessible by means of remote access (cf.\r
+ 8.2.3.) outside the unit.\r
+ \r
+ Let M be a unit with the prefix sequence M1, ..., Mk=M. An attribute W of\r
+ unit M is called a close attribute if W occurs in the close list of Mj for\r
+ some j, 1<=j<=k, and W is not redefined in any unit following that Mj in\r
+ the prefix sequence. However, remote access to a close attribute W is\r
+ allowed within the text of the unit M specifying it to be close, i.e., if\r
+ the static qualification of the object expression is equal to M, remote\r
+ access to W is allowed in all the units declared (directly or indirectly)\r
+ in M.\r
+ \r
+ The list of close attributes must consist of legal identifiers. All\r
+ hidden attributes are simultaneously close attributes.\r
+ \r
+ \r
+ Example\r
+ -------\r
+ \r
+ block\r
+ var v:A;\r
+ unit A: class;\r
+ hidden z;\r
+ close x;\r
+ var x, z:real, y:A;\r
+ \r
+ unit B:A class;\r
+ var t:B;\r
+ begin\r
+ \r
+ ... z ... (* is illegal since hidden in A *)\r
+ ... x ... (* is legal *)\r
+ .. y.x+y.z .. (* is legal since y is qualified by A\r
+ and the expression is within A *)\r
+ ... t.x .. (* is illegal since t is qualified by B *)\r
+ \r
+ end B;\r
+ begin\r
+ \r
+ ... v.x+y.x .... (* is legal *)\r
+ \r
+ end A;\r
+ \r
+ begin (* outside A *)\r
+ \r
+ ... v.z .. (* is illegal since hidden, and so close as well *)\r
+ ... v.y.x ... (* is illegal since x is close *)\r
+ end\r
+1 - 46 -\r
+ \r
+ \r
+ 6.3. Static location\r
+ *********************\r
+ \r
+ \r
+ We say that the occurrence of an identifier W is in a unit M if M is the\r
+ syntactic unit most tightly enclosing that occurrence. On the basis of the\r
+ program structure every occurrence of an identifier W in a unit M can be\r
+ unequivocally related to a unit N, where the corresponding attribute W is\r
+ defined. The unit N is called the static container for that occurrence of W\r
+ in M and is denoted by SC(W, M).\r
+ More precisely, by a static container of an occurrence of an identifier W\r
+ in a unit M we mean a syntactic unit N such that:\r
+ \r
+ - W is defined in N\r
+ \r
+ - there exists a unit P satisfying the following conditons:\r
+ \r
+ \r
+ (1) N belongs to the prefix sequence of P (or is P),\r
+ (2) M is declared in P directly or indirectly,\r
+ (3) there is no other unit closer to M than P satisfying (2) in\r
+ which W is an attribute,\r
+ (4) N is P's nearest prefix defining W\r
+ (5) if W is illegal (hidden or not taken) in P, then the static\r
+ container is undefined.\r
+ \r
+ The following figure illustrates this definition\r
+ \r
+ the prefix sequence of P\r
+ P <-------- R <------------ SC(W,M)=N ... declaration of W ...\r
+ ^\r
+ !\r
+ .\r
+ .\r
+ .\r
+ ^\r
+ !\r
+ M ... the occurrence of W ...\r
+ \r
+ \r
+ The static location of an identifier W is defined for the occurrence of W\r
+ in a unit M iff there exists a static container SC(W, M). Every program\r
+ must be an expression in which the static location is defined for all\r
+ occurring identifiers.\r
+ The static container is sufficient to determine the static attribute of a\r
+ unit (constant).\r
+1 - 47 -\r
+ \r
+ \r
+ Example.\r
+ --------\r
+ \r
+ Consider the following program\r
+ \r
+ block\r
+ unit M: class; var X ... end M;\r
+ unit N: M class; var X ... end N;\r
+ begin\r
+ pref N block (* P *)\r
+ var Y : ...;\r
+ unit R: class;\r
+ ... X ... Y ...\r
+ end R;\r
+ begin\r
+ new R;\r
+ ...\r
+ pref N block (* S *)\r
+ var Y : ...,\r
+ unit T: R class;\r
+ ... X ... Y ...\r
+ end T;\r
+ begin\r
+ new T;\r
+ ...\r
+ end S;\r
+ end P;\r
+ end\r
+ \r
+ \r
+ Here we have\r
+ \r
+ SC(X, R)=SC(X, T)=N\r
+ and SC(Y, R)=P, SC(Y, T)=S.\r
+1 - 48 -\r
+ \r
+ \r
+ 6.4. Objects\r
+ *************\r
+ \r
+ \r
+ \r
+ \r
+ An object O of type M with the prefix sequence M1, ..., Mk=M (k=>1) is:\r
+ \r
+ - a k-tuple of the form O = (<V1, M1>, ... <Vk, Mk>) where Vi\r
+ is the valuation of non-static attributes defined in the\r
+ unit Mi,\r
+ \r
+ \r
+ - and a unique reference pointing to this k-tuple.\r
+ \r
+ \r
+ Since the references are unique, two objects are different even if their\r
+ tuples are identical.\r
+ \r
+ Now let us define the valuation of an attribute of object O, depending on\r
+ the kind of that attribute:\r
+ \r
+ - the valuation of variables and variable parameters gives\r
+ their values,\r
+ \r
+ - the valuation of an attribute which is a subprogram is the\r
+ text of its declaration and an environment. (The environment\r
+ is the object containing the declaration of the subprogram.\r
+ In the case of a formal subprogram the value is determined\r
+ by the actual one (see 9.1.2.). The case of virtuals is\r
+ discussed below.)\r
+ \r
+ - an attribute which is a type has the value of the form:\r
+ (array_of)<j> text of declaration.\r
+1 - 49 -\r
+ \r
+ \r
+ 6.4.1. Virtual attributes\r
+ *************************\r
+ \r
+ \r
+ The main feature of virtual atributes is that a redeclaration of an\r
+ identifier denoting a virtual subprogram in a prefixed unit does not cover\r
+ the declaration in the prefix but replaces it in all occurrences. The\r
+ replacement takes place in the so-called virtual chains of identifiers. We\r
+ define this notion below.\r
+ Let F be a subprogram and M a unit. By a virtual chain of F in M we mean\r
+ a sequence of virtuals corresponding to the maximal subsequence N1, ..., Nk\r
+ of the prefix sequence of M such that:\r
+ \r
+ (1) F is a legal identifier in every Ni and denotes an attribute\r
+ specified as virtual (unit virtual F: ...)\r
+ (2) In all the units Ni except Nk, F must not occur in the\r
+ hidden list\r
+ (3) In all the units except N1, F must occur in the taken list\r
+ unless the list is not specified. F must not occur in the\r
+ taken list in N1 if the list is specified.\r
+ (4) After removing the declaration of F from N1, F should be an\r
+ illegal attribute in N1 (hidden in the prefix, not taken) or\r
+ should denote a non-virtual attribute\r
+ (5) If Nk is not M, then one of the following conditions must be\r
+ satisfied:\r
+ - F occurs in the hidden list in Nk,\r
+ - F does not occur in the taken list in the unit\r
+ prefixed directly by Nk if the list is\r
+ specified,\r
+ - F is redefined in the unit prefixed directly\r
+ by Nk as a non-virtual attribute (then it must\r
+ not occur in the taken list either).\r
+ The class Nk from the definition is called the end of the virtual chain.\r
+ For a given unit and an identifier there may exist more than one virtual\r
+ chain.\r
+1 - 50 -\r
+ \r
+ \r
+ Example 1.\r
+ ----------\r
+ \r
+ \r
+ M unit virtual F: <M-body>\r
+ \r
+ N unit virtual F: <N-body>\r
+ \r
+ P .... F ....\r
+ \r
+ R unit F: <R-body>\r
+ \r
+ S unit virtual F: <S-body>\r
+ hidden F;\r
+ \r
+ T unit F: <T-body>\r
+ \r
+ We have three virtual chains of F with respect to T. One is for F from the\r
+ classes M and N:\r
+ (F: <M-body>), (F: <N-body>),\r
+ The second is for F from the class S:\r
+ (F: <S-body>)\r
+ And the third one is for F in T:\r
+ (F: <T-body>)\r
+ \r
+ \r
+ Restrictions\r
+ ------------\r
+ \r
+ (i) All virtual attributes belonging to the same virtual chain must be of\r
+ the same kind (either function or procedure),\r
+ \r
+ (ii) All the declarations of the virtuals belonging to the same virtual\r
+ chain must have formal parameter lists of the same pattern, in particular:\r
+ \r
+ - the lists may use different names of formal parameters,\r
+ but the correspondence between formal types must remain\r
+ valid,\r
+ \r
+ - the class types of corresponding formal variables or\r
+ functions must belong to the same prefix sequence,\r
+ \r
+ - the types of variable parameters or formal functions in\r
+ the ending of the virtual chain must not be less strongly\r
+ defined than the types of the corresponding parameters in\r
+ the beginning, i.e., a formal or system type against a\r
+ statically defined type,\r
+ \r
+ - the types of virtual functions must be identical or the\r
+ type of the function from the beginning of the virtual\r
+ chain must be a prefix of the type of the function from\r
+ the ending,\r
+ \r
+ (iii) The compatibility of virtuals must be defined statically.\r
+1 - 51 -\r
+ \r
+ \r
+ Example 2.\r
+ ----------\r
+ \r
+ (1)\r
+ The following lists are not compatible\r
+ .... (type T; type P; X: T; Y: P) ....\r
+ .... (type R; type S; X: S; Y: R) ....\r
+ \r
+ \r
+ (2)\r
+ The following lists are compatible iff M and N belong to the same prefix\r
+ sequence (and both are classes)\r
+ .... (type T; Z: T; Z1: M) ....\r
+ .... (type P; X: P; Y: N) ....\r
+ \r
+ \r
+ (3)\r
+ The following lists are compatible iff M denotes a system type (coroutine\r
+ or process) or is a formal type\r
+ \r
+ at the beginning: (X: M; Y: real)\r
+ at the ending: (X:coroutine; Y:real)\r
+ \r
+ (4)\r
+ The following lists are not compatible:\r
+ \r
+ ... (Y:integer)\r
+ ... (Y:real)\r
+ \r
+ (5)\r
+ The lists of the function from the beginning of the chain\r
+ \r
+ ... function (Z:integer; Z1:P) : M\r
+ \r
+ and from the ending\r
+ \r
+ ... function (Z:integer; Z1:P) :N\r
+ \r
+ are compatible iff M is a prefix of N.\r
+1 - 52 -\r
+ \r
+ \r
+ 6.4.2. Valuation of virtuals\r
+ ****************************\r
+ \r
+ \r
+ Let O be an object of type M with the prefix sequence M1, ..., Mk=M. The\r
+ value of virtual attribute F declared in Mi is:\r
+ \r
+ - the text of the declaration taken from the end of the virtual chain,\r
+ - the environment of the object O.\r
+ \r
+ Example\r
+ -------\r
+ An object of the class T given in the example 1 from 6.4.1 is of the\r
+ following form:\r
+ \r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from N ! M !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from N ! N !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! ! P !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from R ! R !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from S ! S !\r
+ ---------------------------------------------\r
+ ! ! !\r
+ ! F : body F from T ! T !\r
+ ---------------------------------------------\r
+ \r
+ \r
+ The name "virtual subprogram" is derived from the features of virtual\r
+ entities, i.e., in any class a virtual subprogram F with an empty statement\r
+ list can be declared and then used as a virtual entity within the body of\r
+ the class. The user can assume the results of its execution without\r
+ knowledge of its internal structure. He can declare in a subclass a virtual\r
+ subprogram F again. This declaration replaces the previous one. So, during\r
+ the calls of the subprogram F in the body of the class as well as in the\r
+ body of the subclass, the subprogram with the text defined in the subclass\r
+ will be executed. This replacement is done only if F is a virtual attribute\r
+ of the subclass. Otherwise the new declaration of F covers the virtual\r
+ attribute of the class.\r
+1 - 53 -\r
+ \r
+ \r
+ \r
+ \r
+ Abstention from those rules permits us:\r
+ \r
+ (i) to define the types of the parameters of a virtual subprogram and to\r
+ check them already at compilation time,\r
+ \r
+ (ii) to execute the virtual subprogram declared at the beginning of the\r
+ prefix sequence; its body may be empty, but it is always defined,\r
+ \r
+ (iii) to end the virtual chain and to cover a virtual identifier by a\r
+ redeclaration.\r
+ \r
+ The possibilities (ii) and (iii) can be used in the following case. Let M\r
+ and N be system classes of the form :\r
+ \r
+ unit M: class;\r
+ unit virtual error: procedure;\r
+ (* virtual procedure to be defined in M's subclasses*)\r
+ end error;\r
+ begin\r
+ ...\r
+ if B1 then call error fi;\r
+ end M;\r
+ \r
+ unit N: M class;\r
+ unit virtual error: procedure;\r
+ (* the definition of the body of error. It\r
+ will be executed during the calls within N\r
+ as well as in M *)\r
+ end error;\r
+ begin\r
+ ...\r
+ if B2 then call error fi;\r
+ end N\r
+ \r
+ If the programmer prefixes his own units by class M, he can declare his\r
+ own virtual procedure error. If he does not intend to signalize any errors,\r
+ he is able to use M without a redeclaration. Then if the condition B1 is\r
+ satisfied, the procedure with an empty body will be called, i.e., no\r
+ statement will be executed. On the other hand, if the programmer uses N as\r
+ a prefix of his own units, he can redeclare his own non-virtual procedure\r
+ error. In consequence, during the execution of statements of the classes M\r
+ and N the procedure defined by this system in the class N will be executed.\r
+ However during the execution of the user's units the procedures defined by\r
+ himself will be executed.\r
+1 - 54 -\r
+ \r
+ \r
+ 6.5. Dynamic location\r
+ **********************\r
+ \r
+ An executable program must always be a well-formed expression. During its\r
+ execution we can deal with many objects of the same syntactic unit even at\r
+ the same time. Hence an execution of a statement (in an object) requires\r
+ identification and access to all the syntactic entities used. In order to\r
+ define the syntactic environment of object O (of unit M) a static link (SL)\r
+ is introduced. This link always points to an object O1 of a unit N such\r
+ that M is declared in N.\r
+ Let us consider the occurrence of identifier W within a body of class N\r
+ from the prefix sequence of M. Let SL(M) denote the SL-chain of objects\r
+ starting from an object of unit M. This means that SL(M) is a sequence of\r
+ objects O1, ..., Ok such that O1 is an object of unit M, Ok is an object of\r
+ the main program, the SL-link of object Oi points to object Oi+1, for every\r
+ i=1, ..., k-1.\r
+ \r
+ The dynamic container of the occurrence of W in a body of class N with\r
+ respect to an object O1 (denoted by DC(W, N, O1)) is an object Oi from\r
+ SL(M) such that:\r
+ \r
+ (*) Oi is an object of the unit prefixed by the static container SC(W,\r
+ N);\r
+ (**) Oi is the nearest object in the SL-chain such that Oi satisfies (*).\r
+ \r
+ Hence the dynamic container is the unique object which contains the\r
+ valuation of the entity W related to the occurrence of this entity. Let us\r
+ return to the example from 6.3.; after the creation (new T) of an object O\r
+ of the class T the SL-chain of O is as follows:\r
+ \r
+ -------------- ------------ ---------------\r
+ ! X ! M ! ! X ! M ! ! ! R !\r
+ <----- !------!-----! <------- !-----!----! <------ !-------!-----!\r
+ ! X ! N ! SL ! X ! N ! SL ! ! !\r
+ !------!-----! !-----!----! ! ! T !\r
+ OP ! Y,R ! P ! OS ! Y,T ! S ! O ! ! !\r
+ -------------- ------------ ---------------\r
+ \r
+ Because SC(X, R)=SC(X, T)=N , we have DC(X, R, O)=DC(X, T, O)=OS. Since\r
+ SC(Y, T)=S , we have DC(Y, T, O)=OS. On the other hand SC(Y, R)=P and DC(Y,\r
+ R, O)=OP.\r
+ The syntactic environment of an object is determined by the SL chain. Its\r
+ main property is that for each identifier occurrence in the statements of\r
+ the given object exists its dynamic container in the chain. In order to\r
+ define the dynamic location of identifier W occurring in object O of unit M\r
+ in a body of unit R (which belongs to the prefix sequence of M), the\r
+ following steps are performed:\r
+ \r
+ - a static container N=SC(W, R) is defined;\r
+ - a dynamic container O1=DC(W, R, O) is defined (in the SL chain of object\r
+ O, the nearest object O1 is found such that this object has a "layer" <V,\r
+ N>);\r
+ - a valuation V1(W) is found in the layers <V1, N1> of the object O1 such\r
+ that N1 is the nearest N's prefix.\r
+1 - 55 -\r
+ \r
+ \r
+ 7. Consistency of types\r
+ #######################\r
+ \r
+ In order to determine the context-sensitive correctness of an assignment\r
+ statement and parameter transmission it is necessary to introduce the\r
+ notion of the static consistency of types. Nevertheless this notion is not\r
+ sufficient to determine the correctness of the executions of those\r
+ constructs. Therefore, the notion of the dynamic consistency of types will\r
+ be introduced to define the semantic correctness of program. The introduced\r
+ distinction follows from the implementation constraints; namely, static\r
+ consistency is verified at compilation time, dynamic consistency is\r
+ verified at run time.\r
+ \r
+ \r
+ Static consistency of types\r
+ ---------------------------\r
+ \r
+ The type (array_of)<i>T is statically consistent with the type\r
+ (array_of)<j>S, where T and S are not array types, iff one of the following\r
+ conditions holds:\r
+ - i=j and T=S,\r
+ - i=j=0 and T, S are integer or real types,\r
+ - both T and S are formal types,\r
+ - T is a formal type, S is not a formal type and i<=j,\r
+ - S is a formal type, T is not a formal type and j<=i,\r
+ - i=j=0 and T, S are generalized class types and T pref* S or\r
+ S pref* T,\r
+ - i=j=0 and T and S are one of them a system type and the other a\r
+ generalized class or system type.\r
+ \r
+ \r
+ Dynamic consistency of types.\r
+ -----------------------------\r
+ \r
+ The type (array_of)<i>T is dynamically consistent with the type\r
+ (array_of)<j>S, where T and S are not array types, iff one of the following\r
+ conditions holds:\r
+ - i=j and T=S,\r
+ - i=j=0 and T, S are integer or real types,\r
+ - i=j=0 and T, S are generalized class types and T pref* S,\r
+ - i=j=0, T = coroutine, and S is declared as:\r
+ unit S: ... coroutine ...; or\r
+ unit S: ... process .....; or\r
+ unit S: R class..., where T is dynamically consistent with R,\r
+ - i=j=0, T = process, and S is declared as:\r
+ unit S: ... process .......; or\r
+ unit S: R class..., where T is dynamically consistent with R.\r
+ \r
+ At run time all formal types are replaced by actual non-formal ones.\r
+ Therefore, there is no reason to define dynamic consistency for formal\r
+ types.\r
+ Dynamic consistency is a subrelation of static consistency. Thus the\r
+ dynamic consistency is checked at compilation time, if possible. In other\r
+ cases the check is made at run-time.\r
+ From now on we shall use the following notation:\r
+ - for the desription of context properties, an occurrence of an\r
+ expression E is considered to be contained in the body of unit M,\r
+ - for the desription of semantic properties, an occurrence of an\r
+ expression E is considered to be contained in the body of unit M, with\r
+ respect to an object O of type M0 such that M pref* M0.\r
+1 - 56 -\r
+ \r
+ \r
+ 8. Expressions\r
+ ##############\r
+ \r
+ \r
+ Expressions are composed of primitive expressions - constants and\r
+ variables by means of system operators and functions. They serve as\r
+ patterns for computing a certain value. Two kinds of expression properties\r
+ have to be considered: context (static) and semantic (dynamic) ones.\r
+ \r
+ \r
+ \r
+ \r
+ Context properties.\r
+ -------------------\r
+ \r
+ We consider two context properties of each expression:\r
+ - to be a well-formed formula,\r
+ - to have a static type.\r
+ \r
+ The context correctness of an expression is examined at compilation time.\r
+ From now on, an expression is said to be a well-formed formula (shortly :\r
+ WFF) if it is statically correct. The static type of an expression is\r
+ determined by the program text.\r
+ \r
+ \r
+ \r
+ \r
+ Semantic properties.\r
+ --------------------\r
+ \r
+ We consider three semantic properties of each expression:\r
+ - to be defined,\r
+ - to have a dynamic type,\r
+ - to have the type of its value.\r
+ \r
+ In some cases (for expressions of formal types) type must be determined\r
+ at run-time. Replacing formal types by the corresponding actual ones in the\r
+ static types of expressions, we obtain the dynamic types of those\r
+ expressions. Notice, that the actual type may not be accessible, if the\r
+ dynamic container for the formal type of the expression was killed. The\r
+ dynamic type will be defined only for the expressions which may occur on\r
+ the left side of an assignment, i.e., for variables. When the value and the\r
+ type of the value are computed, the semantic correctness of the expression\r
+ is established.\r
+ From now on an expression is said to be defined if it is dynamically\r
+ correct at run-time. The correctness of an expression will be examined\r
+ under the assumption that it is a WFF. Five kinds of expressions are\r
+ distinguished: arithmetic, boolean, character, string, and object\r
+ expressions.\r
+1 - 57 -\r
+ \r
+ \r
+ 8.1. Constant\r
+ *************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <constant>:\r
+ \r
+ -----> <identifier> ----->\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ Let E be a constant Q. The expression Q is a WFF if the static container\r
+ SC(Q, M) exists. The static type of Q is determined by its declaration (see\r
+ 5.1.). A constant cannot occur on the left side of an assignment statement,\r
+ as an actual output parameter, or in an expression X.Q, where X is an\r
+ object expression.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The constant Q is always defined. The value of the constant is fixed from\r
+ the declaration of that constant and cannot be modified. The type of the\r
+ value is equal to the static type.\r
+ \r
+ \r
+ \r
+ 8.2. Variable\r
+ *************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <variable>:\r
+ \r
+ --------> <simple variable> ------------>\r
+ ! ^\r
+ !---> <subscripted variable>->!\r
+ ! !\r
+ !----> <dotted variable> ---->!\r
+ ! !\r
+ !----> <system variable> ---->!\r
+ \r
+ \r
+ For each kind of variables its context and semantic correctness will be\r
+ defined. Additionally the dynamic address of a variable will be defined as\r
+ a pair: (reference to an object, attribute of that object).\r
+1 - 58 -\r
+ \r
+ \r
+ 8.2.1. Simple variable\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ (simple variable>:\r
+ \r
+ ----> <identifier> ----->\r
+ \r
+ \r
+ Let E be a variable Z.\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ The variable Z is a WFF if the static container SC(Z, M) = R exists. The\r
+ static type of Z is determined by the declaration of Z and may be a formal\r
+ one.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The variable Z is defined if the dynamic container O1 = DC(Z, M, O)\r
+ exists. Let the static type of Z be: (array_of)<i>S. The dynamic type of Z\r
+ is equal to (array_of)<i>S in the case where S is not formal, otherwise it\r
+ is (array_of)<i+k>T, where the actual type corresponding to the formal one\r
+ is (array_of)<k>T.\r
+ The actual type is taken from the dynamic container DC(S, R, O1), i.e.,\r
+ from an object belonging to the SL chain of the object O1. The value of Z\r
+ is given by the corresponding valuation of Z in the object O1. The address\r
+ of Z is a pair: (the reference to O1, attribute Z of O1).\r
+1 - 59 -\r
+ \r
+ \r
+ 8.2.2. Subscripted variable\r
+ ***************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <subscripted variable>:\r
+ \r
+ --> <simple variable> --> ( -> <arithmetic expression> -----> ) -->\r
+ ^ !\r
+ !<----------- , --------------!\r
+ \r
+ \r
+ Let E be an expression of the form Z(A1, ..., Ak), where Z is a simple\r
+ variable and A1, ..., Ak are arithmetic expressions.\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ Let (array_of)<i>S denote a static type of Z. The expression Z(A1, ...,\r
+ Ak) is a WFF if:\r
+ - Z and A1, ..., Ak are WFFs,\r
+ - static types of A1, ..., Ak are integer or real,\r
+ - 1<=k<=i.\r
+ The static type of E is (array_of)<i-k>S.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The expression E is defined if:\r
+ - the expression Z(A1, ..., Ak-1) is defined and its value equals the\r
+ reference to a non-empty array object O1 with the bounds l and u, l<=u.\r
+ - the value of Ak is defined and its truncation l1 satisfies: l<=l1<=u.\r
+ The dynamic type of E is equal to the static one if S is not formal,\r
+ otherwise it is (array_of)<i-k+j>T where the actual type corresponding to\r
+ the formal one is (array_of)<j>T. The actual type is determined as for a\r
+ simple variable (see 8.2.1.). The value of E is that of the attribute (l1)\r
+ of the object O1. The address of E is the pair: (the reference to O1,\r
+ attribute (l1)).\r
+1 - 60 -\r
+ \r
+ \r
+ 8.2.3. Dotted variable\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <dotted variable>:\r
+ \r
+ -> <qualified object expression> -->. --> <variable> ---->\r
+ \r
+ \r
+ It is sufficient to consider the expression E of the form X.Y, where Y is\r
+ a simple or subscripted variable.\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ The expression E is a WFF if:\r
+ \r
+ \r
+ - X, Y are WFFs, X is the qualified object expression,\r
+ - the static type of X is a generalized class type,\r
+ - Y is a non-closed attribute of the static type of X.\r
+ \r
+ \r
+ The static type of E is the same as the static type of Y. Notice that the\r
+ static type of X cannot be a formal type.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The expression E is defined if:\r
+ \r
+ \r
+ - the expression X is defined,\r
+ - the value of X is a reference to a non-empty object O1.\r
+ \r
+ \r
+ The dynamic type of E is the same as the dynamic type of Y would be if Y\r
+ occurred in the object O1. The value of X.Y is that of the attribute Y of\r
+ the object O1. The address of X.Y is the address of Y would be if Y\r
+ occurred in O1.\r
+1 - 61 -\r
+ \r
+ \r
+ 8.2.4. System variable\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <system variable>:\r
+ \r
+ ------> result ---------------------------------------->\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ For every function F there is an implicitly declared variable result of\r
+ type T of the value of function F. The initial value of that variable\r
+ depends on type T (is equal to the default value of type T), the final\r
+ value (after completion of a function call) is also the value of function F\r
+ for the given call (see 9.1.2.). An occurrence of the variable result is\r
+ matched with the smallest unit F which contains that occurrence and which\r
+ is a function.\r
+ \r
+ \r
+ Example.\r
+ --------\r
+ \r
+ unit Newton_symbol: function (i, k:integer): integer;\r
+ var j: integer;\r
+ begin\r
+ if i>= k and k>=0\r
+ then result:=1;\r
+ for j:=0 to k-1\r
+ do\r
+ result:=result*(i-j)div(j+1)\r
+ od\r
+ fi\r
+ end Newton_symbol;\r
+1 - 62 -\r
+ \r
+ \r
+ 8.3. Arithmetic expression\r
+ **************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <arithmetic expression>:\r
+ \r
+ !------------------->!\r
+ ! !\r
+ -----------> <sign> --------> <term> ------->\r
+ ^ !\r
+ !<--------------------------------!\r
+ \r
+ \r
+ \r
+ <sign>:\r
+ \r
+ -----> + ----->\r
+ ! ^\r
+ !-> - -->!\r
+ \r
+ \r
+ \r
+ <term>:\r
+ \r
+ ---------> <factor> ----------------->\r
+ ^ !\r
+ ! !<-------------------!\r
+ ! ! ! ! !\r
+ ! ! ! ! !\r
+ ! * / div mod\r
+ ! ! ! ! !\r
+ ! ! ! ! !\r
+ !<-----------------!\r
+ \r
+ \r
+ \r
+ <factor>:\r
+ \r
+ ------------------ <integer> -------------------------------->\r
+ ! ^ ! ^\r
+ !-<abs>-! !---> <real> ---------------------------->!\r
+ ! !\r
+ !--> <constant> ------------------------->!\r
+ ! !\r
+ !--> <variable> ------------------------->!\r
+ ! !\r
+ !------> <function call> ---------------->!\r
+ ! !\r
+ !-> ( -><arithmetic expression>-> ) ----->!\r
+1 - 63 -\r
+ \r
+ \r
+ <integer>:\r
+ \r
+ -----> <digit> ------>\r
+ ^ !\r
+ !<------------!\r
+ \r
+ \r
+ <real>:\r
+ \r
+ !-------->!\r
+ ! !\r
+ ---> <integer>--> . ---> <integer>----->E --> <sign>--> <integer> -->\r
+ ! ^ ! ^\r
+ !------------------>! !---------------------------->!\r
+ \r
+ \r
+ (function call will be defined in 9.1.2.).\r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ The type of the value of an arithmetic expression is always equal to its\r
+ static type. The dynamic type is not to be defined. The context and\r
+ semantic properties of arithmetic expressions will be defined inductively.\r
+ \r
+ Factors.\r
+ The type of an integer is integer, the type of a real is real, their\r
+ values are given directly. Constant, variable, and function call must be\r
+ WFFs (in the meaning of 8.1., 8.2 and 9.1.2.), and of type integer or real\r
+ (in order to create a well-formed factor). The factor is defined iff the\r
+ variable and the function call are defined. The context and semantic\r
+ properties of the factors of the form " abs A1 ", and " (A2) " are the same\r
+ as those of arithmetic expressions A1 and A2, respectively. The value of "\r
+ abs A1 " is the absolute value of A1.\r
+ \r
+ \r
+ Terms.\r
+ The operators *, /, div, mod are interpreted as multiplication, division,\r
+ integer division and remaindering, respectively. The last two operators are\r
+ defined for integer arguments only, " A1 div A2 " is equal to the\r
+ truncation of A1/A2; " A1 mod A2 " is equal to the remainder of A1/A2. The\r
+ type of a term of the form <factor> <operator> <factor> is real if the\r
+ operator is /, or at least one of the arguments is of type real. The term "\r
+ A1/A2 " is defined if the value of A2 is different from 0. The value is\r
+ defined inductively if Av1 and Av2 are the values of factor A1 and term A2\r
+ respectively, and <W> is an interpretation of operator W, then the value of\r
+ a term of the form " A1 W A2 " is Av1 <W> Av2. If one of the arguments is\r
+ of type integer and the other is of type real then for the operators *, /\r
+ the integer type value is converted into a real type one.\r
+ \r
+ \r
+ Arithmetic expression.\r
+ An arithmetic expression of the form <term> <sign> <term> is of type\r
+ integer if both terms are of that type and it is of type real in the\r
+ opposite case. A value is defined inductively: if Av1 and Av2 are the\r
+ values of term A1 and arithmetic expression A2, respectively, then the\r
+ value of an expression A1+(-)A2 is Av1+(-)Av2, the value of +(-)A1 is\r
+ +(-)Av1. If one of the arguments is of type integer and the other is of\r
+ type real, then the integer type value is converted into a real type one.\r
+1 - 64 -\r
+ \r
+ \r
+ 8.4. Boolean expression\r
+ ***********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <boolean expression>:\r
+ \r
+ -------> <boolean term> ---------------->\r
+ ^ !\r
+ !<---- or <---------------!\r
+ \r
+ \r
+ <boolean term>:\r
+ \r
+ ------> <boolean factor> ---------->\r
+ ^ !\r
+ !<---- and <------------!\r
+ \r
+ \r
+ <boolean factor>:\r
+ \r
+ ----> not ----> <boolean primary> ------------>\r
+ ! ^\r
+ !-------->!\r
+ \r
+ \r
+ <boolean primary>:\r
+ \r
+ --------> <boolean constant> -------------------->\r
+ ! ^\r
+ !----> <constant> -------------------->!\r
+ ! !\r
+ !----> <variable> -------------------->!\r
+ ! !\r
+ !----> <function call> --------------->!\r
+ ! !\r
+ !----> <relation> -------------------->!\r
+ ! !\r
+ !--> ( --> <boolean expression> ->)--->!\r
+ \r
+ \r
+ <relation>:\r
+ \r
+ -----> <arithmetic relation> --------------->\r
+ ! ^\r
+ !-> <boolean relation> ----------->!\r
+ ! !\r
+ !-> <character relation> --------->!\r
+ ! !\r
+ !-> <reference relation> --------->!\r
+ ! !\r
+ !-> <object relation> ------------>!\r
+ \r
+ \r
+ <boolean constant>:\r
+ \r
+ -----> false -------->\r
+ ! ^\r
+ !--> true --->!\r
+1 - 65 -\r
+ \r
+ \r
+ <arithmetic relation>:\r
+ \r
+ ---> <arithmetic expression> --> <arithmetic relational operator>\r
+ !\r
+ !<-----------------------!\r
+ !\r
+ !---> <arithmetic expression> ---->\r
+ \r
+ \r
+ <arithmetic relational operator>:\r
+ \r
+ ----> <equality operator> --------->\r
+ ! ^\r
+ !-> <inequality operator> -->!\r
+ \r
+ \r
+ <equality operator>:\r
+ \r
+ ----------> = ---------------->\r
+ ! ^\r
+ !------> =/= ------->!\r
+ \r
+ \r
+ <inequality operator>:\r
+ \r
+ --------------------------------->!\r
+ ! ! ! !\r
+ < > <= >=\r
+ ! ! ! !\r
+ !------------------------------->\r
+ \r
+ \r
+ <character relation>:\r
+ \r
+ ---> <character expression> --> <equality operator> -->\r
+ !\r
+ !<-----------------------------------------!\r
+ !\r
+ !---> <character expression> ----->\r
+ \r
+ \r
+ <reference relation>:\r
+ \r
+ ---> <object expression> --> <equality operator> -->\r
+ !\r
+ !<----------------------------------------------!\r
+ !\r
+ !---> <object expression> ------>\r
+ \r
+ \r
+ <object relation>:\r
+ \r
+ ---> <object expression> ----> is ------> <system type> ------->\r
+ ! ^ ! ^\r
+ !--> in -->! !--> <class type> ---->!\r
+1 - 66 -\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ The context and semantic properties of boolean expressions can be defined\r
+ in the same way as those of arithmetic ones. A boolean expression is of\r
+ type boolean.\r
+ \r
+ Boolean primary.\r
+ The value of a boolean constant true and false is T and F, respectively.\r
+ The equality and inequality operators have the usual interpretation. Let\r
+ A1, A2 be two defined arithmetic expressions and let Av1, Av2 be their\r
+ values. Let <W> be an interpretation of the arithmetic relational operator\r
+ W. Then the value of arithmetic relation " A1 W A2 " is Av1 <W> Av2. If one\r
+ of the expressions is of type integer and the other is of type real then\r
+ the integer type value is converted into real type one.\r
+ \r
+ Let C1, C2 be two defined character expressions and let Cv1, Cv2 be their\r
+ values. Then the value of the character relation " C1=C2 " (" C1=/=C2 ") is\r
+ true iff the characters Cv1, Cv2 are identical (different). For string type\r
+ there are no relations, even no equality.\r
+ \r
+ A reference relation " X1=X2 " (" X1=/=X2 ") is a WFF if X1 and X2 are\r
+ well-formed object expression. The static types of the expressions have to\r
+ be statically consistent. The relation is defined if X1 and X2 are defined.\r
+ The value of that relation is true iff the values of both expressions are\r
+ equal to (different from) the same reference; in particular, if they are\r
+ both equal to none, then the value of " X1=X2 " is T.\r
+ An object relation "X is S" is a WFF if S is a generalized class\r
+ identifier, X is a WFF, and the static type of X is statically consistent\r
+ with S. An object relation "X in S" is a WFF if S is a generalized class or\r
+ system type identifier, X is a WFF, and the static type of X is statically\r
+ consistent with S. The value of the relation "X is S" is T iff the value of\r
+ the expression X is the reference to an object of class S. The value of the\r
+ relation "X in S" is T iff the value of X belongs to the set !S! .\r
+ \r
+ Boolean factor.\r
+ The value of a boolean factor "not B", where B is a boolean primary, is T\r
+ iff the value of B is F.\r
+ \r
+ Boolean term.\r
+ Let Bv2 and Bv1 be the values of boolean factor B2 and boolean term B1,\r
+ respectively. Then the value of a term of the form "B1 and B2" is T iff\r
+ Bv2=Bv1=T.\r
+ \r
+ Boolean expression\r
+ Let Bv1 and Bv2 be the values of boolean term B1 and boolean expression\r
+ B2, respectively. Then the value of an expression of the form "B1 or B2" is\r
+ F iff Bv1=Bv2=F.\r
+ \r
+ The value of the arithmetic and boolean expression is computed from left\r
+ to right with the following operator priorities:\r
+ (1) parentheses (, ), abs\r
+ (2) *, /, div, mod\r
+ (3) +, -\r
+ (4) <, <=, >, >=, =, =/=\r
+ (5) not\r
+ (6) and\r
+ (7) or.\r
+1 - 67 -\r
+ \r
+ \r
+ 8.5. Character expression\r
+ *************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <character expression>:\r
+ \r
+ ----> <character constant> --------------------->\r
+ ! ^\r
+ !---> <constant> --------------->!\r
+ ! !\r
+ !---> <variable> --------------->!\r
+ ! !\r
+ !---> <function call> ---------->!\r
+ \r
+ \r
+ <character constant>:\r
+ \r
+ ----> ' -----> <symbol> -----> ' ------>\r
+ \r
+ \r
+ <symbol>:\r
+ \r
+ -------> <letter> ---------------------------->\r
+ ! ^\r
+ !---> <digit> --------------->!\r
+ ! !\r
+ !---> <auxiliary sign> ------>!\r
+ ! !\r
+ !--> <other characters> ----->!\r
+ ! !\r
+ !-> (: --> <integer> --> :) ->!\r
+ \r
+ \r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ Constant, variable and function call are WFFs if they are of type\r
+ character. The standard function ord is defined for a character expression\r
+ and gives an integer value (dependent on implementation).\r
+1 - 68 -\r
+ \r
+ \r
+ 8.6. String expression\r
+ **********************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <string expression>:\r
+ \r
+ -----> <string constant> -------->\r
+ ! ^\r
+ !---> <constant> ------->!\r
+ ! !\r
+ !---> <variable> ------->!\r
+ ! !\r
+ !---> <function call> -->!\r
+ \r
+ \r
+ \r
+ <string constant>:\r
+ \r
+ ---> " -------> <character> ---------------------> " ----->\r
+ ! !\r
+ !<-------------------------------------!\r
+ \r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ Constant, variable and function call are WFFs if they are of string type.\r
+ The quotation mark " in the string constant is written twice "".\r
+ \r
+ Remark\r
+ ------\r
+ The string type is a constant type in the sense that the universe is\r
+ defined at compilation time and there are no string operations predefined\r
+ in the language. However, a standard function may transform a string into\r
+ an array of characters. Then the user can treat the array of character as a\r
+ text type and can define any set of suitable text operations.\r
+ \r
+ End of remark\r
+ -------------\r
+1 - 69 -\r
+ \r
+ \r
+ 8.7. Object expression\r
+ **********************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <qualified object expression>:\r
+ \r
+ --------> <object expression>--------------------------------------->\r
+ ! ^\r
+ !--> <variable>--------> qua -> <class type identifier> -->!\r
+ ! ^\r
+ !--> <function call> -!\r
+ \r
+ <object expression>:\r
+ \r
+ ----------> <object constant> --------------------->\r
+ ! ^\r
+ !-----> <variable> ------------>!\r
+ ! !\r
+ !---> <function call> --------->!\r
+ ! !\r
+ !---> <object generator> ------>!\r
+ ! !\r
+ !----> <local object> --------->!\r
+ ! !\r
+ !-----> <process waiting> ----->!\r
+ \r
+ <object constant>:\r
+ \r
+ -----> none -------- >\r
+ \r
+ <local object>:\r
+ \r
+ ----> this ----> <class type> --------->\r
+ \r
+ \r
+ (Function call and object generator will be defined in 9.1.2, process\r
+ waiting will be defined in 11.1. Variable is described in 8.2.).\r
+1 - 70 -\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ The constant none is of a fictitious type statically consistent with any\r
+ non-primitive type.\r
+ To define the context of a local expression let us recall that the\r
+ occurrence of the expression E is considered in the unit M. Let E be the\r
+ local object "this T", then E is a WFF if there exists a unit N such that M\r
+ decl* N and T pref* N, (i.e., there exists a unit N statically enclosing M\r
+ and containing T in its prefix sequence). The static type of the expression\r
+ E is T.\r
+ The qualified object expression of the form "X qua T" is a WFF if X is a\r
+ WFF and the static type of X is statically consistent with T. The static\r
+ type of this expression is T.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ The constant none is always defined as an empty object. Every compound\r
+ and system type is dynamically consistent with the fictitious type of none.\r
+ The value of the local object "this T" is the nearest object of the type T1\r
+ belonging to the SL chain of the object O such that T1 is prefixed by T,\r
+ (recall that O contains the given occurrence of the local object). The\r
+ expression "this T" is defined if its value exists. The dynamic type is not\r
+ to be defined. The type of the value is S. The qualified object expression\r
+ of the form "X qua T" is defined if X is defined, its value is different\r
+ from none, and the dynamic type of X as well as the type of its value are\r
+ dynamically consistent with T. The value of this expression is equal to the\r
+ value of X. The dynamic type is not to be defined.\r
+1 - 71 -\r
+ \r
+ \r
+ 9. Sequential statements.\r
+ ##########################\r
+ \r
+ \r
+ Sequential statements are patterns for the sequencing of primitive actions.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <sequential statement>:\r
+ \r
+ --------> <primitive statement> ------------>\r
+ ! ^\r
+ !-------> <compound statement> ---->!\r
+ \r
+ \r
+ \r
+ In a similar way to that followed in the description of expressions we\r
+ shall consider context and semantic properties of statements. A statement\r
+ will be called a WFF if it is correct at compilation time, and said to be\r
+ defined if it is correct at run time.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ \r
+ 9.1. Sequential primitive statements\r
+ *************************************\r
+ \r
+ \r
+ The result of an execution of a primitive statement consists in the\r
+ modification of:\r
+ - the valuation (assignment statement);\r
+ - the configuration (allocation and deallocation statement);\r
+ - the control (control statement).\r
+ \r
+ By a configuration we mean the set of all objects existing at a given state\r
+ of computation.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <primitive statement>:\r
+ \r
+ --------> <evaluation statement> ------------->\r
+ ! ^\r
+ !----> <configuration statement> ---->!\r
+ ! !\r
+ !----> <simple control statement> --->!\r
+ ! !\r
+ !----> <coroutine statement> -------->!\r
+ \r
+ \r
+1 - 72 -\r
+ \r
+ \r
+ 9.1.1. Evaluation statement\r
+ ****************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <evaluation statement>:\r
+ \r
+ --------> <empty statement> ---------------------->\r
+ ! ^\r
+ !----> <assignment statement> ------>!\r
+ ! !\r
+ !----> <copying statement> --------->!\r
+ \r
+ \r
+ \r
+ <empty statement>:\r
+ \r
+ --------------------------->\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ An execution of an empty statement has no effect.\r
+ \r
+ \r
+ \r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <assignment statement>:\r
+ \r
+ ------> <variable list> ---> := --> <expression> ---->\r
+ \r
+ \r
+ <variable list>:\r
+ \r
+ ----------> <variable> ------> , --------------->\r
+ ! !\r
+ ! !\r
+ <---------------------------------\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ An assignment statement of the form y1, ..., yk:=e is a WFF if:\r
+ - variables y1, ..., yk and expression E are WFFs;\r
+ - the static types T1, ..., Tk of variables y1, ..., yk are statically\r
+ consistent with the static type S of the expression E.\r
+1 - 73 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The execution of a statement consists of three steps : prologue, body and\r
+ epilogue.\r
+ \r
+ In the prologue the computation of the addresses of variables y1, ..., yk\r
+ is performed, i.e.:\r
+ \r
+ - For a dotted variable of the form X.z, the value of the expression X is\r
+ computed;\r
+ - For a subscripted variable of the form Z(i1, ..., ij) the value of the\r
+ expression Z(i1, ..., ij-1) is computed. If Z is of a formal type, then the\r
+ dynamic type T of the variable Z is determined. Finally the value of the\r
+ expression ij is computed.\r
+ \r
+ The above actions are performed from left to right.\r
+ \r
+ \r
+ During the body the computation of the type and the value of expression E\r
+ is performed.\r
+ \r
+ \r
+ The epilogue checks if the statement is well-defined and assigns the\r
+ values to the attributes determined by the addresses evaluated during the\r
+ prologue.\r
+ \r
+ An assignment is defined, if:\r
+ - the expressions y1, .., yk, E are defined;\r
+ - the dynamic types of y1, .., yk are defined and are dynamically\r
+ consistent with the type of the value of E.\r
+ \r
+ The values are assigned from right to left, i.e., at first the value of E\r
+ is assigned to yk (with possible conversion to the type of yk), next the\r
+ value of yk is assigned to yk-1 (with appropriate conversion), and so on.\r
+ For example, when r is real, n is integer, then:\r
+ \r
+ after r, n:=2.5 we have n=2, r=2.0,\r
+ after n, r:=2.5 we have r=2.5, n=2.\r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ The value of the expression Z computed at prologue may point to a non-empty\r
+ object O, but it could be changed to none as a result of the deallocation\r
+ of the object O (during the execution of the statement). It will be\r
+ detected at epilogue and will result in a run-time error.\r
+ \r
+ End of remark.\r
+ --------------\r
+1 - 74 -\r
+ \r
+ \r
+ An object of a compound type can be simultanously referenced by a number\r
+ of variables. If X and Y are the variables of such a type, then after\r
+ assignment X:=Y, both variables reference the same object. Hence some\r
+ side-effects may occur: the value of an attribute of the object referenced\r
+ by variable X can be changed as a result of an access to that object by\r
+ means of variable Y. In order to avoid such effects, one can use a copying\r
+ statement:\r
+ \r
+ X:=copy(Y)\r
+ \r
+ after which both variables reference identical objects but not the very\r
+ same one.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <copying statement>:\r
+ \r
+ -> <variable list> -> := -> copy -> ( -> <object expression> -> ) ->\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ The semantics of the copying statement differs from that of the assignment\r
+ statement in the following points:\r
+ \r
+ \r
+ - The copying statement is defined if the value of the right side object\r
+ expression E is a reference to a terminated class object (i.e., an object\r
+ whose all statements were completed, see 9.1.3). Coroutine or process\r
+ objects must not be copied.\r
+ \r
+ \r
+ - During the epilogue, the copy of the value of the expression E is\r
+ assigned (a copy of none is none).\r
+1 - 75 -\r
+ \r
+ \r
+ 9.1.2. Configuration statement\r
+ *******************************\r
+ \r
+ \r
+ Configuration statements correspond to the generation and deallocation of\r
+ units and arrays. Allocation of an array object is a result of array\r
+ generation, allocation of a unit object is a result of a subprogram call,\r
+ generation of a generalized class object or block statement.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <configuration statement>:\r
+ \r
+ -----> <object allocation> ------->\r
+ ! ^\r
+ !--> <object deallocation> -->!\r
+ \r
+ \r
+ 9.1.2.1. Allocation statement\r
+ *****************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <object allocation>:\r
+ \r
+ ------> <function call> ----------------->\r
+ ! ^\r
+ !--> <procedure call> -------->!\r
+ ! !\r
+ !--> <object generation> ----->!\r
+ ! !\r
+ !---> <block statement>------->!\r
+ ! !\r
+ !--> <array generation> ------>!\r
+ \r
+ \r
+ <function call>:\r
+ \r
+ ---> <remote function identifier> ---> <actual parameter list> ---->\r
+ ! ^\r
+ !--------------------------->!\r
+ \r
+ \r
+ <procedure call>:\r
+ \r
+ --> call --> <remote procedure identifier> -->!\r
+ !\r
+ !<-----------------------!\r
+ !\r
+ !---> < actual parameter list> ------------>\r
+ ! ^\r
+ !----------------------------------->!\r
+1 - 76 -\r
+ \r
+ \r
+ <object generation>:\r
+ \r
+ --> <qualified object expression> --> . --> new -----!\r
+ ! ^\r
+ !--------------------------------------! !\r
+ !\r
+ !--------------------------------------------------!\r
+ !\r
+ !--> <class identifier>---> <actual parameter list> -------->\r
+ ! ^\r
+ !---------------------------!\r
+ \r
+ \r
+ <remote function identifier>:\r
+ \r
+ ----> <qualified object expression> --> . -->!\r
+ ! ^ !\r
+ !----------------------------------------! !\r
+ !\r
+ !--------------------------------------------!\r
+ !\r
+ !---> <function identifier> --->\r
+ \r
+ \r
+ <remote procedure identifier>:\r
+ \r
+ ----> <qualified object expression> --> . -->!\r
+ ! ^ !\r
+ !----------------------------------------! !\r
+ !\r
+ !--------------------------------------------!\r
+ !\r
+ !---> <procedure identifier> --->\r
+ \r
+ \r
+ <actual parameter list>:\r
+ \r
+ ---->(----------------> <expression> ----------------> ) ---->\r
+ ^ ! ^ !\r
+ ! !-><remote function identifier>-------->! !\r
+ ! ! ! !\r
+ ! !-><remote procedure identifier>------->! !\r
+ ! ! ! !\r
+ ! !-><type identifier>------------------->! !\r
+ ! !\r
+ !--------------- , <---------------------------!\r
+1 - 77 -\r
+ \r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ We shall start with an allocation of a unit object O, i.e., subprogram\r
+ call, object generation and block statement. The execution of those\r
+ statements causes the generation of the new object O. Let Pa1, ..., Pak\r
+ denote actual parameters, k>=0, and let X be an object expression. The\r
+ allocation of an object of unit M is of one of the following forms:\r
+ \r
+ - for function M: M(Pa1, ..., Pak) or X.M(Pa1, ..., Pak)\r
+ (a function call must occur in an expression; it is not allowed as an\r
+ independent statement);\r
+ \r
+ - for procedure M: call M(Pa1, ..., Pak) or call X.M(Pa1, ..., Pak);\r
+ \r
+ - for class M: new M(Pa1, ..., Pak) or X.new M(Pa1, ..., Pak);\r
+ (an object generator may occur in an expression and it is also allowed as\r
+ an independent statement).\r
+ \r
+ - for block statement: pref M(Pa1, ..., Pak) block...end or block... end\r
+ (a block can be considered as an unnamed unit and a generation of its\r
+ object is the result of an occurrence of that block statement).\r
+ \r
+ \r
+ The allocation of a unit object is a WFF if:\r
+ \r
+ - a unit identifier M is visible (in the sense of the rules\r
+ used for the variables, see 8.2.),\r
+ - the actual parameters are WFFs,\r
+ - the formal parameter list and the actual parameter list\r
+ are statically compatible in the sense given below.\r
+ \r
+ Let us recall (5.3.5.) that a formal parameter list of a unit M is\r
+ defined as a concatenation of the lists of units belonging to the prefix\r
+ sequence of M.\r
+ \r
+ Static compatibility of parameters.\r
+ \r
+ The list of formal parameters (Pf1, ..., Pfj) is statically compatible\r
+ with the list of actual parameters (Pa1, ..., Pak) if j=k and for i=1, ...,\r
+ k the following conditions hold:\r
+ \r
+ - if Pfi is an input/output formal parameter then Pai is a\r
+ WFF of a static type which is statically compatible with\r
+ the static type of parameter Pfi,\r
+ - if Pfi is an output/inout parameter then Pai is a\r
+ variable,\r
+ - if Pfi is a formal function (procedure) then Pai is a\r
+ function (procedure) identifier,\r
+ - if Pfi is a formal type then Pai is a non-primitive type\r
+ identifier.\r
+1 - 78 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The allocation of a unit object O is defined if:\r
+ - the unit and its environment are determined,\r
+ - the list of formal parameters is dynamically compatible\r
+ with that of actual parameters (in the sense provided\r
+ below),\r
+ - three steps of actions, called prologue, body, and\r
+ epilogue, are determined.\r
+ \r
+ Note the difference between the unit identifier and the unit itself. The\r
+ environment is the object which becomes the syntactic father of O. In the\r
+ case of a formal subprogram, the unit identifier may be replaced by one of\r
+ many existing units. Denote by O1 the object containing the given unit\r
+ object allocation statement. The prologue computes the values for input\r
+ formal parameters, determines the addresses of output actual parameters,\r
+ and determines actual subprograms/types. The prologue is executed in the\r
+ environment of the object O1. The body transfers the control to the\r
+ statements from the prefix sequence of the given unit. Those statements are\r
+ executed in the environment of the object O.\r
+ The epilogue transmits the values of output formal parameters (in the\r
+ environment of the object O1).\r
+ \r
+ Unit environment\r
+ \r
+ Consider the allocation of a unit which is not a block. A unit identifier\r
+ has one of the following forms:\r
+ \r
+ (a) M,\r
+ (b) X.M or X.new M .\r
+ \r
+ Ad (a). Let the static location of the given occurrence of M be\r
+ determined by the attribute M of the unit T. Consider three cases:\r
+ \r
+ (a1) M is an attribute of T and it is neither a virtual attribute nor a\r
+ formal parameter. Then the declaration of M is determined as (at\r
+ compilation time) as the declaration of the attribute M of unit T. The\r
+ environment of the unit M is the dynamic container of identifier M with\r
+ respect to the object O1.\r
+ \r
+ (a2) M is a virtual attribute of T. Then the declaration of M is\r
+ determined at run-time by the dynamic location of identifier M with respect\r
+ to the given occurrence (see 6.1.5.). The environment is determined as in\r
+ (a1).\r
+ \r
+ (a3) M is a formal subprogram of T. Then the declaration of M and its\r
+ environment are taken from the dynamic container of the identifier M. The\r
+ dynamic container is determined with respect to the object O1.\r
+ \r
+ Ad (b). Let X be a well-formed object expression of type R, let M be a\r
+ not close attribute of R, and let the expression X be defined. Denote by O2\r
+ the non-empty object of unit R0 (R pref* R0) which is pointed to by X. The\r
+ cases (a1)-(a3) have to be considered in the same way as the above ones.\r
+ The descriptions differ in that the environments are determined with\r
+ respect to the object O2. Note that the environment of the object becomes\r
+ the syntactic father of the object O.\r
+1 - 79 -\r
+ \r
+ \r
+ Dynamic compatibility of parameters.\r
+ \r
+ First let us note the difference between the determination of dynamic type\r
+ for the actual parameter Pa and the formal parameter Pf. The dynamic type\r
+ of Pa is determined in the environment of the object O1 (containing the\r
+ given allocation). It means that for the formal type S the actual type is\r
+ taken from the dynamic container with respect to O1. Recall that it\r
+ corresponds to the determination of the valuation of identifier S in the\r
+ SL-chain of O1 (according to the visibility rules) and taking the text of\r
+ declaration assigned to S (cf. 6.1.5.).\r
+ The dynamic type of Pf is determined in the corresponding environment. It\r
+ means that for the formal type S the actual type is taken from the\r
+ corresponding dynamic container. In other words, the valuation of\r
+ identifier S is searched for in the SL-chain of the environment (according\r
+ to the visibility rules).\r
+ \r
+ The list of formal parameters is dynamically compatible with the list of\r
+ actual parameters if the following conditions hold:\r
+ \r
+ - if Pfi is an input formal parameter, then Pai is defined and\r
+ the dynamic type of Pfi is dynamically consistent with the\r
+ type of the value of Pai,\r
+ - if Pfi is an output/inout formal parameter, then Pai is\r
+ defined and the dynamic type of Pai is statically consistent\r
+ (!) with the dynamic type of Pfi,\r
+ - if Pfi is a formal function (procedure), then the lists of\r
+ formal parameters of Pfi and that of Pai must be of the same\r
+ pattern (disregarding the descriptions of subprogram\r
+ parameters). They may differ in the parameter identifiers, and\r
+ they may differ in the class types of corresponding parameters\r
+ (however, the class types must belong to the same prefix\r
+ sequence),\r
+ - if Pfi is a formal function, then the dynamic type of Pfi\r
+ prefixes the dynamic type of Pai, or the two types are\r
+ identical.\r
+ \r
+ The above conditions are checked from left to right (i.e., for i=1, ...,\r
+ k).\r
+ \r
+ Recall that in the following description of prologue and epilogue the\r
+ computations of the values and addresses for formal parameters and actual\r
+ ones are performed in the syntactic environment of the object O1.\r
+1 - 80 -\r
+ \r
+ \r
+ Prologue.\r
+ \r
+ The prologue consists of the following steps:\r
+ \r
+ (i) The frame for a new object O is allocated, the object O1 is called\r
+ the dynamic father of the object O. The sequence of dynamic fathers creates\r
+ a chain called the DL chain (DL for dynamic links);\r
+ \r
+ (ii) For the input and inout formal parameter Pf, the value of the\r
+ corresponding actual parameter is computed and assigned to Pf;\r
+ \r
+ (iii) For the output and inout formal parameter Pf, the address of the\r
+ corresponding actual parameter Pa is computed (in other words, the prologue\r
+ of the assignment of Pf to Pa is performed);\r
+ \r
+ (iv) For the formal type parameter Pf, the corresponding actual type Pa\r
+ is determined. According to 6.1.5. the valuation of the object O assigns\r
+ the text of the determined type Pa to the identifier Pf. Therefore as long\r
+ as that object exists the access to Pf is well-defined and connected with\r
+ Pa;\r
+ \r
+ (v) For the formal subprogram parameter, the actual subprogram is fixed\r
+ (in the same way as the determination of the allocated unit and its\r
+ environment).\r
+ \r
+ \r
+ After the execution of the epilogue the control is transferred to the\r
+ object O. Let M1, ..., Mk=M be the prefix sequence of M. The execution of\r
+ the statements from the object O begins from the first statement of the\r
+ unit M1 (for the description of the further progress of computation, see\r
+ inner statement, 9.1.3.). Note that those statements are executed in the\r
+ syntactic environment of the object O. When the control returns to the\r
+ calling object O1, the actions of the epilogue are performed.\r
+1 - 81 -\r
+ \r
+ \r
+ Epilogue.\r
+ \r
+ The epilogue consists of the following steps:\r
+ \r
+ (i) For the output and inout formal parameter Pf the actions of the\r
+ epilogue for the assignment Pa:=Pf are performed, where Pa is the actual\r
+ parameter corresponding to Pf. It means that the value of Pf (computed\r
+ during the execution of the body) is assigned to Pa (this address was\r
+ computed during the prologue);\r
+ \r
+ (ii) If the unit is a function, then the result of the given call is\r
+ determined by the current value of the corresponding variable result,\r
+ \r
+ (iii) If the unit is a generalized class, then the result of a new M is a\r
+ reference to the object O;\r
+ \r
+ (iv) A terminated object (cf. 9.1.3.) of a block or a subprogram is\r
+ deallocated. However, the terminated object of a generalized class is\r
+ accessible as long as there is a reference pointing to it (unless it is\r
+ directly deallocated by means of the kill statement).\r
+ \r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ Note that for the input formal parameter Pf of non-primitive type, the\r
+ value of the corresponding actual variable parameter Pa may be updated\r
+ (both the formal parameter and the actual one point to the same object). In\r
+ order to access the value of Pa without the possibility of its modification\r
+ one can use the copying statement Pf:=copy(Pf) at the end of the unit body.\r
+ \r
+ End of remark.\r
+ --------------\r
+1 - 82 -\r
+ \r
+ \r
+ Array generation.\r
+ -----------------\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <array generation>:\r
+ \r
+ ----> new_array -----> <variable > -----> ( -->!\r
+ !\r
+ !<----------------------------------------------!\r
+ !\r
+ !--> <arithmetic expression> --> : --> <arithmetic expression>--> ) -->\r
+ \r
+ \r
+ A declaration of a variable of an array type fixes the type of the array\r
+ elements; bound pairs are fixed at the time of generation.\r
+ \r
+ CONTEXT.\r
+ --------\r
+ \r
+ A statement new_array Y dim (l:u) is a WFF if:\r
+ \r
+ - Y is a variable of the type (array_of)<i>T, where i>0, T is a type\r
+ identifier;\r
+ \r
+ - l, u are WFFs and arithmetic expressions.\r
+ \r
+ The above statement is considered to be an assignment of a reference (to a\r
+ newly created object) on the variable Y.\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The following actions are performed:\r
+ \r
+ - determine the address of variable Y;\r
+ - compute the values l1, u1 of expressions l, u;\r
+ - put l0, u0 truncations of l1, u1 respectively;\r
+ - check the condition l0<=u0;\r
+ - generate an array object and assign its address to Y.\r
+ \r
+ The initial values of attributes (l0), ..., (u0) depend on their type of\r
+ the form (array_of)<i-1>T.\r
+ The value of an array type variable may be changed by means of\r
+ assignment, copying, and generation statements. The generation of an\r
+ n-dimensional array consists of n steps. The first dimension is generated:\r
+ e.g. new_array Y dim (l1:u1),\r
+ next the second dimension:\r
+ e.g. for i:=l1 to u1 do new_array Y(i) dim (li2:ui2) od\r
+ and so on. Unregular arrays can be generated in this way.\r
+1 - 83 -\r
+ \r
+ \r
+ 9.1.2.2. Deallocation statement\r
+ *******************************\r
+ SYNTAX.\r
+ -------\r
+ <object deallocation>:\r
+ \r
+ ----> kill ----> ( ----> <object expression> ----> ) --->\r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ A statement kill(X) is a WFF if X is a well formed object expression of\r
+ compound type. The statement kill(none) is always WFF and it is equivalent\r
+ to the empty statement.\r
+ The statement is defined if X points to an object O not belonging to the\r
+ SL chain or DL chain of an active object. By an active object we mean the\r
+ object containing the statement currently being executed (notice that in\r
+ the case of parallelism there may co-exist several active objects).\r
+ The execution of the statement results in the deallocation of object O,\r
+ all variables pointing to O are set to none. The deallocation of an object\r
+ which belongs to the SL chain or DL chain of an active object results in a\r
+ run-time error.\r
+ The statement kill(X) where X points to a coroutine head is described in\r
+ 9.1.4. The statement kill(X) where X points to a process is described in\r
+ 11.1.\r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ After a block or subprogram termination, the corresponding object is\r
+ automatically deallocated. On the other hand, the array, class, coroutine,\r
+ or process objects are not automatically deallocated. The computer memory\r
+ may be overloaded with such objects even if they are no longer referenced.\r
+ Those objects are recovered with the help of the system program called the\r
+ garbage collector. The user can help in the execution of that system\r
+ program and increase the efficiency of his program execution if he\r
+ deallocates unnecessary objects. One should realize, however, what are the\r
+ effects of deallocation (in particular, a side effect consisting in the\r
+ modification of the values of all variables which point to the same\r
+ deallocated object).\r
+ \r
+ End of remark.\r
+ --------------\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ The deallocation of a binary tree can be performed by means of the\r
+ following recursive procedure:\r
+ \r
+ unit tree_kill: procedure (n:node);\r
+ begin\r
+ if n.l=/=none then call tree_kill(n.l) fi;\r
+ if n.r=/=none then call tree_kill(n.r) fi ;\r
+ kill(n)\r
+ end tree_kill\r
+ \r
+ where the class node has the form\r
+ \r
+ unit node: class;\r
+ var l, r: node ;\r
+1 - 84 -\r
+ \r
+ \r
+ end node;\r
+1 - 85 -\r
+ \r
+ \r
+ 9.1.3. Simple control statement\r
+ ********************************\r
+ \r
+ \r
+ There are two kinds of simple control statements: a textual control\r
+ statement and a dynamic control statement. In this section we shall\r
+ consider the occurrence of a control statement in the object O of the unit\r
+ M, in the body of the unit Mj, where M has the prefix sequence M1, ...,\r
+ Mk=M, and 1<=j<=k.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <simple control statement>:\r
+ \r
+ -----> <textual control statement> -------->\r
+ ! ^\r
+ !--> <dynamic control statement> --->!\r
+ \r
+ <textual control statement>:\r
+ \r
+ -------> inner ----->\r
+ ! !\r
+ ! !\r
+ !-----> exit ----->!\r
+ ! ! ! !\r
+ ! !<------! !\r
+ ! ! !\r
+ !---> repeat ----->!\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ For j=1, ..., k-1 the execution of the inner statement results in the\r
+ commencement of the execution of the unit Mj+1. The inner statement in the\r
+ body of the unit Mk=M is empty.\r
+ \r
+ ------- ------- ------- -------\r
+ ! ! ! ! ! ! ! !\r
+ inner < inner < ........ < inner < .....\r
+ ! ! ! ! ! ! ! !\r
+ ------- ------- ------- -------\r
+ \r
+ body of M1 body of M2 body of Mk-1 body of Mk\r
+ \r
+ The semantics of repeat and exit statements will be defined jointly with\r
+ the semantics of a loop statement, see 9.2.3..\r
+1 - 86 -\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <dynamic control statement>:\r
+ \r
+ ---------> return ----------->\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ In this section we shall describe the semantics of a return statement and\r
+ a pseudo-statement end (which bound a unit declaration).\r
+ An object may be in one of the following three states: non-generated,\r
+ generated, terminated. An object is non-generated until the control reaches\r
+ the first return statement. From that moment an object becomes generated.\r
+ An object is terminated after the execution of its end statement. The main\r
+ program is considered to be always generated. A generated object is\r
+ considered to have no dynamic father (its DL is none). Note that the\r
+ execution of a terminated object cannot be resumed. However, the execution\r
+ of the generated object of a coroutine or a process can be resumed and\r
+ suspended. The return statement is empty if M is a coroutine and O is\r
+ generated. If M is a block, subprogram, or generalized class and O is\r
+ non-generated then O becomes generated. The control returns to the dynamic\r
+ father of O. For a coroutine or process the statement following the return\r
+ statement is a reactivation point.\r
+ \r
+ Now we shall consider the execution of the final end. For j=2, ..., k the\r
+ execution of the final end results in the control transfer to the statement\r
+ following the inner statement from the unit Mj-1. Suppose that j=1. If O is\r
+ a non-generated object of a coroutine, then O becomes generated and the\r
+ control returns to the dynamic father of O. Otherwise (O is a\r
+ coroutine/process object) the object O becomes terminated. The control\r
+ transfer is the same as in the case of detach statement. Moreover, if M is\r
+ a process, then the control becomes idle (and the corresponding processor\r
+ may be released, see 11).\r
+1 - 87 -\r
+ \r
+ \r
+ 9.1.4. Coroutine statement\r
+ ***************************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <coroutine statement>:\r
+ \r
+ ------> detach ---------------------------------------------->\r
+ ! ^\r
+ !-----> attach ----> ( ---> <object expression>--> ) -->!\r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ By a chain of coroutine N with the head Ol we shall mean the DL chain of\r
+ objects O1, ..., Ol such that:\r
+ - for i=1, ..., l-1 the object Oi+1 is the dynamic father of Oi;\r
+ - Ol is the generated object of the coroutine N;\r
+ - Ol is non-terminated.\r
+ Thus the chain contains non-generated objects with the exception of the\r
+ head, which is generated but non-terminated.\r
+ The execution of a kill(X) statement where X points to the head Ol of the\r
+ coroutine chain results in a deallocation of the entire chain.\r
+ \r
+ The chain may be in one of the following two states:\r
+ - detached - the execution of the statements contained in this\r
+ chain is suspended, the object O1 contains a distinguished\r
+ point, called the reactivation point of the chain;\r
+ - attached - a statement from the object O1 is currently\r
+ executed.\r
+ \r
+ In the case of a sequential program exactly one chain is operational,\r
+ i.e., in the attached state. Note that a coroutine head may be the main\r
+ program. Coroutine control statements change the states of coroutine\r
+ chains. A reference to the coroutine chain W1 which has recently\r
+ transferred the control to the chain W is associated with chain W. Let us\r
+ denote this reference by CL (coroutine link). This link is then used by the\r
+ detach statement. Suppose that the object O (containing the occurrence of\r
+ the coroutine control statement) belongs to the chain W of the coroutine N\r
+ with the head Ol.\r
+ The statement attach(X) is a WFF if X is a well formed object expression\r
+ or the system variable main. The statement is defined if X points to the\r
+ head O1 of a coroutine chain W1. The execution of the statement results in\r
+ changing the state of W to a detached one and that of W1 to an attached\r
+ one. The statement determined by the reactivation point of the chain W1\r
+ starts its execution. The CL link to the chain W is associated with the\r
+ chain W1. If O=O1 then the statement is empty.\r
+ The statement detach is defined except the case where the CL link of\r
+ chain W is none. The execution of the statement results in detaching the\r
+ chain W and attaching the chain W1 determined by the corresponding CL link\r
+ associated with W. The statement following the detach statement is the\r
+ reactivation point of the chain W. The execution of the chain W1 is resumed\r
+ at its reactivation point.\r
+1 - 88 -\r
+ \r
+ \r
+ 9.2. Compound statements\r
+ *************************\r
+ \r
+ Compound statements define case analysis (conditional and case statement)\r
+ and iteration (loop statements).\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <compound statement):\r
+ \r
+ ----------> <conditional statement> -------->\r
+ ! ^\r
+ !-----> <case statement> ------->!\r
+ ! !\r
+ !-----> <loop statement> ------->!\r
+ \r
+ \r
+ \r
+ \r
+ 9.2.1. Conditional statement\r
+ *****************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <conditional statement>:\r
+ \r
+ ---> if --> <boolean expression> --> then --> <statement list>\r
+ ! ! !\r
+ !---> <orif list> ------->! !\r
+ ! ! !\r
+ !---> <andif list> ------>! !\r
+ !\r
+ !\r
+ !\r
+ <-----------------------------------------------!\r
+ ! !\r
+ !------> else --> <statement list> --------> fi ---------->\r
+ \r
+ \r
+ \r
+ \r
+1 - 89 -\r
+ \r
+ \r
+ <orif list>:\r
+ \r
+ ---- <boolean expression> ----------------->\r
+ ! !\r
+ !<------- or_if <----------!\r
+ \r
+ \r
+ <andif list>:\r
+ \r
+ ---- <boolean expression> ----------------->\r
+ ! !\r
+ !<------ and_if <----------!\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ \r
+ For the execution of an if statement of the form:\r
+ \r
+ if B1 or_if B2 ... or_if Bj\r
+ then\r
+ G\r
+ else\r
+ H\r
+ fi\r
+ \r
+ \r
+ the boolean expressions B1, .., Bj are evaluated in succession until the\r
+ first one evaluates to true, then the sequence G of statements is executed.\r
+ If none of the boolean expressions evaluates to true, then the sequence H\r
+ is executed. The conditional statement with the "else" part omitted is\r
+ equivalent to the conditional statement with the empty statement following\r
+ the else symbol. If the "andif" list occurs instead of the "orif" list,\r
+ then the expressions B1, ..., Bj are evaluated in succession until the\r
+ first one evaluates to false; then the sequence H is executed. Otherwise\r
+ the sequence G is executed. When a boolean expression occurs instead of an\r
+ "orif" or "andif" list, then its value controls the execution of the\r
+ conditional statement in the standard manner.\r
+1 - 90 -\r
+ \r
+ \r
+ 9.2.2. Case statement\r
+ **********************\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <case statement>:\r
+ \r
+ ----> case --!\r
+ !\r
+ !-----------!\r
+ ! !-------------------->!\r
+ ! ! !\r
+ ! <---- <statement list> <--- : -----! !\r
+ ! ! ! !\r
+ !-> <arithmetic expression> ---> when ---> ---<integer>-------->! !\r
+ ! ^ ! ^ ! !\r
+ ! ! -> <constant> ->! ! !\r
+ ! ! ! !\r
+ ! <----- , -------------! !\r
+ ! !\r
+ !-> <character expression> ---> when ---><character constant>->:-! !\r
+ ^ ^ ! ^ ! ! !\r
+ ! ! !-> <constant> ->! ! ! !\r
+ ! ! ! ! !\r
+ ! !<--------- , --------! ! !\r
+ ! ! !\r
+ !<------ <statement list> <----------! !\r
+ ! !\r
+ ! !\r
+ <------------------------------------------------------------!\r
+ ! !\r
+ ! !\r
+ !-> others ----> <statement list> ---------> esac ---->\r
+ \r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ A statement:\r
+ \r
+ case E\r
+ when l1:G1\r
+ ...\r
+ when lk:Gk\r
+ others H\r
+ esac\r
+ \r
+ is a WFF if E is an arithmetic or character expression and l1, ..., lk are\r
+ sequences of different constants. If the list H is empty, then the "others"\r
+ part can be omitted.\r
+ The case statement selects for execution a sequence Gi where the value of\r
+ E belongs to the sequence li. The choice others covers all values (possibly\r
+ none) not given in the previous choices. The choices in a case statement\r
+ must be mutually disjoint and if the "others" part is not present they must\r
+ exhaust all the possibile values of the expression E.\r
+ \r
+ \r
+ \r
+1 - 91 -\r
+ \r
+ \r
+ 9.2.3. Iteration statement\r
+ ***************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <iteration statement>:\r
+ \r
+ \r
+ -------> <loop statement> ---------------------------------------->\r
+ ! ^\r
+ !---> <loop statement with condition> --------------------->!\r
+ ! !\r
+ !---> <loop statement with control variable> -------------->!\r
+ \r
+ \r
+ <loop statement>:\r
+ \r
+ \r
+ ---> do -----> <statement list> ----> od --->\r
+ \r
+ \r
+ <loop statement with condition>:\r
+ \r
+ \r
+ --> while --> <boolean expression> --> do --> <statement list>--> od -->\r
+ \r
+ \r
+ <loop statement with control variable>:\r
+ \r
+ ---> for ---> <simple variable> -->:= --> <arithmetic expression> -->!\r
+ !\r
+ <------------------------------------------------------------------!\r
+ ! !\r
+ !--> step --> <arithmetic expression>----> to ----->!\r
+ ! !\r
+ !-->downto-->!\r
+ !\r
+ <---------------------------------------------------!\r
+ !\r
+ !-> <arithmetic expression> -->do--> <statement list>--->od -->\r
+1 - 92 -\r
+ \r
+ \r
+ CONTEXT and SEMANTICS.\r
+ ----------------------\r
+ \r
+ Let us start from the semantics of loop and exit statements. The loop\r
+ statement:\r
+ \r
+ do\r
+ G\r
+ od\r
+ \r
+ causes the iteration of the sequence G until an exit statement is\r
+ encoutered.\r
+ Consider the occurrence of the exit statement exit ... exit(k-times)\r
+ where k >=1 . Let us denote this statement by H. Suppose that statement H\r
+ occurs in l (l>=0) nested iteration statements G1, ..., Gl, i.e., the\r
+ statement G2 is nested in G1, G3 in G2, etc. Let M be the smallest unit\r
+ enclosing that occurrence of H.\r
+ If k>l then the execution of H causes the termination of the unit body M\r
+ (jump to the final end). Otherwise the iteration statement Gk terminates,\r
+ and either the execution of the iteration statement Gk-1 is continued if\r
+ k<l or the execution of the outermost iteration statement G1 terminates if\r
+ k=l.\r
+ The keyword repeat may occur just after the sequence of exit's. Then the\r
+ iteration statement Gk is continued (if k<=l), i.e., the control is\r
+ switched not outside but to the beginning of the loop without the execution\r
+ of the statements occurring after repeat. If the statement Gk is a loop\r
+ statement with the while condition, then the consequtive iteration starts\r
+ from the condition evaluation. If it is a for statement, then the\r
+ consequtive iteration starts with the change of the controlled variable\r
+ value.\r
+ \r
+ \r
+ Remark.\r
+ -------\r
+ \r
+ The goto statement is totally deleted from LOGLAN-82 (contrary to other\r
+ languages, like ADA where goto within a single unit is allowed). The\r
+ structured statements defined above were applied to many examples of known\r
+ algorithms. These exercises showed that the proposed structured statements\r
+ constitute a good balance point between a non structured goto-label\r
+ statement and a classical while statement (which often requires auxiliary\r
+ control boolean variables).\r
+ Notice that the above unit M body is considered to be "non-concatenated",\r
+ i.e., in the case of the jump to end symbol, this end is taken from the\r
+ body of M, not from the body of M concatenated with its prefix sequence. We\r
+ stress that the textual control statements do not lead outside one unit.\r
+ \r
+ End of remark.\r
+ --------------\r
+1 - 93 -\r
+ \r
+ \r
+ A loop statement with condition:\r
+ \r
+ while B\r
+ do\r
+ G\r
+ od\r
+ \r
+ is equivalent to a loop statement of the form:\r
+ \r
+ do\r
+ if not B then exit fi;\r
+ G\r
+ od\r
+ \r
+ A loop statements with controlled variables are of the forms:\r
+ \r
+ (*) for i:=A1 step A2 to A3 do G od\r
+ (**) for i:=A1 step A2 downto A3 do G od\r
+ \r
+ The controlled variable i must be of discrete type. The statement (*) is\r
+ equivalent to the following sequence of statements:\r
+ \r
+ Av1:=A1; Av2:=A2; Av3:=A3; i:=Av1;\r
+ while Av3>=i\r
+ do\r
+ G;\r
+ i:=i+Av2\r
+ od\r
+ \r
+ The statement (**) is equivalent to the above sequence of statements with\r
+ the condition Av3>=i replaced by Av3<=i and the assignment i:=i+Av2\r
+ replaced by i:=i-Av2. The variables Av1, Av2, Av3 are fictitious variables\r
+ introduced only in order to define the semantics. The expression step A2\r
+ may be omitted if the value of A2 equals 1. The value of the controlled\r
+ variable i should not be modified inside the loop (however, the result of\r
+ such a modification would be well-defined). Moreover, its value is\r
+ determined when loop is terminated according to the introduced semantics.\r
+1 - 94 -\r
+ \r
+ \r
+ Examples.\r
+ ---------\r
+ \r
+ \r
+ (1) A palindrome is a word which is identical when written from left to\r
+ right and conversely. The given algorithm looks for the first occurrence of\r
+ a palindrome in a text and writes its length, (if found).\r
+ \r
+ unit palindrome: procedure;\r
+ var i, j, k: integer,\r
+ text: array_of character;\r
+ begin\r
+ read(j);\r
+ new_array text dim (1:j);\r
+ for k:=1 to j\r
+ do\r
+ read (text(k))\r
+ od;\r
+ for i:=2 to j\r
+ do\r
+ k:=1;\r
+ while text(k)=text(i-k+1)\r
+ do\r
+ k:=k+1;\r
+ if k>i-k+1\r
+ then\r
+ write ("found at i-th item");\r
+ return\r
+ fi\r
+ od\r
+ od;\r
+ write ("not found")\r
+ end palindrome;\r
+1 - 95 -\r
+ \r
+ \r
+ (2) A dictionary is a data structure S with the following operations:\r
+ \r
+ member(x, S) - determines whether x is a member of S\r
+ insert(x, S) - replaces S by the union of S and (x)\r
+ delete(x, S) - replaces S by the difference of S and (x)\r
+ \r
+ The elements of the set S are assumed to be of the same type T and to be\r
+ ordered by the relation less. A dictionary will be implemented by means of\r
+ binary search trees. The user has the access to the operations member,\r
+ insert, and delete and does not have to bother about the way of their\r
+ implementation. Below we propose how to accomplish these operations as\r
+ coroutines.\r
+ \r
+ unit bst: class (type t; function less(x, y:t):boolean);\r
+ hidden root, e, i, d;\r
+ var root: node, member: e, insert: i, delete: d;\r
+ unit node: class (value: t);\r
+ var l, r: node;\r
+ end node;\r
+ \r
+ unit e: coroutine; (*elem- output attribute*)\r
+ close trick, q, v;\r
+ var trick, elem: boolean, q, v: node, x:t;\r
+ begin\r
+ return;\r
+ do trick, elem:=false; (* loop for member *)\r
+ q:=root;\r
+ v:=none;\r
+ while q=/=none\r
+ do\r
+ if less(x, q.value)\r
+ then v:=q; q:=q.l\r
+ else\r
+ if less(q.value, x)\r
+ then v:=q; q:=q.r\r
+ else elem:=true; exit\r
+ fi\r
+ fi\r
+ od;\r
+ inner; (* elem=true iff x belongs to S *)\r
+ detach;\r
+ od\r
+ end e;\r
+ \r
+ unit help: E coroutine;\r
+ taken trick, elem, q, v, x;\r
+ begin\r
+ inner; (* trick=true iff x does not belong to S *)\r
+ if not trick then exit fi;\r
+ if v=none\r
+ then root:=q\r
+ else\r
+ if less(x, v.value)\r
+ then v.l:=q\r
+ else v.r:=q\r
+ fi (* after insert or delete *)\r
+ fi (* attach new node q to its father v *)\r
+ end help;\r
+1 - 96 -\r
+ \r
+ \r
+ unit i: help coroutine;\r
+ taken trick, elem, q, x;\r
+ begin\r
+ trick:=true;\r
+ if elem then exit fi;\r
+ q:=new node(x) (* insert is a dummy if x belongs to S *)\r
+ end i;\r
+ \r
+ unit d: help coroutine;\r
+ taken elem, q;\r
+ hidden close w, u, s;\r
+ var w, u, s: node;\r
+ begin (* delete is a dummy if x does belong to S *)\r
+ if not elem then exit fi;\r
+ w:=q;\r
+ if q.r=none\r
+ then q:=q.l\r
+ else\r
+ if q.l=none\r
+ then q:=q.r\r
+ else u:=q.r;\r
+ if u.l=none\r
+ then u.l:=q.l; q:=u\r
+ else\r
+ do s:=u.l;\r
+ if s.l=none then exit fi;\r
+ u:=s\r
+ od;\r
+ s.l.:=w.l; u.l:=s.r;\r
+ s.r:=w.r; q:=s\r
+ fi\r
+ fi\r
+ fi;\r
+ kill(w)\r
+ end d;\r
+ \r
+ begin\r
+ member:=new e; insert:=new i; delete:=new d;\r
+ inner;\r
+ kill(member); kill(insert); kill(delete)\r
+ end bst;\r
+ \r
+ pref bst(t, less) block\r
+ taken member, insert, delete;\r
+ var y:t;\r
+ ...\r
+ begin\r
+ ...\r
+ member.x:=y;\r
+ attach(member);\r
+ if member.elem then ... fi;\r
+ ...\r
+ insert.x:=y;\r
+ attach(insert);\r
+ ...\r
+ delete.x:=y;\r
+ attach(delete);\r
+ ...\r
+ end;\r
+1 - 97 -\r
+ \r
+ \r
+ 10. Exception handling\r
+ #######################\r
+ \r
+ \r
+ This section defines the facilities for dealing with errors or other\r
+ exceptional situations that may arise during program execution. An\r
+ exception is an event that causes a suspention of normal program execution.\r
+ The occurrence of an exception is expressed by raising a signal. Executing\r
+ some actions in response to the arising of an exceptional situation, is\r
+ called signal handling.\r
+ \r
+ Signal names are introduced by signal specifications. Signals can be\r
+ raised by raise statements, or alternatively, their raising is caused by an\r
+ occurrence of a run-time error. When an exception arises, the control can\r
+ be passed to a user-pointed handler associated with the raised signal. The\r
+ principles of determining a handler that responds to the raised signals are\r
+ presented in 10.3.\r
+ \r
+ \r
+ 10.1 Signal specification\r
+ *************************\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <signal specification>:\r
+ \r
+ ----> signal ---> <signal name> ---> ( --> <formal par. list> --> ) -->; -->\r
+ ! ! !!\r
+ ! !-------------------------------->!!\r
+ !<---------------------- , ---------------------------!\r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ The signal specification defines signals which can appear in raise\r
+ statements and in signal handlers within the scope of the specification.\r
+ The identifiers of system signals, i.e., signals associated with run-time\r
+ errors, are not specified in the signal specification.\r
+ Signal identifiers are not accessible by remote access. They can occur,\r
+ however, in a hidden, close or taken list of a unit.\r
+1 - 98 -\r
+ \r
+ \r
+ 10.2 Signal handlers\r
+ ********************\r
+ \r
+ The response to one or more signals is specified by a signal handler.\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <handlers' declaration>:\r
+ \r
+ ---> handlers\r
+ !\r
+ !-----------> when ---> <signal name> --> : --> <statement list> --!\r
+ ! ! ! !\r
+ ! !<------ , -------! !\r
+ ! !\r
+ !--------<------------------------------------------------------!\r
+ !\r
+ !-----------> others ----> <statement list> --!\r
+ ! !\r
+ !----------------------------------------> end handlers\r
+ ! !\r
+ !-------------->\r
+ CONTEXT\r
+ -------\r
+ \r
+ Handlers' declaration may appear at the end of the declaration part of a\r
+ unit. All identifiers visible in the unit and the signal formal parameters\r
+ may be used in the handler statements. A handler can handle the named\r
+ signals. A handler corresponding to the choice others handles all signals\r
+ not listed in the previously specified handlers, including those whose\r
+ identifiers are not visible within the unit.\r
+ \r
+ Any statement (except inner) whose occurrence in a unit is legal may\r
+ occur in the handler.\r
+ \r
+ Restrictions\r
+ ------------\r
+ \r
+ The formal parameter lists of signals associated with the same handler\r
+ must be identical.\r
+ \r
+ Example\r
+ -------\r
+ \r
+ \r
+ handlers\r
+ when emptytree: T:=new treelem; return;\r
+ others write(" signal not handled"); raise Error;\r
+ end handlers\r
+1 - 99 -\r
+ \r
+ \r
+ 10.3. Signal raising\r
+ ********************\r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ \r
+ ----> raise ---> <signal name> --> ( --> <actual par. list> --> ) ----->\r
+ ! !\r
+ !----------------------------------->!\r
+ \r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ The signal name in the raise statement ought to be visible in the unit in\r
+ which the raise statement appears. The formal and actual parameter lists of\r
+ the signal must be compatible.\r
+ \r
+ Example\r
+ -------\r
+ \r
+ raise empty(exprstack);\r
+ raise end_of_file (input);\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ When a signal is raised, the normal process execution is suspended and\r
+ the control is passed to a signal handler. The actual parameters are\r
+ transmitted to the handler, as in the case of a procedure. However, the\r
+ crucial point of exception handling is the way in which such a handler is\r
+ searched for and activated. Below we present the principles of handler\r
+ determination.\r
+ \r
+ Let us assume that signal f is raised in object Ok. This object and its\r
+ corresponding DL-chain may be illustrated as follows:\r
+ \r
+ \r
+ ------------ ------------ ------------\r
+ ! ! ! ! ! !\r
+ ! ! !handlers ! ! !\r
+ ! !<---...........<---!when f !<---........<---!raise f !\r
+ ! ! ! ! ! !\r
+ ! ! ! ! ! !\r
+ ------------ ------------ ------------\r
+ O1 Oi Ok\r
+ \r
+ where O1 is the object of a coroutine or a process.\r
+1 - 100 -\r
+ \r
+ \r
+ The objects in the DL-chain of Ok are successively checked whether they\r
+ contain a handler for signal f or a handler corresponding to the choice\r
+ others. The object Ok is checked first, next the object Ok-1 is checked and\r
+ so on. This search stops when the first object Oi containing the handler\r
+ for f or the handler for others is found. If such a handler is not found in\r
+ this DL-chain, then the system trap handler is executed and the process\r
+ terminates.\r
+ For the situation presented in the figure, the handler from object Oi is\r
+ executed, provided that none of the objetcs Oi+1, ..., Ok contains a\r
+ handler for signal f or the handler for others.\r
+ \r
+ In a concatenated object, i.e., in an object corresponding to a unit with\r
+ a non-empty prefix, the handlers declared in the prefixing unit are covered\r
+ by the handlers declared in the prefixed unit if they have the same\r
+ identifiers. Thus the signal raised during the execution of the prefix\r
+ statements may be handled by a handler declared in the prefixed unit. The\r
+ handler corresponding to the choice others responds to all the signals not\r
+ listed in the handlers declared in the units from the prefix sequence. The\r
+ handler for the choice others is taken from the innermost unit (with\r
+ respect to prefixing).\r
+ \r
+ Example\r
+ -------\r
+ \r
+ block\r
+ unit A: procedure;\r
+ begin\r
+ ...\r
+ raise f\r
+ ...\r
+ end A;\r
+ unit B: procedure;\r
+ handlers\r
+ when f: .....; (* <----------- handler H1 *)\r
+ end handlers\r
+ begin\r
+ ...\r
+ call A;\r
+ ...\r
+ raise f;\r
+ ...\r
+ end B;\r
+ signal f;\r
+ handlers\r
+ when f: .....; (* <----------- handler H2 *)\r
+ end handlers;\r
+ begin\r
+ ...\r
+ raise f;\r
+ ...\r
+ call B;\r
+ ...\r
+ end\r
+ \r
+ If signal f is raised in the block satement, hanlder H2 will be executed.\r
+ If signal f is raised in procedure B or in procedure A, handler H1 will be\r
+ executed.\r
+1 - 101 -\r
+ \r
+ \r
+ block\r
+ signal f;\r
+ unit A:class;\r
+ signal g;\r
+ handers\r
+ when g: .....; (* <---------- handler G1 *)\r
+ end handlers;\r
+ begin\r
+ ...\r
+ raise f;\r
+ ...\r
+ raise g;\r
+ ...\r
+ end A;\r
+ unit B:A class;\r
+ handlers\r
+ when f: .....; (* <---------- handler F1 *)\r
+ when g: .....; (* <---------- hadller G2 *)\r
+ end handlers;\r
+ begin\r
+ ...\r
+ raise f;\r
+ ...\r
+ raise g;\r
+ ...\r
+ end B;\r
+ begin\r
+ ...\r
+ end;\r
+ \r
+ If signal f is raised in an object of class B, handler F1 will be\r
+ executed. If signal g is raised in an object of class B, handler G2 will be\r
+ executed even if the signal is raised in the statements of class A.\r
+1 - 102 -\r
+ \r
+ \r
+ 10.4. Handler execution\r
+ ***********************\r
+ \r
+ A handler execution terminates if one of the special control statements\r
+ is executed.\r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <handler termination>:\r
+ \r
+ ------> return ----->!\r
+ ! !\r
+ --->!---> wind --------------->\r
+ ! !\r
+ !---> terminate ---->!\r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ The statements wind and terminate may appear only within a handler\r
+ declaration. If none of them occurs in a handler statement list, the\r
+ statement terminate is assumed to be the last statement in such a list.\r
+ The execution of the statements wind and terminate causes an abnormal\r
+ termination of the corresponding objects from the DL-chain (see below). In\r
+ that case, the "last-will" statements are executed before the termination\r
+ of the objects.\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ <last-will statements>:\r
+ \r
+ -----> last_will ----> : ---> <statement list> ----------->\r
+ \r
+ CONTEXT\r
+ -------\r
+ \r
+ Any unit body may be terminated with a sequence of statements labelled by\r
+ last_will. They are not executed during normal program execution. The\r
+ statement inner must not occur within the "last-will" statements.\r
+1 - 103 -\r
+ \r
+ \r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ Let us assume that a signal f raised in an object Ok is handled by a\r
+ handler H from an object Oi:\r
+ \r
+ \r
+ O1 Oi-1 Oi Oi+1 Ok\r
+ ----- ----- ----- ----- -----\r
+ ! ! <---...<---! !<---! !<----! !<---........<---! !\r
+ ----- DL ----- DL ----- DL ----- DL -----\r
+ ! !\r
+ ! SL !\r
+ ----- !\r
+ ! ! H-------------------------------->!\r
+ -----\r
+ \r
+ The statement return in a handler has a similar effect to that of the\r
+ statement return in a procedure. The handler object is deallocated and the\r
+ control is passed to the statement just following the corresponding raise\r
+ f.\r
+ The execution of the statement wind causes the termination and the\r
+ deallocation of the objects H, Ok, ..., Oi+1. Before the termination of\r
+ each of them, the "last-will" statements, if any, are executed. They\r
+ complete the object execution. In the prefixed object the "last-will"\r
+ statements of each prefix are successively executed, starting from the\r
+ innermost and ending on the outermost prefix. When the termination and\r
+ deallocation of these objects is completed, the control is passed to object\r
+ Oi, where the computation is continued in a normal way. Note that the wind\r
+ statement in the case of k=i is equivalent to return.\r
+ \r
+ The statement terminate causes the termination and the deallocation of\r
+ the objects H, Ok, ..., Oi+1, Oi. They are completed as in the case of\r
+ wind, i.e., the "last-will" statements are executed as well. The control is\r
+ passed to Oi-1, if such an object exists. If Oi-1 does not exists, i.e., Oi\r
+ is the head of the DL-chain, then this head is terminated (cf. the\r
+ semantics of the end statement of coroutine and process).\r
+ \r
+ \r
+ Remark\r
+ ------\r
+ \r
+ If any control statement (raise, detach, attach, etc.) is executed within\r
+ the "last-will" statements and the control returns to the interrupted\r
+ object, the execution of the "last-will" statements as well as the\r
+ termination of the remaining objects in the DL-chain will be continued.\r
+ \r
+ End of remark\r
+ -------------\r
+1 - 104 -\r
+ \r
+ \r
+ 10.5. System signals\r
+ ********************\r
+ \r
+ Some of the signals, called system signals, are predefined in the\r
+ language. They are raised automatically when a run-time error or another\r
+ exceptional system situation appears.\r
+ System signals have no parameters. They are not declared in the signal\r
+ specification, but the user may declare handlers for them. The execution of\r
+ the statement return is not allowed in the handler responding to such a\r
+ signal (note that sometimes the statement wind is equivallent to return).\r
+ \r
+ The following signals are predefined in the language:\r
+ \r
+ acc_error\r
+ A remote access to a non-existing object or an error in the\r
+ expression ...x qua A (x does not exist or the type of the object\r
+ pointed to by x is not prefixed by the type A).\r
+ mem_error\r
+ There is no free space for the allocation of a new object.\r
+ num_error\r
+ A numerical error, such as for instance integer overflow,\r
+ floating-point overflow, division by zero etc.\r
+ log_error\r
+ Any kind of the LOGLAN Running System error (except access error)\r
+ like e.g., an attempt to pass the control in a way inconsistent\r
+ with the LOGLAN-82 rules, an attempt to kill an active object, etc.\r
+ con_error\r
+ The value of an index expression exceeds the range of array indices\r
+ or the array bounds are incorrect.\r
+ sys_error\r
+ Any kind of system error like e.g., input-output error, parity\r
+ error, etc.\r
+ \r
+ Some other errors may also be introduced as system errors but are not\r
+ predefined in the language.\r
+1 - 105 -\r
+ \r
+ \r
+ 11. Processes\r
+ ##############\r
+ \r
+ \r
+ Let us consider a snap-shot of a program's computation. This snap-shot is\r
+ called a configuration. Up till now a configuration has consisted of a\r
+ finite number of objects creating a number of coroutine chains. The main\r
+ program is the only chain with the head of process type.\r
+ Moreover, exactly one object has been considered "active" - i.e., its\r
+ statements have been executed by a physical processor. By a physical\r
+ processor we mean here an actual processor as well as the portion of time\r
+ of a central unit.\r
+ A configuration with many active objects illustrates the computation of a\r
+ program with parallel statements. Concurrent computation to some extent\r
+ generalizes coroutines, i.e., a configuration may contain many coroutine\r
+ chains with heads of coroutine type and many process chains with heads of\r
+ process type.\r
+ The fundamental notion is that of a process. A process may be treated as\r
+ a sequential program - only one statement of a process is being executed at\r
+ a time. A parallel program consists of a number of processes. In LOGLAN-82\r
+ a process is a system type. A process object may be generated by means of\r
+ the new statement. The generated process object is suspended with the\r
+ execution of the return statement. This process may be resumed by means of\r
+ the resume statement. After resumption, process statements are executed by\r
+ a new processor, concurrently with the other active processes. During its\r
+ computations, the process may suspend its actions (but not the actions of\r
+ other processes) by means of the stop statement, then it may be resumed\r
+ again, and so on.\r
+ Observe that the attach and detach statements switch the processors from\r
+ one object to another, while the resume and stop statements acquire and\r
+ release a processor respectively. Resumption of a coroutine chain is\r
+ connected with the control transfer from the active coroutine chain.\r
+ Resumption of a process chain acquires new processor for that chain.\r
+ Similarly, suspension of a coroutine chain gives the control back to\r
+ another chain, while suspension of a process chain releases the processor.\r
+ Note that a process object is more complex than a coroutine object. So\r
+ coroutine operations are more efficient with respect to time and space.\r
+ Therefore the user should use processes only when they are indispensable.\r
+1 - 106 -\r
+ \r
+ \r
+ In order to deal with communication among processes (e.g., by messages)\r
+ as well as their competition in acquiring a resource (such as a shared\r
+ variable) one should have the ability to define some synchronizing\r
+ operations. Those operations arise from the following constrains:\r
+ \r
+ - timing, i.e., mutual exclusion of actions;\r
+ - scheduling i.e., stating which of the waiting processes is to be resumed\r
+ as the first one.\r
+ \r
+ \r
+ For this purpose some synchronizing facilities are provided. One may think\r
+ of many such facilities, from low level ones, such as Dijkstra's semaphores\r
+ to high level ones, such as Hoare's monitors. The decision which one of the\r
+ synchronization methods should be chosen and incorporated into the language\r
+ is weighty. The primitive tools are difficult to use, but they are\r
+ efficient. The high-level constructs are safer, but they often limit\r
+ parallelism (because of the strong synchronizing constraints).\r
+ The synchronizing facilities introduced in LOGLAN-82 are elementary (low\r
+ level). Therefore they are implemented efficiently in the kernel of the\r
+ operating system. However, the high-level facilities e.g., monitors (see\r
+ [5], [6]), can be defined with their help. The user can, for a concrete\r
+ synchronization problem, make a choice between the pre-defined facilities\r
+ or program other ones. The low-level facilities are hidden when the high\r
+ level facilities are used. Thus, the properties of the latter cannot be\r
+ disturbed.\r
+ In any case, speaking about a parallel execution of processes, we mean\r
+ that they are executed really in parallel, independently of the relations\r
+ between a number of "ready" processes and a number of available processors\r
+ (the details of processor management are hidden in an operating system).\r
+ \r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <parallel statement>:\r
+ \r
+ ------> <process state transition> ----------------->\r
+ ! ^\r
+ !--> <primitive synchronizing statement> ----->!\r
+ \r
+ \r
+1 - 107 -\r
+ \r
+ \r
+ 11.1. Transition state statement\r
+ *********************************\r
+ \r
+ \r
+ Each process can be in one of five states: active, suspended, locked,\r
+ awaiting, terminated. The transitions among these states are described by\r
+ the following graph (where X denotes the reference to the given process and\r
+ Z a semaphore):\r
+ \r
+ \r
+ \r
+ ****************\r
+ * awaiting *\r
+ **************** X:=new\r
+ ! ! !\r
+ ! ! !\r
+ end of son! ! wait !\r
+ ! ! !\r
+ lock(Z) v ! v\r
+ ************* <------ ************* ------------> ***************\r
+ * locked * * active * stop * suspended *\r
+ ************* -------> ************* <----------- ***************\r
+ unlock(Z) ! resume(X)\r
+ !\r
+ ! end of X\r
+ !\r
+ v\r
+ ******************\r
+ * terminated *\r
+ ******************\r
+ \r
+ \r
+ \r
+ We shall now present the syntax and semantics of object expressions and\r
+ statements connected with the transitions of the process states:\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <process state transition>:\r
+ \r
+ !---> <process suspension> ------------>\r
+ ! !\r
+ !---> <process resumption> ------->!\r
+ ! !\r
+ !------> <process waiting> ------->!\r
+1 - 108 -\r
+ \r
+ \r
+ \r
+ \r
+ <process suspension>:\r
+ \r
+ -----> stop --------> ( ---> <variable> ----> ) ------->\r
+ ! ^\r
+ !--------------------------------->!\r
+ \r
+ \r
+ <process resumption>:\r
+ \r
+ ----> resume -----> ( ---> <object expression> ---> ) ------>\r
+ \r
+ \r
+ <process waiting>:\r
+ \r
+ -----> wait -------------------------------------------->\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ \r
+ From now on we shall consider the occurrence of the transition state\r
+ statement in the object O which belongs to the process R (i.e., there\r
+ exists a DL chain connecting the object O with the object O(R) of the\r
+ process R). If the process O(P) is generated in the process O(R), then the\r
+ process object O(R) is called the father of the process object O(P), and\r
+ O(P) is called a son of O(R).\r
+ The execution of the statement resume(X), where X points to the process\r
+ object, causes resumption of that process, providing that it was previously\r
+ suspended. Otherwise a run-time error occurs.\r
+1 - 109 -\r
+ \r
+ \r
+ The statement stop suspends the process R. The statement stop(Z) is a\r
+ WFF if Z is a variable of type semaphore. The execution of this statement\r
+ suspends the given process and simultaneously opens semaphore Z. The\r
+ indivisibility of those actions means that no other process can refer to\r
+ the variable Z in the meantime (the statement stop(Z) is useful in the\r
+ synchronization of processes, see 11.2.).\r
+ \r
+ A process may wait for the termination of its son with the help of the\r
+ wait expression. The execution of the expression wait in an object\r
+ belonging to the process R causes waiting for the termination of any son of\r
+ the process R. When the first such son terminates its actions, the\r
+ reference to that son is returned as the value of wait and process R\r
+ continues its computation. If the process S does not embrace a\r
+ non-terminated son, the value of the expression wait is none. Thus the\r
+ execution of the statement\r
+ \r
+ while wait =/= none do od\r
+ \r
+ causes waiting for the termination of all the sons of the given process.\r
+ \r
+ The execution of the deallocation statement kill(X) where X points to a\r
+ process depends on its state. When that process is suspended or terminated,\r
+ then the execution of this statement is the same as in the case of a\r
+ coroutine. Otherwise it results in a run-time error.\r
+ \r
+ \r
+ Relations between parallel and coroutine computations.\r
+ \r
+ LOGLAN-82's coroutine computations can easily be simulated by means of\r
+ parallel computations. Coroutine computations are provided in LOGLAN-82,\r
+ nevertheless, in order to deal with the case of interleaving processes.\r
+ With coroutines instead of processes, one can avoid unnecessary memory\r
+ overloading by data structures inherited for processes and, moreover,\r
+ unnecessary scheduler activations.\r
+ Each process is also a coroutine, and so a process may also be subject to\r
+ the coroutine operations detach and attach. Therefore, the description of\r
+ possible state transitions provided above should be extended to transitions\r
+ caused by coroutine operations.\r
+ The execution of attach(Y) in the active process X results in the control\r
+ transfer from process X to process Y, i.e., if Y is not suspended then the\r
+ statement is illegal, otherwise process X becomes suspended and process Y\r
+ becomes active.\r
+ The execution of the detach statement in the active process X has the\r
+ effect as the execution of attach(Y), where Y is the coroutine (process)\r
+ recently resumed (by means of attach statement) by process X.\r
+1 - 110 -\r
+ \r
+ \r
+ 11.2. Primitive synchronizing statement\r
+ ****************************************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <primitive synchronizing statement>:\r
+ \r
+ ----> lock ----> ( ---> <variable> ---> ) ---->\r
+ ! ^\r
+ !-> unlock -!\r
+ \r
+ \r
+ The expression test-and-set (ts) is a boolean expression (see 8.4.).\r
+ \r
+ \r
+ <test-and-set>:\r
+ \r
+ -----> ts ---> (--><variable> ---> ) --->\r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ The variable Z occurring in the expression ts(Z) has to be of type\r
+ semaphore. Evaluation of the expression consists in indivisible actions: Z\r
+ is closed and the returned value is true iff Z was open.\r
+ The statement lock(Z) is a WFF provided Z is a variable of type\r
+ semaphore. If Z is closed then the process which executes this statement is\r
+ suspended until Z becomes open. If Z is open then exactly one process of\r
+ those waiting for this event (having executed the lock instruction) will be\r
+ able to perform its actions. The others remain suspended as long as Z\r
+ becomes open again. Then exactly one process is allowed to proceed and Z\r
+ becomes closed.\r
+ The statement lock(Z) guards the entry into a critical region, i.e., a\r
+ sequence of statements, which are to be executed by only one process . The\r
+ entrance into a critical region may be of the form\r
+ \r
+ while ts(Z) do od\r
+ \r
+ as well, but it would cause busy waiting of processes awaiting for the\r
+ entrance. The statement lock is implemented in the operating system kernel\r
+ and its execution does not engage the processors by delayed processes.\r
+ \r
+ The exit from a critical region is offered by one of the following two\r
+ statements: stop(Z) or unlock(Z). The former statement is described in\r
+ 11.1. The unlock statement is a WFF provided Z is a variable of type\r
+ semaphore. The execution of this statement brings about the following\r
+ indivisible actions: Z becomes open, and if there are processes waiting for\r
+ entrance, then exactly one of the waiting processes enters the region. The\r
+ scheduling of the waiting processes is assumed to be fair.\r
+ \r
+ Thus a critical region may be written as follows:\r
+ \r
+ \r
+ lock (Z) lock (Z)\r
+ ............ or ............\r
+ unlock(Z) stop (Z)\r
+ \r
+1 - 111 -\r
+ \r
+ \r
+ Example 1.\r
+ ----------\r
+ \r
+ Suppose that the following statements occur in two processes executed in\r
+ parallel:\r
+ \r
+ process P: process Q:\r
+ lock (sem); lock (sem);\r
+ x:=(x+4)*x; x:=-3;\r
+ unlock(sem) unlock(sem)\r
+ \r
+ and the initial value of the variable x is equal to 0. The execution of the\r
+ statement x:=(x+4)*x will not be interleaved by the execution of the\r
+ statement x:=-3, irrespectively of the succession of the arrival of\r
+ processes P and Q at their regions. Thus, these statements will be executed\r
+ in sequence and, independently of the succession, the final value of the\r
+ variable x after executing both those statements is equal to -3.\r
+ If the given statements did not occur in the critical regions, their\r
+ concurrent execution might be the following: compute x+4 - (yielding 4),\r
+ assign x:=-3, compute x*(x+4) - (yielding -12) and assign this value to x.\r
+ The presented critical regions make timing possible. For the description\r
+ of scheduling one should use more complex tools, presented in the next\r
+ section.\r
+ \r
+ Example 2.\r
+ ----------\r
+ \r
+ Consider an algorithm which performs the copying of records from the\r
+ input queue to the output queue (comp. [5]). The algorithm gets the first\r
+ record from the input queue and stores it in the input buffer, next copies\r
+ the input buffer into the output buffer, and finally puts the output buffer\r
+ to the output queue and at the same time gets the next record from the\r
+ input queue, as in the following diagram:\r
+ \r
+ get 1\r
+ ,\r
+ ,\r
+ copy 1\r
+ ,\r
+ , ,\r
+ , ,\r
+ get 2 put 1\r
+ , ,\r
+ , ,\r
+ ,\r
+ .\r
+ .\r
+ copy k\r
+ ,\r
+ ,\r
+ put k\r
+ \r
+ In order to program a parallel execution of get and put operations one\r
+ can use the cobegin-coend program connectives. A particular case of these\r
+ connectives is implemented in the copying procedure given below. We assume\r
+ that in the environment of this procedure the type T and the attributes of\r
+ class queue are visible.\r
+1 - 112 -\r
+ \r
+ \r
+ unit copying: procedure (input_queue, output_queue: head);\r
+ var input_buffer, output_buffer:T, completed:boolean, sem:semaphore,\r
+ counter:integer, getr:get_type, putr:put_type;\r
+ unit cobegin: procedure;\r
+ (*resumes the processes putr and getr, suspends the calling process*)\r
+ begin\r
+ lock(sem);\r
+ resume(putr);\r
+ resume(getr);\r
+ stop(sem)\r
+ end cobegin;\r
+ unit coend: procedure;\r
+ (*suspends the calling process, if both processes\r
+ are suspended then the main program is resumed*)\r
+ begin\r
+ lock(sem);\r
+ if counter=0\r
+ then\r
+ counter:=1\r
+ else\r
+ counter:=0; resume(main)\r
+ fi;\r
+ stop(sem)\r
+ end coend;\r
+ \r
+ unit get_type: process;\r
+ begin\r
+ return;\r
+ do\r
+ if empty(input_queue)\r
+ then completed:=true\r
+ else (*get next record*)\r
+ input_buffer := out(input_queue)\r
+ fi;\r
+ call coend;\r
+ od\r
+ end get_type;\r
+ \r
+ unit put_type: process;\r
+ begin\r
+ return;\r
+ do\r
+ call output_buffer.into(output_queue);\r
+ call coend;\r
+ od\r
+ end put_type;\r
+ \r
+ begin\r
+ if not empty(input_queue)\r
+ then\r
+ input_buffer:=out(input_queue);\r
+ getr:=new get_type; putr:=new put_type;\r
+ do (*copying*)\r
+ output_buffer:=copy(input_buffer);\r
+ call cobegin;\r
+ if completed then exit fi\r
+ od;\r
+ kill(getr); kill(putr)\r
+ fi\r
+ end copying;\r
+1 - 113 -\r
+ \r
+ \r
+ 11.3. Monitors (compound synchronization facilities)\r
+ *****************************************************\r
+ \r
+ \r
+ In this section we shall describe Hoare's monitors ([6]). A monitor is a\r
+ data structure shared by many processes and a set of procedures operating\r
+ on this structure. Access to the shared monitor data is possible only via\r
+ these procedures, and so their bodies constitute critical regions.\r
+ Let us present an example of a class that realizes Hoare's monitors.\r
+ Non-conflict access to the monitor data is realized by the so-called entry\r
+ procedures. An entry procedure has a prefix entry which guarantees that\r
+ only one such procedure may enter the monitor.\r
+ In order to permit scheduling of processes that have entered the monitor,\r
+ two specialized procedures operating on the inner monitor queues are\r
+ provided.\r
+ \r
+ delay(Q) -stops the execution of the process and puts it\r
+ into a queue Q, the entry to the monitor is free,\r
+ continue(Q) -resumes the execution of the first process from a\r
+ queue Q (if Q is non-empty, otherwise the entry to\r
+ the monitor is free).\r
+ \r
+ As can easily be seen, correct use of these constructs is achieved when\r
+ continue is called as the last statement of an entry procedure.\r
+ \r
+ The declaration of the class Monitor is as follows:\r
+ \r
+ unit Monitor : queue class;\r
+ hidden sem, queue;\r
+ var sem:semaphore;\r
+ \r
+ unit entry: class; (* all entry procedures must have prefix entry *)\r
+ hidden busy;\r
+ var busy:boolean;\r
+ unit delay: procedure(Q:queue);\r
+ begin\r
+ call Q.into(this process);\r
+ stop(sem)\r
+ end delay;\r
+ unit continue:procedure(Q:queue);\r
+ (* continue can be called as the last statement of an entry procedure *)\r
+ begin\r
+ if not Q.empty\r
+ then\r
+ busy:=true\r
+ resume(Q.out);\r
+ fi;\r
+ end continue;\r
+ begin (* beginning of the prefix entry *)\r
+ lock(sem); (* entry to the critical region *)\r
+ inner;\r
+ if not busy\r
+ then\r
+ unlock(sem)\r
+ fi;\r
+ end entry;\r
+ end Monitor;\r
+1 - 114 -\r
+ \r
+ \r
+ Example 1\r
+ ---------\r
+ \r
+ A simple mail-box system with a circular buffer may be defined as the\r
+ following class prefixed by a Monitor:\r
+ \r
+ unit Mailbox:Monitor class(type T; size: integer);\r
+ var pool: arrayof T, count, in_index, out_index: integer;\r
+ var readers_queue, writers_queue:queue;\r
+ unit writer:entry procedure (r:T);\r
+ begin\r
+ if count=size then call delay(writers_queue) fi;\r
+ in_index:=in_index mod size +1; count:=count+1;\r
+ pool(in_index):=r; call continue(readers_queue)\r
+ end writer;\r
+ unit reader:entry procedure (output r: T);\r
+ begin\r
+ if count=0 then call delay(readers_queue) fi;\r
+ out_index:=out_index mod size +1; count:=count-1;\r
+ r:=pool(out_index); call continue(writers_queue)\r
+ end reader;\r
+ begin\r
+ new_array pool dim (1:size);\r
+ redears_queue:=new queue; writers_queue:=new queue;\r
+ end mailbox;\r
+ \r
+ Example 2\r
+ ---------\r
+ Let W be a non-singular k to k matrix such that the norm of W is less than\r
+ 1. In order to solve the system of linear equations\r
+ \r
+ W*x = B\r
+ \r
+ one can use the Jacobi iteration method, i.e., for a given approximation Y\r
+ of a solution, the next approximation will be of the form:\r
+ \r
+ x(i)= -(W(i, 1)*y(1)+...+W(i, i-1)*y(i-1)+W(i, i+1)*y(i+1)+...+W(i, k)*y(k))+B(i)\r
+ \r
+ (without loss of generality one can assume that W(i, i)=1.)\r
+ \r
+ We shall use k parallel processes to compute the corresponding components\r
+ of the vector x. When the computation of all the components is completed,\r
+ the next approximation starts. Suppose that vector B is included in the\r
+ array W, i.e., it is the last column of W. In general, array W has many\r
+ zeros, and so instead of this array the user delivers the functions\r
+ computing the values\r
+ \r
+ -(W(i, 1)*y(1)+...+W(i, i-1)*y(i-1)+W(i, i+1)*y(i+1)+...+W(i, k)*y(k))+W(i, k+1)\r
+ \r
+ for the given vector y.\r
+1 - 115 -\r
+ \r
+ \r
+ unit Jacobi : procedure(k:integer;eps:real;inout x:array_of real;\r
+ function W(i:integer; y:array_of real):real);\r
+ (* eps-accuracy, the starting point of the iteration should be\r
+ the actual parameter corresponding to x, the final value of x\r
+ will be equal to the solution found *)\r
+ \r
+ unit jac_unit :Monitor class;\r
+ taken entry;\r
+ var dist:real, q:queue;\r
+ \r
+ unit puti: entry procedure(i:integer);\r
+ taken delay, continue;\r
+ begin\r
+ dist:=dist+abs(x(i)-y(i));\r
+ (*y-new iteration, x-old one*)\r
+ if q.cardinal<k-1 (*q.cardinal<k always*)\r
+ then (*wait for others*)\r
+ call delay(q)\r
+ else (*test stop condition*)\r
+ if dist<=eps\r
+ then\r
+ stop(done)\r
+ else\r
+ z:=x; x:=y; y:=z;\r
+ dist:=0; call continue(q)\r
+ fi\r
+ fi;\r
+ end puti;\r
+ \r
+ begin\r
+ q:=new queue;\r
+ end jac_unit;\r
+ \r
+ unit jac: process(i:integer);\r
+ begin\r
+ if i=1 then lock(done) fi;\r
+ return;\r
+ do\r
+ y(i):=W(i, x);\r
+ call jac_mon.puti(i);\r
+ od\r
+ end jac;\r
+ \r
+ var y, z:array_of real, jac_mon:jac_unit, j:integer, done: semaphore;\r
+ var jacob: array_of jac;\r
+ \r
+ begin\r
+ new_array y dim(1:k); new_array jacob dim(1:k);\r
+ jac_mon:=new jac_unit;\r
+ for j:=1 to k do\r
+ jacob(j):= new jac(j); resume(jacob(j))\r
+ od;\r
+ lock(done);\r
+ for j:=1 to k do kill(jacob(j)) od;\r
+ kill(y); kill(jacob); kill(jac_mon)\r
+ end Jacobi;\r
+1 - 116 -\r
+ \r
+ \r
+ \r
+ 12. Separate compilation of units\r
+ #################################\r
+ \r
+ \r
+ Prefixing is a very convenient way of designing large programs and systems.\r
+ These are constructed by linking together individual units and by using\r
+ prefixes as languages in which the programs are written. There are two\r
+ distinct purposes for compiling modules:\r
+ \r
+ -producing an object module, linking it with some units stored in\r
+ libraries and then executing it\r
+ -producing a library item which in turn may be connected with other\r
+ modules.\r
+ \r
+ \r
+ \r
+ Therefore LOGLAN-82 distnguishes two kinds of compilation units:\r
+ \r
+ -binary items ready to be executed, and\r
+ -library items.\r
+ \r
+ \r
+ By an item we mean the basic unit of compilation, i.e., the smallest and\r
+ self-contained class, coroutine, process, function or procedure. It defines\r
+ also the minimum interface, i.e., units which have to be accessible at run\r
+ time. Most of this section deals with how separately compiled units are put\r
+ together to build large systems.\r
+ Because of checking many context-sensitive conditions, LOGLAN-82 requires\r
+ access to system and user libraries; therefore the language provides tools\r
+ for processing them. The form of a library depends upon a given\r
+ implementation. However, the library has to store some necessary\r
+ information about the interface of a module, its source (or slightly\r
+ preprocessed) code and its object code. Each library posesses its own\r
+ identifier, built with respect to ordinary LOGLAN-82 rules. Any library\r
+ item is identified by its own identifier and the name of the library where\r
+ it is stored. A unit identifier must be unique within the library.\r
+ \r
+ \r
+ \r
+ Library items may be used by another module in two main ways:\r
+ \r
+ -as if they were declared within the module, or\r
+ -as if they were only accessible as non-local attributes from the\r
+ SL-chain of the module.\r
+ The first manner we shall call linking a library item, the other forms the\r
+ interface needed by the module.\r
+1 - 117 -\r
+ \r
+ \r
+ Example\r
+ -------\r
+ \r
+ Let M be an already compiled item stored in a library. And let N be an\r
+ item being compiled.\r
+ Linking means that the program tree of N is the following:\r
+ \r
+ \r
+ O <- N\r
+ . .\r
+ . .\r
+ O O <- linking point of M\r
+ . . .\r
+ O O .----\r
+ ! . !\r
+ ! O <- M - item from the library\r
+ ! !\r
+ -----\r
+ \r
+ If the item N specifies M in its interface, it is expected that the\r
+ module which links N is of the form:\r
+ \r
+ \r
+ .\r
+ .\r
+ O <- linking point of M\r
+ . .\r
+ ----. .\r
+ ! . ! .\r
+ M -> O ! .\r
+ ! ! .\r
+ ----- .\r
+ O\r
+ . .\r
+ . .\r
+ O O <- linking point of N\r
+ . .\r
+ . .\r
+ O .----\r
+ ! . !\r
+ ! O <- N\r
+ ! !\r
+ -----\r
+ \r
+ Indeed, in n's SL-chain-to-come the module N will also be linked.\r
+ \r
+ \r
+ The SL-chain-to-come of an item being compiled will be called the\r
+ environment of the linking point of the item.\r
+1 - 118 -\r
+ \r
+ \r
+ 12.1. Library items\r
+ *******************\r
+ \r
+ \r
+ A library item consists of the interface specification and the body. The\r
+ interface is a connector between separate units: it allows us to code in\r
+ the item the access parts of other units and to use other units as prefixes\r
+ or data types.\r
+ The interface defines three kinds of units needed in order to execute the\r
+ item:\r
+ -externals - these are already compiled units stored in libraries. They\r
+ are expected to be visible in the environment of the linking point,\r
+ -languages- these are also already compiled units stored in libraries.\r
+ They must prefix some module in the SL-chain-to-come,\r
+ -sl_virtuals - functions and procedures which will use the item being\r
+ compiled and its environment whatever links the item. They are not known\r
+ during the compilation of the item.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <compilation of a library item>:\r
+ \r
+ --------->library item -->into <library identifier>-->;--->!\r
+ ! ! !\r
+ !--------------------------->-! !\r
+ !\r
+ <-----------------------------------------------!\r
+ !\r
+ !\r
+ !------> <interface specification> --->!\r
+ ! !\r
+ ! <------------------------------------!\r
+ !\r
+ !--> compile ---> <unit declaration> ---------------->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ The item is compiled and then stored in a given library. If in the library\r
+ there is already a module of the same name, it is replaced by the one being\r
+ compiled .\r
+ The default library identifier is the userlib.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into mathlib;\r
+ compile\r
+ unit sin : function (input x: real) : real;\r
+ .\r
+ .\r
+ end sin\r
+1 - 119 -\r
+ \r
+ \r
+ 12.1.1. Interface\r
+ *****************\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ <interface specification>:\r
+ \r
+ ---------->languages--> <language specification> --> ; ----->!\r
+ ! ^ ! !\r
+ ! !<----------- , ------------! !\r
+ ! !\r
+ ! <---------------------------------------------------!\r
+ !\r
+ !----> externals --> <external specification> --> ; ->!\r
+ ! ^ ! !\r
+ ! !<----------- , ------------! !\r
+ ! !\r
+ ! <---------------------------------------------------!\r
+ !\r
+ !----> sl_virtuals --> <sl_virtual specif. > --> ; -->!\r
+ ! ^ ! !\r
+ ! !<---------- , -----------! !\r
+ ! !\r
+ ! <---------------------------------------------------!\r
+ !\r
+ !------------------->\r
+ \r
+ \r
+ <language specification>:\r
+ \r
+ -----> <lib. item identifier> -----> from <library ident.> ------>\r
+ ^ ! ^ !\r
+ !<-------------- , -----------! !------------------------> !\r
+ \r
+ \r
+ <external specification>:\r
+ \r
+ ------> unit <lib. item identifier> : ----> class ------------>!\r
+ ! ^ !\r
+ !-> coroutine -->! !\r
+ ! ! !\r
+ !-> process ---->! !\r
+ ! ! !\r
+ !-> function --->! !\r
+ ! ! !\r
+ !-> procedure -->! !\r
+ !\r
+ ! <--------------------------------------------------------!\r
+ ! !\r
+ !---> from <library identifier> -------------------------> !\r
+ !->\r
+ \r
+ \r
+ The default library identifier is the userlib.\r
+1 - 120 -\r
+ \r
+ \r
+ <sl_virtual specification>:\r
+ \r
+ -> unit <identifier> : -> function -> <form. par. simp. list> ->!\r
+ ! !\r
+ ! !<-------------------------------!\r
+ ! !\r
+ ! !--> : <type identifier> -------->!\r
+ ! !\r
+ !--> <form. par. simp. list> ------------>!\r
+ !\r
+ !->\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ \r
+ The interface defines a minimum environment of the point at which the item\r
+ being compiled is to be linked. It is used to code the item and also to\r
+ check its static properties. Therefore, changing externals or languages in\r
+ the library, the user has to recompile also units depending on them.\r
+ Identifiers of externals may be used in sl_virtual specification to\r
+ define types of parameters and by the compiled unit as prefixes, types of\r
+ data and so on. Interface specification is not redundant, i.e., if an\r
+ external or language uses some other library items in its own interface,\r
+ they do not have to be specified again. However, only identifiers of the\r
+ specified units are accessible in the item being compiled.\r
+ \r
+ Example 1.\r
+ ----------\r
+ \r
+ library item into datalib;\r
+ compile\r
+ unit heap : class....\r
+ ...\r
+ end heap;\r
+ \r
+ library item into datalib;\r
+ externals\r
+ unit heap: class from datalib;\r
+ compile\r
+ unit priority_queue: heap class ...\r
+ var z: heap...\r
+ end priority_queue;\r
+ \r
+ library item into proglib;\r
+ externals\r
+ unit priority_queue: class from datalib;\r
+ compile\r
+ unit prog1: class;\r
+ var x: priority_queue;\r
+ ...\r
+ end prog1;\r
+ \r
+ Within the body of prog1 we can use the identifier of the priority_queue.\r
+ Class heap will be automatically connected, we are not allowed, however, to\r
+ use the identifier of heap. To make it possible we should define another\r
+ interface:\r
+1 - 121 -\r
+ \r
+ \r
+ library item into proglib;\r
+ externals\r
+ unit priority_queue: class from datalib;\r
+ unit heap: class from datalib;\r
+ compile\r
+ unit prog2: class...\r
+ var x: priority_queue;\r
+ var y: heap;\r
+ ...\r
+ y:=x;\r
+ ...\r
+ X qua heap\r
+ end prog2;\r
+ \r
+ \r
+ Example 2.\r
+ ----------\r
+ \r
+ library item into datalib;\r
+ externals\r
+ unit heap: class from datalib;\r
+ compile\r
+ unit test: class;\r
+ var z: heap\r
+ ...\r
+ end test;\r
+ \r
+ library item into proglib;\r
+ externals\r
+ unit priority_queue: class from datalib;\r
+ unit test: class from datalib;\r
+ compile\r
+ unit prog3: class;\r
+ var p: priority_queue, e: test;\r
+ ...\r
+ p.z:=e.z\r
+ ...\r
+ end prog3;\r
+ \r
+ \r
+ In this interface heap means the same class for both the priority_queue\r
+ and the test.\r
+1 - 122 -\r
+ \r
+ \r
+ 12.1.2. Using languages\r
+ ***********************\r
+ \r
+ Languages are classes (coroutines, processes) already compiled. They are\r
+ expected to prefix modules in the SL-chain of the point of linking the item\r
+ being compiled. Their attributes may be used within the body of the\r
+ compiled item by means of the construction:\r
+ this <language identifier>.<attribute>\r
+ If it does not lead to any confusion, the phrase\r
+ this <language identifier>.\r
+ may be omitted. The rules of accessing attributes in the case of regular\r
+ units are also valid in the case of languages. A language may also be used\r
+ like any of the specified externals.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into syslib;\r
+ compile\r
+ unit math: class;\r
+ ...\r
+ unit sin ...\r
+ end math;\r
+ library item into syslib;\r
+ compile\r
+ unit basicio: class;\r
+ ...\r
+ unit writereal...\r
+ end basicio;\r
+ library item;\r
+ languages math, basicio from syslib;\r
+ compile\r
+ unit prog: class...\r
+ ...\r
+ this math.sin (* or simply sin *)\r
+ this basicio.writereal (*or simply writereal *)\r
+ end prog;\r
+ \r
+ A correct use of the unit prog may be of the following form:\r
+ \r
+ library item;\r
+ externals\r
+ unit math: class from syslib,\r
+ unit basicio: class from syslib;\r
+ compile\r
+ unit user: class;...\r
+ basicio block...\r
+ math block...\r
+ class\r
+ external unit prog from userlib\r
+ (* this is linking prog- see 12.2 *)\r
+ ...\r
+ end user;\r
+1 - 123 -\r
+ \r
+ \r
+ 12.1.3. Using externals\r
+ ***********************\r
+ \r
+ \r
+ External items are expected to be linked by the environment of the linking\r
+ point of the item being compiled. They may be used like units which are\r
+ declared and visible in the environment of a regular object. Some simple\r
+ examples have been given in 12.1.1. Some others are given in 12.2.\r
+ \r
+ \r
+ \r
+ 12.1.4. Using sl_virtuals\r
+ *************************\r
+ \r
+ \r
+ The main purpose of sl_virtuals is to permit communication between the\r
+ compiled item and the modules which will use it. Communication may depend\r
+ upon the modules and there may be many fairly distinct of them. Sl_virtuals\r
+ and the modules are not previously compiled, i.e., they are not other\r
+ library items. Sl_virtuals are very similar to formal parameters or\r
+ external subroutines in FORTRAN.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ This is an example of a procedure which sorts real numbers stored in any\r
+ structure with operations put_real and get_real.\r
+ \r
+ library item into sortlib;\r
+ sl_virtuals\r
+ unit empty : function : boolean,\r
+ unit get_real : function : real,\r
+ unit put_real : procedure (input X : real),\r
+ unit clear : procedure;\r
+ compile\r
+ unit sqsetort : procedure;\r
+ ...\r
+ begin\r
+ (*reading numbers*)\r
+ while not empty\r
+ do\r
+ ...\r
+ get_real;\r
+ ... ...\r
+ od;\r
+ ...\r
+ (*writing numbers*)\r
+ clear;\r
+ do\r
+ ...\r
+ call put_real(Z);\r
+ ...\r
+ od;\r
+ ...\r
+ end sqsetsort;\r
+1 - 124 -\r
+ \r
+ \r
+ 12.2. Linking library items\r
+ ***************************\r
+ \r
+ \r
+ Declarations within a module may include specification of a library item to\r
+ be linked at that point.\r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <linked item specification>:\r
+ \r
+ ----------> external <external specification> ---------->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ The object code of the linked item is added to the object code of the item\r
+ being compiled. Adding the same item a few times we create some unrelated\r
+ copies of the item as if the same source code occurred many times in\r
+ different places.\r
+ \r
+ \r
+ 12.2.1.Connecting the interface\r
+ *******************************\r
+ \r
+ \r
+ Languages and sl_virtuals.\r
+ --------------------------\r
+ \r
+ Languages and sl_virtuals specified by the linked item are looked for in\r
+ the environment of the linking point. If they are not found there, they\r
+ must be explicitly specified in the interface of the item being compiled.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into lib;\r
+ compile\r
+ unit M : class;\r
+ ...\r
+ end M;\r
+ \r
+ library item into lib;\r
+ compile\r
+ unit N : class;\r
+ ...\r
+ end N ;\r
+ \r
+ library item into lib;\r
+ languages M, N from lib;\r
+ compile\r
+ unit P : class;\r
+ ...\r
+ end P;\r
+1 - 125 -\r
+ \r
+ \r
+ library item into lib;\r
+ languages M from lib;\r
+ compile\r
+ unit R : class;\r
+ ...\r
+ block\r
+ external unit N : class from lib;\r
+ ...\r
+ N block\r
+ ...\r
+ block\r
+ external unit P : class from lib;\r
+ ...\r
+ end r;\r
+ \r
+ Sl_virtual specification must be compatible in terms of the usual LOGLAN-82\r
+ rules with the actual version or with the specification in the interface of\r
+ the item being compiled.\r
+ \r
+ EXTERNALS\r
+ ---------\r
+ \r
+ The externals specified in the added item are taken from the SL-chain of\r
+ the linking point or from the interface of the item being compiled. If they\r
+ do not occur there, they are linked together with the specified linked item\r
+ at the same point.\r
+ \r
+ Example.\r
+ --------\r
+ \r
+ library item into lib;\r
+ compile\r
+ unit M : class;\r
+ ...\r
+ end M;\r
+ \r
+ library item into lib;\r
+ externals\r
+ unit M : class from lib;\r
+ compile\r
+ unit N : class;\r
+ var X : M\r
+ ...\r
+ end N;\r
+ (a)\r
+ library item into lib;\r
+ externals\r
+ unit M : class from lib;\r
+ compile\r
+ unit P : class;\r
+ external unit N : class from lib;\r
+ ...\r
+ end P;\r
+ \r
+ The actual version of the module M used by the module N is taken from the\r
+ interface of the module p. The SL-link of M is not known.\r
+1 - 126 -\r
+ \r
+ \r
+ (b)\r
+ library item into lib;\r
+ compile\r
+ unit P : class;\r
+ ...\r
+ external unit M : class from lib;\r
+ ...\r
+ block\r
+ ...\r
+ external unit N : class from lib;\r
+ ...\r
+ end P;\r
+ The module M used by the module N comes from P where it is linked. The\r
+ SL-link of M is P.\r
+ Notice that if the program tree is the following:\r
+ \r
+ \r
+ O <- P\r
+ . . .\r
+ . . .\r
+ ----. O O\r
+ ! . ! . .\r
+ M -> O ! . .\r
+ ! ! . .\r
+ ----- .---- .----\r
+ !. ! ! . !\r
+ N1 - copy of N-> O ! ! O <- N2 - copy of N\r
+ ! ! ! !\r
+ ----- -----\r
+ \r
+ Then the attributes X in both copies are compatible, i.e., they are of the\r
+ same type.\r
+ \r
+ \r
+ (c)\r
+ library item into lib;\r
+ compile\r
+ unit P : class;\r
+ unit R : class;\r
+ external unit N : class from lib;\r
+ ...\r
+ end R;\r
+ unit S : class;\r
+ external unit N : class from lib;\r
+ ...\r
+ end S;\r
+ ...\r
+ end P;\r
+ \r
+ In this case two copies of N are formed. Because there occurs no copy of M\r
+ in the SL-chain or in the interface of P, two copies of M are also added.\r
+ The attributes X in the copies of N are of different types and are not\r
+ compatible. The copies of M are "own" copies for each N.\r
+1 - 127 -\r
+ \r
+ \r
+ 12.3. Binary items\r
+ ******************\r
+ \r
+ \r
+ A binary item consists of a very simple interface specification and the\r
+ body. The interface defines languages in which the program is written. A\r
+ binary compiled program is embedded in a number of blocks prefixed by these\r
+ languages. There is also a block containing definitions of linked library\r
+ items.\r
+ Compilation of a binary item results in an object code ready for\r
+ execution.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <compilation of a binary item>:\r
+ \r
+ -----> binary item ---> into <library identifier> ---> ; ------>!\r
+ ! ^ !\r
+ !---------------------------->! !\r
+ !\r
+ !<------------------------------------------------------------!\r
+ !\r
+ !-----> languages ---> <language specification> --> ; --->!\r
+ ! ^ ! !\r
+ ! !<------------ , ------------! !\r
+ ! !\r
+ ! <-------------------------------------------------------!\r
+ !\r
+ !------> externals ---> <external specification> --> ; -->!\r
+ ! ^ ! !\r
+ ! !<------------- , ------------! !\r
+ ! !\r
+ ! <-------------------------------------------------------!\r
+ !\r
+ !---> compile <declaration of a program unit> ----------------->\r
+ \r
+ \r
+ The rules of using languages and externals are the same as for library\r
+ items.\r
+ The default library identifier is bin.\r
+1 - 128 -\r
+ \r
+ \r
+ 12.4. Processing libraries\r
+ **************************\r
+ \r
+ \r
+ 12.4.1. Recompilation\r
+ *********************\r
+ \r
+ \r
+ LOGLAN-82 guarantees uniqueness for types and units. The compiler\r
+ associates a "time stamp" (time of definition and compilation) with each\r
+ compiled unit. Compiling a module twice (even if no changes are made in its\r
+ source code) makes all units defined in the module different\r
+ (non-equivalent). Therefore after some changes in the library we should\r
+ recompile all modules connecting the changed items.\r
+ For example, consider the case where defs1 is used by defs2, and defs2 is\r
+ linked with the user. Suppose that defs1 is recompiled for some reason,\r
+ then defs2 is recompiled, too. Then the user should also be recompiled,\r
+ because recompiling defs2 invalidated the version of the user.\r
+ \r
+ Compilations and recompilations must occur in a specific order.\r
+ To recompile a module storedin the library, LOGLAN-82 commands the\r
+ following syntax:\r
+ \r
+ \r
+ --> recompile --> <lib. item identifier> --> from <library ident.> -->\r
+ ^ !\r
+ !<------------ , ----------!\r
+ \r
+ It is suggested that the LOGLAN-82 compiler makes the necessary\r
+ recompilations automatically.\r
+1 - 129 -\r
+ \r
+ \r
+ 12.4.2. Insertions and deletions\r
+ ********************************\r
+ \r
+ \r
+ To insert an item into a library the programmer writes only the source code\r
+ of the item. It is a code between\r
+ \r
+ \r
+ \r
+ library binary item into <library identifier>;\r
+ ...\r
+ end\r
+ \r
+ \r
+ This code results in the insertion of the module into a given library. If\r
+ in the given library there already exists a module of the same name, the\r
+ new one replaces the old one.\r
+ \r
+ Deletions are made by using the following syntax:\r
+ \r
+ \r
+ --> delete ---> <lib. item identifier> ---> from <library ident.> ---->\r
+ ^ !\r
+ !<------------ , -----------!\r
+ \r
+ A linked item may be deleted from the library. However, the linking module\r
+ cannot be recompiled after that.\r
+1 - 130 -\r
+ \r
+ \r
+ 13. File processing\r
+ ####################\r
+ \r
+ \r
+ 13.1. External and internal files\r
+ *********************************\r
+ \r
+ External files are named after character strings and denote peripheral\r
+ devices or data sets. The logical and the physical structure of an external\r
+ file depend on the given computer and its file system, and so, for the\r
+ users of LOGLAN-82, external files are accessible via internal files only.\r
+ \r
+ \r
+ An internal file is an object of the predefined class type file. When an\r
+ internal file is generated, it may be associated with an appropriate\r
+ external file. Sometimes the user wish to generate an internal file not\r
+ associated with any specified external one. Such a file is called a local\r
+ file and its life-time is not longer than the life-time of the program\r
+ where it has been generated.\r
+ \r
+ \r
+ A file is always treated as an unbounded sequence of bytes. A file can be\r
+ read or written, and can be set to a required position. Each transmission\r
+ from or on a file starts at the byte pointed out by the so-called current\r
+ file position advanced by the number of transmitted bytes. File size is\r
+ defined as the greatest number of a byte transmitted on the file.\r
+ \r
+ There are some primitive facilities in the language which enable the user\r
+ to read or write a specified number of bytes, to change the current file\r
+ position, to obtain the file size, etc. All these facilities are in some\r
+ sense low-level, since they operate on bytes. The user is able, however, to\r
+ declare a class for file processing with high-level operations.\r
+ \r
+ An example of a system class which defines a set of input-output\r
+ operations applicable to files containing elements of a single type is\r
+ shown in 13.6. Moreover this is not the only way to define high-level file\r
+ processing. The user can declare, for instance, a class which defines\r
+ operations applicable to files containing elements of mixed types, a class\r
+ which defines operations on a file of arrays of various lengths, etc.\r
+1 - 131 -\r
+ \r
+ \r
+ 13.2. File generation and deallocation\r
+ **************************************\r
+ \r
+ \r
+ Before any operation on a file can be carried out, an internal file must\r
+ be generated. If the user wishes to communicate with an external file, then\r
+ the generated internal file must be associated with that external one. When\r
+ the generation of an internal file is in effect, the file is said to be\r
+ open.\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ <file declaration>:\r
+ \r
+ -----> <variable list> ----> : file -------------->\r
+ \r
+ <file generation>:\r
+ \r
+ --> open\r
+ !\r
+ !\r
+ (\r
+ !\r
+ <object expression> ---> , ---> <string> ----> ) ------->\r
+ ! !\r
+ !-------------------->!\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ Variables of file type are declared as any other variables of class type.\r
+ An object of file type (internal file) has no attributes visible to the\r
+ programmer.\r
+ File generation differs from class generation. It is performed by an open\r
+ statement. If the second argument appears, then a new internal file\r
+ associated with an external one (identified by the string) is generated.\r
+ The reference to such an internal file is set to the variable of type file\r
+ occurring as the first argument. If there is only one argument, then a new\r
+ local file is generated and the reference to the corresponding internal\r
+ file is set to the variable of type file occurring as the argument of the\r
+ operation. For instance:\r
+ \r
+ open(X, "teletype")\r
+ \r
+ generates a new internal file associated with the external file "teletype".\r
+ Similarly\r
+ \r
+ open(Y)\r
+ \r
+ generates a new local file referenced by Y.\r
+1 - 132 -\r
+ \r
+ \r
+ Thus the operation new is not applicable to files. Moreover, remote\r
+ access to internal files is not permissible (no attributes visible to the\r
+ user).\r
+ Except file generation, remote access and prefixing, file type can be\r
+ applied as any other class type. In particular, expressions of file type\r
+ may be compared, assignments on variables of type file are allowed, the\r
+ user can declare a function of type file, etc.\r
+ \r
+ \r
+ Remark\r
+ ------\r
+ \r
+ External file processing is not predefined in the language. The\r
+ operations on external files, such as file creation, file deletion, file\r
+ protection and so on, depend on the given file system. They may be\r
+ introduced into the language as standard functions or procedures in the\r
+ individual implementation.\r
+ \r
+ End of remark\r
+ -------------\r
+ \r
+ \r
+ \r
+ After processing has been completed on a file, it can be closed and the\r
+ corresponding internal file may be deallocated. These actions are performed\r
+ by the kill statement, where the argument points to the corresponding\r
+ internal file.\r
+1 - 133 -\r
+ \r
+ \r
+ 13.3. Binary input-output\r
+ *************************\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ \r
+ \r
+ < binary input-output operations>:\r
+ \r
+ ---> put ---> (---> <object expression>-> , ---> <expression list> --> ) ---->\r
+ \r
+ ---> get ---> (---> <object expression>-> , ---> <expression list> --> ) ---->\r
+ \r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ \r
+ Operation put transmits a sequence of bytes from memory to an open file\r
+ (defined by the first parameter) at the current file position. This\r
+ sequence of bytes is defined by the list of expressions. For any list\r
+ element, going from left to right, the value of the expression is computed.\r
+ If this value is primitive, then the transmitted bytes correspond exactly\r
+ to the internal representation of the value. If the value is a reference to\r
+ an object, then the transmitted bytes cover all non-system attributes of\r
+ the referenced object. If this value is none, then no transmission is\r
+ performed.\r
+ Operation get transmits a sequence of bytes from an open file (defined by\r
+ the first parameter) to the memory. If a list element is an object\r
+ expression, then the transmitted bytes cover all non-system attributes of\r
+ the referenced object (hence, if the value of this expression is none, then\r
+ no transmission is performed). Otherwise, list element must be a variable\r
+ of primitive type, and then the transmitted bytes cover exactly its\r
+ internal representation. The sequence of transmitted bytes starts at the\r
+ current file position.\r
+ \r
+ For instance, let x be a real, i an integer and Y a reference variable to\r
+ an object of type A:\r
+ \r
+ unit A:class(j:integer);\r
+ var u, v, w:real;\r
+ end A;\r
+ \r
+ Then the statement\r
+ \r
+ put(F, x, i, x+i, "nothing", Y)\r
+ \r
+ transmits to file F the internal representation of the values of x, i, x+i,\r
+ the internal representation of the text "nothing" (i.e., the sequence of\r
+ characters) and the internal representation of the attributes j, u, v, w\r
+ from the object referenced by Y.\r
+1 - 134 -\r
+ \r
+ \r
+ 13.4. Other predefined operations\r
+ *********************************\r
+ \r
+ \r
+ SYNTAX\r
+ ------\r
+ <size operator>:\r
+ \r
+ !-----> <type> ----------->!\r
+ ! !\r
+ ------> size ---> ( -! !---> ) -------->\r
+ ! !\r
+ !----> < expression> ----->!\r
+ \r
+ <eof operator>:\r
+ \r
+ ------> eof -----> ( ---> <object expression> ----> ) ------------------>\r
+ \r
+ <position operator>:\r
+ \r
+ ----> position ---> ( ---> <object expression> -----> ) --------------->\r
+ \r
+ <seek operation>:\r
+ \r
+ --> seek --> ( --> <object expression> --> , --> <arithmetic expression> --> ) -->\r
+ \r
+ SEMANTICS\r
+ ---------\r
+ \r
+ \r
+ The size operator of integer type gives the number of bytes of the\r
+ internal representation of an argument. If the argument is an expression of\r
+ primitive type, then the returned value may be computed at compilation time\r
+ and equals the number of bytes of the internal representation of that\r
+ primitive type. If the argument is an expression of class or array type,\r
+ then the returned value gives the number of bytes of the object referenced\r
+ by the argument (except system-attributes). If the object none is\r
+ referenced, then the returned value is 0.\r
+ Another kind of argument of size operator is type. It may be either an\r
+ explicitly written type or a formal type. If the argument is a primitive\r
+ type or a class type, then its length in bytes computed at compilation time\r
+ is returned. If the argument is an array type, then its size cannot be\r
+ established and so the expression is incorrect. If the argument is a formal\r
+ type, the returned value is defined similarly but computed at run time.\r
+ Thus when the actual type is array the run time error is raised.\r
+ In all these cases size operator informs the user about the length in\r
+ bytes of the internal representation of the argument (if possible). In\r
+ particular, the argument may be a file and then the length in bytes of the\r
+ corresponding external or local file is returned.\r
+ \r
+ The argument of the boolean operator eof must be a file. It returns the\r
+ value true iff the current position of the file exceeds or equals its size.\r
+ The argument of the integer operator position must also be a file. It\r
+ returns the current position of the file.\r
+ The first argument of the seek operation must be a file. Then the current\r
+ position of this file is set to the value defined by the second argument of\r
+ the operation.\r
+1 - 135 -\r
+ \r
+ \r
+ 13.5. Text input-output\r
+ ***********************\r
+ \r
+ \r
+ Besides binary input-output LOGLAN-82 provides text input-output\r
+ operations also. The operations read and write are available for input and\r
+ output in human readable form. Namely, operation read decodes a sequence of\r
+ bytes into the internal representation of the corresponding value before\r
+ the transmission is performed. Similarly operation write encodes the\r
+ internal representation of a value into the corresponding sequence of bytes\r
+ before transmission is performed.\r
+ \r
+ \r
+ SYNTAX.\r
+ -------\r
+ \r
+ \r
+ <text input-output statement>:\r
+ \r
+ !--------------------------->!\r
+ ! !\r
+ --> read --> ( --> <object expression> ---> , --> <variable list> --> ) ---->\r
+ \r
+ \r
+ !------------------------------------>!\r
+ ! !\r
+ ->writeln --> ( --> <object expression> --> ) ------------------------->\r
+ !\r
+ !\r
+ ->write --> ( -------------->!\r
+ ! !\r
+ <object expression>-> , -> <expression> ----> <format> ---> ) -------->\r
+ ^ !\r
+ !<--------- , ------------!\r
+ \r
+ \r
+ <format>:\r
+ \r
+ ------------------------------------------------------------------->\r
+ ! ^ ^\r
+ !-> : -> <arithmetic expression>-!- : -> <arithmetic expression> -!\r
+1 - 136 -\r
+ \r
+ \r
+ SEMANTICS.\r
+ ----------\r
+ \r
+ An input statement read(F, y1, ..., yk) is correct if F is a file and y1,\r
+ ..., yk are variables of integer, real, or character type. File F is\r
+ treated as a sequence of symbols. The execution of that statement causes\r
+ the input data represented as the corresponding sequence of symbols from\r
+ file F to be read, decoded and assigned to y1, ..., yk respectively. The\r
+ input statement is defined if the assignments are defined (going from left\r
+ to right).\r
+ An output statement write(F, E:A1) is correct if F is a file, E is an\r
+ expression of a primitive type, and A1 is an arithmetic expression of\r
+ integer type.\r
+ Consider first the case where expression E is of integer type. The value\r
+ of expression A1 determines the number of symbols to be outputed on file F.\r
+ If the specified number of symbols is greater (less) than the number of\r
+ symbols required for the representation of the value of expression E, then\r
+ the value of E is preceded by the appropriate number of blanks (then the\r
+ least significant digits are omitted). The absence of format indicates a\r
+ standard one (dependent on an individual implementation).\r
+ If expression E is of real type, then the output statement may be of the\r
+ form write(F, E:A1:A2), where A1 and A2 are arithmetic expressions of\r
+ integer type. The meaning of the expression A1 is that described above, the\r
+ value of the expression A2 determines the number of digits following the\r
+ decimal point. In case of an output statement of the form write(F, E:A1),\r
+ where E is of real type, the exponent part is always present. The absence\r
+ of format indicates a standard one (dependent on an individual\r
+ implementation).\r
+ An output statement of the form write(F, E) where E is an expression of\r
+ character type causes the external representation of E to be outputed on\r
+ file F.\r
+ If E is an expression of string type, then its external representation is\r
+ outputed on file F. In this case format A1 may appear and defines the\r
+ maximal number of symbols which may be outputed, i.e., if the length of a\r
+ string exceeds the defined format, then the last symbols are dropped.\r
+ In the statement write(F, E:A1:A2) format A2 is computed first (if\r
+ present), format A1 is computed next (if present), and finally the value of\r
+ E is computed and outputed according to the defined formats.\r
+ The execution of an output statement with a list results in the\r
+ successive evaluations of the expressions A2, A1, E, and in the output of\r
+ the computed value.\r
+ Statement writeln outputs the end of line symbol after output is\r
+ completed. If writeln has only the file parameter, then the end of the line\r
+ symbol is outputed on file F.\r
+ If no file is specified, a default standard input or standard output file\r
+ is used. At the beginning of program execution, these files are open and\r
+ associated with two implementation defined external files.\r
+1 - 137 -\r
+ \r
+ \r
+ 13.6. Example of high-level file processing\r
+ *******************************************\r
+ \r
+ A class defining high-level file processing is presented below. The user\r
+ can prefix the main block of his program by such a class, and then, the\r
+ high-level file operations are provided automatically.\r
+ \r
+ unit input_output class;\r
+ hidden uni_file;\r
+ unit uni_file :class(type T);\r
+ hidden element_size;\r
+ var F:file, element_size:integer;\r
+ unit set_position:procedure(i:integer);\r
+ begin\r
+ call seek(F, i*element_size)\r
+ end set_position;\r
+ unit file_position:function:integer;\r
+ begin\r
+ result:=position(F) div element_size\r
+ end file_position;\r
+ unit end_of_file:function:boolean;\r
+ begin\r
+ result:=eof(F)\r
+ end end_of_file;\r
+ unit file_size:function:integer;\r
+ begin\r
+ result:=size(F) div element_size\r
+ end file_size;\r
+ unit read_element:procedure(output x:T);\r
+ begin\r
+ get(F, x)\r
+ end read_element;\r
+ unit write_element:procedure(x:T);\r
+ begin\r
+ put(F, x)\r
+ end write_element;\r
+ begin\r
+ element_size:=size(T)\r
+ end uni_file;\r
+ unit inout_file:uni_file class(S:string);\r
+ hidden F;\r
+ begin\r
+ open(F, S)\r
+ end inout_file;\r
+ unit in_file:inout_file class;\r
+ hidden write_element;\r
+ end in_file;\r
+ unit out_file:inout_file class;\r
+ hidden read_element;\r
+ end out_file;\r
+ unit local_file:uni_file class;\r
+ hiddden F;\r
+ begin\r
+ open(F)\r
+ end local_file;\r
+ unit close_file:procedure(E:uni_file);\r
+ begin\r
+ kill(E.F); kill(E)\r
+ end close_file;\r
+ end input_output;\r
+1 - 138 -\r
+ \r
+ \r
+ Bibliography.\r
+ #############\r
+ \r
+ Part A: the papers related to the language itself.\r
+ \r
+ [1] Bartol W.M, Kreczmar A., Litwiniuk A., Oktaba H.: Semantics and\r
+ implementation of prefixing at many levels, Ins.Inf.U.W. reports, nr 94.,\r
+ 1980.\r
+ \r
+ [2] Bartol-Ratajczak W.M., Szczepanska-Wasersztrum D.: Data structure for\r
+ simulation purposes in LOGLAN. ICS PAS report 373, 1979.\r
+ \r
+ [3] Dahl O-J., Myhrhaug B., Nygaard K.: Common base language. NCC s-22,\r
+ October 1970.\r
+ \r
+ [4] Dahl O-J., Wang A.: Coroutine sequencing in a block structured\r
+ environment. BIT 11, 1971, pp.425-49.\r
+ \r
+ [5] Hansen P.B.: CONCURRENT PASCAL, a programming language for operating\r
+ system design. IST report no.10 April 1974.\r
+ \r
+ [6] Hoare C.A.R.: Monitors, an operating system structuring concept. CACM,\r
+ vol.17, n.10, October 1974, pp.549-57.\r
+ \r
+ [7] Muldner T.: On the properties of ADA's rendez-vous and an\r
+ implementation of its counterpart in LOGLAN. To appear.\r
+ \r
+ [8] Muldner T.: LOGLAN-82 programmer's manual (in Polish), pp.1-417.\r
+ \r
+ [9] Myhre O.: Protecting attributes of a local class. SIMULA Newsletters,\r
+ vol.5, n.4. November 1977.\r
+ \r
+ [10] Naur P.(ed): Revised report on the algorithmic language ALGOL 60. ACM\r
+ 6, 1963, pp.1-7.\r
+ \r
+ [11] Preliminary ADA reference manual. Sigplan Notices, vol.14 n.6, June\r
+ 1979.\r
+ \r
+ [12] Salwicki A., Muldner T., Oktaba H., Bartol-Ratajczak W.M.: Base\r
+ machine language. General outline. (in Polish). Archiwum opracowan nr 20,\r
+ 1977, IMM MERA.\r
+ \r
+ [13] Wirth N.: The programming language PASCAL, Acta Informatica, 1971, 1,\r
+ pp. 35-63.\r
+1 - 139 -\r
+ \r
+ \r
+ Part B: The papers related to the general project LOGLAN-82\r
+ \r
+ [14] Aho A.V., Hopcroft J.E., Ullman J.D.: The design and analysis of\r
+ computer algorithms. Addison-Wesley. 1974.\r
+ \r
+ [15] Banachowski L., Kreczmar A., Mirkowska G., Rasiowa H., Salwicki A.: An\r
+ introduction to algorithmic logic. Mathematiccal investigations in the\r
+ theory of programs. In Banach Center publications, Warsaw 1977.\r
+ \r
+ [16] Bartol W.M.: The definition of the semantics of some statements of a\r
+ block structured language with type prefixing. To appear in: Lect.Notes in\r
+ Comp. Sc. Proc. Poznan 1980, Symp. on algorithmic logic and LOGLAN.\r
+ \r
+ [17] Burkhard H.D.: On priorities of parallelism: Petri nets under the\r
+ maximum firing strategy. To appear in Lect. Notes in Comp.Sc. Proc. Poznan\r
+ 1980, Symp. on algorithmic logic and LOGLAN.\r
+ \r
+ [18] Dahl O-J., Dijkstra E.W., Hoare C.A.R.: Structured programming.\r
+ London. Academic Press 1972.\r
+ \r
+ [19] Muldner T.: On the semantics of parallel programs. ICS PAS report 348,\r
+ 1979, extended version to appear in Fund. Informaticae.\r
+ \r
+ [20] Muldner T.: Implementation and properties of certain tools for\r
+ parallel programs. ICS PAS report 356, 1979. see also FCT' 77,\r
+ Lect.Not.Comp.Sc.56.\r
+ \r
+ [21] Oktaba H.: On the algorithmic theory of references. To appear in:\r
+ Lect.Not. in Comp.Sc. Proc. Poznan 1980, Algorithmic logic and LOGLAN.\r
+ \r
+ [22] Salwicki A.: Programmability and recursiveness, to appear.\r
+ \r
+ [23] Salwicki A.: Formalized algorithmic languages. Bull.Acad. Polon.Sci.\r
+ 18, 1970, pp.227-232.\r
+ \r
+ [24] Salwicki A.: Applied algorithmic logic. Proc. MFCS' 77. Lect.Not. of\r
+ Comp.Sc. 53, 1977, pp.122-134.\r
+ \r
+ [25] Salwicki A.: An algorithmic approach to set theory. Proc.FCT'77. Lect.\r
+ Not. in Comp. Sc. 56, 1977.\r
+ \r
+ [26] Salwicki A.: On the algorithmic theory of stacks. Proc. MFCS' 78\r
+ Lect.Not. in Comp.Sc. 64, 1978.\r
+1 - 140 -\r
+ \r
+ \r
+ \r
+ Index\r
+ #####\r
+ \r
+ \r
+ A D\r
+ actual paratemetr list, 76 deallocation, 17, 83\r
+ allocation statement, 75-81 - statement, 83\r
+ andif, 9 declaration list, 41\r
+ arithmetic expression, 64-66 detach, 86,104,108\r
+ array, 18,29,75,82 dotted variable, 60\r
+ - generation statement 18,75,82 dynamic compatibility\r
+ - object, 29 of parameters, 79\r
+ - type, 29 dynamic consistency\r
+ assignment statement, 72 of types, 55\r
+ attach, 20,86,104,108 dynamic control statements, 85\r
+ attribute, 11,30,42 dynamic instance, 11,13\r
+ dynamic location, 42,54\r
+ \r
+ B E\r
+ binary item, 126 evaluation statement, 71-73\r
+ block statement, 11-12,35,75 exception, 22,96\r
+ block structure,11 - handler, 22,97\r
+ - handling, 96\r
+ exit, 9,84,91\r
+ C expressions, 56\r
+ call statement, 13 external, 122-123\r
+ case statement, 10,87,89 external file, 129\r
+ character, 23\r
+ character expression, 67 F\r
+ class, 14,33 file, 129,136\r
+ - declaration, 33 - declaration, 130\r
+ - object, 14,17 - generation, 130\r
+ close, 22,40,45 formal\r
+ comment, 25 - function parameter, 38-39\r
+ compound statement, 8,71,87-88 - input parameter, 37-39\r
+ conditional statement, 8,87 - output parameter, 37-39\r
+ configuration statement, 71 - parameter, 37-39\r
+ consistency of types, 55 - procedure parameter, 38-39,41\r
+ constant ,31,57 - type, 30\r
+ - declaration, 31 - type parameter, 37-39\r
+ context properties, 56 function, 13\r
+ copy, 74 - call, 75-81\r
+ copying statement, 72,74\r
+ coroutine, 20,28,36,86\r
+ - object, 20\r
+ - statement, 86\r
+1 - 141 -\r
+ \r
+ \r
+ G O\r
+ garbage collection, 17 object, 14,48\r
+ get, 132 - deallocation, 75,83\r
+ - deallocator, 17\r
+ H - expression, 69-70\r
+ handler - generation, 75\r
+ - declaration, 40 - generator statement, 14\r
+ - execution, 101-102 orif, 8\r
+ - termination, 101-102\r
+ hidden, 22,40,43\r
+ \r
+ I P\r
+ identifier definition, 25 parallel statement, 105\r
+ illegal identifier, 44 prefix 15-16,36\r
+ inheritance list, 40 - sequence, 36\r
+ inner, 16,41,84 prefixing, 15,36\r
+ interface, 118 primitive statement, 71\r
+ internal file, 129 primitive synchronizing\r
+ iteration statement, 9,10,90-92 statement, 105,109\r
+ procedure, 13\r
+ K - call, 75-81\r
+ kill, 17,83 process, 21,28,36,104\r
+ - state transition, 105\r
+ L protection list, 40\r
+ languages, 118,121-123 protection of attributes, 22,43\r
+ last_will, 101-102 put, 132\r
+ - statement, 101-102\r
+ legal identifier, 44 Q\r
+ lexical entity, 25 qua, 70\r
+ library items, 115,117 qualified object expression, 69-70,76\r
+ linked item specification, 31\r
+ lock, 21,109 R\r
+ loop statement, 87,91 raise, 98\r
+ read, 134-135\r
+ M recompilation, 127\r
+ main, 28 reference variable, 14\r
+ monitor, 112 remote\r
+ - access, 14\r
+ N - function identifier, 76\r
+ none, 69 - procedure identifier, 76\r
+ repeat, 10,84,91\r
+ resume, 21,104,107-108\r
+ return, 84\r
+ run-time error, 22\r
+1 - 142 -\r
+ \r
+ \r
+ S T\r
+ scheduling, 21,105 taken, 40,44\r
+ semantic properties, 56 terminate, 101-102\r
+ semaphore, 27 textual control statement, 84\r
+ separate compilation, 22,115-128 this, 70\r
+ sequential statements, 71 ts, 21,109\r
+ signal, 96 type, 26\r
+ - declaration, 31 - class, 30\r
+ - handler, 97 - compound, 26,29\r
+ - raising, 98 - primitive, 26-27\r
+ - specification, 96\r
+ simple control statement, 84 U\r
+ simple variable, 58 unit, 13,25,31\r
+ sl-virtual, 118,122-123 - attributes, 42\r
+ statement list, 41 - body, 40-41\r
+ static attribute, 46 - declaration, 31\r
+ static compatibility unlock, 21,109\r
+ of parameters, 77\r
+ static consistency V\r
+ of types, 55 variable, 32,57\r
+ static container, 46 - declaration, 31\r
+ static location, 42,46 virtual\r
+ storage management, 17 - attribute, 49-53\r
+ stop, 21,104,107-108 - chain, 49-53\r
+ string, 27 - subprogram, 49-53\r
+ - constant, 68 visibility rules, 42,44\r
+ - expression, 68\r
+ subprogram declaration, 34 W\r
+ - body, 40 wait, 21,107-108\r
+ subscripted variable, 59 wind, 101-102\r
+ synchronization, 21,105 write, 134-135\r
+ syntactic writeln, 134-135\r
+ - entity, 42\r
+ - father, 12\r
+ - unit, 13,42\r
+ system signals, 103\r
+ system variable, 61\r
--- /dev/null
+SPIS TRESCI DYSKU ZAWIERAJACEGO PROGRAMY DLA SRODOWISKA JEZYKA LOGLAN\r
+\r
+ENVIRON.LZH LOGDEB.EXE Debuger dla LOGLAN'u\r
+ LOGHELP.HLP Tresc loglanowej bazy danych\r
+ LOGHELP.STR Spisy tresci dla loglanowej bazy danych\r
+ LOTEK.EXE Program zarzadzajacy srodowiskiem loglanowym\r
+ LOTEK.HLP Tresc Help'a o poslugiwaniu sie srodowiskiem\r
+ LOTEKINS.EXE Program instalacyjny (generuje plik LOTEK.PTH)\r
+ LSTTEST.EXE Program pomocniczy podczas kompilacji\r
+ MPLOGED.EXE Wlasciwy program srodowiska loglanowego\r
+ NE2LOTEK.EXE Konwerter plikow \r
+ NE2LOTEK.DOC Opis do powyzszego programu\r
+ PREP.EXE Program pomocniczy dla debuggera\r
+\r
+LOGDOC.LZH IIUWGRAF.PL Te pliki zawieraja opisy jezyka loglan i jego realizacji\r
+ LOGLAN.TXT sa one potrzebne dla dzialania loglanowej bazy danych.\r
+ REPORT.HLP Plik REPORT.HLP jest zmieniony i nie nalezy go wymieniac \r
+ USERMAN.TXT na inna wersje (plik REPORT.TXT z pracowni na Szturmowej)\r
+ \r
+WARSZAWA 1990-06-26 MICHAL PAKIER\r
+\r
--- /dev/null
+Hmm ...\r
+\r
+It is not quite fascinating, isn't it?\r
+\r
+On the other hand LOTEK is quite qood and friendly if you know \r
+how to use its tools.\r
+\r
+We are searching the help in \r
+ - making LOTEK a new in the Xwindows (or MSWindows??)\r
+ environment,\r
+ - typing english (or french) phrases instead of polish,\r
+ One can do it and re-compile Lotek.\r
+ - Preparing a new version of HELP database to be consulted\r
+ via F5 (Window) key from Lotek. One needs to use the\r
+If you wish to help send a message to\r
+ salwicki@infpc1.univ-pau.fr\r
+
\ No newline at end of file
--- /dev/null
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ # ###### ###### # ###### # # \r
+ # # # # # # # ## # \r
+ # # # # # # # # # # \r
+ # # # # ## # ###### # # # \r
+ # # # # # # # # # ## \r
+ ###### ###### ###### ###### # # # # \r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ USER'S GUIDE \r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ version JANUARY'88 \r
+\r
+\r
+\r
+ IIUW Warsaw \r
+\f\r
+\r
+\r
+\r
+LIST OF CONTENTS \r
+\r
+\r
+\r
+0. Preface ......................................... 3. \r
+\r
+1. Using Loglan-82 system .......................... 3. \r
+ 1.1. Compilation ................................ 3. \r
+ 1.2. Compiler switches .......................... 4. \r
+ 1.3. Code generation ............................ 4. \r
+ 1.4. Program interpretation ..................... 5. \r
+ 1.5. Compile time error ......................... 6. \r
+ 1.6. Run-time errors ............................ 6. \r
+\r
+2. Compiler options ................................ 6. \r
+ 2.1. Option format .............................. 7. \r
+ 2.2. Options list ............................... 7. \r
+\r
+3. Loglan implementation specification ............. 7. \r
+ 3.1. Implemented subset of Loglan ............... 7. \r
+ 3.2. Non-standard language elements ............. 8. \r
+ 3.3. File system ................................ 8. \r
+ 3.3.1. File variables ........................ 8. \r
+ 3.3.2. File generation ....................... 8. \r
+ 3.3.3. File deallocation ..................... 9. \r
+ 3.3.4. General file operations ............... 9. \r
+ 3.3.5. Text files ............................ 9. \r
+ 3.3.6. Binary sequential files ............... 10. \r
+ 3.3.7. Direct access binary files............. 10. \r
+ 3.4. Concurrency ................................ 11.\r
+ 3.4.1. Invoking the LOGLAN interpreter for \r
+ concurrent programs ................... 11.\r
+ 3.4.2. Restrictions and differences from the \r
+ report ................................ 12.\r
+ 3.4.3. Communication mechanism ............... 13.\r
+ 3.5. System signals ............................. 14. \r
+ 3.6. Implementation restrictions ................ 15. \r
+\r
+Appendices: \r
+A. Standard constants .............................. 16. \r
+B. Standard classes ................................ 16.\r
+ IIUWGRAPH ................................... 16.\r
+ MOUSE ....................................... 17.\r
+C. Standard procedures and functions ............... 19. \r
+D. Error codes ..................................... 21. \r
+E. Loglan runtime errors ........................... 30. \r
+F. Character set ................................... 32. \r
+\r
+Bibliography ....................................... 33. \r
+\f\r
+\r
+\r
+\r
+0. PREFACE \r
+\r
+\r
+\r
+ This document provides information necessary to compile and execute \r
+Loglan programs on IBM/PC compatible computers. \r
+ This manual assumes basic knowledge of Loglan-82 language, \r
+described in "Report on the Loglan Programming Language" (see \r
+Bibliography). \r
+\r
+\r
+\r
+\r
+1. USING LOGLAN-82 SYSTEM \r
+\r
+\r
+\r
+ The following three steps are required to execute a Loglan \r
+program: \r
+ - Compilation (to intermediate code), \r
+ - Generation of the interpreted code (from intermediate code), \r
+ - Interpretation (i.e. execution of program). \r
+\r
+\r
+ Compilation is accomplished by invoking Loglan compiler. This step \r
+creates two destination files: the intermediate code file and the \r
+listing file. \r
+ The intermediate code file is the input file for the second \r
+step: generation of the code accepted by interpreter.In this step two \r
+files containing object code are produced. They are the input files \r
+for the third step: interpretation. This step is equivalent to \r
+execution of a program.\r
+\r
+\r
+\r
+\r
+1.1. COMPILATION \r
+\r
+\r
+\r
+ To invoke the Loglan compiler without specifying any command \r
+line parameters, type: \r
+ LOGLAN \r
+Then the prompt appears on your terminal: \r
+ File name: \r
+and the compiler waits for file specification.The default extension \r
+is LOG. \r
+ The compiler will produce (optionally) listing file with the same \r
+file name and the extension LST and will produce, if no error occurs, \r
+the code file with the extension LCD. Destination files will be \r
+stored on the same drive and directory as the source file. \r
+ If the compiler's symbol table overflows during compilation, use \r
+HLOGLAN.EXE instead of LOGLAN.EXE.\r
+\r
+Example:\r
+ \r
+ 1. LOGLAN \r
+\r
+ File name: PROGRAM <RETURN> \r
+\r
+ Loglan compiler compiles program from PROGRAM.LOG file and creates \r
+PROGRAM.LCD. \r
+\r
+\r
+ 2. LOGLAN A:PROGRAM.DAT \r
+\r
+\r
+ In this case the source file is PROGRAM.DAT from drive A. The \r
+file PROGRAM.LCD will be created on drive A. \r
+\r
+\r
+\r
+ If any error occurs, the code file is not produced.\r
+At the end of compiltation the following message is printed: \r
+ <number of errors> error(s) detected \r
+ \r
+\r
+1.2. COMPILER SWITCHES \r
+\r
+\r
+\r
+ There are two possibilities to specify compiler's options: by \r
+compiler switches (i.e. external options) or by comments in the source \r
+program (see chapter 2.). \r
+ You may enter the compiler switches in command line after file \r
+name in the followng format:\r
+ sw1 sw2... swk <return>\r
+where swi consists of character that designates the name of the option \r
+and either '+' or '-'.\r
+\r
+\r
+\r
+Example:\r
+ \r
+ 1. LOGLAN PROGRAM L- T+ \r
+\r
+ 2. LOGLAN PROGRAM \r
+\r
+ In this case the default switches values are assumed. \r
+\r
+\r
+ Scope of the switch is the entire program. All switches ,except H, \r
+correspond to options. A switch has greater priority then options: \r
+when you specify switch, all corresponding options inside source \r
+program will be ignored. Full description of each option is given \r
+in chapter 2.2. Switch L has additional significance. When this \r
+switch is set off no listing file is produced. \r
+\r
+\r
+\r
+1.3. CODE GENERATION \r
+\r
+\r
+ In this step information from the intermediate code file is read \r
+and two destination files containing the code are produced. No \r
+switch is permitted for this step. To generate code files, type: \r
+ GEN <file name>\r
+ or\r
+ HGEN <file name>, if the switch H+ was specified for the \r
+compiler.\r
+You type file name without extension (extension is ignored). \r
+\r
+\r
+Example: \r
+\r
+\r
+ 1. GEN \r
+ FILE_NAME: PROGRAM \r
+Information is read from file PROGRAM.LCD from default drive and \r
+directory. Two destination files are produced: PROGRAM.CCD and \r
+PROGRAM.PCD and stored in the same directory as the input file. \r
+\r
+\r
+ 2. HGEN A:PROGRAM \r
+\r
+ Files PROGRAM.CCD and PROGRAM.PCD are stored on drive A. \r
+\r
+\r
+\r
+1.4. PROGRAM INTERPRETATION \r
+\r
+\r
+ To interprete (execute) the Loglan program you must invoke the \r
+interpreter INT or HINT (if the switch H+ was specified). File name \r
+must be specified in command line. The file extension is ignored. The \r
+interpreter reads input files with the given name and extensions CCD \r
+and PCD and executes the Loglan program.\r
+The syntax for calling the onterpreter is\r
+\r
+ INT <options> <file name> \r
+ or\r
+ HINT <options> <file name>\r
+\r
+The following options are supported:\r
+\r
+ /m < n > - set memory size for Loglan program (in 16 bit words \r
+ for small and 32 bit words for huge memory). For \r
+ concurrent programs it means memory size for every \r
+ process.\r
+ /i - information about compactification is printed.\r
+ /r < n > - used to invoke interpreter on nodes different from \r
+ console (see 3.4.). Option parameter is console node \r
+ number (as defined by D-Link Network).\r
+\r
+\r
+ At the end of interpretation the following message is printed: \r
+\r
+\r
+ End of LOGLAN-82 program execution \r
+\r
+\r
+\r
+Example: \r
+\r
+ LOGLAN \DAT\EXAMP.SRC, L+ \r
+\r
+\r
+ The file \DAT\EXAMP.LCD and \DAT\EXAMP.LST are generated. \r
+\r
+ GEN \DAT\EXAMP \r
+\r
+ The files \DAT\EXAMP.CCD and \DAT\EXAMP.PCD are created. Then the \r
+program can be interpreted by: \r
+\r
+ INT \DAT\EXAMP \r
+\r
+1.5. COMPILE TIME ERRORS\r
+\r
+\r
+\r
+ The errors detected during the compilation are printed on the\r
+listing file, if this file is created. In the scope of option L- or\r
+if the switch L is set off only the incorrect lines and errors \r
+messages are printed . When the switch ( not option !) L is set off \r
+then listing file is not produced and incorrect lines and error\r
+messages are printed on the user's terminal. \r
+ Error message has the following format: \r
+ *** ln ERROR en txt id \r
+where: \r
+\r
+ ln - index of incorrect line, \r
+ en - error code (see Appendix B), \r
+ txt- text that explain type of the error, \r
+ id - identifier helpful to situate the error. \r
+\r
+ Error messages are printed in the source listing after incorrect \r
+lines. For syntax errors (numbered 101-147, 201-212), sign '?' \r
+indicates the error position in the line. \r
+ Error may be detected beyond the line containing it. \r
+Identifier helpful to find an error is printed as soon as possible. \r
+\r
+ For codes 331-338 error message is printed after first line of \r
+virtual module declaration. \r
+ Errors like "undeclared identifier" are printed in each module \r
+once, after first reference to this identifier. Further references are \r
+ignored. \r
+ The errors related to case instruction may appear before the \r
+incorrect line. \r
+\r
+\r
+\r
+\r
+1.6. RUN-TIME ERRORS \r
+\r
+\r
+\r
+ Loglan run-time errors are detected by Loglan run-time system. When \r
+any of these errors occurs, the appropriate system signal is raised \r
+and error message is printed if handler is not found. All of \r
+these error messages are described in Appendix C. Moreover \r
+the line number of the last executed statement is printed on the \r
+user's terminal. \r
+\r
+\r
+\r
+\r
+2. COMPILER OPTIONS \r
+\r
+\r
+\r
+ Options, like switches are used to pass some information to \r
+the compiler. Options are placed in source program in comments. \r
+ Scope of options in source program is textual. Option may appear in \r
+any place of source program, but it is active from the beginning of \r
+the nearest instruction. Listing option L is active from the next line \r
+after line containing setting this option on up to the line containing \r
+setting this option off. \r
+ Options overwrite defaults, but are overwritten by switches \r
+(external options). \r
+ Option definition is not allowed before the keyword program. \r
+\r
+\r
+2.1. OPTION FORMAT \r
+\r
+\r
+\r
+ Options may be placed in source program in comments in the \r
+following format: \r
+ (*$opt1,opt2,...*)\r
+where opti consists of character that designates the option and \r
+either '+' or '-' e.g.: (*$L-,T+*). Options in one comment should \r
+be separated by commas. Spaces in such comment are not allowed. \r
+\r
+\r
+\r
+\r
+\r
+\r
+2.2. OPTIONS LIST \r
+\r
+\r
+\r
+ D - trace \r
+ D+ - causes the line numbers of the executed instruction to \r
+ be printed, \r
+ D- - default, \r
+ L - listing \r
+ L- - default, only incorrect lines are printed on the \r
+ terminal\r
+ L+ - all lines are printed on the listing file\r
+ O - optimization \r
+ O+ - optimization of some arithmetical and logical \r
+ expressions are included to generated code (default), \r
+ O- - generate code without optimization, \r
+ T - type conflict checking \r
+ T+ - default, dynamic checking of type conflict in \r
+ assignment instructions and in parameter transmissions, \r
+ T- - no dynamic checking \r
+ H - memory model (switch only)\r
+ H- - default, small memory\r
+ H+ - huge memory\r
+ When H- is specified all code and data must fit into 64K \r
+ bytes. When H+ is specified all memory available on IBM PC \r
+ may be utilized, with the cost of increased execution time.\r
+\r
+\r
+\r
+\r
+3. IBM PC LOGLAN-82 IMPLEMENTATION SPECIFICATION\r
+\r
+\r
+3.1. IMPLEMENTED SUBSET OF LOGLAN \r
+\r
+\r
+\r
+ The following constructions described in the report of Loglan-82 \r
+have not been implemented: \r
+ - local attributes, \r
+ - separate compilation, \r
+File system is described in 3.3. \r
+\r
+\r
+3.2. NON-STANDARD LANGUAGE ELEMENTS \r
+\r
+\r
+\r
+ Standard constants, procedures and functions are added to the \r
+language (see Appendix A). Moreover keywords char (short form of \r
+character) and bool (short form of boolean) are added. \r
+ The character set, defined in the report of Loglan-82, is \r
+extended by lower - case letters and the tabulation character (decimal \r
+code 9). It is possible to use operator '<>' which stands for 'not \r
+equal'. \r
+\r
+\r
+\r
+\r
+3.3. FILE SYSTEM \r
+\r
+\r
+ Loglan contains the predefined reference type file and a set of \r
+statements and standard procedures to manipulate files. Both \r
+sequential and direct access files are implemented.\r
+\r
+\r
+3.3.1. FILE VARIABLES \r
+\r
+\r
+ Variables of the type file can be declared in the Loglan program \r
+and can be used as any variables of a reference type. \r
+\r
+\r
+Example: \r
+\r
+ var f:file, \r
+ A:arrayof file; \r
+ unit p:procedure(f:file); ... end; \r
+ begin \r
+ ...... \r
+ f := A(i); \r
+ ...... \r
+ end; \r
+\r
+\r
+\r
+3.3.2. FILE GENERATION \r
+\r
+\r
+ A file object is generated by open statement of the form: \r
+\r
+ open(f,T) for internal files or \r
+ open(f,T,A) for external files \r
+where \r
+ f is a file variable \r
+\r
+ T = text for text files \r
+ char --- for binary sequential files of character, \r
+ integer or real values\r
+ integer !\r
+ real --- \r
+ direct for direct access binary files\r
+ \r
+ A is an expression of the type arrayof char designating \r
+external file name.\r
+ After execution of open statement the new file object is created \r
+and it becomes a value of the file variable f. If the file is opened \r
+as an external one, then it references to the file A.\r
+\r
+\r
+Example: \r
+\r
+ open(data,text) - new internal text file data is \r
+ opened\r
+ open(num ,integer) - new internal binary file num is \r
+ opened (the file components are \r
+ integer numbers ) \r
+ open(f,text,unpack("my.dat")) - external text file f is opened; it \r
+ references to the file my.dat \r
+ stored on the default drive and \r
+ directory. \r
+ open(f,direct,A) - external direct access file with \r
+ name contained in array A is opened.\r
+\r
+\r
+3.3.3. FILE DEALLOCATION \r
+\r
+\r
+ The file can be closed and deallocated by execution of the \r
+statement kill. \r
+\r
+\r
+\r
+3.3.4. GENERAL FILE OPERATIONS \r
+\r
+\r
+ There are three standard procedures associated with files: RESET, \r
+REWRITE and UNLINK. \r
+\r
+call RESET(f) rewinds the file f. After execution of RESET on \r
+ sequential files only read/get operations are \r
+ available. \r
+\r
+call REWRITE(f) creates a new empty file. After execution of \r
+ REWRITE on sequential files only write/put operations \r
+ are available.\r
+\r
+call UNLINK(f) closes and deletes file f. File object is deallocated \r
+ and f is set to none.\r
+\r
+ RESET or REWRITE must be performed on the file opening\r
+ before the first I/O operation on it. \r
+\r
+\r
+\r
+\r
+3.3.5. TEXT FILES \r
+\r
+\r
+ The following operations are available to text files: read, readln, \r
+eoln, write, writeln, eof. \r
+ The first parameter of the operation is a file variable. If it is \r
+omitted, then a standard input/output file assigned to user's \r
+terminal is used.\r
+\r
+\r
+\r
+\r
+\r
+Example: \r
+\r
+ read(f,a,b); \r
+ read(c); \r
+ writeln(g," .... "); \r
+ if eof(f) then .... \r
+\r
+\r
+For more information see (1). \r
+\r
+\r
+\r
+3.3.6. BINARY SEQUENTIAL FILES\r
+\r
+\r
+ Any file created with the parameter T = integer, real or char is a \r
+binary one.It is a sequence of components of the type T. Only objects \r
+of type T can be read from or written to this file. \r
+ The following operations are avaliable to binary files: \r
+\r
+ put( w1, ..., wn) \r
+ get(f, x1, ..., xn) \r
+ eof(f) \r
+\r
+where f is a file opened with the type T, wi is an expression of the \r
+type T and xi is a variable of the type T. \r
+ The statement put(f, w1, ..., wn) writes the components w1, ...,\r
+wn to the file f. The statement get(f, x1, ..., xn) reads the next n \r
+components from the file f and assigns them to the variables x1, \r
+..., xn. The statement eof is the same as for text files. \r
+\r
+\r
+\r
+3.3.7 DIRECT ACCESS BINARY FILES\r
+\r
+\r
+ Direct access files are treated as a sequence of bytes without any \r
+interpretation. Operations RESET and REWRITE prepare a file for both \r
+reading and writing. RESET is used for existing files, REWRITE for the \r
+new ones. The following additional operations are available:\r
+\r
+call SEEK(f, offset, base) - moves the file pointer to the position \r
+ designated by offset relative to base. \r
+ Offset is a signed integer specifying the \r
+ number of bytes. Possible values for base \r
+ are:\r
+ 0 - begining of file\r
+ 1 - current position of file pointer\r
+ 2 - end of the file\r
+\r
+Examples:\r
+\r
+call SEEK(f, 0, 0) - rewinds file f\r
+call SEEK(f, -3, 1) - backspaces file f by 3 bytes\r
+call SEEK(f, 0, 2) - moves the file pointer to the first byte \r
+ after end of file\r
+\r
+POSITION(f) - returns current position of the file \r
+ pointer associated with f.\r
+\r
+\r
+\r
+PUTREC(f, A, n) - where A is an array of any primitive \r
+ type and n is an integer variable. Let k \r
+ be the number of bytes occupied by \r
+ elements of array A. This operation \r
+ writes min(k, n) bytes from A to the file \r
+ f and advances file pointer by the number \r
+ of written bytes. The number of bytes \r
+ written to the file is returned in the \r
+ variable n.\r
+\r
+\r
+GETREC(f, A, n) - where A is an existing array of any \r
+ primitive type and n is an integer \r
+ variable. Let k be the number of bytes \r
+ occupied by elements of array A This \r
+ operation reads min(k,n) bytes (or less, \r
+ if end of file is encountered) from the \r
+ file and advances the file pointer by the \r
+ number of read bytes. The number of bytes \r
+ read from the file is returned in the \r
+ variable n.\r
+\r
+\r
+\r
+\r
+3.4. CONCURRENCY\r
+\r
+\r
+\r
+ Implemented concurrency mechanisms differ much from those described \r
+in the LOGLAN-82 report. In particular, only distributed processes are \r
+implemented, so they cannot communicate through shared variables. For \r
+this reason semaphores had to be replaced by an entirely new \r
+communication mechanism. Such a mechanism has been designed and it is \r
+based on the rendez-vous schema.\r
+\r
+\r
+3.4.1. INVOKING THE LOGLAN INTERPRETER FOR CONCURRENT PROGRAMS\r
+\r
+\r
+ A concurrent LOGLAN program may run on a single computer with \r
+concurrency simulated by time slicing. In this case LOGLAN interpreter \r
+is invoked as usual. One must only remember that /m optional parameter \r
+(see 1.4.) denotes memory size for each process rather than for the \r
+whole program.\r
+\r
+ To achieve true parallel (multiprocessor) execution, a network of \r
+IBM PC computers may be used. For the time being, only D-Link Network \r
+Version 3.21 is supported. In order to run a LOGLAN program in the \r
+network environment take the following steps:\r
+\r
+ 1) make sure that every node is logged on,\r
+ 2) select arbitrarily one node as a console,\r
+ 3) invoke the LOGLAN interpreter on every node except the console, \r
+ giving it /r option with the console node number (see 1.4.). You \r
+ must give the same program file to all interpreters. Most \r
+ conveniently it may be achieved by accessing a file on a disk \r
+ connected through the network to each node.\r
+ 4) invoke the interpreter on the console without the /r option (in \r
+ the usual way). Give it the same program file as above.\r
+\r
+ After the last step the main program process begins its execution \r
+on the console node. Other processes may be created dynamically on any \r
+node on which an interpreter is running.\r
+\r
+ Regardless of the fact whether the network is used or not, more \r
+than one process may be executed on the same computer.\r
+\r
+\r
+3.4.2. RESTRICTIONS AND DIFFERENCES FROM THE REPORT\r
+\r
+\r
+ All processes (even those executed on the same computer) are \r
+implemented as distributed, i.e. without any shared memory. This fact \r
+implies some restrictions on how processes may be used. Not all \r
+restrictions are enforced by the present compiler, so it is the \r
+programmer's responsibility to respect them. This is the list of \r
+restrictions:\r
+\r
+ 1) all process units must be declared as global, i.e. directly \r
+ inside the main program block\r
+ 2) a process cannot access global variables (except for the main \r
+ program process)\r
+ 3) any remote access to a process object other than a procedure (or \r
+ function) call is inhibited\r
+ 4) each parameter of\r
+ - a process\r
+ - a procedure called by remote access to a process object\r
+ - a procedure parameter of a process\r
+ must be one of the following:\r
+ - a value of the primitive type (INTEGER, REAL, CHAR, BOOLEAN, \r
+ STRING)\r
+ - a procedure declared directly inside a process\r
+ - a procedure which is a formal parameter of a process\r
+ - any reference to a process object.\r
+ This restriction implies that references to objects other than \r
+ processes have only local meaning (in a single process) and \r
+ cannot be passed among the processes.\r
+ 5) comparisons, IS, IN and QUA operations are not allowed for the \r
+ references to processes. \r
+ 6) operations which require dynamic type checking on the references \r
+ to processes are not allowed\r
+ 7) a process may be attached only by a proper coroutine (not by a \r
+ process) generated by it\r
+ 8) the variable MAIN is accesible only in the main program process.\r
+\r
+ The following concurrent constructs described in the report are not \r
+implemented at all:\r
+\r
+ - semaphores and all operations on them\r
+ - the WAIT expression.\r
+\r
+ Semantics of the NEW generator is slightly modified when applied to \r
+the processes. The first parameter of the first process unit in the \r
+prefix sequence must be of type INTEGER. This parameter denotes the \r
+node number of the computer on which this process will be created. For \r
+a single computer operation this parameter must be equal to 0.\r
+\r
+Example:\r
+\r
+unit A:class(msg:string);\r
+...\r
+end A;\r
+unit P:A process(node:integer, pi:real);\r
+...\r
+end P;\r
+...\r
+var x:P;\r
+...\r
+begin\r
+...\r
+ (* Create process on node 4. The first parameter is the *) \r
+ (* string required by the prefix A, the second is the node number *)\r
+ x := new P("Hello", 4, 3.141592653);\r
+...\r
+end\r
+\r
+\r
+ The following parallel constructs are implemented as defined in the \r
+report:\r
+\r
+ - KILL operation for a process\r
+ - RESUME statement\r
+ - STOP statement without parameter.\r
+\r
+\r
+3.4.3. COMMUNICATION MECHANISM\r
+\r
+\r
+ Processes may communicate and synchronize by a mechanism based on \r
+rendez-vous. It will be referred to as "alien call" in the following \r
+description.\r
+\r
+ An alien call is either:\r
+ - a procedure (or function) call performed by a remote access to a \r
+ process object, or\r
+ - a call of a procedure which is a formal parameter of a process, \r
+ or\r
+ - a call of a procedure which is a formal parameter of an \r
+ alien-called procedure (this is a recursive definition).\r
+\r
+ Every process object has an enable mask. It is defined as a subset \r
+of all procedures declared directly inside a process unit or any unit \r
+from its prefix sequence (i.e. subset of all procedures that may be \r
+alien-called).\r
+ A procedure is enabled in a process if it belongs to that process' \r
+enable mask. A procedure is disabled if it does not belong to the \r
+enable mask. \r
+ Immediately after generation of a process object its enable mask is \r
+empty (all procedures are disabled).\r
+\r
+ Semantics of the alien call is different from the remote call \r
+described in the report. Both the calling process and the process in \r
+which the procedure is declared (i.e. the called process) are involved \r
+in the alien call. This way the alien call may be used as a \r
+synchronization mechanism.\r
+ The calling process passes the input parameters and waits for the \r
+call to be completed.\r
+ The alien-called procedure is executed by the called process. \r
+Execution of the procedure will not begin before certain conditions \r
+are satisfied. First, the called process must not be suspended in any \r
+way. The only exception is that it may be waiting during the ACCEPT \r
+statement (see below). Second, the procedure must be enabled in the \r
+called process.\r
+ When the above two conditions are met the called process is \r
+interrupted and forced to execute the alien-called procedure (with \r
+parameters passed by the calling process).\r
+ Upon entry to the alien-called procedure all procedures become \r
+disabled in the called process.\r
+ Upon exit the enable mask of the called process is restored to that \r
+from before the call (regardless of how it has been changed during the \r
+execution of the procedure). The called process is resumed at the \r
+point of the interruption. The execution of the ACCEPT statement is \r
+ended if the called process was waiting during the ACCEPT (see below). \r
+At last the calling process reads back the output parameters and \r
+resumes its execution after the call statement.\r
+\r
+ The process executing an alien-called procedure can easily be \r
+interrupted by another alien call if the enable mask is changed.\r
+\r
+ There are some new language constructs associated with the alien \r
+call mechanism. The following statements change the enable mask of a \r
+process:\r
+ ENABLE p1, ..., pn\r
+enables the procedures with identifiers p1, ..., pn. If there are any \r
+processes waiting for an alien call of one of these procedures, one of \r
+them is chosen and its request is processed. The scheduling is done on \r
+a FIFO basis, so it is strongly fair. The statement:\r
+ DISABLE p1, ..., pn\r
+disables the procedures with identifiers p1, ..., pn.\r
+ In addition a special form of the RETURN statement:\r
+ RETURN ENABLE p1, ..., pn DISABLE q1, ..., qn\r
+allows to enable the procedures p1, ..., pn and disable the procedures \r
+q1,...,qn after the enable mask is restored on exit from the \r
+alien-called procedure. It is legal only in the alien-called \r
+procedures (the legality is not enforced by the compiler).\r
+ A called process may avoid busy waiting for an alien call by means \r
+of the ACCEPT statement:\r
+ ACCEPT p1, ..., pn\r
+adds the procedures p1, ..., pn to the current mask, and waits for an \r
+alien call of one of the currently enabled procedures. After the \r
+procedure return the enable mask is restored to that from before the \r
+ACCEPT statement.\r
+\r
+ Note that the ACCEPT statement alone (i.e. without any \r
+ENABLE/DISABLE statements or options) provides a sufficient \r
+communication mechanism. In this case the called process may execute \r
+the alien-called procedure only during the ACCEPT statement (because \r
+otherwise all procedures are disabled). It means that the enable mask \r
+may be forgotten altogether and the alien call may be used as a pure \r
+totally synchronous rendez-vous. Other constructs are introduced to \r
+make partially asynchronous communication patterns possible.\r
+\r
+\r
+\r
+\r
+3.5. SYSTEM SIGNALS \r
+\r
+\r
+\r
+ System signals are connected to runtime errors (see APPENDIX C). \r
+These signals are the following: \r
+\r
+ ACCERROR - reference to non existing object, \r
+ CONERROR - array index outside the range or lower bound is \r
+ greater than upper bound during array object \r
+ generation, \r
+ LOGERROR - errors related to control transfer, \r
+ MEMERROR - memory overflow, \r
+ NUMERROR - errors related to arithmentic operations like division \r
+ by zero, floating point overflow, \r
+ TYPERROR - type conflict in assignment statement, during \r
+ parameter transmission or headline conflict for actual \r
+ parameter function and procedure. \r
+ SYSERROR - errors related to file system, like reading after \r
+ writing, too many files etc. \r
+\r
+\r
+\r
+\r
+3.6. IMPLEMENTATION RESTRICTIONS \r
+\r
+\r
+\r
+ - Text line in source program can't be longer than 80 \r
+ characters. \r
+ - Maximal length of identifier is 20 characters, but entire \r
+ length of all identifiers and keywords should be less \r
+ than 3000 characters. \r
+ - String constant can't be longer than 260 characters. \r
+ - For case instructions: \r
+ - up to 6 levels of nested case instructions are \r
+ allowed, \r
+ - range of labels can't be greater than 160. \r
+ - Number of formal parameters can't be greater than 40, \r
+ whereas up to 35 output or input parameters are allowed. \r
+ Total number of formal parameters and variables declared \r
+ in one module can't be greater than 130. \r
+ - Number of array indices (i.e. arrayof) can't be greater \r
+ than 63, \r
+ - Standard type integer has the range (-32767,+32767) for \r
+ small memory (16 - bit word ). For huge memory (32-bit \r
+ word) the range is (-2147483647,+2147483647), but values \r
+ of constant expressions in a program must lie within the \r
+ range (-32767,32767).\r
+ - Real numbers have the range (-8.43E-37, 3.37E+38) \r
+ with 24-bit mantissa and 8-bit exponenet for small \r
+ memory , giving about 7 digits of precision. For huge \r
+ memory the range is (4.19E-307, 1.67E+308) with 53-bit \r
+ mantissa and 11-bit exponent, giving about 15 digits of \r
+ precision.Values of constant expression in a program must \r
+ lie in the range (-8.43E-37, 3.37E+38).\r
+\r
+\r
+ Remark \r
+\r
+\r
+ Compiler computes values of expressions built from \r
+ constants without range checking. It means, that integer \r
+ overflow, floating point overflow or underflow cause \r
+ incorrect result without any message. \r
+\r
+\f\r
+APPENDIX A : STANDARD CONSTANTS\r
+\r
+\r
+ INTSIZE\r
+ The size in bytes of integer variables (2 for small \r
+ memory, 4 for huge memory)\r
+\r
+ REALSIZE\r
+ The size in bytes of real variables (4 for small \r
+ memory, 8 for huge memory)\r
+\r
+\r
+\r
+\r
+\r
+APPENDIX B : STANDARD CLASSES\r
+\r
+\r
+IIUWGRAPH\r
+\r
+ Class IIUWGRAPH defines the set of graphics procedures. The full \r
+description of these procedures is contained in the description \r
+of the library IIUWGRAF (Institue of Informatics, University of \r
+Warsaw). The following procedures are available in Loglan (heads \r
+are specified if they are different from these in IIUWGRAF \r
+description): \r
+\r
+ gron \r
+ groff \r
+ cls \r
+ point \r
+ move \r
+ draw \r
+ hfill \r
+ vfill \r
+ color \r
+ style \r
+ patern \r
+ intens \r
+ pallet \r
+ border \r
+ video \r
+ hpage \r
+ nocard : function: integer; \r
+ pushxy \r
+ popxy \r
+ inxpos : function: integer; \r
+ inypos : function: integer; \r
+ inpix \r
+ getmap : function(input x,y:integer): arrayof integer; \r
+ putmap \r
+ ormap \r
+ xormap \r
+ track \r
+ inkey : function : integer; \r
+ hascii \r
+ hfont \r
+ hfont8 \r
+ outstring \r
+ cirb\r
+\r
+\r
+\f\r
+MOUSE\r
+\r
+\r
+ Standard class MOUSE provides basic support for mouse. An external \r
+resident Microsoft compatible mouse driver (such as MOUSE.SYS) must be \r
+installed to use this class. MOUSE contains following procedures and \r
+functions:\r
+\r
+init:function(output b:integer):boolean\r
+ Initializes mouse driver. Number of mouse buttons is returned \r
+ in b. Returns true iff mouse hardware and software are \r
+ installed.\r
+\r
+showcursor:procedure\r
+ This procedure increments the internal cursor counter. If the \r
+ counter is 0 it displays the cursor on the screen. The cursor \r
+ tracks the motion of the mouse, changing position as the mouse \r
+ changes position.\r
+\r
+hidecursor:procedure\r
+ This procedure removes the cursor from the screen and \r
+ decrements the internal cursor counter. Although the cursor is \r
+ hidden it still tracks the motion of the mouse, changing \r
+ position as the mouse changes position.\r
+\r
+status:procedure(output h, v:integer, l, r, c:boolean)\r
+ This procedure reports the status of the buttons and cursor. \r
+ l, r, c are true iff respectively left, right and center (if \r
+ it exists) buttons are down when the procedure is called. Also \r
+ position of cursor is returned in h and v. Position is \r
+ expressed in Color Graphics Adapter pixels (with resolution \r
+ 640x200).\r
+\r
+setposition:procedure(h, v:integer)\r
+ This procedure sets the cursor to the specified horizontal and \r
+ vertical positions on the screen. The new values must be \r
+ within the specified ranges of the virtual screen. The values \r
+ are rounded to the nearest values permitted by the screen for \r
+ horizontal and vertical positions.\r
+\r
+getpress:procedure(b:integer; output h, v, p:integer, l, r, c:boolean)\r
+ This procedure gives a count of selected button presses (on p) \r
+ since the last call to it and the position of the cursor (on h \r
+ and v) the last time the button was pressed. Parameter b \r
+ selects button to be checked: 0 - left, 1 - right, 2 - center. \r
+ In addition current button status is returned in l, r and c \r
+ (see procedure status).\r
+\r
+getrelease:procedure(b:integer; output h, v, p:integer, l, r, c:boolean)\r
+ This procedure gives a count of selected button releases (on \r
+ p) since the last call to it and the position of the cursor \r
+ (on h and v) the last time the button was released. Parameter \r
+ b selects button to be checked: 0 - left, 1 - right, 2 - \r
+ center. In addition current button status is returned in l, r \r
+ and c (see procedure status).\r
+\r
+setwindow:procedure(l, r, t, b:integer)\r
+ Restricts the cursor movement to window described by l, r, t, \r
+ b. L and r are minimum and maximum horizontal cursor position, \r
+ t and b are minimum and maximum vertical cursor position (in \r
+ CGA pixels)\r
+\r
+\r
+defcursor:procedure(s, x, y:integer)\r
+ Selects text mode cursor characteristics. When s is 0, \r
+ software cursor is selected and x, y define masks to be used \r
+ when modifying character-attribute word in screen memory \r
+ associated with position under cursor. This word is logicaly \r
+ ANDed with x and the result is XORed with y. When s is 1, a \r
+ hardware cursor is selected and x, y define first and last \r
+ scan lines of the cursor box within character box. X must be \r
+ not greater than y and both must be in range 0-7 for Color \r
+ Graphics Adapter or 0-13 for Monochrome Display Adapter, \r
+ Hercules Graphics Card and Enhanced Graphics Adapter.\r
+ Examples:\r
+ call defcursor(0, -1, 30464)\r
+ - selects standard (reverse video) software cursor\r
+ call defcursor(1, 11, 12)\r
+ - selects standard hardware cursor for HGC\r
+\r
+getmovement:procedure(output h, v:integer)\r
+ Returns relative mouse movement since last call (in 1/200 \r
+ inches).\r
+\r
+setspeed:procedure(h, v:integer)\r
+ H and v specify horizontal and vertical cursor speed relative \r
+ to mouse speed. It is expressed in mouse steps (1/200 inch) \r
+ corresponding to 8 CGA pixels on screen. Default is 8 \r
+ horizontaly and 16 verticaly.\r
+ Examples:\r
+ call setspeed(1, 1)\r
+ - set maximum cursor speed\r
+ call setspeed(16, 32)\r
+ - set cursor speed two times slower than default\r
+\r
+setthreshold:procedure(s:integer)\r
+ sets threshold speed for double speed feature. If the mouse \r
+ moves faster than the threshold, the cursor speed on the \r
+ screen is doubled. Default threshold is 64 mouse steps/second.\r
+ Example:\r
+ call setthreshold(10000)\r
+ - efectively disable double speed feature.\r
+\r
+\r
+\r
+\f\r
+APPENDIX C : STANDARD PROCEDURES AND FUNCTIONS \r
+\r
+\r
+ ENDRUN:procedure; \r
+ Terminates program execution (ABORT). \r
+\r
+ RANSET:procedure(x:real); \r
+ Initializes random generator (for RANDOM function) \r
+\r
+ RANDOM:function:real; \r
+ Generates uniformly distributed pseudo-random numbers \r
+ in the interval (0,1). \r
+\r
+ SQRT:function(x:real):real; \r
+ Computes square root of parameter x. \r
+\r
+ SIN:function(x:real):real; \r
+ Computes sinus of parameter x. \r
+\r
+ COS:function(x:real):real; \r
+ Computes cosinus of parameter x. \r
+\r
+ TAN:function(x:real):real; \r
+ Computes tangens of parameter x. \r
+\r
+ EXP:function(x:real):real; \r
+ Computes e**x. \r
+\r
+ LN:function(x:real):real; \r
+ Computes natural logarithmus of parameter x. \r
+\r
+ ATAN:function(x:real):real; \r
+ Computes arcus tangens of parameter x. \r
+\r
+ ENTIER:function(x:real):integer; \r
+ Computes entier part of parameter x. \r
+\r
+ ROUND:function(x:real):integer; \r
+ Computes rounded value of parameter x: \r
+ ROUND(x)=ENTIER(x+0.5). \r
+\r
+ IMIN:function(x, y:integer):integer; \r
+ Computes minimum of two parameters. \r
+\r
+ IMAX:function(x, y:integer):integer; \r
+ Computes maximum of two parameters. \r
+\r
+ IMIN3:function(x, y, z:integer):integer; \r
+ Returns the minimum of three parameters. \r
+\r
+ IMAX3:function(x, y, z:integer):integer; \r
+ Returns maximum of three parameters. \r
+\r
+ ISHFT:function(x, k:integer):integer; \r
+ Logically shifts x by k bits: left, when k is \r
+ positive, right otherwise. \r
+\r
+ IAND:function(n, k:integer):integer; \r
+ Returns logical product of parameters (on all bits). \r
+\r
+ IOR:function(n, k:integer):integer; \r
+ Returns logical sum of parameters (on all bits). \r
+\r
+ XOR:function(n, k:integer):integer; \r
+ Returns exlusive sum of parameters (on all bits). \r
+\r
+ INOT:function(n:integer):integer; \r
+ Returns logical complement of parameters (on all \r
+ bits). \r
+\r
+ ORD:function(c:char):integer; \r
+ Returns number that represents character c (see \r
+ APPENDIX D). The following equations are satisfied: \r
+ CHR(ORD(c)) = c \r
+ ORD(CHR(n)) = n \r
+\r
+ CHR:function(n:integer):char; \r
+ Returns character represented by parameter n (see \r
+ APPENDIX D). \r
+\r
+ UNPACK:function(s:string):arrayof char; \r
+ Returns address of new array object containing \r
+ characters of the string s. \r
+\r
+ MEMAVAIL:function:integer;\r
+ Returns the size of available memory in the current \r
+ process (in words).\r
+\r
+ EXEC:function(cmd:arrayof char):integer; \r
+ Calls secondary command processor with cmd as a \r
+ command string. Exit code is returned as a value of \r
+ EXEC. \r
+ \r
+ TIME:function: integer; \r
+ Returns an integer value indicating the amount of \r
+ central processor time in seconds used by current \r
+ process. \r
+ \r
+ RESET:procedure(f:file); \r
+ Positionnes file f at the first component and readies \r
+ it to reading. \r
+\r
+ REWRITE:procedure(f:file); \r
+ Positionnes file f at the first component and readies \r
+ it for output. The file f becomes empty (eof(f) = \r
+ true). \r
+\r
+ UNLINK:procedure(f:file);\r
+ Closes and deletes file f (see 3.3.4)\r
+\r
+ SEEK:procedure(f:file; offset, base:integer);\r
+ Positiones file pointer (see 3.3.7)\r
+\r
+ POSITION:function(f:file):real;\r
+ Reads position of file pointer (see 3.3.7)\r
+\r
+\r
+\r
+\r
+\f\r
+APPENDIX D : ERROPOR CODES\r
+\r
+\r
+\r
+ 0 - ***declaration part overloaded \r
+ Overflow of compiler data structure of declaration \r
+ part. Possible reasons: too complicated program \r
+ structure (too many classes, protection lists, \r
+ parameter lists,...), too complicated function \r
+ expressions e.g. f(g(h(...))). It is possible that \r
+ removing some errors e.g. "unvisible identifier" \r
+ causes shortening of the program. \r
+ 10 - ***too many errors \r
+ Overflow of error diagnostic table. 1024 first \r
+ detected errors are printed, but global number of \r
+ error is equal to number of all detected errors. \r
+ 41 - ***declaration part overloaded \r
+ Comments as for 0. \r
+ 101 - ':=' expected \r
+ 102 - ';' expected \r
+ 103 - 'then' expected \r
+ 104 - 'fi'/'else' expected \r
+ 105 - 'od' expected \r
+ 106 - '(' expected \r
+ 107 - ')' expected \r
+ 108 - 'do' expected \r
+ 109 - identifier expected \r
+ 110 - too many exits found \r
+ Length of sequence exit exit ...exit exceeds level \r
+ of loop nesting +1. \r
+ 111 - illegal character \r
+ 112 - wrong structure of 'if'-statement \r
+ 113 - 'end' missing \r
+ 114 - '.' expected \r
+ 115 - illegal constant in expression \r
+ Character constant or text appears in logical or \r
+ arithmetical expression. \r
+ 116 - '=' expected \r
+ 117 - constant expected \r
+ 118 - ':' expected \r
+ 119 - unit kind specification expected \r
+ Keywords: class, procedure, function, coroutine or \r
+ process missing in module headline. \r
+ 120 - 'hidden' or 'close' occurred twice \r
+ 121 - 'hidden' or 'close' out of a class \r
+ 122 - 'block' expected \r
+ 123 - object expression is not a generator \r
+ Object expression appearing as instruction is not \r
+ a generator e.g. new (a).b \r
+ 124 - 'dim' expected \r
+ 125 - 'to'/'downto' expected \r
+ 126 - illegal arithmetic operator \r
+ 127 - declaration part expected \r
+ 128 - incorrect identifier at 'end' \r
+ Module name after end does not correspond to name \r
+ in module headline. \r
+ 129 - wrong structure of 'case'-statement \r
+ 130 - wrong structure of 'do'-statement \r
+ 131 - illegal use of 'main' \r
+ Name main may be used only as an argument of \r
+ attach operator: in other cases it is illegal. \r
+ 132 - 'when' expected \r
+ 133 - too many branches in 'case'-statement \r
+ Number of branches in case instruction is greater \r
+ than 160. \r
+ 134 - 'begin' missed \r
+ 135 - bad option \r
+ 136 - is it really a loglan program??? \r
+ There is no Loglan keyword found in source program \r
+ like: begin, block, unit, class,... \r
+ 137 - 'block' missed - parsing began \r
+ There is no keyword block or program at the \r
+ beginning of the Loglan program. This message \r
+ indicates the source line, that is the first \r
+ compiled line. \r
+ 138 - 'repeat' out of a loop \r
+ The length of sequence: (exit)*repeat exceeds \r
+ nested depth of the loop. \r
+ 139 - there is no path to this statement \r
+ 140 - 'andif'/'orif' mixed \r
+ 141 - array of 'semaphore' is illegal \r
+ 142 - wrong handler end \r
+ Handler declaration is not ended by instruction \r
+ end or end handlers. \r
+ 143 - lastwill inside a structured statement \r
+ 144 - repeated lastwill \r
+ Label LASTWILL appears more than once in the same \r
+ module. \r
+ 145 - no parameter specification \r
+ 146 - wrong register specification \r
+ 147 - "," expected\r
+ 191 - ***null program \r
+ There is no source program on the input file or \r
+ there is no module declaration. Causes termination \r
+ of program compilation. \r
+ 196 - ***too many identifiers \r
+ Entire length of all identifiers and keywords is \r
+ greater than 3000 characters. This overflow \r
+ terminates program compilation. \r
+ 197 - ***too many formal parameters \r
+ The length of formal parameter list and declared \r
+ local variables (in actual module) is greater than \r
+ 130. This error terminates program compilation. \r
+ 198 - ***parsing stack overloaded \r
+ Too complicated (nested) program structure. This \r
+ error terminates program compilation. \r
+ 199 - ***too many prototypes \r
+ Too many declarations in program caused overflow \r
+ of the compiler data structure. This error \r
+ terminates program compilation. \r
+ 201 - wrong real constant \r
+ 202 - wrong comment \r
+ 203 - wrong character constant \r
+ 204 - wrong integer constant \r
+ 205 - integer overflow \r
+ Integer constant out of range. \r
+ 206 - real overflow \r
+ Real constant out of range. \r
+ 211 - identifier too long \r
+ Length of identifier is greater than 20 \r
+ characters. \r
+ 212 - string too long \r
+ Length of string constant is greater than 260 \r
+ characters. \r
+ 301 - prefix is not a class id \r
+ Prefix name ID is not a class name. It may appear \r
+ when identifier ID is used earlier (declarated \r
+ more than once). \r
+ 303 - coroutine/process illegal here as prefix id \r
+ Procedure, function or block can't be prefixed by \r
+ coroutine or process. \r
+ 304 - hidden identifier cannot be taken id \r
+ Identifier ID placed on taken list is on hidden \r
+ list in the prefixing module. \r
+ 305 - undeclared identifier id \r
+ 306 - undeclared type identifier id \r
+ 307 - type identifier expected id \r
+ Identifier ID used in variable or function \r
+ declaration as a type name, is not declared \r
+ earlier as a type (but name has been used \r
+ earlier). \r
+ 308 - undeclared prefix identifier id \r
+ 309 - declared more than once id \r
+ 310 - taken list in unprefixed unit \r
+ 316 - formal type specification after use id \r
+ Formal type ID appears in the parameter list after \r
+ using this identifier as a parameter type e.g. \r
+ (... x: ID; type ID, ...). \r
+ 317 - hidden type identifier id \r
+ Type name ID is on hidden list in a prefix of one \r
+ of the modules from SL chain of actual module and \r
+ it is a nearest declaration of this identifier. \r
+ 318 - type identifier not taken id \r
+ Type name ID is not on taken list in a prefix of \r
+ one of the modules from SL chain of actual module. \r
+ 319 - hidden identifier in the list id \r
+ Identifier ID from hidden or close list is on \r
+ hidden list in one of the prefixing modules. \r
+ 320 - identifier in the list not taken id \r
+ Identifer ID from hidden or close list is not \r
+ placed on taken list in none of the prefixing \r
+ modules. \r
+ 321 - identifier cannot be taken id \r
+ Identifer ID from taken list is placed on taken \r
+ list in none of the prefixes. \r
+ 322 - hidden prefix identifier id \r
+ Analogical to 317 error. \r
+ 323 - prefix identifier not taken id \r
+ Analogical to 318 error. \r
+ 329 - only procedure and function may be virtual \r
+ virtual specification appears with class \r
+ specification. \r
+ 330 - virtual in unprefixed block/procedure/function \r
+ 331 - incompatible kinds of virtuals id \r
+ Kind of virtual module ID is different from kind \r
+ of replaced module (e.g. one of them is a \r
+ function, the other one is a procedure). \r
+ 332 - incompatible types of virtuals id \r
+ Type of virtual function ID is different from type \r
+ of replaced function. \r
+ 333 - different lengths of form.param.lists in virtuals id \r
+ Virtual module ID and replaced module have \r
+ different number of formal parameters. \r
+ 334 - conflict kinds of the 1st level parameters id \r
+ In the headline of virtual module ID kind of \r
+ formal parameter differs from corresponding formal \r
+ parameter in the headline of replaced module (e.g. \r
+ type and variable, input and output \r
+ parameters,...). \r
+ 335 - incompatible types of the 1st level parameters id \r
+ There are formal parameters of different types \r
+ (function, procedure) in the headline of virtual \r
+ module ID and in the headline of replaced module \r
+ on the same position. \r
+ 336 - different lengths of the 2nd level params lists id \r
+ There are formal procedures/functions with \r
+ different numbers of parameters in the headline of \r
+ virtual module ID and in the headline of replaced \r
+ module on the same position. \r
+ 337 - incompatible kinds of the 2nd level parameters id \r
+ There are parameters of different kinds on the \r
+ same position in the corresponding procedure or \r
+ function parameters in the headline of virtual \r
+ module ID and in the headline of replaced module. \r
+ 338 - incompatible types of the 2nd level parameters id \r
+ There are parameters of different types on the \r
+ same position in the corresponding procedure or \r
+ function in the headline of virtual module ID and \r
+ in the headline of replaced module. \r
+ 341 - ***declaration part overloaded \r
+ Analogical to error 0. \r
+ 342 - ***too many classes declared \r
+ 343 - ***too many prototypes \r
+ Too many modules declared on the same level. \r
+ 350 - undeclared signal identifier id \r
+ 351 - hidden signal identifier id \r
+ Analogical to error 317. \r
+ 352 - signal identifier not taken id \r
+ Analogical to error 318. \r
+ 353 - signal identifier expected id \r
+ Identifier ID placed in handler declaration as a \r
+ signal name has not been declared as a signal. \r
+ 354 - different types of parameters id \r
+ In the headlines of signals, that have common \r
+ handler, parameters of the different types appear \r
+ on the same position. ID is one of these \r
+ parameters. \r
+ 355 - incompatible kinds of parameters id \r
+ In the headlines of signals that have common \r
+ handler, parameters of different kinds appear on \r
+ the same position. ID is one of these parameters. \r
+ 356 - different identifiers of parameters id \r
+ In the headlines of signals that have common \r
+ handler parameters of different names appear on \r
+ the same position. ID is one of these parameters. \r
+ 357 - incompatible kinds of the 2nd level parameters id \r
+ Analogous to error 355 for 2-nd level parameters. \r
+ 358 - different types of the 2nd level parameters id \r
+ Analogous to error 354 for the 2-nd level parameters. \r
+ 359 - different lengths of the 2nd level params lists id \r
+ There are formal procedures or formal functions \r
+ with different number of parameters on the same \r
+ position in the headlines of signals this have \r
+ common handler. ID is one of these formal \r
+ parameters/functions. \r
+ 360 - different lengths of form. param. lists in signals id \r
+ There are different number of formal parameters in \r
+ the signals that have common handler. ID is one of \r
+ these signals. \r
+ 361 - non-local formal type cannot be used id \r
+ Formal parameter ID of signal is of non local \r
+ formal type. \r
+ 362 - repeated handler for signal id \r
+ There are more than one handler for signal ID in \r
+ the same module. \r
+ 370 - only 'input' is legal here \r
+ Formal parameter output or inout is illegal in \r
+ process. \r
+ 398 - class prefixed by itself id \r
+ Construction unit ID: ID class is not allowed. \r
+ 399 - cycle in prefix sequence id \r
+ ID is a class identifier used in cyclic prefixing \r
+ i.e. ID prefixes a, a prefixes b, ... , z prefixes \r
+ ID. This construction is not allowed. \r
+ 401 - wrong label in 'case' id \r
+ Label in case instruction is not a constant. \r
+ 402 - 'case' statement nested too deeply \r
+ Nesting level in case instruction is greater than \r
+ 6. \r
+ 403 - too long span of 'case' labels \r
+ Range of branches in case instruction is greater \r
+ than 160. \r
+ 404 - repeated label in 'case'-statement id \r
+ Label ID appears more than once in case \r
+ instruction. \r
+ 405 - illegal type of 'case' expression id \r
+ Control expression in case statement is not of \r
+ integer or char type. \r
+ 406 - different types of labels and 'case' expression \r
+ 407 - non-logical expression after 'if'/'while' id \r
+ 408 - real constant out of integer range \r
+ Error during conversion of real constant to \r
+ integer constant. \r
+ 410 - simple variable expected id \r
+ Control variable in for loop is not a simple \r
+ variable. \r
+ 411 - non-integer control variable id \r
+ Control variable ID in for loop is not of integer \r
+ type. \r
+ 412 - non-integer expression id \r
+ Expression placed as array index or bound limit in \r
+ array generation or as step in for loop or as \r
+ format in write statement should be reducable to \r
+ integer type. \r
+ 413 - file expression expected id \r
+ 414 - string expression expected id \r
+ 415 - reference expression expected id \r
+ Expression placed before dot (remote access), \r
+ before qua or as a argument of kill or copy \r
+ statement is not of class type. \r
+ 416 - array expression expected id \r
+ 417 - boolean expression expected id \r
+ 418 - semaphore variable expected \r
+ 419 - illegal type in 'open' \r
+ The type name placed in open is different than \r
+ TEXT, REAL, INTEGER, CHAR and DIRECT. \r
+ 420 - variable expected id \r
+ Expression placed on the left side of assignment \r
+ statement or as an argument of read instruction or \r
+ in array instruction is not a variable. \r
+ 421 - class identifier after 'new' expected id \r
+ Identifier ID placed after new is not a class \r
+ identifier. \r
+ 422 - procedure identifier after 'call' expected id \r
+ 423 - 'new' missing id \r
+ Keyword new doesn't appear before class identifier \r
+ for object generation. \r
+ 424 - 'call' missing id \r
+ Keyword call doesn't appear before procedure \r
+ identifier for procedure call. \r
+ 425 - 'inner' out of a class \r
+ 426 - 'inner' occurred more than once \r
+ 427 - 'wind'/'terminate' out of a handler \r
+ 428 - 'inner' inside lastwill \r
+ 429 - definition cannot be reduced to constant id \r
+ Identifier ID placed in constant definition is not \r
+ a constant. \r
+ 430 - undefined constant in the definition id \r
+ 431 - wrong number of indices id \r
+ Number of indices in referencing to array element \r
+ is different from declared number of indices. \r
+ 432 - index out of range id \r
+ 433 - upper bound less than lower bound id \r
+ 434 - too many subscripts id \r
+ Dimension of static array ID is greater than 7. \r
+ 435 - variable is not array id \r
+ 440 - type identifier expected after 'arrayof' id \r
+ Identifier ID placed after arrayof in actual \r
+ parameter list, corresponding to type parameter is \r
+ not a type name. \r
+ 441 - incorrect format in 'write' \r
+ There is format for expression of char type or \r
+ there is double format for expression of type \r
+ integer or string. \r
+ 442 - illegal expression in 'write' \r
+ Argument of write statement is not of type char, \r
+ string, integer or real. \r
+ 443 - illegal type of variable in 'read' id \r
+ Argument of read statement is not of type char, \r
+ integer or real. \r
+ 444 - no data for i/o transfer \r
+ There is only file identifier in I/O instruction. \r
+ 445 - illegal expression in 'put' \r
+ 446 - illegal expression in 'get' \r
+ 448 - 'raise' missing id \r
+ There is signal identifier without keyword raise \r
+ in the context of signal raising. \r
+ 449 - signal identifier expected id \r
+ Identifer ID after keyword raise is not a signal \r
+ identifier. \r
+ 450 - illegal procedure occurrence id \r
+ Procedure name ID appears in illegal context. \r
+ 451 - illegal class occurrence id \r
+ Class name ID appears in illegal context. \r
+ 452 - illegal type occurrence id \r
+ Type name ID appears in illegal context. \r
+ 453 - illegal signal occurrence id \r
+ Signal name ID appears in illegal context. \r
+ 454 - illegal operator occurence \r
+ 455 - wrong number of operands \r
+ 460 - divided by zero \r
+ 470 - illegal input parameter id \r
+ Actual parameter associated with input parameter \r
+ is not expression that may have any value: it is \r
+ e.g. procedure name \r
+ 471 - illegal output parameter id \r
+ Actual parameter corredponded to output parameter \r
+ is not a variable. \r
+ 472 - illegal type parameter id \r
+ Actual parameter ID associated with type parameter \r
+ is not a type name. \r
+ 473 - illegal procedure parameter id \r
+ Actual parameter ID associated with procedure \r
+ parameter is not a procedure name. \r
+ 474 - illegal function parameter id \r
+ Actual parameter ID associated with function \r
+ parameter is not a function name. \r
+ 475 - illegal left side of 'is'/'in' id \r
+ Left side argument ID of is/in is not a reference \r
+ expression. \r
+ 476 - illegal right side od 'is'/'in' id \r
+ Right side argument ID of is / in is not a class \r
+ name. \r
+ 477 - illegal parameter of 'attach' id \r
+ Parameter ID of attach statement is not a \r
+ reference variable of class object. \r
+ 478 - illegal type of expression\r
+ 479 - negative step value\r
+ 550 - ***stack overloaded \r
+ This error may be removed by dividing expressions \r
+ into subexpressions, making simpler nested \r
+ callings of arrays, functions, classes and for \r
+ loops. This error terminates compilation of \r
+ current module, but other modules will be \r
+ compiled. \r
+ 551 - ***too many auxiliary variables needed \r
+ Too complicated expressions. This error may be \r
+ removed by declaration of additional variables and \r
+ using them as auxiliary variables in expressions. \r
+ 552 - ***too many auxiliary reference variable needed \r
+ Analogical to error 551. \r
+ 553 - ***statement sequence too long or too complicated \r
+ This error may be removed by adding 'goto' \r
+ statement into sequence of instructions e.g. if \r
+ false then exit fi, inner, ... or by dividing \r
+ complicated expression into subexpressions. \r
+ 554 - ***real constants dictionary overflow \r
+ Too many real constant, maybe because of \r
+ evaluation of expressions built from real \r
+ constants. \r
+ 600 - undeclared identifier id \r
+ 601 - illegal type before '.' id \r
+ Expression placed before dot (remote access) is \r
+ not of class type. \r
+ 602 - close identifier after '.' id \r
+ Identifier ID placed after dot is on close list in \r
+ the class or its prefix that construct expression \r
+ before dot. \r
+ 603 - undeclared identifier after '.' id \r
+ Identifier ID placed after dot is not attribute of \r
+ expression placed before dot. It may be caused by \r
+ missing declaration or using bad prefix for class \r
+ constructing expression before dot. \r
+ 604 - illegal operand type id \r
+ One of the arguments in arithmetical expression or \r
+ in relation is not of arithmetical type. \r
+ 605 - illegal type in 'div/'mod' term id \r
+ Expression identified by ID used as argument of \r
+ div or mode operation is not of integer type. \r
+ 606 - incompatible types in comparison id \r
+ ID is an identifier of left argument of relation. \r
+ 607 - unrelated class types in comparison id \r
+ ID is an identifier of left argument of relation. \r
+ Both arguments are of class type and none of these \r
+ classes prefixes the other one. \r
+ 608 - string cannot be compared id \r
+ ID identifies a string. \r
+ 609 - incompatible types in assignment/transmission id \r
+ ID is an identifier of left side of assignment \r
+ statement or an identifier of actual parameter in \r
+ object generation. Types of both sides of \r
+ instruction or type of formal parameter and type \r
+ of actual parameter are incompatible. \r
+ 610 - unrelated class types in assignment/transmission id \r
+ Analogical to errors 609 and 607. \r
+ 611 - constant after '.' id \r
+ An attempt to remote access to constant. \r
+ 612 - this class does not occur in sl-chain id \r
+ Class ID appeared in expression this ID, but ID \r
+ dosn't prefix any module in SL chain of actual \r
+ module. It may be a cycle. \r
+ 613,614 - class identifier expected id \r
+ For error 613: identifier ID used in expression \r
+ this ID is not of class type. \r
+ For error 614: identifier ID used in expression \r
+ this ID is not name of any type. \r
+ 615 - illegal type before 'qua' id \r
+ Object expression before qua should be of one of \r
+ the types: class, coroutine, process or simple \r
+ (not array) formal type. \r
+ 616,617 - illegal type after 'qua' id \r
+ For error 616: identifier ID used after qua is not \r
+ of any type. \r
+ For error 617: identifier ID used after qua is not \r
+ of class type. \r
+ 618 - unrelated types in 'qua'-expression id \r
+ Identifier ID is a name of class type used after \r
+ qua. This class type and class type used before \r
+ qua doesn't prefix each other. \r
+ 619 - hidden identifier id \r
+ Identifier ID used in construction qua ID or this \r
+ ID is on hidden list in the prefix of one of the \r
+ module from SL chain of actual module. \r
+ 620 - not taken identifier id \r
+ Identifier ID used in construction qua ID or this \r
+ ID is not on taken list in any prefix of any \r
+ module of actual module. \r
+ 621 - invisible identifier after '.' id \r
+ Identifier ID placed after dot is on hidden list \r
+ or is not on taken list in prefix. \r
+ 622 - formal parameter list is shorter id \r
+ Identifier ID identifies generated object: class, \r
+ procedure or function. Formal parameters list of \r
+ this object is shorter than actual parameters \r
+ list. \r
+ 623 - formal parameter list is longer id \r
+ Analogical to error 622. \r
+ 624 - actual parameter is not a reference type id \r
+ Actual parameter identified by ID in generated \r
+ object can't be of primitive type: integer, real, \r
+ boolean or string. \r
+ 625 - actual parameter is not a type id \r
+ Actual parameter identified by ID is not a type, \r
+ so it can't replace formal type parameter. \r
+ 626 - procedure-function conflict between parameters id \r
+ Actual parameter, identified by ID, that replaced \r
+ formal parameter in generated object is function \r
+ whereas formal parameter is a procedure or vice \r
+ versa. \r
+ 627 - unmatched heads-wrong kinds of parameters id \r
+ ID identifies actual module that replaced formal \r
+ module. There are parameters of different kinds on \r
+ the same position in the headlines of these \r
+ modules. For input - output conflict the agreement \r
+ of parameter types is checked also. \r
+ 628 - unmatched heads-incompatible types in lists id \r
+ ID identifies actual module that replaced formal \r
+ module. There are input /output parameters of \r
+ different types on the same position in the \r
+ headlines of actual and formal module. \r
+ 629 - unmatched heads-unrelated class types in lists id \r
+ ID identifies actual module that replaced formal \r
+ module. There are input/output parameters \r
+ specifying classes of disjointed prefix sequences \r
+ in the headlines of actual and formal module. \r
+ 630 - unmatched heads-different numbers of parameters id \r
+ There are different lengths of headlines in actual \r
+ module identified by ID and formal module. \r
+ 631 - incompatible types of function parameters id \r
+ There are different types of actual function \r
+ specified by identifier ID and formal function in \r
+ generated object. \r
+ 632 - function/procedure expected id \r
+ Actual parameter identified by identifier ID is \r
+ not function/procedure, whereas corresponding \r
+ formal parameter is function/procedure. \r
+ 633 - actual function type defined weaker than formal id \r
+ Type of actual function identified by ID is weaker \r
+ defined than formal function type e.g. formal \r
+ function type is statically defined, whereas \r
+ actual function type is formal (external) or \r
+ formal function is class, whereas actual function \r
+ type is coroutine or process. \r
+ 634 - unmatched heads-too weak type in actual list id \r
+ There are input/output parameters on the same \r
+ position in the headlines of actual module \r
+ identified by identifier ID and formal module, but \r
+ ID is weaker defined than corresponding formal \r
+ module parameter (see error 633). \r
+ 635 - standard function/procedure cannot be actual par. id \r
+ ID identifies standard procedure/function used as \r
+ actual parameter. \r
+ 636 - illegal use of semaphore id \r
+ 637 - 'semaphore' cannot be used id \r
+\r
+\f\r
+APPENDIX E : LOGLAN RUNTIME ERRORS \r
+\r
+ In the following list system signal name, raised after detection of \r
+runtime error, is placed in brackets. \r
+\r
+ARRAY INDEX ERROR (CONERROR) \r
+ Index outside range during reference to array variable. \r
+NEGATIVE STEP VALUE (CONERROR)\r
+SL CHAIN CUT OFF (LOGERROR) \r
+ Control transfer to object that has SL link cut off earlier in \r
+ the consequence of kill operation. \r
+ILLEGAL ATTACH (LOGERROR) \r
+ The value of parameter of attach instruction is none or object \r
+ differs from coroutine. \r
+ILLEGAL DETACH (LOGERROR) \r
+ An attempt to return by detach to coroutine that has been \r
+ dealocated (by kill). \r
+ILLEGAL RESUME (LOGERROR)\r
+ An attempt to resume an object which is not a process or a \r
+ process which is running.\r
+TOO MANY PROCESSES ON ONE MACHINE (SYSERROR)\r
+ Number of processes existing on one computer is greater than 64.\r
+INVALID NODE NUMBER (SYSERROR)\r
+ An attempt to create a process on a computer which is not \r
+ connected to network.\r
+IMPROPER QUA (LOGERROR) \r
+ Error during computing expression of the form: ...x qua a, when \r
+ 'x' references to none or 'a' doesn't prefix dynamic type object, \r
+ which is value of 'x'. \r
+ILLEGAL ASSIGNMENT (TYPERROR) \r
+ Type conflict between left and right side of assignment \r
+ instruction. \r
+FORMAL TYPE MISSING (LOGERROR) \r
+ Formal type is not accessible because of SL cut off. \r
+ILLEGAL KILL (LOGERROR) \r
+ An attempt to deallocate object in SL chain of active object. \r
+ILLEGAL COPY (LOGERROR) \r
+ An attempt to copy non terminated object (i.e. class before \r
+ execution of return statement, coroutine before execution of end \r
+ statement...). \r
+REFERENCE TO NONE (ACCERROR) \r
+ An attempt to remote access (by dot) to attributes of non \r
+ existing object: dealocated or not generated. \r
+MEMORY OVERFLOW (MEMERROR) \r
+INCOMPATIBLE HEADERS (TYPERROR) \r
+ Actual parameter list of generated object (procedure, function \r
+ or class) is incompatible with formal parameter list from module \r
+ declaration or formal function type is incompatible with actual \r
+ function type. \r
+INCORRECT ARRAY BOUNDS (CONERROR) \r
+ An attempt to generate dynamic array object, when lower bound of \r
+ index range is greater than upper bound. \r
+DIVISION BY ZERO (NUMERROR) \r
+COROUTINE TERMINATED (LOGERROR) \r
+ An attempt to transfer control to a terminated coroutine. \r
+COROUTINE ACTIVE (LOGERROR) \r
+ An attempt to transfer control to an active coroutine. \r
+HANDLER NOT FOUND (LOGERROR) \r
+ There is no handler for signal declared by user. \r
+ILLEGAL RETURN (LOGERROR) \r
+ An attempt to execute return instruction in handler serving \r
+ system signal. \r
+UNIMPLEMENTED STANDARD PRC. (LOGERROR) \r
+ Standard procedure or function is not implemented. \r
+FORMAL LIST TOO LONG (MEMERROR) \r
+ Formal parameter list is greater than 40. \r
+ILLEGAL I/O OPERATION (SYSERROR) \r
+ Reading after writing, the type of the read/write parameter does \r
+ not match the type of the file etc. \r
+I/O ERROR (SYSERROR)\r
+ System error during I/O.\r
+CANNOT OPEN FILE (SYSERROR)\r
+INPUT DATA FORMAT BAD (SYSERROR)\r
+SYSTEM ERROR (SYSERROR)\r
+ Should not occur.\r
+UNRECOGNIZED ERROR\r
+\f\r
+APPENDIX F : CHARACTER SET \r
+\r
+\r
+ At the top of the table are hexadecimal digits (0 to 7), and to the \r
+left of the table are hexadecimal digits (0 to F). Hexadecimal code of \r
+ASCII character is constructed by contatenation of column label and \r
+row label. For example, the value of character representing the plus \r
+sign is 2B. \r
+\r
+\r
+ 0 1 2 3 4 5 6 7 \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 0 ! NUL ! DLE ! SP ! 0 ! @ ! P ! ! p ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 1 ! SOH ! DC1 ! ! ! 1 ! A ! Q ! a ! q ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 2 ! STX ! DC2 ! " ! 2 ! B ! R ! b ! r ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 3 ! ETX ! DC3 ! # ! 3 ! C ! S ! c ! s ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 4 ! EOT ! DC4 ! $ ! 4 ! D ! T ! d ! t ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 5 ! ENQ ! NAK ! % ! 5 ! E ! U ! e ! u ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 6 ! ACK ! SYN ! & ! 6 ! F ! V ! f ! v ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 7 ! BEL ! ETB ! ' ! 7 ! G ! W ! g ! w ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 8 ! BS ! CAN ! ( ! 8 ! H ! X ! h ! x ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ 9 ! HT ! EM ! ) ! 9 ! I ! Y ! i ! y ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ A ! LF ! SUB ! * ! : ! J ! Z ! j ! z ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ B ! VT ! ESC ! + ! ; ! K ! [ ! k ! { ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ C ! FF ! FS ! , ! < ! L ! \ ! l ! | ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ D ! CR ! GS ! - ! = ! M ! ] ! m ! } ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ E ! SO ! RS ! . ! > ! N ! ^ ! n ! ~ ! \r
+ _________________________________________________ \r
+ ! ! ! ! ! ! ! ! ! \r
+ F ! SI ! US ! / ! ? ! O ! _ ! o ! DEL ! \r
+ _________________________________________________ \r
+\r
+\r
+where: \r
+ NUL Null DLE Data Link Escape \r
+ SOH Start of Heading DC1 Device Control 1 \r
+ STX Start of Text DC2 Device Control 2 \r
+ ETX End of Text DC3 Device Control 3 \r
+ EOT End of Transmission DC4 Device Control 4 \r
+ ENQ Enquiry NAK Negative Acknowledge \r
+ ACK Acknowledge SYN Synchronous Idle \r
+ BEL Bell ETB End of Transmission Block \r
+ BS Backspace CAN Cancel \r
+ HT Horizontal Tabulation EM End of Medium \r
+ LF Line Feed SUB Substitute \r
+ VF Vertical Tab ESC Escape \r
+ FF Form Feed FS File Separator \r
+ CR Carriage Return GS Group Separator \r
+ SO Shift Out RS Record Separator \r
+ SI Shift In US Unit Separator \r
+ SP Space DEL Delete \r
+\r
+\r
+\r
+\r
+ BIBLIOGRAPHY \r
+\r
+ 1. Report on the Loglan-82 Programming Language. \r
+ 2. IIUWGRAF biblioteka podstawowych procedur graficznych.\r
+ 3. Microsoft (R) Mouse User's Guide.\r
+\r
+\1a
\ No newline at end of file
projects / loglan.git / commitdiff
